Game server and client

client/src/connector.lisp

@@ -3,7 +3,8 @@

(define-constant +supported-server-version+ 1)

(declaim (special *message*))
(declaim (special *message*
                  *connector*))

(defstruct (server-identity
             (:constructor make-server-identity (id name)))
@@ -17,39 +18,36 @@

(defclass connector (lockable disposable dispatcher)
  ((enabled-p :initform t)
   (connection :initarg :connection :reader connection-of)
   (connection :initform nil :reader connection-of)
   (message-counter :initform 0)
   (message-table :initform (make-hash-table :test 'eql))))


(defmethod initialize-instance :after ((this connector) &key)
(defmethod initialize-instance :after ((this connector) &key host port)
  (with-slots (connection message-table enabled-p) this
    (setf connection  (usocket:socket-connect host port
                                              :element-type '(unsigned-byte 8)
                                              :timeout 30))
    (in-new-thread "connector-thread"
      (loop while enabled-p
         do (log-errors
              (usocket:wait-for-input connection)
              (let* ((stream (connection-stream-of this))
                     (message (decode-message stream)))
                     (message (decode-message stream))
                     (*connector* this))
                (if-let ((reply-id (getf message :reply-for)))
                  (with-instance-lock-held (this)
                    (if-let ((handler (gethash reply-id message-table)))
                      (progn
                        (remhash reply-id message-table)
                        (funcall handler message))
                      (log:error "Handler not found for message with id ~A" reply-id)))
                  (progn
                    (encode-message (process-command (getf message :command) message) stream)
                  (when-let ((reply (process-command (getf message :command) message)))
                    (encode-message reply stream)
                    (force-output stream)))))
         finally (usocket:socket-close connection)))))


(defun connect-to-server (host port)
  (make-instance 'connector
                 :connection (usocket:socket-connect host port
                                                     :element-type '(unsigned-byte 8)
                                                     :timeout 30)))


(defun disconnect-from-server (connector)
  (with-slots (enabled-p) connector
    (setf enabled-p nil)))
@@ -70,9 +68,14 @@
    (finish-output stream)))


(defmacro with-response (command-name (&rest properties) response &body body)
  `(destructuring-bind (&key ,@properties &allow-other-keys) ,response
     (check-response ,response ,command-name)
(defmacro with-message ((&rest properties) message &body body)
  `(destructuring-bind (&key ,@properties &allow-other-keys) ,message
     ,@body))


(defmacro with-response ((&rest properties) command-name &body body)
  `(with-message (,@properties) *message*
     (check-response *message* ,command-name)
     ,@body))


@@ -84,46 +87,47 @@
        (flet ((response-callback (message)
                 (let ((*message* message))
                   (funcall task))))
          (setf (gethash next-id message-table) #'response-callback)
          (unless (getf keys :no-reply)
            (setf (gethash next-id message-table) #'response-callback))
          (apply #'send-command this :message-id next-id keys))))))


(defun server-version (connector)
  (-> (connector :command :version) ()
    (with-response :version (version) *message*
    (with-response (version) :version
      version)))


(defun identify (connector name)
  (-> (connector :command :identify :name name) ()
    (with-response :identified (id name) *message*
    (with-response (id name) :identified
      (make-server-identity id name))))


(defun create-arena (connector name)
  (-> (connector :command :create-arena :name name) ()
    (with-response :ok () *message*)))
    (with-response () :ok)))


(defun join-arena (connector name)
  (-> (connector :command :join-arena :name name) ()
    (with-response :ok () *message*)))
    (with-response () :ok)))


(defun get-arena-list (connector)
  (-> (connector :command :get-arena-list) ()
    (with-response :arena-list (list) *message*
    (with-response (list) :arena-list
      list)))


(defun register-game-stream (connector peer-id)
  (-> (connector :command :register-game-stream :peer-id peer-id) ()
    (with-response :ok () *message*)))
    (with-response () :ok)))


(defun ping-peer (connector)
  (-> (connector :command :ping) ()
    (with-response :ok () *message*)))
    (with-response () :ok)))


(defmethod process-command ((command (eql :ping)) message)

client/src/dude.lisp

@@ -78,6 +78,7 @@
(defclass dude-model (model)
  ((mesh :initform nil)
   (body :initform nil)
   (player :initarg :player)
   (program :initform nil)
   (run-animation :initform nil)
   (rest-animation :initform nil)
@@ -118,9 +119,11 @@
(defmethod model-graph-assembly-flow ((this dude-model))
  (with-slots (skeleton mesh program color rest-animation) this
    (scenegraph
     ((animation-node :initial-animation rest-animation :name :dude-animation)
      ((animated-skeleton-node :root-bone skeleton)
       ((dude-mesh :mesh mesh :program program :color color)))))))
     (scene-node
      ((animation-node :initial-animation rest-animation :name :dude-animation)
       ((animated-skeleton-node :root-bone skeleton)
        ((dude-mesh :mesh mesh :program program :color color))))
      (mortar-model)))))


(defmethod scene-pass ((this dude-model) (pass simulation-pass) input)
@@ -135,5 +138,11 @@
    (call-next-method))


(defmethod scene-pass ((this dude-model) (pass rendering-pass) input)
  (call-next-method))
(defmethod scene-pass ((this dude-model) pass input)
  (with-slots (player) this
    (let* ((pos (position-of player))
           (rot (rotation-of player))
           (*model-matrix* (mult *model-matrix*
                                 (translation-mat4 (x pos) 0.0 (- (y pos)))
                                 (euler-angles->mat4 (vec3 0.0 (y rot) 0.0)))))
      (call-next-method))))

client/src/events.lisp

@@ -0,0 +1,5 @@
(in-package :mortar-combat)


(defevent player-added-event ()
  (player))

client/src/game-client.lisp

@@ -0,0 +1,25 @@
(in-package :mortar-combat)


(defclass game-client (connector) ()
  (:default-initargs :host "localhost" :port 8222))


(defun make-game-client ()
  (make-instance 'game-client))


(defun register-player (client name)
  (run (-> (client :command :register-player
                   :name name)
           ())))


(defun send-player-info (client name player)
  (let ((pos (position-of player))
        (rot (rotation-of player)))
    (run (-> (client :command :player-info
                     :name name
                     :position (list (x pos) (y pos))
                     :rotation (list (x rot) (y rot)))
             ()))))

client/src/game-server.lisp

@@ -0,0 +1,30 @@
(in-package :mortar-combat)


(defclass game-server (connector)
  ((players :initform (make-hash-table :test 'equal)))
  (:default-initargs :host "localhost" :port 8222))


(defun make-game-server ()
  (make-instance 'game-server))


(defmethod process-command ((command (eql :register-player)) message)
  (with-slots (players) *connector*
    (with-message (name) message
      (with-instance-lock-held (*connector*)
        (let ((player (make-instance 'player)))
          (setf (gethash name players) player)
          (post (make-player-added-event player) (events))))))
  nil)


(defmethod process-command ((command (eql :player-info)) message)
  (with-slots (players) *connector*
    (with-message (name position rotation) message
      (with-instance-lock-held (*connector*)
        (when-let ((player (gethash name players)))
          (setf (position-of player) (sequence->vec2 position)
                (rotation-of player) (sequence->vec2 rotation))))))
  nil)