module Csound.Typed.GlobalState.Elements(
IdMap(..), saveId, newIdMapId,
GenMap, newGen, newGenId, nextGlobalGenCounter, newTabOfGens,
WriteGenMap, newWriteGen, newWriteTab,
SfFluid(..), SfSpec(..), SfMap, newSf, sfVar, renderSf,
BandLimited(..), BandLimitedMap(..), BandLimitedId(..),
saveBandLimited, renderBandLimited,
readBandLimited, readHardSyncBandLimited,
StringMap, newString,
MidiType(..), Channel, MidiMap, MidiKey(..), saveMidiInstr,
Globals(..), newPersistentGlobalVar, newClearableGlobalVar,
newPersistentGloabalArrVar,
renderGlobals,
Instrs(..), saveInstr, getInstrIds,
NamedInstrs(..), saveNamedInstr,
InstrBody, getIn, sendOut, sendChn, sendGlobal, chnPargId,
Event(..),
ChnRef(..), chnRefFromParg, chnRefAlloc, readChn, writeChn, chnUpdateUdo,
subinstr, subinstr_, event_i, event, safeOut, autoOff, changed,
OscListenPorts, getOscPortVar,
MacrosInits, MacrosInit(..), initMacros,
UdoPlugin, addUdoPlugin, getUdoPluginNames,
tabQueuePlugin, tabQueue2Plugin,
zdfPlugin, solinaChorusPlugin, audaciouseqPlugin, adsr140Plugin,
diodePlugin, korg35Plugin, zeroDelayConvolutionPlugin,
pitchShifterDelayPlugin,
analogDelayPlugin, distortionPlugin, envelopeFolollowerPlugin, flangerPlugin, freqShifterPlugin,
loFiPlugin, panTremPlugin, monoTremPlugin, phaserPlugin, pitchShifterPlugin, reversePlugin,
ringModulatorPlugin, stChorusPlugin, stereoPingPongDelayPlugin,
delay1kPlugin,
) where
import Data.List
import Data.Hashable
import Control.Monad.Trans.State.Strict
import Control.Monad(zipWithM_)
import Data.Default
import qualified Data.Map as M
import qualified Data.IntMap as IM
import Csound.Dynamic.Types
import Csound.Dynamic.Build
import Csound.Dynamic.Build.Numeric()
import Csound.Typed.GlobalState.Opcodes
data IdMap a = IdMap
{ idMapContent :: M.Map a Int
, idMapNewId :: Int
} deriving (Eq, Ord)
instance Default (IdMap a) where
def = IdMap def 1
saveId :: Ord a => a -> State (IdMap a) Int
saveId a = state $ \s ->
case M.lookup a (idMapContent s) of
Nothing ->
let newId = idMapNewId s
s1 = s{ idMapContent = M.insert a newId (idMapContent s)
, idMapNewId = succ newId }
in (newId, s1)
Just n -> (n, s)
newIdMapId :: State (IdMap a) Int
newIdMapId = state $ \s ->
let newId = idMapNewId s
s1 = s { idMapNewId = succ newId }
in (newId, s1)
type GenMap = IdMap Gen
newGen :: Gen -> State GenMap Int
newGen = saveGenId
newTabOfGens :: [Gen] -> State GenMap Int
newTabOfGens = (saveGenId . intTab =<<) . mapM saveGenId
where intTab ns = Gen (length ns) (IntGenId (2)) (fmap fromIntegral ns) Nothing
saveGenId :: Ord a => a -> State (IdMap a) Int
saveGenId a = state $ \s ->
case M.lookup a (idMapContent s) of
Nothing ->
let newId = nextReadOnlyTableId $ idMapNewId s
s1 = s{ idMapContent = M.insert a newId (idMapContent s)
, idMapNewId = nextReadOnlyTableId newId }
in (newId, s1)
Just n -> (n, s)
newGenId :: State GenMap Int
newGenId = state $ \s ->
let newId = idMapNewId s
s1 = s { idMapNewId = nextReadOnlyTableId newId }
in (newId, s1)
type WriteGenMap = [(Int, Gen)]
newWriteGen :: Gen -> State WriteGenMap E
newWriteGen = fmap int . saveWriteGenId
newWriteTab :: Int -> State WriteGenMap E
newWriteTab = newWriteGen . fromSize
where fromSize n = Gen n (IntGenId 2) (replicate n 0) Nothing
saveWriteGenId :: Gen -> State WriteGenMap Int
saveWriteGenId a = state $ \s -> case s of
[] -> (initId, [(initId, a)])
(i,_):_ -> let newId = nextWriteTableId i
in (newId, (newId, a) : s)
where
initId = tableWriteStep
tableWriteStep :: Int
tableWriteStep = 10
nextReadOnlyTableId :: Int -> Int
nextReadOnlyTableId x
| y `mod` tableWriteStep == 0 = y + 1
| otherwise = y
where y = x + 1
nextWriteTableId :: Int -> Int
nextWriteTableId x = tableWriteStep + x
type StringMap = IdMap String
newString :: String -> State StringMap Prim
newString = fmap PrimInt . saveId
nextGlobalGenCounter :: State Int Int
nextGlobalGenCounter = state $ \s -> (s, s + 1)
data SfFluid = SfFluid
{ sfId :: Int
, sfVars :: [Var] }
data SfSpec = SfSpec
{ sfName :: String
, sfBank :: Int
, sfProgram :: Int
} deriving (Eq, Ord, Show)
type SfMap = IdMap SfSpec
newSf :: SfSpec -> State SfMap Int
newSf = saveId
sfVar :: Int -> E
sfVar n = readOnlyVar (VarVerbatim Ir $ sfEngineName n)
sfEngineName :: Int -> String
sfEngineName n = "gi_Sf_engine_" ++ show n
sfInstrName :: Int -> String
sfInstrName n = "i_Sf_instr_" ++ show n
renderSf :: Monad m => SfSpec -> Int -> DepT m ()
renderSf (SfSpec name bank prog) n = verbatim $
engineStr ++ "\n" ++
loadStr ++ "\n" ++
selectProgStr ++ "\n"
where
engineStr = engineName ++ " fluidEngine"
loadStr = insName ++ " fluidLoad \"" ++ name ++ "\", " ++ engineName ++ ", 1"
selectProgStr = "fluidProgramSelect " ++ engineName ++ ", 1, " ++ insName
++ ", " ++ show bank ++ ", " ++ show prog
engineName = sfEngineName n
insName = sfInstrName n
data BandLimited = Saw | Pulse | Square | Triangle | IntegratedSaw | UserGen Gen
deriving (Eq, Ord)
data BandLimitedId = SimpleBandLimitedWave Int | UserBandLimitedWave Int
deriving (Eq, Ord)
bandLimitedIdToExpr :: BandLimitedId -> E
bandLimitedIdToExpr x = case x of
SimpleBandLimitedWave simpleId -> int simpleId
UserBandLimitedWave userId -> noRate $ ReadVar $ bandLimitedVar userId
bandLimitedVar userId = Var GlobalVar Ir ("BandLim" ++ show userId)
data BandLimitedMap = BandLimitedMap
{ simpleBandLimitedMap :: M.Map BandLimited BandLimitedId
, vcoInitMap :: GenMap
} deriving (Eq, Ord)
instance Default BandLimitedMap where
def = BandLimitedMap def def
saveBandLimited :: BandLimited -> State BandLimitedMap BandLimitedId
saveBandLimited x = case x of
Saw -> simpleWave 1 0
IntegratedSaw -> simpleWave 2 1
Pulse -> simpleWave 4 2
Square -> simpleWave 8 3
Triangle -> simpleWave 16 4
UserGen gen -> userGen gen
where
simpleWave writeId readId = state $ \blMap ->
if (M.member x (simpleBandLimitedMap blMap))
then (SimpleBandLimitedWave readId, blMap)
else (SimpleBandLimitedWave readId, blMap { simpleBandLimitedMap = M.insert x (SimpleBandLimitedWave writeId) (simpleBandLimitedMap blMap) })
userGen gen = state $ \blMap ->
let genMap = vcoInitMap blMap
(newId, genMap1) = runState (saveId gen) genMap
blMap1 = blMap { vcoInitMap = genMap1 }
in (UserBandLimitedWave newId, blMap1)
renderBandLimited :: Monad m => GenMap -> BandLimitedMap -> DepT m ()
renderBandLimited genMap blMap =
if isEmptyBlMap blMap
then return ()
else render (idMapNewId genMap) (M.toList $ idMapContent $ vcoInitMap blMap) (M.toList $ simpleBandLimitedMap blMap)
where
isEmptyBlMap m = (M.null $ simpleBandLimitedMap m) && (M.null $ idMapContent $ vcoInitMap m)
render lastGenId gens vcos = do
writeVar freeVcoVar $ int (lastGenId + length gens + 100)
mapM_ (renderGen lastGenId) gens
mapM_ renderVco vcos
renderGen :: Monad m => Int -> (Gen, Int) -> DepT m ()
renderGen lastGenId (gen, genId) = do
renderFtgen lastGenId (gen, genId)
renderVcoGen genId
renderVcoVarAssignment genId
freeVcoVar = Var GlobalVar Ir "free_vco"
ftVar n = Var GlobalVar Ir $ "vco_table_" ++ show n
renderFtgen lastGenId (g, n) = writeVar (ftVar n) $ ftgen (int $ lastGenId + n) g
renderVcoGen ftId = do
ft <- readVar (ftVar ftId)
free <- readVar freeVcoVar
writeVar freeVcoVar $ vco2init [ft, free, 1.05, 1, 1, ft]
renderVcoVarAssignment n = writeVar (bandLimitedVar n) =<< (fmap negate $ readVar (ftVar n))
renderVco :: Monad m => (BandLimited, BandLimitedId) -> DepT m ()
renderVco (bandLimited, blId) = case blId of
SimpleBandLimitedWave waveId -> do
free <- readVar freeVcoVar
writeVar freeVcoVar $ vco2init [int waveId, free]
UserBandLimitedWave _ -> return ()
readBandLimited :: Maybe E -> BandLimitedId -> E -> E
readBandLimited mphase n cps = oscilikt 1 cps (vco2ft cps (bandLimitedIdToExpr n)) mphase
readHardSyncBandLimited :: Maybe BandLimitedId -> Maybe E -> BandLimitedId -> E -> E -> E
readHardSyncBandLimited msmoothShape mphase n slaveCps masterCps = smoothWave * readShape n phasorSlave slaveCps
where
(phasorMaster, syncMaster) = syncphasor masterCps 0 Nothing
(phasorSlave, syncSlave) = syncphasor slaveCps syncMaster mphase
smoothWave = case msmoothShape of
Nothing -> 1
Just shape -> readShape shape phasorMaster masterCps
readShape shapeId phasor freq = tableikt phasor (vco2ft freq (bandLimitedIdToExpr shapeId))
type Channel = Int
data MidiType = Massign | Pgmassign (Maybe Int)
deriving (Show, Eq, Ord)
data MidiKey = MidiKey MidiType Channel
deriving (Show, Eq, Ord)
type MidiMap m = M.Map MidiKey (DepT m ())
saveMidiInstr :: Monad m => MidiType -> Channel -> DepT m () -> MidiMap m -> MidiMap m
saveMidiInstr ty chn body = M.insertWith (flip (>>)) (MidiKey ty chn) body
data Globals = Globals
{ globalsNewId :: Int
, globalsVars :: [AllocVar] }
data AllocVar = AllocVar
{ allocVarType :: GlobalVarType
, allocVar :: Var
, allocVarInit :: E }
| AllocArrVar
{ allocArrVar :: Var
, allocArrVarSizes :: [E] }
data GlobalVarType = PersistentGlobalVar | ClearableGlobalVar
deriving (Eq)
instance Default Globals where
def = Globals def def
newGlobalVar :: GlobalVarType -> Rate -> E -> State Globals Var
newGlobalVar ty rate initVal = state $ \s ->
let newId = globalsNewId s
var = Var GlobalVar rate ('g' : show newId)
s1 = s { globalsNewId = succ newId
, globalsVars = AllocVar ty var initVal : globalsVars s }
in (var, s1)
newPersistentGlobalVar :: Rate -> E -> State Globals Var
newPersistentGlobalVar = newGlobalVar PersistentGlobalVar
newClearableGlobalVar :: Rate -> E -> State Globals Var
newClearableGlobalVar = newGlobalVar ClearableGlobalVar
newPersistentGloabalArrVar :: Rate -> [E] -> State Globals Var
newPersistentGloabalArrVar rate sizes = state $ \s ->
let newId = globalsNewId s
var = Var GlobalVar rate ('g' : show newId)
s1 = s { globalsNewId = succ newId
, globalsVars = AllocArrVar var sizes : globalsVars s }
in (var, s1)
renderGlobals :: Monad m => Globals -> (DepT m (), DepT m ())
renderGlobals a = (initAll, clear)
where
initAll = mapM_ initAlloc gs
clear = mapM_ clearAlloc clearable
clearable = filter isClearable gs
gs = globalsVars a
initAlloc x = case x of
AllocVar _ var init -> initVar var init
AllocArrVar var sizes -> initArr var sizes
clearAlloc x = case x of
AllocVar _ var init -> writeVar var init
AllocArrVar _ _ -> return ()
isClearable x = case x of
AllocVar ty _ _ -> ty == ClearableGlobalVar
_ -> False
data Instrs = Instrs
{ instrsCache :: IM.IntMap InstrId
, instrsNewId :: Int
, instrsContent :: [(InstrId, InstrBody)]
}
instance Default Instrs where
def = Instrs IM.empty 18 []
getInstrIds :: Instrs -> [InstrId]
getInstrIds = fmap fst . instrsContent
saveInstr :: InstrBody -> State Instrs InstrId
saveInstr body = state $ \s ->
let h = hash body
in case IM.lookup h $ instrsCache s of
Just n -> (n, s)
Nothing ->
let newId = instrsNewId s
s1 = s { instrsCache = IM.insert h (intInstrId newId) $ instrsCache s
, instrsNewId = succ newId
, instrsContent = (intInstrId newId, body) : instrsContent s }
in (intInstrId newId, s1)
newtype NamedInstrs = NamedInstrs { unNamedInstrs :: [(String, InstrBody)] }
instance Default NamedInstrs where
def = NamedInstrs []
saveNamedInstr :: String -> InstrBody -> State NamedInstrs ()
saveNamedInstr name body = state $ \(NamedInstrs xs) -> ((), NamedInstrs $ (name, body) : xs)
getIn :: Monad m => Int -> DepT m [E]
getIn arity
| arity == 0 = return []
| otherwise = ($ arity ) $ mdepT $ mopcs "inch" (replicate arity Ar, replicate arity Kr) (fmap int [1 .. arity])
sendOut :: Monad m => Int -> [E] -> DepT m ()
sendOut arity sigs
| arity == 0 = return ()
| otherwise = do
vars <- newLocalVars (replicate arity Ar) (return $ replicate arity 0)
zipWithM_ writeVar vars sigs
vals <- mapM readVar vars
depT_ $ opcsNoInlineArgs name [(Xr, replicate arity Ar)] vals
where
name
| arity == 1 = "out"
| arity == 2 = "outs"
| arity == 4 = "outq"
| arity == 6 = "outh"
| arity == 8 = "outo"
| arity == 16 = "outx"
| arity == 32 = "out32"
| otherwise = "outc"
sendGlobal :: Monad m => Int -> [E] -> State Globals ([E], DepT m ())
sendGlobal arityOuts sigs = do
vars <- mapM (uncurry newClearableGlobalVar) $ replicate arityOuts (Ar, 0)
return (fmap readOnlyVar vars, zipWithM_ (appendVarBy (+)) vars sigs)
sendChn :: Monad m => Int -> Int -> [E] -> DepT m ()
sendChn arityIns arityOuts sigs = writeChn (chnRefFromParg (chnPargId arityIns) arityOuts) sigs
chnPargId :: Int -> Int
chnPargId arityIns = 4 + arityIns
newtype OscListenPorts = OscListenPorts { unOscListenPorts :: IM.IntMap Var }
instance Default OscListenPorts where
def = OscListenPorts IM.empty
getOscPortVar :: Int -> State (OscListenPorts, Globals) Var
getOscPortVar port = state $ \st@(OscListenPorts m, globals) -> case IM.lookup port m of
Just a -> (a, st)
Nothing -> onNothing port m globals
where
onNothing port m globals = (var, (OscListenPorts m1, newGlobals))
where
(var, newGlobals) = runState (allocOscPortVar port) globals
m1 = IM.insert port var m
allocOscPortVar :: Int -> State Globals Var
allocOscPortVar oscPort = newGlobalVar PersistentGlobalVar Ir $ oscInit (fromIntegral oscPort)
type MacrosInits = M.Map String MacrosInit
data MacrosInit
= MacrosInitDouble { macrosInitName :: String, macrosInitValueDouble :: Double }
| MacrosInitString { macrosInitName :: String, macrosInitValueString :: String }
| MacrosInitInt { macrosInitName :: String, macrosInitValueInt :: Int }
deriving (Show, Eq, Ord)
initMacros :: MacrosInit -> State MacrosInits ()
initMacros macrosInit = modify $ \xs -> M.insert (macrosInitName macrosInit) macrosInit xs
newtype UdoPlugin = UdoPlugin { unUdoPlugin :: String }
addUdoPlugin :: UdoPlugin -> State [UdoPlugin] ()
addUdoPlugin a = modify (a :)
getUdoPluginNames :: [UdoPlugin] -> [String]
getUdoPluginNames xs = nub (fmap unUdoPlugin xs)
tabQueuePlugin = UdoPlugin "tabQueue"
tabQueue2Plugin = UdoPlugin "tabQueue2"
zdfPlugin = UdoPlugin "zdf"
solinaChorusPlugin = UdoPlugin "solina_chorus"
audaciouseqPlugin = UdoPlugin "audaciouseq"
adsr140Plugin = UdoPlugin "adsr140"
diodePlugin = UdoPlugin "diode"
korg35Plugin = UdoPlugin "korg35"
zeroDelayConvolutionPlugin = UdoPlugin "zero-delay-convolution"
pitchShifterDelayPlugin = UdoPlugin "PitchShifterDelay"
analogDelayPlugin = UdoPlugin "MultiFX/AnalogDelay"
distortionPlugin = UdoPlugin "MultiFX/Distortion"
envelopeFolollowerPlugin = UdoPlugin "MultiFX/EnvelopeFollower"
flangerPlugin = UdoPlugin "MultiFX/Flanger"
freqShifterPlugin = UdoPlugin "MultiFX/FreqShifter"
loFiPlugin = UdoPlugin "MultiFX/LoFi"
panTremPlugin = UdoPlugin "MultiFX/PanTrem"
monoTremPlugin = UdoPlugin "MultiFX/MonoTrem"
phaserPlugin = UdoPlugin "MultiFX/Phaser"
pitchShifterPlugin = UdoPlugin "MultiFX/PitchShifter"
reversePlugin = UdoPlugin "MultiFX/Reverse"
ringModulatorPlugin = UdoPlugin "MultiFX/RingModulator"
stChorusPlugin = UdoPlugin "MultiFX/StChorus"
stereoPingPongDelayPlugin = UdoPlugin "MultiFX/StereoPingPongDelay"
delay1kPlugin = UdoPlugin "Utility/Delay1k"