{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}

-- | Wrapper to write @gloss@ applications in Rhine, using concurrency.
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

-- mmorph
import Control.Monad.Morph

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

-- rhine
import FRP.Rhine

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

-- * Gloss effects

data GlossEnv = GlossEnv
  { GlossEnv -> MVar Float
timeVar :: MVar Float
  , GlossEnv -> MVar Event
eventVar :: MVar Event
  , GlossEnv -> IORef Picture
picRef :: IORef Picture
  , GlossEnv -> Float
time :: Float
  }

-- | 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, forall {k} (t :: (* -> *) -> k -> *).
(forall (m :: * -> *) (n :: * -> *) (b :: k).
 Monad m =>
 (forall a. m a -> n a) -> t m b -> t n b)
-> MFunctor t
forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> GlossConcT m b -> GlossConcT n b
hoist :: forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> GlossConcT m b -> GlossConcT n b
$choist :: forall (m :: * -> *) (n :: * -> *) b.
Monad m =>
(forall a. m a -> n a) -> GlossConcT m b -> GlossConcT n b
MFunctor, MonadTrans GlossConcT
MFunctor GlossConcT
forall (n :: * -> *) (m :: * -> *) b.
Monad n =>
(forall a. m a -> GlossConcT n a)
-> GlossConcT m b -> GlossConcT n b
forall (t :: (* -> *) -> * -> *).
MFunctor t
-> MonadTrans t
-> (forall (n :: * -> *) (m :: * -> *) b.
    Monad n =>
    (forall a. m a -> t n a) -> t m b -> t n b)
-> MMonad t
embed :: forall (n :: * -> *) (m :: * -> *) b.
Monad n =>
(forall a. m a -> GlossConcT n a)
-> GlossConcT m b -> GlossConcT n b
$cembed :: forall (n :: * -> *) (m :: * -> *) b.
Monad n =>
(forall a. m a -> GlossConcT n a)
-> GlossConcT m b -> GlossConcT n b
MMonad)

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
  GlossEnv {IORef Picture
picRef :: IORef Picture
picRef :: GlossEnv -> 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
        GlossEnv {MVar Event
eventVar :: MVar Event
eventVar :: GlossEnv -> MVar Event
eventVar, Float
time :: Float
time :: GlossEnv -> Float
time} <- 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
          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 (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
        GlossEnv {MVar Float
timeVar :: MVar Float
timeVar :: GlossEnv -> MVar Float
timeVar} <- 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

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
$ MVar Float -> MVar Event -> IORef Picture -> Float -> GlossEnv
GlossEnv 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 Picture
Blank forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Float
0
  let
    getPic :: GlossEnv -> IO Picture
getPic GlossEnv {IORef Picture
picRef :: IORef Picture
picRef :: GlossEnv -> IORef Picture
picRef} = forall a. IORef a -> IO a
readIORef IORef Picture
picRef
    -- Only try to put so this doesn't hang in case noone is listening for events or ticks
    handleEvent :: Event -> GlossEnv -> IO GlossEnv
handleEvent Event
event vars :: GlossEnv
vars@GlossEnv {MVar Event
eventVar :: MVar Event
eventVar :: GlossEnv -> MVar Event
eventVar} = 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 Event
eventVar Event
event
      forall (m :: * -> *) a. Monad m => a -> m a
return GlossEnv
vars
    simStep :: Float -> GlossEnv -> IO GlossEnv
simStep Float
diffTime vars :: GlossEnv
vars@GlossEnv {MVar Float
timeVar :: MVar Float
timeVar :: GlossEnv -> MVar Float
timeVar, Float
time :: Float
time :: GlossEnv -> Float
time} = do
      let !time' :: Float
time' = Float
time forall a. Num a => a -> a -> a
+ Float
diffTime
      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 Float
timeVar Float
time'
      forall (m :: * -> *) a. Monad m => a -> m a
return GlossEnv
vars {time :: Float
time = Float
time'}
  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 GlossEnv -> IO Picture
getPic Event -> GlossEnv -> IO GlossEnv
handleEvent Float -> GlossEnv -> IO GlossEnv
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 ::
  ( MonadIO m
  , Clock (GlossConcT m) cl
  , GetClockProxy cl
  , Time cl ~ Time (In cl)
  , Time cl ~ Time (Out cl)
  ) =>
  GlossSettings ->
  Rhine (GlossConcT m) cl () () ->
  m ()
flowGlossIO :: forall (m :: * -> *) cl.
(MonadIO m, Clock (GlossConcT m) cl, GetClockProxy cl,
 Time cl ~ Time (In cl), Time cl ~ Time (Out cl)) =>
GlossSettings -> Rhine (GlossConcT m) cl () () -> m ()
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 ::
  ( Clock (GlossConcT IO) cl1
  , Clock (GlossConcT IO) cl2
  , Time cl1 ~ Time cl2
  ) =>
  Schedule (GlossConcT IO) cl1 cl2
glossConcurrently :: forall cl1 cl2.
(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