diff --git a/essence-of-live-coding-gloss.cabal b/essence-of-live-coding-gloss.cabal --- a/essence-of-live-coding-gloss.cabal +++ b/essence-of-live-coding-gloss.cabal @@ -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 diff --git a/src/LiveCoding/Gloss.hs b/src/LiveCoding/Gloss.hs --- a/src/LiveCoding/Gloss.hs +++ b/src/LiveCoding/Gloss.hs @@ -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 diff --git a/src/LiveCoding/Gloss/Debugger.hs b/src/LiveCoding/Gloss/Debugger.hs --- a/src/LiveCoding/Gloss/Debugger.hs +++ b/src/LiveCoding/Gloss/Debugger.hs @@ -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 diff --git a/src/LiveCoding/Gloss/GHCi.hs b/src/LiveCoding/Gloss/GHCi.hs deleted file mode 100644 --- a/src/LiveCoding/Gloss/GHCi.hs +++ /dev/null @@ -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 diff --git a/src/LiveCoding/Gloss/PictureM.hs b/src/LiveCoding/Gloss/PictureM.hs --- a/src/LiveCoding/Gloss/PictureM.hs +++ b/src/LiveCoding/Gloss/PictureM.hs @@ -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