#+cmu #:ext
#+sbcl #:sb-ext
#+clisp #:ext)
- #+clisp (:shadow #:map-dependents #:add-dependent #:remove-dependent)
- (:export #:start-atom-game))
+ #+clisp (:shadow #:map-dependents #:add-dependent #:remove-dependent))
(cl:in-package #:atoms)
(eval-when (:compile-toplevel :load-toplevel :execute)
: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))
(state (player-state player)))
(cond ((and (zerop score) (eql state :playing))
(setf (player-state player) :losing))
- ((member state '(:playing :starting))
+ ((member state '(:playing :starting :ready))
(incf remaining)
(setf found player)))))
(changed game :scores :players players)
- (when (= remaining 1)
+ (when (and (= remaining 1) (>= (length players) 2))
(setf (player-state found) :winning)
(changed game :finished :victor found)))))
(when (member (player-state player) '(:starting :playing))
(setf (game-player-index game) j
(player-state player) :ready)
- (player-turn-begin game player)
+ (glib:idle-add (lambda () (player-turn-begin game player) nil))
(changed game :start-turn :player player)
(return))))))
(unless (cell-played cell player-index)
(return-from escape))
(setf (player-state player) :playing)
- (perform-explosions game (list cell)))
- (changed game :processing-move)))))
+ (changed game :processing-move))
+ (perform-explosions game (list cell))))))
(defmethod restart-game ((game atom-game) &key grid players)
(game-cancel-timeout game)
(setf (player-score player) 0
(player-state player) (if (zerop i) :ready :starting))))
(setf (game-player-index game) 0)
- (changed game :refresh))
+ (changed game :refresh)
+ (glib:idle-add (lambda () (player-turn-begin game (aref players 0)) nil)))
;;;--------------------------------------------------------------------------
;;; Snapshots and undo.
for snap-player in snap-players
do (restore player snap-player))
(setf (game-player-index game) (slot-value snapshot 'player-index))
- (changed game :refresh)))
+ (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.
(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
:step-increment 1))
(count-adjustment :type gtk:adjustment
:initform (make-instance 'gtk:adjustment
- :lower 2 :upper 20
+ :lower 1 :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))))
+ :column-types '(gdk:color string string)
+ :column-names '(colour name type))))
(:default-initargs
:title "New game"
:default-height 360
(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))
+ 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))
: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)
(gtk:signal-connect renderer :edited
(lambda (path new-text)
(setf (gtk:tree-model-value
- players
- path
- 'name)
+ players path 'name)
new-text))))
+
(gtk:signal-connect view :row-activated
(lambda (path column)
(when (eql (position column
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))))
+ 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))
(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))))
+ (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 :processing-move)
+ ((:undo :redo :refresh :start-turn)
(update-undo-redo-sensitivity window))))
(defun action-undo (window)
(player spec)
((or string list)
(destructuring-bind
- (name &key colour)
+ (name &key colour (type 'human-player))
(if (listp spec) spec (list spec))
(cond (colour)
((< i (length *player-colours*))
:red (random 1.0)
:green (random 1.0)
:blue (random 1.0)))))
- (make-instance 'human-player
+ (make-instance type
:name name
:colour (gdk:ensure-color colour)))))))
(let ((i 0))
(defvar *window* nil)
+(export 'start-atom-game)
(defun start-atom-game (&rest initargs)
(when *window*
(gtk:widget-destroy *window*)
(setf *window* (apply #'make-instance 'atom-game-window initargs))
(gtk:widget-show-all *window*))
-(start-atom-game :width 7 :players (list "Mark" "Vicky"))
+#+debug
+(start-atom-game :width 7
+ :players '("Alice" "Bob"))
;;;----- That's all, folks --------------------------------------------------