{-# LANGUAGE Arrows #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module FRP.Rhine.Gloss.Pure
( GlossM
, paint
, clear
, paintAll
, GlossClock (..)
, GlossClSF
, currentEvent
, flowGloss
, flowGlossWithWorldMSF
) where
import qualified Control.Category as Category
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Trans.Writer
import qualified Control.Monad.Trans.MSF.Reader as MSFReader
import Data.MonadicStreamFunction.InternalCore
import FRP.Rhine
import FRP.Rhine.Reactimation.ClockErasure
import FRP.Rhine.Gloss.Common
newtype GlossM a = GlossM { unGlossM :: (ReaderT (Float, Maybe Event)) (Writer Picture) a }
deriving (Functor, Applicative, Monad)
paint :: Picture -> GlossM ()
paint = GlossM . lift . tell
clear :: GlossM ()
clear = paint Blank
paintAll :: Picture -> GlossM ()
paintAll pic = clear >> paint pic
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
type GlossClSF = ClSF GlossM GlossClock () Picture
currentEvent :: ClSF GlossM GlossClock () (Maybe Event)
currentEvent = tagS
flowGloss
:: GlossSettings
-> 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
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, _) = snd *** id $ runWriter $ unMSF msf ((diff, maybeEvent), ())
handleEvent event = stepWith (0, Just event)
simStep diff = stepWith (diff, Nothing)