From ca52ea7752b44cf4529cc6e0785f97e8b71d86f0 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 16 Dec 2017 19:06:36 +0100 Subject: [PATCH] making rewrite --- .gitignore | 2 ++ cabal.config | 1 + haskelloids.cabal | 5 +-- src/Commons.hs | 32 +++++++++++++++-- src/Init.hs | 35 +++++++------------ src/Main.hs | 28 +++++++-------- src/Menu.hs | 84 ++++++++++++++++++++++----------------------- src/StateMachine.hs | 13 ++++--- src/Types.hs | 5 +-- 9 files changed, 111 insertions(+), 94 deletions(-) create mode 100644 cabal.config diff --git a/.gitignore b/.gitignore index 79903a3..c720a2c 100644 --- a/.gitignore +++ b/.gitignore @@ -1,6 +1,8 @@ .cabal-sandbox/ cabal.sandbox.config dist/ +*.prof *.aux *.hp *.ps +*.swp diff --git a/cabal.config b/cabal.config new file mode 100644 index 0000000..2544e4b --- /dev/null +++ b/cabal.config @@ -0,0 +1 @@ +constraints: affection +debug diff --git a/haskelloids.cabal b/haskelloids.cabal index cde7cbd..cc314a1 100644 --- a/haskelloids.cabal +++ b/haskelloids.cabal @@ -53,12 +53,13 @@ executable haskelloids ghc-options: -Wall -- Modules included in this executable, other than Main. - other-modules: InGame - , Types + other-modules: Types , Commons , StateMachine , Menu + , Init + default-extensions: OverloadedStrings -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/src/Commons.hs b/src/Commons.hs index 84719dc..ff60770 100644 --- a/src/Commons.hs +++ b/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 + } diff --git a/src/Init.hs b/src/Init.hs index c52add6..d3cd264 100644 --- a/src/Init.hs +++ b/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 - mshipImage <- createImage nvgCtx "assets/ship.svg" 0 - when (isNothing mhasImage || isNothing mshipImage) $ + liftIO $ logIO A.Debug "load ship image" + mshipImage <- createImage nvgCtx (FileName "assets/ship.svg") 0 + 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 diff --git a/src/Main.hs b/src/Main.hs index b519552..c132847 100644 --- a/src/Main.hs +++ b/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) - ud <- getAffection - GL.currentProgram $= (Just . GLU.program $ program sd) - let proj = ortho (-1) 1 (-1) 1 (-1) 1 - view = lookAt - (V3 0 0 (-1)) - (V3 0 0 0) - (V3 0 1 0) - model = mkTransformation (Quaternion 1 (V3 0 0 0)) (V3 0 0 0) + return () + -- GL.viewport $= (GL.Position 0 0, GL.Size 800 600) + -- ud <- getAffection + -- GL.currentProgram $= (Just . GLU.program $ program sd) + -- let proj = ortho (-1) 1 (-1) 1 (-1) 1 + -- view = lookAt + -- (V3 0 0 (-1)) + -- (V3 0 0 0) + -- (V3 0 1 0) + -- model = mkTransformation (Quaternion 1 (V3 0 0 0)) (V3 0 0 0) diff --git a/src/Menu.hs b/src/Menu.hs index f8bd123..389ee59 100644 --- a/src/Menu.hs +++ b/src/Menu.hs @@ -1,73 +1,71 @@ 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 () -handleMenuEvent 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" - smLoad InGame - _ -> return () - SDL.WindowClosedEvent _ -> do - ad <- get - put ad - { quitEvent = True - } - _ -> return () +import Control.Monad (when) +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 + loader + _ -> return () + SDL.WindowClosedEvent _ -> do + ad <- get + put ad + { quitEvent = True + } + _ -> return () + ) es loadMenu :: Affection UserData () loadMenu = do + liftIO $ logIO A.Debug "Loading Menu" 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" + mhaskImage <- liftIO $ + createImage (nano ud) (FileName "assets/haskelloid.svg") 0 + when (isNothing mhaskImage) $ + liftIO $ logIO Error "Failed to load asset haskelloid" + hs <- newHaskelloids (fromJust mhaskImage) putAffection ud { haskelloids = hs , fade = FadeIn 1 , state = Menu - , shots = (shots ud) - { partSysParts = ParticleStorage Nothing [] } + -- , shots = (shots ud) + -- { 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 diff --git a/src/StateMachine.hs b/src/StateMachine.hs index ee8ce2e..5aad6ca 100644 --- a/src/StateMachine.hs +++ b/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 diff --git a/src/Types.hs b/src/Types.hs index 4a65d8e..3c72a58 100644 --- a/src/Types.hs +++ b/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