{-# 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 qualified Control.Category as Category
import Control.Concurrent
import Control.Concurrent.MVar
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
{ unGlossConcT :: ReaderT GlossEnv m a }
deriving (Functor, Applicative, Monad, MonadTrans, MonadIO)
withPicRef
:: MonadIO m
=> (IORef Picture -> IO a)
-> GlossConcT m a
withPicRef action = GlossConcT $ do
(_, _, _, picRef) <- ask
liftIO $ action picRef
paintIO :: MonadIO m => Picture -> GlossConcT m ()
paintIO pic = withPicRef $ \ref -> modifyIORef' ref (<> pic)
clearIO :: MonadIO m => GlossConcT m ()
clearIO = withPicRef $ \ref -> writeIORef ref Blank
paintAllIO :: MonadIO m => Picture -> GlossConcT m ()
paintAllIO pic = clearIO >> paintIO pic
data GlossEventClockIO = GlossEventClockIO
instance MonadIO m => Clock (GlossConcT m) GlossEventClockIO where
type Time GlossEventClockIO = Float
type Tag GlossEventClockIO = Event
initClock _ = return (constM getEvent, 0)
where
getEvent = do
(_, eventVar, timeRef, _) <- GlossConcT ask
liftIO $ do
event <- takeMVar eventVar
time <- readIORef timeRef
return (time, event)
instance GetClockProxy GlossEventClockIO
data GlossSimClockIO = GlossSimClockIO
instance MonadIO m => Clock (GlossConcT m) GlossSimClockIO where
type Time GlossSimClockIO = Float
type Tag GlossSimClockIO = ()
initClock _ = return (constM getTime >>> sumS >>> withSideEffect writeTime &&& arr (const ()), 0)
where
getTime = do
(timeVar, _, _, _) <- GlossConcT ask
liftIO $ takeMVar timeVar
writeTime time = do
(_, _, timeRef, _) <- GlossConcT ask
liftIO $ writeIORef timeRef time
instance GetClockProxy GlossSimClockIO
launchGlossThread
:: MonadIO m
=> GlossSettings
-> GlossConcT m a
-> m a
launchGlossThread GlossSettings { .. } glossLoop = do
vars <- liftIO $ ( , , , ) <$> newEmptyMVar <*> newEmptyMVar <*> newIORef 0 <*> newIORef Blank
let
getPic (_, _, _, picRef) = readIORef picRef
handleEvent event vars@(_, eventVar, _, _) = do
result <- tryPutMVar eventVar event
return vars
simStep diffTime vars@(timeVar, _, _, _) = do
result <- tryPutMVar timeVar diffTime
return vars
void $ liftIO $ forkIO $ playIO display backgroundColor stepsPerSecond vars getPic handleEvent simStep
runReaderT (unGlossConcT glossLoop) 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 settings = launchGlossThread settings . flow
glossConcurrently
:: ( Monad IO
, Clock (GlossConcT IO) cl1, Clock (GlossConcT IO) cl2
, Time cl1 ~ Time cl2
)
=> Schedule (GlossConcT IO) cl1 cl2
glossConcurrently = Schedule
$ \cl1 cl2 -> GlossConcT $ ReaderT
$ \vars -> first liftTransS
<$> initSchedule concurrently
(runGlossEnvClock vars cl1)
(runGlossEnvClock vars cl2)
type RunGlossEnvClock cl = HoistClock (GlossConcT IO) IO cl
runGlossEnvClock
:: GlossEnv
-> cl
-> RunGlossEnvClock cl
runGlossEnvClock env unhoistedClock = HoistClock
{ monadMorphism = flip runReaderT env . unGlossConcT
, ..
}