module As_Saratan_Tape (as_saratan_tape_osc
                       ,as_saratan_tape_au
                       ,as_saratan_sc3_score) where

import Data.Function {- base -}
import Data.List {- base -}
import Data.List.Split {- split -}
import Data.Maybe {- base -}
import Data.Monoid {- base -}
import qualified Foreign.C.Math.Double as C {- cmath -}
import qualified Music.LilyPond.Light as M {- hly -}
import qualified Music.Theory.Pitch as T {- hmt -}
import qualified Music.Theory.Tuning as T {- hmt -}
import Sound.OSC {- hosc -}
import Sound.SC3.ID {- hsc3 -}
import qualified Sound.SC3.Lang.Random.IO as L {- hsc3-lang -}
import System.Random {- random -}

import qualified As_Saratan as A

type R = Double
type P = (R,[R])

seconds_per_pulse :: R
seconds_per_pulse = 60 / (63 * 2)

-- ceiling tape_dur `divMod` 60 == (2,51)
tape_dur :: R
tape_dur =
    let x = sum (map fst A.ts_str_simple)
    in fromIntegral x * seconds_per_pulse

integrate :: (Num a) => [a] -> [a]
integrate = scanl1 (+)

tune :: T.Tuning -> (T.Octave, T.PitchClass) -> R
tune tn (o,pc) =
    let cs = T.cents tn
        m = T.octpc_to_midi (o,0)
        x = cs !! fromIntegral pc
    in midiCPS (fromIntegral m + (x / 100))

mk_pp :: T.Tuning -> [Rational] -> [M.Music] -> [(R, [R])]
mk_pp tn ds ms =
    let fs = map (map (tune tn . T.pitch_to_octpc) . A.un_c) ms
        ds' = filter (< 0) ds
        fn x = seconds_per_pulse * (abs (fromRational x) + 1)
    in zip (takeWhile (< tape_dur) (integrate (map fn ds'))) fs

-- * Instrument

mk_env :: UGen -> UGen -> UGen -> UGen
mk_env a s d =
    let c = EnvNum (-4)
        p = envLinen' a s d 1 (c, c, c)
    in envGen KR 1 0.35 0 1 RemoveSynth p

scale_ampl :: (Fractional a) => a -> a
scale_ampl f = 0.02 / (f / 12000)

sin_tone :: UGen
sin_tone =
    let o = let fr = control KR "f" 440
                ph = rand 'α' (-pi) pi
            in sinOsc AR fr ph * scale_ampl fr
        am = let fr = rand 'β' 0.01 0.1
                 ph = rand 'β' (-pi) pi
             in sinOsc KR fr ph
        p i = let fr = rand 'γ' 0.05 0.1
              in pan2 i (sinOsc KR fr 0) 0.15
        e = let at = rand 'δ' 0.75 2.25
            in mk_env at 5 3.5
    in out 0 (p (o * am * e * 0.65))

-- add random odd harmonics to ~1/2 frequencies
exp_ff :: Int -> Int -> [R] -> [R]
exp_ff sd nh =
    let g = mkStdGen sd
        is = map nub (chunksOf nh (randomRs (3,11) g))
        f_0 x i = let o = odd (floor i :: Integer)
                  in if o
                     then Just (x * C.floor i)
                     else Nothing
        f_1 i x = x : (mapMaybe (f_0 x) i)
    in sort . concat . zipWith f_1 is

-- * OSC Score

chord_osc :: String -> [R] -> [Message]
chord_osc nd =
    let msg x = s_new nd (-1) AddToTail 1 [("f",x)]
    in map msg

p_osc :: String -> Int -> P -> Bundle
p_osc nd sd (t,ff) =
    let ff' = exp_ff sd 4 ff
    in Bundle t (chord_osc nd ff')

coalesce :: (Eq a, Monoid b) => [(a,b)] -> [(a,b)]
coalesce =
    let fn xs = (fst (head xs),mconcat (map snd xs))
    in map fn . groupBy ((==) `on` fst)

pp_osc :: String -> [Int] -> [P] -> [Bundle]
pp_osc nd sd pp = do
  zipWith (p_osc nd) sd (coalesce pp)

instrument_osc :: Message
instrument_osc = d_recv (synthdef "as" sin_tone)

as_saratan_tape_osc :: NRT
as_saratan_tape_osc =
  let w_iii = mk_pp T.werckmeister_iii (A.w_ds_rq A.EL_0) (A.w_mu A.EL_0)
      w_iv = mk_pp T.werckmeister_iv (A.w_ds_rq A.EL_1) (A.w_mu A.EL_1)
      w_v = mk_pp T.werckmeister_v (A.w_ds_rq A.EL_2) (A.w_mu A.EL_2)
      w = sort (w_iii ++ w_iv ++ w_v)
      group_zero = g_new [(1, AddToTail, 0)]
      sc_init = [bundle 0 [group_zero, instrument_osc]]
      sc_end = [bundle (tape_dur + 10) [g_freeAll [1]]]
      sd = randoms (mkStdGen 1694378)
  in NRT (sc_init ++ pp_osc "as" sd w ++ sc_end)

as_saratan_sc3_score :: FilePath -> IO ()
as_saratan_sc3_score nm = writeNRT nm as_saratan_tape_osc

-- * Audition

play_chd :: Transport m => R -> P -> m ()
play_chd t (st,ff) = do
  sd <- L.randomM (minBound,maxBound)
  let ff' = exp_ff sd 4 ff
      post = liftIO . putStrLn
  post ("play_chd: st = " ++ show st)
  pauseThreadUntil (t + st)
  post ("play_chd: ff = " ++ show ff')
  _ <- sendBundle (Bundle immediately (chord_osc "as" ff'))
  return ()

pp_audition :: (Transport m) => [P] -> m ()
pp_audition pp = do
  t <- time
  mapM_ (play_chd t) pp

as_saratan_tape_au :: (Transport m) => m ()
as_saratan_tape_au = do
  let w_iii = mk_pp T.werckmeister_iii (A.w_ds_rq A.EL_0) (A.w_mu A.EL_0)
      w_iv = mk_pp T.werckmeister_iv (A.w_ds_rq A.EL_1) (A.w_mu A.EL_1)
      w_v = mk_pp T.werckmeister_v (A.w_ds_rq A.EL_2) (A.w_mu A.EL_2)
      w = sort (w_iii ++ w_iv ++ w_v)
  send instrument_osc
  pp_audition w

{-
withSC3 (send instrument_osc)
withSC3 as_saratan_tape_au
-}