5 ;;; (c) 2007 Mark Wooding
8 ;;;----- Licensing notice ---------------------------------------------------
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.
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.
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.
24 (cl:defpackage #:atoms
29 #+clisp (:shadow #:map-dependents #:add-dependent #:remove-dependent))
30 (cl:in-package #:atoms)
32 (eval-when (:compile-toplevel :load-toplevel :execute)
33 (asdf:operate 'asdf:load-op :gtk))
37 ;;; Before we start, I should probably point out that the first version of
38 ;;; this program was written in Smalltalk, which may explain its slight
39 ;;; object-ravioli nature.
41 ;;;--------------------------------------------------------------------------
42 ;;; Dependent management.
46 (defgeneric notify (dependent model aspect &key &allow-other-keys)
47 (:method-combination progn)
48 (:method progn (dependent model aspect &rest arguments)
49 (declare (ignore arguments))
52 (defgeneric map-dependents (model function))
53 (defgeneric add-dependent (model dependent))
54 (defgeneric remove-dependent (model dependent))
56 (defgeneric changed (model &optional aspect &key &allow-other-keys)
57 (:method (model &optional aspect &rest arguments)
60 (apply #'notify dependent model aspect arguments)))))
62 ;; Generic implementation.
65 ((dependents :type list :initform nil)))
67 (defun clean-up-danglies (model)
68 (with-slots (dependents) model
70 (delete-if-not (lambda (weak)
71 (nth-value 1 (weak-pointer-value weak)))
74 (defmethod map-dependents ((model model) function)
75 (with-slots (dependents) model
77 (dolist (dependent dependents)
78 (multiple-value-bind (object foundp)
79 (weak-pointer-value dependent)
81 (funcall function object)
83 (when danglies (clean-up-danglies model))
86 (defmethod add-dependent ((model model) dependent)
87 (let ((foundp (block nil
90 (when (eql dependent dep)
93 (push (make-weak-pointer dependent)
94 (slot-value model 'dependents)))))
96 (defmethod remove-dependent ((model model) dependent)
97 (with-slots (dependents) model
98 (setf dependents (delete dependent dependents
99 :key #'weak-pointer-value))
100 (clean-up-danglies model)))
102 ;;;--------------------------------------------------------------------------
105 (defclass undoable ()
106 ((undo-list :type list :reader undo-list :initform nil)
107 (redo-list :type list :reader redo-list :initform nil)))
109 (defgeneric snapshot (object))
110 (defgeneric restore (object snapshot))
111 (defgeneric store-undo-snapshot (object snapshot))
112 (defgeneric undo (object))
113 (defgeneric redo (object))
114 (defgeneric reset-undo-state (object))
116 (defmethod store-undo-snapshot ((object undoable) snapshot)
117 (push snapshot (slot-value object 'undo-list))
118 (setf (slot-value object 'redo-list) nil))
120 (defmacro with-undo-snapshot ((object) &body body)
121 (let ((snap (gensym "SNAPSHOT"))
122 (obj (gensym "OBJECT")))
123 `(let* ((,obj ,object)
124 (,snap (snapshot ,obj)))
125 (multiple-value-prog1 (progn ,@body)
126 (store-undo-snapshot ,obj ,snap)))))
128 (defun undo-redo (object from to)
129 (let ((from-list (slot-value object from)))
131 (let ((undo-snap (car from-list))
132 (here-snap (snapshot object)))
133 (restore object undo-snap)
134 (push here-snap (slot-value object to))
135 (pop (slot-value object from)))))
137 (defmethod undo ((object undoable))
138 (undo-redo object 'undo-list 'redo-list))
140 (defmethod redo ((object undoable))
141 (undo-redo object 'redo-list 'undo-list))
143 (defmethod reset-undo-state ((object undoable))
144 (setf (slot-value object 'undo-list) nil
145 (slot-value object 'redo-list) nil))
147 (defclass undoable-model (undoable model)
150 (defmethod undo :after ((object undoable-model))
151 (changed object :undo))
153 (defmethod redo :after ((object undoable-model))
154 (changed object :redo))
156 ;;;--------------------------------------------------------------------------
161 (defclass atom-cell ()
162 ((owner :reader cell-owner :initform nil :type (or fixnum null))
163 (count :reader cell-count :initform 0 :type fixnum)
164 (pending :initform 0 :type fixnum)
165 (neighbours :reader cell-neighbours :type list :initform nil)
166 (x :reader cell-x :initarg :x :type fixnum)
167 (y :reader cell-y :initarg :y :type fixnum)))
169 (defgeneric cell-played (cell player))
170 (defgeneric cell-critical-p (cell))
171 (defgeneric cell-explode (cell))
172 (defgeneric cell-apply-pending-updates (cell))
173 (defun cell-position (cell) (vector (cell-x cell) (cell-y cell)))
175 (defun make-atoms-grid (width height)
176 (let ((grid (make-array (list height width) :element-type 'atom-cell)))
179 (setf (aref grid j i) (make-instance 'atom-cell :x i :y j))))
182 (setf (slot-value (aref grid j i) 'neighbours)
183 (nconc (and (> j 0) (list (aref grid (1- j) i)))
184 (and (> i 0) (list (aref grid j (1- i))))
185 (and (< i (1- width)) (list (aref grid j (1+ i))))
186 (and (< j (1- height)) (list (aref grid (1+ j) i)))))))
190 ((name :accessor player-name :initarg :name :type string)
191 (score :accessor player-score :initform 0 :type fixnum)
192 (state :accessor player-state :initform :starting
193 :type (member :starting :playing :ready :losing :winning))
194 (colour :accessor player-colour :initarg :colour :type gdk:color)))
196 (defun player-type-name (symbol)
197 (get symbol 'player-type-name))
198 (defun (setf player-type-name) (name symbol)
199 (setf (get symbol 'player-type-name) name))
201 (defclass human-player (player) ())
202 (setf (player-type-name 'human-player) "Human")
204 (defgeneric player-cell-selected (game player i j)
205 (:method (game player i j) nil))
206 (defgeneric player-turn-begin (game player)
207 (:method (game player) nil))
209 (defclass atom-game (undoable-model)
210 ((grid :accessor game-grid :initarg :grid :type (array atom-cell (* *)))
211 (players :accessor game-players :initarg :players :type vector)
212 (player-index :accessor game-player-index :initform 0 :type fixnum)
213 (timeout-id :initform nil)))
215 (defgeneric game-cell-selected (game i j))
216 (defgeneric play-cell (game player i j))
220 (defmethod cell-played ((cell atom-cell) player)
221 (with-slots (owner count) cell
222 (cond ((zerop count) (setf owner player count 1) t)
223 ((eql owner player) (incf count) t)
226 (defmethod cell-critical-p ((cell atom-cell))
227 (with-slots (count neighbours) cell
228 (>= count (length neighbours))))
230 (defmethod cell-explode ((cell atom-cell))
231 (with-slots (count neighbours owner pending) cell
232 (multiple-value-bind (spill left) (floor count (length neighbours))
235 (dolist (neighbour neighbours)
236 (incf (slot-value neighbour 'pending) spill)
237 (setf (slot-value neighbour 'owner) owner))
241 (cons cell (copy-list neighbours)))))))
243 (defmethod cell-apply-pending-updates ((cell atom-cell))
244 (with-slots (count pending) cell
248 (deftype cell-snapshot () '(unsigned-byte 16))
250 (defmethod snapshot ((cell atom-cell))
251 (with-slots (count owner) cell
252 (cond ((null owner) 0)
253 (t (assert (and (<= 0 count 255)
255 (logior (ash owner 8)
258 (defmethod restore ((cell atom-cell) (snapshot integer))
259 (declare (type cell-snapshot snapshot))
260 (with-slots (count owner) cell
261 (setf (values count owner)
264 (values (ldb (byte 8 0) snapshot)
265 (ldb (byte 8 8) snapshot))))))
267 (defmethod player-cell-selected (game (player human-player) i j)
268 (and (eql (player-state player) :ready)
269 (play-cell game player i j)))
271 (defmethod snapshot ((player player))
272 (list (player-score player) (player-state player)))
274 (defmethod restore ((player player) (list list))
275 (destructuring-bind (score state) list
276 (setf (player-score player) score
277 (player-state player) state)))
279 (defmethod game-update-scores (game)
280 (let ((players (game-players game))
281 (grid (game-grid game)))
282 (dotimes (i (length players))
283 (setf (player-score (aref players i)) 0))
284 (dotimes (i (array-total-size grid))
285 (let* ((cell (row-major-aref grid i))
286 (owner (cell-owner cell))
287 (player (and owner (aref players owner)))
288 (count (cell-count cell)))
289 (when (and player (plusp count))
290 (incf (player-score player) count))))
291 (let ((remaining 0) (found nil))
292 (dotimes (i (length players))
293 (let* ((player (aref players i))
294 (score (player-score player))
295 (state (player-state player)))
296 (cond ((and (zerop score) (eql state :playing))
297 (setf (player-state player) :losing))
298 ((member state '(:playing :starting :ready))
300 (setf found player)))))
301 (changed game :scores :players players)
302 (when (and (= remaining 1) (>= (length players) 2))
303 (setf (player-state found) :winning)
304 (changed game :finished :victor found)))))
306 (defmethod game-next-player (game)
307 (let ((players (game-players game))
308 (player-index (game-player-index game)))
309 (dotimes (i (length players))
310 (let* ((j (mod (+ player-index i 1) (length players)))
311 (player (aref players j)))
312 (when (member (player-state player) '(:starting :playing))
313 (setf (game-player-index game) j
314 (player-state player) :ready)
315 (player-turn-begin game player)
316 (changed game :start-turn :player player)
319 (defvar *cells-remaining* nil)
321 (defun perform-pending-explosions (game cells)
322 (let ((affected (delete-duplicates
323 (mapcan #'cell-explode cells))))
324 (mapc #'cell-apply-pending-updates affected)
325 (perform-explosions game affected)))
327 (defvar *explosion-time* 100)
329 (defun perform-explosions (game cells)
330 (game-update-scores game)
331 (changed game :cell-update :cells cells)
332 (let ((critical (delete-if-not #'cell-critical-p cells)))
333 (setf *cells-remaining* critical)
334 (cond ((null critical) (game-next-player game) t)
335 (t (with-slots (timeout-id) game
336 (setf timeout-id (glib:timeout-add
339 (setf timeout-id nil)
340 (perform-pending-explosions game critical)
344 (defun game-cancel-timeout (game)
345 (with-slots (timeout-id) game
347 (glib:source-remove timeout-id)
348 (setf timeout-id nil))))
350 (defmethod game-player ((game atom-game))
351 (aref (game-players game) (game-player-index game)))
353 (defmethod game-cell-selected ((game atom-game) i j)
354 (player-cell-selected game (game-player game) i j))
356 (defmethod initialize-instance :after ((game atom-game) &key)
357 (setf (player-state (game-player game)) :ready))
359 (defmethod play-cell ((game atom-game) player i j)
360 (with-slots (grid players player-index) game
361 (assert (and (<= 0 i) (< i (array-dimension grid 1))
362 (<= 0 j) (< j (array-dimension grid 0))))
363 (let ((cell (aref grid j i))
364 (player (aref players player-index)))
366 (with-undo-snapshot (game)
367 (unless (cell-played cell player-index)
368 (return-from escape))
369 (setf (player-state player) :playing)
370 (changed game :processing-move))
371 (perform-explosions game (list cell))))))
373 (defmethod restart-game ((game atom-game) &key grid players)
374 (game-cancel-timeout game)
375 (setf (game-grid game)
377 (let ((old (game-grid game)))
378 (make-atoms-grid (array-dimension old 1)
379 (array-dimension old 0)))))
381 (setf (game-players game) players)
382 (setf players (game-players game)))
383 (reset-undo-state game)
384 (dotimes (i (length players))
385 (let ((player (aref players i)))
386 (setf (player-score player) 0
387 (player-state player) (if (zerop i) :ready :starting))))
388 (setf (game-player-index game) 0)
389 (changed game :refresh))
391 ;;;--------------------------------------------------------------------------
392 ;;; Snapshots and undo.
394 (defclass atom-game-snapshot ()
395 ((grid :type (array cell-snapshot (* *)) :initarg :grid)
396 (players :type list :initarg :players)
397 (player-index :type fixnum :initarg :player-index)))
399 (defmethod snapshot ((game atom-game))
400 (let* ((grid (game-grid game))
401 (grid-snapshot (make-array (array-dimensions grid)
402 :element-type 'cell-snapshot
403 :initial-element 0)))
404 (dotimes (i (array-total-size grid))
405 (setf (row-major-aref grid-snapshot i)
406 (snapshot (row-major-aref grid i))))
407 (make-instance 'atom-game-snapshot
408 :players (map 'list #'snapshot (game-players game))
409 :player-index (game-player-index game)
410 :grid grid-snapshot)))
412 (defmethod restore ((game atom-game) (snapshot atom-game-snapshot))
413 (let ((snap-grid (slot-value snapshot 'grid))
414 (snap-players (slot-value snapshot 'players))
415 (grid (game-grid game))
416 (players (game-players game)))
417 (dotimes (i (array-total-size grid))
418 (restore (row-major-aref grid i)
419 (row-major-aref snap-grid i)))
420 (loop for player across players
421 for snap-player in snap-players
422 do (restore player snap-player))
423 (setf (game-player-index game) (slot-value snapshot 'player-index))
424 (game-cancel-timeout game)
425 (changed game :refresh)
426 (let ((critical-cells (loop for i below (array-total-size grid)
427 for cell = (row-major-aref grid i)
428 if (cell-critical-p cell)
430 (when critical-cells (perform-explosions game critical-cells)))))
432 ;;;--------------------------------------------------------------------------
433 ;;; The interactive board.
435 (defclass atoms-board (gtk:drawing-area)
436 ((game :accessor board-game :initarg :game :type atom-game)
437 (cache :initform nil :accessor board-cache))
438 (:metaclass glib:gobject-class))
440 (defmethod board-grid ((board atoms-board))
441 (game-grid (board-game board)))
443 (defgeneric paint (widget event))
445 (defun paint-atoms (cr count colour)
446 (let* ((centrep (and (oddp count) (/= count 3)))
447 (surround (if centrep (1- count) count))
448 (angle (and (plusp surround) (/ (* 2 pi) surround)))
451 (t (/ (- pi angle) 2))))
453 (sep (cond ((and centrep (<= surround 6)) (* 2 radius))
454 ((<= surround 2) radius)
455 (t (/ radius (sin (/ angle 2)))))))
457 (cairo:new-sub-path cr)
458 (cairo:arc cr 0 0 radius 0 (* 2 pi)))
459 (dotimes (i surround)
460 (cairo:new-sub-path cr)
463 (- (* sep (sin theta)))
468 (gdk:cairo-set-source-color cr (gdk:ensure-color colour))
470 (setf (cairo:line-width cr)
471 (max 0.02 (cairo:device-to-user-distance cr 1)))
472 (cairo:set-source-color cr 0 0 0)
473 (cairo:stroke cr nil)))
475 (defparameter cache-limit 8)
477 (defun make-cached-atom-surfaces (board colour)
478 (multiple-value-bind (width height) (gtk:widget-get-size-allocation board)
479 (let* ((vector (make-array cache-limit))
480 (grid (board-grid board))
481 (surface-width (floor width (array-dimension grid 1)))
482 (surface-height (floor height (array-dimension grid 0))))
483 (dotimes (i (length vector))
484 (let* ((surface (make-instance 'cairo:image-surface
486 :height surface-height
488 (cr (make-instance 'cairo:context :target surface)))
489 (cairo:scale cr surface-width surface-height)
490 (cairo:translate cr 0.5 0.5)
491 (paint-atoms cr (1+ i) colour)
492 (setf (aref vector i) surface)))
495 (defun cached-atom-surface (board count colour)
496 (let ((cache (board-cache board)))
498 (setf cache (make-hash-table)
499 (board-cache board) cache))
500 (let ((vector (gethash colour cache)))
502 (setf vector (make-cached-atom-surfaces board colour)
503 (gethash colour cache) vector))
504 (and (< 0 count) (<= count (length vector))
505 (aref vector (1- count))))))
507 (defmethod paint ((widget atoms-board) event)
508 (multiple-value-bind (width height) (gtk:widget-get-size-allocation widget)
509 (let* ((style (gtk:widget-style widget))
510 (grid (board-grid widget))
511 (vsq (array-dimension grid 0))
512 (hsq (array-dimension grid 1))
513 (game (board-game widget))
514 (players (game-players game))
515 lo-hsq hi-hsq lo-vsq hi-vsq
516 (display (gtk:widget-get-display widget))
517 (region (make-instance 'gdk:region))
518 (redraw-map (make-array (list vsq hsq)
520 :initial-element 0)))
522 (loop (let* ((loh (floor (* (gdk:event-x event) hsq) width))
523 (hih (ceiling (* (+ (gdk:event-x event)
524 (gdk:event-width event))
527 (lov (floor (* (gdk:event-y event) vsq) height))
528 (hiv (ceiling (* (+ (gdk:event-y event)
529 (gdk:event-height event))
532 (gdk:region-union region
533 (vector (gdk:event-x event)
535 (gdk:event-width event)
536 (gdk:event-height event)))
537 (when (or (null lo-hsq) (< loh lo-hsq)) (setf lo-hsq loh))
538 (when (or (null hi-hsq) (< hih hi-vsq)) (setf hi-hsq hih))
539 (when (or (null lo-vsq) (< lov lo-hsq)) (setf lo-vsq lov))
540 (when (or (null hi-vsq) (< hiv hi-vsq)) (setf hi-vsq hiv))
541 (do ((j lov (1+ j))) ((>= j hiv))
542 (do ((i loh (1+ i))) ((>= i hih))
543 (setf (bit redraw-map j i) 1)))
544 (when (zerop (gdk:event-count event))
546 (setf event (gdk:display-get-event display))))
548 (gdk:with-cairo-context (cr (gtk:widget-window widget))
549 (cairo:reset-clip cr)
550 (gdk:cairo-region cr region)
552 (cairo:with-context (cr)
553 (gdk:cairo-set-source-color cr (gtk:style-fg style :normal))
554 (cairo:translate cr 1/2 1/2)
555 (setf (cairo:line-width cr) 1
556 (cairo:antialias cr) :none)
557 (let ((h (1- height)) (w (1- width)))
558 (do ((j lo-vsq (1+ j))) ((> j hi-vsq))
559 (let ((y (round (* j h) vsq)))
560 (cairo:move-to cr 0 y)
561 (cairo:line-to cr w y)))
562 (do ((i lo-hsq (1+ i))) ((> i hi-hsq))
563 (let ((x (round (* i w) hsq)))
564 (cairo:move-to cr x 0)
565 (cairo:line-to cr x h))))
567 (do ((j lo-vsq (1+ j))) ((>= j hi-vsq))
568 (do ((i lo-hsq (1+ i))) ((>= i hi-hsq))
569 (when (plusp (bit redraw-map j i))
570 (let* ((cell (aref grid j i))
571 (count (cell-count cell))
572 (colour (and (plusp count) (cell-owner cell)
575 (cell-owner cell)))))
577 (cached-atom-surface widget
579 (cond ((or (zerop count) (null (cell-owner cell)))
582 (cairo:with-context (cr)
583 (cairo:scale cr (/ width hsq) (/ height vsq))
584 (cairo:translate cr (+ i 0.5) (+ j 0.5))
585 (paint-atoms cr count colour)))
587 (cairo:set-source-surface cr surface
588 (round (* i width) hsq)
589 (round (* j height) vsq))
590 (cairo:paint cr)))))))))))
592 (defun board-set-size-request (board)
593 (when (slot-boundp board 'game)
594 (let ((grid (board-grid board)))
595 (gtk:widget-set-size-request board
596 (* 50 (array-dimension grid 1))
597 (* 50 (array-dimension grid 0))))))
599 (defmethod (setf board-game) :before (game (board atoms-board))
600 (when (slot-boundp board 'game)
601 (remove-dependent (board-game board) board)))
603 (defmethod (setf board-game) :after (game (board atoms-board))
604 (board-set-size-request board)
605 (add-dependent game board))
607 (defmethod resized ((board atoms-board) allocation)
608 (setf (board-cache board) nil)
611 (defmethod notify progn
612 ((board atoms-board) (game atom-game) (aspect (eql :cell-update))
614 (unless (slot-boundp board 'gtk:window) (return-from notify))
615 (multiple-value-bind (width height) (gtk:widget-get-size-allocation board)
616 (let* ((region (make-instance 'gdk:region))
617 (grid (board-grid board))
618 (hsq (array-dimension grid 1))
619 (vsq (array-dimension grid 0)))
621 (gdk:region-union region
622 (vector (floor (* (cell-x cell) width) hsq)
623 (floor (* (cell-y cell) height) vsq)
625 (ceiling height vsq))))
626 (gdk:window-invalidate-region (gtk:widget-window board) region nil))))
628 (defmethod notify progn
629 ((board atoms-board) (game atom-game) (aspect (eql :refresh)) &key)
630 (board-set-size-request board)
631 (setf (board-cache board) nil)
632 (gtk:widget-queue-draw board))
634 (defmethod button-press ((widget atoms-board) event)
635 (case (gdk:event-class-type (class-of event))
637 (case (gdk:event-button event)
638 (1 (multiple-value-bind (width height)
639 (gtk:widget-get-size-allocation widget)
640 (let* ((grid (board-grid widget))
641 (x (floor (* (gdk:event-x event) (array-dimension grid 1))
643 (y (floor (* (gdk:event-y event) (array-dimension grid 0))
645 (game-cell-selected (board-game widget) x y)
648 (defmethod initialize-instance :after ((board atoms-board) &key)
649 (gtk:signal-connect board :expose-event #'paint :object t)
650 (setf (gtk:widget-events board) (list :button-press))
651 (gtk:signal-connect board :button-press-event #'button-press :object t)
652 (gtk:signal-connect board :size-allocate #'resized :object t)
653 (when (slot-boundp board 'game) (add-dependent (board-game board) board))
654 (board-set-size-request board))
656 ;;;--------------------------------------------------------------------------
657 ;;; Tree view utilities.
659 (defun add-tree-view-column (view title &rest args)
660 (let ((column (apply #'make-instance
661 'gtk:tree-view-column
664 (gtk:tree-view-append-column view column)
667 (defun add-cell-renderer
669 &key (type 'gtk:cell-renderer-text) pack-args renderer-args)
670 (let ((renderer (apply #'make-instance type renderer-args))
671 (store (gtk:tree-view-model view)))
672 (apply #'gtk:cell-layout-pack column renderer pack-args)
673 (loop for (attribute col-name) on attrs by #'cddr
674 do (gtk:cell-layout-add-attribute
675 column renderer attribute
676 (gtk:tree-model-column-index store col-name)))
679 ;;;--------------------------------------------------------------------------
682 (defvar *player-list*)
683 (defvar *player-list-view*)
685 (defclass player-list (gtk:tree-view)
686 ((store :initform (make-instance
688 :column-names '(colour name score state)
689 :column-types '(gdk:color string integer string))
690 :type gtk:list-store)
691 (game :initarg :game :type atom-game))
692 (:metaclass glib:gobject-class))
694 (defun update-player-list (list game)
695 (let ((store (slot-value list 'store))
696 (players (game-players game)))
697 (gtk:list-store-clear store)
698 (loop for player across players
700 do (gtk:list-store-append store
701 (vector (player-colour player)
703 (player-score player)
704 (case (player-state player)
710 (defmethod initialize-instance :after ((list player-list) &key)
711 (let ((store (slot-value list 'store)))
712 (setf (gtk:tree-view-model list) store)
713 (flet ((add-column (&rest args)
714 (apply #'add-tree-view-column list args))
715 (add-renderer (&rest args)
716 (apply #'add-cell-renderer list args)))
717 (add-renderer (add-column ""
721 '(:cell-background-gdk colour)
722 :renderer-args '(:cell-background-set t))
723 (add-renderer (add-column "Name" :resizable t :expand t) '(:text name))
724 (add-renderer (add-column "Score" :resizable t) '(:text score))
725 (add-renderer (add-column "State" :resizable t) '(:text state)))
726 (setf (gtk:tree-selection-mode (gtk:tree-view-selection list)) :none)
727 (when (slot-boundp list 'game)
728 (with-slots (game) list
729 (add-dependent game list)
730 (update-player-list list game)))))
732 (defmethod notify progn ((list player-list) (game atom-game) aspect &key)
734 ((:cell-update :start-turn :refresh)
735 (update-player-list list game))))
737 ;;;--------------------------------------------------------------------------
738 ;;; New game dialogue.
740 (defparameter *player-colours*
741 (vector "red" "blue" "green" "orange" "magenta" "white" "black"))
743 (defparameter *player-types* '(human-player))
745 (defclass new-game-dialogue (gtk:dialog)
746 ((game :initarg :game :type atom-game)
747 (width-adjustment :type gtk:adjustment
748 :initform (make-instance 'gtk:adjustment
751 (height-adjustment :type gtk:adjustment
752 :initform (make-instance 'gtk:adjustment
755 (count-adjustment :type gtk:adjustment
756 :initform (make-instance 'gtk:adjustment
759 (players :type gtk:list-store
760 :initform (make-instance 'gtk:list-store
761 :column-types '(gdk:color string string)
762 :column-names '(colour name type))))
767 (:metaclass glib:gobject-class))
769 (defun choose-player-colour (window path)
770 (let* ((players (slot-value window 'players))
771 (colour-dialogue (make-instance 'gtk:color-selection-dialog))
772 (coloursel (gtk:color-selection-dialog-colorsel colour-dialogue))
773 (colour (gtk:tree-model-value players path 'colour)))
776 (setf (gtk:color-selection-current-color coloursel) colour
777 (gtk:color-selection-previous-color coloursel) colour)
778 (case (gtk:dialog-run colour-dialogue)
779 (:ok (setf (gtk:tree-model-value players path 'colour)
780 (gtk:color-selection-current-color coloursel)))))
781 (gtk:widget-destroy colour-dialogue))))
783 (defun insert-or-remove-players (window)
784 (let* ((players (slot-value window 'players))
785 (current-count (gtk:tree-model-iter-n-children players))
786 (new-count (floor (gtk:adjustment-value
787 (slot-value window 'count-adjustment)))))
788 (if (> current-count new-count)
789 (let ((iter (make-instance 'gtk:tree-iter)))
790 (gtk:tree-model-get-iter players (vector new-count) iter)
791 (dotimes (i (- current-count new-count))
792 (gtk:list-store-remove players iter)))
793 (loop with iter = (make-instance 'gtk:tree-iter)
794 for i from current-count below new-count
795 for colour = (if (< i (length *player-colours*))
796 (gdk:color-parse (aref *player-colours* i))
797 (make-instance 'gdk:color
801 for name = (format nil "Player ~A" (1+ i))
802 do (gtk:list-store-append players
806 (defun start-new-game (window)
807 (with-slots (game width-adjustment height-adjustment players) window
808 (let ((grid (make-atoms-grid
809 (floor (gtk:adjustment-value width-adjustment))
810 (floor (gtk:adjustment-value height-adjustment))))
811 (new-players (let ((iter (make-instance 'gtk:tree-iter)))
812 (gtk:tree-model-get-iter players #(0) iter)
813 (loop for row = (gtk:tree-model-row-data players
815 collect (make-instance
819 :key #'player-type-name)
822 while (gtk:tree-model-iter-next players
824 (restart-game game :grid grid :players (coerce new-players 'vector))
825 (gtk:widget-destroy window))))
827 (defmethod initialize-instance :after ((window new-game-dialogue) &key)
828 (with-slots (width-adjustment height-adjustment count-adjustment players)
830 (let* ((game (slot-value window 'game))
831 (grid (game-grid game)))
833 (setf (gtk:container-border-width window) 4)
834 (gtk:dialog-add-button window "gtk-cancel"
835 #'gtk:widget-destroy :object t)
836 (gtk:dialog-add-button window "gtk-ok"
837 (lambda () (start-new-game window))
840 (setf (gtk:adjustment-value width-adjustment)
841 (array-dimension grid 1)
842 (gtk:adjustment-value height-adjustment)
843 (array-dimension grid 0)
844 (gtk:adjustment-value count-adjustment)
845 (length (game-players game)))
847 (let* ((frame (make-instance 'gtk:frame :label "Board size"))
848 (table (make-instance 'gtk:table
851 :n-columns 2 :n-rows 2
852 :row-spacing 4 :column-spacing 4)))
854 for (adj-slot label) on '(width-adjustment "Width"
855 height-adjustment "Height") by #'cddr
856 do (make-instance 'gtk:label
861 :bottom-attach (1+ row)
864 :x-options '(:fill)))
865 do (make-instance 'gtk:spin-button
868 :adjustment (slot-value window adj-slot)
873 :bottom-attach (1+ row)
876 :x-options '(:expand :fill))))
877 (gtk:container-add window frame :fill nil :expand nil)
878 (gtk:widget-show-all frame))
880 (let* ((frame (make-instance 'gtk:frame :label "Players"))
881 (vbox (make-instance 'gtk:v-box
882 :parent frame :spacing 4
884 (view (make-instance 'gtk:tree-view
886 (make-instance 'gtk:h-box
888 :parent (list vbox :expand nil :fill nil)
889 :child (list (make-instance 'gtk:label
890 :label "Number of players"
892 :expand nil :fill nil)
893 :child (list (make-instance 'gtk:spin-button
901 (make-instance 'gtk:scrolled-window
902 :hscrollbar-policy :automatic
903 :vscrollbar-policy :automatic
907 (add-cell-renderer view
908 (add-tree-view-column view ""
911 (list :cell-background-gdk 'colour)
912 :renderer-args '(:cell-background-set t))
913 (let* ((model (make-instance 'gtk:list-store
914 :column-types '(string)
915 :column-names '(type)
917 (mapcar (lambda (type)
919 (player-type-name type)))
921 (renderer (add-cell-renderer
923 (add-tree-view-column view "Type")
925 :type 'gtk:cell-renderer-combo
926 :renderer-args (list :model model
930 (gtk:signal-connect renderer :changed
931 (lambda (path new-iter)
932 (setf (gtk:tree-model-value
934 (gtk:tree-model-value
935 model new-iter 'type)))))
936 (let ((renderer (add-cell-renderer view
937 (add-tree-view-column view "Name")
939 :renderer-args '(:editable t))))
940 (gtk:signal-connect renderer :edited
941 (lambda (path new-text)
942 (setf (gtk:tree-model-value
946 (gtk:signal-connect view :row-activated
947 (lambda (path column)
948 (when (eql (position column
949 (gtk:tree-view-columns
952 (choose-player-colour window path))))
953 (loop for player across (game-players game)
954 do (gtk:list-store-append
956 (vector (player-colour player)
958 (player-type-name (class-name
959 (class-of player))))))
960 (gtk:signal-connect count-adjustment
962 #'insert-or-remove-players :args (list window))
963 (gtk:container-add window frame :fill t :expand t)
964 (gtk:widget-show-all frame)))))
966 ;;;--------------------------------------------------------------------------
967 ;;; About this program.
969 (defparameter atoms-logo-pixbuf
970 (gdk:pixbuf-load #p"/home/mdw/src/atoms/atoms.png"))
972 (defparameter licence-text
974 "This program is free software; you can redistribute it and/or modify ~
975 it under the terms of the GNU General Public License as published by ~
976 the Free Software Foundation; either version 2 of the License, or ~
977 (at your option) any later version.~2%~
979 This program is distributed in the hope that it will be useful, ~
980 but WITHOUT ANY WARRANTY; without even the implied warranty of ~
981 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ~
982 GNU General Public License for more details.~2%~
984 You should have received a copy of the GNU General Public License ~
985 along with this program; if not, write to the Free Software Foundation, ~
986 Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA."))
989 (defun action-about (window)
990 (declare (ignore window))
992 (setf about (make-instance
996 :copyright "Copyright (c) 2007 Mark Wooding"
997 :website "http://www.distorted.org.uk/"
998 :website-label "Homepage"
999 :authors (list "Mark Wooding <mdw@distorted.org.uk>")
1000 :comments "May contain trace quantities of Lisp."
1001 :license licence-text
1003 :logo atoms-logo-pixbuf
1004 :signal (list :destroy (lambda () (setf about nil)))
1005 :signal (list :cancel (lambda ()
1006 (gtk:widget-destroy about))))))
1007 (gtk:window-present about)))
1009 ;;;--------------------------------------------------------------------------
1010 ;;; Application window.
1012 (defclass atom-game-window (gtk:window)
1013 ((game :type atom-game)
1014 (board :type atoms-board)
1015 (player-list :type player-list)
1016 (actions :type gtk:action-group)
1017 (ui :type gtk:ui-manager)
1018 (new-game :type (or new-game-dialogue null) :initform nil))
1019 (:default-initargs :title "Atoms game" :allow-shrink t :show-children t)
1020 (:metaclass glib:gobject-class))
1022 (defun action-quit (window)
1023 (gtk:widget-destroy window))
1025 (defun action-new-game (window)
1026 (with-slots (new-game game) window
1028 (gtk:window-present new-game)
1030 (setf new-game (make-instance 'new-game-dialogue
1032 :transient-for window))
1033 (gtk:widget-show-all new-game)
1034 (gtk:signal-connect new-game :destroy
1035 (lambda () (setf new-game nil)))))))
1037 (defun update-undo-redo-sensitivity (window)
1038 (with-slots (actions game) window
1039 (flet ((set-sensitive (act-name sensitivep)
1040 (let ((act (gtk:action-group-get-action actions act-name)))
1041 (setf (gtk:action-sensitive-p act) sensitivep))))
1042 (set-sensitive "undo" (undo-list game))
1043 (set-sensitive "redo" (redo-list game)))))
1045 (defmethod notify progn
1046 ((window atom-game-window) (game atom-game) aspect &key)
1048 ((:undo :redo :refresh :start-turn)
1049 (update-undo-redo-sensitivity window))))
1051 (defun action-undo (window)
1052 (undo (slot-value window 'game)))
1054 (defun action-redo (window)
1055 (redo (slot-value window 'game)))
1057 (defmethod destroyed ((window atom-game-window))
1058 (with-slots (new-game) window
1059 (when new-game (gtk:widget-destroy new-game))))
1061 (defun build-player-vector (player-spec)
1062 (flet ((make-player (spec i)
1067 (name &key colour (type 'human-player))
1068 (if (listp spec) spec (list spec))
1070 ((< i (length *player-colours*))
1071 (setf colour (aref *player-colours* i)))
1073 (make-instance 'gdk:color
1076 :blue (random 1.0)))))
1079 :colour (gdk:ensure-color colour)))))))
1083 (make-player spec (prog1 i (incf i))))
1084 (etypecase player-spec
1085 (sequence player-spec)
1087 (loop for i from 1 upto (or player-spec 4)
1088 collect (format nil "Player ~A" i))))))))
1090 (defmethod shared-initialize :after
1091 ((window atom-game-window) slot-names
1093 (width 7) (height width) players)
1094 (declare (ignore slot-names))
1095 (let* ((vbox (make-instance 'gtk:v-box :parent window))
1096 (paned (make-instance 'gtk:h-paned
1097 :parent (list vbox :pack-type :end)))
1098 (aspect (make-instance 'gtk:aspect-frame
1099 :parent (list paned :resize t :shrink t)
1102 :shadow-type :none))
1103 (scrolled (make-instance 'gtk:scrolled-window
1104 :parent (list paned :resize nil :shrink t)
1106 :hscrollbar-policy :automatic
1107 :vscrollbar-policy :automatic))
1108 (action-list (mapcar (lambda (item)
1110 (name callback &rest args) item
1111 (apply #'make-instance 'gtk:action
1116 :args (list window)))
1118 `(("file" nil :label "_File")
1119 ("edit" nil :label "_Edit")
1120 ("help" nil :label "_Help")
1121 ("quit" ,#'action-quit
1122 :stock-id "gtk-close"
1123 :tooltip "Close this window."
1124 :accelerator "<control>W")
1125 ("undo" ,#'action-undo
1126 :stock-id "gtk-undo"
1127 :tooltip "Take back the most recent move."
1129 :accelerator "<Control>Z")
1130 ("redo" ,#'action-redo
1131 :stock-id "gtk-redo"
1133 :tooltip "Revert an undone move."
1134 :accelerator "<Shift><Control>Z")
1135 ("about" ,#'action-about
1136 :tooltip "Show information about this game."
1137 :stock-id "gtk-about")
1138 ("new-game" ,#'action-new-game
1139 :label "_New game..."
1141 :tooltip "Start a new game."
1142 :accelerator "<control>N")))))
1144 (with-slots (game board player-list ui actions) window
1145 (setf actions (make-instance 'gtk:action-group
1147 :actions action-list)
1148 ui (make-instance 'gtk:ui-manager
1150 :action-group actions
1151 :ui '((:menubar "menu-bar"
1153 (:menuitem "new-game")
1159 (:menuitem "about")))
1161 (:toolitem "new-game")
1164 (:toolitem "redo")))))
1165 (gtk:window-add-accel-group window (gtk:ui-manager-accel-group ui))
1166 (setf (gtk:toolbar-show-arrow-p
1167 (gtk:ui-manager-get-widget ui "/toolbar")) nil)
1168 (dolist (name '("/menu-bar" "/toolbar"))
1169 (make-instance 'gtk:handle-box
1170 :child (gtk:ui-manager-get-widget ui name)
1171 :parent (list vbox :expand nil)))
1172 (gtk:signal-connect window :destroy #'destroyed :object t)
1173 (setf game (make-instance 'atom-game
1174 :grid (make-atoms-grid width height)
1175 :players (build-player-vector players))
1176 board (make-instance 'atoms-board :game game :parent aspect)
1177 player-list (make-instance 'player-list
1182 (add-dependent game window))))
1184 ;;;--------------------------------------------------------------------------
1187 (defvar *window* nil)
1189 (export 'start-atom-game)
1190 (defun start-atom-game (&rest initargs)
1192 (gtk:widget-destroy *window*)
1193 (setf *window* nil))
1194 (setf *window* (apply #'make-instance 'atom-game-window initargs))
1195 (gtk:widget-show-all *window*))
1198 (start-atom-game :width 7
1199 :players '("Alice" "Bob"))
1201 ;;;----- That's all, folks --------------------------------------------------