hmeap-0.6: Help/play.hs

import Control.Monad
import Data.List
import qualified Sound.Analysis.Meapsoft as M
import Sound.OpenSoundControl
import Sound.SC3
import System.Environment

grain :: UGen -> UGen
grain b = p * e
    where s = Control KR "start" 0.0
          d = Control KR "dur" 1.0
          g = Control KR "gain" 1.0
          r = bufRateScale KR b
          q = bufSampleRate KR b
          z = envTrapezoid 0.95 0.5 d g
          e = envGen KR 1 1 0 1 RemoveSynth z
          p = playBuf 1 b r 1 (s * q) NoLoop

mk_grain :: (Transport t) => t -> Double -> Double -> IO ()
mk_grain fd s d = send fd (s_new "grain" (-1) AddToTail 1 [ ("start", s)
                                                          , ("dur", d) ])

tone :: UGen
tone = p * e
    where f = Control KR "freq" 0.0
          d = Control KR "dur" 1.0
          g = Control KR "gain" 0.1
          z = envTrapezoid 0.95 0.5 d g
          e = envGen KR 1 1 0 1 RemoveSynth z
          p = saw AR (MCE [f, f*2, f*3]) * (MCE [0.5, 0.2, 0.1])

mk_tone :: (Transport t) => t -> Double -> Double -> IO ()
mk_tone fd f d = send fd (s_new "tone" (-1) AddToTail 1 [ ("freq", f)
                                                        , ("dur", d) ])

type Spec = (Double, [(Double, Double)], [Double])

plyr :: Transport t => t -> Spec -> IO ()
plyr _ (_, [], _) = return ()
plyr fd (t, (s,d):xs, f:fs) = do mk_grain fd s d
                                 mk_tone fd f (d * t * 0.25)
                                 pauseThread (d * t)
                                 plyr fd (t, xs, fs)
plyr _ _ = undefined

interleave :: [a] -> [a] -> [a]
interleave [] b = b
interleave a [] = a
interleave (a:as) (b:bs) = a : b : interleave as bs

run_grn :: FilePath -> FilePath -> ([M.Frame] -> Spec) -> IO ()
run_grn sf ff rule = withSC3 g
    where g fd = do reset fd
                    let g0 = out 0 (grain 10)
                        g1 = out 0 tone
                    async fd (b_allocRead 10 sf 0 0)
                    async fd (d_recv (synthdef "grain" g0))
                    async fd (d_recv (synthdef "tone" g1))
                    c <- M.read_file ff
                    plyr fd (rule c)

freq_1 :: [M.Frame] -> [Double]
freq_1 = map M.avg_freq_simple

freq_2 :: [M.Frame] -> [Double]
freq_2 = map M.avg_spec_centroid

rule_1 :: [M.Frame] -> Spec
rule_1 c = (0.75, M.segments c, freq_1 c)

rule_2 :: [M.Frame] -> Spec
rule_2 c = (0.75, reverse (M.segments c), freq_2 c)

rule_3 :: [M.Frame] -> Spec
rule_3 c = (0.75, sortBy f (M.segments c), freq_1 c)
    where f (_, d1) (_, d2) = compare d1 d2

rule_4 :: [M.Frame] -> Spec
rule_4 c = (0.75, interleave s (reverse s), freq_1 c)
    where f (_, d1) (_, d2) = compare d1 d2
          s = sortBy f (M.segments c)

with_times :: (M.Frame -> a) -> M.Frame -> (Double, Double, a)
with_times f c = (M.onset_time c, M.duration c, f c)

rule_5 :: [M.Frame] -> Spec
rule_5 cs = (0.75, map g x1, map h x1)
    where f (_, _, c1) (_, _, c2) = compare c1 c2
          g (t, d, _) = (t, d)
          h (_, _, fr) = fr
          x0 = map (with_times M.avg_spec_centroid) cs
          x1 = sortBy f x0

reverse_spec :: Spec -> Spec
reverse_spec (t, x, f) = (t, reverse x, reverse f)

rule_6 :: [M.Frame] -> Spec
rule_6 = reverse_spec . rule_5

rule_7 :: [M.Frame] -> Spec
rule_7 cs = (0.75, map g x1, map h x1)
    where f (_, _, c1) (_, _, c2) = compare c1 c2
          g (t, d, _) = (t, d)
          h (_, _, fr) = fr
          x0 = map (with_times M.avg_freq_simple) cs
          x1 = sortBy f x0

rule_8 :: [M.Frame] -> Spec
rule_8 = reverse_spec . rule_7

scale_start_only :: Double -> Spec -> Spec
scale_start_only n (t, x, f) = (t, map g x, f)
    where g (s, d) = (s * n, d)

rule_9 :: [M.Frame] -> Spec
rule_9 = (scale_start_only 0.75) . rule_7

scale_dur_only :: Double -> Spec -> Spec
scale_dur_only n (t, x, f) = (t, map g x, f)
    where g (s, d) = (s, d * n)

rule_10 :: [M.Frame] -> Spec
rule_10 = (scale_dur_only 0.65) . rule_7

fix_dur :: Double -> Spec -> Spec
fix_dur n (t, x, f) = (t, map g x, f)
    where g (s, _) = (s, n)

rule_11 :: [M.Frame] -> Spec
rule_11 = (fix_dur 0.075) . rule_7

main :: IO ()
main = do
  a <- getArgs
  unless (length a == 3) (error "audio-file feature-file rule-number")
  let [w_fn, f_fn, r] = a
      rn = read r - 1
  unless (rn >= 0 && rn < 11) (error "unknown rule")
  run_grn w_fn f_fn ( [ rule_1
                      , rule_2
                      , rule_3
                      , rule_4
                      , rule_5
                      , rule_6
                      , rule_7
                      , rule_8
                      , rule_9
                      , rule_10
                      , rule_11 ] !! rn)