chiark - git - mdw - atoms/blob - atoms.lisp

   1 ;;; -*-lisp-*-
   2 ;;;
   3 ;;; Atoms game
   4 ;;;
   5 ;;; (c) 2007 Mark Wooding
   6 ;;;
   7
   8 ;;;----- Licensing notice ---------------------------------------------------
   9 ;;;
  10 ;;; This program is free software; you can redistribute it and/or modify
  11 ;;; it under the terms of the GNU General Public License as published by
  12 ;;; the Free Software Foundation; either version 2 of the License, or
  13 ;;; (at your option) any later version.
  14 ;;;
  15 ;;; This program is distributed in the hope that it will be useful,
  16 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;;; GNU General Public License for more details.
  19 ;;;
  20 ;;; You should have received a copy of the GNU General Public License
  21 ;;; along with this program; if not, write to the Free Software Foundation,
  22 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
  23
  24 (cl:defpackage #:atoms
  25   (:use #:cl
  26         #+cmu #:ext
  27         #+sbcl #:sb-ext
  28         #+clisp #:ext)
  29   #+clisp (:shadow #:map-dependents #:add-dependent #:remove-dependent)
  30   (:export #:start-atom-game))
  31 (cl:in-package #:atoms)
  32
  33 (eval-when (:compile-toplevel :load-toplevel :execute)
  34   (asdf:operate 'asdf:load-op :gtk))
  35
  36 (clg:clg-init)
  37
  38 ;;; Before we start, I should probably point out that the first version of
  39 ;;; this program was written in Smalltalk, which may explain its slight
  40 ;;; object-ravioli nature.
  41
  42 ;;;--------------------------------------------------------------------------
  43 ;;; Dependent management.
  44
  45 ;; Protocol.
  46
  47 (defgeneric notify (dependent model aspect &key &allow-other-keys)
  48   (:method-combination progn)
  49   (:method progn (dependent model aspect &rest arguments)
  50     (declare (ignore arguments))
  51     nil))
  52
  53 (defgeneric map-dependents (model function))
  54 (defgeneric add-dependent (model dependent))
  55 (defgeneric remove-dependent (model dependent))
  56
  57 (defgeneric changed (model &optional aspect &key &allow-other-keys)
  58   (:method (model &optional aspect &rest arguments)
  59     (map-dependents model
  60                     (lambda (dependent)
  61                       (apply #'notify dependent model aspect arguments)))))
  62
  63 ;; Generic implementation.
  64
  65 (defclass model ()
  66   ((dependents :type list :initform nil)))
  67
  68 (defun clean-up-danglies (model)
  69   (with-slots (dependents) model
  70     (setf dependents
  71           (delete-if-not (lambda (weak)
  72                            (nth-value 1 (weak-pointer-value weak)))
  73                          dependents))))
  74
  75 (defmethod map-dependents ((model model) function)
  76   (with-slots (dependents) model
  77     (let ((danglies nil))
  78       (dolist (dependent dependents)
  79         (multiple-value-bind (object foundp)
  80             (weak-pointer-value dependent)
  81           (if foundp
  82               (funcall function object)
  83               (setf danglies t))))
  84       (when danglies (clean-up-danglies model))
  85       nil)))
  86
  87 (defmethod add-dependent ((model model) dependent)
  88   (let ((foundp (block nil
  89                   (map-dependents model
  90                                   (lambda (dep)
  91                                     (when (eql dependent dep)
  92                                       (return t)))))))
  93     (unless foundp
  94       (push (make-weak-pointer dependent)
  95             (slot-value model 'dependents)))))
  96
  97 (defmethod remove-dependent ((model model) dependent)
  98   (with-slots (dependents) model
  99     (setf dependents (delete dependent dependents
 100                              :key #'weak-pointer-value))
 101     (clean-up-danglies model)))
 102
 103 ;;;--------------------------------------------------------------------------
 104 ;;; Undo and redo.
 105
 106 (defclass undoable ()
 107   ((undo-list :type list :reader undo-list :initform nil)
 108    (redo-list :type list :reader redo-list :initform nil)))
 109
 110 (defgeneric snapshot (object))
 111 (defgeneric restore (object snapshot))
 112 (defgeneric store-undo-snapshot (object snapshot))
 113 (defgeneric undo (object))
 114 (defgeneric redo (object))
 115 (defgeneric reset-undo-state (object))
 116
 117 (defmethod store-undo-snapshot ((object undoable) snapshot)
 118   (push snapshot (slot-value object 'undo-list))
 119   (setf (slot-value object 'redo-list) nil))
 120
 121 (defmacro with-undo-snapshot ((object) &body body)
 122   (let ((snap (gensym "SNAPSHOT"))
 123         (obj (gensym "OBJECT")))
 124     `(let* ((,obj ,object)
 125             (,snap (snapshot ,obj)))
 126        (multiple-value-prog1 (progn ,@body)
 127          (store-undo-snapshot ,obj ,snap)))))
 128
 129 (defun undo-redo (object from to)
 130   (let ((from-list (slot-value object from)))
 131     (assert from-list)
 132     (let ((undo-snap (car from-list))
 133           (here-snap (snapshot object)))
 134       (restore object undo-snap)
 135       (push here-snap (slot-value object to))
 136       (pop (slot-value object from)))))
 137
 138 (defmethod undo ((object undoable))
 139   (undo-redo object 'undo-list 'redo-list))
 140
 141 (defmethod redo ((object undoable))
 142   (undo-redo object 'redo-list 'undo-list))
 143
 144 (defmethod reset-undo-state ((object undoable))
 145   (setf (slot-value object 'undo-list) nil
 146         (slot-value object 'redo-list) nil))
 147
 148 (defclass undoable-model (undoable model)
 149   ())
 150
 151 (defmethod undo :after ((object undoable-model))
 152   (changed object :undo))
 153
 154 (defmethod redo :after ((object undoable-model))
 155   (changed object :redo))
 156
 157 ;;;--------------------------------------------------------------------------
 158 ;;; Main game logic.
 159
 160 ;; Protocol.
 161
 162 (defclass atom-cell ()
 163   ((owner :reader cell-owner :initform nil :type (or fixnum null))
 164    (count :reader cell-count :initform 0 :type fixnum)
 165    (pending :initform 0 :type fixnum)
 166    (neighbours :reader cell-neighbours :type list :initform nil)
 167    (x :reader cell-x :initarg :x :type fixnum)
 168    (y :reader cell-y :initarg :y :type fixnum)))
 169
 170 (defgeneric cell-played (cell player))
 171 (defgeneric cell-critical-p (cell))
 172 (defgeneric cell-explode (cell))
 173 (defgeneric cell-apply-pending-updates (cell))
 174 (defun cell-position (cell) (vector (cell-x cell) (cell-y cell)))
 175
 176 (defun make-atoms-grid (width height)
 177   (let ((grid (make-array (list height width) :element-type 'atom-cell)))
 178     (dotimes (j height)
 179       (dotimes (i width)
 180         (setf (aref grid j i) (make-instance 'atom-cell :x i :y j))))
 181     (dotimes (j height)
 182       (dotimes (i width)
 183         (setf (slot-value (aref grid j i) 'neighbours)
 184               (nconc (and (> j 0) (list (aref grid (1- j) i)))
 185                      (and (> i 0) (list (aref grid j (1- i))))
 186                      (and (< i (1- width)) (list (aref grid j (1+ i))))
 187                      (and (< j (1- height)) (list (aref grid (1+ j) i)))))))
 188     grid))
 189
 190 (defclass player ()
 191   ((name :accessor player-name :initarg :name :type string)
 192    (score :accessor player-score :initform 0 :type fixnum)
 193    (state :accessor player-state :initform :starting
 194           :type (member :starting :playing :ready :losing :winning))
 195    (colour :accessor player-colour :initarg :colour :type gdk:color)))
 196
 197 (defclass human-player (player) ())
 198
 199 (defgeneric player-cell-selected (game player i j)
 200   (:method (game player i j) nil))
 201 (defgeneric player-turn-begin (game player)
 202   (:method (game player) nil))
 203
 204 (defclass atom-game (undoable-model)
 205   ((grid :accessor game-grid :initarg :grid :type (array atom-cell (* *)))
 206    (players :accessor game-players :initarg :players :type vector)
 207    (player-index :accessor game-player-index :initform 0 :type fixnum)
 208    (timeout-id :initform nil)))
 209
 210 (defgeneric game-cell-selected (game i j))
 211 (defgeneric play-cell (game player i j))
 212
 213 ;; Implementation.
 214
 215 (defmethod cell-played ((cell atom-cell) player)
 216   (with-slots (owner count) cell
 217     (cond ((zerop count) (setf owner player count 1) t)
 218           ((eql owner player) (incf count) t)
 219           (t nil))))
 220
 221 (defmethod cell-critical-p ((cell atom-cell))
 222   (with-slots (count neighbours) cell
 223     (>= count (length neighbours))))
 224
 225 (defmethod cell-explode ((cell atom-cell))
 226   (with-slots (count neighbours owner pending) cell
 227     (multiple-value-bind (spill left) (floor count (length neighbours))
 228       (and (plusp spill)
 229            (progn
 230              (dolist (neighbour neighbours)
 231                (incf (slot-value neighbour 'pending) spill)
 232                (setf (slot-value neighbour 'owner) owner))
 233              (setf count left)
 234              (when (zerop left)
 235                (setf owner nil))
 236              (cons cell (copy-list neighbours)))))))
 237
 238 (defmethod cell-apply-pending-updates ((cell atom-cell))
 239   (with-slots (count pending) cell
 240     (incf count pending)
 241     (setf pending 0)))
 242
 243 (deftype cell-snapshot () '(unsigned-byte 16))
 244
 245 (defmethod snapshot ((cell atom-cell))
 246   (with-slots (count owner) cell
 247     (cond ((null owner) 0)
 248           (t (assert (and (<= 0 count 255)
 249                           (<= 0 owner 255)))
 250              (logior (ash owner 8)
 251                      (ash count 0))))))
 252
 253 (defmethod restore ((cell atom-cell) (snapshot integer))
 254   (declare (type cell-snapshot snapshot))
 255   (with-slots (count owner) cell
 256     (setf (values count owner)
 257           (if (zerop snapshot)
 258               (values 0 nil)
 259               (values (ldb (byte 8 0) snapshot)
 260                       (ldb (byte 8 8) snapshot))))))
 261
 262 (defmethod player-cell-selected (game (player human-player) i j)
 263   (and (eql (player-state player) :ready)
 264        (play-cell game player i j)))
 265
 266 (defmethod snapshot ((player player))
 267   (list (player-score player) (player-state player)))
 268
 269 (defmethod restore ((player player) (list list))
 270   (destructuring-bind (score state) list
 271     (setf (player-score player) score
 272           (player-state player) state)))
 273
 274 (defmethod game-update-scores (game)
 275   (let ((players (game-players game))
 276         (grid (game-grid game)))
 277     (dotimes (i (length players))
 278       (setf (player-score (aref players i)) 0))
 279     (dotimes (i (array-total-size grid))
 280       (let* ((cell (row-major-aref grid i))
 281              (owner (cell-owner cell))
 282              (player (and owner (aref players owner)))
 283              (count (cell-count cell)))
 284         (when (and player (plusp count))
 285           (incf (player-score player) count))))
 286     (let ((remaining 0) (found nil))
 287       (dotimes (i (length players))
 288         (let* ((player (aref players i))
 289                (score (player-score player))
 290                (state (player-state player)))
 291           (cond ((and (zerop score) (eql state :playing))
 292                  (setf (player-state player) :losing))
 293                 ((member state '(:playing :starting :ready))
 294                  (incf remaining)
 295                  (setf found player)))))
 296       (changed game :scores :players players)
 297       (when (and (= remaining 1) (>= (length players) 2))
 298         (setf (player-state found) :winning)
 299         (changed game :finished :victor found)))))
 300
 301 (defmethod game-next-player (game)
 302   (let ((players (game-players game))
 303         (player-index (game-player-index game)))
 304     (dotimes (i (length players))
 305       (let* ((j (mod (+ player-index i 1) (length players)))
 306              (player (aref players j)))
 307         (when (member (player-state player) '(:starting :playing))
 308           (setf (game-player-index game) j
 309                 (player-state player) :ready)
 310           (player-turn-begin game player)
 311           (changed game :start-turn :player player)
 312           (return))))))
 313
 314 (defvar *cells-remaining* nil)
 315
 316 (defun perform-pending-explosions (game cells)
 317   (let ((affected (delete-duplicates
 318                    (mapcan #'cell-explode cells))))
 319     (mapc #'cell-apply-pending-updates affected)
 320     (perform-explosions game affected)))
 321
 322 (defvar *explosion-time* 100)
 323
 324 (defun perform-explosions (game cells)
 325   (game-update-scores game)
 326   (changed game :cell-update :cells cells)
 327   (let ((critical (delete-if-not #'cell-critical-p cells)))
 328     (setf *cells-remaining* critical)
 329     (cond ((null critical) (game-next-player game) t)
 330           (t (with-slots (timeout-id) game
 331                (setf timeout-id (glib:timeout-add
 332                                  *explosion-time*
 333                                  (lambda ()
 334                                    (setf timeout-id nil)
 335                                    (perform-pending-explosions game critical)
 336                                    nil))))))
 337     t))
 338
 339 (defun game-cancel-timeout (game)
 340   (with-slots (timeout-id) game
 341     (when timeout-id
 342       (glib:source-remove timeout-id)
 343       (setf timeout-id nil))))
 344
 345 (defmethod game-player ((game atom-game))
 346   (aref (game-players game) (game-player-index game)))
 347
 348 (defmethod game-cell-selected ((game atom-game) i j)
 349   (player-cell-selected game (game-player game) i j))
 350
 351 (defmethod initialize-instance :after ((game atom-game) &key)
 352   (setf (player-state (game-player game)) :ready))
 353
 354 (defmethod play-cell ((game atom-game) player i j)
 355   (with-slots (grid players player-index) game
 356     (assert (and (<= 0 i) (< i (array-dimension grid 1))
 357                  (<= 0 j) (< j (array-dimension grid 0))))
 358     (let ((cell (aref grid j i))
 359           (player (aref players player-index)))
 360       (block escape
 361         (with-undo-snapshot (game)
 362           (unless (cell-played cell player-index)
 363             (return-from escape))
 364           (setf (player-state player) :playing)
 365           (changed game :processing-move))
 366         (perform-explosions game (list cell))))))
 367
 368 (defmethod restart-game ((game atom-game) &key grid players)
 369   (game-cancel-timeout game)
 370   (setf (game-grid game)
 371         (or grid
 372             (let ((old (game-grid game)))
 373               (make-atoms-grid (array-dimension old 1)
 374                                (array-dimension old 0)))))
 375   (if players
 376       (setf (game-players game) players)
 377       (setf players (game-players game)))
 378   (reset-undo-state game)
 379   (dotimes (i (length players))
 380     (let ((player (aref players i)))
 381       (setf (player-score player) 0
 382             (player-state player) (if (zerop i) :ready :starting))))
 383   (setf (game-player-index game) 0)
 384   (changed game :refresh))
 385
 386 ;;;--------------------------------------------------------------------------
 387 ;;; Snapshots and undo.
 388
 389 (defclass atom-game-snapshot ()
 390   ((grid :type (array cell-snapshot (* *)) :initarg :grid)
 391    (players :type list :initarg :players)
 392    (player-index :type fixnum :initarg :player-index)))
 393
 394 (defmethod snapshot ((game atom-game))
 395     (let* ((grid (game-grid game))
 396            (grid-snapshot (make-array (array-dimensions grid)
 397                                       :element-type 'cell-snapshot
 398                                       :initial-element 0)))
 399       (dotimes (i (array-total-size grid))
 400         (setf (row-major-aref grid-snapshot i)
 401               (snapshot (row-major-aref grid i))))
 402       (make-instance 'atom-game-snapshot
 403                      :players (map 'list #'snapshot (game-players game))
 404                      :player-index (game-player-index game)
 405                      :grid grid-snapshot)))
 406
 407 (defmethod restore ((game atom-game) (snapshot atom-game-snapshot))
 408   (let ((snap-grid (slot-value snapshot 'grid))
 409         (snap-players (slot-value snapshot 'players))
 410         (grid (game-grid game))
 411         (players (game-players game)))
 412     (dotimes (i (array-total-size grid))
 413       (restore (row-major-aref grid i)
 414                (row-major-aref snap-grid i)))
 415     (loop for player across players
 416           for snap-player in snap-players
 417           do (restore player snap-player))
 418     (setf (game-player-index game) (slot-value snapshot 'player-index))
 419     (game-cancel-timeout game)
 420     (changed game :refresh)
 421     (let ((critical-cells (loop for i below (array-total-size grid)
 422                                 for cell = (row-major-aref grid i)
 423                                 if (cell-critical-p cell)
 424                                 collect cell)))
 425       (when critical-cells (perform-explosions game critical-cells)))))
 426
 427 ;;;--------------------------------------------------------------------------
 428 ;;; The interactive board.
 429
 430 (defclass atoms-board (gtk:drawing-area)
 431   ((game :accessor board-game :initarg :game :type atom-game)
 432    (cache :initform nil :accessor board-cache))
 433   (:metaclass glib:gobject-class))
 434
 435 (defmethod board-grid ((board atoms-board))
 436   (game-grid (board-game board)))
 437
 438 (defgeneric paint (widget event))
 439
 440 (defun paint-atoms (cr count colour)
 441   (let* ((centrep (and (oddp count) (/= count 3)))
 442          (surround (if centrep (1- count) count))
 443          (angle (and (plusp surround) (/ (* 2 pi) surround)))
 444          (theta (case count
 445                   ((0 1 2 3) (/ pi 2))
 446                   (t (/ (- pi angle) 2))))
 447          (radius 0.15)
 448          (sep (cond ((and centrep (<= surround 6)) (* 2 radius))
 449                     ((<= surround 2) radius)
 450                     (t (/ radius (sin (/ angle 2)))))))
 451     (when centrep
 452       (cairo:new-sub-path cr)
 453       (cairo:arc cr 0 0 radius 0 (* 2 pi)))
 454     (dotimes (i surround)
 455       (cairo:new-sub-path cr)
 456       (cairo:arc cr
 457                  (* sep (cos theta))
 458                  (- (* sep (sin theta)))
 459                  radius
 460                  0
 461                  (* 2 pi))
 462       (incf theta angle))
 463     (gdk:cairo-set-source-color cr (gdk:ensure-color colour))
 464     (cairo:fill cr t)
 465     (setf (cairo:line-width cr)
 466           (max 0.02 (cairo:device-to-user-distance cr 1)))
 467     (cairo:set-source-color cr 0 0 0)
 468     (cairo:stroke cr nil)))
 469
 470 (defparameter cache-limit 8)
 471
 472 (defun make-cached-atom-surfaces (board colour)
 473   (multiple-value-bind (width height) (gtk:widget-get-size-allocation board)
 474     (let* ((vector (make-array cache-limit))
 475            (grid (board-grid board))
 476            (surface-width (floor width (array-dimension grid 1)))
 477            (surface-height (floor height (array-dimension grid 0))))
 478       (dotimes (i (length vector))
 479         (let* ((surface (make-instance 'cairo:image-surface
 480                                        :width surface-width
 481                                        :height surface-height
 482                                        :format :argb32))
 483                (cr (make-instance 'cairo:context :target surface)))
 484           (cairo:scale cr surface-width surface-height)
 485           (cairo:translate cr 0.5 0.5)
 486           (paint-atoms cr (1+ i) colour)
 487           (setf (aref vector i) surface)))
 488       vector)))
 489
 490 (defun cached-atom-surface (board count colour)
 491   (let ((cache (board-cache board)))
 492     (unless cache
 493       (setf cache (make-hash-table)
 494             (board-cache board) cache))
 495     (let ((vector (gethash colour cache)))
 496       (unless vector
 497         (setf vector (make-cached-atom-surfaces board colour)
 498               (gethash colour cache) vector))
 499       (and (< 0 count) (<= count (length vector))
 500            (aref vector (1- count))))))
 501
 502 (defmethod paint ((widget atoms-board) event)
 503   (multiple-value-bind (width height) (gtk:widget-get-size-allocation widget)
 504     (let* ((style (gtk:widget-style widget))
 505            (grid (board-grid widget))
 506            (vsq (array-dimension grid 0))
 507            (hsq (array-dimension grid 1))
 508            (game (board-game widget))
 509            (players (game-players game))
 510            lo-hsq hi-hsq lo-vsq hi-vsq
 511            (display (gtk:widget-get-display widget))
 512            (region (make-instance 'gdk:region))
 513            (redraw-map (make-array (list vsq hsq)
 514                                    :element-type 'bit
 515                                    :initial-element 0)))
 516
 517       (loop (let* ((loh (floor (* (gdk:event-x event) hsq) width))
 518                    (hih (ceiling (* (+ (gdk:event-x event)
 519                                        (gdk:event-width event))
 520                                     hsq)
 521                                  width))
 522                    (lov (floor (* (gdk:event-y event) vsq) height))
 523                    (hiv (ceiling (* (+ (gdk:event-y event)
 524                                        (gdk:event-height event))
 525                                     vsq)
 526                                  height)))
 527               (gdk:region-union region
 528                                 (vector (gdk:event-x event)
 529                                         (gdk:event-y event)
 530                                         (gdk:event-width event)
 531                                         (gdk:event-height event)))
 532               (when (or (null lo-hsq) (< loh lo-hsq)) (setf lo-hsq loh))
 533               (when (or (null hi-hsq) (< hih hi-vsq)) (setf hi-hsq hih))
 534               (when (or (null lo-vsq) (< lov lo-hsq)) (setf lo-vsq lov))
 535               (when (or (null hi-vsq) (< hiv hi-vsq)) (setf hi-vsq hiv))
 536               (do ((j lov (1+ j))) ((>= j hiv))
 537                 (do ((i loh (1+ i))) ((>= i hih))
 538                   (setf (bit redraw-map j i) 1)))
 539               (when (zerop (gdk:event-count event))
 540                 (return))
 541               (setf event (gdk:display-get-event display))))
 542
 543       (gdk:with-cairo-context (cr (gtk:widget-window widget))
 544         (cairo:reset-clip cr)
 545         (gdk:cairo-region cr region)
 546         (cairo:clip cr)
 547         (cairo:with-context (cr)
 548           (gdk:cairo-set-source-color cr (gtk:style-fg style :normal))
 549           (cairo:translate cr 1/2 1/2)
 550           (setf (cairo:line-width cr) 1
 551                 (cairo:antialias cr) :none)
 552           (let ((h (1- height)) (w (1- width)))
 553             (do ((j lo-vsq (1+ j))) ((> j hi-vsq))
 554               (let ((y (round (* j h) vsq)))
 555                 (cairo:move-to cr 0 y)
 556                 (cairo:line-to cr w y)))
 557             (do ((i lo-hsq (1+ i))) ((> i hi-hsq))
 558               (let ((x (round (* i w) hsq)))
 559                 (cairo:move-to cr x 0)
 560                 (cairo:line-to cr x h))))
 561           (cairo:stroke cr))
 562         (do ((j lo-vsq (1+ j))) ((>= j hi-vsq))
 563           (do ((i lo-hsq (1+ i))) ((>= i hi-hsq))
 564             (when (plusp (bit redraw-map j i))
 565               (let* ((cell (aref grid j i))
 566                      (count (cell-count cell))
 567                      (colour (and (plusp count) (cell-owner cell)
 568                                   (player-colour
 569                                    (aref players
 570                                          (cell-owner cell)))))
 571                      (surface (and colour
 572                                    (cached-atom-surface widget
 573                                                         count colour))))
 574                 (cond ((or (zerop count) (null (cell-owner cell)))
 575                        nil)
 576                       ((null surface)
 577                        (cairo:with-context (cr)
 578                          (cairo:scale cr (/ width hsq) (/ height vsq))
 579                          (cairo:translate cr (+ i 0.5) (+ j 0.5))
 580                          (paint-atoms cr count colour)))
 581                       (t
 582                        (cairo:set-source-surface cr surface
 583                                                  (round (* i width) hsq)
 584                                                  (round (* j height) vsq))
 585                        (cairo:paint cr)))))))))))
 586
 587 (defun board-set-size-request (board)
 588   (when (slot-boundp board 'game)
 589     (let ((grid (board-grid board)))
 590       (gtk:widget-set-size-request board
 591                                    (* 50 (array-dimension grid 1))
 592                                    (* 50 (array-dimension grid 0))))))
 593
 594 (defmethod (setf board-game) :before (game (board atoms-board))
 595   (when (slot-boundp board 'game)
 596     (remove-dependent (board-game board) board)))
 597
 598 (defmethod (setf board-game) :after (game (board atoms-board))
 599   (board-set-size-request board)
 600   (add-dependent game board))
 601
 602 (defmethod resized ((board atoms-board) allocation)
 603   (setf (board-cache board) nil)
 604   nil)
 605
 606 (defmethod notify progn
 607     ((board atoms-board) (game atom-game) (aspect (eql :cell-update))
 608      &key cells)
 609   (unless (slot-boundp board 'gtk:window) (return-from notify))
 610   (multiple-value-bind (width height) (gtk:widget-get-size-allocation board)
 611     (let* ((region (make-instance 'gdk:region))
 612            (grid (board-grid board))
 613            (hsq (array-dimension grid 1))
 614            (vsq (array-dimension grid 0)))
 615       (dolist (cell cells)
 616         (gdk:region-union region
 617                           (vector (floor (* (cell-x cell) width) hsq)
 618                                   (floor (* (cell-y cell) height) vsq)
 619                                   (ceiling width hsq)
 620                                   (ceiling height vsq))))
 621       (gdk:window-invalidate-region (gtk:widget-window board) region nil))))
 622
 623 (defmethod notify progn
 624     ((board atoms-board) (game atom-game) (aspect (eql :refresh)) &key)
 625   (board-set-size-request board)
 626   (setf (board-cache board) nil)
 627   (gtk:widget-queue-draw board))
 628
 629 (defmethod button-press ((widget atoms-board) event)
 630   (case (gdk:event-class-type (class-of event))
 631     (:button-press
 632      (case (gdk:event-button event)
 633        (1 (multiple-value-bind (width height)
 634               (gtk:widget-get-size-allocation widget)
 635             (let* ((grid (board-grid widget))
 636                    (x (floor (* (gdk:event-x event) (array-dimension grid 1))
 637                              width))
 638                    (y (floor (* (gdk:event-y event) (array-dimension grid 0))
 639                              height)))
 640               (game-cell-selected (board-game widget) x y)
 641               t)))))))
 642
 643 (defmethod initialize-instance :after ((board atoms-board) &key)
 644   (gtk:signal-connect board :expose-event #'paint :object t)
 645   (setf (gtk:widget-events board) (list :button-press))
 646   (gtk:signal-connect board :button-press-event #'button-press :object t)
 647   (gtk:signal-connect board :size-allocate #'resized :object t)
 648   (when (slot-boundp board 'game) (add-dependent (board-game board) board))
 649   (board-set-size-request board))
 650
 651 ;;;--------------------------------------------------------------------------
 652 ;;; Tree view utilities.
 653
 654 (defun add-tree-view-column (view title &rest args)
 655   (let ((column (apply #'make-instance
 656                        'gtk:tree-view-column
 657                        :title title
 658                        args)))
 659     (gtk:tree-view-append-column view column)
 660     column))
 661
 662 (defun add-cell-renderer
 663     (view column attrs
 664      &key (type 'gtk:cell-renderer-text) pack-args renderer-args)
 665   (let ((renderer (apply #'make-instance type renderer-args))
 666         (store (gtk:tree-view-model view)))
 667     (apply #'gtk:cell-layout-pack column renderer pack-args)
 668     (loop for (attribute col-name) on attrs by #'cddr
 669           do (gtk:cell-layout-add-attribute
 670               column renderer attribute
 671               (gtk:tree-model-column-index store col-name)))
 672     renderer))
 673
 674 ;;;--------------------------------------------------------------------------
 675 ;;; The player list.
 676
 677 (defvar *player-list*)
 678 (defvar *player-list-view*)
 679
 680 (defclass player-list (gtk:tree-view)
 681   ((store :initform (make-instance
 682                      'gtk:list-store
 683                      :column-names '(colour name score state)
 684                      :column-types '(gdk:color string integer string))
 685           :type gtk:list-store)
 686    (game :initarg :game :type atom-game))
 687   (:metaclass glib:gobject-class))
 688
 689 (defun update-player-list (list game)
 690   (let ((store (slot-value list 'store))
 691         (players (game-players game)))
 692     (gtk:list-store-clear store)
 693     (loop for player across players
 694           for i from 0
 695           do (gtk:list-store-append store
 696                                     (vector (player-colour player)
 697                                             (player-name player)
 698                                             (player-score player)
 699                                             (case (player-state player)
 700                                               (:losing "out")
 701                                               (:winning "winner!")
 702                                               (:ready "<<<")
 703                                               (t "")))))))
 704
 705 (defmethod initialize-instance :after ((list player-list) &key)
 706   (let ((store (slot-value list 'store)))
 707     (setf (gtk:tree-view-model list) store)
 708     (flet ((add-column (&rest args)
 709              (apply #'add-tree-view-column list args))
 710            (add-renderer (&rest args)
 711              (apply #'add-cell-renderer list args)))
 712       (add-renderer (add-column ""
 713                                 :expand nil
 714                                 :sizing :fixed
 715                                 :fixed-width 20)
 716                     '(:cell-background-gdk colour)
 717                     :renderer-args '(:cell-background-set t))
 718       (add-renderer (add-column "Name" :resizable t :expand t) '(:text name))
 719       (add-renderer (add-column "Score" :resizable t) '(:text score))
 720       (add-renderer (add-column "State" :resizable t) '(:text state)))
 721     (setf (gtk:tree-selection-mode (gtk:tree-view-selection list)) :none)
 722     (when (slot-boundp list 'game)
 723       (with-slots (game) list
 724         (add-dependent game list)
 725       (update-player-list list game)))))
 726
 727 (defmethod notify progn ((list player-list) (game atom-game) aspect &key)
 728   (case aspect
 729     ((:cell-update :start-turn :refresh)
 730      (update-player-list list game))))
 731
 732 ;;;--------------------------------------------------------------------------
 733 ;;; New game dialogue.
 734
 735 (defparameter *player-colours*
 736   (vector "red" "blue" "green" "orange" "magenta" "white" "black"))
 737
 738 (defclass new-game-dialogue (gtk:dialog)
 739   ((game :initarg :game :type atom-game)
 740    (width-adjustment :type gtk:adjustment
 741                      :initform (make-instance 'gtk:adjustment
 742                                               :lower 1 :upper 99
 743                                               :step-increment 1))
 744    (height-adjustment :type gtk:adjustment
 745                       :initform (make-instance 'gtk:adjustment
 746                                                :lower 1 :upper 99
 747                                                :step-increment 1))
 748    (count-adjustment :type gtk:adjustment
 749                      :initform (make-instance 'gtk:adjustment
 750                                               :lower 1 :upper 20
 751                                               :step-increment 1))
 752    (players :type gtk:list-store
 753             :initform (make-instance 'gtk:list-store
 754                                      :column-types '(gdk:color string)
 755                                      :column-names '(colour name))))
 756   (:default-initargs
 757       :title "New game"
 758       :default-height 360
 759       :has-separator nil)
 760   (:metaclass glib:gobject-class))
 761
 762 (defun choose-player-colour (window path)
 763   (let* ((players (slot-value window 'players))
 764          (colour-dialogue (make-instance 'gtk:color-selection-dialog))
 765          (coloursel (gtk:color-selection-dialog-colorsel colour-dialogue))
 766          (colour (gtk:tree-model-value players path 'colour)))
 767     (unwind-protect
 768          (progn
 769            (setf (gtk:color-selection-current-color coloursel) colour
 770                  (gtk:color-selection-previous-color coloursel) colour)
 771            (case (gtk:dialog-run colour-dialogue)
 772              (:ok (setf (gtk:tree-model-value players path 'colour)
 773                         (gtk:color-selection-current-color coloursel)))))
 774       (gtk:widget-destroy colour-dialogue))))
 775
 776 (defun insert-or-remove-players (window)
 777   (let* ((players (slot-value window 'players))
 778          (current-count (gtk:tree-model-iter-n-children players))
 779          (new-count (floor (gtk:adjustment-value
 780                             (slot-value window 'count-adjustment)))))
 781     (if (> current-count new-count)
 782         (let ((iter (make-instance 'gtk:tree-iter)))
 783           (gtk:tree-model-get-iter players (vector new-count) iter)
 784           (dotimes (i (- current-count new-count))
 785             (gtk:list-store-remove players iter)))
 786         (loop with iter = (make-instance 'gtk:tree-iter)
 787               for i from current-count below new-count
 788               for colour = (if (< i (length *player-colours*))
 789                                (gdk:color-parse (aref *player-colours* i))
 790                                (make-instance 'gdk:color
 791                                               :red (random 1.0)
 792                                               :green (random 1.0)
 793                                               :blue (random 1.0)))
 794               for name = (format nil "Player ~A" (1+ i))
 795               do (gtk:list-store-append players
 796                                         (vector colour name)
 797                                         iter)))))
 798
 799 (defun start-new-game (window)
 800   (with-slots (game width-adjustment height-adjustment players) window
 801     (let ((grid (make-atoms-grid
 802                  (floor (gtk:adjustment-value width-adjustment))
 803                  (floor (gtk:adjustment-value height-adjustment))))
 804           (new-players (let ((iter (make-instance 'gtk:tree-iter)))
 805                          (gtk:tree-model-get-iter players #(0) iter)
 806                          (loop for row = (gtk:tree-model-row-data players
 807                                                                   iter)
 808                                collect (make-instance 'human-player
 809                                                       :colour (aref row 0)
 810                                                       :name (aref row 1))
 811                                while (gtk:tree-model-iter-next players
 812                                                                iter)))))
 813       (restart-game game :grid grid :players (coerce new-players 'vector))
 814       (gtk:widget-destroy window))))
 815
 816 (defmethod initialize-instance :after ((window new-game-dialogue) &key)
 817   (with-slots (width-adjustment height-adjustment count-adjustment players)
 818       window
 819     (let* ((game (slot-value window 'game))
 820            (grid (game-grid game)))
 821
 822       (setf (gtk:container-border-width window) 4)
 823       (gtk:dialog-add-button window "gtk-cancel"
 824                              #'gtk:widget-destroy :object t)
 825       (gtk:dialog-add-button window "gtk-ok"
 826                              (lambda () (start-new-game window))
 827                              :default t)
 828
 829       (setf (gtk:adjustment-value width-adjustment)
 830             (array-dimension grid 1)
 831             (gtk:adjustment-value height-adjustment)
 832             (array-dimension grid 0)
 833             (gtk:adjustment-value count-adjustment)
 834             (length (game-players game)))
 835
 836       (let* ((frame (make-instance 'gtk:frame :label "Board size"))
 837              (table (make-instance 'gtk:table
 838                                    :parent frame
 839                                    :border-width 4
 840                                    :n-columns 2 :n-rows 2
 841                                    :row-spacing 4 :column-spacing 4)))
 842         (loop for row from 0
 843               for (adj-slot label) on '(width-adjustment "Width"
 844                                         height-adjustment "Height") by #'cddr
 845               do (make-instance 'gtk:label
 846                                 :label label
 847                                 :xalign 1
 848                                 :parent (list table
 849                                               :top-attach row
 850                                               :bottom-attach (1+ row)
 851                                               :left-attach 0
 852                                               :right-attach 1
 853                                               :x-options '(:fill)))
 854               do (make-instance 'gtk:spin-button
 855                                 :numeric t
 856                                 :width-chars 2
 857                                 :adjustment (slot-value window adj-slot)
 858                                 :xalign 1
 859                                 :activates-default t
 860                                 :parent (list table
 861                                               :top-attach row
 862                                               :bottom-attach (1+ row)
 863                                               :left-attach 1
 864                                               :right-attach 2
 865                                               :x-options '(:expand :fill))))
 866         (gtk:container-add window frame :fill nil :expand nil)
 867         (gtk:widget-show-all frame))
 868
 869       (let* ((frame (make-instance 'gtk:frame :label "Players"))
 870              (vbox (make-instance 'gtk:v-box
 871                                   :parent frame :spacing 4
 872                                   :border-width 4))
 873              (view (make-instance 'gtk:tree-view
 874                                   :model players)))
 875         (make-instance 'gtk:h-box
 876                        :spacing 4
 877                        :parent (list vbox :expand nil :fill nil)
 878                        :child (list (make-instance 'gtk:label
 879                                                    :label "Number of players"
 880                                                    :xalign 1)
 881                                     :expand nil :fill nil)
 882                        :child (list (make-instance 'gtk:spin-button
 883                                                    :adjustment
 884                                                    count-adjustment
 885                                                    :numeric t
 886                                                    :width-chars 2
 887                                                    :activates-default t
 888                                                    :xalign 1)
 889                                     :expand t :fill t))
 890         (make-instance 'gtk:scrolled-window
 891                        :hscrollbar-policy :automatic
 892                        :vscrollbar-policy :automatic
 893                        :shadow-type :in
 894                        :child view
 895                        :parent vbox)
 896         (add-cell-renderer view
 897                            (add-tree-view-column view ""
 898                                                  :sizing :fixed
 899                                                  :fixed-width 20)
 900                            (list :cell-background-gdk 'colour)
 901                            :renderer-args '(:cell-background-set t))
 902         (let ((renderer (add-cell-renderer view
 903                                            (add-tree-view-column view "Name")
 904                                            (list :text 'name)
 905                                            :renderer-args '(:editable t))))
 906           (gtk:signal-connect renderer :edited
 907                               (lambda (path new-text)
 908                                 (setf (gtk:tree-model-value
 909                                        players
 910                                        path
 911                                        'name)
 912                                       new-text))))
 913         (gtk:signal-connect view :row-activated
 914                             (lambda (path column)
 915                               (when (eql (position column
 916                                                    (gtk:tree-view-columns
 917                                                     view))
 918                                          0)
 919                                 (choose-player-colour window path))))
 920         (loop for player across (game-players game)
 921               do (gtk:list-store-append players
 922                                         (vector (player-colour player)
 923                                                 (player-name player))))
 924         (gtk:signal-connect count-adjustment
 925                             :value-changed
 926                             #'insert-or-remove-players :args (list window))
 927         (gtk:container-add window frame :fill t :expand t)
 928         (gtk:widget-show-all frame)))))
 929
 930 ;;;--------------------------------------------------------------------------
 931 ;;; About this program.
 932
 933 (defparameter atoms-logo-pixbuf
 934   (gdk:pixbuf-load #p"/home/mdw/src/atoms/atoms.png"))
 935
 936 (defparameter licence-text
 937   (format nil
 938    "This program is free software; you can redistribute it and/or modify ~
 939     it under the terms of the GNU General Public License as published by ~
 940     the Free Software Foundation; either version 2 of the License, or ~
 941     (at your option) any later version.~2%~
 942     ~
 943     This program is distributed in the hope that it will be useful, ~
 944     but WITHOUT ANY WARRANTY; without even the implied warranty of ~
 945     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the ~
 946     GNU General Public License for more details.~2%~
 947     ~
 948     You should have received a copy of the GNU General Public License ~
 949     along with this program; if not, write to the Free Software Foundation, ~
 950     Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA."))
 951
 952 (let ((about nil))
 953   (defun action-about (window)
 954     (declare (ignore window))
 955     (unless about
 956       (setf about (make-instance
 957                    'gtk:about-dialog
 958                    :name "Atoms"
 959                    :version "1.0.0"
 960                    :copyright "Copyright (c) 2007 Mark Wooding"
 961                    :website "http://www.distorted.org.uk/"
 962                    :website-label "Homepage"
 963                    :authors (list "Mark Wooding <mdw@distorted.org.uk>")
 964                    :comments "May contain trace quantities of Lisp."
 965                    :license licence-text
 966                    :wrap-license t
 967                    :logo atoms-logo-pixbuf
 968                    :signal (list :destroy (lambda () (setf about nil)))
 969                    :signal (list :cancel (lambda ()
 970                                            (gtk:widget-destroy about))))))
 971     (gtk:window-present about)))
 972
 973 ;;;--------------------------------------------------------------------------
 974 ;;; Application window.
 975
 976 (defclass atom-game-window (gtk:window)
 977   ((game :type atom-game)
 978    (board :type atoms-board)
 979    (player-list :type player-list)
 980    (actions :type gtk:action-group)
 981    (ui :type gtk:ui-manager)
 982    (new-game :type (or new-game-dialogue null) :initform nil))
 983   (:default-initargs :title "Atoms game" :allow-shrink t :show-children t)
 984   (:metaclass glib:gobject-class))
 985
 986 (defun action-quit (window)
 987   (gtk:widget-destroy window))
 988
 989 (defun action-new-game (window)
 990   (with-slots (new-game game) window
 991     (if new-game
 992         (gtk:window-present new-game)
 993         (progn
 994           (setf new-game (make-instance 'new-game-dialogue
 995                                         :game game
 996                                         :transient-for window))
 997           (gtk:widget-show-all new-game)
 998           (gtk:signal-connect new-game :destroy
 999                               (lambda () (setf new-game nil)))))))
1000
1001 (defun update-undo-redo-sensitivity (window)
1002   (with-slots (actions game) window
1003     (setf (gtk:action-sensitive-p
1004            (gtk:action-group-get-action actions "undo"))
1005           (undo-list game)
1006           (gtk:action-sensitive-p
1007            (gtk:action-group-get-action actions "redo"))
1008           (redo-list game))))
1009
1010 (defmethod notify progn
1011     ((window atom-game-window) (game atom-game) aspect &key)
1012   (case aspect
1013     ((:undo :redo :refresh :start-turn)
1014      (update-undo-redo-sensitivity window))))
1015
1016 (defun action-undo (window)
1017   (undo (slot-value window 'game)))
1018
1019 (defun action-redo (window)
1020   (redo (slot-value window 'game)))
1021
1022 (defmethod destroyed ((window atom-game-window))
1023   (with-slots (new-game) window
1024     (when new-game (gtk:widget-destroy new-game))))
1025
1026 (defun build-player-vector (player-spec)
1027   (flet ((make-player (spec i)
1028                (etypecase spec
1029                  (player spec)
1030                  ((or string list)
1031                   (destructuring-bind
1032                       (name &key colour)
1033                       (if (listp spec) spec (list spec))
1034                     (cond (colour)
1035                           ((< i (length *player-colours*))
1036                            (setf colour (aref *player-colours* i)))
1037                           (t (setf colour
1038                                    (make-instance 'gdk:color
1039                                                   :red (random 1.0)
1040                                                   :green (random 1.0)
1041                                                   :blue (random 1.0)))))
1042                     (make-instance 'human-player
1043                                    :name name
1044                                    :colour (gdk:ensure-color colour)))))))
1045     (let ((i 0))
1046       (map 'vector
1047            (lambda (spec)
1048              (make-player spec (prog1 i (incf i))))
1049            (etypecase player-spec
1050              (sequence player-spec)
1051              ((or integer null)
1052               (loop for i from 1 upto (or player-spec 4)
1053                     collect (format nil "Player ~A" i))))))))
1054
1055 (defmethod shared-initialize :after
1056     ((window atom-game-window) slot-names
1057      &key
1058      (width 7) (height width) players)
1059   (declare (ignore slot-names))
1060   (let* ((vbox (make-instance 'gtk:v-box :parent window))
1061          (paned (make-instance 'gtk:h-paned
1062                                :parent (list vbox :pack-type :end)))
1063          (aspect (make-instance 'gtk:aspect-frame
1064                                 :parent (list paned :resize t :shrink t)
1065                                 :obey-child t
1066                                 :frame :none
1067                                 :shadow-type :none))
1068          (scrolled (make-instance 'gtk:scrolled-window
1069                                   :parent (list paned :resize nil :shrink t)
1070                                   :shadow-type :in
1071                                   :hscrollbar-policy :automatic
1072                                   :vscrollbar-policy :automatic))
1073          (action-list (mapcar (lambda (item)
1074                                 (destructuring-bind
1075                                     (name callback &rest args) item
1076                                   (apply #'make-instance 'gtk:action
1077                                          :name name
1078                                          :callback
1079                                          (and callback
1080                                               (list callback
1081                                                     :args (list window)))
1082                                          args)))
1083                               `(("file" nil :label "_File")
1084                                 ("edit" nil :label "_Edit")
1085                                 ("help" nil :label "_Help")
1086                                 ("quit" ,#'action-quit
1087                                  :stock-id "gtk-close"
1088                                  :tooltip "Close this window."
1089                                  :accelerator "<control>W")
1090                                 ("undo" ,#'action-undo
1091                                  :stock-id "gtk-undo"
1092                                  :tooltip "Take back the most recent move."
1093                                  :sensitive nil
1094                                  :accelerator "<Control>Z")
1095                                 ("redo" ,#'action-redo
1096                                  :stock-id "gtk-redo"
1097                                  :sensitive nil
1098                                  :tooltip "Revert an undone move."
1099                                  :accelerator "<Shift><Control>Z")
1100                                 ("about" ,#'action-about
1101                                  :tooltip "Show information about this game."
1102                                  :stock-id "gtk-about")
1103                                 ("new-game" ,#'action-new-game
1104                                  :label "_New game..."
1105                                  :stock-id "gtk-new"
1106                                  :tooltip "Start a new game."
1107                                  :accelerator "<control>N")))))
1108
1109     (with-slots (game board player-list ui actions) window
1110       (setf actions (make-instance 'gtk:action-group
1111                                    :name "actions"
1112                                    :actions action-list)
1113             ui (make-instance 'gtk:ui-manager
1114                               :add-tearoffs t
1115                               :action-group actions
1116                               :ui '((:menubar "menu-bar"
1117                                      (:menu "file"
1118                                       (:menuitem "new-game")
1119                                       (:menuitem "quit"))
1120                                      (:menu "edit"
1121                                       (:menuitem "undo")
1122                                       (:menuitem "redo"))
1123                                      (:menu "help"
1124                                       (:menuitem "about")))
1125                                     (:toolbar "toolbar"
1126                                      (:toolitem "new-game")
1127                                      :separator
1128                                      (:toolitem "undo")
1129                                      (:toolitem "redo")))))
1130       (gtk:window-add-accel-group window (gtk:ui-manager-accel-group ui))
1131       (setf (gtk:toolbar-show-arrow-p
1132              (gtk:ui-manager-get-widget ui "/toolbar")) nil)
1133       (dolist (name '("/menu-bar" "/toolbar"))
1134         (make-instance 'gtk:handle-box
1135                        :child (gtk:ui-manager-get-widget ui name)
1136                        :parent (list vbox :expand nil)))
1137       (gtk:signal-connect window :destroy #'destroyed :object t)
1138       (setf game (make-instance 'atom-game
1139                                 :grid (make-atoms-grid width height)
1140                                 :players (build-player-vector players))
1141             board (make-instance 'atoms-board :game game :parent aspect)
1142             player-list (make-instance 'player-list
1143                                        :game game
1144                                        :width-request 160
1145                                        :parent scrolled))
1146
1147       (add-dependent game window))))
1148
1149 ;;;--------------------------------------------------------------------------
1150 ;;; Useful things.
1151
1152 (defvar *window* nil)
1153
1154 (defun start-atom-game (&rest initargs)
1155   (when *window*
1156     (gtk:widget-destroy *window*)
1157     (setf *window* nil))
1158   (setf *window* (apply #'make-instance 'atom-game-window initargs))
1159   (gtk:widget-show-all *window*))
1160
1161 (start-atom-game :width 7 :players (list "Mark" "Vicky"))
1162
1163 ;;;----- That's all, folks --------------------------------------------------