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