Some extensions to Apecs, working around the TH tuple instances and more lenient return types for systems using Variant/HList

ApecsReturnVariant.hs

{-# LANGUAGE DataKinds             #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell       #-}
{-# LANGUAGE UndecidableInstances  #-}
module ApecsReturnVariant where

import           Data.Kind                 (Constraint, Type)

import qualified Control.Monad.Reader      as R

import           Apecs
import qualified Apecs                     as A
import qualified Apecs.Core                as A.C

type family All (c :: Type -> Constraint) (xs :: [Type]) :: Constraint where
  All _ '[]       = ()
  All c (x ': xs) = (c x, All c xs)

type family MapElem (xs :: [Type]) :: [Type] where
  MapElem '[]       = '[]
  MapElem (x ': xs) = A.C.Elem x : MapElem xs

type family MapStorage (xs :: [Type]) :: [Type] where
  MapStorage '[]       = '[]
  MapStorage (x ': xs) = A.C.Storage x : MapStorage xs

-- Variant
data Variant (xs :: [Type]) where
  Here  :: x        -> Variant (x ': xs)
  There :: Variant xs -> Variant (y ': xs)

instance ( MapElem (MapStorage xs) ~ xs
         , All A.Component xs
         ) => A.Component (Variant xs) where
  type Storage (Variant xs) = VariantStore (MapStorage xs)

instance Monad m => A.C.Has w m (Variant '[]) where
  getStore = SystemT $ R.ReaderT $ \_ -> pure (VariantStore HNil)

instance ( Monad m
         , xss ~ (x ': xs)
         , MapElem (MapStorage xss) ~ xss
         , All A.Component xss
         , A.C.Has w m x
         , A.C.Has w m (Variant xs)
         ) => A.C.Has w m (Variant (x ': xs)) where
  getStore
    = fmap VariantStore
    $ HCons <$> getStore <*> fmap _getVariantStoreHList getStore

newtype VariantStore xs
  = VariantStore { _getVariantStoreHList :: HList xs }

type instance A.C.Elem (VariantStore xs) = Variant (MapElem xs)

instance ( Monad m
         ) => A.C.ExplSet m (VariantStore '[]) where
  explSet _ _ _ = pure ()

instance ( Monad m
         , A.C.ExplSet m x
         , A.C.ExplSet m (VariantStore xs)
         ) => A.C.ExplSet m (VariantStore (x ': xs)) where
  explSet (VariantStore (HCons c _ )) ety (Here x)   = A.C.explSet c ety x
  explSet (VariantStore (HCons _ cs)) ety (There xs) = A.C.explSet (VariantStore cs) ety xs

-- HList
data HList (xs :: [Type]) where
  HNil  :: HList '[]
  HCons :: x -> HList xs -> HList (x ': xs)

instance ( MapElem (MapStorage xs) ~ xs
         , All A.Component xs
         ) => A.Component (HList xs) where
  type Storage (HList xs) = HListStore (MapStorage xs)

instance Monad m => A.C.Has w m (HList '[]) where
  getStore = SystemT $ R.ReaderT $ \_ -> pure (HListStore HNil)

instance ( Monad m
         , xss ~ (x ': xs)
         , MapElem (MapStorage xss) ~ xss
         , All A.Component xss
         , A.C.Has w m x
         , A.C.Has w m (HList xs)
         ) => A.C.Has w m (HList (x ': xs)) where
  getStore
    = fmap HListStore
    $ HCons <$> getStore <*> fmap _getHListStoreHList getStore

newtype HListStore xs
  = HListStore { _getHListStoreHList :: HList xs }

type instance A.C.Elem (HListStore xs) = HList (MapElem xs)

instance ( Monad m
         ) => A.C.ExplSet m (HListStore '[]) where
  explSet _ _ _ = pure ()

instance ( Monad m
         , A.C.ExplSet m x
         , A.C.ExplSet m (HListStore xs)
         ) => A.C.ExplSet m (HListStore (x ': xs)) where
  explSet (HListStore (HCons c cs)) ety (HCons x xs)
    = A.C.explSet c ety x >> A.C.explSet (HListStore cs) ety xs

-- testin
data TransformComponent
  = TransformComponent Position
  deriving Show

instance A.Component TransformComponent where
  type Storage TransformComponent = A.Map TransformComponent

data GridComponent
  = StrictGridComponent
  | SmoothGridComponent Position
  deriving Show

instance A.Component GridComponent where
  type Storage GridComponent = A.Map GridComponent

data Position
  = Position
      { _pX :: Int
      , _pY :: Int
      }
  deriving (Eq, Show)

A.makeWorld "World" [''TransformComponent, ''GridComponent]

fooSystem
  :: (TransformComponent, GridComponent)
  -> SystemT World IO (Variant '[TransformComponent, GridComponent])
fooSystem (t@(TransformComponent (Position x y)), g) = do
  liftIO $ print t
  liftIO $ print g
  if x > y
    then pure $ Here (TransformComponent (Position y x))
    else pure $ There (Here StrictGridComponent)
    
barSystem
  :: (TransformComponent, GridComponent)
  -> SystemT World IO (HList '[TransformComponent, Maybe GridComponent])
barSystem (t@(TransformComponent p@(Position x y) d), g) = do
  liftIO $ print t
  liftIO $ print g
  let gc = case g of
        StrictGridComponent   -> Just $ SmoothGridComponent p
        SmoothGridComponent _ -> Nothing
  pure
    $ HCons (TransformComponent (Position (x + 1) (y + 1)) d)
    $ HCons gc
    $ HNil


main :: IO ()
main = initWorld >>= runSystem test

test :: System World ()
test = do
  let p = Position 3 2
  _ <- newEntity (TransformComponent p, SmoothGridComponent p)
  cmapM fooSystem
  cmapM fooSystem
  cmapM fooSystem
  cmapM barSystem

ApecsTupleWorkaround.hs

{-# LANGUAGE TypeFamilyDependencies #-}
{-# LANGUAGE FlexibleContexts      #-}
{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE InstanceSigs          #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables   #-}
{-# LANGUAGE TypeApplications      #-}
{-# LANGUAGE TypeFamilies          #-}
{-# LANGUAGE UndecidableInstances  #-}
module ApecsTupleWorkaround where

import Data.Kind (Type)

import qualified Control.Monad.Reader as R
import qualified Data.IntMap.Strict   as IM

data Position
  = Position Int Int
  deriving Show

data Velocity
  = Velocity Int Int
  deriving Show

data World
  = World
      { _wPosition :: IM.IntMap Position
      , _wVelocity :: IM.IntMap Velocity
      }
  deriving Show

class HasComponentMap w c where
  getComponentMap :: w -> IM.IntMap c

instance HasComponentMap World Position where
  getComponentMap = _wPosition

instance HasComponentMap World Velocity where
  getComponentMap = _wVelocity

-- dummy stuff yo
data Instruction
  = Change
  | Delete
  | Inc
  deriving Show

--

type family Sig (f :: Type) = (res :: Type) | res -> f where
  Sig (x -> ys) = x -> Sig ys
  Sig [Instruction] = [Instruction]

class Run w c where
  run :: Int -> w -> Sig c -> w

instance (HasComponentMap w x, Run w ys) => Run w (x -> ys) where
  run :: Int -> w -> (x -> Sig ys) -> w
  run i w f
    = let m = getComponentMap w
          mc = m IM.!? i
      in case mc of
           Just c -> run i w (f c)
           Nothing -> w

-- dummy stuff yo
instance Run w [Instruction] where
  run :: Int -> w -> [Instruction] -> w
  run _ w _ = w

testWorld :: World
testWorld
  = World pm vm
  where
    pm
      = IM.fromList
          [ (1, Position 1 1)
          , (2, Position 2 2)
          ]
    vm
      = IM.fromList
          [ (1, Velocity 1 1)
          , (2, Velocity 2 2)
          ]

testRun :: IO ()
testRun
  = do
      let r :: (Position -> Velocity -> [Instruction])
          r (Position px py) (Velocity vx vy)
            = if px > vx
              then [Delete]
              else [Inc]
          res = run 1 testWorld r
      print res