From a503b2cb75802dcdbd6a3faad31ea52bddc101b5 Mon Sep 17 00:00:00 2001 From: nek0 Date: Sat, 31 Dec 2016 17:01:24 +0100 Subject: [PATCH] splitting things up --- haskelloids.cabal | 4 +- src/Commons.hs | 192 ++++++++++++++++++++++++++ src/InGame.hs | 108 +++++++++++++++ src/Main.hs | 336 ++-------------------------------------------- src/Types.hs | 58 ++++++++ 5 files changed, 372 insertions(+), 326 deletions(-) create mode 100644 src/Commons.hs create mode 100644 src/InGame.hs create mode 100644 src/Types.hs diff --git a/haskelloids.cabal b/haskelloids.cabal index bb050b0..9f4a275 100644 --- a/haskelloids.cabal +++ b/haskelloids.cabal @@ -53,7 +53,9 @@ executable haskelloids ghc-options: -Wall -- Modules included in this executable, other than Main. - -- other-modules: + other-modules: InGame + , Types + , Commons -- LANGUAGE extensions used by modules in this package. -- other-extensions: diff --git a/src/Commons.hs b/src/Commons.hs new file mode 100644 index 0000000..95486f0 --- /dev/null +++ b/src/Commons.hs @@ -0,0 +1,192 @@ +module Commons where + +import Affection +import qualified SDL +import GEGL +import BABL + +import qualified Data.Map as M +import Data.Maybe (catMaybes) + +import Control.Monad (foldM) + +import System.Random (randomRIO) + +import Debug.Trace + +import Types + +toR :: Double -> Double +toR deg = deg * pi / 180 + +clean :: UserData -> IO () +clean ud = do + mapM_ gegl_node_drop $ map (\h -> hNodeGraph h M.! "root") (haskelloids ud) + gegl_node_drop $ nodeGraph ud M.! KeyRoot + +load :: SDL.Surface -> IO UserData +load _ = do + traceM "loading" + root <- gegl_node_new + traceM "root node" + bg <- gegl_node_new_child root $ Operation "gegl:rectangle" + [ Property "x" $ PropertyDouble 0 + , Property "y" $ PropertyDouble 0 + , Property "width" $ PropertyDouble 800 + , Property "height" $ PropertyDouble 600 + , Property "color" $ PropertyColor $ GEGL.RGBA 0 0 0.1 1 + ] + ship <- gegl_node_new_child root $ Operation "gegl:svg-load" + [ Property "path" $ PropertyString "assets/ship.svg" + , Property "width" $ PropertyInt 50 + , Property "height" $ PropertyInt 50 + ] + pnop <- gegl_node_new_child root $ Operation "gegl:nop" [] + hnop <- gegl_node_new_child root $ Operation "gegl:nop" [] + fgnop <- gegl_node_new_child root $ Operation "gegl:nop" [] + sover <- gegl_node_new_child root $ defaultOverOperation + hover <- gegl_node_new_child root $ defaultOverOperation + pover <- gegl_node_new_child root $ defaultOverOperation + bgover <- gegl_node_new_child root $ defaultOverOperation + fgover <- gegl_node_new_child root $ defaultOverOperation + translate <- gegl_node_new_child root $ Operation "gegl:translate" + [ Property "x" $ PropertyDouble 375 + , Property "y" $ PropertyDouble 275 + , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic + ] + fgtranslate <- gegl_node_new_child root $ Operation "gegl:translate" + [ Property "x" $ PropertyDouble 150 + , Property "y" $ PropertyDouble 250 + , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic + ] + rotate <- gegl_node_new_child root $ Operation "gegl:rotate" + [ Property "origin-x" $ PropertyDouble 25 + , Property "origin-y" $ PropertyDouble 25 + , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic + ] + crop <- gegl_node_new_child root $ Operation "gegl:crop" + [ Property "width" $ PropertyDouble 800 + , Property "height" $ PropertyDouble 600 + ] + buffer <- 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 + ] + won <- gegl_node_new_child root $ textOperation + [ Property "string" $ PropertyString "YOU WON!" + , Property "font" $ PropertyString "Modulo" + , Property "size" $ PropertyDouble 100 + , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1 + ] + lost <- gegl_node_new_child root $ textOperation + [ Property "string" $ PropertyString "YOU LOST!" + , Property "font" $ PropertyString "Modulo" + , Property "size" $ PropertyDouble 100 + , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1 + ] + vignette <- gegl_node_new_child root $ Operation "gegl:vignette" [] + -- pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize" + pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize" + [ Property "size-x" $ PropertyInt 3 + , Property "size-y" $ PropertyInt 3 + ] + -- vdeg <- gegl_node_new_child root $ Operation "gegl:video-degradation" + -- [ Property "pattern" $ PropertyInt 8 + -- ] + 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 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" + traceM "nodes complete" + myMap <- return $ M.fromList + [ (KeyRoot, root) + , (KeyTranslate, translate) + , (KeyRotate, rotate) + , (KeyShip, ship) + , (KeyPNop, pnop) + , (KeyHNop, hnop) + , (KeyCrop, crop) + , (KeyShipOver, sover) + , (KeySink, sink) + , (KeyWon, won) + , (KeyLost, lost) + , (KeyPixelize, pixelize) + , (KeyFGOver, fgover) + , (KeyFGNop, fgnop) + ] + 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 + { nodeGraph = myMap + , ship = Ship + { sPos = (375, 275) + , sVel = (0, 0) + , sRot = 0 + , sFlange = rotate + } + , buffer = buffer + , shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer + , haskelloids = hs + , wonlost = False + , pixelSize = 3 + , state = InGame + } + +insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid] +insertHaskelloid hasks split (px, py) = do + -- liftIO $ traceIO "inserting haskelloid" + vx <- liftIO $ randomRIO (-10, 10) + vy <- liftIO $ randomRIO (-10, 10) + rdiv <- case split of + Nothing -> liftIO $ randomRIO (1, 2) + Just x -> return $ x + 1 + rot <- liftIO $ randomRIO (0, 360) + pitch <- liftIO $ randomRIO (-45, 45) + tempRoot <- liftIO $ gegl_node_new + tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation + tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load" + [ Property "path" $ PropertyString "assets/haskelloid.svg" + , Property "width" $ PropertyInt (100 `div` rdiv) + , Property "height" $ PropertyInt (100 `div` rdiv) + ] + tempTrans <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:translate" + [ Property "x" $ PropertyDouble $ px + (100 / fromIntegral rdiv / 2) + , Property "y" $ PropertyDouble $ py + (100 / fromIntegral rdiv / 2) + , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic + ] + tempRot <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rotate" + [ Property "origin-x" $ PropertyDouble (100 / 2 / fromIntegral rdiv) + , Property "origin-y" $ PropertyDouble (100 / 2 / fromIntegral rdiv) + , Property "degrees" $ PropertyDouble rot + , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic + ] + liftIO $ gegl_node_link_many [tempSvg, tempRot, tempTrans] + _ <- liftIO $ gegl_node_connect_to tempTrans "output" tempOver "aux" + return $ Just Haskelloid + { hPos = + ( px + (100 / 2 / fromIntegral rdiv) + , py + (100 / 2 / fromIntegral rdiv) + ) + , hVel = (vx, vy) + , hRot = rot + , hPitch = pitch + , hDiv = rdiv + , hFlange = tempOver + , hNodeGraph = M.fromList + [ ("root", tempRoot) + , ("over", tempOver) + , ("svg", tempSvg) + , ("trans", tempTrans) + , ("rot", tempRot) + ] + } : hasks diff --git a/src/InGame.hs b/src/InGame.hs new file mode 100644 index 0000000..e0e86a0 --- /dev/null +++ b/src/InGame.hs @@ -0,0 +1,108 @@ +module InGame where + +import Affection +import qualified SDL +import GEGL + +import qualified Data.Map as M + +import Control.Monad (when) + +import Debug.Trace + +import Types +import Commons + +handleGameEvent :: Double -> SDL.Event -> Affection UserData () +handleGameEvent sec e = do + ad <- get + wd <- getAffection + case SDL.eventPayload e of + SDL.KeyboardEvent dat -> + 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 + } + } + SDL.KeycodeRight -> do + ud <- getAffection + when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ + putAffection ud + { ship = (ship ud) + { 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) + putAffection ud + { ship = (ship ud) + { sVel = (vx, vy) + } + } + -- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud) + SDL.KeycodeSpace -> + when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do + ud <- getAffection + liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $ Operation "gegl:pixelize" + [ Property "size-x" $ PropertyInt 8 + , 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 + tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle" + [ Property "x" $ PropertyDouble $ posX + , Property "y" $ PropertyDouble $ posY + , Property "width" $ PropertyDouble 4 + , Property "height" $ PropertyDouble 4 + , Property "color" $ PropertyColor $ (GEGL.RGBA 1 1 1 1) + ] + tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation + _ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux" + ips <- insertParticle (shots ud) $ + Particle + { particleTimeToLive = 5 + , particleCreation = elapsedTime ad + , particlePosition = (posX, posY) + , particleRotation = Rad 0 + , 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)) + ) + , particlePitchRate = Rad 0 + , particleRootNode = tempRoot + , particleNodeGraph = M.fromList + [ ("root", tempRoot) + , ("over", tempOver) + , ("rect", tempRect) + ] + , particleStackCont = tempOver + , particleDrawFlange = tempOver + } + putAffection $ ud + { shots = ips + , pixelSize = 8 + } + SDL.KeycodeR -> + when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ do + liftIO $ traceIO "reloading" + liftIO $ clean wd + nd <- liftIO $ load $ drawSurface ad + putAffection nd + _ -> return () + SDL.WindowClosedEvent _ -> do + traceM "seeya!" + put ad + { quitEvent = True + } + _ -> return () diff --git a/src/Main.hs b/src/Main.hs index 9518878..1a72bce 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -4,7 +4,6 @@ module Main where import Affection import qualified SDL import GEGL -import BABL import Data.List (delete) import qualified Data.Map as M @@ -12,10 +11,14 @@ import Data.Maybe (catMaybes) import Control.Monad (when, foldM) -import System.Random (randomRIO) - import Debug.Trace +-- internal imports + +import Types +import InGame +import Commons + main :: IO () main = withAffection $ AffectionConfig { initComponents = All @@ -28,173 +31,10 @@ main = withAffection $ AffectionConfig , cleanUp = clean } -load :: SDL.Surface -> IO UserData -load _ = do - traceM "loading" - root <- gegl_node_new - traceM "root node" - bg <- gegl_node_new_child root $ Operation "gegl:rectangle" - [ Property "x" $ PropertyDouble 0 - , Property "y" $ PropertyDouble 0 - , Property "width" $ PropertyDouble 800 - , Property "height" $ PropertyDouble 600 - , Property "color" $ PropertyColor $ GEGL.RGBA 0 0 0.1 1 - ] - ship <- gegl_node_new_child root $ Operation "gegl:svg-load" - [ Property "path" $ PropertyString "assets/ship.svg" - , Property "width" $ PropertyInt 50 - , Property "height" $ PropertyInt 50 - ] - pnop <- gegl_node_new_child root $ Operation "gegl:nop" [] - hnop <- gegl_node_new_child root $ Operation "gegl:nop" [] - fgnop <- gegl_node_new_child root $ Operation "gegl:nop" [] - sover <- gegl_node_new_child root $ defaultOverOperation - hover <- gegl_node_new_child root $ defaultOverOperation - pover <- gegl_node_new_child root $ defaultOverOperation - bgover <- gegl_node_new_child root $ defaultOverOperation - fgover <- gegl_node_new_child root $ defaultOverOperation - translate <- gegl_node_new_child root $ Operation "gegl:translate" - [ Property "x" $ PropertyDouble 375 - , Property "y" $ PropertyDouble 275 - , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic - ] - fgtranslate <- gegl_node_new_child root $ Operation "gegl:translate" - [ Property "x" $ PropertyDouble 150 - , Property "y" $ PropertyDouble 250 - , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic - ] - rotate <- gegl_node_new_child root $ Operation "gegl:rotate" - [ Property "origin-x" $ PropertyDouble 25 - , Property "origin-y" $ PropertyDouble 25 - , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic - ] - crop <- gegl_node_new_child root $ Operation "gegl:crop" - [ Property "width" $ PropertyDouble 800 - , Property "height" $ PropertyDouble 600 - ] - buffer <- 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 - ] - won <- gegl_node_new_child root $ textOperation - [ Property "string" $ PropertyString "YOU WON!" - , Property "font" $ PropertyString "Modulo" - , Property "size" $ PropertyDouble 100 - , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1 - ] - lost <- gegl_node_new_child root $ textOperation - [ Property "string" $ PropertyString "YOU LOST!" - , Property "font" $ PropertyString "Modulo" - , Property "size" $ PropertyDouble 100 - , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1 - ] - vignette <- gegl_node_new_child root $ Operation "gegl:vignette" [] - -- pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize" - pixelize <- gegl_node_new_child root $ Operation "gegl:pixelize" - [ Property "size-x" $ PropertyInt 3 - , Property "size-y" $ PropertyInt 3 - ] - -- vdeg <- gegl_node_new_child root $ Operation "gegl:video-degradation" - -- [ Property "pattern" $ PropertyInt 8 - -- ] - 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 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" - traceM "nodes complete" - myMap <- return $ M.fromList - [ (KeyRoot, root) - , (KeyTranslate, translate) - , (KeyRotate, rotate) - , (KeyShip, ship) - , (KeyPNop, pnop) - , (KeyHNop, hnop) - , (KeyCrop, crop) - , (KeyShipOver, sover) - , (KeySink, sink) - , (KeyWon, won) - , (KeyLost, lost) - , (KeyPixelize, pixelize) - , (KeyFGOver, fgover) - , (KeyFGNop, fgnop) - ] - 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 - { nodeGraph = myMap - , ship = Ship - { sPos = (375, 275) - , sVel = (0, 0) - , sRot = 0 - , sFlange = rotate - } - , buffer = buffer - , shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer - , haskelloids = hs - , wonlost = False - , pixelSize = 3 - } - -data UserData = UserData - { nodeGraph :: M.Map NodeKey GeglNode - , ship :: Ship - , buffer :: GeglBuffer - , haskelloids :: [Haskelloid] - , shots :: ParticleSystem - -- , debris :: ParticleSystem - , wonlost :: Bool - , pixelSize :: Int - } - -data Ship = Ship - { sPos :: (Double, Double) - , sVel :: (Double, Double) - , sRot :: Double - , sFlange :: GeglNode - } - -data Haskelloid = Haskelloid - { hPos :: (Double, Double) - , hVel :: (Double, Double) - , hRot :: Double - , hPitch :: Double - , hDiv :: Int - , hFlange :: GeglNode - , hNodeGraph :: M.Map String GeglNode - } deriving (Eq) - -data NodeKey - = KeyRoot - | KeyTranslate - | KeyRotate - | KeyShip - | KeyPNop - | KeyHNop - | KeyCrop - | KeyShipOver - | KeySink - | KeyWon - | KeyLost - | KeyPixelize - | KeyFGOver - | KeyFGNop - deriving (Ord, Eq) - update :: Double -> Affection UserData () update sec = do -- traceM $ (show $ 1 / sec) ++ " FPS" ad <- get - evs <- SDL.pollEvents 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" @@ -205,90 +45,12 @@ update sec = do putAffection pd { pixelSize = pixelSize wd -1 } + evs <- SDL.pollEvents mapM_ (\e -> - case SDL.eventPayload e of - SDL.KeyboardEvent dat -> - case (SDL.keysymKeycode $ SDL.keyboardEventKeysym dat) of - SDL.KeycodeLeft -> do - ud <- getAffection - when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ - putAffection ud - { ship = (ship ud) - { sRot = (sRot $ ship ud) + 270 * sec - } - } - SDL.KeycodeRight -> do - ud <- getAffection - when (SDL.keyboardEventKeyMotion dat == SDL.Pressed) $ - putAffection ud - { ship = (ship ud) - { 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) - putAffection ud - { ship = (ship ud) - { sVel = (vx, vy) - } - } - -- traceM $ show (vx, vy) ++ " " ++ show (sRot $ ship ud) - SDL.KeycodeSpace -> - when (SDL.keyboardEventKeyMotion dat == SDL.Pressed && not (wonlost wd)) $ do - ud <- getAffection - liftIO $ gegl_node_set (nodeGraph ud M.! KeyPixelize) $ Operation "gegl:pixelize" - [ Property "size-x" $ PropertyInt 8 - , 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 - tempRect <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rectangle" - [ Property "x" $ PropertyDouble $ posX - , Property "y" $ PropertyDouble $ posY - , Property "width" $ PropertyDouble 4 - , Property "height" $ PropertyDouble 4 - , Property "color" $ PropertyColor $ (GEGL.RGBA 1 1 1 1) - ] - tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation - _ <- liftIO $ gegl_node_connect_to tempRect "output" tempOver "aux" - ips <- insertParticle (shots ud) $ - Particle - { particleTimeToLive = 5 - , particleCreation = elapsedTime ad - , particlePosition = (posX, posY) - , particleRotation = Rad 0 - , 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)) - ) - , particlePitchRate = Rad 0 - , particleRootNode = tempRoot - , particleNodeGraph = M.fromList - [ ("root", tempRoot) - , ("over", tempOver) - , ("rect", tempRect) - ] - , particleStackCont = tempOver - , particleDrawFlange = tempOver - } - putAffection $ ud - { shots = ips - , pixelSize = 8 - } - _ -> return () - SDL.WindowClosedEvent _ -> do - traceM "seeya!" - put ad - { quitEvent = True - } - _ -> return () + case state wd of + InGame -> + handleGameEvent sec e + _ -> error "not yet implemented" ) evs ud2 <- getAffection nhs <- mapM (updateHaskelloid sec) (haskelloids ud2) @@ -330,7 +92,6 @@ wrapAround (nx, ny) width = (nnx, nny) draw :: Affection UserData () draw = do - -- traceM "drawing" ud <- getAffection liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink -- mintr <- liftIO $ gegl_rectangle_intersect @@ -346,15 +107,8 @@ draw = do present (GeglRectangle 0 0 800 600) (buffer ud) - -- (not $ wonlost ud) True -clean :: UserData -> IO () -clean ud = gegl_node_drop $ nodeGraph ud M.! KeyRoot - -toR :: Double -> Double -toR deg = deg * pi / 180 - shotsUpd :: Double -> Particle -> Affection UserData Particle shotsUpd sec part@Particle{..} = do let newX = (fst particlePosition) + sec * (fromIntegral $ fst particleVelocity) @@ -398,27 +152,9 @@ shotsUpd sec part@Particle{..} = do haskelloidShotDown :: Haskelloid -> Affection UserData () haskelloidShotDown h = do - -- liftIO $ traceIO "Haskelloid shot down" liftIO $ gegl_node_drop $ hNodeGraph h M.! "root" ud <- getAffection let redHaskelloids = delete h (haskelloids ud) - -- mproducer <- liftIO $ gegl_node_get_producer - -- (hFlange h) - -- "input" - -- case mproducer of - -- Just (prod, padname) -> do - -- consumers <- liftIO $ gegl_node_get_consumers - -- (hFlange h) - -- "output" - -- liftIO $ mapM_ (\(node, inpad) -> do - -- traceIO "klink" - -- gegl_node_connect_to - -- prod - -- padname - -- node - -- inpad - -- ) consumers - -- Nothing -> return () liftIO $ gegl_node_drop $ hNodeGraph h M.! "root" newHaskelloids <- catMaybes <$> foldM (\acc _ -> @@ -429,7 +165,6 @@ haskelloidShotDown h = do return $ Nothing : acc ) (map Just redHaskelloids) ([0..1] :: [Int]) - -- liftIO $ traceIO $ show $ length newHaskelloids liftIO $ gegl_node_link_many $ map hFlange newHaskelloids if not $ null newHaskelloids then @@ -481,55 +216,6 @@ updateHaskelloid sec h@Haskelloid{..} = do , hRot = newRot } -insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid] -insertHaskelloid hasks split (px, py) = do - -- liftIO $ traceIO "inserting haskelloid" - vx <- liftIO $ randomRIO (-10, 10) - vy <- liftIO $ randomRIO (-10, 10) - rdiv <- case split of - Nothing -> liftIO $ randomRIO (1, 2) - Just x -> return $ x + 1 - rot <- liftIO $ randomRIO (0, 360) - pitch <- liftIO $ randomRIO (-45, 45) - tempRoot <- liftIO $ gegl_node_new - tempOver <- liftIO $ gegl_node_new_child tempRoot $ defaultOverOperation - tempSvg <- gegl_node_new_child tempRoot $ Operation "gegl:svg-load" - [ Property "path" $ PropertyString "assets/haskelloid.svg" - , Property "width" $ PropertyInt (100 `div` rdiv) - , Property "height" $ PropertyInt (100 `div` rdiv) - ] - tempTrans <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:translate" - [ Property "x" $ PropertyDouble $ px + (100 / fromIntegral rdiv / 2) - , Property "y" $ PropertyDouble $ py + (100 / fromIntegral rdiv / 2) - , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic - ] - tempRot <- liftIO $ gegl_node_new_child tempRoot $ Operation "gegl:rotate" - [ Property "origin-x" $ PropertyDouble (100 / 2 / fromIntegral rdiv) - , Property "origin-y" $ PropertyDouble (100 / 2 / fromIntegral rdiv) - , Property "degrees" $ PropertyDouble rot - , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic - ] - liftIO $ gegl_node_link_many [tempSvg, tempRot, tempTrans] - _ <- liftIO $ gegl_node_connect_to tempTrans "output" tempOver "aux" - return $ Just Haskelloid - { hPos = - ( px + (100 / 2 / fromIntegral rdiv) - , py + (100 / 2 / fromIntegral rdiv) - ) - , hVel = (vx, vy) - , hRot = rot - , hPitch = pitch - , hDiv = rdiv - , hFlange = tempOver - , hNodeGraph = M.fromList - [ ("root", tempRoot) - , ("over", tempOver) - , ("svg", tempSvg) - , ("trans", tempTrans) - , ("rot", tempRot) - ] - } : hasks - lose :: Affection UserData () lose = do ud <- getAffection diff --git a/src/Types.hs b/src/Types.hs new file mode 100644 index 0000000..88cd3a2 --- /dev/null +++ b/src/Types.hs @@ -0,0 +1,58 @@ +module Types where + +import Affection +import qualified SDL +import GEGL +import BABL +import qualified Data.Map as M + +data UserData = UserData + { nodeGraph :: M.Map NodeKey GeglNode + , ship :: Ship + , buffer :: GeglBuffer + , haskelloids :: [Haskelloid] + , shots :: ParticleSystem + -- , debris :: ParticleSystem + , wonlost :: Bool + , pixelSize :: Int + , state :: StateMachine + } + +data Ship = Ship + { sPos :: (Double, Double) + , sVel :: (Double, Double) + , sRot :: Double + , sFlange :: GeglNode + } + +data Haskelloid = Haskelloid + { hPos :: (Double, Double) + , hVel :: (Double, Double) + , hRot :: Double + , hPitch :: Double + , hDiv :: Int + , hFlange :: GeglNode + , hNodeGraph :: M.Map String GeglNode + } deriving (Eq) + +data NodeKey + = KeyRoot + | KeyTranslate + | KeyRotate + | KeyShip + | KeyPNop + | KeyHNop + | KeyCrop + | KeyShipOver + | KeySink + | KeyWon + | KeyLost + | KeyPixelize + | KeyFGOver + | KeyFGNop + deriving (Ord, Eq) + +data StateMachine + = Menu + | HighScore + | InGame