From 9c71f796b9210e92c3661028f39fbc9ae23abb17 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Thu, 25 May 2023 19:08:14 -0400 Subject: Add minesweeper example. --- examples/minesweeper/assets/images/tiles.png | Bin 0 -> 1358 bytes examples/minesweeper/assets/images/tiles.xcf | Bin 0 -> 7966 bytes examples/minesweeper/minesweeper.scm | 239 +++++++++++++++++++++++++++ 3 files changed, 239 insertions(+) create mode 100644 examples/minesweeper/assets/images/tiles.png create mode 100644 examples/minesweeper/assets/images/tiles.xcf create mode 100644 examples/minesweeper/minesweeper.scm diff --git a/examples/minesweeper/assets/images/tiles.png b/examples/minesweeper/assets/images/tiles.png new file mode 100644 index 0000000..85d73d1 Binary files /dev/null and b/examples/minesweeper/assets/images/tiles.png differ diff --git a/examples/minesweeper/assets/images/tiles.xcf b/examples/minesweeper/assets/images/tiles.xcf new file mode 100644 index 0000000..8959c50 Binary files /dev/null and b/examples/minesweeper/assets/images/tiles.xcf 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 () + (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 () + (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 ) initargs) + (next-method) + (reset-field minefield)) + +(define-method (field-ref (minefield ) x y) + (vector-ref (vector-ref (field minefield) y) x)) + +(define-method (reset-field (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 ))) + (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 )) + (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 ) _alpha) + (draw-sprite-batch* (batch minefield) (world-matrix minefield))) + +(define-method (in-bounds? (minefield ) x y) + (and (>= x 0) (>= y 0) + (< x (field-width minefield)) + (< y (field-height minefield)))) + +(define-method (mine-location? (minefield ) x y) + (and (in-bounds? minefield x y) + (mine? (field-ref minefield x y)))) + +(define-method (empty-location? (minefield ) x y) + (and (in-bounds? minefield x y) + (not (mine? (field-ref minefield x y))))) + +(define-method (count-neighboring-mines (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 ) x y) + (and (empty-location? minefield x y) (reveal minefield x y))) + +(define-method (reveal (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 ) x y) + (let ((tile (field-ref minefield x y))) + (set! (flag? tile) (not (flag? tile))))) + +(define-method (field-state (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 ()) + +(define-method (on-enter (mode )) + (let ((minefield (make #: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 ) 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 ) 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 + #:message "YOU WIN"))) + ((lose) + (push-major-mode (parent mode) + (make + #:message "OOPSIES :("))))))) + +(define-method (on-alt-click (mode ) x y) + (pick-tile mode x y + (lambda (minefield tx ty) + (toggle-flag minefield tx ty) + (refresh-sprites minefield)))) + +(bind-input (mouse-release 'left) on-primary-click) +(bind-input (mouse-release 'right) on-alt-click) + +(define-class () + (message #:accessor message #:init-keyword #:message)) + +(define-method (on-enter (mode )) + (let ((msg (make