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))
                 ()))))))