diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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 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.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 diff --git a/src/FRP/Rhine/Gloss.hs b/src/FRP/Rhine/Gloss.hs --- a/src/FRP/Rhine/Gloss.hs +++ b/src/FRP/Rhine/Gloss.hs @@ -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 diff --git a/src/FRP/Rhine/Gloss/Common.hs b/src/FRP/Rhine/Gloss/Common.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/Gloss/Common.hs @@ -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 + } diff --git a/src/FRP/Rhine/Gloss/IO.hs b/src/FRP/Rhine/Gloss/IO.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/Gloss/IO.hs @@ -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 diff --git a/src/FRP/Rhine/Gloss/Internals.hs b/src/FRP/Rhine/Gloss/Internals.hs deleted file mode 100644 --- a/src/FRP/Rhine/Gloss/Internals.hs +++ /dev/null @@ -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 diff --git a/src/FRP/Rhine/Gloss/Pure.hs b/src/FRP/Rhine/Gloss/Pure.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/Gloss/Pure.hs @@ -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) diff --git a/src/FRP/Rhine/Gloss/Pure/Combined.hs b/src/FRP/Rhine/Gloss/Pure/Combined.hs new file mode 100644 --- /dev/null +++ b/src/FRP/Rhine/Gloss/Pure/Combined.hs @@ -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)