109 lines
2.4 KiB
Haskell
109 lines
2.4 KiB
Haskell
|
{-# 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.Ecstasy
|
||
|
|
|
||
|
|
import Linear
|
||
|
|
|
||
|
|
data UserData = UserData
|
||
|
|
{ state :: State
|
||
|
|
, subsystems :: Subsystems
|
||
|
|
, assetImages :: M.Map ImgId Image
|
||
|
|
, nano :: Context
|
||
|
|
, uuid :: [UUID]
|
||
|
|
, world :: Entity 'WorldOf
|
||
|
|
}
|
||
|
|
|
||
|
|
data State
|
||
|
|
= Menu
|
||
|
|
| Test
|
||
|
|
|
||
|
|
data ImgId
|
||
|
|
= ImgFloor
|
||
|
|
|
||
|
|
data Direction
|
||
|
|
= N
|
||
|
|
| W
|
||
|
|
| S
|
||
|
|
| E
|
||
|
|
| NW
|
||
|
|
| SW
|
||
|
|
| NE
|
||
|
|
| SE
|
||
|
|
|
||
|
|
data Entity f = Entity
|
||
|
|
{ pos :: Component f 'Field (V2 Float)
|
||
|
|
, vel :: Component f 'Field (V2 Float)
|
||
|
|
, rot :: Component f 'Field Direction
|
||
|
|
}
|
||
|
|
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
|