hsc3-data (empty) → 0.15

raw patch · 8 files changed

+924/−0 lines, 8 filesdep +Globdep +SVGPathdep +basesetup-changed

Dependencies added: Glob, SVGPath, base, bifunctors, hcg-minus, hmt, hsc3-lang, hsc3-plot, hsc3-sf-hsndfile, safe, split, xml

Files

README +12/−0
Setup.hs +3/−0
Sound/SC3/Data/Math/Bourke.hs +86/−0
Sound/SC3/Data/Math/Loudness.hs +121/−0
Sound/SC3/Data/Math/Sprott_1993a.hs +304/−0
Sound/SC3/Data/SVG.hs +51/−0
Sound/SC3/Data/Trace.hs +307/−0
hsc3-data.cabal +40/−0

+ README view

@@ -0,0 +1,12 @@+hsc3-data - data functions for SC3 related work+-----------------------------------------------++[hs]: http://haskell.org/+[sc3]: http://audiosynth.com/+[hsc3]: http://rd.slavepianos.org/?t=hsc3+[hsc3-data]: http://rd.slavepianos.org/?t=hsc3-data++© [rohan drape][rd], 2013-2014, [gpl]++[rd]: http://rd.slavepianos.org/+[gpl]: http://gnu.org/copyleft/

+ Setup.hs view

@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+import Distribution.Simple+main = defaultMain

+ Sound/SC3/Data/Math/Bourke.hs view

@@ -0,0 +1,86 @@+-- | <http://paulbourke.net/>+module Sound.SC3.Data.Math.Bourke where++-- | 2-element /h/ transform.+h_transform_2 :: Num t => t -> ((t,t) -> (t,t)) -> (t,t) -> (t,t)+h_transform_2 h f (x,y) =+    let (x',y') = f (x,y)+    in (x + h * x',y + h * y')++-- | 3-element /h/ transform.+h_transform_3 :: Num t => t -> ((t,t,t) -> (t,t,t)) -> (t,t,t) -> (t,t,t)+h_transform_3 h f (x,y,z) =+    let (x',y',z') = f (x,y,z)+    in (x + h * x',y + h * y',z + h * z')++-- | <http://paulbourke.net/fractals/lorenz/>+lorenz :: Num t => t -> t -> t -> (t,t,t) -> (t,t,t)+lorenz a b c (x,y,z) =+    (a * (y - x)+    ,x * (b - z) - y+    ,x * y - c * z)++{- | <http://paulbourke.net/fractals/lorenz/>++> import Sound.SC3.Plot {- hsc3-plot -}++> let l = iterate (lorenz_h 0.01 10 28 (8/3)) (0.1,0.0,0.0)+> in plot_p3_ln [take 5000 l]++> let {l = iterate (lorenz_h 0.01 10 28 (8/3)) (0.1,0.0,0.0)+>     ;f (x,_,z) = (x,z)}+> in plot_p2_ln [take 15000 (map f l)]++-}+lorenz_h :: Num t => t -> t -> t -> t -> (t,t,t) -> (t,t,t)+lorenz_h h a b c = h_transform_3 h (lorenz a b c)++-- | <http://paulbourke.net/fractals/rossler/>+rossler :: Num t => t -> t -> t -> (t, t, t) -> (t, t, t)+rossler a b c (x,y,z) =+    (negate y - z+    ,x + a * y+    ,b + z * (x - c))++{- | <http://paulbourke.net/fractals/rossler/>++> plot_p3_ln [take 5000 (iterate (rossler_h 0.02 0.2 0.2 5.7) (0.1,0,0))]++-}+rossler_h :: Num t => t -> t -> t -> t -> (t,t,t) -> (t,t,t)+rossler_h h a b c = h_transform_3 h (rossler a b c)++{- | <http://paulbourke.net/fractals/peterdejong/>++> let pdj a b c d =+>   let vw x = plot_p2_pt [take 15000 x]+>   in vw (iterate (peter_de_jong a b c d) (-0.72,-0.64))++> pdj 1.4 (-2.3) 2.4 (-2.1)+> pdj 2.01 (-2.53) 1.61 (-0.33)+> pdj (-2.7) (-0.09) (-0.86) (-2.2)+> pdj (-2.24) 0.43 (-0.65) (-2.43)+> pdj (-2.0) (-2.0) (-1.2) 2.0++-}+peter_de_jong :: Floating t => t -> t -> t -> t -> (t, t) -> (t, t)+peter_de_jong a b c d (x,y) =+    (sin (a * y) - cos (b * x)+    ,sin (c * x) - cos (d * y))++{- | <http://paulbourke.net/fractals/clifford/>++> let clf a b c d =+>   let vw x = plot_p2_pt [take 12500 x]+>   in vw (iterate (clifford a b c d) (-0.72,-0.64))++> clf (-1.4) (1.6) (1.0) (0.7)+> clf (1.1) (-1.0) (1.0) (1.5) {- not as pb indicates -}+> clf (1.6) (-0.6) (-1.2) (1.6)+> clf (1.7) (1.7) (0.6) (1.2)++-}+clifford :: Floating t => t -> t -> t -> t -> (t, t) -> (t, t)+clifford a b c d (x,y) =+    (sin (a * y) + c * cos (a * x)+    ,sin (b * x) + d * cos (b * y))

+ Sound/SC3/Data/Math/Loudness.hs view

@@ -0,0 +1,121 @@+-- | Perceptual loudness functions.+module Sound.SC3.Data.Math.Loudness where++-- * A Weighting++{- | A-weighting curve multiplier function, ie. for linear magnitude+-- value.  See <http://en.wikipedia.org/wiki/A-weighting>++> import Sound.SC3.Plot++> let {f w = map w [20::Double,50 .. 20000]+>     ;r = [a_weighting_R,b_weighting_R,c_weighting_R,d_weighting_R]}+> in plotTable (map f r)++> let {f w = zip (map log [1..]) (map w [25,50 .. 20000])+>     ;r = [a_weighting_R,b_weighting_R,c_weighting_R,d_weighting_R]}+> in plot_p2_ln (map f r)++-}+a_weighting_R :: Floating a => a -> a+a_weighting_R f =+    let sq x = x * x+        dot = foldl1 (*)+        n = dot [sq 12200+                ,f ** 4]+        d = dot [sq f + sq 20.6+                ,sqrt ((sq f + sq 107.7) * (sq f + sq 737.9))+                ,sq f + sq 12200]+    in n / d++-- | A-weighting curve Db offset (additive) function, ie. for+-- un-weighted Db readings.+--+-- > plotTable1 (map a_weighting [20,50 .. 20000])+-- > plot_p2_ln [zip (map log [1..]) (map a_weighting [25,50 .. 20000])]+a_weighting :: Floating a => a -> a+a_weighting f = 2 + 20 * logBase 10 (a_weighting_R f)++-- * B Weighting++-- | B-weighting curve multiplier function, ie. for linear magnitude+-- value.  See <http://en.wikipedia.org/wiki/A-weighting>+--+-- > import Sound.SC3.Plot+-- > plotTable1 (map b_weighting_R [20,50 .. 20000])+-- > plot_p2_ln [zip (map log [1..]) (map b_weighting_R [25,50 .. 20000])]+b_weighting_R :: Floating a => a -> a+b_weighting_R f =+    let sq x = x * x+        dot = foldl1 (*)+        n = dot [sq 12200+                ,f ** 3]+        d = dot [sq f + sq 20.6+                ,sqrt (sq f + sq 158.5)+                ,sq f + sq 12200]+    in n / d++-- | B-weighting curve Db offset (additive) function, ie. for+-- un-weighted Db readings.+--+-- > plotTable1 (map b_weighting [20,50 .. 20000])+-- > plot_p2_ln [zip (map log [1..]) (map b_weighting [25,50 .. 20000])]+b_weighting :: Floating a => a -> a+b_weighting f = 0.17 + 20 * logBase 10 (b_weighting_R f)++-- * C Weighting++-- | C-weighting curve multiplier function, ie. for linear magnitude+-- value.  See <http://en.wikipedia.org/wiki/A-weighting>+--+-- > import Sound.SC3.Plot+-- > plotTable1 (map c_weighting_R [20,50 .. 20000])+-- > plot_p2_ln [zip (map log [1..]) (map c_weighting_R [25,50 .. 20000])]+c_weighting_R :: Floating a => a -> a+c_weighting_R f =+    let sq x = x * x+        dot = foldl1 (*)+        n = dot [sq 12200+                ,f ** 2]+        d = dot [sq f + sq 20.6+                ,sq f + sq 12200]+    in n / d++-- | C-weighting curve Db offset (additive) function, ie. for+-- un-weighted Db readings.+--+-- > plotTable1 (map c_weighting [20,50 .. 20000])+-- > plot_p2_ln [zip (map log [1..]) (map c_weighting [25,50 .. 20000])]+c_weighting :: Floating a => a -> a+c_weighting f = 0.06 + 20 * logBase 10 (c_weighting_R f)++-- * D Weighting++-- | /h/ function for D weighting.+d_h_function :: Fractional a => a -> a+d_h_function f =+    let sq x = x * x+        n = sq (1037918.48 - sq f) + (1080768.16 * sq f)+        d = sq (9837328 - sq f) + (11723776 * sq f)+    in n / d++-- | D-weighting curve multiplier function, ie. for linear magnitude+-- value.  See <http://en.wikipedia.org/wiki/A-weighting>+--+-- > import Sound.SC3.Plot+-- > plotTable1 (map d_weighting_R [20,50 .. 20000])+-- > plot_p2_ln [zip (map log [1..]) (map d_weighting_R [25,50 .. 20000])]+d_weighting_R :: Floating a => a -> a+d_weighting_R f =+    let sq x = x * x+        a = f / (6.8966888496476 * (10 ** (-5)))+        b = sqrt (d_h_function f / ((sq f + 79919.29) * (sq f + 1345600)))+    in a * b++-- | D-weighting curve Db offset (additive) function, ie. for+-- un-weighted Db readings.+--+-- > plotTable1 (map d_weighting [20,50 .. 20000])+-- > plot_p2_ln [zip (map log [1..]) (map d_weighting [25,50 .. 20000])]+d_weighting :: Floating a => a -> a+d_weighting f = 20 * logBase 10 (d_weighting_R f)

+ Sound/SC3/Data/Math/Sprott_1993a.hs view

@@ -0,0 +1,304 @@+-- | <http://sprott.physics.wisc.edu/sa.htm>+module Sound.SC3.Data.Math.Sprott_1993a where++import Data.Maybe {- base -}++import Sound.SC3.Plot {- hsc3-plot -}++-- * Coding Table++-- | Table 2-1. ASCII character set and associated coefficient values (p.28)+sprott_tbl_2_1 :: [(Char,Int,Double)]+sprott_tbl_2_1 =+    let i = [32 .. 127]+        n = map (/ 10) [-45,-44 .. 50]+        c = map toEnum i+    in zip3 c i n++-- | Lookup coeffient at 'sprott_tbl_2_1'.+--+-- > sprott_coef 'M' == Just 0+sprott_coef :: Char -> Maybe Double+sprott_coef c =+    let (ch,_,cf) = unzip3 sprott_tbl_2_1+    in lookup c (zip ch cf)++-- | 'fromJust' of 'sprott_coef'.+sprott_coef_err :: Char -> Double+sprott_coef_err = fromJust . sprott_coef++-- * General forms++-- | Pair each elements with the element /n/ places further along.+--+-- > with_delayed 3 [1..9] == [(1,4),(2,5),(3,6),(4,7),(5,8),(6,9)]+with_delayed :: Int -> [t] -> [(t,t)]+with_delayed n l =+    case l of+      [] -> []+      e0:l' -> case drop n l of+                 [] -> []+                 e1:_ -> (e0,e1) : with_delayed n l'++{- hsc3-plot...++-- | /n/ '*' /n/.+square :: Num a => a -> a+square x = x * x++-}++-- | General one-dimensional quadratic iterated map (Equation 2A, p.25)+quadratic_1 :: Num a => a -> a -> a -> a -> a+quadratic_1 a1 a2 a3 x = a1 + a2 * x + a3 * square x++-- | List (/l/) variant of 'quadratic_1'.+quadratic_1l :: Num a => [a] -> a -> a+quadratic_1l l =+    case l of+      [a1,a2,a3] -> quadratic_1 a1 a2 a3+      _ -> error "quadratic_1l"++-- | General one-dimensional quintic iterated map (Equation 2E, p.41)+quintic_1 :: Num a => a -> a -> a -> a -> a -> a -> a -> a+quintic_1 a1 a2 a3 a4 a5 a6 x =+    let f :: Num a => Integer -> a -> a+        f k n = if k == 1 then n else n * f (k - 1) n+    in a1 + a2 * x + a3 * f 2 x + a4 * f 3 x + a5 * f 4 x + a6 * f 5 x++-- | List (/l/) variant of 'quintic_1'.+quintic_1l :: Num a => [a] -> a -> a+quintic_1l l =+    case l of+      [a1,a2,a3,a4,a5,a6] -> quintic_1 a1 a2 a3 a4 a5 a6+      _ -> error "quintic_1l"++-- | Generalised one-dimensional iterated map.+general_1l :: Num a => [a] -> Maybe (a -> a)+general_1l l =+     case length l of+       3 -> Just (quadratic_1l l)+       4 -> Just (quintic_1l (l ++ [0,0]))+       5 -> Just (quintic_1l (l ++ [0]))+       6 -> Just (quintic_1l l)+       _ -> Nothing++-- | General two-dimensional iterated quadratic map (Equation 3B, p.53)+quadratic_2 :: Num t => t->t->t->t->t->t->t->t->t->t->t->t->(t,t)->(t,t)+quadratic_2 a1 a2 a3 a4 a5 a6 a7 a8 a9 aA aB aC (x,y) =+    let sq n = n * n+        x' = a1 + a2 * x + a3 * sq x + a4 * x * y + a5 * y + a6 * sq y+        y' = a7 + a8 * x + a9 * sq x + aA * x * y + aB * y + aC * sq y+    in (x',y')++-- | List (/l/) variant of 'quadratic_2'.+quadratic_2l :: Num t => [t] -> (t,t) -> (t,t)+quadratic_2l l =+    case l of+      [a1,a2,a3,a4,a5,a6,a7,a8,a9,aA,aB,aC] ->+        quadratic_2 a1 a2 a3 a4 a5 a6 a7 a8 a9 aA aB aC+      _ -> error "quadratic_2l"++-- | General two-dimensional iterated cubic map (Equation 3F, p.80)+cubic_2 :: Num t => t->t->t->t->t->t->t->t->t->t->t->t->t->t->t->t->t->t->t->t->(t,t)->(t,t)+cubic_2 a1 a2 a3 a4 a5 a6 a7 a8 a9 aA aB aC aD aE aF aG aH aI aJ aK (x,y) =+    let sq n = n * n+        cb n = n * n * n+        x' = a1 + a2 * x + a3 * sq x + a4 * cb x + a5 * sq x * y ++             a6 * x * y + a7 * x * sq y + a8 * y + a9 * sq y + aA * cb y+        y' = aB + aC * x + aD * sq x + aE * cb x + aF * sq x * y ++             aG * x * y + aH * x * sq y + aI * y + aJ * sq y + aK * cb y+    in (x',y')++-- | List (/l/) variant of 'cubic_2'.+cubic_2l :: Num t => [t] -> (t,t) -> (t,t)+cubic_2l l =+    case l of+      [a1,a2,a3,a4,a5,a6,a7,a8,a9,aA,aB,aC,aD,aE,aF,aG,aH,aI,aJ,aK] ->+        cubic_2 a1 a2 a3 a4 a5 a6 a7 a8 a9 aA aB aC aD aE aF aG aH aI aJ aK+      _ -> error "cubic_2l"+++-- | Generalised two-dimensional iterated map.+general_2l :: Num t => [t] -> Maybe ((t,t) -> (t,t))+general_2l l =+    case length l of+      12 -> Just (quadratic_2l l)+      20 -> Just (cubic_2l l)+      _ -> Nothing++-- | General three-dimensional iterated quadratic map (Equation 4A, p.147)+quadratic_3 :: Num t => t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> t -> (t, t, t) -> (t, t, t)+quadratic_3 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10+            a11 a12 a13 a14 a15 a16 a17 a18 a19 a20+            a21 a22 a23 a24 a25 a26 a27 a28 a29 a30 (x,y,z) =+    let sq n = n * n+        x' = a1 + a2 * x + a3 * sq x + a4 * x * y + a5 * x * z ++             a6 * y + a7 * sq y + a8 * y * z + a9 * z + a10 * sq z+        y' = a11 + a12 * x + a13 * sq x + a14 * x * y + a15 * x * z ++             a16 * y + a17 * sq y + a18 * y * z + a19 * z + a20 * sq z+        z' = a21 + a22 * x + a23 * sq x + a24 * x * y + a25 * x * z ++             a26 * y + a27 * sq y + a28 * y * z + a29 * z + a30 * sq z+    in (x',y',z')++-- | List (/l/) variant of 'quadratic_3'.+quadratic_3l :: Num t => [t] -> (t, t, t) -> (t, t, t)+quadratic_3l l =+    case l of+      [a1,a2,a3,a4,a5,a6,a7,a8,a9,a10,+       a11,a12,a13,a14,a15,a16,a17,a18,a19,a20,+       a21,a22,a23,a24,a25,a26,a27,a28,a29,a30] ->+        quadratic_3 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10+                a11 a12 a13 a14 a15 a16 a17 a18 a19 a20+                a21 a22 a23 a24 a25 a26 a27 a28 a29 a30+      _ -> error "quadratic_3l"++-- | Generalised three-dimensional iterated map.+general_3l :: Num t => [t] -> Maybe ((t,t,t) -> (t,t,t))+general_3l l =+    case length l of+      30 -> Just (quadratic_3l l)+      _ -> Nothing++-- * Projections++-- | Projection onto sphere (Equation 3G, p.107)+sphere_proj :: (Floating t,Ord t) => [(t,t)] -> [(t,t)]+sphere_proj l =+    let (xs,ys) = unzip l+        (x0,x1) = minmax xs+        (y0,y1) = minmax ys+        xa = (x0 + x1) / 2+        ya = (y0 + y1) / 2+        tt = pi / (x1 - x0)+        pt = pi / (y1 - y0)+        prj (x,y) = let th = tt * (x1 - x)+                        ph = pt * (y1 - y)+                    in (xa + 0.36 * (x1 - x0) * cos th * sin ph+                       ,ya + 0.5 * (y1 - y0) * cos ph)+    in map prj l++-- * Code Plotting++-- | Plot one-dimensional code, /m/ is delay, /n/ is iteration degree, /i/ is initial value.+plot_code_1 :: Int -> Int -> Double -> (Code,Annotation) -> IO ()+plot_code_1 m n i (c,_) =+    case c of+      c0:c' -> if c0 `elem` "ABCD"+               then case general_1l (map sprott_coef_err c') of+                      Just f -> plot_p2_pt [with_delayed m (take n (iterate f i))]+                      Nothing -> error "plot_code_1: ill-formed coef"+               else error "plot_code_1: not type {A,B,C,D}"+      _ -> error "plot_code_1: ill-formed code"++-- | Plot two-dimensional code, /n/ is iteration degree, /i/ is initial value.+plot_code_2 :: Bool -> Int -> (Double,Double) -> (Code,Annotation) -> IO ()+plot_code_2 sph n i (c,_) =+    case c of+      c0:c' -> if c0 `elem` "EF"+               then case general_2l (map sprott_coef_err c') of+                      Just f -> let prj = if sph then sphere_proj else id+                                in plot_p2_pt [prj (take n (iterate f i))]+                      Nothing -> error "plot_code_2: ill-formed coef"+               else error "plot_code_2: not type {E,F}"+      _ -> error "plot_code_2: ill-formed code"++-- | Plot three-dimensional code, /n/ is iteration degree, /i/ is initial value.+plot_code_3 :: Int -> (Double,Double,Double) -> (Code,Annotation) -> IO ()+plot_code_3 n i (c,_) =+    case c of+      c0:c' -> if c0 `elem` "I"+               then case general_3l (map sprott_coef_err c') of+                      Just f -> plot_p3_pt [take n (iterate f i)]+                      Nothing -> error "plot_code_3: ill-formed coef"+               else error "plot_code_3: not type {I}"+      _ -> error "plot_code_3: ill-formed code"++-- * Co-efficient codes.++-- | A code is a string.  The set of book codes are at:+-- <http://sprott.physics.wisc.edu/fractals/bookdisk/BOOKFIGS.DIC> and+-- there is a further set of codes at:+-- <http://sprott.physics.wisc.edu/fractals/bookdisk/SELECTED.DIC>+type Code = String+type Annotation = String++-- | One-dimensional codes.+--+-- > plot_code_1 5 12500 0.1 (codes_1 !! 7)+codes_1 :: [(Code,Annotation)]+codes_1 =+    [("AMu%","Fig 1-4")+    ,("AXBH","Fig 2-1")+    ,("ABDU","Fig 2-2")+    ,("ACAV","Fig 2-3")+    ,("AXDA","Fig 2-4")+    ,("BZEZK","Fig 2-5")+    ,("CBLCTX","Fig 2-6")+    ,("CUTXJE","Fig 2-7")+    ,("DBOGIZI","Fig 2-8")+    ,("DFBIEVV","Fig 2-9")+    ,("DOOYRIL","Fig 2-10")]++-- | Two-dimensional codes.+--+-- > plot_code_2 False 25000 (0.1,0) (codes_2 !! 25)+codes_2 :: [(Code,Annotation)]+codes_2 =+    [("EWM?MPMMWMMMM","Fig 3-1") -- 0+    ,("EAGHNFODVNJCP","Fig 3-2")+    ,("EBCQAFMFVPXKQ","Fig 3-3")+    ,("EDSYUECINGQNV","Fig 3-4")+    ,("EELXAPXMPQOBT","Fig 3-5")+    ,("EEYYMKTUMXUVC","Fig 3-6")+    ,("EJTTSMBOGLLQF","Fig 3-7")+    ,("ENNMJRCTVVTYG","Fig 3-8")+    ,("EOUGFJKDHSAJU","Fig 3-9")+    ,("EQKOCSIDVTPGY","Fig 3-10")+    ,("EQLOIARXYGHAJ","Fig 3-11") -- 10+    ,("ETJUBWEDNRORR","Fig 3-12")+    ,("ETSILUNDQSIFA","Fig 3-13")+    ,("EUEBJLCDISIIQ","Fig 3-14")+    ,("EVDUOTLRBKTJD","Fig 3-15")+    ,("EWLKWPSMOGIGS","Fig 3-16")+    ,("EZPMSGCNFRENG","Fig 3-17")+    ,("FIRPGVTFIDGCSXMFPKIDJ","Fig 3-18")+    ,("FISMHQCHPDFKFBKEALIFD","Fig 3-19")+    ,("FJYCBMNFNYOEPYUGHHESU","Fig 3-20")+    ,("FNUYLCURDUHQUQMRZQWQB","Fig 3-24") -- 20+    ,("ECSRKVVQLGFFS","Fig 3-42")+    ,("ECVQKGHQTPHTE","Fig 3-43")+    ,("EKPNERVOTBYCM","Fig 3-44")+    ,("EUWACXDQIGKHF","Fig 3-45")+    ,("ECMMMEWHXRMMM","Fig 3-58")+    ,("EMVWMGCMaMaRM","Fig 8-6 (Tinkerbell)")+    ,("EAEUBNVIAHERQ","SELECTED.DIC #1 (p. 583)")+    ,("EAHSVIGTJKOTB","SELECTED.DIC #1")+    ]++-- | Three-dimensional codes.+--+-- > plot_code_3 15000 (0.1,0,0) (codes_3 !! 1)+codes_3 :: [(Code,Annotation)]+codes_3 =+    [("IJKRADSXGDBHIJTQJJDICEJKYSTXFNU","Fig 4-1")+    ,("ILURCEGOHOIQFJKBSNYGSNRUKKIKIHW","Fig 4-2")+    ,("INRRXLCEYLFHYAPFSTPHHJMYRYJFBNM","Fig 4-4")+    ,("IWDWOGDGWGORJOBTUHFQBPRNTCBYQHP","Fig 4-8")]++-- > let cf = map sprott_coef_err "FUXRRRUIRDYKDUBPHHHOMOBRIRBINCS"+-- > plot_p2_pt [take 25000 (iterate (quartic_2l cf) (0.1,0))]++-- * Specialised forms++-- | Sprott p.9 (Equation 1C)+--+-- > plot_p2_pt [with_delayed 1 (take 5000 (iterate (logistic 4) 0.05))]+logistic :: Num a => a -> a -> a+logistic r x = r * x * (1 - x)++-- | Figure 3-1. The Hénon map (p.52)+--+-- > plot_p2_pt [take 5000 (iterate (henon (-1.4) 0.3) (0.1,0))]+henon :: Num t => t -> t -> (t, t) -> (t, t)+henon a b (x,y) = (1 + a * square x + b * y, x)

+ Sound/SC3/Data/SVG.hs view

@@ -0,0 +1,51 @@+-- | Load linearised path data from SVG files.+module Sound.SC3.Data.SVG where++import Data.Maybe {- base -}+import System.IO.Unsafe {- base -}+import qualified Text.XML.Light as X {- xml -}++import Graphics.SVG.ReadPath as P {- SVGPath -}++import Data.CG.Minus {- hcg-minus -}+import Sound.SC3.Plot {- hsc3-plot -}++-- | Make 'X.QName' with @svg@ 'X.qURI'.+svg_name :: String -> X.QName+svg_name nm =+    X.blank_name+         {X.qName = nm+         ,X.qURI = Just "http://www.w3.org/2000/svg"}++pathFromString' :: String -> Either String [PathCommand]+pathFromString' = Right . unsafePerformIO . P.pathFromString++parse_path :: String -> [P.PathCommand]+parse_path str =+    case pathFromString' str of+      Left err -> error err+      Right cmd -> cmd++svg_read_path_d :: String -> [[P.PathCommand]]+svg_read_path_d s =+    let p = case X.parseXMLDoc s of+              Nothing -> error "svg_read_path_d: no parse"+              Just e -> X.findElements (svg_name "path") e+        d = mapMaybe (X.findAttr (X.unqual "d")) p+    in map parse_path d++subpaths_to_ls :: (Double,Double) -> [P.PathCommand] -> [Ls Double]+subpaths_to_ls (dx,dy) r =+    case P.commandsToPoints r (dx,dy) (0,0) of+      [] -> error "subpaths_to_ls: no sub-paths"+      p -> map (map pt') p++svg_load_ls :: (Double, Double) -> FilePath -> IO [Ls Double]+svg_load_ls rs fn = do+  s <- readFile fn+  let d = svg_read_path_d s+      p = concatMap (subpaths_to_ls rs) d+  return p++plot_ls :: PNum t => [Ls t] -> IO ()+plot_ls = plotCoord . map (map pt_xy)

+ Sound/SC3/Data/Trace.hs view

@@ -0,0 +1,307 @@+module Sound.SC3.Data.Trace where++import Control.Monad {- base -}+import Data.Bifunctor {- bifunctor -}+import Data.List {- base -}+import Data.List.Split {- split -}+import Data.Maybe {- base -}+import Safe {- safe -}+import System.FilePath.Glob {- glob -}++import Data.CG.Minus {- hcg-minus -}+import qualified Music.Theory.List as T {- hmt -}+import qualified Music.Theory.Tuple as T {- hmt -}+import qualified Sound.File.HSndFile as F {- hsc3-sf-hsndfile -}+import Sound.SC3.Lang.Core {- hsc3-lang -}+import Sound.SC3.Plot {- hsc3-plot -}++{- | Traces are sequences @Ord t => [(t,a)]@ where t is ascending.++Ordinarily t is a time-point, and traces are temporal.++However /t/ may be, for instance, distance traversed so that line+segments (sequences of cartesian points) can be transformed into+Traces by associating each point with the distance along the line.++If there is an interpolation function (linear or otherwise) for the type /a/ we can lookup a value for any index /t/ in the window of the trace.++Traces can be both more accurate and more compact than sampled data streams.++Break-point envelopes are Traces where /a/ is a scalar+@(interpolation-type,value)@.++Traces are /normal/ if t0 is >= 0 and tn is <= 1.++Traces are /strictly normal/ if t0 == 0 and tn == 1.++-}+type Trace t a = [(t,a)]++-- | Start time of trace, or zero for null trace.+trace_start_time :: Num t => Trace t a -> t+trace_start_time = maybe 0 fst . headMay++-- | End time of trace, or zero for null trace.+trace_end_time :: Num t => Trace t a -> t+trace_end_time = maybe 0 fst . lastMay++-- | A trace window is a pait (t0,t1) indicating the begin and end+-- time points.+type Window t = (t,t)++-- | Start and end times of trace, or (0,0) for null trace.+trace_window :: Num t => Trace t a -> Window t+trace_window t = (trace_start_time t,trace_end_time t)++-- | Interpolation function type.+type Lerp_F t a b = (t -> a -> a -> b)++-- | Synonym for real valued time point.+type Time = R++-- * IO++-- | Load real valued trace stored as a sound file.+--+-- The temporal data is in the first channel, subsequent channels are+-- associated data points.  If set /nc/ is set it requires the file+-- have precisely the indicated number of _data_ channels, ie. /nc/+-- does not include the _temporal_ channel.+trace_load_sf :: Maybe Int -> FilePath -> IO (Trace Time [R])+trace_load_sf nc fn = do+  (h,t:d) <- F.read fn+  let nc' = F.channelCount h+  when (maybe False (/= (nc' - 1)) nc) (error "trace_load_sf: incorrect nc")+  return (zip t (transpose d))++-- | Variant for loading two-channel trace file.+trace_load_sf2 :: FilePath -> IO (Trace Time (R,R))+trace_load_sf2 =+    let f = map (bimap id T.t2)+    in fmap f . trace_load_sf (Just 2)++-- | Variant for set of traces given by 'glob' pattern'.+trace_load_sf_dir :: Maybe Int -> String -> IO [Trace Time [R]]+trace_load_sf_dir n p = do+  nm <- glob p+  mapM (trace_load_sf n) nm++trace_load_sf2_dir :: String -> IO [Trace Time (R,R)]+trace_load_sf2_dir p = do+  nm <- glob p+  mapM trace_load_sf2 nm++-- * Functor++-- | Map over trace times.+trace_map_t :: (t -> t') -> Trace t a -> Trace t' a+trace_map_t f = map (\(t,a) -> (f t,a))++-- | Map over trace values.+trace_map :: (a -> b) -> Trace t a -> Trace t b+trace_map f = map (\(t,a) -> (t,f a))++-- * Lookup++-- | Trace nodes that bracket time /t/, and trace starting from left neighbour.+--+-- > map (trace_locate (zip [0..9] ['a'..])) [-1,3.5,10]+trace_locate :: (Ord t,Fractional t) => Trace t a -> t -> Either String (((t,a),(t,a)),Trace t a)+trace_locate tr tm =+    case tr of+      p0:p1:r -> let (t0,_) = p0+                     (t1,_) = p1+                 in if tm < t0+                    then Left "trace_locate: time point before trace window"+                    else if tm <= t1+                         then Right ((p0,p1),tr)+                         else trace_locate (p1:r) tm+      _ -> Left "trace_locate: time point after trace window"++-- | 'fst' of 'trace_locate'+--+-- > trace_neighbours (zip [0..9] ['a'..]) 3.5 == Just ((3.0,'d'),(4.0,'e'))+trace_neighbours :: (Ord t,Fractional t) => Trace t a -> t -> Maybe ((t,a),(t,a))+trace_neighbours = either (const Nothing) (Just . fst) .: trace_locate++-- | 'fromJust' of 'trace_neighbours'.+trace_neighbours_err :: (Fractional t,Ord t) => Trace t a -> t -> ((t,a),(t,a))+trace_neighbours_err = fromJust .: trace_neighbours++-- | Interpolate between to trace points using given interpolation function.+trace_lerp :: Fractional t => Lerp_F t a b -> t -> (t,a) -> (t,a) -> (t,b)+trace_lerp lerp_f n (t0,d0) (t1,d1) =+    let i = (n - t0) / (t1 - t0)+    in (n,lerp_f i d0 d1)++-- | Linear interpolating lookup, ie. 'trace_lerp' of 'trace_neighbours'.+--+-- > t <- trace_load_sf2_dir "/home/rohan/sw/hsc3-data/help/au/*.txy.au"+-- > map (\z -> trace_lookup lerpn2 z 0.5) t+trace_lookup :: (Ord t,Fractional t) => Lerp_F t a b -> Trace t a -> t -> Maybe (t,b)+trace_lookup lerp_f t n =+    let f (p0,p1) = trace_lerp lerp_f n p0 p1+    in fmap f (trace_neighbours t n)++-- | 'trace_lookup' with default value.+trace_lookup_def :: (Ord t,Fractional t) => b -> Lerp_F t a b -> Trace t a -> t -> (t,b)+trace_lookup_def def lerp_f t n = maybe (n,def) id (trace_lookup lerp_f t n)++-- | 'fromJust' of 'trace_lookup'.+trace_lookup_err :: (Ord t,Fractional t) => Lerp_F t a b -> Trace t a -> t -> (t,b)+trace_lookup_err = fromJust .:: trace_lookup++trace_lookup_seq_asc :: (Ord t,Fractional t) => Lerp_F t a b -> Trace t a -> [t] -> Trace t b+trace_lookup_seq_asc lerp_f =+    let loop tr n = case n of+                      n0:n' -> case trace_locate tr n0 of+                                 Right ((p0,p1),tr') -> trace_lerp lerp_f n0 p0 p1 : loop tr' n'+                                 Left err -> error err+                      _ -> []+    in loop++-- * Operate++-- | Normalise so that 'trace_window' is (0,1).+--+-- > let r = [(0,'a'),(0.2,'b'),(1,'c')]+-- > in trace_normalise_t [(0,'a'),(1,'b'),(5,'c')] == r+trace_normalise_t :: Fractional t => Trace t a -> Trace t a+trace_normalise_t trace =+    let (t0,t1) = trace_window trace+        d = t1 - t0+        f t = ((t - t0) / d)+    in trace_map_t f trace++-- | Transform trace to an /n/-point linear form (time-points are+-- equi-distant) over indicated 'Window' (which must be ascending, ie+-- /t0/ < /t1/).+trace_linearise :: (Ord t,Fractional t) => Int -> Lerp_F t a b -> Trace t a -> Window t -> Trace t b+trace_linearise n lerp_f t (t0,t1) = trace_lookup_seq_asc lerp_f t (iota t0 t1 n)++-- | Variant where the range is derived implicity from input trace+-- ('trace_window').+--+-- > t <- trace_load_sf2_dir "/home/rohan/sw/hsc3-data/help/au/*.txy.au"+-- > plotCoord (map (trace_linearise_w 1024 lerpn . trace_map fst) t)+-- > plotCoord (map (trace_map fst) t)+-- > trace2_plot_tbl t+trace_linearise_w :: (Ord t,Fractional t) => Int -> Lerp_F t a b -> Trace t a -> Trace t b+trace_linearise_w n lerp_f t = trace_linearise n lerp_f t (trace_window t)++-- | Values only of 'trace_linearise_w'.+--+-- > plotTable (map (trace_table 1024 lerpn . trace_map fst) t)+trace_table :: (Ord t,Fractional t) => Int -> Lerp_F t a b -> Trace t a -> [b]+trace_table = map snd .:: trace_linearise_w++-- | Variant of 'trace_linearize' assuming /t/ is normalised.+--+-- > trace_rescale lerpd [(0,[1]),(2,[2])] 3 == [(0,[1]),(0.5,[1.25]),(1,[1.5])]+trace_rescale :: (Eq t,Ord t,Fractional t) => Lerp_F t a b -> Trace t a -> Int -> Trace t b+trace_rescale lerp_f t = map (trace_lookup_err lerp_f t) . iota 0 1++-- | Interpolate maintaining temporal shape, divide each step in half.+--+-- > let r = [(0,[0]),(0.5,[0.5]),(1,[1]),(2.5,[2.5]),(4,[4])]+-- > in trace_expand lerpd [(0,[0]),(1,[1]),(4,[4])] == r+--+-- > trace2_plot_3d (map (trace_expand lerpn2) t)+trace_expand :: (Fractional t) => Lerp_F t a a -> Trace t a -> Trace t a+trace_expand lerp_f t =+    let f p0 p1 = trace_lerp lerp_f (h p0 p1) p0 p1+        h (t0,_) (t1,_) = ((t1 - t0) / 2.0) + t0+        t' = zipWith f t (tail t)+    in interleave2 (t,t')++-- | Recursive expansion+--+-- > length (trace_expand_n lerpd [(0,[0]),(1,[1]),(4,[4])] 3) == 17+trace_expand_n :: (Fractional t,Integral n) => Lerp_F t a a -> Trace t a -> n -> Trace t a+trace_expand_n f t n =+    if n == 1+    then trace_expand f t+    else trace_expand_n f (trace_expand f t) (n - 1)++-- * Interpolation++-- | Linear interpolation.+--+-- > zipWith (lerpn 0.25) [4,5] [6,9] == [4.5,6.0]+lerpn :: Num a => a -> a -> a -> a+lerpn i a b = a + ((b - a) * i)++-- | Variant at uniform 2-tuple.+--+-- > lerpn2 0.25 (4,5) (6,9) == (4.5,6.0)+lerpn2 :: Num n => n -> (n,n) -> (n,n) -> (n,n)+lerpn2 i = T.t2_zipWith (lerpn i)++-- | Pointwise linear interpolation at lists.+--+-- > lerp_pw lerpn 0.25 [4,5] [6,9] == [4.5,6]+lerp_pw :: Lerp_F t a b -> t -> [a] -> [a] -> [b]+lerp_pw lerp_f i = zipWith (lerp_f i)++-- | 'lerp_pw' of 'lerpn'.+--+-- > lerpd 0.25 [4,5] [6,9] == [4.5,6]+lerpd :: Num c => c -> [c] -> [c] -> [c]+lerpd = lerp_pw lerpn++-- * Geometry++-- | Transform 'Ls' to 'Trace', /t/ is distance along line.+ls_with_distance :: (Eq t,Floating t) => Ls t -> Trace t (Pt t)+ls_with_distance p =+    let d = T.dx_d 0 (zipWith pt_distance p (tail p))+    in zip d p++-- * List++-- | Generic iota function (name courtesy scheme language) with+-- explicit increment.  The last value is the given end-point+-- regardless of accumulated errors.+--+-- > iota' 0 1 0.25 5 == [0,0.25,0.5,0.75,1]+iota' :: (Eq n,Num n,Eq m,Num m) => n -> n -> n -> m -> [n]+iota' a b i n =+    case n of+      0 -> []+      1 -> [b]+      _ -> a : iota' (a + i) b i (n - 1)++-- | Fractional iota function with implicit increment.+--+-- > iota 0 1 5 == [0,0.25,0.5,0.75,1]+iota :: (Integral m,Eq n,Fractional n) => n -> n -> m -> [n]+iota a b n = iota' a b ((b - a) / fromIntegral (n - 1)) n++-- | Alternate elements of two lists.+--+-- > interleave2 ("one","two") == "otnweo"+-- > interleave2 ("long","short") == "lsohnogrt"+interleave2 :: ([t],[t]) -> [t]+interleave2 = concat . transpose . T.t2_list++-- | Inverse of 'interleave2'.+--+-- > interleave2 ("abcd","ABCD") == "aAbBcCdD"+-- > deinterleave2 "aAbBcCdD" == ("abcd","ABCD")+deinterleave2 :: [a] -> ([a],[a])+deinterleave2 = T.t2 . transpose . chunksOf 2++-- * Plotting++-- | Three-dimensional plot of two-dimensional traces (/time/ on @x@ axis), ie. 'plotPath'.+trace2_plot_3d :: [Trace R (R,R)] -> IO ()+trace2_plot_3d = plotPath . map (map (\(t,(p,q)) -> (t,p,q)))++-- | Two-dimensional plot of two-dimensional traces (/time/ not drawn), ie. 'plotCoord'.+trace2_plot_2d :: [Trace R (R,R)] -> IO ()+trace2_plot_2d = plotCoord . map (map snd)++trace2_plot_tbl :: [Trace R (R,R)] -> IO ()+trace2_plot_tbl =+    let f t = [trace_map fst t,trace_map snd t]+    in plotCoord . concatMap f

+ hsc3-data.cabal view

@@ -0,0 +1,40 @@+Name:              hsc3-data+Version:           0.15+Synopsis:          haskell supercollider data+Description:       Data related functions useful when working with SC3.+License:           GPL+Category:          Sound+Copyright:         (c) Rohan Drape, 2013-2014+Author:            Rohan Drape+Maintainer:        rd@slavepianos.org+Stability:         Experimental+Homepage:          http://rd.slavepianos.org/t/hsc3-data+Tested-With:       GHC == 7.8.2+Build-Type:        Simple+Cabal-Version:     >= 1.8++Data-files:        README++Library+  Build-Depends:   base == 4.*,+                   bifunctors,+                   Glob,+                   hcg-minus == 0.15.*,+                   hmt == 0.15.*,+                   hsc3-lang == 0.15.*,+                   hsc3-plot == 0.15.*,+                   hsc3-sf-hsndfile == 0.15.*,+                   safe,+                   split,+                   SVGPath >= 1.1.1,+                   xml+  GHC-Options:     -Wall -fwarn-tabs+  Exposed-modules: Sound.SC3.Data.Math.Bourke+                   Sound.SC3.Data.Math.Loudness+                   Sound.SC3.Data.Math.Sprott_1993a+                   Sound.SC3.Data.SVG+                   Sound.SC3.Data.Trace++Source-Repository  head+  Type:            darcs+  Location:        http://rd.slavepianos.org/sw/hsc3-data