From 46d45c0a6dc1969e4ef631646f6a657dc5eb3a98 Mon Sep 17 00:00:00 2001 From: David Thompson Date: Sat, 6 Dec 2014 11:13:04 -0500 Subject: examples: Add minesweeper clone. * examples/mines/mines.scm: New file. * examples/mines/images/*: New files. * examples/Makefile.am (examples_DATA): Add 'mines.scm'. (image_DATA): Add images. --- examples/Makefile.am | 19 +- examples/mines/images/1-mine.png | Bin 0 -> 256 bytes examples/mines/images/2-mines.png | Bin 0 -> 403 bytes examples/mines/images/3-mines.png | Bin 0 -> 413 bytes examples/mines/images/4-mines.png | Bin 0 -> 343 bytes examples/mines/images/5-mines.png | Bin 0 -> 364 bytes examples/mines/images/6-mines.png | Bin 0 -> 437 bytes examples/mines/images/7-mines.png | Bin 0 -> 330 bytes examples/mines/images/8-mines.png | Bin 0 -> 440 bytes examples/mines/images/exploded.png | Bin 0 -> 394 bytes examples/mines/images/flag.png | Bin 0 -> 349 bytes examples/mines/images/maybe.png | Bin 0 -> 447 bytes examples/mines/images/mine.png | Bin 0 -> 462 bytes examples/mines/images/tile-down.png | Bin 0 -> 343 bytes examples/mines/images/tile-up.png | Bin 0 -> 312 bytes examples/mines/mines.scm | 400 ++++++++++++++++++++++++++++++++++++ 16 files changed, 417 insertions(+), 2 deletions(-) create mode 100644 examples/mines/images/1-mine.png create mode 100644 examples/mines/images/2-mines.png create mode 100644 examples/mines/images/3-mines.png create mode 100644 examples/mines/images/4-mines.png create mode 100644 examples/mines/images/5-mines.png create mode 100644 examples/mines/images/6-mines.png create mode 100644 examples/mines/images/7-mines.png create mode 100644 examples/mines/images/8-mines.png create mode 100644 examples/mines/images/exploded.png create mode 100644 examples/mines/images/flag.png create mode 100644 examples/mines/images/maybe.png create mode 100644 examples/mines/images/mine.png create mode 100644 examples/mines/images/tile-down.png create mode 100644 examples/mines/images/tile-up.png create mode 100644 examples/mines/mines.scm (limited to 'examples') diff --git a/examples/Makefile.am b/examples/Makefile.am index 7ecbe70..0ad17ff 100644 --- a/examples/Makefile.am +++ b/examples/Makefile.am @@ -23,7 +23,8 @@ examples_DATA = \ joystick.scm \ simple.scm \ tilemap.scm \ - 2048/2048 + 2048/2048 \ + mines/mines.scm imagedir = $(pkgdatadir)/examples/images image_DATA = \ @@ -32,4 +33,18 @@ image_DATA = \ images/princess.png \ images/stars.png \ images/tiles.png \ - 2048/tile.png + 2048/tile.png \ + mines/images/1-mine.png \ + mines/images/2-mines.png \ + mines/images/3-mines.png \ + mines/images/4-mines.png \ + mines/images/5-mines.png \ + mines/images/6-mines.png \ + mines/images/7-mines.png \ + mines/images/8-mines.png \ + mines/images/exploded.png \ + mines/images/flag.png \ + mines/images/maybe.png \ + mines/images/mine.png \ + mines/images/tile-down.png \ + mines/images/tile-up.png diff --git a/examples/mines/images/1-mine.png b/examples/mines/images/1-mine.png new file mode 100644 index 0000000..6d30942 Binary files /dev/null and b/examples/mines/images/1-mine.png differ diff --git a/examples/mines/images/2-mines.png b/examples/mines/images/2-mines.png new file mode 100644 index 0000000..226d65c Binary files /dev/null and b/examples/mines/images/2-mines.png differ diff --git a/examples/mines/images/3-mines.png b/examples/mines/images/3-mines.png new file mode 100644 index 0000000..9c89ec9 Binary files /dev/null and b/examples/mines/images/3-mines.png differ diff --git a/examples/mines/images/4-mines.png b/examples/mines/images/4-mines.png new file mode 100644 index 0000000..2daa42d Binary files /dev/null and b/examples/mines/images/4-mines.png differ diff --git a/examples/mines/images/5-mines.png b/examples/mines/images/5-mines.png new file mode 100644 index 0000000..8e6e8d2 Binary files /dev/null and b/examples/mines/images/5-mines.png differ diff --git a/examples/mines/images/6-mines.png b/examples/mines/images/6-mines.png new file mode 100644 index 0000000..619706d Binary files /dev/null and b/examples/mines/images/6-mines.png differ diff --git a/examples/mines/images/7-mines.png b/examples/mines/images/7-mines.png new file mode 100644 index 0000000..78cffaa Binary files /dev/null and b/examples/mines/images/7-mines.png differ diff --git a/examples/mines/images/8-mines.png b/examples/mines/images/8-mines.png new file mode 100644 index 0000000..a0b2b73 Binary files /dev/null and b/examples/mines/images/8-mines.png differ diff --git a/examples/mines/images/exploded.png b/examples/mines/images/exploded.png new file mode 100644 index 0000000..a529b7f Binary files /dev/null and b/examples/mines/images/exploded.png differ diff --git a/examples/mines/images/flag.png b/examples/mines/images/flag.png new file mode 100644 index 0000000..6c6b1ce Binary files /dev/null and b/examples/mines/images/flag.png differ diff --git a/examples/mines/images/maybe.png b/examples/mines/images/maybe.png new file mode 100644 index 0000000..58aa9cd Binary files /dev/null and b/examples/mines/images/maybe.png differ diff --git a/examples/mines/images/mine.png b/examples/mines/images/mine.png new file mode 100644 index 0000000..acac9e9 Binary files /dev/null and b/examples/mines/images/mine.png differ diff --git a/examples/mines/images/tile-down.png b/examples/mines/images/tile-down.png new file mode 100644 index 0000000..379f3db Binary files /dev/null and b/examples/mines/images/tile-down.png differ diff --git a/examples/mines/images/tile-up.png b/examples/mines/images/tile-up.png new file mode 100644 index 0000000..2eb8797 Binary files /dev/null and b/examples/mines/images/tile-up.png differ diff --git a/examples/mines/mines.scm b/examples/mines/mines.scm new file mode 100644 index 0000000..98056cc --- /dev/null +++ b/examples/mines/mines.scm @@ -0,0 +1,400 @@ +;;; Mines +;;; Copyright (C) 2014 David Thompson +;;; +;;; This program is free software: you can redistribute it and/or +;;; modify it under the terms of the GNU General Public License as +;;; published by the Free Software Foundation, either version 3 of the +;;; License, or (at your option) any later version. +;;; +;;; This program is distributed in the hope that it will be useful, +;;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +;;; General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with this program. If not, see +;;; . + +;;; Commentary: +;; +;; Minesweeper (TM) clone. +;; +;;; Code: + +(use-modules (srfi srfi-1) + (srfi srfi-9) + (srfi srfi-26) + (ice-9 match) + (sly utils) + (sly game) + (sly signal) + (sly window) + (sly repl) + (sly math) + (sly math rect) + (sly math transform) + (sly math vector) + (sly render camera) + (sly render color) + (sly render font) + (sly render group) + (sly render model) + (sly render sprite) + (sly input keyboard) + (sly input mouse)) + +(set! *random-state* (random-state-from-platform)) + +;;; +;;; Utils +;;; + +(define (list-replace lst k value) + (append (take lst k) (cons value (drop lst (1+ k))))) + +(define (enumerate-map proc lst) + (define (iter k lst) + (match lst + (() '()) + ((x . rest) + (cons (proc x k) (iter (1+ k) rest))))) + + (iter 0 lst)) + +(define (compact lst) + (filter identity lst)) + +(define (nonzero? n) + (not (= n 0))) + +;;; +;;; Model +;;; + +(define-record-type + (make-tile mine? shown? flag mine-count) + tile? + (mine? tile-mine?) + (shown? tile-shown?) + (flag tile-flag) + (mine-count tile-mine-count)) + +(define tile-show + (match-lambda + (($ mine? _ flag mine-count) + (make-tile mine? #t flag mine-count)))) + +(define (tile-mark tile flag) + (match tile + (($ mine? shown? _ mine-count) + (make-tile mine? shown? flag mine-count)))) + +(define tile-toggle-flag + (match-lambda + (($ mine? shown? flag mine-count) + (make-tile mine? shown? + (match flag + ('none 'flag) + ('flag 'maybe) + ('maybe 'none)) + mine-count)))) + +(define (set-tile-mine-count tile mine-count) + (match tile + (($ mine? shown? flag _) + (make-tile mine? shown? flag mine-count)))) + +(define (tile-flagged? tile) + (not (eq? (tile-flag tile) 'none))) + +(define (make-board size mine-count) + (define (random-mine) + (vector2 (random size) (random size))) + + (let ((mines (let loop ((mines '()) + (m 0)) + (if (< m mine-count) + (loop (cons (let inner-loop ((mine (random-mine))) + ;; Loop until we don't have a + ;; duplicate mine position. + (if (member mine mines) + (inner-loop (random-mine)) + mine)) + mines) + (1+ m)) + mines)))) + + (define (make-tile* x y) + (make-tile (list? (member (vector2 x y) mines)) + #f 'none #f)) + + (define (make-row y) + (list-tabulate size (lambda (x) (make-tile* x y)))) + + (list-tabulate size (lambda (y) (make-row y))))) + +(define board-ref + (case-lambda + ((board x y) (list-ref (list-ref board y) x)) + ((board p) + (list-ref (list-ref board (vy p)) (vx p))))) + +(define (board-update board position tile) + (match position + (($ x y) + (list-replace board y (list-replace (list-ref board y) x tile))))) + +(define (neighbors board pos) + (let* ((size (length board)) + (area (make-rect 0 0 size size))) + (chain (list (vector2 1 1) + (vector2 1 0) + (vector2 1 -1) + (vector2 0 -1) + (vector2 -1 -1) + (vector2 -1 0) + (vector2 -1 1) + (vector2 0 1)) + (map (cut v+ pos <>)) + (filter (cut rect-contains? area <>))))) + +(define (board-reveal board position) + (let* ((tile (board-ref board position))) + (cond + ;; Nothing to do. + ((or (tile-shown? tile) + (tile-flagged? tile)) + board) + ;; Oops! + ((tile-mine? tile) + (board-update board position (tile-show tile))) + (else + (let* ((neighbors (neighbors board position)) + ;; Compute bordering mines and reveal tile. + (mine-count (count (lambda (neighbor) + (tile-mine? (board-ref board neighbor))) + neighbors)) + (tile (tile-show (set-tile-mine-count tile mine-count))) + (board (board-update board position tile))) + ;; Recursively reveal neighboring tiles if the chosen tile + ;; does not border a mine. + (if (= mine-count 0) + (fold (lambda (pos prev) (board-reveal prev pos)) + board neighbors) + board)))))) + +(define (board-toggle-flag board position) + (board-update board position + (tile-toggle-flag (board-ref board position)))) + +(define (board-win? board) + (every (match-lambda + ((or ($ #f #t _ _) + ($ #t #f _ _)) + #t) + (else #f)) + (concatenate board))) + +(define (board-lose? board) + (any (match-lambda + (($ #t #t _ _) #t) + (else #f)) + (concatenate board))) + +;;; +;;; State +;;; + +(define resolution (vector2 640 480)) +(define tile-size 32) + +(define-signal board-size 8) +(define-signal board-area + (signal-map (lambda (size) (make-rect 0 0 size size)) board-size)) + +(define-signal center-position + (signal-map (lambda (board-size) + (v- (v* 1/2 resolution) + (/ (* board-size tile-size) 2))) + board-size)) + +(define-signal tile-position + (signal-map (lambda (p size center) + (vmap floor (v* (v- p center) (/ 1 tile-size)))) + mouse-position board-size center-position)) + +(define-signal reveal-clicks + (chain mouse-last-up + (signal-filter (cut eq? 'left <>) #f) + (signal-sample-on tile-position))) + +(define-signal flag-clicks + (chain mouse-last-up + (signal-filter (cut eq? 'right <>) #f) + (signal-sample-on tile-position))) + +;; User commands. The first command is the null command to prevent +;; acting upon the initial value of reveal-clicks, which must be +;; ignored. +(define-signal command + (signal-merge + (make-signal 'null) + (signal-map (cut list 'reveal <>) reveal-clicks) + (signal-map (cut list 'flag <>) flag-clicks) + (signal-map (lambda _ 'restart) (key-down? 'n)))) + +(define (make-fresh-board) + (make-board (signal-ref board-size) 10)) + +(define (maybe-update-board proc board p) + (if (rect-contains? (signal-ref board-area) p) + (proc board p) + board)) + +(define-signal board + (signal-fold (lambda (op board) + (match op + ('null board) + ('restart (make-fresh-board)) + (('reveal p) + (maybe-update-board board-reveal board p)) + (('flag p) + (maybe-update-board board-toggle-flag board p)))) + (make-fresh-board) + command)) + +;;; +;;; View +;;; + +(open-window) +(enable-fonts) + +(define font (load-default-font)) + +(define sprites + (map (match-lambda + ((key . config) + (cons key (load-sprite + (string-append "images/" (assoc-ref config 'name) ".png") + #:anchor (assoc-ref config 'anchor))))) + '((1 . ((name . "1-mine") + (anchor . center))) + (2 . ((name . "2-mines") + (anchor . center))) + (3 . ((name . "3-mines") + (anchor . center))) + (4 . ((name . "4-mines") + (anchor . center))) + (5 . ((name . "5-mines") + (anchor . center))) + (6 . ((name . "6-mines") + (anchor . center))) + (7 . ((name . "7-mines") + (anchor . center))) + (8 . ((name . "8-mines") + (anchor . center))) + (mine . ((name . "mine") + (anchor . center))) + (exploded . ((name . "exploded") + (anchor . center))) + (flag . ((name . "flag") + (anchor . center))) + (maybe . ((name . "maybe") + (anchor . center))) + (tile-up . ((name . "tile-up") + (anchor . bottom-left))) + (tile-down .((name . "tile-down") + (anchor . bottom-left)))))) + +(define (sprite-ref key) + (assoc-ref sprites key)) + +(define (tile-base-sprite tile) + (sprite-ref + (match tile + (($ _ #t _ _) 'tile-down) + (_ 'tile-up)))) + +(define (tile-overlay-sprite tile) + (and=> (match tile + (($ #t #t _ _) 'exploded) + (($ _ #f 'flag _) 'flag) + (($ _ #f 'maybe _) 'maybe) + (($ #f #t _ (? nonzero? mine-count)) + mine-count) + (_ #f)) + sprite-ref)) + +(define draw-tile + (let ((offset (translate (vector2 (/ tile-size 2) (/ tile-size 2))))) + (lambda (tile) + ;; A tile may or may not have an overlay, so we do a little + ;; quasiquoting magic to build the right list. + (make-group + `(,(tile-base-sprite tile) + ,@(let ((overlay (tile-overlay-sprite tile))) + (if overlay + (list (group-place offset (group overlay))) + '()))))))) + +(define-signal board-view + (signal-map (lambda (board) + (define (draw-column tile x) + (group-move (vector2 (* x tile-size) 0) + (draw-tile tile))) + + (define (draw-row row y) + (group-move (vector2 0 (* y tile-size)) + (make-group (enumerate-map draw-column row)))) + + (make-group (enumerate-map draw-row board))) + board)) + +(define-signal status-message + (signal-map (lambda (board) + (define (make-message message) + (label font message #:anchor 'center)) + + (group-move + (vector2 (/ (vx resolution) 2) (- (vy resolution) 64)) + (make-group + (cond + ((board-lose? board) + (list (make-message "GAME OVER - Press N to play again"))) + ((board-win? board) + (list (make-message "YOU WIN! - Press N to play again"))) + (else '()))))) + board)) + +(define-signal scene + (signal-map (lambda (board-view status center-position) + (group + status + (group-move center-position board-view))) + board-view status-message center-position)) + +(define camera + (orthographic-camera + (vx resolution) (vy resolution) + #:viewport (make-viewport (make-rect (vector2 0 0) resolution) + #:clear-color tango-dark-plum))) + +(define (draw-scene dt alpha) + (draw-group (signal-ref scene) camera)) + +;;; +;;; Initialization +;;; + +(start-sly-repl) + +(add-hook! window-close-hook stop-game-loop) +(add-hook! draw-hook (trampoline draw-scene)) + +(with-window (make-window #:title "Mines" #:resolution resolution) + (start-game-loop)) + +;;; Local Variables: +;;; compile-command: "../../pre-inst-env guile mines.scm" +;;; End: -- cgit v1.2.3