Add pausing functionality
This commit is contained in:
parent
977a1f355e
commit
3f0dcbb1aa
|
@ -10,6 +10,8 @@ data Command
|
||||||
| -- | A command to change the tick speed of the simulation,
|
| -- | A command to change the tick speed of the simulation,
|
||||||
-- given by a function on the period between ticks.
|
-- given by a function on the period between ticks.
|
||||||
ChangeSpeed (Time -> Time)
|
ChangeSpeed (Time -> Time)
|
||||||
|
| -- | A command to play/pause the simulation.
|
||||||
|
PlayPause
|
||||||
|
|
||||||
getResize :: Command -> Maybe (Int, Int)
|
getResize :: Command -> Maybe (Int, Int)
|
||||||
getResize (Resize size) = Just size
|
getResize (Resize size) = Just size
|
||||||
|
@ -19,5 +21,9 @@ getChangeSpeed :: Command -> Maybe (Time -> Time)
|
||||||
getChangeSpeed (ChangeSpeed f) = Just f
|
getChangeSpeed (ChangeSpeed f) = Just f
|
||||||
getChangeSpeed _ = Nothing
|
getChangeSpeed _ = Nothing
|
||||||
|
|
||||||
|
isPlayPause :: Command -> Bool
|
||||||
|
isPlayPause PlayPause = True
|
||||||
|
isPlayPause _ = False
|
||||||
|
|
||||||
-- | An event signalling that a command has been given by the user.
|
-- | An event signalling that a command has been given by the user.
|
||||||
type CommandEvent = Event Command
|
type CommandEvent = Event Command
|
|
@ -39,6 +39,7 @@ processEvent :: InputEvent -> CommandEvent
|
||||||
processEvent = event noEvent $ \case
|
processEvent = event noEvent $ \case
|
||||||
EventKey (Char '-') Down _ _ -> Event $ ChangeSpeed (* 1.25)
|
EventKey (Char '-') Down _ _ -> Event $ ChangeSpeed (* 1.25)
|
||||||
EventKey (Char '+') Down _ _ -> Event $ ChangeSpeed (* 0.8)
|
EventKey (Char '+') Down _ _ -> Event $ ChangeSpeed (* 0.8)
|
||||||
|
EventKey (SpecialKey KeySpace) Down _ _ -> Event PlayPause
|
||||||
EventKey {} -> noEvent
|
EventKey {} -> noEvent
|
||||||
EventMotion {} -> noEvent
|
EventMotion {} -> noEvent
|
||||||
EventResize size -> Event $ Resize size
|
EventResize size -> Event $ Resize size
|
||||||
|
@ -49,9 +50,11 @@ run st =
|
||||||
in proc inp -> do
|
in proc inp -> do
|
||||||
let cmdev = processEvent inp
|
let cmdev = processEvent inp
|
||||||
|
|
||||||
|
playing <- accumHoldBy (const . not) True -< filterE isPlayPause cmdev
|
||||||
time <- accum 0.2 -< mapFilterE getChangeSpeed cmdev
|
time <- accum 0.2 -< mapFilterE getChangeSpeed cmdev
|
||||||
windowSize <- hold (100, 100) -< mapFilterE getResize cmdev
|
windowSize <- hold (100, 100) -< mapFilterE getResize cmdev
|
||||||
|
|
||||||
space <- engine initSpace <<< tickSignal -< time
|
tick <- tickSignal -< time
|
||||||
|
space <- engine initSpace -< gate tick playing
|
||||||
|
|
||||||
returnA -< drawGrid windowSize white (getSpace space)
|
returnA -< drawGrid windowSize white (getSpace space)
|
2
Main.hs
2
Main.hs
|
@ -10,4 +10,4 @@ space :: ToroidalSpace Bool
|
||||||
space = tabulate (\(x,y) -> (x + y `mod` 5) * 10 + x - y > 30)
|
space = tabulate (\(x,y) -> (x + y `mod` 5) * 10 + x - y > 30)
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = playYampa (InWindow "a" (2, 2) (2, 2)) black 30 (run space)
|
main = playYampa (InWindow "a" (200, 200) (10, 10)) black 30 (run space)
|
Loading…
Reference in a new issue