mines and adjacent

This commit is contained in:
mehbark 2023-12-23 18:36:44 -05:00
parent aad9e0e8c9
commit 7f42919cea

125
main.scm
View file

@ -382,12 +382,12 @@
gap gap
gap)) gap))
(define *t* 0.0)
(define (blit-from-skin skin rect pos) (define (blit-from-skin skin rect pos)
;; (display skin) (display " ") (display rect) (display " ") (display pos) ;; (display skin) (display " ") (display rect) (display " ") (display pos)
;; (newline) ;; (newline)
(random-seed (* 1000 (add1 (inexact->exact (+ (rectangle-x rect) (rectangle-y rect)))))) (draw-texture-rec skin rect pos WHITE)
(draw-texture-rec skin rect (vector2+ pos (vector2 (* (random 8) (sin *t*)) (* (random 8) (cos *t*)))) WHITE)) ;; (random-seed (* 1000 (add1 (inexact->exact (+ (rectangle-x rect) (rectangle-y rect))))))
#; (draw-texture-rec skin rect (vector2+ pos (vector2 (* (random 8) (sin *t*)) (* (random 8) (cos *t*)))) WHITE))
(define (blit-number skin n pos) (define (blit-number skin n pos)
(let ([rect (vector-ref number-rects n)]) (let ([rect (vector-ref number-rects n)])
@ -447,22 +447,125 @@
(rectangle-y (cdr t/r))))) (rectangle-y (cdr t/r)))))
border-rects)) border-rects))
(define (main) (define-record-type square
(init-window skin-width skin-height "mineschemer") (fields (immutable mine?)
(mutable num-adjacent)
(mutable flagged?)
(mutable questioned?)
(mutable revealed?)))
(define (vector-swap! vec i1 i2)
(unless (= i1 i2)
(let ([x1 (vector-ref vec i1)]
[x2 (vector-ref vec i2)])
(vector-set! vec i1 x2)
(vector-set! vec i2 x1))))
(define (vector-shuffle! vec)
(for-each (lambda (i1)
(vector-swap! vec i1 (random (add1 i1))))
(reverse (iota (vector-length vec))))
vec)
(define (vector-shuffle vec)
(define out (vector-copy vec))
(vector-shuffle! out))
#;
(map (lambda (_) (apply string-append (map symbol->string (vector->list (vector-shuffle '#(e l v i s))))))
(iota 200))
(define (list-shuffle list)
(vector->list (vector-shuffle! (list->vector list))))
(define (base-square) (make-square #f #f #f #f #f))
(define (make-squares n mine?)
(map (lambda (_) (make-square mine? #f #f #f #f))
(iota n)))
(define-record-type game (fields squares width height num-mines num-flagged))
;unknown pressed mine flag no-mine pressed-mine question pressed-question
(define (game-square-at game x y)
(vector-ref (game-squares game)
(+ x (* y (game-height game)))))
; preliminary
(define (game-square-type-at game x y)
(define square (game-square-at game x y))
(cond
[(square-flagged? square) 'flag]
[(square-mine? square) 'mine]
[else (square-num-adjacent square)]))
(define (game-in-bounds? game x y)
(and (< -1 x (game-width game))
(< -1 y (game-height game))))
(define (game-around game x y)
(map (lambda (x/y) (game-square-at game (car x/y) (cdr x/y)))
(filter (lambda (x/y) (game-in-bounds? game (car x/y) (cdr x/y)))
(map (lambda (x/y)
(cons (+ x (car x/y)) (+ y (cdr x/y))))
'((-1 . -1) ( 0 . -1) ( 1 . -1)
(-1 . 0) ( 1 . 0)
(-1 . 1) ( 0 . 1) ( 1 . 1))))))
; remember: prefer functions over macros
; game last for consistency with for-each
(define (game-squares-for-each proc game)
(for-each
(lambda (x)
(for-each
(lambda (y) (proc x y))
(iota (game-height game))))
(iota (game-width game))))
(define (fill-game-arounds! game)
(game-squares-for-each
(lambda (x y)
(define square (game-square-at game x y))
(square-num-adjacent-set! square
(length (filter square-mine? (game-around game x y)))))
game))
; as feared, make-vector references the same thing
(define (new-game mines width height)
(define squares (list->vector (append (make-squares mines #t)
(make-squares (- (* width height) mines) #f))))
(define game (make-game squares width height mines 0))
(vector-shuffle! squares)
(fill-game-arounds! game)
game)
; ignoring revealed for now
(define (draw-game-squares game skin pos)
(game-squares-for-each
(lambda (x y)
(let ([pos (vector2+ pos (vector2 (* x square-width) (* y square-width)))])
(blit-square skin (game-square-type-at game x y) pos)))
game))
;; (define (square-mouse-over game)
;; (cons (/ )))
; the game shows -99 when you (- num-mines num-flagged) is less than -99
(define (run-game mines width height)
(init-window (* width square-width) (* height square-width) "mineschemer")
(set-target-fps 60) (set-target-fps 60)
(let ([skin (load-skin "xp-flowers.bmp")] (let ([skin (load-skin "xp-flowers.bmp")]
[h 0.0]) [game (new-game mines width height)])
;; (display skin) ;; (display skin)
;; (newline) ;; (newline)
; with the actual game, we almost certainly don't have to redraw everything every time ; with the actual game, we almost certainly don't have to redraw everything every time
(until (window-should-close?) (until (window-should-close?)
(set! h (+ 1 h))
(set! *t* (+ *t* (get-frame-time)))
(with-draw (with-draw
(clear-background (color-from-hsv h 1.0 1.0)) (draw-game-squares game skin (vector2 0 0))
(redraw-skin skin))) ))
(unload-texture skin) (unload-texture skin)
(close-window))) (close-window)))