diff --git a/Help/Graphs/analog-bubbles.lhs b/Help/Graphs/analog-bubbles.lhs deleted file mode 100644 --- a/Help/Graphs/analog-bubbles.lhs +++ /dev/null @@ -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)) diff --git a/Help/Graphs/lfo-modulation.lhs b/Help/Graphs/lfo-modulation.lhs deleted file mode 100644 --- a/Help/Graphs/lfo-modulation.lhs +++ /dev/null @@ -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)) diff --git a/Help/Graphs/moto-rev.lhs b/Help/Graphs/moto-rev.lhs deleted file mode 100644 --- a/Help/Graphs/moto-rev.lhs +++ /dev/null @@ -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)) diff --git a/Help/Graphs/sprinkler.lhs b/Help/Graphs/sprinkler.lhs deleted file mode 100644 --- a/Help/Graphs/sprinkler.lhs +++ /dev/null @@ -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))) } diff --git a/Help/UGen/Filter/buf_comb_n.help.lhs b/Help/UGen/Filter/buf_comb_n.help.lhs deleted file mode 100644 --- a/Help/UGen/Filter/buf_comb_n.help.lhs +++ /dev/null @@ -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) } diff --git a/Help/UGen/Filter/decay.help.lhs b/Help/UGen/Filter/decay.help.lhs deleted file mode 100644 --- a/Help/UGen/Filter/decay.help.lhs +++ /dev/null @@ -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)) } diff --git a/Help/UGen/Filter/iir2.help.lhs b/Help/UGen/Filter/iir2.help.lhs deleted file mode 100644 --- a/Help/UGen/Filter/iir2.help.lhs +++ /dev/null @@ -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)) } diff --git a/Help/UGen/Filter/lag.help.lhs b/Help/UGen/Filter/lag.help.lhs deleted file mode 100644 --- a/Help/UGen/Filter/lag.help.lhs +++ /dev/null @@ -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)) } } - diff --git a/Help/UGen/Filter/latch.help.lhs b/Help/UGen/Filter/latch.help.lhs deleted file mode 100644 --- a/Help/UGen/Filter/latch.help.lhs +++ /dev/null @@ -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)) } diff --git a/Help/UGen/Filter/lin_exp.help.lhs b/Help/UGen/Filter/lin_exp.help.lhs deleted file mode 100644 --- a/Help/UGen/Filter/lin_exp.help.lhs +++ /dev/null @@ -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)) } diff --git a/Help/UGen/Filter/lin_lin.help.lhs b/Help/UGen/Filter/lin_lin.help.lhs deleted file mode 100644 --- a/Help/UGen/Filter/lin_lin.help.lhs +++ /dev/null @@ -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)) } diff --git a/Help/UGen/Filter/resonz.help.lhs b/Help/UGen/Filter/resonz.help.lhs deleted file mode 100644 --- a/Help/UGen/Filter/resonz.help.lhs +++ /dev/null @@ -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) } diff --git a/Help/UGen/Filter/rlpf.help.lhs b/Help/UGen/Filter/rlpf.help.lhs deleted file mode 100644 --- a/Help/UGen/Filter/rlpf.help.lhs +++ /dev/null @@ -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) } diff --git a/Help/UGen/Noise/brown_noise.help.lhs b/Help/UGen/Noise/brown_noise.help.lhs deleted file mode 100644 --- a/Help/UGen/Noise/brown_noise.help.lhs +++ /dev/null @@ -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)) } } diff --git a/Help/UGen/Noise/white_noise.help.lhs b/Help/UGen/Noise/white_noise.help.lhs deleted file mode 100644 --- a/Help/UGen/Noise/white_noise.help.lhs +++ /dev/null @@ -1,4 +0,0 @@ -> import Sound.DF - -> do { n <- white_noise_m -> ; audition [] (out1 (n * 0.1)) } diff --git a/Help/UGen/Oscillator/impulse.help.lhs b/Help/UGen/Oscillator/impulse.help.lhs deleted file mode 100644 --- a/Help/UGen/Oscillator/impulse.help.lhs +++ /dev/null @@ -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)) } diff --git a/Help/UGen/Oscillator/lf_pulse.help.lhs b/Help/UGen/Oscillator/lf_pulse.help.lhs deleted file mode 100644 --- a/Help/UGen/Oscillator/lf_pulse.help.lhs +++ /dev/null @@ -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) } diff --git a/Help/UGen/Oscillator/lf_saw.help.lhs b/Help/UGen/Oscillator/lf_saw.help.lhs deleted file mode 100644 --- a/Help/UGen/Oscillator/lf_saw.help.lhs +++ /dev/null @@ -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)) } diff --git a/Help/UGen/Oscillator/sin_osc.help.lhs b/Help/UGen/Oscillator/sin_osc.help.lhs deleted file mode 100644 --- a/Help/UGen/Oscillator/sin_osc.help.lhs +++ /dev/null @@ -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)) } diff --git a/Help/dot/counter-gr.dot b/Help/dot/counter-gr.dot new file mode 100644 --- /dev/null +++ b/Help/dot/counter-gr.dot @@ -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)"] +} diff --git a/Help/dot/counter.dot b/Help/dot/counter.dot new file mode 100644 --- /dev/null +++ b/Help/dot/counter.dot @@ -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|}}"]; +5 [shape="record",color="blue",label="{{df_add|||}}"]; +6 [shape="record",color="blue",label="{{1.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=""] +} diff --git a/Help/hdf.lhs b/Help/hdf.lhs new file mode 100644 --- /dev/null +++ b/Help/hdf.lhs @@ -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) diff --git a/README b/README --- a/README +++ b/README @@ -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/ diff --git a/Sound/DF.hs b/Sound/DF.hs deleted file mode 100644 --- a/Sound/DF.hs +++ /dev/null @@ -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 diff --git a/Sound/DF/Audition.hs b/Sound/DF/Audition.hs deleted file mode 100644 --- a/Sound/DF/Audition.hs +++ /dev/null @@ -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"))) diff --git a/Sound/DF/CGen.hs b/Sound/DF/CGen.hs deleted file mode 100644 --- a/Sound/DF/CGen.hs +++ /dev/null @@ -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 " - , "#include " - , "#include " - , "#include " - , "#include "] - 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); }" - ] diff --git a/Sound/DF/Draw.hs b/Sound/DF/Draw.hs deleted file mode 100644 --- a/Sound/DF/Draw.hs +++ /dev/null @@ -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 () diff --git a/Sound/DF/Graph.hs b/Sound/DF/Graph.hs deleted file mode 100644 --- a/Sound/DF/Graph.hs +++ /dev/null @@ -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) diff --git a/Sound/DF/Node.hs b/Sound/DF/Node.hs deleted file mode 100644 --- a/Sound/DF/Node.hs +++ /dev/null @@ -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)) diff --git a/Sound/DF/UGen.hs b/Sound/DF/UGen.hs deleted file mode 100644 --- a/Sound/DF/UGen.hs +++ /dev/null @@ -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 diff --git a/Sound/DF/Uniform/Faust.hs b/Sound/DF/Uniform/Faust.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/Faust.hs @@ -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) diff --git a/Sound/DF/Uniform/GADT.hs b/Sound/DF/Uniform/GADT.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/GADT.hs @@ -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 diff --git a/Sound/DF/Uniform/GADT/Audition.hs b/Sound/DF/Uniform/GADT/Audition.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/GADT/Audition.hs @@ -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) diff --git a/Sound/DF/Uniform/GADT/DF.hs b/Sound/DF/Uniform/GADT/DF.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/GADT/DF.hs @@ -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) diff --git a/Sound/DF/Uniform/GADT/Draw.hs b/Sound/DF/Uniform/GADT/Draw.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/GADT/Draw.hs @@ -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 diff --git a/Sound/DF/Uniform/GADT/UGen.hs b/Sound/DF/Uniform/GADT/UGen.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/GADT/UGen.hs @@ -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 +-- 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 diff --git a/Sound/DF/Uniform/GADT/UGen/Monadic.hs b/Sound/DF/Uniform/GADT/UGen/Monadic.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/GADT/UGen/Monadic.hs @@ -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 diff --git a/Sound/DF/Uniform/LL.hs b/Sound/DF/Uniform/LL.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/LL.hs @@ -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 diff --git a/Sound/DF/Uniform/LL/Audition.hs b/Sound/DF/Uniform/LL/Audition.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/LL/Audition.hs @@ -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 () diff --git a/Sound/DF/Uniform/LL/CGen.hs b/Sound/DF/Uniform/LL/CGen.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/LL/CGen.hs @@ -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 " + ,"#include " + ,"#include " + ,"#include " + ,"#include " + ,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" == "" +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 (+) + diff --git a/Sound/DF/Uniform/LL/Command.hs b/Sound/DF/Uniform/LL/Command.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/LL/Command.hs @@ -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" [] diff --git a/Sound/DF/Uniform/LL/Dot.hs b/Sound/DF/Uniform/LL/Dot.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/LL/Dot.hs @@ -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_k + Right i_k -> k_concise i_k + ip = if null ar + then "" + else '|' : intercalate "|" (map mk_i ar) + op = maybe "" (const "|") 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' diff --git a/Sound/DF/Uniform/LL/K.hs b/Sound/DF/Uniform/LL/K.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/LL/K.hs @@ -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 diff --git a/Sound/DF/Uniform/LL/UId.hs b/Sound/DF/Uniform/LL/UId.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/LL/UId.hs @@ -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 diff --git a/Sound/DF/Uniform/PhT.hs b/Sound/DF/Uniform/PhT.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/PhT.hs @@ -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 diff --git a/Sound/DF/Uniform/PhT/Audition.hs b/Sound/DF/Uniform/PhT/Audition.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/PhT/Audition.hs @@ -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) diff --git a/Sound/DF/Uniform/PhT/Draw.hs b/Sound/DF/Uniform/PhT/Draw.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/PhT/Draw.hs @@ -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 diff --git a/Sound/DF/Uniform/PhT/Node.hs b/Sound/DF/Uniform/PhT/Node.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/PhT/Node.hs @@ -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)))) diff --git a/Sound/DF/Uniform/UDF.hs b/Sound/DF/Uniform/UDF.hs new file mode 100644 --- /dev/null +++ b/Sound/DF/Uniform/UDF.hs @@ -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) diff --git a/c/hdf.h b/c/hdf.h new file mode 100644 --- /dev/null +++ b/c/hdf.h @@ -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;} diff --git a/c/text-dl.c b/c/text-dl.c new file mode 100644 --- /dev/null +++ b/c/text-dl.c @@ -0,0 +1,68 @@ +#include +#include +#include +#include +#include +#include +#include +#include + +#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; +} diff --git a/c/text-dl.h b/c/text-dl.h new file mode 100644 --- /dev/null +++ b/c/text-dl.h @@ -0,0 +1,22 @@ +#include + +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) diff --git a/gr/analog-bubbles-buf-m.hs b/gr/analog-bubbles-buf-m.hs new file mode 100644 --- /dev/null +++ b/gr/analog-bubbles-buf-m.hs @@ -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) diff --git a/gr/analog-bubbles-buf.hs b/gr/analog-bubbles-buf.hs new file mode 100644 --- /dev/null +++ b/gr/analog-bubbles-buf.hs @@ -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 diff --git a/gr/analog-bubbles-m.hs b/gr/analog-bubbles-m.hs new file mode 100644 --- /dev/null +++ b/gr/analog-bubbles-m.hs @@ -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) diff --git a/gr/analog-bubbles.hs b/gr/analog-bubbles.hs new file mode 100644 --- /dev/null +++ b/gr/analog-bubbles.hs @@ -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 diff --git a/gr/ctl1.hs b/gr/ctl1.hs new file mode 100644 --- /dev/null +++ b/gr/ctl1.hs @@ -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) diff --git a/gr/drummer.hs b/gr/drummer.hs new file mode 100644 --- /dev/null +++ b/gr/drummer.hs @@ -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 diff --git a/gr/fig-3-6-m.hs b/gr/fig-3-6-m.hs new file mode 100644 --- /dev/null +++ b/gr/fig-3-6-m.hs @@ -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' diff --git a/gr/fig-3-6.hs b/gr/fig-3-6.hs new file mode 100644 --- /dev/null +++ b/gr/fig-3-6.hs @@ -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' diff --git a/gr/lfo-modulation-buf-m.hs b/gr/lfo-modulation-buf-m.hs new file mode 100644 --- /dev/null +++ b/gr/lfo-modulation-buf-m.hs @@ -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) diff --git a/gr/lfo-modulation-buf.hs b/gr/lfo-modulation-buf.hs new file mode 100644 --- /dev/null +++ b/gr/lfo-modulation-buf.hs @@ -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 diff --git a/gr/lfo-modulation-m.hs b/gr/lfo-modulation-m.hs new file mode 100644 --- /dev/null +++ b/gr/lfo-modulation-m.hs @@ -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) diff --git a/gr/lfo-modulation.hs b/gr/lfo-modulation.hs new file mode 100644 --- /dev/null +++ b/gr/lfo-modulation.hs @@ -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 diff --git a/gr/moto-rev-m.hs b/gr/moto-rev-m.hs new file mode 100644 --- /dev/null +++ b/gr/moto-rev-m.hs @@ -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 diff --git a/gr/moto-rev.hs b/gr/moto-rev.hs new file mode 100644 --- /dev/null +++ b/gr/moto-rev.hs @@ -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 diff --git a/gr/pass-through.hs b/gr/pass-through.hs new file mode 100644 --- /dev/null +++ b/gr/pass-through.hs @@ -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 diff --git a/gr/silence.hs b/gr/silence.hs new file mode 100644 --- /dev/null +++ b/gr/silence.hs @@ -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 diff --git a/gr/sprinkler-m.hs b/gr/sprinkler-m.hs new file mode 100644 --- /dev/null +++ b/gr/sprinkler-m.hs @@ -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 [] + diff --git a/gr/sprinkler.hs b/gr/sprinkler.hs new file mode 100644 --- /dev/null +++ b/gr/sprinkler.hs @@ -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 + diff --git a/hdf.cabal b/hdf.cabal --- a/hdf.cabal +++ b/hdf.cabal @@ -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 . + Requires either the @RDL@ UGen from @sc3-rdu@ or + the @jack-dl@ host from @rju@. + . + See + or . 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/