making rewrite

.gitignore

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

cabal.config

@@ -0,0 +1 @@
+constraints: affection +debug

haskelloids.cabal

@@ -53,12 +53,13 @@ executable haskelloids
   ghc-options:         -Wall
   
   -- Modules included in this executable, other than Main.
-  other-modules:      InGame
+  other-modules:      Types 
-                    , Types 
                     , Commons
                     , StateMachine
                     , Menu
+                    , Init
   
+  default-extensions: OverloadedStrings
   -- LANGUAGE extensions used by modules in this package.
   -- other-extensions:    
   

src/Commons.hs

@@ -4,18 +4,19 @@ module Commons where
 
 import Affection
 import qualified SDL
-import GEGL
-import BABL
 
 import qualified Data.Map as M
 import Data.List (delete)
 import Data.Maybe (catMaybes, isJust)
 
 import Control.Monad (foldM, unless, when)
+import Control.Monad.IO.Class (liftIO)
 
 import System.Random (randomRIO)
 
-import Debug.Trace
+import NanoVG hiding (V2(..))
+
+import Linear
 
 import Types
 
@@ -33,3 +34,28 @@ wrapAround (nx, ny) width = (nnx, nny)
       | ny > 600    = ny - (600 + width)
       | ny < -width = ny + 600 + width
       | otherwise   = ny
+
+newHaskelloids :: Image -> Affection UserData [Haskelloid]
+newHaskelloids img = liftIO $ 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
+    img
+  ) [1..10]
+
+updateHaskelloid :: Double -> Haskelloid -> Haskelloid
+updateHaskelloid sec has =
+  has
+    { hPos = hPos has + hVel has * V2 sec sec
+    , hRot = hRot has + hPitch has * sec
+    }

src/Init.hs

@@ -1,6 +1,6 @@
 module Init where
 
-import Affection
+import Affection as A
 
 import SDL (($=))
 import qualified SDL
@@ -8,9 +8,14 @@ import qualified SDL
 import qualified Data.Set as S
 import Data.Maybe
 
+import Control.Monad (when)
+import Control.Monad.IO.Class (liftIO)
+
 import System.Random
 
-import NanoVG
+import NanoVG hiding (V2(..))
+
+import Linear
 
 -- Internal imports
 
@@ -18,33 +23,19 @@ import Types
 
 load :: IO UserData
 load = do
+  liftIO $ logIO A.Debug "loading state"
+  liftIO $ logIO A.Debug "creating NanoVG context"
   nvgCtx <- createGL3 (S.fromList [Antialias, StencilStrokes])
-  mhaskImage <- createImage nvgCtx "assets/haskelloid.svg" 0
+  liftIO $ logIO A.Debug "load ship image"
-  mshipImage <- createImage nvgCtx "assets/ship.svg" 0
+  mshipImage <- createImage nvgCtx (FileName "assets/ship.svg") 0
-  when (isNothing mhasImage || isNothing mshipImage) $
+  when (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
+      , sImg = fromJust mshipImage
       }
     , haskelloids = []
     , wonlost = Nothing

src/Main.hs

@@ -5,9 +5,6 @@ import Affection
 import SDL (($=))
 import qualified SDL
 
-import qualified Graphics.Rendering.OpenGL as GL
-import qualified Graphics.GLUtil as GLU
-
 import qualified Data.Map as M
 
 import Linear as L
@@ -25,7 +22,7 @@ main = do
   withAffection AffectionConfig
     { initComponents = All
     , windowTitle    = "Haskelloids"
-    , windowConfig   = defaultWindow
+    , windowConfig   = SDL.defaultWindow
       { SDL.windowOpenGL = Just SDL.defaultOpenGL
         { SDL.glProfile = SDL.Core SDL.Normal 3 3
         }
@@ -37,7 +34,7 @@ main = do
     , eventLoop      = handle
     , updateLoop     = update
     , drawLoop       = draw
-    , cleanUp        = clean
+    , cleanUp        = (\_ -> return ())
     }
 
 update :: Double -> Affection UserData ()
@@ -45,19 +42,20 @@ update sec = do
   ud <- getAffection
   smUpdate (state ud) sec
 
-handle :: SDL.EventPayload -> Affection UserData ()
+handle :: [SDL.EventPayload] -> Affection UserData ()
 handle e = do
   ud <- getAffection
   smEvent (state ud) e
 
 draw :: Affection UserData ()
 draw = do
-  GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
+  return ()
-  ud <- getAffection
+  -- GL.viewport $= (GL.Position 0 0, GL.Size 800 600)
-  GL.currentProgram $= (Just . GLU.program $ program sd)
+  -- ud <- getAffection
-  let proj = ortho (-1) 1 (-1) 1 (-1) 1
+  -- GL.currentProgram $= (Just . GLU.program $ program sd)
-      view = lookAt
+  -- let proj = ortho (-1) 1 (-1) 1 (-1) 1
-        (V3 0 0 (-1))
+  --     view = lookAt
-        (V3 0 0 0)
+  --       (V3 0 0 (-1))
-        (V3 0 1 0)
+  --       (V3 0 0 0)
-      model = mkTransformation (Quaternion 1 (V3 0 0 0)) (V3 0 0 0)
+  --       (V3 0 1 0)
+  --     model = mkTransformation (Quaternion 1 (V3 0 0 0)) (V3 0 0 0)

src/Menu.hs

@@ -1,22 +1,34 @@
 module Menu where
 
-import Affection
+import Affection as A
 import qualified SDL
 
 import Debug.Trace
 
-import Types
+import Data.Maybe
 
-handleMenuEvent :: SDL.EventPayload -> Affection UserData ()
+import Control.Monad (when)
-handleMenuEvent e =
+import Control.Monad.IO.Class (liftIO)
+
+import qualified Data.Map as M
+
+import NanoVG
+
+-- internal imports
+
+import Types
+import Commons
+
+handleMenuEvent :: (Affection UserData ()) -> [SDL.EventPayload] -> Affection UserData ()
+handleMenuEvent loader es =
+  mapM_ (\e ->
     case 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"
+              loader
-            smLoad InGame
           _ -> return ()
       SDL.WindowClosedEvent _ -> do
         ad <- get
@@ -24,50 +36,36 @@ handleMenuEvent e =
           { quitEvent = True
           }
       _ -> return ()
+    ) es
 
 loadMenu :: Affection UserData ()
 loadMenu = do
+  liftIO $ logIO A.Debug "Loading Menu"
   ud <- getAffection
-  liftIO $ gegl_node_connect_to
+  mhaskImage <- liftIO $
-    (nodeGraph ud M.! KeyMenuOver)
+    createImage (nano ud) (FileName "assets/haskelloid.svg") 0
-    "output"
+  when (isNothing mhaskImage) $
-    (nodeGraph ud M.! KeyFGOver)
+    liftIO $ logIO Error "Failed to load asset haskelloid"
-    "aux"
+  hs <- newHaskelloids (fromJust mhaskImage)
-  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)
+    -- , shots = (shots ud)
-      { partSysParts = ParticleStorage Nothing [] }
+    --   { partSysParts = ParticleStorage Nothing [] }
     }
 
 updateMenu :: Double -> Affection UserData ()
 updateMenu sec = do
   ud <- getAffection
-  nhs <- mapM (updateHaskelloid sec) (haskelloids ud)
+  let nhs = map (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

@@ -4,7 +4,6 @@ module StateMachine where
 
 import Affection
 import qualified SDL
-import GEGL
 
 import qualified Data.Map as M
 import Data.Maybe (catMaybes)
@@ -15,22 +14,22 @@ import System.Random (randomRIO)
 
 import Types
 import Commons
-import InGame
+-- import InGame
 import Menu
 
 instance StateMachine State UserData where
   smLoad Menu = loadMenu
 
-  smLoad InGame = loadGame
+  -- smLoad InGame = loadGame
 
   smUpdate Menu = updateMenu
 
-  smUpdate InGame sec = updateGame sec
+  -- smUpdate InGame sec = updateGame sec
 
-  smEvent Menu = handleMenuEvent
+  smEvent Menu = handleMenuEvent (return ()) -- (smLoad InGame)
 
-  smEvent InGame = handleGameEvent
+  -- smEvent InGame = handleGameEvent
 
   smDraw Menu = return ()
 
-  smDraw InGame = drawGame
+  -- smDraw InGame = drawGame

src/Types.hs

@@ -4,7 +4,8 @@ module Types where
 
 import Affection
 import qualified SDL
-import NanoVG
+import NanoVG hiding (V2(..))
+import Linear
 
 data UserData = UserData
   { ship :: Ship
@@ -15,7 +16,7 @@ data UserData = UserData
   , pixelSize :: Int
   , state :: State
   , fade :: MenuFade
-  , neno :: Context
+  , nano :: Context
   }
 
 data Ship = Ship