making things work

haskelloids.cabal

@@ -58,6 +58,7 @@ executable haskelloids
                     , Commons
                     , StateMachine
                     , Menu
+                    , InGame
                     , Init
   
   default-extensions: OverloadedStrings

src/Commons.hs

@@ -38,23 +38,25 @@ wrapAround (V2 nx ny) width = (V2 nnx nny)
       | otherwise       = ny
     half = width / 2
 
-newHaskelloids :: Image -> Affection UserData [Haskelloid]
+newHaskelloids :: Affection UserData [Haskelloid]
-newHaskelloids img = liftIO $ mapM (\_ -> do
+newHaskelloids = do
-  posx <- randomRIO (0, 800)
+  img <- haskImage <$> getAffection
-  posy <- randomRIO (0, 600)
+  liftIO $ mapM (\_ -> do
-  velx <- randomRIO (-10, 10)
+    posx <- randomRIO (0, 800)
-  vely <- randomRIO (-10, 10)
+    posy <- randomRIO (0, 600)
-  rot <- randomRIO (-180, 180)
+    velx <- randomRIO (-10, 10)
-  pitch <- randomRIO (-pi, pi)
+    vely <- randomRIO (-10, 10)
-  div <- randomRIO (1, 2)
+    rot <- randomRIO (-180, 180)
-  return $ Haskelloid
+    pitch <- randomRIO (-pi, pi)
-    (V2 posx posy)
+    div <- randomRIO (1, 2)
-    (V2 velx vely)
+    return $ Haskelloid
-    rot
+      (V2 posx posy)
-    pitch
+      (V2 velx vely)
-    div
+      rot
-    img
+      pitch
-  ) [1..10]
+      div
+      img
+    ) [1..10]
 
 updateHaskelloid :: Double -> Haskelloid -> Haskelloid
 updateHaskelloid dsec has =

src/InGame.hs

@@ -1,235 +1,81 @@
+{-# LANGUAGE RecordWildCards #-}
 module InGame where
 
-import Affection
+import Affection as A
 import qualified SDL
-import GEGL
 
 import qualified Data.Map as M
 import Data.Maybe (catMaybes, isJust, fromJust, isNothing)
 
-import Control.Monad (when, foldM)
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
 
 import System.Random (randomRIO)
 
-import Debug.Trace
+import Linear
 
 import Types
 import Commons
 import Menu
 
-loadGame :: Affection UserData ()
+loadGame :: Affection UserData () -> Affection UserData ()
-loadGame = do
+loadGame stateChange = do
-  liftIO $ traceIO "loading game"
+  liftIO $ logIO A.Debug "loading game"
   ud <- getAffection
-  _ <- liftIO $ gegl_node_connect_to
+  nhs <- newHaskelloids
-    (nodeGraph ud M.! KeyShipTranslate)
+  kid <- partSubscribe (subKeyboard $ subsystems ud)
-    "output"
+    (\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
-    (nodeGraph ud M.! KeyShipOver)
+      case SDL.keysymKeycode (msgKbdKeysym kbdev) of
-    "aux"
+        SDL.KeycodeSpace -> do
-  liftIO $ traceIO "nodes connected"
+          liftIO $ logIO Debug "TODO: PEW!"
-  hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do
+        SDL.KeycodeR -> do
-    coords <- liftIO excludeShip
+          liftIO $ logIO Debug "Reloading"
-    insertHaskelloid acc Nothing coords
+          putAffection ud
-    ) [] ([0..9] :: [Int])
+            { stateUUIDs = UUIDClean [] []
-  liftIO $ traceIO "inserted haskelloids"
+            }
-  liftIO $ gegl_node_link_many $ map hFlange hs
+          loadGame stateChange
-  liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop)
+        SDL.KeycodeEscape -> do
-  liftIO $ gegl_node_disconnect
+          liftIO $ logIO Debug "Leave to Menu"
-    (nodeGraph ud M.! KeyFGOver)
+          stateChange
-    "aux"
+        _ -> return ()
-  liftIO $ traceIO "nodes linked"
+    )
   putAffection ud
-    { haskelloids = hs
+    { stateUUIDs = UUIDClean [] [kid]
-    , wonlost = Nothing
+    , haskelloids = nhs
-    , shots = ParticleSystem
+    , ship = (ship ud)
-      (ParticleStorage Nothing [])
+      { sPos = V2 400 300
-      (nodeGraph ud M.! KeyPNop)
+      , sVel = V2 0 0
-      (buffer ud)
-    , ship = Ship
-      { sPos = (375, 275)
-      , sVel = (0, 0)
       , sRot = 0
-      , sFlange = nodeGraph ud M.! KeyShipRotate
       }
-    , pixelSize = 3
     , state = InGame
     }
-  liftIO $ traceIO "game loaded"
-  present
-    (GeglRectangle 0 0 800 600)
-    (buffer ud)
-    True
 
-excludeShip :: IO (Double, Double)
-excludeShip = do
-  px <- randomRIO (0, 800)
-  py <- randomRIO (0, 600)
-  inter <- gegl_rectangle_intersect
-    (GeglRectangle px py 100 100)
-    (GeglRectangle 350 250 100 100) -- Ship's starting position and size
-  case inter of
-    Just _ ->
-      excludeShip
-    Nothing ->
-      return (fromIntegral px, fromIntegral py)
 
 updateGame :: Double -> Affection UserData ()
 updateGame sec = do
-  ad <- get
   ud <- getAffection
-  when (((floor $ elapsedTime ad :: Int) * 100) `mod` 10 < 2 && pixelSize ud > 3) $ do
+  let nhs = map (updateHaskelloid sec) (haskelloids ud)
-    pd <- getAffection
+  putAffection ud
-    liftIO $ gegl_node_set (nodeGraph pd M.! KeyPixelize) $ Operation "gegl:pixelize"
-      [ Property "size-x" $ PropertyInt $ pixelSize pd - 1
-      , Property "size-y" $ PropertyInt $ pixelSize pd - 1
-      ]
-    putAffection ud
-      { pixelSize = pixelSize ud -1
-      }
-  let nx = fst (sPos $ ship ud) + fst (sVel $ ship ud) * sec
-      ny = snd (sPos $ ship ud) + snd (sVel $ ship ud) * sec
-      (nnx, nny) = wrapAround (nx, ny) 50
-  liftIO $ gegl_node_set (nodeGraph ud M.! KeyShipTranslate) $ Operation "gegl:translate"
-    [ Property "x" $ PropertyDouble nnx
-    , Property "y" $ PropertyDouble nny
-    ]
-  liftIO $ gegl_node_set (nodeGraph ud M.! KeyShipRotate) $ Operation "gegl:rotate"
-    [ Property "degrees" $ PropertyDouble $ sRot $ ship ud
-    ]
-  td <- getAffection
-  putAffection td
-    { ship = (ship ud)
-      { sPos = (nnx, nny)
-      }
-    }
-  ud2 <- getAffection
-  nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
-  ud3 <- getAffection
-  putAffection ud3
     { haskelloids = nhs
+    , ship = updateShip sec (ship ud)
     }
-  ud3 <- getAffection
+
-  ups <- updateParticleSystem (shots ud3) sec shotsUpd
+updateShip :: Double -> Ship -> Ship
-  ud4 <- getAffection
+updateShip ddt s@Ship{..} = s
-  when (isJust $ wonlost ud3) (winlose $ fromJust $ wonlost ud3)
+  { sPos = wrapAround (sPos + fmap (dt *) sVel) 40
-  putAffection ud4
+  }
-    { shots = ups
+  where
-    }
+    dt = realToFrac ddt
 
 drawGame :: Affection UserData ()
 drawGame = do
   ud <- getAffection
-  liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
+  mapM_ drawHaskelloid (haskelloids ud)
-  present
+  drawShip (ship ud)
-    (GeglRectangle 0 0 800 600)
-    (buffer ud)
-    True
 
-handleGameEvent :: SDL.EventPayload -> Affection UserData ()
+drawShip :: Ship -> Affection UserData ()
-handleGameEvent e = do
+drawShip Ship{..} = do
-  ad <- get
+  ctx <- nano <$> getAffection
-  wd <- getAffection
+  liftIO $ drawImage ctx (sImg) (sPos - fmap (/2) dim) dim sRot 255
-  sec <- getDelta
+  where
-  case e of
+    dim = V2 40 40
-    SDL.KeyboardEvent dat ->
-      case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
-        SDL.KeycodeLeft -> do
-          ud <- getAffection
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
-            && (isNothing $ wonlost ud)) $ do
-              let rawRot = (sRot $ ship ud) + 15 * sec
-                  newRot
-                    | rawRot > 360 = rawRot - 360
-                    | rawRot < 0 = rawRot + 360
-                    | otherwise = rawRot
-              putAffection ud
-                { ship = (ship ud)
-                  { sRot = newRot
-                  }
-                }
-        SDL.KeycodeRight -> do
-          ud <- getAffection
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
-            && (isNothing $ wonlost ud)) $ do
-              let rawRot = (sRot $ ship ud) - 15 * sec
-                  newRot
-                    | rawRot > 360 = rawRot - 360
-                    | rawRot < 0 = rawRot + 360
-                    | otherwise = rawRot
-              putAffection ud
-                { ship = (ship ud)
-                  { sRot = newRot
-                  }
-                }
-        SDL.KeycodeUp ->
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
-            && (isNothing $ wonlost wd)) $ do
-              ud <- getAffection
-              let vx = -10 * sin (toR $ sRot $ ship ud) + fst (sVel $ ship ud)
-                  vy = -10 * cos (toR $ sRot $ ship ud) + snd (sVel $ ship ud)
-              putAffection ud
-                { ship = (ship ud)
-                  { sVel = (vx, vy)
-                  }
-                }
-              -- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
-        SDL.KeycodeSpace ->
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
-            && (isNothing $ wonlost wd)) $ do
-              ud <- getAffection
-              liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $
-                Operation "gegl:pixelize"
-                  [ Property "size-x" $ PropertyInt 8
-                  , Property "size-y" $ PropertyInt 8
-                  ]
-              -- ad <- get
-              let posX = fst (sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud)
-                  posY = snd (sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud)
-              tempRoot <- liftIO gegl_node_new
-              tempRect <- liftIO $ gegl_node_new_child tempRoot $
-                Operation "gegl:rectangle"
-                  [ Property "x" $ PropertyDouble posX
-                  , Property "y" $ PropertyDouble posY
-                  , Property "width" $ PropertyDouble 4
-                  , Property "height" $ PropertyDouble 4
-                  , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
-                  ]
-              tempOver <- liftIO $ gegl_node_new_child tempRoot defaultOverOperation
-              _ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux"
-              ips <- insertParticle (shots ud)
-                Particle
-                  { particleTimeToLive = 5
-                  , particleCreation = elapsedTime ad
-                  , particlePosition = (posX, posY)
-                  , particleRotation = 0
-                  , particleVelocity =
-                    ( (floor $ -200 * (sin $ toR $ sRot $ ship ud))
-                    , (floor $ -200 * (cos $ toR $ sRot $ ship ud))
-                    )
-                  , particlePitchRate = 0
-                  , particleRootNode = tempRoot
-                  , particleNodeGraph = M.fromList
-                    [ ("root", tempRoot)
-                    , ("over", tempOver)
-                    , ("rect", tempRect)
-                    ]
-                  , particleStackCont = tempOver
-                  , particleDrawFlange = tempOver
-                  }
-              putAffection $ ud
-                { shots = ips
-                , pixelSize = 8
-                }
-        SDL.KeycodeR ->
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
-            && isJust (wonlost wd)) $ do
-              liftIO $ traceIO "reloading"
-              liftIO $ clean wd
-              nd <- liftIO $ load
-              putAffection nd
-              loadGame
-        _ -> return ()
-    SDL.WindowClosedEvent _ -> do
-      traceM "seeya!"
-      quit
-    _ -> return ()

src/Main.hs

@@ -49,6 +49,7 @@ pre = do
   liftIO $ logIO A.Debug "Setting global resize event listener"
   _ <- partSubscribe (subWindow subs) $ \msg -> case msg of
     MsgWindowResize _ _ (V2 w h) -> do
+      liftIO $ logIO A.Debug "Window has been resized"
       let nw = floor $ fromIntegral h * (800/600)
           dw = floor $ (fromIntegral w - fromIntegral nw) / 2
       GL.viewport $= (GL.Position dw 0, GL.Size nw h)

src/Menu.hs

@@ -24,32 +24,27 @@ import Foreign.C.Types
 import Types
 import Commons
 
-handleMenuEvent :: (Affection UserData ()) -> [SDL.EventPayload] -> Affection UserData ()
+loadMenu :: (Affection UserData ()) -> Affection UserData ()
-handleMenuEvent _ es = do
+loadMenu stateChange = do
-  (Subsystems w k) <- subsystems <$> getAffection
-  _ <- consumeSDLEvents w =<< consumeSDLEvents k es
-  return ()
-
-loadMenu :: Affection UserData ()
-loadMenu = do
   liftIO $ logIO A.Debug "Loading Menu"
   ud <- getAffection
-  hs <- newHaskelloids (haskImage ud)
+  hs <- newHaskelloids
-  _ <- partSubscribe (subKeyboard $ subsystems ud)
+  kbdUUID <- partSubscribe (subKeyboard $ subsystems ud)
-    (\kbdev -> case SDL.keysymKeycode (msgKbdKeysym kbdev) of
+    (\kbdev -> when (msgKbdKeyMotion kbdev == SDL.Pressed) $
-      SDL.KeycodeEscape -> do
+      case SDL.keysymKeycode (msgKbdKeysym kbdev) of
-        liftIO $ logIO A.Debug "seeya"
+        SDL.KeycodeEscape -> do
-        quit
+          liftIO $ logIO A.Debug "seeya"
-      SDL.KeycodeF -> do
+          quit
-        when (msgKbdKeyMotion kbdev == SDL.Pressed) $ do
+        SDL.KeycodeSpace -> do
-          liftIO $ logIO A.Debug "screen toggling"
+          liftIO $ logIO A.Debug "Leaving Menu to Game"
-          toggleScreen
+          stateChange
-      _ -> return ()
+        _ -> return ()
       )
   putAffection ud
     { haskelloids = hs
     , fade = FadeIn 1
     , state = Menu
+    , stateUUIDs = UUIDClean [] [kbdUUID]
     -- , shots = (shots ud)
     --   { partSysParts = ParticleStorage Nothing [] }
     }
@@ -83,12 +78,9 @@ drawMenu = do
     fontSize ctx 120
     fontFace ctx "modulo"
     textAlign ctx (S.fromList [AlignCenter,AlignTop])
-    -- (Bounds (V4 b0 b1 b2 b3)) <- textBoxBounds ctx x y' 150 "HASKELLOIDS"
     fillColor ctx (rgba 255 255 255 255)
     textBox ctx 0 200 800 "HASKELLOIDS"
     fillColor ctx (rgba 255 128 0 (alpha $ fade ud))
     fontSize ctx 40
     textBox ctx 0 350 800 "Press [Space] to Play\nPress [Esc] to exit"
     restore ctx
-  -- t <- getElapsedTime
-  -- liftIO $ drawSpinner (nano ud) 100 100 100 t

src/StateMachine.hs

@@ -14,20 +14,30 @@ import System.Random (randomRIO)
 
 import Types
 import Commons
--- import InGame
+import InGame
 import Menu
 
 instance StateMachine State UserData where
-  smLoad Menu = loadMenu
+  smLoad Menu = loadMenu (smClean Menu >> smLoad InGame)
 
-  -- smLoad InGame = loadGame
+  smLoad InGame = loadGame (smClean InGame >> smLoad Menu)
 
   smUpdate Menu = updateMenu
 
-  -- smUpdate InGame sec = updateGame sec
+  smUpdate InGame = updateGame
 
   smDraw Menu = drawMenu
 
-  -- smDraw InGame = drawGame
+  smDraw InGame = drawGame
 
   smEvent _ _ = return ()
+
+  smClean _ = do
+    ud <- getAffection
+    let (UUIDClean uuwin uukbd) = stateUUIDs ud
+        (Subsystems win kbd)    = subsystems ud
+    mapM_ (partUnSubscribe win) uuwin
+    mapM_ (partUnSubscribe kbd) uukbd
+    putAffection ud
+      { stateUUIDs = UUIDClean [] []
+      }

src/Types.hs

@@ -23,6 +23,7 @@ data UserData = UserData
   , font :: Font
   , subsystems :: Subsystems
   , haskImage :: Image
+  , stateUUIDs :: UUIDClean
   }
 
 data Ship = Ship
@@ -60,6 +61,11 @@ data Subsystems = Subsystems
   , 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
@@ -67,10 +73,16 @@ instance Participant Window WindowMessage UserData where
     subTups <- liftIO $ readTVarIO t
     return $ map snd subTups
 
-  partSubscribe (Window t) = generalSubscribe t
+  partSubscribe (Window t) funct = do
+    uuid <- genUUID
+    liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+    return $ MsgId uuid MsgWindowEmptyEvent
 
-  partUnSubscribe (Window t) uuid =
+  partUnSubscribe (Window t) (MsgId uuid _) =
-    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
+    liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid))
+    where
+      filterMsg :: (UUID, WindowMessage -> Affection UserData ()) -> UUID -> Bool
+      filterMsg (u, _) p = u /= p
 
 instance SDLSubsystem Window UserData where
   consumeSDLEvents = consumeSDLWindowEvents
@@ -82,15 +94,16 @@ instance Participant Keyboard KeyboardMessage UserData where
     subTups <- liftIO $ readTVarIO t
     return $ map snd subTups
 
-  partSubscribe (Keyboard t) = generalSubscribe t
+  partSubscribe (Keyboard t) funct = do
+    uuid <- genUUID
+    liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
+    return $ MsgId uuid MsgKeyboardEmptyEvent
 
-  partUnSubscribe (Keyboard t) uuid =
+  partUnSubscribe (Keyboard t) (MsgId uuid _) =
-    liftIO $ atomically $ modifyTVar' t (filter (\(u, _) -> u /= uuid))
+    liftIO $ atomically $ modifyTVar' t (filter (flip filterMsg uuid))
+    where
+      filterMsg :: (UUID, KeyboardMessage -> Affection UserData ()) -> UUID -> Bool
+      filterMsg (u, _) p = u /= p
 
 instance SDLSubsystem Keyboard UserData where
   consumeSDLEvents = consumeSDLKeyboardEvents
-
-generalSubscribe t funct = do
-  uuid <- genUUID
-  liftIO $ atomically $ modifyTVar' t ((uuid, funct) :)
-  return uuid