From bcb752add34a51a7b72781090940b76463faefa4 Mon Sep 17 00:00:00 2001
Message-Id: <bcb752add34a51a7b72781090940b76463faefa4.1715593526.git.mdw@distorted.org.uk>
From: Mark Wooding <mdw@chiark.greenend.org.uk>
Date: Sun, 24 Mar 2013 01:40:18 +0000
Subject: [PATCH] atoms.lisp: Multiple player types.
Organization: Straylight/Edgeware

From: Mark Wooding <mdw@distorted.org.uk>

Keep a list of player type names and classes, and allow the user to
fiddle with player types in the `new game' dialogue.
---
 atoms.lisp | 58 ++++++++++++++++++++++++++++++++++++++++++++----------
 1 file changed, 48 insertions(+), 10 deletions(-)

diff --git a/atoms.lisp b/atoms.lisp
index 6aeb8de..1ee1e05 100644
--- 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))
-- 
[mdw]