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

module Graphics.GlossUtils (playYampa, InputEvent) where

-- A utility function to connect the FRP library Yampa to the
-- graphics library Gloss, from the library yampa-gloss

import Control.Monad (when)
import Data.IORef
  ( newIORef,
    readIORef,
    writeIORef,
  )
import FRP.Yampa
  ( Event (..),
    SF,
    react,
    reactInit,
  )
import Graphics.Gloss
  ( Color,
    Display,
    Picture,
    blank,
  )
import qualified Graphics.Gloss
import Graphics.Gloss.Interface.IO.Game (playIO)
import qualified Graphics.Gloss.Interface.IO.Game as G

type InputEvent = Event G.Event

playYampa ::
  -- | The display method
  Display ->
  -- | The background color
  Color ->
  -- | The refresh rate, in Hertz
  Int ->
  SF InputEvent Picture ->
  IO ()
playYampa display color frequency mainSF = do
  picRef <- newIORef blank
  handle <-
    reactInit
      (return NoEvent)
      ( \_ updated pic ->
          when updated (picRef `writeIORef` pic) >> return False
      )
      mainSF
  let delta = 0.01 / fromIntegral frequency
      toPic = const $ readIORef picRef
      handleInput = (\e t -> react handle (delta, Just (Event e)) >> return (t + delta))
      stepWorld =
        ( \d t ->
            let delta' = realToFrac d - t
             in if delta' > 0
                  then react handle (delta', Just NoEvent) >> return 0.0
                  else return (- delta')
        )
  playIO display color frequency 0 toPic handleInput stepWorld