works halfway as intended

src/Commons.hs

@@ -1,3 +1,5 @@
+{-# LANGUAGE RecordWildCards #-}
+
 module Commons where
 
 import Affection
@@ -6,8 +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, when)
 
 import System.Random (randomRIO)
 
@@ -127,14 +131,14 @@ load _ = do
   _ <- 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)
-    , (KeyRotate, rotate)
     , (KeyShip, shipNode)
+    , (KeyShipTranslate, translate)
+    , (KeyShipRotate, rotate)
     , (KeyPNop, pnop)
     , (KeyHNop, hnop)
     , (KeyCrop, crop)
@@ -222,3 +226,139 @@ 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.! KeyFGNop)
+    putAffection ud
+      { wonlost = True
+      }
+  putAffection ud
+    { 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 ()) (\_ ->
+    lose
+    ) 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 =
+      if nx > 800
+      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
+
+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)
+  when (not $ 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 ()) (\_ ->
+    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.! KeyFGNop)
+  putAffection ud
+    { wonlost = True
+    }
+  _ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
+  return ()

src/InGame.hs

@@ -5,14 +5,103 @@ 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
 
+loadGame :: Affection UserData ()
+loadGame = do
+  ud <- getAffection
+  _ <- liftIO $ gegl_node_connect_to
+    (nodeGraph ud M.! KeyShipTranslate)
+    "output"
+    (nodeGraph ud M.! KeyShipOver)
+    "aux"
+  hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do
+    coords <- liftIO excludeShip
+    insertHaskelloid acc Nothing coords
+    ) [] ([0..9] :: [Int])
+  liftIO $ gegl_node_link_many $ map hFlange hs
+  liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop)
+  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
+    }
+
+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)
+  putAffection ud2
+    { haskelloids = nhs
+    }
+  liftIO $ traceIO $ show $ length nhs
+  ud3 <- getAffection
+  ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
+  ud4 <- getAffection
+  putAffection ud4
+    { shots = ups
+    }
+
 handleGameEvent :: Double -> SDL.Event -> Affection UserData ()
 handleGameEvent sec e = do
   ad <- get

src/Main.hs

@@ -40,17 +40,17 @@ pre = smLoad Menu
 update :: Double -> Affection UserData ()
 update sec = do
   -- traceM $ (show $ 1 / sec) ++ " FPS"
-  ad <- get
+  -- ad <- get
   wd <- getAffection
-  when (((floor $ elapsedTime ad :: Int) * 100) `mod` 10 < 2 && pixelSize wd > 3) $ do
+  -- when (((floor $ elapsedTime ad :: Int) * 100) `mod` 10 < 2 && pixelSize wd > 3) $ do
-    liftIO $ gegl_node_set (nodeGraph wd M.! KeyPixelize) $ Operation "gegl:pixelize"
+  --   liftIO $ gegl_node_set (nodeGraph wd M.! KeyPixelize) $ Operation "gegl:pixelize"
-      [ Property "size-x" $ PropertyInt $ pixelSize wd - 1
+  --     [ Property "size-x" $ PropertyInt $ pixelSize wd - 1
-      , Property "size-y" $ PropertyInt $ pixelSize wd - 1
+  --     , Property "size-y" $ PropertyInt $ pixelSize wd - 1
-      ]
+  --     ]
-    pd <- getAffection
+  --   pd <- getAffection
-    putAffection pd
+  --   putAffection pd
-      { pixelSize = pixelSize wd -1
+  --     { pixelSize = pixelSize wd -1
-      }
+  --     }
   -- case state wd of
   --   Menu ->
   --     updateMenu sec
@@ -66,168 +66,168 @@ update sec = do
   --     _ -> error "not yet implemented"
   --   ) evs
   mapM_ (smEvent (state wd) sec) evs
-  ud2 <- getAffection
+  -- ud2 <- getAffection
-  nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
+  -- nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
-  -- liftIO $ traceIO $ show $ length nhs
+  -- -- liftIO $ traceIO $ show $ length nhs
-  putAffection ud2
+  -- putAffection ud2
-    { haskelloids = nhs
+  --   { haskelloids = nhs
-    }
+  --   }
-  ud3 <- getAffection
+  -- ud3 <- getAffection
-  let nx = fst (sPos $ ship ud3) + (fst (sVel $ ship ud3)) * sec
+  -- let nx = fst (sPos $ ship ud3) + (fst (sVel $ ship ud3)) * sec
-      ny = snd (sPos $ ship ud3) + (snd (sVel $ ship ud3)) * sec
+  --     ny = snd (sPos $ ship ud3) + (snd (sVel $ ship ud3)) * sec
-      (nnx, nny) = wrapAround (nx, ny) 50
+  --     (nnx, nny) = wrapAround (nx, ny) 50
-  liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyTranslate) $ Operation "gegl:translate"
+  -- liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyShipTranslate) $ Operation "gegl:translate"
-    [ Property "x" $ PropertyDouble $ nnx
+  --   [ Property "x" $ PropertyDouble $ nnx
-    , Property "y" $ PropertyDouble $ nny
+  --   , Property "y" $ PropertyDouble $ nny
-    ]
+  --   ]
-  liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyRotate) $ Operation "gegl:rotate"
+  -- liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyShipRotate) $ Operation "gegl:rotate"
-    [ Property "degrees" $ PropertyDouble $ sRot $ ship ud3
+  --   [ Property "degrees" $ PropertyDouble $ sRot $ ship ud3
-    ]
+  --   ]
-  ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
+  -- ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
-  ud4 <- getAffection
+  -- ud4 <- getAffection
-  putAffection ud4
+  -- putAffection ud4
-    { ship = (ship ud3)
+  --   { ship = (ship ud3)
-      { sPos = (nnx, nny)
+  --     { sPos = (nnx, nny)
-      }
+  --     }
-    , shots = ups
+  --   , shots = ups
-    }
+  --   }
 
-wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t)
+-- wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t)
-wrapAround (nx, ny) width = (nnx, nny)
+-- wrapAround (nx, ny) width = (nnx, nny)
-  where
+--   where
-    nnx =
+--     nnx =
-      if nx > 800
+--       if nx > 800
-      then nx - (800 + width)
+--       then nx - (800 + width)
-      else if nx < -width then nx + 800 + width else nx
+--       else if nx < -width then nx + 800 + width else nx
-    nny =
+--     nny =
-      if ny > 600
+--       if ny > 600
-      then ny - (600 + width)
+--       then ny - (600 + width)
-      else if ny < -width then ny + 600 + width else ny
+--       else if ny < -width then ny + 600 + width else ny
 
 draw :: Affection UserData ()
 draw = do
   ud <- getAffection
   smDraw $ state ud
 
-shotsUpd :: Double -> Particle -> Affection UserData Particle
+-- shotsUpd :: Double -> Particle -> Affection UserData Particle
-shotsUpd sec part@Particle{..} = do
+-- shotsUpd sec part@Particle{..} = do
-  let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
+--   let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity)
-      newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity)
+--       newY = (snd particlePosition) + sec * (fromIntegral $ snd particleVelocity)
-      (nnx, nny) = wrapAround (newX, newY) 4
+--       (nnx, nny) = wrapAround (newX, newY) 4
-  liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
+--   liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle"
-    [ Property "x" $ PropertyDouble $ nnx
+--     [ Property "x" $ PropertyDouble $ nnx
-    , Property "y" $ PropertyDouble $ nny
+--     , Property "y" $ PropertyDouble $ nny
-    ]
+--     ]
-  ud <- getAffection
+--   ud <- getAffection
-  inters <- catMaybes <$> mapM (\h -> do
+--   inters <- catMaybes <$> mapM (\h -> do
-    col <- liftIO $ gegl_rectangle_intersect
+--     col <- liftIO $ gegl_rectangle_intersect
-      (GeglRectangle (floor nnx) (floor nny) 4 4)
+--       (GeglRectangle (floor nnx) (floor nny) 4 4)
-      (GeglRectangle
+--       (GeglRectangle
-        (floor $ fst $ hPos h)
+--         (floor $ fst $ hPos h)
-        (floor $ snd $ hPos h)
+--         (floor $ snd $ hPos h)
-        (100 `div` hDiv h)
+--         (100 `div` hDiv h)
-        (100 `div` hDiv h)
+--         (100 `div` hDiv h)
-        )
+--         )
-    case col of
+--     case col of
-      Just _ -> return $ Just h
+--       Just _ -> return $ Just h
-      Nothing -> return Nothing
+--       Nothing -> return Nothing
-    ) (haskelloids ud)
+--     ) (haskelloids ud)
-  when (not $ null inters) $
+--   when (not $ null inters) $
-    haskelloidShotDown $ head inters
+--     haskelloidShotDown $ head inters
-  lost <- liftIO $ gegl_rectangle_intersect
+--   lost <- liftIO $ gegl_rectangle_intersect
-    (GeglRectangle (floor nnx) (floor nny) 4 4)
+--     (GeglRectangle (floor nnx) (floor nny) 4 4)
-    (GeglRectangle
+--     (GeglRectangle
-      (floor $ fst $ sPos $ ship ud)
+--       (floor $ fst $ sPos $ ship ud)
-      (floor $ snd $ sPos $ ship ud)
+--       (floor $ snd $ sPos $ ship ud)
-      50
+--       50
-      50
+--       50
-      )
+--       )
-  maybe (return ()) (\_ ->
+--   maybe (return ()) (\_ ->
-    lose
+--     lose
-    ) lost
+--     ) lost
-  return part
+--   return part
-    { particlePosition = (nnx, nny)
+--     { particlePosition = (nnx, nny)
-    , particleTimeToLive = if (not $ null inters) then 0 else particleTimeToLive
+--     , particleTimeToLive = if (not $ null inters) then 0 else particleTimeToLive
-    }
+--     }
-
+-- 
-haskelloidShotDown :: Haskelloid -> Affection UserData ()
+-- haskelloidShotDown :: Haskelloid -> Affection UserData ()
-haskelloidShotDown h = do
+-- haskelloidShotDown h = do
-  liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
+--   liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
-  ud <- getAffection
+--   ud <- getAffection
-  let redHaskelloids = delete h (haskelloids ud)
+--   let redHaskelloids = delete h (haskelloids ud)
-  liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
+--   liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
-  newHaskelloids <- catMaybes <$> foldM
+--   newHaskelloids <- catMaybes <$> foldM
-    (\acc _ ->
+--     (\acc _ ->
-      if hDiv h < 4
+--       if hDiv h < 4
-      then
+--       then
-        liftIO $ insertHaskelloid acc (Just $ hDiv h) $ hPos h
+--         liftIO $ insertHaskelloid acc (Just $ hDiv h) $ hPos h
-      else
+--       else
-        return $ Nothing : acc
+--         return $ Nothing : acc
-      )
+--       )
-    (map Just redHaskelloids) ([0..1] :: [Int])
+--     (map Just redHaskelloids) ([0..1] :: [Int])
-  liftIO $ gegl_node_link_many $ map hFlange newHaskelloids
+--   liftIO $ gegl_node_link_many $ map hFlange newHaskelloids
-  if not $ null newHaskelloids
+--   if not $ null newHaskelloids
-  then 
+--   then 
-    liftIO $ gegl_node_link
+--     liftIO $ gegl_node_link
-      (last $ map hFlange newHaskelloids)
+--       (last $ map hFlange newHaskelloids)
-      (nodeGraph ud M.! KeyHNop)
+--       (nodeGraph ud M.! KeyHNop)
-  else do
+--   else do
-    liftIO $ traceIO "YOU WON!"
+--     liftIO $ traceIO "YOU WON!"
-    liftIO $ gegl_node_link
+--     liftIO $ gegl_node_link
-      (nodeGraph ud M.! KeyWon)
+--       (nodeGraph ud M.! KeyWon)
-      (nodeGraph ud M.! KeyFGNop)
+--       (nodeGraph ud M.! KeyFGNop)
-    putAffection ud
+--     putAffection ud
-      { wonlost = True
+--       { wonlost = True
-      }
+--       }
-  putAffection ud
+--   putAffection ud
-    { haskelloids = newHaskelloids
+--     { haskelloids = newHaskelloids
-    }
+--     }
-
+-- 
-shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()
+-- shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()
-shotsDraw _ _ _ = return ()
+-- shotsDraw _ _ _ = return ()
-
+-- 
-updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
+-- updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
-updateHaskelloid sec h@Haskelloid{..} = do
+-- updateHaskelloid sec h@Haskelloid{..} = do
-  let newX = (fst $ hPos) + sec * (fst $ hVel)
+--   let newX = (fst $ hPos) + sec * (fst $ hVel)
-      newY = (snd $ hPos) + sec * (snd $ hVel)
+--       newY = (snd $ hPos) + sec * (snd $ hVel)
-      newRot = hRot + hPitch * sec
+--       newRot = hRot + hPitch * sec
-      (nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv)
+--       (nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv)
-  liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate"
+--   liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate"
-    [ Property "x" $ PropertyDouble $ nnx
+--     [ Property "x" $ PropertyDouble $ nnx
-    , Property "y" $ PropertyDouble $ nny
+--     , Property "y" $ PropertyDouble $ nny
-    ]
+--     ]
-  liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate"
+--   liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate"
-    [ Property "degrees" $ PropertyDouble newRot
+--     [ Property "degrees" $ PropertyDouble newRot
-    ]
+--     ]
-  ud <- getAffection
+--   ud <- getAffection
-  lost <- 
+--   lost <- 
-    case state ud of
+--     case state ud of
-      InGame -> liftIO $ gegl_rectangle_intersect
+--       InGame -> liftIO $ gegl_rectangle_intersect
-        (GeglRectangle (floor nnx) (floor nny) (100 `div` hDiv) (100 `div` hDiv))
+--         (GeglRectangle (floor nnx) (floor nny) (100 `div` hDiv) (100 `div` hDiv))
-        (GeglRectangle
+--         (GeglRectangle
-          (floor $ fst $ sPos $ ship ud)
+--           (floor $ fst $ sPos $ ship ud)
-          (floor $ snd $ sPos $ ship ud)
+--           (floor $ snd $ sPos $ ship ud)
-          50
+--           50
-          50
+--           50
-          )
+--           )
-      _ -> return Nothing
+--       _ -> return Nothing
-  maybe (return ()) (\_ ->
+--   maybe (return ()) (\_ ->
-    lose
+--     lose
-    ) lost
+--     ) lost
-  return h
+--   return h
-    { hPos = (nnx, nny)
+--     { hPos = (nnx, nny)
-    , hRot = newRot
+--     , hRot = newRot
-    }
+--     }
-
+-- 
-lose :: Affection UserData ()
+-- lose :: Affection UserData ()
-lose = do
+-- lose = do
-  ud <- getAffection
+--   ud <- getAffection
-  liftIO $ traceIO "YOU LOST!"
+--   liftIO $ traceIO "YOU LOST!"
-  _ <- liftIO $ gegl_node_link
+--   _ <- liftIO $ gegl_node_link
-    (nodeGraph ud M.! KeyLost)
+--     (nodeGraph ud M.! KeyLost)
-    (nodeGraph ud M.! KeyFGNop)
+--     (nodeGraph ud M.! KeyFGNop)
-  putAffection ud
+--   putAffection ud
-    { wonlost = True
+--     { wonlost = True
-    }
+--     }
-  _ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
+--   _ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux"
-  return ()
+--   return ()

src/Types.hs

@@ -39,9 +39,9 @@ data Haskelloid = Haskelloid
 
 data NodeKey
   = KeyRoot
-  | KeyTranslate
-  | KeyRotate
   | KeyShip
+  | KeyShipTranslate
+  | KeyShipRotate
   | KeyPNop
   | KeyHNop
   | KeyCrop