Merge branch 'statemachine' of github.com:nek0/haskelloids into statemachine

.gitignore

@@ -1,3 +1,6 @@
 .cabal-sandbox/
 cabal.sandbox.config
 dist/
+*.aux
+*.hp
+*.ps

haskelloids.cabal

@@ -56,6 +56,7 @@ executable haskelloids
   other-modules:      InGame
                     , Types 
                     , Commons
+                    , StateMachine
   
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    
@@ -65,7 +66,7 @@ executable haskelloids
                      , affection
                      , gegl
                      , babl
-                     , sdl2
+                     , sdl2 >= 2.1.3.1
                      , containers
                      , random
   

src/Commons.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE RecordWildCards #-}
+
 module Commons where
 
 import Affection
@@ -6,9 +8,10 @@ import GEGL
 import BABL
 
 import qualified Data.Map as M
+import Data.List (delete)
 import Data.Maybe (catMaybes)
 
-import Control.Monad (foldM)
+import Control.Monad (foldM, unless)
 
 import System.Random (randomRIO)
 
@@ -21,7 +24,7 @@ toR deg = deg * pi / 180
 
 clean :: UserData -> IO ()
 clean ud = do
-  mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud)
+  mapM_ (gegl_node_drop . (\h -> hNodeGraph h M.! "root")) (haskelloids ud)
   gegl_node_drop $ nodeGraph ud M.! KeyRoot
 
 load :: IO UserData
@@ -36,7 +39,7 @@ load = do
     , Property "height" $ PropertyDouble 600
     , Property "color" $ PropertyColor $ GEGL.RGBA 0 0 0.1 1
     ]
-  ship <- gegl_node_new_child root $ Operation "gegl:svg-load"
+  shipNode <- gegl_node_new_child root $ Operation "gegl:svg-load"
     [ Property "path" $ PropertyString "assets/ship.svg"
     , Property "width" $ PropertyInt 50
     , Property "height" $ PropertyInt 50
@@ -44,11 +47,11 @@ load = do
   pnop <- gegl_node_new_child root $ Operation "gegl:nop" []
   hnop <- gegl_node_new_child root $ Operation "gegl:nop" []
   fgnop <- gegl_node_new_child root $ Operation "gegl:nop" []
-  sover <- gegl_node_new_child root $ defaultOverOperation
+  sover <- gegl_node_new_child root defaultOverOperation
-  hover <- gegl_node_new_child root $ defaultOverOperation
+  hover <- gegl_node_new_child root defaultOverOperation
-  pover <- gegl_node_new_child root $ defaultOverOperation
+  pover <- gegl_node_new_child root defaultOverOperation
-  bgover <- gegl_node_new_child root $ defaultOverOperation
+  bgover <- gegl_node_new_child root defaultOverOperation
-  fgover <- gegl_node_new_child root $ defaultOverOperation
+  fgover <- gegl_node_new_child root defaultOverOperation
   translate <- gegl_node_new_child root $ Operation "gegl:translate"
     [ Property "x"        $ PropertyDouble 375
     , Property "y"        $ PropertyDouble 275
@@ -68,10 +71,10 @@ load = do
     [ Property "width" $ PropertyDouble 800
     , Property "height" $ PropertyDouble 600
     ]
-  buffer <- gegl_buffer_new (Just $ GeglRectangle 0 0 800 600) =<<
+  nbuffer <- gegl_buffer_new (Just $ GeglRectangle 0 0 800 600) =<<
     babl_format (PixelFormat BABL.RGBA CFfloat)
   sink <- gegl_node_new_child root $ Operation "gegl:copy-buffer"
-    [ Property "buffer" $ PropertyBuffer buffer
+    [ Property "buffer" $ PropertyBuffer nbuffer
     ]
   won <- gegl_node_new_child root $ textOperation
     [ Property "string" $ PropertyString "YOU WON!"
@@ -93,20 +96,48 @@ load = do
   -- vdeg <- gegl_node_new_child root $ Operation "gegl:video-degradation"
   --   [ Property "pattern" $ PropertyInt 8
   --   ]
-  gegl_node_link_many [ship, rotate, translate]
+  menuHeading <- gegl_node_new_child root $ textOperation
+    [ Property "string" $ PropertyString "Haskelloids"
+    , Property "font"   $ PropertyString "Modulo"
+    , Property "size"   $ PropertyDouble 100
+    , Property "color"  $ PropertyColor $ GEGL.RGBA 1 1 1 1
+    ]
+  menuText <- gegl_node_new_child root $ textOperation
+    [ Property "string" $ PropertyString "Press [Space] to start"
+    , Property "font"   $ PropertyString "Modulo"
+    , Property "size"   $ PropertyDouble 50
+    , Property "alignment" $ PropertyInt 1
+    , Property "color"  $ PropertyColor $ GEGL.RGBA 1 1 1 1
+    ]
+  menuTranslateHeading <- gegl_node_new_child root $ Operation "gegl:translate"
+    [ Property "x" $ PropertyDouble 150
+    , Property "y" $ PropertyDouble 100
+    , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
+    ]
+  menuTranslateText <- gegl_node_new_child root $ Operation "gegl:translate"
+    [ Property "x" $ PropertyDouble 130
+    , Property "y" $ PropertyDouble 300
+    , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic
+    ]
+  menuOver <- gegl_node_new_child root defaultOverOperation
+  gegl_node_link menuHeading menuTranslateHeading
+  gegl_node_link_many [menuText, menuTranslateText, menuOver]
+  _ <- gegl_node_connect_to menuTranslateHeading "output" menuOver "aux"
+  gegl_node_link_many [shipNode, rotate, translate]
   gegl_node_link_many [bgover, pover, hover, sover, crop, fgover, pixelize, vignette, sink]
-  _ <- gegl_node_connect_to translate "output" sover "aux"
+  -- _ <- gegl_node_connect_to translate "output" sover "aux"
   _ <- gegl_node_connect_to pnop "output" pover "aux"
   _ <- gegl_node_connect_to hnop "output" hover "aux"
   _ <- gegl_node_connect_to bg "output" bgover "aux"
   liftIO $ gegl_node_link fgnop fgtranslate
-  _ <- gegl_node_connect_to fgtranslate "output" fgover "aux"
+  -- _ <- gegl_node_connect_to fgtranslate "output" fgover "aux"
+  _ <- gegl_node_connect_to fgnop "output" fgover "aux"
   traceM "nodes complete"
   myMap <- return $ M.fromList
     [ (KeyRoot, root)
-    , (KeyTranslate, translate)
+    , (KeyShip, shipNode)
-    , (KeyRotate, rotate)
+    , (KeyShipTranslate, translate)
-    , (KeyShip, ship)
+    , (KeyShipRotate, rotate)
     , (KeyPNop, pnop)
     , (KeyHNop, hnop)
     , (KeyCrop, crop)
@@ -117,6 +148,10 @@ load = do
     , (KeyPixelize, pixelize)
     , (KeyFGOver, fgover)
     , (KeyFGNop, fgnop)
+    , (KeyFGTrans, fgtranslate)
+    , (KeyMenuHeading, menuTranslateHeading)
+    , (KeyMenuText, menuText)
+    , (KeyMenuOver, menuOver)
     ]
   traceM "built map"
   hs <- catMaybes <$> foldM (\acc _ -> do
@@ -136,12 +171,14 @@ load = do
       , sRot = 0
       , sFlange = rotate
       }
-    , buffer = buffer
+    , buffer = nbuffer
-    , shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer
+    , shots = ParticleSystem (ParticleStorage Nothing []) pnop nbuffer
-    , haskelloids = hs
+    -- , haskelloids = hs
+    , haskelloids = []
     , wonlost = False
     , pixelSize = 3
-    , state = InGame
+    , state = Menu
+    , fade = FadeIn 1
     }
 
 insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid]
@@ -199,3 +236,149 @@ insertHaskelloid hasks split (px, py) = do
       , ("rot", tempRot)
       ]
     } : hasks
+
+haskelloidShotDown :: Haskelloid -> Affection UserData ()
+haskelloidShotDown h = do
+  ud <- getAffection
+  -- liftIO $ traceIO $ show $ length $ haskelloids ud
+  let redHaskelloids = delete h (haskelloids ud)
+  newHaskelloids <- catMaybes <$> foldM
+    (\acc _ ->
+      if hDiv h < 4
+      then
+        liftIO $ insertHaskelloid acc (Just $ hDiv h) $ hPos h
+      else
+        return $ Nothing : acc
+      )
+    (map Just redHaskelloids) ([0..1] :: [Int])
+  liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
+  liftIO $ gegl_node_link_many $ map hFlange newHaskelloids
+  if not $ null newHaskelloids
+  then 
+    liftIO $ gegl_node_link
+      (last $ map hFlange newHaskelloids)
+      (nodeGraph ud M.! KeyHNop)
+  else do
+    liftIO $ traceIO "YOU WON!"
+    _ <- liftIO $ gegl_node_link
+      (nodeGraph ud M.! KeyWon)
+      (nodeGraph ud M.! KeyFGTrans)
+    _ <- liftIO $ gegl_node_connect_to
+      (nodeGraph ud M.! KeyFGTrans)
+      "output"
+      (nodeGraph ud M.! KeyFGOver)
+      "aux"
+    _ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
+    putAffection ud
+      { wonlost = True
+      }
+  ud2 <- getAffection
+  putAffection ud2
+    { haskelloids = newHaskelloids
+    }
+
+updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
+updateHaskelloid sec h@Haskelloid{..} = do
+  let newX = fst hPos + sec * fst hVel
+      newY = snd hPos + sec * snd hVel
+      newRot = hRot + hPitch * sec
+      (nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv)
+  -- liftIO $ traceIO $ "moving to: " ++ show nnx ++ " " ++ show nny
+  liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate"
+    [ Property "x" $ PropertyDouble nnx
+    , Property "y" $ PropertyDouble nny
+    ]
+  liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate"
+    [ Property "degrees" $ PropertyDouble newRot
+    ]
+  ud <- getAffection
+  lost <- 
+    case state ud of
+      InGame -> liftIO $ gegl_rectangle_intersect
+        (GeglRectangle (floor nnx) (floor nny) (100 `div` hDiv) (100 `div` hDiv))
+        (GeglRectangle
+          (floor $ fst $ sPos $ ship ud)
+          (floor $ snd $ sPos $ ship ud)
+          50
+          50
+          )
+      _ -> return Nothing
+  maybe (return ()) (const $ do
+    lose
+    putAffection ud {wonlost = True}
+    ) lost
+  return h
+    { hPos = (nnx, nny)
+    , hRot = newRot
+    }
+
+wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t)
+wrapAround (nx, ny) width = (nnx, nny)
+  where
+    nnx
+      | nx > 800    = nx - (800 + width)
+      | nx < -width = nx + 800 + width
+      | otherwise   = nx
+    nny
+      | ny > 600    = ny - (600 + width)
+      | ny < -width = ny + 600 + width
+      | otherwise   = ny
+
+shotsUpd :: Double -> Particle -> Affection UserData Particle
+shotsUpd sec part@Particle{..} = do
+  let newX = fst particlePosition + sec * fromIntegral (fst particleVelocity)
+      newY = snd particlePosition + sec * fromIntegral (snd particleVelocity)
+      (nnx, nny) = wrapAround (newX, newY) 4
+  liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
+    [ Property "x" $ PropertyDouble nnx
+    , Property "y" $ PropertyDouble nny
+    ]
+  ud <- getAffection
+  inters <- catMaybes <$> mapM (\h -> do
+    col <- liftIO $ gegl_rectangle_intersect
+      (GeglRectangle (floor nnx) (floor nny) 4 4)
+      (GeglRectangle
+        (floor $ fst $ hPos h)
+        (floor $ snd $ hPos h)
+        (100 `div` hDiv h)
+        (100 `div` hDiv h)
+        )
+    case col of
+      Just _ -> return $ Just h
+      Nothing -> return Nothing
+    ) (haskelloids ud)
+  unless (null inters) $
+    haskelloidShotDown $ head inters
+  lost <- liftIO $ gegl_rectangle_intersect
+    (GeglRectangle (floor nnx) (floor nny) 4 4)
+    (GeglRectangle
+      (floor $ fst $ sPos $ ship ud)
+      (floor $ snd $ sPos $ ship ud)
+      50
+      50
+      )
+  maybe (return ()) (const lose) lost
+  return part
+    { particlePosition = (nnx, nny)
+    , particleTimeToLive = if not $ null inters then 0 else particleTimeToLive
+    }
+
+shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()
+shotsDraw _ _ _ = return ()
+
+lose :: Affection UserData ()
+lose = do
+  ud <- getAffection
+  liftIO $ traceIO "YOU LOST!"
+  _ <- liftIO $ gegl_node_link
+    (nodeGraph ud M.! KeyLost)
+    (nodeGraph ud M.! KeyFGTrans)
+  _ <- liftIO $ gegl_node_connect_to
+    (nodeGraph ud M.! KeyFGTrans)
+    "output"
+    (nodeGraph ud M.! KeyFGOver)
+    "aux"
+  _ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
+  putAffection ud
+    { wonlost = True
+    }

src/InGame.hs

@@ -5,13 +5,125 @@ import qualified SDL
 import GEGL
 
 import qualified Data.Map as M
+import Data.Maybe (catMaybes)
 
-import Control.Monad (when)
+import Control.Monad (when, foldM)
+
+import System.Random (randomRIO)
 
 import Debug.Trace
 
 import Types
 import Commons
+import Menu
+
+loadGame :: Affection UserData ()
+loadGame = do
+  liftIO $ traceIO "loading game"
+  ud <- getAffection
+  _ <- liftIO $ gegl_node_connect_to
+    (nodeGraph ud M.! KeyShipTranslate)
+    "output"
+    (nodeGraph ud M.! KeyShipOver)
+    "aux"
+  liftIO $ traceIO "nodes connected"
+  hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do
+    coords <- liftIO excludeShip
+    insertHaskelloid acc Nothing coords
+    ) [] ([0..9] :: [Int])
+  liftIO $ traceIO "inserted haskelloids"
+  liftIO $ gegl_node_link_many $ map hFlange hs
+  liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop)
+  liftIO $ gegl_node_disconnect
+    (nodeGraph ud M.! KeyFGOver)
+    "aux"
+  liftIO $ traceIO "nodes linked"
+  putAffection ud
+    { haskelloids = hs
+    , wonlost = False
+    , shots = ParticleSystem
+      (ParticleStorage Nothing [])
+      (nodeGraph ud M.! KeyPNop)
+      (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
+    pd <- getAffection
+    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
+    }
+  -- liftIO $ traceIO $ show $ length nhs
+  ud3 <- getAffection
+  ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
+  ud4 <- getAffection
+  putAffection ud4
+    { shots = ups
+    }
+
+drawGame :: Affection UserData ()
+drawGame = do
+  ud <- getAffection
+  liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
+  present
+    (GeglRectangle 0 0 800 600)
+    (buffer ud)
+    True
 
 handleGameEvent :: SDL.EventPayload -> Affection UserData ()
 handleGameEvent e = do
@@ -20,7 +132,7 @@ handleGameEvent e = do
   sec <- getDelta
   case e of
     SDL.KeyboardEvent dat ->
-      case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
+      case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
         SDL.KeycodeLeft -> do
           ud <- getAffection
           when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $
@@ -40,8 +152,8 @@ handleGameEvent e = do
         SDL.KeycodeUp ->
           when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
             ud <- getAffection
-            let vx = -10 * (sin (toR $ (sRot $ ship ud))) + fst (sVel $ ship ud)
+            let vx = -10 * sin (toR $ sRot $ ship ud) + fst (sVel $ ship ud)
-                vy = -10 * (cos (toR $ (sRot $ ship ud))) + snd (sVel $ ship ud)
+                vy = -10 * cos (toR $ sRot $ ship ud) + snd (sVel $ ship ud)
             putAffection ud
               { ship = (ship ud)
                 { sVel = (vx, vy)
@@ -56,19 +168,19 @@ handleGameEvent e = do
               , Property "size-y" $ PropertyInt 8
               ]
             -- ad <- get
-            let posX = (fst $ sPos $ ship ud) + 23 - 35 * sin (toR $ sRot $ ship ud)
+            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)
+                posY = snd (sPos $ ship ud) + 23 - 35 * cos (toR $ sRot $ ship ud)
-            tempRoot <- liftIO $ gegl_node_new
+            tempRoot <- liftIO gegl_node_new
             tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle"
-              [ Property "x" $ PropertyDouble $ posX
+              [ Property "x" $ PropertyDouble posX
-              , Property "y" $ PropertyDouble $ posY
+              , Property "y" $ PropertyDouble posY
               , Property "width" $ PropertyDouble 4
               , Property "height" $ PropertyDouble 4
-              , Property "color" $ PropertyColor $ (GEGL.RGBA 1 1 1 1)
+              , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1
               ]
-            tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
+            tempOver <- liftIO $ gegl_node_new_child tempRoot defaultOverOperation
             _ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux"
-            ips <- insertParticle (shots ud) $
+            ips <- insertParticle (shots ud)
               Particle
                 { particleTimeToLive = 5
                 , particleCreation = elapsedTime ad
@@ -93,7 +205,7 @@ handleGameEvent e = do
               , pixelSize = 8
               }
         SDL.KeycodeR ->
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
+          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && wonlost wd) $ do
             liftIO $ traceIO "reloading"
             liftIO $ clean wd
             nd <- liftIO $ load

src/Main.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE OverloadedStrings, RecordWildCards #-}
+{-# LANGUAGE OverloadedStrings #-}
 module Main where
 
 import Affection
@@ -16,11 +16,14 @@ import Debug.Trace
 -- internal imports
 
 import Types
-import InGame
 import Commons
+import StateMachine
+
+import Menu
+import InGame
 
 main :: IO ()
-main = withAffection $ AffectionConfig
+main = withAffection AffectionConfig
   { initComponents = All
   , windowTitle    = "Haskelloids"
   , windowConfig   = defaultWindow
@@ -81,17 +84,11 @@ update sec = do
     , shots = ups
     }
 
-wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t)
+update :: Double -> [SDL.Event] -> Affection UserData ()
-wrapAround (nx, ny) width = (nnx, nny)
+update sec evs = do
-  where
+  wd <- getAffection
-    nnx =
+  smUpdate (state wd) sec
-      if nx > 800
+  mapM_ (smEvent (state wd) sec) evs
-      then nx - (800 + width)
-      else if nx < -width then nx + 800 + width else nx
-    nny =
-      if ny > 600
-      then ny - (600 + width)
-      else if ny < -width then ny + 600 + width else ny
 
 draw :: Affection UserData ()
 draw = do

src/Menu.hs

@@ -0,0 +1,19 @@
+module Menu where
+
+import Affection
+import qualified SDL
+
+import Debug.Trace
+
+import Types
+
+handleMenuEvent :: Double -> SDL.Event -> Affection UserData ()
+handleMenuEvent sec e = do
+  ad <- get
+  case SDL.eventPayload e of
+    SDL.WindowClosedEvent _ -> do
+      traceM "seeya!"
+      put ad
+        { quitEvent = True
+        }
+    _ -> return ()

src/StateMachine.hs

@@ -0,0 +1,105 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module StateMachine where
+
+import Affection
+import qualified SDL
+import GEGL
+
+import qualified Data.Map as M
+import Data.Maybe (catMaybes)
+
+import Control.Monad (foldM, when)
+
+import System.Random (randomRIO)
+
+import Types
+import Commons
+import InGame
+
+class StateMachine a us where
+  smLoad   :: a -> Affection us ()
+  smUpdate :: a -> Double -> Affection us ()
+  smEvent  :: a -> Double -> SDL.Event -> Affection us ()
+  smDraw   :: a -> Affection us ()
+  smClean  :: a -> Affection us ()
+
+instance StateMachine State UserData where
+  smLoad Menu = do
+    ud <- getAffection
+    liftIO $ gegl_node_connect_to
+      (nodeGraph ud M.! KeyMenuOver)
+      "output"
+      (nodeGraph ud M.! KeyFGOver)
+      "aux"
+    hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do
+      px <- randomRIO (0, 800)
+      py <- randomRIO (0, 600)
+      insertHaskelloid acc Nothing (px, py)
+      ) [] ([0..9] :: [Int])
+    liftIO $ gegl_node_link_many $ map hFlange hs
+    liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop)
+    liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyPNop) "input"
+    putAffection ud
+      { haskelloids = hs
+      , fade = FadeIn 1
+      , state = Menu
+      , shots = (shots ud)
+        { partSysParts = ParticleStorage Nothing [] }
+      }
+
+  smLoad InGame = loadGame
+
+  smUpdate Menu sec = do
+    ud <- getAffection
+    nhs <- mapM (updateHaskelloid sec) (haskelloids ud)
+    case fade ud of
+      FadeIn ttl -> do
+        liftIO $ gegl_node_set (nodeGraph ud M.! KeyMenuText) $
+          Operation "gegl:text"
+            [ Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 (1.1 - ttl)
+            ]
+        putAffection ud
+          { fade = if (ttl - sec) > 0 then FadeIn (ttl - sec) else FadeOut 1
+          , haskelloids = nhs
+          }
+      FadeOut ttl -> do
+        liftIO $ gegl_node_set (nodeGraph ud M.! KeyMenuText) $
+          Operation "gegl:text"
+            [ Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 ttl
+            ]
+        putAffection ud
+          { fade = if (ttl - sec) > 0 then FadeOut (ttl - sec) else FadeIn 1
+          , haskelloids = nhs
+          }
+
+  smUpdate InGame sec = updateGame sec
+
+  smEvent Menu _ e = do
+    ad <- get
+    case SDL.eventPayload e of
+      SDL.KeyboardEvent dat ->
+        case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
+          SDL.KeycodeSpace ->
+            when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
+              ud <- getAffection
+              liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyFGNop) "input"
+              smLoad InGame
+          _ -> return ()
+      SDL.WindowClosedEvent _ ->
+        put ad
+          { quitEvent = True
+          }
+      _ -> return ()
+
+  smEvent InGame sec e = handleGameEvent (smLoad Menu) sec e
+
+  smDraw Menu = do
+    ud <- getAffection
+    liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
+    present
+      (GeglRectangle 0 0 800 600)
+      (buffer ud)
+      True
+
+  smDraw InGame = drawGame

src/Types.hs

@@ -1,9 +1,10 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+
 module Types where
 
 import Affection hiding (StateMachine)
 import qualified SDL
 import GEGL
-import BABL
 import qualified Data.Map as M
 
 data UserData = UserData
@@ -15,7 +16,8 @@ data UserData = UserData
   -- , debris :: ParticleSystem
   , wonlost :: Bool
   , pixelSize :: Int
-  , state :: StateMachine
+  , state :: State
+  , fade :: MenuFade
   }
 
 data Ship = Ship
@@ -37,9 +39,9 @@ data Haskelloid = Haskelloid
 
 data NodeKey
   = KeyRoot
-  | KeyTranslate
-  | KeyRotate
   | KeyShip
+  | KeyShipTranslate
+  | KeyShipRotate
   | KeyPNop
   | KeyHNop
   | KeyCrop
@@ -50,9 +52,19 @@ data NodeKey
   | KeyPixelize
   | KeyFGOver
   | KeyFGNop
+  | KeyFGTrans
+  | KeyMenuHeading
+  | KeyMenuText
+  | KeyMenuStart
+  | KeyMenuHighscore
+  | KeyMenuOver
   deriving (Ord, Eq)
 
-data StateMachine
+data State
   = Menu
   | HighScore
   | InGame
+
+data MenuFade
+  = FadeIn Double
+  | FadeOut Double