ea257eed759d — Leonard Ritter 3 months ago
* ODE: joint upcasting and dispatch
1 files changed, 52 insertions(+), 4 deletions(-)

M tukan/ode/init.sc
M tukan/ode/init.sc +52 -4
@@ 133,7 133,7 @@ typedef Body < Wrapper :: dBodyID
     case (self, other)
         dAreConnected self other
     case (self, other, jointtype : type)
-        dAreConnectedExcluding self other jointtype.ID
+        dAreConnectedExcluding self other (jointtype.ID as u32 as i32)
     case (self, other, jointtype : i32)
         dAreConnectedExcluding self other jointtype
 

          
@@ 224,9 224,12 @@ typedef World < Wrapper :: dWorldID
 
     let
         step = dWorldStep
+        quick-step = dWorldQuickStep
         #static-body = (property _cpSpaceGetStaticBody)
         gravity =
             vector-property fvec3 dWorldGetGravity dWorldSetGravity
+        quick-step-num-iterations =
+            property dWorldGetQuickStepNumIterations dWorldSetQuickStepNumIterations
 
 let _dSpaceGetGeom =
     bitcast dSpaceGetGeom

          
@@ 609,9 612,10 @@ typedef JointType < Wrapper
     fn class (self)
         (dJointGetType self) as u32 as (typeof dJointTypeBall)
 
-typedef Joint < Wrapper :: dJointID
+typedef Joint < JointType :: dJointID
 
 typedef+ JointType
+    @@ memo
     inline __imply (cls T)
         static-if (T == Joint)
             inline (self)

          
@@ 619,6 623,15 @@ typedef+ JointType
         else
             super-type.__imply cls T
 
+    @@ memo
+    inline __as (cls T)
+        static-if (T < JointType)
+            inline (self)
+                assert (('class self) == T.ID) "illegal cast"
+                bitcast self T
+        else
+            super-type.__as cls T
+
     inline __drop (self)
         dJointDestroy self
         ;

          
@@ 667,7 680,7 @@ typedef JointGroup < Wrapper :: dJointGr
     let empty = dJointGroupEmpty
 
 typedef ContactJoint < JointType :: dJointID
-    let ID = (dJointTypeContact as u32 as i32)
+    let ID = dJointTypeContact
 
     let _dJointCreateContact =
         bitcast dJointCreateContact

          
@@ 686,7 699,7 @@ typedef ContactJoint < JointType :: dJoi
 inline gen-joint-type (name jtype createf getparamf setparamf)
     let T =
         typedef (do name) < JointType :: dJointID
-            let ID = (jtype as u32 as i32)
+            let ID = jtype
             let _dJointCreate =
                 bitcast createf
                     pointer

          
@@ 735,6 748,41 @@ let
     DHingeJoint = (gen-joint-type "DHingeJoint" dJointTypeDHinge dJointCreateDHinge dJointGetDHingeParam dJointSetDHingeParam)
     TransmissionJoint = (gen-joint-type "TransmissionJoint" dJointTypeTransmission dJointCreateTransmission dJointGetTransmissionParam dJointSetTransmissionParam)
 
+typedef+ JointType
+    spice __dispatch (self ...)
+        let clsid = ('tag `('class self) ('anchor args))
+        let sw = (sc_switch_new clsid)
+        for arg in ('args ...)
+            let anchor = ('anchor arg)
+            let k f = ('dekey arg)
+            inline append-case (key class)
+                sc_switch_append_case sw
+                    'tag `key anchor
+                    'tag `(f (bitcast self class)) anchor
+            switch k
+            case 'BallJoint (append-case dJointTypeBall BallJoint)
+            case 'HingeJoint (append-case dJointTypeHinge HingeJoint)
+            case 'SliderJoint (append-case dJointTypeSlider SliderJoint)
+            case 'UniversalJoint (append-case dJointTypeUniversal UniversalJoint)
+            case 'Hinge2Joint (append-case dJointTypeHinge2 Hinge2Joint)
+            case 'PRJoint (append-case dJointTypePR PRJoint)
+            case 'PUJoint (append-case dJointTypePU PUJoint)
+            case 'PistonJoint (append-case dJointTypePiston PistonJoint)
+            case 'FixedJoint (append-case dJointTypeFixed FixedJoint)
+            case 'AMotorJoint (append-case dJointTypeAMotor AMotorJoint)
+            case 'LMotorJoint (append-case dJointTypeLMotor LMotorJoint)
+            case 'Plane2DJoint (append-case dJointTypePlane2D Plane2DJoint)
+            case 'DBallJoint (append-case dJointTypeDBall DBallJoint)
+            case 'DHingeJoint (append-case dJointTypeDHinge DHingeJoint)
+            case 'TransmissionJoint (append-case dJointTypeTransmission TransmissionJoint)
+            case unnamed
+                sc_switch_append_default sw ('tag `(f) anchor)
+            default
+                hide-traceback;
+                error@ ('anchor arg) "while generating dispatch branches"
+                    .. "unknown case type: " (k as string)
+        sw
+
 typedef+ SliderJoint
     let axis =
         vector-property fvec3 dJointGetSliderAxis dJointSetSliderAxis