diff --git a/main.scm b/main.scm index db5c514..cd97294 100644 --- a/main.scm +++ b/main.scm @@ -485,7 +485,7 @@ (map (lambda (_) (make-square mine? #f #f #f #f)) (iota n))) -(define-record-type game (fields squares width height num-mines num-flagged)) +(define-record-type game (fields squares width height num-mines (mutable num-flagged) (mutable over?))) ;unknown pressed mine flag no-mine pressed-mine question pressed-question @@ -505,6 +505,7 @@ (cons (floor (/ (get-mouse-x) square-width)) (floor (/ (get-mouse-y) square-width)))) +; not correct (we need to know whether the square is revealed) (define (square-pressed? x y) (or (and (button-down? 'left) (equal? (cons x y) (square-mouse-over))) @@ -528,8 +529,8 @@ (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))) +(define (game-map-around proc game x y) + (map (lambda (x/y) (proc 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)))) @@ -537,6 +538,9 @@ (-1 . 0) ( 1 . 0) (-1 . 1) ( 0 . 1) ( 1 . 1)))))) +(define (game-around game x y) + (game-map-around game-square-at game x y)) + ; remember: prefer functions over macros ; game last for consistency with for-each (define (game-squares-for-each proc game) @@ -560,11 +564,19 @@ (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)) + (define game (make-game squares width height mines 0 #f)) (vector-shuffle! squares) (fill-game-arounds! game) game) +(define (game-reveal! game x y) + (define square (game-square-at game x y)) + (unless (square-revealed? square) + (if (square-mine? square) + (game-over?-set! game #t) + (begin (square-revealed?-set! square #t) + (when (zero? (square-num-adjacent square)) + (game-map-around game-reveal! game x y)))))) (define (game-tick! game) (define mouse-x (car (square-mouse-over))) @@ -582,11 +594,37 @@ (button-released? 'right)))) ; not quite perfectly correct - (when (and mouse-in-bounds? (button-pressed? 'right)) + (when (and mouse-in-bounds? (button-pressed? 'right) (not (square-revealed? mouse-square))) + (game-num-flagged-set! + game + ((if (square-flagged? mouse-square) sub1 add1) (game-num-flagged game))) (square-flagged?-set! mouse-square (not (square-flagged? mouse-square)))) + (when (and mouse-in-bounds? (or (button-pressed? 'left) (button-pressed? 'middle))) + (if (and (square-revealed? mouse-square) + (= (square-num-adjacent mouse-square) + (length + (filter square-flagged? + (game-around game mouse-x mouse-y))))) + (game-map-around + (lambda (game x y) + (unless (square-flagged? (game-square-at game x y)) + (game-reveal! game x y))) + game mouse-x mouse-y) + (game-reveal! game mouse-x mouse-y))) + redraw?) +; flags don't actually matter! +(define (game-won? game) + (define won? #t) + (vector-for-each + (lambda (square) + (when (boolean=? (square-mine? square) (square-revealed? square)) + (set! won? #f))) + (game-squares game)) + won?) + (define (draw-write obj x y size color) (draw-text (with-output-to-string (lambda () (write obj))) x y size color)) @@ -643,8 +681,7 @@ (set-vector2-x! draw-pos (+ (vector2-x pos) (* x square-width))) (set-vector2-y! draw-pos (+ (vector2-y pos) (* y square-width))) (blit-square skin (game-square-type-at game x y) draw-pos)) - game) - ) + game)) (define (game-draw game skin) (draw-game-squares game skin vector2-origin)) @@ -654,7 +691,10 @@ (define (run-game mines width height) (init-window (* width square-width) (* height square-width) "mineschemer") (set-target-fps 60) - + (let ([seed (time-nanosecond (current-time))]) + (display "seed: ") (display seed) + (newline) + (random-seed seed)) (let ([skin (load-skin "xp-flowers.bmp")] [game (new-game mines width height)]) ;; (display skin) @@ -672,7 +712,12 @@ ; seems so ;; (clear-background BLACK) ; okay, we could be a bit smarter about what we redraw, but redrawing shouldn't leak *any* memory - (game-draw game skin)) + (game-draw game skin) + ; hacky, yeah + (when (game-over? game) + (draw-text "GAME OVER" 0 0 20 (color 255 0 0))) + (when (game-won? game) + (draw-text "A COMPLETER IS YOU 0 20 20" (color 247 231 54)))) #;(draw-mouse-info BLACK) )) (unload-texture skin)