tracer/src/Types/UserData.hs

121 lines
2.6 KiB
Haskell
Raw Normal View History

2018-02-07 00:18:16 +00:00
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Types.UserData where
import Affection
import qualified SDL
import Control.Concurrent.STM
import NanoVG hiding (V2(..), V3(..))
import qualified Data.Map.Strict as M
import Data.Text (Text(..))
import Data.Matrix
2018-02-07 00:18:16 +00:00
import Data.Ecstasy
import Linear
import Types.Map
2018-02-07 00:18:16 +00:00
data UserData = UserData
{ state :: State
, subsystems :: Subsystems
, assetImages :: M.Map ImgId Image
, nano :: Context
, uuid :: [UUID]
, world :: Entity 'WorldOf
, stateData :: StateData
2018-02-07 00:18:16 +00:00
}
data State
= Menu
| Test
data StateData
= None
| MenuData
{ mapMat :: Matrix TileState
, initCoords :: (Int, Int)
}
2018-02-07 00:18:16 +00:00
data ImgId
= ImgFloor
data Direction
= N
| W
| S
| E
| NW
| SW
| NE
| SE
data Entity f = Entity
2018-02-13 23:54:40 +00:00
{ pos :: Component f 'Field (V2 Float)
, vel :: Component f 'Field (V2 Float)
, rot :: Component f 'Field Direction
, player :: Component f 'Unique Bool
2018-02-07 00:18:16 +00:00
}
deriving (Generic)
data Subsystems = Subsystems
{ subWindow :: Window
, subMouse :: Mouse
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection UserData ())])
instance Participant Window UserData where
type Mesg Window UserData = WindowMessage
partSubscribers (Window t) = generalSubscribers t
partSubscribe (Window t) = generalSubscribe t
partUnSubscribe (Window t) = generalUnSubscribe t
instance SDLSubsystem Window UserData where
consumeSDLEvents = consumeSDLWindowEvents
instance Participant Mouse UserData where
type Mesg Mouse UserData = MouseMessage
partSubscribers (Mouse t) = generalSubscribers t
partSubscribe (Mouse t) = generalSubscribe t
partUnSubscribe (Mouse t) = generalUnSubscribe t
instance SDLSubsystem Mouse UserData where
consumeSDLEvents = consumeSDLMouseEvents
generalSubscribers
:: TVar [(UUID, msg -> Affection UserData ())]
-> Affection UserData [(msg -> Affection UserData ())]
generalSubscribers t = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
generalSubscribe
:: TVar [(UUID, msg -> Affection UserData ())]
-> (msg -> Affection UserData ())
-> Affection UserData UUID
generalSubscribe t funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return uuid
generalUnSubscribe
:: TVar [(UUID, msg -> Affection UserData ())]
-> UUID
-> Affection UserData ()
generalUnSubscribe t uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg (u, _) p = u /= p