gamao-obsoleto/event.lisp

(defpackage #:event (:use #:cl))

(in-package #:event)

#|

The dynamics of the game is implemented in the event-driven style.

In theory, one event queue can serve a few tables with simultaneous matches.

|#

(defvar *event-queue*)

#|

We use a thread safe implementation of the event queue based on safe-queue's mailboxes.

|#

(defclass safe-queue ()
  ((mailbox :initform (safe-queue:make-mailbox))))

(defun make-event-queue ()
  (make-instance 'safe-queue))

(defun put-event (event &optional (event-queue *event-queue*))
  (safe-queue:mailbox-send-message (slot-value event-queue 'mailbox) event))

(defun get-event (&optional (event-queue *event-queue*))
  (safe-queue:mailbox-receive-message (slot-value event-queue 'mailbox)))

#|

GAME EVENTS drive a single game.  For the most part, they are generated by the
players, but sometimes, by the game itself.

Player generated events:

move-event user from pips
undo-event user
finish-move-event user

TODO cube events

Game generated events:

first-move-event
dice-event

Each event includes the game itself as the *source* in case several games are
simultaneously served by the same event loop.

|#

;;; TODO either supply missing types, or remove them altogether

(defstruct event
  source)

(defstruct (player-event (:include event))
  (player :white :type game:player))

(defstruct (move-event (:include player-event))
  (from 1 :type game::origin)
  (pips 1 :type game::die-pips))

(defstruct (undo-event (:include player-event) :named))

(defstruct (finish-move-event (:include player-event)))

(defstruct (first-move-event (:include event)))

(defstruct (dice-event (:include event)))

(defstruct (offer-double-event (:include player-event))
  offered-p)

(defstruct (accept-double-event (:include player-event))
  accepted-p)

(defstruct (pause-event (:include event)))

(defstruct (initial-roll-event (:include event))
  dice)

;(defvar *event*)

#|

Events trigger changes of game's states.  Typically, to compute the next state,
we need a few boolean properties of the event.  It is useful to compute such
properties simultaneously and to return them as multiple values in order not to
duplicate calculations.

|#

#|

When moving checkers, a player can make up to 4 moves (not counting undoes).
Each of them triggers an event.  For such an event we want to know whether it
completes the full move or not and whether it concludes the game.

|#

(defun check-event-move (event)
  "If EVENT corresponds to a valid move in its source game, return the move."
  (if (not (move-event-p event))
      nil
      (let ((game (event-source event))
            (player (move-event-player event)))
        (if (not (eql player (game:turn game)))
            nil
            (game::check-next-move (move-event-from event)
                                   (move-event-pips event)
                                   (game::possible-moves game)
                                   (game::partial-moves game))))))

;; => admissible-partial-move? admissible-full-move? admissible-final-move?
(defun move-event-properties (event)
  (let ((next-move (check-event-move event))
        (game (event-source event)))
    (if (null next-move)
        (values nil nil nil)
        (let ((full? (game::full-move-p (append (game::partial-moves game)
                                                (list next-move))
                                        (game::possible-moves game))))
          (values (not full?) full? (game::checker-move-end? next-move))))))

#|

Undo: 1. is it a legal undo?  2. once performed, is there anything else to undo?

|#

(defun undo-event-properties (event)
  (let* ((game (event-source event))
         (undo? (and (undo-event-p event)
                     (game:player-equal (undo-event-player event) (game::turn game)))))
    (values undo? (and undo? (<= (length (game::partial-moves game)) 1)))))

#|

Is it legal for the player to finish the checker move?

|#

(defun admissible-finishing-p (event)
  (let ((game (event-source event)))
    (and (finish-move-event-p event)
         (game:player-equal (player-event-player event) (game::turn game))
         (game::full-move-p (game::partial-moves game) (game::possible-moves game)))))

#|

Is a double offered?  Is it not offered?  The latter refers to the action of
not offering the double, so both questions can be answered `no' if offering a
double is out of place.

|#

;; double-offered? double-not-offered?
(defun offer-double-event-properties (event)
  (if (and (offer-double-event-p event)
           (game:player-equal (player-event-player event)
                              (game:turn (event-source event))))
      (let ((offered? (offer-double-event-offered-p event)))
        (values offered? (not offered?)))
      (values nil nil)))

#|

Check if the double is being accepted or not.  As above, accepting a double may
be out of place.

|#

;; double-accepted? double-not-accepted?
(defun accept-double-event-properties (event)
  (if (and (accept-double-event-p event)
           (game:player-equal (player-event-player event) (game:turn (event-source event))))
      (let ((accepted? (accept-double-event-accepted-p event)))
        (values accepted? (not accepted?)))
      (values nil nil)))

#|

The following event is used in a money session when asking the players if they
would like to keep on playing.

|#

(defstruct (continue-reply-event (:include player-event))
  reply)

#|

When examining the dice, we would like to know if there are available moves or not.

|#

(defun dice-event-properties (event)
  (let ((game (event-source event)))
    (if (dice-event-p event)
        (let ((cannot-move? (null (game::possible-moves game))))
          (values (not cannot-move?) cannot-move?))
        (values nil nil))))

#|

After the dice have been rolled, we assume that the game enters the dice
examination state (see below for a detailed explanation of the FSM).  Then one
more transition occurs, either to a checker move or the turn passes to the
opponent.  This second transition is not triggered by players.  In a purely
event-driven setting the game itself must emit the event.

|#

(defclass event-driven-game (game:game)
  ())

(defmethod game:roll-dice :after ((game event-driven-game))
  (put-event (make-dice-event :source game)))

;;; TODO Urgent!  The variables defined in game.lisp must be used instead.

(defvar *game-class* 'event-driven-game)
(defvar *match-class* 'game::match)
(defvar *money-session-class* 'game::money-session)

#|

                             WELCOME TO THE MACHINE

From the point of view of control, there are only so many states the game can
be in:

1.  Start (about to roll the dice & set the first turn).
2.  One of the players is moving the checkers.
3.  One of the players is deciding whether to double.
4.  One of the players is deciding whether to accept a double.
5.  The dice are examined in order to see if there are admissible moves.
6.  End.

Remark.  We could do without state 5.  In this case if the player rolled the
dice and there were no admissible moves, he would still have to manually
complete the move.  State 5 allows to automatically pass the turn to the
opponent.  As of now, this is done instantly.  A pause state should be added to
provide a delay.

Events trigger transitions between states.  A sequence of accompanying actions
is is calculated on the basis of the current state, event, and game state.

We model the control by a Mealy machine.  It incorporates nearly all the rules
of backgammon and orchestrates the game actions.  In particular, it ensures
that an action only takes place when appropriate.

A single machine is enough to take care of any game setting.  For instance, if
the game is played without doubles, the unavailability of the cube is a
property of the game, and no event can bring it into a state when doubling is
possible.

|#

(eval-when (:compile-toplevel :load-toplevel :execute)


  (defmethod fsm:state-bindings ((machine t) (state t) machine-arguments)
    (lambda (form)
      form))

  (defmethod fsm:state-bindings ((machine (eql 'backgammon-machine)) (state (eql 'checker-move)) arguments)
    (lambda (form)
      `(multiple-value-bind (admissible-partial-move? admissible-full-move? admissible-final-move?) (move-event-properties ,(first arguments))
         (multiple-value-bind (undo? last-undo?) (undo-event-properties ,(first arguments))
           (let* ((admissible-finishing? (admissible-finishing-p ,(first arguments)))
                  ;; if *event* is an admissible finishing, its source MUST be a game
                  (game (event-source ,(first arguments)))
                  ;; doubling must be checked with respect to a session
                  ;; but if by any chance the game is not a part of a session,
                  ;; we check it with respect to the game itself
                  (opponent-can-double? (game:opponent-can-double-p (or (game::session game) game))))
             ,form)))))

  (defmethod fsm:state-bindings ((machine (eql 'backgammon-machine)) (state (eql 'dice)) arguments)
    (lambda (form)
      `(multiple-value-bind (can-move? cannot-move?) (dice-event-properties ,(first arguments))
         ,form)))

  (defmethod fsm:state-bindings ((machine (eql 'backgammon-machine)) (state (eql 'cannot-move-pause)) arguments)
    (lambda (form)
      `(multiple-value-bind (opponent-can-double? opponent-cannot-double?)
         (if (pause-event-p ,(first arguments))
             (let ((opponent-can-double? (game:opponent-can-double-p (or (game::session game) game))))
               (values opponent-can-double? (not opponent-can-double?)))
             (values nil nil))
         ,form)))

  (defmethod fsm:state-bindings ((machine (eql 'backgammon-machine)) (state (eql 'offer-double?)) arguments)
    (lambda (form)
      `(multiple-value-bind (double-offered? double-not-offered?) (offer-double-event-properties ,(first arguments))
         ,form)))

  (defmethod fsm:state-bindings ((machine (eql 'backgammon-machine)) (state (eql 'accept-double?)) arguments)
    (lambda (form)
      `(multiple-value-bind (double-accepted? double-not-accepted?) (accept-double-event-properties ,(first arguments))
         ,form)))


  )

(defparameter *delay* 2)

;; TODO reuse the scheduled function
(defun schedule-pause (game &optional (event-queue *event-queue*))
  (portable-threads:schedule-function-relative
    (portable-threads:make-scheduled-function (lambda (f)
                                                (declare (ignore f))
                                                (put-event (make-pause-event :source game) event-queue)))
    *delay*))

#|

Here it comes.  It's monolithic by design, since so are the rules of the game.
All the logic in one place.  Behold!

Frankly, perhaps we could use some machine decomposition.  But we haven't got it yet.  So we'd better console ourselves that it would be more trouble than it's worth.

|#

(fsm:defmachine backgammon-machine (event game ui)
  (:initial-state first-roll)
  ;; TODO the start state needs polishing
  ;; TODO game API: something about initial dice; initial-throws are obsolete
  (:state first-roll
   (:arc
     :to first-roll-pause
     :when (initial-roll-event-p event) 
     :action (progn
               (setf (slot-value game 'game::dice) (initial-roll-event-dice event))
               (schedule-pause game)
               (ui:refresh game ui))))
  (:state first-roll-pause
   (:arc
     :to checker-move
     :when (and (pause-event-p event)
                (/= (first (game::dice game))
                    (second (game::dice game))))
     :action (progn
               (game:set-turn game)
               (ui:unlock-only '(:checkers) (game:turn game) ui)
               (ui:refresh game ui)))
   (:arc
     :to first-roll
     :when (and (pause-event-p event)
                (= (first (game::dice game))
                    (second (game::dice game))))
     :action (put-event (make-initial-roll-event :source game :dice (game::random-dice)))))
  (:state checker-move
   (:arc
     :to checker-move
     :when (and admissible-partial-move? (not admissible-final-move?))
     :action (progn
               (game:move-checker (move-event-from event) (move-event-pips event) game)
               (ui:unlock-only '(:checkers :undo) (game:turn game) ui)
               (ui:refresh game ui)))
   (:arc
     :to checker-move
     :when (and admissible-full-move? (not admissible-final-move?))
     :action (progn
               (game:move-checker (move-event-from event) (move-event-pips event) game)
               (ui:unlock-only '(:checkers :undo :finish-move) (game:turn game) ui)
               (ui:refresh game ui)))
   (:arc
     :to end-game
     :when admissible-final-move?
     :action (progn
               (game:move-checker (move-event-from event) (move-event-pips event) game)
               (game:set-winner (game:turn game) game :completed)
               (ui:unlock-only '() (game:turn game) ui)
               (ui:refresh game ui)))
   (:arc
     :to checker-move
     :when (and undo? (not last-undo?))
     :action (progn
               (game:undo-move game)
               (ui:unlock-only '(:checkers :undo) (game:turn game) ui)
               (ui:refresh game ui)))
   (:arc
     :to checker-move
     :when last-undo?
     :action (progn
               (game:undo-move game)
               (ui:unlock-only '(:checkers) (game:turn game) ui)
               (ui:refresh game ui)))
   (:arc
     :to dice
     :when (and admissible-finishing? (not opponent-can-double?))
     :action (progn
               (game:finish-move game)
               (game:opponents-turn game)
               (ui:unlock-only '() (game:turn game) ui)
               (game:roll-dice game)
               (ui:refresh game ui)))
   (:arc
     :to offer-double?
     :when (and admissible-finishing? opponent-can-double?)
     :action (progn
               (game:finish-move game)
               (game:opponents-turn game)
               (ui:unlock-only '(:offer-double) (game:turn game) ui)
               (ui:refresh game ui))))
  (:state dice
   (:arc
     :to checker-move
     :when can-move?
     :action (progn
               (ui:unlock-only '(:checkers) (game:turn game) ui)
               (ui:refresh game ui)))
   (:arc
     :to cannot-move-pause
     :when cannot-move?
     :action (progn
               (ui:refresh game ui)
               (setf (ui:pausedp ui) t)
               (schedule-pause game))))
  (:state cannot-move-pause
    (:arc
     :to dice
     :when opponent-cannot-double?
     :action (progn
               (game:opponents-turn game)
               (game:roll-dice game)
               (ui:unlock-only '() (game:turn game) ui)
               (setf (ui:pausedp ui) nil)
               (ui:refresh game ui)))
   (:arc
     :to offer-double?
     :when opponent-can-double?
     :action (progn
               (game:opponents-turn game)
               (setf (ui:pausedp ui) nil)
               (ui:unlock-only '(:offer-double) (game:turn game) ui)
               (ui:refresh game ui))))
  (:state offer-double?
   (:arc
     :to dice
     :when double-not-offered?
     :action (progn
               (game:roll-dice game)
               (ui:unlock-only '() (game:turn game) ui)
               (ui:refresh game ui)))
   (:arc
     :to accept-double?
     :when double-offered?
     :action (progn
               (game:offer-double game)
               (game:opponents-turn game)
               (ui:unlock-only '(:accept-double) (game:turn game) ui)
               (ui:refresh game ui))))
  (:state accept-double?
   (:arc
     :to dice
     :when double-accepted?
     :action (progn
               (game:accept-double game)
               (game:opponents-turn game)
               (game:roll-dice game)
               (ui:unlock-only '() (game:turn game) ui)
               (ui:refresh game ui)))
   (:arc
     :to end-game
     :when double-not-accepted?
     :action (progn
               (game:refuse-double game)
               (game:set-winner (game:opponent (game:turn game)) game :dropped-double)
               (ui:unlock-only '() (game:turn game) ui)
               (ui:refresh game ui))))
  (:state end-game))

#|

Now we'll define handlers for money sessions and matches.  A match continues as
long as it continues.  A money session goes on as long as the players are
willing to play.  After each game, we ask if they would like to continue.

The handlers are considerably simpler than the game handler, so we don't use
explicit machines here.  Maybe later.

|#


;; TODO I think now it's a part of game-info.  Anyway, neither hunchensocket nor json belong here.
(defun send-score (table)
  (let* ((score (game::score (session table)))
         (message (jonathan:to-json `("score" ,@score))))
    (dolist (user (hunchensocket:clients table))
      (hunchensocket:send-text-message user message))))

#|
TODO

Move it to ui.lisp.

The copy is adapted from ui:refresh.  Perhaps the need of adaptation means that
the tools are inconvenient.  Rethink.
|#
(defun ui-continue-query (ui)
  (loop for connection in (ui::connections ui)
        for user = (ui::connection-user connection)
        for player = (flet ((user (player)
                              (ui::player-user player ui)))
                       (find user '(:white :black) :key #'user))
        when player
        do (ui::send-to-connection '("continue?") connection)))


#|

This is a factory of handlers for determining if the money session continues.

|#

(defun make-continue-query-handler ()
  (let ((agreed '()))
    (lambda (event)
      (if (continue-reply-event-p event)
          (if (continue-reply-event-reply event)
              (progn
                (pushnew (continue-reply-event-player event) agreed)
                (if (subsetp '(:white :black) agreed)
                    'yes
                    'undecided))
              (values 'no (continue-reply-event-player event)))
          'undecided))))

(defun make-money-handler (session ui)
  (let ((game-handler (backgammon-machine))
        continuation-query-handler)
    (lambda (event)
      ;; we only handle game events
      ;; we could also handle session-specific events
      ;; TODO mark end of session
      (cond ((and game-handler
                  (eql (event-source event) (game:game session)))
             (funcall game-handler event (game:game session) ui)
             (when (game::winner (game::game session))
               (setf game-handler nil
                     continuation-query-handler (make-continue-query-handler))
               (send-score (table ui)) ; todo is it needed?
               (ui-continue-query ui)))
            ((and (null game-handler)
                  (eql (event-source event) session))
             (let ((query (funcall continuation-query-handler event)))
               (case query
                 (undecided t)
                 (yes
                   (game::start-new-game session)
                   (setf game-handler (backgammon-machine))
                   (dolist (player '(:white black))
                     (setf (ui:checkers-locked-p player ui) t)
                     (setf (ui:offer-double-locked-p player ui) t)
                     (setf (ui:accept-double-locked-p player ui) t)
                     (setf (ui:finish-move-locked-p player ui) t)
                     (setf (ui:undo-locked-p player ui) t))
                   (put-event (make-initial-roll-event :source (game:game session) :dice (game::random-dice))))
                 (no :stop))))))))

#|

The match handler is fairly simple, but perhaps would be clearer if represented as a machine.

|#

(defun make-match-handler (match ui)
  (let ((game-handler (backgammon-machine))
        (pause? nil))
    (lambda (event)
      (unless (game::winner match)
        (if pause?
            (when (pause-event-p event)
              (setf pause? nil)
              (game::start-new-game match)
                (setf game-handler (backgammon-machine))
                (dolist (player '(:white black))
                  (setf (ui:checkers-locked-p player ui) t)
                  (setf (ui:offer-double-locked-p player ui) t)
                  (setf (ui:accept-double-locked-p player ui) t)
                  (setf (ui:finish-move-locked-p player ui) t)
                  (setf (ui:undo-locked-p player ui) t))
                (put-event (make-initial-roll-event :source (game:game match) :dice (game::random-dice))))
            (progn 
              (funcall game-handler event (game:game match) ui)
              (when (game::winner (game:game match))
                (setf pause? t)
                (schedule-pause (game:game match)) ; perhaps can associate it with the session instead?
                (send-score (table ui)))))))))

#|

The following definitions actually belong to the client-server protocol and
should be removed to another file.

|#

(defvar *event-codes* '())

(defmacro define-event-code ((code &rest arguments) form)
  `(push (list ,code (lambda (encoded-event)
                       (destructuring-bind ,arguments (rest encoded-event)
                         ,form)))
         *event-codes*))

(defvar *game*)
(defvar *player*)
(defvar *session*)
(defvar *table*)
(defvar *user*)

(defun decode-event (event)
  (let ((decoder (second (assoc (first event) *event-codes* :test #'string=))))
    (if (null decoder)
        (error "Cannot decode event ~A." event)
        (funcall decoder event))))



(define-event-code ("m" from pips) (make-move-event :source *game*
                                                    :player *player*
                                                    :from (if (equal from "bar") 
                                                              board:bar
                                                              from)
                                                    :pips pips))

(define-event-code ("u") (make-undo-event :source *game*
                                          :player *player*))

(define-event-code ("f") (make-finish-move-event :source *game*
                                                 :player *player*))

(define-event-code ("c" reply) (make-continue-reply-event :source *session* :player *player* :reply (equal reply "yes")))

(define-event-code ("offer-double" yes-no) (make-offer-double-event :source *game* :player *player* :offered-p (string= yes-no "yes")))
(define-event-code ("accept-double" yes-no) (make-accept-double-event :source *game* :player *player* :accepted-p (string= yes-no "yes")))

(define-event-code ("preference" option value) (make-user-preference-event :source *table* :user *user* :option option :value value))