Add shooting

client/src/ball.lisp

@@ -6,13 +6,15 @@
   (body geom))
 
 
-(defmethod initialize-instance :after ((this ball-body) &key)
+(defmethod initialize-instance :after ((this ball-body) &key position force)
   (with-slots (body geom) this
     (setf body (make-rigid-body)
-          geom (make-instance 'ball-geom :radius 1.025))
-    (bind-geom geom body)
-
-    (setf (position-of body) (vec3 0.0 10.0 0.0))))
+          geom (make-instance 'ball-geom :radius (/ 1.025 2)))
+    (when force
+      (apply-force body force))
+    (when position
+      (setf (position-of body) position))
+    (bind-geom geom body)))
 
 
 (defmethod transform-of ((this ball-body))
@@ -60,14 +62,14 @@
   (body mesh program))
 
 
-(defmethod initialization-flow ((this ball-model) &key)
+(defmethod initialization-flow ((this ball-model) &key position force)
   (with-slots (body mesh program) this
     (>> (resource-flow "mesh.Ball" (shading-program-resource-name "passthru-program"))
         (instantly (m p)
           (setf mesh m
                 program p))
         (-> ((physics)) ()
-          (setf body (make-instance 'ball-body)))
+          (setf body (make-instance 'ball-body :position position :force force)))
         (call-next-method))))
 
 
@@ -84,7 +86,7 @@
 
 
 (defmethod scene-pass ((this ball-model) (pass rendering-pass) ball-transform)
-  (let ((*model-matrix* (mult *model-matrix* ball-transform)))
+  (let ((*model-matrix* ball-transform))
     (call-next-method)))
 
 

client/src/camera.lisp

@@ -10,6 +10,6 @@
   (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)) -10.0 (- (y pos)))))))
+      (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/dude.lisp

@@ -1,6 +1,41 @@
 (in-package :mortar-combat)
 
 
+(defclass dude-bounds (collidable cylinder-geom) ())
+
+
+(defclass dude-body (disposable)
+  (body bounds))
+
+
+(defmethod initialize-instance :after ((this dude-body) &key)
+  (with-slots (body bounds) this
+    (setf body (make-rigid-body)
+          bounds (make-instance 'dude-bounds
+                                :radius 2.0
+                                :length 13.0))
+    #++(bind-geom bounds body)))
+
+
+(define-destructor dude-body (body bounds)
+  (dispose bounds)
+  (dispose body))
+
+
+(defmethod (setf position-of) (value (this dude-body))
+  (with-slots (body) this
+    (setf (position-of body) value)))
+
+
+(defmethod transform-of ((this dude-body))
+  (with-slots (body) this
+    (transform-of body)))
+
+
+(defmethod rotation-of ((this dude-body))
+  (with-slots (body) this
+    (rotation-of body)))
+
 ;;;
 ;;;
 ;;;
@@ -33,12 +68,12 @@
                  (mult (bone-transform name) offset)))
       (call-next-method))))
 
-
 ;;;
 ;;;
 ;;;
 (defclass dude-model (model)
   ((mesh :initform nil)
+   (body :initform nil)
    (program :initform nil)
    (run-animation :initform nil)
    (rest-animation :initform nil)
@@ -51,7 +86,7 @@
 
 
 (defmethod initialization-flow ((this dude-model) &key)
-  (with-slots (mesh animation skeleton program
+  (with-slots (mesh animation skeleton program body
                     strafe-animation run-animation rest-animation)
       this
     (>> (resource-flow "mesh.Dude" "Stickman"
@@ -66,12 +101,35 @@
                 run-animation run
                 rest-animation rest
                 program p))
+        (-> ((physics)) ()
+          (setf body (make-instance 'dude-body)))
         (call-next-method))))
 
 
+(defmethod discard-node ((this dude-model))
+  (with-slots (body) this
+    (dispose body)))
+
+
 (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)))))))
+
+
+(defmethod scene-pass ((this dude-model) (pass simulation-pass) input)
+  (with-slots (body) this
+    #++(let* ((pos (mult *model-matrix* (vec4 0.0 0.0 0.0 1.0)))
+           (w (w pos)))
+      (flet ((w/ (v)
+               (/ v w)))
+        (setf (position-of body) (vec3 (w/ (x pos))
+                                       (w/ (y pos))
+                                       (w/ (z pos))))))
+    (call-next-method)))
+
+
+(defmethod scene-pass ((this dude-model) (pass rendering-pass) input)
+  (call-next-method))

client/src/keymap.lisp

@@ -8,6 +8,13 @@
    (key-table :initform (make-hash-table :test 'eq))))
 
 
+(defun mouse-button->keymap-button (button)
+  (case button
+    (:left :mouse-left)
+    (:right :mouse-right)
+    (:middle :mouse-middle)))
+
+
 (defun enable-keymap (keymap)
   (with-slots (callbacks cursor-action key-table) keymap
     (when callbacks
@@ -19,8 +26,9 @@
                (when-let ((action (gethash (key-from ev) key-table)))
                  (funcall action (state-from ev))))
              (process-button-event (ev)
-               (when-let ((action (gethash (button-from ev) key-table)))
-                 (funcall action (state-from ev))))
+               (let ((button (mouse-button->keymap-button (button-from ev))))
+                 (when-let ((action (gethash button key-table)))
+                   (funcall action (state-from ev)))))
              (process-cursor-event (ev)
                (when cursor-action
                  (funcall cursor-action (x-from ev) (y-from ev)))))

client/src/main.lisp

@@ -2,13 +2,15 @@
 
 
 (define-constant +framestep+ 0.016)
+(define-constant +player-speed+ 15.0)
 (defvar *main-latch* (mt:make-latch))
 
 
 
-(defclass mortar-combat (enableable generic-system)
-  ((scene :initform nil)
-   (keymap :initform (make-instance 'keymap))
+(defclass mortar-combat (enableable generic-system dispatcher)
+  ((scene :initform nil :reader scene-of)
+   (task-queue :initform nil)
+   (keymap :initform nil)
    (player :initform nil))
   (:default-initargs :depends-on '(graphics-system
                                    physics-system
@@ -25,17 +27,33 @@
     ((projection-node :aspect (/ 800 600))
      ((player-camera :player player)
       (room-model)
-      (ball-model)
-      ((transform-node :translation (vec3 4.0 0.0 0.0))
-       (mortar-model)
-       ((dude-model :color (vec3 0.9 0.4 0.4)))))))))
+      ((scene-node :name :ball-group))
+      ((dude-model :color (vec3 0.9 0.4 0.4))
+       (mortar-model)))))))
+
+
+(defmethod dispatch ((this mortar-combat) (task function) invariant &key)
+  (with-slots (task-queue) this
+    (push-task task task-queue)))
+
+
+(defun shoot-ball (scene 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) :ball-group)))
+                 (adopt group ball)))))))
 
 
 (defmethod initialize-system :after ((this mortar-combat))
-  (with-slots (scene player keymap) this
+  (with-slots (scene player keymap task-queue) this
     (register-resource-loader (make-resource-loader (asset-path "font.brf")
                                                     (asset-path "dude-and-mortar.brf")))
-    (setf player (make-instance 'player))
+    (setf player (make-instance 'player)
+          keymap (make-instance 'keymap)
+          task-queue (make-task-queue))
 
     (let ((prev-x nil)
           (prev-y nil)
@@ -44,15 +62,15 @@
                  (when (and prev-x prev-y)
                    (let ((ax (/ (- y prev-y) 1000))
                          (ay (/ (- x prev-x) 1000)))
-                     (look-at player ax ay)))
+                     (look-at player ax (- ay))))
                  (setf prev-x x
                        prev-y y))
                (key-velocity (key)
                  (case key
-                   (:w (vec2 0.0 -10.0))
-                   (:s (vec2 0.0 10.0))
-                   (:a (vec2 -10.0 0.0))
-                   (:d (vec2 10.0 0.0))))
+                   (:w (vec2 0.0 +player-speed+))
+                   (:s (vec2 0.0 (- +player-speed+)))
+                   (:a (vec2 (- +player-speed+) 0.0))
+                   (:d (vec2 +player-speed+ 0.0))))
                (update-velocity ()
                  (setf (player-velocity player) (reduce #'add movement-keys
                                                         :key #'key-velocity
@@ -62,12 +80,18 @@
                    (case state
                      (:pressed (push button movement-keys))
                      (:released (deletef movement-keys button)))
-                   (update-velocity))))
+                   (update-velocity)))
+               (shoot (state)
+                 (when (eq :pressed state)
+                   (shoot-ball scene player))))
+
         (bind-cursor keymap #'rotate-camera)
+
         (bind-button keymap :w (update-buttons :w))
         (bind-button keymap :s (update-buttons :s))
         (bind-button keymap :a (update-buttons :a))
-        (bind-button keymap :d (update-buttons :d))))
+        (bind-button keymap :d (update-buttons :d))
+        (bind-button keymap :mouse-left #'shoot)))
 
     (enable-keymap keymap)
 
@@ -86,7 +110,10 @@
                                        scenegraph-root)))
              (concurrently ()
                (let (looped-flow)
-                 (setf looped-flow (>> (-> ((physics)) ()
+                 (setf looped-flow (>> (instantly ()
+                                         (let ((*system* this))
+                                           (drain task-queue)))
+                                       (-> ((physics)) ()
                                          (observe-universe +framestep+))
                                        (scene-processing-flow scene)
                                        (instantly ()

client/src/player.lisp

@@ -5,8 +5,8 @@
 
 
 (defclass player ()
-  ((position :initform (vec2 0.0 18.0))
-   (rotation :initform (vec2 0.0 0.0) :reader rotation-of)
+  ((position :initform (vec2)) ; f(x,y) field space = f(x,-z) global space
+   (rotation :initform (vec2) :reader rotation-of)
 
    (updated-at :initform (real-time-seconds))
    (velocity :initform (vec2 0.0 0.0))))
@@ -27,6 +27,12 @@
     position))
 
 
+(defun gaze-of (player)
+  "In global coords"
+  (with-slots (rotation) player
+    (normalize (rotate *forward-gaze* (euler-angles->quat (x rotation) (y rotation) 0.0)))))
+
+
 (defun (setf player-velocity) (vec2 player)
   (with-slots (position velocity) player
     (flush-position player)

client/src/utils.lisp

@@ -6,3 +6,6 @@
 
 (defun asset-path (file)
   (merge-pathnames file (merge-working-pathname (property :assets "assets/"))))
+
+
+(defgeneric scene-of (obj))