X-Git-Url: http://www.chiark.greenend.org.uk/ucgi/~mdw/git/atoms/blobdiff_plain/c1be708422af28ae0515b71ebadac0c9e1a8793b..03e309314d430f195f8f0d9cbe4d8d84c551ea46:/atoms.lisp diff --git a/atoms.lisp b/atoms.lisp index 77329cf..915c53e 100644 --- a/atoms.lisp +++ b/atoms.lisp @@ -26,8 +26,7 @@ (cl:defpackage #:atoms #+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) @@ -194,7 +193,13 @@ (defclass player () :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)) @@ -307,7 +312,7 @@ (defmethod game-next-player (game) (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)))))) @@ -362,8 +367,8 @@ (defmethod play-cell ((game atom-game) player i j) (unless (cell-played cell player-index) (return-from escape)) (setf (player-state player) :playing) - (changed game :processing-move) - (perform-explosions game (list cell))))))) + (changed game :processing-move)) + (perform-explosions game (list cell)))))) (defmethod restart-game ((game atom-game) &key grid players) (game-cancel-timeout game) @@ -381,7 +386,8 @@ (defmethod restart-game ((game atom-game) &key grid players) (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. @@ -417,7 +423,12 @@ (defmethod restore ((game atom-game) (snapshot atom-game-snapshot)) do (restore player snap-player)) (setf (game-player-index game) (slot-value snapshot 'player-index)) (game-cancel-timeout game) - (changed game :refresh))) + (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. @@ -730,6 +741,8 @@ (defmethod notify progn ((list player-list) (game atom-game) aspect &key) (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 @@ -746,8 +759,8 @@ (defclass new-game-dialogue (gtk:dialog) :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 @@ -800,9 +813,13 @@ (defun start-new-game (window) (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)) @@ -894,6 +911,29 @@ (defmethod initialize-instance :after ((window new-game-dialogue) &key) :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) @@ -901,10 +941,9 @@ (defmethod initialize-instance :after ((window new-game-dialogue) &key) (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 @@ -913,9 +952,12 @@ (defmethod initialize-instance :after ((window new-game-dialogue) &key) 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)) @@ -995,17 +1037,16 @@ (defun action-new-game (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) @@ -1024,7 +1065,7 @@ (defun build-player-vector (player-spec) (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*)) @@ -1034,7 +1075,7 @@ (defun build-player-vector (player-spec) :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)) @@ -1146,6 +1187,7 @@ (defmethod shared-initialize :after (defvar *window* nil) +(export 'start-atom-game) (defun start-atom-game (&rest initargs) (when *window* (gtk:widget-destroy *window*) @@ -1153,6 +1195,8 @@ (defun start-atom-game (&rest initargs) (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 --------------------------------------------------