{- A simple waveset synthesiser (rd) -}

import Control.Monad
import qualified Data.Array as A {- array -}
import Data.List
import qualified Sound.File.NeXT as F {- hsc3-sf -}
import Sound.OpenSoundControl {- hosc -}
import Sound.SC3
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 -> OSC -> OSC
offset t (Bundle (UTCr t0) m) = Bundle (UTCr (t + t0)) m
offset _ _ = undefined

-- | Play non-empty set of osc bundles.
play_set :: Transport t => t -> [OSC] -> IO ()
play_set _ [] = undefined
play_set fd (x:xs) = do
  let (Bundle (UTCr t) _) = x
  pauseThreadUntil (t - latency)
  mapM_ (\e -> send fd e) (x:xs)

-- | Play grouped score.
play_sets :: Transport t => t -> [[OSC]] -> IO ()
play_sets _ [] = return ()
play_sets fd s = do
  t <- utcr
  mapM_ (play_set fd) (map (\g -> map (offset t) g) 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 t => Int -> t -> [OSC] -> IO ()
play_score n fd s = play_sets fd (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 = env [a, a, 0] [d, 0] [EnvLin] (-1) (-1)
        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 -> OSC
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)] -> [OSC]
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 t => t -> String -> IO ()
run_waveset fd fn = do
  async fd (d_recv (synthdef "waveset" waveset))
  async fd (b_allocRead 10 fn 0 0)
  (hdr, cs) <- 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 fd s >> pauseThread 1
  putStrLn ("#f: " ++ show (nc, nf, sr))
  putStrLn ("#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 (\fd -> run_waveset fd fn)
    _ -> error "audio file?"

{--
withSC3 (\fd -> run_waveset fd "/home/rohan/audio/text.snd")
--}