initiating rewrite

haskelloids.cabal

@@ -57,6 +57,7 @@ executable haskelloids
                     , Types 
                     , Commons
                     , StateMachine
+                    , Menu
   
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    
@@ -64,11 +65,11 @@ executable haskelloids
   -- Other library packages from which modules are imported.
   build-depends:       base >=4.9 && <4.11
                      , affection
-                     , gegl
-                     , babl
                      , sdl2 >= 2.1.3.1
                      , containers
                      , random
+                     , nanovg
+                     , linear
   
   -- Directories containing source files.
   hs-source-dirs:      src

src/Commons.hs

@@ -9,9 +9,9 @@ import BABL
 
 import qualified Data.Map as M
 import Data.List (delete)
-import Data.Maybe (catMaybes)
+import Data.Maybe (catMaybes, isJust)
 
-import Control.Monad (foldM, unless)
+import Control.Monad (foldM, unless, when)
 
 import System.Random (randomRIO)
 
@@ -22,296 +22,6 @@ import Types
 toR :: Double -> Double
 toR deg = deg * pi / 180
 
-clean :: UserData -> IO ()
-clean ud = do
-  mapM_ (gegl_node_drop . (\h -> hNodeGraph h M.! "root")) (haskelloids ud)
-  gegl_node_drop $ nodeGraph ud M.! KeyRoot
-
-load :: 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
-    ]
-  shipNode <- 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
-    ]
-  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 nbuffer
-    ]
-  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"
-    [ Property "size-x" $ PropertyInt 3
-    , Property "size-y" $ PropertyInt 3
-    ]
-  -- vdeg <- gegl_node_new_child root $ Operation "gegl:video-degradation"
-  --   [ Property "pattern" $ PropertyInt 8
-  --   ]
-  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 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 fgnop "output" fgover "aux"
-  traceM "nodes complete"
-  myMap <- return $ M.fromList
-    [ (KeyRoot, root)
-    , (KeyShip, shipNode)
-    , (KeyShipTranslate, translate)
-    , (KeyShipRotate, rotate)
-    , (KeyPNop, pnop)
-    , (KeyHNop, hnop)
-    , (KeyCrop, crop)
-    , (KeyShipOver, sover)
-    , (KeySink, sink)
-    , (KeyWon, won)
-    , (KeyLost, lost)
-    , (KeyPixelize, pixelize)
-    , (KeyFGOver, fgover)
-    , (KeyFGNop, fgnop)
-    , (KeyFGTrans, fgtranslate)
-    , (KeyMenuHeading, menuTranslateHeading)
-    , (KeyMenuText, menuText)
-    , (KeyMenuOver, menuOver)
-    ]
-  traceM "built map"
-  hs <- catMaybes <$> foldM (\acc _ -> do
-    px <- liftIO $ randomRIO (0, 800)
-    py <- liftIO $ randomRIO (0, 600)
-    insertHaskelloid acc Nothing (px, py)
-    ) [] ([0..9] :: [Int])
-  traceM "built haskelloids"
-  liftIO $ gegl_node_link_many $ map hFlange hs
-  liftIO $ gegl_node_link (last $ map hFlange hs) hnop
-  traceM "linking haskelloids and returning UserData"
-  return $ UserData
-    { nodeGraph = myMap
-    , ship      = Ship
-      { sPos = (375, 275)
-      , sVel = (0, 0)
-      , sRot = 0
-      , sFlange = rotate
-      }
-    , buffer = nbuffer
-    , shots = ParticleSystem (ParticleStorage Nothing []) pnop nbuffer
-    -- , haskelloids = hs
-    , haskelloids = []
-    , wonlost = False
-    , pixelSize = 3
-    , state = Menu
-    , fade = FadeIn 1
-    }
-
-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 ((-180) , 180)
-  pitch <- liftIO $ randomRIO ((-(pi/2)), pi/2)
-  tempRoot <- liftIO $ gegl_node_new
-  tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation
-  tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:png-load"
-    [ Property "path" $ PropertyString "assets/haskelloid.png"
-    ]
-  liftIO $ traceIO "svg loaded"
-  tempScale <- gegl_node_new_child tempRoot $ Operation "gegl:scale-size"
-    [ Property "sampler"  $ PropertyInt $ fromEnum GeglSamplerCubic
-    , Property "x" $ PropertyDouble (100 / (fromIntegral rdiv) :: Double)
-    , Property "y" $ PropertyDouble (100 / (fromIntegral rdiv) :: Double)
-    ]
-  liftIO $ traceIO "scaled"
-  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
-    ]
-  liftIO $ traceIO "translated"
-  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 $ traceIO $ "rotated: " ++ show rot
-  liftIO $ gegl_node_link_many [tempSvg, tempScale, 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
-
-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
@@ -323,62 +33,3 @@ wrapAround (nx, ny) width = (nnx, 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,7 +5,7 @@ import qualified SDL
 import GEGL
 
 import qualified Data.Map as M
-import Data.Maybe (catMaybes)
+import Data.Maybe (catMaybes, isJust, fromJust, isNothing)
 
 import Control.Monad (when, foldM)
 
@@ -40,7 +40,7 @@ loadGame = do
   liftIO $ traceIO "nodes linked"
   putAffection ud
     { haskelloids = hs
-    , wonlost = False
+    , wonlost = Nothing
     , shots = ParticleSystem
       (ParticleStorage Nothing [])
       (nodeGraph ud M.! KeyPNop)
@@ -108,11 +108,10 @@ updateGame sec = do
   putAffection ud3
     { haskelloids = nhs
     }
-  -- liftIO $ traceIO $ show $ length nhs
   ud3 <- getAffection
-  -- ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw
   ups <- updateParticleSystem (shots ud3) sec shotsUpd
   ud4 <- getAffection
+  when (isJust $ wonlost ud3) (winlose $ fromJust $ wonlost ud3)
   putAffection ud4
     { shots = ups
     }
@@ -136,81 +135,99 @@ handleGameEvent e = do
       case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of
         SDL.KeycodeLeft -> do
           ud <- getAffection
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $
+          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
-            putAffection ud
+            && (isNothing $ wonlost ud)) $ do
-              { ship = (ship ud)
+              let rawRot = (sRot $ ship ud) + 15 * sec
-                { sRot = (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) $
+          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
-            putAffection ud
+            && (isNothing $ wonlost ud)) $ do
-              { ship = (ship ud)
+              let rawRot = (sRot $ ship ud) - 15 * sec
-                { sRot = (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 && not (wonlost wd)) $ do
+          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
-            ud <- getAffection
+            && (isNothing $ wonlost wd)) $ do
-            let vx = -10 * sin (toR $ sRot $ ship ud) + fst (sVel $ ship ud)
+              ud <- getAffection
-                vy = -10 * cos (toR $ sRot $ ship ud) + snd (sVel $ ship ud)
+              let vx = -10 * sin (toR $ sRot $ ship ud) + fst (sVel $ ship ud)
-            putAffection ud
+                  vy = -10 * cos (toR $ sRot $ ship ud) + snd (sVel $ ship ud)
-              { ship = (ship ud)
+              putAffection ud
-                { sVel = (vx, vy)
+                { ship = (ship ud)
+                  { sVel = (vx, vy)
+                  }
                 }
-              }
+              -- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
-            -- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud)
         SDL.KeycodeSpace ->
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do
+          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
-            ud <- getAffection
+            && (isNothing $ wonlost wd)) $ do
-            liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $ Operation "gegl:pixelize"
+              ud <- getAffection
-              [ Property "size-x" $ PropertyInt 8
+              liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $
-              , Property "size-y" $ PropertyInt 8
+                Operation "gegl:pixelize"
-              ]
+                  [ Property "size-x" $ PropertyInt 8
-            -- ad <- get
+                  , Property "size-y" $ PropertyInt 8
-            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
+              -- ad <- get
-                , particleDrawFlange = tempOver
+              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
                 }
-            putAffection $ ud
-              { shots = ips
-              , pixelSize = 8
-              }
         SDL.KeycodeR ->
-          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && wonlost wd) $ do
+          when (SDL.keyboardEventKeyMotion dat == SDL.Pressed
-            liftIO $ traceIO "reloading"
+            && isJust (wonlost wd)) $ do
-            liftIO $ clean wd
+              liftIO $ traceIO "reloading"
-            nd <- liftIO $ load
+              liftIO $ clean wd
-            putAffection nd
+              nd <- liftIO $ load
+              putAffection nd
+              loadGame
         _ -> return ()
     SDL.WindowClosedEvent _ -> do
       traceM "seeya!"

src/Init.hs

@@ -0,0 +1,81 @@
+module Init where
+
+import Affection
+
+import SDL (($=))
+import qualified SDL
+
+import qualified Data.Set as S
+import Data.Maybe
+
+import System.Random
+
+import NanoVG
+
+-- Internal imports
+
+import Types
+
+load :: IO UserData
+load = do
+  nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes])
+  mhaskImage <- createImage nvgCtx "assets/haskelloid.svg" 0
+  mshipImage <- createImage nvgCtx "assets/ship.svg" 0
+  when (isNothing mhasImage || isNothing mshipImage) $
+    logIO Error "Failed loading image assets"
+  hasks <- mapM (\_ -> do
+    posx <- randomRIO (0, 800)
+    posy <- randomRIO (0, 600)
+    velx <- randomRIO (-10, 10)
+    vely <- randomRIO (-10, 10)
+    rot <- randomRIO (0, 2*pi)
+    pitch <- randomRIO (-pi, pi)
+    div <- randomRIO (1, 2)
+    return Haskelloid
+      (V2 posx posy)
+      (V2 velx vely)
+      rot
+      pitch
+      div
+      (fromJust mhaskImage)
+    ) [1..10]
+  return UserData
+    { ship = Ship
+      { sPos = V2 400 300
+      , sVel = V2 0 0
+      , sRot = 0
+      , sImg = fromust mshipImage
+      }
+    , haskelloids = []
+    , wonlost = Nothing
+    , state = Menu
+    , fade = FadeIn 1
+    , nano = nvgCtx
+    }
+
+
+
+  -- _ <- SDL.setMouseLocationMode SDL.RelativeLocation
+  -- GL.depthFunc $= ust GL.Less
+  -- pane <- GL.genObjectName
+  -- GL.BindVertexArrayObject $= Just pane
+  -- verts <- GL.genObejctName
+  -- let vertCoord =
+  --       [ (-1), (-1), 0
+  --       , 1   , (-1), 0
+  --       , (-1), 1   , 0
+  --       , 1   , 1   , 0
+  --       , (-1), 1   , 0
+  --       , 1   , (-1), 0
+  --       ]
+  -- withArray vertCoord $ \ptr
+  --   GL.bufferData GL.ArrayBuffer $=
+  --     ( fromIntegral $ length vertCoord * 3 * sizeOf (0 :: Double)
+  --     , ptr
+  --     , GL.StaticDraw
+  --     )
+  -- GL.vertexAttribPointer (GL.AttribLocation 0) $=
+  --   ( GL.ToFloat
+  --   , GL.VertexArrayDescriptor 4 GL.Float 0 (plusPtr nullPtr 0)
+  --   )
+ -- GL.vertexAttribArray (GL.AttribLocation 0) $= GL.Enabled

src/Main.hs

@@ -1,222 +1,63 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Main where
 
-import Affection hiding (StateMachine(..))
+import Affection
+import SDL (($=))
 import qualified SDL
-import GEGL
 
-import Data.List (delete)
+import qualified Graphics.Rendering.OpenGL as GL
+import qualified Graphics.GLUtil as GLU
+
 import qualified Data.Map as M
-import Data.Maybe (catMaybes)
 
-import Control.Monad (when, foldM)
+import Linear as L
-
-import Debug.Trace
 
 -- internal imports
 
 import Types
 import Commons
-import StateMachine
+import StateMachine ()
-
+import Init
-import Menu
-import InGame
 
 main :: IO ()
-main = withAffection AffectionConfig
+main = do
-  { initComponents = All
+  logIO Debug "Starting"
-  , windowTitle    = "Haskelloids"
+  withAffection AffectionConfig
-  , windowConfig   = defaultWindow
+    { initComponents = All
-  , initScreenMode = SDL.Windowed
+    , windowTitle    = "Haskelloids"
-  , preLoop        = return ()
+    , windowConfig   = defaultWindow
-  , drawLoop       = draw
+      { SDL.windowOpenGL = Just SDL.defaultOpenGL
-  , updateLoop     = update
+        { SDL.glProfile = SDL.Core SDL.Normal 3 3
-  , loadState      = load
+        }
-  , cleanUp        = clean
+      }
-  , canvasSize     = Nothing
+    , initScreenMode = SDL.Windowed
-  , eventLoop      = handleGameEvent
+    , canvasSize     = Nothing
-  }
+    , loadState      = load
+    , preLoop        = smLoad Menu
+    , eventLoop      = handle
+    , updateLoop     = update
+    , drawLoop       = draw
+    , cleanUp        = clean
+    }
 
 update :: Double -> Affection UserData ()
 update sec = do
   ud <- getAffection
   smUpdate (state ud) sec
 
--- update sec = do
+handle :: SDL.EventPayload -> Affection UserData ()
---   -- traceM $ (show $ 1 / sec) ++ " FPS"
+handle e = do
---   ad <- get
+  ud <- getAffection
---   wd <- getAffection
+  smEvent (state ud) e
---   when (((floor $ elapsedTime ad :: Int) * 100) `mod` 10 < 2 && pixelSize wd > 3) $ do
---     liftIO $ gegl_node_set (nodeGraph wd M.! KeyPixelize) $ Operation "gegl:pixelize"
---       [ Property "size-x" $ PropertyInt $ pixelSize wd - 1
---       , Property "size-y" $ PropertyInt $ pixelSize wd - 1
---       ]
---     pd <- getAffection
---     putAffection pd
---       { pixelSize = pixelSize wd -1
---       }
---   -- evs <- SDL.pollEvents
---   -- mapM_ (\e ->
---   --   case state wd of
---   --     InGame ->
---   --       handleGameEvent sec e
---   --     _ -> error "not yet implemented"
---   --   ) evs
---   ud2 <- getAffection
---   nhs <- mapM (updateHaskelloid sec) (haskelloids ud2)
---   -- liftIO $ traceIO $ show $ length nhs
---   putAffection ud2
---     { haskelloids = nhs
---     }
---   ud3 <- getAffection
---   let nx = fst (sPos $ ship ud3) + (fst (sVel $ ship ud3)) * sec
---       ny = snd (sPos $ ship ud3) + (snd (sVel $ ship ud3)) * sec
---       (nnx, nny) = wrapAround (nx, ny) 50
---   liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyShipTranslate) $ Operation "gegl:translate"
---     [ Property "x" $ PropertyDouble $ nnx
---     , Property "y" $ PropertyDouble $ nny
---     ]
---   liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyShipRotate) $ Operation "gegl:rotate"
---     [ Property "degrees" $ PropertyDouble $ sRot $ ship ud3
---     ]
---   ups <- updateParticleSystem (shots ud3) sec shotsUpd
---   ud4 <- getAffection
---   putAffection ud4
---     { ship = (ship ud3)
---       { sPos = (nnx, nny)
---       }
---     , shots = ups
---     }
 
 draw :: Affection UserData ()
 draw = do
+  GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
   ud <- getAffection
-  smDraw (state ud)
+  GL.currentProgram $= (Just . GLU.program $ program sd)
-  -- drawParticleSystem (shots ud) (\_ _ _ -> return())
+  let proj = ortho (-1) 1 (-1) 1 (-1) 1
-  -- liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink
+      view = lookAt
-  -- present
+        (V3 0 0 (-1))
-  --   (GeglRectangle 0 0 800 600)
+        (V3 0 0 0)
-  --   (buffer ud)
+        (V3 0 1 0)
-  --   True
+      model = mkTransformation (Quaternion 1 (V3 0 0 0)) (V3 0 0 0)
-  -- render Nothing Nothing
-
--- 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
---     }
-
-haskelloidShotDown :: Haskelloid -> Affection UserData ()
-haskelloidShotDown h = do
-  liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
-  ud <- getAffection
-  let redHaskelloids = delete h (haskelloids ud)
-  liftIO $ gegl_node_drop $ hNodeGraph h M.! "root"
-  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_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)
---       rawRot = hRot + hPitch * sec
---       newRot
---         | rawRot > 180  = rawRot - 360
---         | rawRot < -180 = rawRot + 360
---         | otherwise     = rawRot
---       (nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv)
---   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 <- 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 ()) (\_ ->
---     lose
---     ) lost
---   return h
---     { hPos = (nnx, nny)
---     , hRot = newRot
---     }
-
-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/Menu.hs

@@ -7,13 +7,68 @@ import Debug.Trace
 
 import Types
 
-handleMenuEvent :: Double -> SDL.Event -> Affection UserData ()
+handleMenuEvent :: SDL.EventPayload -> Affection UserData ()
-handleMenuEvent sec e = do
+handleMenuEvent e =
-  ad <- get
+  case e of
-  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 _ -> do
-      traceM "seeya!"
+      ad <- get
       put ad
         { quitEvent = True
         }
     _ -> return ()
+
+loadMenu :: Affection UserData ()
+loadMenu = 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 [] }
+    }
+
+updateMenu :: Double -> Affection UserData ()
+updateMenu 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
+        }

src/StateMachine.hs

@@ -2,7 +2,7 @@
 
 module StateMachine where
 
-import Affection hiding (StateMachine(..))
+import Affection
 import qualified SDL
 import GEGL
 
@@ -16,91 +16,21 @@ import System.Random (randomRIO)
 import Types
 import Commons
 import InGame
-
+import Menu
-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
+  smLoad Menu = loadMenu
-    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
+  smUpdate Menu = updateMenu
-    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
+  smEvent Menu = handleMenuEvent
-    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
+  smEvent InGame = handleGameEvent
-  smEvent InGame _ e = handleGameEvent (SDL.eventPayload e)
 
-  smDraw Menu = do
+  smDraw Menu = return ()
-    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

@@ -2,64 +2,38 @@
 
 module Types where
 
-import Affection hiding (StateMachine)
+import Affection
 import qualified SDL
-import GEGL
+import NanoVG
-import qualified Data.Map as M
 
 data UserData = UserData
-  { nodeGraph :: M.Map NodeKey GeglNode
+  { ship :: Ship
-  , ship :: Ship
-  , buffer :: GeglBuffer
   , haskelloids :: [Haskelloid]
-  , shots :: ParticleSystem
+  -- , shots :: ParticleSystem
   -- , debris :: ParticleSystem
-  , wonlost :: Bool
+  , wonlost :: Maybe WonLost
   , pixelSize :: Int
   , state :: State
   , fade :: MenuFade
+  , neno :: Context
   }
 
 data Ship = Ship
-  { sPos :: (Double, Double)
+  { sPos :: V2 Double
-  , sVel :: (Double, Double)
+  , sVel :: V2 Double
   , sRot :: Double
-  , sFlange :: GeglNode
+  , sImg :: Image
   }
 
 data Haskelloid = Haskelloid
-  { hPos :: (Double, Double)
+  { hPos :: V2 Double
-  , hVel :: (Double, Double)
+  , hVel :: V2 Double
   , hRot :: Double
   , hPitch :: Double
   , hDiv :: Int
-  , hFlange :: GeglNode
+  , hImg :: Image
-  , hNodeGraph :: M.Map String GeglNode
   } deriving (Eq)
 
-data NodeKey
-  = KeyRoot
-  | KeyShip
-  | KeyShipTranslate
-  | KeyShipRotate
-  | KeyPNop
-  | KeyHNop
-  | KeyCrop
-  | KeyShipOver
-  | KeySink
-  | KeyWon
-  | KeyLost
-  | KeyPixelize
-  | KeyFGOver
-  | KeyFGNop
-  | KeyFGTrans
-  | KeyMenuHeading
-  | KeyMenuText
-  | KeyMenuStart
-  | KeyMenuHighscore
-  | KeyMenuOver
-  deriving (Ord, Eq)
-
 data State
   = Menu
   | HighScore
@@ -68,3 +42,8 @@ data State
 data MenuFade
   = FadeIn Double
   | FadeOut Double
+
+data WonLost
+  = Won
+  | Lost
+  deriving (Eq)