{- | Example requires the package `random` to be installed

This remarkable tibetan harmonic chant like effect is created by nine sinusoidal
oscillators, whose frequencies are almost identical: separated by a fraction of
1 Hz from each other. Thus for each component, amplitude modulation leads to its
enhancement or cancelling out in turn. In his composition 'Mutations', Risset
gives the instrument two different envelopes: one with sharp rise and one is a
more gradual rise.
-}
module Tibetan where

import Data.List(zip4)
import Data.Traversable(traverse)

import Control.Monad.Trans.State
import Control.Applicative hiding ((<*))

import System.Random

import Csound.Base
import Color(blurp, blue)

-- | A pure tibetan instrument with randomized parameters.
tibetan :: (D, D, D, D) -> SE Sig
tibetan (amp, cps, rise, dec) = fmap (\x -> pureTibetan (amp, cps, x, rise, dec)) off
    where off = fmap (\x -> 0.3 + ir x) $ rand 0.15

pureTibetan :: (D, D, D, D, D) -> Sig
pureTibetan (amp, cps, off, rise, dec) = mean $ fmap partial $ 0 : offs ++ (fmap negate offs)
    where offs = fmap int [1 .. 4]
          partial rat = linen (sig amp) rise idur dec * oscBy wave (sig $ cps + off * rat)
          wave = ifB (cps `lessThan` 230) (waveBy 5) (ifB (cps `lessThan` 350) (waveBy 3) (waveBy 1))
          waveBy n = sines $ [0.3, 0, 0, 0] ++ replicate n 0.1

-----------------------------------------------------------
-- scores

-- tibetan

instant = 1
med = 3
long = 5

-- intersection
deep = 50
shallow = 90
sym = 70

-- myxo mode
ts = [1, 9/8, 5/4, 4/3, 3/2, 5/3, 16/9]

id2cps oct n = baseTone * (2 ^^ (oct + curOct)) * ts !! curId
    where (curOct, curId) = divMod n 7

data Act = Tone Int | Repeat Int | Wait Double

r = Repeat
w = Wait

instance Num Act where
    fromInteger = Tone . fromInteger

type N = (Sig, Sig, D, D, D, D)


data St = St
    { stRepeat :: Int
    , stWait   :: Double
    , stSpan   :: (Double, Double)
    , stRnds   :: [Double] }

-- constants
baseTone = 110 -- an A
innerOverlap = 0.5
noteLength = 25
fixedNoteLength = 15
offset = 0.03
rise = 5
dec = 15
durStep = 7

initRepeat = 2
initWait = 0.7
initSpan = (0, 0)

updateSt f = modify f >> return []

turtle :: Act -> State St [N]
turtle x = case x of
    Repeat n -> updateSt $ \s -> s{ stRepeat = n }
    Wait n -> updateSt $ \s -> s{ stWait = n }
    -- tones
    Tone t -> state (getNotes t)

getNotes :: Int -> St -> ([N], St)
getNotes k st = (notes, st')
    where t0s = startTimes (offsetStartTime (stWait st) $ stSpan st) durStep
          dts = durs noteLength
          cpss = freqs (ts !! (k - 1))
          amps = fmap cps2amp cpss
          offs = offsets offset
          decs = decays dec
          riss = rises rise

          notes = take (stRepeat st) $ getZipList $ (\t0 dt amp cps ris dec ->
                (sig $ double t0, sig $ double dt, double amp, double cps, double ris, double dec)) <$>
                ZipList t0s <*> ZipList dts <*> ZipList amps <*> ZipList cpss <*> ZipList decs <*> ZipList riss

          st' = st{ stSpan = getSpan (stRepeat st) t0s dts }

offsetStartTime :: Double -> (Double, Double) -> Double
offsetStartTime k (t0, dt) = t0 + k * dt

startTimes :: Double -> Double -> [Double]
startTimes t0 step = fmap (+ t0) $ [0, step ..]

durs    = repeat
offsets = repeat
rises   = repeat
decays  = repeat

getSpan :: Int -> [Double] -> [Double] -> (Double, Double)
getSpan num starts durs = (starts !! n, durs !! n)
    where n = num - 1

freqs k = fmap (* base) octs
    where octs = cycle [1, 0.5, 2, 1, 2, 1, 1, 0.5]
          base = k * baseTone

cps2amp a = 0.5 * full a
    where full x
            | x < 100 = 1
            | x < 200 = 0.8
            | x < 300 = 0.6
            | x < 400 = 0.5
            | otherwise = 0.4

run :: [Act] -> IO [N]
run as = fmap concat $ fmap (evalState (mapM turtle as)) initSt
    where initSt = fmap (St initRepeat initWait initSpan) $ fmap (randomRs (0, 1)) newStdGen

acts :: [Act]
acts = concat $ replicate 1 $ [1, 1, 5, 2, 5, 7, 5, 1, 1, 3, 5, 3, 1, 1, 5, 1 ]


note (start, dur, amp, cps, rise, dec) = del start $ str dur $
                temp (amp, cps, rise, dec)

globalEffect =  eff (bindSig $ return . blp 5000 . (0.3 * )) . eff rever

res2 ns = har [res ns, del 13 $ res ns]

res ns = sco tibetan $ har $ fmap note ns

rever x = do
    _ <- delayr 3
    [aleft, aright] <- mapM deltap3 [2.50, 1.25]
    delayw x
    return (f aleft, f aright)
    where x1 = reverb2 (0.6 * x) 6 0.5
          f a = 0.5 * (x1 + a)


------------------------------------------------------------
-- blurp

blurpVol = 0.5
introDur = 15

toStereo = eff $ \x -> return (x, x)

introBlurp = toStereo $ sco blurp $ introDur *| temp (0.7 * blurpVol)

blurpSco = toStereo $ mel [rest 100, cone 15 0.7, rest 60, cone 10 0.4]
    where cone dt v = eff (\x -> return $ linen x (0.25 * idur) idur (0.25 * idur)) $ sco blurp $ dt *| temp (v * blurpVol)

------------------------------------------------------------
-- stars

starLength      = 60
starParams      = zip4 starVolumes starLfos starHarms starSweeps

starVolume      = 0.3
starVolumes     = fmap (starVolume * ) $ cycle [0.7, 0.3, 0.5, 0.8, 0.9, 0.5, 0.2]
starLfos        = cycle [23, 10, 5, 15, 17]
starHarms       = cycle [10, 6, 7, 10]
starSweeps      = cycle [0.7, 0.6, 0.6, 0.5, 0.8, 0.9, 0.25, 0.7, 0.5, 0.5, 0.6]

starTotalDelay  = 1.5 * 60
starInitDelays  =              [ 0, 11,  2, 8,  21, 25]
starPeriods     = fmap (* 2.5) [ 7, 23, 77, 13, 17, 31]

starChord       = [0, 1, 2, 4, 7]

starSco = sco blue $
    flip evalState starParams $ traverse addParam $
    har $ zipWith3 phi starInitDelays starPeriods starChord
    where phi dt period note = del dt $ loopBy 50 $ har [4 *| temp (double $ id2cps 2 note), rest period]

          addParam cps = state $ \((amp, lfo, harm, sweep) : params) ->
            ((amp, cps, lfo, harm, sweep), params)


------------------------------------------------------------

main = do
    notes <- run acts
    dac $ mix $ har
        [ introBlurp
        , del (introDur * 0.70) $ har
            [ globalEffect $ har
                [ res2 notes
                , del starTotalDelay $ starSco
                , del (2 * starTotalDelay) $ starSco]
            , blurpSco
            ]]