Merge branch 'statemachine' of github.com:nek0/haskelloids into statemachine

This commit is contained in:
nek0 2017-11-04 16:30:26 +01:00
commit 664dc8f870
9 changed files with 485 additions and 53 deletions

3
.gitignore vendored
View file

@ -1,3 +1,6 @@
.cabal-sandbox/
cabal.sandbox.config
dist/
*.aux
*.hp
*.ps

BIN
assets/ship.png Normal file

Binary file not shown.

After

Width:  |  Height:  |  Size: 4.6 KiB

View file

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

View file

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

View file

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

View file

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

19
src/Menu.hs Normal file
View file

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

105
src/StateMachine.hs Normal file
View file

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

View file

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