diff --git a/main.scm b/main.scm index efc56f2..37e7d80 100644 --- a/main.scm +++ b/main.scm @@ -382,12 +382,12 @@ gap gap)) -(define *t* 0.0) (define (blit-from-skin skin rect pos) ;; (display skin) (display " ") (display rect) (display " ") (display pos) ;; (newline) - (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)) + (draw-texture-rec skin rect pos 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) (let ([rect (vector-ref number-rects n)]) @@ -447,22 +447,125 @@ (rectangle-y (cdr t/r))))) border-rects)) -(define (main) - (init-window skin-width skin-height "mineschemer") +(define-record-type square + (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) (let ([skin (load-skin "xp-flowers.bmp")] - [h 0.0]) + [game (new-game mines width height)]) ;; (display skin) ;; (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?) - (set! h (+ 1 h)) - (set! *t* (+ *t* (get-frame-time))) (with-draw - (clear-background (color-from-hsv h 1.0 1.0)) - (redraw-skin skin))) + (draw-game-squares game skin (vector2 0 0)) + )) (unload-texture skin) (close-window)))