diff --git a/.gitignore b/.gitignore index c720a2c..dea18e5 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,7 @@ .cabal-sandbox/ cabal.sandbox.config dist/ +dist-newstyle/ *.prof *.aux *.hp diff --git a/src/Commons.hs b/src/Commons.hs index 98a0e31..d1e794d 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -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) diff --git a/src/InGame.hs b/src/InGame.hs index 27e846f..ff68236 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -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 diff --git a/src/Init.hs b/src/Init.hs index 10a40eb..6bbddd2 100644 --- a/src/Init.hs +++ b/src/Init.hs @@ -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 diff --git a/src/Main.hs b/src/Main.hs index 3210fb5..ce8d074 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -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 diff --git a/src/Menu.hs b/src/Menu.hs index 4a3a127..eac306b 100644 --- a/src/Menu.hs +++ b/src/Menu.hs @@ -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 diff --git a/src/StateMachine.hs b/src/StateMachine.hs index aa8618c..7bbbc55 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -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 [] []) diff --git a/src/Types.hs b/src/Types.hs index 9147445..b92be09 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -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