{-# 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 (..),
  launchInGlossThread,
  launchGlossThread,
  flowGlossIO,
  runGlossEnvClock,
  RunGlossEnvClock,
)
where

-- base
import Control.Concurrent
import Control.Monad (when)
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

-- monad-schedule
import Control.Monad.Schedule.Class

-- 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 -> IORef Float
timeRef :: IORef 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 -> b) -> GlossConcT m a -> GlossConcT m b)
-> (forall a b. a -> GlossConcT m b -> GlossConcT m a)
-> Functor (GlossConcT m)
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
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> GlossConcT m a -> GlossConcT m b
fmap :: forall a b. (a -> b) -> GlossConcT m a -> GlossConcT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> GlossConcT m b -> GlossConcT m a
<$ :: forall a b. a -> GlossConcT m b -> GlossConcT m a
Functor, Functor (GlossConcT m)
Functor (GlossConcT m) =>
(forall a. a -> GlossConcT m a)
-> (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 a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b)
-> (forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m a)
-> Applicative (GlossConcT m)
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
$cpure :: forall (m :: * -> *) a. Applicative m => a -> GlossConcT m a
pure :: forall a. a -> GlossConcT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
<*> :: forall a b.
GlossConcT m (a -> b) -> GlossConcT m a -> GlossConcT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c
liftA2 :: forall a b c.
(a -> b -> c) -> GlossConcT m a -> GlossConcT m b -> GlossConcT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
GlossConcT m a -> GlossConcT m b -> GlossConcT m b
*> :: 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 a
<* :: forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m a
Applicative, Applicative (GlossConcT m)
Applicative (GlossConcT m) =>
(forall a b.
 GlossConcT m a -> (a -> GlossConcT m b) -> GlossConcT m b)
-> (forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b)
-> (forall a. a -> GlossConcT m a)
-> Monad (GlossConcT m)
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
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
GlossConcT m a -> (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 -> GlossConcT m b -> GlossConcT m b
>> :: forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> GlossConcT m a
return :: forall a. a -> GlossConcT m a
Monad, (forall (m :: * -> *). Monad m => Monad (GlossConcT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> GlossConcT m a)
-> MonadTrans GlossConcT
forall (m :: * -> *). Monad m => Monad (GlossConcT m)
forall (m :: * -> *) a. Monad m => m a -> GlossConcT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> GlossConcT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> GlossConcT m a
MonadTrans, Monad (GlossConcT m)
Monad (GlossConcT m) =>
(forall a. IO a -> GlossConcT m a) -> MonadIO (GlossConcT m)
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
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> GlossConcT m a
liftIO :: forall a. IO a -> GlossConcT m a
MonadIO, (forall (m :: * -> *) (n :: * -> *) b.
 Monad m =>
 (forall a. m a -> n a) -> GlossConcT m b -> GlossConcT n b)
-> MFunctor GlossConcT
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
$choist :: 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
MFunctor, MonadTrans GlossConcT
MFunctor GlossConcT
(MFunctor GlossConcT, MonadTrans GlossConcT) =>
(forall (n :: * -> *) (m :: * -> *) b.
 Monad n =>
 (forall a. m a -> GlossConcT n a)
 -> GlossConcT m b -> GlossConcT n b)
-> MMonad 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
$cembed :: forall (n :: * -> *) (m :: * -> *) b.
Monad n =>
(forall a. m a -> GlossConcT n a)
-> GlossConcT m b -> GlossConcT n b
embed :: forall (n :: * -> *) (m :: * -> *) b.
Monad n =>
(forall a. m a -> GlossConcT n a)
-> GlossConcT m b -> GlossConcT n b
MMonad)

instance (Monad m, MonadSchedule m) => MonadSchedule (GlossConcT m) where
  schedule :: forall a.
NonEmpty (GlossConcT m a)
-> GlossConcT m (NonEmpty a, [GlossConcT m a])
schedule NonEmpty (GlossConcT m a)
actions = ReaderT GlossEnv m (NonEmpty a, [GlossConcT m a])
-> GlossConcT m (NonEmpty a, [GlossConcT m a])
forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT (ReaderT GlossEnv m (NonEmpty a, [GlossConcT m a])
 -> GlossConcT m (NonEmpty a, [GlossConcT m a]))
-> ReaderT GlossEnv m (NonEmpty a, [GlossConcT m a])
-> GlossConcT m (NonEmpty a, [GlossConcT m a])
forall a b. (a -> b) -> a -> b
$ ((NonEmpty a, [ReaderT GlossEnv m a])
 -> (NonEmpty a, [GlossConcT m a]))
-> ReaderT GlossEnv m (NonEmpty a, [ReaderT GlossEnv m a])
-> ReaderT GlossEnv m (NonEmpty a, [GlossConcT m a])
forall a b.
(a -> b) -> ReaderT GlossEnv m a -> ReaderT GlossEnv m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([ReaderT GlossEnv m a] -> [GlossConcT m a])
-> (NonEmpty a, [ReaderT GlossEnv m a])
-> (NonEmpty a, [GlossConcT m a])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (([ReaderT GlossEnv m a] -> [GlossConcT m a])
 -> (NonEmpty a, [ReaderT GlossEnv m a])
 -> (NonEmpty a, [GlossConcT m a]))
-> ([ReaderT GlossEnv m a] -> [GlossConcT m a])
-> (NonEmpty a, [ReaderT GlossEnv m a])
-> (NonEmpty a, [GlossConcT m a])
forall a b. (a -> b) -> a -> b
$ (ReaderT GlossEnv m a -> GlossConcT m a)
-> [ReaderT GlossEnv m a] -> [GlossConcT m a]
forall a b. (a -> b) -> [a] -> [b]
map ReaderT GlossEnv m a -> GlossConcT m a
forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT) (ReaderT GlossEnv m (NonEmpty a, [ReaderT GlossEnv m a])
 -> ReaderT GlossEnv m (NonEmpty a, [GlossConcT m a]))
-> ReaderT GlossEnv m (NonEmpty a, [ReaderT GlossEnv m a])
-> ReaderT GlossEnv m (NonEmpty a, [GlossConcT m a])
forall a b. (a -> b) -> a -> b
$ NonEmpty (ReaderT GlossEnv m a)
-> ReaderT GlossEnv m (NonEmpty a, [ReaderT GlossEnv m a])
forall a.
NonEmpty (ReaderT GlossEnv m a)
-> ReaderT GlossEnv m (NonEmpty a, [ReaderT GlossEnv m a])
forall (m :: * -> *) a.
MonadSchedule m =>
NonEmpty (m a) -> m (NonEmpty a, [m a])
schedule (NonEmpty (ReaderT GlossEnv m a)
 -> ReaderT GlossEnv m (NonEmpty a, [ReaderT GlossEnv m a]))
-> NonEmpty (ReaderT GlossEnv m a)
-> ReaderT GlossEnv m (NonEmpty a, [ReaderT GlossEnv m a])
forall a b. (a -> b) -> a -> b
$ GlossConcT m a -> ReaderT GlossEnv m a
forall (m :: * -> *) a. GlossConcT m a -> ReaderT GlossEnv m a
unGlossConcT (GlossConcT m a -> ReaderT GlossEnv m a)
-> NonEmpty (GlossConcT m a) -> NonEmpty (ReaderT GlossEnv m a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NonEmpty (GlossConcT m a)
actions

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 = ReaderT GlossEnv m a -> GlossConcT m a
forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT (ReaderT GlossEnv m a -> GlossConcT m a)
-> ReaderT GlossEnv m a -> GlossConcT m a
forall a b. (a -> b) -> a -> b
$ do
  GlossEnv {IORef Picture
picRef :: GlossEnv -> IORef Picture
picRef :: IORef Picture
picRef} <- ReaderT GlossEnv m GlossEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
  IO a -> ReaderT GlossEnv m a
forall a. IO a -> ReaderT GlossEnv m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> ReaderT GlossEnv m a) -> IO a -> ReaderT GlossEnv m a
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 = (IORef Picture -> IO ()) -> GlossConcT m ()
forall (m :: * -> *) a.
MonadIO m =>
(IORef Picture -> IO a) -> GlossConcT m a
withPicRef ((IORef Picture -> IO ()) -> GlossConcT m ())
-> (IORef Picture -> IO ()) -> GlossConcT m ()
forall a b. (a -> b) -> a -> b
$ \IORef Picture
ref -> IORef Picture -> (Picture -> Picture) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef Picture
ref (Picture -> Picture -> Picture
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 = (IORef Picture -> IO ()) -> GlossConcT m ()
forall (m :: * -> *) a.
MonadIO m =>
(IORef Picture -> IO a) -> GlossConcT m a
withPicRef ((IORef Picture -> IO ()) -> GlossConcT m ())
-> (IORef Picture -> IO ()) -> GlossConcT m ()
forall a b. (a -> b) -> a -> b
$ \IORef Picture
ref -> IORef Picture -> Picture -> IO ()
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 = GlossConcT m ()
forall (m :: * -> *). MonadIO m => GlossConcT m ()
clearIO GlossConcT m () -> GlossConcT m () -> GlossConcT m ()
forall a b. GlossConcT m a -> GlossConcT m b -> GlossConcT m b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Picture -> GlossConcT m ()
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
_ = (Automaton (GlossConcT m) () (Float, Event), Float)
-> GlossConcT m (Automaton (GlossConcT m) () (Float, Event), Float)
forall a. a -> GlossConcT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GlossConcT m (Float, Event)
-> Automaton (GlossConcT m) () (Float, Event)
forall (m :: * -> *) b a. Functor m => m b -> Automaton m a b
constM GlossConcT m (Float, Event)
getEvent, Float
0)
    where
      getEvent :: GlossConcT m (Float, Event)
getEvent = do
        GlossEnv {MVar Event
eventVar :: GlossEnv -> MVar Event
eventVar :: MVar Event
eventVar, IORef Float
timeRef :: GlossEnv -> IORef Float
timeRef :: IORef Float
timeRef} <- ReaderT GlossEnv m GlossEnv -> GlossConcT m GlossEnv
forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT ReaderT GlossEnv m GlossEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        IO (Float, Event) -> GlossConcT m (Float, Event)
forall a. IO a -> GlossConcT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Float, Event) -> GlossConcT m (Float, Event))
-> IO (Float, Event) -> GlossConcT m (Float, Event)
forall a b. (a -> b) -> a -> b
$ do
          Event
event <- MVar Event -> IO Event
forall a. MVar a -> IO a
takeMVar MVar Event
eventVar
          Float
time <- IORef Float -> IO Float
forall a. IORef a -> IO a
readIORef IORef Float
timeRef
          (Float, Event) -> IO (Float, Event)
forall a. a -> IO a
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
_ = (Automaton (GlossConcT m) () (Float, ()), Float)
-> GlossConcT m (Automaton (GlossConcT m) () (Float, ()), Float)
forall a. a -> GlossConcT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (GlossConcT m Float -> Automaton (GlossConcT m) () Float
forall (m :: * -> *) b a. Functor m => m b -> Automaton m a b
constM GlossConcT m Float
getTime Automaton (GlossConcT m) () Float
-> Automaton (GlossConcT m) () ()
-> Automaton (GlossConcT m) () (Float, ())
forall b c c'.
Automaton (GlossConcT m) b c
-> Automaton (GlossConcT m) b c'
-> Automaton (GlossConcT m) b (c, c')
forall (a :: * -> * -> *) b c c'.
Arrow a =>
a b c -> a b c' -> a b (c, c')
&&& (() -> ()) -> Automaton (GlossConcT m) () ()
forall b c. (b -> c) -> Automaton (GlossConcT m) b 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 :: GlossEnv -> MVar Float
timeVar :: MVar Float
timeVar} <- ReaderT GlossEnv m GlossEnv -> GlossConcT m GlossEnv
forall (m :: * -> *) a. ReaderT GlossEnv m a -> GlossConcT m a
GlossConcT ReaderT GlossEnv m GlossEnv
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask
        IO Float -> GlossConcT m Float
forall a. IO a -> GlossConcT m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Float -> GlossConcT m Float) -> IO Float -> GlossConcT m Float
forall a b. (a -> b) -> a -> b
$ MVar Float -> IO Float
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 ->
  m GlossEnv
launchGlossThread :: forall (m :: * -> *). MonadIO m => GlossSettings -> m GlossEnv
launchGlossThread GlossSettings {Int
Color
Display
display :: Display
backgroundColor :: Color
stepsPerSecond :: Int
display :: GlossSettings -> Display
backgroundColor :: GlossSettings -> Color
stepsPerSecond :: GlossSettings -> Int
..} = do
  GlossEnv
vars <- IO GlossEnv -> m GlossEnv
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO GlossEnv -> m GlossEnv) -> IO GlossEnv -> m GlossEnv
forall a b. (a -> b) -> a -> b
$ MVar Float
-> MVar Event -> IORef Picture -> IORef Float -> GlossEnv
GlossEnv (MVar Float
 -> MVar Event -> IORef Picture -> IORef Float -> GlossEnv)
-> IO (MVar Float)
-> IO (MVar Event -> IORef Picture -> IORef Float -> GlossEnv)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (MVar Float)
forall a. IO (MVar a)
newEmptyMVar IO (MVar Event -> IORef Picture -> IORef Float -> GlossEnv)
-> IO (MVar Event) -> IO (IORef Picture -> IORef Float -> GlossEnv)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IO (MVar Event)
forall a. IO (MVar a)
newEmptyMVar IO (IORef Picture -> IORef Float -> GlossEnv)
-> IO (IORef Picture) -> IO (IORef Float -> GlossEnv)
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Picture -> IO (IORef Picture)
forall a. a -> IO (IORef a)
newIORef Picture
Blank IO (IORef Float -> GlossEnv) -> IO (IORef Float) -> IO GlossEnv
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Float -> IO (IORef Float)
forall a. a -> IO (IORef a)
newIORef Float
0
  let
    getPic :: GlossEnv -> IO Picture
getPic GlossEnv {IORef Picture
picRef :: GlossEnv -> IORef Picture
picRef :: IORef Picture
picRef} = IORef Picture -> IO Picture
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 :: GlossEnv -> MVar Event
eventVar :: MVar Event
eventVar} = do
      IO Bool -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO Bool -> IO ()) -> IO Bool -> IO ()
forall a b. (a -> b) -> a -> b
$ MVar Event -> Event -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar Event
eventVar Event
event
      GlossEnv -> IO GlossEnv
forall a. a -> IO a
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 :: GlossEnv -> MVar Float
timeVar :: MVar Float
timeVar, IORef Float
timeRef :: GlossEnv -> IORef Float
timeRef :: IORef Float
timeRef} = do
      Float
time <- IORef Float -> IO Float
forall a. IORef a -> IO a
readIORef IORef Float
timeRef
      let !time' :: Float
time' = Float
time Float -> Float -> Float
forall a. Num a => a -> a -> a
+ Float
diffTime
      Bool
timeUpdate <- MVar Float -> Float -> IO Bool
forall a. MVar a -> a -> IO Bool
tryPutMVar MVar Float
timeVar Float
time'
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
timeUpdate (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ IORef Float -> Float -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Float
timeRef Float
time'
      GlossEnv -> IO GlossEnv
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return GlossEnv
vars
  m ThreadId -> m ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (m ThreadId -> m ()) -> m ThreadId -> m ()
forall a b. (a -> b) -> a -> b
$ IO ThreadId -> m ThreadId
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId) -> IO ThreadId -> m ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ Display
-> Color
-> Int
-> GlossEnv
-> (GlossEnv -> IO Picture)
-> (Event -> GlossEnv -> IO GlossEnv)
-> (Float -> GlossEnv -> IO GlossEnv)
-> IO ()
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
  GlossEnv -> m GlossEnv
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return GlossEnv
vars

{- | 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.
-}
launchInGlossThread ::
  (MonadIO m) =>
  GlossSettings ->
  GlossConcT m a ->
  m a
launchInGlossThread :: forall (m :: * -> *) a.
MonadIO m =>
GlossSettings -> GlossConcT m a -> m a
launchInGlossThread GlossSettings
settings GlossConcT m a
glossLoop = do
  GlossEnv
vars <- GlossSettings -> m GlossEnv
forall (m :: * -> *). MonadIO m => GlossSettings -> m GlossEnv
launchGlossThread GlossSettings
settings
  ReaderT GlossEnv m a -> GlossEnv -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (GlossConcT m a -> ReaderT GlossEnv m a
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 = GlossSettings -> GlossConcT m () -> m ()
forall (m :: * -> *) a.
MonadIO m =>
GlossSettings -> GlossConcT m a -> m a
launchInGlossThread GlossSettings
settings (GlossConcT m () -> m ())
-> (Rhine (GlossConcT m) cl () () -> GlossConcT m ())
-> Rhine (GlossConcT m) cl () ()
-> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Rhine (GlossConcT m) cl () () -> GlossConcT m ()
forall (m :: * -> *) cl void.
(Monad m, Clock m cl, GetClockProxy cl, Time cl ~ Time (In cl),
 Time cl ~ Time (Out cl)) =>
Rhine m cl () () -> m void
flow

{- | Apply this wrapper to your clock type @cl@ in order to escape the 'GlossConcT' transformer.
  The resulting clock will be in @m@, not 'GlossConcT m' anymore.
  Typically, @m@ will have the 'MonadIO' constraint.
-}
type RunGlossEnvClock m cl = HoistClock (GlossConcT m) m cl

{- | Apply to a gloss clock to remove a 'GlossConcT' layer.
  You will have to have initialized a 'GlossEnv', for example by calling 'launchGlossThread'.
-}
runGlossEnvClock ::
  GlossEnv ->
  cl ->
  RunGlossEnvClock m cl
runGlossEnvClock :: forall cl (m :: * -> *). GlossEnv -> cl -> RunGlossEnvClock m cl
runGlossEnvClock GlossEnv
env cl
unhoistedClock =
  HoistClock
    { monadMorphism :: forall a. GlossConcT m a -> m a
monadMorphism = (ReaderT GlossEnv m a -> GlossEnv -> m a)
-> GlossEnv -> ReaderT GlossEnv m a -> m a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT GlossEnv m a -> GlossEnv -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT GlossEnv
env (ReaderT GlossEnv m a -> m a)
-> (GlossConcT m a -> ReaderT GlossEnv m a)
-> GlossConcT m a
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GlossConcT m a -> ReaderT GlossEnv m a
forall (m :: * -> *) a. GlossConcT m a -> ReaderT GlossEnv m a
unGlossConcT
    , cl
unhoistedClock :: cl
unhoistedClock :: cl
..
    }