Initial commit.

[atoms] / atoms.lisp

;;; -*-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 --------------------------------------------------