summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--examples/minesweeper/assets/images/tiles.pngbin0 -> 1358 bytes
-rw-r--r--examples/minesweeper/assets/images/tiles.xcfbin0 -> 7966 bytes
-rw-r--r--examples/minesweeper/minesweeper.scm239
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
Binary files differ
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
Binary files differ
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))