content: {-# LANGUAGE FlexibleContexts      #-}
  {-# LANGUAGE FlexibleInstances     #-}
  {-# LANGUAGE MultiParamTypeClasses #-}
  {-# LANGUAGE OverloadedStrings     #-}
  {-# LANGUAGE QuasiQuotes           #-}
  {-# LANGUAGE ScopedTypeVariables   #-}
  {-# LANGUAGE Strict                #-}
  {-# LANGUAGE TemplateHaskell       #-}
  {-# LANGUAGE TypeFamilies          #-}
  {-# LANGUAGE UndecidableInstances  #-}
  {-# LANGUAGE ViewPatterns          #-}
  
  module Apecs.Physics.Shape where
  
  import           Apecs.Core
  import           Control.Monad
  import           Control.Monad.IO.Class (liftIO, MonadIO)
  import           Data.Bits
  import qualified Data.IntMap          as M
  import qualified Data.IntSet          as S
  import           Data.IORef
  import           Data.Monoid          ((<>))
  import qualified Data.Vector.Storable as V
  import qualified Data.Vector.Unboxed  as U
  import           Foreign.ForeignPtr
  import           Foreign.Ptr
  import qualified Language.C.Inline    as C
  import           Linear.V2
  
  import           Apecs.Physics.Space  ()
  import           Apecs.Physics.Types
  
  C.context (phycsCtx <> C.vecCtx)
  C.include "<chipmunk.h>"
  
  maskAll, maskNone :: Bitmask
  maskAll  = complement zeroBits
  maskNone = zeroBits
  -- | Makes a bitmask from a list of indices
  maskList :: [Int] -> Bitmask
  maskList = foldr (flip setBit) maskNone
  
  defaultFilter :: CollisionFilter
  defaultFilter = CollisionFilter 0 maskAll maskAll
  
  -- | A box with the given height, width, and center point
  boxShape :: Double -> Double -> Vec -> Convex
  boxShape w h offset = Convex ((+offset) <$> verts) 0
    where
      w' = w/2
      h' = h/2
      verts = [ V2 (-w') (-h')
              , V2 (-w') h'
              , V2 w' h'
              , V2 w' (-h') ]
  
  instance Component Shape where
    type Storage Shape = Space Shape
  
  instance (MonadIO m, Has w m Physics) => Has w m Shape where
    getStore = (cast :: Space Physics -> Space Shape) <$> getStore
  
  instance MonadIO m => ExplMembers m (Space Shape) where
    explMembers (Space _ sMap _ _ _) = liftIO $ U.fromList . M.keys <$> readIORef sMap
  
  instance MonadIO m => ExplDestroy m (Space Shape) where
    explDestroy (Space bMap sMap _ _ spc) sEty = liftIO $ do
      rd <- M.lookup sEty <$> readIORef sMap
      forM_ rd $ \(Record sPtr (Shape (Entity bEty) _)) -> do
        rd <- M.lookup bEty <$> readIORef bMap
        forM_ rd $ \bRec -> modifyIORef' (brShapes bRec) (S.delete sEty)
        modifyIORef' sMap (M.delete sEty)
        destroyShape spc sPtr
  
  instance MonadIO m => ExplSet m (Space Shape) where
    explSet sp@(Space bMap sMap _ _ spcPtr) sEty shape@(Shape (Entity bEty) sh) = liftIO $ do
      explDestroy sp sEty
      rd <- M.lookup bEty <$> readIORef bMap
      forM_ rd $ \bRec -> do
        shPtr <- newShape spcPtr (brPtr bRec) sh sEty
        modifyIORef' (brShapes bRec) (S.insert sEty)
        modifyIORef' sMap (M.insert sEty (Record shPtr shape))
  
  instance MonadIO m => ExplGet m (Space Shape) where
    explGet    (Space _ sMap _ _ _) ety = liftIO $ do
      Just (Record _ s) <- M.lookup ety <$> readIORef sMap
      return s
    explExists (Space _ sMap _ _ _) ety = liftIO $ M.member ety <$> readIORef sMap
  
  newShape :: SpacePtr -> Ptr Body -> Convex -> Int -> IO (Ptr Shape)
  newShape spacePtr' bodyPtr shape (fromIntegral -> ety) = withForeignPtr spacePtr' (go shape)
    where
  
      go (Convex [fmap realToFrac -> V2 x y] (realToFrac -> radius)) spacePtr = [C.block| cpShape* {
        const cpVect vec = { $(double x), $(double y) };
        cpShape* sh = cpCircleShapeNew($(cpBody* bodyPtr), $(double radius), vec);
        cpShapeSetUserData(sh, (void*) $(intptr_t ety));
        return cpSpaceAddShape( $(cpSpace* spacePtr), sh); } |]
  
      go (Convex [ fmap realToFrac -> V2 xa ya
                 , fmap realToFrac -> V2 xb yb ]
                  (realToFrac -> radius)
         ) spacePtr = [C.block| cpShape* {
         const cpVect va = { $(double xa), $(double ya) };
         const cpVect vb = { $(double xb), $(double yb) };
         cpShape* sh = cpSegmentShapeNew($(cpBody* bodyPtr), va, vb, $(double radius));
         cpShapeSetUserData(sh, (void*) $(intptr_t ety));
         return cpSpaceAddShape( $(cpSpace* spacePtr), sh); } |]
  
      go (Convex ((fmap.fmap) realToFrac -> verts)
                 (realToFrac -> radius)
         ) spacePtr = liftIO $ do
           vec <- V.thaw (V.fromList verts)
           [C.block| cpShape* {
             cpTransform trans = cpTransformIdentity;
             cpShape* sh = cpPolyShapeNew($(cpBody* bodyPtr), $vec-len:vec, $vec-ptr:(cpVect *vec), trans, $(double radius));
             cpShapeSetUserData(sh, (void*) $(intptr_t ety));
             return cpSpaceAddShape( $(cpSpace* spacePtr), sh); } |]
  
  destroyShape :: SpacePtr -> Ptr Shape -> IO ()
  destroyShape spacePtr shapePtr = withForeignPtr spacePtr $ \space -> [C.block| void {
    cpShape *shape = $(cpShape* shapePtr);
    cpSpaceRemoveShape($(cpSpace* space), shape);
    cpShapeFree (shape); }|]
  
  -- Sensor
  getSensor :: Ptr Shape -> IO Bool
  getSensor shape = toEnum . fromIntegral <$> [C.exp| int {
    cpShapeGetSensor($(cpShape* shape)) }|]
  
  setSensor :: Ptr Shape -> Bool -> IO ()
  setSensor shape (fromIntegral . fromEnum -> isSensor) = [C.exp| void {
    cpShapeSetSensor($(cpShape* shape), $(int isSensor)) }|]
  
  instance Component Sensor where
    type Storage Sensor = Space Sensor
  instance (MonadIO m, Has w m Physics) => Has w m Sensor where
    getStore = (cast :: Space Physics -> Space Sensor) <$> getStore
  
  instance MonadIO m => ExplMembers m (Space Sensor) where
    explMembers s = explMembers (cast s :: Space Shape)
  
  instance MonadIO m => ExplSet m (Space Sensor) where
    explSet (Space _ sMap _ _ _) ety (Sensor isSensor) = liftIO $ do
      rd <- M.lookup ety <$> readIORef sMap
      forM_ rd$ \(Record s _) -> setSensor s isSensor
  
  instance MonadIO m => ExplGet m (Space Sensor) where
    explExists s ety = liftIO $ explExists (cast s :: Space Shape) ety
    explGet (Space _ sMap _ _ _) ety = liftIO $ do
      Just (Record s _) <- M.lookup ety <$> readIORef sMap
      Sensor <$> getSensor s
  
  -- Elasticity
  getElasticity :: Ptr Shape -> IO Double
  getElasticity shape = realToFrac <$> [C.exp| double {
    cpShapeGetElasticity($(cpShape* shape)) }|]
  
  setElasticity :: Ptr Shape -> Double -> IO ()
  setElasticity shape (realToFrac -> elasticity) = [C.exp| void {
    cpShapeSetElasticity($(cpShape* shape), $(double elasticity)) }|]
  
  instance Component Elasticity where
    type Storage Elasticity = Space Elasticity
  instance (MonadIO m, Has w m Physics) => Has w m Elasticity where
    getStore = (cast :: Space Physics -> Space Elasticity) <$> getStore
  
  instance MonadIO m => ExplMembers m (Space Elasticity) where
    explMembers s = explMembers (cast s :: Space Shape)
  
  instance MonadIO m => ExplSet m (Space Elasticity) where
    explSet (Space _ sMap _ _ _) ety (Elasticity elasticity) = liftIO $ do
      rd <- M.lookup ety <$> readIORef sMap
      forM_ rd$ \(Record s _) -> setElasticity s elasticity
  
  instance MonadIO m => ExplGet m (Space Elasticity) where
    explExists s ety = liftIO $ explExists (cast s :: Space Shape) ety
    explGet (Space _ sMap _ _ _) ety = liftIO $ do
      Just (Record s _) <- M.lookup ety <$> readIORef sMap
      Elasticity <$> getElasticity s
  
  -- Mass
  getMass :: Ptr Shape -> IO Double
  getMass shape = realToFrac <$> [C.exp| double {
    cpShapeGetMass($(cpShape* shape)) }|]
  
  setMass :: Ptr Shape -> Double -> IO ()
  setMass shape (realToFrac -> mass) = [C.exp| void {
    cpShapeSetMass($(cpShape* shape), $(double mass)) }|]
  
  instance Component Mass where
    type Storage Mass = Space Mass
  instance (MonadIO m, Has w m Physics) => Has w m Mass where
    getStore = (cast :: Space Physics -> Space Mass) <$> getStore
  
  instance MonadIO m => ExplMembers m (Space Mass) where
    explMembers s = explMembers (cast s :: Space Shape)
  
  instance MonadIO m => ExplSet m (Space Mass) where
    explSet (Space _ sMap _ _ _) ety (Mass mass) = liftIO $ do
      rd <- M.lookup ety <$> readIORef sMap
      forM_ rd$ \(Record s _) -> setMass s mass
  
  instance MonadIO m => ExplGet m (Space Mass) where
    explExists s ety = liftIO $ explExists (cast s :: Space Shape) ety
    explGet (Space _ sMap _ _ _) ety = liftIO $ do
      Just (Record s _) <- M.lookup ety <$> readIORef sMap
      Mass <$> getMass s
  
  -- Density
  getDensity :: Ptr Shape -> IO Double
  getDensity shape = realToFrac <$> [C.exp| double {
    cpShapeGetDensity($(cpShape* shape)) }|]
  
  setDensity :: Ptr Shape -> Double -> IO ()
  setDensity shape (realToFrac -> density) = [C.exp| void {
    cpShapeSetDensity($(cpShape* shape), $(double density)) }|]
  
  instance Component Density where
    type Storage Density = Space Density
  instance (MonadIO m, Has w m Physics) => Has w m Density where
    getStore = (cast :: Space Physics -> Space Density) <$> getStore
  
  instance MonadIO m => ExplMembers m (Space Density) where
    explMembers s = explMembers (cast s :: Space Shape)
  
  instance MonadIO m => ExplSet m (Space Density) where
    explSet (Space _ sMap _ _ _) ety (Density density) = liftIO $ do
      rd <- M.lookup ety <$> readIORef sMap
      forM_ rd$ \(Record s _) -> setDensity s density
  
  instance MonadIO m => ExplGet m (Space Density) where
    explExists s ety = liftIO $ explExists (cast s :: Space Shape) ety
    explGet (Space _ sMap _ _ _) ety = liftIO $ do
      Just (Record s _) <- M.lookup ety <$> readIORef sMap
      Density <$> getDensity s
  
  -- Friction
  getFriction :: Ptr Shape -> IO Double
  getFriction shape = realToFrac <$> [C.exp| double {
    cpShapeGetFriction($(cpShape* shape)) }|]
  
  setFriction :: Ptr Shape -> Double -> IO ()
  setFriction shape (realToFrac -> friction) = [C.exp| void {
    cpShapeSetFriction($(cpShape* shape), $(double friction)) }|]
  
  instance Component Friction where
    type Storage Friction = Space Friction
  instance (MonadIO m, Has w m Physics) => Has w m Friction where
    getStore = (cast :: Space Physics -> Space Friction) <$> getStore
  
  instance MonadIO m => ExplMembers m (Space Friction) where
    explMembers s = explMembers (cast s :: Space Shape)
  
  instance MonadIO m => ExplSet m (Space Friction) where
    explSet (Space _ sMap _ _ _) ety (Friction friction) = liftIO $ do
      rd <- M.lookup ety <$> readIORef sMap
      forM_ rd$ \(Record s _) -> setFriction s friction
  
  instance MonadIO m => ExplGet m (Space Friction) where
    explExists s ety = liftIO $ explExists (cast s :: Space Shape) ety
    explGet (Space _ sMap _ _ _) ety = liftIO $ do
      Just (Record s _) <- M.lookup ety <$> readIORef sMap
      Friction <$> getFriction s
  
  -- SurfaceVelocity
  getSurfaceVelocity :: Ptr Shape -> IO Vec
  getSurfaceVelocity shape = do
   x <- [C.exp| double { cpShapeGetSurfaceVelocity($(cpShape* shape)).x }|]
   y <- [C.exp| double { cpShapeGetSurfaceVelocity($(cpShape* shape)).y }|]
   return (V2 (realToFrac x) (realToFrac y))
  
  setSurfaceVelocity :: Ptr Shape -> Vec -> IO ()
  setSurfaceVelocity shape (V2 (realToFrac -> x) (realToFrac -> y)) = [C.block| void {
    const cpVect vec = { $(double x), $(double y) };
    cpShapeSetSurfaceVelocity($(cpShape* shape), vec);
    }|]
  
  instance Component SurfaceVelocity where
    type Storage SurfaceVelocity = Space SurfaceVelocity
  instance (MonadIO m, Has w m Physics) => Has w m SurfaceVelocity where
    getStore = (cast :: Space Physics -> Space SurfaceVelocity) <$> getStore
  
  instance MonadIO m => ExplMembers m (Space SurfaceVelocity) where
    explMembers s = explMembers (cast s :: Space Shape)
  
  instance MonadIO m => ExplSet m (Space SurfaceVelocity) where
    explSet (Space _ sMap _ _ _) ety (SurfaceVelocity svel) = liftIO $ do
      rd <- M.lookup ety <$> readIORef sMap
      forM_ rd$ \(Record s _) -> setSurfaceVelocity s svel
  
  instance MonadIO m => ExplGet m (Space SurfaceVelocity) where
    explExists s ety = liftIO $ explExists (cast s :: Space Shape) ety
    explGet (Space _ sMap _ _ _) ety = liftIO $ do
      Just (Record s _) <- M.lookup ety <$> readIORef sMap
      SurfaceVelocity <$> getSurfaceVelocity s
  
  -- CollisionFilter
  getFilter :: Ptr Shape -> IO CollisionFilter
  getFilter shape = do
   group <- [C.exp| unsigned int { cpShapeGetFilter($(cpShape* shape)).group }|]
   cats  <- [C.exp| unsigned int { cpShapeGetFilter($(cpShape* shape)).categories }|]
   mask  <- [C.exp| unsigned int { cpShapeGetFilter($(cpShape* shape)).mask }|]
   return$ CollisionFilter group (Bitmask cats) (Bitmask mask)
  
  setFilter :: Ptr Shape -> CollisionFilter -> IO ()
  setFilter shape (CollisionFilter group (Bitmask cats) (Bitmask mask)) =
    [C.block| void {
      const cpShapeFilter filter = { $(unsigned int group)
                                   , $(unsigned int cats)
                                   , $(unsigned int mask) };
      cpShapeSetFilter($(cpShape* shape), filter);
    }|]
  
  instance Component CollisionFilter where
    type Storage CollisionFilter = Space CollisionFilter
  instance (MonadIO m, Has w m Physics) => Has w m CollisionFilter where
    getStore = (cast :: Space Physics -> Space CollisionFilter) <$> getStore
  
  instance MonadIO m => ExplMembers m (Space CollisionFilter) where
    explMembers s = explMembers (cast s :: Space Shape)
  
  instance MonadIO m => ExplSet m (Space CollisionFilter) where
    explSet (Space _ sMap _ _ _) ety cfilter = liftIO $ do
      rd <- M.lookup ety <$> readIORef sMap
      forM_ rd$ \(Record s _) -> setFilter s cfilter
  
  instance MonadIO m => ExplGet m (Space CollisionFilter) where
    explExists s ety = liftIO $ explExists (cast s :: Space Shape) ety
    explGet (Space _ sMap _ _ _) ety = liftIO $ do
      Just (Record s _) <- M.lookup ety <$> readIORef sMap
      getFilter s
  
  -- CollisionType
  getCollisionType :: Ptr Shape -> IO C.CUIntPtr
  getCollisionType shape = [C.exp| uintptr_t {
    cpShapeGetCollisionType($(cpShape* shape)) }|]
  
  setCollisionType :: Ptr Shape -> C.CUIntPtr -> IO ()
  setCollisionType shape ctype = [C.exp| void {
    cpShapeSetCollisionType($(cpShape* shape), $(uintptr_t ctype)) }|]
  
  instance Component CollisionType where
    type Storage CollisionType = Space CollisionType
  instance (MonadIO m, Has w m Physics) => Has w m CollisionType where
    getStore = (cast :: Space Physics -> Space CollisionType) <$> getStore
  
  instance MonadIO m => ExplMembers m (Space CollisionType) where
    explMembers s = explMembers (cast s :: Space Shape)
  
  instance MonadIO m => ExplSet m (Space CollisionType) where
    explSet (Space _ sMap _ _ _) ety (CollisionType ctype) = liftIO $ do
      rd <- M.lookup ety <$> readIORef sMap
      forM_ rd$ \(Record s _) -> setCollisionType s ctype
  
  instance MonadIO m => ExplGet m (Space CollisionType) where
    explExists s ety = liftIO $ explExists (cast s :: Space Shape) ety
    explGet (Space _ sMap _ _ _) ety = liftIO $ do
      Just (Record s _) <- M.lookup ety <$> readIORef sMap
      CollisionType <$> getCollisionType s
  