state machine

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:    

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 ->
+  -- mapM_ (\e ->
-    case state wd of
+  --   case state wd of
-      Menu ->
+  --     Menu ->
-        handleMenuEvent sec e
+  --       handleMenuEvent sec e
-      InGame ->
+  --     InGame ->
-        handleGameEvent sec e
+  --       handleGameEvent sec e
-      _ -> error "not yet implemented"
+  --     _ -> error "not yet implemented"
-    ) evs
+  --   ) 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
+  smDraw $ state ud
-  -- 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
 
 shotsUpd :: Double -> Particle -> Affection UserData Particle
 shotsUpd sec part@Particle{..} = do

src/Transitions.hs

@@ -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
-          }

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