{- | Wrapper to write @gloss@ applications in Rhine, using concurrency.
-}

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module FRP.Rhine.Gloss.IO
  ( GlossConcT
  , paintIO
  , clearIO
  , paintAllIO
  , GlossEventClockIO (..)
  , GlossSimClockIO (..)
  , launchGlossThread
  , flowGlossIO
  , glossConcurrently
  )
  where

-- base
import Control.Concurrent
import Data.Functor (void)
import Data.IORef

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

-- gloss
import Graphics.Gloss.Interface.IO.Game

-- rhine
import FRP.Rhine

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

-- * Gloss effects

type GlossEnv = (MVar Float, MVar Event, IORef Float, IORef Picture)

-- | Wraps the concurrent variables needed for communication with the @gloss@ backend.
newtype GlossConcT m a = GlossConcT
  { forall (m :: * -> *) a. GlossConcT m a -> ReaderT GlossEnv m a
unGlossConcT :: ReaderT GlossEnv m a }
  deriving (forall a b. a -> GlossConcT m b -> GlossConcT m a
forall a b. (a -> b) -> GlossConcT m a -> GlossConcT m b
forall (m :: * -> *) a b.
Functor m =>
a -> GlossConcT m b -> GlossConcT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GlossConcT m a -> GlossConcT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> GlossConcT m b -> GlossConcT m a
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> GlossConcT m b -> GlossConcT m a
fmap :: forall a b. (a -> b) -> GlossConcT m a -> GlossConcT m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GlossConcT m a -> GlossConcT m b
Functor, forall a. a -> GlossConcT m a
forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m a
forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b
forall a b.
GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
forall a b c.
(a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m 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
forall {m :: * -> *}. Applicative m => Functor (GlossConcT m)
forall (m :: * -> *) a. Applicative m => a -> GlossConcT m a
forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m a
forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c
<* :: forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m a
*> :: forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
liftA2 :: forall a b c.
(a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c
<*> :: forall a b.
GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
pure :: forall a. a -> GlossConcT m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> GlossConcT m a
Applicative, forall a. a -> GlossConcT m a
forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b
forall a b.
GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m b
forall {m :: * -> *}. Monad m => Applicative (GlossConcT m)
forall (m :: * -> *) a. Monad m => a -> GlossConcT m a
forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m 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 :: forall a. a -> GlossConcT m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> GlossConcT m a
>> :: forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
>>= :: forall a b.
GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m b
Monad, forall (m :: * -> *) a. Monad m => m a -> GlossConcT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
lift :: forall (m :: * -> *) a. Monad m => m a -> GlossConcT m a
$clift :: forall (m :: * -> *) a. Monad m => m a -> GlossConcT m a
MonadTrans, forall a. IO a -> GlossConcT m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (GlossConcT m)
forall (m :: * -> *) a. MonadIO m => IO a -> GlossConcT m a
liftIO :: forall a. IO a -> GlossConcT m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> GlossConcT m a
MonadIO)

withPicRef
  :: MonadIO m
  => (IORef Picture -> IO a)
  -> GlossConcT m a
withPicRef :: forall (m :: * -> *) a.
MonadIO m =>
(IORef Picture -> IO a) -> GlossConcT m a
withPicRef IORef Picture -> IO a
action = forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT forall a b. (a -> b) -> a -> b
$ do
  (MVar Float
_, MVar Event
_, IORef Float
_, IORef Picture
picRef) <- forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IORef Picture -> IO a
action IORef Picture
picRef

-- | Add a picture to the canvas.
paintIO :: MonadIO m => Picture -> GlossConcT m ()
paintIO :: forall (m :: * -> *). MonadIO m => Picture -> GlossConcT m ()
paintIO Picture
pic = forall (m :: * -> *) a.
MonadIO m =>
(IORef Picture -> IO a) -> GlossConcT m a
withPicRef forall a b. (a -> b) -> a -> b
$ \IORef Picture
ref -> forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Picture
ref (forall a. Semigroup a => a -> a -> a
<> Picture
pic)

-- | Clear the canvas.
clearIO :: MonadIO m => GlossConcT m ()
clearIO :: forall (m :: * -> *). MonadIO m => GlossConcT m ()
clearIO = forall (m :: * -> *) a.
MonadIO m =>
(IORef Picture -> IO a) -> GlossConcT m a
withPicRef forall a b. (a -> b) -> a -> b
$ \IORef Picture
ref -> forall a. IORef a -> a -> IO ()
writeIORef IORef Picture
ref Picture
Blank

-- | Clear the canvas and then paint.
paintAllIO :: MonadIO m => Picture -> GlossConcT m ()
paintAllIO :: forall (m :: * -> *). MonadIO m => Picture -> GlossConcT m ()
paintAllIO Picture
pic = forall (m :: * -> *). MonadIO m => GlossConcT m ()
clearIO forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *). MonadIO m => Picture -> GlossConcT m ()
paintIO Picture
pic

-- * Gloss clocks in 'IO'

-- | Concurrently block on @gloss@ events.
data GlossEventClockIO = GlossEventClockIO

instance MonadIO m => Clock (GlossConcT m) GlossEventClockIO where
  type Time GlossEventClockIO = Float
  type Tag  GlossEventClockIO = Event
  initClock :: GlossEventClockIO
-> RunningClockInit
     (GlossConcT m) (Time GlossEventClockIO) (Tag GlossEventClockIO)
initClock GlossEventClockIO
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM GlossConcT m (Float, Event)
getEvent, Float
0)
    where
      getEvent :: GlossConcT m (Float, Event)
getEvent = do
        (MVar Float
_, MVar Event
eventVar, IORef Float
timeRef, IORef Picture
_) <- forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
          Event
event <- forall a. MVar a -> IO a
takeMVar MVar Event
eventVar
          Float
time <- forall a. IORef a -> IO a
readIORef IORef Float
timeRef
          forall (m :: * -> *) a. Monad m => a -> m a
return (Float
time, Event
event)

instance GetClockProxy GlossEventClockIO

-- | Concurrently block on @gloss@ simulation ticks.
data GlossSimClockIO = GlossSimClockIO

instance MonadIO m => Clock (GlossConcT m) GlossSimClockIO where
  type Time GlossSimClockIO = Float
  type Tag  GlossSimClockIO = ()
  initClock :: GlossSimClockIO
-> RunningClockInit
     (GlossConcT m) (Time GlossSimClockIO) (Tag GlossSimClockIO)
initClock GlossSimClockIO
_ = forall (m :: * -> *) a. Monad m => a -> m a
return (forall (m :: * -> *) b a. Monad m => m b -> MSF m a b
constM GlossConcT m Float
getTime forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall v s (m :: * -> *). (VectorSpace v s, Monad m) => MSF m v v
sumS forall {k} (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> forall (m :: * -> *) a b. Monad m => (a -> m b) -> MSF m a a
withSideEffect forall {m :: * -> *}. MonadIO m => Float -> GlossConcT m ()
writeTime forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& forall (a :: * -> * -> *) b c. Arrow a => (b -> c) -> a b c
arr (forall a b. a -> b -> a
const ()), Float
0)
    where
      getTime :: GlossConcT m Float
getTime = do
        (MVar Float
timeVar, MVar Event
_, IORef Float
_, IORef Picture
_) <- forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> IO a
takeMVar MVar Float
timeVar
      writeTime :: Float -> GlossConcT m ()
writeTime Float
time = do
        (MVar Float
_, MVar Event
_, IORef Float
timeRef, IORef Picture
_) <- forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef Float
timeRef Float
time

instance GetClockProxy GlossSimClockIO

-- * Reactimation

-- | Apply this to supply the 'GlossConcT' effect.
--   Creates a new thread in which @gloss@ is run,
--   and feeds the clocks 'GlossEventClockIO' and 'GlossSimClockIO'.
--
--   Usually, this function is applied to the result of 'flow',
--   so you can handle all occurring effects as needed.
--   If you only use @gloss@ in your whole signal network,
--   you can use 'flowGlossIO' instead.
launchGlossThread
  :: MonadIO    m
  => GlossSettings
  -> GlossConcT m a
  ->            m a
launchGlossThread :: forall (m :: * -> *) a.
MonadIO m =>
GlossSettings -> GlossConcT m a -> m a
launchGlossThread GlossSettings { Int
Display
Color
stepsPerSecond :: GlossSettings -> Int
backgroundColor :: GlossSettings -> Color
display :: GlossSettings -> Display
stepsPerSecond :: Int
backgroundColor :: Color
display :: Display
.. } GlossConcT m a
glossLoop = do
  GlossEnv
vars <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ ( , , , ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IO (MVar a)
newEmptyMVar forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. IO (MVar a)
newEmptyMVar forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIORef Float
0 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. a -> IO (IORef a)
newIORef Picture
Blank
  let
      getPic :: (a, b, c, IORef a) -> IO a
getPic               (a
_, b
_, c
_, IORef a
picRef)   = forall a. IORef a -> IO a
readIORef IORef a
picRef
      -- Only try to put so this doesn't hang in case noone is listening for events or ticks
      handleEvent :: a -> (a, MVar a, c, d) -> IO (a, MVar a, c, d)
handleEvent a
event    vars :: (a, MVar a, c, d)
vars@(a
_, MVar a
eventVar, c
_, d
_) = do
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO Bool
tryPutMVar MVar a
eventVar a
event
        forall (m :: * -> *) a. Monad m => a -> m a
return (a, MVar a, c, d)
vars
      simStep :: a -> (MVar a, b, c, d) -> IO (MVar a, b, c, d)
simStep     a
diffTime vars :: (MVar a, b, c, d)
vars@(MVar a
timeVar,  b
_, c
_, d
_) = do
        forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall a. MVar a -> a -> IO Bool
tryPutMVar MVar a
timeVar a
diffTime
        forall (m :: * -> *) a. Monad m => a -> m a
return (MVar a, b, c, d)
vars
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO forall a b. (a -> b) -> a -> b
$ forall world.
Display
-> Color
-> Int
-> world
-> (world -> IO Picture)
-> (Event -> world -> IO world)
-> (Float -> world -> IO world)
-> IO ()
playIO Display
display Color
backgroundColor Int
stepsPerSecond GlossEnv
vars forall {a} {b} {c} {a}. (a, b, c, IORef a) -> IO a
getPic forall {a} {a} {c} {d}.
a -> (a, MVar a, c, d) -> IO (a, MVar a, c, d)
handleEvent forall {a} {b} {c} {d}.
a -> (MVar a, b, c, d) -> IO (MVar a, b, c, d)
simStep
  forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall (m :: * -> *) a. GlossConcT m a -> ReaderT GlossEnv m a
unGlossConcT GlossConcT m a
glossLoop) GlossEnv
vars

-- | Run a 'Rhine' in the 'GlossConcT' monad by launching a separate thread for the @gloss@ backend,
--   and reactimate in the foreground.
flowGlossIO
  :: ( Clock (GlossConcT IO) cl
     , GetClockProxy cl
     , Time cl ~ Time (In  cl)
     , Time cl ~ Time (Out cl)
     )
  => GlossSettings
  -> Rhine (GlossConcT IO) cl () ()
  -> IO ()
flowGlossIO :: forall cl.
(Clock (GlossConcT IO) cl, GetClockProxy cl,
 Time cl ~ Time (In cl), Time cl ~ Time (Out cl)) =>
GlossSettings -> Rhine (GlossConcT IO) cl () () -> IO ()
flowGlossIO GlossSettings
settings = forall (m :: * -> *) a.
MonadIO m =>
GlossSettings -> GlossConcT m a -> m a
launchGlossThread GlossSettings
settings forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) cl.
(Monad m, Clock m cl, GetClockProxy cl, Time cl ~ Time (In cl),
 Time cl ~ Time (Out cl)) =>
Rhine m cl () () -> m ()
flow

-- | A schedule in the 'GlossConcT' transformer,
--   supplying the same backend connection to its scheduled clocks.
glossConcurrently
  :: ( Monad IO
     , Clock (GlossConcT IO) cl1, Clock (GlossConcT IO) cl2
     , Time cl1 ~ Time cl2
     )
  => Schedule (GlossConcT IO) cl1 cl2
glossConcurrently :: forall cl1 cl2.
(Monad IO, Clock (GlossConcT IO) cl1, Clock (GlossConcT IO) cl2,
 Time cl1 ~ Time cl2) =>
Schedule (GlossConcT IO) cl1 cl2
glossConcurrently = forall (m :: * -> *) cl1 cl2.
(Time cl1 ~ Time cl2) =>
(cl1
 -> cl2
 -> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2)))
-> Schedule m cl1 cl2
Schedule
  forall a b. (a -> b) -> a -> b
$ \cl1
cl1 cl2
cl2 -> forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT
  forall a b. (a -> b) -> a -> b
$ \GlossEnv
vars -> forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first forall (t :: (* -> *) -> * -> *) (m :: * -> *) a b.
(MonadTrans t, Monad m, Monad (t m)) =>
MSF m a b -> MSF (t m) a b
liftTransS
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) cl1 cl2.
Schedule m cl1 cl2
-> cl1
-> cl2
-> RunningClockInit m (Time cl1) (Either (Tag cl1) (Tag cl2))
initSchedule forall cl1 cl2.
(Clock IO cl1, Clock IO cl2, Time cl1 ~ Time cl2) =>
Schedule IO cl1 cl2
concurrently
        (forall cl. GlossEnv -> cl -> RunGlossEnvClock cl
runGlossEnvClock GlossEnv
vars cl1
cl1)
        (forall cl. GlossEnv -> cl -> RunGlossEnvClock cl
runGlossEnvClock GlossEnv
vars cl2
cl2)

type RunGlossEnvClock cl = HoistClock (GlossConcT IO) IO cl

runGlossEnvClock
  :: GlossEnv
  -> cl
  -> RunGlossEnvClock cl
runGlossEnvClock :: forall cl. GlossEnv -> cl -> RunGlossEnvClock cl
runGlossEnvClock GlossEnv
env cl
unhoistedClock = HoistClock
  { monadMorphism :: forall a. GlossConcT IO a -> IO a
monadMorphism = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT GlossEnv
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. GlossConcT m a -> ReaderT GlossEnv m a
unGlossConcT
  , cl
unhoistedClock :: cl
unhoistedClock :: cl
..
  }

-- FIXME And a schedule for gloss clocks and other clocks