state machine

This commit is contained in:
nek0 2017-01-03 00:25:34 +01:00
parent f7d75db287
commit eae27cbe15
4 changed files with 13 additions and 93 deletions

View file

@ -56,7 +56,7 @@ executable haskelloids
other-modules: InGame
, Types
, Commons
, Transitions
, StateMachine
-- LANGUAGE extensions used by modules in this package.
-- other-extensions:

View file

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

View file

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

View file

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