csound-expression 1.0.4 → 1.1.1

raw patch · 38 files changed

+3141/−1528 lines, 38 filesdep +processdep +stable-mapsPVP ok

version bump matches the API change (PVP)

Dependencies added: process, stable-maps

API changes (from Hackage documentation)

Files

• csound-expression.cabal +33/−10
• examples/Heartbeat.hs +115/−0
• examples/Test.hs +29/−0
• src/Csound/Air.hs +39/−21
• src/Csound/Base.hs +109/−45
• src/Csound/Exp.hs +131/−44
• src/Csound/Exp/Arg.hs +142/−0
• src/Csound/Exp/Cons.hs +25/−50
• src/Csound/Exp/Event.hs +119/−0
• src/Csound/Exp/EventList.hs +47/−0
• src/Csound/Exp/GE.hs +235/−0
• src/Csound/Exp/Gui.hs +11/−0
• src/Csound/Exp/Instr.hs +84/−0
• src/Csound/Exp/Logic.hs +81/−30
• src/Csound/Exp/Mix.hs +153/−0
• src/Csound/Exp/Numeric.hs +69/−81
• src/Csound/Exp/Options.hs +45/−0
• src/Csound/Exp/Ref.hs +50/−0
• src/Csound/Exp/SE.hs +111/−0
• src/Csound/Exp/Tuple.hs +238/−0
• src/Csound/Exp/Widget.hs +129/−0
• src/Csound/Exp/Wrapper.hs +99/−492
• src/Csound/IO.hs +71/−0
• src/Csound/LowLevel.hs +6/−5
• src/Csound/Opcode/Advanced.hs +41/−39
• src/Csound/Opcode/Basic.hs +65/−50
• src/Csound/Opcode/Data.hs +43/−7
• src/Csound/Render.hs +68/−73
• src/Csound/Render/Channel.hs +88/−0
• src/Csound/Render/Instr.hs +105/−102
• src/Csound/Render/Options.hs +13/−70
• src/Csound/Render/Pretty.hs +75/−22
• src/Csound/Render/Sco.hs +0/−120
• src/Csound/Tab.hs +99/−35
• src/Csound/Tfm/DeduceTypes.hs +124/−0
• src/Csound/Tfm/RateGraph.hs +0/−232
• src/Csound/Tfm/Tab.hs +179/−0
• src/Csound/Tfm/UnfoldMultiOuts.hs +70/−0

@@ -1,12 +1,12 @@ Name:          csound-expression-Version:       1.0.4+Version:       1.1.1 Cabal-Version: >= 1.6 License:       BSD3 License-file:  LICENSE Author:	       Anton Kholomiov Synopsis:      library to make electronic music Stability:     Experimental-Tested-With:   GHC==7.4+Tested-With:   GHC==7.6 Build-Type:    Simple Category:      Music, Sound Maintainer:    <anton.kholomiov@gmail.com>@@ -16,7 +16,7 @@     It's very efficient. But sometimes Csound is too low level. So many details: integer identifiers for instruments      and arrays, should I use control rate or audio rate signals, lack of abstractions, no nested expressions and it has limited set of types.      This library embeds Csound in Haskell. It's Csound code generator. We can use powerful Csound's primitives and glue them-    together with Haskell abstractions. Start with the module "Csound.Base". It contains basic types and functions. +    together with Haskell abstractions. Start with the module "Csound.Base". It contains basic types and functions.          .     Key principles     .@@ -37,11 +37,11 @@     .      * Make low level opcode definitions simple. Let user define his own opcodes (if they are missing).     .-    * Make it independent from any Score-generation library. Let user choose his favorite library.-    .     * Ensure that output signal is limited by amplitude. Csound can produce signals with HUGE amplitudes. Little typo can damage your ears      and your speakers. In generated code all signals are clipped by 0dbfs value. 0dbfs is set to 1. Just as in Pure Data. So 1 is absolute maximum value     for amplitude. +    . +    * No dependency on Score-generation libraries. Score (or list of events) is represented with type class. You can use your favorite Score-generation library if you provide an instance for the CsdSco type class. Currently there is support for temporal-music-notation library (see temporal-csound package).     .     For the future     .        @@ -53,8 +53,12 @@     * Timing of events. User can set the beat rate and align events by beat events.     .     * Set Csound flags with meaningful (well-typed) values. Derive as much as you can from the context.+    .+    * Optimization of the memory allocation (liveness analysis).     Extra-Source-Files : +    examples/Test.hs+    examples/Heartbeat.hs  Homepage:        https://github.com/anton-k/csound-expression Bug-Reports:     https://github.com/anton-k/csound-expression/issues@@ -65,8 +69,9 @@   Library+  Ghc-Options:    -Wall   Build-Depends:-        base >= 4, base < 5, containers, array, transformers, wl-pprint,+        base >= 4, base < 5, containers, array, transformers, wl-pprint, stable-maps >= 0.0.3.3, process,         data-default, Boolean >= 0.1.0, data-fix, data-fix-cse   Hs-Source-Dirs:      src/   Exposed-Modules:@@ -82,15 +87,33 @@   Other-Modules:         Csound.Exp                 Csound.Exp.Wrapper+        Csound.Exp.GE+        Csound.Exp.SE+        Csound.Exp.Ref         Csound.Exp.Cons         Csound.Exp.Logic         Csound.Exp.Numeric       -        -        Csound.Tfm.RateGraph-        +        Csound.Exp.Arg+        Csound.Exp.Tuple+        Csound.Exp.Mix+        Csound.Exp.Event+        Csound.Exp.Instr+        Csound.Exp.Gui+        Csound.Exp.Widget+        Csound.Exp.Options+        Csound.Exp.EventList+       +        Csound.IO++        Csound.Tfm.DeduceTypes       +        Csound.Tfm.UnfoldMultiOuts+        Csound.Tfm.Tab       +         Csound.Render         Csound.Render.Pretty         Csound.Render.Options         Csound.Render.Instr-        Csound.Render.Sco     +        Csound.Render.Channel+      + 

@@ -0,0 +1,115 @@+-- The Heartbeat by Julie Friedman (without crackle)+--+-- requires temporal-csound+--+-- > cabal install temporal-csound+module Main where++import Csound++linenIdur :: Sig -> D -> D -> Sig+linenIdur a rise dec = linen a (idur * rise) idur (idur * dec) ++--------------------------------------++crackle amp cps att dec = (a3 * kpan, a3 * (1 - kpan))+    where a1 = k1 * osc (sig cps)+          k1 = linen (sig amp) att idur dec+          kpan = 0.5 * (1 + osc (5 * sig idur))+          a2 = fof a1 (a1 + sig cps) (a1 * sig amp / 50) k1 200 0.003 0.017 0.005 20 f1 f2 cps+          arev = reverb2 a2 5 1+          a3 = 0.2 * (a2 + arev) +          f1 = sines [1] 								            -- SINE WAVE+          f2 = sines [1, 0.5, 0.3, 0.25, 0.2, 0.167, 0.14, 0.111] 	-- SAWTOOTH+++heartbeat :: D -> Sig+heartbeat amp = phi amp 0.0024 f12 + phi amp 0.0078 f13+    where phi amp dec tab = oscili (sig amp * linseg [1, idur, dec]) 4 tab+          f12 = sines2 [(10, 1), (16, 1.5), (22, 2), (23, 1.5)]+          f13 = sines2 [(25, 1), (29, 0.5), (32, 0.2)] +++monoPluck :: D -> D -> D -> D -> Sig+monoPluck amp cps pick plk = a3  +    where repluck' freq a = repluck plk (sig amp) freq (sig pick) 0.5 a           +          a1 = 0.5 * (+                repluck' (cps - 1) (osc $ sig $ cps - 2) +              + repluck' (cps + 1) (osc $ sig $ cps + 2))+          a2 = linenIdur (a1/2) 0.2 0.8+          arev = reverb2 a2 1.5 1+          a3 = (a2 + 0.6 * arev) / 1.6+          ++chorusel amp cps rise dec = (ar1, ar2)+    where k1 = linen (sig amp) rise idur dec+          k2 = linseg [1, idur, 0]+          k3 = kr $ osc 2+          k4 = kr $ 0.5 * osc 2+          inote = cpspch cps+          as = fmap (\(d, a, f) -> k1 * f (sig (inote + d) + a)) [+            (-1, k3, saw),+            (1,  k4, f9),+            (-0.5, 0, f9),+            (0.5, 0, saw),+            (-2, k4, saw),+            (2, k3, f9),+            (-1.5, k3, saw),+            (1.5, k3, f9),+            (-0.25, 0, f9),+            (0.25, 0, saw),+            (-0.8, k4, saw),+            (0.8, k4, f9)]+            +          ars = zipWith3 (\a k d -> withInits (areson a k d) (1::D)) as (k2:(k2*k3):repeat k2) (fmap (sig . double) $ [10, 20 .. 80] ++ [50, 60 .. 80])+          meanArs = (/ 5.5) . sum . fmap (ars !!) +          asig1 = meanArs [0, 3, 5, 7, 8]+          asig2 = meanArs [1, 2, 4, 6, 9]+          asig3 = 0.5 * (ars !! 10 + ars !! 11)          +          +          ar1 = 0.5 * (asig1 + asig3)+          ar2 = 0.5 * (asig2 + asig3)          +                    +          f9 phs = oscil 1 phs $ sines [0.28, 1, 0.74, 0.66, 0.78, 0.48, 0.05, 0.33, 0.12, 0.08, 0.01, 0.54, 0.19, 0.08, 0.05, 0.16, 0.01, 0.11, 0.3, 0.02, 0.2] +          +instr1 :: D -> Sig2+instr1 amp = (a, a)+    where a = 0.8 * heartbeat amp++instrPluck :: (D, D) -> Sig2+instrPluck (amp, pan) = (sig pan * a,  (sig $ 1 - pan) * a)+    where a = monoPluck 0.5 (cpspch 8) 0.8 0.3++instrChorusel :: (D, D, D, D) -> Sig2+instrChorusel (cps, pan, a, b) = chorusel cps pan a b++instrCrackle :: D -> Sig2+instrCrackle cps = crackle (0.5::D) cps 12 20++scoBeat = sco instr1 $ delay 2 $ loop 32 $ line [0.25 *| lineMap temp [0.5, 0.3], rest 1.5]++scoPluck = sco instrPluck $ delay 8 $ line $ take n $ zipWith (\amp pan -> 0.5 *| temp (amp, pan)) +    ([0, (v/40) .. v] ++ repeat v) (cycle [0.2, 0.8])+    where v = 0.6+          dur = 65+          n = floor $ (dur - 8)/0.5+ +scoChorusel = sco instrChorusel $ chord $ unroll =<< [+    (0, 15, (0.4, [7, 7.07, 6, 8], 10, 5)),+    (18, 17, (0.27, [6, 7, 7.07, 8.02, 8.03, 5], 9, 6)),+    (34, 21, (0.35, [6], 8, 8)),+    (40, 15, (0.35, [6.07], 7, 7)),+    (48, 7,  (0.35, [7.05], 3.5, 3.5)),+    (55, 10, (0.35, [7, 8, 7.07, 6], 5, 8))]+    where unroll (t, dur, (amp, cps, rise, dec)) = [delay t $ stretch dur $ temp (amp, c, rise, dec) | c <- cps]+    +scoCrackle = sco instrCrackle $ chord [+    event 8 100,+    delay 13 $ event 5 50]   +   +main = totem $ chord [+    scoBeat, +    scoChorusel, +    scoPluck, +    scoCrackle]+

@@ -0,0 +1,29 @@+module Main where+ +-- imports everything+import Csound.Base++-- Let's define a simple sound unit that +-- reads in cycles the table that contains a single sine partial.+-- oscil1 is the standard oscillator with linear interpolation.+-- 1 - means the amplitude, cps - is cycles per second and the last argument+-- is the table that we want to read. +myOsc :: Sig -> Sig+myOsc cps = oscili 1 cps (sines [1])++-- Let's define a simple instrument that plays a sound on the specified frequency.+-- We use @sig@ to convert a constant value to signal and then plug it in the osc unit. +-- We make it a bit quieter by multiplying with 0.5.+pureTone :: D -> Sig+pureTone cps = 0.5 * (myOsc $ sig cps)++-- Let's trigger the instrument from the score section.+-- It plays a single note that starts at 1 and lasts for 3 seconds and +-- triggers the instrument 'instr' with frequency of 440 (Hz).+-- A function 'temp' always creates a note that starts right away and +-- lasts for 1 second. Then we can 'stretch' this note or 'delay' it.+res = sco pureTone $ CsdEventList 5 [(0, 1, 440), (1, 2, 330), (3, 2, 220)]++-- Renders generated csd-file to the "tmp.csd".+main :: IO ()+main = writeCsd "tmp.csd" res

@@ -3,10 +3,10 @@     -- * Oscillators          -- ** Bipolar-    osc, saw, sq, tri, -- pulse, ramp,+    osc, oscBy, saw, sq, tri, -- pulse, ramp,          -- ** Unipolar-    unipolar, uosc, usaw, usq, utri, -- upulse, uramp,+    unipolar, uosc, uoscBy, usaw, usq, utri, -- upulse, uramp,          -- * Filters     -- | Arguemnts are inversed to get most out of curruing. First come parameters and the last one is the signal.@@ -18,7 +18,7 @@     blp, bhp, bbp, bbr,          -- * Patterns-    once, mean,+    once, several, sine, mean,          -- ** Series     hase, whase,@@ -29,43 +29,49 @@ ) where  import Csound.Exp(Tab)-import Csound.Exp.Wrapper(Sig, Spec, SE, kr)-import Csound.Exp.Cons(withInits)-import Csound.Exp.Numeric-import Csound.Opcode(idur, oscil3, vco, pvscross, +import Csound.Exp.Wrapper(Sig, Spec, sig, kr, Cps)+import Csound.Exp.SE+import Csound.Opcode(idur, oscil3, pvscross,      atone, tone, areson, reson,     buthp, butbp, butlp, butbr)-import Csound.Tab(hifi, sines, guardPoint)+import Csound.Tab(sines)  -------------------------------------------------------------------------- -- oscillators  -- | Pure tone.-osc :: Sig -> Sig+osc :: Cps -> Sig osc cps = oscil3 1 cps (sines [1]) +-- | Oscillates with the given table (cubic interpolation).+oscBy :: Tab -> Cps -> Sig+oscBy tab cps = oscil3 1 cps tab++resolution :: Int resolution = 12  -- | Sawtooth.-saw :: Sig -> Sig+saw :: Cps -> Sig saw cps = oscil3 1 cps (sines $ take resolution $ fmap (1 / ) [1 .. ]) -- vco 1 cps 1 0.5 `withInits` (sines [1])   -- | Square wave.-sq :: Sig -> Sig-sq cps = oscil3 1 cps (sines $ take resolution $ fmap f [1 .. ])-    where f x+sq :: Cps -> Sig+sq cps = oscil3 1 cps (sines $ take resolution $ fmap f [(1::Int) .. ])+    where f :: Int -> Double+          f x             | even x    = 0             | otherwise = 1 / fromIntegral x -- vco 1 cps 2 0.5 `withInits` (sines [1])  -- | Triangle wave.-tri :: Sig -> Sig+tri :: Cps -> Sig tri cps = oscil3 1 cps (sines $ take resolution $ zipWith f (cycle [1, -1]) [1 ..])-    where f a x+    where f :: Double -> Int -> Double+          f a x             | even x    = 0-            | otherwise = a / fromIntegral (x ^ 2)+            | otherwise = a / fromIntegral (x ^ (2::Int)) -- vco 1 cps 3 0.5 `withInits` (sines [1])  {-@@ -93,19 +99,23 @@ unipolar a = 0.5 + 0.5 * a  -- | Unipolar pure tone.-uosc :: Sig -> Sig+uosc :: Cps -> Sig uosc = unipolar . osc +-- | Unipolar 'Csound.Air.oscBy'.+uoscBy :: Tab -> Cps -> Sig+uoscBy tab = unipolar . oscBy tab+ -- | Unipolar sawtooth.-usaw :: Sig -> Sig+usaw :: Cps -> Sig usaw = unipolar . saw  -- | Unipolar square wave.-usq :: Sig -> Sig+usq :: Cps -> Sig usq = unipolar . sq  -- | Unipolar triangle wave.-utri :: Sig -> Sig+utri :: Cps -> Sig utri = unipolar . tri  {-@@ -173,9 +183,17 @@ -------------------------------------------------------------------------- -- patterns +-- | Table for pure sine wave.+sine :: Tab+sine = sines [1]+ -- | Reads table once during the note length.  once :: Tab -> Sig-once a = oscil3 1 (1 / kr idur) a+once a = kr $ oscil3 1 (1 / sig idur) a++-- | Reads table several times during the note length.  +several :: Tab -> Sig -> Sig+several tab rate = kr $ oscil3 1 (rate / sig idur) tab  -- | Mean value. mean :: Fractional a => [a] -> a

@@ -1,7 +1,7 @@ -- | Basic types and functions. -- -- WARNING (for Csound users): the maximum amplitude is 1.0. There is no way to alter it. --- don't define your amplitudes with 9000 or 11000. But the good news are: all signals+-- Don't define your amplitudes with 9000 or 11000. But the good news are: all signals -- are clipped by 1 so that you can not damage your ears and your speakers by a little typo. module Csound.Base(     -- * Introduction to Csound for Haskell users@@ -20,13 +20,13 @@     -- | You don't need to know Csound to use this library.     -- but it's helpful to know the main features of the Csound: how can you create music with Csound in general,      -- what design choices were made, basic features and quirks. Csound belongs to the MUSIC N family -    -- of  programming languages. What does it mean? It means that music is divided in two parts:+    -- of  programming languages. What does it mean? It means that description of the music is divided in two parts:     --     -- 1. Orchestra. User defines instruments     --     -- 2. Scores. User triggers instruments with a list of notes     ---    -- Ab instrument is something that listens to notes and converts them to signals. +    -- An instrument is something that listens to notes and converts them to signals.      -- Note is a tuple: (instrument name, start time, duration, parameters). Parameters cell is     -- a tuple of primitive types: numbers ('Csound.Base.D'), strings ('Csound.Base.Str') and tables or arrays of numbers ("Csound.Tab").     -- @@ -37,29 +37,51 @@     -- But main strength lies in the Orchestra section. Here you can define the timbres for     -- your musical journey. Csound is mostly for making strange sounds. How you can do it?     -- You do it with instruments. An instrument is a sequence of statements that define a flow-graph-    -- for your sound waves. In instrument you can use predefined sound generators and transformers ("Csound.Opcode" and "Csound.Air").+    -- for your sound waves. For an instrument you can use predefined sound generators and transformers ("Csound.Opcode" and "Csound.Air").     --      -- Score/Orchestra division stays in this library too. You define your instruments of the type     --     -- > (Arg a, Out b) => a -> b     ---    -- An instrument is something that converts arguments-like things (tuple of primitive values) to output-like things (list of signals).+    -- An instrument is something that converts arguments-like things (tuple of primitive values) to output-like things (tuple of signals).     ---    -- Later when you are done with orchestra section you can trigger the instruments with the function 'Csound.Base.score'+    -- When you are done with the orchestra section you can trigger the instruments with the function 'Csound.Base.sco'     ---    -- > score :: (Arg a, Out b) => (a -> b) -> [(Double, Double, a)] -> SigOut+    -- > sco :: (Arg a, Out b, CsdSco f) => (a -> b) -> f a -> f (Mix (NoSE b))     ---    -- It takes an instrument and the list of notes for this instrument. I've said that in Csound note contains-    -- four elements. But here it has only three because we define all notes at the time for one instrument.-    -- No need to label instrument with names explicitly. arguments-like thing is something that can be converted-    -- to the tuple of primitive values. There are a lot of predefined instances.+    -- It takes an instrument and the bunch of notes for this instrument. Bunch of notes is represented with @f@-container.+    -- It's parametrized with note type. f belongs to the type class 'Csound.Base.CsdSco'. +    -- This library lets you use your own representation of scores. The default one is+    -- 'Csound.Base.CsdEventList'. It is close to the Csound native representation of the scores (so it is not very+    -- convinient to use it). You can use a package temporal-csound as an alternative.      ---    -- This library doesn't help you with score section that much. Scores are the same as you would write them with Csound.-    -- It's a list of events. Haskell can help you with powerful functions for lists but it's not so convenient as it-    -- can be. It's so on purpose. Csound-expression stays clear from score-generation libraries. But you can use-    -- your favourite library to create complex scores. You can use temporal-music-notation or Haskore or Euterpea.-    -- Any library that can generate the list of events will do. -    --  +    -- The output looks scary but let's try to understand it by bits:+    --+    -- * @CsdSco f => f a@ - you can think of it as a container of some values of type @a@ (every value of type @a@ +    -- starts at some time and lasts for some time in seconds)+    --+    -- * @Mix a@ - is an output of Csound instrument it can be one or several signals ('Csound.Base.Sig' or 'Csound.Base.CsdTuple'). +    --+    -- * @NoSE a@ - it's a tricky part of the output. 'NoSE' means literaly 'no SE'. It tells to the type checker that it can skip +    -- the 'Csound.Base.SE' wrapper from the type 'a' so that @SE a@ becomes just @a@ or @SE (a, SE b, c)@ becomes @(a, b, c)@. +    -- Why should it be? I need 'SE' to deduce the order of the+    -- opcodes that have side effects. I need it within one instrument. But when instrument is rendered I no longer need 'SE' type. +    -- So 'NoSE' lets me drop it from the output type. +    --+    --+    -- If you got used to Csound you can ask -- where is the instrument name in the score? No need to worry about names +    -- they are generated automatically.+    --+    -- In Csound to apply some effect one must use the global variables. There are some instruments that produce signals and write them to+    -- the global variables and there is an instrument that functions as mixer. It's turned on for the whole piece and it reads the global+    -- variables and applies the effects to the sound and finally writes it to the file or to the speakers. In this library it's very easy+    -- to apply an effect to the outputs of the instruments. There is a function 'Csound.Base.mix':+    --+    -- > mix :: (Out a, Out b, CsdSco f) => (a -> b) -> f (Mix a) -> f (Mix (NoSE a))+    --+    -- Looks like the function 'Csound.Base.sco'. But now the first argument is an effect. It takes not a note but a signal (or a tuple of signals)+    -- and gives back some signal. The second argument holds the sound that we'd like to apply the effect to. With this function we can apply reverb or+    -- adjust the gain levels or apply some envelope, any valid csound transformation will do.           -- ** Flags and options     @@ -93,19 +115,16 @@     -- at control rate, write:     --     -- > env = ar $ linseg [0, idur/2, 1, idur/2, 0]-    ---    -- Constants are converted to signals with them also.          -- *** Table size          -- | For speed table size should be the power of two or power of two plus one (all tables for oscillators). -    -- In this library you can specify the relative size (see 'Csound.Base.Adoptions').+    -- In this library you can specify the relative size (see 'Csound.Base.CsdOptions').     -- I've tried to hide the size definition to make sings easier.               -- ** How to read the Csound docs     -    -- | I'm to lazy to rewrite the Csound docs for all opcodes so you'd better get acquainted with Csound docs.-    -- Docs are very good. How to read them? For instance you want to use an oscillator with cubic interpolation +    -- | You'd better get acquainted with Csound docs. Docs are very good. How to read them? For instance you want to use an oscillator with cubic interpolation      -- so you dig into the "Csound.Opcode.Basic" and find the function:     --     -- > oscil3 :: Sig -> Sig -> Tab -> Sig@@ -170,19 +189,20 @@     -- > myOsc cps = oscili 1 cps (sines [1])     -- >      -- > -- Let's define a simple instrument that plays a sound on the specified frequency.-    -- > -- We use kr to convert a constant value to signal and then plug it in the osc unit. +    -- > -- We use sig to convert a constant value to signal and then plug it in the osc unit.      -- > -- We make it a bit quieter by multiplying with 0.5.     -- > pureTone :: D -> Sig-    -- > pureTone cps = 0.5 * (myOsc $ kr cps)+    -- > pureTone cps = 0.5 * (myOsc $ sig cps)     -- >      -- > -- Let's trigger the instrument from the score section.-    -- > -- It plays a single note that starts at 0 and lasts for 1 second and -    -- > -- triggers the instrument 'instr' with frequency of 440 (Hz).-    -- > res = score pureTone [(0, 1, 440)]+    -- > -- It plays a three notes. One starts at 0 and lasts for one second with frequency of 440,+    -- another one starts at 1 second and lasts for 2 seconds, and the last note lasts for 2 seconds+    -- at the frequency 220 Hz. +    -- > res = sco pureTone $ CsdEventList 5 [(0, 1, 440), (1, 2, 330), (3, 2, 220)]     -- >      -- > -- Renders generated csd-file to the "tmp.csd".     -- > main :: IO ()-    -- > main = writeFile "tmp.csd" $ renderCsd [res]+    -- > main = writeCsd "tmp.csd" res     --     -- Now you can invoke Csound on tmp.csd and listen to the result with your favourite player.     --@@ -191,6 +211,14 @@     -- That's it @csound@ is a separate program that we have to run to compile our csd-files to sounds.     -- We can listen to the sound as it runs. It can be configured with flags.     +    -- ** More examples+    +    -- | You can find many examples at:+    --+    -- * A translation of the Amsterdam catalog of Csound computer instruments: <https://github.com/anton-k/amsterdam>+    --+    -- * Csound expression Tutorial at (TODO).+             -- ** References          -- | Got interested in Csound? Csound is very well documented. There are good tutorials, read about it at:@@ -199,14 +227,14 @@     --     -- * Floss tutorials: <http://en.flossmanuals.net/csound/>     ---    -- * Amsterdam Csound catalog: <http://www.music.buffalo.edu/hiller/accci/>+    -- * Amsterdam catalog of Csound computer instruments: <http://www.codemist.co.uk/AmsterdamCatalog/>     --     -- * Lots of wonderful real-time examples by Iain McCurdy: <http://iainmccurdy.org/csound.html>     --     -- * Outdated but short manual on Csound <http://cara.gsu.edu/courses/csound_users_seminar/csound/3.46/CsIntro.html>         -- * Types-    Val,+    Val, arity,          -- ** Constants          -- | A constant value doesn't change while instrument is playing a note.@@ -238,29 +266,48 @@     CsdTuple,          -- ** Converters-    ToSig(..), ir, double, str,          +    ToSig(..), ar, kr, ir, sig, double, str,                        -- * Making a sound          -- | Let's make some noise. Sound is build from list of tracks ('SigOut').-    Out, SigOut, effect, +    Out,          -- ** Handy short-cuts-    Outs, Sig2, Sig3, Sig4,+    Sig2, Sig3, Sig4, Ksig, Amp, Cps, Iamp, Icps,           -- ** Scores     -- | We can define an instrument and tell it to play some notes.-    score, Arg(..), ArgMethods, makeArgMethods,+    Arg(..), ArgMethods, makeArgMethods,+    Mix, sco, mix, CsdEvent, CsdEventList(..), CsdSco(..),+    +    -- ** Effects+    effect, effectS,      -- ** Midi     -- | We can define a midi-instrument. Then we can trigger the instrument with a midi-keyboard.-    Msg, massign, pgmassign,+    --Msg, midi, pgmidi,      -- ** Rendering     -- | Now we are ready to create a csound-file. The function 'renderCsd' creates a 'String' that     -- contains the description of our music. We can save it to a file and compile it with our @csound@     -- wizard. -    renderCsd,+    renderCsd, writeCsd, playCsd,+    +    -- *** Players (Linux)+    -- | Handy short-cuts for function 'Csound.Base.playCsd'.+    mplayer, totem, +    +    -- *** Players (Windows)+    -- | Handy short-cuts for function 'Csound.Base.playCsd'.+    --+    -- TODO (you can send me your definitions)++    -- *** Players (OS X)+    -- | Handy short-cuts for function 'Csound.Base.playCsd'.+    --+    -- TODO (you can send me your definitions)+         -- ** Opcodes         -- | Some colors to paint our soundscapes.@@ -272,26 +319,43 @@      -- ** Options     -- | We can set some csound options.-    renderCsdBy,    -    Channel, CtrlId, CsdOptions(..), module Data.Default, mixing, mixingBy+    Channel, CtrlId, CsdOptions(..), module Data.Default,+        +    renderCsdBy, writeCsdBy, playCsdBy,  +    +    -- *** Players (Linux)+    -- | Handy short-cuts for function 'Csound.Base.playCsdBy'.+    mplayerBy, totemBy+    +    +    -- *** Players (Windows)+    -- | Handy short-cuts for function 'Csound.Base.playCsd'.+    --+    -- TODO (you can send me your definitions)++    -- *** Players (OS X)+    -- | Handy short-cuts for function 'Csound.Base.playCsd'.+    --+    -- TODO (you can send me your definitions) ) where  import Data.Default import Data.Boolean- import Csound.Air   import Csound.Exp import Csound.Exp.Cons import Csound.Exp.Wrapper+import Csound.Exp.Tuple+import Csound.Exp.Arg import Csound.Tab-import Csound.Opcode-import Csound.Exp.Numeric import Csound.Exp.Logic--import Csound.Render.Sco-import Csound.Render.Options-import Csound.Render+import Csound.Exp.SE+import Csound.Exp.Options+import Csound.Exp.Mix+import Csound.Exp.EventList +import Csound.Opcode+import Csound.IO  

@@ -1,16 +1,18 @@+-- | Main types {-# Language DeriveFunctor, DeriveFoldable, DeriveTraversable #-} module Csound.Exp(-    E, RatedExp(..), RatedVar(..), onExp, Exp, toPrimOr, PrimOr(..), MainExp(..), Name,-    VarType(..), Var(..), Info(..), OpcType(..), Rate(..), +    E, RatedExp(..), RatedVar, ratedVar, ratedVarRate, ratedVarId, Exp, toPrimOr, PrimOr(..), MainExp(..), Name, +    InstrId(..), intInstrId, ratioInstrId,+    VarType(..), Var(..), Info(..), OpcFixity(..), Rate(..),      Signature(..), isProcedure, isInfix, isPrefix,    -    Prim(..), LowTab(..), Tab(..), TabSize(..), TabArgs(..), TabMap,+    Prim(..), LowTab(..), Tab(..), TabSize(..), TabArgs(..), TabMap, TabFi(..),     Inline(..), InlineExp(..), PreInline(..),     BoolExp, CondInfo, CondOp(..), isTrue, isFalse,    -    NumExp, NumOp(..), Msg(..), Note, Event(..), eventEnd,   +    NumExp, NumOp(..), Msg(..), Note,    +    StringMap ) where  import Control.Applicative-import Data.Monoid import Data.Traversable import Data.Foldable hiding (concat) @@ -21,54 +23,94 @@ import qualified Data.Map    as M import Data.Fix --- | The inner representation of csound expressions.-type E = Fix RatedExp+import qualified Csound.Tfm.DeduceTypes as R(Var(..))   type Name = String +data InstrId = InstrId +    { instrIdFrac :: Maybe Int+    , instrIdCeil :: Int +    } deriving (Show, Eq, Ord)++intInstrId :: Int -> InstrId+intInstrId n = InstrId Nothing n++ratioInstrId :: Int -> Int -> InstrId+ratioInstrId beforeDot afterDot = InstrId (Just $ afterDot) beforeDot++-- | The inner representation of csound expressions.+type E = Fix RatedExp+ data RatedExp a = RatedExp -    { ratedExpRate      :: Maybe Rate-    , ratedExpDepends   :: Maybe a-    , ratedExpExp       :: Exp a+    { ratedExpRate      :: Maybe Rate       +        -- ^ Rate (can be undefined or Nothing, +        -- it means that rate should be deduced automatically from the context)+    , ratedExpDepends   :: Maybe a          +        -- ^ Dependency (it is used for expressions with side effects,+        -- value contains the privious statement)+    , ratedExpExp       :: Exp a    +        -- ^ Main expression     } deriving (Show, Eq, Ord, Functor, Foldable, Traversable) -data RatedVar = RatedVar -    { ratedVarRate :: Rate -    , ratedVarId   :: Int -    } deriving (Show)+-- | RatedVar is for pretty printing of the wiring ports.+type RatedVar = R.Var Rate -onExp :: (Exp a -> Exp a) -> RatedExp a -> RatedExp a-onExp f a = a{ ratedExpExp = f (ratedExpExp a) }+ratedVar :: Rate -> Int -> RatedVar+ratedVar     = flip R.Var -data VarType = LocalVar | GlobalVar-    deriving (Show, Eq, Ord)+ratedVarRate :: RatedVar -> Rate+ratedVarRate = R.varType -type Exp a = MainExp (PrimOr a)+ratedVarId :: RatedVar -> Int+ratedVarId   = R.varId +-- | It's a primitive value or something else. It's used for inlining+-- of the constants (primitive values).+newtype PrimOr a = PrimOr { unPrimOr :: Either Prim a }+    deriving (Show, Eq, Ord, Functor)++-- | Constructs PrimOr values from the expressions. It does inlining in+-- case of primitive values. toPrimOr :: E -> PrimOr E toPrimOr a = PrimOr $ case ratedExpExp $ unFix a of     ExpPrim (PString _) -> Right a     ExpPrim p -> Left p     _         -> Right a -newtype PrimOr a = PrimOr { unPrimOr :: Either Prim a }-    deriving (Show, Eq, Ord, Functor)+-- Expressions with inlining.+type Exp a = MainExp (PrimOr a) +-- Csound expressions data MainExp a +    -- | Primitives     = ExpPrim Prim+    -- | Application of the opcode: we have opcode information (Info) and the arguments [a]      | Tfm Info [a]+    -- | Rate conversion     | ConvertRate Rate Rate a+    -- | Selects a cell from the tuple, here argument is always a tuple (result of opcode that returns several outputs)     | Select Rate Int a+    -- | if-then-else     | If (CondInfo a) a a    +    -- | Boolean expressions (rendered in infix notation in the Csound)     | ExpBool (BoolExp a)+    -- | Numerical expressions (rendered in infix notation in the Csound)     | ExpNum (NumExp a)+    -- | Reading/writing a named variable+    | InitVar Var a     | ReadVar Var     | WriteVar Var a    +    -- | Imperative If-then-else+    | IfBegin a+    | ElseIfBegin a+    | ElseBegin+    | IfEnd     deriving (Show, Eq, Ord, Functor, Foldable, Traversable)   +-- Named variable data Var      = Var-        { varType :: VarType+        { varType :: VarType    -- global / local         , varRate :: Rate         , varName :: Name }      | VarVerbatim @@ -76,51 +118,83 @@         , varName :: Name                 } deriving (Show, Eq, Ord)                +-- Variables can be global (then we have to prefix them with `g` in the rendering) or local.+data VarType = LocalVar | GlobalVar+    deriving (Show, Eq, Ord) +-- Opcode information. data Info = Info +    -- Opcode name     { infoName          :: Name     +    -- Opcode type signature     , infoSignature     :: Signature-    , infoOpcType       :: OpcType+    -- Opcode can be infix or prefix+    , infoOpcFixity     :: OpcFixity     , infoNextSE        :: Maybe Int     } deriving (Show, Eq, Ord)               isPrefix, isInfix, isProcedure :: Info -> Bool -isPrefix = (Prefix ==) . infoOpcType-isInfix  = (Infix  ==) . infoOpcType-isProcedure = (Procedure ==) . infoOpcType-  -data OpcType = Prefix | Infix | Procedure+isPrefix = (Prefix ==) . infoOpcFixity+isInfix  = (Infix  ==) . infoOpcFixity+isProcedure = (Procedure ==) . infoOpcFixity+ +-- Opcode fixity+data OpcFixity = Prefix | Infix | Procedure     deriving (Show, Eq, Ord)  -- | The Csound rates.-data Rate = Xr | Ar | Kr | Ir | Sr | Fr+data Rate   -- rate:+    ----------------------------+    = Xr    -- audio or control (and I use it for opcodes that produce no output, ie procedures)+    | Ar    -- audio +    | Kr    -- control +    | Ir    -- init (constants)    +    | Sr    -- strings+    | Fr    -- spectrum (for pvs opcodes)     deriving (Show, Eq, Ord, Enum, Bounded)     +-- Opcode type signature. Opcodes can produce single output (SingleRate) or multiple outputs (MultiRate).+-- In Csound opcodes are often have several signatures. That is one opcode name can produce signals of the +-- different rate (it depends on the type of the outputs). Here we assume (to make things easier) that+-- opcodes that MultiRate-opcodes can produce only the arguments of the same type.  data Signature -    = SingleRate (Map Rate [Rate])+    -- For SingleRate-opcodes type signature is the Map from output rate to the rate of the arguments.+    -- With it we can deduce the type of the argument from the type of the output.+    = SingleRate (Map Rate [Rate]) +    -- For MultiRate-opcodes Map degenerates to the singleton. We have only one link. +    -- It contains rates for outputs and inputs.     | MultiRate          { outMultiRate :: [Rate]          , inMultiRate  :: [Rate] }      deriving (Show, Eq, Ord)- ++-- Primitive values data Prim +    -- instrument p-arguments     = P Int      | PString Int       -- >> p-string:      | PrimInt Int      | PrimDouble Double -    | PrimTab (Either Tab LowTab)     | PrimString String +    | PrimInstrId InstrId+    -- Here we use Tab and well LowTab. Tab contains no size. It is deduced +    -- from the renderer settings.+    | PrimTab (Either Tab LowTab)     deriving (Show, Eq, Ord)-   ++-- Map from tables to unique identifiers. type TabMap = M.Map LowTab Int +-- Table that has all parameters calculated. data LowTab = LowTab      { lowTabSize    :: Int     , lowTabGen     :: Int     , lowTabArgs    :: [Double]     } deriving (Show, Eq, Ord) +-- Table that can have relative size (to be defined from the renderer settings).+ -- | Csound f-tables. You can make a value of 'Tab' with the function 'Csound.Tab.gen' or -- use more higher level functions. data Tab @@ -136,32 +210,40 @@         { hasGuardPoint = False         , sizeDegree = 0 } +-- Table size. data TabSize +    -- Size is fixed by the user.     = SizePlain Int+    -- Size is relative to the renderer settings.     | SizeDegree      { hasGuardPoint :: Bool-    , sizeDegree    :: Int +    , sizeDegree    :: Int      -- is the power of two     } deriving (Show, Eq, Ord)     +-- Table arguments can be data TabArgs +    -- absolute     = ArgsPlain [Double]+    -- or relative to the table size (used for tables that implement interpolation)     | ArgsRelative [Double]     deriving (Show, Eq, Ord) ++-- | Table size fidelity (how many points in the table by default).+data TabFi = TabFi+    { tabFiBase   :: Int+    , tabFiGens   :: IM.IntMap Int }+ -- | Midi messages. data Msg = Msg +-- Csound note type Note = [Prim] -data Event a = Event -    { eventStart :: Double-    , eventDur   :: Double-    , eventContent :: a }-    -eventEnd e = eventStart e + eventDur e+---------------------------------------------------------+-- Strings  -instance Functor Event where-    fmap f a = a{ eventContent = f $ eventContent a }+type StringMap = M.Map String Int  ------------------------------------------------------------ -- types for arithmetic and boolean expressions@@ -171,11 +253,13 @@     , inlineEnv :: IM.IntMap b         } deriving (Show, Eq, Ord, Functor, Foldable, Traversable) +-- Inlined expression.  data InlineExp a     = InlinePrim Int     | InlineExp a [InlineExp a]     deriving (Show, Eq, Ord) +-- Expression as a tree (to be inlined) data PreInline a b = PreInline a [b]     deriving (Show, Eq, Ord, Functor, Foldable, Traversable) @@ -184,8 +268,9 @@ type BoolExp a = PreInline CondOp a type CondInfo a = Inline CondOp a +-- Conditional operators data CondOp  -    = TrueOp | FalseOp | Not | And | Or+    = TrueOp | FalseOp | And | Or     | Equals | NotEquals | Less | Greater | LessEquals | GreaterEquals     deriving (Show, Eq, Ord)     @@ -194,6 +279,7 @@ isTrue  = isCondOp TrueOp isFalse = isCondOp FalseOp +isCondOp :: CondOp -> CondInfo a -> Bool isCondOp op = maybe False (op == ) . getCondInfoOp  getCondInfoOp :: CondInfo a -> Maybe CondOp@@ -201,7 +287,7 @@     InlineExp op _ -> Just op     _ -> Nothing --- numbers+-- Numeric expressions (or Csound infix operators)  type NumExp a = PreInline NumOp a @@ -224,6 +310,7 @@     traverse f x = case unPrimOr x of         Left  p -> pure $ PrimOr $ Left p         Right a -> PrimOr . Right <$> f a+  -- comments -- 

@@ -0,0 +1,142 @@+-- | instrument p-arguments+module Csound.Exp.Arg(        +    Arg(..), arg, toNote, arity, +    ArgMethods, toArg, makeArgMethods,+) where++import Control.Applicative++import Csound.Exp+import Csound.Exp.Wrapper(Val, toExp, D, Str, p)++------------------------------------------------+-- basic extractor++getPrimUnsafe :: Val a => a -> Prim+getPrimUnsafe x = case toExp x of+    ExpPrim a -> a+    _ -> error "Arg.hs:getPrimUnsafe - value is not prim"++-- | The abstract type of methods for the class 'Arg'.+data ArgMethods a = ArgMethods +    { arg_    :: Int -> a+    , toNote_ :: a -> [Prim]+    , arity_  :: a -> Int }++arg :: Arg a => Int -> a+arg = arg_ argMethods++toNote :: Arg a => a -> [Prim]+toNote = toNote_ argMethods++arity :: Arg a => a -> Int+arity = arity_ argMethods++toArg :: Arg a => a+toArg = arg 4++-- | Defines instance of type class 'Arg' for a new type in terms of an already defined one.+makeArgMethods :: (Arg a) => (a -> b) -> (b -> a) -> ArgMethods b+makeArgMethods to from = ArgMethods {+    arg_ = to . arg,+    toNote_ = toNote . from,+    arity_ = const $ arity $ proxy to }+    where proxy :: (a -> b) -> a+          proxy = undefined++-- | Describes all Csound values that can be used in the score section. +-- Instruments are triggered with the values from this type class.+-- Actual methods are hidden, but you can easily make instances for your own types+-- with function 'makeArgMethods'. You need to describe the new instance in  terms +-- of some existing one. For example:+--+-- > data Note = Note +-- >     { noteAmplitude    :: D+-- >     , notePitch        :: D+-- >     , noteVibrato      :: D+-- >     , noteSample       :: S+-- >     }+-- > +-- > instance Arg Note where+-- >     argMethods = makeArgMethods to from+-- >         where to (amp, pch, vibr, sample) = Note amp pch vibr sample+-- >               from (Note amp pch vibr sample) = (amp, pch, vibr, sample)+-- +-- Then you can use this type in an instrument definition.+-- +-- > instr :: Note -> Out+-- > instr x = ...++class Arg a where+    argMethods :: ArgMethods a++instance Arg () where+    argMethods = ArgMethods +        { arg_ = const ()+        , toNote_ = const []+        , arity_ = const 0 }++instance Arg InstrId where+    argMethods = ArgMethods +        { arg_ = error "method arg is undefined for InstrId"+        , toNote_ = pure . PrimInstrId+        , arity_ = const 0 }++instance Arg D where+    argMethods = ArgMethods {+        arg_ = p,+        toNote_ = pure . getPrimUnsafe,+        arity_ = const 1 }++instance Arg Str where+    argMethods = ArgMethods {+        arg_ = p,+        toNote_ = pure . getPrimUnsafe,+        arity_ = const 1 }++instance Arg Tab where+    argMethods = ArgMethods {+        arg_ = p,+        toNote_ = pure . getPrimUnsafe,+        arity_ = const 1 }++instance (Arg a, Arg b) => Arg (a, b) where+    argMethods = ArgMethods arg' toNote' arity' +        where arg' n = (a, b)+                  where a = arg n+                        b = arg (n + arity a)+              toNote' (a, b) = toNote a ++ toNote b+              arity' x = let (a, b) = proxy x in arity a + arity b    +                  where proxy :: (a, b) -> (a, b)+                        proxy = const (undefined, undefined)++instance (Arg a, Arg b, Arg c) => Arg (a, b, c) where+    argMethods = makeArgMethods to from+        where to (a, (b, c)) = (a, b, c)+              from (a, b, c) = (a, (b, c))++instance (Arg a, Arg b, Arg c, Arg d) => Arg (a, b, c, d) where+    argMethods = makeArgMethods to from+        where to (a, (b, c, d)) = (a, b, c, d)+              from (a, b, c, d) = (a, (b, c, d))++instance (Arg a, Arg b, Arg c, Arg d, Arg e) => Arg (a, b, c, d, e) where+    argMethods = makeArgMethods to from+        where to (a, (b, c, d, e)) = (a, b, c, d, e)+              from (a, b, c, d, e) = (a, (b, c, d, e))++instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f) => Arg (a, b, c, d, e, f) where+    argMethods = makeArgMethods to from+        where to (a, (b, c, d, e, f)) = (a, b, c, d, e, f)+              from (a, b, c, d, e, f) = (a, (b, c, d, e, f))++instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f, Arg g) => Arg (a, b, c, d, e, f, g) where+    argMethods = makeArgMethods to from+        where to (a, (b, c, d, e, f, g)) = (a, b, c, d, e, f, g)+              from (a, b, c, d, e, f, g) = (a, (b, c, d, e, f, g))++instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f, Arg g, Arg h) => Arg (a, b, c, d, e, f, g, h) where+    argMethods = makeArgMethods to from+        where to (a, (b, c, d, e, f, g, h)) = (a, b, c, d, e, f, g, h)+              from (a, b, c, d, e, f, g, h) = (a, (b, c, d, e, f, g, h))+

@@ -1,45 +1,27 @@+-- |  Constructors module Csound.Exp.Cons (     Spec1, Specs,-    toE, fromE,     withInits,     bi,+    spec1, specs,     opcs, opc0, opc1, opc2, opc3, opc4, opc5, opc6, opc7, opc8, opc9, opc10, opc11, opc12,     mopcs, mopc0, mopc1, mopc2, mopc3, mopc4, mopc5, mopc6, mopc7 ) where -import Data.String-import Control.Applicative-import Data.Default-import qualified Data.Map as M-import Control.Monad.Trans.State--import Data.Fix+import qualified Data.Map as M(fromList)  import Csound.Exp-import Csound.Exp.Wrapper---- | Converts a value to the private representation.-toE :: Val a => a -> E-toE = Fix . unwrap---- | Constructs a value from the private representation.-fromE :: Val a => E -> a-fromE = wrap . unFix+import Csound.Exp.Wrapper(Sig, Val(..), tfm, pref, onExp)+import Csound.Exp.Tuple(CsdTuple, fromCsdTuple, multiOuts)  -- | Appends initialisation arguments. It's up to you to supply arguments with the right types. For example: -- -- > oscil 0.5 440 sinWave `withInits` (0.5 :: D) withInits :: (Val a, CsdTuple inits) => a -> inits -> Sig-withInits a b = wrap $ onExp phi $ unwrap a+withInits a b = fromE $ onExp phi $ toE a     where phi x = case x of             Tfm t xs -> Tfm t (xs ++ (fmap toPrimOr $ fromCsdTuple b))-            x        -> x----------------------------------------------------- helper constructors--instance IsString Str where-    fromString = str+            _        -> x  ------------------------------------------------ -- constructor for simple arithmetic operators@@ -53,60 +35,55 @@     (Kr, [Kr, Kr]),     (Ir, [Ir, Ir])] -idSignature :: Spec1-idSignature = [-    (Ar, repeat Ar),-    (Kr, repeat Kr),-    (Ir, repeat Ir)]- ------------------------------- spec tfms+-- constructors for opcodes (single or multiple rates)  tfms :: (Val a, Val b) => Info -> [a] -> b-tfms t as = tfm t $ map unwrap as+tfms t as = tfm t $ map toE as  tfm0 :: (Val a) => Info -> a tfm0 t = tfm t []  tfm1 :: (Val a, Val b) => Info -> a -> b-tfm1 t a = tfm t [unwrap a]+tfm1 t a = tfm t [toE a]  tfm2 :: (Val a1, Val a2, Val b) => Info -> a1 -> a2 -> b-tfm2 t a1 a2 = tfm t [unwrap a1, unwrap a2]+tfm2 t a1 a2 = tfm t [toE a1, toE a2]  tfm3 :: (Val a1, Val a2, Val a3, Val b) => Info -> a1 -> a2 -> a3 -> b-tfm3 t a1 a2 a3 = tfm t [unwrap a1, unwrap a2, unwrap a3]+tfm3 t a1 a2 a3 = tfm t [toE a1, toE a2, toE a3]  tfm4 :: (Val a1, Val a2, Val a3, Val a4, Val b) => Info -> a1 -> a2 -> a3 -> a4 -> b-tfm4 t a1 a2 a3 a4 = tfm t [unwrap a1, unwrap a2, unwrap a3, unwrap a4]+tfm4 t a1 a2 a3 a4 = tfm t [toE a1, toE a2, toE a3, toE a4]  tfm5 :: (Val a1, Val a2, Val a3, Val a4, Val a5, Val b) => Info -> a1 -> a2 -> a3 -> a4 -> a5 -> b-tfm5 t a1 a2 a3 a4 a5 = tfm t [unwrap a1, unwrap a2, unwrap a3, unwrap a4, unwrap a5]+tfm5 t a1 a2 a3 a4 a5 = tfm t [toE a1, toE a2, toE a3, toE a4, toE a5]  tfm6 :: (Val a1, Val a2, Val a3, Val a4, Val a5, Val a6, Val b) => Info -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> b-tfm6 t a1 a2 a3 a4 a5 a6 = tfm t [unwrap a1, unwrap a2, unwrap a3, unwrap a4, unwrap a5, unwrap a6]+tfm6 t a1 a2 a3 a4 a5 a6 = tfm t [toE a1, toE a2, toE a3, toE a4, toE a5, toE a6]  tfm7 :: (Val a1, Val a2, Val a3, Val a4, Val a5, Val a6, Val a7, Val b) => Info -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> b-tfm7 t a1 a2 a3 a4 a5 a6 a7 = tfm t [unwrap a1, unwrap a2, unwrap a3, unwrap a4, unwrap a5, unwrap a6, unwrap a7]+tfm7 t a1 a2 a3 a4 a5 a6 a7 = tfm t [toE a1, toE a2, toE a3, toE a4, toE a5, toE a6, toE a7]  tfm8 :: (Val a1, Val a2, Val a3, Val a4, Val a5, Val a6, Val a7, Val a8, Val b) => Info -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> b-tfm8 t a1 a2 a3 a4 a5 a6 a7 a8 = tfm t [unwrap a1, unwrap a2, unwrap a3, unwrap a4, unwrap a5, unwrap a6, unwrap a7, unwrap a8]+tfm8 t a1 a2 a3 a4 a5 a6 a7 a8 = tfm t [toE a1, toE a2, toE a3, toE a4, toE a5, toE a6, toE a7, toE a8]  tfm9 :: (Val a1, Val a2, Val a3, Val a4, Val a5, Val a6, Val a7, Val a8, Val a9, Val b) => Info -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> b-tfm9 t a1 a2 a3 a4 a5 a6 a7 a8 a9 = tfm t [unwrap a1, unwrap a2, unwrap a3, unwrap a4, unwrap a5, unwrap a6, unwrap a7, unwrap a8, unwrap a9]+tfm9 t a1 a2 a3 a4 a5 a6 a7 a8 a9 = tfm t [toE a1, toE a2, toE a3, toE a4, toE a5, toE a6, toE a7, toE a8, toE a9]  tfm10 :: (Val a1, Val a2, Val a3, Val a4, Val a5, Val a6, Val a7, Val a8, Val a9, Val a10, Val b) => Info -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> b-tfm10 t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 = tfm t [unwrap a1, unwrap a2, unwrap a3, unwrap a4, unwrap a5, unwrap a6, unwrap a7, unwrap a8, unwrap a9, unwrap a10]+tfm10 t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 = tfm t [toE a1, toE a2, toE a3, toE a4, toE a5, toE a6, toE a7, toE a8, toE a9, toE a10]  tfm11 :: (Val a1, Val a2, Val a3, Val a4, Val a5, Val a6, Val a7, Val a8, Val a9, Val a10, Val a11, Val b) => Info -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> b-tfm11 t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 = tfm t [unwrap a1, unwrap a2, unwrap a3, unwrap a4, unwrap a5, unwrap a6, unwrap a7, unwrap a8, unwrap a9, unwrap a10, unwrap a11]+tfm11 t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 = tfm t [toE a1, toE a2, toE a3, toE a4, toE a5, toE a6, toE a7, toE a8, toE a9, toE a10, toE a11]  tfm12 :: (Val a1, Val a2, Val a3, Val a4, Val a5, Val a6, Val a7, Val a8, Val a9, Val a10, Val a11, Val a12, Val b) => Info -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> a8 -> a9 -> a10 -> a11 -> a12 -> b-tfm12 t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = tfm t [unwrap a1, unwrap a2, unwrap a3, unwrap a4, unwrap a5, unwrap a6, unwrap a7, unwrap a8, unwrap a9, unwrap a10, unwrap a11, unwrap a12]+tfm12 t a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = tfm t [toE a1, toE a2, toE a3, toE a4, toE a5, toE a6, toE a7, toE a8, toE a9, toE a10, toE a11, toE a12]  ---------------------------------- single out+-- single output +-- User friendly type for single output type signatures type Spec1 = [(Rate, [Rate])]  spec1 :: Spec1 -> Signature@@ -156,8 +133,9 @@   ---------------------------------- multiple outs+-- multiple outputs +-- User friendly type for multiple outputs type signatures type Specs = ([Rate], [Rate])  specs :: Specs -> Signature@@ -192,7 +170,4 @@  mopc7 :: (Val a1, Val a2, Val a3, Val a4, Val a5, Val a6, Val a7, CsdTuple b) => Name -> Specs -> a1 -> a2 -> a3 -> a4 -> a5 -> a6 -> a7 -> b mopc7 name signature a1 a2 a3 a4 a5 a6 a7 = mo $ tfm7 (pref name $ specs signature) a1 a2 a3 a4 a5 a6 a7--- 

@@ -0,0 +1,119 @@+{-# Language TypeFamilies, FlexibleContexts #-}+module Csound.Exp.Event(+    Evt(..), Trig, Snap,+    trigger, filterEvt, accumEvt, snapshot,+    stepper, schedule, toggle+) where++import Data.Monoid++import Csound.Exp+import Csound.Exp.Wrapper+import Csound.Exp.Logic+import Csound.Exp.Tuple+import Csound.Exp.Arg+import Csound.Exp.GE+import Csound.Exp.SE+import Csound.Exp.Ref+import Csound.Exp.Instr++import Csound.Render.Channel(event, instrOn, instrOff)++type Bam a = a -> SE ()+type Trig = Evt ()++newtype Evt a = Evt { runEvt :: Bam a -> SE () }++trigger :: BoolSig -> Evt ()+trigger cond = Evt $ \bam -> when cond $ bam ()++instance Functor Evt where+    fmap f evt = Evt $ \bam -> runEvt evt (bam . f)++instance Monoid (Evt a) where+    mempty = Evt $ const $ return ()+    mappend a b = Evt $ \bam -> runEvt a bam >> runEvt b bam++filterEvt :: (a -> BoolD) -> Evt a -> Evt a+filterEvt cond evt = Evt $ \bam -> runEvt evt $ \a ->+    when (toBoolSig $ cond a) $ bam a++accumEvt :: (CsdTuple s) => s -> (a -> s -> (b, s)) -> Evt a -> Evt b+accumEvt s0 update evt = Evt $ \bam -> do+    (readSt, writeSt) <- sensorsSE s0+    runEvt evt $ \a -> do+        s1 <- readSt+        let (b, s2) = update a s1+        writeSt s2+        bam b++snapshot :: (CsdTuple a) => (Snap a -> b -> c) -> a -> Evt b -> Evt c+snapshot f asig evt = Evt $ \bam -> runEvt evt $ \a -> +    bam (f (readSnap asig) a)++toBoolSig :: BoolD -> BoolSig+toBoolSig = undefined++readSnap :: CsdTuple a => a -> Snap a+readSnap = undefined++-------------------------------------------------------------------+-- snap ++type family Snap a :: *++type instance Snap D   = D+type instance Snap Str = Str+type instance Snap Tab = Tab++type instance Snap Sig = D++type instance Snap (a, b) = (Snap a, Snap b)+type instance Snap (a, b, c) = (Snap a, Snap b, Snap c)+type instance Snap (a, b, c, d) = (Snap a, Snap b, Snap c, Snap d)++--------------------------------------------------+--++evtToBool :: Evt a -> SE BoolSig+evtToBool = undefined++stepper :: CsdTuple a => a -> Evt a -> SE a+stepper initVal evt = do+    (readSt, writeSt) <- sensorsSE initVal+    runEvt evt $ \a -> writeSt a+    readSt ++schedule :: (Arg a, Out b, Out (NoSE b)) => (a -> b) -> Evt (D, a) -> GE (SE (NoSE b))+schedule instr evt = do    +    ref <- newGERef defCsdTuple+    instrId <- saveSourceInstr =<< trigExp (writeGERef ref) instr +    _ <- saveAlwaysOnInstr $ scheduleInstr instrId evt+    return $ readGERef ref++scheduleInstr :: (Arg a) => InstrId -> Evt (D, a) -> E+scheduleInstr instrId evt = execSE $ +    runEvt evt $ \(dt, a) -> do+        event instrId 0 dt a+  +toggle :: (Arg a, Out b, Out (NoSE b)) => (a -> b) -> Evt a -> Evt c -> GE (SE (NoSE b))+toggle instr onEvt offEvt = do+    ref <- newGERef defCsdTuple+    instrId <- saveSourceInstr =<< trigExp (writeGERef ref) instr +    _ <- saveAlwaysOnInstr $ scheduleToggleInstr instrId onEvt offEvt+    return $ readGERef ref++scheduleToggleInstr :: (Arg a) => InstrId -> Evt a -> Evt c -> E+scheduleToggleInstr instrId onEvt offEvt = execSE $ do+    runEvt onEvt $ \a -> do+        instrOn instrId a 0+    cond <- evtToBool offEvt+    when cond $ do+        instrOff instrId+        +        ++    +++

@@ -0,0 +1,47 @@+{-# Language DeriveFunctor, DeriveFoldable, DeriveTraversable #-}+module Csound.Exp.EventList(+    CsdSco(..),+    CsdEvent, csdEventStart, csdEventDur, csdEventContent,+    CsdEventList(..), delayCsdEventList, rescaleCsdEventList+) where++import Data.Traversable+import Data.Foldable++type CsdEvent a = (Double, Double, a)++csdEventStart   :: CsdEvent a -> Double+csdEventDur     :: CsdEvent a -> Double+csdEventContent :: CsdEvent a -> a++csdEventStart   (a, _, _) = a+csdEventDur     (_, a, _) = a+csdEventContent (_, _, a) = a++class CsdSco f where    +    toCsdEventList :: f a -> CsdEventList a+    singleCsdEvent :: Double -> Double -> a -> f a++data CsdEventList a = CsdEventList+    { csdEventListDur   :: Double+    , csdEventListNotes :: [CsdEvent a] +    } deriving (Eq, Show, Functor, Foldable, Traversable)++instance CsdSco CsdEventList where+    toCsdEventList = id+    singleCsdEvent start dur a = CsdEventList (start + dur) [(start, dur, a)]++delayCsdEventList :: Double -> CsdEventList a -> CsdEventList a+delayCsdEventList k (CsdEventList totalDur events) = +    CsdEventList (k + totalDur) (fmap (delayCsdEvent k) events)++delayCsdEvent :: Double -> CsdEvent a -> CsdEvent a +delayCsdEvent k (start, dur, a) = (k + start, dur, a)++rescaleCsdEventList :: Double -> CsdEventList a -> CsdEventList a+rescaleCsdEventList k (CsdEventList totalDur events) = +    CsdEventList (k * totalDur) (fmap (rescaleCsdEvent k) events)++rescaleCsdEvent :: Double -> CsdEvent a -> CsdEvent a+rescaleCsdEvent k (start, dur, a) = (k * start, k * dur, a)+

@@ -0,0 +1,235 @@+-- | Global side effects+module Csound.Exp.GE(+    GE(..), runGE, execGE, History(..),+    getHistory, getOptions, withHistory, putHistory,++    Instrs(..),+    saveMixerInstr, saveSourceInstr, saveAlwaysOnInstr, saveSourceInstrCached,    +    saveMixerNotes, ++    saveTab, saveStr,++    Scos(..),+    LowLevelSco, saveAlwaysOnNote,++    Globals(..), Global(..),++    appendToGui, newGuiId,+    newGlobalVar+) where++import qualified System.Mem.StableName.Dynamic.Map as DM(Map, empty, insert, lookup)+import qualified System.Mem.StableName.Dynamic     as DM(DynamicStableName, makeDynamicStableName)++import Control.Applicative+import Control.Monad(ap)+import Control.Monad.Trans.State.Strict+import Control.Monad.Trans.Reader+import Data.Default++import qualified Data.IntMap as IM++import Csound.Exp+import Csound.Exp.EventList(CsdEvent)+import Csound.Exp.Wrapper+import Csound.Exp.Options+import Csound.Exp.SE+import Csound.Exp.Gui(Gui)++import Csound.Tfm.Tab++newtype GE a = GE { unGE :: ReaderT CsdOptions (StateT History IO) a }++instance Functor GE where+    fmap f = GE . fmap f . unGE++instance Applicative GE where+    pure = return+    (<*>) = ap++instance Monad GE where+    return = GE . return+    ma >>= mf = GE $ unGE ma >>= unGE . mf++data History = History +    { tabIndex :: Index LowTab+    , strIndex :: Index String+    , midis    :: [MidiAssign]+    , instrs   :: Instrs+    , scos     :: Scos+    , guis     :: Guis +    , globals  :: Globals }++instance Default History where +    def = History def def def def def def def++execGE :: GE a -> CsdOptions -> IO History+execGE a opt = fmap snd $ runGE a opt++runGE :: GE a -> CsdOptions -> IO (a, History)+runGE (GE a) options = runStateT (runReaderT a options) def++ge :: (CsdOptions -> History -> IO (a, History)) -> GE a+ge phi = GE $ ReaderT $ \opt -> StateT $ \history -> phi opt history    ++getHistory :: GE History+getHistory = ge $ \_ h -> return (h, h)++putHistory :: History -> GE ()+putHistory h = ge $ \_ _ -> return ((), h)++getOptions :: GE CsdOptions+getOptions = ge $ \opt h -> return (opt, h)++exec :: IO a -> GE a+exec act = ge $ \_ h -> do+    a <- act+    return (a, h)++withHistory :: (History -> (a, History)) -> GE a+withHistory phi = ge $ \_ history -> return $ phi history++modifyHistory :: (History -> History) -> GE ()+modifyHistory f = withHistory $ \h -> ((), f h)++------------------------------------------------------+-- tables++type TabId = Int+type StrId = Int++saveTab :: LowTab -> GE TabId+saveTab x = withHistory $ \history -> +    let (n, tabs') = indexInsert x (tabIndex history)+    in  (n, history{ tabIndex = tabs' })++saveStr :: String -> GE StrId+saveStr x = withHistory $ \history -> +    let (n, strs') = indexInsert x (strIndex history)+    in  (n, history{ strIndex = strs' })++-------------------------------------------------------+-- instruments++data Instrs = Instrs +    { instrSources  :: [(InstrId, E)]+    , instrMixers   :: [(InstrId, E)]     +    , instrCounter  :: Int+    , instrCache    :: DM.Map Int+    , mixerNotes    :: IM.IntMap LowLevelSco }++instance Default Instrs where+    def = Instrs def def 1 DM.empty def++saveSourceInstrCached :: a -> (a -> GE E) -> GE InstrId+saveSourceInstrCached instr render = do+    h <- getHistory+    let cache = instrCache $ instrs h+    name <- exec $ DM.makeDynamicStableName instr+    case DM.lookup name cache of+        Just n  -> return $ intInstrId n+        Nothing -> do+            instrId <- saveSourceInstr =<< render instr+            saveToCache name (instrIdCeil instrId)+            return instrId++saveToCache :: DM.DynamicStableName -> Int -> GE ()+saveToCache name counter = modifyHistory $ \h ->+    let x = instrs h+    in  h { instrs = x { instrCache = DM.insert name counter (instrCache x) }}++saveAlwaysOnInstr :: E -> GE InstrId+saveAlwaysOnInstr expr = do+    instrId <- saveSourceInstr expr+    saveAlwaysOnNote instrId+    return instrId++saveSourceInstr :: E -> GE InstrId+saveSourceInstr = saveInstr $ \a s -> s{ instrSources = a : instrSources s }++saveMixerInstr :: E -> GE InstrId+saveMixerInstr = saveInstr $ \a s -> s{ instrMixers = a : instrMixers s }++saveInstr :: ((InstrId, E) -> Instrs -> Instrs) -> E -> GE InstrId+saveInstr save expr = withHistory $ \h ->+    let ins = instrs h+        counter' = succ $ instrCounter ins+        instrId  = intInstrId counter'+    in  (instrId, h{ instrs = save (instrId, expr) $ ins { instrCounter = counter' }})++saveMixerNotes :: IM.IntMap LowLevelSco -> GE ()+saveMixerNotes sco = modifyHistory $ \h -> +    let x = instrs h+    in  h { instrs = x{ mixerNotes = sco }}++--------------------------------------------------------+-- scores++data Scos = Scos +    { alwaysOnInstrs :: [InstrId] }++type LowLevelSco = [(InstrId, CsdEvent Note)]++instance Default Scos where+    def = Scos def++saveAlwaysOnNote :: InstrId -> GE ()+saveAlwaysOnNote instrId = modifyHistory $ \h -> +    let x = scos h+    in  h { scos = x{ alwaysOnInstrs = instrId : alwaysOnInstrs x } }++--------------------------------------------------------+-- guis++data Guis = Guis+    { guiStateNewId     :: Int+    , guiStateInstr     :: SE ()+    , guiStateToDraw    :: [Gui] }++instance Default Guis where +    def = Guis 0 (return ()) []++newGuiId :: GE Int +newGuiId = withHistory $ \h -> +    let (n, g') = bumpGuiStateId $ guis h+    in  (n, h{ guis = g' })++appendToGui :: Gui -> SE () -> GE ()+appendToGui gui act = withHistory $ \h ->+    ((), h{ guis = appendToGuiState gui act $ guis h })++bumpGuiStateId :: Guis -> (Int, Guis)+bumpGuiStateId s = (guiStateNewId s, s{ guiStateNewId = succ $ guiStateNewId s })++appendToGuiState :: Gui -> SE () -> Guis -> Guis+appendToGuiState gui act s = s+    { guiStateToDraw = gui : guiStateToDraw s+    , guiStateInstr  = guiStateInstr s >> act }++--------------------------------------------------------+-- globals++data Globals = Globals+    { newGlobalVarId :: Int+    , globalsSoFar   :: [Global] }++instance Default Globals where +    def = Globals 0 []++data Global = Global +    { globalVar     :: Var+    , globalInit    :: E }+++newGlobalVarOnGlobals :: Val a => Rate -> a -> Globals -> (Var, Globals)+newGlobalVarOnGlobals rate a s = +    (v, s{ newGlobalVarId = succ n, globalsSoFar = g : globalsSoFar s })+    where n = newGlobalVarId s+          v = Var GlobalVar rate (show n)+          g = Global v (toE a)  ++newGlobalVar :: Val a => Rate -> a -> GE Var+newGlobalVar rate initVal = withHistory $ \h -> +    let (v, globals') = newGlobalVarOnGlobals rate initVal (globals h)+    in  (v, h{ globals = globals' })+

@@ -0,0 +1,11 @@+module Csound.Exp.Gui where++data Gui +    = Comp [Gui] +    | Prim Int Label Elem++data Elem = Slider | Btn | Radio | Text++type Label = String++

@@ -0,0 +1,84 @@+{-# Language ScopedTypeVariables #-}+module Csound.Exp.Instr(+    soundSourceExp,+    effectExp,+    trigExp+) where++import Control.Monad(zipWithM_)+import qualified Data.Map as M++import Csound.Exp+import Csound.Exp.Wrapper+import Csound.Exp.SE+import Csound.Exp.GE+import Csound.Exp.Tuple+import Csound.Exp.Arg+import Csound.Exp.Options++import Csound.Render.Channel+import Csound.Tfm.Tab+++funProxy :: (a -> b) -> (a, b)+funProxy = const (undefined, undefined)    ++soundSourceExp :: (Arg a, Out b) => (a -> b) -> GE E+soundSourceExp instr = substTabs expr+    where insArity = arity $ fst $ funProxy instr+          expr = instrExp insArity $ toOut $ instr toArg++effectExp :: (Out a, Out b) => (a -> b) -> GE E+effectExp eff = substTabs $ mixerExp $ do+    inputs <- ins $ outArity $ fst $ funProxy eff+    toOut $ eff $ fromOut $ inputs+    ++substTabs :: E -> GE E+substTabs expr = do+    opt <- getOptions+    let expr' = defineInstrTabs (tabFi opt) expr+        tabs  = getInstrTabs expr'+    ids <- mapM saveTab tabs+    let tabMap = M.fromList $ zip tabs ids+    return $ substInstrTabs tabMap expr'+   +trigExp :: (Arg a, Out b) => (NoSE b -> SE ()) -> (a -> b) -> GE E+trigExp writer instr = substTabs $ execSE $ +    writer . toCsdTuple . fmap toE =<< (toOut $ instr toArg)+++----------------------------------------------------------+-- simple instrument trigered with score++-- How to render an instrument+mixerExp :: SE [Sig] -> E++-- 4 + arity because there are 3 first arguments (instrId, start, dur) and arity params comes next+mixerExp   = instrExpGen (outs 4) -- for mixing instruments we expect the port number to be the fourth parameter++instrExp :: Int -> SE [Sig] -> E+instrExp insArity = instrExpGen (outs (4 + insArity))++instrExpGen :: ([Sig] -> SE ()) -> SE [Sig] -> E+instrExpGen formOuts instrBody = execSE $ formOuts =<< instrBody++++-- other outputs++outs :: Int -> [Sig] -> SE ()+outs readChnId sigs = zipWithM_ (out readChnId) [1 .. ] sigs+    where out chnId n asig = chnmix asig $ chnName n (p chnId) ++-- inputs++ins :: Int -> SE [Sig]+ins n = mapM in_ [1 .. n] +    where in_ x = do+              let name = chnName x $ readVar chnVar+              asig <- chnget name+              chnclear name+              return asig++

@@ -1,29 +1,71 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# Language TypeFamilies #-}-module Csound.Exp.Logic() where+module Csound.Exp.Logic(+    BoolSig, BoolD, when+) where -import Control.Monad.Trans.State-import Data.Fix-import qualified Data.IntMap as IM-import Control.Applicative+import Control.Monad.Trans.State(State, state, evalState)+import qualified Data.IntMap as IM(fromList)  import Data.Boolean -import Csound.Exp.Wrapper import Csound.Exp+import Csound.Exp.Wrapper(+    Sig, D, Str,  +    setRate, noRate,+    Val(..), toExp, onExp, onE1) +import Csound.Exp.SE(SE, se_, stmtOnly)++------------------------------------------------------+-- imperative if-then-else++when :: BoolSig -> SE () -> SE ()+when p body = do+    ifBegin p+    body+    ifEnd++ifBegin :: Val a => a -> SE ()+ifBegin = withCond IfBegin++{-+elseIfBegin :: Val a => a -> SE ()+elseIfBegin = withCond ElseIfBegin++elseBegin :: SE ()+elseBegin = stmtOnly ElseBegin+-}++ifEnd :: SE ()+ifEnd = stmtOnly IfEnd++withCond :: Val a => (E -> MainExp E) -> a -> SE ()+withCond stmt p = se_ $ fromE $ noRate $ fmap (PrimOr . Right) $ stmt (toE p)+-- booleans++-- | Boolean signals. +newtype BoolSig = BoolSig { unBoolSig :: E }++-- | Boolean constants. +newtype BoolD = BoolD { unBoolD :: E }++instance Val BoolSig    where { toE = unBoolSig;fromE = BoolSig }+instance Val BoolD      where { toE = unBoolD;  fromE = BoolD }+ -- booleans for signals  instance Boolean BoolSig where     true = boolOp0 TrueOp     false = boolOp0 FalseOp-    notB = BoolSig . notE . unBoolSig+    notB = onE1 notE     (&&*) = boolOp2 And     (||*) = boolOp2 Or  type instance BooleanOf Sig = BoolSig  instance IfB Sig where-    ifB = cond'+    ifB = condExp      instance EqB Sig where     (==*) = boolOp2 Equals@@ -40,14 +82,14 @@ instance Boolean BoolD where     true = boolOp0 TrueOp     false = boolOp0 FalseOp-    notB = BoolD . notE . unBoolD+    notB = onE1 notE     (&&*) = boolOp2 And     (||*) = boolOp2 Or  type instance BooleanOf D = BoolD  instance IfB D where-    ifB = cond'+    ifB = condExp      instance EqB D where     (==*) = boolOp2 Equals@@ -64,57 +106,63 @@ type instance BooleanOf Tab = BoolD  instance IfB Tab where-    ifB = cond'+    ifB = condExp  -- booleans for strings  type instance BooleanOf Str = BoolD  instance IfB Str where-    ifB = cond'+    ifB = condExp ---------------------------------------------+-------------------------------------------------------------------------- -- if-then-else+--+-- performs inlining of the boolean expressions +boolExp :: a -> [b] -> PreInline a b boolExp = PreInline -cond' :: (Val bool, Val a) => bool -> a -> a -> a-cond' p t e = wrap $ mkCond (condInfo $ toPrimOr $ Fix $ unwrap p) (unwrap t) (unwrap e)-    where mkCond :: CondInfo (PrimOr E) -> RatedExp E -> RatedExp E -> RatedExp E-          mkCond p t e -            | isTrue p = t-            | isFalse p = e-            | otherwise = noRate $ If p (toPrimOr $ Fix t) (toPrimOr $ Fix e)            +condExp :: (Val bool, Val a) => bool -> a -> a -> a+condExp p t e = fromE $ mkCond (condInfo $ toPrimOr $ toE p) (toE t) (toE e)+    where mkCond :: CondInfo (PrimOr E) -> E -> E -> E+          mkCond pr th el +            | isTrue pr = th+            | isFalse pr = el+            | otherwise = noRate $ If pr (toPrimOr th) (toPrimOr el)              condInfo :: PrimOr E -> CondInfo (PrimOr E)-condInfo exp = (\(a, b) -> Inline a (IM.fromList b)) $ evalState (condInfo' exp) 0+condInfo expr = (\(a, b) -> Inline a (IM.fromList b)) $ evalState (condInfo' expr) 0     where condInfo' :: PrimOr E -> State Int (InlineExp CondOp, [(Int, PrimOr E)])-          condInfo' e = maybe (onLeaf e) (onExp e) $ parseNode e+          condInfo' e = maybe (onLeaf e) (onExpr e) $ parseNode e           onLeaf e = state $ \n -> ((InlinePrim n, [(n, e)]), n+1)  -          onExp  e (op, args) = mkNode <$> mapM condInfo' args+          onExpr  _ (op, args) = fmap mkNode $ mapM condInfo' args               where mkNode as = (InlineExp op (map fst as), concat $ map snd as)             parseNode :: PrimOr E -> Maybe (CondOp, [PrimOr E])-          parseNode x = case unPrimOr $ fmap (ratedExpExp . unFix) x of+          parseNode x = case unPrimOr $ fmap toExp x of               Right (ExpBool (PreInline op args)) -> Just (op, args)               _ -> Nothing     +--------------------------------------------------------------------------------+-- constructors for boolean expressions +-- generic constructor boolOps :: (Val a) => CondOp -> [E] -> a boolOps op as = noRate $ ExpBool $ boolExp op $ fmap toPrimOr as +-- constructors by arity+ boolOp0 :: Val a => CondOp -> a boolOp0 op = boolOps op [] -boolOp1 :: Val a => CondOp -> a -> a-boolOp1 op a = boolOps op [setRate Kr $ Fix $ unwrap a]- boolOp2 :: (Val a1, Val a2, Val b) => CondOp -> a1 -> a2 -> b-boolOp2 op a b = boolOps op $ map (Fix . setRate Kr) [unwrap a, unwrap b]+boolOp2 op a b = boolOps op $ map (setRate Kr) [toE a, toE b] +----------------------------------------------------------------------------- -- no support for not in csound so we perform not-elimination notE :: E -> E-notE x = Fix $ onExp phi $ unFix x+notE x = onExp phi x     where phi (ExpBool (PreInline op args)) = ExpBool $ case op of             TrueOp            -> boolExp FalseOp        []             FalseOp           -> boolExp TrueOp         []@@ -125,5 +173,8 @@             Less              -> boolExp GreaterEquals  args             Greater           -> boolExp LessEquals     args             LessEquals        -> boolExp Greater        args-            GreaterEquals     -> boolExp Less           args     +            GreaterEquals     -> boolExp Less           args++          phi _ = error "Logic.hs:notE - expression is not Boolean"  + 

@@ -0,0 +1,153 @@+module Csound.Exp.Mix(+    -- * Container for sounds (triggered with notes and mixers)+    Mix(..), M(..), nchnls,++    effect, effectS,+    sco, mix, --, midi, pgmidi++    rescaleCsdEventListM+) where++import Data.Traversable(traverse)+import qualified Data.Map    as M++import Csound.Tfm.Tab++import Csound.Exp+import Csound.Exp.Wrapper+import Csound.Exp.SE+import Csound.Exp.GE+import Csound.Exp.Instr+import Csound.Exp.Arg+import Csound.Exp.Tuple(Out(..), CsdTuple, fromCsdTuple, toCsdTuple, outArity)+import Csound.Exp.Options+import Csound.Exp.EventList++newtype Mix a = Mix { unMix :: GE M } ++data M +    = Snd InstrId (CsdEventList Note)+    | Eff InstrId (CsdEventList M)    ++nchnls :: Out a => f (Mix a) -> Int+nchnls = outArity . proxy  +    where proxy :: f (Mix a) -> a+          proxy = undefined  ++-- | Play a bunch of notes with the given instrument.+--+-- > res = sco instrument scores +--+-- * @instrument@ is a function that takes notes and produces a +--   tuple of signals (maybe with some side effect)+--  +-- * @scores@ are some notes (see the module "Temporal.Media" +--   on how to build complex scores out of simple ones)+--+-- Let's try to understand the type of the output. It's @Score (Mix (NoSE a))@. +-- What does it mean? Let's look at the different parts of this type:+--+-- * @Score a@ - you can think of it as a container of some values of +--   type @a@ (every value of type @a@ starts at some time and lasts +--   for some time in seconds)+--+-- * @Mix a@ - is an output of Csound instrument it can be one or several +--   signals ('Csound.Base.Sig' or 'Csound.Base.CsdTuple'). +--+-- *NoSE a* - it's a tricky part of the output. 'NoSE' means literaly 'no SE'. +-- It tells to the type checker that it can skip the 'Csound.Base.SE' wrapper+-- from the type 'a' so that @SE a@ becomes just @a@ or @SE (a, SE b, c)@ +-- becomes @(a, b, c)@. Why should it be? I need 'SE' to deduce the order of the+-- instruments that have side effects. I need it within one instrument. But when +-- instrument is rendered i no longer need 'SE' type. So 'NoSE' lets me drop it+-- from the output type. +sco :: (Arg a, Out b, CsdSco f) => (a -> b) -> f a -> f (Mix (NoSE b))+sco instr notes = singleCsdEvent 0 (csdEventListDur events) $ Mix $ do    +    events'  <- traverse renderNote events+    instrId <- saveSourceInstrCached instr soundSourceExp+    return $ Snd instrId events'+    where events = toCsdEventList notes++renderNote :: (Arg a) => a -> GE [Prim]+renderNote a = tfmNoteStrs =<< tfmNoteTabs (toNote a) ++tfmNoteTabs :: Note -> GE Note+tfmNoteTabs xs = do+    opt <- getOptions+    let xs' = defineNoteTabs (tabFi opt) xs+        tabs = getPrimTabs =<< xs'+    ids <- mapM saveTab tabs+    let tabMap = M.fromList $ zip tabs ids+    return $ substNoteTabs tabMap xs'++tfmNoteStrs :: Note -> GE Note+tfmNoteStrs xs = do    +    ids <- mapM saveStr strs+    let strMap = M.fromList $ zip strs ids+    return $ substNoteStrs strMap xs   +    where strs = getStrings xs+++-- | Applies an effect to the sound. Effect is applied to the sound on the give track. +--+-- > res = mix effect sco +--+-- * @effect@ - a function that takes a tuple of signals and produces +--   a tuple of signals.+--+-- * @sco@ - something that is constructed with 'Csound.Base.sco' or +--   'Csound.Base.mix' or 'Csound.Base.midi'. +--+-- With the function 'Csound.Base.mix' you can apply a reverb or adjust the +-- level of the signal. It functions like a mixing board but unlike mixing +-- board it produces the value that you can arrange with functions from the +-- module "Temporal.Media". You can delay it mix with some other track and +-- apply some another effect on top of it!+mix :: (Out a, Out b, CsdSco f) => (a -> b) -> f (Mix a) -> f (Mix (NoSE b))+mix eff sigs = singleCsdEvent 0 (csdEventListDur events) $ Mix $ do+    notes <- traverse unMix events+    instrId <- saveMixerInstr =<< effectExp eff+    return $ Eff instrId notes +    where events = toCsdEventList sigs+    +{-+-- | Triggers a midi-instrument (like Csound's massign). The result type +-- is a fake one. It's wrapped in the 'Csound.Base.Score' for the ease of mixing.+-- you can not delay or stretch it. The only operation that is meaningful +-- for it is 'Temporal.Media.chord'. But you can add effects to it with 'Csound.Base.mix'!+midi :: (Out a) => Channel -> (Msg -> a) -> Score (Mix (NoSE a))+midi = genMidi Massign++-- | Triggers a - midi-instrument (like Csound's pgmassign). +pgmidi :: (Out a) => Maybe Int -> Channel -> (Msg -> a) -> Score (Mix (NoSE a))+pgmidi mchn = genMidi (Pgmassign mchn)++genMidi :: (Out a) => MidiType -> Channel -> (Msg -> a) -> Score (Mix (NoSE a))+genMidi midiType chn f = temp $ Mid $ mkInstr getMidiArity Msg f (Just (midiType, chn))+    where getMidiArity = mkArity (const 0) outArity+-}++-- | Constructs the effect that applies a given function on every channel.+effect :: (CsdTuple a, Out a) => (Sig -> Sig) -> (a -> a)+effect f = toCsdTuple . fmap (toE . f . fromE) . fromCsdTuple++-- | Constructs the effect that applies a given function with side effect +-- (it uses random opcodes or delays) on every channel.+effectS :: (CsdTuple a, Out a) => (Sig -> SE Sig) -> (a -> SE a)+effectS f a = fmap fromOut $ mapM f =<< toOut a++rescaleCsdEventListM :: CsdEventList M -> CsdEventList M+rescaleCsdEventListM es = +    es { csdEventListNotes = fmap rescaleCsdEventM $ csdEventListNotes es }++rescaleCsdEventM :: CsdEvent M -> CsdEvent M+rescaleCsdEventM (start, dur, evt) = (start, dur, phi evt)+    where phi x = case x of+            Snd n evts -> Snd n $ rescaleCsdEventList (dur/localDur) evts+            Eff n evts -> Eff n $ rescaleCsdEventListM $ rescaleCsdEventList (dur/localDur) evts            +            where localDur = case x of+                    Snd _ evts -> csdEventListDur evts+                    Eff _ evts -> csdEventListDur evts+++

@@ -1,32 +1,26 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# Language TypeSynonymInstances, FlexibleInstances #-} module Csound.Exp.Numeric(     fracD, floorD, ceilD, intD, roundD,     fracSig, floorSig, ceilSig, intSig, roundSig ) where -import Data.Maybe(fromJust)-import Control.Applicative-import Data.Fix-+import Data.Monoid import Csound.Exp-import Csound.Exp.Wrapper-import Csound.Exp.Cons ------------------------------------------------------------ instances for numerical expressions+import Csound.Exp.Wrapper(+    Sig, D, prim, noRate,+    Val(..), toExp, onE1, onE2) -class NumOpt a where-    maybeDouble :: a -> Maybe Double-    fromDouble  :: Double -> a-    fromNum     :: NumExp a -> a+---------------------------------------------+-- monoid -instance NumOpt E where-    maybeDouble x = case ratedExpExp $ unFix x of-        ExpPrim (PrimDouble d) -> Just d-        _ -> Nothing   +instance Monoid Sig where+    mempty  = 0+    mappend = (+) -    fromDouble = prim . PrimDouble-    fromNum = noRate . ExpNum . fmap toPrimOr   +instance Monoid D where+    mempty  = 0+    mappend = (+)  -------------------------------------------- -- numeric instances@@ -62,27 +56,28 @@  instance Floating E where     pi = fromDouble pi-    exp = funOpt exp ExpOp-    sqrt = funOpt sqrt Sqrt-    log = funOpt log Log+    exp = unOpt exp ExpOp+    sqrt = unOpt sqrt Sqrt+    log = unOpt log Log     logBase a n = case n of-        2 -> funOpt (flip logBase 2) Logbtwo a-        10 -> funOpt (flip logBase 10) Log10 a+        2 -> unOpt (flip logBase 2) Logbtwo a+        10 -> unOpt (flip logBase 10) Log10 a         b -> log a / log b     (**) = biOpt (**) Pow-    sin = funOpt sin Sin -    tan = funOpt tan Tan-    cos = funOpt cos Cos-    asin = funOpt asin Sininv-    atan = funOpt atan Taninv-    acos = funOpt acos Cosinv-    sinh = funOpt sinh Sinh-    tanh = funOpt tanh Tanh-    cosh = funOpt cosh Cosh+    sin = unOpt sin Sin +    tan = unOpt tan Tan+    cos = unOpt cos Cos+    asin = unOpt asin Sininv+    atan = unOpt atan Taninv+    acos = unOpt acos Cosinv+    sinh = unOpt sinh Sinh+    tanh = unOpt tanh Tanh+    cosh = unOpt cosh Cosh     asinh a = log $ a + sqrt (a * a + 1)     acosh a = log $ a + sqrt (a + 1) * sqrt (a - 1)     atanh a = 0.5 * log ((1 + a) / (1 - a)) +enumError :: String -> a enumError name = error $ name ++ " -- is defined only for literals"      instance Enum E where@@ -94,12 +89,12 @@          enumFromThen a b = a : enumFromThen (a + b) b      -    enumFromTo a b = case (maybeDouble a, maybeDouble b) of-        (Just x, Just y) -> fmap fromDouble $ enumFromTo x y+    enumFromTo a b = case (toNumOpt a, toNumOpt b) of+        (Left x, Left y) -> fmap fromDouble $ enumFromTo x y         _ -> enumError "[a .. b]"             -    enumFromThenTo a b c = case (maybeDouble a, maybeDouble b, maybeDouble c) of-        (Just x, Just y, Just z) -> fmap fromDouble $ enumFromThenTo x y z+    enumFromThenTo a b c = case (toNumOpt a, toNumOpt b, toNumOpt c) of+        (Left x, Left y, Left z) -> fmap fromDouble $ enumFromThenTo x y z         _ -> enumError "[a, b .. c]"          @@ -114,14 +109,8 @@     divMod a b = (div a b, mod a b)     toInteger = undefined     -onE1 :: (Val a, Val b) => (E -> E) -> (a -> b)-onE1 f = wrap . unFix . f . Fix . unwrap--onE2 :: (Val a, Val b, Val c) => (E -> E -> E) -> (a -> b -> c)-onE2 f a b = wrap $ unFix $ f (Fix $ unwrap a) (Fix $ unwrap b)- onConst :: Val b => (a -> E) -> (a -> b)-onConst f = wrap . unFix . f +onConst f = fromE . f   ------------------------------------------- -- wrappers@@ -243,7 +232,7 @@     fromRational = onConst fromRational  instance Floating Sig where-    pi = wrap $ unFix pi+    pi = fromE pi     exp = onE1 exp     sqrt = onE1 sqrt     log = onE1 log@@ -263,7 +252,7 @@     atanh = onE1 atanh     instance Floating D where-    pi = wrap $ unFix pi+    pi = fromE pi     exp = onE1 exp     sqrt = onE1 sqrt     log = onE1 log@@ -283,41 +272,49 @@     atanh = onE1 atanh  ------------------------------------------------------------+-- Optimizations for constants+--+-- If an arithmetic expression contains constants we can execute+-- it and render as constant. We check wether all arguments +-- are constants. If it's so we apply some numeric function and+-- propogate a constant value. -isZero :: NumOpt a => a -> Bool-isZero a = maybe False id $ ((==0) <$> maybeDouble a)+toNumOpt :: E -> Either Double E+toNumOpt x = case toExp x of+    ExpPrim (PrimDouble d) -> Left d+    _ -> Right x -unOpt :: (NumOpt a) => (Double -> Double) -> NumOp -> a -> a-unOpt doubleOp op a = fromJust $-        (fromDouble . doubleOp <$> maybeDouble a)-    <|> Just (noOpt1 op a)+fromNumOpt :: Either Double E -> E+fromNumOpt = either (prim . PrimDouble) id  -biOpt :: (NumOpt a) => (Double -> Double -> Double) -> NumOp -> a -> a -> a-biOpt doubleOp op a b = fromJust $-        (fromDouble <$> liftA2 doubleOp (maybeDouble a) (maybeDouble b))-    <|> Just (noOpt2 op a b) -        +expNum :: NumExp E -> E+expNum = noRate . ExpNum . fmap toPrimOr -funOpt :: NumOpt a => (Double -> Double) -> NumOp -> a -> a-funOpt doubleOp op a = fromJust $-        (fromDouble . doubleOp <$> maybeDouble a)-    <|> Just (noOpt1 op a)+fromDouble :: Double -> E+fromDouble = fromNumOpt . Left -noOpt1 :: NumOpt a => NumOp -> a -> a-noOpt1 op a = fromNum $ PreInline op [a]+isZero :: E -> Bool+isZero a = either ( == 0) (const False) $ toNumOpt a -noOpt2 :: NumOpt a => NumOp -> a -> a -> a-noOpt2 op a b = fromNum $ PreInline op [a, b]+-- optimization for unary functions+unOpt :: (Double -> Double) -> NumOp -> E -> E+unOpt doubleOp op a = fromNumOpt $ either (Left . doubleOp) (Right . noOpt1) $ toNumOpt a+    where noOpt1 x = expNum $ PreInline op [x]  -doubleToInt :: NumOpt a => (Double -> Int) -> NumOp -> a -> a-doubleToInt fun op a = fromJust $        -        (fromDouble . fromIntegral . fun <$> maybeDouble a)-    <|> Just (noOpt1 op a)+-- optimization for binary functions+biOpt :: (Double -> Double -> Double) -> NumOp -> E -> E -> E+biOpt doubleOp op a b = fromNumOpt $ case (toNumOpt a, toNumOpt b) of+    (Left da, Left db) -> Left $ doubleOp da db+    _ -> Right $ noOpt2 a b+    where noOpt2 x y = expNum $ PreInline op [x, y] +doubleToInt :: (Double -> Int) -> NumOp -> E -> E+doubleToInt fun = unOpt (fromIntegral . fun) + -- arithmetic -mod' :: NumOpt a => a -> a -> a-mod' = biOpt (\a b -> fromIntegral $ mod (floor a) (floor b)) Pow+mod' :: E -> E -> E+mod' = biOpt (\a b -> fromIntegral $ mod (floor a :: Int) (floor b)) Pow   -- other functions @@ -326,15 +323,6 @@ ceilE   = doubleToInt ceiling Ceil  floorE  = doubleToInt floor Floor roundE  = doubleToInt round Round-fracE   = unOpt (snd . properFraction) Frac +fracE   = unOpt (snd . (properFraction :: (Double -> (Int, Double)))) Frac  intE    = doubleToInt truncate IntOp      ----    -----

@@ -0,0 +1,45 @@+module Csound.Exp.Options where++import Data.Default+import Csound.Tab(TabFi, fineFi, idSegs, idExps, idConsts)++type CtrlId = Int+type Channel = Int++-- | Csound options. The default value is+--+-- > instance Default CsdOptions where+-- >     def = CsdOptions +-- >             { flags = "-d"           -- suppress ftable printing+-- >             , sampleRate  = 44100+-- >             , blockSize = 64+-- >             , seed = Nothing+-- >             , initc7 = []+-- >             , tabFi = fineFi 13 [(idSegs, 10), (idExps, 10), (idConsts, 8)] } -- all tables have 8192 points but tables for linear, exponential and constant segments. ++data CsdOptions = CsdOptions +    { flags         :: String       +    , sampleRate    :: Int          +    , blockSize     :: Int          +    , seed          :: Maybe Int    +    , initc7        :: [(Channel, CtrlId, Double)]+    , tabFi         :: TabFi+    }++instance Default CsdOptions where+    def = CsdOptions +            { flags = "-d"+            , sampleRate  = 44100+            , blockSize = 64+            , seed = Nothing+            , initc7 = []+            , tabFi = fineFi 13 [(idSegs, 10), (idExps, 10), (idConsts, 8)] }++data MidiType = Massign | Pgmassign (Maybe Int)++data MidiAssign = MidiAssign +    { midiAssignType    :: MidiType+    , midiAssignChannel :: Channel+    , midiAssignInstr   :: Int }++

@@ -0,0 +1,50 @@+module Csound.Exp.Ref(+    -- * GERef+    GERef, newGERef, readGERef, writeGERef, +    sensorsGE, ++    -- * SERef+    SERef, newSERef, readSERef, writeSERef, +    sensorsSE+) where++import Control.Monad(zipWithM, zipWithM_)++import Csound.Exp.Tuple+import Csound.Exp.GE+import Csound.Exp.SE++-- global references++data GERef a = GERef +    { readGERef  :: SE a+    , writeGERef :: a -> SE () }++sensorsGE :: CsdTuple a => a -> GE (SE a, a -> SE ())+sensorsGE a = do+    vs <- zipWithM newGlobalVar (ratesCsdTuple a) (fromCsdTuple a)+    let reader = return $ toCsdTuple $ fmap readVar vs+        writer x = zipWithM_ writeVar vs (fromCsdTuple x)+    return (reader, writer)++newGERef :: CsdTuple a => a -> GE (GERef a)+newGERef a = fmap (uncurry GERef) $ sensorsGE a++-- local references++data SERef a = SERef+    { readSERef  :: SE a+    , writeSERef :: a -> SE () }++newSERef :: CsdTuple a => a -> SE (SERef a)+newSERef a = fmap (uncurry SERef) (sensorsSE a)++sensorsSE :: CsdTuple a => a -> SE (SE a, a -> SE ())+sensorsSE a = do+    vs <- zipWithM newLocalVar (ratesCsdTuple a) (fromCsdTuple a)+    let reader = return $ toCsdTuple $ fmap readVar vs+        writer x = zipWithM_ writeVar vs (fromCsdTuple x)+    return (reader, writer)+    ++

@@ -0,0 +1,111 @@+-- | side effects+module Csound.Exp.SE(+    Outs,+    SE(..), LocalHistory(..), +    se, se_, stmtOnly, runSE, execSE, +    writeVar, readVar, initVar, newLocalVar+) where++import Control.Applicative+import Control.Monad(ap)+import Control.Monad.Trans.State.Strict+import Data.Default+import Data.Maybe(fromJust)+import Data.Fix(Fix(..))++import Csound.Exp+import Csound.Exp.Wrapper+++type Outs = SE [Sig]++-- | Csound's synonym for 'IO'-monad. 'SE' means Side Effect. +-- You will bump into 'SE' trying to read and write to delay lines,+-- making random signals or trying to save your audio to file. +-- Instrument is expected to return a value of @SE [Sig]@. +-- So it's okay to do some side effects when playing a note.+newtype SE a = SE { unSE :: State LocalHistory a }++data LocalHistory = LocalHistory+    { expDependency     :: Maybe E+    , locals            :: Locals }+++instance Default LocalHistory where+    def = LocalHistory def def++data Locals = Locals +    { newVarId          :: Int+    , localInits        :: [SE ()] }++instance Default Locals where+    def = Locals def def++instance Functor SE where+    fmap f = SE . fmap f . unSE++instance Applicative SE where+    pure = return+    (<*>) = ap++instance Monad SE where+    return = SE . return+    ma >>= mf = SE $ unSE ma >>= unSE . mf++runSE :: SE a -> (a, LocalHistory)+runSE a = runState (unSE a) def++execSE :: SE a -> E+execSE a +    | null initList = expr+    | otherwise     = execSE $ applyInitList initList expr >> clearInitList+    where st = snd $ runSE a+          expr = fromJust $ expDependency st+          initList = localInits $ locals st+          clearInitList = SE $ modify $ \s -> s{ locals = def }+          applyInitList inits xs = sequence_ inits >> se_ xs++-- dependency tracking++se :: (Val a) => E -> SE a+se a = SE $ state $ \s -> +    let x = Fix $ (unFix a) { ratedExpDepends = expDependency s }+    in  (fromE x, s{ expDependency = Just x } )++se_ :: E -> SE ()+se_ = fmap (const ()) . (se :: E -> SE E)++stmtOnly :: Exp E -> SE ()+stmtOnly stmt = se_ $ fromE $ noRate stmt+++--------------------------------------------------+-- variables++-- generic funs++writeVar :: (Val a) => Var -> a -> SE ()+writeVar v x = se_ $ noRate $ WriteVar v $ toPrimOr $ toE x ++readVar :: (Val a) => Var -> a+readVar v = noRate $ ReadVar v++initVar :: (Val a) => Var -> a -> SE ()+initVar v x = se_ $ noRate $ InitVar v $ toPrimOr $ toE x++-- new local variables++newLocalVar :: Val a => Rate -> a -> SE Var+newLocalVar rate initVal = SE $ do+    s <- get+    let (var, locals') = newVarOnLocals rate initVal (locals s)+    put $ s { locals = locals' }+    return var++newVarOnLocals :: Val a => Rate -> a -> Locals -> (Var, Locals)+newVarOnLocals rate initVal st = +    (var, st { newVarId = succ n, localInits = initStmt : localInits st })+    where var = Var LocalVar rate (show n)+          n = newVarId st  +          initStmt = initVar var initVal+

@@ -0,0 +1,238 @@+{-# Language +        TypeFamilies,+        FlexibleContexts #-}+module Csound.Exp.Tuple(+    CsdTuple(..), +    fromCsdTuple, toCsdTuple, arityCsdTuple, ratesCsdTuple, defCsdTuple,+    Out(..), multiOuts, outArity+) where++import Data.Default++import Control.Applicative(liftA2)+import Control.Monad(join)++import Csound.Exp+import Csound.Exp.Wrapper(Val(..), Sig, D, Str, Spec, onExp, toExp, +    withRate, getRates)+import Csound.Exp.SE(SE)++-- | Describes tuples of Csound values. It's used for functions that can return +-- several results (such as 'soundin' or 'diskin2'). Tuples can be nested. +class CsdTuple a where+    csdTupleMethods :: CsdTupleMethods a++data CsdTupleMethods a = CsdTupleMethods+    { fromCsdTuple_  :: a -> [E]+    , toCsdTuple_    :: [E] -> a+    , arityCsdTuple_ :: a -> Int+    , ratesCsdTuple_ :: a -> [Rate]+    , defCsdTuple_   :: a }++fromCsdTuple :: CsdTuple a => a -> [E] +fromCsdTuple = fromCsdTuple_ csdTupleMethods++toCsdTuple :: CsdTuple a => [E] -> a+toCsdTuple = toCsdTuple_ csdTupleMethods++arityCsdTuple :: CsdTuple a => a -> Int+arityCsdTuple = arityCsdTuple_ csdTupleMethods++ratesCsdTuple :: CsdTuple a => a -> [Rate]+ratesCsdTuple = ratesCsdTuple_ csdTupleMethods++defCsdTuple :: CsdTuple a => a+defCsdTuple = defCsdTuple_ csdTupleMethods++-- | Defines instance of type class 'Arg' for a new type in terms of an already defined one.+makeCsdTupleMethods :: (CsdTuple a) => (a -> b) -> (b -> a) -> CsdTupleMethods b+makeCsdTupleMethods to from = CsdTupleMethods +    { fromCsdTuple_  = fromCsdTuple . from+    , toCsdTuple_    = to . toCsdTuple +    , arityCsdTuple_ = const $ arityCsdTuple $ proxy to+    , ratesCsdTuple_ = ratesCsdTuple . from+    , defCsdTuple_   = to defCsdTuple }+    where proxy :: (a -> b) -> a+          proxy = undefined++-- | Output of the instrument.+class CsdTuple (NoSE a) => Out a where+    type NoSE a :: *+    toOut :: a -> SE [Sig]+    fromOut :: [Sig] -> a++outArity :: Out a => a -> Int+outArity a = arityCsdTuple (proxy a)+    where proxy :: Out a => a -> NoSE a+          proxy = undefined  ++-- CsdTuple instances++instance CsdTuple () where+    csdTupleMethods = CsdTupleMethods +        { fromCsdTuple_  = return []+        , toCsdTuple_    = const ()+        , arityCsdTuple_ = const 0+        , ratesCsdTuple_ = const []+        , defCsdTuple_   = () }++instance CsdTuple Sig where+    csdTupleMethods = CsdTupleMethods +        { fromCsdTuple_ = return . toE+        , toCsdTuple_ = fromE . head+        , arityCsdTuple_ = const 1+        , ratesCsdTuple_ = const [Ar]+        , defCsdTuple_   = def }+        +instance CsdTuple D where+    csdTupleMethods = CsdTupleMethods +        { fromCsdTuple_ = return . toE+        , toCsdTuple_ = fromE . head+        , arityCsdTuple_ = const 1+        , ratesCsdTuple_ = const [Ir]+        , defCsdTuple_   = def }++instance CsdTuple Tab where+    csdTupleMethods = CsdTupleMethods +        { fromCsdTuple_ = return . toE+        , toCsdTuple_ = fromE . head+        , arityCsdTuple_ = const 1+        , ratesCsdTuple_ = const [Ir]+        , defCsdTuple_   = def }++instance CsdTuple Str where+    csdTupleMethods = CsdTupleMethods +        { fromCsdTuple_ = return . toE+        , toCsdTuple_ = fromE . head+        , arityCsdTuple_ = const 1+        , ratesCsdTuple_ = const [Sr]+        , defCsdTuple_   = def }++instance CsdTuple Spec where+    csdTupleMethods = CsdTupleMethods +        { fromCsdTuple_ = return . toE+        , toCsdTuple_ = fromE . head+        , arityCsdTuple_ = const 1+        , ratesCsdTuple_ = const [Fr]+        , defCsdTuple_   = def }++instance (CsdTuple a, CsdTuple b) => CsdTuple (a, b) where    +    csdTupleMethods = CsdTupleMethods fromCsdTuple' toCsdTuple' arityCsdTuple' ratesCsdTuple' defCsdTuple'+        where +            fromCsdTuple' (a, b) = fromCsdTuple a ++ fromCsdTuple b+            arityCsdTuple' x = let (a, b) = proxy x in arityCsdTuple a + arityCsdTuple b+                where proxy :: (a, b) -> (a, b)+                      proxy = const (undefined, undefined)  +            toCsdTuple' xs = (a, b)+                where a = toCsdTuple $ take (arityCsdTuple a) xs+                      xsb = drop (arityCsdTuple a) xs  +                      b = toCsdTuple (take (arityCsdTuple b) xsb)++            ratesCsdTuple' (a, b) = ratesCsdTuple a ++ ratesCsdTuple b+            defCsdTuple' = (defCsdTuple, defCsdTuple)++instance (CsdTuple a, CsdTuple b, CsdTuple c) => CsdTuple (a, b, c) where+    csdTupleMethods = makeCsdTupleMethods to from+        where to (a, (b, c)) = (a, b, c)+              from (a, b, c) = (a, (b, c))  ++instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d) => CsdTuple (a, b, c, d) where+    csdTupleMethods = makeCsdTupleMethods to from+        where to (a, (b, c, d)) = (a, b, c, d)+              from (a, b, c, d) = (a, (b, c, d))  ++instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e) => CsdTuple (a, b, c, d, e) where+    csdTupleMethods = makeCsdTupleMethods to from+        where to (a, (b, c, d, e)) = (a, b, c, d, e)+              from (a, b, c, d, e) = (a, (b, c, d, e))  ++instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f) => CsdTuple (a, b, c, d, e, f) where+    csdTupleMethods = makeCsdTupleMethods to from+        where to (a, (b, c, d, e, f)) = (a, b, c, d, e, f)+              from (a, b, c, d, e, f) = (a, (b, c, d, e, f))  ++instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f, CsdTuple g) => CsdTuple (a, b, c, d, e, f, g) where+    csdTupleMethods = makeCsdTupleMethods to from+        where to (a, (b, c, d, e, f, g)) = (a, b, c, d, e, f, g)+              from (a, b, c, d, e, f, g) = (a, (b, c, d, e, f, g))  ++instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f, CsdTuple g, CsdTuple h) => CsdTuple (a, b, c, d, e, f, g, h) where+    csdTupleMethods = makeCsdTupleMethods to from+        where to (a, (b, c, d, e, f, g, h)) = (a, b, c, d, e, f, g, h)+              from (a, b, c, d, e, f, g, h) = (a, (b, c, d, e, f, g, h))  ++------------------------------------------------+-- multiple outs++multiOuts :: CsdTuple a => E -> a+multiOuts expr = res+    where res = toCsdTuple $ multiOutsSection (arityCsdTuple res) expr++multiOutsSection :: Int -> E -> [E]+multiOutsSection n e = zipWith (\cellId r -> select cellId r e') [0 ..] outRates+    where outRates = take n $ getRates $ toExp e          +          e' = onExp (setMultiRate outRates) e+          +          setMultiRate rates (Tfm info xs) = Tfm (info{ infoSignature = MultiRate rates ins }) xs +              where ins = case infoSignature info of+                        MultiRate _ a -> a+                        _ -> error "Tuple.hs: multiOutsSection -- should be multiOut expression" +          setMultiRate _ _ = error "Tuple.hs: multiOutsSection -- argument should be Tfm-expression"  +            +          select cellId rate expr = withRate rate $ Select rate cellId (PrimOr $ Right expr)++------------------------------------------------+-- instrument outs++instance Out () where+    type NoSE () = ()+    toOut = const (return [])+    fromOut = const ()++instance Out Sig where+    type NoSE Sig = Sig+    toOut = return . return+    fromOut = head  ++instance (Out a, CsdTuple a) => Out (SE a) where+    type NoSE (SE a) = a+    toOut = join . fmap toOut+    fromOut = return . fromOut+++instance (CsdTuple a, CsdTuple b, Out a, Out b) => Out (a, b) where+    type NoSE (a, b) = (NoSE a, NoSE b)+    toOut (a, b) = liftA2 (++) (toOut a) (toOut b)+    fromOut = toCsdTuple . fmap toE++    +instance (CsdTuple a, CsdTuple b, CsdTuple c, Out a, Out b, Out c) => Out (a, b, c) where+    type NoSE (a, b, c) = (NoSE a, NoSE b, NoSE c)+    toOut (a, b, c) = toOut (a, (b, c))+    fromOut = toCsdTuple . fmap toE+    +instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, Out a, Out b, Out c, Out d) => Out (a, b, c, d) where+    type NoSE (a, b, c, d) = (NoSE a, NoSE b, NoSE c, NoSE d)+    toOut (a, b, c, d) = toOut (a, (b, c, d))+    fromOut = toCsdTuple . fmap toE+    +instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, Out a, Out b, Out c, Out d, Out e) => Out (a, b, c, d, e) where+    type NoSE (a, b, c, d, e) = (NoSE a, NoSE b, NoSE c, NoSE d, NoSE e)+    toOut (a, b, c, d, e) = toOut (a, (b, c, d, e))+    fromOut = toCsdTuple . fmap toE+    +instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f, Out a, Out b, Out c, Out d, Out e, Out f) => Out (a, b, c, d, e, f) where+    type NoSE (a, b, c, d, e, f) = (NoSE a, NoSE b, NoSE c, NoSE d, NoSE e, NoSE f)+    toOut (a, b, c, d, e, f) = toOut (a, (b, c, d, e, f))+    fromOut = toCsdTuple . fmap toE+    +instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f, CsdTuple g, Out a, Out b, Out c, Out d, Out e, Out f, Out g) => Out (a, b, c, d, e, f, g) where+    type NoSE (a, b, c, d, e, f, g) = (NoSE a, NoSE b, NoSE c, NoSE d, NoSE e, NoSE f, NoSE g)+    toOut (a, b, c, d, e, f, g) = toOut (a, (b, c, d, e, f, g))+    fromOut = toCsdTuple . fmap toE+    +instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f, CsdTuple g, CsdTuple h, Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h) => Out (a, b, c, d, e, f, g, h) where+    type NoSE (a, b, c, d, e, f, g, h) = (NoSE a, NoSE b, NoSE c, NoSE d, NoSE e, NoSE f, NoSE g, NoSE h)+    toOut (a, b, c, d, e, f, g, h) = toOut (a, (b, c, d, e, f, g, h))+    fromOut = toCsdTuple . fmap toE+

@@ -0,0 +1,129 @@+module Csound.Exp.Widget where++import Control.Applicative++import Csound.Exp.Gui++import Csound.Exp+import Csound.Exp.Wrapper+import Csound.Exp.SE+import Csound.Exp.GE+import Csound.Exp.Logic+import Csound.Exp.Event++import Csound.Opcode(idur, linseg)++change :: Sig -> BoolSig+change = undefined++mkGuiVar :: Int -> Var+mkGuiVar n = Var GlobalVar Kr ("fl_" ++ show n)++mkGuiHandle :: Int -> Var+mkGuiHandle n = Var GlobalVar Ir ("hfl_" ++ show n)++type Reader a = SE a+type Writer a = a -> SE ()+type Inner    = SE ()++noWrite :: Writer ()+noWrite = return ++noRead :: Reader ()+noRead  = return ()++noInner :: Inner+noInner = return ()++newtype Widget a b = Widget { unWidget :: GE (Gui, Writer a, Reader b, Inner) }++type Sink   a = Widget a ()+type Source a = Widget () a+type Display  = Widget () ()++widget :: Widget a b -> GE (Gui, Writer a, Reader b)+widget a = do +    (gui, writer, reader, inner) <- unWidget a+    appendToGui gui inner+    return (gui, writer, reader)++sink :: Widget a b -> GE (Gui, Writer a)+sink a = do+    (gui, writer, _) <- widget a+    return (gui, writer)++source :: Widget a b -> GE (Gui, Reader b)+source a = do+    (gui, _, reader) <- widget a+    return (gui, reader)++mkWidgetWith :: GE (Gui, Writer a, Reader b, Inner) -> Widget a b+mkWidgetWith = Widget++mkDisplayWith :: GE (Gui, Inner) -> Display +mkDisplayWith a = mkWidgetWith $ do+    (gui, inner) <- a+    return (gui, noWrite, noRead, inner)+    +mkWidget :: GE (Gui, Writer a, Reader b) -> Widget a b+mkWidget = Widget . fmap appendEmptyBody+    where appendEmptyBody (a, b, c) = (a, b, c, noInner)++mkSink :: GE (Gui, Writer a) -> Sink a+mkSink a = mkWidget $ do+    (gui, writer) <- a +    return (gui, writer, noRead)++mkSource :: GE (Gui, Reader b) -> Source b+mkSource a = mkWidget $ do+    (gui, reader) <- a +    return (gui, noWrite, reader)+    +mkDisplay :: GE Gui -> Display+mkDisplay a = mkWidget $ do+    gui <- a+    return (gui, noWrite, noRead)++-----------------------------------------------------------------------------  +-- primitive elements++slider :: Label -> Widget Sig Sig+slider label = mkWidget $ do+    name <- newGuiId+    let gui = Prim name label Slider+        var = mkGuiVar name+        writer = writeVar var+        reader = return $ readVar var+    return (gui, writer, reader)++btn :: Label -> Source (Evt ()) +btn label = mkSource $ do+    name <- newGuiId +    let gui = Prim name label Btn+        var = mkGuiVar name+        reader = return $ trigger $ change $ readVar var+    return (gui, reader)++text :: Display +text = mkDisplay $ do+    name <- newGuiId+    return $ Prim name "" Text++------------------------------------------------------------------------------------++linenWidget :: Source Sig+linenWidget = mkSource $ do+    (g1, r1) <- source $ slider "first"+    (g2, r2) <- source $ slider "second"+    let out = liftA2 fun r1 r2        +    return (Comp [g1, g2], out)+    where fun a b = linseg [0, ir a, 1, idur - ir a - ir b, 1, ir b, 0]++adder :: Display+adder = mkDisplayWith $ do+    (ga, ina)   <- source $ slider "a"+    (gb, inb)   <- source $ slider "b"+    (gres, res) <- sink   $ slider "res"+    return (Comp [ga, gb, gres], +            res =<< liftA2 (+) ina inb)+

@@ -1,46 +1,45 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} {-# Language +        TypeFamilies,         TypeSynonymInstances,-        FlexibleInstances #-}+        FlexibleInstances,+        FlexibleContexts #-} module Csound.Exp.Wrapper(-    Out(..), Outs, Sig, D, Str, BoolSig(..), BoolD(..), Spec, ToSig(..),-    Sig2, Sig3, Sig4,-    SE, se, se_, runSE, execSE,-    Arg(..), ArgMethods(..), toArg, makeArgMethods,-    CsdTuple(..), multiOuts,+    onE1, onE2, toExp, onExp,+    Sig, D, Str, Spec, ToSig(..),+    Sig2, Sig3, Sig4, Ksig, Amp, Cps, Iamp, Icps,     Val(..),-    str, double, ir,-    tfm, pref, prim, p,-    isMultiOutSignature,-    noRate, setRate, -    getRates, tabMap, updateTabSize, defineInstrTabs, defineScoreTabs, substInstrTabs, substScoreTabs, -    readVar, writeVar, gOutVar,-    Channel+    str, double, ir, ar, kr, sig,+    tfm, pref, prim, p,    +    noRate, setRate, withRate,+    getRates, isMultiOutSignature ) where -import Control.Applicative-import Control.Monad(ap, join)-import Control.Monad.Trans.State--import Data.List(nub)-import Data.String import Data.Fix-import Control.Monad.Trans.State-import qualified Data.Map as M-import Data.Foldable(foldMap)+import Data.Default+import Data.String  import Csound.Exp -type Channel = Int--type Outs = SE [Sig] type Sig2 = (Sig, Sig) type Sig3 = (Sig, Sig, Sig) type Sig4 = (Sig, Sig, Sig, Sig) --- | Output of the instrument.-class Out a where-    toOut :: a -> SE [Sig]+-- | An alias for control rate signals (it's used only to clarify that 'Csound.Base.kr' was applied to the signal).+type Ksig = Sig +-- | An alias for amplitude.+type Amp = Sig++-- | An alias for cycles per second.+type Cps = Sig++-- | An alias for amplitude as number.+type Iamp = D++-- | An alias for cycles per second as number.+type Icps = D+ -- | Audio or control rate signals.  newtype Sig = Sig { unSig :: E } @@ -50,42 +49,47 @@ -- | Strings. newtype Str = Str { unStr :: E } --- | Boolean signals. -newtype BoolSig = BoolSig { unBoolSig :: E }---- | Boolean constants. -newtype BoolD = BoolD { unBoolD :: E }- -- | Spectrum of the signal (see FFT and Spectral Processing at "Csound.Opcode.Advanced").  newtype Spec = Spec { unSpec :: E } ---------------------------------------------------- side effects --- | Csound's synonym for 'IO'-monad. 'SE' means Side Effect. --- You will bump into 'SE' trying to read and write to delay lines,--- making random signals or trying to save your audio to file. --- Instrument is expected to return a value of @SE [Sig]@. --- So it's okay to do some side effects when playing a note.-newtype SE a = SE { unSE :: State E a }+------------------------------------------------------+-- values -instance Functor SE where-    fmap f = SE . fmap f . unSE+instance IsString Str where+    fromString = str -instance Applicative SE where-    pure = return-    (<*>) = ap+class Val a where+    toE     :: a -> E+    fromE   :: E -> a -instance Monad SE where-    return = SE . return-    ma >>= mf = SE $ unSE ma >>= unSE . mf+instance Val E          where { toE = id;       fromE = id }    +instance Val (Exp E)    where { toE = noRate;   fromE = toExp }+instance Val Sig        where { toE = unSig;    fromE = Sig }+instance Val D          where { toE = unD;      fromE = D }+instance Val Str        where { toE = unStr;    fromE = Str }+instance Val Spec       where { toE = unSpec;   fromE = Spec } -runSE :: SE a -> (a, E)-runSE a = runState (unSE a) (unD (p 3 :: D))+instance Val Tab    where+    fromE = TabExp+    toE x = case x of+        TabExp e -> e+        primTab -> (prim . PrimTab . Left) primTab -execSE :: SE a -> E-execSE = snd . runSE+onE1 :: (Val a, Val b) => (E -> E) -> (a -> b)+onE1 f = fromE . f . toE +onE2 :: (Val a, Val b, Val c) => (E -> E -> E) -> (a -> b -> c)+onE2 f a b = fromE $ f (toE a) (toE b)++toExp :: Val a => a -> Exp E+toExp = ratedExpExp . unFix . toE++-- Lifts transformation of main expression+onExp :: (Exp E -> Exp E) -> E -> E+onExp f x = case unFix x of+    a -> Fix $ a{ ratedExpExp = f (ratedExpExp a) }+ ------------------------------------------------ -- basic constructors   @@ -96,27 +100,18 @@ withRate r = ratedExp (Just r)  ratedExp :: Val a => Maybe Rate -> Exp E -> a-ratedExp r = wrap . RatedExp r Nothing+ratedExp r = fromE . Fix . RatedExp r Nothing  prim :: Val a => Prim -> a-prim = wrap . noRate . ExpPrim +prim = noRate . ExpPrim   pref :: Name -> Signature -> Info pref name signature = Info name signature Prefix Nothing -inf :: Name -> Signature -> Info-inf name signature = Info name signature Infix Nothing-  -tfm :: Val a => Info -> [RatedExp E] -> a-tfm info args = wrap $ noRate $ Tfm info $ map (toPrimOr . Fix) args--gvar, var :: Val a => Rate -> Name -> a--var  = mkVar LocalVar -gvar = mkVar GlobalVar+tfm :: Val a => Info -> [E] -> a+tfm info args = noRate $ Tfm info $ fmap toPrimOr args -mkVar :: Val a => VarType -> Rate -> String -> a-mkVar ty rate name = wrap $ noRate $ ReadVar (Var ty rate name)+-- variables  p :: Val a => Int -> a p = prim . P@@ -129,456 +124,68 @@ str :: String -> Str str = prim . PrimString -writeVar :: (Val a) => Var -> a -> SE ()-writeVar v x = se_ $ noRate $ WriteVar v $ toPrimOr $ Fix $ unwrap x --readVar :: (Val a) => Var -> a-readVar v = noRate $ ReadVar v--gOutVar :: Int -> Int -> Var-gOutVar instrId portId = Var GlobalVar Ar (gOutName instrId portId)-    where gOutName instrId portId = "Out" ++ show instrId ++ "_" ++ show portId------------------------------------ side effects--se :: (Val a) => E -> SE a-se a = SE $ state $ \s -> -    let x = (unwrap a) { ratedExpDepends = Just s }-    in  (wrap x, Fix $ x)--se_ :: E -> SE ()-se_ = fmap (const ()) . (se :: E -> SE E)----------------------------------------------------- basic extractors--getPrimUnsafe :: Val a => a -> Prim-getPrimUnsafe a = case ratedExpExp $ unwrap a of-    ExpPrim p -> p--tabMap :: [E] -> [[Event Note]] -> TabMap-tabMap es ps = M.fromList $ zip (nub $ (concat $ mapM (getScoreTabs =<< ) ps) ++ (getInstrTabs =<< es)) [1 ..]+getRates :: MainExp a -> [Rate]+getRates (Tfm info _) = case infoSignature info of+    MultiRate outs _ -> outs+    _ -> error "Wrapper.hs:getRates - argument should be multiOut"+getRates _ = error "Wrapper.hs:getRates - argument should be Tfm-expression"     -getInstrTabs :: E -> [LowTab]-getInstrTabs = cata $ \re -> (maybe [] id $ ratedExpDepends re) ++ case fmap fromPrimOr $ ratedExpExp re of    -    ExpPrim p -> getPrimTabs p-    Tfm _ as -> concat as-    ConvertRate _ _ a -> a-    ExpNum a -> foldMap id a-    Select _ _ a -> a-    If info a b -> foldMap id info ++ a ++ b-    ReadVar _ -> []-    WriteVar _ a -> a-    where fromPrimOr x = case unPrimOr x of-            Left  p -> getPrimTabs p-            Right a -> a--getScoreTabs :: Event Note -> [LowTab]-getScoreTabs = (getPrimTabs =<< ) . eventContent--getPrimTabs :: Prim -> [LowTab]-getPrimTabs x = case x of-    PrimTab (Right t) -> [t]-    _ -> []--substPrimTab :: TabMap -> Prim -> Prim-substPrimTab m x = case x of -    PrimTab (Right tab) -> PrimInt (m M.! tab)-    _ -> x--substInstrTabs :: TabMap -> E -> E-substInstrTabs m = cata $ \re -> Fix $ re { ratedExpExp = fmap phi $ ratedExpExp re }-    where phi x = case unPrimOr x of-            Left p -> PrimOr $ Left $ substPrimTab m p-            _ -> x --substScoreTabs :: TabMap -> [Event Note] -> [Event Note]-substScoreTabs m = fmap (fmap (fmap (substPrimTab m)))--defineScoreTabs :: Int -> [Event Note] -> [Event Note]-defineScoreTabs n = fmap (fmap (fmap (definePrimTab n)))--defineInstrTabs :: Int -> E -> E-defineInstrTabs n = cata $ \re -> Fix $ re { ratedExpExp = fmap phi $ ratedExpExp re }-    where phi x = case unPrimOr x of-            Left p -> PrimOr $ Left $ definePrimTab n p-            _ -> x --definePrimTab :: Int -> Prim -> Prim-definePrimTab n x = case x of-    PrimTab (Left tab) -> PrimTab (Right $ defineTab n tab)-    _ -> x--defineTab :: Int -> Tab -> LowTab-defineTab midSize tab = LowTab size (tabGen tab) args-    where size = defineTabSize midSize (tabSize tab)-          args = defineTabArgs size (tabArgs tab)--defineTabArgs :: Int -> TabArgs -> [Double] -defineTabArgs size args = case args of-    ArgsPlain as -> as -    ArgsRelative as -> fromRelative size as-    where fromRelative n as = substEvens (mkRelative n $ getEvens as) as-          getEvens xs = case xs of-            [] -> []-            a:[] -> []-            a:b:as -> b : getEvens as-            -          substEvens evens xs = case (evens, xs) of-            ([], xs) -> xs-            (es, []) -> []-            (e:es, a:b:as) -> a : e : substEvens es as-            -          mkRelative n as = fmap (fromIntegral . round . (s * )) as-            where s = fromIntegral n / sum as-            --defineTabSize :: Int -> TabSize -> Int-defineTabSize base x = case x of-       SizePlain n -> n-       SizeDegree guardPoint degree ->          -                byGuardPoint guardPoint $-                byDegree base degree-    where byGuardPoint guardPoint -            | guardPoint = (+ 1)-            | otherwise  = id-            -          byDegree base n -            | n == 0 = base-            | n > 0  = base * (2 ^ n)-            | n < 0  = base `div` (2 ^ abs n)    --updateTabSize :: (TabSize -> TabSize) -> Tab -> Tab-updateTabSize phi x = case x of-    TabExp _ -> error "you can change size only for primitive tables (made with gen-routines)"-    primTab  -> primTab{ tabSize = phi $ tabSize primTab }+isMultiOutSignature :: Signature -> Bool+isMultiOutSignature x = case x of+    MultiRate _ _ -> True+    _ -> False  -------------------------------------------- -- signals from primitive types  -- | Values that can be converted to signals.  class ToSig a where-    ar :: a -> Sig  -- ^ Forces signal to audio rate. -    kr :: a -> Sig  -- ^ Forces signal to control rate. +    toSig :: a -> Sig          instance ToSig D where-    ar = setRate Ar-    kr = setRate Kr        +    toSig = sig  instance ToSig Sig where-    ar = setRate Ar-    kr = setRate Kr        +    toSig = id      instance ToSig Int where-    ar = ar . double . fromIntegral-    kr = kr . double . fromIntegral-    +    toSig = sig . double . fromIntegral+    instance ToSig Double where-    ar = ar . double-    kr = kr . double-    +    toSig = sig . double+ -------------------------------------------- -- rate conversion   setRate :: (Val a, Val b) => Rate -> a -> b-setRate r a = wrap $ (\x -> x { ratedExpRate = Just r }) $ unwrap a+setRate r a = fromE $ Fix $ (\x -> x { ratedExpRate = Just r }) $ unFix $ toE a +-- | Sets rate to audio rate.+ar :: Sig -> Sig+ar = setRate Ar++-- | Sets rate to control rate.+kr :: Sig -> Sig +kr = setRate Kr+ -- | Converts signal to double. ir :: Sig -> D ir = setRate Ir ---------------------------------------------------------- values--class Val a where-    wrap    :: RatedExp E -> a -    unwrap  :: a -> RatedExp E--instance Val (RatedExp E) where-    wrap = id-    unwrap = id-     -instance Val E where-    wrap = Fix-    unwrap = unFix-     -instance Val Sig where-    wrap = Sig . Fix-    unwrap = unFix . unSig--instance Val D where-    wrap = D . Fix-    unwrap = unFix . unD--instance Val Str where-    wrap = Str . Fix-    unwrap = unFix . unStr--instance Val Tab where-    wrap = TabExp . Fix-    unwrap x = case x of-        TabExp e -> unFix e-        primTab -> (prim . PrimTab . Left) primTab--instance Val BoolSig where-    wrap = BoolSig . Fix-    unwrap = unFix . unBoolSig --instance Val BoolD where-    wrap = BoolD . Fix-    unwrap = unFix . unBoolD --instance Val Spec where-    wrap = Spec . Fix-    unwrap = unFix . unSpec----------------------------------------------------- arguments---- | The abstract type of methods for the class 'Arg'.-data ArgMethods a = ArgMethods -    { arg :: Int -> a-    , toNote :: a -> [Prim]-    , arity :: a -> Int-    }--toArg :: Arg a => a-toArg = arg argMethods 4---- | Defines instance of type class 'Arg' for a new type in terms of an old one.-makeArgMethods :: (Arg a) => (a -> b) -> (b -> a) -> ArgMethods b-makeArgMethods to from = ArgMethods {-    arg = to . arg argMethods,-    toNote = toNote argMethods . from,-    arity = arity argMethods . from }---- | Describes all Csound values that can be used in the score section. --- Instruments are triggered with the values from this type class.--- Actual methods are hidden, but you can easily make instances for your own types--- with function 'makeArgMethods'. You need to describe the new instance in  terms --- of some existing one. For example:------ > data Note = Note --- >     { noteAmplitude    :: D--- >     , notePitch        :: D--- >     , noteVibrato      :: D--- >     , noteSample       :: S--- >     }--- > --- > instance Arg Note where--- >     argMethods = makeArgMethods to from--- >         where to (amp, pch, vibr, sample) = Note amp pch vibr sample--- >               from (Note amp pch vibr sample) = (amp, pch, vibr, sample)--- --- Then you can use this type in an instrument definition.--- --- > instr :: Note -> Out--- > instr x = ...--class Arg a where-    argMethods :: ArgMethods a--instance Arg () where-    argMethods = ArgMethods -        { arg = const ()-        , toNote = const []-        , arity = const 0 }--instance Arg D where-    argMethods = ArgMethods {-        arg = p,-        toNote = pure . getPrimUnsafe,-        arity = const 1 }--instance Arg Str where-    argMethods = ArgMethods {-        arg = p,-        toNote = pure . getPrimUnsafe,-        arity = const 1 }--instance Arg Tab where-    argMethods = ArgMethods {-        arg = p,-        toNote = pure . getPrimUnsafe,-        arity = const 1 }--instance (Arg a, Arg b) => Arg (a, b) where-    argMethods = ArgMethods arg' toNote' arity' -        where arg' n = (a, b)-                  where a = arg argMethods n-                        b = arg argMethods (n + arity argMethods a)-              toNote' (a, b) = toNote argMethods a ++ toNote argMethods b-              arity' (a, b) = arity argMethods a + arity argMethods b    ---instance (Arg a, Arg b, Arg c) => Arg (a, b, c) where-    argMethods = makeArgMethods to from-        where to (a, (b, c)) = (a, b, c)-              from (a, b, c) = (a, (b, c))--instance (Arg a, Arg b, Arg c, Arg d) => Arg (a, b, c, d) where-    argMethods = makeArgMethods to from-        where to (a, (b, c, d)) = (a, b, c, d)-              from (a, b, c, d) = (a, (b, c, d))--instance (Arg a, Arg b, Arg c, Arg d, Arg e) => Arg (a, b, c, d, e) where-    argMethods = makeArgMethods to from-        where to (a, (b, c, d, e)) = (a, b, c, d, e)-              from (a, b, c, d, e) = (a, (b, c, d, e))--instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f) => Arg (a, b, c, d, e, f) where-    argMethods = makeArgMethods to from-        where to (a, (b, c, d, e, f)) = (a, b, c, d, e, f)-              from (a, b, c, d, e, f) = (a, (b, c, d, e, f))--instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f, Arg g) => Arg (a, b, c, d, e, f, g) where-    argMethods = makeArgMethods to from-        where to (a, (b, c, d, e, f, g)) = (a, b, c, d, e, f, g)-              from (a, b, c, d, e, f, g) = (a, (b, c, d, e, f, g))---instance (Arg a, Arg b, Arg c, Arg d, Arg e, Arg f, Arg g, Arg h) => Arg (a, b, c, d, e, f, g, h) where-    argMethods = makeArgMethods to from-        where to (a, (b, c, d, e, f, g, h)) = (a, b, c, d, e, f, g, h)-              from (a, b, c, d, e, f, g, h) = (a, (b, c, d, e, f, g, h))------------------------------------------------------ tuples---- | Describes tuples of Csound values. It's used for functions that can return --- several results (such as 'soundin' or 'diskin2'). Tuples can be nested. -class CsdTuple a where-    fromCsdTuple :: a -> [E]-    toCsdTuple :: [E] -> a-    arityCsdTuple :: a -> Int--instance CsdTuple Sig where-    fromCsdTuple = return . Fix . unwrap-    toCsdTuple = wrap . unFix . head-    arityCsdTuple = const 1--instance CsdTuple D where-    fromCsdTuple = return . Fix . unwrap-    toCsdTuple = wrap . unFix . head-    arityCsdTuple = const 1--instance CsdTuple Tab where-    fromCsdTuple = return . Fix . unwrap-    toCsdTuple = wrap . unFix . head-    arityCsdTuple = const 1--instance CsdTuple Str where-    fromCsdTuple = return . Fix . unwrap-    toCsdTuple = wrap . unFix . head-    arityCsdTuple = const 1--instance CsdTuple Spec where-    fromCsdTuple = return . Fix . unwrap-    toCsdTuple = wrap . unFix . head-    arityCsdTuple = const 1--instance (CsdTuple a, CsdTuple b) => CsdTuple (a, b) where-    fromCsdTuple (a, b) = fromCsdTuple a ++ fromCsdTuple b-    arityCsdTuple (a, b) = arityCsdTuple a + arityCsdTuple b-    toCsdTuple xs = (a, b)-        where a = toCsdTuple $ take (arityCsdTuple a) xs-              xsb = drop (arityCsdTuple a) xs  -              b = toCsdTuple (take (arityCsdTuple b) xsb)--instance (CsdTuple a, CsdTuple b, CsdTuple c) => CsdTuple (a, b, c) where-    fromCsdTuple (a, b, c) = fromCsdTuple (a, (b, c))-    arityCsdTuple (a, b, c) = arityCsdTuple (a, (b, c))-    toCsdTuple = (\(a, (b, c)) -> (a, b, c)) . toCsdTuple --instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d) => CsdTuple (a, b, c, d) where-    fromCsdTuple (a, b, c, d) = fromCsdTuple (a, (b, c, d))-    arityCsdTuple (a, b, c, d) = arityCsdTuple (a, (b, c, d))-    toCsdTuple = (\(a, (b, c, d)) -> (a, b, c, d)) . toCsdTuple--instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e) => CsdTuple (a, b, c, d, e) where-    fromCsdTuple (a, b, c, d, e) = fromCsdTuple (a, (b, c, d, e))-    arityCsdTuple (a, b, c, d, e) = arityCsdTuple (a, (b, c, d, e))-    toCsdTuple = (\(a, (b, c, d, e)) -> (a, b, c, d, e)) . toCsdTuple--instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f) => CsdTuple (a, b, c, d, e, f) where-    fromCsdTuple (a, b, c, d, e, f) = fromCsdTuple (a, (b, c, d, e, f))-    arityCsdTuple (a, b, c, d, e, f) = arityCsdTuple (a, (b, c, d, e, f))-    toCsdTuple = (\(a, (b, c, d, e, f)) -> (a, b, c, d, e, f)) . toCsdTuple--instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f, CsdTuple g) => CsdTuple (a, b, c, d, e, f, g) where-    fromCsdTuple (a, b, c, d, e, f, g) = fromCsdTuple (a, (b, c, d, e, f, g))-    arityCsdTuple (a, b, c, d, e, f, g) = arityCsdTuple (a, (b, c, d, e, f, g))-    toCsdTuple = (\(a, (b, c, d, e, f, g)) -> (a, b, c, d, e, f, g)) . toCsdTuple--instance (CsdTuple a, CsdTuple b, CsdTuple c, CsdTuple d, CsdTuple e, CsdTuple f, CsdTuple g, CsdTuple h) => CsdTuple (a, b, c, d, e, f, g, h) where-    fromCsdTuple (a, b, c, d, e, f, g, h) = fromCsdTuple (a, (b, c, d, e, f, g, h))-    arityCsdTuple (a, b, c, d, e, f, g, h) = arityCsdTuple (a, (b, c, d, e, f, g, h))-    toCsdTuple = (\(a, (b, c, d, e, f, g, h)) -> (a, b, c, d, e, f, g, h)) . toCsdTuple----------------------------------------------------- multiple outs--multiOuts :: CsdTuple a => E -> a-multiOuts exp = res-    where res = toCsdTuple $ multiOutsSection (arityCsdTuple res) exp--multiOutsSection :: Int -> E -> [E]-multiOutsSection n e = zipWith (\n r -> select n r e') [0 ..] rates-    where rates = take n $ getRates $ ratedExpExp $ unFix e          -          e' = Fix $ onExp (setMultiRate rates) $ unFix e-          -          setMultiRate rates (Tfm info xs) = Tfm (info{ infoSignature = MultiRate rates ins }) xs -              where MultiRate _ ins = infoSignature info-            -          select n r e = withRate r $ Select r n (PrimOr $ Right e)--getRates :: MainExp a -> [Rate]-getRates (Tfm info _) = case infoSignature info of-    MultiRate outs _ -> outs-    -isMultiOutSignature :: Signature -> Bool-isMultiOutSignature x = case x of-    MultiRate _ _ -> True-    _ -> False----------------------------------------------------- instrument outs--instance Out Sig where-    toOut = return . return-    -instance Out a => Out [a] where-    toOut = fmap concat . mapM toOut --instance Out a => Out (SE a) where-    toOut = join . fmap toOut--instance (Out a, Out b) => Out (a, b) where-    toOut (a, b) = liftA2 (++) (toOut a) (toOut b)-    -instance (Out a, Out b, Out c) => Out (a, b, c) where-    toOut (a, b, c) = toOut (a, (b, c))-    -instance (Out a, Out b, Out c, Out d) => Out (a, b, c, d) where-    toOut (a, b, c, d) = toOut (a, (b, c, d))- -instance (Out a, Out b, Out c, Out d, Out e) => Out (a, b, c, d, e) where-    toOut (a, b, c, d, e) = toOut (a, (b, c, d, e))--instance (Out a, Out b, Out c, Out d, Out e, Out f) => Out (a, b, c, d, e, f) where-    toOut (a, b, c, d, e, f) = toOut (a, (b, c, d, e, f))--instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g) => Out (a, b, c, d, e, f, g) where-    toOut (a, b, c, d, e, f, g) = toOut (a, (b, c, d, e, f, g))+-- | Converts numbers to signals. It creates constant signal.+sig :: D -> Sig+sig (D a) = Sig a -instance (Out a, Out b, Out c, Out d, Out e, Out f, Out g, Out h) => Out (a, b, c, d, e, f, g, h) where-    toOut (a, b, c, d, e, f, g, h) = toOut (a, (b, c, d, e, f, g, h))+--------------------------------------------+-- defaults +instance Default E   where def = prim $ PrimDouble 0 -       - +instance Default Sig  where def = fromE def    +instance Default D    where def = fromE def+instance Default Tab  where def = fromE def+instance Default Spec where def = fromE def +instance Default Str  where def = prim $ PrimString ""  

@@ -0,0 +1,71 @@+module Csound.IO (+    renderCsd, renderCsdBy, +    writeCsd, writeCsdBy, playCsd, playCsdBy, +    mplayer, mplayerBy, totem, totemBy,+) where+++import System.Cmd(system)+import Data.Default++import Csound.Exp.EventList(CsdSco)+import Csound.Exp.Mix(Mix)+import Csound.Exp.Options(CsdOptions)+import Csound.Render(render)+import Csound.Exp.Tuple(Out)++-- | Renders Csound file.+renderCsd :: (Out a, CsdSco sco) => sco (Mix a) -> IO String+renderCsd = renderCsdBy def++-- | Renders Csound file with options.+renderCsdBy :: (Out a, CsdSco sco) => CsdOptions -> sco (Mix a) -> IO String+renderCsdBy opt as = render opt as++-- | Render Csound file and save it to the give file.+writeCsd :: (Out a, CsdSco sco) => String -> sco (Mix a) -> IO ()+writeCsd file sco = writeFile file =<< renderCsd sco ++-- | Render Csound file with options and save it to the give file.+writeCsdBy :: (Out a, CsdSco sco) => CsdOptions -> String -> sco (Mix a) -> IO ()+writeCsdBy opt file sco = writeFile file =<< renderCsdBy opt sco++-- | RenderCsound file save it to the given file, render with csound command and play it with the given program.+-- +-- > playCsd program file sco +--+-- Produces files @file.csd@ (with 'Csound.Render.Mix.renderCsd') and @file.wav@ (with @csound@) and then invokes:+--+-- > program file.wav+playCsd :: (Out a, CsdSco sco) => String -> String -> sco (Mix a) -> IO ()+playCsd = playCsdBy def++-- | Works just like 'Csound.Render.Mix.playCsd' but you can supply csound options.+playCsdBy :: (Out a, CsdSco sco) => CsdOptions -> String -> String -> sco (Mix a) -> IO ()+playCsdBy opt player file sco = do+    writeCsdBy opt fileCsd sco+    _ <- system $ "csound -o " ++ fileWav ++ " " ++ fileCsd+    _ <- system $ player ++ " " ++ fileWav+    return ()+    where fileCsd = file ++ ".csd"+          fileWav = file ++ ".wav"  ++--------------------------------------------------------+-- players++-- | Renders to tmp.csd and tmp.wav and plays with mplayer.+mplayer :: (Out a, CsdSco sco) => sco (Mix a) -> IO ()+mplayer = mplayerBy def++-- | Renders to tmp.csd and tmp.wav and plays with mplayer.+mplayerBy :: (Out a, CsdSco sco) => CsdOptions -> sco (Mix a) -> IO ()+mplayerBy opt = playCsdBy opt "mplayer" "tmp"++-- | Renders to tmp.csd and tmp.wav and plays with totem player.+totem :: (Out a, CsdSco sco) => sco (Mix a) -> IO ()+totem = totemBy def++-- | Renders to tmp.csd and tmp.wav and plays with totem player.+totemBy :: (Out a, CsdSco sco) => CsdOptions -> sco (Mix a) -> IO ()+totemBy opt = playCsdBy opt "totem" "tmp"+

@@ -2,7 +2,7 @@ -- You can find a lot of examples in source code (see directory @Csound/Opcode@) module Csound.LowLevel(     -- * Types    -    Rate(..), Name, E, +    Rate(..), Name, E, Val(..),      -- * Handy shortcuts     i, k, a, x, s, f, is, ks, as,@@ -59,23 +59,24 @@     -- >            (a, [x, x, i, i]),     -- >            (k, [k, k, i, i])]     -    toE,-     se, se_ ) where -import Data.Fix- import Csound.Exp import Csound.Exp.Wrapper+import Csound.Exp.SE import Csound.Exp.Cons +i, k, a, x, s, f :: Rate+ i = Ir k = Kr a = Ar x = Xr s = Sr f = Fr++is, ks, as :: Int -> [Rate]  is n = replicate n i ks n = replicate n k 

@@ -65,6 +65,8 @@  import Csound.Exp import Csound.Exp.Wrapper+import Csound.Exp.SE+import Csound.Exp.Tuple import Csound.LowLevel  -----------------------------------------------------@@ -78,7 +80,7 @@ -- > ares foscil xamp, kcps, xcar, xmod, kndx, ifn [, iphs] -- -- doc: <http://www.csounds.com/manual/html/foscil.html>-foscil :: Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Sig+foscil :: Amp -> Cps -> Sig -> Sig -> Sig -> Tab -> Sig foscil = opc6 "foscil" [(a, [x, k, x, x, k, i, i])]  -- | Basic frequency modulated oscillator with linear interpolation. @@ -86,7 +88,7 @@ -- > ares foscili xamp, kcps, xcar, xmod, kndx, ifn [, iphs] -- -- doc: <http://www.csounds.com/manual/html/foscili.html>-foscili :: Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Sig+foscili :: Amp -> Cps -> Sig -> Sig -> Sig -> Tab -> Sig foscili = opc6 "foscili" [(a, [x, k, x, x, k, i, i])]  @@ -103,7 +105,7 @@ crossfmGen :: Name -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> (Sig, Sig) crossfmGen name = mopc7 name ([a, a], [x, x, x, x, k, i, i, i, i]) -crossfm, crossfmi, crosspm, crosspmi, crossfmpm, crossfmpmi :: Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> (Sig, Sig)+crossfm, crossfmi, crosspm, crosspmi, crossfmpm, crossfmpmi :: Cps -> Cps -> Sig -> Sig -> Sig -> Tab -> Tab -> (Sig, Sig)  crossfm = crossfmGen "crossfm" crossfmi = crossfmGen "crossfmi"@@ -267,7 +269,7 @@ -- > ar fof xamp, xfund, xform, koct, kband, kris, kdur, kdec, iolaps, ifna, ifnb, itotdur, [iphs, ifmode] -- -- doc: <http://www.csounds.com/manual/html/fof.html>-fof :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> D -> Tab -> Tab -> D -> Sig+fof :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> D -> Tab -> Tab -> D -> Sig fof = opc12 "fof" [(a, [x, x, x, k, k, k, k, k, i, i, i, i, i, i, i])]     -----------------------------------------------------@@ -595,7 +597,7 @@ -- > ares pluck kamp, kcps, icps, ifn, imeth [, iparm1] [, iparm2]      -- -- doc: <http://www.csounds.com/manual/html/pluck.html>-pluck :: Sig -> Sig -> D -> Tab -> D -> Sig+pluck :: Amp -> Cps -> Icps -> Tab -> D -> Sig pluck = opc5 "pluck" [(a, [k,k,i,i,i,i,i])]  -- | repluck is an implementation of the physical model of the plucked string. A user can control the pluck point, @@ -604,7 +606,7 @@ -- > ares repluck iplk, kamp, icps, kpick, krefl, axcite -- -- doc: <http://www.csounds.com/manual/html/repluck.html>-repluck :: D -> Sig -> D -> Sig -> Sig -> Sig -> Sig+repluck :: D -> Amp -> Icps -> Sig -> Sig -> Sig -> Sig repluck = opc6 "repluck" [(a, [i,k,i,k,k,a])]  -- | Audio output is a tone similar to a bowed string, using a physical model developed from Perry Cook, but re-coded for Csound. @@ -612,7 +614,7 @@ -- > ares wgbow kamp, kfreq, kpres, krat, kvibf, kvamp, ifn [, iminfreq] -- -- doc: <http://www.csounds.com/manual/html/wgbow.html>-wgbow :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Sig+wgbow :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig -> Tab -> Sig wgbow = opc7 "wgbow" [(a, ks 6 ++ is 2)]  -- | A physical model of a bowed bar, belonging to the Perry Cook family of waveguide instruments. @@ -621,7 +623,7 @@ -- >      [, ibowpos] [, ilow] -- -- doc: <http://www.csounds.com/manual/html/wgbowedbar.html>-wgbowedbar :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig+wgbowedbar :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig wgbowedbar = opc5 "wgbowedbar" [(a, ks 5 ++ is 2)]  -- | Audio output is a tone related to a brass instrument, using a physical model developed from Perry Cook, but re-coded for Csound. @@ -629,7 +631,7 @@ -- > ares wgbrass kamp, kfreq, ktens, iatt, kvibf, kvamp, ifn [, iminfreq]    -- -- doc: <http://www.csounds.com/manual/html/wgbrass.html>-wgbrass :: Sig -> Sig -> Sig -> D -> Sig -> Sig -> Tab -> Sig +wgbrass :: Amp -> Cps -> Sig -> D -> Sig -> Sig -> Tab -> Sig  wgbrass = opc7 "wgbrass" [(a, [k,k,k,i,k,k,i,i])]  -- | Audio output is a tone similar to a clarinet, using a physical model developed from Perry Cook, but re-coded for Csound. @@ -638,7 +640,7 @@ -- >       [, iminfreq] -- -- doc: <http://www.csounds.com/manual/html/wgclar.html>-wgclar :: Sig -> Sig -> Sig -> D -> D -> Sig -> Sig -> Sig -> Tab -> Sig+wgclar :: Amp -> Cps -> Sig -> D -> D -> Sig -> Sig -> Sig -> Tab -> Sig wgclar = opc9 "wgclar" [(a, [k,k,k,i,i,k,k,k,i,i])]  -- | Audio output is a tone similar to a flute, using a physical model developed from Perry Cook, but re-coded for Csound. @@ -647,7 +649,7 @@ -- >      [, iminfreq] [, ijetrf] [, iendrf] -- -- doc: <http://www.csounds.com/manual/html/wgflute.html>-wgflute :: Sig -> Sig -> Sig -> D -> D -> Sig -> Sig -> Sig -> Tab -> Sig+wgflute :: Amp -> Cps -> Sig -> D -> D -> Sig -> Sig -> Sig -> Tab -> Sig wgflute = opc9 "wgflute" [(a, [k,k,k,i,i,k,k,k,i,i,i,i])]  -- | A high fidelity simulation of a plucked string, using interpolating delay-lines. @@ -655,7 +657,7 @@ -- > ares wgpluck icps, iamp, kpick, iplk, idamp, ifilt, axcite -- -- doc: <http://www.csounds.com/manual/html/wgpluck.html>-wgpluck :: D -> D -> Sig -> D -> D -> D -> Sig -> Sig+wgpluck :: Icps -> Iamp -> Sig -> D -> D -> D -> Sig -> Sig wgpluck = opc7 "wgplusk" [(a, [i,i,k,i,i,i,a])]  -- | wgpluck2 is an implementation of the physical model of the plucked string, with control over the pluck point, the pickup point and the filter. Based on the Karplus-Strong algorithm. @@ -663,7 +665,7 @@ -- > ares wgpluck2 iplk, kamp, icps, kpick, krefl -- -- doc: <http://www.csounds.com/manual/html/wgpluck2.html>-wgpluck2 :: D -> Sig -> D -> Sig -> Sig -> Sig+wgpluck2 :: D -> Amp -> D -> Sig -> Sig -> Sig wgpluck2 = opc5 "wgpluck2" [(a, [i,k,i,k,k])]  -- | A simple waveguide model consisting of one delay-line and one first-order lowpass filter. @@ -671,7 +673,7 @@ -- > ares wguide1 asig, xfreq, kcutoff, kfeedback -- -- doc: <http://www.csounds.com/manual/html/wguide1.html>-wguide1 :: Sig -> Sig -> Sig -> Sig -> Sig+wguide1 :: Amp -> Cps -> Sig -> Sig -> Sig wguide1 = opc4 "wguide1" [(a, [a,x,k,k])]  -- | A model of beaten plate consisting of two parallel delay-lines and two first-order lowpass filters. @@ -680,7 +682,7 @@ -- >       kfeedback1, kfeedback2 -- -- doc: <http://www.csounds.com/manual/html/wguide2.html>-wguide2 ::  Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig+wguide2 ::  Amp -> Cps -> Cps -> Sig -> Sig -> Sig -> Sig -> Sig wguide2 = opc7 "wguide2" [(a, [a,x,x,k,k,k,k])]    ----------------------------------------------------@@ -697,7 +699,7 @@ -- >      ifn4, ivfn -- -- doc: <http://www.csounds.com/manual/html/fmb3.html>-fmb3 :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig+fmb3 :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig   -- | Uses FM synthesis to create a tublar bell sound. It comes from a family of FM sounds, all using 4 basic oscillators and various architectures, as used in the TX81Z synthesizer. @@ -706,7 +708,7 @@ -- >       ifn4, ivfn[, isus] -- -- doc: <http://www.csounds.com/manual/html/fmbell.html>-fmbell :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig+fmbell :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig  -- | Uses FM synthesis to create a “Heavy Metal” sound. It comes from a family of FM sounds, all using 4 basic oscillators and various architectures, as used in the TX81Z synthesizer.  --@@ -714,7 +716,7 @@ -- >       ifn4, ivfn -- -- doc: <http://www.csounds.com/manual/html/fmmetal.html>-fmmetal :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig+fmmetal :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig  -- | Uses FM synthesis to create a percussive flute sound. It comes from a family of FM sounds, all using 4 basic oscillators and various architectures, as used in the TX81Z synthesizer.  --@@ -722,7 +724,7 @@ -- >       ifn3, ifn4, ivfn -- -- doc: <http://www.csounds.com/manual/html/fmpercfl.html>-fmpercfl :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig+fmpercfl :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig  -- | Uses FM synthesis to create a Fender Rhodes electric piano sound. It comes from a family of FM sounds, all using 4 basic oscillators and various architectures, as used in the TX81Z synthesizer.  --@@ -731,7 +733,7 @@ -- -- doc: <http://www.csounds.com/manual/html/fmrhode.html> -fmrhode :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig+fmrhode :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig  -- | FM Singing Voice Synthesis  --@@ -739,10 +741,10 @@ -- >      ifn2, ifn3, ifn4, ivibfn -- -- doc: <http://www.csounds.com/manual/html/fmvoice.html>-fmvoice :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig+fmvoice :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig  -fmwurlie :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig+fmwurlie :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Tab -> Tab -> Sig        fmb3 = fmGen "fmb3" fmbell = fmGen "fmbell"@@ -762,7 +764,7 @@ -- -- doc: <http://www.csounds.com/manual/html/bamboo.html>  -bamboo :: Sig -> D -> Sig+bamboo :: Amp -> D -> Sig bamboo = opc2 "bamboo" [(a, k:is 7)]  -- | cabasa is a semi-physical model of a cabasa sound.@@ -770,7 +772,7 @@ -- > ares cabasa iamp, idettack [, inum] [, idamp] [, imaxshake] -- -- doc: <http://www.csounds.com/manual/html/cabasa.html> -cabasa :: D -> D -> Sig+cabasa :: Iamp -> D -> Sig cabasa = opc2 "cabasa" [(a, is 5)]  -- | crunch is a semi-physical model of a crunch sound.@@ -779,7 +781,7 @@ -- -- doc: <http://www.csounds.com/manual/html/crunch.html>  -crunch :: D -> D -> Sig+crunch :: Iamp -> D -> Sig crunch = opc2 "crunch" [(a, is 5)]  -- | dripwater is a semi-physical model of a water drop.@@ -789,7 +791,7 @@ -- -- doc: <http://www.csounds.com/manual/html/dripwater.html>  -dripwater :: Sig -> D -> Sig+dripwater :: Amp -> D -> Sig dripwater = opc2 "dripwater" [(a, k:is 7)]  -- | guiro is a semi-physical model of a guiro sound.@@ -798,7 +800,7 @@ -- -- doc: <http://www.csounds.com/manual/html/guiro.html>  -guiro :: Sig -> D -> Sig+guiro :: Amp -> D -> Sig guiro = opc2 "guiro" [(a, k:is 7)]  -- | sandpaper is a semi-physical model of a sandpaper sound.@@ -807,7 +809,7 @@ -- -- doc: <http://www.csounds.com/manual/html/sandpaper.html>  -sandpaper :: D -> D -> Sig+sandpaper :: Iamp -> D -> Sig sandpaper = opc2 "sandpaper" [(a, is 5)]  -- | sekere is a semi-physical model of a sekere sound.@@ -816,7 +818,7 @@ -- -- doc: <http://www.csounds.com/manual/html/sekere.html>  -sekere :: D -> D -> Sig+sekere :: Iamp -> D -> Sig sekere = opc2 "sekere" [(a, is 5)]  -- | sleighbells is a semi-physical model of a sleighbell sound.@@ -826,7 +828,7 @@ -- -- doc: <http://www.csounds.com/manual/html/sleighbells.html>  -sleighbells :: Sig -> D -> Sig+sleighbells :: Amp -> D -> Sig sleighbells = opc2 "sleighbells" [(a, k:is 7)]  -- | stix is a semi-physical model of a stick sound.@@ -835,7 +837,7 @@ -- -- doc: <http://www.csounds.com/manual/html/stix.html>  -stix :: D -> D -> Sig+stix :: Iamp -> D -> Sig stix = opc2 "stix" [(a, is 5)]  -- | tambourine is a semi-physical model of a tambourine sound.@@ -844,7 +846,7 @@ -- >      [, ifreq1] [, ifreq2] -- -- doc: <http://www.csounds.com/manual/html/tambourine.html> -tambourine :: Sig -> D -> Sig+tambourine :: Amp -> D -> Sig tambourine = opc2 "tambourine" [(a, k:is 7)]  -------------------------------------------------------------@@ -856,7 +858,7 @@ -- -- doc: <http://www.csounds.com/manual/html/gogobel.html>  -gogobel :: Sig -> Sig -> D -> D -> D -> Sig -> Sig -> Tab -> Sig+gogobel :: Amp -> Cps -> D -> D -> D -> Sig -> Sig -> Tab -> Sig gogobel = opc8 "gogobel" [(a, [k,k,i,i,i,k,k,i])]  @@ -867,7 +869,7 @@ -- -- doc: <http://www.csounds.com/manual/html/marimba.html>  -marimba :: Sig -> Sig -> D -> D -> Tab -> Sig -> Sig -> Tab -> D -> Sig+marimba :: Amp -> Cps -> D -> D -> Tab -> Sig -> Sig -> Tab -> D -> Sig marimba = opc9 "marimba" [(a, [k,k,i,i,i,k,k,i,i,i,i])]  -- | Audio output is a tone related to the shaking of a maraca or similar gourd instrument.@@ -876,7 +878,7 @@ -- -- doc: <http://www.csounds.com/manual/html/shaker.html>  -shaker :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig+shaker :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig shaker = opc5 "shaker" [(a, ks 5 ++ [i])]  @@ -886,7 +888,7 @@ -- -- doc: <http://www.csounds.com/manual/html/vibes.html>  -vibes :: Sig -> Sig -> D -> D -> Tab -> Sig -> Sig -> Tab -> D -> Sig+vibes :: Amp -> Cps -> D -> D -> Tab -> Sig -> Sig -> Tab -> D -> Sig vibes = opc9 "vibes" [(a, [k,k,i,i,i,k,k,i,i])]  ---------------------------------------------------------------@@ -908,7 +910,7 @@ -- -- doc: <http://www.csounds.com/manual/html/mandol.html>  -mandol :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Sig+mandol :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig -> Tab -> Sig mandol = opc7 "mandol" [(a, ks 6 ++ is 2)]  @@ -918,7 +920,7 @@ -- -- doc: <http://www.csounds.com/manual/html/moog.html>  -moog :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Sig+moog :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Tab -> Sig moog = opc9 "moog" [(a, ks 6 ++ is 3)]   @@ -928,7 +930,7 @@ -- -- doc: <http://www.csounds.com/manual/html/voice.html>  -voice :: Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Sig+voice :: Amp -> Cps -> Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Tab -> Sig voice = opc9 "voice" [(a, [k,k,k,k,k,k,k,i,i])]        

@@ -2,13 +2,13 @@ module Csound.Opcode.Basic(     -----------------------------------------------------     -- * Global constants-    idur, zeroDbfs, sampleRate, blockSize,+    idur, zeroDbfs, getSampleRate, getBlockSize,      -----------------------------------------------------     -- * Oscillators and phasors      -- ** Standard Oscillators-    oscils, poscil, poscil3, oscil, oscili, oscil3,+    oscils, poscil, poscil3, oscil, oscili, oscil3, oscil1i,      -- ** Dynamic Sprectrum Oscillators     buzz, gbuzz, mpulse, vco, vco2,  @@ -18,7 +18,7 @@      -----------------------------------------------------     -- * Random and Noise generators    -    rand, randi, randh, rnd31, random, randomi, randomh, pinkish, noise,+    rand, randi, randh, rnd31, random, randomi, randomh, pinkish, noise, pinkish', noise',      -----------------------------------------------------     -- * Envelopes@@ -93,6 +93,7 @@  import Csound.Exp import Csound.Exp.Wrapper+import Csound.Exp.SE import Csound.LowLevel  -- | Reads @p3@-argument for the current instrument.@@ -104,12 +105,12 @@ zeroDbfs = (setRate Ir :: E -> D) $ readVar (VarVerbatim Ir "0dbfs")  -- | Reads @sr@ value.-sampleRate :: D-sampleRate = (setRate Ir :: E -> D) $ readVar (VarVerbatim Ir "sr")+getSampleRate :: D+getSampleRate = (setRate Ir :: E -> D) $ readVar (VarVerbatim Ir "sr")  -- | Reads @ksmps@ value.-blockSize :: D-blockSize = (setRate Ir :: E -> D) $ readVar (VarVerbatim Ir "ksmps")+getBlockSize :: D+getBlockSize = (setRate Ir :: E -> D) $ readVar (VarVerbatim Ir "ksmps")  ----------------------------------------------------- -- Standard Oscillators@@ -120,7 +121,7 @@ -- > ares oscils iamp, icps, iphs [, iflg] -- -- doc: <http://www.csounds.com/manual/html/oscils.html>-oscils :: D -> D -> D -> Sig+oscils :: Iamp -> Icps -> D -> Sig oscils = opc3 "oscils" [(a, [i, i, i])]  oscGen :: Name -> Sig -> Sig -> Tab -> Sig @@ -134,7 +135,7 @@ -- > kres oscil kamp, kcps, ifn [, iphs] -- -- doc: <http://www.csounds.com/manual/html/oscil.html>-oscil :: Sig -> Sig -> Tab -> Sig+oscil :: Amp -> Cps -> Tab -> Sig oscil = oscGen "oscil"  -- |  oscili reads table ifn sequentially and repeatedly at a frequency xcps. The amplitude is scaled by xamp. Linear interpolation is applied for table look up from internal phase values. @@ -143,7 +144,7 @@ -- > kres oscili kamp, kcps, ifn [, iphs] -- -- doc: <http://www.csounds.com/manual/html/oscili.html>-oscili :: Sig -> Sig -> Tab -> Sig+oscili :: Amp -> Cps -> Tab -> Sig oscili = oscGen "oscili"  -- |  oscil3 reads table ifn sequentially and repeatedly at a frequency xcps. The amplitude is scaled by xamp. Cubic interpolation is applied for table look up from internal phase values. @@ -153,7 +154,7 @@ -- -- doc: <http://www.csounds.com/manual/html/oscil3.html> -oscil3 :: Sig -> Sig -> Tab -> Sig+oscil3 :: Amp -> Cps -> Tab -> Sig oscil3 = oscGen "oscil3"  -- | High precision oscillator. @@ -163,7 +164,7 @@ -- -- doc: <http://www.csounds.com/manual/html/poscil.html> -poscil :: Sig -> Sig -> Tab -> Sig+poscil :: Amp -> Cps -> Tab -> Sig poscil = oscGen "poscil"  -- | High precision oscillator with cubic interpolation. @@ -173,9 +174,17 @@ -- -- doc: <http://www.csounds.com/manual/html/poscil3.html> -poscil3 :: Sig -> Sig -> Tab -> Sig+poscil3 :: Amp -> Cps -> Tab -> Sig poscil3 = oscGen "poscil3" +-- | Accesses table values by incremental sampling with linear interpolation. +--+-- > kres oscil1i idel, kamp, idur, ifn+--+-- doc: <http://www.csounds.com/manual/html/oscil1i.html>+oscil1i :: D -> Amp -> D -> Tab -> Sig+oscil1i = opc4 "oscil1i" [(k, [i, k, i, i])]+ ----------------------------------------------------- -- Dynamic Sprectrum Oscillators @@ -187,7 +196,7 @@ -- -- doc: <http://www.csounds.com/manual/html/buzz.html>  -buzz :: Sig -> Sig -> Sig -> Tab -> Sig+buzz :: Amp -> Cps -> Sig -> Tab -> Sig buzz = opc4 "buzz" [(a, [x, x, k, i, i])]  -- |  Output is a set of harmonically related cosine partials. @@ -196,7 +205,7 @@ -- -- doc: <http://www.csounds.com/manual/html/gbuzz.html>  -gbuzz :: Sig -> Sig -> Sig -> Sig -> Sig -> Tab -> Sig+gbuzz :: Amp -> Cps -> Sig -> Sig -> Sig -> Tab -> Sig gbuzz = opc6 "gbuzz" [(a, [x, x, k, k, k, i, i])]  -- | Generates a set of impulses of amplitude kamp separated by kintvl seconds (or samples if kintvl is negative). The first impulse is generated after a delay of ioffset seconds. @@ -205,7 +214,7 @@ -- -- doc: <http://www.csounds.com/manual/html/mpulse.html>  -mpulse :: Sig -> Sig -> Sig+mpulse :: Amp -> Sig -> Sig mpulse = opc2 "mpulse" [(a, [k, k, i])]  -- | Implementation of a band limited, analog modeled oscillator, based on integration of band limited impulses. vco can be used to simulate a variety of analog wave forms. @@ -215,7 +224,7 @@ -- -- doc: <http://www.csounds.com/manual/html/vco.html>  -vco :: Sig -> Sig -> D -> Sig -> Sig+vco :: Amp -> Cps -> D -> Sig -> Sig vco = opc4 "vco" [(a, [x, x, i, k] ++ is 6)]  -- | vco2 is similar to vco. But the implementation uses pre-calculated tables of band-limited waveforms (see also GEN30) @@ -227,7 +236,7 @@ -- -- doc: <http://www.csounds.com/manual/html/vco2.html>  -vco2 :: Sig -> Sig -> Sig+vco2 :: Amp -> Cps -> Sig vco2 = opc2 "vco2" [(a, [k, k, i, k, k, i])]  @@ -241,7 +250,7 @@ -- -- doc: <http://www.csounds.com/manual/html/phasor.html>  -phasor :: Sig -> Sig +phasor :: Cps -> Sig  phasor = opc1 "phasor" [     (a, [x, i]),     (k, [x, i])]@@ -267,10 +276,10 @@ -- -- doc: <http://www.csounds.com/manual/html/rand.html>  -rand :: Sig -> SE Sig-rand sig = se $ opc1 "rand" [+rand :: Amp -> SE Sig+rand asig = se $ opc1 "rand" [     (a, x:rest),-    (k, k:rest)] sig+    (k, k:rest)] asig     where rest = is 3  -- | Generates a controlled random number series with interpolation between each new number. @@ -280,7 +289,7 @@ -- -- doc: <http://www.csounds.com/manual/html/randi.html>  -randi :: Sig -> Sig -> SE Sig+randi :: Amp -> Sig -> SE Sig randi = randiGen "randi"  -- | Generates random numbers and holds them for a period of time. @@ -290,7 +299,7 @@ -- -- doc: <http://www.csounds.com/manual/html/randh.html>  -randh :: Sig -> Sig -> SE Sig+randh :: Amp -> Sig -> SE Sig randh = randiGen "randh"  randiGen :: Name -> Sig -> Sig -> SE Sig@@ -334,7 +343,7 @@ -- > kres randomi kmin, kmax, kcps [,imode] [,ifirstval] -- -- doc: <http://www.csounds.com/manual/html/randomi.html> -randomi :: Sig -> Sig -> Sig -> SE Sig+randomi :: Amp -> Amp -> Cps -> SE Sig randomi a1 a2 a3 = se $ opc3 "randomi" [     (a, [k, k, x, i, i]),     (k, [k, k, k, i, i])] a1 a2 a3@@ -346,7 +355,7 @@ -- -- doc: <http://www.csounds.com/manual/html/randomh.html>  -randomh :: Sig -> Sig -> Sig -> SE Sig+randomh :: Amp -> Amp -> Cps -> SE Sig randomh a1 a2 a3 = se $ opc3 "randomh" [     (a, [k, k, x, i, i]),     (k, [k, k, k, i, i])] a1 a2 a3@@ -377,14 +386,14 @@ -- -- doc: <http://www.csounds.com/manual/html/noise.html>  -noise :: Sig -> Sig -> SE Sig+noise :: Amp -> Sig -> SE Sig noise a1 a2 = se $ opc2 "noise" [(a, [x, k])] a1 a2  -- | Unsafe version of the 'noise' opcode. Unsafe means that there can be possible alias -- on the expression level. Two expressions with the same arguments can be unexpectedly -- rendered as the same expression within one instrument.  -noise' :: Sig -> Sig -> Sig+noise' :: Amp -> Sig -> Sig noise' = opc2 "noise" [(a, [x, k])]  --------------------------------------------------@@ -396,8 +405,8 @@ -- > kres linseg ia, idur1, ib [, idur2] [, ic] [...] -- -- doc: <http://www.csounds.com/manual/html/linseg.html>-linseg :: [D] -> Sig-linseg = opcs "linseg" [+linseg :: [D] -> Ksig+linseg = kr . opcs "linseg" [     (a, repeat i),     (k, repeat i)] @@ -408,8 +417,8 @@ -- -- doc: <http://www.csounds.com/manual/html/linsegr.html> -linsegr :: [D] -> D -> D -> Sig-linsegr xs relDur relVal = opcs "linsegr" ([+linsegr :: [D] -> D -> D -> Ksig+linsegr xs relDur relVal = kr $ opcs "linsegr" ([     (a, repeat i),     (k, repeat i)]) (xs ++ [relDur, relVal]) @@ -421,8 +430,8 @@ -- -- doc: <http://www.csounds.com/manual/html/expseg.html> -expseg :: [D] -> Sig-expseg = opcs "expseg" [+expseg :: [D] -> Ksig+expseg = kr . opcs "expseg" [     (a, repeat i),     (k, repeat i)] @@ -433,8 +442,8 @@ -- -- doc: <http://www.csounds.com/manual/html/expsegr.html> -expsegr :: [D] -> D -> D -> Sig-expsegr xs relDur relVal = opcs "expsegr" ([+expsegr :: [D] -> D -> D -> Ksig+expsegr xs relDur relVal = kr $ opcs "expsegr" ([     (a, repeat i),     (k, repeat i)]) (xs ++ [relDur, relVal]) @@ -445,7 +454,7 @@ -- -- doc: <http://www.csounds.com/manual/html/lpshold.html> -lpshold :: Sig -> Sig -> [Sig] -> Sig+lpshold :: Sig -> Sig -> [Sig] -> Ksig lpshold = mkLps "lpshold"  -- | Generate control signal consisting of linear segments delimited by two or more specified points. The entire envelope is looped at kfreq rate. Each parameter can be varied at k-rate. @@ -455,7 +464,7 @@ -- -- doc: <http://www.csounds.com/manual/html/loopseg.html> -loopseg :: Sig -> Sig -> [Sig] -> Sig+loopseg :: Sig -> Sig -> [Sig] -> Ksig loopseg = mkLps "loopseg"  -- | Generate control signal consisting of controllable exponential segments or linear segments delimited by two or more specified points. @@ -466,11 +475,11 @@ -- -- doc: <http://www.csounds.com/manual/html/looptseg.html> -looptseg :: Sig -> Sig -> [Sig] -> Sig+looptseg :: Sig -> Sig -> [Sig] -> Ksig looptseg = mkLps "looptseg" -mkLps :: Name -> Sig -> Sig -> [Sig] -> Sig-mkLps name kfreq ktrig kvals = opcs name signature $ kfreq:ktrig:kvals+mkLps :: Name -> Sig -> Sig -> [Sig] -> Ksig+mkLps name kfreq ktrig kvals = kr $ opcs name signature $ kfreq:ktrig:kvals     where signature = [(k, repeat k)]  -- | Apply a stright line rise and decay pattern to an imput amp signal.@@ -479,10 +488,10 @@ -- > ar linen xamp, iris, idur, idec -- -- doc: <http://www.csounds.com/manual/html/linen.html>-linen :: Sig -> D -> D -> D -> Sig-linen = opc4 "linen" [+linen :: Amp -> D -> D -> D -> Sig+linen a1 a2 a3 a4 = opc4 "linen" [     (k, k:is 3),-    (a, x:is 3)]+    (a, x:is 3)] a1 a2 a3 a4      -- | Apply a stright line rise then an exponential decay decay while the note is extended in time. --@@ -490,10 +499,10 @@ -- > ar linenr xamp, iris, idur, iatdec -- -- doc: <http://www.csounds.com/manual/html/linenr.html>-linenr :: Sig -> D -> D -> D -> Sig-linenr = opc4 "linenr" [+linenr :: Amp -> D -> D -> D -> Sig+linenr a1 a2 a3 a4 = opc4 "linenr" [     (k, k:is 3),-    (a, x:is 3)]+    (a, x:is 3)] a1 a2 a3 a4  -- | Apply an envelope consisting of 3 segments: --@@ -507,10 +516,10 @@ -- > ar envlpx xamp, irise, idur, idec, ifn, iatss, iatdec, [ixmod] -- -- doc: <http://www.csounds.com/manual/html/envlpx.html>-envlpx :: Sig -> D -> D -> D -> Tab -> D -> D -> Sig-envlpx = opc7 "envlpx" [+envlpx :: Amp -> D -> D -> D -> Tab -> D -> D -> Sig+envlpx a1 a2 a3 a4 a5 a6 a7 = opc7 "envlpx" [     (k, k:is 8),-    (a, x:is 8)]+    (a, x:is 8)] a1 a2 a3 a4 a5 a6 a7  ---------------------------------------------------- -- audio delays@@ -603,10 +612,16 @@ --------------------------------------------------- -- filters +filterSignature1 :: [(Rate, [Rate])] filterSignature1 = [(a, [a, k, i])]++mkFilter1 :: (Val a1, Val a2, Val b) => Name -> a1 -> a2 -> b mkFilter1 name = opc2 name filterSignature1 +filterSignature2 :: [(Rate, [Rate])] filterSignature2 = [(a, [a, k, k, i])]++mkFilter2 :: (Val a1, Val a2, Val a3, Val b) => Name -> a1 -> a2 -> a3 -> b mkFilter2 name = opc3 name filterSignature2  

@@ -10,7 +10,7 @@     -}      -- ** Reading From Tables-    table, tablei, table3, tab_i, tab, +    table, tablei, table3, tableD, tableiD, table3D, tab_i, tab,       -----------------------------------------------------     -- * Signal Input and Output,  Sample and Loop Playback, Soundfonts@@ -70,6 +70,8 @@  import Csound.Exp import Csound.Exp.Wrapper+import Csound.Exp.SE+import Csound.Exp.Tuple import Csound.LowLevel import Csound.Exp.Numeric @@ -157,10 +159,37 @@ -- doc: <http://www.csounds.com/manual/html/table3.html> table3 :: Sig -> Tab -> Sig ++-- | Accesses table values by direct indexing. +--+-- > ires table indx, ifn [, ixmode] [, ixoff] [, iwrap]+--+-- doc: <http://www.csounds.com/manual/html/table.html>+tableD :: D -> Tab -> D++-- | Accesses table values by direct indexing with linear interpolation. +--+-- > ires tablei indx, ifn [, ixmode] [, ixoff] [, iwrap]+--+-- doc: <http://www.csounds.com/manual/html/tablei.html>++tableiD :: D -> Tab -> D++-- | Accesses table values by direct indexing with cubic interpolation. +--+-- > ires table3 indx, ifn [, ixmode] [, ixoff] [, iwrap]+--+-- doc: <http://www.csounds.com/manual/html/table3.html>+table3D :: D -> Tab -> D+ table = mkTable "table" tablei = mkTable "tablei" table3 = mkTable "table3" +tableD = mkTableD "table"+tableiD = mkTableD "tablei"+table3D = mkTableD "table3"+ mkTable :: Name -> Sig -> Tab -> Sig mkTable name = opc2 name [     (a, a:rest),@@ -168,6 +197,13 @@     (i, i:rest)]     where rest = [i, i, i] +mkTableD :: Name -> D -> Tab -> D+mkTableD name = opc2 name [+    (a, a:rest),+    (k, k:rest),+    (i, i:rest)]+    where rest = [i, i, i]+ -- | 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).@@ -228,7 +264,7 @@ -- -- doc: <http://www.csounds.com/manual/html/outch.html> outch :: [(Sig, Sig)] -> SE ()-outch ts = se_ $ opcs "outch" [(x, cycle [a,k])] $ (\(a, b) -> [a, b]) =<< ts+outch ts = se_ $ opcs "outch" [(x, cycle [a,k])] $ (\(a1, a2) -> [a1, a2]) =<< ts  -- ** Sample Playback With Optional Looping @@ -277,7 +313,7 @@ -- >       [, iwrap[, iformat [, iwsize[, ibufsize[, iskipinit]]]]]] -- -- doc: <http://www.csounds.com/manual/html/diskin2.html>-diskin2 :: CsdTuple a => Str -> Sig -> a+diskin2 :: CsdTuple a => Str -> Cps -> a diskin2 = mopc2 "diskin2" (repeat a, s:k:is 6)  -- | Reads stereo audio data from an external MP3 file. @@ -339,7 +375,7 @@ -- -- doc: <http://www.csounds.com/manual/html/fout.html> fout :: [Sig] -> SE ()-fout as = se_ $ opcs "fout" [(x, repeat a)] as+fout sigs = se_ $ opcs "fout" [(x, repeat a)] sigs  -- ** Non-Soundfile Input And Output @@ -381,12 +417,12 @@ instance Nums D   where isSig = const False  conv :: Nums a => NumOp -> a -> a-conv op a = noRate $ ExpNum $ PreInline op [toPrimOr $ toE a]+conv op arg = noRate $ ExpNum $ PreInline op [toPrimOr $ toE arg]  convKr :: Nums a => NumOp -> a -> a-convKr op a = conv op $ phi a+convKr op arg = conv op $ phi arg     where phi-            | isSig a = setRate Kr +            | isSig arg = setRate Kr              | otherwise = id  

@@ -1,90 +1,85 @@+{-# Language TupleSections #-} module Csound.Render(-    renderCsd, renderCsdBy+    render     ) where -import Data.Default-import Data.Maybe(catMaybes)-import qualified Data.Map as M-import qualified Data.Set as S--import Control.Monad.Trans.State(evalState)-import Data.Fix+import Data.Traversable+import Control.Monad.Trans.Writer+import qualified Data.IntMap as IM  import Csound.Exp-import Csound.Exp.Wrapper hiding (double)-import Csound.Render.Sco+import Csound.Exp.Instr(effectExp)+import Csound.Exp.SE+import Csound.Exp.Options+import Csound.Render.Pretty import Csound.Render.Instr import Csound.Render.Options-import Csound.Exp.Numeric--import Csound.Render.Pretty--import Csound.Opcode(clip, zeroDbfs)+import Csound.Render.Channel --- | Renders Csound file.-renderCsd :: [SigOut] -> String-renderCsd = renderCsdBy def+import Csound.Exp.Tuple(Out)+import Csound.Exp.Mix+import Csound.Exp.GE+import Csound.Exp.EventList --- | Renders Csound file with options.-renderCsdBy :: CsdOptions -> [SigOut] -> String-renderCsdBy opt as = show $ ppCsdFile -    (renderFlags opt)-    (renderInstr0 (nchnls lastInstr) (midiAssignTable ids as) opt)-    (ppOrc $ zipWith (renderInstr krateSet) allIds (fmap (substInstrTabs fts) allInstrs))-    (ppSco $ firstInstrNote : lastInstrNote : zipWith (renderScores strs) ids (fmap (substScoreTabs fts) $ scos))-    (renderStringTable strs)-    (renderTotalDur $$ renderTabs fts)-    where scos   = fmap (scoSigOut' . sigOutContent) as          -          (instrs, effects, initOuts) = unzip3 $ zipWith runExpReader as ids    -          fts    = tabMap allInstrs scos-          strs   = stringMap $ concat scos-          ids    = take nInstr [2 .. ]-          -          allInstrs = fmap (defineInstrTabs (tabResolution opt)) $ firstInstr : lastInstr : instrs-          allIds    = firstInstrId : lastInstrId : ids-          -          nInstr = length as-          firstInstrId = 1-          lastInstrId  = nInstr + 2          -        -          firstInstr = execSE $ sequence_ initOuts-          lastInstr  = mixingInstrExp globalEffect effects-           -          scoSigOut' x = case x of-              PlainSigOut _ _ -> defineScoreTabs (tabResolution opt) $ scoSigOut x-              _ -> []            +render :: (Out a, CsdSco f) => CsdOptions -> f (Mix a) -> IO String+render opt sigs = fmap (show . renderHistory (nchnls sigs) (csdEventListDur events) opt) +    $ flip execGE opt $ do+        notes <- traverse unMix events+        instrId <- saveMixerInstr =<< effectExp (proxy masterOuts sigs)+        let notes' = rescaleCsdEventListM $ toCsdEventList notes +        saveMixerNotes $ toLowLevelNotesMap $ Eff instrId notes'+        saveAlwaysOnNote instrId+    where events = toCsdEventList sigs+          proxy :: (Out a) => (a -> SE ()) -> f (Mix a) -> (a -> SE ()) +          proxy = const -          dur = maybe 64000000 id $ totalDur as-          renderTotalDur = ppTotalDur dur-          firstInstrNote = alwayson firstInstrId dur-          lastInstrNote  = alwayson lastInstrId dur-          alwayson instrId time = ppNote instrId 0 time []-          krateSet = S.fromList $ csdKrate opt-          globalEffect = csdEffect opt+toLowLevelNotesMap :: M -> IM.IntMap LowLevelSco+toLowLevelNotesMap mixNotes = IM.fromList $ execWriter $ phi mixNotes+    where    +        phi :: M -> Writer [(Int, LowLevelSco)] ()+        phi x = case x of+            Eff instrId notes -> +                let (instrNotes, rest) = onEff notes+                in  tell [(instrIdCeil instrId, instrNotes)] >> mapM_ phi rest+            Snd _ _ -> error "Render.hs:toLowLevelNotesMap no effect instrument, end up in Snd case" +onEff :: CsdEventList M -> (LowLevelSco, [M])+onEff (CsdEventList _ events) = execWriter $ mapM_ phi events+    where phi :: CsdEvent M -> Writer (LowLevelSco, [M]) ()+          phi (start, dur, content) = case content of+            Snd instrId notes -> tellFst $ fmap (instrId, ) $ csdEventListNotes $ delayCsdEventList start notes+            Eff instrId _     -> tell ([(instrId, (start, dur, []))], [content])+          tellFst x = tell (x, []) -midiAssignTable :: [Int] -> [SigOut] -> [MidiAssign]-midiAssignTable ids instrs = catMaybes $ zipWith mk ids instrs-    where mk n instr = case sigOutContent $ instr of-            Midi ty chn _ -> Just $ MidiAssign ty chn n-            _ -> Nothing+renderHistory :: Int -> Double -> CsdOptions -> History -> Doc+renderHistory numOfChnls totalDur options history = ppCsdFile +    -- flags+    (renderFlags options) +    -- instr 0+    (renderInstr0 numOfChnls (midis history) options)+    -- orchestra+    (renderOrc $ instrs history)+    -- scores+    (renderSco $ scos history)+    -- strings+    (ppMapTable ppStrset $ strIndex history)+    -- ftables+    (ppTotalDur totalDur $$ (ppMapTable ppTabDef $ tabIndex history))     -renderTabs = ppMapTable ppTabDef-renderStringTable = ppMapTable ppStrset+    +renderSco :: Scos -> Doc+renderSco x = vcat $ fmap ppAlwayson $ alwaysOnInstrs x -mixingInstrExp :: ([[Sig]] -> SE [Sig]) -> [SE [Sig]] -> E-mixingInstrExp globalEffect effects = execSE $ outs' . fmap clip' =<< globalEffect =<< sequence effects-    where clip' x = clip x 0 zeroDbfs+renderOrc :: Instrs -> Doc+renderOrc x = (vcatMap renderSource $ instrSources x) $$ (vcatMap renderMixer $ instrMixers x)+    where getMixerNotes instrId = (fmap renderNotes $ mixerNotes x) IM.! (instrIdCeil instrId)           -totalDur :: [SigOut] -> Maybe Double-totalDur as -    | null as'  = Nothing-    | otherwise = Just $ maximum $ map eventEnd . scoSigOut =<< as' -    where as' = filter isNotMidi $ map sigOutContent as-          isNotMidi x = case x of-            Midi _ _ _ -> False-            _ -> True-  -+          renderSource = uncurry renderInstr    +          renderMixer  (instrId, expr) = ppInstr instrId $+               ppFreeChnStmt+            $$ getMixerNotes instrId+            $$ renderInstrBody expr +renderNotes :: LowLevelSco -> Doc+renderNotes notes = vcat $ fmap (\(instrId, evt) -> ppEvent instrId evt chnVar) notes 

@@ -0,0 +1,88 @@+-- | Opcodes for routing the signals+module Csound.Render.Channel (+    masterOuts,+    -- * channel opcodes+    chnVar, chnName, +    chnmix, chnget, chnclear,+    chnUpdateStmt, chnUpdateOpcodeName, ppFreeChnStmt,+    freeChn, +    -- * trigger an instrument+    event, eventWithChannel, instrOn, instrOff+) where++import Csound.Exp+import Csound.Exp.Wrapper+import Csound.Exp.SE+import Csound.Exp.Arg(Arg, toNote)+import Csound.Exp.Tuple(Out(..))+import Csound.Exp.Cons(opc0, opc1, opc2, opcs)+import Csound.Opcode(clip, zeroDbfs, sprintf)+import Csound.Render.Pretty(Doc, verbatimLines, ppOpc, ppVar)   ++---------------------------------------------------------+-- master instrument output++masterOuts :: (Out a) => a -> SE ()+masterOuts outSigs = outs . clipByMax =<< toOut outSigs+    where outs xs = se_ $ case xs of+              a:[] -> opc1 "out" [(Xr, [Ar])] a+              _    -> opcs "outs" [(Xr, repeat Ar)] xs    ++clipByMax :: [Sig] -> [Sig]+clipByMax = fmap clip'+    where clip' x = clip x 0 zeroDbfs++----------------------------------------------------------+-- channels  ++chnVar :: Var+chnVar = Var LocalVar Ir "Port"++chnName :: Int -> D -> Str+chnName name = sprintf formatString . return+    where formatString = str $ 'p' : show name ++ "_" ++ "%d"++chnmix :: Sig -> Str -> SE ()+chnmix a b = se_ $ opc2 "chnmix" [(Xr, [Ar, Sr])] a b++chnget :: Str -> SE Sig+chnget a = se $ opc1 "chnget" [(Ar, [Sr])] a++chnclear :: Str -> SE ()+chnclear a = se_ $ opc1 "chnclear" [(Xr, [Sr])] a++chnUpdateStmt :: Doc+chnUpdateStmt = verbatimLines [+    "giPort init 1",+    "opcode " ++ chnUpdateOpcodeName ++ ", i, 0",+    "xout giPort",+    "giPort = giPort + 1",+    "endop"]++ppFreeChnStmt :: Doc+ppFreeChnStmt = ppOpc (ppVar chnVar) chnUpdateOpcodeName []++chnUpdateOpcodeName :: String+chnUpdateOpcodeName = "FreePort"++freeChn :: SE D+freeChn = se $ opc0 "FreePort" [(Ir, [])]++-------------------------------------------------------------+-- notes++event :: Arg a => InstrId -> D -> D -> a -> SE ()+event instrId start dur arg = se_ $ opcs "event" [(Xr, repeat Ir)] argExp+    where argExp :: [E]+          argExp = fmap prim $ toNote (str "i", instrId, start, dur, arg) ++eventWithChannel :: Arg a => InstrId -> D -> D -> a -> D -> SE ()+eventWithChannel instrId start dur arg chn = event instrId start dur (arg, chn)++instrOn :: Arg a => InstrId -> a -> D -> SE ()+instrOn instrId arg chn = eventWithChannel instrId 0 (-1) arg chn++instrOff :: InstrId -> SE ()+instrOff instrId = event (toNegative instrId) 0 (-1) ()+    where toNegative a = a { instrIdCeil = negate $ abs $ instrIdCeil a }+

@@ -1,71 +1,36 @@-{-# Language TupleSections #-} module Csound.Render.Instr(-    renderInstr+    renderInstr, renderInstrBody ) where -import qualified Data.IntMap as IM-import Control.Monad.Trans.State.Strict-import Data.Char(toLower)-import Data.List(partition, sortBy) import Control.Arrow(second)-import Data.Ord(comparing)-import Data.Maybe(fromJust)+import Data.List(sort, find)+import qualified Data.Map as M +import Data.Maybe(fromJust)+import Data.Default import Data.Fix(Fix(..), cata) import Data.Fix.Cse(fromDag, cse) -import Csound.Exp-import Csound.Exp.Wrapper hiding (double)+import Csound.Exp hiding (Var)+import Csound.Exp.Wrapper(getRates, isMultiOutSignature) -import Csound.Tfm.RateGraph-import Csound.Render.Pretty+import Csound.Tfm.DeduceTypes+import Csound.Tfm.UnfoldMultiOuts+import Csound.Render.Pretty(ppStmt, ppInstr, vcat, Doc) -type InstrId = Int type Dag f = [(Int, f Int)] -renderInstr :: KrateSet -> InstrId -> E -> Doc-renderInstr krateSet instrId exp = ppInstr instrId $ renderInstrBody krateSet exp--renderInstrBody :: KrateSet -> E -> [Doc]-renderInstrBody krateSet sig = map (stmt . clearEmptyResults) $ collectRates krateSet st g-    where stmt :: ([RatedVar], Exp RatedVar) -> Doc-          stmt (res, exp) = renderExp (ppOuts res) exp-          -          st = getRenderState g-          g  = toDag sig---data RenderState = RenderState -    { multiOutsLinks :: IM.IntMap [MultiOutPort]-    , multiOutsRates :: [(Int, Rate)]    -    }--data MultiOutPort = MultiOutPort-    { idMultiOutPort    :: Int-    , orderMultiOutPort :: Int-    } --getRenderState :: Dag RatedExp -> RenderState-getRenderState a = RenderState moLinks moRates-    where moLinks = IM.fromListWith (++) $ map extract selectInfo-          moRates = fmap (second getRate) selectInfo           --          selectInfo = filter (isSelect . ratedExpExp . snd) a    -            -          extract (n, x) = case ratedExpExp x of-                Select rate order (PrimOr (Right parent)) -> (parent, [MultiOutPort n order])--filterMultiOutHelpers :: [(RatedVar, Exp RatedVar)] -> [(RatedVar, Exp RatedVar)]-filterMultiOutHelpers = filter (not . isSelect . snd) +renderInstr :: InstrId -> E -> Doc+renderInstr instrId expr = ppInstr instrId $ renderInstrBody expr -isSelect x = case x of-    Select _ _ _ -> True-    _ -> False+renderInstrBody :: E -> Doc+renderInstrBody sig = vcat $ map (uncurry ppStmt . clearEmptyResults) $ collectRates $ toDag sig +-------------------------------------------------------------+-- E -> Dag  toDag :: E -> Dag RatedExp -toDag exp = fromDag $ cse $ trimByArgLength exp-+toDag expr = fromDag $ cse $ trimByArgLength expr  trimByArgLength :: E -> E trimByArgLength = cata $ \x -> Fix x{ ratedExpExp = phi $ ratedExpExp x }@@ -77,63 +42,101 @@             MultiRate outs ins -> MultiRate outs (trim ins)                     where trim = take (length args)                       - clearEmptyResults :: ([RatedVar], Exp RatedVar) -> ([RatedVar], Exp RatedVar)-clearEmptyResults (res, exp) = (filter ((/= Xr) . ratedVarRate) res, exp)+clearEmptyResults (res, expr) = (filter ((/= Xr) . ratedVarRate) res, expr)         -collectRates :: KrateSet -> RenderState -> Dag RatedExp -> [([RatedVar], Exp RatedVar)]-collectRates krateSet st dag = evalState res lastFreshId  -    where res = tfmMultiRates st $ filterMultiOutHelpers dag1-          (dag1, lastFreshId) = grate krateSet dag+collectRates :: Dag RatedExp -> [([RatedVar], Exp RatedVar)]+collectRates dag = fmap (second ratedExpExp) res+    where res = unfoldMultiOuts unfoldSpec lastFreshId dag1  +          (dag1, lastFreshId) = rateGraph dag +-----------------------------------------------------------+-- Dag -> Dag -tfmMultiRates :: RenderState -> [(RatedVar, Exp RatedVar)] -> State Int [([RatedVar], Exp RatedVar)]-tfmMultiRates st as = mapM substRate as-    where substRate (n, exp) -            | isMultiOutExp exp = fmap (,exp) $ getMultiOutVars (multiOutsLinks st IM.! ratedVarId n) (getRates exp)-            | otherwise = return ([n], exp)+-----------------------------------------------------------+-- deduces types -          isMultiOutExp x = case x of-              Tfm i _ -> isMultiOutSignature (infoSignature i)-              _ -> False-  -getMultiOutVars :: [MultiOutPort] -> [Rate] -> State Int [RatedVar]-getMultiOutVars ports rates = fmap (zipWith RatedVar rates) (getPorts ports)-    where getPorts ps = state $ \lastFreshId -> -            let ps' = sortBy (comparing orderMultiOutPort) ps-                (ids, lastPortOrder) = runState (mapM (fillMissingPorts lastFreshId) ps') 0-                ids' = ids ++ [map (+ lastFreshId) [0 .. portsSize - 1 - lastPortOrder]]                -            in  (concat ids', lastFreshId + portsSize - inUsePortsSize)                             +rateGraph :: [Stmt RatedExp Int] -> ([Stmt RatedExp (Var Rate)], Int)+rateGraph dag = (stmts, lastId)+     where (stmts, lastId) = deduceTypes algSpec dag+           algSpec = TypeGraph mkConvert' defineType' -          portsSize = length rates    -          inUsePortsSize = length ports  -                    -            -          fillMissingPorts :: Int -> MultiOutPort -> State Int [Int]-          fillMissingPorts lastFreshId port = state $ \s ->-                if s == order-                then ([e], next) -                else (fmap (+ lastFreshId) [s .. order - 1] ++ [e], next)-            where e = idMultiOutPort port-                  order = orderMultiOutPort port                  -                  next = order + 1-             +           mkConvert' a = (to, RatedExp def def $ +                   ConvertRate (ratedVarRate to) (ratedVarRate from) $ PrimOr $ Right from)+               where from = convertFrom a+                     to   = convertTo   a -getRate :: RatedExp a -> Rate-getRate = fromJust . ratedExpRate+           defineType' (outVar, expr) desiredRates = (ratesForConversion, (outVar', expr'))+               where possibleRate = deduceRate desiredRates expr +                     ratesForConversion = filter (not . flip coherentRates possibleRate) desiredRates+                     expr' = RatedExp def def $ rateExp possibleRate $ ratedExpExp expr+                     outVar' = ratedVar possibleRate outVar -renderExp :: Doc -> Exp RatedVar -> Doc-renderExp res exp = case fmap ppPrimOrVar exp of-    ExpPrim (PString n) -> ppStrget res n-    ExpPrim p -> res $= ppPrim p-    Tfm info [a, b] | isInfix  info -> res $= binary (infoName info) a b-    Tfm info xs -> ppOpc res (infoName info) xs-    ConvertRate to from x -> ppConvertRate res to from x-    If info t e -> res $= ppIf (ppInline ppCondOp info) t e-    ExpNum (PreInline op as) -> res $= ppNumOp op as-    WriteVar v a -> ppVar v $= a-    ReadVar v -> res $= ppVar v-    x -> error $ "unknown expression: " ++ show x+----------------------------------------------------------+-- unfolds multiple rates - +unfoldSpec :: UnfoldMultiOuts RatedExp Rate +unfoldSpec = UnfoldMultiOuts getSelector' getParentTypes'+    where getSelector' x = case ratedExpExp x of+                Select _ order (PrimOr (Right parent)) -> Just $ Selector parent order +                _ -> Nothing+          getParentTypes' x = case ratedExpExp x of+                Tfm i _ -> if (isMultiOutSignature $ infoSignature i) +                           then Just (getRates $ ratedExpExp x) +                           else Nothing +                _ -> Nothing++coherentRates :: Rate -> Rate -> Bool+coherentRates to from = case (to, from) of+    (a, b)  | a == b    -> True+    (Xr, _)             -> True             +    (Kr, Ir)            -> True+    _                   -> False++deduceRate :: [Rate] -> RatedExp Int -> Rate+deduceRate desiredRates expr = case ratedExpExp expr of+    ExpPrim _ -> case desiredRates of+        [Sr] -> Sr+        _ -> Ir+       +    Tfm info _ | isProcedure info -> Xr+    Tfm info _ -> case infoSignature info of+        MultiRate _ _ -> Xr+        SingleRate tab -> +            let r1 = tfmNoRate (infoName info) desiredRates tab+            in  case ratedExpRate expr of+                    Just r | M.member r tab -> r+                    Just _ -> r1+                    Nothing -> r1     +    ExpNum _ -> case maximum desiredRates of+        Xr -> Ar+        r -> r+    +    Select rate _ _ -> rate+    If _ _ _ -> head $ filter (/= Xr) $ sort desiredRates   +    ReadVar v -> varRate v+    WriteVar _ _ -> Xr    +    where tfmNoRate name rates tab = case sort rates of+              [Xr]  -> tfmNoRate name [Ar] tab                +              Xr:as -> tfmNoRate name as tab+              as -> fromJust $ find (flip M.member tab) (as ++ [minBound .. maxBound])         ++rateExp :: Rate -> Exp Int -> Exp RatedVar +rateExp curRate expr = case expr of+    ExpPrim (P n) | curRate == Sr -> ExpPrim (PString n)+    Tfm i xs -> Tfm i $ mergeWithPrimOrBy (flip ratedVar) xs (ratesFromSignature curRate (infoSignature i))+    Select rate pid a -> Select rate pid (fmap (ratedVar Xr) a)    +    If _ _ _ -> let curRate' = max curRate Kr+                in  fmap (fmap (ratedVar curRate')) expr+    ExpNum _ -> fmap (fmap (ratedVar curRate)) expr    +    ReadVar v -> ReadVar v+    WriteVar v a -> WriteVar v $ fmap (ratedVar (varRate v)) a+    ExpPrim p -> ExpPrim p+    where ratesFromSignature rate signature = case signature of+              SingleRate table -> table M.! rate+              MultiRate _ rs   -> rs++mergeWithPrimOrBy :: (a -> b -> c) -> [PrimOr a] -> [b] -> [PrimOr c]+mergeWithPrimOrBy cons = zipWith (\primOr b -> fmap (flip cons b) primOr)+

@@ -1,83 +1,28 @@ module Csound.Render.Options(-    CsdOptions(..), mixing, mixingBy,-    renderInstr0, renderFlags, MidiAssign(..), CtrlId+    renderInstr0, renderFlags ) where -import Data.List(transpose)-import Data.Default--import Csound.Exp.Wrapper(Channel, Sig, SE, Out, Outs)-import Csound.Render.Sco+import Csound.Exp.Options import Csound.Render.Pretty--type CtrlId = Int---- | Sums signals for every channel.-mixing :: [[Sig]] -> Outs-mixing = return . fmap sum . transpose---- | Sums signals for every channel and the processes the output with the given function.-mixingBy :: ([Sig] -> Outs) -> ([[Sig]] -> Outs)-mixingBy f = (f =<<) . mixing ---- | Csound options. The default value is------ > instance Default CsdOptions where--- >     def = CsdOptions --- >             { csdFlags = ""--- >             , csdRate  = 44100--- >             , csdBlockSize = 64--- >             , csdSeed = Nothing--- >             , csdInitc7 = []--- >             , csdEffect = mixing--- >             , csdKrate  = ["linseg", "expseg", "linsegr", "expsegr", "linen", "linenr", "envlpx"],--- >             , tabResolution = 8192 }  -- should be power of 2--data CsdOptions = CsdOptions -    { csdFlags      :: String       -    , csdRate       :: Int          -    , csdBlockSize  :: Int          -    , csdSeed       :: Maybe Int    -    , csdInitc7     :: [(Channel, CtrlId, Double)]-    , csdEffect     :: [[Sig]] -> Outs-    , csdKrate      :: [String]-    , tabResolution :: Int-    }--instance Default CsdOptions where-    def = CsdOptions -            { csdFlags = ""-            , csdRate  = 44100-            , csdBlockSize = 64-            , csdSeed = Nothing-            , csdInitc7 = []-            , csdEffect = mixing-            , csdKrate  = ["linseg", "expseg", "linsegr", "expsegr", "linen", "linenr", "envlpx"]-            , tabResolution = 8192 }+import Csound.Render.Channel(chnUpdateStmt) -renderFlags = text . csdFlags+renderFlags :: CsdOptions -> Doc+renderFlags = text . flags  type Nchnls = Int -data MidiAssign = MidiAssign -    { midiAssignType    :: MidiType-    , midiAssignChannel :: Channel-    , midiAssignInstr   :: Int }--type InstrId = Int- renderInstr0 :: Nchnls -> [MidiAssign] -> CsdOptions -> Doc-renderInstr0 nchnls massignTable opt = ppInstr0 $ [-    stmt "sr"    $ csdRate opt,-    stmt "ksmps" $ csdBlockSize opt,+renderInstr0 nchnls massignTable opt = ($$ chnUpdateStmt) $ ppInstr0 $ [+    stmt "sr"    $ sampleRate opt,+    stmt "ksmps" $ blockSize opt,     stmt "nchnls" nchnls,        stmt "0dbfs" 1,-    maybe empty seed $ csdSeed opt] -    ++ map initc7 (csdInitc7 opt)-    ++ fmap renderMidiAssign massignTable+    maybe empty stmtSeed $ seed opt] +    ++ map stmtInitc7 (initc7 opt)+    ++ fmap renderMidiAssign massignTable             where stmt a b = text a $= int b-          seed n = ppProc "seed" [int n]-          initc7 (chn, ctl, val) = ppProc "initc7" [int chn, int ctl, double val]+          stmtSeed n = ppProc "seed" [int n]+          stmtInitc7 (chn, ctl, val) = ppProc "initc7" [int chn, int ctl, double val]                 renderMidiAssign :: MidiAssign -> Doc@@ -88,6 +33,4 @@           auxParams = case midiAssignType a of                Pgmassign (Just n) -> [int n]               _ -> []  -- 

@@ -1,13 +1,16 @@ module Csound.Render.Pretty (-    Doc, int, double, text, empty, ($$),+    Doc, int, double, text, empty, ($$), vcat, vcatMap,+    verbatimLines,      binaries, unaries, funcs,     binary, unary, func,     ppMapTable,-    ($=), ppPrimOrVar, ppRatedVar, ppOuts, ppOpc, ppProc, ppVar,+    ppStmt,+    ($=), ppOpc, ppProc, ppVar,     ppPrim, ppTab, ppStrget, ppStrset, ppTabDef, ppConvertRate, ppIf,     ppCsdFile, ppInstr, ppInstr0, ppScore, ppNote, ppTotalDur, ppOrc, ppSco, -    ppInline, ppCondOp, ppNumOp+    ppInline, ppCondOp, ppNumOp,+    ppEvent, ppMasterNote, ppAlwayson ) where  import Data.Char(toLower)@@ -15,8 +18,17 @@ import qualified Data.IntMap as IM import Text.PrettyPrint.Leijen -import Csound.Exp+import Csound.Tfm.Tab+import Csound.Exp +import Csound.Exp.EventList +vcatMap :: (a -> Doc) -> [a] -> Doc+vcatMap f = vcat . fmap f++verbatimLines :: [String] -> Doc+verbatimLines = vcat . fmap text++($$) :: Doc -> Doc -> Doc ($$) = (<$$>)  binaries, unaries, funcs :: String -> [Doc] -> Doc@@ -34,8 +46,8 @@ func :: String -> Doc -> Doc func op a = text op <> parens a -ppMapTable :: (a -> Int -> Doc) -> M.Map a Int -> Doc-ppMapTable phi = vcat . map (uncurry phi) . M.toList+ppMapTable :: (a -> Int -> Doc) -> Index a -> Doc+ppMapTable phi = vcat . map (uncurry phi) . M.toList . indexElems   ppRate :: Rate -> Doc@@ -48,7 +60,7 @@ ppPrimOrVar x = either ppPrim ppRatedVar $ unPrimOr x  ppRatedVar :: RatedVar -> Doc-ppRatedVar (RatedVar r x) = ppRate r <> int x+ppRatedVar v = ppRate (ratedVarRate v) <> int (ratedVarId v)  ppOuts :: [RatedVar] -> Doc ppOuts xs = hsep $ punctuate comma $ map ppRatedVar xs@@ -75,6 +87,8 @@ ppPrim :: Prim -> Doc ppPrim x = case x of     P n -> char 'p' <> int n+    PrimInstrId a -> ppInstrId a+    PString a -> int a         PrimInt n -> int n     PrimDouble d -> double d     PrimString s -> dquotes $ text s@@ -97,25 +111,29 @@     (Kr, Ir) -> out $= k var     (Ir, Ar) -> downsamp var     (Ir, Kr) -> out $= i var+    (a, b)   -> error $ "bug: no rate conversion from " ++ show b ++ " to " ++ show a ++ "."     where upsamp x = ppOpc out "upsamp" [x]           downsamp x = ppOpc out "downsamp" [x]           k = func "k"           i = func "i" -ppTabDef ft id = char 'f' -    <>  int id +ppTabDef :: LowTab -> Int -> Doc+ppTabDef ft tabId = char 'f' +    <>  int tabId      <+> int 0      <+> (int $ lowTabSize ft)     <+> (int $ lowTabGen ft)      <+> (hsep $ map double $ lowTabArgs ft) -ppStrset str id = text "strset" <+> int id <> comma <+> (dquotes $ text str)+ppStrset :: String -> Int -> Doc+ppStrset str strId = text "strset" <+> int strId <> comma <+> (dquotes $ text str)  -- file +newline :: Doc newline = line -       +ppCsdFile :: Doc -> Doc -> Doc -> Doc -> Doc -> Doc -> Doc ppCsdFile flags instr0 instrs scores strTable tabs =      tag "CsoundSynthesizer" [         tag "CsOptions" [flags],@@ -132,34 +150,54 @@  -- instrument -ppInstr :: Int -> [Doc] -> Doc+ppInstr :: InstrId -> Doc -> Doc ppInstr instrId body = vcat [-    text "instr" <+> int instrId,-    vcat body,+    text "instr" <+> ppInstrId instrId,+    body,     text "endin"] +ppInstr0 :: [Doc] -> Doc ppInstr0 = vcat  ppOrc :: [Doc] -> Doc ppOrc = vcat . punctuate newline +ppInstrId :: InstrId -> Doc+ppInstrId (InstrId den nom) = int nom <> maybe empty ppAfterDot den +    where ppAfterDot x = text $ ('.': ) $ reverse $ show x+ -- score +ppSco :: [Doc] -> Doc ppSco = vcat +ppScore :: [Doc] -> Doc ppScore = vcat -ppNote instrId time dur args = char 'i' <> int instrId <+> double time <+> double dur <+> hsep args+ppNote :: InstrId -> Double -> Double -> [Doc] -> Doc+ppNote instrId time dur args = char 'i' <> ppInstrId instrId <+> double time <+> double dur <+> hsep args +ppMasterNote :: InstrId -> CsdEvent [Prim] -> Doc+ppMasterNote instrId evt = ppNote instrId (csdEventStart evt) (csdEventDur evt) (fmap ppPrim $ csdEventContent evt) <+> int 0++ppEvent :: InstrId -> CsdEvent [Prim] -> Var -> Doc+ppEvent instrId evt var = pre <> comma <+> ppVar var+    where pre = ppProc "event_i" $ dquotes (char 'i') : ppInstrId instrId +                : (double $ csdEventStart evt) : (double $ csdEventDur evt) : (fmap ppPrim $ csdEventContent evt)++ppTotalDur :: Double -> Doc ppTotalDur d = text "f0" <+> double d +ppAlwayson :: InstrId -> Doc+ppAlwayson instrId = char 'i' <> ppInstrId instrId <+> int 0  <+> int (-1)+ -- expressions  ppInline :: (a -> [Doc] -> Doc) -> Inline a Doc -> Doc-ppInline ppNode a = ppExp $ inlineExp a    -    where ppExp x = case x of+ppInline ppNode a = iter $ inlineExp a    +    where iter x = case x of               InlinePrim n        -> inlineEnv a IM.! n-              InlineExp op args   -> ppNode op $ fmap ppExp args  +              InlineExp op args   -> ppNode op $ fmap iter args    -- booleans @@ -167,7 +205,6 @@ ppCondOp op = case op of     TrueOp            -> const $ text "(1 == 1)"                     FalseOp           -> const $ text "(0 == 1)"-    Not               -> uno "~"      And               -> bi "&&"     Or                -> bi "||"     Equals            -> bi "=="@@ -177,7 +214,6 @@     LessEquals        -> bi "<="         GreaterEquals     -> bi ">="                              where bi  = binaries -          uno = unaries            -- numeric @@ -198,7 +234,24 @@     where bi  = binaries           uno = unaries           fun = funcs-          firstLetterToLower (x:xs) = toLower x : xs-          +          firstLetterToLower xs = case xs of+            a:as -> toLower a : as+            [] -> error "ppNumOp firstLetterToLower: empty identifier"  +ppStmt :: [RatedVar] -> Exp RatedVar -> Doc+ppStmt outs expr = ppExp (ppOuts outs) expr++ppExp :: Doc -> Exp RatedVar -> Doc+ppExp res expr = case fmap ppPrimOrVar expr of+    ExpPrim (PString n) -> ppStrget res n+    ExpPrim p -> res $= ppPrim p+    Tfm info [a, b] | isInfix  info -> res $= binary (infoName info) a b+    Tfm info xs -> ppOpc res (infoName info) xs+    ConvertRate to from x -> ppConvertRate res to from x+    If info t e -> res $= ppIf (ppInline ppCondOp info) t e+    ExpNum (PreInline op as) -> res $= ppNumOp op as+    WriteVar v a -> ppVar v $= a+    ReadVar v -> res $= ppVar v+    x -> error $ "unknown expression: " ++ show x+          

@@ -1,120 +0,0 @@-module Csound.Render.Sco(-    score, SigOut(..), effect, -    massign , pgmassign, MidiType(..),-    eventEnd, PlainSigOut(..), renderScores,-    runExpReader, nchnls, stringMap, outs'-) where--import Data.List(nub)-import Data.Tuple(swap)-import qualified Data.Map as M-import Control.Monad.Trans.State-import Control.Monad((<=<), zipWithM)-import Data.Fix--import Csound.Exp-import Csound.Exp.Wrapper hiding (double)-import Csound.Exp.Cons(opcs)-import Csound.Exp.Numeric--import Csound.Render.Pretty--type InstrId = Int--type StringMap = M.Map String Int------------------------------------------------------------ scores---- | Applies a global effect function to the signal. With this function we can add reverb or panning to the mixed signal.--- The argument function takes a list of signals. Each cell of the list contains a signal on the given channel.-effect :: ([Sig] -> SE [Sig]) -> SigOut -> SigOut-effect f a = a{ sigOutEffect = f <=< sigOutEffect a }---- | The abstract type of musical tracks. -data SigOut = SigOut -    { sigOutEffect  :: [Sig] -> SE [Sig]    -    , sigOutContent :: PlainSigOut-    } --type ExpReader = Int -> (E, [Var])--runExpReader :: SigOut -> Int -> (E, SE [Sig], SE ())-runExpReader a n = (exp, sigOutEffect a $ fmap readVar vars, mapM_ (flip writeVar (0 :: Sig)) vars)-    where (exp, vars) = (orcSigOut $ sigOutContent a) n---data PlainSigOut -    = PlainSigOut -      { orcSigOut :: ExpReader-      , scoSigOut :: [Event Note] }-    | Midi -      { midiType  :: MidiType-      , midiChn   :: Channel-      , orcSigOut :: ExpReader }-        -data MidiType = Massign | Pgmassign (Maybe Int)---outs' :: [Sig] -> SE ()-outs' as = se_ $ opcs (name as) [(Xr, repeat Ar)] as-    where name as-            | length as == 1 = "out"-            | otherwise      = "outs"---score :: (Arg a, Out b) => (a -> b) -> [(Double, Double, a)] -> SigOut-score instr scores = SigOut return $ -    PlainSigOut (expReader $  (toOut . instr) toArg) (fmap (\(a, b, c) -> Event a b (toNote argMethods c)) scores)---expReader :: SE [Sig] -> ExpReader-expReader instr instrId = swap $ runSE $ do             -    as <- instr-    let vars = instrPorts instrId as    -    zipWithM (\v a -> writeVar v $ readVar v + a) vars as-    return vars-            --instrPorts :: Int -> [Sig] -> [Var]-instrPorts instrId sigs = fmap (gOutVar instrId) ids-    where ids = fmap fst $ zip [1 ..] sigs--nchnls :: E -> Int-nchnls x = case ratedExpExp $ unFix x of-    Tfm _ as -> length as--massign :: (Out a) => Channel -> (Msg -> a) -> SigOut -massign = midiAssign Massign--pgmassign :: (Out a) => Maybe Channel -> Int -> (Msg -> a) -> SigOut -pgmassign chn = midiAssign (Pgmassign chn)--midiAssign :: (Out a) => MidiType -> Channel -> (Msg -> a) -> SigOut-midiAssign ty n = SigOut return . Midi ty n . expReader . toOut . ($ Msg)---------------------------------------------------------------------- render--renderScores :: StringMap -> InstrId -> [Event Note] -> Doc-renderScores strs instrId as = ppScore $ map (renderNote strs instrId) as--renderNote :: StringMap -> InstrId -> Event Note -> Doc-renderNote strs instrId e = ppNote instrId (eventStart e) (eventDur e) (map prim $ eventContent e)-    where prim x = case x of-              PrimInt n -> int n-              PrimDouble d -> double d              -              PrimString s -> int $ strs M.! s-              PrimTab f -> error $ "i'm lost in the scores, substitute me (" ++ show f ++ ")"-              --stringMap :: [Event Note] -> StringMap-stringMap as = M.fromList $ zip (nub $ allStrings =<< as) [1 .. ]-    where allStrings evt = primStrings =<< eventContent evt-          primStrings x = case x of-              PrimString s -> [s]-              _ -> []----

@@ -5,13 +5,16 @@     -- to power of 2 or power of two plus one which stands for guard point (you do need guard point if your intention is to read the      -- table once but you don't need the guard point if you read the table in many cycles, then the guard point is the the first point of your table).       Tab,-    ++    -- * Table granularity+    TabFi, fineFi, coarseFi,        +     -- * Fill table with numbers     doubles,          -- * (In)Harmonic series     PartialStrength, PartialNumber, PartialPhase, PartialDC,-    sines, sines3, sines4, buzzes,+    sines, sines3, sines2, partials, sines4, buzzes,      -- * Interpolants         -- | All funtions have the same shape of arguments:@@ -29,23 +32,23 @@     -- automatically. For example if we want to define a curve that rises to 1 over 25\% of the table and then falls down to zero     -- we can define it like this:     ---    -- > segs [0, 0.25, 1, 0.75, 0] +    -- > lins [0, 0.25, 1, 0.75, 0]      --     -- or     ---    -- > segs [0, 25, 1, 75, 0]+    -- > lins [0, 25, 1, 75, 0]     --     -- or     ---    -- > segs [0, 1, 1, 3, 0]+    -- > lins [0, 1, 1, 3, 0]     --     -- all these expressions are equivalent. -    consts, segs, cubes, exps, splines,    +    consts, lins, cubes, exps, splines,         -- ** Equally spaced interpolants-    econsts, esegs, ecubes, eexps, esplines,+    econsts, elins, ecubes, eexps, esplines,      -- * Polynomials    -    polys, chebs1, chebs2,+    polys, chebs1, chebs2, bessels,          --  @@ -57,18 +60,51 @@          -- ** Handy shortcuts             -- | handy shortcuts for the function 'setDegree'.-    lllofi, llofi, lofi, midfi, hifi, hhifi, hhhifi+    lllofi, llofi, lofi, midfi, hifi, hhifi, hhhifi,+    +    -- * Identifiers for GEN-routines+    +    -- | Low level Csound integer identifiers for tables. These names can be used in the function 'Csound.Base.fineFi'+    idDoubles, idSines, idSines3, idSines2, idPartials, idSines4, idBuzzes, idConsts, idSegs, idCubes, idExps, idSplines,  idPolys, idChebs1, idChebs2, idBessels ) where  import Data.Default import Csound.Exp-import Csound.Exp.Wrapper(updateTabSize)+import Csound.Tfm.Tab(updateTabSize) -interp id as = Tab def id (ArgsRelative as)-plains id as = Tab def id (ArgsPlain as)+import qualified Data.IntMap as IM +-- | Sets different table size for different GEN-routines. +--+-- > fineFi n ps +--+-- where +-- +-- * @n@ is the default value for table size (size is a @n@ power of 2) for all gen routines that are not listed in the next argument @ps@.+--+-- * @ps@ is a list of pairs @(genRoutineId, tableSizeDegreeOf2)@ that sets the given table size for a +--   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)++-- | Sets the same table size for all tables. +--+-- > coarseFi n+--+-- 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++interp :: Int -> [Double] -> Tab+interp genId as = Tab def genId (ArgsRelative as)++plains :: Int -> [Double] -> Tab+plains genId as = Tab def genId (ArgsPlain as)+ insertOnes :: [Double] -> [Double]-insertOnes as = case as of+insertOnes xs = case xs of     [] -> []     a:[] -> [a]     a:as -> a : 1 : insertOnes as@@ -76,7 +112,7 @@  tableSizes :: [Int] tableSizes = [res | a <- twos, b <- twos1, res <- [a, b]]-    where twos  = fmap (2 ^) [0 .. ]+    where twos  = fmap (2 ^) [(0::Int) .. ]           twos1 = fmap ( +1) twos    findTableSize :: Int -> Int@@ -87,7 +123,7 @@ -- | Table contains all provided values  -- (table is extended to contain all values and to be of the power of 2 or the power of two plus one). doubles :: [Double] -> Tab-doubles as = setSize (findTableSize n) $ plains 2 as+doubles as = setSize (findTableSize n) $ plains idDoubles as     where n = length as  -- | Segments of the exponential curves.@@ -100,7 +136,7 @@ -- -- * @n1, n2, ...@  are lengths of the segments relative to the total number of the points in the table exps :: [Double] -> Tab-exps = interp 5+exps = interp idExps  -- | Equally spaced segments of exponential curves. --@@ -122,7 +158,7 @@ -- -- * @n1, n2, ...@  are lengths of the segments relative to the total number of the points in the table cubes :: [Double] -> Tab-cubes = interp 6+cubes = interp idCubes  -- | Equally spaced segments of cubic polynomials. --@@ -136,25 +172,25 @@  -- | Segments of straight lines.  ----- > segs [a, n1, b, n2, c, ...]+-- > lins [a, n1, b, n2, c, ...] -- -- where -- -- * a, b, c .. - are ordinate values -- -- * @n1, n2, ...@  are lengths of the segments relative to the total number of the points in the table-segs :: [Double] -> Tab-segs = interp 7+lins :: [Double] -> Tab+lins = interp idSegs  -- | Equally spaced segments of straight lines. ----- > esegs [a, b, c, ...] +-- > elins [a, b, c, ...]  -- -- is the same as ----- > segs [a, 1, b, 1, c, ...]-esegs :: [Double] -> Tab-esegs = segs . insertOnes+-- > lins [a, 1, b, 1, c, ...]+elins :: [Double] -> Tab+elins = lins . insertOnes  -- | Cubic spline curve. --@@ -166,7 +202,7 @@ -- -- * @n1, n2, ...@  are lengths of the segments relative to the total number of the points in the table splines :: [Double] -> Tab-splines = interp 8+splines = interp idSplines  -- | Equally spaced spline curve. --@@ -188,7 +224,7 @@ -- -- * @n1, n2, ...@  are lengths of the segments relative to the total number of the points in the table consts :: [Double] -> Tab-consts = interp 17+consts = interp idConsts  -- | Equally spaced constant segments. --@@ -216,15 +252,23 @@ -- -- > triangle = sines $ zipWith (\a b -> a / (b ** 2)) (cycle [1, -1]) [1, 3 .. 11] sines :: [PartialStrength] -> Tab-sines = plains 10+sines = plains idSines +-- | Just like 'Csound.Tab.sines2' but partial strength is set to one.+partials :: [PartialNumber] -> Tab+partials xs = sines2 $ zip xs (repeat 1)++-- | Just like 'Csound.Tab.sines3' but phases are set to zero.+sines2 :: [(PartialNumber, PartialStrength)] -> Tab+sines2 xs = sines3 [(num, str, 0) | (num, str) <- xs]+ -- | Specifies series of possibly inharmonic partials. sines3 :: [(PartialNumber, PartialStrength, PartialPhase)] -> Tab-sines3 xs = plains 9 [a | (pn, str, phs) <- xs, a <- [pn, str, phs]]+sines3 xs = plains idSines3 [a | (pn, str, phs) <- xs, a <- [pn, str, phs]]  -- | Specifies series of possibly inharmonic partials with direct current. sines4 :: [(PartialNumber, PartialStrength, PartialPhase, PartialDC)] -> Tab-sines4 xs = plains 19 [a | (pn, str, phs, dc) <- xs, a <- [pn, str, phs, dc]]+sines4 xs = plains idSines4 [a | (pn, str, phs, dc) <- xs, a <- [pn, str, phs, dc]]  -- | Generates values similar to the opcode 'Csound.Opcode.Basic.buzz'.  --@@ -233,7 +277,7 @@ -- With @buzzes n [l, r]@ you get @n@ harmonics from @l@ that are attenuated by the factor of @r@ -- on each step. buzzes :: Double -> [Double] -> Tab-buzzes nh opts = plains 11 (nh : take 2 opts)+buzzes nh opts = plains idBuzzes (nh : take 2 opts)  -- | Modified Bessel function of the second kind, order 0 (for amplitude modulated FM).  --@@ -241,7 +285,7 @@ -- -- the function is defined within the interval @[0, xint]@. bessels :: Double -> Tab-bessels xint = plains 12 [xint]+bessels xint = plains idBessels [xint]  -- | Polynomials. --@@ -255,7 +299,7 @@ -- -- > c0 + c1 * x + c2 * x * x + ... polys :: Double -> Double -> [Double] -> Tab-polys x0 x1 cs = plains 3 (x0:x1:cs)+polys x0 x1 cs = plains idPolys (x0:x1:cs)  -- | Chebyshev polynomials of the first kind. --@@ -267,7 +311,7 @@ -- -- * [h0, h1, h2, ...] -- relative strength of the partials chebs1 :: Double -> Double -> [Double] -> Tab-chebs1 xint xamp hs = plains 13 (xint : xamp : hs)+chebs1 xint xamp hs = plains idChebs1 (xint : xamp : hs)  -- | Chebyshev polynomials of the second kind. --@@ -279,7 +323,7 @@ -- -- * [h0, h1, h2, ...] -- relative strength of the partials chebs2 :: Double -> Double -> [Double] -> Tab-chebs2 xint xamp hs = plains 14 (xint : xamp : hs)+chebs2 xint xamp hs = plains idChebs2 (xint : xamp : hs)   -- | Creates a table of doubles (It's f-table in Csound).@@ -291,7 +335,7 @@ -- -- All tables are created at 0 and memory is never released. gen :: Int -> [Double] -> Tab-gen id args = Tab def id (ArgsPlain args)+gen genId args = Tab def genId (ArgsPlain args)  -- | Adds guard point to the table size (details of the interpolation schemes: you do need guard point if your intention is to read the  -- table once but you don't need the guard point if you read table in many cycles, the guard point is the the first point of your table).  @@ -339,4 +383,24 @@   +idDoubles, idSines, idSines3, idSines2, idPartials, idSines4, idBuzzes, idConsts, idSegs, idCubes, idExps, idSplines,  idPolys, idChebs1, idChebs2, idBessels :: Int++-- Human readable Csound identifiers for GEN-routines++idDoubles = 2+idSines = 10+idSines3 = 9+idSines2 = 9+idPartials = 9+idSines4 = 19+idBuzzes = 11+idConsts = 17+idSegs = 7+idCubes = 6+idExps = 5+idSplines = 8 +idPolys = 3+idChebs1 = 13+idChebs2 = 14+idBessels = 12 

@@ -0,0 +1,124 @@+module Csound.Tfm.DeduceTypes(+    Var(..), TypeGraph(..), Convert(..), Stmt, deduceTypes    +) where++import Data.List(nub)+import qualified Data.Map as M+import qualified Data.IntMap as IM+import qualified Data.Traversable as T++import Data.STRef+import Control.Monad.ST+import Data.Array.ST++type TypeRequests s ty = STArray s Int [ty]++initTypeRequests :: Int -> ST s (TypeRequests s ty)+initTypeRequests size = newArray (0, size - 1) []++requestType :: Var ty -> TypeRequests s ty -> ST s ()+requestType v arr = modifyArray arr (varId v) (varType v :)++modifyArray :: Ix i => STArray s i a -> i -> (a -> a) -> ST s ()+modifyArray arr i f = writeArray arr i . f =<< readArray arr i++getTypes :: Int -> TypeRequests s ty -> ST s [ty]+getTypes n arr = readArray arr n++-- | Typed variable.+data Var a = Var +    { varId   :: Int+    , varType :: a +    } deriving (Show, Eq, Ord)++data GetType ty     +    = NoConversion ty +    -- If there is a conversion we look for a fresh identifier by map +    -- (map converts mismatched type to fresh identifier)+    | ConversionLookup (M.Map ty Int)++type TypeMap ty = IM.IntMap (GetType ty)++lookupVar :: Ord a => TypeMap a -> Var a -> Var a+lookupVar m (Var i r) = case m IM.! i of+    NoConversion     ty -> Var i ty+    ConversionLookup f  -> Var (f M.! r) r++-- Statement: assignment, like+--    leftHandSide = RightHandSide( arguments )+type Stmt f a = (a, f a)++-- When we haave type collisions we have to insert converters:+data Convert a = Convert+    { convertFrom   :: Var a+    , convertTo     :: Var a }++data Line f a = Line +    { lineType      :: (Int, GetType a) +    , lineStmt      :: Stmt f (Var a) +    , lineConverts  :: [Convert a] }++-- Algorithm specification for the given functor 'f' and type labels of 'a'.+data TypeGraph f a = TypeGraph +    -- create a type conversion statement+    { mkConvert   :: Convert a -> Stmt f (Var a)+    -- for a given statement and a list of requested types for the output produces a pair of+    -- (nonConvertibleTypes, statementWithDeducedTypes)+    -- nonConvertibleTypes is used for insertion of converters.+    , defineType  :: Stmt f Int -> [a] -> ([a], Stmt f (Var a)) }++-- | Deduces types for a dag:+--+-- deduceTypes (functorSpecificFuns) (dag) = (dagWithTypes, lastFreshIdentifier)+--+-- Assumption -- dag is labeled with integers. Labels are unique+-- and a list of labels is a range (0, n) (It's just what we get with CSE algorithm). +-- +-- Algorithm proceeds as follows. We init an array of type requests and a reference for fresh identifiers. +-- Type request comes from right hand side of the statement. We need fresh identifiers for converters.+-- If we are going to use a new statement for conversion we need new variables.+-- +-- (discussLine)+-- Then we process lines in reverse order and collect type requests by looking at right hand sides+-- and writing type requests for all arguments. +--+-- (processLine)+-- In the second run we substitute all identifiers with typed variables. It's no so strightforward+-- due to converters. If there are converters we have to insert new statements and substitute identifiers+-- with new ones. That's why we convert variables to variables in the processLine. +--+deduceTypes :: (Ord a, T.Traversable f) => TypeGraph f a -> [Stmt f Int] -> ([Stmt f (Var a)], Int)+deduceTypes spec as = runST $ do+    freshIds <- newSTRef n+    typeRequests <- initTypeRequests n+    lines' <- mapM (discussLine spec typeRequests freshIds) $ reverse as+    let typeMap = IM.fromList $ fmap lineType lines'+    lastId <- readSTRef freshIds+    return (reverse $ processLine typeMap =<< lines', lastId)+    where n = length as+          processLine typeMap line = fmap (mkConvert spec) (lineConverts line) ++ [(a, fmap (lookupVar typeMap) b)]+              where (a, b) = lineStmt line            ++discussLine :: (Ord a, T.Traversable f) => TypeGraph f a -> TypeRequests s a -> STRef s Int -> Stmt f Int -> ST s (Line f a)+discussLine spec typeRequests freshIds stmt@(pid, _) = do+    (conv, expr') <- fmap (defineType spec stmt . nub) $ getTypes pid typeRequests+    _ <- T.traverse (flip requestType typeRequests) (snd expr')+    let curType = fst expr'+    (getType, convs) <- mkGetType conv curType freshIds+    return $ Line (pid, getType) expr' convs++mkGetType :: Ord a => [a] -> Var a -> STRef s Int -> ST s (GetType a, [Convert a])+mkGetType typesToConvert curVar freshIds +    | null typesToConvert = return (NoConversion $ varType curVar, [])+    | otherwise = do+        ids <- nextIds n freshIds+        return (ConversionLookup $ M.fromList $ (varType curVar, varId curVar) : (zip typesToConvert ids), +                zipWith (\i t -> Convert curVar (Var i t)) ids typesToConvert)+    where n = length typesToConvert    ++nextIds :: Int -> STRef s Int -> ST s [Int]+nextIds n ref = do+    curId <- readSTRef ref+    writeSTRef ref (curId + n)    +    return [curId .. n + curId]+

@@ -1,232 +0,0 @@-module Csound.Tfm.RateGraph(-    grate, KrateSet-) where--import Data.List(sort, sortBy, nub, find)-import qualified Data.Map as M-import qualified Data.IntMap as IM-import qualified Data.Set as S-import Data.Ord(comparing)-import Data.Maybe(fromJust, catMaybes)-import Data.Either--import Data.Default--import Data.STRef-import Control.Monad.ST--import Data.Array-import Data.Array.ST-import Data.Array.MArray--import Csound.Exp--import Debug.Trace---echo :: Show a => String -> a -> a-echo msg a = trace (msg ++ ": " ++ show a) a--type AgentId = Int--data Agent = Agent -    { agentResponses :: [Response]-    , agentQueries :: [Query]-    , agentRate :: Rate-    , agentConversions :: [Conversion] }--type Conversion = (RatedVar, Exp RatedVar)--type KrateSet = S.Set Name--instance Default Agent where-    def = Agent [] [] Xr []--data Addr = Addr-    { addrLine :: Int-    , addrArg  :: Int -    } deriving (Show)--data Query = Query-    { queryAddr :: Addr-    , queryRate :: Rate -    } deriving (Show)--data Response  = Response-    { responseAddr      :: Addr    -    , responseRatedVar  :: RatedVar -    } deriving (Show)-     --newtype MsgBox s = MsgBox { unMsgBox :: STArray s Int Agent }--modifyArray :: Ix i => STArray s i a -> i -> (a -> a) -> ST s ()-modifyArray arr i f = writeArray arr i . f =<< readArray arr i--msgBox :: Int -> ST s (MsgBox s)-msgBox size = fmap MsgBox $ newArray (0, size - 1) def--sendQuery :: AgentId -> Query -> MsgBox s -> ST s ()-sendQuery pid q box = modifyArray (unMsgBox box) pid $ -    \x -> x{ agentQueries = q : agentQueries x }--sendResponse :: AgentId -> Response -> MsgBox s -> ST s ()-sendResponse pid r box = modifyArray (unMsgBox box) pid $ -    \x -> x{ agentResponses = r : agentResponses x }--loadAgent :: AgentId -> MsgBox s -> ST s Agent-loadAgent pid box = readArray (unMsgBox box) pid--saveAgent :: AgentId -> MsgBox s -> Agent -> ST s ()-saveAgent pid box e = writeArray (unMsgBox box) pid e--discussLine :: KrateSet -> MsgBox s -> STRef s Int -> (Int, RatedExp Int) -> ST s ()-discussLine krateSet box freshIds (pid, exp) = do-    ag <- loadAgent pid box-    let desiredRates = nub $ map queryRate $ agentQueries ag-        curRate = deduceRate krateSet desiredRates exp-    notifyChildren pid curRate (ratedExpExp exp) box-    convTab <- conversionTable freshIds pid curRate desiredRates-    notifyParents box convTab (agentQueries ag)-    saveAgent pid box $ ag{ agentRate = curRate, agentConversions = getConversions pid curRate convTab }-        -deduceRate :: KrateSet -> [Rate] -> RatedExp Int -> Rate-deduceRate krateSet desiredRates exp = case ratedExpExp exp of-    ExpPrim p -> case desiredRates of-        [Sr] -> Sr-        _ -> Ir-       -    Tfm info as | isProcedure info -> Xr-    Tfm info as -> case infoSignature info of-        MultiRate _ _ -> Xr-        SingleRate tab -> -            let r1 = tfmNoRate (infoName info) desiredRates tab-            in  case ratedExpRate exp of-                    Just r | M.member r tab -> r-                    Just r -> r1-                    Nothing -> r1-    -    ExpNum _ -> case maximum desiredRates of-        Xr -> Ar-        r -> r-    -    Select rate _ _ -> rate-    If info a b -> head $ filter (/= Xr) $ sort desiredRates   -    ReadVar v -> varRate v-    WriteVar _ _ -> Xr    -    where tfmNoRate name desiredRates tab = case sort desiredRates of-              [Xr] -> let newDesiredRates = if S.member name krateSet then [Kr] else [Ar]-                      in  tfmNoRate name newDesiredRates tab                -              Xr:as -> tfmNoRate name as tab-              as -> fromJust $ find (flip M.member tab) (as ++ [minBound .. maxBound])         -   --notifyChildren :: AgentId -> Rate -> Exp Int -> MsgBox s -> ST s ()-notifyChildren pid curRate exp box = mapM_ (\(to, query) -> sendQuery to query box) $ catMaybes $ fmap wrapFromEither $ case exp of-    Tfm info xs -> notifyTfm curRate (infoSignature info) xs-    WriteVar v a -> [(a, mkQuery 0 $ varRate v)]-    If info a b -> (a, mkQuery (-2) curRate) : (b, mkQuery (-1) curRate) : encodeIfEnv (max Kr curRate) (inlineEnv info)-    ExpNum (PreInline op xs) -> queryList xs (repeat curRate)-    _ -> []-    where notifyTfm r signature xs = case signature of-            SingleRate table -> queryList xs $ table M.! r-            MultiRate _ rs -> queryList xs rs--          queryList args rates = zipWith3 (\n a r -> (a, mkQuery n r)) [0 .. ] args rates--          mkQuery n r = Query (Addr pid n) r--          encodeIfEnv rate info = map (\(port, arg) -> (arg, mkQuery port rate)) $ IM.toList info --          wrapFromEither (to, query) = either (const Nothing) (Just . \x -> (x, query)) (unPrimOr to)---notifyParents :: MsgBox s -> M.Map Rate RatedVar -> [Query] -> ST s ()-notifyParents box convTab qs = mapM_ (notifyParent box convTab) qs--notifyParent :: MsgBox s -> M.Map Rate RatedVar -> Query -> ST s ()-notifyParent box convTab q = sendResponse (addrLine $ queryAddr q) (Response (queryAddr q) (convTab M.! queryRate q)) box---conversionTable :: STRef s Int -> Int -> Rate -> [Rate] -> ST s (M.Map Rate RatedVar)-conversionTable freshIds curId curRate desiredRates = fmap M.fromList $ mapM (flip mkRatedVar curRate) desiredRates-    where coherentRates to from = case (to, from) of-              (Xr, a)             -> True             -              (a, b)  | a == b    -> True-              (Kr, Ir)            -> True-              _                   -> False--          mkRatedVar to from -              | coherentRates to from = return $ (to, RatedVar curRate curId)-              | otherwise = do -                  n <- newId freshIds       -                  return $ (to, RatedVar to n)--          newId x = do -             n <- readSTRef x   -             modifySTRef x succ-             return n      --getConversions :: AgentId -> Rate -> M.Map Rate RatedVar -> [Conversion]-getConversions pid curRate convTable = uncurry phi =<< M.toList convTable-    where phi rate var@(RatedVar r n)-            | n == pid  = []-            | otherwise = [(var, ConvertRate r curRate $ PrimOr $ Right $ RatedVar curRate pid)] ---processLine :: MsgBox s -> (Int, RatedExp Int) -> ST s [(RatedVar, Exp RatedVar)]-processLine box (pid, exp) = fmap phi $ loadAgent pid box     -    where phi a = agentConversions a -            ++ return (RatedVar (agentRate a) pid, rateExp (agentRate a) (agentResponses a) (ratedExpExp exp)) ---rateExp :: Rate -> [Response] -> Exp Int -> Exp RatedVar -rateExp curRate rs exp = case exp of-    ExpPrim (P n) | curRate == Sr -> ExpPrim (PString n)-    ExpPrim p -> ExpPrim p-    Tfm i vsOld -> Tfm i $ mergeWithPrimOr vsOld vs-    Select rate pid a -> Select rate pid (fmap (RatedVar Xr) a)    -    If condInfo a' b' -> case mergeWithPrimOr (encodeIfEnv condInfo a' b') vs of-        a:b:rest -> If (decodeIfEnv condInfo rest) a b-    ExpNum (PreInline op vsOld) -> ExpNum (PreInline op $ mergeWithPrimOr vsOld vs)-    ReadVar v -> ReadVar v-    WriteVar v vsOld -> WriteVar v (substPrimOr vsOld $ head vs)-    where vs = map responseRatedVar $ sortBy (comparing $ addrArg . responseAddr) rs-          decodeIfEnv info xs = info{ inlineEnv = IM.fromList $ zip [0..] xs }      -          encodeIfEnv info a b = a:b:(IM.elems $ inlineEnv info)  ---substPrimOr :: PrimOr a -> b -> PrimOr b-substPrimOr p val = PrimOr $ case unPrimOr p of-    Left  a -> Left a-    Right _ -> Right val--mergeWithPrimOr :: [PrimOr a] -> [b] -> [PrimOr b]-mergeWithPrimOr xs ys = case (xs, ys) of-    ([], _) -> []-    (PrimOr (Left a):as, bs) -> PrimOr (Left a) : mergeWithPrimOr as bs-    (PrimOr (Right _):as, b:bs) -> PrimOr (Right b) : mergeWithPrimOr as bs--findRate :: [Rate] -> Rate-findRate [x] = x-findRate xs = case sort $ nub xs of-    [a] -> a-    [] -> Xr-    Xr:as -> minimum as-    as -> minimum as-        --grate :: KrateSet -> [(Int, RatedExp Int)] -> ([(RatedVar, Exp RatedVar)], Int)-grate krateSet as = runST $ do-    freshIds <- newSTRef n-    box <- msgBox n    -    mapM_ (discussLine krateSet box freshIds) lines-    graph <- fmap (reverse . concat) $ mapM (processLine box) lines-    lastFreshId <- readSTRef freshIds-    return (graph, lastFreshId)-    where n = length as-          lines = reverse as -  ---

@@ -0,0 +1,179 @@+module Csound.Tfm.Tab(+    -- * index table+    Index(..), indexInsert,+    -- * strings+    getStrings, substNoteStrs,        +    -- * f-tables+    getInstrTabs, getPrimTabs,+    substInstrTabs, substNoteTabs, +    defineInstrTabs, defineNoteTabs,+    updateTabSize+) where++import Data.Default+import qualified Data.Map as M(Map, lookup, insert, fromList, (!))+import qualified Data.IntMap as IM(findWithDefault)++import Data.Fix(Fix(..), cata)+import Data.Foldable(foldMap)++import Csound.Exp++---------------------------------------------------------------------+--  ++data Index a = Index +    { indexElems  :: M.Map a Int+    , indexLength :: Int }++indexInsert :: Ord a => a -> Index a -> (Int, Index a)+indexInsert a m = case M.lookup a (indexElems m) of+    Just n  -> (n, m)+    Nothing -> (len, m{ indexElems = M.insert a len (indexElems m), indexLength = succ len })+    where len = indexLength m++instance Ord a => Default (Index a) where+    def = Index (M.fromList []) 1++---------------------------------------------------------------------+--  strings++getStrings :: [Prim] -> [String]+getStrings xs = primStrings =<< xs++primStrings :: Prim -> [String]+primStrings x = case x of+    PrimString s -> [s]+    _ -> []++substNoteStrs :: StringMap -> Note -> Note+substNoteStrs m = fmap (substPrimStrs m)++substPrimStrs :: StringMap -> Prim -> Prim+substPrimStrs strs x = case x of+    PrimString s -> PrimInt (strs M.! s)+    _ -> x++----------------------------------------------------------------------------+-- Collects all tables from instruments [E] and notes [Prim]+--+    +getInstrTabs :: E -> [LowTab]+getInstrTabs = cata $ \re -> (maybe [] id $ ratedExpDepends re) ++ case fmap fromPrimOr $ ratedExpExp re of    +    ExpPrim p -> getPrimTabs p+    Tfm _ as -> concat as+    ConvertRate _ _ a -> a+    ExpNum a -> foldMap id a+    Select _ _ a -> a+    If info a b -> foldMap id info ++ a ++ b+    ReadVar _ -> []+    WriteVar _ a -> a+    InitVar _ _ -> []+    IfBegin _ -> []+    ExpBool _ -> []+    ElseIfBegin _ -> []+    ElseBegin -> []+    IfEnd -> []+    where fromPrimOr x = case unPrimOr x of+            Left  p -> getPrimTabs p+            Right a -> a++getPrimTabs :: Prim -> [LowTab]+getPrimTabs x = case x of+    PrimTab (Right t) -> [t]+    _ -> []++----------------------------------------------------------------------------+-- We substitute tables with their unique identifiers. TabMap defines the identifiers.++-- substitutes tables in the instruments (orchestra)+substInstrTabs :: TabMap -> E -> E+substInstrTabs m = cata $ \re -> Fix $ re { ratedExpExp = fmap phi $ ratedExpExp re }+    where phi x = case unPrimOr x of+            Left p -> PrimOr $ Left $ substPrimTab m p+            _ -> x ++-- substitutes tables in the notes (score)+substNoteTabs :: TabMap -> Note -> Note+substNoteTabs m = fmap (substPrimTab m)++-- substitute table in the primitive value.+substPrimTab :: TabMap -> Prim -> Prim+substPrimTab m x = case x of +    PrimTab (Right tab) -> PrimInt (m M.! tab)+    _ -> x++----------------------------------------------------------------------------+-- Defining tables+--+-- To define table means to transform all relative parameters to absolute.+-- Relative parameters (size or points in the case of tables for interpolation)+-- are set from renderer settings. User can change them globally.+--++-- defines tables for an instrument+defineInstrTabs :: TabFi -> E -> E+defineInstrTabs n = cata $ \re -> Fix $ re { ratedExpExp = fmap phi $ ratedExpExp re }+    where phi x = case unPrimOr x of+            Left p -> PrimOr $ Left $ definePrimTab n p+            _ -> x ++-- define tables for a note+defineNoteTabs :: TabFi -> Note -> Note+defineNoteTabs n = fmap (definePrimTab n)++-- define table for a primitive value+definePrimTab :: TabFi -> Prim -> Prim+definePrimTab n x = case x of+    PrimTab (Left tab) -> PrimTab (Right $ defineTab n tab)+    _ -> x++-- set all relative parameters to absolute. +defineTab :: TabFi -> Tab -> LowTab+defineTab tabFi tab = LowTab size (tabGen tab) args+    where size = defineTabSize (getTabSizeBase tabFi tab) (tabSize tab)+          args = defineTabArgs size (tabArgs tab)++getTabSizeBase :: TabFi -> Tab -> Int+getTabSizeBase tf tab = IM.findWithDefault (tabFiBase tf) (tabGen tab) (tabFiGens tf)++defineTabArgs :: Int -> TabArgs -> [Double] +defineTabArgs size args = case args of+    ArgsPlain as -> as +    ArgsRelative as -> fromRelative size as+    where fromRelative n as = substEvens (mkRelative n $ getEvens as) as+          getEvens xs = case xs of+            [] -> []+            _:[] -> []+            _:b:as -> b : getEvens as+            +          substEvens evens xs = case (evens, xs) of+            ([], as) -> as+            (_, []) -> []+            (e:es, a:_:as) -> a : e : substEvens es as+            _ -> error "table argument list should contain even number of elements"+            +          mkRelative n as = fmap ((fromIntegral :: (Int -> Double)) . round . (s * )) as+            where s = fromIntegral n / sum as+            ++defineTabSize :: Int -> TabSize -> Int+defineTabSize base x = case x of+       SizePlain n -> n+       SizeDegree guardPoint degree ->          +                byGuardPoint guardPoint $+                byDegree base degree+    where byGuardPoint guardPoint +            | guardPoint = (+ 1)+            | otherwise  = id+            +          byDegree zero n = 2 ^ max 0 (zero + n) ++----------------------------------------------------------------------------+-- change table size++updateTabSize :: (TabSize -> TabSize) -> Tab -> Tab+updateTabSize phi x = case x of+    TabExp _ -> error "you can change size only for primitive tables (made with gen-routines)"+    primTab  -> primTab{ tabSize = phi $ tabSize primTab }+

@@ -0,0 +1,70 @@+{-# Language TupleSections #-}+module Csound.Tfm.UnfoldMultiOuts(+    unfoldMultiOuts, UnfoldMultiOuts(..), Selector(..)+) where++import Data.List(sortBy)+import Data.Ord(comparing)+import Data.Maybe(mapMaybe, isNothing)+import Control.Monad.Trans.State.Strict+import qualified Data.IntMap as IM++import Csound.Tfm.DeduceTypes(Var(..))++type ChildrenMap = IM.IntMap [Port]++lookupChildren :: ChildrenMap -> Var a -> [Port]+lookupChildren m parentVar = m IM.! varId parentVar++mkChildrenMap :: [(Var a, Selector a)] -> ChildrenMap+mkChildrenMap = IM.fromListWith (++) . fmap extract +    where extract (var, sel) = (varId $ selectorParent sel, +                                return $ Port (varId var) (selectorOrder sel))++data Port = Port +    { portId    :: Int+    , portOrder :: Int } deriving (Show)++type SingleStmt f a = (Var a, f (Var a))+type MultiStmt  f a = ([Var a], f (Var a))++data Selector a = Selector +    { selectorParent  :: Var a+    , selectorOrder   :: Int }++data UnfoldMultiOuts f a = UnfoldMultiOuts {+    getSelector    :: f (Var a) -> Maybe (Selector a),+    getParentTypes :: f (Var a) -> Maybe [a] }++unfoldMultiOuts :: UnfoldMultiOuts f a -> Int -> [SingleStmt f a] -> [MultiStmt f a]+unfoldMultiOuts algSpec lastFreshId stmts = evalState st lastFreshId+    where selectors = mapMaybe (\(lhs, rhs) -> fmap (lhs,) $ getSelector algSpec rhs) stmts+          st = mapM (unfoldStmt algSpec $ mkChildrenMap selectors) $ dropSelectors stmts+          dropSelectors = filter (isNothing . getSelector algSpec . snd)++unfoldStmt :: UnfoldMultiOuts f a -> ChildrenMap -> SingleStmt f a -> State Int (MultiStmt f a)+unfoldStmt algSpec childrenMap (lhs, rhs) = case getParentTypes algSpec rhs of+    Nothing    -> return ([lhs], rhs)+    Just types -> fmap (,rhs) $ formLhs (lookupChildren childrenMap lhs) types++formLhs :: [Port] -> [a] -> State Int [Var a]+formLhs ports types = fmap (zipWith (flip Var) types) (getPorts ports)+    where getPorts ps = state $ \lastFreshId -> +            let ps' = sortBy (comparing portOrder) ps+                (ids, lastPortOrder) = runState (mapM (fillMissingPorts lastFreshId) ps') 0+                freshIdForTail = 1 + lastFreshId + inUsePortsSize+                tailIds = map (+ freshIdForTail) [0 .. outputArity - 1 - lastPortOrder]+            in  (concat ids ++ tailIds, lastFreshId + outputArity - inUsePortsSize)++          outputArity = length types    +          inUsePortsSize = length ports  +                                +          fillMissingPorts :: Int -> Port -> State Int [Int]+          fillMissingPorts lastFreshId port = state $ \s ->+                if s == order+                then ([e], next) +                else (fmap (+ lastFreshId) [s .. order - 1] ++ [e], next)+            where e = portId port+                  order = portOrder port                  +                  next = order + 1+