{-# 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>"

-- Space
newSpace :: IO SpacePtr
newSpace :: IO SpacePtr
newSpace = do
    Ptr FrnSpace
spaceRaw <- [C.exp| cpSpace* { cpSpaceNew() } |]
    Ptr FrnSpace -> IO () -> IO SpacePtr
forall a. Ptr a -> IO () -> IO (ForeignPtr a)
newForeignPtr Ptr FrnSpace
spaceRaw [C.exp| void { cpSpaceFree($(cpSpace* spaceRaw)) } |]

explStepPhysics :: SpacePtr -> Double -> IO ()
explStepPhysics :: SpacePtr -> Double -> IO ()
explStepPhysics SpacePtr
spacePtr (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
dT) = SpacePtr -> (Ptr FrnSpace -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr SpacePtr
spacePtr ((Ptr FrnSpace -> IO ()) -> IO ())
-> (Ptr FrnSpace -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr FrnSpace
space ->
  [C.exp| void { cpSpaceStep( $(cpSpace* space), $(double dT) ) } |]

stepPhysics :: MonadIO m => Has w m Physics => Double -> SystemT w m ()
stepPhysics :: Double -> SystemT w m ()
stepPhysics Double
dT = do
  Space Physics
s :: Space Physics <- SystemT w m (Space Physics)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore
  IO () -> SystemT w m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO(IO () -> SystemT w m ()) -> IO () -> SystemT w m ()
forall a b. (a -> b) -> a -> b
$ SpacePtr -> Double -> IO ()
explStepPhysics (Space Physics -> SpacePtr
forall c. Space c -> SpacePtr
spacePtr Space Physics
s) Double
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 :: m (Space Physics)
explInit = IO (Space Physics) -> m (Space Physics)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Space Physics) -> m (Space Physics))
-> IO (Space Physics) -> m (Space Physics)
forall a b. (a -> b) -> a -> b
$ do
    SpacePtr
spacePtr <- IO SpacePtr
newSpace
    IORef (IntMap BodyRecord)
bRef     <- IntMap BodyRecord -> IO (IORef (IntMap BodyRecord))
forall a. a -> IO (IORef a)
newIORef IntMap BodyRecord
forall a. Monoid a => a
mempty
    IORef (IntMap (Record Shape))
sRef     <- IntMap (Record Shape) -> IO (IORef (IntMap (Record Shape)))
forall a. a -> IO (IORef a)
newIORef IntMap (Record Shape)
forall a. Monoid a => a
mempty
    IORef (IntMap (Record Constraint))
cRef     <- IntMap (Record Constraint)
-> IO (IORef (IntMap (Record Constraint)))
forall a. a -> IO (IORef a)
newIORef IntMap (Record Constraint)
forall a. Monoid a => a
mempty
    IORef (IntMap (Record CollisionHandler))
hRef     <- IntMap (Record CollisionHandler)
-> IO (IORef (IntMap (Record CollisionHandler)))
forall a. a -> IO (IORef a)
newIORef IntMap (Record CollisionHandler)
forall a. Monoid a => a
mempty
    Space Physics -> IO (Space Physics)
forall (m :: * -> *) a. Monad m => a -> m a
return (IORef (IntMap BodyRecord)
-> IORef (IntMap (Record Shape))
-> IORef (IntMap (Record Constraint))
-> IORef (IntMap (Record CollisionHandler))
-> SpacePtr
-> Space Physics
forall c.
IORef (IntMap BodyRecord)
-> IORef (IntMap (Record Shape))
-> IORef (IntMap (Record Constraint))
-> IORef (IntMap (Record CollisionHandler))
-> SpacePtr
-> Space c
Space IORef (IntMap BodyRecord)
bRef IORef (IntMap (Record Shape))
sRef IORef (IntMap (Record Constraint))
cRef IORef (IntMap (Record CollisionHandler))
hRef SpacePtr
spacePtr)

-- Gravity
earthGravity :: Gravity
earthGravity :: Gravity
earthGravity = Vec -> Gravity
Gravity (Vec -> Gravity) -> Vec -> Gravity
forall a b. (a -> b) -> a -> b
$ Double -> Double -> Vec
forall a. a -> a -> V2 a
V2 Double
0 (-Double
9.81)

getGravity :: SpacePtr -> IO (V2 Double)
getGravity :: SpacePtr -> IO Vec
getGravity SpacePtr
spacePtr = SpacePtr -> (Ptr FrnSpace -> IO Vec) -> IO Vec
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr SpacePtr
spacePtr ((Ptr FrnSpace -> IO Vec) -> IO Vec)
-> (Ptr FrnSpace -> IO Vec) -> IO Vec
forall a b. (a -> b) -> a -> b
$ \Ptr FrnSpace
space -> do
  CDouble
x <- [C.exp| double { cpSpaceGetGravity ($(cpSpace* space)).x } |]
  CDouble
y <- [C.exp| double { cpSpaceGetGravity ($(cpSpace* space)).y } |]
  Vec -> IO Vec
forall (m :: * -> *) a. Monad m => a -> m a
return (Double -> Double -> Vec
forall a. a -> a -> V2 a
V2 (CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CDouble
x) (CDouble -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac CDouble
y))

setGravity :: SpacePtr -> V2 Double -> IO ()
setGravity :: SpacePtr -> Vec -> IO ()
setGravity SpacePtr
spacePtr (V2 (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
x) (Double -> CDouble
forall a b. (Real a, Fractional b) => a -> b
realToFrac -> CDouble
y)) = SpacePtr -> (Ptr FrnSpace -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr SpacePtr
spacePtr ((Ptr FrnSpace -> IO ()) -> IO ())
-> (Ptr FrnSpace -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr FrnSpace
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 :: SystemT w m (Storage Gravity)
getStore = (Space Physics -> Space Gravity
forall a b. Space a -> Space b
cast :: Space Physics -> Space Gravity) (Space Physics -> Space Gravity)
-> SystemT w m (Space Physics) -> SystemT w m (Space Gravity)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemT w m (Space Physics)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore

type instance Elem (Space Gravity) = Gravity

instance MonadIO m => ExplGet m (Space Gravity) where
  explExists :: Space Gravity -> Int -> m Bool
explExists Space Gravity
_ Int
_  = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
  explGet :: Space Gravity -> Int -> m (Elem (Space Gravity))
explGet (Space IORef (IntMap BodyRecord)
_ IORef (IntMap (Record Shape))
_ IORef (IntMap (Record Constraint))
_ IORef (IntMap (Record CollisionHandler))
_ SpacePtr
spcPtr) Int
_ = IO Gravity -> m Gravity
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Gravity -> m Gravity) -> IO Gravity -> m Gravity
forall a b. (a -> b) -> a -> b
$ Vec -> Gravity
Gravity (Vec -> Gravity) -> IO Vec -> IO Gravity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpacePtr -> IO Vec
getGravity SpacePtr
spcPtr
instance MonadIO m => ExplSet m (Space Gravity) where
  explSet :: Space Gravity -> Int -> Elem (Space Gravity) -> m ()
explSet (Space IORef (IntMap BodyRecord)
_ IORef (IntMap (Record Shape))
_ IORef (IntMap (Record Constraint))
_ IORef (IntMap (Record CollisionHandler))
_ SpacePtr
spcPtr) Int
_ (Gravity v) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SpacePtr -> Vec -> IO ()
setGravity SpacePtr
spcPtr Vec
v

-- Iterations
getIterations :: SpacePtr -> IO Int
getIterations :: SpacePtr -> IO Int
getIterations SpacePtr
spacePtr = SpacePtr -> (Ptr FrnSpace -> IO Int) -> IO Int
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr SpacePtr
spacePtr ((Ptr FrnSpace -> IO Int) -> IO Int)
-> (Ptr FrnSpace -> IO Int) -> IO Int
forall a b. (a -> b) -> a -> b
$ \Ptr FrnSpace
space -> CInt -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral (CInt -> Int) -> IO CInt -> IO Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [C.exp| int { cpSpaceGetIterations ($(cpSpace* space)) } |]

setIterations :: SpacePtr -> Int -> IO ()
setIterations :: SpacePtr -> Int -> IO ()
setIterations SpacePtr
spacePtr (Int -> CInt
forall a b. (Integral a, Num b) => a -> b
fromIntegral -> CInt
its) = SpacePtr -> (Ptr FrnSpace -> IO ()) -> IO ()
forall a b. ForeignPtr a -> (Ptr a -> IO b) -> IO b
withForeignPtr SpacePtr
spacePtr ((Ptr FrnSpace -> IO ()) -> IO ())
-> (Ptr FrnSpace -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Ptr FrnSpace
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 :: SystemT w m (Storage Iterations)
getStore = (Space Physics -> Space Iterations
forall a b. Space a -> Space b
cast :: Space Physics -> Space Iterations) (Space Physics -> Space Iterations)
-> SystemT w m (Space Physics) -> SystemT w m (Space Iterations)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SystemT w m (Space Physics)
forall w (m :: * -> *) c. Has w m c => SystemT w m (Storage c)
getStore

type instance Elem (Space Iterations) = Iterations

instance MonadIO m => ExplGet m (Space Iterations) where
  explExists :: Space Iterations -> Int -> m Bool
explExists Space Iterations
_ Int
_  = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  explGet :: Space Iterations -> Int -> m (Elem (Space Iterations))
explGet (Space IORef (IntMap BodyRecord)
_ IORef (IntMap (Record Shape))
_ IORef (IntMap (Record Constraint))
_ IORef (IntMap (Record CollisionHandler))
_ SpacePtr
spcPtr) Int
_ = IO Iterations -> m Iterations
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Iterations -> m Iterations) -> IO Iterations -> m Iterations
forall a b. (a -> b) -> a -> b
$ Int -> Iterations
Iterations (Int -> Iterations) -> IO Int -> IO Iterations
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SpacePtr -> IO Int
getIterations SpacePtr
spcPtr
instance MonadIO m => ExplSet m (Space Iterations) where
  explSet :: Space Iterations -> Int -> Elem (Space Iterations) -> m ()
explSet (Space IORef (IntMap BodyRecord)
_ IORef (IntMap (Record Shape))
_ IORef (IntMap (Record Constraint))
_ IORef (IntMap (Record CollisionHandler))
_ SpacePtr
spcPtr) Int
_ (Iterations v) = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ SpacePtr -> Int -> IO ()
setIterations SpacePtr
spcPtr Int
v