Create prototype run function
This commit is contained in:
parent
42ec44a6f8
commit
ed1deaef5f
|
@ -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
|
||||
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
10
Main.hs
|
@ -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)
|
Loading…
Reference in a new issue