summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAntonKholomiov <>2016-03-26 13:37:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2016-03-26 13:37:00 (GMT)
commit3fecca8a51d5aac124b24a85a2803154b918204e (patch)
tree131a71695128f2fba6ebd7723fff9c8e83aeaeec
parent4a9997d6ac7aa91a4abef38d3e361b1c5fd08262 (diff)
version 0.0.9.20.0.9.2
-rw-r--r--csound-expression-typed.cabal12
-rw-r--r--data/opcodes/tabQueue.udo45
-rw-r--r--data/opcodes/tabQueue2.udo50
-rw-r--r--src/Csound/Typed/Control.hs3
-rw-r--r--src/Csound/Typed/Control/Api.hs178
-rw-r--r--src/Csound/Typed/Control/Evt.hs9
-rw-r--r--src/Csound/Typed/Control/Ref.hs91
-rw-r--r--src/Csound/Typed/GlobalState/Elements.hs97
-rw-r--r--src/Csound/Typed/GlobalState/GE.hs58
-rw-r--r--src/Csound/Typed/GlobalState/Instr.hs1
-rw-r--r--src/Csound/Typed/GlobalState/Opcodes.hs34
-rw-r--r--src/Csound/Typed/GlobalState/Options.hs35
-rw-r--r--src/Csound/Typed/GlobalState/SE.hs8
-rw-r--r--src/Csound/Typed/Plugins/TabQueue.hs48
-rw-r--r--src/Csound/Typed/Render.hs22
-rw-r--r--src/Csound/Typed/Types/MixSco.hs2
-rw-r--r--src/Csound/Typed/Types/Prim.hs74
-rw-r--r--src/Csound/Typed/Types/Tuple.hs3
18 files changed, 703 insertions, 67 deletions
diff --git a/csound-expression-typed.cabal b/csound-expression-typed.cabal
index f8f2244..496e93c 100644
--- a/csound-expression-typed.cabal
+++ b/csound-expression-typed.cabal
@@ -1,5 +1,5 @@
Name: csound-expression-typed
-Version: 0.0.9.1
+Version: 0.0.9.2
Cabal-Version: >= 1.22
License: BSD3
License-file: LICENSE
@@ -23,6 +23,9 @@ Data-Files :
data/hrtf-96000-left.dat
data/hrtf-96000-right.dat
+ data/opcodes/tabQueue.udo
+ data/opcodes/tabQueue2.udo
+
Homepage: https://github.com/anton-k/csound-expression-typed
Bug-Reports: https://github.com/anton-k/csound-expression-typed/issues
@@ -36,7 +39,7 @@ Library
Ghc-Options: -Wall
Build-Depends:
base >= 4, base < 5, ghc-prim, containers, transformers >= 0.3, Boolean >= 0.1.0, colour >= 2.0, data-default, deepseq,
- wl-pprint, csound-expression-dynamic >= 0.1.5, temporal-media >= 0.6.0, hashable
+ wl-pprint, csound-expression-dynamic >= 0.1.6, temporal-media >= 0.6.0, hashable
Hs-Source-Dirs: src/
Exposed-Modules:
Csound.Typed
@@ -69,6 +72,7 @@ Library
Csound.Typed.Control.Vco
Csound.Typed.Control.Mix
Csound.Typed.Control.Midi
+ Csound.Typed.Control.Api
Csound.Typed.Control.Sf2
Csound.Typed.Control.Osc
Csound.Typed.Control.Channel
@@ -85,6 +89,8 @@ Library
Csound.Typed.Lib.StableMaps.Dynamic
Csound.Typed.Lib.StableMaps.Dynamic.Map
+ Csound.Typed.Plugins.TabQueue
+
Paths_csound_expression_typed
- Default-Language: Haskell2010 \ No newline at end of file
+ Default-Language: Haskell2010
diff --git a/data/opcodes/tabQueue.udo b/data/opcodes/tabQueue.udo
new file mode 100644
index 0000000..f8f194a
--- /dev/null
+++ b/data/opcodes/tabQueue.udo
@@ -0,0 +1,45 @@
+opcode TabQueue_Append, 0, ii
+itab, ival xin
+ind = 0
+ik tab_i ind, itab
+tabw_i ival, (ik + 1), itab
+tabw_i (ik + 1), ind, itab
+endop
+
+opcode TabQueue_Delete, 0,ii
+itab, ival xin
+ind = 0
+iLast tab_i ind, itab
+iCount = 1
+iFound = 0
+until iCount > iLast do
+ iCur tab_i iCount, itab
+ if (iCur == ival) then
+ iFound = 1
+ tabw_i (iLast - 1), ind, itab
+ endif
+
+ if (iFound == 1) then
+ iNext tab_i (iCount + 1), itab
+ tabw_i iNext, iCount, itab
+ endif
+
+ iCount = iCount + 1
+od
+endop
+
+opcode TabQueue_HasElement, k, i
+itab xin
+knd = 0
+kk tab knd, itab
+kres = (kk == 0) ? 0 : 1
+xout kres
+endop
+
+opcode TabQueue_ReadLastElement, k, i
+itab xin
+knd = 0
+kk tab knd, itab
+kres tab kk, itab
+xout kres
+endop
diff --git a/data/opcodes/tabQueue2.udo b/data/opcodes/tabQueue2.udo
new file mode 100644
index 0000000..a056129
--- /dev/null
+++ b/data/opcodes/tabQueue2.udo
@@ -0,0 +1,50 @@
+
+opcode TabQueue2_Append, 0, iii
+itab, ival1, ival2 xin
+ind = 0
+ik tab_i ind, itab
+tabw_i ival1, (2 * (ik + 1) ), itab
+tabw_i ival2, (2 * (ik + 1) + 1), itab
+tabw_i (ik + 1), ind, itab
+endop
+
+opcode TabQueue2_Delete, 0,ii
+itab, ival xin
+ind = 0
+iLast tab_i ind, itab
+iCount = 1
+iFound = 0
+until iCount > iLast do
+ iCur tab_i (2 * iCount), itab
+ if (iCur == ival) then
+ iFound = 1
+ tabw_i (iLast - 1), ind, itab
+ endif
+
+ if (iFound == 1) then
+ iNext1 tab_i (2 * (iCount + 1)) , itab
+ iNext2 tab_i (2 * (iCount + 1) + 1), itab
+ tabw_i iNext1, (2 * iCount) , itab
+ tabw_i iNext2, (2 * iCount + 1), itab
+ endif
+
+ iCount = iCount + 1
+od
+endop
+
+opcode TabQueue2_HasElements, k, i
+itab xin
+knd = 0
+kk tab knd, itab
+kres = (kk == 0) ? 0 : 1
+xout kres
+endop
+
+opcode TabQueue2_ReadLastElement, kk, i
+itab xin
+knd = 0
+kk tab knd, itab
+kres1 tab (2 * kk) , itab
+kres2 tab (2 * kk + 1), itab
+xout kres1, kres2
+endop
diff --git a/src/Csound/Typed/Control.hs b/src/Csound/Typed/Control.hs
index e19f508..188f9bc 100644
--- a/src/Csound/Typed/Control.hs
+++ b/src/Csound/Typed/Control.hs
@@ -11,6 +11,8 @@ module Csound.Typed.Control (
module Csound.Typed.Control.Mix,
-- * Midi
module Csound.Typed.Control.Midi,
+ -- * Named instruments (API)
+ module Csound.Typed.Control.Api,
-- * OSC
module Csound.Typed.Control.Osc,
-- * Channel
@@ -29,6 +31,7 @@ import Csound.Typed.Control.Ref
import Csound.Typed.Control.Evt
import Csound.Typed.Control.Mix
import Csound.Typed.Control.Midi
+import Csound.Typed.Control.Api
import Csound.Typed.Control.Osc
import Csound.Typed.Control.Channel
import Csound.Typed.Control.Sf2
diff --git a/src/Csound/Typed/Control/Api.hs b/src/Csound/Typed/Control/Api.hs
new file mode 100644
index 0000000..837a662
--- /dev/null
+++ b/src/Csound/Typed/Control/Api.hs
@@ -0,0 +1,178 @@
+{-# Language ScopedTypeVariables #-}
+module Csound.Typed.Control.Api(
+ trigByName, trigByName_,
+ trigByNameMidi, trigByNameMidi_,
+ namedMonoMsg
+) where
+
+import Data.Boolean
+import Control.Monad.Trans.Class
+
+import qualified Csound.Dynamic as D
+import Csound.Dynamic(Rate(..), opcs, depT_)
+import Data.Boolean((==*), (>*), ifB)
+
+import Csound.Typed.Types
+import Csound.Typed.Control.Ref
+import Csound.Typed.GlobalState
+import Csound.Typed.GlobalState.Opcodes(eventi, Event(..), turnoff, port, downsamp)
+
+import Csound.Typed.Plugins.TabQueue
+
+-- | Creates an instrument that can be triggered by name with Csound API.
+-- The arguments are determined from the structure of the input for the instrument.
+--
+-- With Csound API we can send messages
+--
+-- > i "name" time duration arg1 arg2 arg3
+trigByName_ :: Arg a => String -> (a -> SE ()) -> SE ()
+trigByName_ name instr = geToSe $ saveNamedInstr name =<< (execSE $ instr toArg)
+
+-- | Creates an instrument that can be triggered by name with Csound API.
+-- The arguments are determined from the structure of the input for the instrument.
+-- If we have a tuple of arguments: @(D, D, Tab)@
+-- The would be rendered to instrument arguments that strts from @p4@.
+-- @p1@ is the name of teh instrument, @p2@ is the start time of the note,
+-- @p3@ is the duration of the note. Then @p4@ and @p5@ are going to be doubles and @p6@
+-- is an integer that denotes a functional table.
+trigByName :: (Arg a, Sigs b) => String -> (a -> SE b) -> SE b
+trigByName name instr = do
+ ref <- newClearableGlobalRef 0
+ trigByName_ name (go ref)
+ readRef ref
+ where go ref x = mixRef ref =<< instr x
+
+
+-- | It behaves just like the function @trigByNameMidi@. Only it doesn't produce an audio
+-- signal. It performs some procedure on note on and stops doing the precedure on note off.
+trigByNameMidi_ :: forall a . Arg a => String -> ((D, D, a) -> SE ()) -> SE ()
+trigByNameMidi_ name instr = do
+ instrId <- geToSe $ saveInstr (instr toArg)
+ trigByName_ name (go instrId)
+ where
+ go :: D.InstrId -> (D, D, D, a) -> SE ()
+ go instrId (noteFlag, pch, vol, other) = fromDep_ $ hideGEinDep $ do
+ pchExpr <- toGE pch
+ let instrIdExpr = D.instrIdE instrId + pchExpr / 1000
+ noteFlagExpr <- toGE noteFlag
+ args <- fromTuple (pch, vol, other)
+ return $ do
+ D.when1 (noteFlagExpr ==* 1) $ do
+ eventi (Event instrIdExpr 0 (-1) args)
+ D.when1 (noteFlagExpr ==* 0) $ do
+ eventi (Event (negate instrIdExpr) 0 0 args)
+ turnoff
+
+-- | Creates an instrument that can be triggered by name with Csound API.
+--
+-- It's intended to be used like a midi instrument. It simulates a simplified midi protocol.
+-- We can trigger notes:
+--
+-- > i "givenName" delay duration 1 pitchKey volumeKey auxParams -- note on
+-- > i "givenName" delay duration 0 pitchKey volumeKey auxParams -- note off
+--
+-- The arguments are
+--
+-- > trigByNameMidi name instrument
+--
+-- The instrument takes a triplet of @(pitchKey, volumeKey, auxilliaryTuple)@.
+-- The order does matter. Please don't pass the @volumeKey@ as the first argument.
+-- The instrument expects the pitch key to be a first argument.
+
+-- Under the hood
+-- it creates held notes that are indexed by pitch. If you know the Csound it creates
+-- the notes with indexes:
+--
+-- > i 18.pitchKey
+--
+-- Here the 18 is some generated integer index. And then on receiving a note a note off message for the specific key the
+-- Csound procedure invokes:
+--
+-- > turnoff 18.pitchKey
+trigByNameMidi :: (Arg a, Sigs b) => String -> ((D, D, a) -> SE b) -> SE b
+trigByNameMidi name instr = do
+ ref <- newClearableGlobalRef 0
+ trigByNameMidi_ name (go ref)
+ readRef ref
+ where go ref x = mixRef ref =<< instr x
+
+namedMonoMsg :: D -> D -> String -> SE (Sig, Sig)
+namedMonoMsg portTime relTime name = do
+ refPch <- newGlobalRef 0
+ refVol <- newGlobalRef 0
+ tab <- newGlobalTab 24
+ let onFlag = tabQueue2_hasElements tab
+ trigByNameMidiCbk name (onNote tab) (offNote tab)
+ when1 onFlag $ do
+ let (pch, vol) = tabQueue2_readLastElement tab
+ writeRef refPch pch
+ writeRef refVol vol
+ when1 (notB onFlag) $ do
+ writeRef refVol 0
+ pchKey <- readRef refPch
+ volKey <- readRef refVol
+ let resStatus = ifB onFlag 1 0
+ return (port' (downsamp' volKey) portTime * port' resStatus relTime, port' (downsamp' pchKey) portTime)
+ where
+ onNote = tabQueue2_append
+ offNote tab (pch, vol) = tabQueue2_delete tab pch
+
+trigByNameMidiCbk :: String -> ((D, D) -> SE ()) -> ((D, D) -> SE ()) -> SE ()
+trigByNameMidiCbk name noteOn noteOff =
+ trigByName_ name go
+ where
+ go :: (D, D, D) -> SE ()
+ go (noteFlag, pch, vol) = do
+ whenD1 (noteFlag ==* 1) $ noteOn (pch, vol)
+ whenD1 (noteFlag ==* 0) $ noteOff (pch, vol)
+ SE turnoff
+
+port' :: Sig -> D -> Sig
+port' a b = fromGE $ do
+ a' <- toGE a
+ b' <- toGE b
+ return $ port a' b'
+
+downsamp' :: Sig -> Sig
+downsamp' a = fromGE $ do
+ a' <- toGE a
+ return $ downsamp a'
+
+-- |
+-- Fast table opcodes.
+--
+-- Fast table opcodes. Faster than
+-- table and
+-- tablew because don't
+-- allow wrap-around and limit and don't check index validity. Have
+-- been implemented in order to provide fast access to
+-- arrays. Support non-power of two tables (can be generated by any
+-- GEN function by giving a negative length value).
+--
+-- > tabw ksig, kndx, ifn [,ixmode]
+-- > tabw asig, andx, ifn [,ixmode]
+--
+-- csound doc: <http://www.csounds.com/manual/html/tab.html>
+tabw :: Sig -> Sig -> Tab -> SE ()
+tabw b1 b2 b3 = SE $ (depT_ =<<) $ lift $ f <$> unSig b1 <*> unSig b2 <*> unTab b3
+ where f a1 a2 a3 = opcs "tabw" [(Xr,[Kr,Kr,Ir,Ir])] [a1,a2,a3]
+
+
+-- |
+-- Fast table opcodes.
+--
+-- Fast table opcodes. Faster than
+-- table and
+-- tablew because don't
+-- allow wrap-around and limit and don't check index validity. Have
+-- been implemented in order to provide fast access to
+-- arrays. Support non-power of two tables (can be generated by any
+-- GEN function by giving a negative length value).
+--
+-- > kr tab kndx, ifn[, ixmode]
+-- > ar tab xndx, ifn[, ixmode]
+--
+-- csound doc: <http://www.csounds.com/manual/html/tab.html>
+tab :: Sig -> Tab -> Sig
+tab b1 b2 = Sig $ f <$> unSig b1 <*> unTab b2
+ where f a1 a2 = opcs "tab" [(Kr,[Kr,Ir,Ir]),(Ar,[Xr,Ir,Ir])] [a1,a2] \ No newline at end of file
diff --git a/src/Csound/Typed/Control/Evt.hs b/src/Csound/Typed/Control/Evt.hs
index 139011c..a06fcaf 100644
--- a/src/Csound/Typed/Control/Evt.hs
+++ b/src/Csound/Typed/Control/Evt.hs
@@ -19,6 +19,7 @@ import qualified Csound.Typed.GlobalState.Elements as C
import Csound.Typed.Types
import Csound.Typed.GlobalState
+import Csound.Typed.GlobalState.Opcodes(primInstrId)
import Csound.Typed.Control.Instr
import Csound.Typed.Control.Mix(Sco)
@@ -72,7 +73,7 @@ saveEvtInstr arity instrId evts = saveInstr $ do
event :: Arg a => C.ChnRef -> (D, D, a) -> Dep ()
event chnId (start, dur, args) = hideGEinDep $ fmap C.event $
- C.Event instrId <$> toGE start <*> toGE dur <*> (fmap (++ [C.chnRefId chnId]) $ toNote args)
+ C.Event (primInstrId instrId) <$> toGE start <*> toGE dur <*> (fmap (++ [C.chnRefId chnId]) $ toNote args)
-- | Retriggers an instrument every time an event happens. The note
-- is held until the next event happens.
@@ -108,7 +109,7 @@ saveRetrigEvtInstr arity instrId evts = saveInstr $ do
event :: Arg a => C.ChnRef -> D -> a -> Dep ()
event chnId currentRetrig args = hideGEinDep $ fmap C.event $ do
currentRetrigExp <- toGE currentRetrig
- C.Event instrId 0 infiniteDur <$> (fmap (++ [C.chnRefId chnId, currentRetrigExp]) $ toNote args)
+ C.Event (primInstrId instrId) 0 infiniteDur <$> (fmap (++ [C.chnRefId chnId, currentRetrigExp]) $ toNote args)
evtLoop :: (Num a, Tuple a, Sigs a) => Maybe (Evt Unit) -> [SE a] -> [Evt Unit] -> a
evtLoop = evtLoopGen True
@@ -216,7 +217,7 @@ saveEvtLoopInstr mustLoop loopLength maybeOffEvt arity instrId evtInstrId = save
eventForAudioInstr = eventFor instrId
eventFor idx chnId currentRetrig =
- C.Event idx 0 infiniteDur [C.chnRefId chnId, currentRetrig]
+ C.Event (primInstrId idx) 0 infiniteDur [C.chnRefId chnId, currentRetrig]
readServantEvt :: GE C.ChnRef -> SE Sig
readServantEvt chnId = SE $ fmap fromE $ hideGEinDep $ fmap readChnEvtLoop chnId
@@ -249,7 +250,7 @@ autoOff dt sigs = fmap toTuple $ fromDep $ hideGEinDep $ phi =<< fromTuple sigs
saveEvtInstr_ :: Arg a => C.InstrId -> Evt [(D, D, a)] -> Dep ()
saveEvtInstr_ instrId evts = unSE $ runEvt evts $ \es -> fromDep_ $ mapM_ event es
- where event (start, dur, args) = hideGEinDep $ fmap C.event $ C.Event instrId <$> toGE start <*> toGE dur <*> toNote args
+ where event (start, dur, args) = hideGEinDep $ fmap C.event $ C.Event (primInstrId instrId) <$> toGE start <*> toGE dur <*> toNote args
-------------------------------------------------------------------
diff --git a/src/Csound/Typed/Control/Ref.hs b/src/Csound/Typed/Control/Ref.hs
index 3ad718f..fd96877 100644
--- a/src/Csound/Typed/Control/Ref.hs
+++ b/src/Csound/Typed/Control/Ref.hs
@@ -1,12 +1,19 @@
-module Csound.Typed.Control.Ref where
+module Csound.Typed.Control.Ref(
+ Ref, writeRef, readRef, newRef, mixRef, modifyRef, sensorsSE, newGlobalRef,
+ newCtrlRef, newGlobalCtrlRef,
+ globalSensorsSE, newClearableGlobalRef, newTab, newGlobalTab
+) where
import Control.DeepSeq(deepseq)
import Control.Monad
+import Control.Monad.Trans.Class
import Csound.Dynamic hiding (newLocalVars)
+import Csound.Typed.Types.Prim
import Csound.Typed.Types.Tuple
import Csound.Typed.GlobalState.SE
+import Csound.Typed.GlobalState.GE
-- | It describes a reference to mutable values.
newtype Ref a = Ref [Var]
@@ -32,6 +39,18 @@ readRef (Ref vars) = SE $ fmap (toTuple . return) $ mapM readVar vars
newRef :: Tuple a => a -> SE (Ref a)
newRef t = fmap Ref $ newLocalVars (tupleRates t) (fromTuple t)
+-- | Allocates a new local (it is visible within the instrument) mutable value and initializes it with value.
+-- A reference can contain a tuple of variables.
+-- It contains control signals (k-rate) and constants for numbers (i-rates).
+newCtrlRef :: Tuple a => a -> SE (Ref a)
+newCtrlRef t = fmap Ref $ newLocalVars (fmap toCtrlRate $ tupleRates t) (fromTuple t)
+ where
+
+toCtrlRate x = case x of
+ Ar -> Kr
+ Kr -> Ir
+ _ -> x
+
-- | Adds the given signal to the value that is contained in the
-- reference.
mixRef :: (Num a, Tuple a) => Ref a -> a -> SE ()
@@ -55,9 +74,79 @@ sensorsSE a = do
newGlobalRef :: Tuple a => a -> SE (Ref a)
newGlobalRef t = fmap Ref $ newGlobalVars (tupleRates t) (fromTuple t)
+-- | Allocates a new global mutable value and initializes it with value.
+-- A reference can contain a tuple of variables.
+-- It contains control signals (k-rate) and constants for numbers (i-rates).
+newGlobalCtrlRef :: Tuple a => a -> SE (Ref a)
+newGlobalCtrlRef t = fmap Ref $ newGlobalVars (fmap toCtrlRate $ tupleRates t) (fromTuple t)
+
-- | An alias for the function @newRef@. It returns not the reference
-- to mutable value but a pair of reader and writer functions.
globalSensorsSE :: Tuple a => a -> SE (SE a, a -> SE ())
globalSensorsSE a = do
ref <- newRef a
return $ (readRef ref, writeRef ref)
+
+-- | Allocates a new clearable global mutable value and initializes it with value.
+-- A reference can contain a tuple of variables.
+-- The variable is set to zero at the end of every iteration.
+-- It's useful for accumulation of audio values from several instruments.
+newClearableGlobalRef :: Tuple a => a -> SE (Ref a)
+newClearableGlobalRef t = fmap Ref $ newClearableGlobalVars (tupleRates t) (fromTuple t)
+
+-------------------------------------------------------------------------------
+-- writable tables
+
+-- | Creates a new table. The Tab could be used while the instrument
+-- is playing. When the instrument is retriggered the new tab is allocated.
+--
+-- > newTab size
+newTab :: D -> SE Tab
+newTab size = ftgentmp 0 0 size 7 0 [size, 0]
+
+-- | Creates a new global table.
+-- It's generated only once. It's persisted between instrument calls.
+--
+-- > newGlobalTab identifier size
+newGlobalTab :: Int -> SE Tab
+newGlobalTab size = do
+ ref <- newGlobalCtrlRef ((fromGE $ saveWriteTab size) :: D)
+ fmap (fromGE . toGE) $ readRef ref
+
+{-
+ identifier <- geToSe $ getNextGlobalGenId
+ ref <- newGlobalRef (0 :: D)
+ tabId <- ftgenonce 0 (Csound.Typed.Types.Prim.int identifier) size 7 0 [size, 0]
+ writeRef ref (fromGE $ toGE tabId)
+ fmap (fromGE . toGE) $ readRef ref
+-}
+
+-----------------------------------------------------------------------
+-- some opcodes that I have to define upfront
+
+
+-- |
+-- Generate a function table from within an instrument definition, without duplication of data.
+--
+-- Enables the creation of function tables entirely inside
+-- instrument definitions, without any duplication of data.
+--
+-- > ifno ftgenonce ip1, ip2dummy, isize, igen, iarga, iargb, ...
+--
+-- csound doc: <http://www.csounds.com/manual/html/ftgenonce.html>
+ftgenonce :: D -> D -> D -> D -> D -> [D] -> SE Tab
+ftgenonce b1 b2 b3 b4 b5 b6 = fmap ( Tab . return) $ SE $ (depT =<<) $ lift $ f <$> unD b1 <*> unD b2 <*> unD b3 <*> unD b4 <*> unD b5 <*> mapM unD b6
+ where f a1 a2 a3 a4 a5 a6 = opcs "ftgenonce" [(Ir,(repeat Ir))] ([a1,a2,a3,a4,a5] ++ a6)
+
+-- |
+-- Generate a score function table from within the orchestra, which is deleted at the end of the note.
+--
+-- Generate a score function table from within the orchestra,
+-- which is optionally deleted at the end of the note.
+--
+-- > ifno ftgentmp ip1, ip2dummy, isize, igen, iarga, iargb, ...
+--
+-- csound doc: <http://www.csounds.com/manual/html/ftgentmp.html>
+ftgentmp :: D -> D -> D -> D -> D -> [D] -> SE Tab
+ftgentmp b1 b2 b3 b4 b5 b6 = fmap ( Tab . return) $ SE $ (depT =<<) $ lift $ f <$> unD b1 <*> unD b2 <*> unD b3 <*> unD b4 <*> unD b5 <*> mapM unD b6
+ where f a1 a2 a3 a4 a5 a6 = opcs "ftgentmp" [(Ir,(repeat Ir))] ([a1,a2,a3,a4,a5] ++ a6) \ No newline at end of file
diff --git a/src/Csound/Typed/GlobalState/Elements.hs b/src/Csound/Typed/GlobalState/Elements.hs
index 7a4dfd8..1c5c24d 100644
--- a/src/Csound/Typed/GlobalState/Elements.hs
+++ b/src/Csound/Typed/GlobalState/Elements.hs
@@ -4,6 +4,7 @@ module Csound.Typed.GlobalState.Elements(
IdMap(..), saveId, newIdMapId,
-- ** Gens
GenMap, newGen, newGenId, nextGlobalGenCounter, newTabOfGens,
+ WriteGenMap, newWriteGen, newWriteTab,
-- Sf2
SfFluid(..), SfSpec(..), SfMap, newSf, sfVar, renderSf,
-- ** Band-limited waveforms
@@ -15,17 +16,23 @@ module Csound.Typed.GlobalState.Elements(
-- * Midi
MidiType(..), Channel, MidiMap, MidiKey(..), saveMidiInstr,
-- * Global variables
- Globals(..), newPersistentGlobalVar, newClearableGlobalVar,
+ Globals(..), newPersistentGlobalVar, newClearableGlobalVar,
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
+ subinstr, subinstr_, event_i, event, safeOut, autoOff, changed,
+ -- * Udo plugins
+ UdoPlugin, addUdoPlugin, getUdoPluginNames,
+ tabQueuePlugin, tabQueue2Plugin
) where
+import Data.List
import Data.Hashable
import Control.Monad.Trans.State.Strict
@@ -34,8 +41,6 @@ import Data.Default
import qualified Data.Map as M
import qualified Data.IntMap as IM
-import qualified Csound.Typed.GlobalState.Opcodes as C(midiVolumeFactor)
-
import Csound.Dynamic.Types
import Csound.Dynamic.Build
import Csound.Dynamic.Build.Numeric()
@@ -72,14 +77,58 @@ newIdMapId = state $ \s ->
type GenMap = IdMap Gen
newGen :: Gen -> State GenMap E
-newGen = fmap int . saveId
+newGen = fmap int . saveGenId
newTabOfGens :: [Gen] -> State GenMap E
-newTabOfGens = fmap int . (saveId . intTab =<<) . mapM saveId
- where intTab ns = Gen (length ns) (-2) (fmap fromIntegral ns) Nothing
+newTabOfGens = fmap int . (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 = newIdMapId
+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
@@ -263,11 +312,6 @@ data Instrs = Instrs
instance Default Instrs where
def = Instrs IM.empty 18 []
-type CacheName = Int
-
-makeCacheName :: Hashable a => a -> CacheName
-makeCacheName = hash
-
getInstrIds :: Instrs -> [InstrId]
getInstrIds = fmap fst . instrsContent
@@ -318,6 +362,17 @@ saveInstr body = do
-}
-----------------------------------------------------------------
+-- 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]
@@ -369,3 +424,19 @@ chnPargId arityIns = 4 + arityIns
-- scaleVolumeFactor = (setRate Ir (C.midiVolumeFactor (pn 1)) * )
-- guis
+
+
+--------------------------------------------------------
+-- Udo plugins
+
+newtype UdoPlugin = UdoPlugin { unUdoPlugin :: String }
+
+tabQueuePlugin = UdoPlugin "tabQueue"
+tabQueue2Plugin = UdoPlugin "tabQueue2"
+
+addUdoPlugin :: UdoPlugin -> State [UdoPlugin] ()
+addUdoPlugin a = modify (a :)
+
+getUdoPluginNames :: [UdoPlugin] -> [String]
+getUdoPluginNames xs = nub (fmap unUdoPlugin xs)
+
diff --git a/src/Csound/Typed/GlobalState/GE.hs b/src/Csound/Typed/GlobalState/GE.hs
index d9d0bbb..8d91125 100644
--- a/src/Csound/Typed/GlobalState/GE.hs
+++ b/src/Csound/Typed/GlobalState/GE.hs
@@ -9,6 +9,8 @@ module Csound.Typed.GlobalState.GE(
MidiCtrl(..), saveMidiCtrl, renderMidiCtrl,
-- * Instruments
saveAlwaysOnInstr, onInstr, saveUserInstr0, getSysExpr,
+ -- * Named instruments
+ saveNamedInstr,
-- * Total duration
TotalDur(..), pureGetTotalDurForF0, getTotalDurForTerminator,
setDurationForce, setDuration, setDurationToInfinite,
@@ -16,6 +18,7 @@ module Csound.Typed.GlobalState.GE(
addNote,
-- * GEN routines
saveGen, saveTabs, getNextGlobalGenId,
+ saveWriteGen, saveWriteTab,
-- * Sf2
saveSf, sfTable,
-- * Band-limited waves
@@ -31,7 +34,9 @@ module Csound.Typed.GlobalState.GE(
listenKeyEvt, Key(..), KeyEvt(..), Guis(..),
getKeyEventListener,
-- * Hrtf pan
- simpleHrtfmove, simpleHrtfstat
+ simpleHrtfmove, simpleHrtfstat,
+ -- * Udo plugins
+ addUdoPlugin, renderUdoPlugins
) where
import Paths_csound_expression_typed
@@ -52,12 +57,14 @@ import Csound.Dynamic
import Csound.Typed.GlobalState.Options
import Csound.Typed.GlobalState.Cache
-import Csound.Typed.GlobalState.Elements
+import Csound.Typed.GlobalState.Elements hiding(saveNamedInstr, addUdoPlugin)
import Csound.Typed.Constants(infiniteDur)
-import Csound.Typed.GlobalState.Opcodes(hrtfmove, hrtfstat)
+import Csound.Typed.GlobalState.Opcodes(hrtfmove, hrtfstat, primInstrId)
import Csound.Typed.Gui.Gui(Panel(..), Win(..), GuiNode, GuiHandle(..), restoreTree, guiMap, mapGuiOnPanel, defText)
+import qualified Csound.Typed.GlobalState.Elements as E(saveNamedInstr, addUdoPlugin)
+
type Dep a = DepT GE a
-- global side effects
@@ -88,12 +95,15 @@ instance MonadIO GE where
data History = History
{ genMap :: GenMap
- , globalGenCounter :: Int
+ , writeGenMap :: WriteGenMap
+ , globalGenCounter :: Int
, stringMap :: StringMap
, sfMap :: SfMap
, midiMap :: MidiMap GE
, globals :: Globals
, instrs :: Instrs
+ , udoPlugins :: [UdoPlugin]
+ , namedInstrs :: NamedInstrs
, midis :: [MidiAssign]
, midiCtrls :: [MidiCtrl]
, totalDur :: Maybe TotalDur
@@ -105,7 +115,7 @@ data History = History
, guis :: Guis }
instance Default History where
- def = History def def def def def def def def def def def def (return ()) def def def
+ def = History def def def def def def def def def def def def def def def (return ()) def def def
data Msg = Msg
data MidiAssign = MidiAssign MidiType Channel InstrId
@@ -164,6 +174,14 @@ saveGen = onGenMap . newGen
onGenMap = onHistory genMap (\val h -> h{ genMap = val })
+saveWriteGen :: Gen -> GE E
+saveWriteGen = onWriteGenMap . newWriteGen
+
+saveWriteTab :: Int -> GE E
+saveWriteTab = onWriteGenMap . newWriteTab
+
+onWriteGenMap = onHistory writeGenMap (\val h -> h{ writeGenMap = val })
+
saveTabs :: [Gen] -> GE E
saveTabs = onGenMap . newTabOfGens
@@ -205,7 +223,7 @@ getSysExpr :: InstrId -> GE (Dep ())
getSysExpr terminatorInstrId = do
e1 <- withHistory $ clearGlobals . globals
dt <- getTotalDurForTerminator
- let e2 = event_i $ Event terminatorInstrId dt 0.01 []
+ let e2 = event_i $ Event (primInstrId terminatorInstrId) dt 0.01 []
return $ e1 >> e2
where clearGlobals = snd . renderGlobals
@@ -216,9 +234,6 @@ saveAlwaysOnInstr instrId = onAlwaysOnInstrs $ modify (instrId : )
addNote :: InstrId -> CsdEvent -> GE ()
addNote instrId evt = modifyHistory $ \h -> h { notes = (instrId, evt) : notes h }
-
-
-
{-
setMasterInstrId :: InstrId -> GE ()
setMasterInstrId masterId = onMasterInstrId $ put masterId
@@ -267,6 +282,13 @@ onGlobals :: UpdField Globals a
onGlobals = onHistory globals (\a h -> h { globals = a })
----------------------------------------------------------------------
+-- named instruments
+
+saveNamedInstr :: String -> InstrBody -> GE ()
+saveNamedInstr name body = onNamedInstrs $ E.saveNamedInstr name body
+ where onNamedInstrs = onHistory namedInstrs (\a h -> h { namedInstrs = a })
+
+----------------------------------------------------------------------
-- cache
-- midi functions
@@ -514,3 +536,21 @@ getHrtfFiles = do
hrtfFileNames :: Int -> IO (String, String)
hrtfFileNames sr = liftA2 (,) (getDataFileName (name "left" sr)) (getDataFileName (name "right" sr))
where name dir n = concat ["data/hrtf-", show n, "-", dir, ".dat"]
+
+-----------------------------------------------
+-- udo plugins
+
+addUdoPlugin :: UdoPlugin -> GE ()
+addUdoPlugin p = onUdo (E.addUdoPlugin p)
+ where onUdo = onHistory udoPlugins (\val h -> h{ udoPlugins = val })
+
+renderUdoPlugins :: History -> IO String
+renderUdoPlugins h = fmap concat $ mapM getUdoPluginBody $ getUdoPluginNames $ udoPlugins h
+
+getUdoPluginBody :: String -> IO String
+getUdoPluginBody name = readFile =<< getDataFileName filename
+ where filename = concat ["data/opcodes/", name, ".udo"]
+
+
+
+
diff --git a/src/Csound/Typed/GlobalState/Instr.hs b/src/Csound/Typed/GlobalState/Instr.hs
index bcedf11..e963f83 100644
--- a/src/Csound/Typed/GlobalState/Instr.hs
+++ b/src/Csound/Typed/GlobalState/Instr.hs
@@ -114,4 +114,3 @@ terminatorInstr :: GE (SE ())
terminatorInstr = do
ids <- fmap (getInstrIds . instrs) getHistory
return $ fromDep_ $ (mapM_ turnoff2 $ fmap instrIdE ids) >> exitnow
-
diff --git a/src/Csound/Typed/GlobalState/Opcodes.hs b/src/Csound/Typed/GlobalState/Opcodes.hs
index 32ebc58..5fa073e 100644
--- a/src/Csound/Typed/GlobalState/Opcodes.hs
+++ b/src/Csound/Typed/GlobalState/Opcodes.hs
@@ -7,7 +7,7 @@ module Csound.Typed.GlobalState.Opcodes(
masterUpdateChnRetrig, servantUpdateChnRetrig,
servantUpdateChnEvtLoop, getRetrigVal,
-- * trigger an instrument
- Event(..), event, event_i, appendChn, subinstr, subinstr_, changed, diff, delay1,
+ Event(..), event, eventi, event_i, appendChn, subinstr, subinstr_, changed, diff, delay1, primInstrId,
-- * output
out, outs, safeOut, autoOff, turnoff, turnoff2, exitnow,
-- * vco2
@@ -29,7 +29,11 @@ module Csound.Typed.GlobalState.Opcodes(
-- * Hrtf Pan
hrtfmove, hrtfstat,
-- * Read tables
- tableK, tableI
+ tableK, tableI,
+ -- * Portamento
+ port,
+ -- * Rate convertion
+ downsamp
) where
import Prelude hiding ((<*))
@@ -156,8 +160,11 @@ freeChn = depT $ opcs chnUpdateOpcodeName [(Ir, [])] []
-- trigger
+primInstrId :: InstrId -> E
+primInstrId = prim . PrimInstrId
+
data Event = Event
- { eventInstrId :: InstrId
+ { eventInstrId :: E
, eventStart :: E
, eventDur :: E
, eventArgs :: [E] }
@@ -165,12 +172,15 @@ data Event = Event
event :: Monad m => Event -> DepT m ()
event = eventBy "event" Kr
+eventi :: Monad m => Event -> DepT m ()
+eventi = eventBy "event" Ir
+
event_i :: Monad m => Event -> DepT m ()
event_i = eventBy "event_i" Ir
eventBy :: Monad m => String -> Rate -> Event -> DepT m ()
eventBy name rate a = depT_ $ opcs name [(Xr, Sr : repeat rate)]
- (str "i" : (prim (PrimInstrId $ eventInstrId a)) : (eventStart a) : (eventDur a) : (eventArgs a))
+ (str "i" : (eventInstrId a) : (eventStart a) : (eventDur a) : (eventArgs a))
appendChn :: E -> Event -> Event
appendChn chn a = a { eventArgs = eventArgs a ++ [chn] }
@@ -206,8 +216,10 @@ outs as = depT_ $ opcsNoInlineArgs "outs" [(Xr, repeat Ar)] as
-- clipps values by 0dbfs
safeOut :: Double -> [E] -> [E]
-safeOut gainLevel = fmap (( * double gainLevel) . clip)
- where clip x = opcs "clip" [(Ar, [Ar, Ir, Ir])] [x, 0, readOnlyVar (VarVerbatim Ir "0dbfs")]
+safeOut gainLevel = fmap (( * double gainLevel) . limiter)
+
+limiter :: E -> E
+limiter x = opcs "compress" [(Ar, [Ar, Ar, Kr, Kr, Kr, Kr, Kr, Kr, Ir])] [x, 1, 0, 89, 89, 100, 0, 0, 0]
autoOff :: Monad m => E -> [E] -> DepT m [E]
autoOff dt a = do
@@ -277,10 +289,15 @@ vco2ift cps iwave = opcs "vco2ift" [(Kr, [Ir, Ir, Ir])] [cps, iwave]
ftgen :: E -> Gen -> E
ftgen n g = opcs "ftgen" [(Ir, repeat Ir)]
- $ [n, 0, int $ genSize g, int $ genId g]
+ $ [n, 0, int $ genSize g, genIdE $ genId g]
++ (maybe [] (return . str) $ genFile g)
++ (fmap double $ genArgs g)
+genIdE :: GenId -> E
+genIdE genId = case genId of
+ IntGenId n -> int n
+ StringGenId a -> str a
+
vco2init :: [E] -> E
vco2init = opcs "vco2init" [(Ir, repeat Ir)]
@@ -367,6 +384,9 @@ activeIr instrId = opcs "active" [(Ir, [Ir])] [instrId]
port :: E -> E -> E
port a b = opcs "portk" [(Kr, [Kr, Ir])] [a, b]
+downsamp :: E -> E
+downsamp a = opcs "downsamp" [(Kr, [Ar])] [a]
+
-----------------------------------------------------------
getPair mout = (a, b)
diff --git a/src/Csound/Typed/GlobalState/Options.hs b/src/Csound/Typed/GlobalState/Options.hs
index 678f855..9be6b3f 100644
--- a/src/Csound/Typed/GlobalState/Options.hs
+++ b/src/Csound/Typed/GlobalState/Options.hs
@@ -1,18 +1,23 @@
module Csound.Typed.GlobalState.Options (
Options(..),
defGain, defSampleRate, defBlockSize, defTabFi,
- -- ** Table fidelity
+ -- * Table fidelity
TabFi(..), fineFi, coarseFi,
- -- *** Gen identifiers
+ -- ** Gen identifiers
-- | Low level Csound integer identifiers for tables. These names can be used in the function 'Csound.Base.fineFi'
+ -- *** Integer identifiers
idWavs, idMp3s, idDoubles, idSines, idSines3, idSines2,
idPartials, idSines4, idBuzzes, idConsts, idLins, idCubes,
- idExps, idSplines, idStartEnds, idPolys, idChebs1, idChebs2, idBessels, idWins
+ idExps, idSplines, idStartEnds, idPolys, idChebs1, idChebs2, idBessels, idWins,
+ -- *** String identifiers
+ idPadsynth, idTanh, idExp, idSone, idFarey, idWave
) where
import Control.Applicative
import Data.Default
+
import qualified Data.IntMap as IM
+import qualified Data.Map as M
import Csound.Dynamic hiding (csdFlags)
@@ -59,10 +64,13 @@ defTabFi = maybe def id . csdTabFi
-- | Table size fidelity (how many points in the table by default).
data TabFi = TabFi
{ tabFiBase :: Int
- , tabFiGens :: IM.IntMap Int }
+ , tabFiGens :: IM.IntMap Int
+ , tabNamedFiGens :: M.Map String Int }
instance Default TabFi where
- def = fineFi 13 [(idLins, 11), (idExps, 11), (idConsts, 9), (idSplines, 11), (idStartEnds, 12)]
+ def = fineFi 13
+ [(idLins, 11), (idExps, 11), (idConsts, 9), (idSplines, 11), (idStartEnds, 12)]
+ [(idPadsynth, 18), (idSone, 14), (idTanh, 13), (idExp, 13)]
-- | Sets different table size for different GEN-routines.
@@ -77,8 +85,8 @@ instance Default TabFi where
-- given GEN-routine.
--
-- with this function we can set lower table sizes for tables that are usually used in the envelopes.
-fineFi :: Int -> [(Int, Int)] -> TabFi
-fineFi n xs = TabFi n (IM.fromList xs)
+fineFi :: Int -> [(Int, Int)] -> [(String, Int)] -> TabFi
+fineFi n xs ys = TabFi n (IM.fromList xs) (M.fromList ys)
-- | Sets the same table size for all tables.
--
@@ -86,7 +94,7 @@ fineFi n xs = TabFi n (IM.fromList xs)
--
-- where @n@ is a degree of 2. For example, @n = 10@ sets size to 1024 points for all tables by default.
coarseFi :: Int -> TabFi
-coarseFi n = TabFi n IM.empty
+coarseFi n = TabFi n IM.empty M.empty
idWavs, idMp3s, idDoubles, idSines, idSines3, idSines2,
idPartials, idSines4, idBuzzes, idConsts, idLins, idCubes,
@@ -116,3 +124,14 @@ idBessels = 12
idWins = 20
idMp3s = 49
+-- Identifiers for named GEN-routines
+
+idPadsynth, idTanh, idExp, idSone, idFarey, idWave :: String
+
+idPadsynth = "padsynth"
+idTanh = "tanh"
+idExp = "exp"
+idSone = "sone"
+idFarey = "farey"
+idWave = "wave"
+
diff --git a/src/Csound/Typed/GlobalState/SE.hs b/src/Csound/Typed/GlobalState/SE.hs
index 7df5ee4..4bb7903 100644
--- a/src/Csound/Typed/GlobalState/SE.hs
+++ b/src/Csound/Typed/GlobalState/SE.hs
@@ -2,7 +2,7 @@ module Csound.Typed.GlobalState.SE(
SE(..), LocalHistory(..),
runSE, execSE, evalSE, execGEinSE, hideGEinDep,
fromDep, fromDep_, geToSe,
- newLocalVar, newLocalVars, newGlobalVars
+ newLocalVar, newLocalVars, newGlobalVars, newClearableGlobalVars
) where
import Control.Applicative
@@ -12,7 +12,7 @@ import Control.Monad.Trans.Class
import Csound.Dynamic hiding (newLocalVar, newLocalVars)
import qualified Csound.Dynamic as D(newLocalVar, newLocalVars)
import Csound.Typed.GlobalState.GE
-import Csound.Typed.GlobalState.Elements(newPersistentGlobalVar)
+import Csound.Typed.GlobalState.Elements(newPersistentGlobalVar, newClearableGlobalVar)
-- | The Csound's @IO@-monad. All values that produce side effects are wrapped
-- in the @SE@-monad.
@@ -75,4 +75,6 @@ newGlobalVars :: [Rate] -> GE [E] -> SE [Var]
newGlobalVars rs vs = geToSe $ zipWithM f rs =<< vs
where f r v = onGlobals $ newPersistentGlobalVar r v
-
+newClearableGlobalVars :: [Rate] -> GE [E] -> SE [Var]
+newClearableGlobalVars rs vs = geToSe $ zipWithM f rs =<< vs
+ where f r v = onGlobals $ newClearableGlobalVar r v
diff --git a/src/Csound/Typed/Plugins/TabQueue.hs b/src/Csound/Typed/Plugins/TabQueue.hs
new file mode 100644
index 0000000..6bd5bcf
--- /dev/null
+++ b/src/Csound/Typed/Plugins/TabQueue.hs
@@ -0,0 +1,48 @@
+module Csound.Typed.Plugins.TabQueue(
+ tabQueue2_append, tabQueue2_delete, tabQueue2_hasElements, tabQueue2_readLastElement
+) where
+
+import Data.Boolean
+import Control.Monad.Trans.Class
+
+import Csound.Dynamic
+
+import Csound.Typed.Types
+import Csound.Typed.GlobalState
+import qualified Csound.Typed.GlobalState.Elements as E(tabQueue2Plugin)
+
+-------------------------------------------------------------------------------
+-- table queue for midi notes
+
+-- |
+-- > tabQueue2_append table (pch, vol)
+tabQueue2_append :: Tab -> (D, D) -> SE ()
+tabQueue2_append tab (pch, vol) = SE $ (depT_ =<<) $ lift $ do
+ addUdoPlugin E.tabQueue2Plugin
+ f <$> toGE tab <*> toGE pch <*> toGE vol
+ where f tab pch vol = opcs "TabQueue2_Append" [(Xr, [Ir, Ir, Ir])] [tab, pch, vol]
+
+-- | Delete by pitch
+--
+-- > tabQueue2_delete table pch
+tabQueue2_delete :: Tab -> D -> SE ()
+tabQueue2_delete tab pch = SE $ (depT_ =<<) $ lift $ do
+ addUdoPlugin E.tabQueue2Plugin
+ f <$> toGE tab <*> toGE pch
+ where f tab pch = opcs "TabQueue2_Delete" [(Xr, [Ir, Ir])] [tab, pch]
+
+-- | Queue is not empty
+tabQueue2_hasElements :: Tab -> BoolSig
+tabQueue2_hasElements = (==* 1) . tabQueue2_hasElements'
+
+tabQueue2_hasElements' :: Tab -> Sig
+tabQueue2_hasElements' tab = fromGE $ do
+ addUdoPlugin E.tabQueue2Plugin
+ f <$> toGE tab
+ where f tab = opcs "TabQueue2_HasElements" [(Kr, [Ir])] [tab]
+
+tabQueue2_readLastElement :: Tab -> (Sig, Sig)
+tabQueue2_readLastElement tab = toTuple $ fmap ($ 2) $ do
+ addUdoPlugin E.tabQueue2Plugin
+ f <$> toGE tab
+ where f tab = mopcs "TabQueue2_ReadLastElement" ([Kr, Kr], [Ir]) [tab]
diff --git a/src/Csound/Typed/Render.hs b/src/Csound/Typed/Render.hs
index cc98655..1a325e8 100644
--- a/src/Csound/Typed/Render.hs
+++ b/src/Csound/Typed/Render.hs
@@ -11,13 +11,16 @@ import qualified Data.Map as M
import Data.Default
import Data.Maybe
import Data.Tuple
+import Data.Monoid
import Data.Ord
import Data.List(sortBy, groupBy)
import qualified Data.IntMap as IM
+import Control.Monad.IO.Class
import Csound.Dynamic hiding (csdFlags)
import Csound.Typed.Types
import Csound.Typed.GlobalState
+import Csound.Typed.GlobalState.Elements(NamedInstrs(..))
import Csound.Typed.GlobalState.Options
import Csound.Typed.Control.Instr
import Csound.Typed.Control(getIns)
@@ -64,27 +67,29 @@ renderHistory :: Maybe Int -> Int -> Options -> GE Csd
renderHistory mnchnls_i nchnls opt = do
keyEventListener <- getKeyEventListener
hist1 <- getHistory
- instr0 <- execDepT $ getInstr0 mnchnls_i nchnls opt hist1
+ udos <- fmap verbatim $ liftIO $ renderUdoPlugins hist1
+ instr0 <- execDepT $ getInstr0 mnchnls_i nchnls opt udos hist1
terminatorInstrId <- saveInstr =<< terminatorInstr
expr2 <- getSysExpr terminatorInstrId
saveAlwaysOnInstr =<< saveInstr (SE expr2)
expr3 <- guiInstrExp
saveAlwaysOnInstr =<< saveInstr (SE expr3)
- hist2 <- getHistory
- let orc = Orc instr0 (maybeAppend keyEventListener $ fmap (uncurry Instr) $ instrsContent $ instrs hist2)
- hist3 <- getHistory
+ hist2 <- getHistory
+ let namedIntruments = fmap (\(name, body) -> Instr (InstrLabel name) body) $ unNamedInstrs $ namedInstrs hist2
+ let orc = Orc instr0 ((namedIntruments ++ ) $ maybeAppend keyEventListener $ fmap (uncurry Instr) $ instrsContent $ instrs hist2)
+ hist3 <- getHistory
let flags = reactOnMidi hist3 $ csdFlags opt
sco = Sco (Just $ pureGetTotalDurForF0 $ totalDur hist3)
- (renderGens $ genMap hist3) $
+ (renderGens (genMap hist3) (writeGenMap hist3)) $
((fmap alwaysOn $ alwaysOnInstrs hist3) ++ (getNoteEvents $ notes hist3))
return $ Csd flags orc sco
where
- renderGens = fmap swap . M.toList . idMapContent
+ renderGens gens writeGens = (fmap swap $ M.toList $ idMapContent gens) ++ writeGens
maybeAppend ma = maybe id (:) ma
getNoteEvents = fmap $ \(instrId, evt) -> (instrId, [evt])
-getInstr0 :: Maybe Int -> Int -> Options -> History -> Dep ()
-getInstr0 mnchnls_i nchnls opt hist = do
+getInstr0 :: Maybe Int -> Int -> Options -> Dep () -> History -> Dep ()
+getInstr0 mnchnls_i nchnls opt udos hist = do
globalConstants
midiAssigns
midiInitCtrls
@@ -92,6 +97,7 @@ getInstr0 mnchnls_i nchnls opt hist = do
renderBandLimited (genMap hist) (bandLimitedMap hist)
userInstr0 hist
chnUpdateUdo
+ udos
sf2
guiStmt $ getPanels hist
where
diff --git a/src/Csound/Typed/Types/MixSco.hs b/src/Csound/Typed/Types/MixSco.hs
index 1196e36..a3da253 100644
--- a/src/Csound/Typed/Types/MixSco.hs
+++ b/src/Csound/Typed/Types/MixSco.hs
@@ -108,4 +108,4 @@ mkEvent :: InstrId -> D -> D -> [E] -> Dep ()
mkEvent instrId startD durD args = hideGEinDep $ do
start <- toGE startD
dur <- toGE durD
- return $ event_i $ Event instrId start dur args
+ return $ event_i $ Event (primInstrId instrId) start dur args
diff --git a/src/Csound/Typed/Types/Prim.hs b/src/Csound/Typed/Types/Prim.hs
index 5c79029..3096a7e 100644
--- a/src/Csound/Typed/Types/Prim.hs
+++ b/src/Csound/Typed/Types/Prim.hs
@@ -4,10 +4,10 @@ module Csound.Typed.Types.Prim(
BoolSig(..), unBoolSig, BoolD(..), unBoolD, Unit(..), unit, Val(..), hideGE, SigOrD,
-- ** Tables
- preTab, TabSize(..), TabArgs(..), updateTabSize,
+ preTab, preStringTab, TabSize(..), TabArgs(..), updateTabSize,
fromPreTab, getPreTabUnsafe, skipNorm, forceNorm,
nsamp, ftlen, ftchnls, ftsr, ftcps,
- TabList, tabList, fromTabList, fromTabListD,
+ TabList, tabList, fromTabList, fromTabListD,
-- ** constructors
double, int, text,
@@ -26,7 +26,8 @@ module Csound.Typed.Types.Prim(
-- ** logic funs
when1, whens, untilDo, whileDo, boolSig,
- equalsTo, notEqualsTo, lessThan, greaterThan, lessThanEquals, greaterThanEquals
+ equalsTo, notEqualsTo, lessThan, greaterThan, lessThanEquals, greaterThanEquals,
+ whenD1, whenDs, untilDoD, whileDoD, untilBeginD
) where
import Prelude hiding ((<*))
@@ -35,7 +36,8 @@ import Control.Applicative hiding ((<*))
import Control.Monad
import Control.Monad.Trans.Class
import Data.Monoid
-import qualified Data.IntMap as IM
+import qualified Data.IntMap as IM
+import qualified Data.Map as M
import Data.Default
import Data.Boolean
@@ -121,11 +123,14 @@ data Tab
| TabPre PreTab
preTab :: TabSize -> Int -> TabArgs -> Tab
-preTab size gen args = TabPre $ PreTab size gen args
+preTab size gen args = TabPre $ PreTab size (IntGenId gen) args
+
+preStringTab :: TabSize -> String -> TabArgs -> Tab
+preStringTab size gen args = TabPre $ PreTab size (StringGenId gen) args
data PreTab = PreTab
{ preTabSize :: TabSize
- , preTabGen :: Int
+ , preTabGen :: GenId
, preTabArgs :: TabArgs }
-- Table size.
@@ -170,7 +175,9 @@ fromPreTab a = withOptions $ \opt -> go (defTabFi opt) a
(args, file) = defineTabArgs size (preTabArgs tab)
getTabSizeBase :: TabFi -> PreTab -> Int
-getTabSizeBase tf tab = IM.findWithDefault (tabFiBase tf) (preTabGen tab) (tabFiGens tf)
+getTabSizeBase tf tab = case preTabGen tab of
+ IntGenId intId -> IM.findWithDefault (tabFiBase tf) intId (tabFiGens tf)
+ StringGenId stringId -> M.findWithDefault (tabFiBase tf) stringId (tabNamedFiGens tf)
defineTabSize :: Int -> TabSize -> Int
defineTabSize base x = case x of
@@ -222,14 +229,23 @@ defineTabArgs size args = case args of
skipNorm :: Tab -> Tab
skipNorm x = case x of
Tab _ -> error "you can skip normalization only for primitive tables (made with gen-routines)"
- TabPre a -> TabPre $ a{ preTabGen = negate $ abs $ preTabGen a }
+ TabPre a -> TabPre $ a{ preTabGen = skipNormGenId $ preTabGen a }
+
+skipNormGenId = mapIntGenId (negate . abs)
-- | Force normalization (sets table size to positive value).
-- Might be useful to restore normalization for table 'Csound.Tab.doubles'.
forceNorm :: Tab -> Tab
forceNorm x = case x of
Tab _ -> error "you can force normalization only for primitive tables (made with gen-routines)"
- TabPre a -> TabPre $ a{ preTabGen = abs $ preTabGen a }
+ TabPre a -> TabPre $ a{ preTabGen = normGenId $ preTabGen a }
+
+normGenId = mapIntGenId abs
+
+mapIntGenId :: (Int -> Int) -> GenId -> GenId
+mapIntGenId f genId = case genId of
+ IntGenId intId -> IntGenId (f intId)
+ _ -> genId
----------------------------------------------------------------------------
-- change table size
@@ -408,6 +424,8 @@ instance Default Tab where def = fromE 0
instance Default Str where def = text ""
instance Default Spec where def = fromE 0
+instance Default TabList where def = fromE 0
+
-------------------------------------------------------------------------------
-- monoid
@@ -602,6 +620,32 @@ ifEnd = fromDep_ D.ifEnd
elseBegin :: SE ()
elseBegin = fromDep_ D.elseBegin
+-- | Invokes the given procedure if the boolean signal is true.
+whenD1 :: BoolD -> SE () -> SE ()
+whenD1 xp body = case xp of
+ PrimBoolD p -> if p then body else return ()
+ _ -> do
+ ifBeginD xp
+ body
+ ifEnd
+
+-- | The chain of @when1@s. Tests all the conditions in sequence
+-- if everything is false it invokes the procedure given in the second argument.
+whenDs :: [(BoolD, SE ())] -> SE () -> SE ()
+whenDs bodies el = case bodies of
+ [] -> el
+ a:as -> do
+ ifBeginD (fst a)
+ snd a
+ elseIfs as
+ elseBegin
+ el
+ foldl1 (>>) $ replicate (length bodies) ifEnd
+ where elseIfs = mapM_ (\(p, body) -> elseBegin >> ifBeginD p >> body)
+
+ifBeginD :: BoolD -> SE ()
+ifBeginD a = fromDep_ $ D.ifBegin =<< lift (toGE a)
+
-- elseIfBegin :: BoolSig -> SE ()
-- elseIfBegin a = fromDep_ $ D.elseIfBegin =<< lift (toGE a)
@@ -620,6 +664,18 @@ untilBegin a = fromDep_ $ D.untilBegin =<< lift (toGE a)
untilEnd :: SE ()
untilEnd = fromDep_ D.untilEnd
+untilDoD :: BoolD -> SE () -> SE ()
+untilDoD p body = do
+ untilBeginD p
+ body
+ untilEnd
+
+whileDoD :: BoolD -> SE () -> SE ()
+whileDoD p = untilDoD (notB p)
+
+untilBeginD :: BoolD -> SE ()
+untilBeginD a = fromDep_ $ D.untilBegin =<< lift (toGE a)
+
-- | Creates a constant boolean signal.
boolSig :: BoolD -> BoolSig
boolSig x = case x of
diff --git a/src/Csound/Typed/Types/Tuple.hs b/src/Csound/Typed/Types/Tuple.hs
index a5b5df2..eaf2237 100644
--- a/src/Csound/Typed/Types/Tuple.hs
+++ b/src/Csound/Typed/Types/Tuple.hs
@@ -106,6 +106,8 @@ instance Tuple Tab where tupleMethods = primTupleMethods Kr
instance Tuple Str where tupleMethods = primTupleMethods Sr
instance Tuple Spec where tupleMethods = primTupleMethods Fr
+instance Tuple TabList where tupleMethods = primTupleMethods Kr
+
instance (Tuple a, Tuple b) => Tuple (a, b) where
tupleMethods = TupleMethods fromTuple' toTuple' tupleArity' tupleRates' defTuple'
where
@@ -180,6 +182,7 @@ instance Arg Unit
instance Arg D
instance Arg Str
instance Arg Tab
+instance Arg TabList
instance (Arg a, Arg b) => Arg (a, b)
instance (Arg a, Arg b, Arg c) => Arg (a, b, c)