diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,10 @@ # Revision history for rhine-gloss +## 1.0 + +* Removed schedules. See the [page about changes in version 1](/version1.md). +* Simplified `gloss` backends. Renamed `launchGlossThread` to `launchInGlossThread`. + ## 0.7.0 * Reworked `gloss` backends. diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -28,8 +28,8 @@ putStrLn "Please choose between the pure (1), the pure combined (2), and the IO backend (3):" n <- readLn case n of - 1 -> flowGloss defaultSettings pureClSF - 2 -> flowGlossCombined defaultSettings pureRhine + 1 -> flowGlossClSF defaultSettings pureClSF + 2 -> flowGloss defaultSettings pureRhine 3 -> flowGlossIO defaultSettings ioRhine _ -> error "Invalid input" @@ -39,7 +39,7 @@ {- | Run the gears simulation with the pure backend with two subsystems, one at the rate of events, one at the rate of simulation. -} -pureRhine = tagS @@ glossEventClock >-- collect -@- glossSchedule --> sim >-> arrMCl paintAll @@ glossSimulationClock +pureRhine = tagS @@ glossEventClock >-- collect --> sim >-> arrMCl paintAll @@ glossSimulationClock -- | Run the gears simulation with the 'IO' backend. -ioRhine = tagS @@ GlossEventClockIO >-- collect -@- glossConcurrently --> sim >-> arrMCl paintAllIO @@ GlossSimClockIO +ioRhine = tagS @@ GlossEventClockIO >-- collect --> sim >-> arrMCl paintAllIO @@ GlossSimClockIO diff --git a/rhine-gloss.cabal b/rhine-gloss.cabal --- a/rhine-gloss.cabal +++ b/rhine-gloss.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: rhine-gloss -version: 0.9 +version: 1.0 synopsis: Gloss backend for Rhine description: This package provides a simple wrapper for the `gloss` library, @@ -26,7 +26,7 @@ source-repository this type: git location: https://github.com/turion/rhine.git - tag: v0.9 + tag: v1.0 library @@ -38,10 +38,11 @@ FRP.Rhine.Gloss.Pure.Combined build-depends: base >= 4.14 && < 4.18 , transformers >= 0.5 - , rhine == 0.9 + , rhine == 1.0 , dunai ^>= 0.9 , gloss >= 1.12 , mmorph >= 1.1 + , monad-schedule >= 0.1 hs-source-dirs: src default-language: Haskell2010 default-extensions: diff --git a/src/FRP/Rhine/Gloss/IO.hs b/src/FRP/Rhine/Gloss/IO.hs --- a/src/FRP/Rhine/Gloss/IO.hs +++ b/src/FRP/Rhine/Gloss/IO.hs @@ -14,9 +14,11 @@ paintAllIO, GlossEventClockIO (..), GlossSimClockIO (..), + launchInGlossThread, launchGlossThread, flowGlossIO, - glossConcurrently, + runGlossEnvClock, + RunGlossEnvClock, ) where @@ -35,6 +37,9 @@ -- gloss import Graphics.Gloss.Interface.IO.Game +-- monad-schedule +import Control.Monad.Schedule.Class + -- rhine import FRP.Rhine @@ -55,6 +60,9 @@ {unGlossConcT :: ReaderT GlossEnv m a} deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MFunctor, MMonad) +instance (Monad m, MonadSchedule m) => MonadSchedule (GlossConcT m) where + schedule actions = GlossConcT $ fmap (second $ map GlossConcT) $ schedule $ unGlossConcT <$> actions + withPicRef :: MonadIO m => (IORef Picture -> IO a) -> @@ -121,9 +129,8 @@ launchGlossThread :: MonadIO m => GlossSettings -> - GlossConcT m a -> - m a -launchGlossThread GlossSettings {..} glossLoop = do + m GlossEnv +launchGlossThread GlossSettings {..} = do vars <- liftIO $ GlossEnv <$> newEmptyMVar <*> newEmptyMVar <*> newIORef Blank <*> pure 0 let getPic GlossEnv {picRef} = readIORef picRef @@ -136,6 +143,24 @@ void $ tryPutMVar timeVar time' return vars {time = time'} void $ liftIO $ forkIO $ playIO display backgroundColor stepsPerSecond vars getPic handleEvent simStep + return 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 settings glossLoop = do + vars <- launchGlossThread settings runReaderT (unGlossConcT glossLoop) vars {- | Run a 'Rhine' in the 'GlossConcT' monad by launching a separate thread for the @gloss@ backend, @@ -151,37 +176,23 @@ GlossSettings -> Rhine (GlossConcT m) cl () () -> m () -flowGlossIO settings = launchGlossThread settings . flow +flowGlossIO settings = launchInGlossThread settings . flow -{- | A schedule in the 'GlossConcT' transformer, - supplying the same backend connection to its scheduled clocks. +{- | 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. -} -glossConcurrently :: - ( 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 +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 cl + RunGlossEnvClock m cl runGlossEnvClock env unhoistedClock = HoistClock { monadMorphism = flip runReaderT env . unGlossConcT , .. } - --- FIXME And a schedule for gloss clocks and other clocks diff --git a/src/FRP/Rhine/Gloss/Pure.hs b/src/FRP/Rhine/Gloss/Pure.hs --- a/src/FRP/Rhine/Gloss/Pure.hs +++ b/src/FRP/Rhine/Gloss/Pure.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE Arrows #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -19,39 +18,47 @@ GlossClSF, currentEvent, flowGloss, - flowGlossWithWorldMSF, + flowGlossClSF, ) where -- base import qualified Control.Category as Category +import Data.Functor.Identity -- transformers import Control.Monad.Trans.Class import Control.Monad.Trans.Reader -import Control.Monad.Trans.Writer +import Control.Monad.Trans.Writer.Strict -- dunai +import Control.Monad.Trans.MSF (performOnFirstSample) import qualified Control.Monad.Trans.MSF.Reader as MSFReader +import qualified Control.Monad.Trans.MSF.Writer as MSFWriter import Data.MonadicStreamFunction.InternalCore +-- monad-schedule +import Control.Monad.Schedule.Class +import Control.Monad.Schedule.Yield + -- rhine import FRP.Rhine -import FRP.Rhine.Reactimation.ClockErasure -- rhine-gloss import FRP.Rhine.Gloss.Common -- * @gloss@ effects --- FIXME How about a Reader (MSF () (Either Float Event))? That might unify the two backends and make the pure one more flexible. - -- | A pure monad in which all effects caused by the @gloss@ backend take place. -newtype GlossM a = GlossM {unGlossM :: (ReaderT (Float, Maybe Event)) (Writer Picture) a} +newtype GlossM a = GlossM {unGlossM :: YieldT (ReaderT (Float, Maybe Event) (Writer Picture)) a} deriving (Functor, Applicative, Monad) +-- Would have liked to make this a derived instance, but for some reason deriving gets thrown off by the newtype +instance MonadSchedule GlossM where + schedule actions = fmap (fmap (fmap GlossM)) $ GlossM $ schedule $ fmap unGlossM actions + -- | Add a picture to the canvas. paint :: Picture -> GlossM () -paint = GlossM . lift . tell +paint = GlossM . lift . lift . tell -- FIXME This doesn't what you think it does @@ -76,7 +83,7 @@ instance Clock GlossM GlossClock where type Time GlossClock = Float type Tag GlossClock = Maybe Event - initClock _ = return (constM (GlossM ask) >>> (sumS *** Category.id), 0) + initClock _ = return (constM (GlossM $ yield >> lift ask) >>> (sumS *** Category.id), 0) instance GetClockProxy GlossClock @@ -99,29 +106,29 @@ -- * Reactimation -{- | The main function that will start the @gloss@ backend and run the 'SN' - (in the case of the combined clock). --} -flowGloss :: +-- | Specialisation of 'flowGloss' to a 'GlossClSF' +flowGlossClSF :: GlossSettings -> - -- | The @gloss@-compatible 'Rhine'. + -- | The @gloss@-compatible 'ClSF'. GlossClSF -> IO () -flowGloss settings clsf = flowGlossWithWorldMSF settings GlossClock $ proc (time, tag) -> do - arrM (const clear) -< () - pic <- eraseClockClSF getClockProxy 0 clsf -< (time, tag, ()) - arrM paint -< pic +flowGlossClSF settings clsf = flowGloss settings $ clsf >-> arrMCl paintAll @@ GlossClock --- FIXME Hide? +type WorldMSF = MSF Identity ((Float, Maybe Event), ()) (Picture, Maybe ()) --- | Helper function -flowGlossWithWorldMSF GlossSettings {..} clock msf = +-- | The main function that will start the @gloss@ backend and run the 'Rhine' +flowGloss :: + (Clock GlossM cl, GetClockProxy cl) => + GlossSettings -> + Rhine GlossM cl () () -> + IO () +flowGloss GlossSettings {..} rhine = play display backgroundColor stepsPerSecond (worldMSF, Blank) getPic handleEvent simStep where - worldMSF = MSFReader.runReaderS $ morphS unGlossM $ proc () -> do - (time, tag) <- fst $ fst $ runWriter $ flip runReaderT (0, Nothing) $ unGlossM $ initClock clock -< () - msf -< (time, tag) + worldMSF :: WorldMSF + worldMSF = MSFWriter.runWriterS $ MSFReader.runReaderS $ morphS (runYieldT . unGlossM) $ performOnFirstSample $ eraseClock rhine + stepWith :: (Float, Maybe Event) -> (WorldMSF, Picture) -> (WorldMSF, Picture) + stepWith (diff, eventMaybe) (msf, _) = let ((picture, _), msf') = runIdentity $ unMSF msf ((diff, eventMaybe), ()) in (msf', picture) getPic (_, pic) = pic - stepWith (diff, maybeEvent) (msf, _) = first snd $ runWriter $ unMSF msf ((diff, maybeEvent), ()) handleEvent event = stepWith (0, Just event) simStep diff = stepWith (diff, Nothing) diff --git a/src/FRP/Rhine/Gloss/Pure/Combined.hs b/src/FRP/Rhine/Gloss/Pure/Combined.hs --- a/src/FRP/Rhine/Gloss/Pure/Combined.hs +++ b/src/FRP/Rhine/Gloss/Pure/Combined.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE Arrows #-} {-# LANGUAGE RecordWildCards #-} {- | A pure @gloss@ backend for Rhine, @@ -12,7 +11,6 @@ -- rhine import FRP.Rhine -import FRP.Rhine.Reactimation.ClockErasure -- rhine-gloss import FRP.Rhine.Gloss.Common @@ -24,14 +22,9 @@ -} type GlossCombinedClock a = SequentialClock - GlossM (GlossEventClock a) GlossSimulationClock --- | Schedule the subclocks of the 'GlossCombinedClock'. -glossSchedule :: Schedule GlossM (GlossEventClock a) GlossSimulationClock -glossSchedule = schedSelectClocks - -- ** Events -- | The clock that ticks whenever a specific @gloss@ event occurs. @@ -92,7 +85,7 @@ myGlossRhine :: GlossRhine a myGlossRhine - = myEventSubsystem @@ myEventClock >-- collect -@- glossSchedule --> mySim @@ glossSimulationClock + = myEventSubsystem @@ myEventClock >-- collect --> mySim @@ glossSimulationClock @ -} type GlossRhine a = Rhine GlossM (GlossCombinedClock a) () () @@ -110,19 +103,5 @@ GlossRhine a buildGlossRhine selector clsfSim = timeInfoOf tag @@ glossEventSelectClock selector - >-- collect -@- glossSchedule + >-- collect --> clsfSim @@ glossSimulationClock - --- * Reactimation - --- | The main function that will start the @gloss@ backend and run the 'SN'. -flowGlossCombined :: - GlossSettings -> - -- | The @gloss@-compatible 'Rhine'. - GlossRhine a -> - IO () -flowGlossCombined settings Rhine {..} = flowGlossWithWorldMSF settings clock $ proc tick -> do - eraseClockSN 0 sn - -< case tick of - (_, Left event) -> (0, Left event, Just ()) - (diffTime, Right ()) -> (diffTime, Right (), Nothing)