A first attempt at McCLIM.

minesweeper.asd

;;;; minesweeper.asd

(asdf:defsystem "minesweeper"
  :serial t
  :description "A quick minesweeper game using McCLIM"
  :author "Dimitri Fontaine <[email protected]>"
  :license "ISC"
  :depends-on (#:mcclim)
  :components ((:file "minesweeper")))

minesweeper.lisp

(in-package :common-lisp-user)

(defpackage "MINESWEEPER"
  (:use :clim :clim-lisp)
  (:export "PLAY"))

(in-package :minesweeper)

#|
(setf mcclim-truetype::*truetype-font-path* "#P/Users/dim/Library/Fonts/")
(mcclim-truetype::autoconfigure-fonts)
|#

;;; Define a application-frame (a.k.a. application window in traditional GUI's).

(defparameter *cell-size* 30)
(defparameter *rows* 10)
(defparameter *cols* 20)

;;;
;;; Only a few of those can be displayed by the font :(
;;;  ♣ ⚑ ♥ ☣ ☉ ☙ ☢ ☤ ☩ ☵ ♦ ⚐ ⚓ ⚡ ⚰ ♯ ♠
;;;
(defparameter *bomb* (aref "♣" 0))
(defparameter *flag* (aref "♠" 0))

(defstruct minesweeper-cell
  row col bomb-p flagged-p clicked-p count-bombs-around)

(defmethod minesweeper-cell-label ((cell minesweeper-cell) &optional show-bombs)
  (cond ((and show-bombs (minesweeper-cell-bomb-p cell)) *bomb*)
        ((minesweeper-cell-flagged-p cell) *flag*)
        ((or show-bombs (minesweeper-cell-clicked-p cell))
         (if (zerop (minesweeper-cell-count-bombs-around cell))
             #\Space
             (code-char (+ #. (char-code #\0)
                           (minesweeper-cell-count-bombs-around cell)))))
        (t #\Space)))

(defmethod walk-cell-neighbors ((cell minesweeper-cell) grid thunk)
  (destructuring-bind (rows cols)
      (array-dimensions grid)
    (loop :for r :from -1 :to 1
       :do (loop :for c :from -1 :to 1
              :unless (= 0 r c)
              :do (let ((rr (+ r (minesweeper-cell-row cell)))
                        (cc (+ c (minesweeper-cell-col cell))))
                    (when (and (< -1 rr rows)             ; 0 .. rows-1
                               (< -1 cc cols))            ; 0 .. cols-1
                      (let ((neighbor (aref grid rr cc)))
                        (funcall thunk neighbor grid))))))))

(defmethod minesweeper-count-bombs-around ((cell minesweeper-cell) grid)
  (flet ((sum-the-bombs (neighbor grid)
           (declare (ignore grid))
           (when (minesweeper-cell-bomb-p neighbor)
             (incf (minesweeper-cell-count-bombs-around cell)))))
    (walk-cell-neighbors cell grid #'sum-the-bombs)))

(defmethod click-neighbors-cells ((cell minesweeper-cell) grid)
  "When a user clicks on a cell, we mark every neighbor cell that has no bomb
   around as clicked too"
  (with-slots (row col clicked-p count-bombs-around) cell
    (unless clicked-p
      (cond ((= 0 count-bombs-around)
             (setf clicked-p t)

             (walk-cell-neighbors cell grid
                                  (lambda (cell grid)
                                    (click-neighbors-cells cell grid))))

            ((< 0 count-bombs-around)
             (setf clicked-p t))))))

;;;
;;; Implement patterns to display the bomb and the flag.
;;;
;;; Ideally we would use unicode characters for them, but finding and using
;;; the font that has the characters proved difficult even before
;;; considering the portability of such a choice. It's only 2018 :/
;;;
(defparameter *bomb-pattern*
  (make-pattern
   #2a#((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 0 0 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0)
        (0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
        (0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
        (0 0 0 0 0 0 1 1 1 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
        (0 0 0 0 0 0 1 1 1 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
        (0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0)
        (0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0)
        (0 0 0 0 1 1 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0)
        (0 0 0 0 1 1 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0)
        (0 0 0 0 1 1 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0)
        (0 0 0 0 1 1 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0)
        (0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0)
        (0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0)
        (0 0 0 0 0 0 1 1 1 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
        (0 0 0 0 0 0 1 1 1 2 2 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
        (0 0 0 0 0 0 1 1 1 1 1 1 1 2 2 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
        (0 0 0 0 0 0 1 1 1 1 1 1 1 2 2 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
        (0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
   (list +transparent-ink+              ; 0
         +black+                        ; 1
         +white+)))

(defparameter *flag-pattern*
  (make-pattern
   #2a#((0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0)
        (0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0)
        (0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
        (0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
        (0 0 0 0 1 1 1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 1 1 1 0 0 0 0)
        (0 0 0 0 1 1 1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 1 1 1 0 0 0 0)
        (0 0 0 0 1 1 1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 1 1 1 0 0 0 0)
        (0 0 0 0 1 1 1 1 0 0 0 0 0 0 1 1 0 0 0 0 0 0 1 1 1 1 0 0 0 0)
        (0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
        (0 0 0 0 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 0 0 0 0)
        (0 0 0 0 0 0 1 1 1 1 1 1 1 1 0 0 1 1 1 1 1 1 1 1 0 0 0 0 0 0)
        (0 0 0 0 0 0 1 1 1 1 1 1 1 1 0 0 1 1 1 1 1 1 1 1 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 1 1 1 1 1 1 1 1 1 1 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 1 1 0 0 1 1 0 0 1 1 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 1 1 0 0 1 1 0 0 1 1 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0)
        (0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0))
   (list +transparent-ink+              ; 0
         +black+                        ; 1
         +white+)))                     ; 2


;;;
;;; Introduce a graphical view for the main 'display pane
;;;

(defclass graphical-view (view) ())

(defparameter +graphical-view+ (make-instance 'graphical-view))

(define-application-frame minesweeper ()
  ((grid :initform (make-array (list *rows* *cols*)
                               :element-type '(or minesweeper-cell null)
                               :initial-element nil)
         :accessor grid)
   (show-bombs :initform nil :accessor show-bombs)
   (difficulty :initform :easy :accessor difficulty))
  (:menu-bar menubar-command-table)
  (:panes (display :application
                   :display-function 'draw-minesweeper
                   :default-view +graphical-view+
                   :text-style (clim:make-text-style :serif :bold 24)
                   :text-cursor nil
                   :scroll-bars nil)
          (int :interactor
               :height 50
               :text-style (clim:make-text-style :serif :roman 12)
               :end-of-page-action :scroll
               :scroll-bars t))
  (:layouts
   (:default (vertically ()
               (scrolling (:height (+ 2 *rows* (* *cell-size* *rows*))
                                   :width (+ 2 *cols* (* *cell-size* *cols*))
                                   :scroll-bars nil)
                 display)
               int))))

(defmethod run-frame-top-level :before ((minesweeper minesweeper) &key)
  (initialize-grid minesweeper))

(defmethod initialize-grid ((minesweeper minesweeper))
  (let* ((grid  (grid minesweeper))
         (bombs (ecase (difficulty minesweeper)
                  (:easy   20)
                  (:medium 30)
                  (:hard   40)))
         (bombs-so-far 0))
    (destructuring-bind (rows cols)
        (array-dimensions grid)

      ;; prepare an empty grid with many cells.
      (loop :for row :below rows
         :do (loop :for col :below cols
                :do (setf (aref grid row col)
                          (make-minesweeper-cell :row row
                                                 :col col
                                                 :clicked-p nil
                                                 :flagged-p nil
                                                 :bomb-p nil
                                                 :count-bombs-around 0))))
      ;; now generate bombs randomly
      (loop :until (= bombs-so-far bombs)
         :do (multiple-value-bind (row col)
                 (truncate (random (* rows cols)) cols)
               (let ((cell (aref grid row col)))
                 (unless (minesweeper-cell-bomb-p cell)
                   (incf bombs-so-far)
                   (setf (minesweeper-cell-bomb-p cell) t)))))

      ;; now initialize neighbour bombs count
      (loop :for row :below rows
         :do (loop :for col :below cols
                :do (let ((cell (aref grid row col)))
                      (minesweeper-count-bombs-around cell grid)))))))

(defmethod unveiled-all-bombs-p ((minesweeper minesweeper))
  "Return non-nil when all bombs in grid have been discovered."
  (let* ((grid  (grid minesweeper))
         (bombs (ecase (difficulty minesweeper)
                  (:easy   20)
                  (:medium 30)
                  (:hard   40))))
    (destructuring-bind (rows cols)
        (array-dimensions grid)
      (= bombs
         (loop :for row :below rows
            :sum (loop :for col :below cols
                    :count (let ((cell (aref grid row col)))
                             (and (minesweeper-cell-flagged-p cell)
                                  (minesweeper-cell-bomb-p cell)))))))))

;;; if minesweeper-cell is a standard-class, then this will use it (so objects
;;; of said class will be recognized as this presentation-type).
(define-presentation-type minesweeper-cell ())

(define-presentation-method present
    (cell (type minesweeper-cell) stream (view textual-view) &key)
  (declare (ignorable view))
  (with-slots (row col) cell
    (format stream "~a:~a ~a"
            row col
            (minesweeper-cell-label cell (show-bombs *application-frame*)))))

(define-presentation-method present
    (cell (type minesweeper-cell) stream (view graphical-view) &key)
  (declare (ignorable view))
  (let ((char      (minesweeper-cell-label cell (show-bombs *application-frame*)))
        (done      (unveiled-all-bombs-p *application-frame*))
        (bomb-p    (minesweeper-cell-bomb-p cell))
        (clicked-p (minesweeper-cell-clicked-p cell)))
    (draw-rectangle* stream 0 0 *cell-size* *cell-size*
                     :filled t
                     :ink (cond ((and bomb-p done) +PaleGreen3+)
                                (clicked-p         +white+)
                                (t                 +wheat2+)))
    (cond
      ((and bomb-p done)   (draw-design stream *bomb-pattern*))
      ((char= char *bomb*) (draw-design stream *bomb-pattern*))
      ((char= char *flag*) (draw-design stream *flag-pattern*))
      (t                   (format stream " ~a" char)))))

(define-presentation-method highlight-presentation
    ((type minesweeper-cell) record stream state)
  (declare (ignorable state stream))
  (unless (minesweeper-cell-clicked-p (clim:presentation-object record))
    (case state
      (:highlight   (clim:with-bounding-rectangle* (left top right bottom)
                        record
                      (draw-rectangle* stream left top right bottom
                                       :filled t
                                       :ink clim:+flipping-ink+)))
      (:unhighlight (clim:repaint-sheet stream record)))))

(defmethod draw-minesweeper ((minesweeper minesweeper) stream
                             &key max-width max-height)
  (declare (ignore max-width max-height))
  (let ((grid (grid minesweeper)))
    (formatting-table (stream :x-spacing 1 :y-spacing 1
                              :equalize-column-widths t)
      (loop :for row :below *rows*
         :do (formatting-row (stream)
               (loop :for col :below *cols*
                  :do (let ((value   (aref grid row col))
                            (cell-id (cons row col)))
                        (progn ;updating-output (stream :unique-id cell-id)
                          (formatting-cell
                              (stream :align-x :center
                                      :align-y :center
                                      :min-width *cell-size*
                                      :min-height *cell-size*)
                            (clim:present value))))))))))

(define-minesweeper-command com-click-cell ((cell minesweeper-cell))
  (with-slots (grid) *application-frame*
    (if (minesweeper-cell-bomb-p cell)
        (setf (show-bombs *application-frame*) t)
        (click-neighbors-cells cell grid))))

(define-presentation-to-command-translator click-cell
    (minesweeper-cell com-click-cell minesweeper
                      :documentation "Click cell"
                      :gesture :select
                      :echo t
                      :tester ((object) t))
    (object)
  (list object))

(define-minesweeper-command com-flag-cell ((cell minesweeper-cell))
  (with-slots (grid) *application-frame*
    (setf (minesweeper-cell-flagged-p cell)
          (not (minesweeper-cell-flagged-p cell)) )))

(define-presentation-to-command-translator flag-cell
    (minesweeper-cell com-flag-cell minesweeper
                      :documentation "Flag cell"
                      :gesture :describe
                      :echo t
                      :tester ((object) t))
    (object)
  (list object))

;;; Following function launches an instance of "superapp" application-frame.
(defun play ()
  (run-frame-top-level (make-application-frame 'minesweeper)))

(define-minesweeper-command (com-quit :name t) ()
  (clim:frame-exit clim:*application-frame*))

(define-minesweeper-command (com-reset :name t) ()
  (setf (show-bombs *application-frame*) nil)
  (initialize-grid clim:*application-frame*))

(define-minesweeper-command (com-show-bombs :name t) ()
  (with-slots (show-bombs) *application-frame*
    (setf show-bombs (not show-bombs))))

(define-minesweeper-command (com-set-easy :name t) ()
  (setf (difficulty clim:*application-frame*) :easy)
  (initialize-grid clim:*application-frame*))

(define-minesweeper-command (com-set-medium :name t) ()
  (setf (difficulty clim:*application-frame*) :medium)
  (initialize-grid clim:*application-frame*))

(define-minesweeper-command (com-set-hard :name t) ()
  (setf (difficulty clim:*application-frame*) :hard)
  (initialize-grid clim:*application-frame*))

(make-command-table 'difficulty-command-table
                    :errorp nil
                    :menu '(("Easy"   :command com-set-easy)
                            ("Medium" :command com-set-medium)
                            ("Hard"   :command com-set-hard)))

(make-command-table 'menubar-command-table
		    :errorp nil
		    :menu '(("Difficulty" :menu difficulty-command-table)
                            ("Reset" :command com-reset)
                            ("Show Bombs" :command com-show-bombs)
                            ("Quit" :command com-quit)))