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

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