hmeap-0.9: cmd/play.hs

import Control.Monad
import Data.Function
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 DoNothing

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

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 =
    let xs = [ ("freq", f)
             , ("dur", d) ]
    in send fd (s_new "tone" (-1) AddToTail 1 xs)

-- (Temporal_Scalar, [Segments], [Freq])
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

run_grn :: FilePath -> FilePath -> (M.MEAP -> 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))
                    (Right m) <- M.read_meap ff
                    plyr fd (rule m)

col :: String -> M.MEAP -> [Double]
col n m =
    let f = M.required_feature n (M.features m)
        j = M.feature_column f
    in M.column_l m j

freq_1 :: M.MEAP -> [Double]
freq_1 = col "AvgFreqSimple"

-- forwards
rule_1 :: M.MEAP -> Spec
rule_1 c = (0.75, M.segments_l c, freq_1 c)

freq_2 :: M.MEAP -> [Double]
freq_2 = col "AvgSpecCentroid"

-- backwards
rule_2 :: M.MEAP -> Spec
rule_2 c = (0.5, reverse (M.segments_l c), reverse (freq_2 c))

gen_order_1 :: M.MEAP -> String -> [Int]
gen_order_1 m f =
    let cs = zip [0..] (col f m)
        cs' = sortBy (compare `on` snd) cs
    in map fst cs'

apply_order :: [Int] -> [a] -> [a]
apply_order o xs = map (\i -> xs !! i) o

srt_rule :: String -> (M.MEAP -> [Double]) -> M.MEAP -> Spec
srt_rule n r m =
    let o = gen_order_1 m n
        s = apply_order o (M.segments_l m)
        f = apply_order o (r m)
    in (0.5, s, f)

-- sorted by segment length (ascending)
rule_3 :: M.MEAP -> Spec
rule_3 = srt_rule "chunk_length" freq_1

-- sorted by frequency (ascending)
rule_4 :: M.MEAP -> Spec
rule_4 = srt_rule "AvgFreqSimple" freq_1

-- sorted by spectral centroid (ascending)
rule_5 :: M.MEAP -> Spec
rule_5 = srt_rule "AvgSpecCentroid" freq_2

-- sorted by spectral stability (ascending)
rule_6 :: M.MEAP -> Spec
rule_6 = srt_rule "SpectralStability" freq_2

gen_sel_1 :: M.MEAP -> String -> (Double -> Bool) -> [Int]
gen_sel_1 m f p =
    let cs = zip [0..] (col f m)
        cs' = filter (p . snd) cs
    in map fst cs'

sel_rule :: String -> (Double -> Bool) -> (M.MEAP -> [Double]) -> M.MEAP -> Spec
sel_rule n p r m =
    let o = gen_sel_1 m n p
        s = apply_order o (M.segments_l m)
        f = apply_order o (r m)
    in (0.5, s, f)

-- filtered by frequency (> 600)
rule_7 :: M.MEAP -> Spec
rule_7 = sel_rule "AvgFreqSimple" (> 600) freq_1

-- filtered by spectral centroid (> 1200)
rule_8 :: M.MEAP -> Spec
rule_8 = sel_rule "AvgSpecCentroid" (> 1200) freq_2

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

-- interleaving of rules 4 & 5
rule_9 :: M.MEAP -> Spec
rule_9 m =
    let (_, s4, f4) = rule_4 m
        (_, s5, f5) = rule_5 m
    in (0.75, interleave s4 s5, interleave f4 f5)

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

-- reverse of rule 9
rule_10 :: M.MEAP -> Spec
rule_10 = reverse_spec . rule_9

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 10 with start times compressed but durations kept equal
rule_11 :: M.MEAP -> Spec
rule_11 = (scale_start_only 0.5) . rule_10

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 7 with durations compressed but start times retained
rule_12 :: M.MEAP -> Spec
rule_12 = (scale_dur_only 0.5) . rule_7

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

-- rule 7 with durations fixed at 0.25 seconds
rule_13 :: M.MEAP -> Spec
rule_13 = (fix_dur 0.25) . rule_7

rules :: [M.MEAP -> Spec]
rules = [ rule_1
        , rule_2
        , rule_3
        , rule_4
        , rule_5
        , rule_6
        , rule_7
        , rule_8
        , rule_9
        , rule_10
        , rule_11
        , rule_12
        , rule_13 ]

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 < length rules) (error "unknown rule")
  run_grn w_fn f_fn ( rules !! rn )