{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module Apecs.Core where
import Control.Monad.Reader
import Data.Functor.Identity
import qualified Data.Vector.Unboxed as U
import qualified Apecs.THTuples as T
newtype Entity = Entity {unEntity :: Int} deriving (Num, Eq, Ord, Show)
newtype System w a = System {unSystem :: ReaderT w IO a} deriving (Functor, Monad, Applicative, MonadIO)
class (Elem (Storage c) ~ c) => Component c where
type Storage c
class Component c => Has w c where
getStore :: System w (Storage c)
type family Elem s
class ExplInit s where
explInit :: IO s
class ExplGet s where
explGet :: s -> Int -> IO (Elem s)
explExists :: s -> Int -> IO Bool
class ExplSet s where
explSet :: s -> Int -> Elem s -> IO ()
class ExplDestroy s where
explDestroy :: s -> Int -> IO ()
class ExplMembers s where
explMembers :: s -> IO (U.Vector Int)
type Get w c = (Has w c, ExplGet (Storage c))
type Set w c = (Has w c, ExplSet (Storage c))
type Members w c = (Has w c, ExplMembers (Storage c))
type Destroy w c = (Has w c, ExplDestroy (Storage c))
instance Component c => Component (Identity c) where
type Storage (Identity c) = Identity (Storage c)
instance Has w c => Has w (Identity c) where
getStore = Identity <$> getStore
type instance Elem (Identity s) = Identity (Elem s)
instance ExplGet s => ExplGet (Identity s) where
explGet (Identity s) e = Identity <$> explGet s e
explExists (Identity s) = explExists s
instance ExplSet s => ExplSet (Identity s) where
explSet (Identity s) e (Identity x) = explSet s e x
instance ExplMembers s => ExplMembers (Identity s) where
explMembers (Identity s) = explMembers s
instance ExplDestroy s => ExplDestroy (Identity s) where
explDestroy (Identity s) = explDestroy s
T.makeInstances [2..8]
data Not a = Not
newtype NotStore s = NotStore s
instance Component c => Component (Not c) where
type Storage (Not c) = NotStore (Storage c)
instance (Has w c) => Has w (Not c) where
getStore = NotStore <$> getStore
type instance Elem (NotStore s) = Not (Elem s)
instance ExplGet s => ExplGet (NotStore s) where
explGet _ _ = return Not
explExists (NotStore sa) ety = not <$> explExists sa ety
instance ExplDestroy s => ExplSet (NotStore s) where
explSet (NotStore sa) ety _ = explDestroy sa ety
newtype MaybeStore s = MaybeStore s
instance Component c => Component (Maybe c) where
type Storage (Maybe c) = MaybeStore (Storage c)
instance (Has w c) => Has w (Maybe c) where
getStore = MaybeStore <$> getStore
type instance Elem (MaybeStore s) = Maybe (Elem s)
instance ExplGet s => ExplGet (MaybeStore s) where
explGet (MaybeStore sa) ety = do
e <- explExists sa ety
if e then Just <$> explGet sa ety
else return Nothing
explExists _ _ = return True
instance (ExplDestroy s, ExplSet s) => ExplSet (MaybeStore s) where
explSet (MaybeStore sa) ety Nothing = explDestroy sa ety
explSet (MaybeStore sa) ety (Just x) = explSet sa ety x
data EitherStore sa sb = EitherStore sa sb
instance (Component ca, Component cb) => Component (Either ca cb) where
type Storage (Either ca cb) = EitherStore (Storage ca) (Storage cb)
instance (Has w ca, Has w cb) => Has w (Either ca cb) where
getStore = EitherStore <$> getStore <*> getStore
type instance Elem (EitherStore sa sb) = Either (Elem sa) (Elem sb)
instance (ExplGet sa, ExplGet sb) => ExplGet (EitherStore sa sb) where
explGet (EitherStore sa sb) ety = do
e <- explExists sb ety
if e then Right <$> explGet sb ety
else Left <$> explGet sa ety
explExists (EitherStore sa sb) ety = do
e <- explExists sb ety
if e then return True
else explExists sa ety
instance (ExplSet sa, ExplSet sb) => ExplSet (EitherStore sa sb) where
explSet (EitherStore _ sb) ety (Right b) = explSet sb ety b
explSet (EitherStore sa _) ety (Left a) = explSet sa ety a
instance Has w () where
getStore = return ()
instance Component () where
type Storage () = ()
type instance Elem () = ()
instance ExplGet () where
explExists _ _ = return True
explGet _ _ = return ()
instance ExplSet () where
explSet _ _ _ = return ()
instance ExplDestroy () where
explDestroy _ _ = return ()
data Filter c = Filter deriving (Eq, Show)
newtype FilterStore s = FilterStore s
instance Component c => Component (Filter c) where
type Storage (Filter c) = FilterStore (Storage c)
instance Has w c => Has w (Filter c) where
getStore = FilterStore <$> getStore
type instance Elem (FilterStore s) = Filter (Elem s)
instance ExplGet s => ExplGet (FilterStore s) where
explGet _ _ = return Filter
explExists (FilterStore s) ety = explExists s ety
instance ExplMembers s => ExplMembers (FilterStore s) where
explMembers (FilterStore s) = explMembers s
data EntityStore = EntityStore
instance Component Entity where
type Storage Entity = EntityStore
instance (Has w Entity) where
getStore = return EntityStore
type instance Elem EntityStore = Entity
instance ExplGet EntityStore where
explGet _ ety = return $ Entity ety
explExists _ _ = return True