content: {-# LANGUAGE OverloadedStrings #-}
  
  module Estuary.Render.R where
  
  import Data.Time
  import Data.Text (Text)
  import qualified Data.Text as T
  import qualified Data.Text.IO as T
  import Control.Monad.Reader
  import Control.Monad.State.Strict
  import Control.Exception (evaluate,catch,SomeException,try)
  import Control.Concurrent.MVar
  import Data.IntMap.Strict as IntMap
  import Data.Map.Strict as Map
  -- import Data.List (nub)
  import Data.IORef
  import Sound.MusicW
  import TextShow
  import GHCJS.Types (JSVal)
  import Data.Witherable
  import qualified Sound.Tidal.Context as Tidal
  import qualified Sound.Punctual.Resolution as Punctual
  import qualified Sound.Punctual as Punctual
  import Sound.Punctual.GL
  
  import Estuary.Types.Definition
  import Estuary.Types.TextNotation
  import Estuary.Types.NoteEvent
  import Estuary.Types.RenderInfo
  import Estuary.Types.RenderState
  import Estuary.Languages.ExoLang
  import Estuary.Render.MainBus
  import Estuary.Render.WebDirt
  import Estuary.Render.SuperDirt
  import Estuary.Render.RenderOp
  import Estuary.Types.Tempo
  import Estuary.Resources
  import Estuary.Types.ResourceOp
  import Estuary.Client.Settings as Settings
  import Estuary.Types.Language
  import Estuary.Render.WebSerial as WebSerial
  import Estuary.Render.WebDirt as WebDirt
  import Estuary.Types.RenderInfo
  import Estuary.Render.RenderEnvironment as RenderEnvironment
  import Estuary.Render.Renderer
  
  putRenderOps :: MonadIO m => RenderEnvironment -> [RenderOp] -> m ()
  putRenderOps re x = liftIO $ do
    ops <- takeMVar $ renderOps re
    putMVar (renderOps re) $ ops ++ x
  
  takeRenderOps :: R [RenderOp]
  takeRenderOps = do
    mv <- asks renderOps
    ops <- liftIO $ takeMVar mv
    liftIO $ putMVar mv []
    -- when (length ops > 0) $ liftIO $ putStrLn $ show (length ops) ++ " ops"
    return ops
  
  
  setCC :: Int -> Double -> RenderEnvironment -> IO ()
  setCC n v rEnv = modifyIORef' (ccMap rEnv) $ Map.insert (showt n) v
  
  getCC :: Int -> RenderEnvironment -> IO (Maybe Double)
  getCC n irc = do
    m <- readIORef $ ccMap irc
    return $ Map.lookup (showt n) m
  
  updateTidalValueMap :: R ()
  updateTidalValueMap = do
    rEnv <- ask
    m <- liftIO $ readIORef $ ccMap rEnv
    RenderEnvironment.setValueMap rEnv $ fmap Tidal.toValue $ Map.mapKeys T.unpack m
  
  type R = ReaderT RenderEnvironment (StateT RenderState IO)
  
  runR :: R a -> RenderEnvironment -> RenderState -> IO RenderState
  runR r rEnv rState = do
    let r' = runReaderT r rEnv -- :: (StateT RenderState IO) a
    (execStateT r' rState)
    `catch` (\e -> putStrLn "runRenderer" >> putStrLn (show (e :: SomeException)) >> return rState)
  
  pushNoteEvents :: [NoteEvent] -> R ()
  pushNoteEvents xs = modify' $ \x -> x { noteEvents = noteEvents x ++ xs }
  
  setZoneError :: Int -> Text -> R ()
  setZoneError z t = do
    rEnv <- ask
    RenderEnvironment.setZoneError rEnv z t
  
  clearZoneError :: Int -> R ()
  clearZoneError z = do
    rEnv <- ask
    RenderEnvironment.clearZoneError rEnv z
    
  setBaseDefinition :: Int -> Definition -> R ()
  setBaseDefinition z x = do
    rEnv <- ask
    RenderEnvironment.setBaseDefinition rEnv z x
  
  clearBaseDefinition :: Int -> R ()
  clearBaseDefinition z = do
    rEnv <- ask
    RenderEnvironment.clearBaseDefinition rEnv z
  
  getBaseDefinition :: Int -> R (Maybe Definition)
  getBaseDefinition z = do 
    rEnv <- ask
    RenderEnvironment.getBaseDefinition rEnv z
  
  setBaseRenderer :: Int -> Text -> R ()
  setBaseRenderer z name = do
    rEnv <- ask
    RenderEnvironment.setBaseRenderer rEnv z name
  
  clearBaseRenderer :: Int -> R ()
  clearBaseRenderer z = do
    rEnv <- ask
    RenderEnvironment.clearBaseRenderer rEnv z
    
  updateActiveRenderers :: R ()
  updateActiveRenderers = ask >>= RenderEnvironment.updateActiveRenderers
  
  getActiveRenderers :: R (Map.Map Text Renderer)
  getActiveRenderers = ask >>= RenderEnvironment.getActiveRenderers
  
  getActiveRenderer :: Int -> R (Maybe Renderer)
  getActiveRenderer z = do
    rEnv <- ask
    RenderEnvironment.getActiveRenderer rEnv z
    
  getAllRendererNames :: R [TextNotation]
  getAllRendererNames = do
    rEnv <- ask
    RenderEnvironment.getAllRendererNames rEnv
  
  rendererExists :: TextNotation -> R Bool
  rendererExists x = ask >>= RenderEnvironment.getAllRendererNames >>= pure . elem x
  
  
  -- clearEvaluationTime :: Int -> R ()
  -- clearEvaluationTime z = modify' $ \x -> x { evaluationTimes = IntMap.delete z $ evaluationTimes x}
  
  clearParamPattern :: Int -> R ()
  clearParamPattern z = modify' $ \s -> s { paramPatterns = IntMap.delete z (paramPatterns s) }
  
  
  -- updating Settings (eg. in response to user action in widgets)
  
  updateSettings :: RenderEnvironment -> Settings -> IO ()
  updateSettings re = writeIORef (_settings re)
  
  
  -- asking/reading settings from within the R monad
  -- (note: not all Settings are given accessors here, just those that might
  -- be useful during computations with Estuary's render threads)
  
  askSettings :: (Settings -> a) -> R a
  askSettings f = asks _settings >>= liftIO . readIORef >>= return . f
  
  language :: R Language
  language = askSettings Settings.language
  
  canvasOn :: R Bool
  canvasOn = askSettings Settings.canvasOn
  
  resolution :: R Punctual.Resolution
  resolution = askSettings Settings.resolution
  
  brightness :: R Double
  brightness = askSettings Settings.brightness
  
  fpsLimit :: R (Maybe NominalDiffTime)
  fpsLimit = askSettings Settings.fpsLimit
  
  cineCer0ZIndex :: R Int
  cineCer0ZIndex = askSettings Settings.cineCer0ZIndex
  
  punctualZIndex :: R Int
  punctualZIndex = askSettings Settings.punctualZIndex
  
  improvizZIndex :: R Int
  improvizZIndex = askSettings Settings.improvizZIndex
  
  hydraZIndex :: R Int
  hydraZIndex = askSettings Settings.hydraZIndex
  
  webDirtOn :: R Bool
  webDirtOn = askSettings Settings.webDirtOn
  
  unsafeModeOn :: R Bool
  unsafeModeOn = askSettings Settings.unsafeModeOn
  
  superDirtOn :: R Bool
  superDirtOn = askSettings Settings.superDirtOn
  
  updateWebDirtVoices :: R ()
  updateWebDirtVoices = ask >>= RenderEnvironment.updateWebDirtVoices
  