--- /dev/null
+;;; -*-lisp-*-
+;;;
+;;; Atoms game
+;;;
+;;; (c) 2007 Mark Wooding
+;;;
+
+;;;----- Licensing notice ---------------------------------------------------
+;;;
+;;; This program is free software; you can redistribute it and/or modify
+;;; it under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 2 of the License, or
+;;; (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;;; GNU General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software Foundation,
+;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+
+(cl:defpackage #:atoms
+ (:use #:cl
+ #+cmu #:ext
+ #+sbcl #:sb-ext
+ #+clisp #:ext)
+ #+clisp (:shadow #:map-dependents #:add-dependent #:remove-dependent)
+ (:export #:start-atom-game))
+(cl:in-package #:atoms)
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (asdf:operate 'asdf:load-op :gtk))
+
+(clg:clg-init)
+
+;;; Before we start, I should probably point out that the first version of
+;;; this program was written in Smalltalk, which may explain its slight
+;;; object-ravioli nature.
+
+;;;--------------------------------------------------------------------------
+;;; Dependent management.
+
+;; Protocol.
+
+(defgeneric notify (dependent model aspect &key &allow-other-keys)
+ (:method-combination progn)
+ (:method progn (dependent model aspect &rest arguments)
+ (declare (ignore arguments))
+ nil))
+
+(defgeneric map-dependents (model function))
+(defgeneric add-dependent (model dependent))
+(defgeneric remove-dependent (model dependent))
+
+(defgeneric changed (model &optional aspect &key &allow-other-keys)
+ (:method (model &optional aspect &rest arguments)
+ (map-dependents model
+ (lambda (dependent)
+ (apply #'notify dependent model aspect arguments)))))
+
+;; Generic implementation.
+
+(defclass model ()
+ ((dependents :type list :initform nil)))
+
+(defun clean-up-danglies (model)
+ (with-slots (dependents) model
+ (setf dependents
+ (delete-if-not (lambda (weak)
+ (nth-value 1 (weak-pointer-value weak)))
+ dependents))))
+
+(defmethod map-dependents ((model model) function)
+ (with-slots (dependents) model
+ (let ((danglies nil))
+ (dolist (dependent dependents)
+ (multiple-value-bind (object foundp)
+ (weak-pointer-value dependent)
+ (if foundp
+ (funcall function object)
+ (setf danglies t))))
+ (when danglies (clean-up-danglies model))
+ nil)))
+
+(defmethod add-dependent ((model model) dependent)
+ (let ((foundp (block nil
+ (map-dependents model
+ (lambda (dep)
+ (when (eql dependent dep)
+ (return t)))))))
+ (unless foundp
+ (push (make-weak-pointer dependent)
+ (slot-value model 'dependents)))))
+
+(defmethod remove-dependent ((model model) dependent)
+ (with-slots (dependents) model
+ (setf dependents (delete dependent dependents
+ :key #'weak-pointer-value))
+ (clean-up-danglies model)))
+
+;;;--------------------------------------------------------------------------
+;;; Undo and redo.
+
+(defclass undoable ()
+ ((undo-list :type list :reader undo-list :initform nil)
+ (redo-list :type list :reader redo-list :initform nil)))
+
+(defgeneric snapshot (object))
+(defgeneric restore (object snapshot))
+(defgeneric store-undo-snapshot (object snapshot))
+(defgeneric undo (object))
+(defgeneric redo (object))
+(defgeneric reset-undo-state (object))
+
+(defmethod store-undo-snapshot ((object undoable) snapshot)
+ (push snapshot (slot-value object 'undo-list))
+ (setf (slot-value object 'redo-list) nil))
+
+(defmacro with-undo-snapshot ((object) &body body)
+ (let ((snap (gensym "SNAPSHOT"))
+ (obj (gensym "OBJECT")))
+ `(let* ((,obj ,object)
+ (,snap (snapshot ,obj)))
+ (multiple-value-prog1 (progn ,@body)
+ (store-undo-snapshot ,obj ,snap)))))
+
+(defun undo-redo (object from to)
+ (let ((from-list (slot-value object from)))
+ (assert from-list)
+ (let ((undo-snap (car from-list))
+ (here-snap (snapshot object)))
+ (restore object undo-snap)
+ (push here-snap (slot-value object to))
+ (pop (slot-value object from)))))
+
+(defmethod undo ((object undoable))
+ (undo-redo object 'undo-list 'redo-list))
+
+(defmethod redo ((object undoable))
+ (undo-redo object 'redo-list 'undo-list))
+
+(defmethod reset-undo-state ((object undoable))
+ (setf (slot-value object 'undo-list) nil
+ (slot-value object 'redo-list) nil))
+
+(defclass undoable-model (undoable model)
+ ())
+
+(defmethod undo :after ((object undoable-model))
+ (changed object :undo))
+
+(defmethod redo :after ((object undoable-model))
+ (changed object :redo))
+
+;;;--------------------------------------------------------------------------
+;;; Main game logic.
+
+;; Protocol.
+
+(defclass atom-cell ()
+ ((owner :reader cell-owner :initform nil :type (or fixnum null))
+ (count :reader cell-count :initform 0 :type fixnum)
+ (pending :initform 0 :type fixnum)
+ (neighbours :reader cell-neighbours :type list :initform nil)
+ (x :reader cell-x :initarg :x :type fixnum)
+ (y :reader cell-y :initarg :y :type fixnum)))
+
+(defgeneric cell-played (cell player))
+(defgeneric cell-critical-p (cell))
+(defgeneric cell-explode (cell))
+(defgeneric cell-apply-pending-updates (cell))
+(defun cell-position (cell) (vector (cell-x cell) (cell-y cell)))
+
+(defun make-atoms-grid (width height)
+ (let ((grid (make-array (list height width) :element-type 'atom-cell)))
+ (dotimes (j height)
+ (dotimes (i width)
+ (setf (aref grid j i) (make-instance 'atom-cell :x i :y j))))
+ (dotimes (j height)
+ (dotimes (i width)
+ (setf (slot-value (aref grid j i) 'neighbours)
+ (nconc (and (> j 0) (list (aref grid (1- j) i)))
+ (and (> i 0) (list (aref grid j (1- i))))
+ (and (< i (1- width)) (list (aref grid j (1+ i))))
+ (and (< j (1- height)) (list (aref grid (1+ j) i)))))))
+ grid))
+
+(defclass player ()
+ ((name :accessor player-name :initarg :name :type string)
+ (score :accessor player-score :initform 0 :type fixnum)
+ (state :accessor player-state :initform :starting
+ :type (member :starting :playing :ready :losing :winning))
+ (colour :accessor player-colour :initarg :colour :type gdk:color)))
+
+(defclass human-player (player) ())
+
+(defgeneric player-cell-selected (game player i j)
+ (:method (game player i j) nil))
+(defgeneric player-turn-begin (game player)
+ (:method (game player) nil))
+
+(defclass atom-game (undoable-model)
+ ((grid :accessor game-grid :initarg :grid :type (array atom-cell (* *)))
+ (players :accessor game-players :initarg :players :type vector)
+ (player-index :accessor game-player-index :initform 0 :type fixnum)
+ (timeout-id :initform nil)))
+
+(defgeneric game-cell-selected (game i j))
+(defgeneric play-cell (game player i j))
+
+;; Implementation.
+
+(defmethod cell-played ((cell atom-cell) player)
+ (with-slots (owner count) cell
+ (cond ((zerop count) (setf owner player count 1) t)
+ ((eql owner player) (incf count) t)
+ (t nil))))
+
+(defmethod cell-critical-p ((cell atom-cell))
+ (with-slots (count neighbours) cell
+ (>= count (length neighbours))))
+
+(defmethod cell-explode ((cell atom-cell))
+ (with-slots (count neighbours owner pending) cell
+ (multiple-value-bind (spill left) (floor count (length neighbours))
+ (and (plusp spill)
+ (progn
+ (dolist (neighbour neighbours)
+ (incf (slot-value neighbour 'pending) spill)
+ (setf (slot-value neighbour 'owner) owner))
+ (setf count left)
+ (when (zerop left)
+ (setf owner nil))
+ (cons cell (copy-list neighbours)))))))
+
+(defmethod cell-apply-pending-updates ((cell atom-cell))
+ (with-slots (count pending) cell
+ (incf count pending)
+ (setf pending 0)))
+
+(deftype cell-snapshot () '(unsigned-byte 16))
+
+(defmethod snapshot ((cell atom-cell))
+ (with-slots (count owner) cell
+ (cond ((null owner) 0)
+ (t (assert (and (<= 0 count 255)
+ (<= 0 owner 255)))
+ (logior (ash owner 8)
+ (ash count 0))))))
+
+(defmethod restore ((cell atom-cell) (snapshot integer))
+ (declare (type cell-snapshot snapshot))
+ (with-slots (count owner) cell
+ (setf (values count owner)
+ (if (zerop snapshot)
+ (values 0 nil)
+ (values (ldb (byte 8 0) snapshot)
+ (ldb (byte 8 8) snapshot))))))
+
+(defmethod player-cell-selected (game (player human-player) i j)
+ (and (eql (player-state player) :ready)
+ (play-cell game player i j)))
+
+(defmethod snapshot ((player player))
+ (list (player-score player) (player-state player)))
+
+(defmethod restore ((player player) (list list))
+ (destructuring-bind (score state) list
+ (setf (player-score player) score
+ (player-state player) state)))
+
+(defmethod game-update-scores (game)
+ (let ((players (game-players game))
+ (grid (game-grid game)))
+ (dotimes (i (length players))
+ (setf (player-score (aref players i)) 0))
+ (dotimes (i (array-total-size grid))
+ (let* ((cell (row-major-aref grid i))
+ (owner (cell-owner cell))
+ (player (and owner (aref players owner)))
+ (count (cell-count cell)))
+ (when (and player (plusp count))
+ (incf (player-score player) count))))
+ (let ((remaining 0) (found nil))
+ (dotimes (i (length players))
+ (let* ((player (aref players i))
+ (score (player-score player))
+ (state (player-state player)))
+ (cond ((and (zerop score) (eql state :playing))
+ (setf (player-state player) :losing))
+ ((member state '(:playing :starting))
+ (incf remaining)
+ (setf found player)))))
+ (changed game :scores :players players)
+ (when (= remaining 1)
+ (setf (player-state found) :winning)
+ (changed game :finished :victor found)))))
+
+(defmethod game-next-player (game)
+ (let ((players (game-players game))
+ (player-index (game-player-index game)))
+ (dotimes (i (length players))
+ (let* ((j (mod (+ player-index i 1) (length players)))
+ (player (aref players j)))
+ (when (member (player-state player) '(:starting :playing))
+ (setf (game-player-index game) j
+ (player-state player) :ready)
+ (player-turn-begin game player)
+ (changed game :start-turn :player player)
+ (return))))))
+
+(defvar *cells-remaining* nil)
+
+(defun perform-pending-explosions (game cells)
+ (let ((affected (delete-duplicates
+ (mapcan #'cell-explode cells))))
+ (mapc #'cell-apply-pending-updates affected)
+ (perform-explosions game affected)))
+
+(defvar *explosion-time* 100)
+
+(defun perform-explosions (game cells)
+ (game-update-scores game)
+ (changed game :cell-update :cells cells)
+ (let ((critical (delete-if-not #'cell-critical-p cells)))
+ (setf *cells-remaining* critical)
+ (cond ((null critical) (game-next-player game) t)
+ (t (with-slots (timeout-id) game
+ (setf timeout-id (glib:timeout-add
+ *explosion-time*
+ (lambda ()
+ (setf timeout-id nil)
+ (perform-pending-explosions game critical)
+ nil))))))
+ t))
+
+(defun game-cancel-timeout (game)
+ (with-slots (timeout-id) game
+ (when timeout-id
+ (glib:source-remove timeout-id)
+ (setf timeout-id nil))))
+
+(defmethod game-player ((game atom-game))
+ (aref (game-players game) (game-player-index game)))
+
+(defmethod game-cell-selected ((game atom-game) i j)
+ (player-cell-selected game (game-player game) i j))
+
+(defmethod initialize-instance :after ((game atom-game) &key)
+ (setf (player-state (game-player game)) :ready))
+
+(defmethod play-cell ((game atom-game) player i j)
+ (with-slots (grid players player-index) game
+ (assert (and (<= 0 i) (< i (array-dimension grid 1))
+ (<= 0 j) (< j (array-dimension grid 0))))
+ (let ((cell (aref grid j i))
+ (player (aref players player-index)))
+ (block escape
+ (with-undo-snapshot (game)
+ (unless (cell-played cell player-index)
+ (return-from escape))
+ (setf (player-state player) :playing)
+ (perform-explosions game (list cell)))
+ (changed game :processing-move)))))
+
+(defmethod restart-game ((game atom-game) &key grid players)
+ (game-cancel-timeout game)
+ (setf (game-grid game)
+ (or grid
+ (let ((old (game-grid game)))
+ (make-atoms-grid (array-dimension old 1)
+ (array-dimension old 0)))))
+ (if players
+ (setf (game-players game) players)
+ (setf players (game-players game)))
+ (reset-undo-state game)
+ (dotimes (i (length players))
+ (let ((player (aref players i)))
+ (setf (player-score player) 0
+ (player-state player) (if (zerop i) :ready :starting))))
+ (setf (game-player-index game) 0)
+ (changed game :refresh))
+
+;;;--------------------------------------------------------------------------
+;;; Snapshots and undo.
+
+(defclass atom-game-snapshot ()
+ ((grid :type (array cell-snapshot (* *)) :initarg :grid)
+ (players :type list :initarg :players)
+ (player-index :type fixnum :initarg :player-index)))
+
+(defmethod snapshot ((game atom-game))
+ (let* ((grid (game-grid game))
+ (grid-snapshot (make-array (array-dimensions grid)
+ :element-type 'cell-snapshot
+ :initial-element 0)))
+ (dotimes (i (array-total-size grid))
+ (setf (row-major-aref grid-snapshot i)
+ (snapshot (row-major-aref grid i))))
+ (make-instance 'atom-game-snapshot
+ :players (map 'list #'snapshot (game-players game))
+ :player-index (game-player-index game)
+ :grid grid-snapshot)))
+
+(defmethod restore ((game atom-game) (snapshot atom-game-snapshot))
+ (let ((snap-grid (slot-value snapshot 'grid))
+ (snap-players (slot-value snapshot 'players))
+ (grid (game-grid game))
+ (players (game-players game)))
+ (dotimes (i (array-total-size grid))
+ (restore (row-major-aref grid i)
+ (row-major-aref snap-grid i)))
+ (loop for player across players
+ for snap-player in snap-players
+ do (restore player snap-player))
+ (setf (game-player-index game) (slot-value snapshot 'player-index))
+ (changed game :refresh)))
+
+;;;--------------------------------------------------------------------------
+;;; The interactive board.
+
+(defclass atoms-board (gtk:drawing-area)
+ ((game :accessor board-game :initarg :game :type atom-game)
+ (cache :initform nil :accessor board-cache))
+ (:metaclass glib:gobject-class))
+
+(defmethod board-grid ((board atoms-board))
+ (game-grid (board-game board)))
+
+(defgeneric paint (widget event))
+
+(defun paint-atoms (cr count colour)
+ (let* ((centrep (and (oddp count) (/= count 3)))
+ (surround (if centrep (1- count) count))
+ (angle (and (plusp surround) (/ (* 2 pi) surround)))
+ (theta (case count
+ ((0 1 2 3) (/ pi 2))
+ (t (/ (- pi angle) 2))))
+ (radius 0.15)
+ (sep (cond ((and centrep (<= surround 6)) (* 2 radius))
+ ((<= surround 2) radius)
+ (t (/ radius (sin (/ angle 2)))))))
+ (when centrep
+ (cairo:new-sub-path cr)
+ (cairo:arc cr 0 0 radius 0 (* 2 pi)))
+ (dotimes (i surround)
+ (cairo:new-sub-path cr)
+ (cairo:arc cr
+ (* sep (cos theta))
+ (- (* sep (sin theta)))
+ radius
+ 0
+ (* 2 pi))
+ (incf theta angle))
+ (gdk:cairo-set-source-color cr (gdk:ensure-color colour))
+ (cairo:fill cr t)
+ (setf (cairo:line-width cr)
+ (max 0.02 (cairo:device-to-user-distance cr 1)))
+ (cairo:set-source-color cr 0 0 0)
+ (cairo:stroke cr nil)))
+
+(defparameter cache-limit 8)
+
+(defun make-cached-atom-surfaces (board colour)
+ (multiple-value-bind (width height) (gtk:widget-get-size-allocation board)
+ (let* ((vector (make-array cache-limit))
+ (grid (board-grid board))
+ (surface-width (floor width (array-dimension grid 1)))
+ (surface-height (floor height (array-dimension grid 0))))
+ (dotimes (i (length vector))
+ (let* ((surface (make-instance 'cairo:image-surface
+ :width surface-width
+ :height surface-height
+ :format :argb32))
+ (cr (make-instance 'cairo:context :target surface)))
+ (cairo:scale cr surface-width surface-height)
+ (cairo:translate cr 0.5 0.5)
+ (paint-atoms cr (1+ i) colour)
+ (setf (aref vector i) surface)))
+ vector)))
+
+(defun cached-atom-surface (board count colour)
+ (let ((cache (board-cache board)))
+ (unless cache
+ (setf cache (make-hash-table)
+ (board-cache board) cache))
+ (let ((vector (gethash colour cache)))
+ (unless vector
+ (setf vector (make-cached-atom-surfaces board colour)
+ (gethash colour cache) vector))
+ (and (< 0 count) (<= count (length vector))
+ (aref vector (1- count))))))
+
+(defmethod paint ((widget atoms-board) event)
+ (multiple-value-bind (width height) (gtk:widget-get-size-allocation widget)
+ (let* ((style (gtk:widget-style widget))
+ (grid (board-grid widget))
+ (vsq (array-dimension grid 0))
+ (hsq (array-dimension grid 1))
+ (game (board-game widget))
+ (players (game-players game))
+ lo-hsq hi-hsq lo-vsq hi-vsq
+ (display (gtk:widget-get-display widget))
+ (region (make-instance 'gdk:region))
+ (redraw-map (make-array (list vsq hsq)
+ :element-type 'bit
+ :initial-element 0)))
+
+ (loop (let* ((loh (floor (* (gdk:event-x event) hsq) width))
+ (hih (ceiling (* (+ (gdk:event-x event)
+ (gdk:event-width event))
+ hsq)
+ width))
+ (lov (floor (* (gdk:event-y event) vsq) height))
+ (hiv (ceiling (* (+ (gdk:event-y event)
+ (gdk:event-height event))
+ vsq)
+ height)))
+ (gdk:region-union region
+ (vector (gdk:event-x event)
+ (gdk:event-y event)
+ (gdk:event-width event)
+ (gdk:event-height event)))
+ (when (or (null lo-hsq) (< loh lo-hsq)) (setf lo-hsq loh))
+ (when (or (null hi-hsq) (< hih hi-vsq)) (setf hi-hsq hih))
+ (when (or (null lo-vsq) (< lov lo-hsq)) (setf lo-vsq lov))
+ (when (or (null hi-vsq) (< hiv hi-vsq)) (setf hi-vsq hiv))
+ (do ((j lov (1+ j))) ((>= j hiv))
+ (do ((i loh (1+ i))) ((>= i hih))
+ (setf (bit redraw-map j i) 1)))
+ (when (zerop (gdk:event-count event))
+ (return))
+ (setf event (gdk:display-get-event display))))
+
+ (gdk:with-cairo-context (cr (gtk:widget-window widget))
+ (cairo:reset-clip cr)
+ (gdk:cairo-region cr region)
+ (cairo:clip cr)
+ (cairo:with-context (cr)
+ (gdk:cairo-set-source-color cr (gtk:style-fg style :normal))
+ (cairo:translate cr 1/2 1/2)
+ (setf (cairo:line-width cr) 1
+ (cairo:antialias cr) :none)
+ (let ((h (1- height)) (w (1- width)))
+ (do ((j lo-vsq (1+ j))) ((> j hi-vsq))
+ (let ((y (round (* j h) vsq)))
+ (cairo:move-to cr 0 y)
+ (cairo:line-to cr w y)))
+ (do ((i lo-hsq (1+ i))) ((> i hi-hsq))
+ (let ((x (round (* i w) hsq)))
+ (cairo:move-to cr x 0)
+ (cairo:line-to cr x h))))
+ (cairo:stroke cr))
+ (do ((j lo-vsq (1+ j))) ((>= j hi-vsq))
+ (do ((i lo-hsq (1+ i))) ((>= i hi-hsq))
+ (when (plusp (bit redraw-map j i))
+ (let* ((cell (aref grid j i))
+ (count (cell-count cell))
+ (colour (and (plusp count) (cell-owner cell)
+ (player-colour
+ (aref players
+ (cell-owner cell)))))
+ (surface (and colour
+ (cached-atom-surface widget
+ count colour))))
+ (cond ((or (zerop count) (null (cell-owner cell)))
+ nil)
+ ((null surface)
+ (cairo:with-context (cr)
+ (cairo:scale cr (/ width hsq) (/ height vsq))
+ (cairo:translate cr (+ i 0.5) (+ j 0.5))
+ (paint-atoms cr count colour)))
+ (t
+ (cairo:set-source-surface cr surface
+ (round (* i width) hsq)
+ (round (* j height) vsq))
+ (cairo:paint cr)))))))))))
+
+(defun board-set-size-request (board)
+ (when (slot-boundp board 'game)
+ (let ((grid (board-grid board)))
+ (gtk:widget-set-size-request board
+ (* 50 (array-dimension grid 1))
+ (* 50 (array-dimension grid 0))))))
+
+(defmethod (setf board-game) :before (game (board atoms-board))
+ (when (slot-boundp board 'game)
+ (remove-dependent (board-game board) board)))
+
+(defmethod (setf board-game) :after (game (board atoms-board))
+ (board-set-size-request board)
+ (add-dependent game board))
+
+(defmethod resized ((board atoms-board) allocation)
+ (setf (board-cache board) nil)
+ nil)
+
+(defmethod notify progn
+ ((board atoms-board) (game atom-game) (aspect (eql :cell-update))
+ &key cells)
+ (unless (slot-boundp board 'gtk:window) (return-from notify))
+ (multiple-value-bind (width height) (gtk:widget-get-size-allocation board)
+ (let* ((region (make-instance 'gdk:region))
+ (grid (board-grid board))
+ (hsq (array-dimension grid 1))
+ (vsq (array-dimension grid 0)))
+ (dolist (cell cells)
+ (gdk:region-union region
+ (vector (floor (* (cell-x cell) width) hsq)
+ (floor (* (cell-y cell) height) vsq)
+ (ceiling width hsq)
+ (ceiling height vsq))))
+ (gdk:window-invalidate-region (gtk:widget-window board) region nil))))
+
+(defmethod notify progn
+ ((board atoms-board) (game atom-game) (aspect (eql :refresh)) &key)
+ (board-set-size-request board)
+ (setf (board-cache board) nil)
+ (gtk:widget-queue-draw board))
+
+(defmethod button-press ((widget atoms-board) event)
+ (case (gdk:event-class-type (class-of event))
+ (:button-press
+ (case (gdk:event-button event)
+ (1 (multiple-value-bind (width height)
+ (gtk:widget-get-size-allocation widget)
+ (let* ((grid (board-grid widget))
+ (x (floor (* (gdk:event-x event) (array-dimension grid 1))
+ width))
+ (y (floor (* (gdk:event-y event) (array-dimension grid 0))
+ height)))
+ (game-cell-selected (board-game widget) x y)
+ t)))))))
+
+(defmethod initialize-instance :after ((board atoms-board) &key)
+ (gtk:signal-connect board :expose-event #'paint :object t)
+ (setf (gtk:widget-events board) (list :button-press))
+ (gtk:signal-connect board :button-press-event #'button-press :object t)
+ (gtk:signal-connect board :size-allocate #'resized :object t)
+ (when (slot-boundp board 'game) (add-dependent (board-game board) board))
+ (board-set-size-request board))
+
+;;;--------------------------------------------------------------------------
+;;; Tree view utilities.
+
+(defun add-tree-view-column (view title &rest args)
+ (let ((column (apply #'make-instance
+ 'gtk:tree-view-column
+ :title title
+ args)))
+ (gtk:tree-view-append-column view column)
+ column))
+
+(defun add-cell-renderer
+ (view column attrs
+ &key (type 'gtk:cell-renderer-text) pack-args renderer-args)
+ (let ((renderer (apply #'make-instance type renderer-args))
+ (store (gtk:tree-view-model view)))
+ (apply #'gtk:cell-layout-pack column renderer pack-args)
+ (loop for (attribute col-name) on attrs by #'cddr
+ do (gtk:cell-layout-add-attribute
+ column renderer attribute
+ (gtk:tree-model-column-index store col-name)))
+ renderer))
+
+;;;--------------------------------------------------------------------------
+;;; The player list.
+
+(defvar *player-list*)
+(defvar *player-list-view*)
+
+(defclass player-list (gtk:tree-view)
+ ((store :initform (make-instance
+ 'gtk:list-store
+ :column-names '(colour name score state)
+ :column-types '(gdk:color string integer string))
+ :type gtk:list-store)
+ (game :initarg :game :type atom-game))
+ (:metaclass glib:gobject-class))
+
+(defun update-player-list (list game)
+ (let ((store (slot-value list 'store))
+ (players (game-players game)))
+ (gtk:list-store-clear store)
+ (loop for player across players
+ for i from 0
+ do (gtk:list-store-append store
+ (vector (player-colour player)
+ (player-name player)
+ (player-score player)
+ (case (player-state player)
+ (:losing "out")
+ (:winning "winner!")
+ (:ready "<<<")
+ (t "")))))))
+
+(defmethod initialize-instance :after ((list player-list) &key)
+ (let ((store (slot-value list 'store)))
+ (setf (gtk:tree-view-model list) store)
+ (flet ((add-column (&rest args)
+ (apply #'add-tree-view-column list args))
+ (add-renderer (&rest args)
+ (apply #'add-cell-renderer list args)))
+ (add-renderer (add-column ""
+ :expand nil
+ :sizing :fixed
+ :fixed-width 20)
+ '(:cell-background-gdk colour)
+ :renderer-args '(:cell-background-set t))
+ (add-renderer (add-column "Name" :resizable t :expand t) '(:text name))
+ (add-renderer (add-column "Score" :resizable t) '(:text score))
+ (add-renderer (add-column "State" :resizable t) '(:text state)))
+ (setf (gtk:tree-selection-mode (gtk:tree-view-selection list)) :none)
+ (when (slot-boundp list 'game)
+ (with-slots (game) list
+ (add-dependent game list)
+ (update-player-list list game)))))
+
+(defmethod notify progn ((list player-list) (game atom-game) aspect &key)
+ (case aspect
+ ((:cell-update :start-turn :refresh)
+ (update-player-list list game))))
+
+;;;--------------------------------------------------------------------------
+;;; New game dialogue.
+
+(defparameter *player-colours*
+ (vector "red" "blue" "green" "orange" "magenta" "white" "black"))
+
+(defclass new-game-dialogue (gtk:dialog)
+ ((game :initarg :game :type atom-game)
+ (width-adjustment :type gtk:adjustment
+ :initform (make-instance 'gtk:adjustment
+ :lower 1 :upper 99
+ :step-increment 1))
+ (height-adjustment :type gtk:adjustment
+ :initform (make-instance 'gtk:adjustment
+ :lower 1 :upper 99
+ :step-increment 1))
+ (count-adjustment :type gtk:adjustment
+ :initform (make-instance 'gtk:adjustment
+ :lower 2 :upper 20
+ :step-increment 1))
+ (players :type gtk:list-store
+ :initform (make-instance 'gtk:list-store
+ :column-types '(gdk:color string)
+ :column-names '(colour name))))
+ (:default-initargs
+ :title "New game"
+ :default-height 360
+ :has-separator nil)
+ (:metaclass glib:gobject-class))
+
+(defun choose-player-colour (window path)
+ (let* ((players (slot-value window 'players))
+ (colour-dialogue (make-instance 'gtk:color-selection-dialog))
+ (coloursel (gtk:color-selection-dialog-colorsel colour-dialogue))
+ (colour (gtk:tree-model-value players path 'colour)))
+ (unwind-protect
+ (progn
+ (setf (gtk:color-selection-current-color coloursel) colour
+ (gtk:color-selection-previous-color coloursel) colour)
+ (case (gtk:dialog-run colour-dialogue)
+ (:ok (setf (gtk:tree-model-value players path 'colour)
+ (gtk:color-selection-current-color coloursel)))))
+ (gtk:widget-destroy colour-dialogue))))
+
+(defun insert-or-remove-players (window)
+ (let* ((players (slot-value window 'players))
+ (current-count (gtk:tree-model-iter-n-children players))
+ (new-count (floor (gtk:adjustment-value
+ (slot-value window 'count-adjustment)))))
+ (if (> current-count new-count)
+ (let ((iter (make-instance 'gtk:tree-iter)))
+ (gtk:tree-model-get-iter players (vector new-count) iter)
+ (dotimes (i (- current-count new-count))
+ (gtk:list-store-remove players iter)))
+ (loop with iter = (make-instance 'gtk:tree-iter)
+ for i from current-count below new-count
+ for colour = (if (< i (length *player-colours*))
+ (gdk:color-parse (aref *player-colours* i))
+ (make-instance 'gdk:color
+ :red (random 1.0)
+ :green (random 1.0)
+ :blue (random 1.0)))
+ for name = (format nil "Player ~A" (1+ i))
+ do (gtk:list-store-append players
+ (vector colour name)
+ iter)))))
+
+(defun start-new-game (window)
+ (with-slots (game width-adjustment height-adjustment players) window
+ (let ((grid (make-atoms-grid
+ (floor (gtk:adjustment-value width-adjustment))
+ (floor (gtk:adjustment-value height-adjustment))))
+ (new-players (let ((iter (make-instance 'gtk:tree-iter)))
+ (gtk:tree-model-get-iter players #(0) iter)
+ (loop for row = (gtk:tree-model-row-data players
+ iter)
+ collect (make-instance 'human-player
+ :colour (aref row 0)
+ :name (aref row 1))
+ while (gtk:tree-model-iter-next players
+ iter)))))
+ (restart-game game :grid grid :players (coerce new-players 'vector))
+ (gtk:widget-destroy window))))
+
+(defmethod initialize-instance :after ((window new-game-dialogue) &key)
+ (with-slots (width-adjustment height-adjustment count-adjustment players)
+ window
+ (let* ((game (slot-value window 'game))
+ (grid (game-grid game)))
+
+ (setf (gtk:container-border-width window) 4)
+ (gtk:dialog-add-button window "gtk-cancel"
+ #'gtk:widget-destroy :object t)
+ (gtk:dialog-add-button window "gtk-ok"
+ (lambda () (start-new-game window))
+ :default t)
+
+ (setf (gtk:adjustment-value width-adjustment)
+ (array-dimension grid 1)
+ (gtk:adjustment-value height-adjustment)
+ (array-dimension grid 0)
+ (gtk:adjustment-value count-adjustment)
+ (length (game-players game)))
+
+ (let* ((frame (make-instance 'gtk:frame :label "Board size"))
+ (table (make-instance 'gtk:table
+ :parent frame
+ :border-width 4
+ :n-columns 2 :n-rows 2
+ :row-spacing 4 :column-spacing 4)))
+ (loop for row from 0
+ for (adj-slot label) on '(width-adjustment "Width"
+ height-adjustment "Height") by #'cddr
+ do (make-instance 'gtk:label
+ :label label
+ :xalign 1
+ :parent (list table
+ :top-attach row
+ :bottom-attach (1+ row)
+ :left-attach 0
+ :right-attach 1
+ :x-options '(:fill)))
+ do (make-instance 'gtk:spin-button
+ :numeric t
+ :width-chars 2
+ :adjustment (slot-value window adj-slot)
+ :xalign 1
+ :activates-default t
+ :parent (list table
+ :top-attach row
+ :bottom-attach (1+ row)
+ :left-attach 1
+ :right-attach 2
+ :x-options '(:expand :fill))))
+ (gtk:container-add window frame :fill nil :expand nil)
+ (gtk:widget-show-all frame))
+
+ (let* ((frame (make-instance 'gtk:frame :label "Players"))
+ (vbox (make-instance 'gtk:v-box
+ :parent frame :spacing 4
+ :border-width 4))
+ (view (make-instance 'gtk:tree-view
+ :model players)))
+ (make-instance 'gtk:h-box
+ :spacing 4
+ :parent (list vbox :expand nil :fill nil)
+ :child (list (make-instance 'gtk:label
+ :label "Number of players"
+ :xalign 1)
+ :expand nil :fill nil)
+ :child (list (make-instance 'gtk:spin-button
+ :adjustment
+ count-adjustment
+ :numeric t
+ :width-chars 2
+ :activates-default t
+ :xalign 1)
+ :expand t :fill t))
+ (make-instance 'gtk:scrolled-window
+ :hscrollbar-policy :automatic
+ :vscrollbar-policy :automatic
+ :shadow-type :in
+ :child view
+ :parent vbox)
+ (add-cell-renderer view
+ (add-tree-view-column view ""
+ :sizing :fixed
+ :fixed-width 20)
+ (list :cell-background-gdk 'colour)
+ :renderer-args '(:cell-background-set t))
+ (let ((renderer (add-cell-renderer view
+ (add-tree-view-column view "Name")
+ (list :text 'name)
+ :renderer-args '(:editable t))))
+ (gtk:signal-connect renderer :edited
+ (lambda (path new-text)
+ (setf (gtk:tree-model-value
+ players
+ path
+ 'name)
+ new-text))))
+ (gtk:signal-connect view :row-activated
+ (lambda (path column)
+ (when (eql (position column
+ (gtk:tree-view-columns
+ view))
+ 0)
+ (choose-player-colour window path))))
+ (loop for player across (game-players game)
+ do (gtk:list-store-append players
+ (vector (player-colour player)
+ (player-name player))))
+ (gtk:signal-connect count-adjustment
+ :value-changed
+ #'insert-or-remove-players :args (list window))
+ (gtk:container-add window frame :fill t :expand t)
+ (gtk:widget-show-all frame)))))
+
+;;;--------------------------------------------------------------------------
+;;; About this program.
+
+(defparameter atoms-logo-pixbuf
+ (gdk:pixbuf-load #p"/home/mdw/src/atoms/atoms.png"))
+
+(defparameter licence-text
+ (format nil
+ "This program is free software; you can redistribute it and/or modify ~
+ it under the terms of the GNU General Public License as published by ~
+ the Free Software Foundation; either version 2 of the License, or ~
+ (at your option) any later version.~2%~
+ ~
+ This program is distributed in the hope that it will be useful, ~
+ but WITHOUT ANY WARRANTY; without even the implied warranty of ~
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ~
+ GNU General Public License for more details.~2%~
+ ~
+ You should have received a copy of the GNU General Public License ~
+ along with this program; if not, write to the Free Software Foundation, ~
+ Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA."))
+
+(let ((about nil))
+ (defun action-about (window)
+ (declare (ignore window))
+ (unless about
+ (setf about (make-instance
+ 'gtk:about-dialog
+ :name "Atoms"
+ :version "1.0.0"
+ :copyright "Copyright (c) 2007 Mark Wooding"
+ :website "http://www.distorted.org.uk/"
+ :website-label "Homepage"
+ :authors (list "Mark Wooding <mdw@distorted.org.uk>")
+ :comments "May contain trace quantities of Lisp."
+ :license licence-text
+ :wrap-license t
+ :logo atoms-logo-pixbuf
+ :signal (list :destroy (lambda () (setf about nil)))
+ :signal (list :cancel (lambda ()
+ (gtk:widget-destroy about))))))
+ (gtk:window-present about)))
+
+;;;--------------------------------------------------------------------------
+;;; Application window.
+
+(defclass atom-game-window (gtk:window)
+ ((game :type atom-game)
+ (board :type atoms-board)
+ (player-list :type player-list)
+ (actions :type gtk:action-group)
+ (ui :type gtk:ui-manager)
+ (new-game :type (or new-game-dialogue null) :initform nil))
+ (:default-initargs :title "Atoms game" :allow-shrink t :show-children t)
+ (:metaclass glib:gobject-class))
+
+(defun action-quit (window)
+ (gtk:widget-destroy window))
+
+(defun action-new-game (window)
+ (with-slots (new-game game) window
+ (if new-game
+ (gtk:window-present new-game)
+ (progn
+ (setf new-game (make-instance 'new-game-dialogue
+ :game game
+ :transient-for window))
+ (gtk:widget-show-all new-game)
+ (gtk:signal-connect new-game :destroy
+ (lambda () (setf new-game nil)))))))
+
+(defun update-undo-redo-sensitivity (window)
+ (with-slots (actions game) window
+ (setf (gtk:action-sensitive-p
+ (gtk:action-group-get-action actions "undo"))
+ (undo-list game)
+ (gtk:action-sensitive-p
+ (gtk:action-group-get-action actions "redo"))
+ (redo-list game))))
+
+(defmethod notify progn
+ ((window atom-game-window) (game atom-game) aspect &key)
+ (case aspect
+ ((:undo :redo :refresh :processing-move)
+ (update-undo-redo-sensitivity window))))
+
+(defun action-undo (window)
+ (undo (slot-value window 'game)))
+
+(defun action-redo (window)
+ (redo (slot-value window 'game)))
+
+(defmethod destroyed ((window atom-game-window))
+ (with-slots (new-game) window
+ (when new-game (gtk:widget-destroy new-game))))
+
+(defun build-player-vector (player-spec)
+ (flet ((make-player (spec i)
+ (etypecase spec
+ (player spec)
+ ((or string list)
+ (destructuring-bind
+ (name &key colour)
+ (if (listp spec) spec (list spec))
+ (cond (colour)
+ ((< i (length *player-colours*))
+ (setf colour (aref *player-colours* i)))
+ (t (setf colour
+ (make-instance 'gdk:color
+ :red (random 1.0)
+ :green (random 1.0)
+ :blue (random 1.0)))))
+ (make-instance 'human-player
+ :name name
+ :colour (gdk:ensure-color colour)))))))
+ (let ((i 0))
+ (map 'vector
+ (lambda (spec)
+ (make-player spec (prog1 i (incf i))))
+ (etypecase player-spec
+ (sequence player-spec)
+ ((or integer null)
+ (loop for i from 1 upto (or player-spec 4)
+ collect (format nil "Player ~A" i))))))))
+
+(defmethod shared-initialize :after
+ ((window atom-game-window) slot-names
+ &key
+ (width 7) (height width) players)
+ (declare (ignore slot-names))
+ (let* ((vbox (make-instance 'gtk:v-box :parent window))
+ (paned (make-instance 'gtk:h-paned
+ :parent (list vbox :pack-type :end)))
+ (aspect (make-instance 'gtk:aspect-frame
+ :parent (list paned :resize t :shrink t)
+ :obey-child t
+ :frame :none
+ :shadow-type :none))
+ (scrolled (make-instance 'gtk:scrolled-window
+ :parent (list paned :resize nil :shrink t)
+ :shadow-type :in
+ :hscrollbar-policy :automatic
+ :vscrollbar-policy :automatic))
+ (action-list (mapcar (lambda (item)
+ (destructuring-bind
+ (name callback &rest args) item
+ (apply #'make-instance 'gtk:action
+ :name name
+ :callback
+ (and callback
+ (list callback
+ :args (list window)))
+ args)))
+ `(("file" nil :label "_File")
+ ("edit" nil :label "_Edit")
+ ("help" nil :label "_Help")
+ ("quit" ,#'action-quit
+ :stock-id "gtk-close"
+ :tooltip "Close this window."
+ :accelerator "<control>W")
+ ("undo" ,#'action-undo
+ :stock-id "gtk-undo"
+ :tooltip "Take back the most recent move."
+ :sensitive nil
+ :accelerator "<Control>Z")
+ ("redo" ,#'action-redo
+ :stock-id "gtk-redo"
+ :sensitive nil
+ :tooltip "Revert an undone move."
+ :accelerator "<Shift><Control>Z")
+ ("about" ,#'action-about
+ :tooltip "Show information about this game."
+ :stock-id "gtk-about")
+ ("new-game" ,#'action-new-game
+ :label "_New game..."
+ :stock-id "gtk-new"
+ :tooltip "Start a new game."
+ :accelerator "<control>N")))))
+
+ (with-slots (game board player-list ui actions) window
+ (setf actions (make-instance 'gtk:action-group
+ :name "actions"
+ :actions action-list)
+ ui (make-instance 'gtk:ui-manager
+ :add-tearoffs t
+ :action-group actions
+ :ui '((:menubar "menu-bar"
+ (:menu "file"
+ (:menuitem "new-game")
+ (:menuitem "quit"))
+ (:menu "edit"
+ (:menuitem "undo")
+ (:menuitem "redo"))
+ (:menu "help"
+ (:menuitem "about")))
+ (:toolbar "toolbar"
+ (:toolitem "new-game")
+ :separator
+ (:toolitem "undo")
+ (:toolitem "redo")))))
+ (gtk:window-add-accel-group window (gtk:ui-manager-accel-group ui))
+ (setf (gtk:toolbar-show-arrow-p
+ (gtk:ui-manager-get-widget ui "/toolbar")) nil)
+ (dolist (name '("/menu-bar" "/toolbar"))
+ (make-instance 'gtk:handle-box
+ :child (gtk:ui-manager-get-widget ui name)
+ :parent (list vbox :expand nil)))
+ (gtk:signal-connect window :destroy #'destroyed :object t)
+ (setf game (make-instance 'atom-game
+ :grid (make-atoms-grid width height)
+ :players (build-player-vector players))
+ board (make-instance 'atoms-board :game game :parent aspect)
+ player-list (make-instance 'player-list
+ :game game
+ :width-request 160
+ :parent scrolled))
+
+ (add-dependent game window))))
+
+;;;--------------------------------------------------------------------------
+;;; Useful things.
+
+(defvar *window* nil)
+
+(defun start-atom-game (&rest initargs)
+ (when *window*
+ (gtk:widget-destroy *window*)
+ (setf *window* nil))
+ (setf *window* (apply #'make-instance 'atom-game-window initargs))
+ (gtk:widget-show-all *window*))
+
+(start-atom-game :width 7 :players (list "Mark" "Vicky"))
+
+;;;----- That's all, folks --------------------------------------------------
~mdw / atoms / commitdiff
