diff --git a/Main.hs b/Main.hs --- a/Main.hs +++ b/Main.hs @@ -1,7 +1,8 @@ -{- | Example application for the @gloss@ wrapper. -} - {-# LANGUAGE TypeFamilies #-} +-- | Example application for the @gloss@ wrapper. +module Main where + -- base import Data.Maybe (maybeToList) @@ -10,12 +11,15 @@ -- | Calculate a gear wheel rotated by a certain angle. gears :: Float -> Picture -gears angle = color green $ pictures - $ circleSolid 60 - : map (rotate angle) [ rotate (45 * n) $ rectangleSolid 20 150 | n <- [0..3] ] +gears angle = + color green $ + pictures $ + circleSolid 60 + : [rotate (angle + 45 * n) $ rectangleSolid 20 150 | n <- [0 .. 3]] --- | Rotate the gear with a constant angular velocity. --- Disregards all events. +{- | Rotate the gear with a constant angular velocity. + Disregards all events. +-} sim :: Monad m => BehaviourF m Float [Event] Picture sim = timeInfoOf sinceInit >>> arr (* 50) >>> arr gears @@ -32,8 +36,9 @@ -- | 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. +{- | 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. diff --git a/Setup.hs b/Setup.hs --- a/Setup.hs +++ b/Setup.hs @@ -1,2 +1,3 @@ import Distribution.Simple + main = defaultMain 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.8.1.1 +version: 0.9 synopsis: Gloss backend for Rhine description: This package provides a simple wrapper for the `gloss` library, @@ -17,7 +17,7 @@ build-type: Simple extra-source-files: ChangeLog.md extra-doc-files: README.md -cabal-version: 1.18 +cabal-version: 2.0 source-repository head type: git @@ -26,7 +26,7 @@ source-repository this type: git location: https://github.com/turion/rhine.git - tag: v0.8.1.1 + tag: v0.9 library @@ -38,8 +38,8 @@ FRP.Rhine.Gloss.Pure.Combined build-depends: base >= 4.14 && < 4.18 , transformers >= 0.5 - , rhine == 0.8.1.1 - , dunai >= 0.8 + , rhine == 0.9 + , dunai ^>= 0.9 , gloss >= 1.12 , mmorph >= 1.1 hs-source-dirs: src 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 @@ -17,7 +17,8 @@ import FRP.Rhine as X -- rhine-gloss -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.Common as X +import FRP.Rhine.Gloss.IO 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 --- a/src/FRP/Rhine/Gloss/Common.hs +++ b/src/FRP/Rhine/Gloss/Common.hs @@ -1,27 +1,29 @@ -{- | Common definitions for all @gloss@ backends. --} - -module FRP.Rhine.Gloss.Common - ( module FRP.Rhine.Gloss.Common - , module X - ) where +-- | 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 +import qualified Graphics.Gloss.Interface.Pure.Game as X -- | 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. + { 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 - } +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 --- a/src/FRP/Rhine/Gloss/IO.hs +++ b/src/FRP/Rhine/Gloss/IO.hs @@ -1,24 +1,25 @@ -{- | Wrapper to write @gloss@ applications in Rhine, using concurrency. --} - +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module FRP.Rhine.Gloss.IO - ( GlossConcT - , paintIO - , clearIO - , paintAllIO - , GlossEventClockIO (..) - , GlossSimClockIO (..) - , launchGlossThread - , flowGlossIO - , glossConcurrently - ) - where +-- | Wrapper to write @gloss@ applications in Rhine, using concurrency. +module FRP.Rhine.Gloss.IO ( + GlossConcT, + paintIO, + clearIO, + paintAllIO, + GlossEventClockIO (..), + GlossSimClockIO (..), + launchGlossThread, + flowGlossIO, + glossConcurrently, +) +where + -- base import Control.Concurrent import Data.Functor (void) @@ -42,19 +43,24 @@ -- * Gloss effects -type GlossEnv = (MVar Float, MVar Event, IORef Float, IORef Picture) +data GlossEnv = GlossEnv + { timeVar :: MVar Float + , eventVar :: MVar Event + , picRef :: IORef Picture + , time :: Float + } -- | Wraps the concurrent variables needed for communication with the @gloss@ backend. newtype GlossConcT m a = GlossConcT - { unGlossConcT :: ReaderT GlossEnv m a } + {unGlossConcT :: ReaderT GlossEnv m a} deriving (Functor, Applicative, Monad, MonadTrans, MonadIO, MFunctor, MMonad) -withPicRef - :: MonadIO m - => (IORef Picture -> IO a) - -> GlossConcT m a +withPicRef :: + MonadIO m => + (IORef Picture -> IO a) -> + GlossConcT m a withPicRef action = GlossConcT $ do - (_, _, _, picRef) <- ask + GlossEnv {picRef} <- ask liftIO $ action picRef -- | Add a picture to the canvas. @@ -76,14 +82,13 @@ instance MonadIO m => Clock (GlossConcT m) GlossEventClockIO where type Time GlossEventClockIO = Float - type Tag GlossEventClockIO = Event + type Tag GlossEventClockIO = Event initClock _ = return (constM getEvent, 0) where getEvent = do - (_, eventVar, timeRef, _) <- GlossConcT ask + GlossEnv {eventVar, time} <- GlossConcT ask liftIO $ do event <- takeMVar eventVar - time <- readIORef timeRef return (time, event) instance GetClockProxy GlossEventClockIO @@ -93,84 +98,90 @@ 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) + type Tag GlossSimClockIO = () + initClock _ = return (constM getTime &&& arr (const ()), 0) where getTime = do - (timeVar, _, _, _) <- GlossConcT ask + GlossEnv {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 +{- | 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 $ GlossEnv <$> newEmptyMVar <*> newEmptyMVar <*> newIORef Blank <*> pure 0 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 - void $ tryPutMVar eventVar event - return vars - simStep diffTime vars@(timeVar, _, _, _) = do - void $ tryPutMVar timeVar diffTime - return vars + getPic GlossEnv {picRef} = readIORef picRef + -- Only try to put so this doesn't hang in case noone is listening for events or ticks + handleEvent event vars@GlossEnv {eventVar} = do + void $ tryPutMVar eventVar event + return vars + simStep diffTime vars@GlossEnv {timeVar, time} = do + let !time' = time + diffTime + void $ tryPutMVar timeVar time' + return vars {time = time'} 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 - :: ( MonadIO m - , Clock (GlossConcT m) cl - , GetClockProxy cl - , Time cl ~ Time (In cl) - , Time cl ~ Time (Out cl) - ) - => GlossSettings - -> Rhine (GlossConcT m) cl () () - -> m () +{- | Run a 'Rhine' in the 'GlossConcT' monad by launching a separate thread for the @gloss@ backend, + and reactimate in the foreground. +-} +flowGlossIO :: + ( MonadIO m + , Clock (GlossConcT m) cl + , GetClockProxy cl + , Time cl ~ Time (In cl) + , Time cl ~ Time (Out cl) + ) => + GlossSettings -> + Rhine (GlossConcT m) cl () () -> + m () flowGlossIO settings = launchGlossThread settings . flow --- | A schedule in the 'GlossConcT' transformer, --- supplying the same backend connection to its scheduled clocks. -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) +{- | A schedule in the 'GlossConcT' transformer, + supplying the same backend connection to its scheduled clocks. +-} +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 -runGlossEnvClock - :: GlossEnv - -> cl - -> RunGlossEnvClock cl -runGlossEnvClock env unhoistedClock = HoistClock - { monadMorphism = flip runReaderT env . unGlossConcT - , .. - } +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/Pure.hs b/src/FRP/Rhine/Gloss/Pure.hs --- a/src/FRP/Rhine/Gloss/Pure.hs +++ b/src/FRP/Rhine/Gloss/Pure.hs @@ -1,9 +1,3 @@ -{- | 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 #-} @@ -11,18 +5,23 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} -module FRP.Rhine.Gloss.Pure - ( GlossM - , paint - , clear - , paintAll - , GlossClock (..) - , GlossClSF - , currentEvent - , flowGloss - , flowGlossWithWorldMSF - ) where +{- | 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'. +-} +module FRP.Rhine.Gloss.Pure ( + GlossM, + paint, + clear, + paintAll, + GlossClock (..), + GlossClSF, + currentEvent, + flowGloss, + flowGlossWithWorldMSF, +) where + -- base import qualified Control.Category as Category @@ -47,7 +46,7 @@ -- 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 :: (ReaderT (Float, Maybe Event)) (Writer Picture) a} deriving (Functor, Applicative, Monad) -- | Add a picture to the canvas. @@ -55,6 +54,7 @@ paint = GlossM . lift . tell -- FIXME This doesn't what you think it does + -- | Clear the canvas. clear :: GlossM () clear = paint Blank @@ -65,8 +65,9 @@ -- * 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@). +{- | 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 @@ -74,7 +75,7 @@ instance Clock GlossM GlossClock where type Time GlossClock = Float - type Tag GlossClock = Maybe Event + type Tag GlossClock = Maybe Event initClock _ = return (constM (GlossM ask) >>> (sumS *** Category.id), 0) instance GetClockProxy GlossClock @@ -90,34 +91,37 @@ -} type GlossClSF = ClSF GlossM GlossClock () Picture --- | Observe whether there was an event this tick, --- and which one. +{- | 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 () +{- | The main function that will start the @gloss@ backend and run the 'SN' + (in the case of the combined clock). +-} +flowGloss :: + GlossSettings -> + -- | The @gloss@-compatible 'Rhine'. + 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 - -- 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) +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, _) = 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,3 +1,6 @@ +{-# LANGUAGE Arrows #-} +{-# LANGUAGE RecordWildCards #-} + {- | A pure @gloss@ backend for Rhine, with separated event and simulation loop. @@ -5,10 +8,6 @@ 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 -- rhine @@ -19,13 +18,15 @@ 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 +{- | 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 @@ -36,15 +37,17 @@ -- | 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) - } +{- | 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 @@ -56,11 +59,11 @@ type GlossSimulationClock = SelectClock GlossClock () glossSimulationClock :: GlossSimulationClock -glossSimulationClock = SelectClock { .. } +glossSimulationClock = SelectClock {..} where mainClock = GlossClock select (Just _event) = Nothing - select Nothing = Just () + select Nothing = Just () -- * Signal networks @@ -99,23 +102,27 @@ 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 +buildGlossRhine :: + -- | The event selector + (Event -> Maybe a) -> + -- | The 'ClSF' representing the game loop. + ClSF GlossM GlossSimulationClock [a] () -> + 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) +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)