{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeFamilies #-}
module FRP.Rhine.Gloss.IO (
GlossConcT,
paintIO,
clearIO,
paintAllIO,
GlossEventClockIO (..),
GlossSimClockIO (..),
launchInGlossThread,
launchGlossThread,
flowGlossIO,
runGlossEnvClock,
RunGlossEnvClock,
)
where
import Control.Concurrent
import Control.Monad (when)
import Data.Functor (void)
import Data.IORef
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Control.Monad.Morph
import Graphics.Gloss.Interface.IO.Game
import Control.Monad.Schedule.Class
import FRP.Rhine
import FRP.Rhine.Gloss.Common
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
}
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
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)
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
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
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
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
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
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
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
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
type RunGlossEnvClock m cl = HoistClock (GlossConcT m) m cl
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
..
}