[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))
(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)))

(defun player-type-name (symbol)
  (get symbol 'player-type-name))
(defun (setf player-type-name) (name symbol)
  (setf (get symbol 'player-type-name) name))

(defclass human-player (player) ())
(setf (player-type-name 'human-player) "Human")

(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 :ready))
		 (incf remaining)
		 (setf found player)))))
      (changed game :scores :players players)
      (when (and (= remaining 1) (>= (length players) 2))
	(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)
	  (changed game :processing-move))
	(perform-explosions game (list cell))))))

(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))
    (game-cancel-timeout game)
    (changed game :refresh)
    (let ((critical-cells (loop for i below (array-total-size grid)
				for cell = (row-major-aref grid i)
				if (cell-critical-p cell)
				collect cell)))
      (when critical-cells (perform-explosions game critical-cells)))))

;;;--------------------------------------------------------------------------
;;; 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"))

(defparameter *player-types* '(human-player))

(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 1 :upper 20
					      :step-increment 1))
   (players :type gtk:list-store
	    :initform (make-instance 'gtk:list-store
				     :column-types '(gdk:color string string)
				     :column-names '(colour name type))))
  (: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
					(find (aref row 2)
					      *player-types*
					      :test #'string=
					      :key #'player-type-name)
					: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* ((model (make-instance 'gtk:list-store
				     :column-types '(string)
				     :column-names '(type)
				     :initial-content
				     (mapcar (lambda (type)
					       (vector
						(player-type-name type)))
					     *player-types*)))
	       (renderer (add-cell-renderer
			  view
			  (add-tree-view-column view "Type")
			  (list :text 'type)
			  :type 'gtk:cell-renderer-combo
			  :renderer-args (list :model model
					       :text-column 0
					       :has-entry nil
					       :editable t))))
	  (gtk:signal-connect renderer :changed
			      (lambda (path new-iter)
				(setf (gtk:tree-model-value
				       players path 'type)
				      (gtk:tree-model-value
				       model new-iter 'type)))))
	(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)
			  (player-type-name (class-name
					     (class-of 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
    (flet ((set-sensitive (act-name sensitivep)
	     (let ((act (gtk:action-group-get-action actions act-name)))
	       (setf (gtk:action-sensitive-p act) sensitivep))))
      (set-sensitive "undo" (undo-list game))
      (set-sensitive "redo" (redo-list game)))))

(defmethod notify progn
    ((window atom-game-window) (game atom-game) aspect &key)
  (case aspect
    ((:undo :redo :refresh :start-turn)
     (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 (type 'human-player))
		      (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 type
				   :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)

(export 'start-atom-game)
(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*))

#+debug
(start-atom-game :width 7
		 :players '("Alice" "Bob"))

;;;----- That's all, folks --------------------------------------------------