Skip to content

Commit

Permalink
tidied up game interface and added nash-bargain, no AI
Browse files Browse the repository at this point in the history
  • Loading branch information
@vii
vii committed Sep 21, 2009
1 parent 31542ef commit 0a8e199
Show file tree
Hide file tree
Showing 8 changed files with 204 additions and 75 deletions.
60 changes: 17 additions & 43 deletions src/game/framework.lisp
View file
Original file line number Diff line number Diff line change
@@ -1,12 +1,5 @@
(in-package #:tpd2.game)

(defgeneric move (controller player-state move-type choices &rest args))
(defmethod move (controller player-state move-type choices &rest args)
(declare (ignore args controller player-state move-type))
(random-choice choices))
(defgeneric move-continuation (k controller player-state move-type choices &rest args))
(defmethod move-continuation (k controller player-state move-type choices &rest args)
(funcall k (apply 'move controller player-state move-type choices args)))

(defmyclass game
game-over
Expand All @@ -32,36 +25,12 @@
(t
'invalid-choice)))

(defgeneric choices-list (choice))
(defgeneric choices-list-form (first &rest rest))

(defmethod choices-list ((choices list))
(apply 'choices-list-form (first choices) (rest choices)))

(defmethod choices-list ((choices (eql :boolean)))
(list t nil))

(defmethod choices-list-form ((first (eql :integer)) &rest args)
(destructuring-bind
(min-inclusive max-exclusive)
args
(loop for i from min-inclusive below max-exclusive
collect i)))

(defmethod choices-list-form ((first (eql :one)) &rest args)
args)

(defun random-choice (choices)
(random-elt (choices-list choices)))

(eval-always
(defgeneric play (game)))

(defgeneric game-name (game))

(my-defun game finished (winner)
(my-defun game finished (&rest args)
(setf (my game-over) t)
(my announce :game-over :player winner)
(apply 'game-announce me :game-over args)
(values))

(defmyclass player
Expand All @@ -72,10 +41,6 @@
(my-defun game listeners ()
(append (mapcar 'player-controller (my players)) (my other-listeners)))

(defgeneric inform (listener game-state message &rest args))
(defmethod inform (listener game-state message &rest args)
(declare (ignore args listener game-state message)))

(my-defun game announce (message &rest args)
(loop for l in (my listeners)
do (apply 'inform l me message args)))
Expand All @@ -87,7 +52,9 @@
(eval-always (defvar *games* (make-hash-table :test 'equalp)))

(defmacro defgame (name superclasses slots defplayer &rest options)
(let ((game-name-string (force-byte-vector (or (getf options :documentation) (string-capitalize (symbol-name name))))))
(let* ((options (copy-list options))
(game-name-string (force-byte-vector (or (second (assoc :game-name options)) (string-capitalize (symbol-name name))))))
(deletef :game-name options :key 'car)
(flet ((defgameclass-form (name superclasses options slots)
`(defmyclass (,name
,@(mapcar (lambda(c) `(:include ,c))
Expand Down Expand Up @@ -159,17 +126,24 @@
(my-defun game talk (sender text)
(my announce :talk :sender sender :text text))

(my-defun game drop-player (p)
(deletef p (my players))
(unless (cdr (my players))
(my finished :winner (first (my players)))))

(my-defun game resign (player-controller)
(let ((p (find player-controller (my players) :key 'player-controller)))
(when p
(my announce :resigned player-controller)
(deletef p (my players))
(when (eql 1 (length (my players)))
(my finished (first (my players)))))))

(my drop-player p))))

(defrules game new-state ()
(my announce :new-state)
(loop for p in (my players) do (my secret-move :ready-to-play p '(:one t))))

(defgeneric player-controller-name-to-ml (controller))
(defmethod player-controller-var ((player player) var)
(player-controller-var (player-controller player) var))
(defmethod (setf player-controller-var) (new-value (player player) var)
(setf (player-controller-var (player-controller player) var) new-value))
(defmethod player-controller-name-to-ml ((player player))
(player-controller-name-to-ml (player-controller player)))
88 changes: 68 additions & 20 deletions src/game/web.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -22,6 +22,8 @@
(appendf (my announcements) (list a))
(my notify))

;;;; XXXX refactor this repetitive nonsense

(my-defun web-state 'inform (game-state (message (eql :talk)) &rest args)
(declare (ignore game-state))
(let ((sender (getf args :sender)) (msg (getf args :text)))
Expand Down Expand Up @@ -64,9 +66,35 @@
(with-ml-output " " it " chips"))
".")))

(my-defun web-state 'inform (game-state (message (eql :game-over)) &rest args)
(my-defun web-state 'inform (game-state (message (eql :game-over)) &key winner result &allow-other-keys)
(declare (ignore game-state))
(my add-announcement (<h2 :class "game-message" (player-controller-name-to-ml (player-controller (getf args :player))) " won the game.")))
(cond (winner
(my add-announcement (<h2 :class "game-message" (player-controller-name-to-ml (player-controller winner)) " won the game.")))
(t
(my add-announcement (<h2 :class "game-message"
(when result
(string-capitalize (format nil "~A. " result)))
"Game over.")))))

(my-defun web-state 'inform (game-state (message (eql :demand)) &key player amount &allow-other-keys)
(my add-announcement
(<p :class "game-message"
(player-controller-name-to-ml player)
" demanded " demand ".")))

(my-defun web-state 'inform (game-state (message (eql :profit)) &key player amount &allow-other-keys)
(my add-announcement
(<p :class "game-message"
(player-controller-name-to-ml player)
(if (minusp amount) " lost " " gained ")
(abs amount) ".")))

(my-defun web-state 'inform (game-state (message (eql :bankrupt)) &key player &allow-other-keys)
(my add-announcement
(<p :class "game-message"
(player-controller-name-to-ml player)
" went bankrupt.")))


(my-defun web-state 'inform (game-state (message (eql :new-state)) &rest args)
(declare (ignore game-state))
Expand All @@ -83,7 +111,7 @@
(output-object-to-ml args))))

(defmethod move-continuation (k (controller web-state) player-state move-type choices &rest args)
(its add-move-state controller
(web-state-add-move-state controller
(make-move-state :cc k
:move-type move-type
:player-state player-state
Expand Down Expand Up @@ -115,13 +143,14 @@
(my-defun web-state try-to-move ()
(loop for waiting in (my waiting-for-input) do
(loop for qc in (my queued-choices)
do (when (eql (its move-type qc) (its move-type waiting))
(deletef qc (my queued-choices))
(unless (eq 'invalid-choice (validate-choice (its choices waiting) (its choice qc)))
(deletef waiting (my waiting-for-input))
(funcall (its cc waiting) (its choice qc))
(my notify)
(return-from web-state-try-to-move))))))
do
(when (eql (queued-choice-move-type qc) (move-state-move-type waiting))
(deletef qc (my queued-choices))
(unless (eq 'invalid-choice (validate-choice (move-state-choices waiting) (queued-choice-choice qc)))
(deletef waiting (my waiting-for-input))
(funcall (move-state-cc waiting) (queued-choice-choice qc))
(my notify)
(return-from web-state-try-to-move))))))


(defun keyword-to-friendly-string (keyword)
Expand All @@ -146,8 +175,8 @@
(t
(<p friendly-move-type
(cond ((eql (force-first (my choices)) :integer)
(with-ml-output " from " (apply 'min (choices-list (my choices))) " to "
(apply 'max (choices-list (my choices))) ". "))
(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) ))))

Expand All @@ -170,7 +199,7 @@

(my-defun game 'object-to-ml :around ()
(if (my game-over)
(<p "Game over.")
(<h2 "Game over." (my play-again-ml) "?")
(call-next-method)))

(defun current-web-controller (controller)
Expand All @@ -185,11 +214,22 @@
(my-defun web-state 'player-controller-name-to-ml ()
(<span :class "username" (frame-username (my frame))))

(my-defun web-state 'player-controller-var ( var)
(frame-var (my frame) var))

(my-defun web-state (setf 'player-controller-var) (new-value var)
(setf (frame-var (my frame) var) new-value))

(defgeneric game-title-ml (game)
(:method (game)
(<h2 :class "game-title"
(string-capitalize (force-string (game-name game))))))

(my-defun web-state 'object-to-ml ()
(assert (my game-state) () "No game started; please use game-new-state")
(<div :class "game-state"
(<div :class "game-header"
(<h2 :class "game-title"
(string-capitalize (force-string (game-name (my game-state))))))
(game-title-ml (my game-state)))

(call-next-method)

Expand All @@ -199,19 +239,27 @@
(without-ml-output
(game-talk (my game-state) me text))))))

(my-defun game play-again-ml ()
(html-replace-link "Play again"
(web-game-start (my generator))))

(my-defun web-state play-again-ml ()
(game-play-again-ml (my game-state)))



(my-defun web-state 'simple-channel-body-ml ()
(<div :class "game-state"
(<div :class "game-state-body"
(<p :class "close-game"
(cond ((its game-over (my game-state))
(html-replace-link "Play again"
(web-game-start (game-generator (my game-state)))))
(cond ((game-game-over (my game-state))
(my play-again-ml))
(t
(html-action-link "Resign"
(my resign))))))

(<div :class "messages-and-talk"
(<div :class tpd2.webapp::+html-class-scroll-to-bottom+
(<div :class tpd2.webapp:+html-class-scroll-to-bottom+
(output-object-to-ml (my announcements))))

(cond ((my resigned)
Expand Down Expand Up @@ -253,7 +301,7 @@
:margin-left "5em"
:text-align "right")
(".robot" :font-style "italic")
('(strcat ".messages-and-talk > ." tpd2.webapp::+html-class-scroll-to-bottom+)
('(strcat ".messages-and-talk > ." tpd2.webapp:+html-class-scroll-to-bottom+)
:overflow "auto"
:padding-right "0.5em"
:height "10em" )
Expand Down
12 changes: 6 additions & 6 deletions src/ml/output.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -46,13 +46,13 @@
(case (first form)
(with-ml-output (mapcan #'r (rest form)))
(output-raw-ml (copy-list (rest form)))
((or without-ml-output escape-data) (list form))
((without-ml-output escape-data) (list form))
(t
(multiple-value-bind (new changed)
(macroexpand-1 form env)
(if changed
(r new)
(list `(escape-data ,form)))))))
(multiple-value-bind (new changed)
(macroexpand-1 form env)
(if changed
(r new)
(list `(escape-data ,form)))))))
(t (list `(escape-data ,form))))))
(r form)))

Expand Down
7 changes: 7 additions & 0 deletions src/packages.lisp
View file
Original file line number Diff line number Diff line change
Expand Up @@ -335,6 +335,7 @@


#:+html-id-async-status+
#:+html-class-scroll-to-bottom+
))


Expand Down Expand Up @@ -368,6 +369,7 @@
#:+cards-per-suit+

#:player-controller-name-to-ml
#:player-controller-var
#:web-state-queue-choice
#:current-web-controller
#:player-controller))
Expand Down Expand Up @@ -398,6 +400,11 @@
(:nicknames #:tpd2.game.truc)
(:use #:tpd2.game #:tpd2.ml #:tpd2.lib #:teepeedee2.webapp #:common-lisp #:tpd2.ml.html))

(defpackage #:teepeedee2.game.nash-bargain
(:nicknames #:tpd2.game.nash-bargain)
(:use #:tpd2.game #:tpd2.ml #:tpd2.lib #:teepeedee2.webapp #:common-lisp #:tpd2.ml.html))


(defpackage #:teepeedee2.game.cheat
(:nicknames #:tpd2.game.cheat)
(:use #:tpd2.game #:tpd2.ml #:tpd2.lib #:teepeedee2.webapp #:common-lisp #:tpd2.ml.html))
Expand Down
Loading

0 comments on commit 0a8e199

Please sign in to comment.