124 lines
3.2 KiB
Haskell
124 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.StateData
|
|
import Types.ImgId
|
|
import Types.FontId
|
|
import Types.Animation
|
|
import Types.Entity
|
|
|
|
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
|
|
deriving (Eq)
|
|
|
|
data SubMain
|
|
= WorldMap
|
|
| MindMap
|
|
deriving (Eq)
|
|
|
|
data Subsystems = Subsystems
|
|
{ subWindow :: Types.UserData.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 Types.UserData.Window UserData where
|
|
type Mesg Types.UserData.Window UserData = WindowMessage
|
|
|
|
partSubscribers (Window t) = generalSubscribers t
|
|
|
|
partSubscribe (Window t) = generalSubscribe t
|
|
|
|
partUnSubscribe (Window t) = generalUnSubscribe t
|
|
|
|
instance SDLSubsystem Types.UserData.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
|