{-# 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
import Control.Concurrent
import Data.Functor (void)
import Data.IORef
import Control.Monad.Trans.Class
import Control.Monad.Trans.Reader
import Graphics.Gloss.Interface.IO.Game
import FRP.Rhine
import FRP.Rhine.Gloss.Common
type GlossEnv = (MVar Float, MVar Event, IORef Float, IORef Picture)
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
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)
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
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
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
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
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
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
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
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
..
}