haskelloids/src/Types.hs

116 lines
2.7 KiB
Haskell
Raw Normal View History

2017-01-02 15:22:23 +00:00
{-# LANGUAGE MultiParamTypeClasses #-}
2016-12-31 16:01:24 +00:00
module Types where
2017-12-16 10:55:30 +00:00
import Affection
2016-12-31 16:01:24 +00:00
import qualified SDL
2017-12-16 18:06:36 +00:00
import NanoVG hiding (V2(..))
import Linear
2016-12-31 16:01:24 +00:00
2017-12-19 05:49:41 +00:00
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
2016-12-31 16:01:24 +00:00
data UserData = UserData
2017-12-16 10:55:30 +00:00
{ ship :: Ship
2016-12-31 16:01:24 +00:00
, haskelloids :: [Haskelloid]
2017-12-20 23:56:16 +00:00
, shots :: [Pew]
2016-12-31 16:01:24 +00:00
-- , debris :: ParticleSystem
2017-12-16 10:55:30 +00:00
, wonlost :: Maybe WonLost
2016-12-31 16:01:24 +00:00
, pixelSize :: Int
2017-01-02 15:22:23 +00:00
, state :: State
2017-01-01 21:58:54 +00:00
, fade :: MenuFade
2017-12-16 18:06:36 +00:00
, nano :: Context
2017-12-19 16:30:44 +00:00
, font :: Font
2017-12-19 05:49:41 +00:00
, subsystems :: Subsystems
2017-12-19 20:53:07 +00:00
, haskImage :: Image
2017-12-20 01:00:28 +00:00
, stateUUIDs :: UUIDClean
2016-12-31 16:01:24 +00:00
}
data Ship = Ship
2017-12-19 07:18:57 +00:00
{ sPos :: V2 Float
, sVel :: V2 Float
, sRot :: Float
2017-12-16 10:55:30 +00:00
, sImg :: Image
2016-12-31 16:01:24 +00:00
}
2017-12-20 23:56:16 +00:00
data Pew = Pew
{ pPos :: V2 Float
, pVel :: V2 Float
, pTTL :: Double
2017-12-21 04:21:20 +00:00
} deriving (Eq)
2017-12-20 23:56:16 +00:00
2016-12-31 16:01:24 +00:00
data Haskelloid = Haskelloid
2017-12-19 07:18:57 +00:00
{ hPos :: V2 Float
, hVel :: V2 Float
, hRot :: Float
, hPitch :: Float
2016-12-31 16:01:24 +00:00
, hDiv :: Int
2017-12-16 10:55:30 +00:00
, hImg :: Image
2016-12-31 16:01:24 +00:00
} deriving (Eq)
2017-01-02 15:22:23 +00:00
data State
2016-12-31 16:01:24 +00:00
= Menu
2017-12-20 23:56:16 +00:00
-- | HighScore
2016-12-31 16:01:24 +00:00
| InGame
2017-01-01 21:58:54 +00:00
data MenuFade
= FadeIn Double
| FadeOut Double
2017-12-16 10:55:30 +00:00
data WonLost
= Won
| Lost
deriving (Eq)
2017-12-19 05:49:41 +00:00
data Subsystems = Subsystems
{ subWindow :: Window
, subKeyboard :: Keyboard
}
2017-12-20 01:00:28 +00:00
data UUIDClean = UUIDClean
{ uuWindow :: [MsgId WindowMessage]
, uuKeyboard :: [MsgId KeyboardMessage]
}
2017-12-19 05:49:41 +00:00
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
2017-12-20 01:00:28 +00:00
partSubscribe (Window t) funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return $ MsgId uuid MsgWindowEmptyEvent
2017-12-19 05:49:41 +00:00
2017-12-20 01:00:28 +00:00
partUnSubscribe (Window t) (MsgId uuid _) =
liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid))
where
filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p
2017-12-19 05:49:41 +00:00
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
2017-12-20 01:00:28 +00:00
partSubscribe (Keyboard t) funct = do
uuid <- genUUID
liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
return $ MsgId uuid MsgKeyboardEmptyEvent
2017-12-19 05:49:41 +00:00
2017-12-20 01:00:28 +00:00
partUnSubscribe (Keyboard t) (MsgId uuid _) =
liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid))
where
filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p
2017-12-19 05:49:41 +00:00
instance SDLSubsystem Keyboard UserData where
consumeSDLEvents = consumeSDLKeyboardEvents