chiark / gitweb /
atoms.lisp: Rewrite `update-undo-redo-sensitivity'.
[atoms] / atoms.lisp
CommitLineData
6f866d53
MW
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))
752d6599 293 ((member state '(:playing :starting :ready))
6f866d53
MW
294 (incf remaining)
295 (setf found player)))))
296 (changed game :scores :players players)
c1be7084 297 (when (and (= remaining 1) (>= (length players) 2))
6f866d53
MW
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)
99667eae
MW
365 (changed game :processing-move))
366 (perform-explosions game (list cell))))))
6f866d53
MW
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))
508a54a3 419 (game-cancel-timeout game)
3c0a8e1f
MW
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)))))
6f866d53
MW
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
c1be7084 750 :lower 1 :upper 20
6f866d53
MW
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
c10ee6be
MW
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)))))
6f866d53
MW
1008
1009(defmethod notify progn
1010 ((window atom-game-window) (game atom-game) aspect &key)
1011 (case aspect
99667eae 1012 ((:undo :redo :refresh :start-turn)
6f866d53
MW
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 --------------------------------------------------