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 (= remaining 1)
 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           (perform-explosions game (list cell)))
 366         (changed game :processing-move)))))
 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     (changed game :refresh)))
 420
 421 ;;;--------------------------------------------------------------------------
 422 ;;; The interactive board.
 423
 424 (defclass atoms-board (gtk:drawing-area)
 425   ((game :accessor board-game :initarg :game :type atom-game)
 426    (cache :initform nil :accessor board-cache))
 427   (:metaclass glib:gobject-class))
 428
 429 (defmethod board-grid ((board atoms-board))
 430   (game-grid (board-game board)))
 431
 432 (defgeneric paint (widget event))
 433
 434 (defun paint-atoms (cr count colour)
 435   (let* ((centrep (and (oddp count) (/= count 3)))
 436          (surround (if centrep (1- count) count))
 437          (angle (and (plusp surround) (/ (* 2 pi) surround)))
 438          (theta (case count
 439                   ((0 1 2 3) (/ pi 2))
 440                   (t (/ (- pi angle) 2))))
 441          (radius 0.15)
 442          (sep (cond ((and centrep (<= surround 6)) (* 2 radius))
 443                     ((<= surround 2) radius)
 444                     (t (/ radius (sin (/ angle 2)))))))
 445     (when centrep
 446       (cairo:new-sub-path cr)
 447       (cairo:arc cr 0 0 radius 0 (* 2 pi)))
 448     (dotimes (i surround)
 449       (cairo:new-sub-path cr)
 450       (cairo:arc cr
 451                  (* sep (cos theta))
 452                  (- (* sep (sin theta)))
 453                  radius
 454                  0
 455                  (* 2 pi))
 456       (incf theta angle))
 457     (gdk:cairo-set-source-color cr (gdk:ensure-color colour))
 458     (cairo:fill cr t)
 459     (setf (cairo:line-width cr)
 460           (max 0.02 (cairo:device-to-user-distance cr 1)))
 461     (cairo:set-source-color cr 0 0 0)
 462     (cairo:stroke cr nil)))
 463
 464 (defparameter cache-limit 8)
 465
 466 (defun make-cached-atom-surfaces (board colour)
 467   (multiple-value-bind (width height) (gtk:widget-get-size-allocation board)
 468     (let* ((vector (make-array cache-limit))
 469            (grid (board-grid board))
 470            (surface-width (floor width (array-dimension grid 1)))
 471            (surface-height (floor height (array-dimension grid 0))))
 472       (dotimes (i (length vector))
 473         (let* ((surface (make-instance 'cairo:image-surface
 474                                        :width surface-width
 475                                        :height surface-height
 476                                        :format :argb32))
 477                (cr (make-instance 'cairo:context :target surface)))
 478           (cairo:scale cr surface-width surface-height)
 479           (cairo:translate cr 0.5 0.5)
 480           (paint-atoms cr (1+ i) colour)
 481           (setf (aref vector i) surface)))
 482       vector)))
 483
 484 (defun cached-atom-surface (board count colour)
 485   (let ((cache (board-cache board)))
 486     (unless cache
 487       (setf cache (make-hash-table)
 488             (board-cache board) cache))
 489     (let ((vector (gethash colour cache)))
 490       (unless vector
 491         (setf vector (make-cached-atom-surfaces board colour)
 492               (gethash colour cache) vector))
 493       (and (< 0 count) (<= count (length vector))
 494            (aref vector (1- count))))))
 495
 496 (defmethod paint ((widget atoms-board) event)
 497   (multiple-value-bind (width height) (gtk:widget-get-size-allocation widget)
 498     (let* ((style (gtk:widget-style widget))
 499            (grid (board-grid widget))
 500            (vsq (array-dimension grid 0))
 501            (hsq (array-dimension grid 1))
 502            (game (board-game widget))
 503            (players (game-players game))
 504            lo-hsq hi-hsq lo-vsq hi-vsq
 505            (display (gtk:widget-get-display widget))
 506            (region (make-instance 'gdk:region))
 507            (redraw-map (make-array (list vsq hsq)
 508                                    :element-type 'bit
 509                                    :initial-element 0)))
 510
 511       (loop (let* ((loh (floor (* (gdk:event-x event) hsq) width))
 512                    (hih (ceiling (* (+ (gdk:event-x event)
 513                                        (gdk:event-width event))
 514                                     hsq)
 515                                  width))
 516                    (lov (floor (* (gdk:event-y event) vsq) height))
 517                    (hiv (ceiling (* (+ (gdk:event-y event)
 518                                        (gdk:event-height event))
 519                                     vsq)
 520                                  height)))
 521               (gdk:region-union region
 522                                 (vector (gdk:event-x event)
 523                                         (gdk:event-y event)
 524                                         (gdk:event-width event)
 525                                         (gdk:event-height event)))
 526               (when (or (null lo-hsq) (< loh lo-hsq)) (setf lo-hsq loh))
 527               (when (or (null hi-hsq) (< hih hi-vsq)) (setf hi-hsq hih))
 528               (when (or (null lo-vsq) (< lov lo-hsq)) (setf lo-vsq lov))
 529               (when (or (null hi-vsq) (< hiv hi-vsq)) (setf hi-vsq hiv))
 530               (do ((j lov (1+ j))) ((>= j hiv))
 531                 (do ((i loh (1+ i))) ((>= i hih))
 532                   (setf (bit redraw-map j i) 1)))
 533               (when (zerop (gdk:event-count event))
 534                 (return))
 535               (setf event (gdk:display-get-event display))))
 536
 537       (gdk:with-cairo-context (cr (gtk:widget-window widget))
 538         (cairo:reset-clip cr)
 539         (gdk:cairo-region cr region)
 540         (cairo:clip cr)
 541         (cairo:with-context (cr)
 542           (gdk:cairo-set-source-color cr (gtk:style-fg style :normal))
 543           (cairo:translate cr 1/2 1/2)
 544           (setf (cairo:line-width cr) 1
 545                 (cairo:antialias cr) :none)
 546           (let ((h (1- height)) (w (1- width)))
 547             (do ((j lo-vsq (1+ j))) ((> j hi-vsq))
 548               (let ((y (round (* j h) vsq)))
 549                 (cairo:move-to cr 0 y)
 550                 (cairo:line-to cr w y)))
 551             (do ((i lo-hsq (1+ i))) ((> i hi-hsq))
 552               (let ((x (round (* i w) hsq)))
 553                 (cairo:move-to cr x 0)
 554                 (cairo:line-to cr x h))))
 555           (cairo:stroke cr))
 556         (do ((j lo-vsq (1+ j))) ((>= j hi-vsq))
 557           (do ((i lo-hsq (1+ i))) ((>= i hi-hsq))
 558             (when (plusp (bit redraw-map j i))
 559               (let* ((cell (aref grid j i))
 560                      (count (cell-count cell))
 561                      (colour (and (plusp count) (cell-owner cell)
 562                                   (player-colour
 563                                    (aref players
 564                                          (cell-owner cell)))))
 565                      (surface (and colour
 566                                    (cached-atom-surface widget
 567                                                         count colour))))
 568                 (cond ((or (zerop count) (null (cell-owner cell)))
 569                        nil)
 570                       ((null surface)
 571                        (cairo:with-context (cr)
 572                          (cairo:scale cr (/ width hsq) (/ height vsq))
 573                          (cairo:translate cr (+ i 0.5) (+ j 0.5))
 574                          (paint-atoms cr count colour)))
 575                       (t
 576                        (cairo:set-source-surface cr surface
 577                                                  (round (* i width) hsq)
 578                                                  (round (* j height) vsq))
 579                        (cairo:paint cr)))))))))))
 580
 581 (defun board-set-size-request (board)
 582   (when (slot-boundp board 'game)
 583     (let ((grid (board-grid board)))
 584       (gtk:widget-set-size-request board
 585                                    (* 50 (array-dimension grid 1))
 586                                    (* 50 (array-dimension grid 0))))))
 587
 588 (defmethod (setf board-game) :before (game (board atoms-board))
 589   (when (slot-boundp board 'game)
 590     (remove-dependent (board-game board) board)))
 591
 592 (defmethod (setf board-game) :after (game (board atoms-board))
 593   (board-set-size-request board)
 594   (add-dependent game board))
 595
 596 (defmethod resized ((board atoms-board) allocation)
 597   (setf (board-cache board) nil)
 598   nil)
 599
 600 (defmethod notify progn
 601     ((board atoms-board) (game atom-game) (aspect (eql :cell-update))
 602      &key cells)
 603   (unless (slot-boundp board 'gtk:window) (return-from notify))
 604   (multiple-value-bind (width height) (gtk:widget-get-size-allocation board)
 605     (let* ((region (make-instance 'gdk:region))
 606            (grid (board-grid board))
 607            (hsq (array-dimension grid 1))
 608            (vsq (array-dimension grid 0)))
 609       (dolist (cell cells)
 610         (gdk:region-union region
 611                           (vector (floor (* (cell-x cell) width) hsq)
 612                                   (floor (* (cell-y cell) height) vsq)
 613                                   (ceiling width hsq)
 614                                   (ceiling height vsq))))
 615       (gdk:window-invalidate-region (gtk:widget-window board) region nil))))
 616
 617 (defmethod notify progn
 618     ((board atoms-board) (game atom-game) (aspect (eql :refresh)) &key)
 619   (board-set-size-request board)
 620   (setf (board-cache board) nil)
 621   (gtk:widget-queue-draw board))
 622
 623 (defmethod button-press ((widget atoms-board) event)
 624   (case (gdk:event-class-type (class-of event))
 625     (:button-press
 626      (case (gdk:event-button event)
 627        (1 (multiple-value-bind (width height)
 628               (gtk:widget-get-size-allocation widget)
 629             (let* ((grid (board-grid widget))
 630                    (x (floor (* (gdk:event-x event) (array-dimension grid 1))
 631                              width))
 632                    (y (floor (* (gdk:event-y event) (array-dimension grid 0))
 633                              height)))
 634               (game-cell-selected (board-game widget) x y)
 635               t)))))))
 636
 637 (defmethod initialize-instance :after ((board atoms-board) &key)
 638   (gtk:signal-connect board :expose-event #'paint :object t)
 639   (setf (gtk:widget-events board) (list :button-press))
 640   (gtk:signal-connect board :button-press-event #'button-press :object t)
 641   (gtk:signal-connect board :size-allocate #'resized :object t)
 642   (when (slot-boundp board 'game) (add-dependent (board-game board) board))
 643   (board-set-size-request board))
 644
 645 ;;;--------------------------------------------------------------------------
 646 ;;; Tree view utilities.
 647
 648 (defun add-tree-view-column (view title &rest args)
 649   (let ((column (apply #'make-instance
 650                        'gtk:tree-view-column
 651                        :title title
 652                        args)))
 653     (gtk:tree-view-append-column view column)
 654     column))
 655
 656 (defun add-cell-renderer
 657     (view column attrs
 658      &key (type 'gtk:cell-renderer-text) pack-args renderer-args)
 659   (let ((renderer (apply #'make-instance type renderer-args))
 660         (store (gtk:tree-view-model view)))
 661     (apply #'gtk:cell-layout-pack column renderer pack-args)
 662     (loop for (attribute col-name) on attrs by #'cddr
 663           do (gtk:cell-layout-add-attribute
 664               column renderer attribute
 665               (gtk:tree-model-column-index store col-name)))
 666     renderer))
 667
 668 ;;;--------------------------------------------------------------------------
 669 ;;; The player list.
 670
 671 (defvar *player-list*)
 672 (defvar *player-list-view*)
 673
 674 (defclass player-list (gtk:tree-view)
 675   ((store :initform (make-instance
 676                      'gtk:list-store
 677                      :column-names '(colour name score state)
 678                      :column-types '(gdk:color string integer string))
 679           :type gtk:list-store)
 680    (game :initarg :game :type atom-game))
 681   (:metaclass glib:gobject-class))
 682
 683 (defun update-player-list (list game)
 684   (let ((store (slot-value list 'store))
 685         (players (game-players game)))
 686     (gtk:list-store-clear store)
 687     (loop for player across players
 688           for i from 0
 689           do (gtk:list-store-append store
 690                                     (vector (player-colour player)
 691                                             (player-name player)
 692                                             (player-score player)
 693                                             (case (player-state player)
 694                                               (:losing "out")
 695                                               (:winning "winner!")
 696                                               (:ready "<<<")
 697                                               (t "")))))))
 698
 699 (defmethod initialize-instance :after ((list player-list) &key)
 700   (let ((store (slot-value list 'store)))
 701     (setf (gtk:tree-view-model list) store)
 702     (flet ((add-column (&rest args)
 703              (apply #'add-tree-view-column list args))
 704            (add-renderer (&rest args)
 705              (apply #'add-cell-renderer list args)))
 706       (add-renderer (add-column ""
 707                                 :expand nil
 708                                 :sizing :fixed
 709                                 :fixed-width 20)
 710                     '(:cell-background-gdk colour)
 711                     :renderer-args '(:cell-background-set t))
 712       (add-renderer (add-column "Name" :resizable t :expand t) '(:text name))
 713       (add-renderer (add-column "Score" :resizable t) '(:text score))
 714       (add-renderer (add-column "State" :resizable t) '(:text state)))
 715     (setf (gtk:tree-selection-mode (gtk:tree-view-selection list)) :none)
 716     (when (slot-boundp list 'game)
 717       (with-slots (game) list
 718         (add-dependent game list)
 719       (update-player-list list game)))))
 720
 721 (defmethod notify progn ((list player-list) (game atom-game) aspect &key)
 722   (case aspect
 723     ((:cell-update :start-turn :refresh)
 724      (update-player-list list game))))
 725
 726 ;;;--------------------------------------------------------------------------
 727 ;;; New game dialogue.
 728
 729 (defparameter *player-colours*
 730   (vector "red" "blue" "green" "orange" "magenta" "white" "black"))
 731
 732 (defclass new-game-dialogue (gtk:dialog)
 733   ((game :initarg :game :type atom-game)
 734    (width-adjustment :type gtk:adjustment
 735                      :initform (make-instance 'gtk:adjustment
 736                                               :lower 1 :upper 99
 737                                               :step-increment 1))
 738    (height-adjustment :type gtk:adjustment
 739                       :initform (make-instance 'gtk:adjustment
 740                                                :lower 1 :upper 99
 741                                                :step-increment 1))
 742    (count-adjustment :type gtk:adjustment
 743                      :initform (make-instance 'gtk:adjustment
 744                                               :lower 2 :upper 20
 745                                               :step-increment 1))
 746    (players :type gtk:list-store
 747             :initform (make-instance 'gtk:list-store
 748                                      :column-types '(gdk:color string)
 749                                      :column-names '(colour name))))
 750   (:default-initargs
 751       :title "New game"
 752       :default-height 360
 753       :has-separator nil)
 754   (:metaclass glib:gobject-class))
 755
 756 (defun choose-player-colour (window path)
 757   (let* ((players (slot-value window 'players))
 758          (colour-dialogue (make-instance 'gtk:color-selection-dialog))
 759          (coloursel (gtk:color-selection-dialog-colorsel colour-dialogue))
 760          (colour (gtk:tree-model-value players path 'colour)))
 761     (unwind-protect
 762          (progn
 763            (setf (gtk:color-selection-current-color coloursel) colour
 764                  (gtk:color-selection-previous-color coloursel) colour)
 765            (case (gtk:dialog-run colour-dialogue)
 766              (:ok (setf (gtk:tree-model-value players path 'colour)
 767                         (gtk:color-selection-current-color coloursel)))))
 768       (gtk:widget-destroy colour-dialogue))))
 769
 770 (defun insert-or-remove-players (window)
 771   (let* ((players (slot-value window 'players))
 772          (current-count (gtk:tree-model-iter-n-children players))
 773          (new-count (floor (gtk:adjustment-value
 774                             (slot-value window 'count-adjustment)))))
 775     (if (> current-count new-count)
 776         (let ((iter (make-instance 'gtk:tree-iter)))
 777           (gtk:tree-model-get-iter players (vector new-count) iter)
 778           (dotimes (i (- current-count new-count))
 779             (gtk:list-store-remove players iter)))
 780         (loop with iter = (make-instance 'gtk:tree-iter)
 781               for i from current-count below new-count
 782               for colour = (if (< i (length *player-colours*))
 783                                (gdk:color-parse (aref *player-colours* i))
 784                                (make-instance 'gdk:color
 785                                               :red (random 1.0)
 786                                               :green (random 1.0)
 787                                               :blue (random 1.0)))
 788               for name = (format nil "Player ~A" (1+ i))
 789               do (gtk:list-store-append players
 790                                         (vector colour name)
 791                                         iter)))))
 792
 793 (defun start-new-game (window)
 794   (with-slots (game width-adjustment height-adjustment players) window
 795     (let ((grid (make-atoms-grid
 796                  (floor (gtk:adjustment-value width-adjustment))
 797                  (floor (gtk:adjustment-value height-adjustment))))
 798           (new-players (let ((iter (make-instance 'gtk:tree-iter)))
 799                          (gtk:tree-model-get-iter players #(0) iter)
 800                          (loop for row = (gtk:tree-model-row-data players
 801                                                                   iter)
 802                                collect (make-instance 'human-player
 803                                                       :colour (aref row 0)
 804                                                       :name (aref row 1))
 805                                while (gtk:tree-model-iter-next players
 806                                                                iter)))))
 807       (restart-game game :grid grid :players (coerce new-players 'vector))
 808       (gtk:widget-destroy window))))
 809
 810 (defmethod initialize-instance :after ((window new-game-dialogue) &key)
 811   (with-slots (width-adjustment height-adjustment count-adjustment players)
 812       window
 813     (let* ((game (slot-value window 'game))
 814            (grid (game-grid game)))
 815
 816       (setf (gtk:container-border-width window) 4)
 817       (gtk:dialog-add-button window "gtk-cancel"
 818                              #'gtk:widget-destroy :object t)
 819       (gtk:dialog-add-button window "gtk-ok"
 820                              (lambda () (start-new-game window))
 821                              :default t)
 822
 823       (setf (gtk:adjustment-value width-adjustment)
 824             (array-dimension grid 1)
 825             (gtk:adjustment-value height-adjustment)
 826             (array-dimension grid 0)
 827             (gtk:adjustment-value count-adjustment)
 828             (length (game-players game)))
 829
 830       (let* ((frame (make-instance 'gtk:frame :label "Board size"))
 831              (table (make-instance 'gtk:table
 832                                    :parent frame
 833                                    :border-width 4
 834                                    :n-columns 2 :n-rows 2
 835                                    :row-spacing 4 :column-spacing 4)))
 836         (loop for row from 0
 837               for (adj-slot label) on '(width-adjustment "Width"
 838                                         height-adjustment "Height") by #'cddr
 839               do (make-instance 'gtk:label
 840                                 :label label
 841                                 :xalign 1
 842                                 :parent (list table
 843                                               :top-attach row
 844                                               :bottom-attach (1+ row)
 845                                               :left-attach 0
 846                                               :right-attach 1
 847                                               :x-options '(:fill)))
 848               do (make-instance 'gtk:spin-button
 849                                 :numeric t
 850                                 :width-chars 2
 851                                 :adjustment (slot-value window adj-slot)
 852                                 :xalign 1
 853                                 :activates-default t
 854                                 :parent (list table
 855                                               :top-attach row
 856                                               :bottom-attach (1+ row)
 857                                               :left-attach 1
 858                                               :right-attach 2
 859                                               :x-options '(:expand :fill))))
 860         (gtk:container-add window frame :fill nil :expand nil)
 861         (gtk:widget-show-all frame))
 862
 863       (let* ((frame (make-instance 'gtk:frame :label "Players"))
 864              (vbox (make-instance 'gtk:v-box
 865                                   :parent frame :spacing 4
 866                                   :border-width 4))
 867              (view (make-instance 'gtk:tree-view
 868                                   :model players)))
 869         (make-instance 'gtk:h-box
 870                        :spacing 4
 871                        :parent (list vbox :expand nil :fill nil)
 872                        :child (list (make-instance 'gtk:label
 873                                                    :label "Number of players"
 874                                                    :xalign 1)
 875                                     :expand nil :fill nil)
 876                        :child (list (make-instance 'gtk:spin-button
 877                                                    :adjustment
 878                                                    count-adjustment
 879                                                    :numeric t
 880                                                    :width-chars 2
 881                                                    :activates-default t
 882                                                    :xalign 1)
 883                                     :expand t :fill t))
 884         (make-instance 'gtk:scrolled-window
 885                        :hscrollbar-policy :automatic
 886                        :vscrollbar-policy :automatic
 887                        :shadow-type :in
 888                        :child view
 889                        :parent vbox)
 890         (add-cell-renderer view
 891                            (add-tree-view-column view ""
 892                                                  :sizing :fixed
 893                                                  :fixed-width 20)
 894                            (list :cell-background-gdk 'colour)
 895                            :renderer-args '(:cell-background-set t))
 896         (let ((renderer (add-cell-renderer view
 897                                            (add-tree-view-column view "Name")
 898                                            (list :text 'name)
 899                                            :renderer-args '(:editable t))))
 900           (gtk:signal-connect renderer :edited
 901                               (lambda (path new-text)
 902                                 (setf (gtk:tree-model-value
 903                                        players
 904                                        path
 905                                        'name)
 906                                       new-text))))
 907         (gtk:signal-connect view :row-activated
 908                             (lambda (path column)
 909                               (when (eql (position column
 910                                                    (gtk:tree-view-columns
 911                                                     view))
 912                                          0)
 913                                 (choose-player-colour window path))))
 914         (loop for player across (game-players game)
 915               do (gtk:list-store-append players
 916                                         (vector (player-colour player)
 917                                                 (player-name player))))
 918         (gtk:signal-connect count-adjustment
 919                             :value-changed
 920                             #'insert-or-remove-players :args (list window))
 921         (gtk:container-add window frame :fill t :expand t)
 922         (gtk:widget-show-all frame)))))
 923
 924 ;;;--------------------------------------------------------------------------
 925 ;;; About this program.
 926
 927 (defparameter atoms-logo-pixbuf
 928   (gdk:pixbuf-load #p"/home/mdw/src/atoms/atoms.png"))
 929
 930 (defparameter licence-text
 931   (format nil
 932    "This program is free software; you can redistribute it and/or modify ~
 933     it under the terms of the GNU General Public License as published by ~
 934     the Free Software Foundation; either version 2 of the License, or ~
 935     (at your option) any later version.~2%~
 936     ~
 937     This program is distributed in the hope that it will be useful, ~
 938     but WITHOUT ANY WARRANTY; without even the implied warranty of ~
 939     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the ~
 940     GNU General Public License for more details.~2%~
 941     ~
 942     You should have received a copy of the GNU General Public License ~
 943     along with this program; if not, write to the Free Software Foundation, ~
 944     Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA."))
 945
 946 (let ((about nil))
 947   (defun action-about (window)
 948     (declare (ignore window))
 949     (unless about
 950       (setf about (make-instance
 951                    'gtk:about-dialog
 952                    :name "Atoms"
 953                    :version "1.0.0"
 954                    :copyright "Copyright (c) 2007 Mark Wooding"
 955                    :website "http://www.distorted.org.uk/"
 956                    :website-label "Homepage"
 957                    :authors (list "Mark Wooding <mdw@distorted.org.uk>")
 958                    :comments "May contain trace quantities of Lisp."
 959                    :license licence-text
 960                    :wrap-license t
 961                    :logo atoms-logo-pixbuf
 962                    :signal (list :destroy (lambda () (setf about nil)))
 963                    :signal (list :cancel (lambda ()
 964                                            (gtk:widget-destroy about))))))
 965     (gtk:window-present about)))
 966
 967 ;;;--------------------------------------------------------------------------
 968 ;;; Application window.
 969
 970 (defclass atom-game-window (gtk:window)
 971   ((game :type atom-game)
 972    (board :type atoms-board)
 973    (player-list :type player-list)
 974    (actions :type gtk:action-group)
 975    (ui :type gtk:ui-manager)
 976    (new-game :type (or new-game-dialogue null) :initform nil))
 977   (:default-initargs :title "Atoms game" :allow-shrink t :show-children t)
 978   (:metaclass glib:gobject-class))
 979
 980 (defun action-quit (window)
 981   (gtk:widget-destroy window))
 982
 983 (defun action-new-game (window)
 984   (with-slots (new-game game) window
 985     (if new-game
 986         (gtk:window-present new-game)
 987         (progn
 988           (setf new-game (make-instance 'new-game-dialogue
 989                                         :game game
 990                                         :transient-for window))
 991           (gtk:widget-show-all new-game)
 992           (gtk:signal-connect new-game :destroy
 993                               (lambda () (setf new-game nil)))))))
 994
 995 (defun update-undo-redo-sensitivity (window)
 996   (with-slots (actions game) window
 997     (setf (gtk:action-sensitive-p
 998            (gtk:action-group-get-action actions "undo"))
 999           (undo-list game)
1000           (gtk:action-sensitive-p
1001            (gtk:action-group-get-action actions "redo"))
1002           (redo-list game))))
1003
1004 (defmethod notify progn
1005     ((window atom-game-window) (game atom-game) aspect &key)
1006   (case aspect
1007     ((:undo :redo :refresh :processing-move)
1008      (update-undo-redo-sensitivity window))))
1009
1010 (defun action-undo (window)
1011   (undo (slot-value window 'game)))
1012
1013 (defun action-redo (window)
1014   (redo (slot-value window 'game)))
1015
1016 (defmethod destroyed ((window atom-game-window))
1017   (with-slots (new-game) window
1018     (when new-game (gtk:widget-destroy new-game))))
1019
1020 (defun build-player-vector (player-spec)
1021   (flet ((make-player (spec i)
1022                (etypecase spec
1023                  (player spec)
1024                  ((or string list)
1025                   (destructuring-bind
1026                       (name &key colour)
1027                       (if (listp spec) spec (list spec))
1028                     (cond (colour)
1029                           ((< i (length *player-colours*))
1030                            (setf colour (aref *player-colours* i)))
1031                           (t (setf colour
1032                                    (make-instance 'gdk:color
1033                                                   :red (random 1.0)
1034                                                   :green (random 1.0)
1035                                                   :blue (random 1.0)))))
1036                     (make-instance 'human-player
1037                                    :name name
1038                                    :colour (gdk:ensure-color colour)))))))
1039     (let ((i 0))
1040       (map 'vector
1041            (lambda (spec)
1042              (make-player spec (prog1 i (incf i))))
1043            (etypecase player-spec
1044              (sequence player-spec)
1045              ((or integer null)
1046               (loop for i from 1 upto (or player-spec 4)
1047                     collect (format nil "Player ~A" i))))))))
1048
1049 (defmethod shared-initialize :after
1050     ((window atom-game-window) slot-names
1051      &key
1052      (width 7) (height width) players)
1053   (declare (ignore slot-names))
1054   (let* ((vbox (make-instance 'gtk:v-box :parent window))
1055          (paned (make-instance 'gtk:h-paned
1056                                :parent (list vbox :pack-type :end)))
1057          (aspect (make-instance 'gtk:aspect-frame
1058                                 :parent (list paned :resize t :shrink t)
1059                                 :obey-child t
1060                                 :frame :none
1061                                 :shadow-type :none))
1062          (scrolled (make-instance 'gtk:scrolled-window
1063                                   :parent (list paned :resize nil :shrink t)
1064                                   :shadow-type :in
1065                                   :hscrollbar-policy :automatic
1066                                   :vscrollbar-policy :automatic))
1067          (action-list (mapcar (lambda (item)
1068                                 (destructuring-bind
1069                                     (name callback &rest args) item
1070                                   (apply #'make-instance 'gtk:action
1071                                          :name name
1072                                          :callback
1073                                          (and callback
1074                                               (list callback
1075                                                     :args (list window)))
1076                                          args)))
1077                               `(("file" nil :label "_File")
1078                                 ("edit" nil :label "_Edit")
1079                                 ("help" nil :label "_Help")
1080                                 ("quit" ,#'action-quit
1081                                  :stock-id "gtk-close"
1082                                  :tooltip "Close this window."
1083                                  :accelerator "<control>W")
1084                                 ("undo" ,#'action-undo
1085                                  :stock-id "gtk-undo"
1086                                  :tooltip "Take back the most recent move."
1087                                  :sensitive nil
1088                                  :accelerator "<Control>Z")
1089                                 ("redo" ,#'action-redo
1090                                  :stock-id "gtk-redo"
1091                                  :sensitive nil
1092                                  :tooltip "Revert an undone move."
1093                                  :accelerator "<Shift><Control>Z")
1094                                 ("about" ,#'action-about
1095                                  :tooltip "Show information about this game."
1096                                  :stock-id "gtk-about")
1097                                 ("new-game" ,#'action-new-game
1098                                  :label "_New game..."
1099                                  :stock-id "gtk-new"
1100                                  :tooltip "Start a new game."
1101                                  :accelerator "<control>N")))))
1102
1103     (with-slots (game board player-list ui actions) window
1104       (setf actions (make-instance 'gtk:action-group
1105                                    :name "actions"
1106                                    :actions action-list)
1107             ui (make-instance 'gtk:ui-manager
1108                               :add-tearoffs t
1109                               :action-group actions
1110                               :ui '((:menubar "menu-bar"
1111                                      (:menu "file"
1112                                       (:menuitem "new-game")
1113                                       (:menuitem "quit"))
1114                                      (:menu "edit"
1115                                       (:menuitem "undo")
1116                                       (:menuitem "redo"))
1117                                      (:menu "help"
1118                                       (:menuitem "about")))
1119                                     (:toolbar "toolbar"
1120                                      (:toolitem "new-game")
1121                                      :separator
1122                                      (:toolitem "undo")
1123                                      (:toolitem "redo")))))
1124       (gtk:window-add-accel-group window (gtk:ui-manager-accel-group ui))
1125       (setf (gtk:toolbar-show-arrow-p
1126              (gtk:ui-manager-get-widget ui "/toolbar")) nil)
1127       (dolist (name '("/menu-bar" "/toolbar"))
1128         (make-instance 'gtk:handle-box
1129                        :child (gtk:ui-manager-get-widget ui name)
1130                        :parent (list vbox :expand nil)))
1131       (gtk:signal-connect window :destroy #'destroyed :object t)
1132       (setf game (make-instance 'atom-game
1133                                 :grid (make-atoms-grid width height)
1134                                 :players (build-player-vector players))
1135             board (make-instance 'atoms-board :game game :parent aspect)
1136             player-list (make-instance 'player-list
1137                                        :game game
1138                                        :width-request 160
1139                                        :parent scrolled))
1140
1141       (add-dependent game window))))
1142
1143 ;;;--------------------------------------------------------------------------
1144 ;;; Useful things.
1145
1146 (defvar *window* nil)
1147
1148 (defun start-atom-game (&rest initargs)
1149   (when *window*
1150     (gtk:widget-destroy *window*)
1151     (setf *window* nil))
1152   (setf *window* (apply #'make-instance 'atom-game-window initargs))
1153   (gtk:widget-show-all *window*))
1154
1155 (start-atom-game :width 7 :players (list "Mark" "Vicky"))
1156
1157 ;;;----- That's all, folks --------------------------------------------------