From 5661e72cf2782a550bf6191097db999db3fef293 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 1 Jan 2017 22:58:54 +0100 Subject: [PATCH 01/18] stuff --- src/Commons.hs | 73 +++++++++++++++++++++++++++++++++++++++++--------- src/Main.hs | 29 +++++++++++++------- src/Types.hs | 10 +++++++ 3 files changed, 90 insertions(+), 22 deletions(-) diff --git a/src/Commons.hs b/src/Commons.hs index 95486f0..cc4ba0c 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -94,14 +94,42 @@ load _ = do -- 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\nPress [H] for Highscore" + , 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 [ship, 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 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" + -- 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) @@ -118,15 +146,18 @@ load _ = do , (KeyPixelize, pixelize) , (KeyFGOver, fgover) , (KeyFGNop, fgnop) + , (KeyMenuHeading, menuTranslateHeading) + , (KeyMenuText, menuText) + , (KeyMenuOver, menuOver) ] - hs <- catMaybes <$> foldM (\acc _ -> do - px <- liftIO $ randomRIO (0, 800) - py <- liftIO $ 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) hnop - return $ UserData + -- hs <- catMaybes <$> foldM (\acc _ -> do + -- px <- liftIO $ randomRIO (0, 800) + -- py <- liftIO $ 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) hnop + loadMenu $ UserData { nodeGraph = myMap , ship = Ship { sPos = (375, 275) @@ -136,10 +167,26 @@ load _ = do } , buffer = buffer , shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer - , haskelloids = hs + -- , haskelloids = hs + , haskelloids = [] , wonlost = False , pixelSize = 3 - , state = InGame + , state = Menu + } + +loadMenu :: UserData -> IO UserData +loadMenu ud = do + gegl_node_link (nodeGraph ud M.! KeyMenuOver) (nodeGraph ud M.! KeyFGNop) + hs <- 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) + return ud + { haskelloids = hs + , fade = FadeIn 1 } insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid] diff --git a/src/Main.hs b/src/Main.hs index 1a72bce..b900777 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -16,9 +16,11 @@ import Debug.Trace -- internal imports import Types -import InGame import Commons +import Menu +import InGame + main :: IO () main = withAffection $ AffectionConfig { initComponents = All @@ -45,9 +47,15 @@ update sec = do putAffection pd { pixelSize = pixelSize wd -1 } + case state wd of + Menu -> + updateMenu sec + _ -> return () evs <- SDL.pollEvents mapM_ (\e -> case state wd of + Menu -> + handleMenuEvent sec e InGame -> handleGameEvent sec e _ -> error "not yet implemented" @@ -200,14 +208,17 @@ updateHaskelloid sec h@Haskelloid{..} = do [ 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 - ) + 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 diff --git a/src/Types.hs b/src/Types.hs index 88cd3a2..bf6574a 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -16,6 +16,7 @@ data UserData = UserData , wonlost :: Bool , pixelSize :: Int , state :: StateMachine + , fade :: MenuFade } data Ship = Ship @@ -50,9 +51,18 @@ data NodeKey | KeyPixelize | KeyFGOver | KeyFGNop + | KeyMenuHeading + | KeyMenuText + | KeyMenuStart + | KeyMenuHighscore + | KeyMenuOver deriving (Ord, Eq) data StateMachine = Menu | HighScore | InGame + +data MenuFade + = FadeIn Double + | FadeOut Double From 8fc717fd8bfcc5d4bf9f97f7d70c5186fe48ba4f Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 2 Jan 2017 16:22:23 +0100 Subject: [PATCH 02/18] make make --- haskelloids.cabal | 1 + src/Commons.hs | 15 --------------- src/Main.hs | 5 ++++- src/Transitions.hs | 21 +++++++++++++++++++++ src/Types.hs | 16 ++++++++++++++-- 5 files changed, 40 insertions(+), 18 deletions(-) create mode 100644 src/Transitions.hs diff --git a/haskelloids.cabal b/haskelloids.cabal index 9f4a275..64a61db 100644 --- a/haskelloids.cabal +++ b/haskelloids.cabal @@ -56,6 +56,7 @@ executable haskelloids other-modules: InGame , Types , Commons + , Transitions -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/src/Commons.hs b/src/Commons.hs index cc4ba0c..926f0b6 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -174,21 +174,6 @@ load _ = do , state = Menu } -loadMenu :: UserData -> IO UserData -loadMenu ud = do - gegl_node_link (nodeGraph ud M.! KeyMenuOver) (nodeGraph ud M.! KeyFGNop) - hs <- 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) - return ud - { haskelloids = hs - , fade = FadeIn 1 - } - insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid] insertHaskelloid hasks split (px, py) = do -- liftIO $ traceIO "inserting haskelloid" diff --git a/src/Main.hs b/src/Main.hs index b900777..dc4eb86 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -26,7 +26,7 @@ main = withAffection $ AffectionConfig { initComponents = All , windowTitle = "Haskelloids" , windowConfig = defaultWindow - , preLoop = return () + , preLoop = transition , drawLoop = draw , updateLoop = update , loadState = load @@ -86,6 +86,9 @@ update sec = do , shots = ups } +transition :: Affection us () +transition = return () + wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t) wrapAround (nx, ny) width = (nnx, nny) where diff --git a/src/Transitions.hs b/src/Transitions.hs new file mode 100644 index 0000000..fdf5604 --- /dev/null +++ b/src/Transitions.hs @@ -0,0 +1,21 @@ +module Transitions where + +import Affection +import qualified SDL +import GEGL +import BABL + +loadMenu :: UserData -> IO UserData +loadMenu ud = do + gegl_node_link (nodeGraph ud M.! KeyMenuOver) (nodeGraph ud M.! KeyFGNop) + hs <- 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) + return ud + { haskelloids = hs + , fade = FadeIn 1 + } diff --git a/src/Types.hs b/src/Types.hs index bf6574a..eb42b9e 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + module Types where import Affection @@ -15,7 +17,7 @@ data UserData = UserData -- , debris :: ParticleSystem , wonlost :: Bool , pixelSize :: Int - , state :: StateMachine + , state :: State , fade :: MenuFade } @@ -58,11 +60,21 @@ data NodeKey | KeyMenuOver deriving (Ord, Eq) -data StateMachine +data State = Menu | HighScore | InGame +class StateMachine a us where + load :: a -> Affection us () + update :: a -> Affection us () + draw :: a -> Affection us () + clean :: a -> Affection us () + +instance StateMachine State UserData where + update Menu = return () + + data MenuFade = FadeIn Double | FadeOut Double From 0aff3e84ca036f1c46e937fcea754b04fa4fa12b Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 2 Jan 2017 23:29:32 +0100 Subject: [PATCH 03/18] more state machining --- src/Commons.hs | 2 +- src/Main.hs | 15 +++++++---- src/Transitions.hs | 64 ++++++++++++++++++++++++++++++++++++---------- src/Types.hs | 12 ++++----- 4 files changed, 67 insertions(+), 26 deletions(-) diff --git a/src/Commons.hs b/src/Commons.hs index 926f0b6..a243902 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -157,7 +157,7 @@ load _ = do -- ) [] ([0..9] :: [Int]) -- liftIO $ gegl_node_link_many $ map hFlange hs -- liftIO $ gegl_node_link (last $ map hFlange hs) hnop - loadMenu $ UserData + return $ UserData { nodeGraph = myMap , ship = Ship { sPos = (375, 275) diff --git a/src/Main.hs b/src/Main.hs index dc4eb86..d14d57e 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -17,6 +17,7 @@ import Debug.Trace import Types import Commons +import Transitions import Menu import InGame @@ -26,13 +27,16 @@ main = withAffection $ AffectionConfig { initComponents = All , windowTitle = "Haskelloids" , windowConfig = defaultWindow - , preLoop = transition + , preLoop = pre , drawLoop = draw , updateLoop = update , loadState = load , cleanUp = clean } +pre :: Affection UserData () +pre = smLoad Menu + update :: Double -> Affection UserData () update sec = do -- traceM $ (show $ 1 / sec) ++ " FPS" @@ -47,10 +51,11 @@ update sec = do putAffection pd { pixelSize = pixelSize wd -1 } - case state wd of - Menu -> - updateMenu sec - _ -> return () + -- case state wd of + -- Menu -> + -- updateMenu sec + -- _ -> return () + smUpdate (state wd) sec evs <- SDL.pollEvents mapM_ (\e -> case state wd of diff --git a/src/Transitions.hs b/src/Transitions.hs index fdf5604..a561598 100644 --- a/src/Transitions.hs +++ b/src/Transitions.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + module Transitions where import Affection @@ -5,17 +7,51 @@ import qualified SDL import GEGL import BABL -loadMenu :: UserData -> IO UserData -loadMenu ud = do - gegl_node_link (nodeGraph ud M.! KeyMenuOver) (nodeGraph ud M.! KeyFGNop) - hs <- 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) - return ud - { haskelloids = hs - , fade = FadeIn 1 - } +import qualified Data.Map as M +import Data.Maybe (catMaybes) + +import Control.Monad (foldM) + +import System.Random (randomRIO) + +import Types +import Commons + +instance StateMachine State UserData where + smLoad Menu = do + ud <- getAffection + liftIO $ gegl_node_link + (nodeGraph ud M.! KeyMenuOver) + (nodeGraph ud M.! KeyFGNop) + 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) + putAffection ud + { haskelloids = hs + , fade = FadeIn 1 + , state = Menu + } + + smUpdate Menu sec = do + ud <- getAffection + 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 + } + 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 + } diff --git a/src/Types.hs b/src/Types.hs index eb42b9e..711fa81 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -66,13 +66,13 @@ data State | InGame class StateMachine a us where - load :: a -> Affection us () - update :: a -> Affection us () - draw :: a -> Affection us () - clean :: a -> Affection us () + smLoad :: a -> Affection us () + smUpdate :: a -> Double -> Affection us () + smDraw :: a -> Affection us () + smClean :: a -> Affection us () -instance StateMachine State UserData where - update Menu = return () +-- instance StateMachine State UserData where +-- update Menu = return () data MenuFade From f7d75db28780c986c6a693633f43b8324e571b9a Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 2 Jan 2017 23:49:17 +0100 Subject: [PATCH 04/18] reducing warnings --- src/Commons.hs | 18 +++++++++--------- src/Transitions.hs | 2 -- src/Types.hs | 2 -- 3 files changed, 9 insertions(+), 13 deletions(-) diff --git a/src/Commons.hs b/src/Commons.hs index a243902..7040d0b 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -6,7 +6,6 @@ import GEGL import BABL import qualified Data.Map as M -import Data.Maybe (catMaybes) import Control.Monad (foldM) @@ -36,7 +35,7 @@ load _ = do , Property "height" $ PropertyDouble 600 , Property "color" $ PropertyColor $ GEGL.RGBA 0 0 0.1 1 ] - ship <- gegl_node_new_child root $ Operation "gegl:svg-load" + shipNode <- gegl_node_new_child root $ Operation "gegl:svg-load" [ Property "path" $ PropertyString "assets/ship.svg" , Property "width" $ PropertyInt 50 , Property "height" $ PropertyInt 50 @@ -68,10 +67,10 @@ load _ = do [ Property "width" $ PropertyDouble 800 , Property "height" $ PropertyDouble 600 ] - buffer <- gegl_buffer_new (Just $ GeglRectangle 0 0 800 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 buffer + [ Property "buffer" $ PropertyBuffer nbuffer ] won <- gegl_node_new_child root $ textOperation [ Property "string" $ PropertyString "YOU WON!" @@ -120,8 +119,8 @@ load _ = do 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 [ship, rotate, translate] + _ <- 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" @@ -135,7 +134,7 @@ load _ = do [ (KeyRoot, root) , (KeyTranslate, translate) , (KeyRotate, rotate) - , (KeyShip, ship) + , (KeyShip, shipNode) , (KeyPNop, pnop) , (KeyHNop, hnop) , (KeyCrop, crop) @@ -165,13 +164,14 @@ load _ = do , sRot = 0 , sFlange = rotate } - , buffer = buffer - , shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer + , 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] diff --git a/src/Transitions.hs b/src/Transitions.hs index a561598..d1d51be 100644 --- a/src/Transitions.hs +++ b/src/Transitions.hs @@ -3,9 +3,7 @@ module Transitions where import Affection -import qualified SDL import GEGL -import BABL import qualified Data.Map as M import Data.Maybe (catMaybes) diff --git a/src/Types.hs b/src/Types.hs index 711fa81..7095f1a 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -3,9 +3,7 @@ module Types where import Affection -import qualified SDL import GEGL -import BABL import qualified Data.Map as M data UserData = UserData From eae27cbe15cb8aedf8f24f6a59bb77d0c28b9455 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 3 Jan 2017 00:25:34 +0100 Subject: [PATCH 05/18] state machine --- haskelloids.cabal | 2 +- src/Main.hs | 38 ++++++++++---------------------- src/Transitions.hs | 55 ---------------------------------------------- src/Types.hs | 11 +--------- 4 files changed, 13 insertions(+), 93 deletions(-) delete mode 100644 src/Transitions.hs diff --git a/haskelloids.cabal b/haskelloids.cabal index 64a61db..c8f0f34 100644 --- a/haskelloids.cabal +++ b/haskelloids.cabal @@ -56,7 +56,7 @@ executable haskelloids other-modules: InGame , Types , Commons - , Transitions + , StateMachine -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/src/Main.hs b/src/Main.hs index d14d57e..92189c6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -17,7 +17,7 @@ import Debug.Trace import Types import Commons -import Transitions +import StateMachine import Menu import InGame @@ -57,14 +57,15 @@ update sec = do -- _ -> return () smUpdate (state wd) sec evs <- SDL.pollEvents - mapM_ (\e -> - case state wd of - Menu -> - handleMenuEvent sec e - InGame -> - handleGameEvent sec e - _ -> error "not yet implemented" - ) evs + -- mapM_ (\e -> + -- case state wd of + -- Menu -> + -- handleMenuEvent sec e + -- InGame -> + -- handleGameEvent sec e + -- _ -> error "not yet implemented" + -- ) evs + mapM_ (smEvent (state wd) sec) evs ud2 <- getAffection nhs <- mapM (updateHaskelloid sec) (haskelloids ud2) -- liftIO $ traceIO $ show $ length nhs @@ -91,9 +92,6 @@ update sec = do , shots = ups } -transition :: Affection us () -transition = return () - wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t) wrapAround (nx, ny) width = (nnx, nny) where @@ -109,21 +107,7 @@ wrapAround (nx, ny) width = (nnx, nny) draw :: Affection UserData () draw = do ud <- getAffection - liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink - -- mintr <- liftIO $ gegl_rectangle_intersect - -- (GeglRectangle 0 0 800 600) - -- (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50) - -- maybe (return ()) (\intr -> - -- present - -- (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50) - -- (buffer ud) - -- False - -- ) mintr - -- XXX: above part crashes regularly for no apparent reason - present - (GeglRectangle 0 0 800 600) - (buffer ud) - True + smDraw $ state ud shotsUpd :: Double -> Particle -> Affection UserData Particle shotsUpd sec part@Particle{..} = do diff --git a/src/Transitions.hs b/src/Transitions.hs deleted file mode 100644 index d1d51be..0000000 --- a/src/Transitions.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# LANGUAGE MultiParamTypeClasses #-} - -module Transitions where - -import Affection -import GEGL - -import qualified Data.Map as M -import Data.Maybe (catMaybes) - -import Control.Monad (foldM) - -import System.Random (randomRIO) - -import Types -import Commons - -instance StateMachine State UserData where - smLoad Menu = do - ud <- getAffection - liftIO $ gegl_node_link - (nodeGraph ud M.! KeyMenuOver) - (nodeGraph ud M.! KeyFGNop) - 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) - putAffection ud - { haskelloids = hs - , fade = FadeIn 1 - , state = Menu - } - - smUpdate Menu sec = do - ud <- getAffection - 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 - } - 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 - } diff --git a/src/Types.hs b/src/Types.hs index 7095f1a..5dfea8a 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -3,6 +3,7 @@ module Types where import Affection +import qualified SDL import GEGL import qualified Data.Map as M @@ -63,16 +64,6 @@ data State | HighScore | InGame -class StateMachine a us where - smLoad :: a -> Affection us () - smUpdate :: a -> Double -> Affection us () - smDraw :: a -> Affection us () - smClean :: a -> Affection us () - --- instance StateMachine State UserData where --- update Menu = return () - - data MenuFade = FadeIn Double | FadeOut Double From a1c6ce6b92b12cfc9231d2b20b2665d3955a393a Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 3 Jan 2017 17:34:37 +0100 Subject: [PATCH 06/18] works halfway as intended --- src/Commons.hs | 148 +++++++++++++++++++++- src/InGame.hs | 91 +++++++++++++- src/Main.hs | 336 ++++++++++++++++++++++++------------------------- src/Types.hs | 4 +- 4 files changed, 404 insertions(+), 175 deletions(-) diff --git a/src/Commons.hs b/src/Commons.hs index 7040d0b..0a15211 100644 --- a/src/Commons.hs +++ b/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 () diff --git a/src/InGame.hs b/src/InGame.hs index e0e86a0..f275b09 100644 --- a/src/InGame.hs +++ b/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 diff --git a/src/Main.hs b/src/Main.hs index 92189c6..d324c96 100644 --- a/src/Main.hs +++ b/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 - 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 - } + -- 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 + -- } -- 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 - 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.! KeyTranslate) $ Operation "gegl:translate" - [ Property "x" $ PropertyDouble $ nnx - , Property "y" $ PropertyDouble $ nny - ] - liftIO $ gegl_node_set (nodeGraph ud3 M.! KeyRotate) $ Operation "gegl:rotate" - [ Property "degrees" $ PropertyDouble $ sRot $ ship ud3 - ] - ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw - ud4 <- getAffection - putAffection ud4 - { ship = (ship ud3) - { sPos = (nnx, nny) - } - , shots = ups - } + -- 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 shotsDraw + -- ud4 <- getAffection + -- putAffection ud4 + -- { ship = (ship ud3) + -- { sPos = (nnx, nny) + -- } + -- , shots = ups + -- } -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 +-- 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 draw :: Affection UserData () draw = do ud <- getAffection smDraw $ state ud -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 - } - -shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData () -shotsDraw _ _ _ = return () - -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 $ 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 - } - -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 () +-- 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 +-- } +-- +-- shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData () +-- shotsDraw _ _ _ = return () +-- +-- 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 $ 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 +-- } +-- +-- 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 () diff --git a/src/Types.hs b/src/Types.hs index 5dfea8a..46cee94 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -39,9 +39,9 @@ data Haskelloid = Haskelloid data NodeKey = KeyRoot - | KeyTranslate - | KeyRotate | KeyShip + | KeyShipTranslate + | KeyShipRotate | KeyPNop | KeyHNop | KeyCrop From b2e622a5c8fc0706ca77feef7aa5504c4b3149c6 Mon Sep 17 00:00:00 2001 From: nek0 Date: Tue, 3 Jan 2017 19:36:01 +0100 Subject: [PATCH 07/18] linted --- src/Commons.hs | 66 ++++++++++++++++++++++++-------------------------- src/InGame.hs | 40 +++++++++++++++--------------- src/Main.hs | 4 +-- 3 files changed, 53 insertions(+), 57 deletions(-) diff --git a/src/Commons.hs b/src/Commons.hs index 0a15211..bb38165 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -11,7 +11,7 @@ import qualified Data.Map as M import Data.List (delete) import Data.Maybe (catMaybes) -import Control.Monad (foldM, when) +import Control.Monad (foldM, unless) import System.Random (randomRIO) @@ -24,7 +24,7 @@ toR deg = deg * pi / 180 clean :: UserData -> IO () clean ud = do - mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud) + mapM_ (gegl_node_drop . (\h -> hNodeGraph h M.! "root")) (haskelloids ud) gegl_node_drop $ nodeGraph ud M.! KeyRoot load :: SDL.Surface -> IO UserData @@ -47,11 +47,11 @@ load _ = do 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 + 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 @@ -120,7 +120,7 @@ load _ = do , Property "y" $ PropertyDouble 300 , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic ] - menuOver <- gegl_node_new_child root $ defaultOverOperation + 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" @@ -160,7 +160,7 @@ load _ = do -- ) [] ([0..9] :: [Int]) -- liftIO $ gegl_node_link_many $ map hFlange hs -- liftIO $ gegl_node_link (last $ map hFlange hs) hnop - return $ UserData + return UserData { nodeGraph = myMap , ship = Ship { sPos = (375, 275) @@ -188,8 +188,8 @@ insertHaskelloid hasks split (px, py) = do Just x -> return $ x + 1 rot <- liftIO $ randomRIO (0, 360) pitch <- liftIO $ randomRIO (-45, 45) - tempRoot <- liftIO $ gegl_node_new - tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation + tempRoot <- liftIO gegl_node_new + tempOver <- liftIO $ gegl_node_new_child tempRoot defaultOverOperation tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load" [ Property "path" $ PropertyString "assets/haskelloid.svg" , Property "width" $ PropertyInt (100 `div` rdiv) @@ -262,14 +262,14 @@ haskelloidShotDown h = do updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid updateHaskelloid sec h@Haskelloid{..} = do - let newX = (fst $ hPos) + sec * (fst $ hVel) - newY = (snd $ hPos) + sec * (snd $ hVel) + 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 + [ Property "x" $ PropertyDouble nnx + , Property "y" $ PropertyDouble nny ] liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate" [ Property "degrees" $ PropertyDouble newRot @@ -286,9 +286,7 @@ updateHaskelloid sec h@Haskelloid{..} = do 50 ) _ -> return Nothing - maybe (return ()) (\_ -> - lose - ) lost + maybe (return ()) (const lose) lost return h { hPos = (nnx, nny) , hRot = newRot @@ -297,23 +295,23 @@ updateHaskelloid sec h@Haskelloid{..} = do 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 + nnx + | nx > 800 = nx - (800 + width) + | nx < -width = nx + 800 + width + | otherwise = nx + 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) + 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 + [ Property "x" $ PropertyDouble nnx + , Property "y" $ PropertyDouble nny ] ud <- getAffection inters <- catMaybes <$> mapM (\h -> do @@ -329,7 +327,7 @@ shotsUpd sec part@Particle{..} = do Just _ -> return $ Just h Nothing -> return Nothing ) (haskelloids ud) - when (not $ null inters) $ + unless (null inters) $ haskelloidShotDown $ head inters lost <- liftIO $ gegl_rectangle_intersect (GeglRectangle (floor nnx) (floor nny) 4 4) @@ -339,12 +337,10 @@ shotsUpd sec part@Particle{..} = do 50 50 ) - maybe (return ()) (\_ -> - lose - ) lost + maybe (return ()) (const lose) lost return part { particlePosition = (nnx, nny) - , particleTimeToLive = if (not $ null inters) then 0 else particleTimeToLive + , particleTimeToLive = if not $ null inters then 0 else particleTimeToLive } shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData () diff --git a/src/InGame.hs b/src/InGame.hs index f275b09..9a9f8c1 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -41,7 +41,7 @@ loadGame = do { sPos = (375, 275) , sVel = (0, 0) , sRot = 0 - , sFlange = (nodeGraph ud M.! KeyShipRotate) + , sFlange = nodeGraph ud M.! KeyShipRotate } , pixelSize = 3 , state = InGame @@ -73,12 +73,12 @@ updateGame sec = do 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 + 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 + [ 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 @@ -108,13 +108,13 @@ handleGameEvent sec e = do wd <- getAffection case SDL.eventPayload e of SDL.KeyboardEvent dat -> - case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of + case SDL.keysymKeycode $ SDL.keyboardEventKeysym dat of SDL.KeycodeLeft -> do ud <- getAffection when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $ putAffection ud { ship = (ship ud) - { sRot = (sRot $ ship ud) + 270 * sec + { sRot = sRot (ship ud) + 270 * sec } } SDL.KeycodeRight -> do @@ -122,14 +122,14 @@ handleGameEvent sec e = do when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ putAffection ud { ship = (ship ud) - { sRot = (sRot $ ship ud) - 270 * sec + { sRot = sRot (ship ud) - 270 * sec } } SDL.KeycodeUp -> when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do ud <- getAffection - let vx = -10 * (sin (toR $ (sRot $ ship ud))) + fst (sVel $ ship ud) - vy = -10 * (cos (toR $ (sRot $ ship ud))) + snd (sVel $ ship ud) + let vx = -10 * sin (toR $ sRot $ ship ud) + fst (sVel $ ship ud) + vy = -10 * cos (toR $ sRot $ ship ud) + snd (sVel $ ship ud) putAffection ud { ship = (ship ud) { sVel = (vx, vy) @@ -144,19 +144,19 @@ handleGameEvent sec e = do , Property "size-y" $ PropertyInt 8 ] -- ad <- get - 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 + 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 "x" $ PropertyDouble posX + , Property "y" $ PropertyDouble posY , Property "width" $ PropertyDouble 4 , Property "height" $ PropertyDouble 4 - , Property "color" $ PropertyColor $ (GEGL.RGBA 1 1 1 1) + , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1 ] - tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation + tempOver <- liftIO $ gegl_node_new_child tempRoot defaultOverOperation _ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux" - ips <- insertParticle (shots ud) $ + ips <- insertParticle (shots ud) Particle { particleTimeToLive = 5 , particleCreation = elapsedTime ad @@ -165,8 +165,8 @@ handleGameEvent sec e = do , particleVelocity = -- ( (floor $ -200 * (sin $ toR $ (sRot $ ship ud) + (fst $ sVel $ ship ud))) -- , (floor $ -200 * (cos $ toR $ (sRot $ ship ud) + (snd $ sVel $ ship ud))) - ( (floor $ -200 * (sin $ toR $ sRot $ ship ud)) - , (floor $ -200 * (cos $ toR $ sRot $ ship ud)) + ( (floor $ (-200) * (sin $ toR $ sRot $ ship ud)) + , (floor $ (-200) * (cos $ toR $ sRot $ ship ud)) ) , particlePitchRate = Rad 0 , particleRootNode = tempRoot diff --git a/src/Main.hs b/src/Main.hs index d324c96..a9afdf1 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} module Main where import Affection @@ -23,7 +23,7 @@ import Menu import InGame main :: IO () -main = withAffection $ AffectionConfig +main = withAffection AffectionConfig { initComponents = All , windowTitle = "Haskelloids" , windowConfig = defaultWindow From ef6aa711428c708e5b60a98450fed81a8273c0ee Mon Sep 17 00:00:00 2001 From: nek0 Date: Thu, 12 Jan 2017 18:48:23 +0100 Subject: [PATCH 08/18] blergh --- src/InGame.hs | 18 ++++- src/Main.hs | 192 +++----------------------------------------------- 2 files changed, 25 insertions(+), 185 deletions(-) diff --git a/src/InGame.hs b/src/InGame.hs index 9a9f8c1..80559fa 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -94,7 +94,7 @@ updateGame sec = do putAffection ud2 { haskelloids = nhs } - liftIO $ traceIO $ show $ length nhs + -- liftIO $ traceIO $ show $ length nhs ud3 <- getAffection ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw ud4 <- getAffection @@ -102,6 +102,22 @@ updateGame sec = do { shots = ups } +drawGame :: Affection UserData () +drawGame = do + ud <- getAffection + liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink + present + (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50) + (buffer ud) + False + mapM_ (\h -> do + let s = 100 `div` hDiv h + present + (GeglRectangle (floor $ fst $ hPos h) (floor $ snd $ hPos h) s s) + (buffer ud) + False + ) (haskelloids ud) + handleGameEvent :: Double -> SDL.Event -> Affection UserData () handleGameEvent sec e = do ad <- get diff --git a/src/Main.hs b/src/Main.hs index a9afdf1..4545a72 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -35,199 +35,23 @@ main = withAffection AffectionConfig } pre :: Affection UserData () -pre = smLoad Menu +pre = do + smLoad Menu + -- ud <- getAffection + -- liftIO $ gegl_node_process (nodeGraph ud M.! KeySink) + -- present + -- (GeglRectangle 0 0 800 600) + -- (buffer ud) + -- True update :: Double -> Affection UserData () update sec = do - -- traceM $ (show $ 1 / sec) ++ " FPS" - -- ad <- get wd <- getAffection - -- 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 - -- } - -- case state wd of - -- Menu -> - -- updateMenu sec - -- _ -> return () smUpdate (state wd) sec evs <- SDL.pollEvents - -- mapM_ (\e -> - -- case state wd of - -- Menu -> - -- handleMenuEvent sec e - -- InGame -> - -- handleGameEvent sec e - -- _ -> error "not yet implemented" - -- ) evs mapM_ (smEvent (state wd) sec) 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 shotsDraw - -- ud4 <- getAffection - -- putAffection ud4 - -- { ship = (ship ud3) - -- { sPos = (nnx, nny) - -- } - -- , shots = ups - -- } - --- 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 draw :: Affection UserData () draw = do ud <- getAffection smDraw $ state ud - --- 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 --- } --- --- shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData () --- shotsDraw _ _ _ = return () --- --- 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 $ 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 --- } --- --- 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 () From 58417742849c0f55ad64bdbd4d88278a6a3e54aa Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 20 Feb 2017 20:21:06 +0100 Subject: [PATCH 09/18] changes in the engine --- haskelloids.cabal | 2 +- src/InGame.hs | 33 ++++++++++++++++++++++++--------- src/Main.hs | 5 ++--- 3 files changed, 27 insertions(+), 13 deletions(-) diff --git a/haskelloids.cabal b/haskelloids.cabal index c8f0f34..9ce4d1e 100644 --- a/haskelloids.cabal +++ b/haskelloids.cabal @@ -66,7 +66,7 @@ executable haskelloids , affection , gegl , babl - , sdl2 + , sdl2 >= 2.1.3.1 , containers , random diff --git a/src/InGame.hs b/src/InGame.hs index 80559fa..81d8e2f 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -18,18 +18,22 @@ import Commons loadGame :: Affection UserData () loadGame = do + liftIO $ traceIO "loading game" ud <- getAffection _ <- liftIO $ gegl_node_connect_to (nodeGraph ud M.! KeyShipTranslate) "output" (nodeGraph ud M.! KeyShipOver) "aux" + liftIO $ traceIO "nodes connected" hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do coords <- liftIO excludeShip insertHaskelloid acc Nothing coords ) [] ([0..9] :: [Int]) + liftIO $ traceIO "inserted haskelloids" liftIO $ gegl_node_link_many $ map hFlange hs liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop) + liftIO $ traceIO "nodes linked" putAffection ud { haskelloids = hs , wonlost = False @@ -46,6 +50,11 @@ loadGame = do , pixelSize = 3 , state = InGame } + liftIO $ traceIO "game loaded" + present + (GeglRectangle 0 0 800 600) + (buffer ud) + True excludeShip :: IO (Double, Double) excludeShip = do @@ -104,19 +113,25 @@ updateGame sec = do drawGame :: Affection UserData () drawGame = do + -- ud <- getAffection + -- liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink + -- present + -- (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50) + -- (buffer ud) + -- False + -- mapM_ (\h -> do + -- let s = 100 `div` hDiv h + -- present + -- (GeglRectangle (floor $ fst $ hPos h) (floor $ snd $ hPos h) s s) + -- (buffer ud) + -- False + -- ) (haskelloids ud) ud <- getAffection liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink present - (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50) + (GeglRectangle 0 0 800 600) (buffer ud) - False - mapM_ (\h -> do - let s = 100 `div` hDiv h - present - (GeglRectangle (floor $ fst $ hPos h) (floor $ snd $ hPos h) s s) - (buffer ud) - False - ) (haskelloids ud) + True handleGameEvent :: Double -> SDL.Event -> Affection UserData () handleGameEvent sec e = do diff --git a/src/Main.hs b/src/Main.hs index 4545a72..deb67b6 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -44,11 +44,10 @@ pre = do -- (buffer ud) -- True -update :: Double -> Affection UserData () -update sec = do +update :: Double -> [SDL.Event] -> Affection UserData () +update sec evs = do wd <- getAffection smUpdate (state wd) sec - evs <- SDL.pollEvents mapM_ (smEvent (state wd) sec) evs draw :: Affection UserData () From e2d1bf9042fa21528a0e973e7547e462ef09431d Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 20 Feb 2017 20:51:06 +0100 Subject: [PATCH 10/18] ship missing --- assets/ship.png | Bin 0 -> 4705 bytes 1 file changed, 0 insertions(+), 0 deletions(-) create mode 100644 assets/ship.png diff --git a/assets/ship.png b/assets/ship.png new file mode 100644 index 0000000000000000000000000000000000000000..d247a5361fd24624c84ca40fa21fe4f7fd33e6cf GIT binary patch literal 4705 zcmX9?2UJr_*S+*2kMabm(u*j)NReI=K>|pTB1H&2pco>dDj*052pDQ;QUqy1CG;YQ zQY4|OK{}7FBp@I~+JE`}yVl%UXU~~EXV00rGwUW=nnV9#=3@o`;2)ElMpj^5eqI>q z!MA0?E*h+8gA7b;7{Mok(IWx0nF4P*1Ob5T@p+-b^=#yTATP?;9%cQ&3x#$=dID%P zTF&=AA_(pl=qdLA>77T>;sXGVSra3Dn~;2RK`1K27TY^#I*~2>N|;fW-7-3OdCiHi!0zu)C+{yJZ6KG^@95uUn52OlvZXAlc&ksmm`G5n9Yd9}3cDvI^ZSXK zs@J$-Bw~+OQsrHLeuqhjH+0xGQ8o{sV)DP*?RV}k)Yf&9IewRM&KE^t8u}J~f2GFL zH3IT}sh<}s=|U2suFi{-e}`yMb5czuZr>m)hH6o3naX7936UR$Zu7jNd5dX1z7y_W zs70UiZ(oKRX`@zK$3l=AMIRh*?lfR}wNiz6$WK-b+h)IqUH{n4;w2YE#)X#bscVPQ z2FkpZLd{pVKNsFDW{cPG#|CBX*@O6&(^|V<74IkEGRRJjH{Xu%h+%kpp%$=4f6T7= zK;!}fCe8SnbIN%ql&l!O4a^^oJcO!$tjyr73Db!cBY|k^CA1Z(Y)mvK9o>R%7_^$ zIu%$*@Euykug*VYPY^7tDSPSuoL{9}Sms`|FF`0uZgOW!oz{|Nw4hgmpiw1F=LXPh z;0}}boU~Y}M(ciL+KlDRrYM2_9>u-}k9zcz&Ouds`C6>N zvE6Ruuy8ZWGtiU($s8yjX&CDx{(|1EoW zz98k_A=Gy`Fy1fF`TlEcj7e3Y24B2nIFtaPI}zTPbeN0H;_GD5h4GYsKEH&`ZIheMtQnwYb&z(Bf=ijFr#D>%P0i3Fr$i~QyIs-mWl)R zbFW3{tXA{aDf0EHw;^2WoNrk?7v@8o9G;uMRm@@~q1QWHPRO*HF1{7z@AnXoo_oWphB`MX1G&>Hch%U|2!8}T4 zROLr;9TkFa4JfP1t}}Y;RzX;6(@I|gTO^5K3#saURfi9DBK0%DqB!T(=h%;wPM#7S4^b+o&}I zN*hSxn<4|C{q^}Be|L;8VZVVSu_;0)vM;wLNO{+`5;}>%G^Le*9-I}3&gu@G&`B`xll&0N9 z6HGb|CpUcIziADM@Vj-l5%PeUF635t$2R@gd6bfh0~GA4PhIX#+RAxEFM|Eyc@E`g zqb_QzA~fd_aR`DDF_IgCE-7(>9iCrtXShK?b`*C!9- z{ej>(KlK=bAwovfZ|%b`7tq9kyu0eD;HO`P+<>CbIL`!wrlo$IL#OfNuXUCy&p-yL zkdG=}s)6Nu*cB~%k$rSv{9l7rtmbH<_9z1eIBwc&T~YBc0lBeXY}yd4V=i;~aWYI` znhVzb(ZuWqlA4srAjmv2t_ALS>jsj>s__5pcLIYhdst8BR~KB z5TXt}q?dI*I1aTOzt*z_tbmZYUe>vybu+aT2fF-{4vGU?V7)_w{{?WYz96lmQnt@D z2NvWK4~#G(M5 zVsoI<5I}A|Us33zU^^Nji&-@UK_UO4h}`(dVrJIZ>9&%VQRqax^Nvx#lQ+>~VBX%a zMXC!#Dkyi!fJl^~$Ue?Ta0fhPX~TSu#24r7!Ku7jK0(0_BaXyN=kN7*Tnm%t1E>Q5 zb^R%MUK;568rS{%!#Sw6(N&3>6`YfjLqb!V7dl|B>@p~HTpboE((e8ZJaH3sW(DUR zK%DCp|BG`+IvItOLz)reDP7;ETIWfk;kkzAh~Yw>iON@T&s0AQi?iFnh2}RFS<#1{C(V3OrK&XD6tM6)l9ov8JD0-El;;H(D?cp|}aZf9D$qlta^lT7x5 zwD47YtVA$L3o_*mqZdMM=08)QO@iVhzl(2)><{@#--5v@z$D_Rb`+?K6WbTrzwc}B zf1ubU9`Hex85Ca;V%m}8Qu*y}yC+{zxH$?I(ciJdHx$^0(0M~{qwkKNUQNk*M{xQX zpm!tS?AryMC7lN<|9{#|J$ZQET#yA_T&!$*G;=wE@Rbu zbAn@rnkG`~_NCv)94Bw)Y1Y-IF>735@T}O#xcuI*aWGgq)9TQ)^JN`kw>IJ$bSdE@ z!D=vkyO1S&VIg%{)Jh=Hh*h$+qb!BV$jBozA)hPxjniLKR}Eo?moq4chWQJOvY(Bp zgpwZpP5E_++A>?mx&5~SSxVBFx}|Fl*ASkzDUDyg<2xTzX}At$zkdJq_*+5xO%Jb< zsatW1@*L?TKd2b`is#8sbbT5&*~Ds|;)9BvuH5oSJgjy#5>1aSG|R71 ztm91Ajn$pI+VsUgw}2pN4Pjds$?lg>g7o&cAaR@~x8bg>4n{hh=^qmN>6w!4B}MZ@ z({Dbi>SYkP7Oihs%F3QDB05&BSm!GL3ju32xZ?p+bC#`MuDMrdE`E?YE&p$#jh8<_ zE3#h{>)O+~!2c)h=yccnUyMD`@5uDm-wBpuju4jS9GQ?n&JnI=+K_)k7#0`cf8G_4 z30~L5cuhp&st^iU@AkIt51^>v29zg5!?w(~4VbKRzpO^g@`&95>ZsAwG)j(dX+>^| z%25f@&q~~sug*q(IaK}N#nWShd?{*lkj6$7$)qMKJIFMo9Tn~_i3qxD|4Q}x)YGLD zW0Tyi=LTWUfJD9MvhCW8+I}YKYATJ%HM0ow`kD`3U9>aulx_2K(vE&L%aJhw7U7Z# z(ddxA#~z8q$1%7Nnh^~#y4%zVfMGOmSNUIND`T#@9nEZ{FNE(VcwhOQt`S>jf+o>o zsrWylkCTVTT3wZMx(S|gx<*A#JgLm{x>1ACt2k<9H=IjH}OgSP(ljn z?nn%!vzvGj32(g+h&jB!&e-w*dP7oabk^=&rTD>rN~||GZ*K`a72Y|ap7%_EWinTm zJkJizU0|_DQWP_?@6+6oRRf4)stcEBZ`1=daA#9P3WHLb1Hm1wqAV;}&Dh!AymPNY z#b8VJOh4H|BQLXN=_=0ju2E4oFVKEFF8Z%CACm(e!r zgQ7Fw95q18z4zTstu40~pD`U7sA@NrCsg!vVA}V7qzwEbpAUzz)+fUZ(vvc{P&bVW z!)p|Ep(aopeOH0?B-h5Wo3mW}k+K^VUBs7)6)#;eTjzQ&>IQSi&sCD>!6B3vv-Jco zY_0wWt=Y%8zNuv%TA>|o{f!wXsQh4#Bok~ujtS*zr5^YAhPeg{)NRWFpB06 z?{>g^g>+Sg)Mvn(L*PXlN;Xb8YLY6;Z=vVX5EWvhwRY7v;RBPzQPw3vb7Ex#K zvoc(@yA=LR;G{tN2N0;)or~9`mn}`^Z!W$a&yqKq{LedRjgCn(g4&qJnl?!(H_0Flhn+C5^M8&G#;Kw zP4@=)CqACc6R1>N8j!|epiD7sZg!vVZWzn_CvNWd7V(%!TDf%!349ldp$}x~*6$Qm zf)^z+CWdPj9hmde%dsKv8DoOB(HyHK>BuiF&k#R(>NSYcDTUwY?WfjoiCoAJu@a0Q znew~*y{x&;9KTsaCyhH@u()Ipn6joa|0>}5vW&Md4V<8np14<(60pG!`^WV*Ow~K+ zIwqHJ>cdhtAQ^M*1@ctX$pXnPp3&~czr-FN^1Q;wkUw@Fwc8YdI2~YslCiX_w-Kp- z{JrWsdidU_&b#C`@?x8$pu!Vp(?0y=$x3p|RCw@f(a+;HnqIy@i+jPg5*0PF2 z!;tJT7nLn8I;rvZxL>k1Q{;ztv{e8)W?%S2wl_iUZOl0)a?e;o-?P4=>Aru@ zQ0?UG=}8H9jjsKLj4Q!Gor-*46&4 z)YFa?ZXrPTj$pl1DgZGcRKAkXO9vvOJ7}|;Ua#(%rdCif;@rcTa?C?Y=nv>dTtoc@ dEm+Rj%0q7XPv5v+0{#vHOpMKqa0d5c{tw?&*aH9n literal 0 HcmV?d00001 From 2ff4f617225c5878f09b89ec137d82ffe2b3f91f Mon Sep 17 00:00:00 2001 From: nek0 Date: Mon, 20 Feb 2017 20:51:33 +0100 Subject: [PATCH 11/18] I forgot to push this --- src/Menu.hs | 19 +++++++++ src/StateMachine.hs | 100 ++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 119 insertions(+) create mode 100644 src/Menu.hs create mode 100644 src/StateMachine.hs diff --git a/src/Menu.hs b/src/Menu.hs new file mode 100644 index 0000000..6982903 --- /dev/null +++ b/src/Menu.hs @@ -0,0 +1,19 @@ +module Menu where + +import Affection +import qualified SDL + +import Debug.Trace + +import Types + +handleMenuEvent :: Double -> SDL.Event -> Affection UserData () +handleMenuEvent sec e = do + ad <- get + case SDL.eventPayload e of + SDL.WindowClosedEvent _ -> do + traceM "seeya!" + put ad + { quitEvent = True + } + _ -> return () diff --git a/src/StateMachine.hs b/src/StateMachine.hs new file mode 100644 index 0000000..f84bf9b --- /dev/null +++ b/src/StateMachine.hs @@ -0,0 +1,100 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + +module StateMachine where + +import Affection +import qualified SDL +import GEGL + +import qualified Data.Map as M +import Data.Maybe (catMaybes) + +import Control.Monad (foldM, when) + +import System.Random (randomRIO) + +import Types +import Commons +import InGame + +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 + ud <- getAffection + liftIO $ gegl_node_link + (nodeGraph ud M.! KeyMenuOver) + (nodeGraph ud M.! KeyFGNop) + 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) + putAffection ud + { haskelloids = hs + , fade = FadeIn 1 + , state = Menu + } + + smLoad InGame = loadGame + + smUpdate Menu 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 + } + + smUpdate InGame sec = updateGame sec + + smEvent Menu _ e = do + 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 sec e + + smDraw Menu = do + ud <- getAffection + liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink + present + (GeglRectangle 0 0 800 600) + (buffer ud) + True + + smDraw InGame = drawGame From 79642ec557c6b61553caaa81a9c7ea5505b28cbc Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 26 Feb 2017 02:13:58 +0100 Subject: [PATCH 12/18] get the nodes in the right order --- src/Commons.hs | 25 ++++++++++++++++++------- src/InGame.hs | 3 +++ src/StateMachine.hs | 9 +++++++-- src/Types.hs | 1 + 4 files changed, 29 insertions(+), 9 deletions(-) diff --git a/src/Commons.hs b/src/Commons.hs index bb38165..b3ea430 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -130,8 +130,8 @@ load _ = do _ <- 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" + 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 @@ -149,6 +149,7 @@ load _ = do , (KeyPixelize, pixelize) , (KeyFGOver, fgover) , (KeyFGNop, fgnop) + , (KeyFGTrans, fgtranslate) , (KeyMenuHeading, menuTranslateHeading) , (KeyMenuText, menuText) , (KeyMenuOver, menuOver) @@ -250,9 +251,15 @@ haskelloidShotDown h = do (nodeGraph ud M.! KeyHNop) else do liftIO $ traceIO "YOU WON!" - liftIO $ gegl_node_link + _ <- liftIO $ gegl_node_link (nodeGraph ud M.! KeyWon) - (nodeGraph ud M.! KeyFGNop) + (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 } @@ -352,9 +359,13 @@ lose = do liftIO $ traceIO "YOU LOST!" _ <- liftIO $ gegl_node_link (nodeGraph ud M.! KeyLost) - (nodeGraph ud M.! KeyFGNop) + (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 } - _ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux" - return () diff --git a/src/InGame.hs b/src/InGame.hs index 81d8e2f..e711a97 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -33,6 +33,9 @@ loadGame = do liftIO $ traceIO "inserted haskelloids" 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.! KeyFGOver) + "aux" liftIO $ traceIO "nodes linked" putAffection ud { haskelloids = hs diff --git a/src/StateMachine.hs b/src/StateMachine.hs index f84bf9b..36a578f 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -27,9 +27,11 @@ class StateMachine a us where instance StateMachine State UserData where smLoad Menu = do ud <- getAffection - liftIO $ gegl_node_link + liftIO $ gegl_node_connect_to (nodeGraph ud M.! KeyMenuOver) - (nodeGraph ud M.! KeyFGNop) + "output" + (nodeGraph ud M.! KeyFGOver) + "aux" hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do px <- randomRIO (0, 800) py <- randomRIO (0, 600) @@ -37,10 +39,13 @@ instance StateMachine State UserData where ) [] ([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 diff --git a/src/Types.hs b/src/Types.hs index 46cee94..aaf2717 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -52,6 +52,7 @@ data NodeKey | KeyPixelize | KeyFGOver | KeyFGNop + | KeyFGTrans | KeyMenuHeading | KeyMenuText | KeyMenuStart From e59ecbd1e1ec76dbf7154a1aae6d5af84daf8906 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 26 Feb 2017 02:14:49 +0100 Subject: [PATCH 13/18] fix state fuckup --- src/Commons.hs | 8 ++++++-- src/InGame.hs | 4 +++- 2 files changed, 9 insertions(+), 3 deletions(-) diff --git a/src/Commons.hs b/src/Commons.hs index b3ea430..71498cd 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -263,7 +263,8 @@ haskelloidShotDown h = do putAffection ud { wonlost = True } - putAffection ud + ud2 <- getAffection + putAffection ud2 { haskelloids = newHaskelloids } @@ -293,7 +294,10 @@ updateHaskelloid sec h@Haskelloid{..} = do 50 ) _ -> return Nothing - maybe (return ()) (const lose) lost + maybe (return ()) (const $ do + lose + putAffection ud {wonlost = True} + ) lost return h { hPos = (nnx, nny) , hRot = newRot diff --git a/src/InGame.hs b/src/InGame.hs index e711a97..750ea83 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -15,6 +15,7 @@ import Debug.Trace import Types import Commons +import Menu loadGame :: Affection UserData () loadGame = do @@ -103,7 +104,8 @@ updateGame sec = do } ud2 <- getAffection nhs <- mapM (updateHaskelloid sec) (haskelloids ud2) - putAffection ud2 + ud3 <- getAffection + putAffection ud3 { haskelloids = nhs } -- liftIO $ traceIO $ show $ length nhs From f155e1832b97af2bd79bab2dda502bd30c79f35a Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 26 Feb 2017 02:15:03 +0100 Subject: [PATCH 14/18] remove old code --- src/InGame.hs | 13 ------------- 1 file changed, 13 deletions(-) diff --git a/src/InGame.hs b/src/InGame.hs index 750ea83..586bf56 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -118,19 +118,6 @@ updateGame sec = do drawGame :: Affection UserData () drawGame = do - -- ud <- getAffection - -- liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink - -- present - -- (GeglRectangle (floor $ fst $ sPos $ ship ud) (floor $ snd $ sPos $ ship ud) 50 50) - -- (buffer ud) - -- False - -- mapM_ (\h -> do - -- let s = 100 `div` hDiv h - -- present - -- (GeglRectangle (floor $ fst $ hPos h) (floor $ snd $ hPos h) s s) - -- (buffer ud) - -- False - -- ) (haskelloids ud) ud <- getAffection liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink present From aafbfbbc9f4687acf97bff071bcadc1e0005913a Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 26 Feb 2017 02:15:24 +0100 Subject: [PATCH 15/18] go back to menu after winning or losing the game --- src/InGame.hs | 15 +++++++++------ src/StateMachine.hs | 2 +- 2 files changed, 10 insertions(+), 7 deletions(-) diff --git a/src/InGame.hs b/src/InGame.hs index 586bf56..a1befd2 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -125,8 +125,12 @@ drawGame = do (buffer ud) True -handleGameEvent :: Double -> SDL.Event -> Affection UserData () -handleGameEvent sec e = do +handleGameEvent + :: Affection UserData () + -> Double + -> SDL.Event + -> Affection UserData () +handleGameEvent menuload sec e = do ad <- get wd <- getAffection case SDL.eventPayload e of @@ -206,11 +210,10 @@ handleGameEvent sec e = do , pixelSize = 8 } SDL.KeycodeR -> - when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do + when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && wonlost wd) $ do liftIO $ traceIO "reloading" - liftIO $ clean wd - nd <- liftIO $ load $ drawSurface ad - putAffection nd + -- liftIO $ clean wd + menuload _ -> return () SDL.WindowClosedEvent _ -> do traceM "seeya!" diff --git a/src/StateMachine.hs b/src/StateMachine.hs index 36a578f..7a2f16f 100644 --- a/src/StateMachine.hs +++ b/src/StateMachine.hs @@ -92,7 +92,7 @@ instance StateMachine State UserData where } _ -> return () - smEvent InGame sec e = handleGameEvent sec e + smEvent InGame sec e = handleGameEvent (smLoad Menu) sec e smDraw Menu = do ud <- getAffection From 9d1bbf33d4e92def6873ae220712b6b9f8870e19 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sun, 26 Feb 2017 11:19:55 +0100 Subject: [PATCH 16/18] ignore profiling data --- .gitignore | 3 +++ 1 file changed, 3 insertions(+) diff --git a/.gitignore b/.gitignore index 05d4d64..79903a3 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,6 @@ .cabal-sandbox/ cabal.sandbox.config dist/ +*.aux +*.hp +*.ps From e13f5c73019d3242e18bd5d8f01b148aa00c589d Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 1 Mar 2017 17:01:58 +0100 Subject: [PATCH 17/18] no highscore --- src/Commons.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/Commons.hs b/src/Commons.hs index 71498cd..7416499 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -104,7 +104,7 @@ load _ = do , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1 ] menuText <- gegl_node_new_child root $ textOperation - [ Property "string" $ PropertyString "Press [Space] to start\nPress [H] for Highscore" + [ Property "string" $ PropertyString "Press [Space] to start" , Property "font" $ PropertyString "Modulo" , Property "size" $ PropertyDouble 50 , Property "alignment" $ PropertyInt 1 From 662567804d06a1f05a612a5b8cd3fc2812b7d471 Mon Sep 17 00:00:00 2001 From: nek0 Date: Wed, 1 Mar 2017 17:02:08 +0100 Subject: [PATCH 18/18] static turn rate --- src/InGame.hs | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/InGame.hs b/src/InGame.hs index a1befd2..3fdbad0 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -141,7 +141,7 @@ handleGameEvent menuload sec e = do when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost ud)) $ putAffection ud { ship = (ship ud) - { sRot = sRot (ship ud) + 270 * sec + { sRot = sRot (ship ud) + 5 } } SDL.KeycodeRight -> do @@ -149,7 +149,7 @@ handleGameEvent menuload sec e = do when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ putAffection ud { ship = (ship ud) - { sRot = sRot (ship ud) - 270 * sec + { sRot = sRot (ship ud) - 5 } } SDL.KeycodeUp ->