119 lines
2.7 KiB
Haskell
119 lines
2.7 KiB
Haskell
{-# LANGUAGE MultiParamTypeClasses #-}
|
|
{-# LANGUAGE TypeFamilies #-}
|
|
|
|
module Types where
|
|
|
|
import Affection
|
|
import NanoVG hiding (V2(..))
|
|
|
|
import Control.Concurrent.STM
|
|
import Control.Concurrent.MVar
|
|
|
|
data UserData = UserData
|
|
{ ship :: MVar Ship
|
|
, haskelloids :: MVar [Haskelloid]
|
|
, shots :: MVar [Pew]
|
|
, wonlost :: MVar (Maybe WonLost)
|
|
, state :: MVar (State)
|
|
, fade :: MVar (MenuFade)
|
|
, nano :: Context
|
|
, font :: Font
|
|
, subsystems :: Subsystems
|
|
, haskImage :: Image
|
|
, stateUUIDs :: MVar (UUIDClean)
|
|
, doNextStep :: MVar Bool
|
|
}
|
|
|
|
data Ship = Ship
|
|
{ sPos :: V2 Float
|
|
, sVel :: V2 Float
|
|
, sThrust :: Bool
|
|
, sRot :: Float
|
|
, sImg :: Image
|
|
}
|
|
|
|
data Pew = Pew
|
|
{ pPos :: V2 Float
|
|
, pVel :: V2 Float
|
|
, pTTL :: Double
|
|
} deriving (Eq)
|
|
|
|
data Haskelloid = Haskelloid
|
|
{ hPos :: V2 Float
|
|
, hVel :: V2 Float
|
|
, hRot :: Float
|
|
, hPitch :: Float
|
|
, hDiv :: Int
|
|
, hImg :: Image
|
|
} deriving (Eq)
|
|
|
|
data State
|
|
= Menu
|
|
-- | HighScore
|
|
| InGame
|
|
|
|
data MenuFade
|
|
= FadeIn Double
|
|
| FadeOut Double
|
|
|
|
data WonLost
|
|
= Won
|
|
| Lost
|
|
deriving (Eq)
|
|
|
|
data Subsystems = Subsystems
|
|
{ subWindow :: SubWindow
|
|
, subKeyboard :: SubKeyboard
|
|
}
|
|
|
|
data UUIDClean = UUIDClean
|
|
{ uuWindow :: [UUID]
|
|
, uuKeyboard :: [UUID]
|
|
}
|
|
|
|
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
|
|
|
|
instance Participant SubWindow where
|
|
type Mesg SubWindow = WindowMessage
|
|
|
|
partSubscribers (SubWindow t) = do
|
|
subTups <- liftIO $ readTVarIO t
|
|
return $ map snd subTups
|
|
|
|
partSubscribe (SubWindow t) funct = do
|
|
uuid <- genUUID
|
|
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
|
|
return uuid
|
|
|
|
partUnSubscribe (SubWindow t) uuid =
|
|
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
|
|
where
|
|
filterMsg :: (UUID, WindowMessage -> Affection ()) -> UUID -> Bool
|
|
filterMsg (u, _) p = u /= p
|
|
|
|
instance SDLSubsystem SubWindow where
|
|
consumeSDLEvents = consumeSDLWindowEvents
|
|
|
|
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
|
|
|
|
instance Participant SubKeyboard where
|
|
type Mesg SubKeyboard = KeyboardMessage
|
|
|
|
partSubscribers (SubKeyboard t) = do
|
|
subTups <- liftIO $ readTVarIO t
|
|
return $ map snd subTups
|
|
|
|
partSubscribe (SubKeyboard t) funct = do
|
|
uuid <- genUUID
|
|
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
|
|
return uuid
|
|
|
|
partUnSubscribe (SubKeyboard t) uuid =
|
|
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
|
|
where
|
|
filterMsg :: (UUID, KeyboardMessage -> Affection ()) -> UUID -> Bool
|
|
filterMsg (u, _) p = u /= p
|
|
|
|
instance SDLSubsystem SubKeyboard where
|
|
consumeSDLEvents = consumeSDLKeyboardEvents
|