Geom contact callbacks

borodust · Nov 19, 2016 · 211ac9f · 211ac9f
1 parent 3b4d952
commit 211ac9f
Show file tree

Hide file tree

Showing 5 changed files with 52 additions and 31 deletions.
diff --git a/cl-bodge.asd b/cl-bodge.asd
@@ -71,9 +71,9 @@
                                      (:file "system")))
                (:module physics
                         :serial t
-                        :components ((:file "universe")
+                        :components ((:file "ode")
+                                     (:file "universe")
                                      (:file "system")
-                                     (:file "ode")
                                      (:file "mass")
                                      (:file "rigid-body")
                                      (:file "joints")

diff --git a/packages.lisp b/packages.lisp
@@ -340,6 +340,7 @@
            observe-universe
            gravity
            register-collision-callback
+           register-contact-callback
 
            make-rigid-body
            position-of
@@ -424,7 +425,7 @@
   (:nicknames :ge.sg)
   (:use :cl-bodge.utils :cl-bodge.engine :cl-bodge.graphics :cl-bodge.physics
         :cl-bodge.math :cl-bodge.concurrency :cl-bodge.host :cl-bodge.memory
-        :cl-bodge.animation :cl-bodge.resources
+        :cl-bodge.animation :cl-bodge.resources :cl-bodge.audio
         :cl :cl-muth)
   (:export node
            find-node

diff --git a/physics/system.lisp b/physics/system.lisp
@@ -14,6 +14,10 @@
   (%register-collision-callback (universe) callback))
 
 
+(defun register-contact-callback (callback)
+  (%register-contact-callback (universe) callback))
+
+
 (defclass physics-system (thread-bound-system) ())
 
 

diff --git a/physics/universe.lisp b/physics/universe.lisp
@@ -8,7 +8,8 @@
   ((world :initform (%ode:world-create) :reader world-of)
    (space :initform (%ode:hash-space-create (cffi:null-pointer)) :reader space-of)
    (geoms :initform (tg:make-weak-hash-table :weakness :value :test 'eql) :reader geoms-of)
-   (collision-callbacks :initform '() :reader collision-callbacks-of)))
+   (collision-callbacks :initform '() :reader collision-callbacks-of)
+   (contact-callbacks :initform '() :reader contact-callbacks-of)))
 
 
 (defun %register-geom (universe geom)
@@ -21,6 +22,11 @@
     (pushnew callback collision-callbacks)))
 
 
+(defun %register-contact-callback (universe callback)
+  (with-slots (contact-callbacks) universe
+    (pushnew callback contact-callbacks)))
+
+
 (defmethod initialize-instance :after ((this universe) &key)
   (with-slots (world) this
     (%ode:world-set-erp world 0.8)
@@ -49,35 +55,40 @@
 
 
 (define-collision-callback fill-joint-group (in this that)
-  (unless (loop with geoms = (geoms-of (universe))
-             for cb in (collision-callbacks-of (universe))
-             for processed-p = (funcall cb (gethash (cffi:pointer-address (ptr this)) geoms)
-                                        (gethash (cffi:pointer-address (ptr that)) geoms))
-             until processed-p
-             finally (return processed-p))
-    (destructuring-bind (world joint-group) in
-      (c-with ((contact-geoms %ode:contact-geom :count *contact-points-per-collision*))
-        (let ((contact-count (%ode:collide this that
-                                           *contact-points-per-collision*
-                                           contact-geoms
-                                           (foreign-type-size
-                                            (find-type '%ode:contact-geom)))))
-          (when (> contact-count 0)
-            (c-with ((contacts %ode:contact :count contact-count :calloc t))
-              (loop for i from 0 below contact-count do
-                   (let* ((contact (initialize-contact
-                                    (c-ref contacts %ode:contact i)
-                                    (c-ref contact-geoms %ode:contact-geom i)))
-                          (joint (%ode:joint-create-contact world joint-group contact))
-                          (this-body (%ode:geom-get-body this))
-                          (that-body (%ode:geom-get-body that)))
-                     (%ode:joint-attach joint this-body that-body))))))))))
+  (destructuring-bind (universe joint-group) in
+    (let* ((geoms (geoms-of universe))
+           (this-geom (gethash (cffi:pointer-address (ptr this)) geoms))
+           (that-geom (gethash (cffi:pointer-address (ptr that)) geoms))
+           (world (world-of universe)))
+      (unless (loop for cb in (collision-callbacks-of universe)
+                 for processed-p = (funcall cb this-geom that-geom)
+                 until processed-p
+                 finally (return processed-p))
+        (c-with ((contact-geoms %ode:contact-geom :count *contact-points-per-collision*))
+          (let ((contact-count (%ode:collide this that
+                                             *contact-points-per-collision*
+                                             contact-geoms
+                                             (foreign-type-size
+                                              (find-type '%ode:contact-geom)))))
+            (when (> contact-count 0)
+              (loop for cb in (contact-callbacks-of universe) do
+                   (funcall cb this-geom that-geom))
+              (c-with ((contacts %ode:contact :count contact-count :calloc t))
+                (loop for i from 0 below contact-count do
+                     (let* ((contact (initialize-contact
+                                      (c-ref contacts %ode:contact i)
+                                      (c-ref contact-geoms %ode:contact-geom i)))
+                            (joint (%ode:joint-create-contact world
+                                                              joint-group contact))
+                            (this-body (%ode:geom-get-body this))
+                            (that-body (%ode:geom-get-body that)))
+                       (%ode:joint-attach joint this-body that-body)))))))))))
 
 
 (defun detect-collisions (universe)
-  (with-slots (space world) universe
+  (with-slots (space) universe
     (let ((joint-group (%ode:joint-group-create 0)))
-      (space-collide space (list world joint-group) (collision-callback fill-joint-group))
+      (space-collide space (list universe joint-group) (collision-callback fill-joint-group))
       joint-group)))
 
 

diff --git a/scene/scene.lisp b/scene/scene.lisp
@@ -9,6 +9,7 @@
 (defclass scene-root-node (node)
   ((gx :initform (engine-system 'graphics-system) :reader graphics-system-of)
    (phx :initform (engine-system 'physics-system) :reader physics-system-of)
+   (au :initform (engine-system 'audio-system) :reader audio-system-of)
    (host :initform (engine-system 'host-system) :reader host-system-of)))
 
 ;;;
@@ -38,13 +39,17 @@
 (defun initialize-tree (scene root)
   (let* ((scene-root (root-of scene))
          (gx-sys (graphics-system-of scene-root))
-         (phx-sys (physics-system-of scene-root)))
+         (phx-sys (physics-system-of scene-root))
+         (au-sys (audio-system-of scene-root)))
     (when-all ((-> (gx-sys :high)
                  (dotree (node root)
                    (initialize-node node gx-sys)))
                (-> (phx-sys :high)
                  (dotree (node root)
-                   (initialize-node node phx-sys)))))))
+                   (initialize-node node phx-sys)))
+               (-> (au-sys :high)
+                 (dotree (node root)
+                   (initialize-node node au-sys)))))))
 
 
 (defun make-scene (&rest children)