add a base-game for coin games to inherit from and make nash-bargain …

…depend on that
vii · Sep 23, 2009 · 0cffeea · 0cffeea
1 parent 2ec4723
commit 0cffeea
Show file tree

Hide file tree

Showing 3 changed files with 80 additions and 70 deletions.
diff --git a/src/game/coins.lisp b/src/game/coins.lisp
@@ -0,0 +1,46 @@
+(in-package #:tpd2.game)
+
+(defgame coin-game ()
+  ()
+  (defplayer ()
+      ((coins 0)))
+  (:unplayable t))
+
+(my-defun coin-game finished :before (&rest args)
+	  (declare (ignorable args))
+	  (loop for p in (my players)
+		do 
+		(setf (player-controller-var p 'coins) (its coins p))))
+
+(my-defun coin-game-player 'object-to-ml ()
+  (<div :class "coin-game-player"
+	(call-next-method)
+	(let ((coins (or (my coins) (my 'player-controller-var 'coins))))
+	  (when coins
+	    (<p (format nil "~D coin~:P" coins))))))
+
+(my-defun coin-game 'object-to-ml :around ()
+  (<div :class "coin-game"
+	(call-next-method)
+	(let ((coins (webapp-frame-var 'coins)))
+	  (cond (
+		 (and coins (plusp coins))
+		 (<h3 (format nil "You have ~D coin~:P." coins)))
+		(t
+		 (<h3 :class "bankrupt" "You have no coins."))))))
+
+(my-defun coin-game setup-coins ()
+  (loop for p in (my players)
+	do (setf (its coins p) 
+		 (setf (player-controller-var p 'coins)
+		       (max-nil-ok (its coins p) (player-controller-var p 'coins))))))
+
+(my-defun coin-game players-ready :after ()
+	  (my setup-coins))
+
+(my-defun coin-game-player give-coins (amount)
+  (incf (my coins) amount)
+  (my announce :profit :player me :amount amount)
+  (when (minusp (my coins))
+    (my announce :bankrupt :player me))
+  (values))
diff --git a/src/small-games/nash-bargain.lisp b/src/small-games/nash-bargain.lisp
@@ -5,60 +5,44 @@
 (defvar *max-penalty* 5)
 (defvar *min-penalty* 0)
 
-(defun random-between (min max)
-  (+ min (random (1+ (- max min)))))
-
-(defgame nash-bargain ()
+(defgame nash-bargain (coin-game)
   ((pot (random-between *min-pot* *max-pot*))
    (penalty (random-between *min-penalty* *max-penalty*)))
   (defplayer ()
-      ((coins)
-       (demand 0)))
-  (:game-name "Nash bargaining game"))
+      ((demand 0)))
+  (:game-name "Nash's Bargaining Game")
+  (:game-description
+   (with-ml-output
+     "There is a pot of coins to be shared. Players each make a secret demand to receive a certain number of coins. If the players can all be satisfied, they all receive their demand. Otherwise, if their combined demands are too high, then all the players receive a penalty. " (<br)
+     "This is a generalisation of the prisoner's dilemma. Read more at "
+     (<a :href "http://en.wikipedia.org/wiki/Nash_bargaining_game" "Wikipedia") ".")))
 
-(defun max-nil-ok (&rest args)
-  (let (one)
-    (let ((result (loop for a in args when a do (setf one t) and maximizing a)))
-      (when one result))))
 
-(my-defun nash-bargain finished :before (&rest args)
-	  (declare (ignorable args))
-	  (loop for p in (my players)
-		do 
-		(setf (player-controller-var p 'coins) (its coins p))))
 
 (my-defun nash-bargain 'play ()
-  (with-game
-    (my new-state)
-    (loop for p in (my players)
-	  do (setf (its coins p) 
-		   (setf (player-controller-var p 'coins)
-			 (max-nil-ok (1+ (random *max-penalty*)) (player-controller-var p 'coins)))))
-    (with-join-spawn/cc ()
+  (with-its-type (p nash-bargain-player)
+    (with-game
+      (my new-state)
+      (with-join-spawn/cc ()
 	(loop for p in (my players)
-	      do (let-current-values (p) 
-		   (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) 
-		 do
-		 (my announce :demand :player p :amount demand)
-		 summing demand)))
-      (flet ((give-coins (p c)
-	       (incf (its coins p) c)
-	       (my announce :profit :player p :amount c)
-	       (unless (plusp (its coins p))
-		 (my announce :bankrupt :player p))
-	       ))
-       (cond ((>= (my pot) total-demand)
-	      (loop for p in (my players) do
-		    (give-coins p (its demand p)))
-	      (my finished :result :sharing))
-	     (t
-	      (loop for p in (my players) do
-		    (give-coins p (- (my penalty))))
-	      (my finished :result :penalty)))))))
+	      do 
+	      (let-current-values (p) 
+		(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) 
+		   do
+		   (my announce :demand :player p :amount demand)
+		   summing demand)))
+	(cond ((>= (my pot) total-demand)
+	       (loop for p in (my players) do
+		     (its give-coins p (its demand p)))
+	       (my finished :result :sharing))
+	      (t
+	       (loop for p in (my players) do
+		     (its give-coins p (- (my penalty))))
+	       (my finished :result :penalty)))))))
 
 (my-defun nash-bargain 'object-to-ml ()
   (flet ((coins (c) (format nil "~R coin~:P" c)))
@@ -69,31 +53,10 @@
 	  "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 each forfeit " (coins (my penalty)) ". ")
       (<p
-	"Your real demand is secret, but you can talk to the other player.")
-      (<p "Read more at "
-	  (<a :href "http://en.wikipedia.org/wiki/Nash_bargaining_game" "wikipedia") "."))))
-
-(my-defun nash-bargain 'object-to-ml :around ()
-  (<div :class "nash-bargain"
-	(call-next-method)
-	(let ((coins (webapp-frame-var 'coins)))
-	  (cond ((not coins) (values))
-		((minusp coins)
-		 (<h3 :class "bankrupt" "You are bankrupt."))
-		(t
-		 (<h3 (format nil "You have ~D coin~:P." coins)))))))
+	"Your real demand is secret, but you can talk to the other player."))))
 
 (my-defun nash-bargain drop-player :before (p)
 	  (unless (my game-over)
-	    (decf (its coins p) (my penalty))))
-
-(my-defun nash-bargain-player 'object-to-ml ()
-  (<div :class "nash-bargain-player"
-	(call-next-method)
-	(let ((coins (or (my coins) (my 'player-controller-var 'coins))))
-	  (when coins
-	    (<p (format nil "~D coin~:P" coins))))))
+	    (with-shorthand-accessor (p coin-game-player p)
+	      (p give-coins (- (my penalty))))))
 
-(my-defun nash-bargain title-ml ()
-  (<div :class "nash-bargain-title"
-	(call-next-method)))
diff --git a/teepeedee2.asd b/teepeedee2.asd
@@ -105,6 +105,7 @@
 							   (:file "framework" :depends-on ("generic")) 
 							   (:file "controllers" :depends-on ("framework"))
 							   (:file "card")
+							   (:file "coins" :depends-on ("framework"))
 							   (:file "unassigned-controller" :depends-on ("controllers"))
 							   (:file "web" :depends-on ("card" "controllers" "unassigned-controller"))
 							   ))