splitting things up

haskelloids.cabal

@@ -53,7 +53,9 @@ executable haskelloids
   ghc-options:         -Wall
   
   -- Modules included in this executable, other than Main.
-  -- other-modules:       
+  other-modules:      InGame
+                    , Types 
+                    , Commons
   
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    

src/Commons.hs

@@ -0,0 +1,192 @@
+module Commons where
+
+import Affection
+import qualified SDL
+import GEGL
+import BABL
+
+import qualified Data.Map as M
+import Data.Maybe (catMaybes)
+
+import Control.Monad (foldM)
+
+import System.Random (randomRIO)
+
+import Debug.Trace
+
+import Types
+
+toR :: Double -> Double
+toR deg = deg * pi / 180
+
+clean :: UserData -> IO ()
+clean ud = do
+  mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud)
+  gegl_node_drop $ nodeGraph ud M.! KeyRoot
+
+load :: SDL.Surface -> IO UserData
+load _ = do
+  traceM "loading"
+  root <- gegl_node_new
+  traceM "root node"
+  bg <- gegl_node_new_child root $ Operation "gegl:rectangle"
+    [ Property "x" $ PropertyDouble 0
+    , Property "y" $ PropertyDouble 0
+    , Property "width" $ PropertyDouble 800
+    , Property "height" $ PropertyDouble 600
+    , Property "color" $ PropertyColor $ GEGL.RGBA 0 0 0.1 1
+    ]
+  ship <- gegl_node_new_child root $ Operation "gegl:svg-load"
+    [ Property "path" $ PropertyString "assets/ship.svg"
+    , Property "width" $ PropertyInt 50
+    , Property "height" $ PropertyInt 50
+    ]
+  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
+  hover <- gegl_node_new_child root $ defaultOverOperation
+  pover <- gegl_node_new_child root $ defaultOverOperation
+  bgover <- 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
+    , Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
+    ]
+  fgtranslate <- gegl_node_new_child root $ Operation "gegl:translate"
+    [ Property "x"        $ PropertyDouble 150
+    , Property "y"        $ PropertyDouble 250
+    , Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
+    ]
+  rotate <- gegl_node_new_child root $ Operation "gegl:rotate"
+    [ Property "origin-x" $ PropertyDouble 25
+    , Property "origin-y" $ PropertyDouble 25
+    , Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
+    ]
+  crop <- gegl_node_new_child root $ Operation "gegl:crop"
+    [ Property "width" $ PropertyDouble 800
+    , Property "height" $ PropertyDouble 600
+    ]
+  buffer <- 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
+    ]
+  won <- gegl_node_new_child root $ textOperation
+    [ Property "string" $ PropertyString "YOU WON!"
+    , Property "font"   $ PropertyString "Modulo"
+    , Property "size"   $ PropertyDouble 100
+    , Property "color"  $ PropertyColor $ GEGL.RGBA 1 1 1 1
+    ]
+  lost <- gegl_node_new_child root $ textOperation
+    [ Property "string" $ PropertyString "YOU LOST!"
+    , Property "font"   $ PropertyString "Modulo"
+    , Property "size"   $ PropertyDouble 100
+    , Property "color"  $ PropertyColor $ GEGL.RGBA 1 1 1 1
+    ]
+  vignette <- gegl_node_new_child root $ Operation "gegl:vignette" []
+  -- pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize"
+  pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize"
+    [ Property "size-x" $ PropertyInt 3
+    , Property "size-y" $ PropertyInt 3
+    ]
+  -- vdeg <- gegl_node_new_child root $ Operation "gegl:video-degradation"
+  --   [ Property "pattern" $ PropertyInt 8
+  --   ]
+  gegl_node_link_many [ship, 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 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"
+  traceM "nodes complete"
+  myMap <- return $ M.fromList
+    [ (KeyRoot, root)
+    , (KeyTranslate, translate)
+    , (KeyRotate, rotate)
+    , (KeyShip, ship)
+    , (KeyPNop, pnop)
+    , (KeyHNop, hnop)
+    , (KeyCrop, crop)
+    , (KeyShipOver, sover)
+    , (KeySink, sink)
+    , (KeyWon, won)
+    , (KeyLost, lost)
+    , (KeyPixelize, pixelize)
+    , (KeyFGOver, fgover)
+    , (KeyFGNop, fgnop)
+    ]
+  hs <- catMaybes <$> foldM (\acc _ -> do
+    px <- liftIO $ randomRIO (0, 800)
+    py <- liftIO $ 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) hnop
+  return $ UserData
+    { nodeGraph = myMap
+    , ship      = Ship
+      { sPos = (375, 275)
+      , sVel = (0, 0)
+      , sRot = 0
+      , sFlange = rotate
+      }
+    , buffer = buffer
+    , shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer
+    , haskelloids = hs
+    , wonlost = False
+    , pixelSize = 3
+    , state = InGame
+    }
+
+insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid]
+insertHaskelloid hasks split (px, py) = do
+  -- liftIO $ traceIO "inserting haskelloid"
+  vx <- liftIO $ randomRIO (-10, 10)
+  vy <- liftIO $ randomRIO (-10, 10)
+  rdiv <- case split of
+    Nothing -> liftIO $ randomRIO (1, 2)
+    Just x -> return $ x + 1
+  rot <- liftIO $ randomRIO (0, 360)
+  pitch <- liftIO $ randomRIO (-45, 45)
+  tempRoot <- liftIO $ gegl_node_new
+  tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
+  tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load"
+    [ Property "path" $ PropertyString "assets/haskelloid.svg"
+    , Property "width" $ PropertyInt (100 `div` rdiv)
+    , Property "height" $ PropertyInt (100 `div` rdiv)
+    ]
+  tempTrans <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:translate"
+    [ Property "x" $ PropertyDouble $ px + (100 / fromIntegral rdiv / 2)
+    , Property "y" $ PropertyDouble $ py + (100 / fromIntegral rdiv / 2)
+    , Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
+    ]
+  tempRot <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rotate"
+    [ Property "origin-x" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
+    , Property "origin-y" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
+    , Property "degrees" $ PropertyDouble rot
+    , Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
+    ]
+  liftIO $ gegl_node_link_many [tempSvg, tempRot, tempTrans]
+  _ <- liftIO $ gegl_node_connect_to tempTrans "output" tempOver "aux"
+  return $ Just  Haskelloid
+    { hPos =
+      ( px + (100 / 2 / fromIntegral rdiv)
+      , py + (100 / 2 / fromIntegral rdiv)
+      )
+    , hVel = (vx, vy)
+    , hRot = rot
+    , hPitch = pitch
+    , hDiv = rdiv
+    , hFlange = tempOver
+    , hNodeGraph = M.fromList
+      [ ("root", tempRoot)
+      , ("over", tempOver)
+      , ("svg", tempSvg)
+      , ("trans", tempTrans)
+      , ("rot", tempRot)
+      ]
+    } : hasks

src/InGame.hs

@@ -0,0 +1,108 @@
+module InGame where
+
+import Affection
+import qualified SDL
+import GEGL
+
+import qualified Data.Map as M
+
+import Control.Monad (when)
+
+import Debug.Trace
+
+import Types
+import Commons
+
+handleGameEvent :: Double -> SDL.Event -> Affection UserData ()
+handleGameEvent sec e = do
+  ad <- get
+  wd <- getAffection
+  case SDL.eventPayload e of
+    SDL.KeyboardEvent dat ->
+      case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
+        SDL.KeycodeLeft -> do
+          ud <- getAffection
+          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $
+            putAffection ud
+              { ship = (ship ud)
+                { sRot = (sRot $ ship ud) + 270 * sec
+                }
+              }
+        SDL.KeycodeRight -> do
+          ud <- getAffection
+          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
+            putAffection ud
+              { ship = (ship ud)
+                { sRot = (sRot $ ship ud) - 270 * sec
+                }
+              }
+        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)
+                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 && not (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 = Rad 0
+                , particleVelocity =
+                  -- ( (floor $ -200 * (sin $ toR $ (sRot $ ship ud) + (fst $ sVel $ ship ud)))
+                  -- , (floor $ -200 * (cos $ toR $ (sRot $ ship ud) + (snd $ sVel $ ship ud)))
+                  ( (floor $ -200 * (sin $ toR $ sRot $ ship ud))
+                  , (floor $ -200 * (cos $ toR $ sRot $ ship ud))
+                  )
+                , particlePitchRate = Rad 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) $ do
+            liftIO $ traceIO "reloading"
+            liftIO $ clean wd
+            nd <- liftIO $ load $ drawSurface ad
+            putAffection nd
+        _ -> return ()
+    SDL.WindowClosedEvent _ -> do
+      traceM "seeya!"
+      put ad
+        { quitEvent = True
+        }
+    _ -> return ()

src/Main.hs

@@ -4,7 +4,6 @@ module Main where
 import Affection
 import qualified SDL
 import GEGL
-import BABL
 
 import Data.List (delete)
 import qualified Data.Map as M
@@ -12,10 +11,14 @@ import Data.Maybe (catMaybes)
 
 import Control.Monad (when, foldM)
 
-import System.Random (randomRIO)
-
 import Debug.Trace
 
+-- internal imports
+
+import Types
+import InGame
+import Commons
+
 main :: IO ()
 main = withAffection $ AffectionConfig
   { initComponents = All
@@ -28,173 +31,10 @@ main = withAffection $ AffectionConfig
   , cleanUp        = clean
   }
 
-load :: SDL.Surface -> IO UserData
-load _ = do
-  traceM "loading"
-  root <- gegl_node_new
-  traceM "root node"
-  bg <- gegl_node_new_child root $ Operation "gegl:rectangle"
-    [ Property "x" $ PropertyDouble 0
-    , Property "y" $ PropertyDouble 0
-    , Property "width" $ PropertyDouble 800
-    , Property "height" $ PropertyDouble 600
-    , Property "color" $ PropertyColor $ GEGL.RGBA 0 0 0.1 1
-    ]
-  ship <- gegl_node_new_child root $ Operation "gegl:svg-load"
-    [ Property "path" $ PropertyString "assets/ship.svg"
-    , Property "width" $ PropertyInt 50
-    , Property "height" $ PropertyInt 50
-    ]
-  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
-  hover <- gegl_node_new_child root $ defaultOverOperation
-  pover <- gegl_node_new_child root $ defaultOverOperation
-  bgover <- 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
-    , Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
-    ]
-  fgtranslate <- gegl_node_new_child root $ Operation "gegl:translate"
-    [ Property "x"        $ PropertyDouble 150
-    , Property "y"        $ PropertyDouble 250
-    , Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
-    ]
-  rotate <- gegl_node_new_child root $ Operation "gegl:rotate"
-    [ Property "origin-x" $ PropertyDouble 25
-    , Property "origin-y" $ PropertyDouble 25
-    , Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
-    ]
-  crop <- gegl_node_new_child root $ Operation "gegl:crop"
-    [ Property "width" $ PropertyDouble 800
-    , Property "height" $ PropertyDouble 600
-    ]
-  buffer <- 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
-    ]
-  won <- gegl_node_new_child root $ textOperation
-    [ Property "string" $ PropertyString "YOU WON!"
-    , Property "font"   $ PropertyString "Modulo"
-    , Property "size"   $ PropertyDouble 100
-    , Property "color"  $ PropertyColor $ GEGL.RGBA 1 1 1 1
-    ]
-  lost <- gegl_node_new_child root $ textOperation
-    [ Property "string" $ PropertyString "YOU LOST!"
-    , Property "font"   $ PropertyString "Modulo"
-    , Property "size"   $ PropertyDouble 100
-    , Property "color"  $ PropertyColor $ GEGL.RGBA 1 1 1 1
-    ]
-  vignette <- gegl_node_new_child root $ Operation "gegl:vignette" []
-  -- pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize"
-  pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize"
-    [ Property "size-x" $ PropertyInt 3
-    , Property "size-y" $ PropertyInt 3
-    ]
-  -- vdeg <- gegl_node_new_child root $ Operation "gegl:video-degradation"
-  --   [ Property "pattern" $ PropertyInt 8
-  --   ]
-  gegl_node_link_many [ship, 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 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"
-  traceM "nodes complete"
-  myMap <- return $ M.fromList
-    [ (KeyRoot, root)
-    , (KeyTranslate, translate)
-    , (KeyRotate, rotate)
-    , (KeyShip, ship)
-    , (KeyPNop, pnop)
-    , (KeyHNop, hnop)
-    , (KeyCrop, crop)
-    , (KeyShipOver, sover)
-    , (KeySink, sink)
-    , (KeyWon, won)
-    , (KeyLost, lost)
-    , (KeyPixelize, pixelize)
-    , (KeyFGOver, fgover)
-    , (KeyFGNop, fgnop)
-    ]
-  hs <- catMaybes <$> foldM (\acc _ -> do
-    px <- liftIO $ randomRIO (0, 800)
-    py <- liftIO $ 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) hnop
-  return $ UserData
-    { nodeGraph = myMap
-    , ship      = Ship
-      { sPos = (375, 275)
-      , sVel = (0, 0)
-      , sRot = 0
-      , sFlange = rotate
-      }
-    , buffer = buffer
-    , shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer
-    , haskelloids = hs
-    , wonlost = False
-    , pixelSize = 3
-    }
-
-data UserData = UserData
-  { nodeGraph :: M.Map NodeKey GeglNode
-  , ship :: Ship
-  , buffer :: GeglBuffer
-  , haskelloids :: [Haskelloid]
-  , shots :: ParticleSystem
-  -- , debris :: ParticleSystem
-  , wonlost :: Bool
-  , pixelSize :: Int
-  }
-
-data Ship = Ship
-  { sPos :: (Double, Double)
-  , sVel :: (Double, Double)
-  , sRot :: Double
-  , sFlange :: GeglNode
-  }
-
-data Haskelloid = Haskelloid
-  { hPos :: (Double, Double)
-  , hVel :: (Double, Double)
-  , hRot :: Double
-  , hPitch :: Double
-  , hDiv :: Int
-  , hFlange :: GeglNode
-  , hNodeGraph :: M.Map String GeglNode
-  } deriving (Eq)
-
-data NodeKey
-  = KeyRoot
-  | KeyTranslate
-  | KeyRotate
-  | KeyShip
-  | KeyPNop
-  | KeyHNop
-  | KeyCrop
-  | KeyShipOver
-  | KeySink
-  | KeyWon
-  | KeyLost
-  | KeyPixelize
-  | KeyFGOver
-  | KeyFGNop
-  deriving (Ord, Eq)
-
 update :: Double -> Affection UserData ()
 update sec = do
   -- traceM $ (show $ 1 / sec) ++ " FPS"
   ad <- get
-  evs <- SDL.pollEvents
   wd <- getAffection
   when (((floor $ elapsedTime ad :: Int) * 100) `mod` 10 < 2 && pixelSize wd > 3) $ do
     liftIO $ gegl_node_set (nodeGraph wd M.! KeyPixelize) $ Operation "gegl:pixelize"
@@ -205,90 +45,12 @@ update sec = do
     putAffection pd
       { pixelSize = pixelSize wd -1
       }
+  evs <- SDL.pollEvents
   mapM_ (\e ->
-    case SDL.eventPayload e of
+    case state wd of
-      SDL.KeyboardEvent dat ->
+      InGame ->
-        case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of
+        handleGameEvent sec e
-           SDL.KeycodeLeft -> do
+      _ -> error "not yet implemented"
-             ud <- getAffection
-             when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $
-               putAffection ud
-                 { ship = (ship ud)
-                   { sRot = (sRot $ ship ud) + 270 * sec
-                   }
-                 }
-           SDL.KeycodeRight -> do
-             ud <- getAffection
-             when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $
-               putAffection ud
-                 { ship = (ship ud)
-                   { sRot = (sRot $ ship ud) - 270 * sec
-                   }
-                 }
-           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)
-                   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 && not (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 = Rad 0
-                   , particleVelocity =
-                     -- ( (floor $ -200 * (sin $ toR $ (sRot $ ship ud) + (fst $ sVel $ ship ud)))
-                     -- , (floor $ -200 * (cos $ toR $ (sRot $ ship ud) + (snd $ sVel $ ship ud)))
-                     ( (floor $ -200 * (sin $ toR $ sRot $ ship ud))
-                     , (floor $ -200 * (cos $ toR $ sRot $ ship ud))
-                     )
-                   , particlePitchRate = Rad 0
-                   , particleRootNode = tempRoot
-                   , particleNodeGraph = M.fromList
-                     [ ("root", tempRoot)
-                     , ("over", tempOver)
-                     , ("rect", tempRect)
-                     ]
-                   , particleStackCont = tempOver
-                   , particleDrawFlange = tempOver
-                   }
-               putAffection $ ud
-                 { shots = ips
-                 , pixelSize = 8
-                 }
-           _ -> return ()
-      SDL.WindowClosedEvent _ -> do
-        traceM "seeya!"
-        put ad
-          { quitEvent = True
-          }
-      _ -> return ()
     ) evs
   ud2 <- getAffection
   nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
@@ -330,7 +92,6 @@ wrapAround (nx, ny) width = (nnx, nny)
 
 draw :: Affection UserData ()
 draw = do
-  -- traceM "drawing"
   ud <- getAffection
   liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
   -- mintr <- liftIO $ gegl_rectangle_intersect
@@ -346,15 +107,8 @@ draw = do
   present
     (GeglRectangle 0 0 800 600)
     (buffer ud)
-    -- (not $ wonlost ud)
     True
 
-clean :: UserData -> IO ()
-clean ud = gegl_node_drop $ nodeGraph ud M.! KeyRoot
-
-toR :: Double -> Double
-toR deg = deg * pi / 180
-
 shotsUpd :: Double -> Particle -> Affection UserData Particle
 shotsUpd sec part@Particle{..} = do
   let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
@@ -398,27 +152,9 @@ shotsUpd sec part@Particle{..} = do
 
 haskelloidShotDown :: Haskelloid -> Affection UserData ()
 haskelloidShotDown h = do
-  -- liftIO $ traceIO "Haskelloid shot down"
   liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
   ud <- getAffection
   let redHaskelloids = delete h (haskelloids ud)
-  -- mproducer <- liftIO $ gegl_node_get_producer
-  --   (hFlange h)
-  --   "input"
-  -- case mproducer of
-  --   Just (prod, padname) -> do
-  --     consumers <- liftIO $ gegl_node_get_consumers
-  --       (hFlange h)
-  --       "output"
-  --     liftIO $ mapM_ (\(node, inpad) -> do
-  --       traceIO "klink"
-  --       gegl_node_connect_to
-  --         prod
-  --         padname
-  --         node
-  --         inpad
-  --         ) consumers
-  --   Nothing -> return ()
   liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
   newHaskelloids <- catMaybes <$> foldM
     (\acc _ ->
@@ -429,7 +165,6 @@ haskelloidShotDown h = do
         return $ Nothing : acc
       )
     (map Just redHaskelloids) ([0..1] :: [Int])
-  -- liftIO $ traceIO $ show $ length newHaskelloids
   liftIO $ gegl_node_link_many $ map hFlange newHaskelloids
   if not $ null newHaskelloids
   then 
@@ -481,55 +216,6 @@ updateHaskelloid sec h@Haskelloid{..} = do
     , hRot = newRot
     }
 
-insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid]
-insertHaskelloid hasks split (px, py) = do
-  -- liftIO $ traceIO "inserting haskelloid"
-  vx <- liftIO $ randomRIO (-10, 10)
-  vy <- liftIO $ randomRIO (-10, 10)
-  rdiv <- case split of
-    Nothing -> liftIO $ randomRIO (1, 2)
-    Just x -> return $ x + 1
-  rot <- liftIO $ randomRIO (0, 360)
-  pitch <- liftIO $ randomRIO (-45, 45)
-  tempRoot <- liftIO $ gegl_node_new
-  tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
-  tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load"
-    [ Property "path" $ PropertyString "assets/haskelloid.svg"
-    , Property "width" $ PropertyInt (100 `div` rdiv)
-    , Property "height" $ PropertyInt (100 `div` rdiv)
-    ]
-  tempTrans <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:translate"
-    [ Property "x" $ PropertyDouble $ px + (100 / fromIntegral rdiv / 2)
-    , Property "y" $ PropertyDouble $ py + (100 / fromIntegral rdiv / 2)
-    , Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
-    ]
-  tempRot <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rotate"
-    [ Property "origin-x" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
-    , Property "origin-y" $ PropertyDouble (100 / 2 / fromIntegral rdiv)
-    , Property "degrees" $ PropertyDouble rot
-    , Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
-    ]
-  liftIO $ gegl_node_link_many [tempSvg, tempRot, tempTrans]
-  _ <- liftIO $ gegl_node_connect_to tempTrans "output" tempOver "aux"
-  return $ Just  Haskelloid
-    { hPos =
-      ( px + (100 / 2 / fromIntegral rdiv)
-      , py + (100 / 2 / fromIntegral rdiv)
-      )
-    , hVel = (vx, vy)
-    , hRot = rot
-    , hPitch = pitch
-    , hDiv = rdiv
-    , hFlange = tempOver
-    , hNodeGraph = M.fromList
-      [ ("root", tempRoot)
-      , ("over", tempOver)
-      , ("svg", tempSvg)
-      , ("trans", tempTrans)
-      , ("rot", tempRot)
-      ]
-    } : hasks
-
 lose :: Affection UserData ()
 lose = do
   ud <- getAffection

src/Types.hs

@@ -0,0 +1,58 @@
+module Types where
+
+import Affection
+import qualified SDL
+import GEGL
+import BABL
+import qualified Data.Map as M
+
+data UserData = UserData
+  { nodeGraph :: M.Map NodeKey GeglNode
+  , ship :: Ship
+  , buffer :: GeglBuffer
+  , haskelloids :: [Haskelloid]
+  , shots :: ParticleSystem
+  -- , debris :: ParticleSystem
+  , wonlost :: Bool
+  , pixelSize :: Int
+  , state :: StateMachine
+  }
+
+data Ship = Ship
+  { sPos :: (Double, Double)
+  , sVel :: (Double, Double)
+  , sRot :: Double
+  , sFlange :: GeglNode
+  }
+
+data Haskelloid = Haskelloid
+  { hPos :: (Double, Double)
+  , hVel :: (Double, Double)
+  , hRot :: Double
+  , hPitch :: Double
+  , hDiv :: Int
+  , hFlange :: GeglNode
+  , hNodeGraph :: M.Map String GeglNode
+  } deriving (Eq)
+
+data NodeKey
+  = KeyRoot
+  | KeyTranslate
+  | KeyRotate
+  | KeyShip
+  | KeyPNop
+  | KeyHNop
+  | KeyCrop
+  | KeyShipOver
+  | KeySink
+  | KeyWon
+  | KeyLost
+  | KeyPixelize
+  | KeyFGOver
+  | KeyFGNop
+  deriving (Ord, Eq)
+
+data StateMachine
+  = Menu
+  | HighScore
+  | InGame