path: root/examples/mines/mines.scm

;;; Mines
;;; Copyright (C) 2014 David Thompson <davet@gnu.org>
;;;
;;; 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
;;; <http://www.gnu.org/licenses/>.

;;; 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)
             (sly render camera)
             (sly render color)
             (sly render font)
             (sly render sprite)
             (sly render sprite-batch)
             (sly render texture)
             (sly render tileset)
             (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-each proc lst)
  (let loop ((k 0) (lst lst))
    (match lst
      (() *unspecified*)
      ((head . tail)
       (proc head k)
       (loop (1+ k) tail)))))

(define (compact lst)
  (filter identity lst))

(define nonzero? (negate zero?))

;;;
;;; Model
;;;

(define-record-type <tile>
  (make-tile mine? shown? flag mine-count)
  tile?
  (mine? tile-mine?)
  (shown? tile-shown?)
  (flag tile-flag)
  (mine-count tile-mine-count))

(define (tile-shown-mine? tile)
  (and (tile-shown? tile)
       (tile-mine? tile)))

(define (tile-hidden-mine? tile)
  (and (not (tile-shown? tile))
       (tile-mine? tile)))

(define (tile-shown-not-mine? tile)
  (and (tile-shown? tile)
       (not (tile-mine? tile))))

(define (tile-neighboring-mines? tile)
  (nonzero? (tile-mine-count tile)))

(define tile-show
  (match-lambda
   (($ <tile> mine? _ flag mine-count)
    (make-tile mine? #t flag mine-count))))

(define (tile-mark tile flag)
  (match tile
    (($ <tile> mine? shown? _ mine-count)
     (make-tile mine? shown? flag mine-count))))

(define tile-toggle-flag
  (match-lambda
    (($ <tile> 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
    (($ <tile> mine? shown? flag _)
     (make-tile mine? shown? flag mine-count))))

(define (tile-flagged? tile)
  (not (eq? (tile-flag tile) 'none)))

(define (tile-flagged-mine? tile)
  (eq? (tile-flag tile) 'flag))

(define (tile-flagged-maybe? tile)
  (eq? (tile-flag tile) 'maybe))

(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 v)
     (list-ref (list-ref board (vy v)) (vx v)))))

(define (board-update board position tile)
  (match position
    (($ <vector2> 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-lose? board))
      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 (zero? mine-count)
            (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 (lambda (row)
           (every (lambda (tile)
                    (or (tile-shown-not-mine? tile)
                        (tile-hidden-mine? tile)))
                  row))
         board))

(define (board-lose? board)
  (any (cut any tile-shown-mine? <>) board))

;;;
;;; State
;;;

(define resolution (vector2 640 480))
(define tile-size 32)

(define-signal board-size 8)

(define-signal board-area
  (signal-let ((size board-size))
    (make-rect 0 0 size size)))

(define-signal center-position
  (signal-let ((board-size board-size))
    (v- (v* 1/2 resolution)
        (/ (* board-size tile-size) 2))))

(define-signal tile-position
  (signal-let ((p      mouse-position)
               (size   board-size)
               (center center-position))
    (vmap floor (v* (v- p center) (/ 1 tile-size)))))

(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-constant '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
;;;

(define (make-tiles tileset)
  (map (match-lambda
         ((key . tile-index)
          (cons key (tileset-ref tileset tile-index))))
       '((1 . 10)
         (2 . 11)
         (3 . 4)
         (4 . 5)
         (5 . 6)
         (6 . 7)
         (7 . 0)
         (8 . 1)
         (mine . 14)
         (exploded . 15)
         (flag . 8)
         (maybe . 9)
         (tile-up . 13)
         (tile-down . 12))))

(define (tile-ref tiles key)
  (assoc-ref tiles key))

(define (tile-base tiles tile)
  (tile-ref tiles
            (if (tile-shown? tile)
                'tile-down
                'tile-up)))

(define (tile-overlay tiles tile)
  (let ((type (cond
               ((tile-shown-mine? tile) 'exploded)
               ((tile-flagged-mine? tile) 'flag)
               ((tile-flagged-maybe? tile) 'maybe)
               ((and (tile-shown-not-mine? tile)
                     (tile-neighboring-mines? tile))
                (tile-mine-count tile))
               (else #f))))
    (tile-ref tiles type)))

(define tile-rect (make-rect 0 0 32 32))

(define (render-board board tiles batch)
  (lambda (gfx)
    (with-sprite-batch batch gfx
      (enumerate-each
       (lambda (row y)
         (enumerate-each
          (lambda (tile x)
            (let ((rect (rect-move tile-rect
                                   (* x tile-size)
                                   (* y tile-size)))
                  (base-tex (tile-base tiles tile))
                  (overlay-tex (tile-overlay tiles tile)))
              (sprite-batch-add! batch gfx base-tex rect)
              (when overlay-tex
                (sprite-batch-add! batch gfx overlay-tex rect))))
          row))
       board))))

(define (render-message font message)
  (move (vector2 (/ (vx resolution) 2)
                 (- (vy resolution) 64))
        (render-sprite
         (make-label font message #:anchor 'center))))

(define (render-message-maybe message)
  (signal-map-maybe (lambda (font)
                      (render-message font message))
                    font))

(define camera
  (2d-camera #:area (make-rect (vector2 0 0) resolution)
             #:clear-color tango-dark-plum))

(define-signal font
  (on-start (load-default-font)))

;; Minefield is 8x8, and there are 2 layers of tile graphics.
(define-signal batch
  (on-start (make-sprite-batch (* 8 8 2))))

(define-signal tileset
  (on-start (load-tileset "images/tiles.png" 32 32)))

(define-signal tiles
  (signal-map-maybe make-tiles tileset))

(define-signal board-view
  (signal-map-maybe render-board board tiles batch))

(define-signal status-message
  (signal-let ((game-over (render-message-maybe
                           "GAME OVER - Press N to play again"))
               (you-win   (render-message-maybe
                           "YOU WIN! - Press N to play again"))
               (board board))
    (cond
     ((not (or game-over you-win)) ; assets not loaded
      render-nothing)
     ((board-lose? board)
      game-over)
     ((board-win? board)
      you-win)
     (else render-nothing))))

(define-signal scene
  (signal-let ((view   board-view)
               (status status-message)
               (center center-position))
    (with-camera camera
      (render-begin
       status
       (move center (or view render-nothing))))))

;;;
;;; Initialization
;;;

;;(start-sly-repl)

(add-hook! window-close-hook stop-game-loop)

(with-window (make-window #:title "Mines" #:resolution resolution)
  (enable-fonts)
  (run-game-loop scene))

;;; Local Variables:
;;; compile-command: "../../pre-inst-env guile mines.scm"
;;; End: