rhine-gloss (empty) → 0.3.0.0

raw patch · 7 files changed

+276/−0 lines, 7 filesdep +basedep +dunaidep +glosssetup-changed

Dependencies added: base, dunai, gloss, rhine, rhine-gloss

Files

ChangeLog.md +9/−0
LICENSE +30/−0
Main.hs +20/−0
Setup.hs +2/−0
rhine-gloss.cabal +34/−0
src/FRP/Rhine/Gloss.hs +92/−0
src/FRP/Rhine/Gloss/Internals.hs +89/−0

+ ChangeLog.md view

@@ -0,0 +1,9 @@+# Revision history for rhine-gloss++## 0.2.0.0  -- 2017-11-29++* First version. Version numbers follow rhine.++## 0.3.0.0  -- 2017-11-30++* Added simple example.

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2017, Manuel Bärenz++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Manuel Bärenz nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

+ Main.hs view

@@ -0,0 +1,20 @@+{- | Example application for the @gloss@ wrapper. -}+++-- rhine-gloss+import FRP.Rhine.Gloss+++-- | 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] ]++-- | Rotate the gear with a constant angular velocity.+mainSyncSF :: GlossSyncSF a+mainSyncSF = timeInfoOf sinceStart >>> arr (* 50) >>> arr gears++main :: IO ()+main = flowGloss (InWindow "sonnen" (400, 400) (10, 10)) (greyN 0.3) 30+     $ buildGlossRhine Just mainSyncSF

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ rhine-gloss.cabal view

@@ -0,0 +1,34 @@+-- Initial rhine-gloss.cabal generated by cabal init.  For further+-- documentation, see http://haskell.org/cabal/users-guide/++name:                rhine-gloss+version:             0.3.0.0+-- synopsis:+description:         Wrapper to run reactive programs written in Rhine+                     with Gloss as backend+license:             BSD3+license-file:        LICENSE+author:              Manuel Bärenz+maintainer:          programming@manuelbaerenz.de+-- copyright:+category:            FRP+build-type:          Simple+extra-source-files:  ChangeLog.md+cabal-version:       >=1.18++library+  exposed-modules:     FRP.Rhine.Gloss+  other-modules:       FRP.Rhine.Gloss.Internals+  build-depends:       base  >= 4.7    && < 5+                     , rhine == 0.3.*+                     , dunai == 0.3.*+                     , gloss == 1.11.*+  hs-source-dirs:      src+  default-language:    Haskell2010++executable rhine-gloss-gears+  main-is:             Main.hs+  ghc-options:         -threaded+  build-depends:       base        >= 4.7    && < 5+                     , rhine-gloss+  default-language:    Haskell2010

+ src/FRP/Rhine/Gloss.hs view

@@ -0,0 +1,92 @@+{- | Wrapper library to write Gloss applications in Rhine.+@gloss@ acts as the backend here.++A Rhine app with the Gloss backend must use the 'GlossClock',+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++-- gloss+import Graphics.Gloss.Interface.Pure.Game++import qualified Graphics.Gloss as X++-- rhine+import FRP.Rhine+import FRP.Rhine.Clock.Select+import FRP.Rhine.Reactimation.Tick+import FRP.Rhine.ResamplingBuffer.Collect+import FRP.Rhine.ResamplingBuffer.KeepLast++import qualified FRP.Rhine        as X+import qualified FRP.Rhine.SyncSF as X++-- rhine-gloss+import FRP.Rhine.Gloss.Internals++-- TODO Consider generalising to IO+++-- | The overall clock of a valid @rhine@ 'SF' 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 'SyncSF' that you have to implement to get a @gloss@ app.+type GlossSyncSF a = SyncSF Identity GlossSimulationClock [a] Picture++{- | For most applications, it is sufficient to implement+a single synchronous 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+  -> GlossSyncSF a      -- ^ The 'SyncSF' representing the game loop.+  -> GlossRhine a+buildGlossRhine select syncsfSim+  =   timeInfoOf tag @@  SelectClock { mainClock = GlossEventClock, .. }+  >-- collect -@- glossSchedule+  --> withProperSimClock syncsfSim @@ GlossSimulationClock_++-- | The main function that will start the @gloss@ backend and run the 'SF'.+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) sf 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

+ src/FRP/Rhine/Gloss/Internals.hs view

@@ -0,0 +1,89 @@+{- | 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+import FRP.Rhine.Clock.Select+++-- * Clocks++-- | The error message that gets thrown when you try to start a @gloss@ app with 'flow'.+errMsg :: String+errMsg =  "You cannot start gloss apps with FRP.Rhine.flow. "+       ++ "Use FRP.Rhine.Gloss.flowGloss instead."++-- | The clock that ticks whenever a @gloss@ event occurs.+data GlossEventClock = GlossEventClock++instance Clock m GlossEventClock where+  type TimeDomainOf GlossEventClock = ()+  type Tag          GlossEventClock = Event+  startClock _ = error errMsg++-- | The clock that ticks for every @gloss@ simulation step,+--   but only shows the time delta in the tag.+--   Usually, you don't need this clock, but rather 'GlossSimulationClock'.+data GlossSimulationClock_ = GlossSimulationClock_++instance Clock m GlossSimulationClock_ where+  type TimeDomainOf GlossSimulationClock_ = ()+  type Tag          GlossSimulationClock_ = Float+  startClock _ = 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 TimeDomainOf GlossSimulationClock = Float+  type Tag          GlossSimulationClock = ()+  startClock _ = error errMsg++-- | To use all features of the 'SyncSF' framework,+--   write your synchronous stream function on the 'GlossSimulationClock'+--   and then use this function to transform it.+withProperSimClock+  :: Monad m+  => SyncSF m GlossSimulationClock  a b+  -> SyncSF m GlossSimulationClock_ a b+withProperSimClock syncsf = readerS+  $ (intermingle *** Category.id) >>> runReaderS syncsf+  where+    intermingle :: Monad m => MSF m (TimeInfo GlossSimulationClock_) (TimeInfo GlossSimulationClock)+    intermingle = proc TimeInfo {tag} -> do+      let sinceTick = tag+      absolute <- sumS -< sinceTick+      let sinceStart = absolute+      returnA          -< TimeInfo { tag = (), .. }++-- | The clock that ticks for every @gloss@ graphics output.+data GlossGraphicsClock = GlossGraphicsClock++instance Clock m GlossGraphicsClock where+  type TimeDomainOf GlossGraphicsClock = ()+  type Tag          GlossGraphicsClock = ()+  startClock _ = error errMsg++-- | A schedule you can't actually use, for internal purposes.+glossSchedule :: Schedule Identity (SelectClock GlossEventClock a) GlossSimulationClock_+glossSchedule = error errMsg