chiark / gitweb /
atoms.lisp: Call `player-turn-begin' from the main loop.
[atoms] / atoms.lisp
index eac69bc..915c53e 100644 (file)
@@ -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.
@@ -735,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
@@ -751,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
@@ -805,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))
@@ -899,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)
@@ -906,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
@@ -918,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))
@@ -1000,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)
@@ -1029,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*))
@@ -1039,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))
@@ -1151,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*)
@@ -1158,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 --------------------------------------------------