{- | 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'.
-}

{-# 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

-- 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 { GlossM a -> ReaderT (Float, Maybe Event) (Writer Picture) a
unGlossM :: (ReaderT (Float, Maybe Event)) (Writer Picture) a }
  deriving (a -> GlossM b -> GlossM a
(a -> b) -> GlossM a -> GlossM b
(forall a b. (a -> b) -> GlossM a -> GlossM b)
-> (forall a b. a -> GlossM b -> GlossM a) -> Functor GlossM
forall a b. a -> GlossM b -> GlossM a
forall a b. (a -> b) -> GlossM a -> GlossM b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> GlossM b -> GlossM a
$c<$ :: forall a b. a -> GlossM b -> GlossM a
fmap :: (a -> b) -> GlossM a -> GlossM b
$cfmap :: forall a b. (a -> b) -> GlossM a -> GlossM b
Functor, Functor GlossM
a -> GlossM a
Functor GlossM
-> (forall a. a -> GlossM a)
-> (forall a b. GlossM (a -> b) -> GlossM a -> GlossM b)
-> (forall a b c.
    (a -> b -> c) -> GlossM a -> GlossM b -> GlossM c)
-> (forall a b. GlossM a -> GlossM b -> GlossM b)
-> (forall a b. GlossM a -> GlossM b -> GlossM a)
-> Applicative GlossM
GlossM a -> GlossM b -> GlossM b
GlossM a -> GlossM b -> GlossM a
GlossM (a -> b) -> GlossM a -> GlossM b
(a -> b -> c) -> GlossM a -> GlossM b -> GlossM c
forall a. a -> GlossM a
forall a b. GlossM a -> GlossM b -> GlossM a
forall a b. GlossM a -> GlossM b -> GlossM b
forall a b. GlossM (a -> b) -> GlossM a -> GlossM b
forall a b c. (a -> b -> c) -> GlossM a -> GlossM b -> GlossM c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: GlossM a -> GlossM b -> GlossM a
$c<* :: forall a b. GlossM a -> GlossM b -> GlossM a
*> :: GlossM a -> GlossM b -> GlossM b
$c*> :: forall a b. GlossM a -> GlossM b -> GlossM b
liftA2 :: (a -> b -> c) -> GlossM a -> GlossM b -> GlossM c
$cliftA2 :: forall a b c. (a -> b -> c) -> GlossM a -> GlossM b -> GlossM c
<*> :: GlossM (a -> b) -> GlossM a -> GlossM b
$c<*> :: forall a b. GlossM (a -> b) -> GlossM a -> GlossM b
pure :: a -> GlossM a
$cpure :: forall a. a -> GlossM a
$cp1Applicative :: Functor GlossM
Applicative, Applicative GlossM
a -> GlossM a
Applicative GlossM
-> (forall a b. GlossM a -> (a -> GlossM b) -> GlossM b)
-> (forall a b. GlossM a -> GlossM b -> GlossM b)
-> (forall a. a -> GlossM a)
-> Monad GlossM
GlossM a -> (a -> GlossM b) -> GlossM b
GlossM a -> GlossM b -> GlossM b
forall a. a -> GlossM a
forall a b. GlossM a -> GlossM b -> GlossM b
forall a b. GlossM a -> (a -> GlossM b) -> GlossM b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: a -> GlossM a
$creturn :: forall a. a -> GlossM a
>> :: GlossM a -> GlossM b -> GlossM b
$c>> :: forall a b. GlossM a -> GlossM b -> GlossM b
>>= :: GlossM a -> (a -> GlossM b) -> GlossM b
$c>>= :: forall a b. GlossM a -> (a -> GlossM b) -> GlossM b
$cp1Monad :: Applicative GlossM
Monad)

-- | Add a picture to the canvas.
paint :: Picture -> GlossM ()
paint :: Picture -> GlossM ()
paint = ReaderT (Float, Maybe Event) (Writer Picture) () -> GlossM ()
forall a.
ReaderT (Float, Maybe Event) (Writer Picture) a -> GlossM a
GlossM (ReaderT (Float, Maybe Event) (Writer Picture) () -> GlossM ())
-> (Picture -> ReaderT (Float, Maybe Event) (Writer Picture) ())
-> Picture
-> GlossM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WriterT Picture Identity ()
-> ReaderT (Float, Maybe Event) (Writer Picture) ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (WriterT Picture Identity ()
 -> ReaderT (Float, Maybe Event) (Writer Picture) ())
-> (Picture -> WriterT Picture Identity ())
-> Picture
-> ReaderT (Float, Maybe Event) (Writer Picture) ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Picture -> WriterT Picture Identity ()
forall (m :: * -> *) w. Monad m => w -> WriterT w m ()
tell

-- FIXME This doesn't what you think it does
-- | Clear the canvas.
clear :: GlossM ()
clear :: GlossM ()
clear = Picture -> GlossM ()
paint Picture
Blank

-- | Clear the canvas and then paint.
paintAll :: Picture -> GlossM ()
paintAll :: Picture -> GlossM ()
paintAll Picture
pic = GlossM ()
clear GlossM () -> GlossM () -> GlossM ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Picture -> GlossM ()
paint Picture
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
_ <> :: GlossClock -> GlossClock -> GlossClock
<> GlossClock
_ = GlossClock
GlossClock

instance Clock GlossM GlossClock where
  type Time GlossClock = Float
  type Tag  GlossClock = Maybe Event
  initClock :: GlossClock
-> RunningClockInit GlossM (Time GlossClock) (Tag GlossClock)
initClock GlossClock
_ = (MSF GlossM () (Float, Maybe Event), Float)
-> GlossM (MSF GlossM () (Float, Maybe Event), Float)
forall (m :: * -> *) a. Monad m => a -> m a
return (GlossM (Float, Maybe Event) -> MSF GlossM () (Float, Maybe Event)
forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM (ReaderT (Float, Maybe Event) (Writer Picture) (Float, Maybe Event)
-> GlossM (Float, Maybe Event)
forall a.
ReaderT (Float, Maybe Event) (Writer Picture) a -> GlossM a
GlossM ReaderT (Float, Maybe Event) (Writer Picture) (Float, Maybe Event)
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask) MSF GlossM () (Float, Maybe Event)
-> MSF GlossM (Float, Maybe Event) (Float, Maybe Event)
-> MSF GlossM () (Float, Maybe Event)
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> (MSF GlossM Float Float
forall v s (m :: * -> *). (VectorSpace v s, Monad m) => MSF m v v
sumS MSF GlossM Float Float
-> MSF GlossM (Maybe Event) (Maybe Event)
-> MSF GlossM (Float, Maybe Event) (Float, Maybe Event)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** MSF GlossM (Maybe Event) (Maybe Event)
forall k (cat :: k -> k -> *) (a :: k). Category cat => cat a a
Category.id), Float
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 :: ClSF GlossM GlossClock () (Maybe Event)
currentEvent = ClSF GlossM GlossClock () (Maybe Event)
forall (m :: * -> *) cl a. Monad m => ClSF m cl a (Tag cl)
tagS

-- * Reactimation

-- | The main function that will start the @gloss@ backend and run the 'SN'
--   (in the case of the combined clock).
flowGloss
  :: GlossSettings
  -> GlossClSF -- ^ The @gloss@-compatible 'Rhine'.
  -> IO ()
flowGloss :: GlossSettings -> GlossClSF -> IO ()
flowGloss GlossSettings
settings GlossClSF
clsf = GlossSettings
-> GlossClock
-> MSF GlossM (Time GlossClock, Tag GlossClock) ()
-> IO ()
forall cl b.
Clock GlossM cl =>
GlossSettings -> cl -> MSF GlossM (Time cl, Tag cl) b -> IO ()
flowGlossWithWorldMSF GlossSettings
settings GlossClock
GlossClock (MSF GlossM (Time GlossClock, Tag GlossClock) () -> IO ())
-> MSF GlossM (Time GlossClock, Tag GlossClock) () -> IO ()
forall a b. (a -> b) -> a -> b
$ proc (Time GlossClock
time, Tag GlossClock
tag) -> do
  (() -> GlossM ()) -> MSF GlossM () ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM (GlossM () -> () -> GlossM ()
forall a b. a -> b -> a
const GlossM ()
clear) -< ()
  Picture
pic <- ClockProxy GlossClock
-> Time GlossClock
-> GlossClSF
-> MSF GlossM (Time GlossClock, Tag GlossClock, ()) Picture
forall (m :: * -> *) cl a b.
(Monad m, Clock m cl) =>
ClockProxy cl
-> Time cl -> ClSF m cl a b -> MSF m (Time cl, Tag cl, a) b
eraseClockClSF ClockProxy GlossClock
forall cl. GetClockProxy cl => ClockProxy cl
getClockProxy Time GlossClock
0 GlossClSF
clsf -< (Float
Time GlossClock
time, Maybe Event
Tag GlossClock
tag, ())
  (Picture -> GlossM ()) -> MSF GlossM Picture ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a b
arrM Picture -> GlossM ()
paint -< Picture
pic


-- FIXME Hide?
-- | Helper function
flowGlossWithWorldMSF :: GlossSettings -> cl -> MSF GlossM (Time cl, Tag cl) b -> IO ()
flowGlossWithWorldMSF GlossSettings { Int
Display
Color
stepsPerSecond :: GlossSettings -> Int
backgroundColor :: GlossSettings -> Color
display :: GlossSettings -> Display
stepsPerSecond :: Int
backgroundColor :: Color
display :: Display
.. } cl
clock MSF GlossM (Time cl, Tag cl) b
msf
  = Display
-> Color
-> Int
-> (MSF (Writer Picture) ((Float, Maybe Event), ()) b, Picture)
-> ((MSF (Writer Picture) ((Float, Maybe Event), ()) b, Picture)
    -> Picture)
-> (Event
    -> (MSF (Writer Picture) ((Float, Maybe Event), ()) b, Picture)
    -> (MSF (Writer Picture) ((Float, Maybe Event), ()) b, Picture))
-> (Float
    -> (MSF (Writer Picture) ((Float, Maybe Event), ()) b, Picture)
    -> (MSF (Writer Picture) ((Float, Maybe Event), ()) b, Picture))
-> IO ()
forall world.
Display
-> Color
-> Int
-> world
-> (world -> Picture)
-> (Event -> world -> world)
-> (Float -> world -> world)
-> IO ()
play Display
display Color
backgroundColor Int
stepsPerSecond (MSF (Writer Picture) ((Float, Maybe Event), ()) b
worldMSF, Picture
Blank) (MSF (Writer Picture) ((Float, Maybe Event), ()) b, Picture)
-> Picture
forall a b. (a, b) -> b
getPic Event
-> (MSF (Writer Picture) ((Float, Maybe Event), ()) b, Picture)
-> (MSF (Writer Picture) ((Float, Maybe Event), ()) b, Picture)
forall a a w b b.
Num a =>
a
-> (MSF (WriterT w Identity) ((a, Maybe a), ()) b, b)
-> (MSF (WriterT w Identity) ((a, Maybe a), ()) b, w)
handleEvent Float
-> (MSF (Writer Picture) ((Float, Maybe Event), ()) b, Picture)
-> (MSF (Writer Picture) ((Float, Maybe Event), ()) b, Picture)
forall a w a b b.
a
-> (MSF (WriterT w Identity) ((a, Maybe a), ()) b, b)
-> (MSF (WriterT w Identity) ((a, Maybe a), ()) b, w)
simStep
    where
      worldMSF :: MSF (Writer Picture) ((Float, Maybe Event), ()) b
worldMSF = MSF (ReaderT (Float, Maybe Event) (Writer Picture)) () b
-> MSF (Writer Picture) ((Float, Maybe Event), ()) b
forall (m :: * -> *) r a b.
Monad m =>
MSF (ReaderT r m) a b -> MSF m (r, a) b
MSFReader.runReaderS (MSF (ReaderT (Float, Maybe Event) (Writer Picture)) () b
 -> MSF (Writer Picture) ((Float, Maybe Event), ()) b)
-> MSF (ReaderT (Float, Maybe Event) (Writer Picture)) () b
-> MSF (Writer Picture) ((Float, Maybe Event), ()) b
forall a b. (a -> b) -> a -> b
$ (forall c.
 GlossM c -> ReaderT (Float, Maybe Event) (Writer Picture) c)
-> MSF GlossM () b
-> MSF (ReaderT (Float, Maybe Event) (Writer Picture)) () b
forall (m2 :: * -> *) (m1 :: * -> *) a b.
(Monad m2, Monad m1) =>
(forall c. m1 c -> m2 c) -> MSF m1 a b -> MSF m2 a b
morphS forall c.
GlossM c -> ReaderT (Float, Maybe Event) (Writer Picture) c
unGlossM (MSF GlossM () b
 -> MSF (ReaderT (Float, Maybe Event) (Writer Picture)) () b)
-> MSF GlossM () b
-> MSF (ReaderT (Float, Maybe Event) (Writer Picture)) () b
forall a b. (a -> b) -> a -> b
$ proc () -> do
        (Time cl
time, Tag cl
tag) <- (MSF GlossM () (Time cl, Tag cl), Time cl)
-> MSF GlossM () (Time cl, Tag cl)
forall a b. (a, b) -> a
fst ((MSF GlossM () (Time cl, Tag cl), Time cl)
 -> MSF GlossM () (Time cl, Tag cl))
-> (MSF GlossM () (Time cl, Tag cl), Time cl)
-> MSF GlossM () (Time cl, Tag cl)
forall a b. (a -> b) -> a -> b
$ ((MSF GlossM () (Time cl, Tag cl), Time cl), Picture)
-> (MSF GlossM () (Time cl, Tag cl), Time cl)
forall a b. (a, b) -> a
fst (((MSF GlossM () (Time cl, Tag cl), Time cl), Picture)
 -> (MSF GlossM () (Time cl, Tag cl), Time cl))
-> ((MSF GlossM () (Time cl, Tag cl), Time cl), Picture)
-> (MSF GlossM () (Time cl, Tag cl), Time cl)
forall a b. (a -> b) -> a -> b
$ Writer Picture (MSF GlossM () (Time cl, Tag cl), Time cl)
-> ((MSF GlossM () (Time cl, Tag cl), Time cl), Picture)
forall w a. Writer w a -> (a, w)
runWriter (Writer Picture (MSF GlossM () (Time cl, Tag cl), Time cl)
 -> ((MSF GlossM () (Time cl, Tag cl), Time cl), Picture))
-> Writer Picture (MSF GlossM () (Time cl, Tag cl), Time cl)
-> ((MSF GlossM () (Time cl, Tag cl), Time cl), Picture)
forall a b. (a -> b) -> a -> b
$ (ReaderT
   (Float, Maybe Event)
   (Writer Picture)
   (MSF GlossM () (Time cl, Tag cl), Time cl)
 -> (Float, Maybe Event)
 -> Writer Picture (MSF GlossM () (Time cl, Tag cl), Time cl))
-> (Float, Maybe Event)
-> ReaderT
     (Float, Maybe Event)
     (Writer Picture)
     (MSF GlossM () (Time cl, Tag cl), Time cl)
-> Writer Picture (MSF GlossM () (Time cl, Tag cl), Time cl)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT
  (Float, Maybe Event)
  (Writer Picture)
  (MSF GlossM () (Time cl, Tag cl), Time cl)
-> (Float, Maybe Event)
-> Writer Picture (MSF GlossM () (Time cl, Tag cl), Time cl)
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (Float
0, Maybe Event
forall a. Maybe a
Nothing) (ReaderT
   (Float, Maybe Event)
   (Writer Picture)
   (MSF GlossM () (Time cl, Tag cl), Time cl)
 -> Writer Picture (MSF GlossM () (Time cl, Tag cl), Time cl))
-> ReaderT
     (Float, Maybe Event)
     (Writer Picture)
     (MSF GlossM () (Time cl, Tag cl), Time cl)
-> Writer Picture (MSF GlossM () (Time cl, Tag cl), Time cl)
forall a b. (a -> b) -> a -> b
$ GlossM (MSF GlossM () (Time cl, Tag cl), Time cl)
-> ReaderT
     (Float, Maybe Event)
     (Writer Picture)
     (MSF GlossM () (Time cl, Tag cl), Time cl)
forall c.
GlossM c -> ReaderT (Float, Maybe Event) (Writer Picture) c
unGlossM (GlossM (MSF GlossM () (Time cl, Tag cl), Time cl)
 -> ReaderT
      (Float, Maybe Event)
      (Writer Picture)
      (MSF GlossM () (Time cl, Tag cl), Time cl))
-> GlossM (MSF GlossM () (Time cl, Tag cl), Time cl)
-> ReaderT
     (Float, Maybe Event)
     (Writer Picture)
     (MSF GlossM () (Time cl, Tag cl), Time cl)
forall a b. (a -> b) -> a -> b
$ cl -> GlossM (MSF GlossM () (Time cl, Tag cl), Time cl)
forall (m :: * -> *) cl.
Clock m cl =>
cl -> RunningClockInit m (Time cl) (Tag cl)
initClock cl
clock -< ()
        MSF GlossM (Time cl, Tag cl) b
msf -< (Time cl
time, Tag cl
tag)
      getPic :: (a, b) -> b
getPic (a
_, b
pic) = b
pic
      stepWith :: (a, b)
-> (MSF (WriterT w Identity) ((a, b), ()) b, b)
-> (MSF (WriterT w Identity) ((a, b), ()) b, w)
stepWith (a
diff, b
maybeEvent) (MSF (WriterT w Identity) ((a, b), ()) b
msf, b
_) = (b, MSF (WriterT w Identity) ((a, b), ()) b)
-> MSF (WriterT w Identity) ((a, b), ()) b
forall a b. (a, b) -> b
snd ((b, MSF (WriterT w Identity) ((a, b), ()) b)
 -> MSF (WriterT w Identity) ((a, b), ()) b)
-> (w -> w)
-> ((b, MSF (WriterT w Identity) ((a, b), ()) b), w)
-> (MSF (WriterT w Identity) ((a, b), ()) b, w)
forall (a :: * -> * -> *) b c b' c'.
Arrow a =>
a b c -> a b' c' -> a (b, b') (c, c')
*** w -> w
forall a. a -> a
id (((b, MSF (WriterT w Identity) ((a, b), ()) b), w)
 -> (MSF (WriterT w Identity) ((a, b), ()) b, w))
-> ((b, MSF (WriterT w Identity) ((a, b), ()) b), w)
-> (MSF (WriterT w Identity) ((a, b), ()) b, w)
forall a b. (a -> b) -> a -> b
$ Writer w (b, MSF (WriterT w Identity) ((a, b), ()) b)
-> ((b, MSF (WriterT w Identity) ((a, b), ()) b), w)
forall w a. Writer w a -> (a, w)
runWriter (Writer w (b, MSF (WriterT w Identity) ((a, b), ()) b)
 -> ((b, MSF (WriterT w Identity) ((a, b), ()) b), w))
-> Writer w (b, MSF (WriterT w Identity) ((a, b), ()) b)
-> ((b, MSF (WriterT w Identity) ((a, b), ()) b), w)
forall a b. (a -> b) -> a -> b
$ MSF (WriterT w Identity) ((a, b), ()) b
-> ((a, b), ())
-> Writer w (b, MSF (WriterT w Identity) ((a, b), ()) b)
forall (m :: * -> *) a b. MSF m a b -> a -> m (b, MSF m a b)
unMSF MSF (WriterT w Identity) ((a, b), ()) b
msf ((a
diff, b
maybeEvent), ())
      handleEvent :: a
-> (MSF (WriterT w Identity) ((a, Maybe a), ()) b, b)
-> (MSF (WriterT w Identity) ((a, Maybe a), ()) b, w)
handleEvent a
event = (a, Maybe a)
-> (MSF (WriterT w Identity) ((a, Maybe a), ()) b, b)
-> (MSF (WriterT w Identity) ((a, Maybe a), ()) b, w)
forall a b w b b.
(a, b)
-> (MSF (WriterT w Identity) ((a, b), ()) b, b)
-> (MSF (WriterT w Identity) ((a, b), ()) b, w)
stepWith (a
0, a -> Maybe a
forall a. a -> Maybe a
Just a
event)
      simStep :: a
-> (MSF (WriterT w Identity) ((a, Maybe a), ()) b, b)
-> (MSF (WriterT w Identity) ((a, Maybe a), ()) b, w)
simStep a
diff = (a, Maybe a)
-> (MSF (WriterT w Identity) ((a, Maybe a), ()) b, b)
-> (MSF (WriterT w Identity) ((a, Maybe a), ()) b, w)
forall a b w b b.
(a, b)
-> (MSF (WriterT w Identity) ((a, b), ()) b, b)
-> (MSF (WriterT w Identity) ((a, b), ()) b, w)
stepWith (a
diff, Maybe a
forall a. Maybe a
Nothing)