rhine-gloss 0.6.0.1 → 0.7.0

raw patch · 9 files changed

+510/−184 lines, 9 filesdep +transformersdep ~rhinePVP ok

version bump matches the API change (PVP)

Dependencies added: transformers

Dependency ranges changed: rhine

API changes (from Hackage documentation)

Files

• Main.hs +25/−5
• README.md +4/−3
• rhine-gloss.cabal +11/−4
• src/FRP/Rhine/Gloss.hs +15/−81
• src/FRP/Rhine/Gloss/Common.hs +27/−0
• src/FRP/Rhine/Gloss/IO.hs +175/−0
• src/FRP/Rhine/Gloss/Internals.hs +0/−91
• src/FRP/Rhine/Gloss/Pure.hs +123/−0
• src/FRP/Rhine/Gloss/Pure/Combined.hs +130/−0

@@ -1,10 +1,14 @@ {- | Example application for the @gloss@ wrapper. -} +{-# LANGUAGE TypeFamilies #-} +-- base+import qualified Control.Category as Category+import Data.Maybe (maybeToList)+ -- rhine-gloss import FRP.Rhine.Gloss - -- | Calculate a gear wheel rotated by a certain angle. gears :: Float -> Picture gears angle = color green $ pictures@@ -12,9 +16,25 @@   : map (rotate angle) [ rotate (45 * n) $ rectangleSolid 20 150 | n <- [0..3] ]  -- | Rotate the gear with a constant angular velocity.-mainClSF :: GlossClSF a-mainClSF = timeInfoOf sinceInit >>> arr (* 50) >>> arr gears+--   Disregards all events.+sim :: Monad m => BehaviourF m Float [Event] Picture+sim = timeInfoOf sinceInit >>> arr (* 50) >>> arr gears  main :: IO ()-main = flowGloss (InWindow "rhine-gloss-gears" (400, 400) (10, 10)) (greyN 0.3) 30-     $ buildGlossRhine Just mainClSF+main = do+  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+    3 -> flowGlossIO defaultSettings ioRhine++-- | Run the gears simulation with the pure backend synchronously.+pureClSF = currentEvent >>> arr maybeToList >>> sim++-- | 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++-- | Run the gears simulation with the 'IO' backend.+ioRhine = tagS @@ GlossEventClockIO >-- collect -@- glossConcurrently --> sim >-> arrMCl paintAllIO @@ GlossSimClockIO

@@ -8,6 +8,8 @@ now becomes as simple as:  ```haskell+module README where+ import FRP.Rhine.Gloss  @@ -18,12 +20,11 @@   : map (rotate angle) [ rotate (45 * n) $ rectangleSolid 20 150 | n <- [0..3] ]  -- | Rotate the gear with a constant angular velocity.-mainClSF :: GlossClSF a+mainClSF :: GlossClSF mainClSF = timeInfoOf sinceInit >>> arr (* 50) >>> arr gears  main :: IO ()-main = flowGloss (InWindow "rhine-gloss-gears" (400, 400) (10, 10)) (greyN 0.3) 30-     $ buildGlossRhine Just mainClSF+main = flowGloss defaultSettings mainClSF ```  ## Installation

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                rhine-gloss-version:             0.6.0.1+version:             0.7.0 synopsis:            Gloss backend for Rhine description:   This package provides a simple wrapper for the `gloss` library,@@ -30,14 +30,20 @@   library-  exposed-modules:     FRP.Rhine.Gloss-  other-modules:       FRP.Rhine.Gloss.Internals+  exposed-modules:+    FRP.Rhine.Gloss+    FRP.Rhine.Gloss.Common+    FRP.Rhine.Gloss.IO+    FRP.Rhine.Gloss.Pure+    FRP.Rhine.Gloss.Pure.Combined   build-depends:       base         >= 4.9 && < 5-                     , rhine        == 0.6.*+                     , transformers >= 0.5+                     , rhine        == 0.7.0                      , dunai        >= 0.6                      , gloss        >= 1.12   hs-source-dirs:      src   default-language:    Haskell2010+  ghc-options:         -Wall  executable rhine-gloss-gears   main-is:             Main.hs@@ -45,3 +51,4 @@   build-depends:       base         >= 4.9 && < 5                      , rhine-gloss   default-language:    Haskell2010+  ghc-options:         -Wall -threaded -rtsopts -with-rtsopts=-N

@@ -1,89 +1,23 @@-{- | Wrapper library to write Gloss applications in Rhine.-@gloss@ acts as the backend here.+{- | Wrapper library to write @gloss@ Gloss applications in Rhine. -A Rhine app with the Gloss backend must use the 'GlossClock',+A pure Rhine app with @gloss@ backend must use the 'GlossClock' or 'GlossCombinedClock'+(from 'FRP.Rhine.Gloss.Pure.Single' and 'FRP.Rhine.Gloss.Pure.Combined', respectively), since the @gloss@ API only offers callbacks.-In order to run such a reactive program, you have to use 'flowGloss'.--}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}-module FRP.Rhine.Gloss-  ( module FRP.Rhine.Gloss-  , module X-  )-  where---- base-import Data.Functor.Identity (Identity, runIdentity)--import qualified Control.Arrow as X+In order to run such a reactive program, you have to use 'flowGloss' or 'flowGlossCombined'. --- gloss-import Graphics.Gloss.Interface.Pure.Game+A more flexible alternative, at the cost of introducing 'IO' concurrency,+is the 'FRP.Rhine.Gloss.IO' wrapper.+There, you can combine the @gloss@ clocks with arbitrary other 'IO' clocks.+-}+module FRP.Rhine.Gloss (module X) where -import qualified Graphics.Gloss as X+import Control.Arrow as X  -- rhine-import FRP.Rhine hiding (trivialResamplingBuffer)-import FRP.Rhine.Reactimation.Tick--import qualified FRP.Rhine      as X-import qualified FRP.Rhine.ClSF as X+import FRP.Rhine as X  -- rhine-gloss-import FRP.Rhine.Gloss.Internals---- TODO Consider generalising to IO----- | The overall clock of a valid @rhine@ 'SN' that can be run by @gloss@.---   @a@ is the type of subevents that are selected.-type GlossClock a-  = SequentialClock Identity-      (SelectClock GlossEventClock a)-      GlossSimulationClock_---- | The type of a valid 'Rhine' that can be run by @gloss@.---   @a@ is the type of subevents that are selected.-type GlossRhine a = Rhine Identity (GlossClock a) () Picture---- | The type of a 'ClSF' that you have to implement to get a @gloss@ app.-type GlossClSF a = ClSF Identity GlossSimulationClock [a] Picture--{- | For most applications, it is sufficient to implement-a single signal function-that is called with a list of all relevant events-that occurred in the last tick.--}-buildGlossRhine-  :: (Event -> Maybe a) -- ^ The event selector-  -> GlossClSF a        -- ^ The 'ClSF' representing the game loop.-  -> GlossRhine a-buildGlossRhine select clsfSim-  =   timeInfoOf tag @@  SelectClock { mainClock = GlossEventClock, .. }-  >-- collect -@- glossSchedule-  --> withProperSimClock clsfSim @@ GlossSimulationClock_---- | The main function that will start the @gloss@ backend and run the 'SN'.-flowGloss-  :: Display      -- ^ Display mode (e.g. 'InWindow' or 'FullScreen').-  -> Color        -- ^ Background color.-  -> Int          -- ^ Number of simulation steps per second of real time.-  -> GlossRhine a -- ^ The @gloss@-compatible 'Rhine'.-  -> IO ()-flowGloss display color n Rhine {..}-  = play display color n world getPic handleEvent simStep-  where-    graphicsBuffer-      :: ResamplingBuffer Identity-           GlossSimulationClock_ GlossGraphicsClock-           Picture               Picture-    graphicsBuffer = keepLast Blank-    world = createTickable (trivialResamplingBuffer clock) sn graphicsBuffer ()-    getPic Tickable { buffer2 } = fst $ runIdentity $ get buffer2 $ TimeInfo () () () ()-    handleEvent event tickable = case select (sequentialCl1 clock) event of-      Just a  -> runIdentity $ tick tickable () $ Left a -- Event is relevant-      Nothing -> tickable -- Event is irrelevant, state doesn't change-    simStep diff tickable = runIdentity $ tick tickable () $ Right diff+import FRP.Rhine.Gloss.IO            as X+import FRP.Rhine.Gloss.Common        as X+import FRP.Rhine.Gloss.Pure          as X+import FRP.Rhine.Gloss.Pure.Combined as X

@@ -0,0 +1,27 @@+{- | Common definitions for all @gloss@ backends.+-}++module FRP.Rhine.Gloss.Common+  ( module FRP.Rhine.Gloss.Common+  , module X+  ) where++-- gloss+import qualified Graphics.Gloss as X+import qualified Graphics.Gloss.Interface.Pure.Game as X+import Graphics.Gloss.Interface.Pure.Game++-- | Collect all settings that the @gloss@ backend requires.+data GlossSettings = GlossSettings+  { display         :: Display      -- ^ Display mode (e.g. 'InWindow' or 'FullScreen').+  , backgroundColor :: Color        -- ^ Background color.+  , stepsPerSecond  :: Int          -- ^ Number of simulation steps per second of real time.+  }++-- | Some standard settings, a 400 x 400 window with grey background, at 30 FPS.+defaultSettings :: GlossSettings+defaultSettings = GlossSettings+  { display         = InWindow "rhine-gloss" (400, 400) (10, 10)+  , backgroundColor = greyN 0.3+  , stepsPerSecond  = 30+  }

@@ -0,0 +1,175 @@+{- | Wrapper to write @gloss@ applications in Rhine, using concurrency.+-}++{-# 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++-- base+import qualified Control.Category as Category+import Control.Concurrent+import Control.Concurrent.MVar+import Data.Functor (void)+import Data.IORef++-- transformers+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader++-- gloss+import Graphics.Gloss.Interface.IO.Game++-- rhine+import FRP.Rhine++-- rhine-gloss+import FRP.Rhine.Gloss.Common++-- * Gloss effects++type GlossEnv = (MVar Float, MVar Event, IORef Float, IORef Picture)++-- | Wraps the concurrent variables needed for communication with the @gloss@ backend.+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++-- | Add a picture to the canvas.+paintIO :: MonadIO m => Picture -> GlossConcT m ()+paintIO pic = withPicRef $ \ref -> modifyIORef' ref (<> pic)++-- | Clear the canvas.+clearIO :: MonadIO m => GlossConcT m ()+clearIO = withPicRef $ \ref -> writeIORef ref Blank++-- | Clear the canvas and then paint.+paintAllIO :: MonadIO m => Picture -> GlossConcT m ()+paintAllIO pic = clearIO >> paintIO 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 _ = 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++-- | 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 _ = 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++-- * 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+  -> GlossConcT m a+  ->            m a+launchGlossThread GlossSettings { .. } glossLoop = do+  vars <- liftIO $ ( , , , ) <$> newEmptyMVar <*> newEmptyMVar <*> newIORef 0 <*> newIORef Blank+  let+      getPic               (_, _, _, picRef)   = readIORef picRef+      -- Only try to put so this doesn't hang in case noone is listening for events or ticks+      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++-- | Run a 'Rhine' in the 'GlossConcT' monad by launching a separate thread for the @gloss@ backend,+--   and reactimate in the foreground.+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++-- | A schedule in the 'GlossConcT' transformer,+--   supplying the same backend connection to its scheduled clocks.+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+  , ..+  }++-- FIXME And a schedule for gloss clocks and other clocks

@@ -1,91 +0,0 @@-{- | Internals for 'FRP.Rhine.Gloss'.-You probably won't need this module.--}-{-# LANGUAGE Arrows #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE TypeFamilies #-}--module FRP.Rhine.Gloss.Internals where---- base-import qualified Control.Category as Category-import Data.Functor.Identity (Identity)---- dunai-import Control.Monad.Trans.MSF.Reader (readerS, runReaderS)---- gloss-import Graphics.Gloss.Interface.Pure.Game---- rhine-import FRP.Rhine hiding (readerS, runReaderS)----- * Clocks---- | The error message that gets thrown when you try to start a pure @rhine-gloss@ app with 'flow'.-errMsg :: String-errMsg = unwords-  [ "You cannot start pure rhine-gloss apps with FRP.Rhine.flow,"-  , "since gloss has its own main loop."-  , "Use FRP.Rhine.Gloss.flowGloss instead."-  ]---- | The clock that ticks whenever a @gloss@ event occurs.-data GlossEventClock = GlossEventClock--instance Clock m GlossEventClock where-  type Time GlossEventClock = ()-  type Tag  GlossEventClock = Event-  initClock _ = error errMsg---- | The clock that ticks for every @gloss@ simulation step,---   but only shows the time /differences/ in the tag.---   Usually, you don't need this clock, but rather 'GlossSimulationClock'.-data GlossSimulationClock_ = GlossSimulationClock_--instance Clock m GlossSimulationClock_ where-  type Time GlossSimulationClock_ = ()-  type Tag  GlossSimulationClock_ = Float-  initClock _ = error errMsg---- | The clock that ticks for every @gloss@ simulation step.---   Use 'withProperSimClock' to transform to 'GlossSimulationClock_'.-data GlossSimulationClock = GlossSimulationClock--instance Clock m GlossSimulationClock where-  type Time GlossSimulationClock = Float-  type Tag  GlossSimulationClock = ()-  initClock _ = error errMsg---- | To use all features of the 'ClSF' framework,---   write your synchronous stream function on the 'GlossSimulationClock'---   and then use this function to transform it.-withProperSimClock-  :: Monad m-  => ClSF m GlossSimulationClock  a b-  -> ClSF m GlossSimulationClock_ a b-withProperSimClock clsf = readerS-  $ (intermingle *** Category.id) >>> runReaderS clsf-  where-    intermingle :: Monad m => MSF m (TimeInfo GlossSimulationClock_) (TimeInfo GlossSimulationClock)-    intermingle = proc TimeInfo {tag} -> do-      let sinceLast = tag-      absolute <- sumS -< sinceLast-      let sinceInit = absolute-      returnA          -< TimeInfo { tag = (), .. }---- | The clock that ticks for every @gloss@ graphics output.-data GlossGraphicsClock = GlossGraphicsClock--instance Clock m GlossGraphicsClock where-  type Time GlossGraphicsClock = ()-  type Tag  GlossGraphicsClock = ()-  initClock _ = error errMsg---- | A schedule you can't actually use, for internal purposes.-glossSchedule :: Schedule Identity (SelectClock GlossEventClock a) GlossSimulationClock_-glossSchedule = error errMsg

@@ -0,0 +1,123 @@+{- | A pure @gloss@ backend for Rhine.++To run pure Rhine apps with @gloss@,+write a clocked signal function ('ClSF') in the 'GlossClock' and use 'flowGloss'.+-}++{-# LANGUAGE Arrows #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeFamilies #-}++module FRP.Rhine.Gloss.Pure+  ( GlossM+  , paint+  , clear+  , paintAll+  , GlossClock (..)+  , GlossClSF+  , currentEvent+  , flowGloss+  , flowGlossWithWorldMSF+  ) where++-- base+import qualified Control.Category as Category++-- transformers+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer++-- dunai+import qualified Control.Monad.Trans.MSF.Reader as MSFReader+import Data.MonadicStreamFunction.InternalCore++-- 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 }+  deriving (Functor, Applicative, Monad)++-- | Add a picture to the canvas.+paint :: Picture -> GlossM ()+paint = GlossM . lift . tell++-- FIXME This doesn't what you think it does+-- | Clear the canvas.+clear :: GlossM ()+clear = paint Blank++-- | Clear the canvas and then paint.+paintAll :: Picture -> GlossM ()+paintAll pic = clear >> paint pic++-- * Clocks++-- | The overall clock of a pure @rhine@ 'ClSF' that can be run by @gloss@.+--   It ticks both on events (@tag = Just Event@) and simulation steps (@tag = Nothing@).+data GlossClock = GlossClock++instance Semigroup GlossClock where+  _ <> _ = GlossClock++instance Clock GlossM GlossClock where+  type Time GlossClock = Float+  type Tag  GlossClock = Maybe Event+  initClock _ = return (constM (GlossM ask) >>> (sumS *** Category.id), 0)++instance GetClockProxy GlossClock++-- * Signal functions++{- |+The type of a 'ClSF' you can implement to get a @gloss@ app,+if you chose to handle events and simulation steps in the same subsystem.++You can, but don't need to paint via 'GlossM':+You can also simply output the picture and it will be painted on top.+-}+type GlossClSF = ClSF GlossM GlossClock () Picture++-- | Observe whether there was an event this tick,+--   and which one.+currentEvent :: ClSF GlossM GlossClock () (Maybe Event)+currentEvent = tagS++-- * Reactimation++-- | The main function that will start the @gloss@ backend and run the 'SN'+--   (in the case of the combined clock).+flowGloss+  :: GlossSettings+  -> GlossClSF -- ^ The @gloss@-compatible 'Rhine'.+  -> IO ()+flowGloss settings clsf = flowGlossWithWorldMSF settings GlossClock $ proc (time, tag) -> do+  arrM (const clear) -< ()+  pic <- eraseClockClSF getClockProxy 0 clsf -< (time, tag, ())+  arrM paint -< pic+++-- FIXME Hide?+-- | Helper function+flowGlossWithWorldMSF GlossSettings { .. } clock msf+  = 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)+      getPic (_, pic) = pic+      stepWith (diff, maybeEvent) (msf, _) = snd *** id $ runWriter $ unMSF msf ((diff, maybeEvent), ())+      handleEvent event = stepWith (0, Just event)+      simStep diff = stepWith (diff, Nothing)

@@ -0,0 +1,130 @@+{- | A pure @gloss@ backend for Rhine,+with separated event and simulation loop.++To run pure Rhine apps with @gloss@,+write a signal network ('SN') in the 'GlossCombinedClock' and use 'flowGlossCombined'.+As an easy starter, you can use the helper function 'buildGlossRhine'.+-}++{-# LANGUAGE Arrows #-}+{-# LANGUAGE RecordWildCards #-}++module FRP.Rhine.Gloss.Pure.Combined where++-- transformers+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.Writer++-- dunai+import qualified Control.Monad.Trans.MSF.Reader as MSFReader+import Data.MonadicStreamFunction.InternalCore++-- rhine+import FRP.Rhine+import FRP.Rhine.Reactimation.ClockErasure++-- rhine-gloss+import FRP.Rhine.Gloss.Common+import FRP.Rhine.Gloss.Pure++-- | The overall clock of a pure @rhine@ 'SN' that can be run by @gloss@.+--   It is combined of two subsystems, the event part and the simulation part.+--   @a@ is the type of subevents that are selected.+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.+type GlossEventClock a = SelectClock GlossClock a++-- | Select the relevant events by converting them to @Just a@,+--   and the irrelevant ones to 'Nothing'.+glossEventSelectClock+  :: (Event -> Maybe a)+  -> GlossEventClock a+glossEventSelectClock selector = SelectClock+  { mainClock = GlossClock+  , select = (>>= selector)+  }++-- | Tick on every event.+glossEventClock :: GlossEventClock Event+glossEventClock = glossEventSelectClock Just++-- ** Simulation++-- | The clock that ticks for every @gloss@ simulation step.+type GlossSimulationClock = SelectClock GlossClock ()++glossSimulationClock :: GlossSimulationClock+glossSimulationClock = SelectClock { .. }+  where+    mainClock = GlossClock+    select (Just _event) = Nothing+    select Nothing        = Just ()++-- * Signal networks++{- |+The type of a valid 'Rhine' that can be run by @gloss@,+if you chose to separate events and simulation into two subsystems.+@a@ is the type of subevents that are selected.++All painting has to be done in 'GlossM', e.g. via the 'paint' method.++Typically, such a 'Rhine' is built something like this:++@+-- | Select only key press events+myEventClock :: GlossEventClock Key+myEventClock = glossEventSelectClock selector+  where+    selector (EventKey key _ _ _) = Just key+    selector _ = Nothing++myEventSubsystem :: ClSF GlossM GlossEventClock () MyType+myEventSubsystem = ...++mySim :: ClSF GlossM GlossSimulationClock [MyType] ()+mySim = ...++myGlossRhine :: GlossRhine a+myGlossRhine+  = myEventSubsystem @@ myEventClock >-- collect -@- glossSchedule --> mySim @@ glossSimulationClock+@+-}+type GlossRhine a = Rhine GlossM (GlossCombinedClock a) () ()++{- | For most applications, it is sufficient to implement+a single signal function+that is called with a list of all relevant events+that occurred in the last tick.+-}+buildGlossRhine+  :: (Event -> Maybe a) -- ^ The event selector+  -> ClSF GlossM GlossSimulationClock [a] () -- ^ The 'ClSF' representing the game loop.+  -> GlossRhine a+buildGlossRhine selector clsfSim+  =   timeInfoOf tag @@ glossEventSelectClock selector+  >-- collect       -@- glossSchedule+  --> clsfSim        @@ glossSimulationClock++-- * Reactimation++-- | The main function that will start the @gloss@ backend and run the 'SN'.+flowGlossCombined+  :: GlossSettings+  -> GlossRhine a -- ^ The @gloss@-compatible 'Rhine'.+  -> 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)