gamao-obsoleto/table.lisp

(defpackage #:table
  (:use #:cl))

(in-package #:event)

(defclass connection (hunchensocket:websocket-client)
  ((web-session :accessor web-session :initarg web-session :initform nil)))

(defmethod ui::connection-user ((connection connection))
  (hunchentoot:session-value :user (web-session connection)))

(defclass table (hunchensocket:websocket-resource)
  ((id :initarg :id :initform (error "Name this room!") :reader table-id)
   (ui :reader ui)
   (session :reader session)
   (event-queue :accessor event-queue)
   (proposal :accessor proposal :initform nil)
   (proposals :accessor proposals :initform '()))
  (:default-initargs :client-class 'connection))

(defclass hunchensocket-ui (ui::multiple-connections-ui)
  ((table :accessor table :initarg :table)))

(defmethod ui::connections ((ui hunchensocket-ui))
  (hunchensocket:clients (table ui)))

(defmethod ui::send-to-connection (message (connection connection))
  (hunchensocket:send-text-message connection (jonathan:to-json message)))

(defmethod initialize-instance :after ((table table) &key &allow-other-keys)
  (setf (slot-value table 'ui) (make-instance 'hunchensocket-ui :table table)))

(defstruct (client-connected-event (:include event))
  connection)

(defmethod hunchensocket:client-connected ((table table) (connection connection))
  (setf (web-session connection) hunchentoot:*session*)
  (put-event (make-client-connected-event :source table :connection connection) (event-queue table)))

#+nil (defmethod hunchensocket:client-connected ((table table) (connection connection))
  (setf (web-session connection) hunchentoot:*session*)
  (let ((ui (ui table)))
    (unless (member (hunchentoot:session-value :user hunchentoot:*session*)
                    (list (ui::player-user :white ui)
                          (ui::player-user :black ui)))
      (dolist (player '(:white :black))
        (when (null (ui::player-user player ui))
          (setf (ui::player-user player ui) (hunchentoot:session-value :user hunchentoot:*session*))
          (hunchensocket:send-text-message connection (jonathan:to-json `("player" ,(string-downcase (string player)))))
          (return))))
    ;; ...
    (dolist (player '(:white :black))
      (when (ui::user= (ui::connection-user connection) (ui::player-user player ui)) 
        (hunchensocket:send-text-message connection (jonathan:to-json `("player" ,(string-downcase (string player)))))
        (return)))
    (when (and (ui::player-user :white ui)
               (ui::player-user :black ui)
               (null (game:turn (game:game (session table))))
               (null (game::dice (game:game (session table)))))
      (put-event (make-initial-roll-event :source (game:game (session table))
                                          :dice (game::random-dice))
                 (event-queue table))))
  #+nil (destructuring-bind (white-points black-points) (game::score (session table))
          (hunchensocket:send-text-message user (jonathan:to-json `("score" ,white-points ,black-points))))
  (ui:refresh (game:game (session table)) (ui table)))

;; TODO formalize the protocol

(defvar *connection*)

(defmethod hunchensocket:text-message-received ((table table) connection message)
  ;; todo error handling
  (let ((e (ignore-errors (let ((*player* (find-if (lambda (player)
                                                     (eql (ui::player-user player (ui table))
                                                          (ui::connection-user connection)))
                                                   '(:white :black)))
                                (*game* (game:game (session table)))
                                (*session* (session table))
                                (*connection* connection)
                                (*user* (ui::connection-user connection))
                                (*table* table))
                            (decode-event (jonathan:parse message))))))
    (when e
      (let ((*event-queue* (event-queue table)))
        (put-event e)))))

(defmethod hunchensocket:client-disconnected ((table table) (user connection))
  )


(defclass match-table (table)
  ())

(defmethod initialize-instance :after ((table match-table) &key
                                                           limit
                                                           (game-class *game-class*)
                                                           (match-class *match-class*)
                                                           (cube t)
                                                           &allow-other-keys)
  (check-type limit (integer 1 21))
  (setf (slot-value table 'session) (make-instance match-class
                                                   :game-class game-class
                                                   :cube cube
                                                   :limit limit)))

(defclass money-session-table (table)
  ())

(defmethod initialize-instance :after ((table money-session-table) &key
                                                                   (game-class *game-class*)
                                                                   (match-class *money-session-class*)
                                                                   (cube t)
                                                                   (jacoby t)
                                                                   &allow-other-keys)
  (setf (slot-value table 'session) (make-instance match-class
                                                   :game-class game-class
                                                   :cube cube
                                                   :jacoby jacoby)))


(defstruct (user-preference-event (:include event))
  user
  option
  value)

;;; hmmm
#+nil (defun user-preference-event-handler (event)
  (let ((user (user-preference-event-user event))
        (option (user-preference-event-option event))
        (value (user-preference-event-value event)))
    (setf (gethash option (user::preferences user)) value)))

(defstruct (proposal-event (:include event))
  connection)

(defstruct (proposal-decision-event (:include event))
  accept-p)

(defstruct (proposal-cancel-event (:include event))
  user)

;; TODO ??? spontaneous doubling in proposals?
;; TOOD proposal-decision-event received twice

;; TODO error handling

;; TODO call a generic function on UI
(defun show-proposal (table)
  (let* ((ui (ui table))
         (white (ui::player-user :white ui))
         (from (ui::connection-user (proposal table))))
    (dolist (connection (ui::connections ui))
      (when (eql (ui::connection-user connection) white)
        (hunchensocket:send-text-message connection (jojo:to-json `("proposal" ,(ui::name from))))))))

(defun cancel-all-user-proposals (user table)
  (setf (slot-value table 'proposals)
        (loop for connection in (proposals table)
              if (eql (ui::connection-user connection) user) do (hunchensocket:close-connection connection)
              else collect connection)))

(defun reject-all-user-proposals (user table)
  (setf (slot-value table 'proposals)
        (loop for connection in (proposals table)
              if (eql (ui::connection-user connection) user) do (ui::send-to-connection '("rejected") connection) (hunchensocket:close-connection connection)
              else collect connection)))

(defun accept-proposal (table)
  (let ((black (ui::connection-user (proposal table))))
    (dolist (connection (ui::connections (ui table)))
      (ui::send-to-connection (if (eql (ui::connection-user connection) black)
                                  '("accepted")
                                  '("rejected"))
                              connection)
      #+nil (hunchensocket:close-connection connection))
      ;; this shouldn't be here
    (dolist (connection (ui::connections (ui table)))
      (when (eql (ui::connection-user connection) black)
        (ui::send-to-connection '("player" "black") connection)))
    (setf (slot-value table 'proposals) nil)
    (setf (ui::player-user :black (ui table)) black)))

(defun notify-canceled-proposal (table)
  (let* ((ui (ui table))
         (white (ui::player-user :white ui))
         (from (ui::connection-user (proposal table))))
    (dolist (connection (ui::connections ui))
      (when (eql (ui::connection-user connection) white)
        (hunchensocket:send-text-message connection (jojo:to-json `("cancelled" ,(ui::name from)))))))
  )

(eval-when (:compile-toplevel :load-toplevel :execute)
  
  (defmethod fsm:state-bindings ((machine (eql 'proposal-machine)) (state (eql 'considering)) arguments)
  (destructuring-bind (event-v table-v) arguments
    (lambda (form)
      `(let ((proposal? (proposal-event-p ,event-v))
             (cancelled? (proposal-cancel-event-p ,event-v))
             (more-proposals? (flet ((different-user-p (connection)
                                       (not (eql (ui::connection-user connection)
                                                 (ui::connection-user (proposal ,table-v))))))
                                (some #'different-user-p (rest (proposals ,table-v)))))
             (holds? (member (ui::connection-user (proposal table)) (proposals table) :key #'ui::connection-user)))
         (multiple-value-bind (accepted? rejected?) (if (proposal-decision-event-p ,event-v)
                                                        (if (proposal-decision-event-accept-p ,event-v)
                                                            (values t nil)
                                                            (values nil t))
                                                        (values nil nil))
           ,form))))))

;;; todo white cancels table
(fsm:defmachine proposal-machine (event table)
  (:initial-state waiting) 
  (:state waiting
   (:arc
     :to considering
     :when (proposal-event-p event)
     :action (progn
               (setf (proposal table) (proposal-event-connection event)
                     (proposals table) (list (proposal-event-connection event)))
               (show-proposal table))))
  (:state considering
   (:arc
     :to considering
     :when proposal?
     :action (nconc (proposals table) (list (proposal-event-connection event))))
   (:arc
     :to considering
     :when cancelled?
     :action (cancel-all-user-proposals (proposal-cancel-event-user event) table))
   (:arc
     :to considering
     :when (and rejected? more-proposals?)
     :action (progn
               (reject-all-user-proposals (ui::connection-user (proposal table)) table)
               (setf (proposal table) (first (proposals table)))
               (show-proposal table)))
   (:arc
     :to waiting
     :when (and rejected? (not more-proposals?))
     :action (progn
               (reject-all-user-proposals (ui::connection-user (proposal table)) table)
               (setf (proposal table) nil)))
   (:arc
     :to game
     :when (and accepted? holds?)
     :action (accept-proposal table))
   (:arc
     :to considering
     :when (and (and accepted? (not holds?))
                more-proposals?)
     :action (progn
               (notify-canceled-proposal table)
               (setf (proposal table) (first (proposals table)))
               (show-proposal table)))
   (:arc
     :to waiting
     :when (and (and accepted? (not holds?)) (not more-proposals?))
     :action (progn
               (notify-canceled-proposal table)
               (setf (proposal table) nil))))
  (:state game))

(define-event-code ("proposal-decision" reply) (make-proposal-decision-event :source *table* :accept-p (equal reply "yes")))

(define-event-code ("proposal") (make-proposal-event :source *table* :connection *connection*))

(define-event-code ("proposal-cancel") (make-proposal-cancel-event :source *table* :user *user*))


(defstruct (proposal-cancel-event (:include event))
  user)

#+nil (defun make-table-handler (table)
  (let* ((session (session table))
         (ui (ui table))
         (session-handler (make-match-handler session ui)))
    (lambda (event)
      (let ((source (event-source event)))
        (cond ((member source (list session ui (game:game session)))
               (funcall session-handler event))
              ((and (eql source table)
                    (user-preference-event-p event))
               (user-preference-event-handler event)))))))

(defun make-table-handler (table)
  (let* ((session (session table))
         (ui (ui table))
         (session-handler (if (typep table 'match-table)
                              (make-match-handler session ui)
                              (make-money-handler session ui)))
         (proposal-handler (let ((m (proposal-machine)))
                             (lambda (event)
                               (funcall m event table))))
         (handler proposal-handler))
    (lambda (event)
      (if (client-connected-event-p event)
          (let ((connection (client-connected-event-connection event)))
            (cond ((null (ui::player-user :white ui))
                   (setf (ui::player-user :white ui) (ui::connection-user connection))
                   (ui::send-to-connection '("player" "white") connection)
                   (ui:refresh (game:game (session table)) (ui table)))
                  ((eql (ui::connection-user connection) (ui::player-user :white (ui table)))
                   (ui::send-to-connection '("player" "white") connection)
                   (ui:refresh (game:game (session table)) (ui table)))
                  ((eql (ui::connection-user connection) (ui::player-user :black (ui table)))
                   (ui::send-to-connection '("player" "black") connection)
                   (ui:refresh (game:game (session table)) (ui table)))))
          (cond ((and (eql handler proposal-handler)
                      (eql (funcall handler event) 'game))
                 (setf handler session-handler)
                 (put-event (make-initial-roll-event :source (game:game (session table))
                                                     :dice (game::random-dice))
                            (event-queue table))
                 (ui:refresh (game:game session) ui))
                ((eql handler proposal-handler)
                 ;; relax, we have already called it
                 )
                (t (funcall handler event))))
      )))

;;; TODO: something about the clients' behaviour
;;; perhaps if everyone goes away, a special event could be generated
;;; todo I think this one processes an event with null source
(defun table-loop (table)
  (let ((*event-queue* (event-queue table)))
    (let ((handler (make-table-handler table)))
      (loop until (game::finished-p (session table))
            do (funcall handler (get-event))
            finally (remhash (table-id table) *tables*)))))