3 files changed, 98 insertions(+), 84 deletions(-)

M src/engine.lisp
M src/json.lisp
M src/ur-game.lisp

@@ 3,7 3,6 @@
   (:import-from :alexandria
                 :switch)
   (:export :game
-           :make-game
            :winner
 
            ;; Game actions


@@ 16,8 15,7 @@
 
 (in-package #:ur-game.engine)
 
-(defun make-empty-path (length)
-  (make-array length :initial-element :none))
+
 
 ;; path lengths
 (defparameter +start-length+ 4)


@@ 28,15 26,14 @@
 
 (defparameter +starting-pieces+ 7)
 
-;; Rosette tiles protect pieces from battle and give the player a
-;; second turn
-(defparameter +rosettes+ '(4 8 14))
-
 ;; Board Data
 (defclass path-segment ()
   ((tile-vector :initarg :tile-vector :reader tile-vector)
-   (black-next :initarg :black-next :reader black-next)
-   (white-next :initarg :white-next :reader white-next)))
+   (black-next :initarg :black-next :reader black-next
+               :documentation "Next path segment for black checkers")
+   (white-next :initarg :white-next :reader white-next
+               :documentation "Next path segment for white checkers"))
+  (:documentation "A segment of a route that a game checker travels to reach the end."))
 
 (defun next-segment (path-segment color)
   (ecase color


@@ 44,13 41,16 @@
     (:white (white-next path-segment))))
 
 (defun route-length (path-segment color)
+  "Return the length of the entire route for the given color."
   (loop :for segment := path-segment :then (next-segment segment color)
         :while segment
         :sum (length (tile-vector segment))))
 
 (defun find-tile-vector (n path-segment color)
+  "If n is in-bounds, return two values: the vector that contains the nth tile,
+   and the offset to access that tile. Otherwise, return nil."
   (when (null path-segment)
-    (return-from find-tile-vector nil))
+    (return-from find-tile-vector))
 
   (let* ((tile-vector (tile-vector path-segment))
          (length (length tile-vector)))


@@ 61,6 61,7 @@
                           color))))
 
 (defun nth-tile (n path-segment color)
+  "Return the nth tile for the given color's route."
   (multiple-value-bind (vector relative-n)
     (find-tile-vector n path-segment color)
 


@@ 68,6 69,7 @@
       (aref vector relative-n))))
 
 (defun (setf nth-tile) (new-value n path-segment color)
+  "Set the nth tile for the given color's route."
   (multiple-value-bind (vector relative-n)
     (find-tile-vector n path-segment color)
 


@@ 75,6 77,7 @@
       (setf (aref vector relative-n) new-value))))
 
 (defun route-tiles (path-segment color)
+  "Return a vector of all path segments concatenated together."
   (loop :for segment := path-segment :then (next-segment segment color)
         :while segment
         :collect (tile-vector segment) :into vectors


@@ 85,7 88,8 @@
    (white-start :initarg :white-start)
    (shared-middle :initarg :shared-middle)
    (black-end :initarg :black-end)
-   (white-end :initarg :white-end)))
+   (white-end :initarg :white-end))
+  (:documentation "Collection of all tile vectors"))
 
 (defun make-tile-vector (length)
   (make-array length :initial-element :none))


@@ 120,8 124,10 @@
                            :white-next shared-path-segment))))
 
 (defun rosettep (index)
-  "Return whether the tile has a rosette"
-  (member index +rosettes+))
+  "Return whether the tile index has a rosette"
+  (member index '(4 8 14)))
+
+
 
 (defclass player ()
   ((start-path :initarg :start-path


@@ 133,23 139,20 @@
 
 (defclass game ()
   ((random-state :initform (make-random-state t))
-   (black :initarg :black
-          :reader black-player)
-   (white :initarg :white
-          :reader white-player)
-   (board :initarg :board
-          :reader board)
+   (black :reader black-player)
+   (white :reader white-player)
+   (board :reader board)
    (turn :initform :white
          :accessor turn)
    (last-roll :initform nil
               :accessor last-roll)))
 
-(defun make-game ()
-  (multiple-value-bind (board black-path white-path) (make-board-and-paths)
-    (make-instance 'game
-                   :black (make-instance 'player :start-path black-path)
-                   :white (make-instance 'player :start-path white-path)
-                   :board board)))
+(defmethod initialize-instance :after ((instance game) &key &allow-other-keys)
+  (multiple-value-bind (new-board black-path white-path) (make-board-and-paths)
+    (with-slots (black white board) instance
+      (setf black (make-instance 'player :start-path black-path)
+            white (make-instance 'player :start-path white-path)
+            board new-board))))
 
 ;; TODO figure out how to separate this last piece of presentation from the
 ;; game engine.

@@ 9,6 9,8 @@
 
 (in-package #:ur-game.json)
 
+
+
 (defclass json-bool ()
   ((p :initarg :p :initform nil :reader json-bool-p)
    (generalised :initarg :generalised :initform nil))

@@ 17,6 17,8 @@
 
 (in-package #:ur-game)
 
+
+
 ;; Logging (TODO: set level in configuration.)
 
 (vom:config :ur-game :debug)


@@ 34,29 36,17 @@
 (defconstant +ws-code-opponent-disconnected+ 4000)
 (defconstant +ws-code-session-full+ 4002)
 
-(defclass session ()
-  ((game :initform nil :accessor game)
-   (token :initarg :token :reader token)
-   (clients :initform () :accessor clients)))
-
-(defun in-game-p (session)
-  (and (game session) t))
+(defvar *sessions* (make-hash-table :test 'equal))
 
-(defun game-over-p (session)
-  (and (= 2 (length (clients session)))
-       (null (game session))))
+(defun register-session (session)
+  (setf (gethash (slot-value session 'token) *sessions*)
+        session))
 
-(defun session-full-p (session)
-  (>= (length (clients session)) 2))
+(defun find-session (token)
+  (gethash token *sessions*))
 
-(defun add-client (session client)
-  "Attempt to add the client to the session, and return whether it was successful."
-  (if (session-full-p session)
-      (prog1 nil
-        (websocket-driver:close-connection
-          (ws client) "Session is already full" +ws-code-session-full+))
-      (prog1 t
-        (push client (clients session)))))
+(defun deregister-session (session)
+  (remhash (slot-value session 'token) *sessions*))
 
 ;; NOTE: The default generator from `session-token' grabs randomness
 ;; from /dev/urandom or /dev/arandom, and therefore doesn't work on


@@ 64,25 54,40 @@
 (defvar *game-token-generator*
   (session-token:make-generator :token-length 10))
 
-(defvar *sessions* (make-hash-table :test 'equal)
-  "Hash of sessions fetched by their token.")
-
-(defun start-session ()
-  (let* ((token (funcall *game-token-generator*))
-         (session (make-instance 'session :token token)))
-    (setf (gethash token *sessions*) session)
-    (vom:info "STARTED session ~A" token)
-    session))
+(defclass session ()
+  ((game :initform nil :accessor game)
+   (token :initform (funcall *game-token-generator*) :reader token)
+   (clients :initform () :accessor clients)))
 
-(defun find-session (token)
-  (gethash token *sessions*))
+(defmethod initialize-instance :after ((instance session) &key &allow-other-keys)
+  ;; Start and register the session
+  (register-session instance)
+  (vom:info "STARTED session ~A" (slot-value instance 'token)))
+
+(defun quit-session (session reason &key (code 1000))
+  "Disconnect all clients and deregister the game session."
+  (deregister-session session)
+  (dolist (client (clients session))
+    (websocket-driver:close-connection (ws client) reason code))
+  (vom:notice "STOPPED session ~A: ~A" (token session) reason))
+
+(defun session-status (session)
+  (with-slots (clients game) session
+    (cond
+      ((< (length clients) 2) :waiting-for-players)
+      (game :in-game)
+      (t :game-over))))
 
-(defun stop-session (session reason &key (code 1000))
-  "Disconnect all clients and remove the game session from memory."
-  (vom:notice "STOPPED session ~A: ~A" (token session) reason)
-  (loop :for client :in (clients session)
-        :do (websocket-driver:close-connection (ws client) reason code))
-  (remhash (token session) *sessions*))
+(defun add-client (session client)
+  "Attempt to add the client to the session, and return whether it was successful."
+  (if (eq :waiting-for-players (session-status session))
+      (progn
+        (push client (clients session))
+        t)
+      (progn
+        (websocket-driver:close-connection
+          (ws client) "Session is already full" +ws-code-session-full+)
+        nil)))
 
 (defclass client ()
   ((color :accessor color)


@@ 102,15 107,15 @@
   (send-message client message))
 
 (defun broadcast-message (session message)
-  "Send a message to all clients."
-  (loop :for client :in (clients session)
-        :do (send-message client message)))
+  "Send the same message to all clients."
+  (dolist (client (clients session))
+    (send-message client message)))
 
 (defun broadcast-message* (session &rest message)
   (broadcast-message session message))
 
 (defun start-game (session)
-  (setf (game session) (make-game))
+  (setf (game session) (make-instance 'game))
   (let ((clients (alexandria:shuffle (clients session))))
     (setf (color (first clients)) :white
           (color (second clients)) :black)


@@ 127,22 132,7 @@
                       :game (game session))
   (setf (game session) nil))
 
-(defun handle-new-connection (session client)
-  (unless (add-client session client)
-    (return-from handle-new-connection))
-
-  (if (session-full-p session)
-      (start-game session)
-      (send-message* client
-                     :op :game-token
-                     :token (token session))))
-
-(defun handle-close-connection (session client &key code reason)
-  (declare (ignore client code reason))
-  ;; TODO see if (stop-session) disconnecting clients manually triggers this event.
-  ;; TODO maybe maintain a session until it has 0 clients.
-  (stop-session session "Opponent disconnected"
-                :code +ws-code-opponent-disconnected+))
+
 
 ;; Request handling
 (defparameter *request-dispatch*


@@ 165,7 155,7 @@
 
 (defrequest handle-rematch "rematch" (session client message)
   (declare (ignore message))
-  (if (game-over-p session)
+  (if (eq :game-over (session-status session))
       (start-game session)
       (send-message* client
                      :op :error


@@ 244,10 234,27 @@
                      :op :err
                      :reason :no-such-operand))))
 
+(defun handle-new-connection (session client)
+  (unless (add-client session client)
+    (return-from handle-new-connection))
+
+  (if (eq :waiting-for-players (session-status session))
+      (send-message* client
+                     :op :game-token
+                     :token (token session))
+      (start-game session)))
+
+(defun handle-close-connection (session client &key code reason)
+  (declare (ignore client code reason))
+  ;; TODO see if (quit-session) disconnecting clients manually triggers this event.
+  ;; TODO maybe maintain a session until it has 0 clients.
+  (quit-session session "Opponent disconnected"
+                :code +ws-code-opponent-disconnected+))
+
 (defun session-app (env &optional token)
   (let* ((ws (websocket-driver:make-server env))
          (client (make-instance 'client :ws ws))
-         (session (or (find-session token) (start-session))))
+         (session (or (find-session token) (make-instance 'session))))
     (websocket-driver:on :open ws (curry 'handle-new-connection session client))
     (websocket-driver:on :message ws (curry 'handle-message session client))
     (websocket-driver:on :close ws (curry 'handle-close-connection session client))


@@ 256,6 263,8 @@
       (declare (ignore responder))
       (websocket-driver:start-connection ws))))
 
+
+
 (defun make-path-scanner (path-regex)
   "Converts a path regex like /a/b/{something}/c into a regex that captures {...}'s and "
   (let* ((query-replaced-paths (cl-ppcre:regex-replace-all