Refactor run function to fix bugs

Graphics/Command.hs

@@ -0,0 +1,17 @@
+module Graphics.Command where
+
+import FRP.Yampa (Time, Event)
+
+data Command
+  = Resize (Int, Int)
+  | ChangeSpeed (Time -> Time)
+
+getResize :: Command -> Maybe (Int, Int)
+getResize (Resize size) = Just size
+getResize _ = Nothing
+
+getChangeSpeed :: Command -> Maybe (Time -> Time)
+getChangeSpeed (ChangeSpeed f) = Just f
+getChangeSpeed _ = Nothing
+
+type CommandEvent = Event Command

Graphics/Config.hs

@@ -1,15 +0,0 @@
-module Graphics.Config where
-
-import FRP.Yampa (Time)
-import GOL.Rule
-import Graphics.Gloss (Color, white)
-
-data Config = Config
-  { rule :: Rule,
-    tickPeriod :: Time,
-    cellColor :: Color,
-    windowSize :: (Int, Int)
-  }
-
-defaultConfig :: Config
-defaultConfig = Config standardRule 0.2 white (500, 500)

Graphics/Display.hs

@@ -6,7 +6,6 @@ module Graphics.Display where
 import Control.Monad.Representable.Reader
 import Data.Maybe (mapMaybe)
 import GOL.Space
-import Graphics.Config
 import Graphics.Gloss
 
 -- * Drawing the display grid
@@ -28,9 +27,8 @@ drawCells xs size =
   let poss = (,) <$> [0 .. sizex @f -1] <*> [0 .. sizey @f -1]
    in mapMaybe (\pos -> drawCell xs pos size) poss
 
-drawGrid :: forall f. DisplayableSpace f => Config -> f Bool -> Picture
-drawGrid config xs =
-  let (w, h) = windowSize config
-      size = fromIntegral $ if w > h then h `div` sizey @f else w `div` sizex @f
+drawGrid :: forall f. DisplayableSpace f => (Int, Int) -> Color -> f Bool -> Picture
+drawGrid (w, h) c xs =
+  let size = fromIntegral $ if w > h then h `div` sizey @f else w `div` sizex @f
    in translate (fromIntegral $ -w `div` 2) (fromIntegral $ -h `div` 2) $
-      color (cellColor config) $ pictures $ drawCells xs size
+      color c $ pictures $ drawCells xs size

Graphics/Engine.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE AllowAmbiguousTypes #-}
 {-# LANGUAGE Arrows #-}
+{-# LANGUAGE LambdaCase #-}
 {-# LANGUAGE RankNTypes #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 
@@ -11,7 +12,7 @@ import FRP.Yampa
 import GOL.Engine
 import GOL.Rule
 import GOL.Space
-import Graphics.Config
+import Graphics.Command
 import Graphics.Display (drawGrid)
 import Graphics.Gloss
 import Graphics.Gloss.Interface.IO.Game hiding (Event)
@@ -34,15 +35,23 @@ tickSignal =
   arr (\ev -> ((), fmap repeatTick ev))
     >>> drSwitch (repeatTick 0.2)
 
-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 :: InputEvent -> CommandEvent
+processEvent = event noEvent $ \case
+  EventKey (Char '-') Down _ _ -> Event $ ChangeSpeed (* 1.25)
+  EventKey (Char '+') Down _ _ -> Event $ ChangeSpeed (* 0.8)
+  EventKey {} -> noEvent
+  EventMotion {} -> noEvent
+  EventResize size -> Event $ Resize size
 
 run :: forall f. DisplayableSpace f => f Bool -> SF InputEvent Picture
-run st = proc ev -> do
-              c <- accum defaultConfig -< fmap processEvent ev
-              c' <- hold defaultConfig -< c
-              t <- tickSignal -< fmap tickPeriod c
-              s <- engine (gol' standardRule st) -< t
-              identity -< drawGrid c' (getSpace s)
+run st =
+  let initSpace = gol' standardRule st
+   in proc inp -> do
+        let cmdev = processEvent inp
+
+        time <- accum 0.2 -< mapFilterE getChangeSpeed cmdev
+        windowSize <- hold (100, 100) -< mapFilterE getResize cmdev
+
+        space <- engine initSpace <<< tickSignal -< time
+
+        returnA -< drawGrid windowSize white (getSpace space)

conways-game-of-life.cabal

@@ -12,7 +12,7 @@ executable gol
                   GOL.Space,
                   GOL.Engine,
                   Graphics.GlossUtils,
-                  Graphics.Config,
+                  Graphics.Command,
                   Graphics.Engine,
                   Graphics.Display
   build-depends:  base,