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