Add minesweeper example.

3 files changed, 239 insertions, 0 deletions

diff --git a/examples/minesweeper/assets/images/tiles.png b/examples/minesweeper/assets/images/tiles.png
new file mode 100644
index 0000000..85d73d1
--- /dev/null
+++ b/examples/minesweeper/assets/images/tiles.png
diff --git a/examples/minesweeper/assets/images/tiles.xcf b/examples/minesweeper/assets/images/tiles.xcf
new file mode 100644
index 0000000..8959c50
--- /dev/null
+++ b/examples/minesweeper/assets/images/tiles.xcf
diff --git a/examples/minesweeper/minesweeper.scm b/examples/minesweeper/minesweeper.scm
new file mode 100644
index 0000000..4784ade
--- /dev/null
+++ b/examples/minesweeper/minesweeper.scm
@@ -0,0 +1,239 @@
+(use-modules (catbird)
+             (catbird asset)
+             (catbird camera)
+             (catbird kernel)
+             (catbird mixins)
+             (catbird mode)
+             (catbird node)
+             (catbird node-2d)
+             (catbird region)
+             (catbird scene)
+             (chickadee graphics texture)
+             (chickadee graphics sprite)
+             (chickadee math vector)
+             (chickadee utils)
+             (ice-9 match)
+             (oop goops))
+
+(define %default-width 640)
+(define %default-height 480)
+(define-asset (%tileset (file "assets/images/tiles.png"))
+  (load-tileset file 32 32))
+
+(define (make-empty-sprite-batch)
+  (make-sprite-batch #f))
+
+(define-class <tile> ()
+  (mine? #:accessor mine? #:init-value #f)
+  (flag? #:accessor flag? #:init-value #f)
+  (revealed? #:accessor revealed? #:init-value #f)
+  (neighbor-mines #:accessor neighbor-mines #:init-value 0))
+
+(define-class <minefield> (<node-2d>)
+  (field-width #:accessor field-width #:init-keyword #:width #:init-value 10)
+  (field-height #:accessor field-height #:init-keyword #:height #:init-value 10)
+  (field #:accessor field)
+  (mines #:accessor mines #:init-keyword mines #:init-value 10)
+  (batch #:accessor batch #:init-thunk make-empty-sprite-batch))
+
+(define-method (initialize (minefield <minefield>) initargs)
+  (next-method)
+  (reset-field minefield))
+
+(define-method (field-ref (minefield <minefield>) x y)
+  (vector-ref (vector-ref (field minefield) y) x))
+
+(define-method (reset-field (minefield <minefield>))
+  ;; Build new vector of vectors.
+  (define h (field-height minefield))
+  (define w (field-width minefield))
+  (define new-field (make-vector h))
+  (for-range ((y h))
+    (let ((new-row (make-vector w)))
+      (for-range ((x w))
+        (vector-set! new-row x (make <tile>)))
+      (vector-set! new-field y new-row)))
+  (set! (field minefield) new-field)
+  ;; Add mines.
+  (let loop ((i 0))
+    (when (< i (mines minefield))
+      (let ((x (random w))
+            (y (random h)))
+        ;; Try again if we randomly picked the same place more than
+        ;; once.
+        (let ((tile (field-ref minefield x y)))
+          (if (mine? tile)
+              (loop i)
+              (begin
+                (set! (mine? tile) #t)
+                (loop (+ i 1))))))))
+  (resize minefield (* w 32.0) (* h 32.0))
+  (refresh-sprites minefield))
+
+(define-method (refresh-sprites (minefield <minefield>))
+  (set-sprite-batch-texture! (batch minefield)
+                             (texture-parent
+                              (texture-atlas-ref (artifact %tileset) 0)))
+  (sprite-batch-clear! (batch minefield))
+  (for-range ((x (field-width minefield))
+              (y (field-height minefield)))
+    (let* ((tile (field-ref minefield x y))
+           (i (cond
+               ((and (revealed? tile) (mine? tile)) 2)
+               ((revealed? tile) (+ 3 (neighbor-mines tile)))
+               ((flag? tile) 1)
+               (else 0))))
+      (sprite-batch-add! (batch minefield)
+                         (vec2 (* x 32.0) (* y 32.0))
+                         #:texture-region
+                         (texture-atlas-ref (artifact %tileset) i)))))
+
+(define-method (render (minefield <minefield>) _alpha)
+  (draw-sprite-batch* (batch minefield) (world-matrix minefield)))
+
+(define-method (in-bounds? (minefield <minefield>) x y)
+  (and (>= x 0) (>= y 0)
+       (< x (field-width minefield))
+       (< y (field-height minefield))))
+
+(define-method (mine-location? (minefield <minefield>) x y)
+  (and (in-bounds? minefield x y)
+       (mine? (field-ref minefield x y))))
+
+(define-method (empty-location? (minefield <minefield>) x y)
+  (and (in-bounds? minefield x y)
+       (not (mine? (field-ref minefield x y)))))
+
+(define-method (count-neighboring-mines (minefield <minefield>) x y)
+  (+ (if (mine-location? minefield (- x 1) (- y 1)) 1 0)
+     (if (mine-location? minefield x (- y 1)) 1 0)
+     (if (mine-location? minefield (+ x 1) (- y 1)) 1 0)
+     (if (mine-location? minefield (- x 1) y) 1 0)
+     (if (mine-location? minefield (+ x 1) y) 1 0)
+     (if (mine-location? minefield (- x 1) (+ y 1)) 1 0)
+     (if (mine-location? minefield x (+ y 1)) 1 0)
+     (if (mine-location? minefield (+ x 1) (+ y 1)) 1 0)))
+
+(define-method (reveal-if-empty (minefield <minefield>) x y)
+  (and (empty-location? minefield x y) (reveal minefield x y)))
+
+(define-method (reveal (minefield <minefield>) x y)
+  (let ((tile (field-ref minefield x y)))
+    (unless (or (revealed? tile) (flag? tile))
+      (set! (revealed? tile) #t)
+      (unless (mine? tile)
+        (let ((n (count-neighboring-mines minefield x y)))
+          (set! (neighbor-mines tile) n)
+          (when (= n 0)
+            (reveal-if-empty minefield (- x 1) (- y 1))
+            (reveal-if-empty minefield x (- y 1))
+            (reveal-if-empty minefield (+ x 1) (- y 1))
+            (reveal-if-empty minefield (- x 1) y)
+            (reveal-if-empty minefield (+ x 1) y)
+            (reveal-if-empty minefield (- x 1) (+ y 1))
+            (reveal-if-empty minefield x (+ y 1))
+            (reveal-if-empty minefield (+ x 1) (+ y 1))))))))
+
+(define-method (toggle-flag (minefield <minefield>) x y)
+  (let ((tile (field-ref minefield x y)))
+    (set! (flag? tile) (not (flag? tile)))))
+
+(define-method (field-state (minefield <minefield>))
+  (let y-loop ((y 0) (state 'win))
+    (if (< y (field-height minefield))
+        (case (let x-loop ((x 0) (state 'win))
+                (if (< x (field-width minefield))
+                    (let ((tile (field-ref minefield x y)))
+                      (cond
+                       ((and (revealed? tile) (mine? tile))
+                        'lose)
+                       ((and (not (revealed? tile)) (not (mine? tile)))
+                        (x-loop (+ x 1) 'in-progress))
+                       (else
+                        (x-loop (+ x 1) state))))
+                    state))
+          ((win)
+           (y-loop (+ y 1) state))
+          ((lose) 'lose)
+          ((in-progress)
+           (y-loop (+ y 1) 'in-progress)))
+        state)))
+
+(define-method (local->tile p)
+  (let ((tx (inexact->exact (floor (/ (vec2-x p) 32.0))))
+        (ty (inexact->exact (floor (/ (vec2-y p) 32.0)))))
+    (values tx ty)))
+
+(define-class <minesweeper-mode> (<major-mode>))
+
+(define-method (on-enter (mode <minesweeper-mode>))
+  (let ((minefield (make <minefield> #:name 'minefield)))
+    (attach-to (parent mode) minefield)
+    (center-in-parent minefield)))
+
+(define (world->tile node p)
+  (local->tile (world->local node p)))
+
+(define-method (pick-tile (mode <minesweeper-mode>) x y proc)
+  (let* ((p (vec2 x y))
+         (picked (pick (parent mode) p)))
+    (when picked
+      (call-with-values (lambda () (world->tile picked p))
+        (lambda (tx ty)
+          (proc picked tx ty))))))
+
+(define-method (on-primary-click (mode <minesweeper-mode>) x y)
+  (pick-tile mode x y
+             (lambda (minefield tx ty)
+               (reveal minefield tx ty)
+               (refresh-sprites minefield)
+               (case (field-state minefield)
+                 ((win)
+                  (push-major-mode (parent mode)
+                                   (make <reset-game-mode>
+                                     #:message "YOU WIN")))
+                 ((lose)
+                  (push-major-mode (parent mode)
+                                   (make <reset-game-mode>
+                                     #:message "OOPSIES :(")))))))
+
+(define-method (on-alt-click (mode <minesweeper-mode>) x y)
+  (pick-tile mode x y
+             (lambda (minefield tx ty)
+               (toggle-flag minefield tx ty)
+               (refresh-sprites minefield))))
+
+(bind-input <minesweeper-mode> (mouse-release 'left) on-primary-click)
+(bind-input <minesweeper-mode> (mouse-release 'right) on-alt-click)
+
+(define-class <reset-game-mode> (<major-mode>)
+  (message #:accessor message #:init-keyword #:message))
+
+(define-method (on-enter (mode <reset-game-mode>))
+  (let ((msg (make <label>
+               #:name 'message
+               #:text (message mode)
+               #:rank 99)))
+    (attach-to (parent mode) msg)
+    (center-horizontal-in-parent msg)
+    (set! (position-y msg) (- (height (parent mode)) 48.0))))
+
+(define-method (on-primary-click (mode <reset-game-mode>) x y)
+  (let ((scene (parent mode)))
+    (detach (& scene message))
+    (reset-field (& (parent mode) minefield))
+    (pop-major-mode (parent mode))))
+
+(bind-input <reset-game-mode> (mouse-release 'left) on-primary-click)
+
+(define (launch-game)
+  (let ((region (create-full-region #:name 'main))
+        (scene (make <scene> #:name 'minesweeper)))
+    (replace-scene region scene)
+    (set-camera region (make <camera-2d>))
+    (replace-major-mode scene (make <minesweeper-mode>))))
+
+(when (batch-mode?)
+  (run-catbird launch-game
+               #:width %default-width
+               #:height %default-height))