Pure.hs

{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

{- | A pure @gloss@ backend for Rhine.

To run pure Rhine apps with @gloss@,
write a clocked signal function ('ClSF') in the 'GlossClock' and use 'flowGloss'.
-}
module FRP.Rhine.Gloss.Pure (
  GlossM,
  paint,
  clear,
  paintAll,
  GlossClock (..),
  GlossClSF,
  currentEvent,
  flowGloss,
  flowGlossWithWorldMSF,
) where

-- base
import qualified Control.Category as Category

-- transformers
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer

-- dunai
import qualified Control.Monad.Trans.MSF.Reader as MSFReader
import Data.MonadicStreamFunction.InternalCore

-- rhine
import FRP.Rhine
import FRP.Rhine.Reactimation.ClockErasure

-- rhine-gloss
import FRP.Rhine.Gloss.Common

-- * @gloss@ effects

-- FIXME How about a Reader (MSF () (Either Float Event))? That might unify the two backends and make the pure one more flexible.

-- | A pure monad in which all effects caused by the @gloss@ backend take place.
newtype GlossM a = GlossM {unGlossM :: (ReaderT (Float, Maybe Event)) (Writer Picture) a}
  deriving (Functor, Applicative, Monad)

-- | Add a picture to the canvas.
paint :: Picture -> GlossM ()
paint = GlossM . lift . tell

-- FIXME This doesn't what you think it does

-- | Clear the canvas.
clear :: GlossM ()
clear = paint Blank

-- | Clear the canvas and then paint.
paintAll :: Picture -> GlossM ()
paintAll pic = clear >> paint pic

-- * Clocks

{- | The overall clock of a pure @rhine@ 'ClSF' that can be run by @gloss@.
   It ticks both on events (@tag = Just Event@) and simulation steps (@tag = Nothing@).
-}
data GlossClock = GlossClock

instance Semigroup GlossClock where
  _ <> _ = GlossClock

instance Clock GlossM GlossClock where
  type Time GlossClock = Float
  type Tag GlossClock = Maybe Event
  initClock _ = return (constM (GlossM ask) >>> (sumS *** Category.id), 0)

instance GetClockProxy GlossClock

-- * Signal functions

{- |
The type of a 'ClSF' you can implement to get a @gloss@ app,
if you chose to handle events and simulation steps in the same subsystem.

You can, but don't need to paint via 'GlossM':
You can also simply output the picture and it will be painted on top.
-}
type GlossClSF = ClSF GlossM GlossClock () Picture

{- | Observe whether there was an event this tick,
   and which one.
-}
currentEvent :: ClSF GlossM GlossClock () (Maybe Event)
currentEvent = tagS

-- * Reactimation

{- | The main function that will start the @gloss@ backend and run the 'SN'
   (in the case of the combined clock).
-}
flowGloss ::
  GlossSettings ->
  -- | The @gloss@-compatible 'Rhine'.
  GlossClSF ->
  IO ()
flowGloss settings clsf = flowGlossWithWorldMSF settings GlossClock $ proc (time, tag) -> do
  arrM (const clear) -< ()
  pic <- eraseClockClSF getClockProxy 0 clsf -< (time, tag, ())
  arrM paint -< pic

-- FIXME Hide?

-- | Helper function
flowGlossWithWorldMSF GlossSettings {..} clock msf =
  play display backgroundColor stepsPerSecond (worldMSF, Blank) getPic handleEvent simStep
  where
    worldMSF = MSFReader.runReaderS $ morphS unGlossM $ proc () -> do
      (time, tag) <- fst $ fst $ runWriter $ flip runReaderT (0, Nothing) $ unGlossM $ initClock clock -< ()
      msf -< (time, tag)
    getPic (_, pic) = pic
    stepWith (diff, maybeEvent) (msf, _) = first snd $ runWriter $ unMSF msf ((diff, maybeEvent), ())
    handleEvent event = stepWith (0, Just event)
    simStep diff = stepWith (diff, Nothing)