csound-expression-typed-0.2.0.1: src/Csound/Typed/GlobalState/Elements.hs
{-# Language DeriveFunctor #-}
module Csound.Typed.GlobalState.Elements(
-- * Identifiers
IdMap(..), saveId, newIdMapId,
-- ** Gens
GenMap, newGen, newGenId, nextGlobalGenCounter, newTabOfGens,
WriteGenMap, newWriteGen, newWriteTab,
-- Sf2
SfFluid(..), SfSpec(..), SfMap, newSf, sfVar, renderSf,
-- ** Band-limited waveforms
BandLimited(..), BandLimitedMap(..), BandLimitedId(..),
saveBandLimited, renderBandLimited,
readBandLimited, readHardSyncBandLimited,
-- ** String arguments
StringMap, newString,
-- * Midi
MidiType(..), Channel, MidiMap, MidiKey(..), saveMidiInstr,
-- * Global variables
Globals(..), newPersistentGlobalVar, newClearableGlobalVar,
newPersistentGloabalArrVar,
renderGlobals,
-- * Instruments
Instrs(..), saveInstr, getInstrIds, -- newInstrId, saveInstrById, saveInstr, CacheName, makeCacheName, saveCachedInstr, getInstrIds,
-- * Named instruments
NamedInstrs(..), saveNamedInstr,
-- * Src
InstrBody, getIn, sendOut, sendChn, sendGlobal, chnPargId,
Event(..),
ChnRef(..), chnRefFromParg, chnRefAlloc, readChn, writeChn, chnUpdateUdo,
subinstr, subinstr_, event_i, event, safeOut, autoOff, changed,
-- * OSC listen ports
OscListenPorts, getOscPortVar,
-- * Macros inits
MacrosInits, MacrosInit(..), initMacros,
-- * Udo plugins
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
-- tables of identifiers
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)
-- gens
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)
-- writeable gens
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
-- strings
type StringMap = IdMap String
newString :: String -> State StringMap Prim
newString = fmap PrimInt . saveId
-- gen counter
nextGlobalGenCounter :: State Int Int
nextGlobalGenCounter = state $ \s -> (s, s + 1)
-- sf
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
-- band-limited waveforms (used with vco2init)
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 ()
{-
renderFirstVco n (head vcos)
mapM_ renderTailVco (tail vcos)
getUserGens as = phi =<< as
where phi (x, gId) = case x of
UserGen g -> [(g, gId)]
_ -> []
renderGen (g, n) = toDummy $ ftgen (int n) g
renderFirstVco n x = renderVco (int n) x
renderTailVco x = renderVco (readOnlyVar vcoVar) x
renderVco ftId (wave, waveId) = toVcoVar $ vco2init $ case wave of
UserGen _ -> [ int waveId, ftId, 1.05, -1, -1, int $ negate waveId ]
_ -> [ int waveId, ftId ]
vcoVar = dummyVar
toVcoVar = toDummy
dummyVar = Var LocalVar Ir "ft"
toDummy = writeVar dummyVar
-}
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))
----------------------------------------------------------
-- Midi
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
-- global variables
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
-----------------------------------------------------------------
-- instrs
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)
{-
saveCachedInstr :: InstrBody -> State Instrs InstrId
saveCachedInstr name body = state $ \s ->
case IM.lookup name $ instrsCache s of
Just n -> (n, s)
Nothing ->
let newId = instrsNewId s
s1 = s { instrsCache = IM.insert name (intInstrId newId) $ instrsCache s
, instrsNewId = succ newId
, instrsContent = (intInstrId newId, body) : instrsContent s }
in (intInstrId newId, s1)
newInstrId :: State Instrs InstrId
newInstrId = state $ \s ->
let newId = instrsNewId s
s1 = s { instrsNewId = succ newId }
in (intInstrId newId, s1)
saveInstrById :: InstrId -> InstrBody -> State Instrs ()
saveInstrById instrId body = state $ \s ->
let s1 = s { instrsContent = (instrId, body) : instrsContent s }
in ((), s1)
saveInstr :: InstrBody -> State Instrs InstrId
saveInstr body = do
newId <- newInstrId
saveInstrById newId body
return newId
-}
-----------------------------------------------------------------
-- named instrs
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)
-----------------------------------------------------------------
-- sound sources
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
-- scaleVolumeFactor :: E -> E
-- scaleVolumeFactor = (setRate Ir (C.midiVolumeFactor (pn 1)) * )
-- guis
--------------------------------------------------------
-- Osc listeners
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)
----------------------------------------------------------
-- macros arguments
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
--------------------------------------------------------
-- Udo plugins
newtype UdoPlugin = UdoPlugin { unUdoPlugin :: String }
addUdoPlugin :: UdoPlugin -> State [UdoPlugin] ()
addUdoPlugin a = modify (a :)
getUdoPluginNames :: [UdoPlugin] -> [String]
getUdoPluginNames xs = nub (fmap unUdoPlugin xs)
-- tabQueue
tabQueuePlugin = UdoPlugin "tabQueue"
tabQueue2Plugin = UdoPlugin "tabQueue2"
----------------------------------------------------------
-- Steven Yi wonderful UDOs
zdfPlugin = UdoPlugin "zdf" -- Zero delay filters
solinaChorusPlugin = UdoPlugin "solina_chorus" -- solina chorus
audaciouseqPlugin = UdoPlugin "audaciouseq" -- audacious 10 band EQ
adsr140Plugin = UdoPlugin "adsr140" -- adsr with retriggering
diodePlugin = UdoPlugin "diode" -- diode ladder filter
korg35Plugin = UdoPlugin "korg35" -- korg 35 filter
zeroDelayConvolutionPlugin = UdoPlugin "zero-delay-convolution" -- zero delay convolutio by Victor Lazzarini
pitchShifterDelayPlugin = UdoPlugin "PitchShifterDelay" -- pitch shifter delay
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"