{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
module Apecs.Physics.Types where
import Apecs
import Apecs.Core
import Data.Bits
import Data.Char (intToDigit)
import qualified Data.IntMap as M
import qualified Data.IntSet as S
import Data.IORef
import qualified Data.Map as Map
import Data.Monoid ((<>))
import qualified Foreign.C.Types as C
import Foreign.ForeignPtr
import Foreign.Ptr
import Language.C.Inline
import Language.C.Inline.Context
import qualified Language.C.Types as C
import qualified Language.Haskell.TH as TH
import Linear.V2
import Numeric (showIntAtBase)
phycsCtx :: Context
phycsCtx = baseCtx <> funCtx <> ctx
where ctx = mempty { ctxTypesTable = phycsTypesTable }
phycsTypesTable :: Map.Map C.TypeSpecifier TH.TypeQ
phycsTypesTable = Map.fromList
[ (C.TypeName "cpArbiter", [t| Collision |])
, (C.TypeName "cpBody", [t| Body |])
, (C.TypeName "cpCollisionHandler", [t| CollisionHandler |])
, (C.TypeName "cpConstraint", [t| Constraint |])
, (C.TypeName "cpDataPointer", [t| C.CUInt |])
, (C.TypeName "cpShape", [t| Shape |])
, (C.TypeName "cpPointQueryInfo", [t| PointQueryResult |])
, (C.TypeName "cpVect", [t| V2 C.CDouble |])
, (C.TypeName "cpSpace", [t| FrnSpace |])
]
data Physics
type Vec = V2 Double
type BVec = Vec
type WVec = Vec
data Body = DynamicBody | KinematicBody | StaticBody deriving (Eq, Ord, Enum)
newtype Position = Position WVec
newtype Velocity = Velocity WVec
newtype Force = Force Vec
newtype Torque = Torque Double
newtype BodyMass = BodyMass Double deriving (Eq, Show)
newtype Moment = Moment Double deriving (Eq, Show)
newtype Angle = Angle Double deriving (Eq, Show)
newtype AngularVelocity = AngularVelocity Double
newtype CenterOfGravity = CenterOfGravity BVec
data Shape = Shape Convex
| ShapeExtend Entity Convex
| ShapeRead
data Convex = Convex [BVec] Double deriving (Eq, Show)
newtype Sensor = Sensor Bool deriving (Eq, Show)
newtype Elasticity = Elasticity Double deriving (Eq, Show)
newtype Mass = Mass Double deriving (Eq, Show)
newtype Density = Density Double deriving (Eq, Show)
newtype Friction = Friction Double deriving (Eq, Show)
newtype SurfaceVelocity = SurfaceVelocity Vec deriving (Eq, Show)
newtype CollisionType = CollisionType C.CUIntPtr deriving (Eq, Show)
newtype ShapeBody = ShapeBody Entity deriving (Eq, Show)
type CollisionGroup = CUInt
data CollisionFilter = CollisionFilter
{ filterGroup :: CollisionGroup
, filterCategories :: Bitmask
, filterMask :: Bitmask
} deriving (Eq, Show)
newtype Bitmask = Bitmask CUInt deriving (Eq, Bits)
instance Show Bitmask where
show (Bitmask mask) = "Bitmask " ++ showIntAtBase 2 intToDigit mask ""
data FrnSpace
data FrnVec
data Space c = Space
{ spBodies :: IOMap BodyRecord
, spShapes :: PtrMap Shape
, spConstraints :: PtrMap Constraint
, spHandlers :: PtrMap CollisionHandler
, spacePtr :: SpacePtr
}
type instance Elem (Space a) = a
data BodyRecord = BodyRecord
{ brPtr :: Ptr Body
, brShapes :: S.IntSet
, brConstraints :: S.IntSet
}
type IOMap a = IORef (M.IntMap a)
type PtrMap a = IOMap (Ptr a)
type SpacePtr = ForeignPtr FrnSpace
newtype Iterations = Iterations Int
newtype Gravity = Gravity Vec deriving (Eq, Show)
newtype Damping = Damping Double
newtype IdleSpeedThreshold = IdleSpeedThreshold Double
newtype SleepIdleTime = SleepIdleTime Double
newtype CollisionSlop = CollisionSlop Double
newtype CollisionBias = CollisionBias Double
cast :: Space a -> Space b
cast (Space b s c h w) = Space b s c h w
newtype MaxForce = MaxForce Double
newtype MaxBias = MaxBias Double
newtype ErrorBias = ErrorBias Double
newtype CollideBodies = CollideBodies Bool
data Constraint = Constraint Entity ConstraintType
| ConstraintExtend Entity Entity ConstraintType
| ConstraintRead
data ConstraintType
= PinJoint BVec BVec
| SlideJoint BVec BVec Double Double
| PivotJoint WVec
| PivotJoint2 BVec BVec
| GrooveJoint BVec BVec BVec
| DampedSpring BVec BVec Double Double Double
| DampedRotarySpring Double Double Double
| RotaryLimitJoint Double Double
| RatchetJoint Double Double
| GearJoint Double Double
| SimpleMotor Double
newtype BeginCB = BeginCB BeginFunc
newtype SeparateCB = SeparateCB SeparateFunc
newtype PreSolveCB = PreSolveCB PreSolveFunc
newtype PostSolveCB = PostSolveCB PostSolveFunc
type BeginFunc = Ptr Collision -> Ptr FrnSpace -> C.CUInt -> IO C.CUChar
type SeparateFunc = Ptr Collision -> Ptr FrnSpace -> C.CUInt -> IO ()
type PreSolveFunc = Ptr Collision -> Ptr FrnSpace -> C.CUInt -> IO C.CUChar
type PostSolveFunc = Ptr Collision -> Ptr FrnSpace -> C.CUInt -> IO ()
data CollisionHandler = CollisionHandler
{ source :: CollisionSource
, beginCB :: Maybe BeginCB
, separateCB :: Maybe SeparateCB
, preSolveCB :: Maybe PreSolveCB
, postSolveCB :: Maybe PostSolveCB
}
data CollisionSource
= Wildcard CollisionGroup
| Between CollisionGroup CollisionGroup
data Collision = Collision
{ collisionNormal :: Vec
, collisionA :: Entity
, collisionB :: Entity
} deriving (Eq, Show)
data CollisionProperties = CollisionProperties
{ collisionElasticity :: Double
, collisionFriction :: Double
, collisionSurfaceVelocity :: Vec
} deriving (Eq, Show)
data SegmentQueryResult = SegmentQueryResult
{ sqShape :: Entity
, sqImpactPoint :: Vec
, sqImpactNormal :: Vec
, sqImpactAlpha :: Double
} deriving (Eq, Show)
data PointQueryResult = PointQueryResult
{ pqShape :: Entity
, pqPoint :: WVec
, pqDistance :: Double
, pqGradient :: Double
} deriving (Eq, Show)