hsc3-graphs-0.12: gr/waveset.hs

-- A simple waveset synthesiser (rd)

import qualified Data.Array as A {- array -}
import Data.List {- base -}
import qualified Sound.File.NeXT as F {- hsc3-sf -}
import Sound.OSC {- hosc -}
import Sound.SC3 {- hsc3 -}
import System.Environment
import System.Random {- random -}

-- * Score model.

-- | Interval to schedule in advance.
latency :: Double
latency = 0.15

-- | Add t to timestamp.
offset :: Double -> Bundle -> Bundle
offset t b =
    case b of
      Bundle (UTCr t0) m -> Bundle (UTCr (t + t0)) m
      _ -> error "offset:non-UTCr bundle"

-- | Play non-empty set of osc bundles.
play_set :: Transport m => [Bundle] -> m ()
play_set [] = error "play_set:empty"
play_set (x:xs) = do
  let (Bundle (UTCr t) _) = x
  pauseThreadUntil (t - latency)
  mapM_ sendBundle (x:xs)

-- | Play grouped score.
play_sets :: Transport m => [[Bundle]] -> m ()
play_sets [] = return ()
play_sets s = do
  t <- utcr
  mapM_ (play_set . map (offset t)) s

-- | Split l into chunks of at most n elements.
form_sets :: Int -> [a] -> [[a]]
form_sets _ [] = []
form_sets n l =
    let (a,b) = splitAt n l
    in a : form_sets n b

-- | Play score, send in sets on indicated cardinality.
play_score :: Transport m => Int -> [Bundle] -> m ()
play_score n s = play_sets (form_sets n s)

-- * Waveset analysis

-- | Zero-crossing predicate.
is_zc :: (Num a, Ord a) => a -> a -> Bool
is_zc a b = a <= 0 && b > 0

-- | Locate fractional zero-crossing point.
locate_fzc :: (Ord a, Fractional a) => a -> a -> a
locate_fzc x y = (1.0 / (y - x)) * abs x

-- | Fractional zero-crossing constructor, n is the initial frame location.
fzc :: (Ord a, Fractional a) => a -> [a] -> [a]
fzc _ [] = []
fzc _ [_] = []
fzc n (x:y:z) = if is_zc x y
                then (n + locate_fzc x y) : fzc (n + 2.0) z
                else fzc (n + 1.0) (y : z)

-- | Remove zero crossings so that no waveset has length less than m.
prune :: (Ord a, Num a) => a -> a -> [a] -> [a]
prune _ _ [] = [] -- hmmm....
prune m n (x:xs) = if (x - n) < m
                   then prune m n xs
                   else x : prune m x xs

-- | zc -> ws
ws :: [a] -> [(a,a)]
ws [] = []
ws [_] = []
ws (x:y:z) = (x,y) : ws (y : z)

-- * Waveset instrument

-- | A trivial waveset instrument with unit envelope.
waveset :: UGen
waveset =
    let k = control KR
        o = k "out" 0
        b = k "bufnum" 0
        s = k "start" 0
        e = k "end" 0
        r = k "rate" 1
        d = k "dur" 1
        a = k "amp" 0.2
        rs = bufRateScale KR b * r
        ph = phasor AR 0 rs 0 (e - s) 0 + s
        e_data = Envelope [a, a, 0] [d, 0] [EnvLin] Nothing Nothing
        e_ugen = envGen AR 1 1 0 1 RemoveSynth e_data
    in offsetOut o (bufRdL 1 AR b ph Loop * e_ugen)

-- * Waveset synthesizer

-- | Construct s_new message for synthesiser.
mk_msg :: Double -> Double -> Double -> Double -> Message
mk_msg b sf ef d =
    let a = [("bufnum", b), ("start", sf), ("end", ef), ("dur", d)]
    in s_new "waveset" (-1) AddToTail 1 a

-- | Compare wavesets by duration.
dur_ord :: (Num t, Ord t) => (t, t) -> (t, t) -> Ordering
dur_ord (s0, e0) (s1, e1) = compare (e0 - s0) (e1 - s1)

-- | Generate score from waveset data.
mk_score :: Double -> [Double] -> [(Double, Double)] -> [Bundle]
mk_score sr repeats w =
    let durations = zipWith (\(s, e) r -> (e - s) * r / sr) w repeats
        start_times = scanl (+) 0 durations
        mk_elem (s,e) t d = Bundle (UTCr t) [mk_msg 10 s e d]
    in zipWith3 mk_elem w start_times durations

-- | n randomly chosen elements of w.
rchoose :: Int -> [a] -> [a]
rchoose n w =
    let (l, r) = (1, length w)
        a = A.listArray (l,r) w
    in take n (map (a A.!) (randomRs (l,r) (mkStdGen 1)))

-- | Load waveset instrument, allocate sound file buffer, do waveset
--   analysis, generate & play scores.
run_waveset :: Transport m => String -> m ()
run_waveset fn = do
  _ <- async (d_recv (synthdef "waveset" waveset))
  _ <- async (b_allocRead 10 fn 0 0)
  (hdr, cs) <- liftIO (F.read fn)
  let nc = F.channelCount hdr
      nf = F.frameCount hdr
      sr = fromIntegral (F.sampleRate hdr)
      b = cs !! 0
      w = ws (prune 64 0 (fzc 0 b))
      pl s = play_score 10 s >> pauseThread 1
      post = liftIO . putStrLn
  post ("#f: " ++ show (nc, nf, sr))
  post ("#w: " ++ show (length w)) -- force w
  pl (mk_score sr (repeat 1) w)
  pl (mk_score sr (repeat 2) (reverse w))
  pl (mk_score sr (cycle [2,4,8]) (sortBy dur_ord w))
  pl (mk_score sr (randomRs (1,24) (mkStdGen 2)) (rchoose 512 w))

main :: IO ()
main = do
  a <- getArgs
  case a of
    [fn] -> withSC3 (run_waveset fn)
    _ -> error "audio file?"

{--
withSC3 (run_waveset "/home/rohan/data/audio/pf-c5.snd")
--}