csound-expression-typed 0.0.9.1 → 0.0.9.2

raw patch · 18 files changed

+702/−66 lines, 18 filesdep ~csound-expression-dynamicPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependency ranges changed: csound-expression-dynamic

API changes (from Hackage documentation)

Files

• csound-expression-typed.cabal +8/−2
• data/opcodes/tabQueue.udo +45/−0
• data/opcodes/tabQueue2.udo +50/−0
• src/Csound/Typed/Control.hs +3/−0
• src/Csound/Typed/Control/Api.hs +178/−0
• src/Csound/Typed/Control/Evt.hs +5/−4
• src/Csound/Typed/Control/Ref.hs +90/−1
• src/Csound/Typed/GlobalState/Elements.hs +84/−13
• src/Csound/Typed/GlobalState/GE.hs +49/−9
• src/Csound/Typed/GlobalState/Instr.hs +0/−1
• src/Csound/Typed/GlobalState/Opcodes.hs +27/−7
• src/Csound/Typed/GlobalState/Options.hs +27/−8
• src/Csound/Typed/GlobalState/SE.hs +5/−3
• src/Csound/Typed/Plugins/TabQueue.hs +48/−0
• src/Csound/Typed/Render.hs +14/−8
• src/Csound/Typed/Types/MixSco.hs +1/−1
• src/Csound/Typed/Types/Prim.hs +65/−9
• src/Csound/Typed/Types/Tuple.hs +3/−0

@@ -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,7 +23,10 @@     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 @@   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 @@     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@@ -84,6 +88,8 @@      Csound.Typed.Lib.StableMaps.Dynamic     Csound.Typed.Lib.StableMaps.Dynamic.Map++    Csound.Typed.Plugins.TabQueue      Paths_csound_expression_typed 

@@ -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

@@ -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

@@ -11,6 +11,8 @@     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.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

@@ -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]

@@ -19,6 +19,7 @@  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 @@              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 @@         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 @@         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 @@  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  ------------------------------------------------------------------- 

@@ -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 @@ 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 @@ 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)

@@ -4,6 +4,7 @@     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 @@     -- * 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 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,15 +77,59 @@ 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  type StringMap = IdMap String@@ -263,11 +312,6 @@ 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 @@ -}  -----------------------------------------------------------------+-- 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 @@ -- 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)+

@@ -9,6 +9,8 @@     MidiCtrl(..), saveMidiCtrl, renderMidiCtrl,     -- * Instruments     saveAlwaysOnInstr, onInstr, saveUserInstr0, getSysExpr,+    -- * Named instruments+    saveNamedInstr,     -- * Total duration     TotalDur(..), pureGetTotalDurForF0, getTotalDurForTerminator,      setDurationForce, setDuration, setDurationToInfinite,    @@ -16,6 +18,7 @@     addNote,     -- * GEN routines     saveGen, saveTabs, getNextGlobalGenId,+    saveWriteGen, saveWriteTab,     -- * Sf2     saveSf, sfTable,     -- * Band-limited waves@@ -31,7 +34,9 @@     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.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 @@      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 @@     , 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 @@  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 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 @@ 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 = 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 @@ 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"]++++

@@ -114,4 +114,3 @@ terminatorInstr = do     ids <- fmap (getInstrIds . instrs) getHistory     return $ fromDep_ $ (mapM_ turnoff2 $ fmap instrIdE ids) >> exitnow-

@@ -7,7 +7,7 @@     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 @@     -- * Hrtf Pan     hrtfmove, hrtfstat,     -- * Read tables-    tableK, tableI+    tableK, tableI,+    -- * Portamento+    port,+    -- * Rate convertion+    downsamp ) where  import Prelude hiding ((<*))@@ -156,8 +160,11 @@  -- trigger +primInstrId :: InstrId -> E+primInstrId = prim . PrimInstrId+ data Event = Event-    { eventInstrId  :: InstrId+    { eventInstrId  :: E     , eventStart    :: E     , eventDur      :: E     , eventArgs     :: [E] }@@ -165,12 +172,15 @@ 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,9 +216,11 @@  -- 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     ihold    @@ -277,10 +289,15 @@  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)] @@ -366,6 +383,9 @@  port :: E -> E -> E port a b = opcs "portk" [(Kr, [Kr, Ir])] [a, b]++downsamp :: E -> E+downsamp a = opcs "downsamp" [(Kr, [Ar])] [a]  ----------------------------------------------------------- 

@@ -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 @@ -- | 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 @@ --   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 @@ -- -- 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,@@ -115,4 +123,15 @@ 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" 

@@ -2,7 +2,7 @@     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 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 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

@@ -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]

@@ -11,13 +11,16 @@ 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 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 @@     renderBandLimited (genMap hist) (bandLimitedMap hist)     userInstr0 hist     chnUpdateUdo+    udos     sf2     guiStmt $ getPanels hist     where

@@ -108,4 +108,4 @@ 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

@@ -4,10 +4,10 @@     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 @@         -- ** 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.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 @@     | 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 @@                   (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,15 +229,24 @@ 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 Str    where def = text "" instance Default Spec   where def = fromE 0  +instance Default TabList where def = fromE 0+ ------------------------------------------------------------------------------- -- monoid @@ -602,6 +620,32 @@ 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) @@ -619,6 +663,18 @@  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

@@ -106,6 +106,8 @@ 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 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)