conways-game-of-life/Graphics/Engine.hs

60 lines
1.8 KiB
Haskell
Raw Normal View History

2021-12-28 18:16:51 -05:00
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE Arrows #-}
2021-12-29 18:51:48 -05:00
{-# LANGUAGE LambdaCase #-}
2021-12-28 18:16:51 -05:00
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
2021-12-28 16:40:48 -05:00
2021-12-27 18:08:04 -05:00
module Graphics.Engine where
import Control.Arrow
import Control.Monad.Representable.Reader
import FRP.Yampa
import GOL.Engine
2021-12-28 18:16:51 -05:00
import GOL.Rule
2021-12-27 18:08:04 -05:00
import GOL.Space
2021-12-29 18:51:48 -05:00
import Graphics.Command
2021-12-28 18:16:51 -05:00
import Graphics.Display (drawGrid)
2021-12-28 16:38:15 -05:00
import Graphics.Gloss
import Graphics.Gloss.Interface.IO.Game hiding (Event)
import qualified Graphics.Gloss.Interface.IO.Game as G
2021-12-28 16:40:48 -05:00
import Graphics.GlossUtils (InputEvent)
2021-12-27 18:08:04 -05:00
2021-12-28 16:40:48 -05:00
type TickEvent = Event ()
2021-12-27 18:08:04 -05:00
initialSpace :: Space f => f Bool
initialSpace = tabulate $ const False
2021-12-28 16:40:48 -05:00
engine :: Space f => GOL f Bool -> SF TickEvent (GOL f Bool)
2021-12-28 16:38:15 -05:00
engine = accumHoldBy (\s _ -> tick s)
2021-12-28 16:40:48 -05:00
repeatTick :: Time -> SF a TickEvent
repeatTick t = repeatedly t ()
2021-12-28 16:38:15 -05:00
2021-12-28 16:40:48 -05:00
tickSignal :: SF (Event Time) TickEvent
2021-12-28 16:38:15 -05:00
tickSignal =
arr (\ev -> ((), fmap repeatTick ev))
>>> drSwitch (repeatTick 0.2)
2021-12-28 18:16:51 -05:00
2021-12-29 18:51:48 -05:00
processEvent :: InputEvent -> CommandEvent
processEvent = event noEvent $ \case
EventKey (Char '-') Down _ _ -> Event $ ChangeSpeed (* 1.25)
EventKey (Char '+') Down _ _ -> Event $ ChangeSpeed (* 0.8)
2021-12-29 20:37:00 -05:00
EventKey (SpecialKey KeySpace) Down _ _ -> Event PlayPause
2021-12-29 18:51:48 -05:00
EventKey {} -> noEvent
EventMotion {} -> noEvent
EventResize size -> Event $ Resize size
2021-12-28 18:16:51 -05:00
run :: forall f. DisplayableSpace f => f Bool -> SF InputEvent Picture
2021-12-29 18:51:48 -05:00
run st =
let initSpace = gol' standardRule st
in proc inp -> do
let cmdev = processEvent inp
2021-12-29 20:37:00 -05:00
playing <- accumHoldBy (const . not) True -< filterE isPlayPause cmdev
2021-12-29 18:51:48 -05:00
time <- accum 0.2 -< mapFilterE getChangeSpeed cmdev
windowSize <- hold (100, 100) -< mapFilterE getResize cmdev
2021-12-29 20:37:00 -05:00
tick <- tickSignal -< time
space <- engine initSpace -< gate tick playing
2021-12-29 18:51:48 -05:00
returnA -< drawGrid windowSize white (getSpace space)