tracer/src/Types/UserData.hs
2018-08-10 11:34:46 +02:00

126 lines
3.2 KiB
Haskell

{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Types.UserData where
import Affection
import Control.Concurrent.STM
import qualified SDL
import NanoVG hiding (V2(..), V3(..))
import qualified Data.Map.Strict as M
import qualified Data.Text as T
import Data.Ecstasy
import Control.Concurrent.MVar
import Types.Map
import Types.StateData
import Types.ImgId
import Types.FontId
import Types.Direction
import Types.Animation
import Types.ObjType
import Types.Entity
import Types.NPCState
data UserData = UserData
{ state :: State
, subsystems :: Subsystems
, assetImages :: M.Map ImgId Image
, assetFonts :: M.Map FontId T.Text
, assetAnimations :: M.Map AnimId Animation
, nano :: Context
, uuid :: [UUID]
, worldState :: SystemState Entity (AffectionState (AffectionData UserData) IO)
, stateData :: StateData
, stateMVar :: MVar
( SystemState Entity (AffectionState (AffectionData UserData) IO)
, StateData
)
, stateProgress :: MVar (Float, T.Text)
, threadContext :: Maybe SDL.GLContext
, window :: Maybe SDL.Window
}
data State
= Load
| Main SubMain
data SubMain
= WorldMap
| MindMap
data Subsystems = Subsystems
{ subWindow :: Window
, subMouse :: Mouse
, subkeyboard :: Keyboard
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData())])
newtype Mouse = Mouse (TVar [(UUID, MouseMessage -> Affection UserData ())])
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> 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
instance Participant Keyboard UserData where
type Mesg Keyboard UserData = KeyboardMessage
partSubscribers (Keyboard t) = generalSubscribers t
partSubscribe (Keyboard t) = generalSubscribe t
partUnSubscribe (Keyboard t) = generalUnSubscribe t
instance SDLSubsystem Keyboard UserData where
consumeSDLEvents = consumeSDLKeyboardEvents
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
uu <- genUUID
liftIO $ atomically $ modifyTVar' t ((uu, funct) :)
return uu
generalUnSubscribe
:: TVar [(UUID, msg -> Affection UserData ())]
-> UUID
-> Affection UserData ()
generalUnSubscribe t uu =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uu))
where
filterMsg (u, _) p = u /= p