Updated game to use affection 0.0.0.10

This commit is contained in:
nek0 2020-05-04 21:17:06 +02:00
parent 13b6da1e44
commit de77724135
8 changed files with 262 additions and 279 deletions

1
.gitignore vendored
View File

@ -1,6 +1,7 @@
.cabal-sandbox/
cabal.sandbox.config
dist/
dist-newstyle/
*.prof
*.aux
*.hp

View File

@ -2,8 +2,6 @@ module Commons where
import Affection
import Control.Monad.IO.Class (liftIO)
import System.Random (randomRIO)
import NanoVG as N hiding (V2(..))
@ -30,10 +28,9 @@ wrapAround (V2 nx ny) w = V2 nnx nny
| otherwise = ny
half = w / 2
newHaskelloids :: Affection UserData [Haskelloid]
newHaskelloids =
newHaskelloids :: Image -> Affection [Haskelloid]
newHaskelloids img =
do
img <- haskImage <$> getAffection
liftIO $ mapM (\_ -> do
d <- randomRIO (1, 2)
(posx, posy) <- getCoordinates d
@ -113,9 +110,8 @@ drawSpinner ctx x y cr ct = do
fill ctx
restore ctx
drawHaskelloid :: Haskelloid -> Affection UserData ()
drawHaskelloid (Haskelloid pos _ rot _ d img) = do
ctx <- nano <$> getAffection
drawHaskelloid :: Context -> Haskelloid -> Affection ()
drawHaskelloid ctx (Haskelloid pos _ rot _ d img) = do
liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 1
where
dim = fmap (/ fromIntegral d) (V2 100 100)

View File

@ -7,8 +7,8 @@ import qualified SDL
import qualified Data.Set as S
import Data.Maybe (isNothing, catMaybes)
import Control.Monad (when, unless)
import Control.Monad.IO.Class (liftIO)
import Control.Monad
import Control.Concurrent.MVar
import System.Random (randomRIO)
@ -31,103 +31,94 @@ pewTTL :: Double
pewTTL = 10
dRot :: Float
dRot = 150
dRot = 5
loadGame
:: Affection UserData ()
-> Affection UserData ()
-> Affection UserData ()
loadGame stateChange clean = do
:: Affection ()
-> Affection ()
-> UserData
-> Affection ()
loadGame stateChange clean ud = do
liftIO $ logIO A.Debug "loading game"
ud <- getAffection
nhs <- newHaskelloids
nhs <- newHaskelloids (haskImage ud)
kid <- partSubscribe
(subKeyboard $ subsystems ud)
(handleGameKeys stateChange clean)
putAffection ud
{ stateUUIDs = UUIDClean [] [kid]
, haskelloids = nhs
, ship = (ship ud)
{ sPos = V2 400 300
, sVel = V2 0 0
, sRot = 0
, sThrust = False
}
, shots = []
, state = InGame
, wonlost = Nothing
}
(handleGameKeys stateChange clean ud)
oldship <- liftIO $ readMVar (ship ud)
void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [kid])
void $ liftIO $ swapMVar (haskelloids ud) (nhs)
void $ liftIO $ swapMVar (ship ud) (oldship
{ sPos = V2 400 300
, sVel = V2 0 0
, sRot = 0
, sThrust = False
})
void $ liftIO $ swapMVar (shots ud) []
void $ liftIO $ swapMVar (wonlost ud) Nothing
void $ liftIO $ swapMVar (state ud) InGame
handleGameKeys
:: Affection UserData ()
-> Affection UserData ()
:: Affection ()
-> Affection ()
-> UserData
-> KeyboardMessage
-> Affection UserData ()
handleGameKeys stateChange clean kbdev =
-> Affection ()
handleGameKeys stateChange clean ud kbdev =
if (msgKbdKeyMotion kbdev == SDL.Pressed)
then case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeSpace -> unless (msgKbdKeyRepeat kbdev) $ do
shoot
shoot ud
SDL.KeycodeR -> unless (msgKbdKeyRepeat kbdev) $ do
ud <- getAffection
unless (isNothing $ wonlost ud) $ do
wlcond <- liftIO $ readMVar (wonlost ud)
unless (isNothing $ wlcond) $ do
liftIO $ logIO A.Debug "Reloading"
clean
SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "Leave to Menu"
stateChange
SDL.KeycodeW -> accelShip dVel
SDL.KeycodeA -> rotateShip dRot
SDL.KeycodeD -> rotateShip (-dRot)
SDL.KeycodeW -> accelShip ud dVel
SDL.KeycodeA -> rotateShip ud dRot
SDL.KeycodeD -> rotateShip ud (-dRot)
_ -> return ()
else case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeW -> deThrust
SDL.KeycodeA -> deThrust
SDL.KeycodeD -> deThrust
SDL.KeycodeW -> deThrust ud
SDL.KeycodeA -> deThrust ud
SDL.KeycodeD -> deThrust ud
_ -> return ()
shoot :: Affection UserData ()
shoot = do
ud <- getAffection
let Ship{..} = ship ud
npew = Pew ppos pVel pewTTL
shoot :: UserData -> Affection ()
shoot ud = do
Ship{..} <- liftIO $ readMVar (ship ud)
let npew = Pew ppos pVel pewTTL
ppos = sPos + (V2 0 25 `rotVec` sRot)
pVel = sVel + (V2 0 pewVel `rotVec` sRot)
putAffection ud
{ shots = npew : shots ud
}
oldshots <- liftIO $ readMVar (shots ud)
void $ liftIO $ swapMVar (shots ud) (npew : oldshots)
accelShip :: Float -> Affection UserData ()
accelShip vel = do
ud <- getAffection
accelShip :: UserData -> Float -> Affection ()
accelShip ud vel = do
dt <- getDelta
let s = ship ud
nVel = sVel s + fmap (realToFrac dt *) (V2 0 vel `rotVec` sRot s)
putAffection ud
{ ship = s
{ sVel = nVel
, sThrust = True
}
}
s <- liftIO $ readMVar (ship ud)
let nVel = sVel s + fmap (realToFrac dt *) (V2 0 vel `rotVec` sRot s)
void $ liftIO $ swapMVar (ship ud) (s
{ sVel = nVel
, sThrust = True
})
deThrust :: Affection UserData ()
deThrust = do
ud <- getAffection
putAffection ud
{ ship = (ship ud)
{ sThrust = False
}
}
deThrust :: UserData -> Affection ()
deThrust ud = do
s <- liftIO $ readMVar (ship ud)
void $ liftIO $ swapMVar (ship ud) (s
{ sThrust = False
})
rotateShip :: Float -> Affection UserData ()
rotateShip deg = do
ud <- getAffection
dt <- getDelta
putAffection ud
{ ship = (ship ud)
{ sRot = sRot (ship ud) - deg * realToFrac dt
}
}
rotateShip :: UserData -> Float -> Affection ()
rotateShip ud deg = do
-- dt <- getDelta
s <- liftIO $ readMVar (ship ud)
void $ liftIO $ swapMVar (ship ud) (s
{ sRot = sRot s - deg -- * realToFrac dt
})
rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a
rotVec (V2 x y) deg = V2 nx ny
@ -136,71 +127,64 @@ rotVec (V2 x y) deg = V2 nx ny
ny = x * sin (dtor deg) - y * cos (dtor deg)
dtor = (pi / 180 *)
updateGame :: Double -> Affection UserData ()
updateGame sec = do
ud <- getAffection
let nhs = map (updateHaskelloid sec) (haskelloids ud)
npews = filter (\p -> pTTL p > 0) $ map (updatePew sec) (shots ud)
putAffection ud
{ haskelloids = nhs
, shots = npews
, ship = updateShip sec (ship ud)
}
checkShotDown
ud2 <- getAffection
updateGame :: UserData -> Double -> Affection ()
updateGame ud sec = do
nhs <- map (updateHaskelloid sec) <$> liftIO (readMVar $ haskelloids ud)
npews <- (filter (\p -> pTTL p > 0) . map (updatePew sec)) <$> liftIO (readMVar $ shots ud)
s <- liftIO $ readMVar (ship ud)
let nship = updateShip sec s
void $ liftIO $ swapMVar (haskelloids ud) nhs
void $ liftIO $ swapMVar (shots ud) npews
void $ liftIO $ swapMVar (ship ud) nship
checkShotDown ud
hasks <- liftIO $ readMVar (haskelloids ud)
hotShots <- liftIO $ readMVar (shots ud)
wlcond <- liftIO $ readMVar (wonlost ud)
when
( ( any (checkCollision (ship ud2)) (haskelloids ud2)
|| any (checkFriendlyFire (ship ud2)) (shots ud2)
( ( any (checkCollision nship) hasks
|| any (checkFriendlyFire nship) hotShots
)
&& isNothing (wonlost ud2)
&& isNothing wlcond
) $ do
liftIO $ logIO A.Debug "You Lost!"
putAffection ud2
{ wonlost = Just Lost
}
when (isNothing (wonlost ud2) && null (haskelloids ud2)) $ do
void $ liftIO $ swapMVar (wonlost ud) (Just Lost)
when (isNothing wlcond && null hasks) $ do
liftIO $ logIO A.Debug "You Won!"
putAffection ud2
{ wonlost = Just Won
}
void $ liftIO $ swapMVar (wonlost ud) (Just Won)
checkShotDown :: Affection UserData ()
checkShotDown =
do
ud <- getAffection
let pews = shots ud
hasks = haskelloids ud
pairs = catMaybes $ concatMap (crossOut hasks) pews
deadHasks = map fst pairs
nhask = foldl
(\acc a -> filter (\x -> a /= x) acc)
hasks
deadHasks
npews = foldl
(\acc a -> filter (\x -> a /= x) acc)
pews
(map snd pairs)
children <- liftIO $ concat <$> mapM (\Haskelloid{..} -> do
n1velx <- randomRIO (-10, 10)
n1vely <- randomRIO (-10, 10)
n1rot <- randomRIO (-180, 180)
n1pitch <- randomRIO (-pi, pi)
n2velx <- randomRIO (-10, 10)
n2vely <- randomRIO (-10, 10)
n2rot <- randomRIO (-180, 180)
n2pitch <- randomRIO (-pi, pi)
let ndiv = hDiv + 1
if ndiv > 5
then return []
else return
[ Haskelloid hPos (V2 n1velx n1vely) n1rot n1pitch ndiv hImg
, Haskelloid hPos (V2 n2velx n2vely) n2rot n2pitch ndiv hImg
]
) deadHasks
putAffection ud
{ shots = npews
, haskelloids = nhask ++ children
}
checkShotDown :: UserData -> Affection ()
checkShotDown ud = do
pews <- liftIO $ readMVar (shots ud)
hasks <- liftIO $ readMVar (haskelloids ud)
let pairs = catMaybes $ concatMap (crossOut hasks) pews
deadHasks = map fst pairs
nhask = foldl
(\acc a -> filter (\x -> a /= x) acc)
hasks
deadHasks
npews = foldl
(\acc a -> filter (\x -> a /= x) acc)
pews
(map snd pairs)
children <- liftIO $ concat <$> mapM (\Haskelloid{..} -> do
n1velx <- randomRIO (-10, 10)
n1vely <- randomRIO (-10, 10)
n1rot <- randomRIO (-180, 180)
n1pitch <- randomRIO (-pi, pi)
n2velx <- randomRIO (-10, 10)
n2vely <- randomRIO (-10, 10)
n2rot <- randomRIO (-180, 180)
n2pitch <- randomRIO (-pi, pi)
let ndiv = hDiv + 1
if ndiv > 5
then return []
else return
[ Haskelloid hPos (V2 n1velx n1vely) n1rot n1pitch ndiv hImg
, Haskelloid hPos (V2 n2velx n2vely) n2rot n2pitch ndiv hImg
]
) deadHasks
void $ liftIO $ swapMVar (shots ud) npews
void $ liftIO $ swapMVar (haskelloids ud) (nhask ++ children)
where
crossOut :: [Haskelloid] -> Pew -> [Maybe (Haskelloid, Pew)]
crossOut hs p =
@ -235,18 +219,20 @@ updatePew ddt p@Pew{..} = p
where
dt = realToFrac ddt
drawGame :: Affection UserData ()
drawGame = do
ud <- getAffection
mapM_ drawHaskelloid (haskelloids ud)
mapM_ drawPew (shots ud)
case wonlost ud of
Just x -> drawWonLost x
Nothing -> drawShip (ship ud)
drawGame :: UserData -> Affection ()
drawGame ud = do
hasks <- liftIO $ readMVar (haskelloids ud)
pews <- liftIO $ readMVar (shots ud)
wlcond <- liftIO $ readMVar (wonlost ud)
s <- liftIO $ readMVar (ship ud)
mapM_ (drawHaskelloid (nano ud)) hasks
mapM_ (drawPew (nano ud)) pews
case wlcond of
Just x -> drawWonLost (nano ud) x
Nothing -> drawShip (nano ud) s
drawWonLost :: WonLost -> Affection UserData ()
drawWonLost wl = do
ctx <- nano <$> getAffection
drawWonLost :: Context -> WonLost -> Affection ()
drawWonLost ctx wl =
liftIO $ do
let color = case wl of
Won -> rgba 128 255 0 255
@ -265,9 +251,8 @@ drawWonLost wl = do
textBox ctx 0 350 800 "Press [Esc] to exit\nPress [R] to try again"
restore ctx
drawShip :: Ship -> Affection UserData ()
drawShip Ship{..} = do
ctx <- nano <$> getAffection
drawShip :: Context -> Ship -> Affection ()
drawShip ctx Ship{..} =
liftIO $ do
when (sThrust) $ do
let pos@(V2 px py) = fmap CFloat sPos - V2 0 10 `rotVec` cRot
@ -289,9 +274,8 @@ drawShip Ship{..} = do
where
dim = V2 40 40
drawPew :: Pew -> Affection UserData ()
drawPew Pew{..} = do
ctx <- nano <$> getAffection
drawPew :: Context -> Pew -> Affection ()
drawPew ctx Pew{..} =
liftIO $ do
let (V2 x y) = fmap CFloat pPos
save ctx

View File

@ -14,8 +14,8 @@ import qualified Data.Set as S
import Data.Maybe
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.STM
import Control.Concurrent.MVar
import System.Exit (exitFailure)
@ -61,22 +61,22 @@ load = do
liftIO $ logIO A.Debug "Setting viewport"
GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
liftIO $ logIO A.Debug "Returning UserData"
return UserData
{ ship = Ship
UserData
<$> newMVar (Ship
{ sPos = V2 400 300
, sVel = V2 0 0
, sRot = 0
, sImg = fromJust mshipImage
, sThrust = False
}
, haskelloids = []
, shots = []
, wonlost = Nothing
, state = Menu
, fade = FadeIn 1
, nano = nvgCtx
, font = fromJust mfont
, subsystems = subs
, haskImage = fromJust mhaskImage
, stateUUIDs = UUIDClean [] []
}
})
<*> newMVar []
<*> newMVar []
<*> newMVar Nothing
<*> newMVar Menu
<*> newMVar (FadeIn 1)
<*> return nvgCtx
<*> return (fromJust mfont)
<*> return subs
<*> return (fromJust mhaskImage)
<*> newMVar (UUIDClean [] [])
<*> newMVar True

View File

@ -8,8 +8,11 @@ import Linear as L
import NanoVG hiding (V2(..), V4(..))
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.MVar
import Control.Monad (when, void)
import Data.String (fromString)
-- internal imports
@ -17,32 +20,37 @@ import Types
import StateMachine ()
import Init
instance Affectionate UserData where
loadState = load
preLoop = (\ud -> pre ud >> smLoad Menu ud)
handleEvents = handle
update = Main.update
draw = Main.draw
cleanUp = \_ -> return ()
hasNextStep = liftIO . readMVar . doNextStep
main :: IO ()
main = do
logIO A.Debug "Starting"
withAffection AffectionConfig
withAffection (AffectionConfig
{ initComponents = All
, windowTitle = "Haskelloids"
, windowConfig = SDL.defaultWindow
{ SDL.windowOpenGL = Just SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
, SDL.glColorPrecision = V4 8 8 8 1
, windowConfigs = [
( 0
, SDL.defaultWindow
{ SDL.windowGraphicsContext = SDL.OpenGLContext SDL.defaultOpenGL
{ SDL.glProfile = SDL.Core SDL.Normal 3 2
, SDL.glColorPrecision = V4 8 8 8 1
}
, SDL.windowResizable = True
}
, SDL.windowResizable = True
}
, initScreenMode = SDL.Windowed
, canvasSize = Nothing
, loadState = load
, preLoop = pre >> smLoad Menu
, eventLoop = handle
, updateLoop = update
, drawLoop = draw
, cleanUp = \_ -> return ()
}
, SDL.Windowed
)]
} :: AffectionConfig UserData)
pre :: Affection UserData ()
pre = do
subs <- subsystems <$> getAffection
pre :: UserData -> Affection ()
pre ud = do
let subs = subsystems ud
liftIO $ logIO A.Debug "Setting global resize event listener"
_ <- partSubscribe (subWindow subs) (fitViewport (800/600))
_ <- partSubscribe (subKeyboard subs) $ \kbdev ->
@ -50,33 +58,31 @@ pre = do
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeF -> do
dt <- getDelta
liftIO $ logIO A.Debug $ "FPS: " ++ show (1/dt)
SDL.KeycodeO -> toggleScreen
liftIO $ logIO A.Debug $ "FPS: " <> (fromString $ show (1/dt))
SDL.KeycodeO -> toggleScreen 0
_ -> return ()
return ()
update :: Double -> Affection UserData ()
update sec = do
ud <- getAffection
smUpdate (state ud) sec
update :: UserData -> Double -> Affection ()
update ud sec = do
curstate <- liftIO $ readMVar (state ud)
smUpdate curstate ud sec
handle :: [SDL.EventPayload] -> Affection UserData ()
handle e = do
(Subsystems w k) <- subsystems <$> getAffection
_ <- consumeSDLEvents w =<< consumeSDLEvents k e
return ()
handle :: UserData -> [SDL.EventPayload] -> Affection ()
handle ud e = do
let (Subsystems w k) = subsystems ud
void $ consumeSDLEvents w =<< consumeSDLEvents k e
draw :: Affection UserData ()
draw = do
ud <- getAffection
draw :: UserData -> Affection ()
draw ud = do
liftIO $ beginFrame (nano ud) 800 600 1
smDraw (state ud)
drawVignette
curstate <- liftIO $ readMVar (state ud)
smDraw curstate ud
drawVignette (nano ud)
liftIO $ endFrame (nano ud)
drawVignette :: Affection UserData ()
drawVignette = do
ctx <- nano <$> getAffection
drawVignette :: Context -> Affection ()
drawVignette ctx =
liftIO $ do
save ctx
beginPath ctx

View File

@ -5,8 +5,9 @@ import qualified SDL
import qualified Data.Set as S
import Control.Monad (when)
import Control.Monad.IO.Class (liftIO)
import Control.Monad
import Control.Concurrent.MVar
import NanoVG
@ -15,51 +16,41 @@ import NanoVG
import Types
import Commons
loadMenu :: Affection UserData () -> Affection UserData ()
loadMenu stateChange = do
loadMenu :: Affection () -> UserData -> Affection ()
loadMenu stateChange ud = do
liftIO $ logIO A.Debug "Loading Menu"
ud <- getAffection
hs <- newHaskelloids
hs <- newHaskelloids (haskImage ud)
kbdUUID <- partSubscribe (subKeyboard $ subsystems ud)
(\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
case SDL.keysymKeycode (msgKbdKeysym kbdev) of
SDL.KeycodeEscape -> do
liftIO $ logIO A.Debug "seeya"
quit
void $ liftIO $ swapMVar (doNextStep ud) False
SDL.KeycodeSpace -> do
liftIO $ logIO A.Debug "Leaving Menu to Game"
stateChange
_ -> return ()
)
putAffection ud
{ haskelloids = hs
, fade = FadeIn 1
, state = Menu
, stateUUIDs = UUIDClean [] [kbdUUID]
-- , shots = (shots ud)
-- { partSysParts = ParticleStorage Nothing [] }
}
void $ liftIO $ swapMVar (haskelloids ud) hs
void $ liftIO $ swapMVar (fade ud) (FadeIn 1)
void $ liftIO $ swapMVar (state ud) Menu
void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [kbdUUID])
updateMenu :: Double -> Affection UserData ()
updateMenu sec = do
ud <- getAffection
let nhs = map (updateHaskelloid sec) (haskelloids ud)
case fade ud of
updateMenu :: UserData -> Double -> Affection ()
updateMenu ud sec = do
nhs <- map (updateHaskelloid sec) <$> liftIO (readMVar (haskelloids ud))
void $ liftIO $ swapMVar (haskelloids ud) nhs
fadeState <- liftIO (readMVar $ fade ud)
case fadeState of
FadeIn ttl ->
putAffection ud
{ fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
, haskelloids = nhs
}
void $ liftIO $ swapMVar (fade ud) (if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1)
FadeOut ttl ->
putAffection ud
{ fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
, haskelloids = nhs
}
void $ liftIO $ swapMVar (fade ud) (if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1)
drawMenu :: Affection UserData ()
drawMenu = do
ud <- getAffection
mapM_ drawHaskelloid (haskelloids ud)
drawMenu :: UserData -> Affection ()
drawMenu ud = do
hasks <- liftIO $ readMVar (haskelloids ud)
mapM_ (drawHaskelloid (nano ud)) hasks
liftIO $ do
let ctx = nano ud
alpha fio = case fio of
@ -71,7 +62,8 @@ drawMenu = do
textAlign ctx (S.fromList [AlignCenter,AlignTop])
fillColor ctx (rgba 255 255 255 255)
textBox ctx 0 200 800 "HASKELLOIDS"
fillColor ctx (rgba 0 128 255 (alpha $ fade ud))
fadeState <- readMVar (fade ud)
fillColor ctx (rgba 0 128 255 (alpha $ fadeState))
fontSize ctx 40
textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit"
restore ctx

View File

@ -3,16 +3,24 @@
module StateMachine where
import Control.Concurrent.MVar
import Control.Monad (void)
import Affection
import Types
import InGame
import Menu
instance StateMachine State UserData where
smLoad Menu = loadMenu (smClean Menu >> smLoad InGame)
instance StateMachine UserData State where
smLoad Menu = (\ud -> loadMenu (smClean Menu ud >> smLoad InGame ud) ud)
smLoad InGame = loadGame (smClean InGame >> smLoad Menu) (smClean InGame >> smLoad InGame)
smLoad InGame = (\ud -> loadGame
(smClean InGame ud >> smLoad Menu ud)
(smClean InGame ud >> smLoad InGame ud)
ud
)
smUpdate Menu = updateMenu
@ -22,14 +30,11 @@ instance StateMachine State UserData where
smDraw InGame = drawGame
smEvent _ _ = return ()
smEvent _ _ _ = return ()
smClean _ = do
ud <- getAffection
let (UUIDClean uuwin uukbd) = stateUUIDs ud
(Subsystems win kbd) = subsystems ud
smClean _ ud = do
(UUIDClean uuwin uukbd) <- liftIO $ readMVar (stateUUIDs ud)
let (Subsystems win kbd) = subsystems ud
mapM_ (partUnSubscribe win) uuwin
mapM_ (partUnSubscribe kbd) uukbd
putAffection ud
{ stateUUIDs = UUIDClean [] []
}
void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [])

View File

@ -5,24 +5,23 @@ module Types where
import Affection
import NanoVG hiding (V2(..))
import Linear
import Control.Concurrent.STM
import Control.Monad.IO.Class (liftIO)
import Control.Concurrent.MVar
data UserData = UserData
{ ship :: Ship
, haskelloids :: [Haskelloid]
, shots :: [Pew]
-- , debris :: ParticleSystem
, wonlost :: Maybe WonLost
, state :: State
, fade :: MenuFade
, nano :: Context
, font :: Font
, subsystems :: Subsystems
, haskImage :: Image
, stateUUIDs :: UUIDClean
{ 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
@ -72,10 +71,10 @@ data UUIDClean = UUIDClean
, uuKeyboard :: [UUID]
}
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection UserData ())])
newtype SubWindow = SubWindow (TVar [(UUID, WindowMessage -> Affection ())])
instance Participant SubWindow UserData where
type Mesg SubWindow UserData = WindowMessage
instance Participant SubWindow where
type Mesg SubWindow = WindowMessage
partSubscribers (SubWindow t) = do
subTups <- liftIO $ readTVarIO t
@ -89,16 +88,16 @@ instance Participant SubWindow UserData where
partUnSubscribe (SubWindow t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool
filterMsg :: (UUID, WindowMessage -> Affection ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p
instance SDLSubsystem SubWindow UserData where
instance SDLSubsystem SubWindow where
consumeSDLEvents = consumeSDLWindowEvents
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection UserData ())])
newtype SubKeyboard = SubKeyboard (TVar [(UUID, KeyboardMessage -> Affection ())])
instance Participant SubKeyboard UserData where
type Mesg SubKeyboard UserData = KeyboardMessage
instance Participant SubKeyboard where
type Mesg SubKeyboard = KeyboardMessage
partSubscribers (SubKeyboard t) = do
subTups <- liftIO $ readTVarIO t
@ -112,8 +111,8 @@ instance Participant SubKeyboard UserData where
partUnSubscribe (SubKeyboard t) uuid =
liftIO $ atomically $ modifyTVar' t (filter (`filterMsg` uuid))
where
filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool
filterMsg :: (UUID, KeyboardMessage -> Affection ()) -> UUID -> Bool
filterMsg (u, _) p = u /= p
instance SDLSubsystem SubKeyboard UserData where
instance SDLSubsystem SubKeyboard where
consumeSDLEvents = consumeSDLKeyboardEvents