From ac2a71cdc4abd654d6a0739c900ab22f03bd6dfc Mon Sep 17 00:00:00 2001
From: nek0 <nek0@chelnok.de>
Date: Wed, 28 Dec 2016 20:38:49 +0100
Subject: [PATCH] finishing up. game works

---
 src/Main.hs | 78 ++++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 56 insertions(+), 22 deletions(-)

diff --git a/src/Main.hs b/src/Main.hs
index a7ea917..a5c1377 100644
--- a/src/Main.hs
+++ b/src/Main.hs
@@ -177,10 +177,12 @@ update sec = do
              when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do
                ud <- getAffection
                -- ad <- get
+               let posX = (fst $ sPos $ ship ud) + 23 - 30 * sin (toR $ sRot $ ship ud)
+                   posY = (snd $ sPos $ ship ud) + 23 - 30 * cos (toR $ sRot $ ship ud)
                tempRoot <- liftIO $ gegl_node_new
                tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle"
-                 [ Property "x" $ (PropertyDouble $ (fst $ sPos $ ship ud) + 23)
-                 , Property "y" $ (PropertyDouble $ (snd $ sPos $ ship ud) + 23)
+                 [ 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)
@@ -191,10 +193,7 @@ update sec = do
                  Particle
                    { particleTimeToLive = 5
                    , particleCreation = elapsedTime ad
-                   , particlePosition =
-                     ( (fst $ sPos $ ship ud) + 23
-                     , (snd $ sPos $ ship ud) + 23
-                     )
+                   , particlePosition = (posX, posY)
                    , particleRotation = Rad 0
                    , particleVelocity =
                      -- ( (floor $ -200 * (sin $ toR $ (sRot $ ship ud) + (fst $ sVel $ ship ud)))
@@ -225,7 +224,7 @@ update sec = do
     ) evs
   ud2 <- getAffection
   nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
-  liftIO $ traceIO $ show $ length nhs
+  -- liftIO $ traceIO $ show $ length nhs
   putAffection ud2
     { haskelloids = nhs
     }
@@ -263,7 +262,7 @@ wrapAround (nx, ny) width = (nnx, nny)
 
 draw :: Affection UserData ()
 draw = do
-  traceM "drawing"
+  -- traceM "drawing"
   ud <- getAffection
   liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
   -- mintr <- liftIO $ gegl_rectangle_intersect
@@ -311,8 +310,21 @@ shotsUpd sec part@Particle{..} = do
       Nothing -> return Nothing
     ) (haskelloids ud)
   killings <- mapM haskelloidShotDown inters
-  ud2 <- getAffection
-  liftIO $ traceIO $ show $ length $ haskelloids ud2
+  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 ()) (\_ -> do
+    ad <- get
+    liftIO $ traceIO "YOU LOST!"
+    put ad
+      { quitEvent = True
+      }
+    ) lost
   return part
     { particlePosition = (nnx, nny)
     , particleTimeToLive = if (not $ null killings) then 0 else particleTimeToLive
@@ -320,31 +332,37 @@ shotsUpd sec part@Particle{..} = do
 
 haskelloidShotDown :: Haskelloid -> Affection UserData ()
 haskelloidShotDown h = do
-  liftIO $ traceIO "Haskelloid shot down"
+  -- liftIO $ traceIO "Haskelloid shot down"
   ud <- getAffection
   let redHaskelloids = delete h (haskelloids ud)
   newHaskelloids <- catMaybes <$> foldM
     (\acc _ ->
-      if hDiv h < 6
+      if hDiv h < 4
       then
         liftIO $ insertHaskelloid acc (Just $ hDiv h) $ hPos h
       else
         return $ Nothing : acc
       )
     (map Just redHaskelloids) ([0..1] :: [Int])
-  liftIO $ traceIO $ show $ length newHaskelloids
+  -- liftIO $ traceIO $ show $ length newHaskelloids
   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
+    ad <- get
+    liftIO $ traceIO "YOU WON!"
+    put ad
+      { quitEvent = True
+      }
   putAffection ud
     { haskelloids = newHaskelloids
     }
 
 shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData ()
-shotsDraw _ _ _ = do
-  -- present
-  --   (GeglRectangle (floor $ fst particlePosition - 2) (floor $ snd particlePosition - 2) 4 4)
-  --   buf
-  --   False
-  return ()
+shotsDraw _ _ _ = return ()
 
 updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid
 updateHaskelloid sec h@Haskelloid{..} = do
@@ -359,6 +377,22 @@ updateHaskelloid sec h@Haskelloid{..} = do
   liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate"
     [ Property "degrees" $ PropertyDouble newRot
     ]
+  ud <- getAffection
+  lost <- 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
+      )
+  maybe (return ()) (\_ -> do
+    ad <- get
+    liftIO $ traceIO "YOU LOST!"
+    put ad
+      { quitEvent = True
+      }
+    ) lost
   return h
     { hPos = (nnx, nny)
     , hRot = newRot
@@ -366,14 +400,14 @@ updateHaskelloid sec h@Haskelloid{..} = do
 
 insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid]
 insertHaskelloid hs split (px, py) = do
-  liftIO $ traceIO "inserting haskelloid"
+  -- 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 (-2 * pi, 2 * pi)
-  pitch <- liftIO $ randomRIO (-2 * pi, 2 * pi)
+  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"