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