diff options
| -rw-r--r-- | examples/minesweeper/assets/images/tiles.png | bin | 0 -> 1358 bytes | |||
| -rw-r--r-- | examples/minesweeper/assets/images/tiles.xcf | bin | 0 -> 7966 bytes | |||
| -rw-r--r-- | examples/minesweeper/minesweeper.scm | 239 |
3 files changed, 239 insertions, 0 deletions
diff --git a/examples/minesweeper/assets/images/tiles.png b/examples/minesweeper/assets/images/tiles.png Binary files differnew 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 Binary files differnew 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)) |
