hdf 0.11 → 0.14

raw patch · 71 files changed

+4606/−1419 lines, 71 filesdep +hsc3dep +murmur-hashdep +sc3-rdudep ~hoscPVP ok

version bump matches the API change (PVP)

Dependencies added: hsc3, murmur-hash, sc3-rdu, split, transformers

Dependency ranges changed: hosc

API changes (from Hackage documentation)

Files

• Help/Graphs/analog-bubbles.lhs +0/−21
• Help/Graphs/lfo-modulation.lhs +0/−20
• Help/Graphs/moto-rev.lhs +0/−17
• Help/Graphs/sprinkler.lhs +0/−15
• Help/UGen/Filter/buf_comb_n.help.lhs +0/−13
• Help/UGen/Filter/decay.help.lhs +0/−7
• Help/UGen/Filter/iir2.help.lhs +0/−7
• Help/UGen/Filter/lag.help.lhs +0/−9
• Help/UGen/Filter/latch.help.lhs +0/−7
• Help/UGen/Filter/lin_exp.help.lhs +0/−7
• Help/UGen/Filter/lin_lin.help.lhs +0/−7
• Help/UGen/Filter/resonz.help.lhs +0/−10
• Help/UGen/Filter/rlpf.help.lhs +0/−6
• Help/UGen/Noise/brown_noise.help.lhs +0/−12
• Help/UGen/Noise/white_noise.help.lhs +0/−4
• Help/UGen/Oscillator/impulse.help.lhs +0/−8
• Help/UGen/Oscillator/lf_pulse.help.lhs +0/−5
• Help/UGen/Oscillator/lf_saw.help.lhs +0/−8
• Help/UGen/Oscillator/sin_osc.help.lhs +0/−12
• Help/dot/counter-gr.dot +20/−0
• Help/dot/counter.dot +13/−0
• Help/hdf.lhs +26/−0
• README +17/−5
• Sound/DF.hs +0/−16
• Sound/DF/Audition.hs +0/−34
• Sound/DF/CGen.hs +0/−208
• Sound/DF/Draw.hs +0/−40
• Sound/DF/Graph.hs +0/−76
• Sound/DF/Node.hs +0/−305
• Sound/DF/UGen.hs +0/−502
• Sound/DF/Uniform/Faust.hs +859/−0
• Sound/DF/Uniform/GADT.hs +18/−0
• Sound/DF/Uniform/GADT/Audition.hs +19/−0
• Sound/DF/Uniform/GADT/DF.hs +382/−0
• Sound/DF/Uniform/GADT/Draw.hs +31/−0
• Sound/DF/Uniform/GADT/UGen.hs +776/−0
• Sound/DF/Uniform/GADT/UGen/Monadic.hs +467/−0
• Sound/DF/Uniform/LL.hs +15/−0
• Sound/DF/Uniform/LL/Audition.hs +58/−0
• Sound/DF/Uniform/LL/CGen.hs +356/−0
• Sound/DF/Uniform/LL/Command.hs +12/−0
• Sound/DF/Uniform/LL/Dot.hs +71/−0
• Sound/DF/Uniform/LL/K.hs +107/−0
• Sound/DF/Uniform/LL/UId.hs +29/−0
• Sound/DF/Uniform/PhT.hs +11/−0
• Sound/DF/Uniform/PhT/Audition.hs +19/−0
• Sound/DF/Uniform/PhT/Draw.hs +14/−0
• Sound/DF/Uniform/PhT/Node.hs +255/−0
• Sound/DF/Uniform/UDF.hs +469/−0
• c/hdf.h +71/−0
• c/text-dl.c +68/−0
• c/text-dl.h +22/−0
• gr/analog-bubbles-buf-m.hs +25/−0
• gr/analog-bubbles-buf.hs +24/−0
• gr/analog-bubbles-m.hs +19/−0
• gr/analog-bubbles.hs +20/−0
• gr/ctl1.hs +27/−0
• gr/drummer.hs +17/−0
• gr/fig-3-6-m.hs +22/−0
• gr/fig-3-6.hs +22/−0
• gr/lfo-modulation-buf-m.hs +23/−0
• gr/lfo-modulation-buf.hs +23/−0
• gr/lfo-modulation-m.hs +37/−0
• gr/lfo-modulation.hs +19/−0
• gr/moto-rev-m.hs +17/−0
• gr/moto-rev.hs +15/−0
• gr/pass-through.hs +8/−0
• gr/silence.hs +9/−0
• gr/sprinkler-m.hs +15/−0
• gr/sprinkler.hs +14/−0
• hdf.cabal +45/−38

@@ -1,21 +0,0 @@-analog bubbles (jmcc)--> import Control.Monad-> import Sound.DF--> let { dpl f a b = liftM2 (,) (f a) (f b)->     ; madd m a = fmap ((+ a) . (* m))->     ; mk_o f = madd 3.0 80.0 (lf_saw f 0.0)->     ; mk_f a = madd 24.0 a (lf_saw 0.4 0.0)->     ; mk_s f = fmap (* 0.04) (sin_osc (midi_cps f) 0.0) }-> in do { (o1, o2) <- dpl mk_o 8.0 7.23->       ; (f1, f2) <- dpl mk_f o1 o2->       ; (s1, s2) <- dpl mk_s f1 f2->       ; c1 <- buf_comb_n 0 s1 0.2 4.0->       ; c2 <- buf_comb_n 1 s2 0.2 4.0->       ; audition [b_alloc 0 44100, b_alloc 1 44100] (out2 (c1, c2)) }--let { o = lfSaw kr (mce2 8 7.23) 0 * 3 + 80-    ; f = lfSaw kr 0.4 0 * 24 + o-    ; s = sinOsc ar (midiCPS f) 0 * 0.04 }-in audition (out 0 (combN s 0.2 0.2 4))

@@ -1,20 +0,0 @@-lfo modulation (jmcc)--> import Control.Monad-> import Sound.DF--> let { dpl f p q = liftM2 (,) (f p) (f q)->     ; madd m a = fmap ((+ a) . (* m))->     ; mk_p f = madd 3600.0 4000.0 (sin_osc f 0.0) }-> in do { s <- madd 80.0 160.0 (sin_osc 0.05 0.0)->       ; (p1, p2) <- dpl mk_p 0.6 0.7->       ; l <- fmap (* 0.05) (lf_pulse s 0 0.4)->       ; (r1, r2) <- dpl (\x -> rlpf l x 0.2) p1 p2->       ; c1 <- buf_comb_n 0 r1 0.20 2.0->       ; c2 <- buf_comb_n 1 r2 0.25 2.0->       ; audition [b_alloc 0 44100, b_alloc 1 44100] (out2 (c1, c2)) }--let { o = fSinOsc kr 0.05 0 * 80 + 160-    ; p = fSinOsc kr (mce2 0.6 0.7) 0 * 3600 + 4000-    ; s = rlpf (lfPulse ar o 0 0.4 * 0.05) p 0.2 }-in audition (out 0 (combL s 0.3 (mce2 0.2 0.25) 2))

@@ -1,17 +0,0 @@-moto rev (jmcc)--> import Control.Monad-> import Sound.DF--> let { dpl f a b = (,) (f a) (f b)->     ; madd m a = fmap ((+ a) . (* m))->     ; dplm f a b = liftM2 (,) (f a) (f b) }-> in do { f <- madd 10.0 21.0 (sin_osc 0.2 0.0)->       ; (s1, s2) <- dplm (\x -> lf_pulse f x 0.1) 0.0 0.1->       ; (o1, o2) <- dplm (\x -> rlpf x 100.0 0.1) s1 s2->       ; let (c1, c2) = dpl (\x -> clip2 x 0.4) o1 o2->         in audition [] (out2 (c1, c2)) }--let { f = sinOsc kr 0.2 0 * 10 + 21-    ; s = lfPulse ar f (mce2 0 0.1) 0.1 }-in audition (out 0 (clip2 (rlpf s 100 0.1) 0.4))

@@ -1,15 +0,0 @@-sprinkler (jmcc)--> import Sound.DF--> let madd m a = fmap ((+ a) . (* m))-> in do { n <- white_noise_m->       ; f <- madd 10.0 7.0 (lf_pulse 0.09 0.0 0.16)->       ; t <- fmap (* 0.1) (lf_pulse f 0.0 0.25)->       ; o <- bpz2 (n * t)->       ; audition [] (out1 o) }--do { n <- M.whiteNoise ar-   ; let { f = lfPulse kr 0.09 0 0.16 * 10 + 7-         ; t = lfPulse kr f 0 0.25 * 0.1 }-     in audition (out 0 (bpz2 (n * t))) }

@@ -1,13 +0,0 @@-> import Sound.DF--> do { n <- white_noise_m->    ; dt <- let f x = lin_exp (x + 2.0) 1.0 2.0 0.0001 0.01->            in fmap f (lf_saw 0.1 0.0)->    ; c <- buf_comb_n 0 (n * 0.1) dt 0.2->    ; audition [b_alloc 0 44100] (out1 c) }--> do { i <- impulse 0.5 0.0->    ; n <- white_noise_m->    ; e <- decay (i * 0.5) 0.2->    ; c <- buf_comb_n 0 (e * n) 0.2 3.0->    ; audition [b_alloc 0 44100] (out1 c) }

@@ -1,7 +0,0 @@-> import Sound.DF--> do { n <- brown_noise_m->    ; f <- lf_saw 0.1 0.0->    ; i <- impulse (lin_lin f (-1.0) 1.0 2.0 5.0) 0.25->    ; e <- decay i 0.2->    ; audition [] (out1 (e * n)) }

@@ -1,7 +0,0 @@-> import Sound.DF--> do { c1 <- iir2 (\x y1 _ -> x + y1) 0.001->    ; o1 <- sin_osc (c1 + 220.0) 0->    ; c2 <- iir2 (\x _ y2 -> x + y2) 0.001->    ; o2 <- sin_osc (c2 + 220.0) 0->    ; audition [] (out2 (o1 * 0.1, o2 * 0.1)) }

@@ -1,9 +0,0 @@-> import Sound.DF--> do { s <- sin_osc 0.05 0.0->    ; let f = lin_lin s (-1.0) 1.0 220.0 440.0->      in do { o <- sin_osc f 0.0->            ; f' <- lag f 1.0->            ; o' <- sin_osc f' 0.0->            ; audition [] (out2 (o * 0.2, o' * 0.2)) } }-

@@ -1,7 +0,0 @@-> import Sound.DF--> do { n <- white_noise_m->    ; i <- impulse 9.0 0.0->    ; l <- latch n i->    ; o <- sin_osc (l * 400.0 + 500.0) 0.0->    ; audition [] (out1 (o * 0.2)) }

@@ -1,7 +0,0 @@-> import Sound.DF--> map (\i -> lin_exp i 1 2 1 3) [1, 1.1 .. 2]--> do { s <- lf_saw 0.25 0.0->    ; o <- sin_osc (lin_exp (s + 1.0) 0.0 2.0 220.0 440.0) 0.0->    ; audition [] (out1 (o * 0.1)) }

@@ -1,7 +0,0 @@-> import Sound.DF--> map (\i -> lin_lin i (-1) 1 0 1) [-1, -0.9 .. 1.0]--> do { s <- lf_saw 1.0 0.0->    ; o <- sin_osc (lin_lin s (-1.0) 1.0 220.0 440.0) 0.0->    ; audition [] (out1 (o * 0.1)) }

@@ -1,10 +0,0 @@-> import Sound.DF--> do { n <- white_noise_m->    ; r <- resonz (n * 0.5) 440.0 0.1->    ; audition [] (out1 r) }--> do { n <- white_noise_m->    ; f <- fmap (\x -> x * 3500.0 + 4500.0) (lf_saw 0.1 0.0)->    ; r <- resonz (n * 0.5) f 0.05->    ; audition [] (out1 r) }

@@ -1,6 +0,0 @@-> import Sound.DF--> do { n <- white_noise_m->    ; f <- fmap (\x -> x * 40.0 + 220.0) (sin_osc 0.5 0.0)->    ; r <- rlpf n f 0.1->    ; audition [] (out1 r) }

@@ -1,12 +0,0 @@-> import Sound.DF--> do { n <- brown_noise_m->    ; audition [] (out1 (n * 0.1)) }--> do { n <- white_noise_m->    ; audition [] (out1 (n * 0.1)) }--> do { n <- brown_noise_m->    ; let f = lin_exp n (-1) 1 64 9600->      in do { o <- sin_osc f 0->            ; audition [] (out1 (o * 0.1)) } }

@@ -1,4 +0,0 @@-> import Sound.DF--> do { n <- white_noise_m->    ; audition [] (out1 (n * 0.1)) }

@@ -1,8 +0,0 @@-> import Sound.DF--> do { o <- impulse 800.0 0.0->    ; audition [] (out1 (o * 0.1)) }--> do { f <- fmap (\x -> x * 2500.0 + 2505.0) (sin_osc 0.25 0.0)->    ; o <- impulse f 0.0->    ; audition [] (out1 (o * 0.1)) }

@@ -1,5 +0,0 @@-> import Sound.DF--> do { o1 <- fmap (\x -> x * 200.0 + 200.0) (lf_pulse 3.0 0.0 0.3)->    ; o2 <- fmap (\x -> x * 0.1) (lf_pulse o1 0.0 0.2)->    ; audition [] (out1 o2) }

@@ -1,8 +0,0 @@-> import Sound.DF--> do { o <- lf_saw 500.0 1.0->    ; audition [] (out1 (o * 0.1)) }--> do { f <- lf_saw 4.0 0.0->    ; o <- lf_saw (f * 400.0 + 400.0) 0.0->    ; audition [] (out1 (o * 0.1)) }

@@ -1,12 +0,0 @@-> import Sound.DF--> do { o <- sin_osc 440.0 0.0->    ; audition [] (out1 (o * 0.1)) }--> do { f <- sin_osc 4.0 0.0->    ; o <- sin_osc (f * 400.0 + 400.0) 0.0->    ; audition [] (out1 (o * 0.1)) }--> do { o1 <- sin_osc 440.0 0.0->    ; o2 <- sin_osc 440.0 pi->    ; audition [] (out1 (o1 + o2)) }

@@ -0,0 +1,20 @@+digraph fgl {+        margin = "0"+        size = "2.0,3.25"+        rotate = "0"+        ratio = "fill"+	1 [label = "df_out1:()"]+	2 [label = "recWr"]+	3 [label = "recRd:0.0"]+	4 [label = "recWr"]+	5 [label = "df_add:Float"]+	6 [label = "1.0"]+	7 [label = "recRd:0.0"]+	2 -> 3 [label = "(0,implicit)"]+	3 -> 1 [label = "(0,recRd)"]+	4 -> 7 [label = "(0,implicit)"]+	5 -> 4 [label = "(0,recWr)"]+	5 -> 2 [label = "(0,recWr)"]+	6 -> 5 [label = "(0,normal)"]+	7 -> 5 [label = "(1,recRd)"]+}

@@ -0,0 +1,13 @@+digraph Anonymous {+margin = "0"+size = "1.25,1.25"+rotate = "0"+ratio = "fill"+graph [splines=false];+1 [shape="record",color="grey",label="{{df_out1|<i_0>}}"];+5 [shape="record",color="blue",label="{{df_add|<i_0>|<i_1>|<o_0>}}"];+6 [shape="record",color="blue",label="{{1.0|<o_0>}}"];+5:o_0 -> 1:i_0 [color="red",label=""]+6:o_0 -> 5:i_0 [color="black",label=""]+5:o_0 -> 5:i_1 [color="red",label=""]+}

@@ -0,0 +1,26 @@+> import Sound.DF.Uniform.GADT++A counter is a first order `iir` at `+` with a unit delay.++> audition_text 5 (out1 (unit_delay 0.0 (iir1 0.0 (+) 1.0)))++    0: 0.000000+    1: 1.000000+    2: 2.000000+    3: 3.000000+    4: 4.000000++The graph drawing indicates two backward arcs, one introduced by+`iir1`, the other by `unit_delay`.++> draw (out1 (counter 0.0 1.0))++![](sw/hdf/Help/svg/counter.svg)++An alternative drawing can be made that includes the _read_ and+_write_ nodes that implement the recursion scheme, connected by an+_implicit_ edge.++> gr_draw' (out1 (counter 0.0 1.0))++![](sw/hdf/Help/svg/counter-gr.svg)

@@ -1,8 +1,20 @@-hdf - haskell data flow library for audio processing+hdf - haskell data flow+----------------------- -requires jack-dl from rju.+[haskell][hs] library for audio processing -  http://slavepianos.org/rd/?t=rju+requires either `RDL` from [sc3-rdu][sc3-rdu] or `jack-dl` from [rju][rju]. -(c) rohan drape, 2006-2011-    gpl, http://gnu.org/copyleft/+implements `text-dl` for testing.++there is a small set of [graphs][ix].++[hs]: http://haskell.org/+[sc3-rdu]: http://rd.slavepianos.org/?t=sc3-rdu+[rju]: http://rd.slavepianos.org/?t=rju+[ix]: http://rd.slavepianos.org/?t=hdf&m=md/ix.md++© [rohan drape][rd], 2006-2013, [gpl]++[rd]: http://rd.slavepianos.org/+[gpl]: http://gnu.org/copyleft/

@@ -1,16 +0,0 @@--- | Top level module for @hdf@.------ > view (lf_pulse 0.09 0.0 0.16)-module Sound.DF (module Sound.DF.Audition-                ,module Sound.DF.CGen-                ,module Sound.DF.Draw-                ,module Sound.DF.Graph-                ,module Sound.DF.Node-                ,module Sound.DF.UGen) where--import Sound.DF.Audition-import Sound.DF.CGen-import Sound.DF.Draw-import Sound.DF.Graph-import Sound.DF.Node-import Sound.DF.UGen

@@ -1,34 +0,0 @@--- | Interaction with @jack-dl@ server-module Sound.DF.Audition where--import Sound.DF.CGen-import Sound.DF.Node-import Sound.OpenSoundControl-import System.Directory-import System.FilePath---- | Allocate buffer.-b_alloc :: Int -> Int -> OSC-b_alloc b n = Message "/b_alloc" [Int b, Int n]---- | Load graph.-g_load :: Int -> String -> OSC-g_load i s = Message "/g_load" [Int i, String s]---- | Unload graph.-g_unload :: Int -> OSC-g_unload i = Message "/g_unload" [Int i]---- | Run action with @UDP@ link to @jack-dl@.-with_jack_dl :: (UDP -> IO a) -> IO a-with_jack_dl = withTransport (openUDP "127.0.0.1" 57190)---- | Audition graph after sending initialisation messages.-audition :: [OSC] -> Node -> IO ()-audition is n =-    do t <- getTemporaryDirectory-       k <- generateID-       let fn = t </> ("audition" ++ show k)-       dl_gen fn n-       _ <- with_jack_dl (\fd -> mapM (send fd) is)-       with_jack_dl (\fd -> send fd (g_load 0 (fn <.> "so")))

@@ -1,208 +0,0 @@--- | C code generator-module Sound.DF.CGen (code_gen,dl_gen) where--import Data.List-import Sound.DF.Node-import Sound.DF.Graph-import System.Cmd-import System.FilePath---- | Generate C code for graph.-code_gen :: Node -> String-code_gen n =-    let as = analyse (tsort n)-        ns = map fst as-        hd = [ "#include <stdio.h>"-             , "#include <stdlib.h>"-             , "#include <stdbool.h>"-             , "#include <math.h>"-             , "#include <jack.dl.h>"]-        c = [hd, cdef, cstate ns, dsp_init ns, dsp_step as ns]-    in (unlines . concat) c---- | Generate C code, write file to disk and call the GNU C compiler---   to build shared library.-dl_gen :: FilePath -> Node -> IO ()-dl_gen fn n =-    do let c = fn <.> "c"-           so = fn <.> "so"-           gcc = "gcc -g --std=c99 -O2 -shared -I ~/include "-           cmd = gcc ++ c ++ " -o " ++ so-       writeFile c (code_gen n)-       _ <- system cmd-       return ()---- | Construct an identifier.-clabel :: String -> (NodeID, PortID) -> String-clabel p (k, n) = concat [p, "_", show k, "_", show n]---- | Construct a function/macro call.-ccall :: String -> [String] -> String-ccall s as = concat ([s, "("] ++ intersperse "," as ++ [");"])---- | A ccall variant with trace output.-d_ccall :: String -> Node -> [String] -> [String]-d_ccall s n as = [ "/*" ++ show n ++ "*/"-                 , ccall s as ]--ctype :: Type -> String-ctype Real_Type = "float"-ctype Integer_Type = "long int"-ctype Boolean_Type = "bool"--type CVar = (String, String, Maybe Double, Bool)--cvar_from_constant :: NodeID -> String -> Constant -> Bool -> CVar-cvar_from_constant k c (Real_Constant i) st =-    (ctype Real_Type, clabel c (k, 0), Just i, st)-cvar_from_constant k c (Integer_Constant i) st =-    (ctype Integer_Type, clabel c (k, 0), Just (fromIntegral i), st)---- | List of required variable declarations.-cvars_n :: (NodeID, Node) -> [CVar]-cvars_n (k, S i) =-    [cvar_from_constant k "n" i False]-cvars_n (k, R (R_ID j) (Left i)) =-    [cvar_from_constant j "r" i True-    ,cvar_from_constant k "n" i False]-cvars_n (k, R (R_ID _) (Right _)) =-    [("float", clabel "n" (k, 0), Nothing, False)]-cvars_n (k, A _ _ o) =-    let f p t = let t' = port_data_type t-                in (ctype t', clabel "n" (k, p), Nothing, False)-    in zipWith f [0 .. length o - 1] o-cvars_n (_, M _ _) = undefined-cvars_n (_, P _ _) = undefined--cvars :: [(NodeID, Node)] -> [CVar]-cvars = concatMap cvars_n--is_stateful :: CVar -> Bool-is_stateful (_, _, _, st) = st--stateful_cvars :: [(NodeID, Node)] -> [CVar]-stateful_cvars = filter is_stateful . cvars--non_stateful_cvars :: [(NodeID, Node)] -> [CVar]-non_stateful_cvars = filter (not . is_stateful) . cvars--cstate :: [(NodeID, Node)] -> [String]-cstate ns =-    let f (t, n, _, _) = t ++ " " ++ n ++ ";"-    in "struct df_state {" : map f (stateful_cvars ns) ++ ["};"]--cstate_init :: String -> [(NodeID, Node)] -> [String]-cstate_init s ns =-    let f (_, n, Just i, _) = s ++ "->" ++ n ++ " = " ++ show i ++ ";"-        f (_, _, Nothing, _) = error "cstate_init"-    in map f (stateful_cvars ns)---- | Non-statefule variable declarations.  Unintialised, the node---   writes the constant value.-non_state_decl :: [(NodeID, Node)] -> [String]-non_state_decl ns =-    let f (ty, n, _, _) = ty ++ " " ++ n ++ ";"-    in map f (non_stateful_cvars ns)---- | Generate dsp_init function.-dsp_init :: [(NodeID, Node)] -> [String]-dsp_init ns =-    let a = [ "void *dsp_init(struct world *w, int g)"-            , "{"-            , "struct df_state *s = malloc(sizeof(struct df_state));" ]-        b = [ "return (void*)s;"-            , "}"]-    in a ++ cstate_init "s" ns ++ b---- | Generate dsp_step function.-dsp_step :: [((NodeID, Node), [Edge])] -> [(NodeID, Node)] -> [String]-dsp_step as ns =-    let s = "void dsp_step(struct world *w, int g, void *ptr, int nf)"-        f (t, n, _, _) = t ++ " " ++ n ++ " = s->" ++ n ++ ";"-        g (_, n, _, _) = "s->" ++ n ++ " = " ++ n ++ ";"-        ss = [ [ s-               , "{"-               , "struct df_state *s = (struct df_state *)ptr;"-               , "/* load state */" ]-             , map f (stateful_cvars ns)-             , [ "/* non-stateful variables */" ]-             , non_state_decl ns-             , [ "/* algorithm */"-               , "for(int i = 0; i < nf; i++) {" ]-             , concatMap cgen as-             , [ "}"-               , "/* store state */" ]-             , map g (stateful_cvars ns)-             , [ "}" ] ]-    in concat ss---- | List of code statements.-cgen :: ((NodeID, Node), [Edge]) -> [String]-cgen ((k, n@(S (Real_Constant x))), []) =-    d_ccall "df_real_constant" n [clabel "n" (k, 0), show x]-cgen ((k, n@(S (Integer_Constant x))), []) =-    d_ccall "df_integer_constant" n [clabel "n" (k, 0), show x]-cgen ((k, n@(R (R_ID j) (Left _))), []) =-    d_ccall "df_rec_r" n [clabel "n" (k, 0), clabel "r" (j, 0)]-cgen ((_, n@(R (R_ID j) (Right _))), [(s, _)]) =-    d_ccall "df_rec_w" n [clabel "r" (j, 0), clabel "n" s]-cgen ((k, n@(A a _ o)), es) =-    let o_l = map (clabel "n") (zip (repeat k) [0 .. length o - 1])-        i_l = map (clabel "n". fst) es-    in d_ccall a n (o_l ++ i_l)-cgen ((_, P _ _), _) =-    []-cgen c = error ("cgen: " ++ show c)---- | Macro definitions-cdef :: [String]-cdef =-    ["/* reader */"-    ,"#define df_integer_constant(o_0,i_0) { o_0 = i_0; }"-    ,"#define df_real_constant(o_0,i_0) { o_0 = i_0; }"-    ,"#define df_rec_r(o_0,i_0) { o_0 = i_0; }"-    ,"#define df_rec_w(o_0,i_0) { o_0 = i_0; }"-    ,"/* instance Num */"-    ,"#define df_add(o_0,i_0,i_1) { o_0 = (i_0) + (i_1); }"-    ,"#define df_mul(o_0,i_0,i_1) { o_0 = (i_0) * (i_1); }"-    ,"#define df_sub(o_0,i_0,i_1) { o_0 = (i_0) - (i_1); }"-    ,"#define df_negate(o_0,i_0) { o_0 = -(i_0); }"-    ,"#define df_fabs(o_0,i_0) { o_0 = fabsf(i_0); }"-    ,"#define df_iabs(o_0,i_0) { o_0 = labs(i_0); }"-    ,"#define df_signum(o_0,i_0) { o_0 = i_0 > 0 ? 1 (i_0 < 0 ? -1 : 0); } }"-    ,"/* instance Fractional */"-    ,"#define df_div(o_0,i_0,i_1) { o_0 = (i_0) / (i_1); }"-    ,"#define df_recip(o_0,i_0) { o_0 = 1.0 / i_0; }"-    ,"/* instance Floating */"-    ,"#define df_exp(o_0,i_0) { o_0 = expf(i_0); }"-    ,"#define df_sqrt(o_0,i_0) { o_0 = sqrtf(i_0); }"-    ,"#define df_log(o_0,i_0) { o_0 = logf(i_0); }"-    ,"#define df_pow(o_0,i_0,i_1) { o_0 = powf(i_0,i_1); }"-    ,"#define df_sin(o_0,i_0) { o_0 = sinf(i_0); }"-    ,"#define df_cos(o_0,i_0) { o_0 = cosf(i_0); }"-    ,"#define df_tan(o_0,i_0) { o_0 = tanf(i_0); }"-    ,"/* instance Ord */"-    ,"#define df_lt(o_0,i_0,i_1) { o_0 = i_0 < i_1 ? true : false; }"-    ,"#define df_lte(o_0,i_0,i_1) { o_0 = i_0 <= i_1 ? true : false; }"-    ,"#define df_gt(o_0,i_0,i_1) { o_0 = i_0 > i_1 ? true : false; }"-    ,"#define df_gte(o_0,i_0,i_1) { o_0 = i_0 >= i_1 ? true : false; }"-    ,"#define df_max(o_0,i_0,i_1) { o_0 = i_0 > i_1 ? i_0 : i_1; }"-    ,"#define df_min(o_0,i_0,i_1) { o_0 = i_0 < i_1 ? i_0 : i_1; }"-    ,"/* instance Eq */"-    ,"#define df_eq(o_0,i_0,i_1) { o_0 = i_0 == i_1 ? true : false; }"-    ,"/* instance RealFrac */"-    ,"#define df_floor(o_0,i_0) { o_0 = floorf(i_0); }"-    ,"#define df_lrint(o_0,i_0) { o_0 = lrintf(i_0); }"-    ,"/* Control */"-    ,"#define df_and(o_0,i_0,i_1) { o_0 = i_0 && i_1 ? true : false; }"-    ,"#define df_or(o_0,i_0,i_1) { o_0 = i_0 || i_1 ? true : false; }"-    ,"#define df_select2(o_0,i_0,i_1,i_2) { o_0 = i_0 ? i_1 : i_2; }"-    ,"/* World|Environment */"-    ,"#define df_sample_rate(o_0) { o_0 = w_sr(w); }"-    ,"#define df_b_read(o_0,i_0,i_1) { o_0=w_b_read1(w,i_0,i_1); }"-    ,"#define df_b_write(i_0,i_1,i_2) { w_b_write1(w,i_0,i_1,i_2); }"-    ,"#define df_random(o_0,i_0) { o_0 = ((float)rand() / (float)RAND_MAX); }"-    ,"#define df_out1(i_0) { w_out1(w,i,i_0); }"-    ,"#define df_out2(i_0,i_1) { w_out2(w,i,i_0,i_1); }"-    ,"#define df_out3(i_0,i_1,i_2) { w_out3(w,i,i_0,i_1,i_2); }"-    ]

@@ -1,40 +0,0 @@--- | Graph drawing-module Sound.DF.Draw (view) where--import Sound.DF.Node-import Sound.DF.Graph--import qualified Data.Graph.Inductive as G-import Data.Maybe-import Data.List-import System.Cmd-import System.Directory-import System.FilePath---- | Implicit edge from wR to rW.-r_edge :: [(NodeID, Node)] -> (NodeID, Node) -> Maybe Edge-r_edge ns (i, R (R_ID d) (Left _)) =-    let f x (_, R (R_ID y) (Right _)) = x == y-        f _ _ = False-        (j, _) = fromMaybe (error "r_edge") (find (f d) ns)-    in Just ((j,0),(i,0))-r_edge _ _ = Nothing---- | Transform the actual graph into the viewing graph.-vgraph :: G.Gr Node (PortID, PortID) -> G.Gr Node (PortID, PortID)-vgraph g = let ns = G.labNodes g-               es = G.labEdges g-               es' = map mod_e (mapMaybe (r_edge ns) ns)-           in G.mkGraph ns (es ++ es')--draw :: Node -> String-draw = G.graphviz' . vgraph . graph---- | Draw graph using graphviz.-view :: Node -> IO ()-view n = do t <- getTemporaryDirectory-            let s = draw n-                fn = t </> "df_view" <.> "dot"-            writeFile fn s-            _ <- rawSystem "dotty" [fn]-            return ()

@@ -1,76 +0,0 @@--- | Graph analysis-module Sound.DF.Graph where--import qualified Data.Graph.Inductive as G-import Data.List-import Data.Maybe-import Sound.DF.Node---- | List of nodes, in left biased order.-nodes :: Node -> [Node]-nodes n =-    case n of-      S _ -> [n]-      A _ i _ -> n : concatMap nodes i-      R _ (Left _) -> [n]-      R _ (Right (l, r)) -> n : (nodes l ++ nodes r)-      P i _ -> n : nodes i-      M l r -> n : (nodes l ++ nodes r)---- | Read label of node.-label :: [(NodeID, Node)] -> Node -> NodeID-label ns n =-    let r = find ((== n) . snd) ns-    in maybe (error ("label: " ++ show n)) fst r---- | Transform node to source, see through rec_r and proxy and mrg.-source :: [(NodeID, Node)] -> Node -> (NodeID, PortID)-source ns n =-    case n of-      S _ -> (label ns n, 0)-      A _ _ [_] -> (label ns n, 0)-      A _ _ _ -> error "non unary A"-      R _ (Left _) -> (label ns n, 0)-      R _ (Right (n', _)) -> source ns n'-      P n' i -> (label ns n', i)-      M l _ -> source ns l---- | Edge between ports.-type Edge = ((NodeID, PortID), (NodeID, PortID))---- | List incoming node edges,-edges :: [(NodeID, Node)] -> Node -> [Edge]-edges ns r@(A _ is _) = let f i k = (source ns i, (label ns r, k))-                        in zipWith f is [0..]-edges ns r@(R _ (Right (_, rr))) = [(source ns rr, (label ns r, 0))]-edges _ (P _ _) = []-edges _ _ = []---- | Label nodes and list edges.  Proxy and multiple-root nodes are---   erased.-analyse :: [Node] -> [((NodeID, Node), [Edge])]-analyse ns = let l_ns = zip [1..] ns-                 w_es (k, n) = ((k, n), edges l_ns n)-                 rem_p ((_, P _ _), _) = False-                 rem_p _ = True-                 rem_m ((_, M _ _), _) = False-                 rem_m _ = True-            in filter rem_m (filter rem_p (map w_es l_ns))---- | Transform edge into form required by fgl.-mod_e :: Edge -> (NodeID, NodeID, (PortID, PortID))-mod_e ((l, lp), (r, rp)) = (l, r, (lp, rp))---- | Generate graph.-graph :: Node -> G.Gr Node (PortID, PortID)-graph n =-    let a = analyse (nub (nodes n))-        ns = map fst a-        es = concatMap (map mod_e . snd) a-    in G.mkGraph ns es---- | Topological sort of nodes (via graph).-tsort :: Node -> [Node]-tsort s =-    let g = graph s-    in map (fromMaybe (error "tsort") . G.lab g) (G.topsort g)

@@ -1,305 +0,0 @@--- | Data flow nodes.-module Sound.DF.Node where--import Control.Monad-import Data.Unique---- * The Node data type---- | Recursion identifer.-data R_ID = R_ID Int-            deriving (Eq)---- | Enumeration of types of data on ports.-data Type = Real_Type-          | Integer_Type-          | Boolean_Type-            deriving (Eq, Show)---- | Constant values.-data Constant = Real_Constant Double-              | Integer_Constant Int-                deriving (Eq)---- | How to display constants.-instance Show Constant where-    show (Real_Constant x) = show x-    show (Integer_Constant x) = show x---- | Port meta data.-data Port = Port { port_data_type :: Type-                 , port_tokens :: Int }-            deriving (Eq)---- | Data flow node.-data Node = S { constant :: Constant }-          | A { operator :: String-              , inputs :: [Node]-              , outputs :: [Port] }-          | R { identifier :: R_ID-              , input :: Either Constant (Node, Node) }-          | P { proxy :: Node-              , port :: Int }-          | M { mleft :: Node-              , mright :: Node }-            deriving (Eq)---- | Node identifier.-type NodeID = Int---- | Port identifier.-type PortID = Int---- | Multiple root graph (alias for M).-mrg :: Node -> Node -> Node-mrg = M---- | How to display nodes.-instance Show Node where-    show (S x) = show x-    show (A p _ _) = p-    show (R (R_ID d) (Left i)) = "rR_" ++ show d ++ ":" ++ show i-    show (R (R_ID d) (Right _)) = "wR_" ++ show d-    show (P _ p) = "proxy_" ++ show p-    show (M l r) = "m(" ++ show l ++ "," ++ show r ++ ")"---- * Querying data type on ports---- | Type of a constant value.-constant_type :: Constant -> Type-constant_type (Real_Constant _) = Real_Type-constant_type (Integer_Constant _) = Integer_Type---- | Type of a node.-node_type :: Node -> Type-node_type n =-    case n of-      S c -> constant_type c-      A _ _ [Port t _] -> t-      A _ _ _ -> error "node_type: A: non unary output"-      R _ (Left c) -> constant_type c-      R _ (Right (n',_)) -> node_type n'-      P n' i -> port_data_type (outputs n' !! i)-      M l _ -> node_type l---- * Numeric primitives for class instances---- | Lift constant to node.-n_real_constant :: Double -> Node-n_real_constant = S . Real_Constant---- | Lift constant to node.-n_integer_constant :: Int -> Node-n_integer_constant = S . Integer_Constant---- | Unary operator over Real and Integer values.-numerical_unary_operator :: String -> Node -> Node-numerical_unary_operator s p = A s [p] [Port (node_type p) 1]---- | Binary operator over Real and Integer values.-numerical_binary_operator :: String -> Node -> Node -> Node-numerical_binary_operator s p q =-    let pt = node_type p-        qt = node_type q-    in if pt /= qt-       then error (show ("binary operator", s, pt, qt, p, q))-       else A s [p, q] [Port pt 1]---- | Unary operator over Real values.-real_unary_operator :: String -> Node -> Node-real_unary_operator s p =-    if node_type p == Real_Type-    then A s [p] [Port Real_Type 1]-    else error (show ("real unary operator", s, p))---- | Binary operator over Real values.-real_binary_operator :: String -> Node -> Node -> Node-real_binary_operator s p q =-    if node_type p == Real_Type && node_type q == Real_Type-    then A s [p, q] [Port Real_Type 1]-    else error (show ("real binary operator", s, p, q))---- | Addition.-n_add :: Node -> Node -> Node-n_add = numerical_binary_operator "df_add"---- | Multiplication.-n_mul :: Node -> Node -> Node-n_mul = numerical_binary_operator "df_mul"---- | Subtraction.-n_sub :: Node -> Node -> Node-n_sub = numerical_binary_operator "df_sub"---- | Negation.-n_negate :: Node -> Node-n_negate = numerical_unary_operator "df_negate"---- | Absolute value.-n_abs :: Node -> Node-n_abs p =-    case node_type p of-      Real_Type -> A "df_fabs" [p] [Port Real_Type 1]-      Integer_Type -> A "df_iabs" [p] [Port Integer_Type 1]-      _ -> error "n_abs" {- quieten compiler -}---- | Sign of.-n_signum :: Node -> Node-n_signum = numerical_unary_operator "df_signum"--instance Num Node where-  (+) = n_add-  (*) = n_mul-  (-) = n_sub-  negate = n_negate-  abs = n_abs-  signum = n_signum-  fromInteger = n_integer_constant . fromInteger---- | Division.-n_div :: Node -> Node -> Node-n_div = real_binary_operator "df_div"---- | Reciprocal.-n_recip :: Node -> Node-n_recip = real_unary_operator "df_recip"--instance Fractional Node where-  (/) = n_div-  recip = n_recip-  fromRational = n_real_constant . fromRational---- | Natural exponential.-n_exp :: Node -> Node-n_exp = real_unary_operator "df_exp"---- | Square root.-n_sqrt :: Node -> Node-n_sqrt = real_unary_operator "df_sqrt"---- | Natural logarithm.-n_log :: Node -> Node-n_log = real_unary_operator "df_log"---- | 'p' to the power of 'q'.-n_pow :: Node -> Node -> Node-n_pow = real_binary_operator "df_pow"---- | Sine.-n_sin :: Node -> Node-n_sin = real_unary_operator "df_sin"---- | Cosine.-n_cos :: Node -> Node-n_cos = real_unary_operator "df_cos"---- | Tangent.-n_tan :: Node -> Node-n_tan = real_unary_operator "df_tan"--instance Floating Node where-  pi = n_real_constant pi-  exp = n_exp-  sqrt = n_sqrt-  log = n_log-  (**) = n_pow-  logBase = undefined-  sin = n_sin-  tan = n_tan-  cos = n_cos-  asin = undefined-  atan = undefined-  acos = undefined-  sinh = undefined-  tanh = undefined-  cosh = undefined-  asinh = undefined-  atanh = undefined-  acosh = undefined---- | Operator from Real or Integer values to a Boolean value.-numerical_comparison_operator :: String -> Node -> Node -> Node-numerical_comparison_operator s p q =-    let pt = node_type p-        qt = node_type q-    in if pt == qt && (pt == Integer_Type || pt == Real_Type)-       then A s [p, q] [Port Boolean_Type 1]-       else error (show ("comparison operator", s, pt, qt, p, q))---- | Less than.-n_lt :: Node -> Node -> Node-n_lt = numerical_comparison_operator "df_lt"---- | Greater than or equal to.-n_gte :: Node -> Node -> Node-n_gte = numerical_comparison_operator "df_gte"---- | Greater than.-n_gt :: Node -> Node -> Node-n_gt = numerical_comparison_operator "df_gt"---- | Less than or equal to.-n_lte :: Node -> Node -> Node-n_lte = numerical_comparison_operator "df_lte"---- | Maximum.-n_max :: Node -> Node -> Node-n_max = numerical_binary_operator "df_max"---- | Minimum.-n_min :: Node -> Node -> Node-n_min = numerical_binary_operator "df_min"--instance Ord Node where-  compare = undefined-  (<) = undefined-  (>=) = undefined-  (>) = undefined-  (<=) = undefined-  max = n_max-  min = n_min---- | Real valued floor.-n_floor :: Node -> Node-n_floor = real_unary_operator "df_floor"---- | Integer valued floor.-n_lrint :: Node -> Node-n_lrint p-    | node_type p == Real_Type = A "df_lrint" [p] [Port Integer_Type 1]-    | otherwise = error "n_lrint"--{--class (Real a, Fractional a) => RealFrac a where-  properFraction :: (Integral b) => a -> (b, a)-  truncate :: (Integral b) => a -> b-  round :: (Integral b) => a -> b-  ceiling :: (Integral b) => a -> b-  floor :: (Integral b) => a -> b--}---- | Class of monads generating identifers-class (Monad m) => ID m where-   generateID :: m Int--instance ID IO where-   generateID = liftM hashUnique newUnique---- * Backward arcs---- | Introduce backward arc with implicit unit delay.-rec_r :: R_ID -> Constant -> (Node -> (Node, Node)) -> Node-rec_r n i f = R n (Right (f (R n (Left i))))---- | Monadic variant of rec_r.-rec :: ID m => Constant -> (Node -> (Node, Node)) -> m Node-rec i f = do n <- generateID-             return (rec_r (R_ID n) i f)---- | Variant or rec with monadic action in backward arc.-recm :: ID m => Constant -> (Node -> m (Node, Node)) -> m Node-recm i f =-    do n <- generateID-       let r_r = R (R_ID n) (Left i)-       r <- f r_r-       return (R (R_ID n) (Right r))

@@ -1,502 +0,0 @@--- | Data flow node functions, or unit generators.-module Sound.DF.UGen where--import Control.Monad-import Sound.DF.Node---- * Primitive unit generators---- | Uniform input type operator.-uniform_operator :: Type -> Int -> String -> [Node] -> Node-uniform_operator t n s ps =-    if all (\p -> node_type p == t) ps-    then A s ps (replicate n (Port t 1))-    else error (show ("output operator", ps))---- | Single channel output.-out1 :: Node -> Node-out1 p = uniform_operator Real_Type 0 "df_out1" [p]---- | Two channel output.-out2 :: (Node, Node) -> Node-out2 (p, q) = uniform_operator Real_Type 0 "df_out2" [p, q]---- | Three channel output.-out3 :: (Node, Node, Node) -> Node-out3 (p, q, r) = uniform_operator Real_Type 0 "df_out3" [p, q, r]---- | Operating sample rate.-sample_rate :: Node-sample_rate = A "df_sample_rate" [] [Port Real_Type 1]---- | Equal to.-eq :: Node -> Node -> Node-eq = numerical_comparison_operator "df_eq"---- | If 'p' then 'q' else 'r'.-select2 :: Node -> Node -> Node -> Node-select2 p q r =-    if node_type p == Boolean_Type &&-       node_type q == node_type r-    then A "df_select2" [p, q, r] [Port (node_type q) 1]-    else error (show ("select2", p, q, r))---- | Binary boolean valued operator.-logical_operator :: String -> Node -> Node -> Node-logical_operator s p q =-    if node_type p == Boolean_Type && node_type q == Boolean_Type-    then A s [p, q] [Port Boolean_Type 1]-    else error (show ("logical operator", s, p, q))---- | Logical and.-n_and :: Node -> Node -> Node-n_and = logical_operator "df_and"---- | Logical or.-n_or :: Node -> Node -> Node-n_or = logical_operator "df_or"---- | Buffer read.-b_read :: Node -> Node -> Node-b_read p q =-    if node_type p == Integer_Type && node_type q == Integer_Type-    then A "df_b_read" [p, q] [Port Real_Type 1]-    else error (show ("b_read", p, q))---- | Buffer write.-b_write :: Node -> Node -> Node -> Node-b_write p q r =-    if node_type p == Integer_Type &&-       node_type q == Integer_Type &&-       node_type r == Real_Type-    then A "df_b_write" [p, q, r] []-    else error (show ("b_write", p, q, r))---- | White noise (0, 1).-white_noise_u :: Node -> Node-white_noise_u p = A "df_random" [p] [Port Real_Type 1]---- * Ordinary unit generators---- | Linear pan.-pan2 :: Node -> Node -> (Node, Node)-pan2 p q = (p * q, p * (q - 1.0))---- | Reversed tuple constructor, (ie. @flip (,)@)-swap :: a -> b -> (b, a)-swap = flip (,)---- | Duplicate a value into a tuple.-split :: a -> (a, a)-split p = (p, p)---- | Single sample delay with indicated initial value.-unit_delay :: ID m => Constant -> Node -> m Node-unit_delay y0 = rec y0 . swap---- | Single place infinte impulse response filter with indicated initial value.-iir1 :: ID m => Constant -> (Node -> Node -> Node) -> Node -> m Node-iir1 y0 f i = rec y0 (split . f i)---- | Two place infinte impulse response filter.  Inputs are: /f/=--- function @(\x0 y1 y2 -> y0)@, /i/ = input signal.------ > do { c1 <- iir2 (\x y1 _ -> x + y1) 0.001--- >    ; o1 <- sin_osc (c1 + 220.0) 0--- >    ; c2 <- iir2 (\x _ y2 -> x + y2) 0.001--- >    ; o2 <- sin_osc (c2 + 220.0) 0--- >    ; audition [] (out2 (o1 * 0.1, o2 * 0.1)) }-iir2 :: ID m => (Node -> Node -> Node -> Node) -> Node -> m Node-iir2 f i = recm-             (Real_Constant 0)-             (liftM split . (\y1 -> do y2 <- unit_delay (Real_Constant 0) y1-                                       return (f i y1 y2)))---- | Single place finte impulse response filter.-fir1 :: ID m => (Node -> Node -> Node) -> Node -> m Node-fir1 f i = do-  x1 <- unit_delay (Real_Constant 0) i-  return (f i x1)---- | Two place finte impulse response filter.-fir2 :: ID m => (Node -> Node -> Node -> Node) -> Node -> m Node-fir2 f i = do-  x1 <- unit_delay (Real_Constant 0) i-  x2 <- unit_delay (Real_Constant 0) x1-  return (f i x1 x2)---- | Ordinary biquad filter section.-biquad :: ID m => (Node -> Node -> Node -> Node -> Node -> Node) -> Node -> m Node-biquad f i = recm-               (Real_Constant 0)-               (liftM split . (\y1 -> do x1 <- unit_delay (Real_Constant 0) i-                                         x2 <- unit_delay (Real_Constant 0) x1-                                         y2 <- unit_delay (Real_Constant 0) y1-                                         return (f i x1 x2 y1 y2)))---- | Counter from indicated initial value.-counter :: ID m => Constant -> Node -> m Node-counter y0 = iir1 y0 (+)---- | Environment value, equal to @'two_pi' / 'sample_rate'@.-radians_per_sample :: Node-radians_per_sample = two_pi / sample_rate---- | r = cycle (two-pi), hz = frequency, sr = sample rate-hz_to_incr :: Node -> Node -> Node -> Node-hz_to_incr r hz sr = (r / sr) * hz---- | Two pi.-two_pi :: Floating a => a-two_pi = 2.0 * pi---- | If 'q >= p' then 'q - p' else 'q'.-clipr :: Node -> Node -> Node-clipr p q = select2 (q `n_gte` p) (q - p) q---- | r = right hand edge, ip = initial phase, x = increment-phasor :: ID m => Constant -> Node -> Node -> m Node-phasor ip r = iir1 ip (\x y1 -> clipr r (x + y1))---- | Sine oscillator.  Inputs are: /f/ = frequency (in hz), /ip/ =--- initial phase.------ > do { o <- sin_osc 440.0 0.0--- >    ; audition [] (out1 (o * 0.1)) }------ Used as both Oscillator and LFO.------ > do { f <- sin_osc 4.0 0.0--- >    ; o <- sin_osc (f * 400.0 + 400.0) 0.0--- >    ; audition [] (out1 (o * 0.1)) }------ Cancellation.------ > do { o1 <- sin_osc 440.0 0.0--- >    ; o2 <- sin_osc 440.0 pi--- >    ; audition [] (out1 (o1 + o2)) }-sin_osc :: ID m => Node -> Double -> m Node-sin_osc f ip = do-  p <- phasor (Real_Constant ip) two_pi (hz_to_incr two_pi f sample_rate)-  return (sin p)---- | Non-band limited sawtooth oscillator.  Output ranges from -1 to +1.--- Inputs are: /f/ = frequency (in hertz), /ip/ = initial phase (0,2).------ > do { o <- lf_saw 500.0 1.0--- >    ; audition [] (out1 (o * 0.1)) }------ Used as both Oscillator and LFO.------ > do { f <- lf_saw 4.0 0.0--- >    ; o <- lf_saw (f * 400.0 + 400.0) 0.0--- >    ; audition [] (out1 (o * 0.1)) }-lf_saw :: ID m => Node -> Double -> m Node-lf_saw f ip = do-  p <- phasor (Real_Constant ip) 2.0 (hz_to_incr 2.0 f sample_rate)-  return (p - 1.0)---- | Non-band-limited pulse oscillator. Outputs a high value of one--- and a low value of zero. Inputs are: /f/ = frequency (in hertz),--- /ip/ = initial phase (0, 1), /w/ = pulse width duty cycle (0, 1).------ > do { o1 <- fmap (\x -> x * 200.0 + 200.0) (lf_pulse 3.0 0.0 0.3)--- >    ; o2 <- fmap (\x -> x * 0.1) (lf_pulse o1 0.0 0.2)--- >    ; audition [] (out1 o2) }-lf_pulse :: ID m => Node -> Double -> Node -> m Node-lf_pulse f ip w =-    do p <- phasor (Real_Constant ip) 1.0 (hz_to_incr 1.0 f sample_rate)-       return (select2 (p `n_gte` w) 0.0 1.0)---- | Midi note number to cycles per second.-midi_cps :: Floating a => a -> a-midi_cps a = 440.0 * (2.0 ** ((a - 69.0) * (1.0 / 12.0)))---- | Multiply and add.-mul_add :: Num a => a -> a -> a -> a-mul_add i m a = (i * m) + a---- | Calculate feedback multipler given /delay/ and /decay/ times.-calc_fb :: Floating a => a -> a -> a-calc_fb delayt decayt = exp ((log 0.001 * delayt) / decayt)---- | Delay.-delay :: ID m => Node -> Node -> Node -> m Node-delay b s n = do-  wi <- phasor (Integer_Constant 0) n 1-  let ri = clipr n (wi + 1)-  return (mrg (b_read b ri) (b_write b wi s))---- | Non-interpolating comb filter.  Inputs are: /b/ = buffer index,--- /i/ = input signal, /dl/ = delay time, /dc/ = decay time.------ All times are in seconds.  The decay time is the time for the--- echoes to decay by @60@ decibels. If this time is negative then the--- feedback coefficient will be negative, thus emphasizing only odd--- harmonics at an octave lower.------ Comb used as a resonator. The resonant fundamental is equal to--- reciprocal of the delay time.------ > do { n <- white_noise_m--- >    ; dt <- let f x = lin_exp (x + 2.0) 1.0 2.0 0.0001 0.01--- >            in fmap f (lf_saw 0.1 0.0)--- >    ; c <- buf_comb_n 0 (n * 0.1) dt 0.2--- >    ; audition [b_alloc 0 44100] (out1 c) }------ Comb used as an echo.------ > do { i <- impulse 0.5 0.0--- >    ; n <- white_noise_m--- >    ; e <- decay (i * 0.5) 0.2--- >    ; c <- buf_comb_n 0 (e * n) 0.2 3.0--- >    ; audition [b_alloc 0 44100] (out1 c) }-buf_comb_n :: ID m => Node -> Node -> Node -> Node -> m Node-buf_comb_n b s dlt dct = do-  let n = n_lrint (dlt * sample_rate)-      fb = calc_fb dlt dct-      c i = do x <- delay b i n-               return (split (s + (fb * x)))-  recm (Real_Constant 0) c---- | Resonant low pass filter. Inputs are: /i/ = input signal, /f/ =--- frequency (hertz), /rq/ = reciprocal of Q (resonance).------ > do { n <- white_noise_m--- >    ; f <- fmap (\x -> x * 40.0 + 220.0) (sin_osc 0.5 0.0)--- >    ; r <- rlpf n f 0.1--- >    ; audition [] (out1 r) }-rlpf :: ID m => Node -> Node -> Node -> m Node-rlpf i f r =-    let qr = max 0.001 r-        pf = f * radians_per_sample-        d = tan (pf * qr * 0.5)-        c = (1.0 - d) / (1.0 + d)-        b1 = (1.0 + c) * cos pf-        b2 = negate c-        a0 = (1.0 + c - b1) * 0.25-    in iir2 (\x y1 y2 -> a0 * x + b1 * y1 + b2 * y2) i---- | Constrain p in (-q, q).-clip2 :: Node -> Node -> Node-clip2 p q =-    let nq = negate q-    in min q (max p nq)---- | White noise (-1, 1).-white_noise :: Node -> Node-white_noise p = white_noise_u p * 2.0 - 1.0---- | White noise (-1, 1).  Generates noise whose spectrum has equal--- power at all frequencies.------ > do { n <- white_noise_m--- >    ; audition [] (out1 (n * 0.1)) }-white_noise_m :: ID m => m Node-white_noise_m = do-  i <- generateID-  return (white_noise (n_integer_constant i))---- | Brown noise (-1, 1).  Generates noise whose spectrum falls off in--- power by 6 dB per octave.------ > do { n <- brown_noise_m--- >    ; audition [] (out1 (n * 0.1)) }------ > do { n <- brown_noise_m--- >    ; let f = lin_exp n (-1.0) 1.0 64.0 9600.0--- >      in do { o <- sin_osc f 0--- >            ; audition [] (out1 (o * 0.1)) } }-brown_noise_m :: ID m => m Node-brown_noise_m = do-  w <- white_noise_m-  let w8 = w / 8.0-  iir1-   (Real_Constant 0)-   (\x y1 -> let z = x + y1-                 r = select2 (z `n_lt` (-1.0)) ((-2.0) - z) z-             in select2 (z `n_gt` 1.0) (2.0 - z) r)-   w8---- | Two zero fixed midpass filter.-bpz2 :: ID m => Node -> m Node-bpz2 = fir2 (\x _ x2 -> (x - x2) * 0.5)---- | Two zero fixed midcut filter.-brz2 :: ID m => Node -> m Node-brz2 = fir2 (\x _ x2 -> (x + x2) * 0.5)---- | Two point average filter-lpz1 :: ID m => Node -> m Node-lpz1 = fir1 (\x x1 -> (x + x1) * 0.5)---- | Two zero fixed lowpass filter-lpz2 :: ID m => Node -> m Node-lpz2 = fir2 (\x x1 x2 -> (x + (2.0 * x1) + x2) * 0.25)---- | One pole filter.-one_pole :: ID m => Node -> Node -> m Node-one_pole i cf = iir1-                  (Real_Constant 0)-                  (\x y1 -> ((1.0 - abs cf) * x) + (cf * y1))-                  i---- | One zero filter.-one_zero :: ID m => Node -> Node -> m Node-one_zero i cf = fir1 (\x x1 -> ((1.0 - abs cf) * x) + (cf * x1)) i---- | Second order filter section.-sos :: ID m => Node -> Node -> Node -> Node -> Node -> Node -> m Node-sos i a0 a1 a2 b1 b2 =-    let f x x1 x2 y1 y2 = a0*x + a1*x1 + a2*x2 + b1*y1 + b2*y2-    in biquad f i---- | Impulse oscillator (non band limited).--- Outputs non band limited single sample impulses.--- Inputs are: /f/ = frequency (in hertz), /ip/ = phase offset (0..1)------ > do { o <- impulse 800.0 0.0--- >    ; audition [] (out1 (o * 0.1)) }------ > do { f <- fmap (\x -> x * 2500.0 + 2505.0) (sin_osc 0.25 0.0)--- >    ; o <- impulse f 0.0--- >    ; audition [] (out1 (o * 0.1)) }-impulse :: ID m => Node -> Double -> m Node-impulse f ip = do-  let i = hz_to_incr 1.0 f sample_rate-  p <- phasor (Real_Constant ip) 1.0 i-  x1 <- unit_delay (Real_Constant 0) p-  let s = (x1 `n_lt` 0.5) `n_and` (p `n_gte` 0.5)-  return (select2 s 1.0 0.0)---- | A two pole resonant filter with zeroes at z = +/- 1. Based on--- K. Steiglitz, \"A Note on Constant-Gain Digital Resonators\",--- /Computer Music Journal/, vol 18, no. 4, pp. 8-10, Winter 1994.--- The reciprocal of Q is used rather than Q because it saves a divide--- operation inside the unit generator.------ Inputs are: /i/ = input signal, /f/ = resonant frequency (in--- hertz), /rq/ = bandwidth ratio (reciprocal of Q); where /rq/ =--- bandwidth / centerFreq.------ > do { n <- white_noise_m--- >    ; r <- resonz (n * 0.5) 440.0 0.1--- >    ; audition [] (out1 r) }------ Modulate frequency------ > do { n <- white_noise_m--- >    ; f <- fmap (\x -> x * 3500.0 + 4500.0) (lf_saw 0.1 0.0)--- >    ; r <- resonz (n * 0.5) f 0.05--- >    ; audition [] (out1 r) }-resonz :: ID m => Node -> Node -> Node -> m Node-resonz i f rq =-    let ff = f * radians_per_sample-        b = ff * rq-        r = 1.0 - b * 0.5-        two_r = 2.0 * r-        r2 = r * r-        ct = (two_r * cos ff) / (1.0 + r2)-        b1 = two_r * ct-        b2 = negate r2-        a0 = (1.0 - r2) * 0.5-    in iir2 (\x y1 y2 -> let y0 = x + b1 * y1 + b2 * y2-                         in a0 * (y0 - y2)) i---- | Sample and hold. Holds input signal value when triggered.  Inputs--- are: /i/ = input signal, /t/ = trigger (non-positive to positive).------ > do { n <- white_noise_m--- >    ; i <- impulse 9.0 0.0--- >    ; l <- latch n i--- >    ; o <- sin_osc (l * 400.0 + 500.0) 0.0--- >    ; audition [] (out1 (o * 0.2)) }-latch :: ID m => Node -> Node -> m Node-latch i t = iir1-              (Real_Constant 0)-              (select2 (t `n_gt` 0.0))-              i---- | Linear range conversion.------ > map (\i -> lin_lin i (-1) 1 0 1) [-1, -0.9 .. 1.0]------ > do { s <- lf_saw 1.0 0.0--- >    ; o <- sin_osc (lin_lin s (-1.0) 1.0 220.0 440.0) 0.0--- >    ; audition [] (out1 (o * 0.1)) }-lin_lin :: Fractional a => a -> a -> a -> a -> a -> a-lin_lin i in_l in_r out_l out_r =-    let s = (out_r - out_l) / (in_r - in_l)-        o = out_l - (s * in_l)-    in (i * s) + o---- | Exponential range conversion.------ > map (\i -> lin_exp i 1 2 1 3) [1, 1.1 .. 2]------ > do { s <- lf_saw 0.25 0.0--- >    ; o <- sin_osc (lin_exp (s + 1.0) 0.0 2.0 220.0 440.0) 0.0--- >    ; audition [] (out1 (o * 0.1)) }-lin_exp :: Floating a => a -> a -> a -> a -> a -> a-lin_exp i in_l in_r out_l out_r =-    let rt = out_r / out_l-        rn = 1.0 / (in_r - in_l)-        rr = rn * negate in_l-    in out_l * (rt ** (i * rn + rr))---- | Exponential decay. Inputs are: /i/ = input signal, /t/ = decay--- time.  This is essentially the same as Integrator except that--- instead of supplying the coefficient directly, it is caculated from--- a 60 dB decay time. This is the time required for the integrator to--- lose 99.9 % of its value or -60dB. This is useful for exponential--- decaying envelopes triggered by impulses.------ Used as an envelope.------ > do { n <- brown_noise_m--- >    ; f <- lf_saw 0.1 0.0--- >    ; i <- impulse (lin_lin f (-1.0) 1.0 2.0 5.0) 0.25--- >    ; e <- decay i 0.2--- >    ; audition [] (out1 (e * n)) }-decay :: ID m => Node -> Node -> m Node-decay i dt =-    let b1 = exp (log 0.001 / (dt * sample_rate))-    in iir1 (Real_Constant 0) (\x y1 -> x + b1 * y1) i---- | Exponential decay (equvalent to @decay dcy - decay atk@).-decay2 :: ID m => Node -> Node -> Node -> m Node-decay2 i atk dcy =  liftM2 (-) (decay i dcy) (decay i atk)---- | Single sample delay.-delay1 :: ID m => Node -> m Node-delay1 = iir1 (Real_Constant 0) (\_ y1 -> y1)---- | Two sample delay.-delay2 :: ID m => Node -> m Node-delay2 = iir2 (\_ _ y2 -> y2)---- | Simple averaging filter.  Inputs are: /i/ = input signal, /t/ =--- lag time.------ > do { s <- sin_osc 0.05 0.0--- >    ; let f = lin_lin s (-1.0) 1.0 220.0 440.0--- >      in do { o <- sin_osc f 0.0--- >            ; f' <- lag f 1.0--- >            ; o' <- sin_osc f' 0.0--- >            ; audition [] (out2 (o * 0.2, o' * 0.2)) } }-lag :: ID m => Node -> Node -> m Node-lag i t = let b1 = exp (log (0.001 / (t * sample_rate)))-          in iir1 (Real_Constant 0) (\x y1 -> x + b1 * (y1 - x)) i---- | Nested lag filter.-lag2 :: ID m => Node -> Node -> m Node-lag2 i t = do-  a <- lag i t-  lag a t---- | Twice nested lag filter.-lag3 :: ID m => Node -> Node -> m Node-lag3 i t = do-  a <- lag i t-  b <- lag a t-  lag b t

@@ -0,0 +1,859 @@+-- | Faust signal processing block diagram model.+module Sound.DF.Uniform.Faust where++import qualified Data.Graph.Inductive as G {- fgl -}+import Data.Maybe {- base -}+import Data.List {- base -}+import qualified Data.List.Split as S {- split -}+import Data.Typeable {- base -}+import Sound.OSC {- hosc -}+import System.Process {- process -}+import Text.Printf {- base -}++import qualified Sound.DF.Uniform.LL.Audition as L+import Sound.DF.Uniform.LL.CGen+import Sound.DF.Uniform.LL.Dot+import Sound.DF.Uniform.LL.K+import Sound.DF.Uniform.LL.UId++-- * Block diagram data type++-- | The /write/ and /read/ 'Id's, and the wire type.+type Rec_Id = (Id,Id,TypeRep)++-- | Block diagram.+data BD = Constant (Maybe Id) K+        | Prim (Maybe Id) String [TypeRep] (Maybe TypeRep)+        | Par BD BD+        | Seq BD BD+        | Split BD BD+        | Rec (Maybe [Rec_Id]) BD BD+          deriving (Eq,Show)++instance Num BD where+    p + q = (p ~. q) ~:> (ty_add p q)+    p - q = (p ~. q) ~:> (ty_sub p q)+    p * q = (p ~. q) ~:> (ty_mul p q)+    abs = ty_uop bd_ty_uniform i_abs r_abs+    negate = ty_uop bd_ty_uniform i_negate r_negate+    signum = undefined+    fromInteger = i_constant . fromInteger++instance Fractional BD where+    p / q = (p ~. q) ~:> (ty_div p q)+    fromRational = r_constant . fromRational++-- * Identifiers++-- | Read identifier.+bd_id :: BD -> Maybe Id+bd_id bd =+    case bd of+      Constant k _ -> k+      Prim k _ _ _ -> k+      _ -> Nothing++-- | Erroring 'bd_id'.+bd_req_id :: BD -> Id+bd_req_id = fromMaybe (error "bd_req_id") . bd_id++-- * Pretty printing++-- | Pretty printer for 'BD'.+bd_pp :: BD -> String+bd_pp bd =+    case bd of+      Constant _ n -> show n+      Prim _ nm _ _ -> nm+      Par _ _ -> ","+      Seq _ _ -> ":"+      Split _ _ -> "<:"+      Rec _ _ _ -> "~"++-- * Diagram types and signature++-- | Diagram type signature, ie. 'port_ty' at 'ports'.+bd_signature :: BD -> ([TypeRep],[TypeRep])+bd_signature = let f = map port_ty in bimap f f . ports++-- | Type of /output/ ports of 'BD'.+bd_ty :: BD -> [TypeRep]+bd_ty = map port_ty . snd . ports++-- | Type of /uniform/ output ports of 'BD'.+bd_ty_uniform :: BD -> Maybe TypeRep+bd_ty_uniform bd =+    case nub (bd_ty bd) of+      [t] -> Just t+      _ -> Nothing++-- | Type of /singular/ output port of 'BD'.+bd_ty1 :: BD -> Maybe TypeRep+bd_ty1 bd =+    let (_,op) = ports bd+    in case op of+      [Output_Port (Constant _ n)] -> Just (typeOf n)+      [Output_Port (Prim _ _ _ (Just o))] -> Just o+      _ -> Nothing++-- * Operator synonyms++infixl 4 `rec`, ~~+infixl 3 `Par`, ~.+infixl 2 `Seq`, ~:+infixl 1 `split`, ~<:+infixl 1 `merge`, ~:>++-- | Faust uses single tilde, which is reserved by "GHC.Exts".+(~~) :: BD -> BD -> BD+(~~) = rec++-- | Faust uses comma, which is reserved by "Data.Tuple", and indeed+-- @~,@ is not legal either.+(~.) :: BD -> BD -> BD+(~.) = Par++-- | Faust uses ':', which is reserved by "Data.List".+(~:) :: BD -> BD -> BD+(~:) = Seq++-- | Faust uses '<:', which is legal, however see '~:>'.+(~<:) :: BD -> BD -> BD+(~<:) = split++-- | Faust uses ':>', however ':' is not allowed as a prefix.+--+-- > draw (graph (par_l [1,2,3,4] ~:> i_mul))+-- > draw (graph (par_l [1,2,3] ~:> i_negate))+(~:>) :: BD -> BD -> BD+(~:>) = merge++-- * Fold and traverse++-- | Fold over 'BD', signature as 'foldl'.+bd_foldl :: (t -> BD -> t) -> t -> BD -> t+bd_foldl f st bd =+    let g p q = f (bd_foldl f (bd_foldl f st p) q) bd+    in case bd of+         Constant _ _ -> f st bd+         Prim _ _ _ _ -> f st bd+         Par p q -> g p q+         Seq p q -> g p q+         Split p q -> g p q+         Rec _ p q -> g p q++-- | Traversal with state, signature as 'mapAccumL'.+bd_traverse :: (st -> BD -> (st,BD)) -> st -> BD -> (st,BD)+bd_traverse f st bd =+    let g j t p q = let (t',p') = bd_traverse f t p+                        (t'',q') = bd_traverse f t' q+                    in f t'' (j p' q')+    in case bd of+         Constant _ _ -> f st bd+         Prim _ _ _ _ -> f st bd+         Par p q -> g Par st p q+         Seq p q -> g Seq st p q+         Split p q -> g Split st p q+         Rec k p q -> g (Rec k) st p q++-- * Introduce node identifiers++-- | 'Rec' nodes introduce identifiers for each backward arc.  /k/ is+-- the initial 'Id', /n/ the number of arcs, and /ty/ the arc types.+--+-- > rec_ids 5 2 [int32_t,float_t] == [(5,6,int32_t),(7,8,float_t)]+rec_ids :: Id -> Int -> [TypeRep] -> [Rec_Id]+rec_ids k n ty =+    let k' = k + (n * 2) - 1+        (p,q) = unzip (adjacent [k .. k'])+    in zip3 p q ty++-- | Set identifiers at 'Constant', 'Prim', and 'Rec' nodes.+bd_set_id :: BD -> (Id,BD)+bd_set_id =+    let f k bd =+            case bd of+              Constant _ n -> (k + 1,Constant (Just k) n)+              Prim _ nm i o -> (k + 1,Prim (Just k) nm i o)+              Rec _ p q -> let n = out_degree q+                               k' = rec_ids k n (bd_ty q)+                           in (k + (n * 2),Rec (Just k') p q)+              _ -> (k,bd)+    in bd_traverse f 0++-- * Degree++-- | Node degree as /(input,output)/ pair.+type Degree = (Int,Int)++-- | 'Degree' of block diagram 'BD'.+degree :: BD -> Degree+degree bd =+    case bd of+      Constant _ _ -> (0,1)+      Prim _ _ i o -> (length i,maybe 0 (const 1) o)+      Par p q -> (in_degree p + in_degree q,out_degree p + out_degree q)+      Seq p q ->+          let (ip,op) = degree p+              (iq,oq) = degree q+          in case op `compare` iq of+               EQ -> (ip,oq)+               GT -> (ip,oq + op - iq)+               LT -> (ip + iq - op,oq)+      Split p q -> (in_degree p,out_degree q)+      Rec _ p q -> (in_degree p - out_degree q,out_degree p)++-- | 'fst' of 'degree'.+in_degree :: BD -> Int+in_degree = fst . degree++-- | 'snd' of 'degree'.+out_degree :: BD -> Int+out_degree = snd . degree++-- * Ports++-- | The index of an 'Input_Port', all outputs are unary.+type Port_Index = Int++-- | Port (input or output) at block diagram.+data Port = Input_Port {port_bd :: BD, port_index :: Port_Index}+          | Output_Port {port_bd :: BD}+            deriving (Eq,Show)++-- | The left and right /outer/ ports of a block diagram.+ports :: BD -> ([Port],[Port])+ports bd =+    case bd of+      Constant _ _ -> ([],[Output_Port bd])+      Prim _ _ i o -> (map (Input_Port bd) [0 .. length i - 1]+                      ,maybe [] (const [Output_Port bd]) o)+      Par p q -> let (ip,op) = ports p+                     (iq,oq) = ports q+                 in (ip ++ iq,op ++ oq)+      Seq p q ->+          let (_,opk) = degree p+              (iqk,_) = degree q+              (ip,op) = ports p+              (iq,oq) = ports q+          in case opk `compare` iqk of+               EQ -> (ip,oq)+               GT -> (ip,oq ++ (drop iqk op))+               LT -> (ip ++ (drop opk iq),oq)+      Split p q -> let (ip,_) = ports p+                       (_,oq) = ports q+                   in (ip,oq)+      Rec _ p q -> let (ip,op) = ports p+                       k = out_degree q+                   in (drop k ip,op)++-- | Type of 'Port'.+port_ty :: Port -> TypeRep+port_ty p =+    case p of+      Output_Port (Constant _ n) -> typeOf n+      Input_Port (Prim _ _ i _) k -> i !! k+      Output_Port (Prim _ _ _ (Just o)) -> o+      _ -> undefined++-- * Wires++-- | Enumeration of wire types.+data Wire_Ty = Normal -- ^ Normal forward edge.+             | Backward Rec_Id  -- ^ Backward edge.+             | Implicit_Normal -- ^ Implicit wire from /recRd/ to node.+             | Implicit_Rec -- ^ Implicit wire from node to /recWr/.+             | Implicit_Backward -- ^ Implicit wire from /recWr/ to /recRd/.+               deriving (Eq,Show)++-- | A 'Wire' runs between two 'Ports'.+type Wire = (Port,Port,Wire_Ty)++-- | Set of 'Normal' wires between 'Port's.+normal_wires :: [Port] -> [Port] -> [Wire]+normal_wires = let f p q = (p,q,Normal) in zipWith f++-- | Set of 'Backward' wires between 'Port's.+rec_back_wires :: [Rec_Id] -> [Port] -> [Port] -> [Wire]+rec_back_wires = let f k p q = (p,q,Backward k) in zipWith3 f++-- | Immediate internal wires of a block diagram.+wires_immed :: BD -> [Wire]+wires_immed bd =+    case bd of+      Constant _ _ -> []+      Prim _ _ _ _ -> []+      Par _ _ -> []+      Seq p q -> let (_,op) = ports p+                     (iq,_) = ports q+                 in normal_wires op iq+      Split p q -> let (_,op) = ports p+                       (iq,_) = ports q+                   in normal_wires (cycle op) iq+      Rec (Just k) p q ->+          let (ip,op) = ports p+              (iq,oq) = ports q+          in rec_back_wires k oq ip ++ normal_wires op iq+      Rec Nothing _ _ -> error "wires_immed"++-- | Internal wires of a block diagram.+wires :: BD -> [Wire]+wires = bd_foldl (\st r -> st ++ wires_immed r) []++-- * Coherence++-- | A wire coheres if the 'port_ty' of the left and right hand sides+-- are equal.+wire_coheres :: Wire -> Bool+wire_coheres (p,q,_) = port_ty p == port_ty q++-- | The set of non-coherent wires at diagram.+bd_non_coherent :: BD -> [Wire]+bd_non_coherent = filter (not . wire_coheres) . wires++-- | Coherence predicate, ie. is 'bd_non_coherent' empty.+bd_is_coherent :: BD -> Bool+bd_is_coherent = null . bd_non_coherent++-- * Graph++-- | Primitive block diagram elements.+data Node = N_Constant {n_constant_id :: Id+                       ,n_constant_k :: K}+          | N_Prim {n_prim_id :: Either Id (Id,Id)+                   ,n_prim_name :: String+                   ,n_prim_in_degree :: Int+                   ,n_prim_ty :: Maybe TypeRep}+            deriving (Eq)++-- | Extract the current /actual/ node /id/ from 'n_prim_id'.+actual_id :: Either Id (Id,Id) -> Id+actual_id = either id fst++-- | Output type of 'Node', if out degree non-zero.+node_ty :: Node -> Maybe TypeRep+node_ty n =+    case n of+      N_Constant _ k -> Just (k_typeOf k)+      N_Prim _ _ _ ty -> ty++-- | Either 'n_constant_id' or 'actual_id' of 'n_prim_id'.+node_id :: Node -> Id+node_id n =+    case n of+      N_Constant k _ -> k+      N_Prim k _ _ _ -> actual_id k++-- | Pair 'Node' 'Id' with node.+node_lift_id :: Node -> (Id,Node)+node_lift_id n = (node_id n,n)++-- | Pretty printer, and 'Show' instance.+node_pp :: Node -> String+node_pp n =+    case n of+      N_Constant _ k -> k_concise k+      N_Prim _ nm _ _ -> nm++instance Show Node where show = node_pp++-- | Primitive edge, left hand 'Id', right hand side 'Id', right hand+-- 'Port_Index' and edge /type/.+type Edge = (Id,Id,(Port_Index,Wire_Ty))++-- | A graph is a list of 'Node' and a list of 'Edge's.+type Graph = ([Node],[Edge])++-- | Is 'Wire_Ty' of 'Edge' 'Implicit_Backward'.+edge_is_implicit_backward :: Edge -> Bool+edge_is_implicit_backward (_,_,(_,ty)) = ty == Implicit_Backward++-- | Implicit /rec/ nodes.+rec_nodes :: [Rec_Id] -> [Node]+rec_nodes =+    let f (i,j,ty) = [N_Prim (Right (i,i)) "df_rec_w" 1 (Just ty)+                     ,N_Prim (Right (j,i)) "df_rec_r" 1 (Just ty)]+    in concatMap f++-- | Collect all primitive nodes at a block diagram.+nodes :: Bool -> BD -> [Node]+nodes impl bd =+    let f = nodes impl+    in case bd of+         Constant (Just k) n -> [N_Constant k n]+         Constant _ _ -> error "nodes"+         Prim (Just k) nm i o -> [N_Prim (Left k) nm (length i) o]+         Prim _ _ _ _ -> error "nodes"+         Par p q -> f p ++ f q+         Seq p q -> f p ++ f q+         Split p q -> f p ++ f q+         Rec (Just k) p q -> f p ++ f q ++ if impl then rec_nodes k else []+         Rec _ _ _ -> error "nodes"++-- | A backward 'Wire' will introduce three /implicit/ edges, a+-- 'Normal' wire introduces one 'Normal' edge.+wire_to_edges :: Bool -> Wire -> [Edge]+wire_to_edges impl w =+    case w of+      (Output_Port p,Input_Port q qn,Backward (k0,k1,ty)) ->+          if impl+          then [(bd_req_id p,k0,(0,Implicit_Rec))+               ,(k1,bd_req_id q,(qn,Implicit_Normal))+               ,(k0,k1,(0,Implicit_Backward))]+          else [(bd_req_id p,bd_req_id q,(qn,Backward (k0,k1,ty)))]+      (Output_Port p,Input_Port q qn,Normal) ->+          [(bd_req_id p,bd_req_id q,(qn,Normal))]+      _ -> error (show ("wire_to_edges",w))++-- | 'concatMap' of 'wire_to_edges'.+wires_to_edges :: Bool -> [Wire] -> [Edge]+wires_to_edges impl = concatMap (wire_to_edges impl)++-- | 'wires_to_edges' of 'wires'.+edges :: Bool -> BD -> [Edge]+edges impl = wires_to_edges impl . wires++-- | Construct 'Graph' of block diagram, either with or without+-- /implicit/ edges.+graph' :: Bool -> BD -> Graph+graph' impl bd =+    let (_,bd') = bd_set_id bd+        n = nub (nodes impl bd')+        w = wires bd'+        e = wires_to_edges impl w+    in case filter (not . wire_coheres) w of+         [] -> (n,e)+         w' -> error (show ("graph': incoherent",w'))++-- | Construct 'Graph' of block diagram without /implicit/ edges.+-- This graph will include backward arcs if the graph contains /rec/s.+graph :: BD -> Graph+graph = graph' False++-- * Gr++-- | FGL graph of 'BD'.+type Gr = G.Gr Node (Port_Index,Wire_Ty)++-- | Transform 'BD' to 'Gr'.+gr :: BD -> Gr+gr bd =+    let (n,e) = graph' True bd+        n' = map node_lift_id n+        e' = filter (not . edge_is_implicit_backward) e+    in G.mkGraph n' e'++-- | Topological sort of nodes (via 'gr').+tsort :: BD -> Graph+tsort bd =+    let g = gr bd+    in (map (fromMaybe (error "tsort") . G.lab g) (G.topsort g)+       ,G.labEdges g)++-- | Make @dot@ rendering of graph at 'Node'.+gr_dot :: BD -> String+gr_dot = G.graphviz' . gr++-- | 'draw_dot' of 'gr_dot'.+gr_draw :: BD -> IO ()+gr_draw = draw_dot . gr_dot++-- * Drawing++-- | Dot description of 'Node'.+dot_node :: Node -> String+dot_node nd =+    case nd of+      N_Constant k c -> dot_rec' k (k_concise c) [] (k_typeOf c)+      N_Prim k nm i o -> dot_rec (actual_id k) nm (dot_rec_ar i) o++-- | Wires are coloured according to type.+wire_colour :: Wire_Ty -> String+wire_colour w =+    case w of+      Normal -> "black"+      Backward _ -> "red"+      Implicit_Normal -> "grey"+      Implicit_Rec -> "blue"+      Implicit_Backward -> "red"++-- | Dot description of 'Edge'.+dot_edge :: Edge -> String+dot_edge (p,q,(k,d)) =+    let c = wire_colour d+    in printf "%d:o_0 -> %d:i_%d %s;" p q k (dot_attr [("color",c)])++-- | Dot description of 'Graph'.+dot_graph :: Graph -> [String]+dot_graph (n,e) =+    concat [["digraph Anonymous {"+            ,"graph [splines=false];"]+           ,map dot_node n+           ,map dot_edge e+           ,["}"]]++-- | Draw dot graph.+draw_dot :: String -> IO ()+draw_dot d = do+  writeFile "/tmp/faust.dot" d+  _ <- system "dotty /tmp/faust.dot"+  return ()++-- | 'draw_dot' of 'dot_graph'.+draw :: Graph -> IO ()+draw = draw_dot . unlines . dot_graph++-- * Composition++-- | Fold of 'Par'.+--+-- > degree (par_l [1,2,3,4]) == (0,4)+-- > draw (graph (par_l [1,2,3,4] ~:> i_mul))+par_l :: [BD] -> BD+par_l = foldr1 Par++-- | Type-directed sum.+--+-- > draw (graph (bd_sum [1,2,3,4]))+bd_sum :: [BD] -> BD+bd_sum l =+    case l of+      [] -> error "bd_sum"+      [d] -> d+      p:q:l' -> bd_sum (((p ~. q) ~: (ty_add p q)) : l')++-- | Predicate to determine if /p/ can be /split/ onto /q/.+split_r :: BD -> BD -> Bool+split_r p q =+    let (i,j) = in_degree q `divMod` out_degree p+    in i >= 1 && j == 0++-- | /split/ if diagrams cohere.+split_m :: BD -> BD -> Maybe BD+split_m p q =+    if split_r p q+    then Just (Split p q)+    else Nothing++-- | /split/ if diagrams cohere, else 'error'.  Synonym of '~<:'.+split :: BD -> BD -> BD+split p = fromMaybe (error "split") . split_m p++-- | If merge is legal, the number of in-edges per port at /q/.+--+-- > merge_degree (par_l [1,2,3]) i_negate == Just 3+-- > merge_degree (par_l [1,2,3,4]) i_mul == Just 2+merge_degree :: BD -> BD -> Maybe Int+merge_degree p q =+    let (i,j) = out_degree p `divMod` in_degree q+    in if i > 1 && j == 0 then Just i else Nothing++-- | /merge/ if diagrams cohere.+--+-- > merge_m (par_l [1,2,3]) i_negate+-- > merge_m (par_l [1,2,3,4]) i_mul+merge_m :: BD -> BD -> Maybe BD+merge_m p q =+    case merge_degree p q of+      Just n ->+          let (_,op) = ports p+              (iq,_) = degree q+              op' = map port_bd op+              p' = if iq == 1+                   then [op']+                   else transpose (S.chunksOf n op')+          in Just (Seq (par_l (map bd_sum p')) q)+      _ -> Nothing++-- | /merge/ if diagrams cohere, else 'error'.  Synonym of '~:>'.+merge :: BD -> BD -> BD+merge p = fromMaybe (error "merge") . merge_m p++-- | Predicate to determine if /p/ can be /rec/ onto /q/.+rec_r :: BD -> BD -> Bool+rec_r p q = out_degree p >= in_degree q && in_degree p >= out_degree q++-- | /rec/ if diagrams cohere.+rec_m :: BD -> BD -> Maybe BD+rec_m p q =+    if rec_r p q+    then Just (Rec Nothing p q)+    else Nothing++-- | /rec/ if diagrams cohere, else 'error'.  Synonym of '~~'.+rec :: BD -> BD -> BD+rec p = fromMaybe (error "rec") . rec_m p++-- * Constants++-- | Integer constant.+i_constant :: Int -> BD+i_constant = Constant Nothing . I . fromIntegral++-- | Real constant.+r_constant :: Float -> BD+r_constant = Constant Nothing . F++-- * Primitives++-- | Construct uniform /type/ primitive diagram.+u_prim :: TypeRep -> String -> Int -> BD+u_prim ty nm i = Prim Nothing nm (replicate i ty) (Just ty)++-- | 'u_prim' of 'int32_t'.+i_prim :: String -> Int -> BD+i_prim = u_prim int32_t++-- | 'u_prim' of 'float_t'.+r_prim :: String -> Int -> BD+r_prim = u_prim float_t++-- | Adddition, ie. '+' of 'Num'.+--+-- > (1 ~. 2) ~: i_add+-- > (1 :: BD) + 2+i_add,r_add :: BD+i_add = i_prim "df_add" 2+r_add = r_prim "df_add" 2++-- | Subtraction, ie. '-' of 'Num'.+i_sub,r_sub :: BD+i_sub = i_prim "df_sub" 2+r_sub = r_prim "df_sub" 2++-- | Multiplication, ie. '*' of 'Num'.+i_mul,r_mul :: BD+i_mul = i_prim "df_mul" 2+r_mul = r_prim "df_mul" 2++-- | Division, ie. 'div' of 'Integral'.+i_div :: BD+i_div = i_prim "df_div" 2++-- | Division, ie. '/' of 'Fractional'.+r_div :: BD+r_div = r_prim "df_div" 2++-- | Absolute value, ie. 'abs' of 'Num'.+i_abs,r_abs :: BD+i_abs = i_prim "df_abs" 1+r_abs = r_prim "df_abs" 1++-- | Negation, ie. 'negate' of 'Num'.+i_negate,r_negate :: BD+i_negate = i_prim "df_negate" 1+r_negate = r_prim "df_negate" 1++-- | Identity diagram.+i_identity, r_identity :: BD+i_identity = u_prim int32_t "df_identity" 1+r_identity = u_prim float_t "df_identity" 1++-- | Coerce 'float_t' to 'int32_t'.+float_to_int32 :: BD+float_to_int32 = Prim Nothing "df_float_to_int32" [float_t] (Just int32_t)++-- | Coerce 'int32_t' to 'float_t'.+int32_to_float :: BD+int32_to_float = Prim Nothing "df_int32_to_float" [int32_t] (Just float_t)++-- | 'int32_to_float' and then scale to be in (-1,1).+i32_to_normal_f32 :: BD+i32_to_normal_f32 = (int32_to_float ~. 2147483647.0) ~: r_div++-- | Single channel output.+--+-- > degree out1 == (1,0)+-- > bd_signature out1 == ([float_t],[])+out1 :: BD+out1 = Prim Nothing "df_out1" [float_t] Nothing++-- * Type following primitives++-- | Type following unary operator.+ty_uop :: (BD -> Maybe TypeRep) -> t -> t -> BD -> t+ty_uop ty f g p =+    let p' = ty p+    in if p' == Just int32_t+       then f+       else if p' == Just float_t+            then g+            else error "ty_uop"++-- | Type following binary operator.+ty_binop :: (BD -> Maybe TypeRep) -> t -> t -> BD -> BD -> t+ty_binop ty f g p q =+    let p' = ty p+        q' = ty q+    in if p' == Just int32_t && q' == Just int32_t+       then f+       else if p' == Just float_t && q' == Just float_t+            then g+            else error "ty_binop"++-- | Type following math operator, uniform types.+--+-- > 1.0 `ty_add` 2.0 == r_add+-- > (1 ~. 2) `ty_add` (3 ~. 4) == i_add+-- > 1.0 `ty_add` 2 == _|_+-- > draw (graph ((1 ~. 2) - (3 ~. 4)))+ty_add,ty_sub,ty_mul,ty_div :: BD -> BD -> BD+ty_add = ty_binop bd_ty_uniform i_add r_add+ty_sub = ty_binop bd_ty_uniform i_sub r_sub+ty_mul = ty_binop bd_ty_uniform i_mul r_mul+ty_div = ty_binop bd_ty_uniform i_div r_div++-- | Type following math operator, singular types.+--+-- > 1.0 `ty_add1` 2.0 == r_add+-- > 1.0 `ty_add1` 2 == _|_+ty_add1,ty_mul1,ty_div1 :: BD -> BD -> BD+ty_add1 = ty_binop bd_ty1 i_add r_add+ty_mul1 = ty_binop bd_ty1 i_mul r_mul+ty_div1 = ty_binop bd_ty1 i_div r_div++-- * Code Gen++-- | List of constants for CGen.+cg_k :: [Node] -> [(Id,K)]+cg_k =+    let f n = case n of+                N_Constant k c -> Just (k,c)+                _ -> Nothing+    in mapMaybe f++-- | 'Var' of 'Node'.+cg_node_var :: Node -> Maybe Var+cg_node_var n =+    case n of+      N_Constant k c -> Just (k_var k Std_Var c)+      N_Prim k _ _ (Just ty) ->+          case k of+            Left k' -> Just (Std_Var,ty,k',Nothing)+            Right (k',k'') ->+                if k' == k''+                then Just (Rec_Var,ty,k',Just (Left 0))+                else Just (Std_Var,ty,k',Nothing)+      N_Prim _ _ _ Nothing -> Nothing++-- | Output reference for 'Node'.+node_output :: Node -> Maybe (Var_Ty,Id)+node_output n =+    case n of+      N_Prim _ _ _ Nothing -> Nothing+      N_Constant k _ -> Just (Std_Var,k)+      N_Prim (Right (k,_)) "df_rec_r" _ _ -> Just (Std_Var,k)+      N_Prim (Right (k,_)) "df_rec_w" _ _ -> Just (Rec_Var,k)+      N_Prim (Right _) _ _ _ -> error "node_output: Right"+      N_Prim (Left k) _ _ _ -> Just (Std_Var,k)++-- | Input references for 'Node'.+node_inputs :: [Edge] -> Node -> [(Var_Ty,Id)]+node_inputs e n =+    let f k (_,k',_) = k == k'+        g (k,_,(p,_)) = (p,k)+        i = sort (map g (filter (f (node_id n)) e))+    in case n of+         N_Prim (Right (_,k)) "df_rec_r" _ _ -> [(Rec_Var,k)]+         _ -> zip (repeat Std_Var) (map snd i)++-- | 'C_Call' of 'Node'.+cg_node_c_call :: [Edge] -> Node -> Maybe C_Call+cg_node_c_call e n =+    case n of+      N_Constant _ _ -> Nothing+      N_Prim _ nm _ _ -> let i = node_inputs e n+                             i' = case node_output n of+                                    Just o -> o : i+                                    Nothing -> i+                         in Just (Nothing,nm,i')++-- | Generate CGen 'Instructions' for 'BD'.+bd_instructions :: BD -> Instructions+bd_instructions bd =+    let (n,e) = tsort bd+    in (cg_k n+       ,mapMaybe cg_node_var n+       ,mapMaybe (cg_node_c_call e) n)++-- * Audition++-- | Audition graph after sending initialisation messages.+audition :: [Message] -> BD -> IO ()+audition is bd = L.audition is (bd_instructions bd)++-- * Figures from /Quick Reference/++-- | Figure illustrating '~.'.+--+-- > degree fig_3_2 == (2,2)+-- > draw (graph fig_3_2)+fig_3_2 :: BD+fig_3_2 = 10.0 ~. r_mul++-- | Figure illustrating '~:'.+--+-- > degree fig_3_3 == (4,1)+-- > bd_signature fig_3_3+-- > draw (graph fig_3_3)+fig_3_3 :: BD+fig_3_3 = (r_mul ~. r_div) ~: r_add++-- | Figure illustrating '~<:'.+--+-- > degree fig_3_4 == (0,3)+-- > draw (graph fig_3_4)+fig_3_4 :: BD+fig_3_4 = (10.0 ~. 20.0) ~<: (par_l [r_add,r_mul,r_div])++-- | Figure illustrating '~:>'.+--+-- > degree fig_3_5 == (0,1)+-- > draw (graph fig_3_5)+fig_3_5 :: BD+fig_3_5 = par_l [10,20,30,40] ~:> i_mul++-- | Figure illustrating '~~'.+--+-- > degree fig_3_6 == (0,1)+-- > draw (graph fig_3_6)+fig_3_6 :: BD+fig_3_6 =+    let p = 12345 ~: i_add+        q = 1103515245 ~: i_mul+    in p ~~ q++-- | Variant generating audible graph.+--+-- > draw (graph fig_3_6')+-- > gr_draw fig_3_6'+-- > audition [] fig_3_6'+fig_3_6' :: BD+fig_3_6' = fig_3_6 ~: i32_to_normal_f32 ~: (0.1 ~: r_mul) ~: out1++-- | A counter, illustrating /identity/ diagram.+--+-- > draw (graph (i_counter ~: i_negate))+-- > gr_draw (i_counter ~: i_negate)+i_counter :: BD+i_counter = (1 ~: i_add) ~~ i_identity++-- * List++-- | Adjacent elements of list.+--+-- > adjacent [1..4] == [(1,2),(3,4)]+adjacent :: [t] -> [(t,t)]+adjacent l =+    case l of+      [] -> []+      p:q:l' -> (p,q) : adjacent l'+      _ -> error "adjacent"++-- * Tuple++-- | Bimap at tuple.+--+-- > bimap abs negate (-1,1) == (1,-1)+bimap :: (a -> b) -> (c -> d) -> (a,c) -> (b,d)+bimap f g (p,q) = (f p,g q)

@@ -0,0 +1,18 @@+-- | Top level module for uniform rate model @hdf@.+--+-- > import Sound.DF.Uniform.GADT+-- > draw (lf_pulse 0.09 0.0 0.16)+module Sound.DF.Uniform.GADT+    (module Sound.DF.Uniform.GADT.Audition+    ,module Sound.DF.Uniform.GADT.DF+    ,module Sound.DF.Uniform.GADT.Draw+    ,module Sound.DF.Uniform.GADT.UGen.Monadic+    ,module Sound.DF.Uniform.GADT.UGen+    ,module Sound.DF.Uniform.LL.UId) where++import Sound.DF.Uniform.GADT.Audition+import Sound.DF.Uniform.GADT.Draw+import Sound.DF.Uniform.GADT.DF+import Sound.DF.Uniform.GADT.UGen+import Sound.DF.Uniform.GADT.UGen.Monadic+import Sound.DF.Uniform.LL.UId

@@ -0,0 +1,19 @@+-- | Interaction with @jack-dl@, @scsynth@ and @text-dl@.+module Sound.DF.Uniform.GADT.Audition where++import Sound.OSC {- hosc -}++import Sound.DF.Uniform.GADT.DF+import Sound.DF.Uniform.UDF as U++-- | Audition graph at @jack-dl@ after sending initialisation messages.+audition :: [Message] -> DF () -> IO ()+audition is n = U.audition is (df_erase n)++-- | Audition graph at @SC3@ after sending initialisation messages.+audition_sc3 :: [Message] -> DF () -> IO ()+audition_sc3 is n = U.audition_sc3 is (df_erase n)++-- | Audition graph at @text-dl@.+audition_text :: Int -> DF () -> IO ()+audition_text nf n = U.audition_text nf (df_erase n)

@@ -0,0 +1,382 @@+{-# Language FlexibleInstances,GADTs,DeriveDataTypeable,StandaloneDeriving #-}+-- | Data flow nodes.+module Sound.DF.Uniform.GADT.DF where++import Data.Int {- base -}+import Data.Typeable {- base -}+import Data.Digest.Murmur32 {- murmur-hash -}++import Sound.DF.Uniform.LL+import Sound.DF.Uniform.UDF++-- * DF++-- | Data flow node.+data DF a where+    K :: K' a => a -> DF a+    A :: Vec Float -> DF (Vec Float)+    R :: K' a => R_Id -> TypeRep -> Either a (DF b,DF a) -> DF b+    P0 :: K' a => String -> TypeRep -> DF a+    P1 :: (K' a,K' b) => String -> TypeRep -> DF a -> DF b+    P2 :: (K' a,K' b,K' c) => String -> TypeRep -> DF a -> DF b -> DF c+    P3 :: (K' a,K' b,K' c,K' d) =>+          String -> TypeRep -> DF a -> DF b -> DF c -> DF d+    M :: K' a => DF a -> DF () -> DF a++deriving instance Show a => Show (DF a)++-- | Typeable instance for 'DF'.+--+-- > df_typeOf (C (undefined::Int32)) == int32_t+-- > df_typeOf (C (undefined::Float)) == float_t+-- > df_typeOf (A undefined) == vec_float_t+-- > df_typeOf (0::DF Int32) == int32_t+-- > df_typeOf (0.0::DF Float) == float_t+df_typeOf :: K' a => DF a -> TypeRep+df_typeOf df =+    case df of+      K k -> typeOf k+      A _ -> vec_float_t+      R _ t _ -> t+      P0 _ t -> t+      P1 _ t _ -> t+      P2 _ t _ _ -> t+      P3 _ t _ _ _ -> t+      M n _ -> df_typeOf n++instance K' a => Typeable (DF a) where typeOf = df_typeOf++-- | Name of primitive if 'DF' is 'P0' or 'P1' etc.+df_primitive :: DF a -> Maybe String+df_primitive df =+    case df of+      P0 nm _ -> Just nm+      P1 nm _ _ -> Just nm+      P2 nm _ _ _ -> Just nm+      P3 nm _ _ _ _ -> Just nm+      _ -> Nothing++-- * MRG++-- | Multiple root graph (alias for M).+mrg :: K' a => DF a -> DF () -> DF a+mrg = M++-- * DF Vec++-- | 'DF' 'Vec' constructor.+df_vec :: V_Id -> [Float] -> DF (Vec Float)+df_vec k v = A (Vec k (length v) v)++-- | Monadic 'DF' 'Vec' constructor.+df_vec_m :: UId m => [Float] -> m (DF (Vec Float))+df_vec_m v = do+  k <- generateId+  return (df_vec (V_Id k) v)++-- | 'DF' 'Vec' size.+df_vec_size :: DF a -> Maybe Int+df_vec_size df =+    case df of+      A (Vec _ n _) -> Just n+      _ -> Nothing++-- | 'df_vec_size' variant, tables have a guard point.+df_tbl_size :: DF a -> Maybe Int+df_tbl_size = fmap (+ (-1)) . df_vec_size++-- * Operator types++-- | Unary operator.+type Unary_Op a = a -> a++-- | Binary operator.+type Binary_Op a = a -> a -> a++-- | Ternary operator.+type Ternary_Op a = a -> a -> a -> a++-- | Quaternary operator.+type Quaternary_Op a = a -> a -> a -> a -> a++-- | Quinary operator.+type Quinary_Op a = a -> a -> a -> a -> a -> a++-- | Senary operator.+type Senary_Op a = a -> a -> a -> a -> a -> a -> a++-- * Uniform function types++-- | Binary function.+type Binary_Fn i o = i -> i -> o++-- * Primitive constructors++-- | Unary operator.+mk_uop :: (K' a) => String -> Unary_Op (DF a)+mk_uop nm p = P1 nm (df_typeOf p) p++-- | Binary operator.+mk_binop :: K' a => String -> Binary_Op (DF a)+mk_binop nm p q = P2 nm (df_typeOf p) p q++-- | Binary operator.+mk_ternaryop :: K' a => String -> Ternary_Op (DF a)+mk_ternaryop nm p q r = P3 nm (df_typeOf p) p q r++-- | 'DF' multiply and add.+df_mul_add :: K_Num a => DF a -> DF a -> DF a -> DF a+df_mul_add = mk_ternaryop "df_mul_add"++-- | Optimising addition primitive.  If either input is a multiplier+-- node, unfold to a multiplier-add node.+--+-- > df_add_optimise (2 * 3) (4::DF Int32)+-- > df_add_optimise (2::DF Int32) (3 * 4)+df_add_optimise :: K_Num a => DF a -> DF a -> DF a+df_add_optimise p q =+    case (p,q) of+      (P2 "df_mul" t l r,_) -> P3 "df_mul_add" t l r q+      (_,P2 "df_mul" t l r) -> P3 "df_mul_add" t l r p+      _ -> mk_binop "df_add" p q++instance K_Num a => Num (DF a) where+    (+) = df_add_optimise+    (*) = mk_binop "df_mul"+    (-) = mk_binop "df_sub"+    negate = mk_uop "df_negate"+    abs = mk_uop "df_abs"+    signum = mk_uop "df_signum"+    fromInteger = K . fromInteger++instance Fractional (DF Float) where+    (/) = P2 "df_div" float_t+    recip = P1 "df_recip" float_t+    fromRational = K . fromRational++instance Floating (DF Float) where+  pi = K pi+  exp = P1 "df_exp" float_t+  sqrt = P1 "df_sqrt" float_t+  log = P1 "df_log" float_t+  (**) = P2 "df_pow" float_t+  logBase = undefined+  sin = P1 "df_sin" float_t+  tan = P1 "df_tan" float_t+  cos = P1 "df_cos" float_t+  asin = undefined+  atan = undefined+  acos = undefined+  sinh = undefined+  tanh = undefined+  cosh = undefined+  asinh = undefined+  atanh = undefined+  acosh = undefined++-- * Bits++-- | "Data.Bits" @.&.@.+df_bw_and :: DF Int32 -> DF Int32 -> DF Int32+df_bw_and = P2 "df_bw_and" int32_t++-- | "Data.Bits" @.|.@.+df_bw_or :: DF Int32 -> DF Int32 -> DF Int32+df_bw_or = P2 "df_bw_or" int32_t++-- | "Data.Bits" @complement@.+df_bw_not :: DF Int32 -> DF Int32+df_bw_not = P1 "df_bw_not" int32_t++-- * Ord++-- | '==', equal to.+df_eq :: K_Ord a => DF a -> DF a -> DF Bool+df_eq = P2 "df_eq" bool_t++-- | '<', less than.+df_lt :: K_Ord a => DF a -> DF a -> DF Bool+df_lt = P2 "df_lt" bool_t++-- | '>=', greater than or equal to.+df_gte :: K_Ord a => DF a -> DF a -> DF Bool+df_gte = P2 "df_gte" bool_t++-- | '>', greater than.+df_gt :: K_Ord a => DF a -> DF a -> DF Bool+df_gt = P2 "df_gt" bool_t++-- | '<=', less than or equal to.+df_lte :: K_Ord a => DF a -> DF a -> DF Bool+df_lte = P2 "df_lte" bool_t++-- | 'max', select maximum.+df_max :: K_Ord a => DF a -> DF a -> DF a+df_max = mk_binop "df_max"++-- | 'min', select minimum.+df_min :: K_Ord a => DF a -> DF a -> DF a+df_min = mk_binop "df_min"++-- * Cast++-- | Cast floating point to integer.+df_float_to_int32 :: DF Float -> DF Int32+df_float_to_int32 = P1 "df_float_to_int32" int32_t++-- | Cast integer to floating point.+df_int32_to_float :: DF Int32 -> DF Float+df_int32_to_float = P1 "df_int32_to_float" float_t++-- | Scale 'Int32' to (-1,1) normalised 'Float'.+--+-- > maxBound == (2147483647::Int32)+i32_to_normal_f32 :: DF Int32 -> DF Float+i32_to_normal_f32 = (/ 2147483647) . df_int32_to_float++-- * Integral++-- | Integral modulo, ie. 'mod'.+df_mod :: Binary_Op (DF Int32)+df_mod = P2 "df_mod" int32_t++-- | Floating point modulo, ie. "Foreign.C.Math" /fmodf/.+df_fmodf :: Binary_Op (DF Float)+df_fmodf = P2 "df_fmodf" float_t++-- * RealFrac++-- | ceilf(3)+df_ceilf :: DF Float -> DF Float+df_ceilf = P1 "df_ceilf" float_t++-- | floorf(3)+df_floorf :: DF Float -> DF Float+df_floorf = P1 "df_floorf" float_t++-- | lrintf(3)+df_lrintf :: DF Float -> DF Int32+df_lrintf = P1 "df_lrintf" int32_t++-- | roundf(3)+df_roundf :: DF Float -> DF Float+df_roundf = P1 "df_roundf" float_t++-- * Backward arcs++-- | Introduce backward arc with implicit unit delay.+--+-- The function receives the previous output as input, initially @y0@,+-- and returns a /(feed-forward,feed-backward)/ pair.+--+-- > rec_r (R_Id 0) (0::Int) ((\i->(i,i)) . (+) 1)+-- > rec_r (R_Id 0) (0.0::Float) ((\i->(i,i)) . (+) 1.0)+rec_r :: K' a => R_Id -> a -> (DF a -> (DF b,DF a)) -> DF b+rec_r n y0 f =+    let t = typeOf y0+        i = R n t (Left y0)+    in R n t (Right (f i))++-- | Monadic variant of 'rec_r'.+rec_m :: (K' a,UId m) => a -> (DF a -> (DF b,DF a)) -> m (DF b)+rec_m y0 f = do+  n <- generateId+  return (rec_r (R_Id n) y0 f)++-- | Hash-eq variant of 'rec_r'.+rec_h :: (K' a,Show b) => a -> (DF a -> (DF b,DF a)) -> DF b+rec_h y0 f =+    let n = abs (fromIntegral (asWord32 (hash32 (show (f (K y0))))))+    in rec_r (R_Id n) y0 f++-- | Variant of 'rec_m' with monadic action in backward arc.+rec_mM :: (K' a,UId m) => a -> (DF a -> m (DF b,DF a)) -> m (DF b)+rec_mM i f = do+  n <- generateId+  let t = typeOf i+      r_r = R (R_Id n) t (Left i)+  r <- f r_r+  return (R (R_Id n) t (Right r))++-- * Primitives++-- | Single channel input (channel 0).+in1 :: DF Float+in1 = P0 "df_in1" float_t++-- | Single channel output (channel 0).+out1 :: DF Float -> DF ()+out1 = P1 "df_out1" nil_t++-- | Two channel output (channels 1 & 2).+out2 :: DF Float -> DF Float -> DF ()+out2 = P2 "df_out2" nil_t++-- | Three channel output.+out3 :: DF Float -> DF Float -> DF Float -> DF ()+out3 = P3 "df_out3" nil_t++-- | Single control input.+ctl1 :: DF Int32 -> DF Float+ctl1 = P1 "df_ctl1" float_t++-- | Logical '&&'.+df_and :: DF Bool -> DF Bool -> DF Bool+df_and = P2 "df_and" bool_t++-- | Logical '||'.+df_or :: DF Bool -> DF Bool -> DF Bool+df_or = P2 "df_or" bool_t++-- | Logical 'not'.+df_not :: DF Bool -> DF Bool+df_not = P1 "df_not" bool_t++-- | If /p/ then /q/ else /r/.  /p/ must have type bool, and /q/+-- and /r/ must have equal types.+select2 :: K' a => DF Bool -> DF a -> DF a -> DF a+select2 p q = P3 "df_select2" (df_typeOf q) p q++-- | Operating sample rate.+w_sample_rate :: DF Float+w_sample_rate = P0 "df_sample_rate" float_t++-- | Number of frames in current control period.+w_kr_nframes :: DF Int32+w_kr_nframes = P0 "df_kr_nframes" int32_t++-- | 'True' at first frame of each control period.+w_kr_edge :: DF Bool+w_kr_edge = P0 "df_kr_edge" bool_t++-- | Buffer read, read from buffer /p/ at index /q/.+b_read :: DF Int32 -> DF Int32 -> DF Float+b_read = P2 "df_b_read" float_t++-- | Buffer write, write to buffer /p/ at index /q/ value /r/.+b_write :: DF Int32 -> DF Int32 -> DF Float -> DF ()+b_write = P3 "df_b_write" nil_t++-- | Array read.+a_read :: DF (Vec Float)-> DF Int32 -> DF Float+a_read = P2 "df_a_read" float_t++-- | Array writ.+a_write :: DF (Vec Float) -> DF Int32 -> DF Float -> DF ()+a_write = P3 "df_a_write" nil_t++-- * Untyped++-- | Transform typed 'DF' to un-typed 'UDF'.+df_erase :: K' a => DF a -> UDF+df_erase n =+    case n of+      K i -> UDF_K (to_k i)+      A a -> UDF_A a+      R k _ (Left i) -> UDF_R k (Left (to_k i))+      R k _ (Right (i,j)) -> UDF_R k (Right (df_erase i,df_erase j))+      P0 nm t -> UDF_P nm t []+      P1 nm t i -> UDF_P nm t [df_erase i]+      P2 nm t i j -> UDF_P nm t [df_erase i,df_erase j]+      P3 nm t i j k -> UDF_P nm t [df_erase i,df_erase j,df_erase k]+      M i j -> UDF_M (df_erase i) (df_erase j)

@@ -0,0 +1,31 @@+-- | Graph drawing+module Sound.DF.Uniform.GADT.Draw where++import Control.Monad.Trans.State {- transformers -}+import Sound.DF.Uniform.GADT.DF+import Sound.DF.Uniform.LL+import Sound.DF.Uniform.UDF as U++-- | 'U.draw' of 'df_erase'.+draw :: K' a => DF a -> IO ()+draw = U.draw . df_erase++-- | `U.draw'` of 'df_erase'.+draw' :: K' a => DF a -> IO ()+draw' = U.draw' . df_erase++-- | 'U.draw' of 'df_erase' of 'evalId'.+drawM :: K' a => State Id (DF a) -> IO ()+drawM = U.draw . df_erase . evalId++-- | 'U.gr_draw' of 'df_erase'.+gr_draw :: K' a => DF a -> IO ()+gr_draw = U.gr_draw . df_erase++-- | `U.gr_draw'` of 'df_erase'.+gr_draw' :: K' a => DF a -> IO ()+gr_draw' = U.gr_draw' . df_erase++-- | 'U.gr_draw' of 'df_erase' of 'evalId'.+gr_drawM :: K' a => State Id (DF a) -> IO ()+gr_drawM = U.gr_draw . df_erase . evalId

@@ -0,0 +1,776 @@+-- | Data flow node functions, or unit generators.+module Sound.DF.Uniform.GADT.UGen where++import Data.Int {- base -}+import Data.Maybe {- base -}++import Sound.DF.Uniform.GADT.DF+import Sound.DF.Uniform.LL.K++-- * Tuples++-- | Duplicate a value into a tuple.+--+-- > split 1 == (1,1)+split :: a -> (a,a)+split p = (p,p)++-- | Reversed tuple constructor, (ie. @flip (,)@)+--+-- > swap 2 1 == (1,2)+swap :: a -> b -> (b,a)+swap = flip (,)++-- * Math++-- | Two pi.+--+-- > two_pi == 6.283185307179586+two_pi :: Floating a => a+two_pi = 2.0 * pi++-- | Midi note number to cycles per second.+--+-- > midi_cps 69 == 440+midi_cps :: Floating a => a -> a+midi_cps a = 440.0 * (2.0 ** ((a - 69.0) * (1.0 / 12.0)))++-- | Multiply and add.+--+-- > map (mul_add 2 3) [1,2] == [5,7] && map (mul_add 3 4) [1,2] == [7,10]+mul_add :: Num a => a -> a -> a -> a+mul_add m a = (+ a) .(* m)++-- | Calculate feedback multipler in comb filter circuit given /delay/+-- and /decay/ times.+--+-- > calc_fb 0.2 3.0 == 0.6309573444801932+calc_fb :: Floating a => a -> a -> a+calc_fb delayt decayt = exp ((log 0.001 * delayt) / decayt)++-- | Linear range conversion.+--+-- > map (\i -> lin_lin i (-1) 1 0 1) [-1,-0.9 .. 1.0]+--+-- > do {s <- lf_saw 1.0 0.0+-- >    ;o <- sin_osc (lin_lin s (-1.0) 1.0 220.0 440.0) 0.0+-- >    ;audition [] (out1 (o * 0.1))}+lin_lin :: Fractional a => a -> a -> a -> a -> a -> a+lin_lin i in_l in_r out_l out_r =+    let s = (out_r - out_l) / (in_r - in_l)+        o = out_l - (s * in_l)+    in (i * s) + o++-- | Exponential range conversion.+--+-- > map (\i -> lin_exp i 1 2 1 3) [1,1.1 .. 2]+--+-- > do {s <- lf_saw 0.25 0.0+-- >    ;o <- sin_osc (lin_exp (s + 1.0) 0.0 2.0 220.0 440.0) 0.0+-- >    ;audition [] (out1 (o * 0.1))}+lin_exp :: Floating a => a -> a -> a -> a -> a -> a+lin_exp i in_l in_r out_l out_r =+    let rt = out_r / out_l+        rn = 1.0 / (in_r - in_l)+        rr = rn * negate in_l+    in out_l * (rt ** (i * rn + rr))++-- | Constrain p in (-q,q).+--+-- > let r = -10 : -10 : [-10,-9 .. 10]+-- > in map (flip clip2 10) [-12,-11 .. 12] == r+clip2 :: (Num a, Ord a) => a -> a -> a+clip2 p q =+    let nq = negate q+    in min q (max p nq)++-- | /sr/ = sample rate, /r/ = cycle (two-pi), /hz/ = frequency+--+-- > hz_to_incr 48000 128 375 == 1+-- > hz_to_incr 48000 two_pi 458.3662361046586 == 6e-2+hz_to_incr :: Fractional a => a -> a -> a -> a+hz_to_incr sr r hz = (r / sr) * hz++-- | Inverse of 'hz_to_incr'.+--+-- > incr_to_hz 48000 128 1 == 375+incr_to_hz :: Fractional a => a -> a -> a -> a+incr_to_hz sr r ic = ic / (r / sr)++-- | Linear pan.+--+-- > map (lin_pan2 1) [-1,0,1] == [(1,0),(0.5,0.5),(0,1)]+--+-- > do {o <- sin_osc 440.0 0.0+-- >    ;l <- sin_osc 0.5 0.0+-- >    ;let (p,q) = lin_pan2 (o * 0.1) l+-- >     in audition [] (out2 p q)}+lin_pan2 :: Fractional t => t -> t -> (t, t)+lin_pan2 p q =+    let q' = (q / 2) + 0.5+    in (p * (1 - q'),p * q')++-- * Environment++-- | Compile time sample rate constant.+k_sample_rate :: Fractional n => n+k_sample_rate = 48000++-- | Environment value, equal to @'two_pi' / 'w_sample_rate'@.+w_radians_per_sample :: DF Float+w_radians_per_sample = two_pi / w_sample_rate++-- * Tbl++-- | Add guard point.+--+-- > tbl_guard [1,2,3] == [1,2,3,1]+tbl_guard :: [a] -> [a]+tbl_guard t =+    case t of+      [] -> []+      i:_ -> t ++ [i]++-- | Generate guarded sin table.+--+-- > map (round . (* 100)) (tbl_sin 12) == [0,50,87,100,87,50,0,-50,-87,-100,-87,-50,0]+tbl_sin :: Floating n => Int -> [n]+tbl_sin n =+    let f = sin . (* 2) . (* pi) . (/ fromIntegral n) . fromIntegral+    in tbl_guard (map f [0 .. n - 1])++-- * Phasor++-- | If 'q >= p' then 'q - p' else 'q'.+clipr :: K_Num a => DF a -> DF a -> DF a+clipr p q = select2 (q `df_gte` p) (q - p) q++-- | 'clip2' variant.+--+-- > do {o <- sin_osc 440 0+-- >    ;audition [] (out1 (df_clip2 (o * 2) 0.1))}+df_clip2 :: K_Num a => DF a -> DF a -> DF a+df_clip2 p q =+    let nq = negate q+    in df_min q (df_max p nq)++-- | Single place infinite impulse response filter with indicated+-- initial value.+--+-- > import Data.Int+-- > import Sound.DF.Uniform.GADT+-- > import Sound.DF.Uniform.LL.K+--+-- > draw (iir1 (0::Int32) (+) 1)+-- > draw (iir1 (0::Float) (+) 1)+iir1 :: (K' a) => a -> (Binary_Op (DF a)) -> DF a -> DF a+iir1 y0 f i = rec_h y0 (split . f i)++-- | /r/ = right hand edge, /ip/ = initial phase, /x/ = increment+--+-- > draw (phasor 9.0 (4.5::Float) 0.5)+-- > draw (phasor 9 (0::Int32) 1)+phasor :: K_Num a => DF a -> a -> DF a -> DF a+phasor r ip = iir1 ip (\x y1 -> clipr r (x + y1))++-- * Array++-- | Allocate /n/ second array, variant of 'df_vec'.+a_alloc_sec :: V_Id -> Float -> DF (Vec Float)+a_alloc_sec k z =+    let z' = ceiling (z * k_sample_rate) + 1 + 1+    in df_vec k (replicate z' 0)++-- | Array delay with /phasor/ argument for write index.+a_delay_ph :: DF (Vec Float) -> DF Float -> DF Int32 -> DF Int32 -> DF Float+a_delay_ph a s n wi =+  let ri = clipr n (wi + 1)+  in mrg (a_read a ri) (a_write a wi s)++-- | Array delay.+--+-- > do {a <- df_vec_m [0,1,2]+-- >    ;draw (a_delay a 0.0 0)}+--+-- > let {f = sin_osc 0.1 0.0+-- >     ;o = sin_osc (f * 200.0 + 600.0) 0.0+-- >     ;a = df_vec (V_Id 0) (replicate 48000 0)+-- >     ;d = a_delay a o 24000}+-- > in audition [] (out2 (o * 0.1) (d * 0.05))+a_delay :: DF (Vec Float) -> DF Float -> DF Int32 -> DF Float+a_delay a s n = a_delay_ph a s n (phasor n 0 1)++-- | Array fill function (sin).+--+-- > do {i <- phasor 64 0 1+-- >    ;a = a_tbl_sin (V_Id 0) 64+-- >    ;let s = a_read a i+-- >     in audition [] (out1 (s * 0.2))}+a_tbl_sin :: V_Id -> Int -> DF (Vec Float)+a_tbl_sin k = df_vec k . tbl_sin++-- | Linear interpolating variant of 'a_read'.+--+-- > let {i = phasor 64.0 0 (hz_to_incr k_sample_rate 64.0 330.0)+-- >     ;a = a_tbl_sin (V_Id 0) 64+-- >     ;s = a_lerp a i}+-- > in audition [] (out1 (s * 0.2))+a_lerp :: DF (Vec Float) -> DF Float -> DF Float+a_lerp a i =+    let i_f = df_floorf i+        i_c = df_ceilf i+        z = i - i_f+        p = a_read a (df_lrintf i_f)+        q = a_read a (df_lrintf i_c)+    in (p * (1.0 - z)) + (q * z)++-- * Osc++-- | 'phasor' for table of /z/ places. /ip/ is in (0,1).+--+-- > draw (phasor 64.0 (0.0::Float) (hz_to_incr k_sample_rate 64.0 330.0))+-- > draw (tbl_phasor 64 0.0 330.0)+tbl_phasor :: Int -> Float -> DF Float -> DF Float+tbl_phasor z ip f =+  let z_r = fromIntegral z+      z_c = K z_r+      ip_c = ip * z_r+  in phasor z_c ip_c (hz_to_incr w_sample_rate z_c f)++-- | Table lookup oscillator. /ip/ is in (0,1).+--+-- > let {a = a_tbl_sin (V_Id 0) 256+-- >     ;f = a_osc a 4.0 0.0+-- >     ;o = a_osc a (f * 200.0 + 400.0) 0.0}+-- > in audition [] (out1 (o * 0.1))+--+-- Cancellation:+--+-- > let {a = a_tbl_sin (V_Id 0) 256+-- >     ;o1 = a_osc a 440.0 0.0+-- >     ;o2 = a_osc a 440.0 0.5}+-- > in audition [] (out1 (o1 + o2))+a_osc :: DF (Vec Float) -> DF Float -> Float -> DF Float+a_osc a f ip =+    let z = fromMaybe 0 (df_tbl_size a)+        p = tbl_phasor z ip f+    in a_lerp a p++-- * Filter constructors.++-- | Single sample delay with indicated initial value.+--+-- > draw (unit_delay (0::Int32) 1)+-- > draw (unit_delay (0.0::Float) 1.0)+--+-- > let {c = counter 0.0 1.0+-- >     ;d = unit_delay 0.0 c}+-- > in audition_text 12 (out2 c d)+unit_delay :: K' a => a -> DF a -> DF a+unit_delay y0 s = rec_h y0 (\i -> (i,s))++-- | Two place infinite impulse response filter.  Inputs are: /f/=+-- function @(\x0 y1 y2 -> y0)@, /i/ = input signal.+--+-- > let {c1 = iir2 (\x y1 _ -> x + y1) 0.001+-- >     ;o1 = sin_osc (c1 + 220.0) 0+-- >     ;c2 = iir2 (\x _ y2 -> x + y2) 0.001+-- >     ;o2 = sin_osc (c2 + 220.0) 0}+-- > in audition [] (out2 (o1 * 0.1) (o2 * 0.1))+iir2 :: K_Num a => (Ternary_Op (DF a)) -> DF a -> DF a+iir2 f i =+    rec_h+    0+    (split . (\y1 -> let y2 = unit_delay 0 y1+                     in f i y1 y2))++-- | Single place finite impulse response filter.+fir1 :: K' a => a -> (DF a -> DF a -> DF b) -> DF a -> DF b+fir1 z0 f i = f i (unit_delay z0 i)++-- | Two place finite impulse response filter.+fir2 :: (Ternary_Op (DF Float)) -> DF Float -> DF Float+fir2 f i =+  let x1 = unit_delay 0.0 i+      x2 = unit_delay 0.0 x1+  in f i x1 x2++-- | Ordinary biquad filter section.+biquad :: (Quinary_Op (DF Float)) -> DF Float -> DF Float+biquad f i =+    rec_h+    0.0+    (split . (\y1 -> let x1 = unit_delay 0.0 i+                         x2 = unit_delay 0.0 x1+                         y2 = unit_delay 0.0 y1+                     in f i x1 x2 y1 y2))++-- * Counter++-- | Counter from indicated initial value.+--+-- > draw (counter (0::Int32) 1)+-- > draw (counter (0.0::Float) 1.0)+--+-- > audition_text 10 (out1 (counter 0.0 1.0))+counter :: K_Num a => a -> DF a -> DF a+counter y0 n = unit_delay y0 (iir1 y0 (+) n)++-- * Buffer++-- | Buffer delay.+--+-- > draw (buf_delay 0 0.0 0)+buf_delay :: DF Int32 -> DF Float-> DF Int32 -> DF Float+buf_delay b s n =+    let wi = phasor n 0 1+        ri = clipr n (wi + 1)+    in mrg (b_read b ri) (b_write b wi s)++-- | Non-interpolating comb filter.  Inputs are: /b/ = buffer index,+-- /i/ = input signal, /dl/ = delay time, /dc/ = decay time.+--+-- All times are in seconds.  The decay time is the time for the+-- echoes to decay by @60@ decibels. If this time is negative then the+-- feedback coefficient will be negative, thus emphasizing only odd+-- harmonics at an octave lower.+--+-- > draw (out1 (buf_comb_n 0 0.0 0.0 0.0))+--+-- Comb used as a resonator. The resonant fundamental is equal to+-- reciprocal of the delay time.+--+-- > import qualified Sound.SC3 as S+--+-- > let {n = white_noise 0+-- >     ;dt = let f x = lin_exp (x + 2.0) 1.0 2.0 0.0001 0.01+-- >           in f (lf_saw 0.1 0.0)+-- >     ;c = buf_comb_n 0 (n * 0.1) dt 0.2}+-- > in audition [S.b_alloc 0 48000 1] (out1 c)+--+-- Comb used as an echo.+--+-- > let {i = impulse 0.5 0.0+-- >     ;n = white_noise 0+-- >     ;e = decay (i * 0.5) 0.2+-- >     ;c = buf_comb_n 0 (e * n) 0.2 3.0}+-- > in audition [S.b_alloc 0 48000 1] (out1 c)+buf_comb_n :: DF Int32 -> DF Float -> DF Float -> DF Float -> DF Float+buf_comb_n b s dlt dct = do+  let n = df_lrintf (dlt * w_sample_rate)+      fb = calc_fb dlt dct+      c i = let x = buf_delay b i n+            in split (s + (fb * x))+  rec_h 0.0 c++-- * Comb++-- | Array variant of 'buf_comb_n'.  Max delay time is in seconds.+--+-- > let {n = white_noise 0+-- >     ;dt = let f x = lin_exp (x + 2.0) 1.0 2.0 0.0001 0.01+-- >           in f (lf_saw 0.1 0.0)+-- >     ;c = comb_n (V_Id 0) 0.1 (n * 0.1) dt 0.2}+-- > in audition [] (out1 c)+--+-- > let {i = impulse 0.5 0.0+-- >     ;n = white_noise 0+-- >     ;e = decay (i * 0.5) 0.2+-- >     ;c = comb_n (V_Id 0) 0.2 (e * n) 0.2 3.0}+-- > in audition [] (out1 c)+comb_n :: V_Id -> Float -> DF Float -> DF Float -> DF Float -> DF Float+comb_n k z s dlt dct =+  let a = a_alloc_sec k z+      n = df_lrintf (dlt * w_sample_rate)+      fb = calc_fb dlt dct+      c i = let x = a_delay a i n+            in split (s + (fb * x))+  in rec_h 0.0 c++-- * Noise++-- | 'Int32' linear congruential generator, hence signed modulo of+-- @2^32@.  Note that the state and all internal math is 32bit.+--+-- See <http://en.wikipedia.org/wiki/Linear_congruential_generator>+-- for possible parameters.+lcg_i32 :: Int32 -> Int32 -> Int32 -> DF Int32+lcg_i32 a c x0 =+    let tilde f g = rec_h x0 (\i -> let r = f i in (r,g r))+    in ((K c) +) `tilde` (* (K a))++-- | 'lcg_i32' 1103515245 12345, so in (minBound,maxBound).+lcg_glibc :: Int32 -> DF Int32+lcg_glibc = lcg_i32 1103515245 12345++-- | 'abs' of 'lcg_glibc, so in (0,maxBound).+randi :: Int32 -> DF Int32+randi = abs . lcg_glibc++-- | 'i32_to_normal_f32' of 'randi', so in (0,1).+--+-- > audition_text 24 (out1 (randf 0))+randf :: Int32 -> DF Float+randf = i32_to_normal_f32 . randi++-- | White noise (-1,1).  Generates noise whose spectrum has equal+-- power at all frequencies.+--+-- > audition_text 24 (out1 (white_noise 0))+--+-- > let n = white_noise 0 * 0.1+-- > in draw (out1 (n - n))+--+-- > let {n = white_noise 0 * 0.1+-- >     ;m = white_noise 5 * 0.1}+-- > in audition [] (out1 (n - m))+white_noise :: Int32 -> DF Float+white_noise = i32_to_normal_f32 . lcg_glibc++-- | 'iir1' brown noise function.+brown_noise_f :: Binary_Op (DF Float)+brown_noise_f x y1 =+    let z = x + y1+        r = select2 (z `df_lt` (-1.0)) ((-2.0) - z) z+    in select2 (z `df_gt` 1.0) (2.0 - z) r++-- | Brown noise (-1,1).  Generates noise whose spectrum falls off in+-- power by 6 dB per octave.+--+-- > let n = brown_noise 0+-- > in audition [] (out1 (n * 0.1))+--+-- > let {n = brown_noise 0+-- >     ;f = lin_exp n (-1.0) 1.0 64.0 9600.0+-- >     ;o = sin_osc f 0}+-- > in audition [] (out1 (o * 0.1))+brown_noise :: Int32 -> DF Float+brown_noise k =+    let w = white_noise k+        w8 = w / 8.0+    in iir1 0.0 brown_noise_f w8++-- * Osc++-- | Sine oscillator.  Inputs are: /f/ = frequency (in hz), /ip/ =+-- initial phase.+--+-- > let o = sin_osc 440.0 0.0+-- > in audition [] (out1 (o * 0.1))+--+-- Used as both Oscillator and LFO.+--+-- > let {f = sin_osc 4.0 0.0+-- >     ;o = sin_osc (f * 200.0 + 400.0) 0.0}+-- > in audition [] (out1 (o * 0.1))+--+-- Cancellation.+--+-- > let {o1 = sin_osc 440.0 0.0+-- >     ;o2 = sin_osc 440.0 pi}+-- > in audition [] (out1 (o1 + o2))+sin_osc :: DF Float -> Float -> DF Float+sin_osc f ip =+    let p = phasor two_pi ip (hz_to_incr w_sample_rate two_pi f)+    in sin p++-- | Impulse oscillator (non band limited).+-- Outputs non band limited single sample impulses.+-- Inputs are: /f/ = frequency (in hertz), /ip/ = phase offset (0..1)+--+-- > let o = impulse 800.0 0.0+-- > in audition [] (out1 (o * 0.1))+--+-- > let {f = sin_osc 0.25 0.0 * 2500.0 + 2505.0+-- >     ;o = impulse f 0.0}+-- > in audition [] (out1 (o * 0.1))+impulse :: DF Float -> Float -> DF Float+impulse f ip =+    let i = hz_to_incr w_sample_rate 1.0 f+        p = phasor 1.0 ip i+        x1 = unit_delay 0.0 p+        s = (x1 `df_lt` 0.5) `df_and` (p `df_gte` 0.5)+    in select2 s 1.0 0.0++-- * LF Osc.++-- | Non-band limited sawtooth oscillator.  Output ranges from -1 to +1.+-- Inputs are: /f/ = frequency (in hertz), /ip/ = initial phase (0,2).+--+-- > let o = lf_saw 500.0 1.0+-- > in audition [] (out1 (o * 0.1))+--+-- Used as both Oscillator and LFO.+--+-- > let {f = lf_saw 4.0 0.0+-- >     ;o = lf_saw (f * 400.0 + 400.0) 0.0}+-- > in audition [] (out1 (o * 0.1))+lf_saw :: DF Float -> Float -> DF Float+lf_saw f ip =+    let p = phasor 2.0 ip (hz_to_incr w_sample_rate 2.0 f)+    in p - 1.0++-- | Non-band-limited pulse oscillator. Outputs a high value of one+-- and a low value of zero. Inputs are: /f/ = frequency (in hertz),+-- /ip/ = initial phase (0,1), /w/ = pulse width duty cycle (0,1).+--+-- > let {o1 = lf_pulse 3.0 0.0 0.3 * 200.0 + 200.0+-- >     ;o2 = lf_pulse o1 0.0 0.2 * 0.1}+-- > in audition [] (out1 o2)+lf_pulse :: DF Float -> Float -> DF Float -> DF Float+lf_pulse f ip w =+    let p = phasor 1.0 ip (hz_to_incr w_sample_rate 1.0 f)+    in select2 (p `df_gte` w) 0.0 1.0++-- * Filters++-- | Two zero fixed midpass filter.+bpz2 :: DF Float -> DF Float+bpz2 = fir2 (\x _ x2 -> (x - x2) * 0.5)++-- | Two zero fixed midcut filter.+brz2 :: DF Float -> DF Float+brz2 = fir2 (\x _ x2 -> (x + x2) * 0.5)++-- | Two point average filter+lpz1 :: DF Float -> DF Float+lpz1 = fir1 0 (\x x1 -> (x + x1) * 0.5)++-- | Two zero fixed lowpass filter+lpz2 :: DF Float -> DF Float+lpz2 = fir2 (\x x1 x2 -> (x + (2.0 * x1) + x2) * 0.25)++-- | Given /cf/ construct 'iir1' one-pole function.+one_pole_f :: Fractional a => a -> Binary_Op a+one_pole_f cf x y1 = ((1.0 - abs cf) * x) + (cf * y1)++-- | One pole filter.+--+-- > let {n = white_noise 0+-- >     ;f = one_pole (n * 0.5) 0.95}+-- > in audition [] (out1 f)+one_pole :: DF Float -> DF Float -> DF Float+one_pole i cf = iir1 0.0 (one_pole_f cf) i++-- | Given /cf/ construct 'fir1' one-zero function.+one_zero_f :: Fractional a => a -> Binary_Op a+one_zero_f cf x x1 = ((1.0 - abs cf) * x) + (cf * x1)++-- | One zero filter.+--+-- > let {n = white_noise 0+-- >     ;f = one_zero (n * 0.5) 0.5}+-- > in audition [] (out1 f)+one_zero :: DF Float -> DF Float -> DF Float+one_zero i cf = fir1 0 (one_zero_f cf) i++-- | Given coefficients construct 'biquad' 'sos' function.+sos_f :: Num a => a -> a -> a -> a -> a -> Quinary_Op a+sos_f a0 a1 a2 b1 b2 x x1 x2 y1 y2 = a0*x + a1*x1 + a2*x2 + b1*y1 + b2*y2++-- | Second order filter section.+sos :: DF Float -> DF Float -> DF Float -> DF Float -> DF Float -> DF Float -> DF Float+sos i a0 a1 a2 b1 b2 = biquad (sos_f a0 a1 a2 b1 b2) i++-- | Given /f/ and /rq/ construct 'iir2' 'resonz' function.+resonz_f :: DF Float -> DF Float -> Ternary_Op (DF Float)+resonz_f f rq x y1 y2 =+    let ff = f * w_radians_per_sample+        b = ff * rq+        r = 1.0 - b * 0.5+        two_r = 2.0 * r+        r2 = r * r+        ct = (two_r * cos ff) / (1.0 + r2)+        b1 = two_r * ct+        b2 = negate r2+        a0 = (1.0 - r2) * 0.5+        y0 = x + b1 * y1 + b2 * y2+    in a0 * (y0 - y2)++-- | A two pole resonant filter with zeroes at z = +/- 1. Based on+-- K. Steiglitz, \"A Note on Constant-Gain Digital Resonators\",+-- /Computer Music Journal/, vol 18, no. 4, pp. 8-10, Winter 1994.+-- The reciprocal of Q is used rather than Q because it saves a divide+-- operation inside the unit generator.+--+-- Inputs are: /i/ = input signal, /f/ = resonant frequency (in+-- hertz), /rq/ = bandwidth ratio (reciprocal of Q);where /rq/ =+-- bandwidth / centerFreq.+--+-- > let {n = white_noise 0+-- >     ;r = resonz (n * 0.5) 440.0 0.1}+-- > in audition [] (out1 r)+--+-- Modulate frequency+--+-- > let {n = white_noise 0+-- >     ;f = lf_saw 0.1 0.0 * 3500.0 + 4500.0+-- >     ;r = resonz (n * 0.5) f 0.05}+-- > in audition [] (out1 r)+resonz :: DF Float -> DF Float -> DF Float -> DF Float+resonz i f rq = iir2 (resonz_f f rq) i++-- | Given /f/ and /r/ construct 'iir2' 'rlpf' function.+rlpf_f :: DF Float -> DF Float -> Ternary_Op (DF Float)+rlpf_f f r x y1 y2 =+    let qr = df_max (K 0.001) r+        pf = f * w_radians_per_sample+        d = tan (pf * qr * 0.5)+        c = (1.0 - d) / (1.0 + d)+        b1 = (1.0 + c) * cos pf+        b2 = negate c+        a0 = (1.0 + c - b1) * 0.25+    in a0 * x + b1 * y1 + b2 * y2++-- | Resonant low pass filter. Inputs are: /i/ = input signal, /f/ =+-- frequency (hertz), /rq/ = reciprocal of Q (resonance).+--+-- > let {n = white_noise 0+-- >     ;f = sin_osc 0.5 0.0  * 40.0 + 220.0+-- >     ;r = rlpf n f 0.1}+-- > in audition [] (out1 r)+rlpf :: DF Float -> DF Float -> DF Float -> DF Float+rlpf i f r = iir2 (rlpf_f f r) i++-- | 5-tuple+type T5 t = (t,t,t,t,t)++-- | 2nd order Butterworth high-pass filter coefficients.+--+-- > hpf_c 48000.0 (440.0 :: DF Float)+hpf_c :: Floating t => t -> t -> T5 t+hpf_c sr f =+    let c = tan ((pi * f) / sr)+        c2 = c ** 2.0+        s2 = sqrt 2.0+        a0 = (1.0 + (s2 * c) + c2) ** (-1.0)+        a1 = -2.0 * a0+        a2 = a0+        b1 = 2 * (c2 - 1.0) * a0+        b2 = (1.0 - (s2 * c) + c2) * a0+    in (a0,a1,a2,b1,b2)++-- | 'sos' of 'hpf_c'.+hpf :: DF Float -> DF Float -> DF Float+hpf i f =+    let sr = w_sample_rate+        (a0,a1,a2,b1,b2) = hpf_c sr f+    in sos i a0 a1 a2 b1 b2++-- * Triggers++-- | `df_gt` @0@.+positive :: K_Num a => DF a -> DF Bool+positive x = x `df_gt` 0++-- | 'df_not' of 'positive'.+non_positive :: K_Num a => DF a -> DF Bool+non_positive = df_not . positive++-- | 'fir1' /trigger/ function.+trigger_f :: K_Num a => DF a -> DF a -> DF Bool+trigger_f x x1 = positive x `df_and` non_positive x1++-- | True on non-positive to positive transition.+trigger :: K_Num a => DF a -> DF Bool+trigger = fir1 0 trigger_f++-- | Count 'True' values at input.+--+-- > let n = white_noise 0+-- > in audition_text 12 (out2 n (count_true (trigger n)))+count_true :: K_Num a => DF Bool -> DF a+count_true s = rec_h 0 (\y1 -> split (select2 s (y1 + 1) y1))++-- | Pulse divider at 'Bool'.+pulse_divider :: DF Bool -> DF Int32 -> DF Int32 -> DF Bool+pulse_divider tr n st =+    let c = count_true tr + st+    in tr `df_and` ((c `df_mod` n) `df_eq` 0)++-- | SC3 @PulseDivider@.+--+-- > let n = white_noise 0+-- > in audition_text 12 (out2 n (pulse_divider' n 2 1))+pulse_divider' :: K_Num a => DF a -> DF Int32 -> DF Int32 -> DF a+pulse_divider' tr n =+    let f x = select2 x 1 0+    in f . pulse_divider (trigger tr) n++-- | Sample and hold. Holds input signal value when triggered.  Inputs+-- are: /i/ = input signal, /t/ = trigger.+--+-- > let {n = white_noise 0+-- >     ;i = impulse 9.0 0.0+-- >     ;l = latch n (trigger i)+-- >     ;o = sin_osc (l * 400.0 + 500.0) 0.0}+-- > in audition [] (out1 (o * 0.2))+latch :: K_Num a => DF a -> DF Bool -> DF a+latch i t = iir1 0 (select2 t) i++-- * Decays++-- | Given /dt/ construct 'iir1' 'decay' function.+decay_f :: DF Float -> Binary_Op (DF Float)+decay_f dt x y1 =+    let b1 = exp (log 0.001 / (dt * w_sample_rate))+    in x + b1 * y1++-- | Exponential decay. Inputs are: /i/ = input signal, /t/ = decay+-- time.  This is essentially the same as Integrator except that+-- instead of supplying the coefficient directly, it is caculated from+-- a 60 dB decay time. This is the time required for the integrator to+-- lose 99.9 % of its value or -60dB. This is useful for exponential+-- decaying envelopes triggered by impulses.+--+-- Used as an envelope.+--+-- > let {n = brown_noise 0+-- >     ;f = lf_saw 0.1 0.0+-- >     ;i = impulse (lin_lin f (-1.0) 1.0 2.0 5.0) 0.25+-- >     ;e = decay i 0.2}+-- > in audition [] (out1 (e * n))+decay :: DF Float -> DF Float -> DF Float+decay i dt = iir1 0.0 (decay_f dt) i++-- | Exponential decay (equivalent to @decay dcy - decay atk@).+decay2 :: DF Float -> DF Float -> DF Float -> DF Float+decay2 i atk dcy = decay i dcy - decay i atk++-- * Delays++-- | Single sample delay.+delay1 :: K_Num a => DF a -> DF a+delay1 = iir1 0 (\_ y1 -> y1)++-- | Two sample delay.+delay2 :: K_Num a => DF a -> DF a+delay2 = iir2 (\_ _ y2 -> y2)++-- * Lags++-- | Given /t/ construct 'iir1' 'lag' function.+lag_f :: DF Float -> Binary_Op (DF Float)+lag_f t x y1 =+    let b1 = exp (log (0.001 / (t * w_sample_rate)))+    in x + b1 * (y1 - x)++-- | Simple averaging filter.  Inputs are: /i/ = input signal, /t/ =+-- lag time.+--+-- > let {s = sin_osc 0.05 0.0+-- >     ;f = lin_lin s (-1.0) 1.0 220.0 440.0+-- >     ;o = sin_osc f 0.0+-- >     ;f' = lag f 1.0+-- >     ;o' = sin_osc f' 0.0}+-- > in audition [] (out2 (o * 0.2) (o' * 0.2))+lag :: DF Float -> DF Float -> DF Float+lag i t = iir1 0 (lag_f t) i++-- | Nested lag filter.+lag2 :: DF Float -> DF Float -> DF Float+lag2 i t = lag (lag i t) t++-- | Twice nested lag filter.+lag3 :: DF Float -> DF Float -> DF Float+lag3 i t = lag (lag (lag i t) t) t

@@ -0,0 +1,467 @@+-- | Data flow node functions, or unit generators.+module Sound.DF.Uniform.GADT.UGen.Monadic where++import Control.Monad {- base -}+import Data.Int {- base -}+import Data.Maybe {- base -}++import Sound.DF.Uniform.GADT.DF+import Sound.DF.Uniform.GADT.UGen+import Sound.DF.Uniform.LL.UId+import Sound.DF.Uniform.LL.K++-- | Single place infinite impulse response filter with indicated+-- initial value.+--+-- > import Data.Int+-- > import Sound.DF.Uniform.GADT+-- > draw =<< iir1_m (0::Int32) (+) 1+-- > draw =<< iir1_m (0::Float) (+) 1+iir1_m :: (K' a,UId m) => a -> (Binary_Op (DF a)) -> DF a -> m (DF a)+iir1_m y0 f i = rec_m y0 (split . f i)++-- | /r/ = right hand edge, /ip/ = initial phase, /x/ = increment+--+-- > draw =<< phasor_m 9.0 (4.5::Float) 0.5+-- > drawM (phasor_m 9 (0::Int32) 1)+phasor_m :: (K_Num a,UId m) => DF a -> a -> DF a -> m (DF a)+phasor_m r ip = iir1_m ip (\x y1 -> clipr r (x + y1))++-- * Array++-- | Allocate /n/ second array, variant of 'df_vec'.+a_alloc_sec_m :: UId m => Float -> m (DF (Vec Float))+a_alloc_sec_m z =+    let z' = ceiling (z * k_sample_rate) + 1 + 1+    in df_vec_m (replicate z' 0)++-- | Array delay.+--+-- > do {a <- df_vec_m [0,1,2]+-- >    ;d <- a_delay a 0.0 0+-- >    ;draw (a_delay a 0.0 0)}+--+-- > do {f <- sin_osc 0.1 0.0+-- >    ;o <- sin_osc (f * 200.0 + 600.0) 0.0+-- >    ;a <- df_vec_m (replicate 48000 0)+-- >    ;d <- a_delay a o 24000+-- >    ;audition [] (out2 (o * 0.1) (d * 0.05))}+a_delay_m :: UId m => DF (Vec Float) -> DF Float -> DF Int32 -> m (DF Float)+a_delay_m a s n = do+  wi <- phasor_m n 0 1+  return (a_delay_ph a s n wi)++-- | Array fill function (sin).+a_tbl_sin_m :: UId m => Int -> m (DF (Vec Float))+a_tbl_sin_m = df_vec_m . tbl_sin++-- * Osc++-- | 'phasor' for table of /z/ places. /ip/ is in (0,1).+--+-- > drawM (phasor 64.0 (0.0::Float) (hz_to_incr k_sample_rate 64.0 330.0))+-- > drawM (tbl_phasor 64 0.0 330.0)+tbl_phasor_m :: UId m => Int -> Float -> DF Float -> m (DF Float)+tbl_phasor_m z ip f =+  let z_r = fromIntegral z+      z_c = K z_r+      ip_c = ip * z_r+  in phasor_m z_c ip_c (hz_to_incr w_sample_rate z_c f)++-- | Table lookup oscillator. /ip/ is in (0,1).+--+-- > do {a <- a_tbl_sin 256+-- >    ;f <- a_osc a 4.0 0.0+-- >    ;o <- a_osc a (f * 200.0 + 400.0) 0.0+-- >    ;audition [] (out1 (o * 0.1))}+--+-- Cancellation:+--+-- > do {a <- a_tbl_sin 256+-- >    ;o1 <- a_osc a 440.0 0.0+-- >    ;o2 <- a_osc a 440.0 0.5+-- >    ;audition [] (out1 (o1 + o2))}+a_osc_m :: UId m => DF (Vec Float) -> DF Float -> Float -> m (DF Float)+a_osc_m a f ip = do+  let z = fromMaybe 0 (df_tbl_size a)+  p <- tbl_phasor_m z ip f+  return (a_lerp a p)++-- * Filter constructors.++-- | Single sample delay with indicated initial value.+--+-- > drawM (unit_delay_m (0::Int32) 1)+-- > drawM (unit_delay_m (0.0::Float) 1.0)+--+-- > do {c <- counter_m 0 1.0+-- >    ;d <- unit_delay_m 0 c+-- >    ;audition_text 12 (out2 c d)}+unit_delay_m :: (K' a,UId m) => a -> DF a -> m (DF a)+unit_delay_m y0 s = rec_m y0 (\i -> (i,s))++-- | Two place infinite impulse response filter.  Inputs are: /f/=+-- function @(\x0 y1 y2 -> y0)@, /i/ = input signal.+--+-- > do {c1 <- iir2 (\x y1 _ -> x + y1) 0.001+-- >    ;o1 <- sin_osc (c1 + 220.0) 0+-- >    ;c2 <- iir2 (\x _ y2 -> x + y2) 0.001+-- >    ;o2 <- sin_osc (c2 + 220.0) 0+-- >    ;audition [] (out2 (o1 * 0.1) (o2 * 0.1))}+iir2_m :: (K_Num a,UId m) => (Ternary_Op (DF a)) -> DF a -> m (DF a)+iir2_m f i =+    rec_mM+    0+    (liftM split . (\y1 -> do+                      y2 <- unit_delay_m 0 y1+                      return (f i y1 y2)))++-- | Single place finite impulse response filter.+fir1_m :: UId m => (Binary_Op (DF Float)) -> DF Float -> m (DF Float)+fir1_m f i = do+  x1 <- unit_delay_m 0 i+  return (f i x1)++-- | Two place finite impulse response filter.+fir2_m :: UId m => (Ternary_Op (DF Float)) -> DF Float -> m (DF Float)+fir2_m f i = do+  x1 <- unit_delay_m 0.0 i+  x2 <- unit_delay_m 0.0 x1+  return (f i x1 x2)++-- | Ordinary biquad filter section.+biquad_m :: UId m => (Quinary_Op (DF Float)) -> DF Float -> m (DF Float)+biquad_m f i =+    rec_mM+    0.0+    (liftM split . (\y1 -> do+                      x1 <- unit_delay_m 0.0 i+                      x2 <- unit_delay_m 0.0 x1+                      y2 <- unit_delay_m 0.0 y1+                      return (f i x1 x2 y1 y2)))++-- * Counter++-- | Counter from indicated initial value.+--+-- > draw =<< counter (0::Int32) 1+-- > drawM (counter (0.0::Float) 1.0)+--+-- > audition_text 10 . out1 =<< counter_m 0.0 1.0+counter_m :: (K_Num a,UId m) => a -> DF a -> m (DF a)+counter_m y0 n = unit_delay_m y0 =<< iir1_m y0 (+) n++-- * Buffer++-- | Buffer delay.+--+-- > drawM (buf_delay 0 0.0 0)+buf_delay_m :: UId m => DF Int32 -> DF Float-> DF Int32 -> m (DF Float)+buf_delay_m b s n = do+  wi <- phasor_m n 0 1+  let ri = clipr n (wi + 1)+  return (mrg (b_read b ri) (b_write b wi s))++-- | Non-interpolating comb filter.  Inputs are: /b/ = buffer index,+-- /i/ = input signal, /dl/ = delay time, /dc/ = decay time.+--+-- All times are in seconds.  The decay time is the time for the+-- echoes to decay by @60@ decibels. If this time is negative then the+-- feedback coefficient will be negative, thus emphasizing only odd+-- harmonics at an octave lower.+--+-- > drawM (fmap out1 (buf_comb_n 0 0.0 0.0 0.0))+--+-- Comb used as a resonator. The resonant fundamental is equal to+-- reciprocal of the delay time.+--+-- > import qualified Sound.SC3 as S+--+-- > do {n <- white_noise_m+-- >    ;dt <- let f x = lin_exp (x + 2.0) 1.0 2.0 0.0001 0.01+-- >           in fmap f (lf_saw 0.1 0.0)+-- >    ;c <- buf_comb_n 0 (n * 0.1) dt 0.2+-- >    ;audition [S.b_alloc 0 48000 1] (out1 c)}+--+-- Comb used as an echo.+--+-- > do {i <- impulse 0.5 0.0+-- >    ;n <- white_noise_m+-- >    ;e <- decay (i * 0.5) 0.2+-- >    ;c <- buf_comb_n 0 (e * n) 0.2 3.0+-- >    ;audition [S.b_alloc 0 48000 1] (out1 c)}+buf_comb_n_m :: UId m => DF Int32 -> DF Float -> DF Float -> DF Float -> m (DF Float)+buf_comb_n_m b s dlt dct = do+  let n = df_lrintf (dlt * w_sample_rate)+      fb = calc_fb dlt dct+      c i = do x <- buf_delay_m b i n+               return (split (s + (fb * x)))+  rec_mM 0.0 c++-- * Comb++-- | Array variant of 'buf_comb_n'.  Max delay time is in seconds.+--+-- > do {n <- white_noise_m+-- >    ;dt <- let f x = lin_exp (x + 2.0) 1.0 2.0 0.0001 0.01+-- >           in fmap f (lf_saw 0.1 0.0)+-- >    ;c <- comb_n 0.1 (n * 0.1) dt 0.2+-- >    ;audition [] (out1 c)}+--+-- > do {i <- impulse 0.5 0.0+-- >    ;n <- white_noise_m+-- >    ;e <- decay (i * 0.5) 0.2+-- >    ;c <- comb_n 0.2 (e * n) 0.2 3.0+-- >    ;audition [] (out1 c)}+comb_n_m :: UId m => Float -> DF Float -> DF Float -> DF Float -> m (DF Float)+comb_n_m z s dlt dct = do+  a <- a_alloc_sec_m z+  let n = df_lrintf (dlt * w_sample_rate)+      fb = calc_fb dlt dct+      c i = do x <- a_delay_m a i n+               return (split (s + (fb * x)))+  rec_mM 0.0 c++-- * Noise++-- | White noise (-1,1).  Generates noise whose spectrum has equal+-- power at all frequencies.+--+-- > do {n <- white_noise_m+-- >    ;audition [] (out1 (n * 0.1))}+white_noise_m :: UId m => m (DF Float)+white_noise_m = do+  i <- generateId+  return (white_noise (fromIntegral i))++-- | Brown noise (-1,1).  Generates noise whose spectrum falls off in+-- power by 6 dB per octave.+--+-- > do {n <- brown_noise_m+-- >    ;audition [] (out1 (n * 0.1))}+--+-- > do {n <- brown_noise_m+-- >    ;let f = lin_exp n (-1.0) 1.0 64.0 9600.0+-- >     in do {o <- sin_osc f 0+-- >           ;audition [] (out1 (o * 0.1))}}+brown_noise_m :: UId m => m (DF Float)+brown_noise_m = do+  w <- white_noise_m+  let w8 = w / 8.0+  iir1_m 0.0 brown_noise_f w8++-- * Osc++-- | Sine oscillator.  Inputs are: /f/ = frequency (in hz), /ip/ =+-- initial phase.+--+-- > do {o <- sin_osc 440.0 0.0+-- >    ;audition [] (out1 (o * 0.1))}+--+-- Used as both Oscillator and LFO.+--+-- > do {f <- sin_osc 4.0 0.0+-- >    ;o <- sin_osc (f * 200.0 + 400.0) 0.0+-- >    ;audition [] (out1 (o * 0.1))}+--+-- Cancellation.+--+-- > do {o1 <- sin_osc 440.0 0.0+-- >    ;o2 <- sin_osc 440.0 pi+-- >    ;audition [] (out1 (o1 + o2))}+sin_osc_m :: UId m => DF Float -> Float -> m (DF Float)+sin_osc_m f ip = do+  p <- phasor_m two_pi ip (hz_to_incr w_sample_rate two_pi f)+  return (sin p)++-- | Impulse oscillator (non band limited).+-- Outputs non band limited single sample impulses.+-- Inputs are: /f/ = frequency (in hertz), /ip/ = phase offset (0..1)+--+-- > do {o <- impulse 800.0 0.0+-- >    ;audition [] (out1 (o * 0.1))}+--+-- > do {f <- fmap (\x -> x * 2500.0 + 2505.0) (sin_osc 0.25 0.0)+-- >    ;o <- impulse f 0.0+-- >    ;audition [] (out1 (o * 0.1))}+impulse_m :: UId m => DF Float -> Float -> m (DF Float)+impulse_m f ip = do+  let i = hz_to_incr w_sample_rate 1.0 f+  p <- phasor_m 1.0 ip i+  x1 <- unit_delay_m 0.0 p+  let s = (x1 `df_lt` 0.5) `df_and` (p `df_gte` 0.5)+  return (select2 s 1.0 0.0)++-- * LF Osc.++-- | Non-band limited sawtooth oscillator.  Output ranges from -1 to +1.+-- Inputs are: /f/ = frequency (in hertz), /ip/ = initial phase (0,2).+--+-- > do {o <- lf_saw 500.0 1.0+-- >    ;audition [] (out1 (o * 0.1))}+--+-- Used as both Oscillator and LFO.+--+-- > do {f <- lf_saw 4.0 0.0+-- >    ;o <- lf_saw (f * 400.0 + 400.0) 0.0+-- >    ;audition [] (out1 (o * 0.1))}+lf_saw_m :: UId m => DF Float -> Float -> m (DF Float)+lf_saw_m f ip = do+  p <- phasor_m 2.0 ip (hz_to_incr w_sample_rate 2.0 f)+  return (p - 1.0)++-- | Non-band-limited pulse oscillator. Outputs a high value of one+-- and a low value of zero. Inputs are: /f/ = frequency (in hertz),+-- /ip/ = initial phase (0,1), /w/ = pulse width duty cycle (0,1).+--+-- > do {o1 <- fmap (\x -> x * 200.0 + 200.0) (lf_pulse 3.0 0.0 0.3)+-- >    ;o2 <- fmap (\x -> x * 0.1) (lf_pulse o1 0.0 0.2)+-- >    ;audition [] (out1 o2)}+lf_pulse_m :: UId m => DF Float -> Float -> DF Float -> m (DF Float)+lf_pulse_m f ip w = do+  p <- phasor_m 1.0 ip (hz_to_incr w_sample_rate 1.0 f)+  return (select2 (p `df_gte` w) 0.0 1.0)++-- * Filters++-- | Two zero fixed midpass filter.+bpz2_m :: UId m => DF Float -> m (DF Float)+bpz2_m = fir2_m (\x _ x2 -> (x - x2) * 0.5)++-- | Two zero fixed midcut filter.+brz2_m :: UId m => DF Float -> m (DF Float)+brz2_m = fir2_m (\x _ x2 -> (x + x2) * 0.5)++-- | Two point average filter+lpz1_m :: UId m => DF Float -> m (DF Float)+lpz1_m = fir1_m (\x x1 -> (x + x1) * 0.5)++-- | Two zero fixed lowpass filter+lpz2_m :: UId m => DF Float -> m (DF Float)+lpz2_m = fir2_m (\x x1 x2 -> (x + (2.0 * x1) + x2) * 0.25)++-- | One pole filter.+--+-- > do {n <- white_noise_m+-- >    ;f <- one_pole (n * 0.5) 0.95+-- >    ;audition [] (out1 f)}+one_pole_m :: UId m => DF Float -> DF Float -> m (DF Float)+one_pole_m i cf = iir1_m 0.0 (one_pole_f cf) i++-- | One zero filter.+--+-- > do {n <- white_noise_m+-- >    ;f <- one_zero (n * 0.5) 0.5+-- >    ;audition [] (out1 f)}+one_zero_m :: UId m => DF Float -> DF Float -> m (DF Float)+one_zero_m i cf = fir1_m (\x x1 -> ((1.0 - abs cf) * x) + (cf * x1)) i++-- | Second order filter section.+sos_m :: UId m => DF Float -> DF Float -> DF Float -> DF Float -> DF Float -> DF Float -> m (DF Float)+sos_m i a0 a1 a2 b1 b2 = biquad_m (sos_f a0 a1 a2 b1 b2) i++-- | A two pole resonant filter with zeroes at z = +/- 1. Based on+-- K. Steiglitz, \"A Note on Constant-Gain Digital Resonators\",+-- /Computer Music Journal/, vol 18, no. 4, pp. 8-10, Winter 1994.+-- The reciprocal of Q is used rather than Q because it saves a divide+-- operation inside the unit generator.+--+-- Inputs are: /i/ = input signal, /f/ = resonant frequency (in+-- hertz), /rq/ = bandwidth ratio (reciprocal of Q);where /rq/ =+-- bandwidth / centerFreq.+--+-- > do {n <- white_noise_m+-- >    ;r <- resonz (n * 0.5) 440.0 0.1+-- >    ;audition [] (out1 r)}+--+-- Modulate frequency+--+-- > do {n <- white_noise_m+-- >    ;f <- fmap (\x -> x * 3500.0 + 4500.0) (lf_saw 0.1 0.0)+-- >    ;r <- resonz (n * 0.5) f 0.05+-- >    ;audition [] (out1 r)}+resonz_m :: UId m => DF Float -> DF Float -> DF Float -> m (DF Float)+resonz_m i f rq = iir2_m (resonz_f f rq) i++-- | Resonant low pass filter. Inputs are: /i/ = input signal, /f/ =+-- frequency (hertz), /rq/ = reciprocal of Q (resonance).+--+-- > do {n <- white_noise_m+-- >    ;f <- fmap (\x -> x * 40.0 + 220.0) (sin_osc 0.5 0.0)+-- >    ;r <- rlpf n f 0.1+-- >    ;audition [] (out1 r)}+rlpf_m :: UId m => DF Float -> DF Float -> DF Float -> m (DF Float)+rlpf_m i f r = iir2_m (rlpf_f f r) i++-- * Triggers++-- | Sample and hold. Holds input signal value when triggered.  Inputs+-- are: /i/ = input signal, /t/ = trigger.+--+-- > do {n <- white_noise_m+-- >    ;i <- impulse_m 9.0 0.0+-- >    ;l <- latch_m n (trigger i)+-- >    ;o <- sin_osc (l * 400.0 + 500.0) 0.0+-- >    ;audition [] (out1 (o * 0.2))}+latch_m :: (K_Num a,UId m) => DF a -> DF Bool -> m (DF a)+latch_m i t = iir1_m 0 (select2 t) i++-- * Decays++-- | Exponential decay. Inputs are: /i/ = input signal, /t/ = decay+-- time.  This is essentially the same as Integrator except that+-- instead of supplying the coefficient directly, it is caculated from+-- a 60 dB decay time. This is the time required for the integrator to+-- lose 99.9 % of its value or -60dB. This is useful for exponential+-- decaying envelopes triggered by impulses.+--+-- Used as an envelope.+--+-- > do {n <- brown_noise_m+-- >    ;f <- lf_saw 0.1 0.0+-- >    ;i <- impulse (lin_lin f (-1.0) 1.0 2.0 5.0) 0.25+-- >    ;e <- decay i 0.2+-- >    ;audition [] (out1 (e * n))}+decay_m :: UId m => DF Float -> DF Float -> m (DF Float)+decay_m i dt = iir1_m 0.0 (decay_f dt) i++-- | Exponential decay (equivalent to @decay dcy - decay atk@).+decay2_m :: UId m => DF Float -> DF Float -> DF Float -> m (DF Float)+decay2_m i atk dcy = liftM2 (-) (decay_m i dcy) (decay_m i atk)++-- * Delays++-- | Single sample delay.+delay1_m :: (K_Num a,UId m) => DF a -> m (DF a)+delay1_m = iir1_m 0 (\_ y1 -> y1)++-- | Two sample delay.+delay2_m :: (K_Num a,UId m) => DF a -> m (DF a)+delay2_m = iir2_m (\_ _ y2 -> y2)++-- * Lags++-- | Simple averaging filter.  Inputs are: /i/ = input signal, /t/ =+-- lag time.+--+-- > do {s <- sin_osc 0.05 0.0+-- >    ;let f = lin_lin s (-1.0) 1.0 220.0 440.0+-- >     in do {o <- sin_osc f 0.0+-- >           ;f' <- lag f 1.0+-- >           ;o' <- sin_osc f' 0.0+-- >           ;audition [] (out2 (o * 0.2) (o' * 0.2))}}+lag_m :: UId m => DF Float -> DF Float -> m (DF Float)+lag_m i t = iir1_m 0 (lag_f t) i++-- | Nested lag filter.+lag2_m :: UId m => DF Float -> DF Float -> m (DF Float)+lag2_m i t = do+  a <- lag_m i t+  lag_m a t++-- | Twice nested lag filter.+lag3_m :: UId m => DF Float -> DF Float -> m (DF Float)+lag3_m i t = do+  a <- lag_m i t+  b <- lag_m a t+  lag_m b t

@@ -0,0 +1,15 @@+-- | Composite of all low-level modules.+module Sound.DF.Uniform.LL+    (module Sound.DF.Uniform.LL.Audition+    ,module Sound.DF.Uniform.LL.CGen+    ,module Sound.DF.Uniform.LL.Command+    ,module Sound.DF.Uniform.LL.Dot+    ,module Sound.DF.Uniform.LL.K+    ,module Sound.DF.Uniform.LL.UId) where++import Sound.DF.Uniform.LL.Audition+import Sound.DF.Uniform.LL.CGen+import Sound.DF.Uniform.LL.Command+import Sound.DF.Uniform.LL.Dot+import Sound.DF.Uniform.LL.K+import Sound.DF.Uniform.LL.UId

@@ -0,0 +1,58 @@+-- | Interaction with @jack-dl@, @scsynth@ and @text-dl@.+module Sound.DF.Uniform.LL.Audition where++import Sound.OSC {- hosc -}+import qualified Sound.SC3 as S {- hsc3 -}+import Sound.SC3.UGen.External.RDU {- sc3-rdu -}+import System.Directory {- directory -}+import System.FilePath {- filepath -}+import System.Process {- process -}++import Sound.DF.Uniform.LL.CGen+import Sound.DF.Uniform.LL.Command+import Sound.DF.Uniform.LL.UId++-- * jack-dl++-- | Run action with @UDP@ link to @jack-dl@.+with_jack_dl :: Connection UDP a -> IO a+with_jack_dl = withTransport (openUDP "127.0.0.1" 57190)++-- | Audition graph after sending initialisation messages.+audition :: [Message] -> Instructions -> IO ()+audition is ins = do+  t <- getTemporaryDirectory+  k <- generateId+  let fn = t </> ("audition" ++ show k)+  dl_gen fn (JACK,"/home/rohan/opt") ins+  with_jack_dl (mapM sendMessage is >>+                sendMessage (g_load (fn <.> "so")))++-- * scsynth++-- | Load graph.+u_cmd_g_load :: Int -> Int -> String -> Message+u_cmd_g_load nid uid s = S.u_cmd nid uid "/g_load" [string s]++-- | Audition graph after sending initialisation messages.+audition_sc3 :: [Message] -> Instructions -> IO ()+audition_sc3 is ins = do+  t <- getTemporaryDirectory+  k <- generateId+  let fn = t </> ("audition" ++ show k)+  dl_gen fn (SC3,"/home/rohan/opt") ins+  S.withSC3 (mapM sendMessage is >>+             S.play (S.out 0 (rdl 2 0)) >>+             sendMessage (u_cmd_g_load (-1) 0 (fn <.> "so")))++-- * text-dl++-- | Audition at @text-dl@.+audition_text :: Int -> Instructions -> IO ()+audition_text nf ins = do+  t <- getTemporaryDirectory+  k <- generateId+  let fn = t </> ("audition" ++ show k)+  dl_gen fn (Text,"/home/rohan/opt") ins+  _ <- rawSystem "text-dl" ["-f",show nf,fn <.> "so"]+  return ()

@@ -0,0 +1,356 @@+{-# Language GADTs #-}+-- | C code generator+module Sound.DF.Uniform.LL.CGen where++import Data.List {- base -}+import Data.Maybe {- base -}+import Data.Typeable {- base -}+import System.Cmd {- process -}+import System.FilePath {- filepath -}++import Sound.DF.Uniform.LL.K+import Sound.DF.Uniform.LL.UId++-- * C init / call++-- | C comment.+type C_Comment = String++-- | Add comment markers.+--+-- > c_comment "c" == "/* c */"+c_comment :: String -> C_Comment+c_comment c = concat ["/* ",c," */"]++-- | C type.+type C_Type = String++-- | Translate 'TypeRep' to 'C_Type'.+--+-- > c_typerep_ctype bool_t == "bool"+-- > c_typerep_ctype (typeOf (0.0::Float)) == "float"+c_typerep_ctype :: TypeRep -> C_Type+c_typerep_ctype t =+    let tbl = [(bool_t,"bool")+              ,(int32_t,"int32_t")+              ,(float_t,"float")]+    in fromMaybe (error (show ("c_typerep_ctype",t))) (lookup t tbl)++-- | Qualified name, (structure,access,member).+type C_QName = (String,String,String)++-- | Initialise 'C_QName' to value.+--+-- > c_init_atom ("s",".","r") 5 == "s.m = 5;"+c_init_atom :: Show a => C_QName -> a -> String+c_init_atom (s,a,p) q = concat [s,a,p," = ",show q,";"]++-- | Initialise 'C_QName' to array.  Generates loop code for sequences+-- of equal initial values.+--+-- > c_init_vec ("s",".","r") [0,1] == ["s.r[0] = 0;"+-- >                                   ,"s.r[1] = 1;"]+--+-- > let r = ["for(int i=0;i < 2;i++) {s.r[i] = 0;}"]+-- > in c_init_vec ("s",".","r") [0,0] == r+c_init_vec :: (Eq a,Show a) => C_QName -> [a] -> [String]+c_init_vec (s,a,n) l =+    let init_arr_1 p q r = concat [s,a,p,"[",q,"] = ",show r,";"]+        init_arr p q r = ["for(int i=",show q+                         ,";i < ",show (q + length r)+                         ,";i++) {"+                         ,init_arr_1 p "i" (head r)+                         ,"}"]+        f (k,i) = case i of+                    [i'] -> init_arr_1 n (show k) i'+                    _ -> concat (init_arr n k i)+        l' = group l+    in map f (zip (dx_d (map length l')) l')++-- | Initialise 'C_QName' to value or array.+--+-- > let {qn = ("s","->","r")+-- >     ;r = ["for(int i=0;i < 2;i++) {s->r[i] = 0;}","s->r[2] = 1;"]}+-- > in c_init_var qn (Right [0,0,1]) == r+c_init_var :: (Eq n,Show n) => C_QName -> Either n [n] -> [String]+c_init_var qn e =+    case e of+      Left i -> [c_init_atom qn i]+      Right [] -> error "c_init_var: Right []"+      Right l -> c_init_vec qn l++-- | Qualify name if required.  The /rf/ flag indicates if array is a+-- reference or an allocation.+--+-- > c_array_qual (Vec_Port float_t 3) "a" True == "*a"+-- > c_array_qual (Vec_Port float_t 3) "a" False == "a[3]"+c_array_qual :: Maybe Int -> String -> Bool -> String+c_array_qual vc nm rf =+    case vc of+      Nothing -> nm+      Just n -> if rf+                then '*' : nm+                else nm ++ bracket ('[',']') (show n)++-- | C function call.  (comment?,function,arguments)+type C_Call = (Maybe String,String,[(Var_Ty,Id)])++-- | Construct a function/macro call.+--+-- > c_call (Nothing,"f",["0","1"]) == "f(0,1);"+-- > c_call ("c","f",["0","1"]) == "f(0,1); /* c */"+c_call :: C_Call -> String+c_call (tr,s,as) =+    let as' = map m_clabel as+        c = concat ([s,"("] ++ intersperse "," as' ++ [");"])+    in concat [c," ",maybe "" c_comment tr]++-- * Variables++-- | Enumeration of variable types.+data Var_Ty = Rec_Var | Std_Var | Buf_Var Int+              deriving (Eq,Show)++-- | The character prefix for a 'Var' name is given by the 'Var_Ty'.+var_ty_char :: Var_Ty -> Char+var_ty_char ty =+    case ty of+      Rec_Var -> 'r'+      Std_Var -> 'n'+      Buf_Var _ -> 'n'++-- | (Type,Array,Label,Initialised)+type Var = (Var_Ty,TypeRep,Id,Maybe (Either Float [Float]))++-- | 'Var' name.+var_nm :: Var -> String+var_nm (vc,_,k,_) = clabel (vc,k)++-- | Non-'Std_Var' are stateful, ie. 'Rec_Var' and 'Buf_Var'.+is_stateful :: Var -> Bool+is_stateful (vt,_,_,_) = vt /= Std_Var++-- | 'Rec_Var' are stateful and /atom/s.+is_stateful_atom :: Var -> Bool+is_stateful_atom (vt,_,_,_) = vt == Rec_Var++-- | Generate 'Var' from 'K'.+k_var :: Id -> Var_Ty -> K -> Var+k_var k vt n =+    case n of+      N _ -> error "k_var: ()"+      B _ -> error "k_var: bool"+      I i -> (vt,int32_t,k,Just (Left (fromIntegral i)))+      F i -> (vt,float_t,k,Just (Left i))+      V _ -> error "k_var: vec"++-- | Generate 'Buf_Var' from 'Vec'.+buffer_var :: Id -> Vec Float -> Var+buffer_var k (Vec _ n l) = (Buf_Var n,float_t,k,Just (Right l))++-- | 'c_init_var' of 'Var'.+var_init :: String -> String -> Var -> [String]+var_init s a (vt,_,k,i) =+    case i of+      Nothing -> error (show ("var_init",s,a,vt,k))+      Just i' -> c_init_var (s,a,clabel (vt,k)) i'++-- | 'Var' C declaration, /rf/ determines 'c_array_qual' form.+var_decl :: Bool -> Var -> String+var_decl rf (vt,ty,k,_) =+    let vc = case vt of+               Buf_Var n -> Just n+               _ -> Nothing+        nm = clabel (vt,k)+    in c_typerep_ctype ty ++ " " ++ c_array_qual vc nm rf ++ ";"++-- | Generate a C @struct@ for 'Var', predicate determines if array+-- variables are refernces or allocations.+gen_var_struct :: String -> (Var -> Bool) -> [Var] -> [String]+gen_var_struct nm f vs =+    let dc = zipWith var_decl (map f vs) vs+    in c_comment nm :+       bracket ("struct " ++ nm ++ " {","};") dc++-- | Construct an identifier.+--+-- > clabel (Std_Var,0) == "n_0"+clabel :: (Var_Ty,Id) -> String+clabel (ty,k) = var_ty_char ty : '_' : show k++-- | 'clabel' of 'Std_Var'.+--+-- > std_clabel 0 == "n_0"+std_clabel :: Id -> String+std_clabel k = clabel (Std_Var,k)++-- | Variant with @m.@ prefix.+m_clabel :: (Var_Ty,Id) -> String+m_clabel = ("m." ++) . clabel++-- | 'c_init_var' for constant.+--+-- > c_const (0,I 1) == ["m.n_0 = 1;"]+c_const :: (Id,K) -> [String]+c_const (k,v) =+    case v of+      B x -> c_init_var ("m",".",std_clabel k) (Left x)+      F x -> c_init_var ("m",".",std_clabel k) (Left x)+      I x -> c_init_var ("m",".",std_clabel k) (Left x)+      _ -> error "c_const: k"++-- * Code generators++-- | C declarations for DSP functions (memreq,init and step).+dsp_fun_decl :: [String]+dsp_fun_decl =+    ["size_t dsp_memreq();"+    ,"void dsp_init(void *p);"+    ,"void dsp_step(df_world *w,int w_nf);"]++-- | The structure for all memory stores.  In the uniform model this+-- is a notational convenience only.  In a partioned model it is+-- functional.+cmem :: [Var] -> [String]+cmem = gen_var_struct "df_mem" is_stateful++-- | The structure for stateful 'Var'.+cstate :: [Var] -> [String]+cstate = gen_var_struct "df_state" (const False) . filter is_stateful++-- | Generate dsp_memreq function.+dsp_memreq :: [String]+dsp_memreq =+    ["size_t dsp_memreq()"+    ,"{"+    ,"return (sizeof(struct df_state));"+    ,"}"]++-- | Generate dsp_init function.+dsp_init :: [Var] -> [String]+dsp_init vs =+    let a = ["void dsp_init(void *p)"+            ,"{"]+        b = ["return;"+            ,"}"]+        c = case filter is_stateful vs of+              [] -> []+              vs' -> "struct df_state *s = (struct df_state *)p;" :+                     concatMap (var_init "s" "->") vs'+    in a ++ c ++ b++-- | List of constants, list of variables, list of c-calls.+type Instructions = ([(Id,K)],[Var],[C_Call])++-- | Generate @dsp_step@ function.+dsp_step :: Instructions -> [String]+dsp_step (ks,vs,cc) =+    let f v = let nm = var_nm v in "m." ++ nm ++ " = s->" ++ nm ++ ";"+        g v = let nm = var_nm v in "s->" ++ nm ++ " = m." ++ nm ++ ";"+    in concat [["void dsp_step(df_world *w,int w_nf)"+               ,"{"+               ,"struct df_mem m;"]+              ,let v = filter is_stateful vs+               in if null v+                  then []+                  else ["struct df_state *s = (struct df_state*)w_state(w);"+                       ,"/* load state */"] +++                        map f v+              ,["/* constants */"]+              ,concatMap c_const ks+              ,["/* algorithm */"+               ,"/* k-rate (fc == 0) */"+               ,"/* a-rate (fc == 1..) */"+               ,"for(int fc = 0; fc < w_nf; fc++) {"]+              ,map c_call cc+              ,["}"+               ,"/* store state */"]+              ,map g (filter is_stateful_atom vs)+              ,["}"]]++-- | Generate C code for graph.+code_gen :: Host -> Instructions -> String+code_gen h (ks,vs,cc) =+    let hd = ["#include <stdio.h>"+             ,"#include <stdint.h>"+             ,"#include <stdlib.h>"+             ,"#include <stdbool.h>"+             ,"#include <math.h>"+             ,host_include h+             ,"#include \"/home/rohan/sw/hdf/c/hdf.h\""]+        c = [hd+            ,host_dsp_fun_decl h+            ,cstate vs+            ,cmem vs+            ,dsp_memreq+            ,dsp_init vs+            ,dsp_step (ks,vs,cc)]+    in (unlines . concat) c++-- * Host++-- | Enumeration of code hosts.+data Host = JACK | SC3 | Text++-- | Host specific @#include@ file.+host_include :: Host -> String+host_include h =+    case h of+      JACK -> "#include \"/home/rohan/sw/rju/jack-dl.h\""+      SC3 -> "#include \"/home/rohan/sw/sc3-rdu/cpp/RDL.h\""+      Text -> "#include \"/home/rohan/sw/hdf/c/text-dl.h\""++-- | Host specific form of 'dsp_fun_decl' (@extern C@ where required).+host_dsp_fun_decl :: Host -> [String]+host_dsp_fun_decl h =+    case h of+      SC3 -> bracket ("extern \"C\" {","}") dsp_fun_decl+      _ -> dsp_fun_decl++-- | Generate compiler command for 'Host' given @include@ directory+-- prefix.+--+-- > host_compiler_cmd (JACK,"/home/rohan/opt")+-- > host_compiler_cmd (SC3,"/home/rohan/opt")+-- > host_compiler_cmd (Text,"/home/rohan/opt")+host_compiler_cmd :: (Host,FilePath) -> (String,[String])+host_compiler_cmd (h,d) =+    case h of+      SC3 ->+           ("g++"+           ,["-Wall","-g","-O2","-shared"+            ,"-I",d </> "include/SuperCollider/plugin_interface"+            ,"-I",d </> "include/SuperCollider/common"])+      _ ->+          ("gcc"+          ,["-Wall","-g","--std=c99","-O2","-shared"+           ,"-I",d </> "include"])++-- * IO++-- | Generate C code, write file to disk and call the GNU C compiler+--   to build shared library.+dl_gen :: FilePath -> (Host,FilePath) -> Instructions -> IO ()+dl_gen fn (h,d) i = do+  let c = fn <.> "c"+      so = fn <.> "so"+      (cmd,opt) = host_compiler_cmd (h,d)+      opt' = opt ++ [c,"-o",so]+  writeFile c (code_gen h i)+  _ <- rawSystem cmd opt'+  return ()++-- * List++-- | Bracket list with elements.+--+-- > bracket ('<','>') "float" == "<float>"+bracket :: (a,a) -> [a] -> [a]+bracket (i,j) k = i : k ++ [j]++-- | Integrate, with implicit @0@.+--+-- > dx_d [5,6] == [0,5,11]+dx_d :: Num n => [n] -> [n]+dx_d = (0 :) . scanl1 (+)+

@@ -0,0 +1,12 @@+-- | OSC graph commands.+module Sound.DF.Uniform.LL.Command where++import Sound.OSC {- hosc -}++-- | Load graph.+g_load :: String -> Message+g_load s = Message "/g_load" [string s]++-- | Unload graph.+g_unload :: Message+g_unload = Message "/g_unload" []

@@ -0,0 +1,71 @@+-- | Elementary dot.+module Sound.DF.Uniform.LL.Dot where++import Data.List {- base -}+import Data.Maybe {- base -}+import Data.Typeable {- base -}+import Text.Printf {- base -}++import Sound.DF.Uniform.LL.K+import Sound.DF.Uniform.LL.UId++-- | Map from 'TypeRep' to colour name.+--+-- > map (ty_colour . Just) [int32_t,float_t] == ["orange","blue"]+ty_colour :: Maybe TypeRep -> String+ty_colour m =+    let tbl = [(bool_t,"brown")+              ,(int32_t,"orange")+              ,(float_t,"blue")+              ,(nil_t,"black")+              ,(vec_float_t,"purple")]+    in case m of+         Nothing -> "grey"+         Just ty -> fromMaybe "red" (lookup ty tbl)++-- | Left & right bracket.+--+-- > w_bracket '(' ')' "parentheses" == "(parentheses)"+w_bracket :: a -> a -> [a] -> [a]+w_bracket p q l = p : l ++ [q]++-- | Dot notation for /key,value/ attributes.+dot_attr :: [(String,String)] -> String+dot_attr a =+    let in_quotes = w_bracket '"' '"'+        in_square = w_bracket '[' ']'+        sep_commas = intercalate ","+        join_eq p q = p ++ "=" ++ q+        (k,v) = unzip a+    in in_square (sep_commas (zipWith join_eq k (map in_quotes v)))++-- | Dot node as /record/.  Constant values are drawn directly into+-- input ports.  The /nm/ 'String' has the @df_@ prefix removed for+-- printing.+--+-- > dot_rec 0 "nm" [] (Just float_t)+dot_rec :: Id -> String -> [Either Int K] -> Maybe TypeRep -> String+dot_rec k nm ar ty =+    let mk_i i = case i of+                   Left i_k -> printf "<i_%d>" i_k+                   Right i_k -> k_concise i_k+        ip = if null ar+             then ""+             else '|' : intercalate "|" (map mk_i ar)+        op = maybe "" (const "|<o_0>") ty+        nm' = fromMaybe nm (stripPrefix "df_" nm)+        c = ty_colour ty+        a = [("shape","record")+            ,("color",c)+            ,("label",printf "{{%s%s%s}}" nm' ip op)]+    in printf "%d %s;" k (dot_attr a)++-- | Make arguments input for 'dot_rec' from arity.+dot_rec_ar :: Int -> [Either Int K]+dot_rec_ar n = map Left [0 .. n - 1]++-- | Variant where 'nil_t' indicates no output.+dot_rec' :: Id -> String -> [Either Int K] -> TypeRep -> String+dot_rec' k nm n ty =+    let ty' = if ty == nil_t then Nothing else Just ty+    in dot_rec k nm n ty'

@@ -0,0 +1,107 @@+{-# Language DeriveDataTypeable,FlexibleInstances #-}+-- | Data flow wire values.+module Sound.DF.Uniform.LL.K where++import Data.Int {- base -}+import Data.Typeable {- base -}++import Sound.DF.Uniform.LL.UId++-- * Vector++-- | Vector identifier.+data V_Id = V_Id Id deriving (Eq,Ord,Show)++-- | Vector type.+data Vec a = Vec V_Id Int [a] deriving (Typeable,Eq,Ord,Show)++-- | 'Id' of 'V_Id' of 'Vec'.+vec_id :: Vec t -> Id+vec_id (Vec (V_Id k) _ _) = k++-- | Concise pretty printer and 'Show' instance for 'Vec'.+--+-- > vec_concise (Vec (V_Id 0) 1 [0]) == "vec(0,1)"+vec_concise :: Vec a -> String+vec_concise (Vec (V_Id k) n _) = concat ["vec(",show k,",",show n,")"]++-- * K++-- | Sum type for wire values.+data K = N ()+       | B Bool+       | I Int32+       | F Float+       | V (Vec Float)+           deriving(Eq)++-- | 'Typeable' instance for 'K'.+--+-- map k_typeOf [B False,I 0,F 0.0] == [bool_t,int32_t,float_t]+k_typeOf :: K -> TypeRep+k_typeOf k =+    case k of+      N () -> nil_t+      B _ -> bool_t+      I _ -> int32_t+      F _ -> float_t+      V _ -> vec_float_t++instance Typeable K where typeOf = k_typeOf++-- | Concise pretty printer and 'Show' instance for 'K'.+k_concise :: K -> String+k_concise k =+    case k of+      N () -> "()"+      B b -> show b+      I i -> show i+      F f -> show f+      V v -> vec_concise v++instance Show K where show = k_concise++-- * TypeRep constants++-- | 'typeOf' @()@.+nil_t :: TypeRep+nil_t = typeOf ()++-- | 'typeOf' of 'Bool'.+bool_t :: TypeRep+bool_t = typeOf (undefined::Bool)++-- | 'typeOf' of 'Int32'.+int32_t :: TypeRep+int32_t = typeOf (undefined::Int32)++-- | 'typeOf' of 'Float'.+float_t :: TypeRep+float_t = typeOf (undefined::Float)++-- | 'typeOf' of ('Vec' 'Float').+vec_float_t :: TypeRep+vec_float_t = typeOf (undefined::Vec Float)++-- * Type classes++-- | Class for values that can be lifted to 'K'.+class (Typeable a,Eq a,Ord a,Show a) => K' a where+    to_k :: a -> K++instance K' () where to_k () = N ()+instance K' Bool where to_k b = B b+instance K' Int32 where to_k i = I i+instance K' Float where to_k f = F f+instance K' (Vec Float) where to_k v = V v++-- | Composite of 'Ord' and `K'`.+class (K' a,Ord a) => K_Ord a where+instance K_Ord Bool+instance K_Ord Int32+instance K_Ord Float++-- | Composite of 'K_Ord' and 'Num'.+class (K_Ord a,Num a) => K_Num a where+instance K_Num Int32+instance K_Num Float

@@ -0,0 +1,29 @@+{-# Language FlexibleInstances #-}+-- | Unique identifiers.+module Sound.DF.Uniform.LL.UId where++import Control.Monad {- base -}+import Control.Monad.Trans.State {- transformers -}+import Data.Unique {- base -}++-- * UId Class++-- | Identifiers are integers.+type Id = Int++-- | Class of monads generating identifers+class (Monad m) => UId m where+   generateId :: m Id++instance UId IO where+   generateId = liftM (fromIntegral . hashUnique) newUnique++instance UId (State Id) where+    generateId = do+      i <- get+      put (i + 1)+      return i++-- | Evaluate /m/ 'DF'.+evalId :: State Id a -> a+evalId c = evalState c 0

@@ -0,0 +1,11 @@+-- | Top level module for /PhT/ uniform rate model @hdf@.+module Sound.DF.Uniform.PhT+    (module Sound.DF.Uniform.PhT.Audition+    ,module Sound.DF.Uniform.PhT.Draw+    ,module Sound.DF.Uniform.PhT.Node+    ,module Sound.DF.Uniform.LL.UId) where++import Sound.DF.Uniform.PhT.Audition+import Sound.DF.Uniform.PhT.Draw+import Sound.DF.Uniform.PhT.Node+import Sound.DF.Uniform.LL.UId

@@ -0,0 +1,19 @@+-- | Interaction with @jack-dl@, @scsynth@ and @text-dl@.+module Sound.DF.Uniform.PhT.Audition where++import Sound.OSC {- hosc -}++import Sound.DF.Uniform.PhT.Node+import qualified Sound.DF.Uniform.UDF as U++-- | Audition graph after sending initialisation messages.+audition :: [Message] -> DF () -> IO ()+audition is n = U.audition is (df_udf n)++-- | Audition graph after sending initialisation messages.+audition_sc3 :: [Message] -> DF () -> IO ()+audition_sc3 is n = U.audition_sc3 is (df_udf n)++-- | Audition at @text-dl@.+audition_text :: Int -> DF () -> IO ()+audition_text nf n = U.audition_text nf (df_udf n)

@@ -0,0 +1,14 @@+-- | Graph drawing+module Sound.DF.Uniform.PhT.Draw (draw,drawM) where++import Control.Monad.Trans.State {- transformers -}+import Sound.DF.Uniform.LL+import Sound.DF.Uniform.PhT.Node+import qualified Sound.DF.Uniform.UDF as U++-- | View graph using graphviz.+draw :: DF a -> IO ()+draw = U.draw . df_udf++drawM :: State Id (DF a) -> IO ()+drawM = draw . evalId

@@ -0,0 +1,255 @@+{-# Language FlexibleInstances,DeriveDataTypeable #-}+-- | Data flow nodes.+module Sound.DF.Uniform.PhT.Node where++import Data.Bits+import Data.Int+import Data.Typeable++import Sound.DF.Uniform.LL+import Sound.DF.Uniform.UDF++-- * Types++-- | Constant with phantom type.+data KT ty = KT {kt_k :: K} deriving (Eq)++-- | Data flow node with phantom type.+data DF ty = DF {df_udf :: UDF} deriving (Eq)++-- * Construct, destruct & predicate++-- | Lift 'Int32' to constant, ie. 'KT' of 'I'.+k_Int32 :: Int32 -> KT Int32+k_Int32 = KT . I++-- | Lift 'Float' to constant, ie. 'KT' of 'F'.+k_Float :: Float -> KT Float+k_Float = KT . F++-- | A zero with unresolved type, ie. 'KT' of 'F' of @0@.+k_zero :: KT ty+k_zero = KT (F 0)++-- | Lift 'Int32' to 'DF'.+df_Int32 :: Int32 -> DF Int32+df_Int32 = DF . UDF_K . I++-- | Lift 'Float' to 'DF'.+df_Float :: Float -> DF Float+df_Float = DF . UDF_K . F++-- | Tables have a guard point.+df_tbl_size :: DF a -> Maybe Int+df_tbl_size df =+    case df of+      DF (UDF_A (Vec _ k _)) -> Just (k - 1)+      _ -> Nothing++-- | Multiple root graph.+mrg :: DF a -> DF () -> DF a+mrg p q = DF (UDF_M (df_udf p) (df_udf q))++-- * Querying data type on ports++-- | 'typeOf' 'DF'.+df_type :: DF a -> TypeRep+df_type = udf_typeOf . df_udf++-- * Operator cons++-- | 'DF' of 'UDF_P'.+mk_a :: String -> [DF a] -> TypeRep -> DF ty+mk_a s i ty = DF (UDF_P s ty (map df_udf i))++-- | Primitive unary operator.+unary_operator :: String -> DF a -> DF a+unary_operator s p = mk_a s [p] (df_type p)++-- | Primitive binary operator.+binary_operator :: String -> DF a -> DF a -> DF a+binary_operator s p q = mk_a s [p,q] (df_type p)++-- | Primitive comparator.+comparison_operator :: String -> DF a -> DF a -> DF Bool+comparison_operator s p q = mk_a s [p,q] bool_t++-- | Primitive sink.+sink_node :: String -> [DF a] -> DF ()+sink_node s ps = mk_a s ps nil_t++-- | Primitive unary operator with separate primitives for integral+-- and floating types.+alt_unary_operator :: (String,String) -> DF a -> DF a+alt_unary_operator (nm_i,nm_f) n =+    let ty = df_type n+    in if ty == int32_t+       then mk_a nm_i [n] int32_t+       else if ty == float_t+            then mk_a nm_f [n] float_t+            else error "alt_unary_operator"++-- | Lift list of float to 'DF' 'Vec'.+df_vec_m :: UId m => [Float] -> m (DF (Vec Float))+df_vec_m v = do+  k <- generateId+  return (DF (UDF_A (Vec (V_Id k) (length v) v)))++instance Num n => Num (DF n) where+    (+) = binary_operator "df_add"+    (*) = binary_operator "df_mul"+    (-) = binary_operator "df_sub"+    negate = unary_operator "df_negate"+    abs = alt_unary_operator ("df_labs","df_fabsf")+    signum = unary_operator "df_signum"+    fromInteger = DF . UDF_K . I . fromInteger++instance Fractional (DF Float) where+    (/) = binary_operator "df_div"+    recip = unary_operator "df_recip"+    fromRational = DF . UDF_K . F . fromRational++instance Floating (DF Float) where+  pi = DF (UDF_K (F pi))+  exp = unary_operator "df_exp"+  sqrt = unary_operator "df_sqrt"+  log = unary_operator "df_log"+  (**) = binary_operator "df_pow"+  logBase = undefined+  sin = unary_operator "df_sin"+  tan = unary_operator "df_tan"+  cos = unary_operator "df_cos"+  asin = undefined+  atan = undefined+  acos = undefined+  sinh = undefined+  tanh = undefined+  cosh = undefined+  asinh = undefined+  atanh = undefined+  acosh = undefined++instance Eq a => Bits (DF a) where+    (.&.) = binary_operator "df_and"+    (.|.) = binary_operator "df_or"+    xor = undefined+    complement = undefined+    bit = undefined+    testBit = undefined+    bitSize = undefined+    isSigned = undefined+    popCount = undefined++-- * Ord++-- | '==', equal to.+df_eq :: DF a -> DF a -> DF Bool+df_eq = comparison_operator "df_eq"++-- | '<', less than.+df_lt :: Num a => DF a -> DF a -> DF Bool+df_lt = comparison_operator "df_lt"++-- | '>=', greater than or equal to.+df_gte :: Num a => DF a -> DF a -> DF Bool+df_gte = comparison_operator "df_gte"++-- | '>', greater than.+df_gt :: Num a => DF a -> DF a -> DF Bool+df_gt = comparison_operator "df_gt"++-- | '<=', less than or equal to.+n_lte :: Num a => DF a -> DF a -> DF Bool+n_lte = comparison_operator "df_lte"++instance Eq a => Ord (DF a) where+  compare = undefined+  (<) = undefined+  (>=) = undefined+  (>) = undefined+  (<=) = undefined+  max = binary_operator "df_max"+  min = binary_operator "df_min"++-- * RealFrac++-- | ceilf(3)+df_ceilingf :: DF Float -> DF Float+df_ceilingf = unary_operator "df_ceilf"++-- | floorf(3)+df_floorf :: DF Float -> DF Float+df_floorf = unary_operator "df_floorf"++-- | lrintf(3)+df_lrintf :: DF Float -> DF Int32+df_lrintf p = mk_a "df_lrintf" [p] int32_t++-- | roundf(3)+df_roundf :: DF Float -> DF Float+df_roundf = unary_operator "df_roundf"++-- * Primitives++-- | Single channel output.+out1 :: DF Float -> DF ()+out1 p = sink_node "df_out1" [p]++-- | Two channel output.+out2 :: DF Float -> DF Float -> DF ()+out2 p q = sink_node "df_out2" [p,q]++-- | Three channel output.+out3 :: DF Float -> DF Float -> DF Float -> DF ()+out3 p q r = sink_node "df_out3" [p,q,r]++-- | Single control input.+ctl1 :: DF Int32 -> DF Float+ctl1 p = mk_a "df_ctl1" [p] float_t++-- | If /p/ then /q/ else /r/.  /p/ must have type bool, and /q/+-- and /r/ must have equal types.+select2 :: DF Bool -> DF a -> DF a -> DF a+select2 p q r = DF (UDF_P "df_select2" (df_type q) [df_udf p,df_udf q,df_udf r])++-- | Operating sample rate.+w_sample_rate :: DF Float+w_sample_rate = mk_a "df_sample_rate" [] float_t++-- | Buffer read, read from buffer /p/ at index /q/.+b_read :: DF Int32 -> DF Int32 -> DF Float+b_read p q = mk_a "df_b_read" [p,q] float_t++-- | Buffer write, write to buffer /p/ at index /q/ value /r/.+b_write :: DF Int32 -> DF Int32 -> DF Float -> DF ()+b_write p q r = DF (UDF_P "df_b_write" nil_t [df_udf p,df_udf q,df_udf r])++-- | Array read.+a_read :: DF (Vec Float)-> DF Int32 -> DF Float+a_read p q = DF (UDF_P "df_a_read" float_t [df_udf p,df_udf q])++-- | Array write.+a_write :: DF (Vec Float) -> DF Int32 -> DF Float -> DF ()+a_write p q r = DF (UDF_P "df_a_write" nil_t [df_udf p,df_udf q,df_udf r])++-- * Backward arcs++-- | Introduce backward arc with implicit unit delay.+rec_r :: R_Id -> KT a -> (DF a -> (DF a,DF a)) -> DF a+rec_r n i f =+    let (p,q) = f (DF (UDF_R n (Left (kt_k i))))+    in DF (UDF_R n (Right (df_udf p,df_udf q)))++-- | Monadic variant of rec_r.+rec :: UId m => KT a -> (DF a -> (DF a,DF a)) -> m (DF a)+rec i f = do+  n <- generateId+  return (rec_r (R_Id n) i f)++-- | Variant or rec with monadic action in backward arc.+recm :: UId m => KT a -> (DF a -> m (DF a,DF a)) -> m (DF a)+recm i f = do+  n <- generateId+  let r_r = DF (UDF_R (R_Id n) (Left (kt_k i)))+  (p,q) <- f r_r+  return (DF (UDF_R (R_Id n) (Right (df_udf p,df_udf q))))

@@ -0,0 +1,469 @@+-- | Untyped /DF/.+module Sound.DF.Uniform.UDF where++import qualified Data.Graph.Inductive as G {- fgl -}+import Data.Maybe {- base -}+import Data.List {- base -}+import Data.Typeable {- base -}+import Sound.OSC {- hosc -}+import System.Directory {- directory -}+import System.Environment {- base -}+import System.FilePath {- filepath -}+import System.Process {- process -}+import Text.Printf {- base -}++import qualified Sound.DF.Uniform.LL.Audition as L+import Sound.DF.Uniform.LL.CGen+import Sound.DF.Uniform.LL.Dot+import Sound.DF.Uniform.LL.K+import Sound.DF.Uniform.LL.UId++-- | Recursion identifier.+data R_Id = R_Id Id deriving (Eq,Show)++-- | Un-typed data-flow node.+data UDF = UDF_K {udf_k :: K}+         | UDF_A {udf_a :: Vec Float}+         | UDF_R R_Id (Either K (UDF,UDF))+         | UDF_P String TypeRep [UDF]+         | UDF_M UDF UDF+           deriving(Eq,Show)++-- | Concise pretty printer for 'UDF'.+udf_concise :: UDF -> String+udf_concise n =+    case n of+      UDF_K k -> k_concise k+      UDF_A v -> vec_concise v+      UDF_R _ (Left i) -> printf "recRd:%s" (k_concise i)+      UDF_R _ (Right _) -> "recWr"+      UDF_P nm ty _ -> printf "%s:%s" nm (show ty)+      UDF_M l r -> printf "m(%s,%s)" (show l) (show r)++-- | Maybe variant of 'udf_k'.+udf_k' :: UDF -> Maybe K+udf_k' n =+    case n of+      UDF_K x -> Just x+      _ -> Nothing++-- | List elements in left biased order.+udf_elem :: UDF -> [UDF]+udf_elem n =+    case n of+      UDF_K _ -> [n]+      UDF_A _ -> [n]+      UDF_P _ _ i -> n : concatMap udf_elem i+      UDF_R _ (Left _) -> [n]+      UDF_R _ (Right (l,r)) -> n : (udf_elem l ++ udf_elem r)+      UDF_M l r -> n : (udf_elem l ++ udf_elem r)++-- | Output type of 'UDF'.+udf_typeOf :: UDF -> TypeRep+udf_typeOf df =+    case df of+      UDF_K k -> k_typeOf k+      UDF_A _ -> vec_float_t+      UDF_P _ t _ -> t+      UDF_R _ (Left k) -> k_typeOf k+      UDF_R _ (Right (n,_)) -> udf_typeOf n+      UDF_M n _ -> udf_typeOf n++-- | Traversal with state, signature as 'mapAccumL'.+udf_traverse :: (st -> UDF -> (st,UDF)) -> st -> UDF -> (st,UDF)+udf_traverse f st udf =+    case udf of+      UDF_K _ -> f st udf+      UDF_A _ -> f st udf+      UDF_P nm ty i ->+          let (st',i') = mapAccumL f st i+          in f st' (UDF_P nm ty i')+      UDF_R _ (Left _) -> f st udf+      UDF_R r (Right (p,q)) ->+          let (st',p') = f st p+              (st'',q') = f st' q+          in f st'' (UDF_R r (Right (p',q')))+      UDF_M p q ->+          let (st',p') = f st p+              (st'',q') = f st' q+          in f st'' (UDF_M p' q')++-- * Graph++-- | Index for input port.+type Port_Index = Int++-- | A node is a 'UDF' with associated 'Id'.+type Node = (Id,UDF)++-- | Enumeration of 'Edge' types.+data Edge_Ty = Normal_Edge+             | Rec_Wr_Edge Id -- ^ Edge /to/ recWr node+             | Rec_Rd_Edge Id -- ^ Edge /from/ recRd node+             | Implicit_Edge Int -- ^ Edge /to/ recRd node (from recWr)++-- | Pretty printer for 'Edge_Ty', and 'Show' instance.+edge_ty_concise :: Edge_Ty -> String+edge_ty_concise e =+    case e of+      Normal_Edge -> "normal"+      Rec_Rd_Edge _ -> "recRd"+      Rec_Wr_Edge _ -> "recWr"+      Implicit_Edge _ -> "implicit"++instance Show Edge_Ty where show = edge_ty_concise++-- | Edge from left hand side node to right hand side port.+type Edge = (Id,Id,(Port_Index,Edge_Ty))++-- | A graph is a list of 'Node's and 'Edge's.+type Graph = ([Node],[Edge])++-- | A variant graph form associating the list of /in/ edges with each+-- 'Node'.+type Analysis = [(Node,[Edge])]++-- | 'Id' of 'Node'.+node_id :: Node -> Id+node_id = fst++-- | 'UDF' of 'Node'.+node_udf :: Node -> UDF+node_udf = snd++-- | Read label of node.+label :: [Node] -> UDF -> Id+label ns n =+    let r = find ((== n) . node_udf) ns+    in maybe (error ("label: " ++ show n)) node_id r++-- | Transform node to source, see through 'UDF_R' (rec) and 'UDF_M' (mrg).+source :: [Node] -> UDF -> Id+source ns n =+    case n of+      UDF_K _ -> label ns n+      UDF_A _ -> label ns n+      UDF_P _ _ _ -> label ns n+      UDF_R _ (Left _) -> label ns n+      UDF_R _ (Right (n',_)) -> source ns n'+      UDF_M l _ -> source ns l++-- | Type of /out/ edge of 'UDF'.+udf_edge_ty :: UDF -> Edge_Ty+udf_edge_ty u =+    case u of+      UDF_R (R_Id k) (Left _) -> Rec_Rd_Edge k+      UDF_R (R_Id _) (Right (n,_)) -> udf_edge_ty n+      _ -> Normal_Edge++-- | List /incoming/ node edges.+edges :: [Node] -> UDF -> [Edge]+edges ns u =+    case u of+      UDF_P _ _ is ->+          let f i k = (source ns i,label ns u,(k,udf_edge_ty i))+          in zipWith f is [0..]+      UDF_R (R_Id k) (Right (_,r)) ->+          [(source ns r,label ns u,(0,Rec_Wr_Edge k))]+      _ -> []++-- | True if 'Node' is 'Right' form of 'UDF_R' with indicated 'R_Id'.+match_rec :: R_Id -> Node -> Bool+match_rec x n =+    case n of+      (_,UDF_R y (Right _)) -> x == y+      _ -> False++-- | Implicit edge from wR to rW.+implicit_edge :: [Node] -> Node -> Maybe Edge+implicit_edge n nd =+    case nd of+      (i,UDF_R d (Left _)) ->+          let (j,_) = fromMaybe+                      (error (show ("implicit_edge",nd)))+                      (find (match_rec d) n)+          in Just (j,i,(0,Implicit_Edge 1))+      _ -> Nothing++-- | Is 'Node' 'UDF_K'.+is_k_node :: Node -> Bool+is_k_node (_,udf) =+    case udf of+      UDF_K _ -> True+      _ -> False++-- | An 'Edge' is orphaned if it refers to a 'Node' that is not in the+-- node list.+is_orphan_edge :: [Node] -> Edge -> Bool+is_orphan_edge n (i,j,_) =+    let k = map fst n+    in i `notElem` k || j `notElem` k++-- | Transform the actual graph into a viewing graph by adding+-- implicit edges from /recWr/ to /recRd/ nodes.+vgraph_impl :: Graph -> Graph+vgraph_impl (n,e) =+    let n' = filter (not . is_k_node) n+        e' = mapMaybe (implicit_edge n) n+        e'' = filter (not . is_orphan_edge n') (e ++ e')+    in (n',e'')++-- | Find edge with indicated right hand side port.+find_in_edge_m :: [Edge] -> (Id,Port_Index) -> Maybe Edge+find_in_edge_m e (r,p) =+    let f (_,r',(p',_)) = r == r' && p == p'+    in find f e++-- | Variant of 'find_in_edge_m' that 'error's.+find_in_edge :: [Edge] -> (Id,Port_Index) -> Edge+find_in_edge e rp =+    let err = error (show ("find_in_edge",e,rp))+    in fromMaybe err (find_in_edge_m e rp)++-- | Trace in edges until arrival at a 'Rec_Wr_Edge' that is not+-- proceeded by an 'Implicit_Edge'.  This traces the /depth/ of the+-- chain, however that is not currently drawn.+solve_rec_edge :: Int -> [Edge] -> (Id,Port_Index) -> (Int,Id)+solve_rec_edge d e rp =+    case find_in_edge e rp of+      (l,_,(_,Rec_Wr_Edge _)) ->+          case find_in_edge_m e (l,0) of+            Just (l',_,(_,Implicit_Edge _)) -> solve_rec_edge (d + 1) e (l',0)+            _ -> (d,l)+      (l,_,(_,_)) -> solve_rec_edge (d + 1) e (l,0)++-- | Transform 'Rec_Rd_Edge' to resolved 'Implicit_Edge'.+implicit_edge' :: [Edge] -> Edge -> Maybe Edge+implicit_edge' es e =+    let (l,r,(p,ty)) = e+    in case ty of+         Rec_Rd_Edge _ ->+             let (d,l') = solve_rec_edge 1 es (l,0)+             in Just (l',r,(p,Implicit_Edge d))+         Rec_Wr_Edge _ -> Nothing+         Implicit_Edge _ -> Nothing+         Normal_Edge -> Just e++-- | Is 'Node' 'UDF_R'.+is_rec_node :: Node -> Bool+is_rec_node (_,udf) =+    case udf of+      UDF_R _ _ -> True+      _ -> False++-- | Transform the actual graph into a viewing graph by deleting+-- /recWr/ and /recRd/ nodes and drawing a direct backward edge.+vgraph_direct :: Graph -> Graph+vgraph_direct (n,e) =+    let n' = filter (not . is_rec_node) n+        e' = mapMaybe (implicit_edge' e) e+    in (n',e')++-- | Label nodes and list incoming edges.  Multiple-root nodes are+-- erased.+--+-- > analyse (udf_elem c)+analyse :: [UDF] -> Analysis+analyse ns =+    let l_ns = zip [1..] ns+        w_es (k,n) = ((k,n),edges l_ns n)+        rem_m ((_,UDF_M _ _),_) = False+        rem_m _ = True+    in filter rem_m (map w_es l_ns)++-- | Generate graph (node list and edge list).+--+-- > import Sound.DF.Uniform.GADT+-- > import qualified Sound.DF.Uniform.UDF as U+--+-- > let g = iir1 (0.0::Float) (+) 1+-- > let c = df_erase g+--+-- > map U.udf_concise (U.udf_elem c)+-- > > [recWr,df_add:Float,1.0,recRd:0.0,df_add:Float,1.0,recRd:0.0]+--+-- > U.vgraph_direct (U.graph c)+-- > > ([(1,wR_1),(2,df_add:Float),(3,1.0),(4,rR_1:0.0)]+-- > > ,[(2,1,0),(3,2,0),(4,2,1)])+--+-- > U.draw c+graph :: UDF -> Graph+graph n =+    let a = analyse (nub (udf_elem n))+        (ns,es) = unzip a+    in (ns,concat es)++-- * FGL Graph++-- | FGL graph with 'UDF' label.+type Gr = G.Gr UDF (Port_Index,Edge_Ty)++-- | FGL graph with pretty-printed 'UDF' label.+type Gr' = G.Gr String (Port_Index,Edge_Ty)++-- | Generate 'Gr'.+udf_gr :: Graph -> Gr+udf_gr (n,e) = G.mkGraph n e++-- | Generate 'Gr''.+udf_gr' :: Graph -> Gr'+udf_gr' (n,e) = G.mkGraph (map (fmap udf_concise) n) e++-- | Topological sort of nodes (via 'udf_gr').+tsort :: UDF -> [UDF]+tsort u =+    let g = udf_gr (graph u)+    in map (fromMaybe (error "tsort") . G.lab g) (G.topsort g)++-- * Code Gen++-- | List of required variable declarations.+node_vars :: Node -> [Var]+node_vars (k,df) =+    case df of+      UDF_K i -> [k_var k Std_Var i]+      UDF_A i -> [buffer_var k i]+      UDF_R (R_Id j) (Left i) ->+          [k_var j Rec_Var i+          ,k_var k Std_Var i]+      UDF_R (R_Id _) (Right (n,_)) ->+          [(Std_Var,udf_typeOf n,k,Nothing)]+      UDF_P _ ty _ ->+          if ty == nil_t+          then []+          else [(Std_Var,ty,k,Nothing)]+      UDF_M _ _ -> error "node_vars_n: mrg"++-- | Possible c-call code statement.+node_c_call :: (Node,[Edge]) -> Maybe C_Call+node_c_call ((k,n),es) =+    let fc p q = Just (Nothing,p,q)+    in case (n,es) of+         (UDF_K _,[]) -> Nothing+         (UDF_A _,[]) -> Nothing+         (UDF_R (R_Id j) (Left _),[]) ->+             fc "df_rec_r" [(Std_Var,k),(Rec_Var,j)]+         (UDF_R (R_Id j) (Right _),[(s,_,_)]) ->+             fc "df_rec_w" [(Rec_Var,j),(Std_Var,s)]+         (UDF_P a t _,_) ->+             let o_l = if t /= nil_t+                       then [(Std_Var,k)]+                       else []+                 i_l = map (\(l,_,_) -> (Std_Var,l)) es+             in fc a (o_l ++ i_l)+         _ -> error ("node_c_call: " ++ show (n,es))++-- | Constant nodes.+k_nodes :: [Node] -> [(Id,K)]+k_nodes ns =+    let ks = filter (isJust . udf_k' . node_udf) ns+    in map (fmap udf_k) ks++-- | Generate 'Instructions' from 'UDF'.+udf_instructions :: UDF -> Instructions+udf_instructions n =+    let a = analyse (tsort n)+        ns = map fst a+        ks = k_nodes ns+        vs = concatMap node_vars ns+        cc = mapMaybe node_c_call a+    in (ks,vs,cc)++-- | 'dl_gen' of 'udf_instructions'.+udf_dl_gen :: FilePath -> (Host,FilePath) -> UDF -> IO ()+udf_dl_gen fn hd = dl_gen fn hd . udf_instructions++-- * Graph Drawing++-- | Make 'dot_rec' /arguments/ input.+dot_ar :: [UDF] -> [Either Int K]+dot_ar =+    let f (i,u) = case u of+                    UDF_K k -> Right k+                    _ -> Left i+    in map f . zip [0..]++-- | Dot notation of 'Node'.+dot_node :: Node -> String+dot_node (k,u) =+    case u of+      UDF_K _ -> error "dot_node: UDF_K"+      UDF_A v -> dot_rec' k (vec_concise v) [] vec_float_t+      UDF_P nm ty i -> dot_rec' k nm (dot_ar i) ty+      UDF_R _ (Left c) -> dot_rec' k (udf_concise u) [Right c] (k_typeOf c)+      UDF_R _ (Right (u',_)) -> dot_rec' k (udf_concise u) (dot_ar [u']) (udf_typeOf u')+      UDF_M _ _ -> error "dot_node: UDF_M"++-- | Edges are coloured according to their type.+edge_ty_colour :: Edge_Ty -> String+edge_ty_colour ty =+    case ty of+      Normal_Edge -> "black"+      Rec_Rd_Edge _ -> "orange"+      Rec_Wr_Edge _ -> "purple"+      Implicit_Edge _ -> "red"++-- | Dot notation of 'Edge'.+dot_edge :: Edge -> String+dot_edge (j,k,(p,ty)) =+    let a = [("color",edge_ty_colour ty)]+    in printf "%d:o_0 -> %d:i_%d %s" j k p (dot_attr a)++-- | Dot notation of 'Graph'.+dot_graph :: Graph -> [String]+dot_graph (n,e) =+    concat [["digraph Anonymous {"+            ,"graph [splines=false];"]+           ,map dot_node n+           ,map dot_edge e+           ,["}"]]++-- | View dot graph.+dot_draw :: String -> IO ()+dot_draw s = do+  t <- getTemporaryDirectory+  v <- fmap (fromMaybe "dotty") (lookupEnv "DOTVIEWER")+  let fn = t </> "udf" <.> "dot"+  writeFile fn s+  _ <- rawSystem v [fn]+  return ()++-- | Draw graph, transformed by `vgraph_direct`.+draw :: UDF -> IO ()+draw = dot_draw . unlines . dot_graph . vgraph_direct . vgraph_impl . graph++-- | Draw graph, transformed by `vgraph_impl`.+draw' :: UDF -> IO ()+draw' = dot_draw . unlines . dot_graph . vgraph_impl . graph++-- * Gr Drawing++-- | Make @dot@ rendering of graph at 'Node', via 'vgraph_direct'.+gr_dot :: UDF -> String+gr_dot = G.graphviz' . udf_gr' . vgraph_direct . vgraph_impl . graph++-- | Make @dot@ rendering of graph at 'Node', via 'vgraph_impl'.+gr_dot' :: UDF -> String+gr_dot' = G.graphviz' . udf_gr' . vgraph_impl . graph++-- | Draw graph, via 'gr_dot'.+gr_draw :: UDF -> IO ()+gr_draw = dot_draw . gr_dot++-- | Draw graph, via `gr_dot'`.+gr_draw' :: UDF -> IO ()+gr_draw' = dot_draw . gr_dot'++-- * Audition++-- | Audition graph after sending initialisation messages.+audition :: [Message] -> UDF -> IO ()+audition is n = L.audition is (udf_instructions n)++-- | Audition graph after sending initialisation messages.+audition_sc3 :: [Message] -> UDF -> IO ()+audition_sc3 is n = L.audition_sc3 is (udf_instructions n)++-- | Audition at @text-dl@.+audition_text :: Int -> UDF -> IO ()+audition_text nf n = L.audition_text nf (udf_instructions n)

@@ -0,0 +1,71 @@+/* reader */+#define df_integer_constant(o_0,i_0) {o_0 = i_0;}+#define df_real_constant(o_0,i_0) {o_0 = i_0;}+#define df_rec_r(o_0,i_0) {o_0 = i_0;}+#define df_rec_w(o_0,i_0) {o_0 = i_0;}+/* instance Num */+#define df_add(o_0,i_0,i_1) {o_0 = (i_0) + (i_1);}+#define df_mul(o_0,i_0,i_1) {o_0 = (i_0) * (i_1);}+#define df_mul_add(o_0,i_0,i_1,i_2) {o_0 = (i_0) * (i_1) + (i_2);}+#define df_sub(o_0,i_0,i_1) {o_0 = (i_0) - (i_1);}+#define df_negate(o_0,i_0) {o_0 = -(i_0);}+#define df_abs(o_0,i_0) {o_0 = (i_0) < 0 ? -(i_0) : (i_0);}+#define df_fabsf(o_0,i_0) {o_0 = fabsf(i_0);}+#define df_labs(o_0,i_0) {o_0 = labs(i_0);}+#define df_signum(o_0,i_0) {o_0 = i_0 > 0 ? 1 (i_0 < 0 ? -1 : 0);}}+/* instance Integral */+#define df_mod(o_0,i_0,i_1) {o_0 = i_0 % i_1;}+#define df_fmodf(o_0,i_0,i_1) {o_0 = fmodf(i_0,i_1);}+/* instance Fractional */+#define df_div(o_0,i_0,i_1) {o_0 = (i_0) / (i_1);}+#define df_recip(o_0,i_0) {o_0 = 1.0 / i_0;}+/* instance Floating */+#define df_exp(o_0,i_0) {o_0 = expf(i_0);}+#define df_sqrt(o_0,i_0) {o_0 = sqrtf(i_0);}+#define df_log(o_0,i_0) {o_0 = logf(i_0);}+#define df_pow(o_0,i_0,i_1) {o_0 = powf(i_0,i_1);}+#define df_sin(o_0,i_0) {o_0 = sinf(i_0);}+#define df_cos(o_0,i_0) {o_0 = cosf(i_0);}+#define df_tan(o_0,i_0) {o_0 = tanf(i_0);}+/* cast */+#define df_float_to_int32(o_0,i_0) {o_0 = (int32_t)i_0;}+#define df_int32_to_float(o_0,i_0) {o_0 = (float)i_0;}+/* identity */+#define df_identity(o_0,i_0) {o_0 = i_0;}+/* instance Ord */+#define df_lt(o_0,i_0,i_1) {o_0 = i_0 < i_1 ? true : false;}+#define df_lte(o_0,i_0,i_1) {o_0 = i_0 <= i_1 ? true : false;}+#define df_gt(o_0,i_0,i_1) {o_0 = i_0 > i_1 ? true : false;}+#define df_gte(o_0,i_0,i_1) {o_0 = i_0 >= i_1 ? true : false;}+#define df_max(o_0,i_0,i_1) {o_0 = i_0 > i_1 ? i_0 : i_1;}+#define df_min(o_0,i_0,i_1) {o_0 = i_0 < i_1 ? i_0 : i_1;}+/* instance Eq */+#define df_eq(o_0,i_0,i_1) {o_0 = i_0 == i_1 ? true : false;}+/* instance RealFrac */+#define df_floorf(o_0,i_0) {o_0 = floorf(i_0);}+#define df_ceilf(o_0,i_0) {o_0 = ceilf(i_0);}+#define df_roundf(o_0,i_0) {o_0 = roundf(i_0);}+#define df_lrintf(o_0,i_0) {o_0 = lrintf(i_0);}+/* instance Bits */+#define df_bw_and(o_0,i_0,i_1) {o_0 = i_0 & i_1;}+#define df_bw_or(o_0,i_0,i_1) {o_0 = i_0 | i_1;}+#define df_bw_not(o_0,i_0) {o_0 = ~ i_0;}+/* Control */+#define df_and(o_0,i_0,i_1) {o_0 = i_0 && i_1 ? true : false;}+#define df_or(o_0,i_0,i_1) {o_0 = i_0 || i_1 ? true : false;}+#define df_not(o_0,i_0) {o_0 = i_0 ? false : true;}+#define df_select2(o_0,i_0,i_1,i_2) {o_0 = i_0 ? i_1 : i_2;}+/* Array */+#define df_a_read(o_0,i_0,i_1) {o_0 = i_0[i_1];}+#define df_a_write(i_0,i_1,i_2) {i_0[i_1] = i_2;}+/* World|Environment */+#define df_sample_rate(o_0) {o_0 = w_sr(w);}+#define df_b_read(o_0,i_0,i_1) {o_0 = w_b_read1(w,i_0,i_1);}+#define df_b_write(i_0,i_1,i_2) {w_b_write1(w,i_0,i_1,i_2);}+#define df_in1(o_0) {o_0 = w_in1(w,fc);}+#define df_out1(i_0) {w_out1(w,fc,i_0);}+#define df_out2(i_0,i_1) {w_out2(w,fc,i_0,i_1);}+#define df_out3(i_0,i_1,i_2) {w_out3(w,fc,i_0,i_1,i_2);}+#define df_ctl1(o_0,i_0) {o_0 = w_c_get1(w,i_0);}+#define df_kr_nframes(o_0) {o_0 = (long int)w_nf;}+#define df_kr_edge(o_0) {o_0 = fc == 0 ? true : false;}

@@ -0,0 +1,68 @@+#include <dlfcn.h>+#include <math.h>+#include <stdbool.h>+#include <stdio.h>+#include <stdlib.h>+#include <string.h>+#include <time.h>+#include <unistd.h>++#include "text-dl.h"++void usage(void)+{+  printf("Usage: text-dl [ options ] dsp-file\n");+  printf("    -b N : Number of buffers (default=8).\n");+  printf("    -f N : Number of frames (default=48000).\n");+  printf("    -k N : Number of controls (default=64).\n");+  printf("    -l N : Buffer size (uniform, default=48000).\n");+  printf("    -s N : Sample rate (default=48000).\n");+  exit(EXIT_SUCCESS);+}++int main(int argc, char **argv)+{+  size_t (*dsp_memreq)();+  void (*dsp_init)(void *);+  void (*dsp_step)(struct world *, int);+  void *gh;+  struct world w;+  int nf = 48000;+  int bl = 48000;+  int c;+  w.nb = 8;+  w.nk = 64;+  w.sr = 48000;+  while((c = getopt(argc, argv, "b:f:hk:s:")) != -1) {+    switch(c) {+    case 'b': w.nb = (int)strtol(optarg, NULL, 0); break;+    case 'f': nf = (int)strtol(optarg, NULL, 0); break;+    case 'h': usage(); break;+    case 'k': w.nk = (int)strtol(optarg, NULL, 0); break;+    case 'l': bl = (int)strtol(optarg, NULL, 0); break;+    case 's': w.sr = (int)strtof(optarg, NULL); break;+    }+  }+  if (optind >= argc) usage();+  char *fn = argv[optind];+  w.ctl = calloc(w.nk, sizeof(float));+  w.bl = calloc(w.nb, sizeof(int));+  w.bd = calloc(w.nb, sizeof(float*));+  for(int i = 0; i < w.nb; i++ ) {+    w.bl[i] = bl;+    w.bd[i] = calloc(w.bl[i],sizeof(float));+  }+  gh = dlopen(fn, RTLD_LAZY);+  if(!gh) {+    printf("text-dl: %s",dlerror());+    return EXIT_FAILURE;+  }+  dsp_memreq = dlsym(gh, "dsp_memreq");+  dsp_init = dlsym(gh, "dsp_init");+  dsp_step = dlsym(gh, "dsp_step");+  size_t k = dsp_memreq();+  w.st = malloc(k);+  dsp_init(w.st);+  dsp_step(&w,nf);+  return EXIT_SUCCESS;+}

@@ -0,0 +1,22 @@+#include <stdbool.h>++struct world {+  void *st;                    /* graph state */+  float sr;                    /* sample rate */+  int nk;                      /* number of controls */+  float *ctl;                  /* control data */+  int nb;                      /* number of buffers */+  int *bl;                     /* buffer sizes */+  float **bd;                  /* buffer data */+};++#define df_world struct world+#define w_state(w) (w)->st+#define w_sr(w) (w)->sr+#define w_c_get1(w,i) (w)->ctl[(i)]+#define w_c_set1(w,i,n) (w)->ctl[(i)]=(n)+#define w_in1(w,i) 0+#define w_out1(w,i,n) printf("%d: %f\n",i,n)+#define w_out2(w,i,n1,n2) printf("%d: %f, %f\n",i,n1,n2)+#define w_b_read1(w,b,i) (w)->bd[(b)][(i)]+#define w_b_write1(w,b,i,n) (w)->bd[(b)][(i)]=(n)

@@ -0,0 +1,25 @@+import Control.Monad+import Sound.DF.Uniform.GADT {- hdf -}+import Sound.OSC {- hosc -}+import qualified Sound.SC3.ID as S {- hsc3 -}++main :: IO ()+main = audition analog_bubbles_buf_msg =<< analog_bubbles_buf_m++analog_bubbles_buf_msg :: [Message]+analog_bubbles_buf_msg = [S.b_alloc 0 44100 1,S.b_alloc 1 44100 1]++-- > drawM analog_bubbles_buf_m+-- > analog_bubbles_buf_m >>= audition analog_bubbles_buf_msg+analog_bubbles_buf_m :: (Functor m,UId m) => m (DF ())+analog_bubbles_buf_m = do+  let dpl f a b = liftM2 (,) (f a) (f b)+      mk_o f = fmap (mul_add 3.0 80.0) (lf_saw_m f 0.0)+      mk_f a = fmap (mul_add 24.0 a) (lf_saw_m 0.4 0.0)+      mk_s f = fmap (* 0.04) (sin_osc_m (midi_cps f) 0.0)+  (o1,o2) <- dpl mk_o 8.0 7.23+  (f1,f2) <- dpl mk_f o1 o2+  (s1,s2) <- dpl mk_s f1 f2+  c1 <- buf_comb_n_m 0 s1 0.2 4.0+  c2 <- buf_comb_n_m 1 s2 0.2 4.0+  return (out2 c1 c2)

@@ -0,0 +1,24 @@+import Control.Monad+import Sound.DF.Uniform.GADT {- hdf -}+import Sound.OSC {- hosc -}+import qualified Sound.SC3.ID as S {- hsc3 -}++main :: IO ()+main = audition analog_bubbles_buf_msg analog_bubbles_buf++analog_bubbles_buf_msg :: [Message]+analog_bubbles_buf_msg = [S.b_alloc 0 44100 1,S.b_alloc 1 44100 1]++-- > draw analog_bubbles_buf+analog_bubbles_buf :: DF ()+analog_bubbles_buf =+  let dpl f a b = (f a,f b)+      mk_o f = lf_saw f 0.0 * 3.0 + 80.0+      mk_f a = lf_saw 0.4 0.0 * 24.0 + a+      mk_s f = sin_osc (midi_cps f) 0.0 * 0.04+      (o1,o2) = dpl mk_o 8.0 7.23+      (f1,f2) = dpl mk_f o1 o2+      (s1,s2) = dpl mk_s f1 f2+      c1 = buf_comb_n 0 s1 0.2 4.0+      c2 = buf_comb_n 1 s2 0.2 4.0+  in out2 c1 c2

@@ -0,0 +1,19 @@+import Control.Monad+import Sound.DF.Uniform.GADT {- hdf -}++main :: IO ()+main = audition [] =<< analog_bubbles_m++-- > drawM analog_bubbles_m+analog_bubbles_m :: (Functor m,UId m) => m (DF ())+analog_bubbles_m = do+  let dpl f a b = liftM2 (,) (f a) (f b)+      mk_o f = fmap (mul_add 3.0 80.0) (lf_saw_m f 0.0)+      mk_f a = fmap (mul_add 24.0 a) (lf_saw_m 0.4 0.0)+      mk_s f = fmap (* 0.04) (sin_osc_m (midi_cps f) 0.0)+  (o1,o2) <- dpl mk_o 8.0 7.23+  (f1,f2) <- dpl mk_f o1 o2+  (s1,s2) <- dpl mk_s f1 f2+  c1 <- comb_n_m 0.2 s1 0.2 4.0+  c2 <- comb_n_m 0.2 s2 0.2 4.0+  return (out2 c1 c2)

@@ -0,0 +1,20 @@+import Control.Monad+import Sound.DF.Uniform.GADT {- hdf -}+import Sound.DF.Uniform.LL.K {- hdf -}++-- > draw analog_bubbles+analog_bubbles :: DF ()+analog_bubbles =+  let dpl f a b = (f a,f b)+      mk_o f = lf_saw f 0.0 * 3.0 + 80.0+      mk_f a = lf_saw 0.4 0.0 * 24.0 + a+      mk_s f = sin_osc (midi_cps f) 0.0 * 0.04+      (o1,o2) = dpl mk_o 8.0 7.23+      (f1,f2) = dpl mk_f o1 o2+      (s1,s2) = dpl mk_s f1 f2+      c1 = comb_n (V_Id 0) 0.2 s1 0.2 4.0+      c2 = comb_n (V_Id 1) 0.4 s2 0.2 4.0+  in out2 c1 c2++main :: IO ()+main = audition [] analog_bubbles

@@ -0,0 +1,27 @@+import Control.Monad+import Sound.DF.Uniform.GADT {- hdf -}+import Sound.OSC {- hosc -}+import qualified Sound.SC3.ID as S {- hsc3 -}++-- > import qualified Sound.DF.Uniform.LL as L {- hdf -}+-- > L.with_jack_dl (mapM_ S.send ctl_osc_msg)+ctl_osc_msg :: [Message]+ctl_osc_msg = [S.c_set1 0 440,S.c_set1 1 0.1]++-- > draw ctl_osc+ctl_osc :: DF ()+ctl_osc =+    let o = sin_osc (ctl1 0) 0.0 * ctl1 1+    in out1 o++-- > L.with_jack_dl (mapM_ S.send [S.c_set1 0 880,S.c_set1 1 0.1])+-- > L.with_jack_dl (mapM_ S.send [S.c_set1 0 220,S.c_set1 1 0.2])+main :: IO ()+main = audition ctl_osc_msg ctl_osc++-- > drawM ctl_osc_m+-- > ctl_osc_m >>= audition ctl_osc_msg+ctl_osc_m :: (Functor m,UId m) => m (DF ())+ctl_osc_m = do+  o <- fmap (* (ctl1 1)) (sin_osc_m (ctl1 0) 0.0)+  return (out1 o)

@@ -0,0 +1,17 @@+import Sound.DF.Uniform.GADT {- hdf -}++-- > draw drummer+drummer :: DF ()+drummer =+  let n = white_noise 0+      tempo = 4+      tr = impulse tempo 0+      tr_2 = pulse_divider' tr 4 2+      tr_4 = pulse_divider' tr 4 0+      snare = n * decay2 tr_2 0.005 0.5+      bass = sin_osc 60 0 * decay2 tr_4 0.005 0.5+      hihat = hpf n 10000 * decay2 tr 0.005 0.5+  in out1 ((snare + bass + hihat) * 0.4)++main :: IO ()+main = audition [] drummer

@@ -0,0 +1,22 @@+import Data.Int {- base -}+import Sound.DF.Uniform.GADT {- hdf -}+import Sound.DF.Uniform.LL.K {- hdf -}++-- | DF variant of Faust @~@.+tilde_m :: (UId m,Num a,K' a) => (DF a -> DF a) -> (DF a -> DF a) -> m (DF a)+tilde_m f g = rec_m 0 (\i -> let r = f i in (r,g r))++-- | DF translation of Faust graph @(12345 : +) ~ (1103515245 : *)@.+--+-- > drawM fig_3_6_m+fig_3_6_m :: (Functor m,UId m) => m (DF Int32)+fig_3_6_m = (+ 12345) `tilde_m` (* 1103515245)++-- | Converted to floating point and sent to output.+--+-- > drawM fig_3_6_m'+fig_3_6_m' :: (Functor m,UId m) => m (DF ())+fig_3_6_m' = fmap (out1 . (* 0.1) . i32_to_normal_f32) fig_3_6_m++main :: IO ()+main = audition [] =<< fig_3_6_m'

@@ -0,0 +1,22 @@+import Data.Int {- base -}+import Sound.DF.Uniform.GADT {- hdf -}+import Sound.DF.Uniform.LL.K {- hdf -}++-- | DF variant of Faust @~@.+tilde :: (Num a,K' a) => (DF a -> DF a) -> (DF a -> DF a) -> DF a+tilde f g = rec_h 0 (\i -> let r = f i in (r,g r))++-- | DF translation of Faust graph @(12345 : +) ~ (1103515245 : *)@.+--+-- > draw fig_3_6+fig_3_6 :: DF Int32+fig_3_6 = (12345 +) `tilde` (* 1103515245)++-- | Converted to floating point and sent to output.+--+-- > draw fig_3_6'+fig_3_6' :: DF ()+fig_3_6' = out1 (i32_to_normal_f32 fig_3_6 * 0.1)++main :: IO ()+main = audition [] fig_3_6'

@@ -0,0 +1,23 @@+import Control.Monad+import Sound.DF.Uniform.GADT {- hdf -}+import Sound.OSC {- hosc -}+import qualified Sound.SC3 as S {- hsc3 -}++main :: IO ()+main = audition lfo_modulation_buf_msg =<< lfo_modulation_buf_m++lfo_modulation_buf_msg :: [Message]+lfo_modulation_buf_msg = [S.b_alloc 0 44100 1, S.b_alloc 1 44100 1]++-- > drawM lfo_modulation_buf_m+lfo_modulation_buf_m :: (Functor m,UId m) => m (DF ())+lfo_modulation_buf_m = do+  let dpl f p q = liftM2 (,) (f p) (f q)+      mk_p f = fmap (mul_add 3600.0 4000.0) (sin_osc_m f 0.0)+  s <- fmap (mul_add 80.0 160.0) (sin_osc_m 0.05 0.0)+  (p1, p2) <- dpl mk_p 0.6 0.7+  l <- fmap (* 0.05) (lf_pulse_m s 0 0.4)+  (r1, r2) <- dpl (\x -> rlpf_m l x 0.2) p1 p2+  c1 <- buf_comb_n_m 0 r1 0.20 2.0+  c2 <- buf_comb_n_m 1 r2 0.25 2.0+  return (out2 c1 c2)

@@ -0,0 +1,23 @@+import Control.Monad+import Sound.DF.Uniform.GADT {- hdf -}+import Sound.OSC {- hosc -}+import qualified Sound.SC3 as S {- hsc3 -}++main :: IO ()+main = audition lfo_modulation_buf_msg lfo_modulation_buf++lfo_modulation_buf_msg :: [Message]+lfo_modulation_buf_msg = [S.b_alloc 0 44100 1, S.b_alloc 1 44100 1]++-- > draw lfo_modulation_buf+lfo_modulation_buf :: DF ()+lfo_modulation_buf =+    let dpl f p q = (f p,f q)+        mk_p f = sin_osc f 0.0 * 3600.0 + 4000.0+        s = sin_osc 0.05 0.0 * 80.0 + 160.0+        (p1,p2) = dpl mk_p 0.6 0.7+        l = lf_pulse s 0 0.4 * 0.05+        (r1,r2) = dpl (\x -> rlpf l x 0.2) p1 p2+        c1 = buf_comb_n 0 r1 0.20 2.0+        c2 = buf_comb_n 1 r2 0.25 2.0+    in out2 c1 c2

@@ -0,0 +1,37 @@+import Control.Monad+import Sound.DF.Uniform.GADT {- hdf -}+import Sound.OSC {- hosc -}+import qualified Sound.SC3 as S {- hsc3 -}++-- > drawM lfo_modulation_m+lfo_modulation_m :: (Functor m,UId m) => m (DF ())+lfo_modulation_m = do+  let dpl f p q = liftM2 (,) (f p) (f q)+      mk_p f = fmap (mul_add 3600.0 4000.0) (sin_osc_m f 0.0)+  s <- fmap (mul_add 80.0 160.0) (sin_osc_m 0.05 0.0)+  (p1, p2) <- dpl mk_p 0.6 0.7+  l <- fmap (* 0.05) (lf_pulse_m s 0 0.4)+  (r1, r2) <- dpl (\x -> rlpf_m l x 0.2) p1 p2+  c1 <- comb_n_m 0.2 r1 0.20 2.0+  c2 <- comb_n_m 0.25 r2 0.25 2.0+  return (out2 c1 c2)++main :: IO ()+main = audition [] =<< lfo_modulation_m++lfo_modulation_buf_msg :: [Message]+lfo_modulation_buf_msg = [S.b_alloc 0 44100 1, S.b_alloc 1 44100 1]++-- > drawM lfo_modulation_buf_m+-- > lfo_modulation_buf_m >>= audition lfo_modulation_buf_msg+lfo_modulation_buf_m :: (Functor m,UId m) => m (DF ())+lfo_modulation_buf_m = do+  let dpl f p q = liftM2 (,) (f p) (f q)+      mk_p f = fmap (mul_add 3600.0 4000.0) (sin_osc_m f 0.0)+  s <- fmap (mul_add 80.0 160.0) (sin_osc_m 0.05 0.0)+  (p1, p2) <- dpl mk_p 0.6 0.7+  l <- fmap (* 0.05) (lf_pulse_m s 0 0.4)+  (r1, r2) <- dpl (\x -> rlpf_m l x 0.2) p1 p2+  c1 <- buf_comb_n_m 0 r1 0.20 2.0+  c2 <- buf_comb_n_m 1 r2 0.25 2.0+  return (out2 c1 c2)

@@ -0,0 +1,19 @@+import Control.Monad+import Sound.DF.Uniform.GADT {- hdf -}+import Sound.DF.Uniform.LL.K {- hdf -}++-- > draw lfo_modulation+lfo_modulation :: DF ()+lfo_modulation =+    let dpl f p q = (f p,f q)+        mk_p f = sin_osc f 0.0 * 3600.0 + 4000.0+        s = sin_osc 0.05 0.0 * 80.0 + 160.0+        (p1,p2) = dpl mk_p 0.6 0.7+        l = lf_pulse s 0 0.4 * 0.05+        (r1,r2) = dpl (\x -> rlpf l x 0.2) p1 p2+        c1 = comb_n (V_Id 0) 0.2 r1 0.20 2.0+        c2 = comb_n (V_Id 1) 0.25 r2 0.25 2.0+    in out2 c1 c2++main :: IO ()+main = audition [] lfo_modulation

@@ -0,0 +1,17 @@+import Control.Monad+import Sound.DF.Uniform.GADT {- hdf -}++-- > drawM moto_rev_m+moto_rev_m :: (Functor m,UId m) => m (DF ())+moto_rev_m = do+  let dpl f a b = (,) (f a) (f b)+      madd m a = fmap ((+ a) . (* m))+      dplm f a b = liftM2 (,) (f a) (f b)+  f <- madd 10.0 21.0 (sin_osc_m 0.2 0.0)+  (s1, s2) <- dplm (\x -> lf_pulse_m f x 0.1) 0.0 0.1+  (o1, o2) <- dplm (\x -> rlpf_m x 100.0 0.1) s1 s2+  let (c1, c2) = dpl (\x -> df_clip2 x 0.4) o1 o2+  return (out2 c1 c2)++main :: IO ()+main = audition [] =<< moto_rev_m

@@ -0,0 +1,15 @@+import Control.Monad+import Sound.DF.Uniform.GADT {- hdf -}++main :: IO ()+main = audition [] moto_rev++-- > draw moto_rev+moto_rev :: DF ()+moto_rev =+    let dpl f a b = (f a,f b)+        f0 = sin_osc 0.2 0.0 * 10.0 + 21.0+        (s1,s2) = dpl (\x -> lf_pulse f0 x 0.1) 0.0 0.1+        (o1,o2) = dpl (\x -> rlpf x 100.0 0.1) s1 s2+        (c1,c2) = dpl (\x -> df_clip2 x 0.4) o1 o2+    in out2 c1 c2

@@ -0,0 +1,8 @@+import Sound.DF.Uniform.GADT {- hdf -}++-- > draw pass_through+pass_through :: DF ()+pass_through = out1 in1++main :: IO ()+main = audition [] pass_through

@@ -0,0 +1,9 @@+import Sound.DF.Uniform.GADT {- hdf -}++-- > draw silence+silence :: DF ()+silence = out1 0.0++-- > audition_text 12 silence+main :: IO ()+main = audition [] silence

@@ -0,0 +1,15 @@+import Sound.DF.Uniform.GADT {- hdf -}++-- > drawM sprinkler_m+sprinkler_m :: (Functor m,UId m) => m (DF ())+sprinkler_m = do+  let madd m a = fmap ((+ a) . (* m))+  n <- white_noise_m+  f <- madd 10.0 7.0 (lf_pulse_m 0.09 0.0 0.16)+  t <- fmap (* 0.1) (lf_pulse_m f 0.0 0.25)+  o <- bpz2_m (n * t)+  return (out1 o)++main :: IO ()+main = sprinkler_m >>= audition []+

@@ -0,0 +1,14 @@+import Sound.DF.Uniform.GADT {- hdf -}++-- > draw sprinkler+sprinkler :: DF ()+sprinkler =+    let n = white_noise 0+        f = lf_pulse 0.09 0.0 0.16 * 10.0 + 7.0+        t = lf_pulse f 0.0 0.25 * 0.1+        o = bpz2 (n * t)+    in out1 o++main :: IO ()+main = audition [] sprinkler+

@@ -1,60 +1,67 @@ Name:              hdf-Version:           0.11+Version:           0.14 Synopsis:          Haskell data flow library for audio processing Description:       Haskell data flow library for audio processing.-                   Requires the @jack-dl@ host from @rju@,-                   see <http://slavepianos.org/rd/?t=rju>.+                   Requires either the @RDL@ UGen from @sc3-rdu@ or+                   the @jack-dl@ host from @rju@.+                   .+                   See <http://rd.slavepianos.org/?t=sc3-rdu>+                   or <http://rd.slavepianos.org/?t=rju>. License:           GPL Category:          Sound-Copyright:         (c) Rohan Drape, 2006-2011+Copyright:         (c) Rohan Drape, 2006-2013 Author:            Rohan Drape Maintainer:        rd@slavepianos.org Stability:         Experimental-Homepage:          http://slavepianos.org/rd/?t=hdf-Tested-With:       GHC == 7.2.2+Homepage:          http://rd.slavepianos.org/?t=hdf+Tested-With:       GHC == 7.6.1 Build-Type:        Simple Cabal-Version:     >= 1.8  Data-files:        README-                   -- The below is appended by:-                   -- find Help -name "*.[l]hs" | sort | \-                   -- sed "s/^/                   /"-                   Help/Graphs/analog-bubbles.lhs-                   Help/Graphs/lfo-modulation.lhs-                   Help/Graphs/moto-rev.lhs-                   Help/Graphs/sprinkler.lhs-                   Help/UGen/Filter/buf_comb_n.help.lhs-                   Help/UGen/Filter/decay.help.lhs-                   Help/UGen/Filter/iir2.help.lhs-                   Help/UGen/Filter/lag.help.lhs-                   Help/UGen/Filter/latch.help.lhs-                   Help/UGen/Filter/lin_exp.help.lhs-                   Help/UGen/Filter/lin_lin.help.lhs-                   Help/UGen/Filter/resonz.help.lhs-                   Help/UGen/Filter/rlpf.help.lhs-                   Help/UGen/Noise/brown_noise.help.lhs-                   Help/UGen/Noise/white_noise.help.lhs-                   Help/UGen/Oscillator/impulse.help.lhs-                   Help/UGen/Oscillator/lf_pulse.help.lhs-                   Help/UGen/Oscillator/lf_saw.help.lhs-                   Help/UGen/Oscillator/sin_osc.help.lhs+                   c/*.c+                   c/*.h+                   gr/*.hs+                   Help/*.lhs+                   Help/dot/*.dot  Library   Build-Depends:   base == 4.*,                    directory,                    fgl,                    filepath,-                   hosc == 0.11.*,-                   process+                   hosc == 0.14.*,+                   hsc3 == 0.14.*,+                   murmur-hash,+                   process,+                   sc3-rdu == 0.14.*,+                   split,+                   transformers   GHC-Options:     -Wall -fwarn-tabs-  Exposed-modules: Sound.DF-                   Sound.DF.Audition-                   Sound.DF.CGen-                   Sound.DF.Draw-                   Sound.DF.Graph-                   Sound.DF.Node-                   Sound.DF.UGen+  Exposed-modules: Sound.DF.Uniform.LL+                   Sound.DF.Uniform.LL.Audition+                   Sound.DF.Uniform.LL.CGen+                   Sound.DF.Uniform.LL.Command+                   Sound.DF.Uniform.LL.Dot+                   Sound.DF.Uniform.LL.K+                   Sound.DF.Uniform.LL.UId +                   Sound.DF.Uniform.UDF++                   Sound.DF.Uniform.PhT+                   Sound.DF.Uniform.PhT.Audition+                   Sound.DF.Uniform.PhT.Draw+                   Sound.DF.Uniform.PhT.Node++                   Sound.DF.Uniform.GADT+                   Sound.DF.Uniform.GADT.Audition+                   Sound.DF.Uniform.GADT.DF+                   Sound.DF.Uniform.GADT.Draw+                   Sound.DF.Uniform.GADT.UGen+                   Sound.DF.Uniform.GADT.UGen.Monadic++                   Sound.DF.Uniform.Faust+ Source-Repository  head   Type:            darcs-  Location:        http://slavepianos.org/rd/sw/hdf/+  Location:        http://rd.slavepianos.org/sw/hdf/