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