essence-of-live-coding-gloss 0.1.0.3 → 0.2.0.0

raw patch · 5 files changed

+114/−101 lines, 5 filesdep ~essence-of-live-codingdep ~foreign-storedep ~glossPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: essence-of-live-coding, foreign-store, gloss, syb, transformers

API changes (from Hackage documentation)

Files

• essence-of-live-coding-gloss.cabal +7/−7
• src/LiveCoding/Gloss.hs +82/−55
• src/LiveCoding/Gloss/Debugger.hs +2/−2
• src/LiveCoding/Gloss/GHCi.hs +0/−29
• src/LiveCoding/Gloss/PictureM.hs +23/−8

@@ -1,5 +1,5 @@ name:                essence-of-live-coding-gloss-version:             0.1.0.3+version:             0.2.0.0 synopsis: General purpose live coding framework - Gloss backend description:   essence-of-live-coding is a general purpose and type safe live coding framework.@@ -38,14 +38,14 @@   exposed-modules:     LiveCoding.Gloss     LiveCoding.Gloss.Debugger-    LiveCoding.Gloss.GHCi     LiveCoding.Gloss.PictureM   build-depends:       base >= 4.11 && < 5-    , syb-    , transformers-    , essence-of-live-coding-    , foreign-store-    , gloss+    , syb >= 0.7+    , transformers >= 0.5+    , essence-of-live-coding >= 0.2.0.0+    , foreign-store >= 0.2+    , gloss >= 1.13   hs-source-dirs:      src   default-language:    Haskell2010+  default-extensions: StrictData

@@ -1,3 +1,5 @@+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE Arrows #-}  module LiveCoding.Gloss@@ -7,10 +9,14 @@  -- base import Control.Concurrent+import Control.Monad (when) import Data.IORef+import System.Exit (exitSuccess)  -- transformers+import Control.Arrow (returnA) import Control.Monad.Trans.Writer+import Control.Monad.Trans.State.Strict (StateT)  -- gloss import Graphics.Gloss as X@@ -23,64 +29,85 @@ import LiveCoding.Gloss.Debugger as X import LiveCoding.Gloss.PictureM as X -type GlossCellWorldForeground = (GlossCell, [Event], Picture)+-- | In a 'Handle', store a separate thread where the gloss main loop is executed,+--   and several concurrent variables to communicate with it.+data GlossHandle = GlossHandle+  { glossThread :: ThreadId+  , glossVars   :: GlossVars+  } -playCellForeground :: GlossCell -> IO ()-playCellForeground cell = playIO (InWindow "Gears" (600, 800) (20, 20)) black stepRate (initialWorld cell) toPicture handleEvent playStep+-- | The concurrent variables needed to communicate with the gloss thread.+data GlossVars = GlossVars+  { glossEventsRef :: IORef [Event]+    -- ^ Stores all 'Event's that arrived since the last tick+  , glossPicRef    :: IORef Picture+    -- ^ Stores the next 'Picture' to be painted+  , glossDTimeVar  :: MVar Float+    -- ^ Stores the time passed since the last tick+  , glossExitRef   :: IORef Bool+    -- ^ Write 'True' here to stop the gloss thread+  } -type GlossCellWorld = (MVar GlossCell, [Event], Picture)+-- | Collect all settings that the @gloss@ backend requires.+--   Taken from @rhine-gloss@.+data GlossSettings = GlossSettings+  { displaySetting  :: Display      -- ^ Display mode (e.g. 'InWindow' or 'FullScreen').+  , backgroundColor :: Color        -- ^ Background color.+  , stepsPerSecond  :: Int          -- ^ Number of simulation steps per second of real time.+  } --- TODO Abstract external main loops-playCell :: GlossCell -> IO (MVar GlossCell)-playCell glossCell = do-  var <- newMVar glossCell-  forkIO $ playIO (InWindow "Gears" (600, 800) (20, 20)) black stepRate (initialWorld var) toPicture handleEvent playStepMVar-  return var+defaultSettings :: GlossSettings+defaultSettings = GlossSettings+  { displaySetting  = InWindow "Essence of live coding" (600, 800) (20, 20)+  , backgroundColor = black+  , stepsPerSecond  = 30+  } --- TODO Of course these are general for cells-updateGloss :: MVar GlossCell -> GlossCell -> IO ()-updateGloss var newGlossCell = do-  oldGlossCell <- takeMVar var-  putMVar var $ hotCodeSwapCell newGlossCell oldGlossCell+-- | Will create a handle for communication with the gloss thread,+--   and start gloss.+glossHandle :: GlossSettings -> Handle IO GlossHandle+glossHandle GlossSettings { .. } = Handle+  { create = do+      glossEventsRef <- newIORef []+      glossDTimeVar <- newEmptyMVar+      glossPicRef <- newIORef blank+      glossExitRef <- newIORef False+      let glossVars = GlossVars { .. }+      glossThread <- forkIO+        $ playIO displaySetting backgroundColor stepsPerSecond glossVars getPicture handleEvent stepGloss+      return GlossHandle { .. }+  , destroy = \GlossHandle { glossVars = GlossVars { .. }, .. } -> writeIORef glossExitRef True+  } -initialWorld cell = (cell, [], blank)-toPicture (_, _, picture) = do-  --putStrLn "toPicture"-  threadDelay 10000-  return picture-handleEvent event (cell, events, picture) = do-  --putStrLn "handleEvent"-  threadDelay 10000-  return (cell, event : events, picture)-playStep _ (cell, events, _) = do-  (picture, cell') <- fmap massageWriterOutput $ runWriterT $ step cell events-  threadDelay 10000-  --putStrLn "playStep"-  return (cell', [], picture)-playStepMVar _ (var, events, _) = do-  cell <- takeMVar var-  (picture, cell') <- fmap massageWriterOutput $ runWriterT $ step cell events-  putMVar var cell'-  threadDelay 10000-  --putStrLn "playStepMVar"-  return (var, [], picture)+getPicture :: GlossVars -> IO Picture+getPicture GlossVars { .. } = readIORef glossPicRef -glossWrap :: GlossCell -> IO (LiveProgram IO)-glossWrap cell = do-  pictureVar <- newMVar blank-  eventRef <- newIORef []-  stepVar <- newMVar 0-  let-    getPicture () = takeMVar pictureVar-    putEvent event () = modifyIORef eventRef $ (event :)-    putStep _ () = putMVar stepVar $ 1 / stepRate-  forkIO $ playIO (InWindow "Gears" (600, 800) (20, 20)) black stepRate () getPicture putEvent putStep-  let-    putPicture = putMVar pictureVar-    getEvents = atomicModifyIORef eventRef $ \events -> ([], events)-    getStep = takeMVar stepVar-  return $ liveCell $ proc _ -> do-    _       <- constM getStep            -< ()-    events  <- constM getEvents          -< ()-    picture <- runPictureM cell -< events-    arrM putPicture                            -< picture+handleEvent :: Event -> GlossVars -> IO GlossVars+handleEvent event vars@GlossVars { .. } = do+  modifyIORef glossEventsRef (event :)+  return vars++stepGloss :: Float -> GlossVars -> IO GlossVars+stepGloss dTime vars@GlossVars { .. } = do+  threadDelay $ round $ dTime * 1000+  putMVar glossDTimeVar dTime+  exitNow <- readIORef glossExitRef+  when exitNow exitSuccess+  return vars++-- | Given a cell in the gloss monad 'PictureM',+--   start the gloss backend and connect the cell to it.+--   This introduces 'Handle's, which need to be taken care of by calling 'runHandlingState'+--   or a similar function.+glossWrapC :: GlossSettings -> Cell PictureM a b -> Cell (StateT (HandlingState IO) IO) a b+glossWrapC glossSettings cell = proc a -> do+  GlossHandle { .. } <- handling $ glossHandle glossSettings -< ()+  liftCell pump -< (glossVars, a)+  where+    pump = proc (GlossVars { .. }, a) -> do+      _      <- arrM takeMVar                        -< glossDTimeVar+      events <- arrM $ flip atomicModifyIORef ([], ) -< glossEventsRef+      (picture, b) <- runPictureT cell               -< (events, a)+      arrM (uncurry writeIORef)                      -< (glossPicRef, picture)+      arrM threadDelay                               -< 10000 -- TODO Tweak for better performance+      returnA                                        -< b

@@ -8,7 +8,7 @@ -- transformers import Control.Monad.Trans.Writer import Control.Monad.Trans.Class-import Control.Monad.Trans.State+import Control.Monad.Trans.State.Strict  -- syb import Data.Generics.Text@@ -26,7 +26,7 @@ statePicture = translate (-100) 200 . scale 0.2 0.2 . color red . text . stateShow  statePlay :: Debugger PictureM-statePlay = Debugger $ liveCell $ every 2 >>> keep blank >>> arrM (lift . tell)+statePlay = Debugger $ liveCell $ every 2 >>> keep blank >>> arrM (lift . lift . tell)  every :: Data s => Integer -> Cell (StateT s PictureM) () (Maybe Picture) every maxN = proc () -> do

@@ -1,29 +0,0 @@-module LiveCoding.Gloss.GHCi where---- base-import Control.Concurrent---- foreign-store-import Foreign.Store---- essence-of-live-coding-import LiveCoding.LiveProgram---- essence-of-live-coding-gloss-import LiveCoding.Gloss--livegloss "" = livegloss "glossCell"-livegloss glossCell = return $ unlines-  [ "var <- playCell " ++ glossCell-  , "saveGloss var"-  ]-livereloadgloss "" = livereloadgloss "glossCell"-livereloadgloss glossCell  = return $ unlines-  [ ":reload"-  , "var <- loadGloss"-  , "updateGloss var " ++ glossCell-  ]-loadGloss :: IO (MVar GlossCell)-loadGloss = readStore (Store 0)-saveGloss :: MVar GlossCell -> IO ()-saveGloss var = writeStore (Store 0) var

@@ -1,6 +1,8 @@ module LiveCoding.Gloss.PictureM where  -- transformers+import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader import Control.Monad.Trans.Writer  -- gloss@@ -10,15 +12,28 @@ -- essence-of-live-coding import LiveCoding -type PictureM = WriterT Picture IO+{- | The monad transformer that captures the effects of gloss,+which are reading events and writing pictures. -runPictureM :: GlossCell -> Cell IO [Event] Picture-runPictureM = transformOutput $ fmap massageWriterOutput . runWriterT+You can call these effects for example by... -massageWriterOutput (((), s), pic) = (pic, s)+* ...using 'ask' to read the events that occurred,+* ...composing a cell with 'addPicture' to paint a picture.+-}+type PictureT m = ReaderT [Event] (WriterT Picture m) --- TODO Rhine integration instead of fixed sample size-type GlossCell = Cell PictureM [Event] ()+-- | 'PictureT' specialised to the 'IO' monad.+type PictureM = PictureT IO -addPicture :: Cell PictureM Picture ()-addPicture = arrM tell+-- | Run the effects of the gloss monad stack by explicitly passing events and pictures.+runPictureT+  :: Monad m+  => Cell (PictureT m) a b+  -> Cell m ([Event], a) (Picture, b)+runPictureT = hoistCellOutput (fmap massageWriterOutput . runWriterT) . runReaderC'+  where+    massageWriterOutput :: ((b, s), pic) -> ((pic, b), s)+    massageWriterOutput ((b, s), pic) = ((pic, b), s)++addPicture :: Monad m => Cell (PictureT m) Picture ()+addPicture = arrM $ lift . tell