{-# Language FlexibleContexts #-}
-- | Midi.
module Csound.Control.Midi(
    MidiChn(..), MidiFun, toMidiFun, toMidiFun_, 
    Msg, Channel, midi, midin, pgmidi, ampCps,
    midi_, midin_, pgmidi_,
    -- * Mono-midi synth
    monoMsg, holdMsg, trigNamedMono, genMonoMsg, smoothMonoArg, 
    genFilteredMonoMsg, genFilteredMonoMsgTemp,

    -- ** Custom temperament
    monoMsgTemp, holdMsgTemp, genMonoMsgTemp,
    -- * Midi event streams
    midiKeyOn, midiKeyOff,
    -- * Reading midi note parameters
    cpsmidi, ampmidi, initc7, ctrl7, midiCtrl7, midiCtrl, umidiCtrl,
    ampmidinn,

    -- ** Custom temperament
    ampCps', cpsmidi', cpsmidi'D, cpsmidi'Sig, 

    -- * Overload
    tryMidi, tryMidi', MidiInstr(..), MidiInstrTemp(..)
) where

import Data.Boolean

import Csound.Typed
import Csound.Typed.Opcode hiding (initc7)
import Csound.Control.Overload
import Csound.Control.Instr(alwaysOn)
import Csound.Control.Evt(Tick)
import Csound.Types

import Csound.Tuning

-- | Specifies the midi channel or programm.
data MidiChn = ChnAll | Chn Int | Pgm (Maybe Int) Int
	deriving (Show, Eq)

type MidiFun a = (Msg -> SE a) -> SE a

toMidiFun :: Sigs a => MidiChn -> MidiFun a
toMidiFun x = case x of
	ChnAll  -> midi
	Chn n   -> midin n
	Pgm a b -> pgmidi a b

toMidiFun_ :: MidiChn -> MidiFun ()
toMidiFun_ x = case x of
	ChnAll  -> midi_
	Chn n   -> midin_ n
	Pgm a b -> pgmidi_ a b

ampCps :: Msg -> (D, D)
ampCps msg = (ampmidi msg 1, cpsmidi msg)

-- | Converts midi velocity number to amplitude. 
-- The first argument is dynamic range in decibels.
--
-- > ampmidinn (volMinDb, volMaxDb) volumeKey = amplitude
ampmidinn :: (D, D) -> D -> D
ampmidinn (volMin, volMax) volKey = ampdbfs (volMin + ir (ampmidid volKey (volMax - volMin)))

-- | Midi message convertion with custom temperament.
ampCps' :: Temp -> Msg -> (D, D)
ampCps' temp msg = (ampmidi msg 1, cpsmidi' temp msg)

-- | Midi message convertion to Hz with custom temperament.
cpsmidi' :: Temp -> Msg -> D
cpsmidi' (Temp t) msg = cpstmid msg t

-- | Midi pitch key convertion to Hz with custom temperament. It works on constants.
cpsmidi'D :: Temp -> D -> D
cpsmidi'D (Temp t) key = cpstuni key t

-- | Midi pitch key convertion to Hz with custom temperament. It works on signals.
cpsmidi'Sig :: Temp -> Sig -> Sig
cpsmidi'Sig (Temp t) key = cpstun 1 key t

-----------------------------------------------------------------------
-- Midi addons

-- mono midi

-- | Produces midi amplitude and frequency as a signal.
-- The signal fades out when nothing is pressed.
-- It can be used in mono-synths. Arguments are portamento time
-- and release time. A portamento time is time it takes for transition
-- from one note to another.
--
-- > monoMsg channel portamentoTime releaseTime
monoMsg :: MidiChn -> D -> D -> SE (Sig, Sig)
monoMsg = smoothMonoMsg cpsmidi

-- | Produces midi amplitude and frequency as a signal.
-- The signal fades out when nothing is pressed.
-- It can be used in mono-synths. Arguments are custom temperament, midi channel, portamento time
-- and release time. A portamento time is time it takes for transition
-- from one note to another. 
--
-- > monoMsgTemp temperament channel portamentoTime releaseTime
monoMsgTemp :: Temp -> MidiChn -> D -> D -> SE (Sig, Sig)
monoMsgTemp tm = smoothMonoMsg (cpsmidi' tm)

-- | Produces an argument for monophonic midi-synth.
-- The signal fades out when nothing is pressed.
-- It can be used in mono-synths. 
--
-- > genMonoMsg channel
genMonoMsg :: MidiChn -> SE MonoArg
genMonoMsg chn = genAmpCpsSig cpsmidi (toMidiFun chn)

-- | Just like mono @genMonoMsg@ but also we can alter the temperament. The temperament spec goes first. 
--
-- > genMonoMsgTemp temperament channel
genMonoMsgTemp :: Temp -> MidiChn -> SE MonoArg
genMonoMsgTemp tm chn = genAmpCpsSig (cpsmidi' tm) (toMidiFun chn)

smoothMonoArg :: D -> MonoArg -> MonoArg
smoothMonoArg time arg = arg { monoAmp = port (monoAmp arg) time, monoCps = port (monoCps arg) time }

smoothMonoMsg :: (Msg -> D) -> MidiChn -> D -> D -> SE (Sig, Sig)
smoothMonoMsg key2cps chn portTime relTime = do
	(MonoArg amp cps status _) <- genAmpCpsSig key2cps (toMidiFun chn)
	return (port amp portTime * port status relTime,  port cps portTime)


genFilteredMonoMsg :: MidiChn -> (D -> BoolD) -> SE MonoArg
genFilteredMonoMsg chn cond = filteredGenAmpCpsSig cpsmidi (toMidiFun chn) cond

-- | Just like mono @genMonoMsg@ but also we can alter the temperament. The temperament spec goes first. 
--
-- > genMonoMsgTemp temperament channel
genFilteredMonoMsgTemp :: Temp -> MidiChn -> (D -> BoolD) -> SE MonoArg
genFilteredMonoMsgTemp tm chn cond = filteredGenAmpCpsSig (cpsmidi' tm) (toMidiFun chn) cond

-- | Produces midi amplitude and frequency as a signal and holds the 
-- last value till the next one is present.
-- It can be used in mono-synths. Arguments are portamento time
-- and release time. A portamento time is time it takes for transition
-- from one note to another.
--
-- > holdMsg portamentoTime
holdMsg :: MidiChn -> D -> SE (Sig, Sig)
holdMsg = genHoldMsg cpsmidi

-- | Produces midi amplitude and frequency as a signal and holds the 
-- last value till the next one is present.
-- It can be used in mono-synths. Arguments are portamento time
-- and release time. A portamento time is time it takes for transition
-- from one note to another.
--
-- > holdMsg portamentoTime
holdMsgTemp :: Temp -> MidiChn -> D -> SE (Sig, Sig)
holdMsgTemp tm = genHoldMsg (cpsmidi' tm)

genHoldMsg :: (Msg -> D) -> MidiChn -> D -> SE (Sig, Sig)
genHoldMsg key2cps channel portTime = do
	(amp, cps) <- genHoldAmpCpsSig key2cps (toMidiFun_ channel)
	return (port amp portTime,  port cps portTime)



genAmpCpsSig :: (Msg -> D) -> ((Msg -> SE Sig) -> SE Sig) -> SE MonoArg
genAmpCpsSig key2cps midiFun = do
    ref <- newGlobalRef ((0, 0) :: (Sig, Sig))
    status <- midiFun (instr ref)
    (amp, cps) <- readRef ref
    return $ makeMonoArg (amp, cps) status	
	where
        makeMonoArg (amp, cps) status = MonoArg kamp kcps resStatus retrig
            where
                kamp = downsamp amp
                kcps = downsamp cps
                kstatus = downsamp status
                resStatus = ifB (kstatus ==* 0) 0 1
                retrig = changed [kamp, kcps, kstatus]

        instr :: Ref (Sig, Sig) -> Msg -> SE Sig
        instr hNote msg = do
            writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg)
            return 1		

filteredGenAmpCpsSig :: (Msg -> D) -> ((Msg -> SE Sig) -> SE Sig) -> (D -> BoolD) -> SE MonoArg
filteredGenAmpCpsSig key2cps midiFun cond  = do
    ref <- newGlobalRef ((0, 0) :: (Sig, Sig))
    status <- midiFun (instr ref)
    (amp, cps) <- readRef ref
    return $ makeMonoArg (amp, cps) status  
    where
        makeMonoArg (amp, cps) status = MonoArg kamp kcps resStatus retrig
            where
                kamp = downsamp amp
                kcps = downsamp cps
                kstatus = downsamp status
                resStatus = ifB (kstatus ==* 0) 0 1
                retrig = changed [kamp, kcps, kstatus]

        instr :: Ref (Sig, Sig) -> Msg -> SE Sig
        instr hNote msg = do
            resRef <- newRef 0
            whenElseD (cond $ key2cps msg)
                (do
                    writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg)
                    writeRef resRef 1)
                (do
                    writeRef resRef 0)
            readRef resRef            

genHoldAmpCpsSig :: (Msg -> D) -> ((Msg -> SE ()) -> SE ()) -> SE (Sig, Sig)
genHoldAmpCpsSig key2cps midiFun = do
	ref <- newGlobalRef ((0, 0) :: (Sig, Sig))
	midiFun (instr ref)	
	(amp, cps) <- readRef ref
	return (downsamp amp, downsamp cps)
	where 
		instr :: Ref (Sig, Sig) -> Msg -> SE ()
		instr hNote msg = do
			writeRef hNote (sig $ ampmidi msg 1, sig $ key2cps msg)			

-- | Creates a named instrument that can be triggered with Csound API. 
-- This way we can create a csd file that can be used inside another program/language.
--
-- It simulates the input for monophonic midi-like instrument. Notes are encoded with messages:
--
-- > i "givenName" 1 pitchKey volumeKey     -- note on
-- > i "givenName" 0 pitchKey volumeKey     -- note off
--
-- The output is a pair of signals @(midiVolume, midiPitch)@.
trigNamedMono :: String -> SE MonoArg
trigNamedMono name = namedMonoMsg name

namedAmpCpsSig:: String -> SE (Sig, Sig, Sig)
namedAmpCpsSig name = do
	ref <- newGlobalRef ((0, 0) :: (Sig, Sig))	
	statusRef <- newGlobalRef (0 :: Sig)
	status <- trigByNameMidi name (instr statusRef ref)
	writeRef statusRef status 
	let resStatus = ifB (downsamp status ==* 0) 0 1
	(amp, cps) <- readRef ref
	return (downsamp amp, downsamp cps, resStatus)
	where 
		instr :: Ref Sig -> Ref (Sig, Sig) -> (D, D, Unit) -> SE Sig
		instr statusRef hNote (pitchKey, volKey, _) = do
			curId <- readRef statusRef
			myIdRef <- newRef (ir curId)
			myId <- readRef myIdRef			
			when1 (curId ==* (sig $ myId + 1)) $ do
				writeRef hNote (sig volKey, sig pitchKey)
			return 1

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

-- | Listens to midi on event on the given key as event stream.
-- The event stream carries the level of volume (ranges from 0 to 1).
midiKeyOn :: MidiChn -> D -> SE (Evt D)
midiKeyOn = midiKeyOnBy . toMidiFun

-- | Listens to midi on event off the given key as event stream.
midiKeyOff :: MidiChn -> D -> SE Tick
midiKeyOff = midiKeyOffBy . toMidiFun

midiKeyOnBy :: MidiFun Sig -> D -> SE (Evt D)
midiKeyOnBy midiFun key = do	
	chRef  <- newGlobalRef (0 :: Sig)
	evtRef <- newGlobalRef (0 :: Sig)
	writeRef chRef =<< midiFun instr

	alwaysOn $ do
		a <- readRef chRef
		writeRef evtRef $ diff a

	evtSig <- readRef evtRef
	return $ filterE ( >* 0) $ snaps evtSig
	where
		instr msg = do
			print' [notnum msg] 
			return $ ifB (boolSig $ notnum msg ==* key) (sig $ ampmidi msg 1) 0


midiKeyOffBy :: MidiFun Sig -> D -> SE Tick
midiKeyOffBy midiFun key = do	
	chRef  <- newGlobalRef (0 :: Sig)
	evtRef <- newGlobalRef (0 :: Sig)
	writeRef chRef =<< midiFun instr

	alwaysOn $ do
		a <- readRef chRef
		writeRef evtRef $ diff a

	evtSig <- readRef evtRef
	return $ fmap (const unit) $ filterE ( `lessThan` 0) $ snaps evtSig
	where
		instr msg = do
			print' [notnum msg] 
			return $ ifB (boolSig $ notnum msg ==* key) (sig $ ampmidi msg 1) 0

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

-- | Initialization of the midi control-messages.
initc7 :: D -> D -> D -> SE ()
initc7 = initMidiCtrl 

-- | Initializes midi control and get the value in the specified range.
midiCtrl7 :: D -> D -> D -> D -> D -> SE Sig
midiCtrl7 chno ctrlno ival imin imax = do
    initc7 chno ctrlno ival
    return $ ctrl7 chno ctrlno imin imax
    
-- | Initializes midi control and get the value in the range (-1) to 1.
midiCtrl :: D -> D -> D -> SE Sig
midiCtrl chno ctrlno ival = midiCtrl7 chno ctrlno ival (-1) 1
    
-- | Unipolar midiCtrl. Initializes midi control and get the value in the range 0 to 1.
umidiCtrl :: D -> D -> D -> SE Sig
umidiCtrl chno ctrlno ival = midiCtrl7 chno ctrlno ival 0 1

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

-- | Invokes ooverloaded instruments with midi.
-- Example:
--
-- > dac $ tryMidi (mul (fades 0.01 0.1) . tri)
tryMidi :: (MidiInstr a, Sigs (MidiInstrOut a)) => a -> SE (MidiInstrOut a)
tryMidi x = midi $ onMsg x

-- | Invokes ooverloaded instruments with midi and custom temperament.
-- Example:
--
-- > dac $ tryMidi' youngTemp2 (mul (fades 0.01 0.1) . tri)
tryMidi' :: (MidiInstrTemp a, Sigs (MidiInstrOut a)) => Temp -> a -> SE (MidiInstrOut a)
tryMidi' tm x = midi $ onMsg' tm x