diff --git a/HODE.cabal b/HODE.cabal new file mode 100644 --- /dev/null +++ b/HODE.cabal @@ -0,0 +1,45 @@ +Name: HODE +Version: 2008.10.27 +Maintainer: Lemmih (lemmih@gmail.com) +Author: Lemmih (lemmih@gmail.com) +Copyright: 2005-2008, Lemmih +License-File: LICENSE +License: BSD3 +Build-Type: Simple +Build-Depends: base, array +Category: Game, Physics +Synopsis: Binding to libODE +Description: ODE is an open source, high performance library for simulating rigid body dynamics. + It has advanced joint types and integrated collision detection with friction. + ODE is useful for simulating vehicles, objects in virtual reality environments + and virtual creatures. It is currently used in many computer games, 3D authoring + tools and simulation tools. See http://www.ode.org/ +Extensions: CPP, ForeignFunctionInterface, EmptyDataDecls +Exposed-Modules: + Physics.ODE.Types, + Physics.ODE.Mass, + Physics.ODE.World, + Physics.ODE.Body, + Physics.ODE.Joint, + Physics.ODE.Geom, + Physics.ODE.Space, + Physics.ODE.Objects, + Physics.ODE.Collision, + Physics.ODE.Rotation, + Physics.ODE.Overloading, + Physics.ODE +Other-modules: + Physics.ODE.Utilities, + Physics.ODE.Hsc +Includes: ode/ode.h +Extra-libraries: ode +Hs-Source-Dirs: src +GHC-Options: -fwarn-duplicate-exports -fwarn-incomplete-patterns -fwarn-missing-signatures -fwarn-unused-binds -fwarn-unused-imports +Extra-Source-Files: generateBinding.sh, + src/Physics/ODE/Body.th, + src/Physics/ODE/Geom.th, + src/Physics/ODE/Joint.th, + src/Physics/ODE/Mass.th, + src/Physics/ODE/Objects.th, + src/Physics/ODE/Space.th, + src/Physics/ODE/World.th diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,35 @@ +Copyright (c) 2004-2008, David Himmelstrup +All rights reserved. + +Redistribution and use in source and binary forms, +with or without modification, are permitted provided +that the following conditions are met: + + * Redistributions of source code must retain + the above copyright notice, this list of + conditions and the following disclaimer. + * Redistributions in binary form must reproduce + the above copyright notice, this list of + conditions and the following disclaimer in the + documentation and/or other materials provided + with the distribution. + * Neither the name of David Himmelstrup nor the + names of other contributors may be used to + endorse or promote products derived from this + software without specific prior written permission. + + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND +CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, +INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES +OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE +ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER +OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, +BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR +SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, +WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE +USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY +OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/generateBinding.sh b/generateBinding.sh new file mode 100644 --- /dev/null +++ b/generateBinding.sh @@ -0,0 +1,26 @@ +#!/usr/bin/env sh + +BASE_DIR=src/Physics/ODE +GHC_FLAGS="-lode -fglasgow-exts -ignore-package HODE -cpp -isrc" + +# The order of these matters +MODULES="Mass World Body Geom Joint Objects Space" +HSCFILES="Types.hsc Hsc.hsc" + + +ZEROTH=zeroth + + +for hsc in $HSCFILES; do + hsc2hs $BASE_DIR/$hsc +done + +for module in $MODULES; do + hsFile=$BASE_DIR/$module.hs + thFile=$BASE_DIR/$module.th + if test ! -e $hsFile || test $hsFile -ot $thFile + then + echo Preprocessing: $thFile + $ZEROTH --input=$thFile --output=$hsFile "--ghc-args=$GHC_FLAGS" + fi +done diff --git a/src/Physics/ODE.hs b/src/Physics/ODE.hs new file mode 100644 --- /dev/null +++ b/src/Physics/ODE.hs @@ -0,0 +1,82 @@ +{-# LANGUAGE TypeSynonymInstances #-} +module Physics.ODE + ( module Physics.ODE.Overloading + , module Physics.ODE.Types + ) where + +import Physics.ODE.Overloading +import Physics.ODE.Types ( World, Space, Body, Geom, Joint, JointGroup, Mass + , ContactGeom (..), ContactInfo (..), Surface (..) + , JointType (..), BodyIndex (..), GeomClass (..) + , ODEreal ) +import Physics.ODE.World as World +import Physics.ODE.Body as Body +import Physics.ODE.Geom as Geom +import Physics.ODE.Joint as Joint +import Physics.ODE.Space as Space +import Physics.ODE.Mass as Mass + +instance HasDestroy World where + destroy = World.destroyWorld +instance HasDestroy Geom where + destroy = Geom.destroyGeom +instance HasDestroy Space where + destroy = Space.destroySpace +instance HasDestroy Body where + destroy = Body.destroyBody +instance HasDestroy Joint where + destroy = Joint.destroyJoint +instance HasDestroy JointGroup where + destroy = Joint.destroyGroup +instance HasDestroy Mass where + destroy = Mass.destroyMass + +instance IsPlaceable Body where + getPosition = Body.getBodyPosition + setPosition = Body.setBodyPosition + getQuaternion = Body.getBodyQuaternion + setQuaternion = Body.setBodyQuaternion + getRotation = Body.getBodyRotation + setRotation = Body.setBodyRotation +instance IsPlaceable Geom where + getPosition = Geom.getGeomPosition + setPosition = Geom.setGeomPosition + getQuaternion = Geom.getGeomQuaternion + setQuaternion = Geom.setGeomQuaternion + getRotation = Geom.getGeomRotation + setRotation = Geom.setGeomRotation + +instance HasData Body where + setRawData = Body.setRawBodyData + setData = Body.setBodyData + setSafeData = Body.setSafeBodyData + getRawData = Body.getRawBodyData + getData = Body.getBodyData + getSafeData = Body.getSafeBodyData + tryGetSafeData = Body.tryGetSafeBodyData +instance HasData Geom where + setRawData = Geom.setRawGeomData + setData = Geom.setGeomData + setSafeData = Geom.setSafeGeomData + getRawData = Geom.getRawGeomData + getData = Geom.getGeomData + getSafeData = Geom.getSafeGeomData + tryGetSafeData = Geom.tryGetSafeGeomData +instance HasData Joint where + setRawData = Joint.setRawJointData + setData = Joint.setJointData + setSafeData = Joint.setSafeJointData + getRawData = Joint.getRawJointData + getData = Joint.getJointData + getSafeData = Joint.getSafeJointData + tryGetSafeData = Joint.tryGetSafeJointData + +instance HasEnable Body where + enable = Body.enableBody + disable = Body.disableBody + isEnabled =Body.isBodyEnabled +instance HasEnable Geom where + enable = Geom.enableGeom + disable = Geom.disableGeom + isEnabled = Geom.isGeomEnabled + diff --git a/src/Physics/ODE/Body.hs b/src/Physics/ODE/Body.hs new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Body.hs @@ -0,0 +1,261 @@ +module Physics.ODE.Body + (create, destroyBody, setBodyPosition, getBodyPosition, + setBodyQuaternion, getBodyQuaternion, setBodyRotation, + getBodyRotation, setLinearVel, getLinearVel, setAngularVel, + getAngularVel, setMass, getMass, addForce, setForce, getForce, + addTorque, setTorque, getTorque, enableBody, disableBody, + isBodyEnabled, setRawBodyData, setBodyData, setSafeBodyData, + getRawBodyData, getBodyData, tryGetSafeBodyData, getSafeBodyData, + setFiniteRotationMode, getFiniteRotationMode, getNumJoints, + getJoint, setGravityMode, getGravityMode) + where +import Foreign +import Data.Typeable +import Data.Maybe +import qualified Physics.ODE.Mass as Mass (create) +import Physics.ODE.Types +import Physics.ODE.Utilities + +foreign import ccall unsafe "dBodyGetMass" cGetMass :: + Ptr BodyStruct -> Ptr MassStruct -> IO () + +getMass :: Body -> IO Mass +getMass body + = Mass.create >>= + \ mass -> + withForeignPtr mass $ \ cMass -> cGetMass body cMass >> return mass + +foreign import ccall unsafe "dBodySetData" setRawBodyData :: + Ptr BodyStruct -> Ptr a -> IO () + +setBodyData :: Body -> a -> IO () +setBodyData body d + = newStablePtr d >>= + \ stablePtr -> setRawBodyData body (castStablePtrToPtr stablePtr) + +setSafeBodyData :: (Typeable a) => Body -> a -> IO () +setSafeBodyData body d = setBodyData body (typeOf d, d) + +foreign import ccall unsafe "dBodyGetData" getRawBodyData :: + Ptr BodyStruct -> IO (Ptr a) + +getBodyData :: Body -> IO a +getBodyData body + = getRawBodyData body >>= deRefStablePtr . castPtrToStablePtr + +tryGetSafeBodyData :: (Typeable a) => Body -> IO (Maybe a) +tryGetSafeBodyData body + = getBodyData body >>= + \ (t, d) -> + if t == typeOf d then return (Just d) else return Nothing + +getSafeBodyData :: (Typeable a) => Body -> IO a +getSafeBodyData + = fmap (fromMaybe (error errMsg)) . tryGetSafeBodyData + where errMsg = "Physics.ODE.Body.getSafeBodyData: invalid type." + +setFiniteRotationMode :: Body -> RotationMode -> IO () +setFiniteRotationMode body (Infinitesimal) + = setFiniteRotationMode_ body 0 +setFiniteRotationMode body (Finite x y z) + = do setFiniteRotationMode_ body 1 + setFiniteRotationAxis_ body x y z + +getFiniteRotationMode :: Body -> IO RotationMode +getFiniteRotationMode body + = do n <- getFiniteRotationMode_ body + if n == 0 then return Infinitesimal else + do (x, y, z) <- getFiniteRotationAxis_ body + return $ Finite x y z +create :: World -> IO Body +create = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- createdBodyCreate marshaledArg_2 + return (ret_3)) +foreign import ccall unsafe "dBodyCreate" createdBodyCreate :: World -> + IO Body +destroyBody :: Body -> IO () +destroyBody = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- destroyBodydBodyDestroy marshaledArg_2 + case () of + () -> do return ()) +foreign import ccall unsafe "dBodyDestroy" destroyBodydBodyDestroy :: Body -> + IO () +setBodyPosition :: Body -> ODEreal -> ODEreal -> ODEreal -> IO () +setBodyPosition = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- setBodyPositiondBodySetPosition marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dBodySetPosition" setBodyPositiondBodySetPosition :: Body -> + ODEreal -> + ODEreal -> + ODEreal -> IO () +getBodyPosition :: Body -> IO ((ODEreal, ODEreal, ODEreal)) +getBodyPosition = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getBodyPositiondBodyGetPosition marshaledArg_2 + peekVector3 (ret_3)) +foreign import ccall unsafe "dBodyGetPosition" getBodyPositiondBodyGetPosition :: Body -> + IO (Ptr ODEreal) +setBodyQuaternion :: Body -> + (ODEreal, ODEreal, ODEreal, ODEreal) -> IO () +setBodyQuaternion = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> allocaArray 4 (\ptr_5 -> (>>) (pokeArray ptr_5 (case arg_1 of + (a_6, + b_7, + c_8, + d_9) -> [a_6, + b_7, + c_8, + d_9])) (action_4 ptr_5))) (\marshaledArg_10 -> do ret_11 <- setBodyQuaterniondBodySetQuaternion marshaledArg_3 marshaledArg_10 + case () of + () -> do return ())) +foreign import ccall unsafe "dBodySetQuaternion" setBodyQuaterniondBodySetQuaternion :: Body -> + Ptr ODEreal -> + IO () +getBodyQuaternion :: Body -> + IO ((ODEreal, ODEreal, ODEreal, ODEreal)) +getBodyQuaternion = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getBodyQuaterniondBodyGetQuaternion marshaledArg_2 + peekVector4 (ret_3)) +foreign import ccall unsafe "dBodyGetQuaternion" getBodyQuaterniondBodyGetQuaternion :: Body -> + IO (Ptr ODEreal) +setBodyRotation :: Body -> Matrix3 -> IO () +setBodyRotation = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- setBodyRotationdBodySetRotation marshaledArg_3 marshaledArg_5 + case () of + () -> do return ())) +foreign import ccall unsafe "dBodySetRotation" setBodyRotationdBodySetRotation :: Body -> + Matrix3 -> IO () +getBodyRotation :: Body -> IO Matrix3 +getBodyRotation = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getBodyRotationdBodyGetRotation marshaledArg_2 + return (ret_3)) +foreign import ccall unsafe "dBodyGetRotation" getBodyRotationdBodyGetRotation :: Body -> + IO Matrix3 +setLinearVel :: Body -> ODEreal -> ODEreal -> ODEreal -> IO () +setLinearVel = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- setLinearVeldBodySetLinearVel marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dBodySetLinearVel" setLinearVeldBodySetLinearVel :: Body -> + ODEreal -> + ODEreal -> + ODEreal -> IO () +getLinearVel :: Body -> IO ((ODEreal, ODEreal, ODEreal)) +getLinearVel = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getLinearVeldBodyGetLinearVel marshaledArg_2 + peekVector3 (ret_3)) +foreign import ccall unsafe "dBodyGetLinearVel" getLinearVeldBodyGetLinearVel :: Body -> + IO (Ptr ODEreal) +setAngularVel :: Body -> ODEreal -> ODEreal -> ODEreal -> IO () +setAngularVel = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- setAngularVeldBodySetAngularVel marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dBodySetAngularVel" setAngularVeldBodySetAngularVel :: Body -> + ODEreal -> + ODEreal -> + ODEreal -> IO () +getAngularVel :: Body -> IO ((ODEreal, ODEreal, ODEreal)) +getAngularVel = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getAngularVeldBodyGetAngularVel marshaledArg_2 + peekVector3 (ret_3)) +foreign import ccall unsafe "dBodyGetAngularVel" getAngularVeldBodyGetAngularVel :: Body -> + IO (Ptr ODEreal) +setMass :: Body -> Mass -> IO () +setMass = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> withForeignPtr arg_1 (\marshaledArg_4 -> do ret_5 <- setMassdBodySetMass marshaledArg_3 marshaledArg_4 + case () of + () -> do return ())) +foreign import ccall unsafe "dBodySetMass" setMassdBodySetMass :: Body -> + Ptr MassStruct -> IO () +addForce :: Body -> ODEreal -> ODEreal -> ODEreal -> IO () +addForce = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- addForcedBodyAddForce marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dBodyAddForce" addForcedBodyAddForce :: Body -> + ODEreal -> + ODEreal -> ODEreal -> IO () +setForce :: Body -> ODEreal -> ODEreal -> ODEreal -> IO () +setForce = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- setForcedBodySetForce marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dBodySetForce" setForcedBodySetForce :: Body -> + ODEreal -> + ODEreal -> ODEreal -> IO () +getForce :: Body -> IO ((ODEreal, ODEreal, ODEreal)) +getForce = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getForcedBodyGetForce marshaledArg_2 + peekVector3 (ret_3)) +foreign import ccall unsafe "dBodyGetForce" getForcedBodyGetForce :: Body -> + IO (Ptr ODEreal) +addTorque :: Body -> ODEreal -> ODEreal -> ODEreal -> IO () +addTorque = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- addTorquedBodyAddTorque marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dBodyAddTorque" addTorquedBodyAddTorque :: Body -> + ODEreal -> + ODEreal -> ODEreal -> IO () +setTorque :: Body -> ODEreal -> ODEreal -> ODEreal -> IO () +setTorque = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- setTorquedBodySetTorque marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dBodySetTorque" setTorquedBodySetTorque :: Body -> + ODEreal -> + ODEreal -> ODEreal -> IO () +getTorque :: Body -> IO ((ODEreal, ODEreal, ODEreal)) +getTorque = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getTorquedBodyGetTorque marshaledArg_2 + peekVector3 (ret_3)) +foreign import ccall unsafe "dBodyGetTorque" getTorquedBodyGetTorque :: Body -> + IO (Ptr ODEreal) +enableBody :: Body -> IO () +enableBody = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- enableBodydBodyEnable marshaledArg_2 + case () of + () -> do return ()) +foreign import ccall unsafe "dBodyEnable" enableBodydBodyEnable :: Body -> + IO () +disableBody :: Body -> IO () +disableBody = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- disableBodydBodyDisable marshaledArg_2 + case () of + () -> do return ()) +foreign import ccall unsafe "dBodyDisable" disableBodydBodyDisable :: Body -> + IO () +isBodyEnabled :: Body -> IO Bool +isBodyEnabled = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- isBodyEnableddBodyIsEnabled marshaledArg_2 + return (toBool (ret_3))) +foreign import ccall unsafe "dBodyIsEnabled" isBodyEnableddBodyIsEnabled :: Body -> + IO Int +setFiniteRotationMode_ :: Body -> Int -> IO () +setFiniteRotationMode_ = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- setFiniteRotationMode_dBodySetFiniteRotationMode marshaledArg_3 marshaledArg_5 + case () of + () -> do return ())) +foreign import ccall unsafe "dBodySetFiniteRotationMode" setFiniteRotationMode_dBodySetFiniteRotationMode :: Body -> + Int -> + IO () +getFiniteRotationMode_ :: Body -> IO Int +getFiniteRotationMode_ = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getFiniteRotationMode_dBodyGetFiniteRotationMode marshaledArg_2 + return (ret_3)) +foreign import ccall unsafe "dBodyGetFiniteRotationMode" getFiniteRotationMode_dBodyGetFiniteRotationMode :: Body -> + IO Int +setFiniteRotationAxis_ :: Body -> + ODEreal -> ODEreal -> ODEreal -> IO () +setFiniteRotationAxis_ = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- setFiniteRotationAxis_dBodySetFiniteRotationAxis marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dBodySetFiniteRotationAxis" setFiniteRotationAxis_dBodySetFiniteRotationAxis :: Body -> + ODEreal -> + ODEreal -> + ODEreal -> + IO () +getFiniteRotationAxis_ :: Body -> IO ((ODEreal, ODEreal, ODEreal)) +getFiniteRotationAxis_ = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> allocaArray 4 (\marshaledArg_3 -> do ret_4 <- getFiniteRotationAxis_dBodyGetFiniteRotationAxis marshaledArg_2 marshaledArg_3 + peekVector3 (marshaledArg_3))) +foreign import ccall unsafe "dBodyGetFiniteRotationAxis" getFiniteRotationAxis_dBodyGetFiniteRotationAxis :: Body -> + Ptr ODEreal -> + IO () +getNumJoints :: Body -> IO Int +getNumJoints = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getNumJointsdBodyGetNumJoints marshaledArg_2 + return (ret_3)) +foreign import ccall unsafe "dBodyGetNumJoints" getNumJointsdBodyGetNumJoints :: Body -> + IO Int +getJoint :: Body -> Int -> IO Joint +getJoint = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- getJointdBodyGetJoint marshaledArg_3 marshaledArg_5 + return (ret_6))) +foreign import ccall unsafe "dBodyGetJoint" getJointdBodyGetJoint :: Body -> + Int -> IO Joint +setGravityMode :: Body -> Bool -> IO () +setGravityMode = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 (fromBool arg_1)) (\marshaledArg_5 -> do ret_6 <- setGravityModedBodySetGravityMode marshaledArg_3 marshaledArg_5 + case () of + () -> do return ())) +foreign import ccall unsafe "dBodySetGravityMode" setGravityModedBodySetGravityMode :: Body -> + Int -> IO () +getGravityMode :: Body -> IO Bool +getGravityMode = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getGravityModedBodyGetGravityMode marshaledArg_2 + return (toBool (ret_3))) +foreign import ccall unsafe "dBodyGetGravityMode" getGravityModedBodyGetGravityMode :: Body -> + IO Int diff --git a/src/Physics/ODE/Body.th b/src/Physics/ODE/Body.th new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Body.th @@ -0,0 +1,157 @@ +module Physics.ODE.Body + ( create + , destroyBody + , setBodyPosition + , getBodyPosition + , setBodyQuaternion + , getBodyQuaternion + , setBodyRotation + , getBodyRotation + , setLinearVel + , getLinearVel + , setAngularVel + , getAngularVel + , setMass + , getMass + , addForce + , setForce + , getForce + , addTorque + , setTorque + , getTorque + , enableBody + , disableBody + , isBodyEnabled + , setRawBodyData + , setBodyData + , setSafeBodyData + , getRawBodyData + , getBodyData + , tryGetSafeBodyData + , getSafeBodyData + , setFiniteRotationMode + , getFiniteRotationMode + , getNumJoints + , getJoint + , setGravityMode + , getGravityMode + ) where + + +import Foreign +import Data.Typeable +import Data.Maybe + +import qualified Physics.ODE.Mass as Mass ( create ) +import Physics.ODE.Types +import Physics.ODE.Utilities + +#ifdef HASTH +import Foreign.HacanonLight.DIS +import Foreign.HacanonLight.Generate +import Physics.ODE.DIS +#endif + +$(bind "create" "dBodyCreate" [world,body]) + +$(bind "destroyBody" "dBodyDestroy" [body,unit]) + +$(bind "setBodyPosition" "dBodySetPosition" [body,ode,ode,ode,unit]) + +$(bind "getBodyPosition" "dBodyGetPosition" [body,vector3Out]) + +$(bind "setBodyQuaternion" "dBodySetQuaternion" [body,vector4,unit]) + +$(bind "getBodyQuaternion" "dBodyGetQuaternion" [body,vector4Out]) + +$(bind "setBodyRotation" "dBodySetRotation" [body,matrix3,unit]) + +$(bind "getBodyRotation" "dBodyGetRotation" [body,matrix3]) + +$(bind "setLinearVel" "dBodySetLinearVel" [body,ode,ode,ode,unit]) + +$(bind "getLinearVel" "dBodyGetLinearVel" [body,vector3Out]) + +$(bind "setAngularVel" "dBodySetAngularVel" [body,ode,ode,ode,unit]) + +$(bind "getAngularVel" "dBodyGetAngularVel" [body,vector3Out]) + +$(bind "setMass" "dBodySetMass" [body,mass,unit]) + + +foreign import ccall unsafe "dBodyGetMass" cGetMass :: Ptr BodyStruct -> Ptr MassStruct -> IO () +getMass :: Body -> IO Mass +getMass body + = Mass.create >>= \mass -> + withForeignPtr mass $ \cMass -> + cGetMass body cMass >> return mass + +$(bind "addForce" "dBodyAddForce" [body,ode,ode,ode,unit]) + +$(bind "setForce" "dBodySetForce" [body,ode,ode,ode,unit]) + +$(bind "getForce" "dBodyGetForce" [body,vector3Out]) + +$(bind "addTorque" "dBodyAddTorque" [body,ode,ode,ode,unit]) + +$(bind "setTorque" "dBodySetTorque" [body,ode,ode,ode,unit]) + +$(bind "getTorque" "dBodyGetTorque" [body,vector3Out]) + +$(bind "enableBody" "dBodyEnable" [body,unit]) + +$(bind "disableBody" "dBodyDisable" [body,unit]) + +$(bind "isBodyEnabled" "dBodyIsEnabled" [body,bool]) + +foreign import ccall unsafe "dBodySetData" setRawBodyData :: Ptr BodyStruct -> Ptr a -> IO () + +setBodyData :: Body -> a -> IO () +setBodyData body d = newStablePtr d >>= \stablePtr -> + setRawBodyData body (castStablePtrToPtr stablePtr) + +setSafeBodyData :: Typeable a => Body -> a -> IO () +setSafeBodyData body d = setBodyData body (typeOf d,d) + +foreign import ccall unsafe "dBodyGetData" getRawBodyData :: Ptr BodyStruct -> IO (Ptr a) + +getBodyData :: Body -> IO a +getBodyData body = getRawBodyData body >>= deRefStablePtr.castPtrToStablePtr + +tryGetSafeBodyData :: Typeable a => Body -> IO (Maybe a) +tryGetSafeBodyData body = getBodyData body >>= \(t,d) -> + if t == typeOf d + then return (Just d) + else return Nothing + +getSafeBodyData :: Typeable a => Body -> IO a +getSafeBodyData = fmap (fromMaybe (error errMsg)).tryGetSafeBodyData + where errMsg = "Physics.ODE.Body.getSafeBodyData: invalid type." + +$(bind "setFiniteRotationMode_" "dBodySetFiniteRotationMode" [body, int, unit]) +$(bind "getFiniteRotationMode_" "dBodyGetFiniteRotationMode" [body, int]) + +$(bind "setFiniteRotationAxis_" "dBodySetFiniteRotationAxis" [body, ode, ode, ode, unit]) +$(bind "getFiniteRotationAxis_" "dBodyGetFiniteRotationAxis" [body, vector3Out, unit]) + +setFiniteRotationMode :: Body -> RotationMode -> IO () +setFiniteRotationMode body Infinitesimal = setFiniteRotationMode_ body 0 +setFiniteRotationMode body (Finite x y z) = do setFiniteRotationMode_ body 1 + setFiniteRotationAxis_ body x y z + +getFiniteRotationMode :: Body -> IO RotationMode +getFiniteRotationMode body + = do n <- getFiniteRotationMode_ body + if n == 0 + then return Infinitesimal + else do (x,y,z) <- getFiniteRotationAxis_ body + return $ Finite x y z + +$(bind "getNumJoints" "dBodyGetNumJoints" [body,int]) + +$(bind "getJoint" "dBodyGetJoint" [body,int,joint]) + +$(bind "setGravityMode" "dBodySetGravityMode" [body,bool,unit]) + +$(bind "getGravityMode" "dBodyGetGravityMode" [body,bool]) + diff --git a/src/Physics/ODE/Collision.hs b/src/Physics/ODE/Collision.hs new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Collision.hs @@ -0,0 +1,43 @@ +module Physics.ODE.Collision + ( collide + , spaceCollide + ) where + +import Foreign + +import Physics.ODE.Types +import Physics.ODE.Hsc +-- import Physics.ODE.Utilities + +foreign import ccall unsafe "memset" cMemset :: Ptr a -> Int -> Int -> IO (Ptr a) + +foreign import ccall unsafe "dCollide" rawCollide + :: Ptr GeomStruct -> Ptr GeomStruct -> Int -> Ptr ContactGeom -> Int -> IO Int + +collide :: Geom -> Geom -> Int -> IO [ContactInfo] +collide geom1 geom2 nElems + = allocaArray nElems $ \points -> + do cMemset points 0 (sizeOfContactInfo * nElems) + ret <- rawCollide geom1 geom2 nElems (addressOfGeom points) sizeOfContactInfo + peekArray ret points + where sizeOfContactInfo = sizeOf (undefined :: ContactInfo) + +type RawCallback = Ptr () -> Ptr GeomStruct -> Ptr GeomStruct -> IO () +type Callback = Geom -> Geom -> IO () + +foreign import ccall unsafe "wrapper" mkRawCallback :: RawCallback -> IO (FunPtr RawCallback) +mkCallback :: Callback -> IO (FunPtr RawCallback) +mkCallback cb + = mkRawCallback rawCb + where rawCb _data geom1 geom2 + = cb geom1 geom2 + +foreign import ccall safe "dSpaceCollide" cSpaceCollide + :: Ptr SpaceStruct -> Ptr () -> FunPtr RawCallback -> IO () + +spaceCollide :: Space -> Callback -> IO () +spaceCollide space callback + = mkCallback callback >>= \rawCallback -> + cSpaceCollide space nullPtr rawCallback >> + freeHaskellFunPtr rawCallback + diff --git a/src/Physics/ODE/Geom.hs b/src/Physics/ODE/Geom.hs new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Geom.hs @@ -0,0 +1,149 @@ +module Physics.ODE.Geom + (destroyGeom, setRawGeomData, setGeomData, setSafeGeomData, + getRawGeomData, getGeomData, getSafeGeomData, tryGetSafeGeomData, + setBody, getBodyUnsafe, getBody, setGeomPosition, getGeomPosition, + setGeomQuaternion, getGeomQuaternion, setGeomRotation, + getGeomRotation, isSpace, getSpace, getClass, enableGeom, + disableGeom, isGeomEnabled) + where +import Foreign +import Data.Typeable +import Data.Maybe +import Physics.ODE.Types +import Physics.ODE.Utilities +import Physics.ODE.Hsc + +foreign import ccall unsafe "dGeomSetData" setRawGeomData :: + Ptr GeomStruct -> Ptr a -> IO () + +setGeomData :: Geom -> a -> IO () +setGeomData body d + = newStablePtr d >>= + \ stablePtr -> setRawGeomData body (castStablePtrToPtr stablePtr) + +setSafeGeomData :: (Typeable a) => Geom -> a -> IO () +setSafeGeomData body d = setGeomData body (typeOf d, d) + +foreign import ccall unsafe "dGeomGetData" getRawGeomData :: + Ptr GeomStruct -> IO (Ptr a) + +getGeomData :: Geom -> IO a +getGeomData body + = getRawGeomData body >>= deRefStablePtr . castPtrToStablePtr + +tryGetSafeGeomData :: (Typeable a) => Geom -> IO (Maybe a) +tryGetSafeGeomData body + = getGeomData body >>= + \ (t, d) -> + if t == typeOf d then return (Just d) else return Nothing + +getSafeGeomData :: (Typeable a) => Geom -> IO a +getSafeGeomData + = fmap (fromMaybe (error errMsg)) . tryGetSafeGeomData + where errMsg = "Physics.ODE.Geom.getSafeGeomData: invalid type." +destroyGeom :: Geom -> IO () +destroyGeom = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- destroyGeomdGeomDestroy marshaledArg_2 + case () of + () -> do return ()) +foreign import ccall unsafe "dGeomDestroy" destroyGeomdGeomDestroy :: Geom -> + IO () +setBody :: Geom -> Maybe Body -> IO () +setBody = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (case arg_1 of + Data.Maybe.Just a_4 -> \action_5 -> action_5 a_4 + Data.Maybe.Nothing -> \action_6 -> action_6 nullPtr) (\marshaledArg_7 -> do ret_8 <- setBodydGeomSetBody marshaledArg_3 marshaledArg_7 + case () of + () -> do return ())) +foreign import ccall unsafe "dGeomSetBody" setBodydGeomSetBody :: Geom -> + Body -> IO () +getBodyUnsafe :: Geom -> IO Body +getBodyUnsafe = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getBodyUnsafedGeomGetBody marshaledArg_2 + return (ret_3)) +foreign import ccall unsafe "dGeomGetBody" getBodyUnsafedGeomGetBody :: Geom -> + IO Body +getBody :: Geom -> IO (Maybe Body) +getBody = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getBodydGeomGetBody marshaledArg_2 + if (ret_3) == nullPtr + then return Nothing + else fmap Just (return (ret_3))) +foreign import ccall unsafe "dGeomGetBody" getBodydGeomGetBody :: Geom -> + IO Body +setGeomPosition :: Geom -> ODEreal -> ODEreal -> ODEreal -> IO () +setGeomPosition = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- setGeomPositiondGeomSetPosition marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dGeomSetPosition" setGeomPositiondGeomSetPosition :: Geom -> + ODEreal -> + ODEreal -> + ODEreal -> IO () +getGeomPosition :: Geom -> IO ((ODEreal, ODEreal, ODEreal)) +getGeomPosition = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getGeomPositiondGeomGetPosition marshaledArg_2 + peekVector3 (ret_3)) +foreign import ccall unsafe "dGeomGetPosition" getGeomPositiondGeomGetPosition :: Geom -> + IO (Ptr ODEreal) +setGeomQuaternion :: Geom -> + (ODEreal, ODEreal, ODEreal, ODEreal) -> IO () +setGeomQuaternion = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> allocaArray 4 (\ptr_5 -> (>>) (pokeArray ptr_5 (case arg_1 of + (a_6, + b_7, + c_8, + d_9) -> [a_6, + b_7, + c_8, + d_9])) (action_4 ptr_5))) (\marshaledArg_10 -> do ret_11 <- setGeomQuaterniondGeomSetQuaternion marshaledArg_3 marshaledArg_10 + case () of + () -> do return ())) +foreign import ccall unsafe "dGeomSetQuaternion" setGeomQuaterniondGeomSetQuaternion :: Geom -> + Ptr ODEreal -> + IO () +getGeomQuaternion :: Geom -> + IO ((ODEreal, ODEreal, ODEreal, ODEreal)) +getGeomQuaternion = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> allocaArray 4 (\marshaledArg_3 -> do ret_4 <- getGeomQuaterniondGeomGetQuaternion marshaledArg_2 marshaledArg_3 + peekVector4 (marshaledArg_3))) +foreign import ccall unsafe "dGeomGetQuaternion" getGeomQuaterniondGeomGetQuaternion :: Geom -> + Ptr ODEreal -> + IO () +setGeomRotation :: Geom -> Matrix3 -> IO () +setGeomRotation = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- setGeomRotationdGeomSetRotation marshaledArg_3 marshaledArg_5 + case () of + () -> do return ())) +foreign import ccall unsafe "dGeomSetRotation" setGeomRotationdGeomSetRotation :: Geom -> + Matrix3 -> IO () +getGeomRotation :: Geom -> IO Matrix3 +getGeomRotation = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getGeomRotationdGeomGetRotation marshaledArg_2 + return (ret_3)) +foreign import ccall unsafe "dGeomGetRotation" getGeomRotationdGeomGetRotation :: Geom -> + IO Matrix3 +isSpace :: Geom -> IO Bool +isSpace = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- isSpacedGeomIsSpace marshaledArg_2 + return (toBool (ret_3))) +foreign import ccall unsafe "dGeomIsSpace" isSpacedGeomIsSpace :: Geom -> + IO Int +getSpace :: Geom -> IO (Maybe Space) +getSpace = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getSpacedGeomGetSpace marshaledArg_2 + if (ret_3) == nullPtr + then return Nothing + else fmap Just (return (ret_3))) +foreign import ccall unsafe "dGeomGetSpace" getSpacedGeomGetSpace :: Geom -> + IO Space +getClass :: Geom -> IO GeomClass +getClass = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getClassdGeomGetClass marshaledArg_2 + return (toGeomClass (ret_3))) +foreign import ccall unsafe "dGeomGetClass" getClassdGeomGetClass :: Geom -> + IO Int +enableGeom :: Geom -> IO () +enableGeom = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- enableGeomdGeomEnable marshaledArg_2 + case () of + () -> do return ()) +foreign import ccall unsafe "dGeomEnable" enableGeomdGeomEnable :: Geom -> + IO () +disableGeom :: Geom -> IO () +disableGeom = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- disableGeomdGeomDisable marshaledArg_2 + case () of + () -> do return ()) +foreign import ccall unsafe "dGeomDisable" disableGeomdGeomDisable :: Geom -> + IO () +isGeomEnabled :: Geom -> IO Bool +isGeomEnabled = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- isGeomEnableddGeomIsEnabled marshaledArg_2 + return (toBool (ret_3))) +foreign import ccall unsafe "dGeomIsEnabled" isGeomEnableddGeomIsEnabled :: Geom -> + IO Int diff --git a/src/Physics/ODE/Geom.th b/src/Physics/ODE/Geom.th new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Geom.th @@ -0,0 +1,96 @@ +module Physics.ODE.Geom + ( destroyGeom + , setRawGeomData + , setGeomData + , setSafeGeomData + , getRawGeomData + , getGeomData + , getSafeGeomData + , tryGetSafeGeomData + , setBody + , getBodyUnsafe + , getBody + , setGeomPosition + , getGeomPosition + , setGeomQuaternion + , getGeomQuaternion + , setGeomRotation + , getGeomRotation + , isSpace + , getSpace + , getClass + , enableGeom + , disableGeom + , isGeomEnabled + ) where + +import Foreign +import Data.Typeable +import Data.Maybe + +import Physics.ODE.Types +import Physics.ODE.Utilities +import Physics.ODE.Hsc + +#ifdef HASTH +import Foreign.HacanonLight.DIS +import Foreign.HacanonLight.Generate +import Physics.ODE.DIS +#endif + +$(bind "destroyGeom" "dGeomDestroy" [geom,unit]) + +foreign import ccall unsafe "dGeomSetData" setRawGeomData :: Ptr GeomStruct -> Ptr a -> IO () + +setGeomData :: Geom -> a -> IO () +setGeomData body d = newStablePtr d >>= \stablePtr -> + setRawGeomData body (castStablePtrToPtr stablePtr) + +setSafeGeomData :: Typeable a => Geom -> a -> IO () +setSafeGeomData body d = setGeomData body (typeOf d,d) + +foreign import ccall unsafe "dGeomGetData" getRawGeomData :: Ptr GeomStruct -> IO (Ptr a) + +getGeomData :: Geom -> IO a +getGeomData body = getRawGeomData body >>= deRefStablePtr.castPtrToStablePtr + +tryGetSafeGeomData :: Typeable a => Geom -> IO (Maybe a) +tryGetSafeGeomData body = getGeomData body >>= \(t,d) -> + if t == typeOf d + then return (Just d) + else return Nothing + +getSafeGeomData :: Typeable a => Geom -> IO a +getSafeGeomData = fmap (fromMaybe (error errMsg)).tryGetSafeGeomData + where errMsg = "Physics.ODE.Geom.getSafeGeomData: invalid type." + +$(bind "setBody" "dGeomSetBody" [geom,maybePtr body,unit]) + +$(bind "getBodyUnsafe" "dGeomGetBody" [geom,body]) +$(bind "getBody" "dGeomGetBody" [geom,maybePtr body]) + +$(bind "setGeomPosition" "dGeomSetPosition" [geom,ode,ode,ode,unit]) + +$(bind "getGeomPosition" "dGeomGetPosition" [geom,vector3]) + +$(bind "setGeomQuaternion" "dGeomSetQuaternion" [geom,vector4,unit]) + +$(bind "getGeomQuaternion" "dGeomGetQuaternion" [geom,vector4Out,unit]) + +$(bind "setGeomRotation" "dGeomSetRotation" [geom,matrix3,unit]) + +$(bind "getGeomRotation" "dGeomGetRotation" [geom,matrix3]) + +$(bind "isSpace" "dGeomIsSpace" [geom,bool]) + +$(bind "getSpace" "dGeomGetSpace" [geom,maybePtr space]) + +$(bind "getClass" "dGeomGetClass" [geom,geomClass]) + +$(bind "enableGeom" "dGeomEnable" [geom,unit]) + +$(bind "disableGeom" "dGeomDisable" [geom,unit]) + +$(bind "isGeomEnabled" "dGeomIsEnabled" [geom,bool]) + + diff --git a/src/Physics/ODE/Hsc.hsc b/src/Physics/ODE/Hsc.hsc new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Hsc.hsc @@ -0,0 +1,207 @@ +#include +module Physics.ODE.Hsc + ( addressOfGeom + , toBitmask + , fromBitmask + , sizeOfMass + , sizeOfMatrix3 + , sizeOfMatrix4 + , peekMass + , toSurfaceMode + , fromSurfaceMode + , toJointType + , fromJointType + , toBodyIndex + , fromBodyIndex + , toGeomClass + , fromGeomClass + ) where + +import Physics.ODE.Types +import Physics.ODE.Utilities +import Foreign + +import Control.Monad +import Data.Maybe + +instance Storable ContactGeom where + sizeOf _ = #{size struct dContactGeom} + alignment _ = 4 + peek ptr + = do pos <- peekVector3 (#{ptr struct dContactGeom, pos} ptr) + normal <- peekVector3 (#{ptr struct dContactGeom, normal} ptr) + depth <- peek (#{ptr struct dContactGeom, depth} ptr) + obj1 <- peek (#{ptr struct dContactGeom, g1} ptr) + obj2 <- peek (#{ptr struct dContactGeom, g2} ptr) + return (ContactGeom pos normal depth (obj1,obj2)) + poke ptr cGeom + = do pokeVector3 (#{ptr struct dContactGeom, pos} ptr) (contactPos cGeom) + pokeVector3 (#{ptr struct dContactGeom, normal} ptr) (contactNormal cGeom) + #{poke struct dContactGeom, depth} ptr (contactDepth cGeom) + #{poke struct dContactGeom, g1} ptr (fst (contactObjects cGeom)) + #{poke struct dContactGeom, g2} ptr (snd (contactObjects cGeom)) + +instance Storable ContactInfo where + sizeOf _ = #{size struct dContact} + alignment _ = alignment (undefined :: ODEreal) + peek ptr + = do surface <- #{peek struct dContact, surface} ptr + geom <- #{peek struct dContact, geom} ptr + fdir <- peekVector3 (#{ptr struct dContact, fdir1} ptr) + return (ContactInfo surface geom fdir) + poke ptr info + = do #{poke struct dContact, surface} ptr (contactSurface info) + #{poke struct dContact, geom} ptr (contactGeom info) + pokeVector3 (#{ptr struct dContact,fdir1} ptr) (contactFDir1 info) + +instance Storable Surface where + sizeOf _ = #{size struct dSurfaceParameters} + alignment _ = alignment (undefined :: ODEreal) + peek ptr + = do mode <- fmap (fromBitmask fromSurfaceMode) (#{peek struct dSurfaceParameters, mode} ptr) + let mbPeek flag action + | flag `elem` mode = fmap Just action + | otherwise = return Nothing + mu <- #{peek struct dSurfaceParameters, mu} ptr + mu2 <- mbPeek HaveMu2 $ #{peek struct dSurfaceParameters, mu2} ptr + bounce <- mbPeek HaveBounce $ liftM2 (,) (#{peek struct dSurfaceParameters, bounce} ptr) + (#{peek struct dSurfaceParameters, bounce_vel} ptr) + softERP <- mbPeek HaveSoftERP $ #{peek struct dSurfaceParameters, soft_erp} ptr + softCFM <- mbPeek HaveSoftCFM $ #{peek struct dSurfaceParameters, soft_cfm} ptr + motion1 <- mbPeek HaveMotion1 $ #{peek struct dSurfaceParameters, motion1} ptr + motion2 <- mbPeek HaveMotion2 $ #{peek struct dSurfaceParameters, motion2} ptr + slip1 <- mbPeek HaveSlip1 $ #{peek struct dSurfaceParameters, slip1} ptr + slip2 <- mbPeek HaveSlip2 $ #{peek struct dSurfaceParameters, slip2} ptr + return (Surface mu mu2 bounce softERP softCFM motion1 motion2 slip1 slip2) + poke ptr surface + = do #{poke struct dSurfaceParameters, mode} ptr (toBitmask fromSurfaceMode flags) + #{poke struct dSurfaceParameters, mu} ptr (surfaceMu surface) + mbPoke surfaceMu2 $ #{poke struct dSurfaceParameters, mu2} ptr + mbPoke surfaceBounce $ \(bounce,vel) -> #{poke struct dSurfaceParameters, bounce} ptr bounce >> + #{poke struct dSurfaceParameters, bounce_vel} ptr vel + mbPoke surfaceSoftERP $ #{poke struct dSurfaceParameters, soft_erp} ptr + mbPoke surfaceSoftCFM $ #{poke struct dSurfaceParameters, soft_cfm} ptr + mbPoke surfaceMotion1 $ #{poke struct dSurfaceParameters, motion1} ptr + mbPoke surfaceMotion2 $ #{poke struct dSurfaceParameters, motion2} ptr + mbPoke surfaceSlip1 $ #{poke struct dSurfaceParameters, slip1} ptr + mbPoke surfaceSlip2 $ #{poke struct dSurfaceParameters, slip2} ptr + where flags = foldr mkFlag (maybe [] (const [HaveBounce]) (surfaceBounce surface)) + (zip (HaveMu2 : [ HaveSoftERP .. HaveApprox12]) + [ surfaceMu2, surfaceSoftERP + , surfaceSoftCFM, surfaceMotion1, surfaceMotion2 + , surfaceSlip1, surfaceSlip2 ]) + mkFlag (flag,fn) + | isJust (fn surface) = (:) flag + | otherwise = id + mbPoke fn action + = case fn surface of + Just val -> action val + Nothing -> return () + +addressOfGeom :: Ptr ContactInfo -> Ptr ContactGeom +addressOfGeom = #{ptr struct dContact, geom} + +toBitmask :: Bits b => (a -> b) -> [a] -> b +toBitmask from = foldr (.|.) 0 . map from + +fromBitmask :: (Enum a, Bounded a,Bits b) => (a -> b) -> b -> [a] +fromBitmask from mask = foldr worker [] lst + where lst = [minBound .. maxBound] + worker v + = if (mask .&. from v) /= 0 + then (:) v + else id + +toSurfaceMode :: Int -> SurfaceMode +toSurfaceMode #{const dContactMu2} = HaveMu2 +toSurfaceMode #{const dContactFDir1} = HaveFDir1 +toSurfaceMode #{const dContactBounce} = HaveBounce +toSurfaceMode #{const dContactSoftERP} = HaveSoftERP +toSurfaceMode #{const dContactSoftCFM} = HaveSoftCFM +toSurfaceMode #{const dContactMotion1} = HaveMotion1 +toSurfaceMode #{const dContactMotion2} = HaveMotion2 +toSurfaceMode #{const dContactSlip1} = HaveSlip1 +toSurfaceMode #{const dContactSlip2} = HaveSlip2 +toSurfaceMode #{const dContactApprox1_1} = HaveApprox11 +toSurfaceMode #{const dContactApprox1_2} = HaveApprox12 +toSurfaceMode _ = error "Physics.ODE.Hsc.toSurfaceMode: bad argument" + +fromSurfaceMode :: SurfaceMode -> Int +fromSurfaceMode HaveMu2 = #{const dContactMu2} +fromSurfaceMode HaveFDir1 = #{const dContactFDir1} +fromSurfaceMode HaveBounce = #{const dContactBounce} +fromSurfaceMode HaveSoftERP = #{const dContactSoftERP} +fromSurfaceMode HaveSoftCFM = #{const dContactSoftCFM} +fromSurfaceMode HaveMotion1 = #{const dContactMotion1} +fromSurfaceMode HaveMotion2 = #{const dContactMotion2} +fromSurfaceMode HaveSlip1 = #{const dContactSlip1} +fromSurfaceMode HaveSlip2 = #{const dContactSlip2} +fromSurfaceMode HaveApprox11 = #{const dContactApprox1_1} +fromSurfaceMode HaveApprox12 = #{const dContactApprox1_2} + +sizeOfMass :: Int +sizeOfMass = #{size struct dMass} + +sizeOfMatrix3 :: Int +sizeOfMatrix3 = sizeOf (undefined::ODEreal)*4*3 + +sizeOfMatrix4 :: Int +sizeOfMatrix4 = sizeOf (undefined::ODEreal)*4*4 + +peekMass :: Ptr MassStruct -> IO ODEreal +peekMass = #{peek struct dMass, mass} + +toJointType :: Int -> JointType +toJointType #{const dJointTypeBall} = Ball +toJointType #{const dJointTypeHinge} = Hinge +toJointType #{const dJointTypeSlider} = Slider +toJointType #{const dJointTypeContact} = Contact +toJointType #{const dJointTypeUniversal} = Universal +toJointType #{const dJointTypeHinge2} = Hinge2 +toJointType #{const dJointTypeFixed} = Fixed +toJointType #{const dJointTypeAMotor} = AMotor +toJointType _ = error "Physics.ODE.Hsc.toJointType: bad argument" + +fromJointType :: JointType -> Int +fromJointType Ball = #{const dJointTypeBall} +fromJointType Hinge = #{const dJointTypeHinge} +fromJointType Slider = #{const dJointTypeSlider} +fromJointType Contact = #{const dJointTypeContact} +fromJointType Universal = #{const dJointTypeUniversal} +fromJointType Hinge2 = #{const dJointTypeHinge2} +fromJointType Fixed = #{const dJointTypeFixed} +fromJointType AMotor = #{const dJointTypeAMotor} + +toBodyIndex :: Int -> BodyIndex +toBodyIndex 0 = First +toBodyIndex 1 = Second +toBodyIndex _ = error "Physics.ODE.Hsc.toBodyIndex: bad argument" + +fromBodyIndex :: BodyIndex -> Int +fromBodyIndex First = 0 +fromBodyIndex Second = 1 + +toGeomClass :: Int -> GeomClass +toGeomClass #{const dSphereClass} = Sphere +toGeomClass #{const dBoxClass} = Box +toGeomClass #{const dCCylinderClass} = CappedCylinder +toGeomClass #{const dCylinderClass} = Cylinder +toGeomClass #{const dPlaneClass} = Plane +toGeomClass #{const dGeomTransformClass} = GeomTransform +toGeomClass #{const dRayClass} = Ray +toGeomClass #{const dTriMeshClass} = TriangleMesh +toGeomClass #{const dSimpleSpaceClass} = SimpleSpace +toGeomClass #{const dHashSpaceClass} = HashSpace +toGeomClass _ = error "Physics.ODE.Hsc.toGeomClass: bad argument" + +fromGeomClass :: GeomClass -> Int +fromGeomClass Sphere = #{const dSphereClass} +fromGeomClass Box = #{const dBoxClass} +fromGeomClass CappedCylinder = #{const dCCylinderClass} +fromGeomClass Cylinder = #{const dCylinderClass} +fromGeomClass Plane = #{const dPlaneClass} +fromGeomClass GeomTransform = #{const dGeomTransformClass} +fromGeomClass Ray = #{const dRayClass} +fromGeomClass TriangleMesh = #{const dTriMeshClass} +fromGeomClass SimpleSpace = #{const dSimpleSpaceClass} +fromGeomClass HashSpace = #{const dHashSpaceClass} diff --git a/src/Physics/ODE/Joint.hs b/src/Physics/ODE/Joint.hs new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Joint.hs @@ -0,0 +1,170 @@ +module Physics.ODE.Joint + (createBall, createHinge, createSlider, createContact, createGroup, + destroyJoint, destroyGroup, emptyGroup, attach, setRawJointData, + setJointData, setSafeJointData, getRawJointData, getJointData, + getSafeJointData, tryGetSafeJointData, getType, getBody, + areConnected, areConnectedExcluding, setBallAnchor, getBallAnchor, + setHingeAnchor, setHingeAxis) + where +import Foreign +import Data.Typeable +import Data.Maybe +import Physics.ODE.Types +import Physics.ODE.Utilities +import Physics.ODE.Hsc + +createGroup :: IO JointGroup +createGroup = createGroup' 0 + +foreign import ccall unsafe "dJointSetData" setRawJointData :: + Ptr JointStruct -> Ptr a -> IO () + +setJointData :: Joint -> a -> IO () +setJointData body d + = newStablePtr d >>= + \ stablePtr -> setRawJointData body (castStablePtrToPtr stablePtr) + +setSafeJointData :: (Typeable a) => Joint -> a -> IO () +setSafeJointData body d = setJointData body (typeOf d, d) + +foreign import ccall unsafe "dJointGetData" getRawJointData :: + Ptr JointStruct -> IO (Ptr a) + +getJointData :: Joint -> IO a +getJointData body + = getRawJointData body >>= deRefStablePtr . castPtrToStablePtr + +tryGetSafeJointData :: (Typeable a) => Joint -> IO (Maybe a) +tryGetSafeJointData body + = getJointData body >>= + \ (t, d) -> + if t == typeOf d then return (Just d) else return Nothing + +getSafeJointData :: (Typeable a) => Joint -> IO a +getSafeJointData + = fmap (fromMaybe (error errMsg)) . tryGetSafeJointData + where errMsg = "Physics.ODE.Joint.getSafeJointData: invalid type." +-- import qualified Physics.ODE.Mass as Mass ( create ) +createBall :: World -> Maybe JointGroup -> IO Joint +createBall = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (case arg_1 of + Data.Maybe.Just a_4 -> \action_5 -> action_5 a_4 + Data.Maybe.Nothing -> \action_6 -> action_6 nullPtr) (\marshaledArg_7 -> do ret_8 <- createBalldJointCreateBall marshaledArg_3 marshaledArg_7 + return (ret_8))) +foreign import ccall unsafe "dJointCreateBall" createBalldJointCreateBall :: World -> + JointGroup -> IO Joint +createHinge :: World -> Maybe JointGroup -> IO Joint +createHinge = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (case arg_1 of + Data.Maybe.Just a_4 -> \action_5 -> action_5 a_4 + Data.Maybe.Nothing -> \action_6 -> action_6 nullPtr) (\marshaledArg_7 -> do ret_8 <- createHingedJointCreateHinge marshaledArg_3 marshaledArg_7 + return (ret_8))) +foreign import ccall unsafe "dJointCreateHinge" createHingedJointCreateHinge :: World -> + JointGroup -> + IO Joint +createSlider :: World -> Maybe JointGroup -> IO Joint +createSlider = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (case arg_1 of + Data.Maybe.Just a_4 -> \action_5 -> action_5 a_4 + Data.Maybe.Nothing -> \action_6 -> action_6 nullPtr) (\marshaledArg_7 -> do ret_8 <- createSliderdJointCreateSlider marshaledArg_3 marshaledArg_7 + return (ret_8))) +foreign import ccall unsafe "dJointCreateSlider" createSliderdJointCreateSlider :: World -> + JointGroup -> + IO Joint +createContact :: World -> + Maybe JointGroup -> ContactInfo -> IO Joint +createContact = \arg_0 arg_1 arg_2 -> (\action_3 -> action_3 arg_0) (\marshaledArg_4 -> (case arg_1 of + Data.Maybe.Just a_5 -> \action_6 -> action_6 a_5 + Data.Maybe.Nothing -> \action_7 -> action_7 nullPtr) (\marshaledArg_8 -> (\action_9 -> alloca (\ptr_10 -> do poke ptr_10 arg_2 + action_9 ptr_10)) (\marshaledArg_11 -> do ret_12 <- createContactdJointCreateContact marshaledArg_4 marshaledArg_8 marshaledArg_11 + return (ret_12)))) +foreign import ccall unsafe "dJointCreateContact" createContactdJointCreateContact :: World -> + JointGroup -> + Ptr ContactInfo -> + IO Joint +createGroup' :: Int -> IO JointGroup +createGroup' = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- createGroup'dJointGroupCreate marshaledArg_2 + return (ret_3)) +foreign import ccall unsafe "dJointGroupCreate" createGroup'dJointGroupCreate :: Int -> + IO JointGroup +destroyJoint :: Joint -> IO () +destroyJoint = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- destroyJointdJointDestroy marshaledArg_2 + case () of + () -> do return ()) +foreign import ccall unsafe "dJointDestroy" destroyJointdJointDestroy :: Joint -> + IO () +destroyGroup :: JointGroup -> IO () +destroyGroup = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- destroyGroupdJointGroupDestroy marshaledArg_2 + case () of + () -> do return ()) +foreign import ccall unsafe "dJointGroupDestroy" destroyGroupdJointGroupDestroy :: JointGroup -> + IO () +emptyGroup :: JointGroup -> IO () +emptyGroup = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- emptyGroupdJointGroupEmpty marshaledArg_2 + case () of + () -> do return ()) +foreign import ccall unsafe "dJointGroupEmpty" emptyGroupdJointGroupEmpty :: JointGroup -> + IO () +attach :: Joint -> Maybe Body -> Maybe Body -> IO () +attach = \arg_0 arg_1 arg_2 -> (\action_3 -> action_3 arg_0) (\marshaledArg_4 -> (case arg_1 of + Data.Maybe.Just a_5 -> \action_6 -> action_6 a_5 + Data.Maybe.Nothing -> \action_7 -> action_7 nullPtr) (\marshaledArg_8 -> (case arg_2 of + Data.Maybe.Just a_9 -> \action_10 -> action_10 a_9 + Data.Maybe.Nothing -> \action_11 -> action_11 nullPtr) (\marshaledArg_12 -> do ret_13 <- attachdJointAttach marshaledArg_4 marshaledArg_8 marshaledArg_12 + case () of + () -> do return ()))) +foreign import ccall unsafe "dJointAttach" attachdJointAttach :: Joint -> + Body -> Body -> IO () +getType :: Joint -> IO JointType +getType = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getTypedJointGetType marshaledArg_2 + return (toJointType (ret_3))) +foreign import ccall unsafe "dJointGetType" getTypedJointGetType :: Joint -> + IO Int +getBody :: Joint -> BodyIndex -> IO Body +getBody = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 (fromBodyIndex arg_1)) (\marshaledArg_5 -> do ret_6 <- getBodydJointGetBody marshaledArg_3 marshaledArg_5 + return (ret_6))) +foreign import ccall unsafe "dJointGetBody" getBodydJointGetBody :: Joint -> + Int -> IO Body +areConnected :: Body -> Body -> IO Bool +areConnected = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- areConnecteddAreConnected marshaledArg_3 marshaledArg_5 + return (toBool (ret_6)))) +foreign import ccall unsafe "dAreConnected" areConnecteddAreConnected :: Body -> + Body -> IO Int +areConnectedExcluding :: Body -> Body -> JointType -> IO Bool +areConnectedExcluding = \arg_0 arg_1 arg_2 -> (\action_3 -> action_3 arg_0) (\marshaledArg_4 -> (\action_5 -> action_5 arg_1) (\marshaledArg_6 -> (\action_7 -> action_7 (fromJointType arg_2)) (\marshaledArg_8 -> do ret_9 <- areConnectedExcludingdAreConnectedExcluding marshaledArg_4 marshaledArg_6 marshaledArg_8 + return (toBool (ret_9))))) +foreign import ccall unsafe "dAreConnectedExcluding" areConnectedExcludingdAreConnectedExcluding :: Body -> + Body -> + Int -> + IO Int +setBallAnchor :: Joint -> ODEreal -> ODEreal -> ODEreal -> IO () +setBallAnchor = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- setBallAnchordJointSetBallAnchor marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dJointSetBallAnchor" setBallAnchordJointSetBallAnchor :: Joint -> + ODEreal -> + ODEreal -> + ODEreal -> + IO () +getBallAnchor :: Joint -> IO ((ODEreal, ODEreal, ODEreal)) +getBallAnchor = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> allocaArray 4 (\marshaledArg_3 -> do ret_4 <- getBallAnchordJointGetBallAnchor marshaledArg_2 marshaledArg_3 + peekVector3 (marshaledArg_3))) +foreign import ccall unsafe "dJointGetBallAnchor" getBallAnchordJointGetBallAnchor :: Joint -> + Ptr ODEreal -> + IO () +-- ------------------------------------------- +-- Hinge joint +setHingeAnchor :: Joint -> ODEreal -> ODEreal -> ODEreal -> IO () +setHingeAnchor = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- setHingeAnchordJointSetHingeAnchor marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dJointSetHingeAnchor" setHingeAnchordJointSetHingeAnchor :: Joint -> + ODEreal -> + ODEreal -> + ODEreal -> + IO () +setHingeAxis :: Joint -> ODEreal -> ODEreal -> ODEreal -> IO () +setHingeAxis = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- setHingeAxisdJointSetHingeAxis marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dJointSetHingeAxis" setHingeAxisdJointSetHingeAxis :: Joint -> + ODEreal -> + ODEreal -> + ODEreal -> IO () diff --git a/src/Physics/ODE/Joint.th b/src/Physics/ODE/Joint.th new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Joint.th @@ -0,0 +1,104 @@ +module Physics.ODE.Joint + ( createBall + , createHinge + , createSlider + , createContact + , createGroup + , destroyJoint + , destroyGroup + , emptyGroup + , attach + , setRawJointData + , setJointData + , setSafeJointData + , getRawJointData + , getJointData + , getSafeJointData + , tryGetSafeJointData + , getType + , getBody + , areConnected + , areConnectedExcluding + , setBallAnchor + , getBallAnchor + , setHingeAnchor + , setHingeAxis + ) where + +import Foreign +import Data.Typeable +import Data.Maybe + +-- import qualified Physics.ODE.Mass as Mass ( create ) +import Physics.ODE.Types +import Physics.ODE.Utilities +import Physics.ODE.Hsc + +#ifdef HASTH +import Foreign.HacanonLight.DIS +import Foreign.HacanonLight.Generate +import Physics.ODE.DIS +#endif + +$(bind "createBall" "dJointCreateBall" [world,maybePtr jointGroup,joint]) +$(bind "createHinge" "dJointCreateHinge" [world,maybePtr jointGroup,joint]) +$(bind "createSlider" "dJointCreateSlider" [world,maybePtr jointGroup,joint]) +$(bind "createContact" "dJointCreateContact" [world,maybePtr jointGroup,contact,joint]) + +$(bind "createGroup'" "dJointGroupCreate" [int,jointGroup]) + +createGroup :: IO JointGroup +createGroup = createGroup' 0 + +$(bind "destroyJoint" "dJointDestroy" [joint,unit]) + +$(bind "destroyGroup" "dJointGroupDestroy" [jointGroup,unit]) + +$(bind "emptyGroup" "dJointGroupEmpty" [jointGroup,unit]) + +$(bind "attach" "dJointAttach" [joint,maybePtr body,maybePtr body,unit]) + +foreign import ccall unsafe "dJointSetData" setRawJointData :: Ptr JointStruct -> Ptr a -> IO () + +setJointData :: Joint -> a -> IO () +setJointData body d = newStablePtr d >>= \stablePtr -> + setRawJointData body (castStablePtrToPtr stablePtr) + +setSafeJointData :: Typeable a => Joint -> a -> IO () +setSafeJointData body d = setJointData body (typeOf d,d) + +foreign import ccall unsafe "dJointGetData" getRawJointData :: Ptr JointStruct -> IO (Ptr a) + +getJointData :: Joint -> IO a +getJointData body = getRawJointData body >>= deRefStablePtr.castPtrToStablePtr + +tryGetSafeJointData :: Typeable a => Joint -> IO (Maybe a) +tryGetSafeJointData body = getJointData body >>= \(t,d) -> + if t == typeOf d + then return (Just d) + else return Nothing + +getSafeJointData :: Typeable a => Joint -> IO a +getSafeJointData = fmap (fromMaybe (error errMsg)).tryGetSafeJointData + where errMsg = "Physics.ODE.Joint.getSafeJointData: invalid type." + +$(bind "getType" "dJointGetType" [joint,jointType]) + +$(bind "getBody" "dJointGetBody" [joint,bodyIndex,body]) + +$(bind "areConnected" "dAreConnected" [body,body,bool]) + +$(bind "areConnectedExcluding" "dAreConnectedExcluding" [body,body,jointType,bool]) + +$(bind "setBallAnchor" "dJointSetBallAnchor" [joint,ode,ode,ode,unit]) + +$(bind "getBallAnchor" "dJointGetBallAnchor" [joint,vector3Out,unit]) + +--------------------------------------------- +-- Hinge joint + +$(bind "setHingeAnchor" "dJointSetHingeAnchor" [joint,ode,ode,ode,unit]) + +$(bind "setHingeAxis" "dJointSetHingeAxis" [joint,ode,ode,ode,unit]) + + diff --git a/src/Physics/ODE/Mass.hs b/src/Physics/ODE/Mass.hs new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Mass.hs @@ -0,0 +1,50 @@ +module Physics.ODE.Mass + (create, destroyMass, mass, setZero, adjust) where +import Foreign +import Physics.ODE.Types +import Physics.ODE.Utilities +import Physics.ODE.Hsc + +create :: IO Mass +create = mallocForeignPtrBytes sizeOfMass + +destroyMass :: Mass -> IO () +destroyMass = forceFinalization + +mass :: Mass -> IO ODEreal +mass m = withForeignPtr m peekMass +-- void dMassSetZero (dMass *); +setZero :: Mass -> IO () +setZero = \arg_0 -> withForeignPtr arg_0 (\marshaledArg_1 -> do ret_2 <- setZerodMassSetZero marshaledArg_1 + case () of + () -> do return ()) +foreign import ccall unsafe "dMassSetZero" setZerodMassSetZero :: Ptr MassStruct -> + IO () +-- void dMassSetParameters (dMass *, dReal themass, +-- dReal cgx, dReal cgy, dReal cgz, +-- dReal I11, dReal I22, dReal I33, +-- dReal I12, dReal I13, dReal I23); +-- void dMassSetSphere (dMass *, dReal density, dReal radius); +-- void dMassSetSphereTotal (dMass *, dReal total_mass, dReal radius); +-- void dMassSetCappedCylinder (dMass *, dReal density, int direction, +-- dReal radius, dReal length); +-- void dMassSetCappedCylinderTotal (dMass *, dReal total_mass, int direction, +-- dReal radius, dReal length); +-- void dMassSetCylinder (dMass *, dReal density, int direction, +-- dReal radius, dReal length); +-- void dMassSetCylinderTotal (dMass *, dReal total_mass, int direction, +-- dReal radius, dReal length); +-- void dMassSetBox (dMass *, dReal density, +-- dReal lx, dReal ly, dReal lz); +-- void dMassSetBoxTotal (dMass *, dReal total_mass, +-- dReal lx, dReal ly, dReal lz); +-- void dMassAdjust (dMass *, dReal newmass); +adjust :: Mass -> ODEreal -> IO () +adjust = \arg_0 arg_1 -> withForeignPtr arg_0 (\marshaledArg_2 -> (\action_3 -> action_3 arg_1) (\marshaledArg_4 -> do ret_5 <- adjustdMassAdjust marshaledArg_2 marshaledArg_4 + case () of + () -> do return ())) +foreign import ccall unsafe "dMassAdjust" adjustdMassAdjust :: Ptr MassStruct -> + ODEreal -> IO () +-- void dMassTranslate (dMass *, dReal x, dReal y, dReal z); +-- void dMassRotate (dMass *, const dMatrix3 R); +-- void dMassAdd (dMass *a, const dMass *b); diff --git a/src/Physics/ODE/Mass.th b/src/Physics/ODE/Mass.th new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Mass.th @@ -0,0 +1,65 @@ +module Physics.ODE.Mass + ( create + , destroyMass + , mass + , setZero + , adjust + ) where + +import Foreign + +import Physics.ODE.Types +import Physics.ODE.Utilities +import Physics.ODE.Hsc + +#ifdef HASTH +import Foreign.HacanonLight.DIS +import Foreign.HacanonLight.Generate +import Physics.ODE.DIS +#endif + +create :: IO Mass +create = mallocForeignPtrBytes sizeOfMass + +destroyMass :: Mass -> IO () +destroyMass = forceFinalization + +mass :: Mass -> IO ODEreal +mass m + = withForeignPtr m peekMass + +-- void dMassSetZero (dMass *); +$(bind "setZero" "dMassSetZero" [mass,unit]) + + +-- void dMassSetParameters (dMass *, dReal themass, +-- dReal cgx, dReal cgy, dReal cgz, +-- dReal I11, dReal I22, dReal I33, +-- dReal I12, dReal I13, dReal I23); + +-- void dMassSetSphere (dMass *, dReal density, dReal radius); +-- void dMassSetSphereTotal (dMass *, dReal total_mass, dReal radius); + +-- void dMassSetCappedCylinder (dMass *, dReal density, int direction, +-- dReal radius, dReal length); +-- void dMassSetCappedCylinderTotal (dMass *, dReal total_mass, int direction, +-- dReal radius, dReal length); + +-- void dMassSetCylinder (dMass *, dReal density, int direction, +-- dReal radius, dReal length); +-- void dMassSetCylinderTotal (dMass *, dReal total_mass, int direction, +-- dReal radius, dReal length); + +-- void dMassSetBox (dMass *, dReal density, +-- dReal lx, dReal ly, dReal lz); +-- void dMassSetBoxTotal (dMass *, dReal total_mass, +-- dReal lx, dReal ly, dReal lz); + +-- void dMassAdjust (dMass *, dReal newmass); +$(bind "adjust" "dMassAdjust" [mass,ode,unit]) + +-- void dMassTranslate (dMass *, dReal x, dReal y, dReal z); + +-- void dMassRotate (dMass *, const dMatrix3 R); + +-- void dMassAdd (dMass *a, const dMass *b); diff --git a/src/Physics/ODE/Objects.hs b/src/Physics/ODE/Objects.hs new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Objects.hs @@ -0,0 +1,113 @@ +module Physics.ODE.Objects + (createSphere, sphereSetRadius, sphereGetRadius, spherePointDepth, + createBox, boxSetLengths, boxGetLengths, boxPointDepth, + createPlane, planeSetParams, planeGetParams, planePointDepth) + where +import Foreign +import Data.Maybe +import Physics.ODE.Types +import Physics.ODE.Utilities +-- foreign import ccall unsafe "&dGeomDestroy" cDestroy :: FinalizerPtr GeomStruct +-- ------------------------------------------- +-- Sphere class +createSphere :: Maybe Space -> ODEreal -> IO Geom +createSphere = \arg_0 arg_1 -> (case arg_0 of + Data.Maybe.Just a_2 -> \action_3 -> action_3 a_2 + Data.Maybe.Nothing -> \action_4 -> action_4 nullPtr) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> do ret_8 <- createSpheredCreateSphere marshaledArg_5 marshaledArg_7 + return (ret_8))) +foreign import ccall unsafe "dCreateSphere" createSpheredCreateSphere :: Space -> + ODEreal -> IO Geom +sphereSetRadius :: Geom -> ODEreal -> IO () +sphereSetRadius = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- sphereSetRadiusdGeomSphereSetRadius marshaledArg_3 marshaledArg_5 + case () of + () -> do return ())) +foreign import ccall unsafe "dGeomSphereSetRadius" sphereSetRadiusdGeomSphereSetRadius :: Geom -> + ODEreal -> + IO () +sphereGetRadius :: Geom -> IO ODEreal +sphereGetRadius = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- sphereGetRadiusdGeomSphereGetRadius marshaledArg_2 + return (ret_3)) +foreign import ccall unsafe "dGeomSphereGetRadius" sphereGetRadiusdGeomSphereGetRadius :: Geom -> + IO ODEreal +spherePointDepth :: Geom -> + ODEreal -> ODEreal -> ODEreal -> IO ODEreal +spherePointDepth = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- spherePointDepthdGeomSpherePointDepth marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + return (ret_12))))) +foreign import ccall unsafe "dGeomSpherePointDepth" spherePointDepthdGeomSpherePointDepth :: Geom -> + ODEreal -> + ODEreal -> + ODEreal -> + IO ODEreal +-- ------------------------------------------- +-- Box class +createBox :: Maybe Space -> + ODEreal -> ODEreal -> ODEreal -> IO Geom +createBox = \arg_0 arg_1 arg_2 arg_3 -> (case arg_0 of + Data.Maybe.Just a_4 -> \action_5 -> action_5 a_4 + Data.Maybe.Nothing -> \action_6 -> action_6 nullPtr) (\marshaledArg_7 -> (\action_8 -> action_8 arg_1) (\marshaledArg_9 -> (\action_10 -> action_10 arg_2) (\marshaledArg_11 -> (\action_12 -> action_12 arg_3) (\marshaledArg_13 -> do ret_14 <- createBoxdCreateBox marshaledArg_7 marshaledArg_9 marshaledArg_11 marshaledArg_13 + return (ret_14))))) +foreign import ccall unsafe "dCreateBox" createBoxdCreateBox :: Space -> + ODEreal -> + ODEreal -> ODEreal -> IO Geom +boxSetLengths :: Geom -> ODEreal -> ODEreal -> ODEreal -> IO () +boxSetLengths = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- boxSetLengthsdGeomBoxSetLengths marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dGeomBoxSetLengths" boxSetLengthsdGeomBoxSetLengths :: Geom -> + ODEreal -> + ODEreal -> + ODEreal -> IO () +boxGetLengths :: Geom -> IO ((ODEreal, ODEreal, ODEreal)) +boxGetLengths = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> allocaArray 4 (\marshaledArg_3 -> do ret_4 <- boxGetLengthsdGeomBoxGetLengths marshaledArg_2 marshaledArg_3 + peekVector3 (marshaledArg_3))) +foreign import ccall unsafe "dGeomBoxGetLengths" boxGetLengthsdGeomBoxGetLengths :: Geom -> + Ptr ODEreal -> + IO () +boxPointDepth :: Geom -> + ODEreal -> ODEreal -> ODEreal -> IO ODEreal +boxPointDepth = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- boxPointDepthdGeomBoxPointDepth marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + return (ret_12))))) +foreign import ccall unsafe "dGeomBoxPointDepth" boxPointDepthdGeomBoxPointDepth :: Geom -> + ODEreal -> + ODEreal -> + ODEreal -> + IO ODEreal +-- ------------------------------------------- +-- Plane class +createPlane :: Maybe Space -> + ODEreal -> ODEreal -> ODEreal -> ODEreal -> IO Geom +createPlane = \arg_0 arg_1 arg_2 arg_3 arg_4 -> (case arg_0 of + Data.Maybe.Just a_5 -> \action_6 -> action_6 a_5 + Data.Maybe.Nothing -> \action_7 -> action_7 nullPtr) (\marshaledArg_8 -> (\action_9 -> action_9 arg_1) (\marshaledArg_10 -> (\action_11 -> action_11 arg_2) (\marshaledArg_12 -> (\action_13 -> action_13 arg_3) (\marshaledArg_14 -> (\action_15 -> action_15 arg_4) (\marshaledArg_16 -> do ret_17 <- createPlanedCreatePlane marshaledArg_8 marshaledArg_10 marshaledArg_12 marshaledArg_14 marshaledArg_16 + return (ret_17)))))) +foreign import ccall unsafe "dCreatePlane" createPlanedCreatePlane :: Space -> + ODEreal -> + ODEreal -> + ODEreal -> ODEreal -> IO Geom +planeSetParams :: Geom -> + ODEreal -> ODEreal -> ODEreal -> ODEreal -> IO () +planeSetParams = \arg_0 arg_1 arg_2 arg_3 arg_4 -> (\action_5 -> action_5 arg_0) (\marshaledArg_6 -> (\action_7 -> action_7 arg_1) (\marshaledArg_8 -> (\action_9 -> action_9 arg_2) (\marshaledArg_10 -> (\action_11 -> action_11 arg_3) (\marshaledArg_12 -> (\action_13 -> action_13 arg_4) (\marshaledArg_14 -> do ret_15 <- planeSetParamsdGeomPlaneSetParams marshaledArg_6 marshaledArg_8 marshaledArg_10 marshaledArg_12 marshaledArg_14 + case () of + () -> do return ()))))) +foreign import ccall unsafe "dGeomPlaneSetParams" planeSetParamsdGeomPlaneSetParams :: Geom -> + ODEreal -> + ODEreal -> + ODEreal -> + ODEreal -> + IO () +planeGetParams :: Geom -> IO ((ODEreal, ODEreal, ODEreal, ODEreal)) +planeGetParams = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> allocaArray 4 (\marshaledArg_3 -> do ret_4 <- planeGetParamsdGeomPlaneGetParams marshaledArg_2 marshaledArg_3 + peekVector4 (marshaledArg_3))) +foreign import ccall unsafe "dGeomPlaneGetParams" planeGetParamsdGeomPlaneGetParams :: Geom -> + Ptr ODEreal -> + IO () +planePointDepth :: Geom -> + ODEreal -> ODEreal -> ODEreal -> IO ODEreal +planePointDepth = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- planePointDepthdGeomPlanePointDepth marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + return (ret_12))))) +foreign import ccall unsafe "dGeomPlanePointDepth" planePointDepthdGeomPlanePointDepth :: Geom -> + ODEreal -> + ODEreal -> + ODEreal -> + IO ODEreal +-- FIXME: Do the rest. diff --git a/src/Physics/ODE/Objects.th b/src/Physics/ODE/Objects.th new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Objects.th @@ -0,0 +1,61 @@ +module Physics.ODE.Objects + ( -- * Sphere class + createSphere + , sphereSetRadius + , sphereGetRadius + , spherePointDepth + -- * Box class + , createBox + , boxSetLengths + , boxGetLengths + , boxPointDepth + -- * Plane class + , createPlane + , planeSetParams + , planeGetParams + , planePointDepth + ) where + +import Foreign +import Data.Maybe + +import Physics.ODE.Types +import Physics.ODE.Utilities + +#ifdef HASTH +import Foreign.HacanonLight.DIS +import Foreign.HacanonLight.Generate +import Physics.ODE.DIS +#endif + +--foreign import ccall unsafe "&dGeomDestroy" cDestroy :: FinalizerPtr GeomStruct + +--------------------------------------------- +-- Sphere class + +$(bind "createSphere" "dCreateSphere" [maybePtr space,ode,geom]) + +$(bind "sphereSetRadius" "dGeomSphereSetRadius" [geom,ode,unit]) +$(bind "sphereGetRadius" "dGeomSphereGetRadius" [geom,ode]) +$(bind "spherePointDepth" "dGeomSpherePointDepth" [geom,ode,ode,ode,ode]) + +--------------------------------------------- +-- Box class + +$(bind "createBox" "dCreateBox" [maybePtr space,ode,ode,ode,geom]) + +$(bind "boxSetLengths" "dGeomBoxSetLengths" [geom,ode,ode,ode,unit]) +$(bind "boxGetLengths" "dGeomBoxGetLengths" [geom,vector3Out,unit]) +$(bind "boxPointDepth" "dGeomBoxPointDepth" [geom,ode,ode,ode,ode]) + +--------------------------------------------- +-- Plane class + +$(bind "createPlane" "dCreatePlane" [maybePtr space,ode,ode,ode,ode,geom]) + +$(bind "planeSetParams" "dGeomPlaneSetParams" [geom,ode,ode,ode,ode,unit]) +$(bind "planeGetParams" "dGeomPlaneGetParams" [geom,vector4Out,unit]) +$(bind "planePointDepth" "dGeomPlanePointDepth" [geom,ode,ode,ode,ode]) + + +-- FIXME: Do the rest. diff --git a/src/Physics/ODE/Overloading.hs b/src/Physics/ODE/Overloading.hs new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Overloading.hs @@ -0,0 +1,30 @@ +module Physics.ODE.Overloading where + +import Physics.ODE.Types +import Data.Typeable +import Foreign + +class HasDestroy a where + destroy :: a -> IO () + +class IsPlaceable a where + getPosition :: a -> IO (ODEreal, ODEreal, ODEreal) + setPosition :: a -> ODEreal -> ODEreal -> ODEreal -> IO () + getQuaternion :: a -> IO (ODEreal, ODEreal, ODEreal, ODEreal) + setQuaternion :: a -> (ODEreal, ODEreal, ODEreal, ODEreal) -> IO () + getRotation :: a -> IO Matrix3 + setRotation :: a -> Matrix3 -> IO () + +class HasData a where + setRawData :: a -> Ptr b -> IO () + setData :: a -> b -> IO () + setSafeData :: Typeable b => a -> b -> IO () + getRawData :: a -> IO (Ptr b) + getData :: a -> IO b + getSafeData :: Typeable b => a -> IO b + tryGetSafeData :: Typeable b => a -> IO (Maybe b) + +class HasEnable a where + enable :: a -> IO () + disable :: a -> IO () + isEnabled :: a -> IO Bool diff --git a/src/Physics/ODE/Rotation.hs b/src/Physics/ODE/Rotation.hs new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Rotation.hs @@ -0,0 +1,38 @@ +module Physics.ODE.Rotation + ( createMatrix3 + , setIdentity + , fromAxisAndAngle + , fromEulerAngles +-- , rToQ + , peekMatrix3 + ) where + +import Foreign + +import Physics.ODE.Types +import Physics.ODE.Hsc + +createMatrix3 :: IO Matrix3 +createMatrix3 = do matrix <- mallocBytes sizeOfMatrix3 + setIdentity matrix + return matrix + +foreign import ccall unsafe "dRSetIdentity" setIdentity :: Matrix3 -> IO () +foreign import ccall unsafe "dRFromAxisAndAngle" fromAxisAndAngle + :: Matrix3 -> ODEreal -> ODEreal -> ODEreal -> ODEreal -> IO () +foreign import ccall unsafe "dRFromEulerAngles" fromEulerAngles + :: Matrix3 -> ODEreal -> ODEreal -> ODEreal -> IO () + +{-foreign import ccall unsafe "dRtoQ" dRtoQ + :: Matrix3 -> Ptr ODEreal -> IO () + +rToQ :: Matrix3 -> IO Quaternion +rToQ matrix + = allocaArray 4 $ \ptr -> + do dRtoQ matrix ptr + [a,b,c,d] <- peekArray 4 ptr + return (a,b,c,d) -} + + +peekMatrix3 :: Matrix3 -> IO [ODEreal] +peekMatrix3 = peekArray (3*4) diff --git a/src/Physics/ODE/Space.hs b/src/Physics/ODE/Space.hs new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Space.hs @@ -0,0 +1,100 @@ +module Physics.ODE.Space + (createSimple, createHash, destroySpace, setLevels, getLevels, + setCleanup, getCleanup, add, remove, query, getNumGeoms, + getGeomUnsafe, tryGetGeom, getGeom) + where +import Foreign +import Data.Maybe +import Physics.ODE.Types + +tryGetGeom :: Space -> Int -> IO (Maybe Geom) +tryGetGeom space nth + = do num <- getNumGeoms space + if nth > num - 1 then return Nothing else + fmap Just (getGeomUnsafe space nth) + +getGeom :: Space -> Int -> IO Geom +getGeom space nth + = fmap (fromMaybe (error msg)) (tryGetGeom space nth) + where msg + = "Physics.ODE.Space.getGeom: Index (" ++ show nth ++ + ") out of range." +createSimple :: Maybe Space -> IO Space +createSimple = \arg_0 -> (case arg_0 of + Data.Maybe.Just a_1 -> \action_2 -> action_2 a_1 + Data.Maybe.Nothing -> \action_3 -> action_3 nullPtr) (\marshaledArg_4 -> do ret_5 <- createSimpledSimpleSpaceCreate marshaledArg_4 + return (ret_5)) +foreign import ccall unsafe "dSimpleSpaceCreate" createSimpledSimpleSpaceCreate :: Space -> + IO Space +createHash :: Maybe Space -> IO Space +createHash = \arg_0 -> (case arg_0 of + Data.Maybe.Just a_1 -> \action_2 -> action_2 a_1 + Data.Maybe.Nothing -> \action_3 -> action_3 nullPtr) (\marshaledArg_4 -> do ret_5 <- createHashdHashSpaceCreate marshaledArg_4 + return (ret_5)) +foreign import ccall unsafe "dHashSpaceCreate" createHashdHashSpaceCreate :: Space -> + IO Space +destroySpace :: Space -> IO () +destroySpace = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- destroySpacedSpaceDestroy marshaledArg_2 + case () of + () -> do return ()) +foreign import ccall unsafe "dSpaceDestroy" destroySpacedSpaceDestroy :: Space -> + IO () +setLevels :: Space -> Int -> Int -> IO () +setLevels = \arg_0 arg_1 arg_2 -> (\action_3 -> action_3 arg_0) (\marshaledArg_4 -> (\action_5 -> action_5 arg_1) (\marshaledArg_6 -> (\action_7 -> action_7 arg_2) (\marshaledArg_8 -> do ret_9 <- setLevelsdHashSpaceSetLevels marshaledArg_4 marshaledArg_6 marshaledArg_8 + case () of + () -> do return ()))) +foreign import ccall unsafe "dHashSpaceSetLevels" setLevelsdHashSpaceSetLevels :: Space -> + Int -> + Int -> IO () +getLevels :: Space -> IO ((Int, Int)) +getLevels = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> alloca (\marshaledArg_3 -> alloca (\marshaledArg_4 -> do ret_5 <- getLevelsdHashSpaceGetLevels marshaledArg_2 marshaledArg_3 marshaledArg_4 + case (marshaledArg_3, + marshaledArg_4) of + (tuplePart_6, + tuplePart_7) -> do returnVariable_8 <- do n_9 <- peek tuplePart_6 + return n_9 + returnVariable_10 <- do n_11 <- peek tuplePart_7 + return n_11 + return (returnVariable_8, + returnVariable_10)))) +foreign import ccall unsafe "dHashSpaceGetLevels" getLevelsdHashSpaceGetLevels :: Space -> + Ptr Int -> + Ptr Int -> IO () +setCleanup :: Space -> Bool -> IO () +setCleanup = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 (fromBool arg_1)) (\marshaledArg_5 -> do ret_6 <- setCleanupdSpaceSetCleanup marshaledArg_3 marshaledArg_5 + case () of + () -> do return ())) +foreign import ccall unsafe "dSpaceSetCleanup" setCleanupdSpaceSetCleanup :: Space -> + Int -> IO () +getCleanup :: Space -> IO Bool +getCleanup = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getCleanupdSpaceGetCleanup marshaledArg_2 + return (toBool (ret_3))) +foreign import ccall unsafe "dSpaceGetCleanup" getCleanupdSpaceGetCleanup :: Space -> + IO Int +add :: Space -> Geom -> IO () +add = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- adddSpaceAdd marshaledArg_3 marshaledArg_5 + case () of + () -> do return ())) +foreign import ccall unsafe "dSpaceAdd" adddSpaceAdd :: Space -> + Geom -> IO () +remove :: Space -> Geom -> IO () +remove = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- removedSpaceRemove marshaledArg_3 marshaledArg_5 + case () of + () -> do return ())) +foreign import ccall unsafe "dSpaceRemove" removedSpaceRemove :: Space -> + Geom -> IO () +query :: Space -> Geom -> IO Bool +query = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- querydSpaceQuery marshaledArg_3 marshaledArg_5 + return (toBool (ret_6)))) +foreign import ccall unsafe "dSpaceQuery" querydSpaceQuery :: Space -> + Geom -> IO Int +getNumGeoms :: Space -> IO Int +getNumGeoms = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getNumGeomsdSpaceGetNumGeoms marshaledArg_2 + return (ret_3)) +foreign import ccall unsafe "dSpaceGetNumGeoms" getNumGeomsdSpaceGetNumGeoms :: Space -> + IO Int +getGeomUnsafe :: Space -> Int -> IO Geom +getGeomUnsafe = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- getGeomUnsafedSpaceGetGeom marshaledArg_3 marshaledArg_5 + return (ret_6))) +foreign import ccall unsafe "dSpaceGetGeom" getGeomUnsafedSpaceGetGeom :: Space -> + Int -> IO Geom diff --git a/src/Physics/ODE/Space.th b/src/Physics/ODE/Space.th new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Space.th @@ -0,0 +1,57 @@ +module Physics.ODE.Space + ( createSimple + , createHash + , destroySpace + , setLevels + , getLevels + , setCleanup + , getCleanup + , add + , remove + , query + , getNumGeoms + , getGeomUnsafe + , tryGetGeom + , getGeom + ) where + +import Foreign +import Data.Maybe + +import Physics.ODE.Types + +#ifdef HASTH +import Foreign.HacanonLight.DIS +import Foreign.HacanonLight.Generate +import Physics.ODE.DIS +#endif + +$(bind "createSimple" "dSimpleSpaceCreate" [maybePtr space,space]) +$(bind "createHash" "dHashSpaceCreate" [maybePtr space,space]) + +$(bind "destroySpace" "dSpaceDestroy" [space,unit]) + +$(bind "setLevels" "dHashSpaceSetLevels" [space,int,int,unit]) +$(bind "getLevels" "dHashSpaceGetLevels" [space,mkOut int,mkOut int,unit]) + +$(bind "setCleanup" "dSpaceSetCleanup" [space,bool,unit]) +$(bind "getCleanup" "dSpaceGetCleanup" [space,bool]) + +$(bind "add" "dSpaceAdd" [space,geom,unit]) +$(bind "remove" "dSpaceRemove" [space,geom,unit]) +$(bind "query" "dSpaceQuery" [space,geom,bool]) + +$(bind "getNumGeoms" "dSpaceGetNumGeoms" [space,int]) +$(bind "getGeomUnsafe" "dSpaceGetGeom" [space,int,geom]) + +tryGetGeom :: Space -> Int -> IO (Maybe Geom) +tryGetGeom space nth + = do num <- getNumGeoms space + if nth > num-1 + then return Nothing + else fmap Just (getGeomUnsafe space nth) + +getGeom :: Space -> Int -> IO Geom +getGeom space nth + = fmap (fromMaybe (error msg)) (tryGetGeom space nth) + where msg = "Physics.ODE.Space.getGeom: Index ("++show nth++") out of range." diff --git a/src/Physics/ODE/Types.hsc b/src/Physics/ODE/Types.hsc new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Types.hsc @@ -0,0 +1,109 @@ +{-# LANGUAGE EmptyDataDecls #-} +#include +module Physics.ODE.Types where + +import Foreign + +type ODEreal = #{type dReal} + +type Matrix3 = Ptr ODEreal +type Quaternion = (ODEreal, ODEreal, ODEreal, ODEreal) + +data WorldStruct +type World = Ptr WorldStruct + +data SpaceStruct +type Space = Ptr SpaceStruct + +data BodyStruct +type Body = Ptr BodyStruct + +data GeomStruct +type Geom = Ptr GeomStruct + +data JointStruct +type Joint = Ptr JointStruct + +data JointGroupStruct +type JointGroup = Ptr JointGroupStruct + +data MassStruct +type Mass = ForeignPtr MassStruct + +data ContactGeom + = ContactGeom + { contactPos :: (ODEreal, ODEreal, ODEreal) + , contactNormal :: (ODEreal, ODEreal, ODEreal) + , contactDepth :: ODEreal + , contactObjects:: (Geom,Geom) + } deriving (Show) + +data ContactInfo + = ContactInfo + { contactSurface :: Surface + , contactGeom :: ContactGeom + , contactFDir1 :: (ODEreal,ODEreal,ODEreal) + } deriving (Show) + +data Surface + = Surface + { surfaceMu :: ODEreal + , surfaceMu2 :: Maybe ODEreal + , surfaceBounce :: Maybe (ODEreal,ODEreal) + , surfaceSoftERP :: Maybe ODEreal + , surfaceSoftCFM :: Maybe ODEreal + , surfaceMotion1 :: Maybe ODEreal + , surfaceMotion2 :: Maybe ODEreal + , surfaceSlip1 :: Maybe ODEreal + , surfaceSlip2 :: Maybe ODEreal + } deriving (Show,Eq) + + + +data SurfaceMode + = HaveMu2 + | HaveFDir1 + | HaveBounce + | HaveSoftERP + | HaveSoftCFM + | HaveMotion1 + | HaveMotion2 + | HaveSlip1 + | HaveSlip2 + | HaveApprox11 + | HaveApprox12 + deriving (Show,Eq,Enum,Bounded) + +data JointType + = Ball + | Hinge + | Slider + | Contact + | Universal + | Hinge2 + | Fixed + | AMotor + deriving (Show,Eq,Ord) + +data BodyIndex + = First + | Second + deriving (Show,Eq,Ord) + +data GeomClass + = Sphere + | Box + | CappedCylinder + | Cylinder + | Plane + | GeomTransform + | Ray + | TriangleMesh + | SimpleSpace + | HashSpace + deriving (Show,Eq,Ord) + +data RotationMode + = Infinitesimal + | Finite ODEreal ODEreal ODEreal + deriving (Show,Eq,Ord) diff --git a/src/Physics/ODE/Utilities.hs b/src/Physics/ODE/Utilities.hs new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/Utilities.hs @@ -0,0 +1,32 @@ +{-# LANGUAGE ParallelListComp #-} +module Physics.ODE.Utilities where + +import Foreign + +import Data.Array + +forceFinalization :: ForeignPtr a -> IO () +#ifdef __GLASGOW_HASKELL__ +forceFinalization = finalizeForeignPtr +#else +forceFinalization _ = return () +#endif + +peekVector3 :: Storable a => Ptr a -> IO (a,a,a) +peekVector3 ptr + = do [x,y,z] <- peekArray 3 ptr + return (x,y,z) + +pokeVector3 :: Storable a => Ptr a -> (a,a,a) -> IO () +pokeVector3 ptr (x,y,z) + = pokeArray ptr [x,y,z] + +peekVector4 :: Storable a => Ptr a -> IO (a,a,a,a) +peekVector4 ptr + = do [x,y,z,n] <- peekArray 4 ptr + return (x,y,z,n) + +peekMatrix :: Storable a => (Int,Int) -> Ptr a -> IO (Array (Int,Int) a) +peekMatrix (x,y) ptr + = do elts <- peekArray (x*y) ptr + return (array ((0,0),(x,y)) [((a,b),e) | e <- elts | a <- [0..x-1], b <- [0..y-1]]) diff --git a/src/Physics/ODE/World.hs b/src/Physics/ODE/World.hs new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/World.hs @@ -0,0 +1,56 @@ +module Physics.ODE.World + (create, destroyWorld, setGravity, getGravity, closeODE, step, + quickStep, setContactSurfaceLayer, getContactSurfaceLayer) + where +import Foreign +import Physics.ODE.Types +import Physics.ODE.Utilities + +foreign import ccall unsafe "dCloseODE" closeODE :: IO () +create :: IO World +create = do ret_0 <- createdWorldCreate + return (ret_0) +foreign import ccall unsafe "dWorldCreate" createdWorldCreate :: IO World +destroyWorld :: World -> IO () +destroyWorld = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- destroyWorlddWorldDestroy marshaledArg_2 + case () of + () -> do return ()) +foreign import ccall unsafe "dWorldDestroy" destroyWorlddWorldDestroy :: World -> + IO () +setGravity :: World -> ODEreal -> ODEreal -> ODEreal -> IO () +setGravity = \arg_0 arg_1 arg_2 arg_3 -> (\action_4 -> action_4 arg_0) (\marshaledArg_5 -> (\action_6 -> action_6 arg_1) (\marshaledArg_7 -> (\action_8 -> action_8 arg_2) (\marshaledArg_9 -> (\action_10 -> action_10 arg_3) (\marshaledArg_11 -> do ret_12 <- setGravitydWorldSetGravity marshaledArg_5 marshaledArg_7 marshaledArg_9 marshaledArg_11 + case () of + () -> do return ())))) +foreign import ccall unsafe "dWorldSetGravity" setGravitydWorldSetGravity :: World -> + ODEreal -> + ODEreal -> + ODEreal -> IO () +getGravity :: World -> IO ((ODEreal, ODEreal, ODEreal)) +getGravity = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> allocaArray 4 (\marshaledArg_3 -> do ret_4 <- getGravitydWorldGetGravity marshaledArg_2 marshaledArg_3 + peekVector3 (marshaledArg_3))) +foreign import ccall unsafe "dWorldGetGravity" getGravitydWorldGetGravity :: World -> + Ptr ODEreal -> IO () +step :: World -> ODEreal -> IO () +step = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- stepdWorldStep marshaledArg_3 marshaledArg_5 + case () of + () -> do return ())) +foreign import ccall unsafe "dWorldStep" stepdWorldStep :: World -> + ODEreal -> IO () +quickStep :: World -> ODEreal -> IO () +quickStep = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- quickStepdWorldQuickStep marshaledArg_3 marshaledArg_5 + case () of + () -> do return ())) +foreign import ccall unsafe "dWorldQuickStep" quickStepdWorldQuickStep :: World -> + ODEreal -> IO () +setContactSurfaceLayer :: World -> ODEreal -> IO () +setContactSurfaceLayer = \arg_0 arg_1 -> (\action_2 -> action_2 arg_0) (\marshaledArg_3 -> (\action_4 -> action_4 arg_1) (\marshaledArg_5 -> do ret_6 <- setContactSurfaceLayerdWorldSetContactSurfaceLayer marshaledArg_3 marshaledArg_5 + case () of + () -> do return ())) +foreign import ccall unsafe "dWorldSetContactSurfaceLayer" setContactSurfaceLayerdWorldSetContactSurfaceLayer :: World -> + ODEreal -> + IO () +getContactSurfaceLayer :: World -> IO ODEreal +getContactSurfaceLayer = \arg_0 -> (\action_1 -> action_1 arg_0) (\marshaledArg_2 -> do ret_3 <- getContactSurfaceLayerdWorldGetContactSurfaceLayer marshaledArg_2 + return (ret_3)) +foreign import ccall unsafe "dWorldGetContactSurfaceLayer" getContactSurfaceLayerdWorldGetContactSurfaceLayer :: World -> + IO ODEreal diff --git a/src/Physics/ODE/World.th b/src/Physics/ODE/World.th new file mode 100644 --- /dev/null +++ b/src/Physics/ODE/World.th @@ -0,0 +1,41 @@ +module Physics.ODE.World + ( create + , destroyWorld + , setGravity + , getGravity + , closeODE + , step + , quickStep + , setContactSurfaceLayer + , getContactSurfaceLayer + ) where + +import Foreign + +import Physics.ODE.Types +import Physics.ODE.Utilities + +#ifdef HASTH +import Foreign.HacanonLight.DIS +import Foreign.HacanonLight.Generate +import Physics.ODE.DIS +#endif + +$(bind "create" "dWorldCreate" [world]) + +$(bind "destroyWorld" "dWorldDestroy" [world,unit]) + +$(bind "setGravity" "dWorldSetGravity" [world,ode,ode,ode,unit]) + +$(bind "getGravity" "dWorldGetGravity" [world,vector3Out,unit]) + +foreign import ccall unsafe "dCloseODE" closeODE :: IO () + +$(bind "step" "dWorldStep" [world,ode,unit]) + +$(bind "quickStep" "dWorldQuickStep" [world,ode,unit]) + +$(bind "setContactSurfaceLayer" "dWorldSetContactSurfaceLayer" [world,ode,unit]) + +$(bind "getContactSurfaceLayer" "dWorldGetContactSurfaceLayer" [world,ode]) +