with-join-spawn/cc so multiple players can make their demands simulta…

…neously
vii · Sep 21, 2009 · 2e7d463 · 2e7d463
1 parent 3b1e656
commit 2e7d463
Show file tree

Hide file tree

Showing 5 changed files with 29 additions and 5 deletions.
diff --git a/src/game/web.lisp b/src/game/web.lisp
@@ -310,7 +310,7 @@
     ('(strcat ".messages-and-talk > ." tpd2.webapp:+html-class-scroll-to-bottom+) 
       :overflow "auto"      
       :padding-right "0.5em"
-      :height "10em" )
+      :height "20em" )
     (".game-header"  :float "left")
     (".close-game:before" :content "\"+ \"")
     (".players"        

diff --git a/src/lib/callcc.lisp b/src/lib/callcc.lisp
@@ -20,6 +20,25 @@
      ,@(loop for n in names collect
 	     `(cl-cont-pass-through-one-construct ,n))))
 
+(defmacro with-join-spawn/cc ((&optional (name (gensym "join"))) &body body)
+  (with-unique-names (k)
+   `(call/cc
+     (lambda (,k)
+       (let ((,name 1))
+	 (flet ((,name ()
+		  (assert (plusp ,name) (,name) "spawn/cc returned too much")
+		  (decf ,name)
+		  (when (zerop ,name)
+		    (funcall ,k))))
+	   (macrolet ((spawn/cc ((&optional (name ',name)) &body body)
+			`(progn
+			   (incf ,name)
+			   (with-call/cc
+			     ,@body
+			     (,name)))))
+	     ,@body)
+	   (,name)))))))
+
 (eval-always
   (cl-cont-pass-through-constructs
    handler-case

diff --git a/src/packages.lisp b/src/packages.lisp
@@ -127,6 +127,8 @@
    #:without-call/cc
    #:with-call/cc
    #:call/cc
+   #:spawn/cc
+   #:with-join-spawn/cc
 
    #:read-safely
    #:read-safely-from-string

diff --git a/src/small-games/nash-bargain.lisp b/src/small-games/nash-bargain.lisp
@@ -34,8 +34,10 @@
 	  do (setf (its coins p) 
 		   (setf (player-controller-var p 'coins)
 			 (max-nil-ok (1+ (random *max-penalty*)) (player-controller-var p 'coins)))))
-    (loop for p in (my players)
-	  do (setf (its demand p) (my secret-move :select-demand p `(:integer 0 ,(my pot)))))
+    (with-join-spawn/cc ()
+	(loop for p in (my players)
+	      do (spawn/cc () 
+			   (setf (its demand p) (my secret-move :select-demand p `(:integer 0 ,(my pot)))))))
     (let ((total-demand 
 	   (loop for p in (my players) 
 		 for demand = (its demand p) 
@@ -64,7 +66,7 @@
       (<h3 "Pot: " (my pot) ", penalty: " (my penalty) ".")
       (<p "The pot has " (coins (my pot)) "; you can demand zero or more of them. "
 	  "If the total demanded by the players is less than or equal to " (coins (my pot)) ", then each player receives his or her demand. "
-	      "Otherwise, if the players are too greedy, they lose " (coins (my penalty)) ". ")
+	      "Otherwise, if the players are too greedy, they each forfeit " (coins (my penalty)) ". ")
       (<p
 	"Your real demand is secret, but you can talk to the other player.")
       (<p "Read more at "

diff --git a/teepeedee2.asd b/teepeedee2.asd
@@ -12,13 +12,14 @@
 (pushnew "../cl-irregsexp/" asdf:*central-registry* :test #'equal)
 (pushnew "../trivial-backtrace/" asdf:*central-registry* :test #'equal)
 
+#.(pushnew :tpd2-debug *features*)
+
 #-tpd2-debug
 (declaim (optimize speed))
 
 #+tpd2-debug
 (progn
   (declaim (optimize debug safety (speed 1)))
-  (pushnew :tpd2-debug *features*)
   (pushnew :tpd2-debug-assert *features*))
 
 (asdf:defsystem :teepeedee2