-- | Wonderful echoes from morpheus.
-- Granular synthesis for morphing between waveforms.
-- It's a simplification of partikkel opcode for the case of morphing.
module Csound.Air.Granular.Morpheus(
	WaveAmp, WaveKey, MorphWave, 
	MorphSpec(..), GrainDensity(..), GrainEnv(..),

	morpheus,

	-- *  Sound files
	morphSnd1, morphSnd,

	-- * Amplitude modes
	pairToSquare,

	-- * Oscillators
	morpheusOsc, morpheusOsc2
) where

import Control.Arrow
import Data.Default

import Csound.Typed
import Csound.Typed.Opcode
import Csound.Tab
import Csound.SigSpace

import Csound.Air.Granular(Pointer, csdPartikkel)
import Csound.Air.Wav
import Csound.Air.Wave
import Csound.Types(compareWhenD)

type WaveAmp = Sig
type WaveKey = Sig

type MorphWave = (Tab, WaveAmp, WaveKey, Pointer)

-- | Density of the grain stream.  
-- 
-- * @rate@ is how many grains per second is generated
--
-- * @size@ is the size of each grain in milliseconds (it's good to set it relative to grain rate)
--
-- * @skip@ skip is a skip ratio (0 to 1). It's the probability of grain skip. Zero means no skip and 1 means every grain is left out.
--
-- see docs for Csound partikkel opcode for more detailed information <http://www.csounds.com/manual/html/partikkel.html>
data GrainDensity = GrainDensity 
	{ grainRate :: Sig
	, grainSize :: Sig
	, grainSkip :: Sig }

instance Default GrainDensity where
	def = GrainDensity
			{ grainRate = kGrainRate
			, grainSize = kduration
			, grainSkip = 0 }
		where 
			kGrainDur	= 2.5							-- length of each grain relative to grain rate 
			kduration	= (kGrainDur*1000)/kGrainRate	-- grain dur in milliseconds, relative to grain rate
			kGrainRate  = 12

-- | Parameters for grain envelope.
--
-- * attShape -- table that contains shape of the attack.
--
-- * decShape -- table that contains shape of the decay
--
-- * sustRatio -- how big is sustain phase relative to attack and decay
--
-- * attack to decay ration -- relative amount of attack decay ration. 0.5 means attack equals decay.
--
-- see docs for Csound partikkel opcode for more detailed information <http://www.csounds.com/manual/html/partikkel.html>
data GrainEnv = GrainEnv 
	{ grainAttShape :: Tab
	, grainDecShape :: Tab
	, grainSustRatio :: Sig
	, grainAttDecRatio :: Sig }

instance Default GrainEnv where
	def = GrainEnv 
			{ grainAttShape = sigmoidRise
			, grainDecShape = sigmoidFall
			, grainSustRatio = 0.25
			, grainAttDecRatio = 0.5 }

-- sigmoidRise = guardPoint $ sines4 [(0.5, 1, 270, 1)]
-- sigmoidFall = guardPoint $ sines4 [(0.5, 1, 90, 1)]

-- | Specification of morphing synth. It has the default instance 
-- and the values in its records has default instances too
data MorphSpec = MorphSpec 
	{ morphGrainDensity :: GrainDensity
	, morphGrainEnv     :: GrainEnv	
	}

instance Default MorphSpec where
	def = MorphSpec 
		{ morphGrainDensity = def
		, morphGrainEnv     = def
		}

-- | Synth that is based on partikkel. It allows easy morphing between unlimited number of waves.
-- While partikkel allows only 4 waves to be used. We can use as many as we like. Internally
-- the list is split on groups 4 elements or less in each and one partikkel is applied to each group.
-- Many parameters of partikel were simplified to get the good defaults for sound morphing behavior.
--
-- > morpheus spec waves frequencyScale
--
-- * spec -- contains many misc parameters
--
-- * waves list can contain up to four wave tables to read grains from.
--
-- * frequencyScale -- scaling factor for frequency. 1 means playing at the original frequency, 2 rises the pitch by octave. 
--     We can use negative values to play the grains in reverse.
morpheus :: MorphSpec -> [MorphWave] -> Sig -> SE Sig2
morpheus spec pwaves cps = sum $ fmap (\waves -> morpheus4 spec waves cps) (splitBy4 pwaves)

splitBy4 :: [a] -> [[a]]
splitBy4 xs = case xs of
    a:b:c:d:rest -> [a,b,c,d] : splitBy4 rest
    rest         -> [rest]

morpheus4 :: MorphSpec -> [MorphWave] -> Sig -> SE Sig2
morpheus4 spec pwaves cps = do
	iwaveamptab <- makeMorphTable amp1 amp2 amp3 amp4
	return $ csdPartikkel agrainrate kdistribution idisttab async kenv2amt ienv2tab
					ienv_attack ienv_decay ksustain_amount ka_d_ratio kduration kamp igainmasks
               	  	kwavfreq ksweepshape iwavfreqstarttab iwavfreqendtab awavfm
               	  	ifmamptab ifmenv icosine kTrainCps knumpartials
               	  	kchroma ichannelmasks krandommask kwaveform1 kwaveform2 kwaveform3 kwaveform4
               	  	iwaveamptab asamplepos1 asamplepos2 asamplepos3 asamplepos4
               	  	kwavekey1 kwavekey2 kwavekey3 kwavekey4 imax_grains
    where
    	wave1 : wave2 : wave3 : wave4 : _ = cycle pwaves

    	async = 0
    	kamp = 1	
   	
    	ichannelmasks = skipNorm $ doubles [0, 0,  0.5]
    			    	
    	kdistribution = 1
    	idisttab = setSize 16 $ startEnds [1, 16, -10, 0]

    	-- grain shape settings
    	grainEnv = morphGrainEnv spec
    	ienv_attack = grainAttShape grainEnv
    	ienv_decay  = grainDecShape grainEnv
    	ksustain_amount = grainSustRatio grainEnv
    	ka_d_ratio = grainAttDecRatio grainEnv
    	kenv2amt = 0    
    	ienv2tab = eexps [1, 0.0001]	

    	-- grain density
    	grainDensity = morphGrainDensity spec
    	kGrainRate = grainRate grainDensity
    	kduration = grainSize grainDensity                    

    	kwavfreq = cps

    	krandommask = grainSkip grainDensity

    	-- waves

    	kwavekey1 = getWaveKey wave1
    	kwavekey2 = getWaveKey wave2
    	kwavekey3 = getWaveKey wave3
    	kwavekey4 = getWaveKey wave4

    	asamplepos1 = getSamplePos wave1
    	asamplepos2 = getSamplePos wave2
    	asamplepos3 = getSamplePos wave3
    	asamplepos4 = getSamplePos wave4

    	kwaveform1 = getWaveForm wave1
    	kwaveform2 = getWaveForm wave2
    	kwaveform3 = getWaveForm wave3
    	kwaveform4 = getWaveForm wave4

    	amp1 = getAmp wave1
    	amp2 = getAmp wave2
    	amp3 = getAmp wave3
    	amp4 = getAmp wave4

    	imax_grains = 100   	

    	getWaveKey (tab1, amp1, key1, ptr1) = key1 / sig (getTabLen tab1)

    	getSamplePos (_, _, _, ptr) = ptr
    	getWaveForm (form, _, _, _) = form
    	getAmp (_, amp, _, _) = kr amp

    	-- no trainlets
    	icosine = cosine
    	kTrainCps = kGrainRate
    	knumpartials = 7
    	kchroma = 3

    	-- no FM
    	kGrFmFreq = kGrainRate / 4
    	kGrFmIndex = 0    	
    	aGrFmSig = kGrFmIndex * osc kGrFmFreq
    	agrainrate = kGrainRate + aGrFmSig * kGrainRate
    	ifmenv = elins [0, 1, 0]
    	ifmamptab = skipNorm $ doubles [0, 0, 1]    	
    	awavfm = 0

    	-- other params
    	igainmasks = skipNorm $ doubles [0, 0,   1]
    	ksweepshape = 0.5
    	iwavfreqstarttab = skipNorm $ doubles [0, 0, 1]
    	iwavfreqendtab = skipNorm $ doubles [0, 0, 1]

    	makeMorphTable a1 a2 a3 a4 = do
    		t <- newTab 64
    		mapM_  (\(i, amp) -> tablew amp  (2 + sig (int i)) t ) (zip [0 .. ] [a1, a2, a3, a4])
    		return t

getTabLen t = ftlen t / getSampleRate

-- | Creates four control signals out two signals. The control signals are encoded by the position
-- of the point on XY-plane. The four resulting signals are derived from the proximity of the point
-- to four squares of the ((0, 1), (0, 1)) square. It can be useful to control the morpheus with XY-pad controller.
pairToSquare :: (Sig, Sig) -> (Sig, Sig, Sig, Sig)
pairToSquare (x, y) = ((1 - x) * (1 - y), x * (1 - y) , x * y, (1 - x) * y)

-- | Morpheus synth for mono-audio files. The first cell in each tripple is occupied by file name.
-- The rest arguments are the same as for @morpheus@.
morphSnd1 :: MorphSpec -> [(String, WaveAmp, WaveKey)] -> Sig -> SE Sig2
morphSnd1 spec waves cps = morpheus spec (fmap fromSnd waves) cps
	where
		fromSnd (file, amp, key) = (wavLeft file, amp, key, phasor (1 / sig (lengthSnd file)))

-- | Morpheus synth for stereo-audio files. The first cell in each tripple is occupied by file name.
-- The rest arguments are the same as for @morpheus@.
morphSnd :: MorphSpec -> [(String, WaveAmp, WaveKey)] -> Sig -> SE Sig2
morphSnd spec waves cps = morphSndByTab wavLeft spec waves cps + morphSndByTab wavRight spec waves cps

morphSndByTab :: (String -> Tab) -> MorphSpec -> [(String, WaveAmp, WaveKey)] -> Sig -> SE Sig2
morphSndByTab getTab spec waves cps = morpheus spec (fmap fromSnd waves) cps
	where
		fromSnd (file, amp, key) = (getTab file, amp, key, phasor (1 / sig (lengthSnd file)))

-- | Morpheus oscillator.
--
-- > morpheusOsc spec (baseFrequency, table) cps
--
-- @baseFrequency@ is the frequency of the sample contained in the table. With oscillator
-- we can read the table on different frequencies. 
morpheusOsc :: MorphSpec -> (D, Tab) -> Sig -> SE Sig2
morpheusOsc spec (baseFreq, t) cps = morpheus spec waves ratio
	where
		ratio = cps / sig baseFreq
		aptr = cycleTab t
		waves = [(t, 1, 1, aptr)]

cycleTab t = phasor $ sig $ recip $ getTabLen t

-- | Morpheus oscillator. We control the four tables with pair of control signals (see the function @pairToSquare@).
--
-- > morpheusOsc2 spec baseFrequency waves (x, y) cps = ...
morpheusOsc2 :: MorphSpec -> D -> [(Sig, Tab)] -> (Sig, Sig) -> Sig -> SE Sig2
morpheusOsc2 spec baseFreq ts (x, y) cps = morpheus spec waves ratio
	where
		(a1, a2, a3, a4) = pairToSquare (x, y)
		ratio = cps / sig baseFreq		
		waves = zipWith (\amp (key, t) -> (t, amp, key, cycleTab t)) (cycle [a1, a2, a3, a4]) ts


{- examples

main' = dac $ mul 0.2 $ morphSnd1 def [("floss/ClassGuit.wav", linseg [1, 3, 1, 3, 0], linseg [1, 3, 1, 3, 0]), ("floss/ClassGuit.wav", linseg [0, 3, 0, 3, 1], (-1))] 1

main = dac $ lift1 (\p -> mixAt 0.25 largeHall2 $ mixAt 0.6 (pingPong 0.124 0.5 0.7) $
	at (filt 2 (\cfq res x -> moogladder x cfq res) (env * 12000) 0.1) $ mul (0.2 * env) $ 
	morpheus (def { morphGrainDensity = def { grainRate = linseg [36, 18, 4], grainSize = linseg [ 1200, 6, 5700, 12, 750 ], grainSkip = 0.45 * uosc 0.17 }}) 
		(tabs p) (negate $ semitone (5))) (ujoy (0.5, 0.5)) 
		where
			tabs (x, y) = [file a1 1, file a2 0.5, file2 a3 1, file3 a4 1]
				where (a1, a2, a3, a4) = pairToSquare (x, y)

			file a x = (wavl "floss/ClassGuit.wav", a, x, linseg [2.5, 18, 3.5])
			file2 a x = (wavl "floss/hd.wav", a, x, linseg [0.2, 18, 0.6])
			file3 a x = (wavl "floss/hd.wav", a, x, linseg [0.02, 18, 0.5])

			env = linseg [0, 1, 1, 3, 1] -- 10, 0]

			amp1 = linseg [1, 8, 1, 4, 0]
			amp2 = linseg [0, 6, 0, 6, 1]

-}


{-
-- todo
-- playing samples in chain

pyramidWeights

partWaveChain :: [Double] -> Sig -> (Sig, Sig, Sig, Sig)
partWaveChain xs pointer = case xs of
	[a, da] -> 
		let (amp1, amp2) = go1 a da pointer
		in  (amp1, amp2, 0, 0)
	[a, da, b, db] -> 		
		let (amp1, amp2, amp3) = go2 a da b db pointer
		in  (amp1, amp2, amp3, 0)
	[a, da, b, db, c, dc] -> 
		let (amp1, amp2, amp3, amp4) = go3 a da b db c dc pointer	
		in  (amp1, amp2, amp3, amp4)
	_ -> error "partWaveChain: wrong number of elements in the list. Should be [a, da], [a, da, b, db] or [a, da, b, db, c, dc]."		
	where
		go1 a da ptr = (readTab t1 ptr, readTab t2 ptr)
			where
				d = da / 2
				t1 = leftTab (a - d) (a + d)
				t2 = rightTab (a - d) (a + d)

		go2 a da b db = (readTab t1 ptr, readTab t2 ptr, readTab t3 ptr)
			where
				da2 = da / 2
				db2 = db / 2
				t1 = leftTab (a - da2) (a + da2)
				t2 = centerTab (a - da2) (a + da2) (b - db2) (b + db2)
				t3 = rightTab (b - db2) (b + db2)

		go3 = undefined

		readTab t ptr = table ptr t1 `withD` 1
		leftTab a b c  = lins [1, a, 1, b, 0, c, 0] 
		rightTab a b c = lins [0, a, 0, b, 1, c, 1] 
		centerTab a b c d e = lins [0, a, 0, b, 1, c, 1, d, 0, e, 0]

partWaveChain2 :: Sig -> (Sig, Sig, Sig, Sig)
partWaveChain2 = partWaveChain [0.5, 0.25]

partWaveChain3 :: Sig -> (Sig, Sig, Sig, Sig) 
partWaveChain3 = partWaveChain [1/3, 0.25, 1/3, 0.25]

partWaveChain4 :: Sig -> (Sig, Sig, Sig, Sig) 
partWaveChain4 = partWaveChain [0.25, 0.2, 0.25, 0.2, 0.25, 0.2]

cfdChainWeights :: [Double] -> Sig -> [Sig]
cfdChainWeights xs ptr = getWeights ptr (getPairs xs)
	where
		getPairs xs = case xs of
			a:b:rest -> (a, b) : getPairs rest
			_        -> []

		getPairs ptr xs = case xs of
			[] -> [1]
			[(a, rada)] -> go1 a rada ptr
			a : as -> goN a (init as) (zip lengs $ makeAdjacentPairs xs) (last as)
		where
			go1 a da ptr = [readTab t1 ptr, readTab t2 ptr]
				where
					d = da / 2
					t1 = leftTab (a - d) (a + d)
					t2 = rightTab (a - d) (a + d)

			goN (start, startRad) center (end, endRad) = 
				startTab ++ centerTabs ++ [endTab]
				where
					startTab = leftTab (start - startRad) (2 * startRad) (1 - (start + startRad))
					endTab   = rightTab (1 - (end - endRad)) (2 * endRad) (end + endRad) 
					centerTabs = fmap toCenterTab center

					toCenterTab (leng, (a, rada), (b, radb)) = centerTab (leng - rada) (2 * rada)

			readTab t ptr = table ptr t1 `withD` 1
			leftTab a b c  = lins [1, a, 1, b, 0, c, 0] 
			rightTab a b c = lins [0, a, 0, b, 1, c, 1] 
			centerTab a b c d e = lins [0, a, 0, b, 1, c, 1, d, 0, e, 0]

			makeAdjacentPairs xs = case xs of
				[] -> []
				x:xs -> tail $ scanl (\(a, b) c -> (b, c)) (x, x) xs 

			lengs xs = tail $ scanl (\res (a, _) -> res + a) 0 xs 
-}