added the ultimatum game and roshambo

vii · Sep 29, 2009 · b80797a · b80797a
1 parent 259b84e
commit b80797a
Show file tree

Hide file tree

Showing 5 changed files with 120 additions and 4 deletions.
diff --git a/src/game/web.lisp b/src/game/web.lisp
@@ -56,6 +56,14 @@
   (declare (ignore game-state))
   (my add-announcement (<p :class "game-message" (player-controller-name-to-ml (player-controller (getf args :player))) " played " (output-object-to-ml (make-card-from-number (getf args :choice))) ".")))
 
+(my-defun web-state 'inform (game-state (message (eql :select-demand)) &key player choice &allow-other-keys)
+  (declare (ignore game-state))
+  (my add-announcement (<p :class "game-message" (player-controller-name-to-ml (player-controller player)) " demanded " choice ".")))
+
+(my-defun web-state 'inform (game-state (message (eql :select)) &key player selection &allow-other-keys)
+  (declare (ignore game-state))
+  (my add-announcement (<p :class "game-message" (player-controller-name-to-ml (player-controller player)) " chose " (friendly-string selection) ".")))
+
 (my-defun web-state 'inform (game-state (message (eql :reject-cards)) &rest args)
   (declare (ignore game-state))
   (my add-announcement (<p :class "game-message" (player-controller-name-to-ml (player-controller (getf args :player)))
@@ -187,6 +195,13 @@
 (defun keyword-to-friendly-string (keyword)
   (string-capitalize (string-downcase (match-replace-all (force-string keyword) ("-" " "))) :end 1))
 
+(defun friendly-string (object)
+  (typecase object
+    (symbol
+     (keyword-to-friendly-string object))
+    (t
+     object)))
+
 (my-defun move-state 'object-to-ml ()
   (<div :class "move-state"
 	(let ((friendly-move-type (keyword-to-friendly-string (my move-type))))
@@ -209,17 +224,17 @@
 			    (with-ml-output " from " (reduce #'min (choices-list (my choices))) " to " 
 					    (reduce #'max (choices-list (my choices))) ". "))
 			   (t
-			    (with-ml-output (format nil " ~{~A ~}" (my args)) " from " (format nil "~A" (my choices) ))))
+			    (with-ml-output (format nil " ~{~A ~}" (my args)) " from ")))
 
 		     (loop for c in (choices-list (my choices)) do 
 			   (let-current-values (c)
 			     (with-ml-output " "
-					     (html-action-link c
+					     (html-action-link (friendly-string c)
 					       (my queue-choice c)))))
 
 		     (html-action-form 		     
 			 ""
-			 ((choice (first (choices-list (my choices)))))
+			 (choice)
 		       (my queue-choice (read-safely-from-string choice))
 		       (values))))))))
 

diff --git a/src/packages.lisp b/src/packages.lisp
@@ -419,6 +419,14 @@
   (:use #:tpd2.game #:tpd2.ml #:tpd2.lib #:teepeedee2.webapp #:common-lisp #:tpd2.ml.html)
   (:export #:nash-bargain))
 
+(defpackage #:teepeedee2.game.ultimatum
+  (:nicknames #:tpd2.game.ultimatum)
+  (:use #:tpd2.game #:tpd2.ml #:tpd2.lib #:teepeedee2.webapp #:common-lisp #:tpd2.ml.html))
+
+(defpackage #:teepeedee2.game.roshambo
+  (:nicknames #:tpd2.game.roshambo)
+  (:use #:tpd2.game #:tpd2.ml #:tpd2.lib #:teepeedee2.webapp #:common-lisp #:tpd2.ml.html))
+
 (defpackage #:teepeedee2.game.prisoners-dilemma
   (:nicknames #:tpd2.game.prisoners-dilemma)
   (:use #:tpd2.game #:tpd2.ml #:tpd2.lib #:teepeedee2.webapp #:common-lisp #:tpd2.ml.html #:tpd2.game.nash-bargain))

diff --git a/src/small-games/roshambo.lisp b/src/small-games/roshambo.lisp
@@ -0,0 +1,42 @@
+(in-package #:tpd2.game.roshambo)
+
+(defvar *objects* '(rock paper scissors))
+
+(defgame roshambo ()
+  ()
+  (defplayer ()
+      (choice))
+  (:game-name "Rock, Paper, Scissors")
+  (:game-description
+   (with-ml-output
+     "Two players simultaneously choose either rock, paper or scissors. Rock blunts scissors, scissors cut paper, and paper covers rock. Also called roshambo." (<br)
+     "Read more at "
+     (<a :href "http://en.wikipedia.org/wiki/Rock,_Paper,_Scissors" "Wikipedia") ".")))
+
+(my-defun roshambo 'play ()
+  (with-game
+    (my new-state)
+    (with-join-spawn/cc ()
+      (loop for p in (my players)
+	    do 
+	    (let-current-values (p) 
+		 (spawn/cc () 
+			   (setf (its choice p) (my secret-move :select p `(:one ,@*objects*)))))))
+
+    (loop for p in (my players)
+	  do (my announce :select :player p :selection (its choice p)))
+
+    (let ((winner
+	   (without-call/cc
+	     (flet ((v (c)
+		      (position c *objects*)))
+	      (loop for p in (my players)
+		    for vp = (v (its choice p))
+		    thereis (loop for q in (my players)
+				  for vq = (v (its choice q))
+				  thereis (when (= vp (mod (1+ vq) (length *objects*)))
+					    p)))))))
+      (cond (winner
+	     (my finished :winner winner))
+	    (t
+	     (my finished :result :draw))))))
diff --git a/src/small-games/ultimatum.lisp b/src/small-games/ultimatum.lisp
@@ -0,0 +1,47 @@
+(in-package #:tpd2.game.ultimatum)
+
+(defvar *max-pot* 20)
+(defvar *min-pot* 1)
+(defvar *max-penalty* 4)
+(defvar *min-penalty* 0)
+
+(defgame ultimatum (coin-game)
+  ((pot (random-between *min-pot* *max-pot*))
+   (penalty (random-between *min-penalty* *max-penalty*)))
+  (defplayer ()
+      ((demand 0)))
+  (:game-name "The Ultimatum Game")
+  (:game-description
+   (with-ml-output
+     "There is a pot of coins to be shared. The first player decides how to share them. The second player can accept the choice, and receive the allotment, or reject it, in which case the players will both be fined." (<br)
+     "Read more at "
+     (<a :href "http://en.wikipedia.org/wiki/Ultimatum_game" "Wikipedia") ".")))
+
+(my-defun ultimatum 'play ()
+  (with-game
+    (my new-state)
+    (destructuring-bind (proposer acceptor)
+	(random-shuffle (my players))
+      (with-its-type (proposer ultimatum-player)
+	(with-its-type (acceptor ultimatum-player)
+
+	  (let ((demand (my move :select-demand proposer `(:integer 0 ,(my pot)))))
+	    (let ((ok (my move :cooperate acceptor :boolean)))
+	      (cond (ok
+		     (its give-coins proposer demand)
+		     (its give-coins acceptor (- (my pot) demand))
+		     (my finished :result :sharing))
+		    (t
+		     (its give-coins proposer (- (my penalty)))
+		     (its give-coins acceptor (- (my penalty)))
+		     (my finished :result :penalty))))))))))
+
+(my-defun ultimatum 'object-to-ml ()
+  (flet ((coins (c) (format nil "~R coin~:P" c)))
+    (with-ml-output
+      (call-next-method)
+      (<h3 "Pot: " (my pot) ", penalty: " (my penalty) ".")
+      (<p "The first player demands some portion of " (coins (my pot)) ". The second player will get the rest, "
+	  "but if he or she is unhappy with this division then both players lose " (coins (my penalty)) ". "))))
+
+
diff --git a/teepeedee2.asd b/teepeedee2.asd
@@ -111,7 +111,11 @@
 							   ))
 				     (:module :small-games
 					      :depends-on (:game)
-					      :components ((:file "nash-bargain") (:file "prisoners-dilemma")))
+					      :components (
+							   (:file "nash-bargain") 
+							   (:file "prisoners-dilemma") 
+							   (:file "ultimatum")
+							   (:file "roshambo")))
 				     (:module :blog
 					      :depends-on (:webapp :ml :datastore)
 					      :components ((:file "entry")