141 lines
3.7 KiB
Haskell
141 lines
3.7 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.Matrix
|
|
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
|
|
|
|
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 IO
|
|
, stateData :: StateData
|
|
, stateMVar :: MVar (SystemState Entity IO, StateData)
|
|
, stateProgress :: MVar Float
|
|
, threadContext :: Maybe SDL.GLContext
|
|
, mainContext :: Maybe SDL.GLContext
|
|
, window :: Maybe SDL.Window
|
|
}
|
|
|
|
data State
|
|
= Load
|
|
| Menu
|
|
| Test
|
|
|
|
data Entity f = Entity
|
|
{ pos :: Component f 'Field (V2 Double)
|
|
, gridPos :: Component f 'Field (V2 Int)
|
|
, vel :: Component f 'Field (V2 Double)
|
|
, velFact :: Component f 'Field Double
|
|
, rot :: Component f 'Field Direction
|
|
, obstacle :: Component f 'Field (Boundaries Double)
|
|
, player :: Component f 'Unique ()
|
|
, npcMoveState :: Component f 'Field NPCMoveState
|
|
, anim :: Component f 'Field AnimState
|
|
}
|
|
deriving (Generic)
|
|
|
|
data NPCMoveState
|
|
= NPCWalking
|
|
{ npcWalkPath :: [V2 Int]
|
|
}
|
|
| NPCStanding
|
|
{ npcStandTime :: Double
|
|
, npcFuturePath :: MVar [V2 Int]
|
|
}
|
|
|
|
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
|