Add arena object

client/src/arena.lisp

@@ -0,0 +1,75 @@
+(in-package :mortar-combat)
+
+
+(defclass arena (lockable subscriber)
+  ((player :reader player-of)
+   (dudes :initform (make-hash-table :test 'equal))))
+
+
+(defun dudes-of (arena)
+  (with-slots (dudes) arena
+    (loop for dude being the hash-value of dudes
+       collect dude)))
+
+
+(defun add-dude (arena dude)
+  (with-slots (dudes) arena
+    (with-instance-lock-held (arena)
+      (setf (gethash (name-of dude) dudes) dude))))
+
+
+(defun find-dude (arena name)
+  (with-slots (dudes) arena
+    (with-instance-lock-held (arena)
+      (gethash name dudes))))
+
+
+(defun update-game-state (this state timestamp)
+  (with-slots (dudes player) this
+    (dolist (dude-state (getf state :player-list))
+      (with-instance-lock-held (this)
+        (let* ((dude-name (getf dude-state :name))
+               (dude (gethash dude-name dudes)))
+          (unless (equal dude-name (name-of player))
+            (unless dude
+              (setf dude (make-instance 'proxy :name dude-name)
+                    (gethash dude-name dudes) dude)
+              (post (make-player-added dude) (events)))
+            (update-proxy dude
+                          (sequence->vec2 (getf dude-state :position))
+                          (sequence->vec2(getf dude-state :rotation))
+                          timestamp)))))))
+
+
+(defun shoot-ball (player)
+  (let ((pos (position-of player)))
+    (run (>> (assembly-flow 'ball-model
+                            :position (vec3 (+ (x pos) 1.0) 10.0 (- (y pos)))
+                            :force (mult (gaze-of player) 10000))
+             (-> ((mortar-combat)) (ball)
+               (let ((group (find-node (root-of (scene-of *system*)) :ball-group)))
+                 (adopt group ball)))))))
+
+
+(defmethod initialize-instance :after ((this arena) &key player-name)
+  (with-slots (player dudes) this
+    (unless player-name
+      (error "Player name should be provided for arena"))
+    (setf player (make-instance 'player :name player-name))
+    (flet ((add-player (ev)
+             (run (>> (assembly-flow 'dude-model
+                                     :player (player-from ev)
+                                     :color (vec3 0.9 0.4 0.4))
+                      (-> ((mortar-combat)) (dude)
+                        (let ((dude-group (find-node (root-of (scene-of *system*)) :dude-group)))
+                          (adopt dude-group dude))))))
+           (game-state-updated (ev)
+             (update-game-state this (state-from ev) (timestamp-from ev)))
+           (shoot (ev)
+             (declare (ignore ev))
+             (shoot-ball player))
+           (update-velocity (ev)
+             (setf (velocity-of player) (velocity-from ev))))
+      (register-event-handler 'trigger-pulled #'shoot)
+      (register-event-handler 'player-added #'add-player)
+      (register-event-handler 'game-state-updated #'game-state-updated))))

client/src/camera.lisp

@@ -2,14 +2,17 @@
 
 
 (defclass player-camera (camera-node)
-  ((player :initarg :player)
+  ((player :initarg :player :initform nil :accessor player-of)
    (front-gaze :initform (vec3 0.0 0.0 -1.0))))
 
 
 (defmethod scene-pass ((this player-camera) pass input)
   (with-slots (player front-gaze) this
-    (let* ((pos (position-of player))
-           (rotation (rotation-of player)))
-      (setf (transform-of this) (mult (euler-angles->mat4 (vec3 (- (x rotation)) (- (y rotation)) 0.0))
-                                      (translation-mat4 (- (x pos)) -13.0 (y pos))))))
+    (when player
+      (let* ((pos (position-of player))
+             (rotation (rotation-of player)))
+        (setf (transform-of this) (mult (euler-angles->mat4 (vec3 (- (x rotation))
+                                                                  (- (y rotation))
+                                                                  0.0))
+                                        (translation-mat4 (- (x pos)) -13.0 (y pos)))))))
   (call-next-method))

client/src/events.lisp

@@ -1,5 +1,44 @@
 (in-package :mortar-combat)
 
 
-(defevent player-added-event ()
+(defclass subscriber (disposable)
+  ((callbacks :initform (cons nil nil))))
+
+
+(defun register-event-handler (class handler)
+  (declare (special *callbacks*))
+  (push (cons class (subscribe-to class handler (events))) *callbacks*))
+
+
+(defmethod initialize-instance :around ((this subscriber) &key)
+  (with-slots (callbacks) this
+    (let ((*callbacks* (list)))
+      (declare (special *callbacks*))
+      (call-next-method)
+      (rplacd callbacks *callbacks*))))
+
+
+(define-destructor subscriber (callbacks)
+  (loop with eve = (events)
+     for (class . cb) in (cdr callbacks)
+     do (unsubscribe-from class cb eve)))
+
+
+;;
+(defevent player-added ()
   (player))
+
+
+(defevent game-state-updated ()
+  (state timestamp))
+
+
+(defevent camera-rotated ()
+  (ax ay))
+
+
+(defevent velocity-changed ()
+  (velocity))
+
+
+(defevent trigger-pulled () ())

client/src/game-client.lisp

@@ -1,13 +1,14 @@
 (in-package :mortar-combat)
 
 
-(defclass game-client (connector) ()
+(defclass game-client (connector)
+  ((arena :initarg :arena))
   (:default-initargs :host (property :server-address "127.0.0.1")
     :port (property :proxy-server-port 8222)))
 
 
-(defun make-game-client ()
-  (make-instance 'game-client))
+(defun make-game-client (arena)
+  (make-instance 'game-client :arena arena))
 
 
 (defun register-player (client name)
@@ -16,12 +17,18 @@
            ())))
 
 
-(defun send-player-info (client name player)
+(defun send-player-info (client player)
   (let ((pos (position-of player))
         (rot (rotation-of player)))
     (run (-> (client :command :player-info
-                     :name name
+                     :no-reply t
+                     :name (name-of player)
                      :timestamp (real-time-seconds)
                      :position (list (x pos) (y pos))
                      :rotation (list (x rot) (y rot)))
              ()))))
+
+
+(defmethod process-command ((command (eql :game-state)) message)
+  (post (make-game-state-updated (getf message :state) (getf message :timestamp)) (events))
+  nil)

client/src/game-server.lisp

@@ -2,29 +2,43 @@
 
 
 (defclass game-server (connector)
-  ((players :initform (make-hash-table :test 'equal)))
+  ((arena :initarg :arena))
   (:default-initargs :host (property :server-address "127.0.0.1")
     :port (property :proxy-server-port 8222)))
 
 
-(defun make-game-server ()
-  (make-instance 'game-server))
+(defun make-game-server (arena)
+  (make-instance 'game-server :arena arena))
 
 
 (defmethod process-command ((command (eql :register-player)) message)
-  (with-slots (players) *connector*
+  (with-slots (arena) *connector*
     (with-message (name) message
-      (with-instance-lock-held (*connector*)
-        (let ((player (make-instance 'proxy)))
-          (setf (gethash name players) player)
-          (post (make-player-added-event player) (events))))))
+      (let ((player (make-instance 'proxy :name name)))
+        (add-dude arena player)
+        (post (make-player-added player) (events)))))
   nil)
 
 
 (defmethod process-command ((command (eql :player-info)) message)
-  (with-slots (players) *connector*
+  (with-slots (arena) *connector*
     (with-message (name position rotation timestamp) message
-      (with-instance-lock-held (*connector*)
-        (when-let ((player (gethash name players)))
-          (update-proxy player (sequence->vec2 position) (sequence->vec2 rotation) timestamp)))))
+      (when-let ((player (find-dude arena name)))
+        (update-proxy player (sequence->vec2 position) (sequence->vec2 rotation) timestamp))))
   nil)
+
+
+(defun broadcast-game-state (server)
+  (with-slots (arena) server
+    (flet ((player-info (p)
+             (let ((pos (position-of p))
+                   (rot (rotation-of p)))
+             (list :name (name-of p)
+                   :position (list (x pos) (y pos))
+                   :rotation (list (x rot) (y rot))))))
+      (let ((proxies (mapcar #'player-info (cons (player-of arena) (dudes-of arena)))))
+        (run (-> (server :command :game-state
+                         :no-reply t
+                         :timestamp (real-time-seconds)
+                         :state (list :player-list proxies))
+                 ()))))))