diff --git a/Estuary/RenderState.hs b/Estuary/RenderState.hs index f8676dee..092f8dc6 100644 --- a/Estuary/RenderState.hs +++ b/Estuary/RenderState.hs @@ -1,23 +1,45 @@ module Estuary.RenderState where import Data.Time.Clock -import Data.Map +import Data.IntMap.Strict import qualified Sound.Tidal.Context as Tidal import Estuary.Types.Definition +data RenderInfo = RenderInfo { + errors :: !(IntMap String), + avgRenderLoad :: !Int, + peakRenderLoad :: !Int, + avgParseLoad :: !Int, + peakParseLoad :: !Int, + avgPatternsLoad :: !Int, + peakPatternsLoad :: !Int + } deriving (Show) + +emptyRenderInfo :: RenderInfo +emptyRenderInfo = RenderInfo { + errors = empty, + avgRenderLoad = 0, + peakRenderLoad = 0, + avgParseLoad = 0, + peakParseLoad = 0, + avgPatternsLoad = 0, + peakPatternsLoad = 0 + } + data RenderState = RenderState { - logicalTime :: UTCTime, - cachedDefs :: DefinitionMap, - paramPatterns :: Map Int Tidal.ParamPattern, - errors :: Map Int String, - dirtEvents :: [(UTCTime,Tidal.ParamMap)], - renderStartTime :: UTCTime, - parseEndTime :: UTCTime, - patternsToEventsEndTime :: UTCTime, - renderEndTime :: UTCTime, - renderTimes :: [NominalDiffTime], - avgRenderTime :: NominalDiffTime + logicalTime :: !UTCTime, + cachedDefs :: !DefinitionMap, + paramPatterns :: !(IntMap Tidal.ParamPattern), + dirtEvents :: ![(UTCTime,Tidal.ParamMap)], + renderStartTime :: !UTCTime, + parseEndTime :: !UTCTime, + patternsEndTime :: !UTCTime, + renderEndTime :: !UTCTime, + renderTimes :: ![NominalDiffTime], + parseTimes :: ![NominalDiffTime], + patternsTimes :: ![NominalDiffTime], + info :: !RenderInfo } initialRenderState :: UTCTime -> RenderState @@ -25,12 +47,13 @@ initialRenderState t = RenderState { logicalTime = t, cachedDefs = empty, paramPatterns = empty, - errors = empty, dirtEvents = [], renderStartTime = t, parseEndTime = t, - patternsToEventsEndTime = t, + patternsEndTime = t, renderEndTime = t, renderTimes = [], - avgRenderTime = 0 + parseTimes = [], + patternsTimes = [], + info = emptyRenderInfo } diff --git a/Estuary/Renderer.hs b/Estuary/Renderer.hs index ec1bb86b..b54c2d68 100644 --- a/Estuary/Renderer.hs +++ b/Estuary/Renderer.hs @@ -3,12 +3,12 @@ module Estuary.Renderer where import Data.Time.Clock import qualified Sound.Tidal.Context as Tidal import Control.Monad.IO.Class (liftIO) -import Control.Monad.State +import Control.Monad.State.Strict import Control.Concurrent import Control.Concurrent.MVar import Control.Monad.Loops import Data.Functor (void) -import Data.Map +import Data.IntMap.Strict as IntMap import Data.Maybe import Estuary.Types.Context @@ -22,6 +22,9 @@ import Estuary.RenderState type Renderer = StateT RenderState IO () +renderPeriod :: NominalDiffTime +renderPeriod = 0.2 + flushEvents :: Context -> Renderer flushEvents c = do events <- gets dirtEvents @@ -53,10 +56,10 @@ render :: Context -> Renderer render c = do defsToPatterns c t1 <- liftIO $ getCurrentTime - modify $ (\x -> x { parseEndTime = t1 }) + modify' $ (\x -> x { parseEndTime = t1 }) patternsToDirtEvents c t2 <- liftIO $ getCurrentTime - modify $ (\x -> x { patternsToEventsEndTime = t2 }) + modify' $ (\x -> x { patternsEndTime = t2 }) flushEvents c defsToPatterns :: Context -> Renderer @@ -64,20 +67,22 @@ defsToPatterns c = do s <- get let prevDefs = cachedDefs s let prevPatterns = paramPatterns s - let prevErrors = errors s + let prevErrors = errors (info s) let newDefs = fmap definitionForRendering $ definitions c - -- + modify' $ \x -> x { cachedDefs = newDefs } + -- determine which definitions (for rendering purposes) have either changed or been deleted let additionsChanges = differenceWith (\x y -> if x == y then Nothing else Just x) newDefs prevDefs let deletions = difference prevDefs newDefs - -- - let (newErrors,newPatterns) = Data.Map.mapEither definitionToPattern additionsChanges - let newPatterns' = union (Data.Map.mapMaybe id newPatterns) prevPatterns + -- parse definitions into ParamPatterns or errors, add new ParamPatterns to previous patterns, delete patterns when defs deleted + let (newErrors,newPatterns) = IntMap.mapEither definitionToPattern additionsChanges + let newPatterns' = union (IntMap.mapMaybe id newPatterns) prevPatterns let newPatterns'' = difference newPatterns' deletions + modify' $ \x -> x { paramPatterns = newPatterns'' } + -- maintain map of errors by adding new errors, subtracting deleted defs and subtracting any for new successful ParamPatterns let newErrors' = union newErrors prevErrors let newErrors'' = difference newErrors' deletions let newErrors''' = difference newErrors'' newPatterns - -- liftIO $ if Data.Map.null newErrors''' then return () else putStrLn (show newErrors''') - put $ s { paramPatterns = newPatterns'', errors = newErrors''', cachedDefs = newDefs } + modify' $ \x -> x { info = (info s) { errors = newErrors''' } } patternsToDirtEvents :: Context -> Renderer patternsToDirtEvents c = do @@ -85,26 +90,26 @@ patternsToDirtEvents c = do let lt = logicalTime s let tempo' = tempo c let ps = paramPatterns s - let events = concat $ fmap (renderTidalPattern lt (0.1::NominalDiffTime) tempo') ps - put $ s { dirtEvents = events } + let events = concat $ fmap (renderTidalPattern lt renderPeriod tempo') ps + modify' $ \x -> x { dirtEvents = events } -runRender :: MVar Context -> MVar RenderState -> Renderer -runRender c s = do +runRender :: MVar Context -> MVar RenderInfo -> Renderer +runRender c ri = do t1 <- liftIO $ getCurrentTime - modify $ \x -> x { renderStartTime = t1 } + modify' $ \x -> x { renderStartTime = t1 } c' <- liftIO $ readMVar c render c' t2 <- liftIO $ getCurrentTime - modify $ \x -> x { renderEndTime = t2 } + modify' $ \x -> x { renderEndTime = t2 } calculateRenderTimes - s' <- get -- get the final state... - liftIO $ swapMVar s s' -- and copy it into MVar so widgets can reflect it as necessary + ri' <- gets info -- RenderInfo from the state maintained by this iteration... + liftIO $ swapMVar ri ri' -- ...is copied to an MVar so it can be read elsewhere. sleepUntilNextRender sleepUntilNextRender :: Renderer sleepUntilNextRender = do s <- get - let next = addUTCTime (0.1::NominalDiffTime) (logicalTime s) + let next = addUTCTime renderPeriod (logicalTime s) let diff = diffUTCTime next (renderEndTime s) let delay = floor $ realToFrac diff * 1000000 - 10000 -- ie. wakeup ~ 10 milliseconds before next logical time liftIO $ threadDelay delay @@ -113,12 +118,38 @@ sleepUntilNextRender = do calculateRenderTimes :: Renderer calculateRenderTimes = do s <- get + -- let renderTime = diffUTCTime (renderEndTime s) (renderStartTime s) - let newRenderTimes = take 50 $ renderTime:(renderTimes s) + let newRenderTimes = take 20 $ renderTime:(renderTimes s) let newAvgRenderTime = sum newRenderTimes / (fromIntegral $ length newRenderTimes) - put $ s { renderTimes = newRenderTimes, avgRenderTime = newAvgRenderTime } + let newPeakRenderTime = maximum newRenderTimes + let newAvgRenderLoad = ceiling (newAvgRenderTime * 100 / renderPeriod) + let newPeakRenderLoad = ceiling (newPeakRenderTime * 100 / renderPeriod) + modify' $ \x -> x { renderTimes = newRenderTimes } + modify' $ \x -> x { info = (info x) { avgRenderLoad = newAvgRenderLoad }} + modify' $ \x -> x { info = (info x) { peakRenderLoad = newPeakRenderLoad }} + -- + let parseTime = diffUTCTime (parseEndTime s) (renderStartTime s) + let newParseTimes = take 20 $ parseTime:(parseTimes s) + let newAvgParseTime = sum newParseTimes / (fromIntegral $ length newParseTimes) + let newPeakParseTime = maximum newParseTimes + let newAvgParseLoad = ceiling (newAvgParseTime * 100 / renderPeriod) + let newPeakParseLoad = ceiling (newPeakParseTime * 100 / renderPeriod) + modify' $ \x -> x { parseTimes = newParseTimes } + modify' $ \x -> x { info = (info x) { avgParseLoad = newAvgParseLoad }} + modify' $ \x -> x { info = (info x) { peakParseLoad = newPeakParseLoad }} + -- + let patternsTime = diffUTCTime (patternsEndTime s) (parseEndTime s) + let newPatternsTimes = take 20 $ patternsTime:(patternsTimes s) + let newAvgPatternsTime = sum newPatternsTimes / (fromIntegral $ length newPatternsTimes) + let newPeakPatternsTime = maximum newPatternsTimes + let newAvgPatternsLoad = ceiling (newAvgPatternsTime * 100 / renderPeriod) + let newPeakPatternsLoad = ceiling (newPeakPatternsTime * 100 / renderPeriod) + modify' $ \x -> x { patternsTimes = newPatternsTimes } + modify' $ \x -> x { info = (info x) { avgPatternsLoad = newAvgPatternsLoad }} + modify' $ \x -> x { info = (info x) { peakPatternsLoad = newPeakPatternsLoad }} -forkRenderThread :: MVar Context -> MVar RenderState -> IO () -forkRenderThread c s = do +forkRenderThread :: MVar Context -> MVar RenderInfo -> IO () +forkRenderThread c ri = do renderStart <- getCurrentTime - void $ forkIO $ iterateM_ (execStateT $ runRender c s) (initialRenderState renderStart) + void $ forkIO $ iterateM_ (execStateT $ runRender c ri) (initialRenderState renderStart) diff --git a/Estuary/Types/Context.hs b/Estuary/Types/Context.hs index 2876294d..074cada5 100644 --- a/Estuary/Types/Context.hs +++ b/Estuary/Types/Context.hs @@ -1,7 +1,7 @@ module Estuary.Types.Context where import Data.Time -import Data.Map +import Data.IntMap.Strict import qualified Sound.Tidal.Context as Tidal import Estuary.Tidal.Types @@ -24,8 +24,7 @@ data Context = Context { peakLevels :: [Double], rmsLevels :: [Double], wsStatus :: String, - clientCount :: Int, - renderState :: RenderState + clientCount :: Int } initialContext :: UTCTime -> WebDirt -> SuperDirt -> Context @@ -42,8 +41,7 @@ initialContext now wd sd = Context { peakLevels = [], rmsLevels = [], wsStatus = "", - clientCount = 0, - renderState = initialRenderState now + clientCount = 0 } type ContextChange = Context -> Context @@ -65,9 +63,3 @@ setClientCount x c = c { clientCount = x } setDefinitions :: DefinitionMap -> ContextChange setDefinitions x c = c { definitions = x } - --- setRenderErrors :: RenderState -> ContextChange --- setRenderErrors x c = c { renderErrors = errors x } - -setRenderState :: RenderState -> ContextChange -setRenderState x c = c { renderState = x } diff --git a/Estuary/Types/Definition.hs b/Estuary/Types/Definition.hs index 91e7fbba..1cdda4bc 100644 --- a/Estuary/Types/Definition.hs +++ b/Estuary/Types/Definition.hs @@ -5,7 +5,7 @@ module Estuary.Types.Definition where import Text.JSON import Text.JSON.Generic import Data.Maybe (mapMaybe) -import qualified Data.Map as Map +import qualified Data.IntMap.Strict as IntMap import Estuary.Tidal.Types import Estuary.Types.Live @@ -18,7 +18,7 @@ data Definition = LabelText String deriving (Eq,Show,Data,Typeable) -type DefinitionMap = Map.Map Int Definition +type DefinitionMap = IntMap.IntMap Definition instance JSON Definition where showJSON = toJSON diff --git a/Estuary/Types/EnsembleState.hs b/Estuary/Types/EnsembleState.hs index 7b5c2daf..6e63a8ea 100644 --- a/Estuary/Types/EnsembleState.hs +++ b/Estuary/Types/EnsembleState.hs @@ -1,6 +1,7 @@ module Estuary.Types.EnsembleState where import Data.Map +import qualified Data.IntMap.Strict as IntMap import qualified Sound.Tidal.Tempo as Tidal import Data.Time import Data.Time.Clock.POSIX @@ -16,7 +17,7 @@ import qualified Estuary.Types.Terminal as Terminal data EnsembleState = EnsembleState { ensembleName :: String, userHandle :: String, - zones :: Map Int Definition, + zones :: IntMap.IntMap Definition, publishedViews :: Map String View, defaultView :: View, customView :: View, @@ -28,7 +29,7 @@ newEnsembleState :: String -> UTCTime -> EnsembleState newEnsembleState x now = EnsembleState { ensembleName = x, userHandle = "", - zones = empty, + zones = IntMap.empty, publishedViews = empty, defaultView = emptyView, customView = emptyView, @@ -55,12 +56,12 @@ commandsToStateChanges (Terminal.DeleteView x) es = es { publishedViews = delete commandsToStateChanges _ es = es requestsToStateChanges :: EnsembleRequest Definition -> EnsembleState -> EnsembleState -requestsToStateChanges (ZoneRequest (Sited n (Edit x))) es = es { zones = insert n x (zones es) } +requestsToStateChanges (ZoneRequest (Sited n (Edit x))) es = es { zones = IntMap.insert n x (zones es) } requestsToStateChanges _ es = es responsesToStateChanges :: EnsembleResponse Definition -> EnsembleState -> EnsembleState responsesToStateChanges (ZoneResponse (Sited n (Edit v))) es = es { zones = newZones } - where newZones = insert n v (zones es) + where newZones = IntMap.insert n v (zones es) responsesToStateChanges (View (Sited s v)) es = es { publishedViews = newViews } where newViews = insert s v (publishedViews es) responsesToStateChanges (DefaultView v) es = es { defaultView = v } diff --git a/Estuary/Types/Term.hs b/Estuary/Types/Term.hs index fe3f3785..27753b65 100644 --- a/Estuary/Types/Term.hs +++ b/Estuary/Types/Term.hs @@ -2,7 +2,7 @@ module Estuary.Types.Term where import Estuary.Types.Language -data Term = +data Term = EstuaryDescription | Tutorials | Solo | @@ -16,14 +16,16 @@ data Term = AdministratorPassword | EnsembleName | EnsemblePassword | - TerminalChat | - Theme + TerminalChat | + Theme | + Load | + Peak deriving (Show,Eq) - + translate :: Term -> Language -> String translate EstuaryDescription English = "estuary (a live coding symbiont)" -translate EstuaryDescription Español = "estuary (una simbionte live coding)" +translate EstuaryDescription Español = "estuary (una simbionte live coding)" translate Tutorials Español = "Tutoriales" translate Tutorials English = "Tutorials" @@ -70,5 +72,8 @@ translate Send Español = "enviar" translate Theme English = "Theme" translate Theme Español = "Tema" -translate x _ = "?" ++ show x +translate Load English = "load" +translate Peak English = "peak" + +translate x _ = "?" ++ show x diff --git a/Estuary/Widgets/Estuary.hs b/Estuary/Widgets/Estuary.hs index a0e16977..fbd09947 100644 --- a/Estuary/Widgets/Estuary.hs +++ b/Estuary/Widgets/Estuary.hs @@ -31,18 +31,18 @@ import Estuary.Types.Language import qualified Estuary.Types.Term as Term import Estuary.RenderState -estuaryWidget :: MonadWidget t m => MVar Context -> MVar RenderState -> EstuaryProtocolObject -> Context -> m () -estuaryWidget ctxM rsM protocol ic = divClass "estuary" $ mdo - -- mapDyn (avgRenderTime . renderState) ctx >>= display - headerChanges <- header ctx +estuaryWidget :: MonadWidget t m => MVar Context -> MVar RenderInfo -> EstuaryProtocolObject -> m () +estuaryWidget ctxM riM protocol = divClass "estuary" $ mdo + ic <- liftIO $ readMVar ctxM + renderInfo <- pollRenderInfoChanges riM + headerChanges <- header ctx renderInfo (values,deltasUp,hints) <- divClass "page" $ navigation (startTime ic) ctx commands deltasDown' commands <- divClass "chat" $ terminalWidget ctx deltasUp deltasDown' (deltasDown,wsStatus) <- alternateWebSocket protocol (startTime ic) deltasUp let definitionChanges = fmap setDefinitions $ updated values let deltasDown' = ffilter (not . Prelude.null) deltasDown let ccChange = fmap setClientCount $ fmapMaybe justServerClientCount deltasDown' - -- renderStateChanges <- pollRenderStateChanges rsM - let contextChanges = mergeWith (.) [definitionChanges,headerChanges,ccChange {- ,renderStateChanges -} ] + let contextChanges = mergeWith (.) [definitionChanges,headerChanges,ccChange] ctx <- foldDyn ($) ic contextChanges -- Dynamic t Context t <- mapDyn theme ctx -- Dynamic t String let t' = updated t -- Event t String @@ -53,14 +53,13 @@ estuaryWidget ctxM rsM protocol ic = divClass "estuary" $ mdo updateContext :: MonadWidget t m => MVar Context -> Dynamic t Context -> m () updateContext cMvar cDyn = performEvent_ $ fmap (liftIO . void . swapMVar cMvar) $ updated cDyn -pollRenderStateChanges :: MonadWidget t m => MVar RenderState -> m (Event t ContextChange) -pollRenderStateChanges rsMvar = do +pollRenderInfoChanges :: MonadWidget t m => MVar RenderInfo -> m (Dynamic t RenderInfo) +pollRenderInfoChanges riM = do now <- liftIO $ getCurrentTime - rsInitial <- liftIO $ readMVar rsMvar - ticks <- tickLossy (0.104::NominalDiffTime) now - -- newState <- performEvent $ fmap (liftIO . const (readMVar rsMvar)) ticks - newState <- performEventAsync $ ffor ticks $ \_ cb -> liftIO (readMVar rsMvar >>= cb) - return $ fmap setRenderState newState + riInitial <- liftIO $ readMVar riM + ticks <- tickLossy (0.204::NominalDiffTime) now + newInfo <- performEvent $ fmap (liftIO . const (readMVar riM)) ticks + holdDyn riInitial newInfo changeTheme :: MonadWidget t m => Event t String -> m () changeTheme newStyle = performEvent_ $ fmap (liftIO . js_setThemeHref . pToJSVal) newStyle @@ -69,14 +68,23 @@ foreign import javascript safe "document.getElementById('estuary-current-theme').setAttribute('href', $1);" js_setThemeHref :: JSVal -> IO () -header :: (MonadWidget t m) => Dynamic t Context -> m (Event t ContextChange) -header ctx = divClass "header" $ do +header :: (MonadWidget t m) => Dynamic t Context -> Dynamic t RenderInfo -> m (Event t ContextChange) +header ctx renderInfo = divClass "header" $ do tick <- getPostBuild hostName <- performEvent $ fmap (liftIO . (\_ -> getHostName)) tick port <- performEvent $ fmap (liftIO . (\_ -> getPort)) tick hostName' <- holdDyn "" hostName port' <- holdDyn "" port divClass "logo" $ dynText =<< translateDyn Term.EstuaryDescription ctx + do + dynText =<< translateDyn Term.Load ctx + text ": " + dynText =<< mapDyn (show . avgRenderLoad) renderInfo + text "% (" + dynText =<< mapDyn (show . peakRenderLoad) renderInfo + text "% " + dynText =<< translateDyn Term.Peak ctx + text ") " wsStatus' <- mapDyn wsStatus ctx clientCount' <- mapDyn clientCount ctx statusMsg <- combineDyn f wsStatus' clientCount' @@ -92,7 +100,6 @@ header ctx = divClass "header" $ do f "connection open" c = "(" ++ (show c) ++ " clients)" f x _ = x - clientConfigurationWidgets :: (MonadWidget t m) => Dynamic t Context -> m (Event t ContextChange) clientConfigurationWidgets ctx = divClass "webDirt" $ divClass "webDirtMute" $ do let styleMap = fromList [("classic.css", "Classic"),("inverse.css","Inverse")] diff --git a/Estuary/Widgets/Navigation.hs b/Estuary/Widgets/Navigation.hs index c0289818..1b5d8e59 100644 --- a/Estuary/Widgets/Navigation.hs +++ b/Estuary/Widgets/Navigation.hs @@ -10,7 +10,7 @@ import Estuary.Widgets.Generic import Estuary.Widgets.Text import Estuary.Widgets.TransformedPattern import Control.Monad (liftM) -import Data.Map +import Data.IntMap.Strict import Text.Read import Text.JSON import Data.Time.Clock diff --git a/Estuary/Widgets/View.hs b/Estuary/Widgets/View.hs index 4ab9ae15..ae954ddb 100644 --- a/Estuary/Widgets/View.hs +++ b/Estuary/Widgets/View.hs @@ -2,7 +2,7 @@ module Estuary.Widgets.View where -import qualified Data.Map as Map +import qualified Data.IntMap.Strict as Map import Control.Monad import Reflex import Reflex.Dom diff --git a/EstuaryClient.hs b/EstuaryClient.hs index 696085b2..6fac80fc 100644 --- a/EstuaryClient.hs +++ b/EstuaryClient.hs @@ -24,9 +24,9 @@ main = do protocol <- estuaryProtocol let ic = initialContext now wd sd c <- newMVar $ ic - s <- newMVar $ initialRenderState now - forkRenderThread c s - mainWidget $ estuaryWidget c s protocol ic + ri <- newMVar $ emptyRenderInfo + forkRenderThread c ri + mainWidget $ estuaryWidget c ri protocol foreign import javascript safe "window.addEventListener('beforeunload', function (e) { e.preventDefault(); e.returnValue = ''; });"