performance improvements and addition of render-load monitoring with …

…display in client

Estuary/RenderState.hs

@@ -1,36 +1,59 @@
 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
 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
   }

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,58 +56,60 @@ 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
 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
   s <- get
   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)

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 }

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

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 }

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