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