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 diff --git a/assets/ship.png b/assets/ship.png new file mode 100644 index 0000000..d247a53 Binary files /dev/null and b/assets/ship.png differ diff --git a/haskelloids.cabal b/haskelloids.cabal index 504b840..c6bd651 100644 --- a/haskelloids.cabal +++ b/haskelloids.cabal @@ -56,6 +56,7 @@ executable haskelloids other-modules: InGame , Types , Commons + , StateMachine -- LANGUAGE extensions used by modules in this package. -- other-extensions: @@ -65,7 +66,7 @@ executable haskelloids , affection , gegl , babl - , sdl2 + , sdl2 >= 2.1.3.1 , containers , random diff --git a/src/Commons.hs b/src/Commons.hs index e724291..e1fc90e 100644 --- a/src/Commons.hs +++ b/src/Commons.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE RecordWildCards #-} + module Commons where import Affection @@ -6,9 +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, unless) import System.Random (randomRIO) @@ -21,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 :: IO UserData @@ -36,7 +39,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 @@ -44,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 @@ -68,10 +71,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!" @@ -93,20 +96,48 @@ load = do -- vdeg <- gegl_node_new_child root $ Operation "gegl:video-degradation" -- [ Property "pattern" $ PropertyInt 8 -- ] - gegl_node_link_many [ship, rotate, translate] + menuHeading <- gegl_node_new_child root $ textOperation + [ Property "string" $ PropertyString "Haskelloids" + , Property "font" $ PropertyString "Modulo" + , Property "size" $ PropertyDouble 100 + , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1 + ] + menuText <- gegl_node_new_child root $ textOperation + [ Property "string" $ PropertyString "Press [Space] to start" + , Property "font" $ PropertyString "Modulo" + , Property "size" $ PropertyDouble 50 + , Property "alignment" $ PropertyInt 1 + , Property "color" $ PropertyColor $ GEGL.RGBA 1 1 1 1 + ] + menuTranslateHeading <- gegl_node_new_child root $ Operation "gegl:translate" + [ Property "x" $ PropertyDouble 150 + , Property "y" $ PropertyDouble 100 + , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic + ] + menuTranslateText <- gegl_node_new_child root $ Operation "gegl:translate" + [ Property "x" $ PropertyDouble 130 + , Property "y" $ PropertyDouble 300 + , Property "sampler" $ PropertyInt $ fromEnum GeglSamplerCubic + ] + menuOver <- gegl_node_new_child root defaultOverOperation + gegl_node_link menuHeading menuTranslateHeading + gegl_node_link_many [menuText, menuTranslateText, menuOver] + _ <- gegl_node_connect_to menuTranslateHeading "output" menuOver "aux" + gegl_node_link_many [shipNode, rotate, translate] gegl_node_link_many [bgover, pover, hover, sover, crop, fgover, pixelize, vignette, sink] - _ <- gegl_node_connect_to translate "output" sover "aux" + -- _ <- gegl_node_connect_to translate "output" sover "aux" _ <- gegl_node_connect_to pnop "output" pover "aux" _ <- gegl_node_connect_to hnop "output" hover "aux" _ <- gegl_node_connect_to bg "output" bgover "aux" liftIO $ gegl_node_link fgnop fgtranslate - _ <- gegl_node_connect_to fgtranslate "output" fgover "aux" + -- _ <- gegl_node_connect_to 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, ship) + , (KeyShip, shipNode) + , (KeyShipTranslate, translate) + , (KeyShipRotate, rotate) , (KeyPNop, pnop) , (KeyHNop, hnop) , (KeyCrop, crop) @@ -117,6 +148,10 @@ load = do , (KeyPixelize, pixelize) , (KeyFGOver, fgover) , (KeyFGNop, fgnop) + , (KeyFGTrans, fgtranslate) + , (KeyMenuHeading, menuTranslateHeading) + , (KeyMenuText, menuText) + , (KeyMenuOver, menuOver) ] traceM "built map" hs <- catMaybes <$> foldM (\acc _ -> do @@ -136,12 +171,14 @@ load = do , sRot = 0 , sFlange = rotate } - , buffer = buffer - , shots = ParticleSystem (ParticleStorage Nothing []) pnop buffer - , haskelloids = hs + , buffer = nbuffer + , shots = ParticleSystem (ParticleStorage Nothing []) pnop nbuffer + -- , haskelloids = hs + , haskelloids = [] , wonlost = False , pixelSize = 3 - , state = InGame + , state = Menu + , fade = FadeIn 1 } insertHaskelloid :: [Maybe Haskelloid] -> Maybe Int -> (Double, Double) -> IO [Maybe Haskelloid] @@ -199,3 +236,149 @@ 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.! KeyFGTrans) + _ <- liftIO $ gegl_node_connect_to + (nodeGraph ud M.! KeyFGTrans) + "output" + (nodeGraph ud M.! KeyFGOver) + "aux" + _ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux" + putAffection ud + { wonlost = True + } + ud2 <- getAffection + putAffection ud2 + { haskelloids = newHaskelloids + } + +updateHaskelloid :: Double -> Haskelloid -> Affection UserData Haskelloid +updateHaskelloid sec h@Haskelloid{..} = do + let newX = fst hPos + sec * fst hVel + newY = snd hPos + sec * snd hVel + newRot = hRot + hPitch * sec + (nnx, nny) = wrapAround (newX, newY) (100 / fromIntegral hDiv) + -- liftIO $ traceIO $ "moving to: " ++ show nnx ++ " " ++ show nny + liftIO $ gegl_node_set (hNodeGraph M.! "trans") $ Operation "gegl:translate" + [ Property "x" $ PropertyDouble nnx + , Property "y" $ PropertyDouble nny + ] + liftIO $ gegl_node_set (hNodeGraph M.! "rot") $ Operation "gegl:rotate" + [ Property "degrees" $ PropertyDouble newRot + ] + ud <- getAffection + lost <- + case state ud of + InGame -> liftIO $ gegl_rectangle_intersect + (GeglRectangle (floor nnx) (floor nny) (100 `div` hDiv) (100 `div` hDiv)) + (GeglRectangle + (floor $ fst $ sPos $ ship ud) + (floor $ snd $ sPos $ ship ud) + 50 + 50 + ) + _ -> return Nothing + maybe (return ()) (const $ do + lose + putAffection ud {wonlost = True} + ) lost + return h + { hPos = (nnx, nny) + , hRot = newRot + } + +wrapAround :: (Ord t, Num t) => (t, t) -> t -> (t, t) +wrapAround (nx, ny) width = (nnx, nny) + where + 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) + (nnx, nny) = wrapAround (newX, newY) 4 + liftIO $ gegl_node_set (particleNodeGraph M.! "rect") $ Operation "gegl:rectangle" + [ Property "x" $ PropertyDouble nnx + , Property "y" $ PropertyDouble nny + ] + ud <- getAffection + inters <- catMaybes <$> mapM (\h -> do + col <- liftIO $ gegl_rectangle_intersect + (GeglRectangle (floor nnx) (floor nny) 4 4) + (GeglRectangle + (floor $ fst $ hPos h) + (floor $ snd $ hPos h) + (100 `div` hDiv h) + (100 `div` hDiv h) + ) + case col of + Just _ -> return $ Just h + Nothing -> return Nothing + ) (haskelloids ud) + unless (null inters) $ + haskelloidShotDown $ head inters + lost <- liftIO $ gegl_rectangle_intersect + (GeglRectangle (floor nnx) (floor nny) 4 4) + (GeglRectangle + (floor $ fst $ sPos $ ship ud) + (floor $ snd $ sPos $ ship ud) + 50 + 50 + ) + maybe (return ()) (const lose) lost + return part + { particlePosition = (nnx, nny) + , particleTimeToLive = if not $ null inters then 0 else particleTimeToLive + } + +shotsDraw :: GeglBuffer -> GeglNode -> Particle -> Affection UserData () +shotsDraw _ _ _ = return () + +lose :: Affection UserData () +lose = do + ud <- getAffection + liftIO $ traceIO "YOU LOST!" + _ <- liftIO $ gegl_node_link + (nodeGraph ud M.! KeyLost) + (nodeGraph ud M.! KeyFGTrans) + _ <- liftIO $ gegl_node_connect_to + (nodeGraph ud M.! KeyFGTrans) + "output" + (nodeGraph ud M.! KeyFGOver) + "aux" + _ <- liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyShipOver) "aux" + putAffection ud + { wonlost = True + } diff --git a/src/InGame.hs b/src/InGame.hs index 99630fa..7ba8597 100644 --- a/src/InGame.hs +++ b/src/InGame.hs @@ -5,13 +5,125 @@ 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 +import Menu + +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 $ gegl_node_disconnect + (nodeGraph ud M.! KeyFGOver) + "aux" + liftIO $ traceIO "nodes linked" + 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 + } + liftIO $ traceIO "game loaded" + present + (GeglRectangle 0 0 800 600) + (buffer ud) + True + +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) + ud3 <- getAffection + putAffection ud3 + { haskelloids = nhs + } + -- liftIO $ traceIO $ show $ length nhs + ud3 <- getAffection + ups <- updateParticleSystem (shots ud3) sec shotsUpd shotsDraw + ud4 <- getAffection + putAffection ud4 + { shots = ups + } + +drawGame :: Affection UserData () +drawGame = do + ud <- getAffection + liftIO $ gegl_node_process $ nodeGraph ud M.! KeySink + present + (GeglRectangle 0 0 800 600) + (buffer ud) + True handleGameEvent :: SDL.EventPayload -> Affection UserData () handleGameEvent e = do @@ -20,7 +132,7 @@ handleGameEvent e = do sec <- getDelta case 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)) $ @@ -40,8 +152,8 @@ handleGameEvent e = do 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) @@ -56,19 +168,19 @@ handleGameEvent 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 @@ -93,7 +205,7 @@ handleGameEvent 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 diff --git a/src/Main.hs b/src/Main.hs index 5c6f1b8..526d3ac 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -1,4 +1,4 @@ -{-# LANGUAGE OverloadedStrings, RecordWildCards #-} +{-# LANGUAGE OverloadedStrings #-} module Main where import Affection @@ -16,11 +16,14 @@ import Debug.Trace -- internal imports import Types -import InGame import Commons +import StateMachine + +import Menu +import InGame main :: IO () -main = withAffection $ AffectionConfig +main = withAffection AffectionConfig { initComponents = All , windowTitle = "Haskelloids" , windowConfig = defaultWindow @@ -81,17 +84,11 @@ update sec = do , 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 +update :: Double -> [SDL.Event] -> Affection UserData () +update sec evs = do + wd <- getAffection + smUpdate (state wd) sec + mapM_ (smEvent (state wd) sec) evs draw :: Affection UserData () draw = do 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..7a2f16f --- /dev/null +++ b/src/StateMachine.hs @@ -0,0 +1,105 @@ +{-# 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_connect_to + (nodeGraph ud M.! KeyMenuOver) + "output" + (nodeGraph ud M.! KeyFGOver) + "aux" + hs <- liftIO $ catMaybes <$> foldM (\acc _ -> do + px <- randomRIO (0, 800) + py <- randomRIO (0, 600) + insertHaskelloid acc Nothing (px, py) + ) [] ([0..9] :: [Int]) + liftIO $ gegl_node_link_many $ map hFlange hs + liftIO $ gegl_node_link (last $ map hFlange hs) (nodeGraph ud M.! KeyHNop) + liftIO $ gegl_node_disconnect (nodeGraph ud M.! KeyPNop) "input" + putAffection ud + { haskelloids = hs + , fade = FadeIn 1 + , state = Menu + , shots = (shots ud) + { partSysParts = ParticleStorage Nothing [] } + } + + smLoad InGame = loadGame + + smUpdate Menu sec = do + 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 (smLoad Menu) 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 diff --git a/src/Types.hs b/src/Types.hs index 5ca5b7b..14bd4c3 100644 --- a/src/Types.hs +++ b/src/Types.hs @@ -1,9 +1,10 @@ +{-# LANGUAGE MultiParamTypeClasses #-} + module Types where import Affection hiding (StateMachine) import qualified SDL import GEGL -import BABL import qualified Data.Map as M data UserData = UserData @@ -15,7 +16,8 @@ data UserData = UserData -- , debris :: ParticleSystem , wonlost :: Bool , pixelSize :: Int - , state :: StateMachine + , state :: State + , fade :: MenuFade } data Ship = Ship @@ -37,9 +39,9 @@ data Haskelloid = Haskelloid data NodeKey = KeyRoot - | KeyTranslate - | KeyRotate | KeyShip + | KeyShipTranslate + | KeyShipRotate | KeyPNop | KeyHNop | KeyCrop @@ -50,9 +52,19 @@ data NodeKey | KeyPixelize | KeyFGOver | KeyFGNop + | KeyFGTrans + | KeyMenuHeading + | KeyMenuText + | KeyMenuStart + | KeyMenuHighscore + | KeyMenuOver deriving (Ord, Eq) -data StateMachine +data State = Menu | HighScore | InGame + +data MenuFade + = FadeIn Double + | FadeOut Double