From 0aff3e84ca036f1c46e937fcea754b04fa4fa12b Mon Sep 17 00:00:00 2001
From: nek0 <nek0@chelnok.de>
Date: Mon, 2 Jan 2017 23:29:32 +0100
Subject: [PATCH] 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