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 module Graphics.Engine where
@ -6,8 +9,10 @@ import Control.Arrow
import Control.Monad.Representable.Reader import Control.Monad.Representable.Reader
import FRP.Yampa import FRP.Yampa
import GOL.Engine import GOL.Engine
import GOL.Rule
import GOL.Space import GOL.Space
import Graphics.Config import Graphics.Config
import Graphics.Display (drawGrid)
import Graphics.Gloss import Graphics.Gloss
import Graphics.Gloss.Interface.IO.Game hiding (Event) import Graphics.Gloss.Interface.IO.Game hiding (Event)
import qualified Graphics.Gloss.Interface.IO.Game as G 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 :: Space f => GOL f Bool -> SF TickEvent (GOL f Bool)
engine = accumHoldBy (\s _ -> tick s) engine = accumHoldBy (\s _ -> tick s)
defaultPeriod = 0.5
repeatTick :: Time -> SF a TickEvent repeatTick :: Time -> SF a TickEvent
repeatTick t = repeatedly t () repeatTick t = repeatedly t ()
tickSignal :: SF (Event Time) TickEvent tickSignal :: SF (Event Time) TickEvent
tickSignal = tickSignal =
arr (\ev -> ((), fmap repeatTick ev)) arr (\ev -> ((), fmap repeatTick ev))
>>> drSwitch (repeatTick defaultPeriod) >>> drSwitch (repeatTick 0.5)
run :: SF InputEvent Picture processEvent :: G.Event -> Config -> Config
run = arr (fmap processEvent) >>> accum defaultConfig >>> () processEvent (EventKey (Char '-') Down _ _) c = c {tickPeriod = tickPeriod c * 0.8}
where processEvent (EventResize s) c = c {windowSize = s}
processEvent :: G.Event -> Config -> Config processEvent _ c = c
processEvent (EventKey (Char '-') Down _ _) c = c {tickPeriod = tickPeriod c * 0.8}
processEvent (EventResize s) c = c {windowSize = s} run :: forall f. DisplayableSpace f => f Bool -> SF InputEvent Picture
processEvent _ c = c 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 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 :: IO ()
main = putStrLn "Hello" main = playYampa (InWindow "a" (2, 2) (2, 2)) black 30 (run space)