Skip to content

Instantly share code, notes, and snippets.

@alexpeits
Last active June 2, 2019 16:25
Show Gist options
  • Save alexpeits/e7b805927c0e7d6644b98de0b48421c6 to your computer and use it in GitHub Desktop.
Save alexpeits/e7b805927c0e7d6644b98de0b48421c6 to your computer and use it in GitHub Desktop.
Some extensions to Apecs, working around the TH tuple instances and more lenient return types for systems using Variant/HList
{-# 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
{-# 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
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment