From 7f42919ceafdbb9a158b852b43ff6b7b0efba634 Mon Sep 17 00:00:00 2001
From: mehbark <terezi@pyrope.net>
Date: Sat, 23 Dec 2023 18:36:44 -0500
Subject: [PATCH] mines and adjacent

---
 main.scm | 125 ++++++++++++++++++++++++++++++++++++++++++++++++++-----
 1 file changed, 114 insertions(+), 11 deletions(-)

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)))