atoms.lisp: Multiple player types.

[atoms] / atoms.lisp

diff --git a/atoms.lisp b/atoms.lisp
index 6aeb8de8647bc08a5c9bed700f0b32ea3894a58e..1ee1e05f1118835e0f1a9cee88a35a6b91f190d9 100644 (file)
--- a/atoms.lisp
+++ b/atoms.lisp
@@ -193,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))
@@ -734,6 +740,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
@@ -750,8 +758,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
@@ -804,9 +812,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))
@@ -898,6 +910,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)
@@ -917,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))
@@ -1027,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*))
@@ -1037,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))