Add score table

client/src/arena.lisp

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

(defclass arena (lockable subscriber)
  ((player :reader player-of)
   (dudes :initform (make-hash-table :test 'equal))))
   (dudes :initform (make-hash-table :test 'equal))
   (score-table :initform (make-hash-table :test 'equal))))


(defun dudes-of (arena)
@@ -24,6 +25,20 @@
      (gethash name dudes))))


(defun register-hit (arena player)
  (with-slots (score-table) arena
    (with-instance-lock-held (arena)
      (incf (gethash (name-of player) score-table 0)))))


(defun score (arena)
  (with-slots (score-table) arena
    (with-instance-lock-held (arena)
      (loop for name being the hash-key of score-table
         using (hash-value score)
         collect (cons name score)))))


(defun update-game-state (this state timestamp)
  (with-slots (dudes player) this
    (dolist (dude-state (getf state :player-list))

client/src/ball.lisp

@@ -1,7 +1,26 @@
(in-package :mortar-combat)


(defclass ball-geom (ownable collidable sphere-geom) ())
(defclass ball-geom (ownable collidable sphere-geom)
  ((body :initarg :body :accessor body-of)))


(defmethod collide ((this ball-geom) (that ball-geom))
  nil)


(defmethod filter-contacts (contacts (this ball-geom) (that dude-bounds))
  (unless (or (eq (owner-of this) (owner-of that))
              (< (vector-length (linear-velocity-of (body-of this))) 10))
    (post (make-hit-detected (owner-of that)) (events)))
  contacts)


(defmethod filter-contacts (contacts (that dude-bounds) (this ball-geom))
  (filter-contacts contacts this that))


;;
(defclass ball-body (disposable)
  (body geom))

@@ -10,6 +29,7 @@
  (with-slots (body geom) this
    (setf body (make-rigid-body)
          geom (make-instance 'ball-geom
                              :body body
                              :owner owner
                              :radius (/ 1.025 2)))
    (when force

client/src/events.lisp

@@ -57,3 +57,7 @@


(defevent arena-leave-requested () ())


(defevent hit-detected ()
  (player))

client/src/game-client.lisp

@@ -49,3 +49,14 @@
      (when-let ((dude (find-dude arena player-name)))
        (post (make-trigger-pulled dude) (events)))))
  nil)


(defmethod process-command ((command (eql :server-hit-info)) message)
  (with-slots (arena) *connector*
    (with-message (player-name) message
      (let ((dude (find-dude arena player-name))
            (player (player-of arena)))
        (cond
          (dude (register-hit arena dude))
          ((equal player-name (name-of player)) (register-hit arena player))))))
  nil)

client/src/game-server.lisp

@@ -18,10 +18,23 @@
           ())))


(defun broadcast-hit-info (server player)
  (run (-> (server :command :server-hit-info
                   :no-reply t
                   :player-name (name-of player))
           ())))


(defmethod initialize-instance :after ((this game-server) &key)
  (flet ((broadcast-shot (ev)
           (broadcast-shot-info this (player-from ev))))
  (register-event-handler 'trigger-pulled #'broadcast-shot)))
  (with-slots (arena) this
    (flet ((broadcast-shot (ev)
             (broadcast-shot-info this (player-from ev)))
           (broadcast-hit (ev)
             (let ((player (player-from ev)))
               (register-hit arena player)
               (broadcast-hit-info this player))))
      (register-event-handler 'trigger-pulled #'broadcast-shot)
      (register-event-handler 'hit-detected #'broadcast-hit))))


(defmethod process-command ((command (eql :register-player)) message)

client/src/main.lisp

@@ -137,7 +137,8 @@
                            'exit-requested
                            'new-arena-requested
                            'arena-join-requested
                            'arena-leave-requested)
                            'arena-leave-requested
                            'hit-detected)
    (register-poiu-events (events))
    (setf keymap (make-instance 'keymap)
          task-queue (make-task-queue))

client/src/ui.lisp

@@ -1,6 +1,14 @@
(in-package :mortar-combat)


(defun fill-score-table (layout arena)
  (abandon-all layout)
  (loop for (name . score) in (score arena)
     do
       (adopt layout (make-text-label name :align :left))
       (adopt layout (make-text-label (format nil "~A" score) :align :right))))


(defun make-ui (board)
  (enable-mouse-input board)
  (enable-character-input board)
@@ -12,17 +20,16 @@
                                                  :title "Enter arena name:"
                                                  :headerless nil
                                                  :hidden t))
        (game-menu (make-board-window board 20 536 760 44 :hidden t))
        (game-menu (make-board-window board 20 236 760 250 :hidden t))
        (combat-zone (make-board-window board 10 10 780 580 :hidden t))
        (login-dialog (make-board-window board 300 200 200 145
                                  :title "Enter your name:"
                                  :headerless nil)))
    (adopt-layout-by (main-menu)
      ((dynamic-row-layout 32 1)
      ((dynamic-row-layout 32 :columns 1)
       ((label-button "Combat zone" :name :combat-zone))
       ((label-button "Quit" :name :quit))))


    (adopt-layout-by (login-dialog)
      ((dynamic-row-layout 32)
       ((text-edit :name :nickname)))
@@ -32,7 +39,6 @@
       ((spacing))
       ((label-button "Log in" :name :login))))


    (adopt-layout-by (arena-creation-dialog)
      ((dynamic-row-layout 32)
       ((text-edit :name :arena-name)))
@@ -45,21 +51,25 @@
    (adopt-layout-by (game-menu)
      ((dynamic-row-layout 32)
       ((label-button "Leave arena" :name :leave))
       ((label-button "Quit" :name :quit))))
       ((label-button "Quit" :name :quit)))
      ((dynamic-row-layout 26)
       ((text-label "Score:")))
      ((dynamic-row-layout 32 :columns 2 :name :score-table)))

    (adopt-layout-by (combat-zone)
      ((dynamic-row-layout 32)
       ((label-button "Create" :name :create))
       ((label-button "Join" :name :join))
       ((label-button "Refresh " :name :refresh))
       ((label-button "Main menu" :name :zone-to-main-menu)))
      ((dynamic-row-layout 32 1)
      ((dynamic-row-layout 32 :columns 1)
       ((text-label "Available arenas:"))
       ((list-select 32 :name :arena-list))))

    (let ((nickname-edit (find-element login-dialog :nickname))
          (arena-name-edit (find-element arena-creation-dialog :arena-name))
          (arena-list (find-element combat-zone :arena-list))
          (score-table (find-element game-menu :score-table))
          (selected-arena))
      (flet ((refresh-arena-list ()
               (run (>> (load-arena-list)
@@ -73,8 +83,10 @@
                 (run (>> (-> ((mortar-combat)) ()
                            (let ((hidden-p (hiddenp game-menu)))
                              (if hidden-p
                                   (show-window game-menu)
                                   (hide-window game-menu))
                                  (progn
                                    (fill-score-table score-table (arena-of *system*))
                                    (show-window game-menu))
                                  (hide-window game-menu))
                              hidden-p))
                          (-> ((host)) (was-hidden-p)
                            (if was-hidden-p

mortar-combat.asd

@@ -35,9 +35,9 @@
               (:file "arena")
               (:file "camera")
               (:file "room")
               (:file "ball")
               (:file "mortar")
               (:file "dude")
               (:file "ball")
               (:file "shaders/dude")
               (:file "shaders/passthru")
               (:file "connector")