Updated game to use affection 0.0.0.10

.gitignore

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

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 :: Image -> Affection [Haskelloid]
-newHaskelloids =
+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 :: Context -> Haskelloid -> Affection ()
-drawHaskelloid (Haskelloid pos _ rot _ d img) = do
+drawHaskelloid ctx (Haskelloid pos _ rot _ d img) = do
-  ctx <- nano <$> getAffection
   liftIO $ drawImage ctx img (pos - fmap (/2) dim) dim rot 1
   where
     dim = fmap (/ fromIntegral d) (V2 100 100)

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
-import Control.Monad.IO.Class (liftIO)
+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 ()
-  -> Affection UserData ()
+  -> Affection ()
-  -> Affection UserData ()
+  -> UserData
-loadGame stateChange clean = do
+  -> Affection ()
+loadGame stateChange clean ud = do
   liftIO $ logIO A.Debug "loading game"
-  ud <- getAffection
+  nhs <- newHaskelloids (haskImage ud)
-  nhs <- newHaskelloids
   kid <- partSubscribe
     (subKeyboard $ subsystems ud)
-    (handleGameKeys stateChange clean)
+    (handleGameKeys stateChange clean ud)
-  putAffection ud
+  oldship <- liftIO $ readMVar (ship ud)
-    { stateUUIDs = UUIDClean [] [kid]
+  void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [kid])
-    , haskelloids = nhs
+  void $ liftIO $ swapMVar (haskelloids ud) (nhs)
-    , ship = (ship ud)
+  void $ liftIO $ swapMVar (ship ud) (oldship
     { sPos = V2 400 300
     , sVel = V2 0 0
     , sRot = 0
     , sThrust = False
-      }
+    })
-    , shots = []
+  void $ liftIO $ swapMVar (shots ud) []
-    , state = InGame
+  void $ liftIO $ swapMVar (wonlost ud) Nothing
-    , wonlost = Nothing
+  void $ liftIO $ swapMVar (state ud) InGame
-    }
 
 handleGameKeys
-  :: Affection UserData ()
+  :: Affection ()
-  -> Affection UserData ()
+  -> Affection ()
+  -> UserData
   -> KeyboardMessage
-  -> Affection UserData ()
+  -> Affection ()
-handleGameKeys stateChange clean kbdev =
+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
+      wlcond <- liftIO $ readMVar (wonlost ud)
-      unless (isNothing $ wonlost ud) $ do
+      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.KeycodeW -> accelShip ud dVel
-    SDL.KeycodeA -> rotateShip dRot
+    SDL.KeycodeA -> rotateShip ud dRot
-    SDL.KeycodeD -> rotateShip (-dRot)
+    SDL.KeycodeD -> rotateShip ud (-dRot)
     _ -> return ()
   else case SDL.keysymKeycode (msgKbdKeysym kbdev) of
-    SDL.KeycodeW -> deThrust
+    SDL.KeycodeW -> deThrust ud
-    SDL.KeycodeA -> deThrust
+    SDL.KeycodeA -> deThrust ud
-    SDL.KeycodeD -> deThrust
+    SDL.KeycodeD -> deThrust ud
     _ -> return ()
 
-shoot :: Affection UserData ()
+shoot :: UserData -> Affection ()
-shoot = do
+shoot ud = do
-  ud <- getAffection
+  Ship{..} <- liftIO $ readMVar (ship ud)
-  let Ship{..} = ship ud
+  let npew = Pew ppos pVel pewTTL
-      npew = Pew ppos pVel pewTTL
       ppos = sPos + (V2 0 25 `rotVec` sRot)
       pVel = sVel + (V2 0 pewVel `rotVec` sRot)
-  putAffection ud
+  oldshots <- liftIO $ readMVar (shots ud)
-    { shots = npew : shots ud
+  void $ liftIO $ swapMVar (shots ud) (npew : oldshots)
-    }
 
-accelShip :: Float -> Affection UserData ()
+accelShip :: UserData -> Float -> Affection ()
-accelShip vel = do
+accelShip ud vel = do
-  ud <- getAffection
   dt <- getDelta
-  let s    = ship ud
+  s <- liftIO $ readMVar (ship ud)
-      nVel = sVel s + fmap (realToFrac dt *) (V2 0 vel `rotVec` sRot s)
+  let nVel = sVel s + fmap (realToFrac dt *) (V2 0 vel `rotVec` sRot s)
-  putAffection ud
+  void $ liftIO $ swapMVar (ship ud) (s
-    { ship = s
     { sVel = nVel
     , sThrust = True
-      }
+    })
-    }
 
-deThrust :: Affection UserData ()
+deThrust :: UserData -> Affection ()
-deThrust = do
+deThrust ud = do
-  ud <- getAffection
+  s <- liftIO $ readMVar (ship ud)
-  putAffection ud
+  void $ liftIO $ swapMVar (ship ud) (s
-    { ship = (ship ud)
     { sThrust = False
-      }
+    })
-    }
 
-rotateShip :: Float -> Affection UserData ()
+rotateShip :: UserData -> Float -> Affection ()
-rotateShip deg = do
+rotateShip ud deg = do
-  ud <- getAffection
+  -- dt <- getDelta
-  dt <- getDelta
+  s <- liftIO $ readMVar (ship ud)
-  putAffection ud
+  void $ liftIO $ swapMVar (ship ud) (s
-    { ship = (ship ud)
+    { sRot = sRot s - deg -- * realToFrac dt
-      { sRot = sRot (ship ud) - deg * realToFrac dt
+    })
-      }
-    }
 
 rotVec :: (Num a, Floating a) => V2 a -> a -> V2 a
 rotVec (V2 x y) deg = V2 nx ny
@@ -136,41 +127,36 @@ 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 :: UserData -> Double -> Affection ()
-updateGame sec = do
+updateGame ud sec = do
-  ud <- getAffection
+  nhs <- map (updateHaskelloid sec) <$> liftIO (readMVar $ haskelloids ud)
-  let nhs = map (updateHaskelloid sec) (haskelloids ud)
+  npews <- (filter (\p -> pTTL p > 0) . map (updatePew sec)) <$> liftIO (readMVar $ shots ud)
-      npews = filter (\p -> pTTL p > 0) $ map (updatePew sec) (shots ud)
+  s <- liftIO $ readMVar (ship ud)
-  putAffection ud
+  let nship = updateShip sec s
-    { haskelloids = nhs
+  void $ liftIO $ swapMVar (haskelloids ud) nhs
-    , shots = npews
+  void $ liftIO $ swapMVar (shots ud) npews
-    , ship = updateShip sec (ship ud)
+  void $ liftIO $ swapMVar (ship ud) nship
-    }
+  checkShotDown ud
-  checkShotDown
+  hasks <- liftIO $ readMVar (haskelloids ud)
-  ud2 <- getAffection
+  hotShots <- liftIO $ readMVar (shots ud)
+  wlcond <- liftIO $ readMVar (wonlost ud)
   when
-    (  (  any (checkCollision (ship ud2)) (haskelloids ud2)
+    (  (  any (checkCollision nship) hasks
-       || any (checkFriendlyFire (ship ud2)) (shots ud2)
+       || any (checkFriendlyFire nship) hotShots
        )
-    && isNothing (wonlost ud2)
+    && isNothing wlcond
     ) $ do
       liftIO $ logIO A.Debug "You Lost!"
-      putAffection ud2
+      void $ liftIO $ swapMVar (wonlost ud) (Just Lost)
-        { wonlost = Just Lost
+  when (isNothing wlcond && null hasks) $ do
-        }
-  when (isNothing (wonlost ud2) && null (haskelloids ud2)) $ do
     liftIO $ logIO A.Debug "You Won!"
-    putAffection ud2
+    void $ liftIO $ swapMVar (wonlost ud) (Just Won)
-      { wonlost = Just Won
-      }
 
-checkShotDown :: Affection UserData ()
+checkShotDown :: UserData -> Affection ()
-checkShotDown =
+checkShotDown ud = do
-  do
+  pews  <- liftIO $ readMVar (shots ud)
-    ud <- getAffection
+  hasks <- liftIO $ readMVar (haskelloids ud)
-    let pews = shots ud
+  let pairs = catMaybes $ concatMap (crossOut hasks) pews
-        hasks = haskelloids ud
-        pairs = catMaybes $ concatMap (crossOut hasks) pews
       deadHasks = map fst pairs
       nhask = foldl
         (\acc a -> filter (\x -> a /= x) acc)
@@ -197,10 +183,8 @@ checkShotDown =
       , Haskelloid hPos (V2 n2velx n2vely) n2rot n2pitch ndiv hImg
       ]
     ) deadHasks
-    putAffection ud
+  void $ liftIO $ swapMVar (shots ud) npews
-      { shots = npews
+  void $ liftIO $ swapMVar (haskelloids ud) (nhask ++ children)
-      , haskelloids = 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 :: UserData -> Affection ()
-drawGame = do
+drawGame ud = do
-  ud <- getAffection
+  hasks <- liftIO $ readMVar (haskelloids ud)
-  mapM_ drawHaskelloid (haskelloids ud)
+  pews <- liftIO $ readMVar (shots ud)
-  mapM_ drawPew (shots ud)
+  wlcond <- liftIO $ readMVar (wonlost ud)
-  case wonlost ud of
+  s <- liftIO $ readMVar (ship ud)
-    Just x -> drawWonLost x
+  mapM_ (drawHaskelloid (nano ud)) hasks
-    Nothing -> drawShip (ship ud)
+  mapM_ (drawPew (nano ud)) pews
+  case wlcond of
+    Just x -> drawWonLost (nano ud) x
+    Nothing -> drawShip (nano ud) s
 
-drawWonLost :: WonLost -> Affection UserData ()
+drawWonLost :: Context -> WonLost -> Affection ()
-drawWonLost wl = do
+drawWonLost ctx wl =
-  ctx <- nano <$> getAffection
   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 :: Context -> Ship -> Affection ()
-drawShip Ship{..} = do
+drawShip ctx Ship{..} =
-  ctx <- nano <$> getAffection
   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 :: Context -> Pew -> Affection ()
-drawPew Pew{..} = do
+drawPew ctx Pew{..} =
-  ctx <- nano <$> getAffection
   liftIO $ do
     let (V2 x y) = fmap CFloat pPos
     save ctx

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
+  UserData
-    { ship = Ship
+    <$> newMVar (Ship
       { sPos = V2 400 300
       , sVel = V2 0 0
       , sRot = 0
       , sImg = fromJust mshipImage
       , sThrust = False
-      }
+      })
-    , haskelloids = []
+    <*> newMVar []
-    , shots = []
+    <*> newMVar []
-    , wonlost = Nothing
+    <*> newMVar Nothing
-    , state = Menu
+    <*> newMVar Menu
-    , fade = FadeIn 1
+    <*> newMVar (FadeIn 1)
-    , nano = nvgCtx
+    <*> return nvgCtx
-    , font = fromJust mfont
+    <*> return (fromJust mfont)
-    , subsystems = subs
+    <*> return subs
-    , haskImage = fromJust mhaskImage
+    <*> return (fromJust mhaskImage)
-    , stateUUIDs = UUIDClean [] []
+    <*> newMVar (UUIDClean [] [])
-    }
+    <*> newMVar True

src/Main.hs

@@ -8,8 +8,11 @@ import Linear as L
 
 import NanoVG hiding (V2(..), V4(..))
 
-import Control.Monad (when)
+import Control.Concurrent.MVar
-import Control.Monad.IO.Class (liftIO)
+
+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
+    , windowConfigs  = [
-      { SDL.windowOpenGL = Just SDL.defaultOpenGL
+      ( 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
         }
-    , initScreenMode = SDL.Windowed
+      , SDL.Windowed
-    , canvasSize     = Nothing
+      )]
-    , loadState      = load
+    } :: AffectionConfig UserData)
-    , preLoop        = pre >> smLoad Menu
-    , eventLoop      = handle
-    , updateLoop     = update
-    , drawLoop       = draw
-    , cleanUp        = \_ -> return ()
-    }
 
-pre :: Affection UserData ()
+pre :: UserData -> Affection ()
-pre = do
+pre ud = do
-  subs <- subsystems <$> getAffection
+  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)
+          liftIO $ logIO A.Debug $ "FPS: " <> (fromString $ show (1/dt))
-        SDL.KeycodeO -> toggleScreen
+        SDL.KeycodeO -> toggleScreen 0
         _ -> return ()
   return ()
 
-update :: Double -> Affection UserData ()
+update :: UserData -> Double -> Affection ()
-update sec = do
+update ud sec = do
-  ud <- getAffection
+  curstate <- liftIO $ readMVar (state ud)
-  smUpdate (state ud) sec
+  smUpdate curstate ud sec
 
-handle :: [SDL.EventPayload] -> Affection UserData ()
+handle :: UserData -> [SDL.EventPayload] -> Affection ()
-handle e = do
+handle ud e = do
-  (Subsystems w k) <- subsystems <$> getAffection
+  let (Subsystems w k) = subsystems ud
-  _ <- consumeSDLEvents w =<< consumeSDLEvents k e
+  void $ consumeSDLEvents w =<< consumeSDLEvents k e
-  return ()
 
-draw :: Affection UserData ()
+draw :: UserData -> Affection ()
-draw = do
+draw ud = do
-  ud <- getAffection
   liftIO $ beginFrame (nano ud) 800 600 1
-  smDraw (state ud)
+  curstate <- liftIO $ readMVar (state ud)
-  drawVignette
+  smDraw curstate ud
+  drawVignette (nano ud)
   liftIO $ endFrame (nano ud)
 
-drawVignette :: Affection UserData ()
+drawVignette :: Context -> Affection ()
-drawVignette = do
+drawVignette ctx =
-  ctx <- nano <$> getAffection
   liftIO $ do
     save ctx
     beginPath ctx

src/Menu.hs

@@ -5,8 +5,9 @@ import qualified SDL
 
 import qualified Data.Set as S
 
-import Control.Monad (when)
+import Control.Monad
-import Control.Monad.IO.Class (liftIO)
+
+import Control.Concurrent.MVar
 
 import NanoVG
 
@@ -15,51 +16,41 @@ import NanoVG
 import Types
 import Commons
 
-loadMenu :: Affection UserData () -> Affection UserData ()
+loadMenu :: Affection () -> UserData -> Affection ()
-loadMenu stateChange = do
+loadMenu stateChange ud = do
   liftIO $ logIO A.Debug "Loading Menu"
-  ud <- getAffection
+  hs <- newHaskelloids (haskImage ud)
-  hs <- newHaskelloids
   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
+  void $ liftIO $ swapMVar (haskelloids ud) hs
-    { haskelloids = hs
+  void $ liftIO $ swapMVar (fade ud) (FadeIn 1)
-    , fade = FadeIn 1
+  void $ liftIO $ swapMVar (state ud) Menu
-    , state = Menu
+  void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [kbdUUID])
-    , stateUUIDs = UUIDClean [] [kbdUUID]
-    -- , shots = (shots ud)
-    --   { partSysParts = ParticleStorage Nothing [] }
-    }
 
-updateMenu :: Double -> Affection UserData ()
+updateMenu :: UserData -> Double -> Affection ()
-updateMenu sec = do
+updateMenu ud sec = do
-  ud <- getAffection
+  nhs <- map (updateHaskelloid sec) <$> liftIO (readMVar (haskelloids ud))
-  let nhs = map (updateHaskelloid sec) (haskelloids ud)
+  void $ liftIO $ swapMVar (haskelloids ud) nhs
-  case fade ud of
+  fadeState <- liftIO (readMVar $ fade ud)
+  case fadeState of
     FadeIn ttl ->
-      putAffection ud
+      void $ liftIO $ swapMVar (fade ud) (if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1)
-        { fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
-        , haskelloids = nhs
-        }
     FadeOut ttl ->
-      putAffection ud
+      void $ liftIO $ swapMVar (fade ud) (if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1)
-        { fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
-        , haskelloids = nhs
-        }
 
-drawMenu :: Affection UserData ()
+drawMenu :: UserData -> Affection ()
-drawMenu = do
+drawMenu ud = do
-  ud <- getAffection
+  hasks <- liftIO $ readMVar (haskelloids ud)
-  mapM_ drawHaskelloid (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

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
+instance StateMachine UserData State where
-  smLoad Menu = loadMenu (smClean Menu >> smLoad InGame)
+  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
+  smClean _ ud = do
-    ud <- getAffection
+    (UUIDClean uuwin uukbd) <- liftIO $ readMVar (stateUUIDs ud)
-    let (UUIDClean uuwin uukbd) = stateUUIDs ud
+    let (Subsystems win kbd)    = subsystems ud
-        (Subsystems win kbd)    = subsystems ud
     mapM_ (partUnSubscribe win) uuwin
     mapM_ (partUnSubscribe kbd) uukbd
-    putAffection ud
+    void $ liftIO $ swapMVar (stateUUIDs ud) (UUIDClean [] [])
-      { stateUUIDs = UUIDClean [] []
-      }

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
+  { ship        :: MVar Ship
-  , haskelloids :: [Haskelloid]
+  , haskelloids :: MVar [Haskelloid]
-  , shots :: [Pew]
+  , shots       :: MVar [Pew]
-  -- , debris :: ParticleSystem
+  , wonlost     :: MVar (Maybe WonLost)
-  , wonlost :: Maybe WonLost
+  , state       :: MVar (State)
-  , state :: State
+  , fade        :: MVar (MenuFade)
-  , fade :: MenuFade
   , nano        :: Context
   , font        :: Font
   , subsystems  :: Subsystems
   , haskImage   :: Image
-  , stateUUIDs :: UUIDClean
+  , 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
+instance Participant SubWindow where
-  type Mesg SubWindow UserData = WindowMessage
+  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
+instance Participant SubKeyboard where
-  type Mesg SubKeyboard UserData = KeyboardMessage
+  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