Create prototype run function

This commit is contained in:
Kiana Sheibani 2021-12-28 18:16:51 -05:00
parent 42ec44a6f8
commit ed1deaef5f
2 changed files with 28 additions and 12 deletions

View file

@ -1,4 +1,7 @@
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Graphics.Engine where
@ -6,8 +9,10 @@ import Control.Arrow
import Control.Monad.Representable.Reader
import FRP.Yampa
import GOL.Engine
import GOL.Rule
import GOL.Space
import Graphics.Config
import Graphics.Display (drawGrid)
import Graphics.Gloss
import Graphics.Gloss.Interface.IO.Game hiding (Event)
import qualified Graphics.Gloss.Interface.IO.Game as G
@ -21,20 +26,23 @@ initialSpace = tabulate $ const False
engine :: Space f => GOL f Bool -> SF TickEvent (GOL f Bool)
engine = accumHoldBy (\s _ -> tick s)
defaultPeriod = 0.5
repeatTick :: Time -> SF a TickEvent
repeatTick t = repeatedly t ()
tickSignal :: SF (Event Time) TickEvent
tickSignal =
arr (\ev -> ((), fmap repeatTick ev))
>>> drSwitch (repeatTick defaultPeriod)
>>> drSwitch (repeatTick 0.5)
run :: SF InputEvent Picture
run = arr (fmap processEvent) >>> accum defaultConfig >>> ()
where
processEvent :: G.Event -> Config -> Config
processEvent (EventKey (Char '-') Down _ _) c = c {tickPeriod = tickPeriod c * 0.8}
processEvent (EventResize s) c = c {windowSize = s}
processEvent _ c = c
run :: forall f. DisplayableSpace f => f Bool -> SF InputEvent Picture
run st =
(arr . fmap) processEvent
>>> accum defaultConfig
>>> identity &&& (arr . fmap) tickPeriod
>>> hold defaultConfig *** (tickSignal >>> engine @f (gol' standardRule st))
>>> arr (\(c, s) -> drawGrid @f c (getSpace s))

10
Main.hs
View file

@ -1,5 +1,13 @@
module Main where
import Control.Monad.Representable.Reader
import GOL.Space
import Graphics.Engine (initialSpace, run)
import Graphics.Gloss
import Graphics.GlossUtils (playYampa)
space :: ToroidalSpace Bool
space = tabulate (\(x,y) -> (x + y `mod` 5) * 10 + x - y > 30)
main :: IO ()
main = putStrLn "Hello"
main = playYampa (InWindow "a" (2, 2) (2, 2)) black 30 (run space)