rhine-gloss 0.8.1.1 → 0.9
raw patch · 8 files changed
+229/−198 lines, 8 filesdep ~dunaidep ~rhinesetup-changedPVP ok
version bump matches the API change (PVP)
Dependency ranges changed: dunai, rhine
API changes (from Hackage documentation)
Files
- Main.hs +14/−9
- Setup.hs +1/−0
- rhine-gloss.cabal +5/−5
- src/FRP/Rhine/Gloss.hs +4/−3
- src/FRP/Rhine/Gloss/Common.hs +18/−16
- src/FRP/Rhine/Gloss/IO.hs +98/−87
- src/FRP/Rhine/Gloss/Pure.hs +44/−40
- src/FRP/Rhine/Gloss/Pure/Combined.hs +45/−38
Main.hs view
@@ -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.
Setup.hs view
@@ -1,2 +1,3 @@ import Distribution.Simple+ main = defaultMain
rhine-gloss.cabal view
@@ -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
src/FRP/Rhine/Gloss.hs view
@@ -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
src/FRP/Rhine/Gloss/Common.hs view
@@ -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+ }
src/FRP/Rhine/Gloss/IO.hs view
@@ -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
src/FRP/Rhine/Gloss/Pure.hs view
@@ -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)
src/FRP/Rhine/Gloss/Pure/Combined.hs view
@@ -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)