haskelloids/src/Types.hs
2017-12-21 14:43:13 +01:00

115 lines
2.7 KiB
Haskell

{-# LANGUAGE MultiParamTypeClasses #-}
module Types where
import Affection
import qualified SDL
import NanoVG hiding (V2(..))
import Linear
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
data UserData = UserData
{ ship :: Ship
, haskelloids :: [Haskelloid]
, shots :: [Pew]
-- , debris :: ParticleSystem
, wonlost :: Maybe WonLost
, pixelSize :: Int
, state :: State
, fade :: MenuFade
, nano :: Context
, font :: Font
, subsystems :: Subsystems
, haskImage :: Image
, stateUUIDs :: UUIDClean
}
data Ship = Ship
{ sPos :: V2 Float
, sVel :: V2 Float
, 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 :: Window
, subKeyboard :: Keyboard
}
data UUIDClean = UUIDClean
{ uuWindow :: [MsgId WindowMessage]
, uuKeyboard :: [MsgId KeyboardMessage]
}
newtype Window = Window (TVar [(UUID, WindowMessage -> Affection UserData ())])
instance Participant Window WindowMessage UserData where
partSubscribers (Window t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Window t) funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return $ MsgId uuid MsgWindowEmptyEvent
partUnSubscribe (Window t) (MsgId uuid _) =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p
instance SDLSubsystem Window UserData where
consumeSDLEvents = consumeSDLWindowEvents
newtype Keyboard = Keyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
instance Participant Keyboard KeyboardMessage UserData where
partSubscribers (Keyboard t) = do
subTups <- liftIO $ readTVarIO t
return $ map snd subTups
partSubscribe (Keyboard t) funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return $ MsgId uuid MsgKeyboardEmptyEvent
partUnSubscribe (Keyboard t) (MsgId uuid _) =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p
instance SDLSubsystem Keyboard UserData where
consumeSDLEvents = consumeSDLKeyboardEvents