{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE Strict #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE ViewPatterns #-}
module Apecs.Physics.Space where
import Apecs
import Apecs.Core
import Control.Monad.IO.Class (liftIO, MonadIO)
import Data.IORef
import Foreign.Concurrent
import Foreign.ForeignPtr (withForeignPtr)
import qualified Language.C.Inline as C
import Linear.V2
import Apecs.Physics.Types
C.context phycsCtx
C.include "<chipmunk.h>"
newSpace :: IO SpacePtr
newSpace = do
spaceRaw <- [C.exp| cpSpace* { cpSpaceNew() } |]
newForeignPtr spaceRaw [C.exp| void { cpSpaceFree($(cpSpace* spaceRaw)) } |]
explStepPhysics :: SpacePtr -> Double -> IO ()
explStepPhysics spacePtr (realToFrac -> dT) = withForeignPtr spacePtr $ \space ->
[C.exp| void { cpSpaceStep( $(cpSpace* space), $(double dT) ) } |]
stepPhysics :: MonadIO m => Has w m Physics => Double -> SystemT w m ()
stepPhysics dT = do
s :: Space Physics <- getStore
liftIO$ explStepPhysics (spacePtr s) dT
instance Component Physics where
type Storage Physics = Space Physics
type instance Elem (Space Physics) = Physics
instance MonadIO m => ExplInit m (Space Physics) where
explInit = liftIO $ do
spacePtr <- newSpace
bRef <- newIORef mempty
sRef <- newIORef mempty
cRef <- newIORef mempty
hRef <- newIORef mempty
return (Space bRef sRef cRef hRef spacePtr)
earthGravity :: Gravity
earthGravity = Gravity $ V2 0 (-9.81)
getGravity :: SpacePtr -> IO (V2 Double)
getGravity spacePtr = withForeignPtr spacePtr $ \space -> do
x <- [C.exp| double { cpSpaceGetGravity ($(cpSpace* space)).x } |]
y <- [C.exp| double { cpSpaceGetGravity ($(cpSpace* space)).y } |]
return (V2 (realToFrac x) (realToFrac y))
setGravity :: SpacePtr -> V2 Double -> IO ()
setGravity spacePtr (V2 (realToFrac -> x) (realToFrac -> y)) = withForeignPtr spacePtr $ \space -> [C.block| void {
const cpVect vec = { $(double x), $(double y) };
cpSpaceSetGravity($(cpSpace* space), vec);
} |]
instance Component Gravity where
type Storage Gravity = Space Gravity
instance (MonadIO m, Has w m Physics) => Has w m Gravity where
getStore = (cast :: Space Physics -> Space Gravity) <$> getStore
type instance Elem (Space Gravity) = Gravity
instance MonadIO m => ExplGet m (Space Gravity) where
explExists _ _ = return True
explGet (Space _ _ _ _ spcPtr) _ = liftIO $ Gravity <$> getGravity spcPtr
instance MonadIO m => ExplSet m (Space Gravity) where
explSet (Space _ _ _ _ spcPtr) _ (Gravity v) = liftIO $ setGravity spcPtr v
getIterations :: SpacePtr -> IO Int
getIterations spacePtr = withForeignPtr spacePtr $ \space -> fromIntegral <$> [C.exp| int { cpSpaceGetIterations ($(cpSpace* space)) } |]
setIterations :: SpacePtr -> Int -> IO ()
setIterations spacePtr (fromIntegral -> its) = withForeignPtr spacePtr $ \space -> [C.block| void {
cpSpaceSetIterations($(cpSpace* space), $(int its));
} |]
instance Component Iterations where
type Storage Iterations = Space Iterations
instance (MonadIO m, Has w m Physics) => Has w m Iterations where
getStore = (cast :: Space Physics -> Space Iterations) <$> getStore
type instance Elem (Space Iterations) = Iterations
instance MonadIO m => ExplGet m (Space Iterations) where
explExists _ _ = return False
explGet (Space _ _ _ _ spcPtr) _ = liftIO $ Iterations <$> getIterations spcPtr
instance MonadIO m => ExplSet m (Space Iterations) where
explSet (Space _ _ _ _ spcPtr) _ (Iterations v) = liftIO $ setIterations spcPtr v