gamao-obsoleto/ui.lisp

(in-package #:ui)

#|

While the game object represents the state of a game, a UI object is meant to
mediate all its relations with the outer world.

For one thing, it makes sense to restrict possible user actions depending on
the game state.  For instance, it is useful to prevent a player from moving
checkers when his opponent is considering a cube decision.  This makes it
possible to filter out unwanted events without re-implementing a state machine
on the client side.  Thus, a UI object contains the information about which
actions are admissible at a given state of the game.

TODO add about pauses

|#

(defclass base-ui ()
  ((checkers-locked :initform (list :white t :black t))
   (offer-double-locked :initform (list :white t :black t))
   (accept-double-locked :initform (list :white t :black t))
   (finish-move-locked ::initform (list :white t :black t))
   (undo-locked :initform (list :white t :black t))
   (paused :accessor pausedp :initform nil)))

#|

For each of the slots, we define a getter (slot-p player ui) and a setter
(setf (slot-pp player ui) val), which return and modify corresponding
properties of the plists.

|#

(macrolet ((def (function slot)
             `(progn

                (defgeneric ,function (player ui))

                (defmethod ,function (player (ui base-ui))
                  (or (pausedp ui) (getf (slot-value ui ',slot) player)))

                (defgeneric (setf ,function) (new-value player ui))

                (defmethod (setf ,function) (new-value player (ui base-ui))
                  (setf (getf (slot-value ui ',slot) player) new-value)))))
  (def checkers-locked-p checkers-locked)
  (def offer-double-locked-p offer-double-locked)
  (def accept-double-locked-p accept-double-locked)
  (def finish-move-locked-p finish-move-locked)
  (def undo-locked-p undo-locked))

(defun unlock-only (actions player ui)
  (macrolet ((foo (accessor code)
               `(setf (,accessor player ui) (if (member ,code actions) nil t)
                      (,accessor (game:opponent player) ui) t)))
    (foo checkers-locked-p :checkers)
    (foo offer-double-locked-p :offer-double)
    (foo accept-double-locked-p :accept-double)
    (foo finish-move-locked-p :finish-move)
    (foo undo-locked-p :undo)))

#|

A UI object is responsible for updating users' views of the game.

In a typical web setting, there are several views of a single game.  The
players are supposed to have it open in their browsers.  A player can open it
more than once.  There can be spectators.  All these views are managed by the
same UI object.  We say that the views are associated with *connections* taken
in an abstract sense.  The set of connections is dynamic (for instance, a user
can close a browser tab with the game, or a new spectator can join).  Now our
aim is to provide a few primitives in terms of connections.  We don't want to
concretize the implementation of a connection, so we make the fundamental
functions generic in order to establish methods in a more specific setting.
Two possible specific settings are hunchensocket and websocket-driver
connections.

|#

(defgeneric refresh (game ui))

(defmethod refresh ((game game:game) (ui base-ui)))

(defclass user ()
  ((id :reader id :initarg :id)
   (name :accessor name :initarg :name :initform nil)
   (preferences :reader preferences :initform (make-hash-table :test 'equal))))

(defclass registered-user (user)
  ())

(defclass guest-user (user)
  ())

(defmethod name ((user guest-user))
  (or (call-next-method) (format nil "Guest ~D" (abs (id user)))))

(defclass multiple-connections-ui (base-ui)
  ((player-users :initform (list :white nil :black nil))))

(defmethod player-user (player (ui multiple-connections-ui))
  (getf (slot-value ui 'player-users) player))

(defmethod (setf player-user) (new-value player (ui multiple-connections-ui))
  (setf (getf (slot-value ui 'player-users) player) new-value))


(defgeneric connections (ui))

;; user or nil
(defgeneric connection-user (connection))

(defgeneric add-connection (connectiton ui))
(defgeneric remove-connection (connectiton ui))

(defgeneric send-to-connection (message connection))

;; user or nil
(defgeneric player-user (player ui))

(defgeneric user= (user1 user2))

(defmethod user= (user1 user2)
  (eql user1 user2))

(defun board-info (board)
  `(:bar (:white ,(board:checkers-on-bar :white board)
          :black ,(board:checkers-on-bar :black board))
    :off (:white ,(board:checkers-off :white board)
          :black ,(board:checkers-off :black board))
    :points ,(loop with k
                   with player
                   for i from 1 to 24
                   do (setf (values k player) (board:checkers-on-point i board))
                   collect `(:checkers ,k ,@(if player `(:player ,player))))))

;; todo typep => matchp
(defun game-info (game &optional with-moves?)
  (let* ((session (game::session game))
         (info `(:board ,(board-info (game::partial-board game))
                 :dice ,(game::dice game)
                 :rest-dice ,(game::rest-dice game)
                 :score ,(let ((score (game::game-score game)))
                           (abs score))
                 :dice-no ,(game::dice-no game)
                 :game-no ,(if session
                               (length (game::games session))
                               1))))
    (flet ((push-non-null (tag-value)
             (when (second tag-value)
               (setf info (append tag-value info)))))
      (mapcar #'push-non-null `((:cube ,(game::cube game))
                                 (:turn ,(game::turn game))
                                 (:cube-owner ,(game::cube-owner game))
                                 (:is-doubling ,(game::is-doubling game))
                                 (:winner ,(game::winner game))
                                 (:match-score ,(and session (game::score session)))
                                 (:match-limit ,(and (typep session 'game::match) (game::limit session)))
                                 (:crawford? ,(game::crawford-game-p game))
                                 (:jacoby? ,(and session (game::jacobyp session)))))
      (when with-moves?
        (push-non-null `(:moves ,(loop for seq in (game::remaining-moves (game::partial-moves game)
                                                                         (game::possible-moves game))
                                       collect (butlast (first seq))))))
      (list :game info))))

(defun ui-info (player ui)
  (let ((info (loop for (tag lock) on '(:checkers-enabled ui:checkers-locked-p
                                               :offer-double-enabled ui:offer-double-locked-p
                                               :accept-double-enabled ui:accept-double-locked-p
                                               :move-completion-enabled ui:finish-move-locked-p
                                               :undo-enabled ui:undo-locked-p)
                           by #'cddr
                           when (not (funcall lock player ui))
                           nconc (list tag t))))
    (loop for player in '(:white :black)
          for key in '(:white-name :black-name)
          for user = (player-user player ui)
          when user
          do (setf info (list* key (name user) info))
          finally (return `(:ui ,info)))))

(defmethod refresh ((game game:game) (ui multiple-connections-ui))
  (loop with turn = (game:turn game)
        for connection in (connections ui)
        for user = (connection-user connection)
        for player = (flet ((user (player)
                              (player-user player ui)))
                       (find user '(:white :black) :key #'user))
        ;; TODO this is not pretty at all
        ;; avoid recalculating the game info
        ;; the `list "update"' stuff is just atrocious
        do (send-to-connection (cond ((and player (game:player-equal player turn))
                                      (list "update" (append (ui-info player ui) (game-info game t))))
                                     (player
                                      (list "update" (append (ui-info player ui) (game-info game nil))))
                                     (t (list "update" (game-info game nil))))
                               connection)))