{-# Language DeriveFunctor #-}
module Csound.Typed.GlobalState.Elements(
    -- * Identifiers
    IdMap(..), saveId, newIdMapId,
    -- ** Gens
    GenMap, newGen, newGenId, nextGlobalGenCounter, newTabOfGens,
    WriteGenMap, newWriteGen, newWriteTab,
    -- Sf2
    SfFluid(..), SfSpec(..), SfMap, newSf, sfVar, renderSf,
    -- ** Band-limited waveforms
    BandLimited(..), BandLimitedMap(..), BandLimitedId(..),
    saveBandLimited, renderBandLimited,
    readBandLimited, readHardSyncBandLimited,

    -- ** String arguments
    StringMap, newString,
    -- * Midi
    MidiType(..), Channel, MidiMap, MidiKey(..), saveMidiInstr,
    -- * Global variables
    Globals(..), newPersistentGlobalVar, newClearableGlobalVar,
    newPersistentGloabalArrVar,
    renderGlobals, bpmVarName, bpmVar,
    -- * Instruments
    Instrs(..), saveInstr, getInstrIds, -- newInstrId, saveInstrById, saveInstr, CacheName, makeCacheName, saveCachedInstr, getInstrIds,
    -- * Named instruments
    NamedInstrs(..), saveNamedInstr,
    -- * Src
    InstrBody, getIn, sendOut, sendChn, sendGlobal, chnPargId,
    Event(..),
    ChnRef(..), chnRefFromParg, chnRefAlloc, readChn, writeChn, chnUpdateUdo,
    subinstr, subinstr_, event_i, event, safeOut, autoOff, changed,
    -- * OSC listen ports
    OscListenPorts, getOscPortVar,
    -- * Macros inits
    MacrosInits, MacrosInit(..), initMacros,
    -- * Udo plugins
    UdoPlugin, addUdoPlugin, getUdoPluginNames,
    tabQueuePlugin, tabQueue2Plugin,
    zdfPlugin, solinaChorusPlugin, audaciouseqPlugin, adsr140Plugin,
    diodePlugin, korg35Plugin, zeroDelayConvolutionPlugin,
    pitchShifterDelayPlugin,
    analogDelayPlugin, distortionPlugin, envelopeFolollowerPlugin, flangerPlugin, freqShifterPlugin,
    loFiPlugin, panTremPlugin, monoTremPlugin, phaserPlugin, pitchShifterPlugin, reversePlugin,
    ringModulatorPlugin, stChorusPlugin, stereoPingPongDelayPlugin,
    tapeEchoPlugin,
    delay1kPlugin,
    liveRowPlugin, liveRowsPlugin,
    ambiRowPlugin, ambiRowMp3Plugin
) where

import Data.List
import Data.Hashable

import Control.Monad.Trans.State.Strict
import Control.Monad(zipWithM_)
import Data.Default
import qualified Data.Map as M
import qualified Data.IntMap as IM

import Csound.Dynamic.Types hiding (genId)
import Csound.Dynamic.Build
import Csound.Dynamic.Build.Numeric()

import Csound.Typed.GlobalState.Opcodes

-- tables of identifiers

data IdMap a = IdMap
    { idMapContent :: M.Map a Int
    , idMapNewId   :: Int
    } deriving (Eq, Ord)

instance Default (IdMap a) where
    def = IdMap def 1

saveId :: Ord a => a -> State (IdMap a) Int
saveId a = state $ \s ->
    case M.lookup a (idMapContent s) of
        Nothing ->
            let newId = idMapNewId s
                s1    = s{ idMapContent = M.insert a newId (idMapContent s)
                         , idMapNewId = succ newId }
            in  (newId, s1)
        Just n  -> (n, s)

newIdMapId :: State (IdMap a) Int
newIdMapId = state $ \s ->
    let newId = idMapNewId s
        s1 = s { idMapNewId = succ newId }
    in  (newId, s1)

-- gens

type GenMap = IdMap Gen

newGen :: Gen -> State GenMap Int
newGen = saveGenId

newTabOfGens :: [Gen] -> State GenMap Int
newTabOfGens = (saveGenId . intTab =<<) . mapM saveGenId
    where intTab ns = Gen (nextPowOfTwo $ length ns) (IntGenId (-2)) (fmap fromIntegral ns) Nothing

nextPowOfTwo :: Int -> Int
nextPowOfTwo n
    | frac == 0 = n
    | otherwise = 2 ^ ((integ :: Int) + 1)
    where
        (integ, frac) = (properFraction $ logBase 2 (fromIntegral n)) :: (Int, Double)

saveGenId :: Ord a => a -> State (IdMap a) Int
saveGenId a = state $ \s ->
    case M.lookup a (idMapContent s) of
        Nothing ->
            let newId = nextReadOnlyTableId $ idMapNewId s
                s1    = s{ idMapContent = M.insert a newId (idMapContent s)
                         , idMapNewId = nextReadOnlyTableId newId }
            in  (newId, s1)
        Just n  -> (n, s)

newGenId :: State GenMap Int
newGenId = state $ \s ->
    let newId = idMapNewId s
        s1 = s { idMapNewId = nextReadOnlyTableId newId }
    in  (newId, s1)

-- writeable gens

type WriteGenMap = [(Int, Gen)]

newWriteGen :: Gen -> State WriteGenMap E
newWriteGen = fmap int . saveWriteGenId

newWriteTab :: Int -> State WriteGenMap E
newWriteTab = newWriteGen . fromSize
    where fromSize n = Gen n (IntGenId 2) (replicate n 0) Nothing

saveWriteGenId :: Gen -> State WriteGenMap Int
saveWriteGenId a = state $ \s -> case s of
    []         -> (initId, [(initId, a)])
    (i,_):_    ->   let newId = nextWriteTableId i
                    in (newId, (newId, a) : s)
    where
        initId = tableWriteStep

tableWriteStep :: Int
tableWriteStep = 10

nextReadOnlyTableId :: Int -> Int
nextReadOnlyTableId x
    | y `mod` tableWriteStep == 0 = y + 1
    | otherwise                   = y
    where y = x + 1

nextWriteTableId :: Int -> Int
nextWriteTableId x = tableWriteStep + x

-- strings

type StringMap = IdMap String

newString :: String -> State StringMap Prim
newString = fmap PrimInt . saveId

-- gen counter

nextGlobalGenCounter :: State Int Int
nextGlobalGenCounter = state $ \s -> (s, s + 1)

-- sf

data SfFluid = SfFluid
    { sfId   :: Int
    , sfVars :: [Var] }

data SfSpec = SfSpec
    { sfName    :: String
    , sfBank    :: Int
    , sfProgram :: Int
    } deriving (Eq, Ord, Show)

type SfMap = IdMap SfSpec

newSf :: SfSpec -> State SfMap Int
newSf = saveId

sfVar :: Int -> E
sfVar n = readOnlyVar (VarVerbatim Ir $ sfEngineName n)

sfEngineName :: Int -> String
sfEngineName n = "gi_Sf_engine_" ++ show n

sfInstrName :: Int -> String
sfInstrName n = "i_Sf_instr_" ++ show n

renderSf :: Monad m => SfSpec -> Int -> DepT m ()
renderSf (SfSpec name bank prog) n = verbatim $
    engineStr ++ "\n" ++
    loadStr   ++ "\n" ++
    selectProgStr ++ "\n"
    where
        engineStr = engineName ++ " fluidEngine"
        loadStr   = insName ++ " fluidLoad \"" ++ name ++ "\", " ++  engineName ++ ", 1"
        selectProgStr = "fluidProgramSelect " ++ engineName ++ ", 1, " ++ insName
            ++ ", " ++ show bank ++ ", " ++ show prog

        engineName = sfEngineName n
        insName    = sfInstrName n

-- band-limited waveforms (used with vco2init)

data BandLimited = Saw | Pulse | Square | Triangle | IntegratedSaw | UserGen Gen
    deriving (Eq, Ord)

data BandLimitedId = SimpleBandLimitedWave Int | UserBandLimitedWave Int
    deriving (Eq, Ord)

bandLimitedIdToExpr :: BandLimitedId -> E
bandLimitedIdToExpr x = case x of
    SimpleBandLimitedWave simpleId -> int simpleId
    UserBandLimitedWave   userId   -> noRate $ ReadVar $ bandLimitedVar userId

bandLimitedVar :: Show a => a -> Var
bandLimitedVar userId = Var GlobalVar Ir ("BandLim" ++ show userId)

data BandLimitedMap = BandLimitedMap
    { simpleBandLimitedMap :: M.Map BandLimited BandLimitedId
    , vcoInitMap     :: GenMap
    } deriving (Eq, Ord)

instance Default BandLimitedMap where
    def = BandLimitedMap def def

saveBandLimited :: BandLimited -> State BandLimitedMap BandLimitedId
saveBandLimited x = case x of
    Saw             -> simpleWave 1  0
    IntegratedSaw   -> simpleWave 2  1
    Pulse           -> simpleWave 4  2
    Square          -> simpleWave 8  3
    Triangle        -> simpleWave 16 4
    UserGen gen     -> userGen gen
    where
        simpleWave writeId readId = state $ \blMap ->
            if (M.member x (simpleBandLimitedMap blMap))
                then (SimpleBandLimitedWave readId, blMap)
                else (SimpleBandLimitedWave readId, blMap { simpleBandLimitedMap = M.insert x (SimpleBandLimitedWave writeId) (simpleBandLimitedMap blMap) })

        userGen gen = state $ \blMap ->
            let genMap = vcoInitMap blMap
                (newId, genMap1) = runState (saveId gen) genMap
                blMap1 = blMap { vcoInitMap = genMap1 }
            in  (UserBandLimitedWave newId, blMap1)


renderBandLimited :: Monad m => GenMap -> BandLimitedMap -> DepT m ()
renderBandLimited genMap blMap =
    if isEmptyBlMap blMap
        then return ()
        else render (idMapNewId genMap) (M.toList $ idMapContent $ vcoInitMap blMap) (M.toList $ simpleBandLimitedMap blMap)
    where
        isEmptyBlMap m = (M.null $ simpleBandLimitedMap m) && (M.null $ idMapContent $ vcoInitMap m)

        render lastGenId gens vcos = do
            writeVar freeVcoVar $ int (lastGenId + length gens + 100)
            mapM_ (renderGen lastGenId) gens
            mapM_ renderVco vcos

        renderGen :: Monad m => Int -> (Gen, Int) -> DepT m ()
        renderGen lastGenId (gen, genId) = do
            renderFtgen lastGenId (gen, genId)
            renderVcoGen genId
            renderVcoVarAssignment genId

        freeVcoVar = Var GlobalVar Ir "free_vco"
        ftVar n = Var GlobalVar Ir $ "vco_table_" ++ show n

        renderFtgen lastGenId (g, n) = writeVar (ftVar n) $ ftgen (int $ lastGenId + n) g

        renderVcoGen ftId  = do
            ft   <- readVar (ftVar ftId)
            free <- readVar freeVcoVar
            writeVar freeVcoVar $ vco2init [-ft, free, 1.05, -1, -1, ft]

        renderVcoVarAssignment n = writeVar (bandLimitedVar n) =<< (fmap negate $ readVar (ftVar n))

        renderVco :: Monad m => (BandLimited, BandLimitedId) -> DepT m ()
        renderVco (_bandLimited, blId) = case blId of
            SimpleBandLimitedWave waveId -> do
                free <- readVar freeVcoVar
                writeVar freeVcoVar $ vco2init [int waveId, free]
            UserBandLimitedWave   _      -> return ()

readBandLimited :: Maybe E -> BandLimitedId -> E -> E
readBandLimited mphase n cps = oscilikt 1 cps (vco2ft cps (bandLimitedIdToExpr n)) mphase

readHardSyncBandLimited :: Maybe BandLimitedId -> Maybe E -> BandLimitedId -> E -> E -> E
readHardSyncBandLimited msmoothShape mphase n slaveCps masterCps = smoothWave * readShape n phasorSlave slaveCps
    where
        (phasorMaster, syncMaster) = syncphasor masterCps 0 Nothing
        (phasorSlave,  _syncSlave) = syncphasor slaveCps syncMaster mphase

        smoothWave = case msmoothShape of
            Nothing    -> 1
            Just shape -> readShape shape phasorMaster masterCps

        readShape shapeId phasor freq = tableikt phasor (vco2ft freq (bandLimitedIdToExpr shapeId))

----------------------------------------------------------
-- Midi

type Channel = Int

data MidiType = Massign | Pgmassign (Maybe Int)
    deriving (Show, Eq, Ord)

data MidiKey = MidiKey MidiType Channel
    deriving (Show, Eq, Ord)

type MidiMap m = M.Map MidiKey (DepT m ())

saveMidiInstr :: Monad m => MidiType -> Channel -> DepT m () -> MidiMap m -> MidiMap m
saveMidiInstr ty chn body = M.insertWith (flip (>>)) (MidiKey ty chn) body

-- global variables

data Globals = Globals
    { globalsNewId  :: Int
    , globalsVars   :: [AllocVar] }

data AllocVar = AllocVar
        { _allocVarType     :: GlobalVarType
        , _allocVar         :: Var
        , _allocVarInit     :: E }
    | AllocArrVar
        { _allocArrVar :: Var
        , _allocArrVarSizes :: [E] }

data GlobalVarType = PersistentGlobalVar | ClearableGlobalVar
    deriving (Eq)

instance Default Globals where
    def = Globals 0 [AllocVar PersistentGlobalVar bpmVar 110]

bpmVar :: Var
bpmVar = Var GlobalVar Kr bpmVarName

bpmVarName :: String
bpmVarName = "gBpmVar"

newGlobalVar :: GlobalVarType -> Rate -> E -> State Globals Var
newGlobalVar ty rate initVal = state $ \s ->
    let newId = globalsNewId s
        var   = Var GlobalVar rate ('g' : show newId)
        s1    = s { globalsNewId = succ newId
                  , globalsVars  = AllocVar ty var initVal : globalsVars s }
    in  (var, s1)

newPersistentGlobalVar :: Rate -> E -> State Globals Var
newPersistentGlobalVar = newGlobalVar PersistentGlobalVar

newClearableGlobalVar :: Rate -> E -> State Globals Var
newClearableGlobalVar = newGlobalVar ClearableGlobalVar

newPersistentGloabalArrVar :: Rate -> [E] -> State Globals Var
newPersistentGloabalArrVar rate sizes = state $ \s ->
    let newId = globalsNewId s
        var   = Var GlobalVar rate ('g' : show newId)
        s1    = s { globalsNewId = succ newId
                  , globalsVars  = AllocArrVar var sizes : globalsVars s }
    in (var, s1)

renderGlobals :: Monad m => Globals -> (DepT m (), DepT m ())
renderGlobals a = (initAll, clear)
    where
        initAll = mapM_ initAlloc gs
        clear   = mapM_ clearAlloc clearable
        clearable = filter isClearable gs
        gs = globalsVars a

        initAlloc x = case x of
            AllocVar _  var initProc -> initVar var initProc
            AllocArrVar var sizes    -> initArr var sizes

        clearAlloc x = case x of
            AllocVar _  var initProc -> writeVar var initProc
            AllocArrVar _ _          -> return ()

        isClearable x = case x of
            AllocVar ty _ _ -> ty == ClearableGlobalVar
            _               -> False

-----------------------------------------------------------------
-- instrs

data Instrs = Instrs
    { instrsCache   :: IM.IntMap InstrId
    , instrsNewId   :: Int
    , instrsContent :: [(InstrId, InstrBody)]
    }

instance Default Instrs where
    def = Instrs IM.empty 18 []

getInstrIds :: Instrs -> [InstrId]
getInstrIds = fmap fst . instrsContent

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


saveInstr :: InstrBody -> State Instrs InstrId
saveInstr body = state $ \s ->
    let h = hash body
    in  case IM.lookup h $ instrsCache s of
            Just  n -> (n, s)
            Nothing ->
                let newId = instrsNewId s
                    s1    = s { instrsCache   = IM.insert h (intInstrId newId) $ instrsCache s
                              , instrsNewId   = succ newId
                              , instrsContent = (intInstrId newId, body) : instrsContent s }
                in  (intInstrId newId, s1)

{-
saveCachedInstr :: InstrBody -> State Instrs InstrId
saveCachedInstr name body = state $ \s ->
    case IM.lookup name $ instrsCache s of
        Just n  -> (n, s)
        Nothing ->
            let newId   = instrsNewId s
                s1      = s { instrsCache   = IM.insert name (intInstrId newId) $ instrsCache s
                            , instrsNewId   = succ newId
                            , instrsContent = (intInstrId newId, body) : instrsContent s }
            in  (intInstrId newId, s1)

newInstrId :: State Instrs InstrId
newInstrId = state $ \s ->
    let newId   = instrsNewId s
        s1      = s { instrsNewId = succ newId }
    in  (intInstrId newId, s1)

saveInstrById :: InstrId -> InstrBody -> State Instrs ()
saveInstrById instrId body = state $ \s ->
    let s1 = s { instrsContent = (instrId, body) : instrsContent s }
    in  ((), s1)

saveInstr :: InstrBody -> State Instrs InstrId
saveInstr body = do
    newId <- newInstrId
    saveInstrById newId body
    return newId
-}

-----------------------------------------------------------------
-- named instrs

newtype NamedInstrs = NamedInstrs { unNamedInstrs :: [(String, InstrBody)] }

instance Default NamedInstrs where
    def = NamedInstrs []

saveNamedInstr :: String -> InstrBody -> State NamedInstrs ()
saveNamedInstr name body = state $ \(NamedInstrs xs) -> ((), NamedInstrs $ (name, body) : xs)

-----------------------------------------------------------------
-- sound sources

getIn :: Monad m => Int -> DepT m [E]
getIn arity
    | arity == 0    = return []
    | otherwise     = ($ arity ) $ mdepT $ mopcs "inch" (replicate arity Ar, replicate arity Kr) (fmap int [1 .. arity])

sendOut :: Monad m => Int -> [E] -> DepT m ()
sendOut arity sigs
    | arity == 0    = return ()
    | otherwise     = do
        vars <- newLocalVars (replicate arity Ar) (return $ replicate arity 0)
        zipWithM_ writeVar vars sigs
        vals <- mapM readVar vars
        depT_ $ opcsNoInlineArgs name [(Xr, replicate arity Ar)] vals
    where
        name
            | arity == 1 = "out"
            | arity == 2 = "outs"
            | arity == 4 = "outq"
            | arity == 6 = "outh"
            | arity == 8 = "outo"
            | arity == 16 = "outx"
            | arity == 32 = "out32"
            | otherwise = "outc"

sendGlobal :: Monad m => Int -> [E] -> State Globals ([E], DepT m ())
sendGlobal arityOuts sigs = do
    vars <- mapM (uncurry newClearableGlobalVar) $ replicate arityOuts (Ar, 0)
    return (fmap readOnlyVar vars, zipWithM_ (appendVarBy (+)) vars sigs)

sendChn :: Monad m => Int -> Int -> [E] -> DepT m ()
sendChn arityIns arityOuts sigs = writeChn (chnRefFromParg (chnPargId arityIns) arityOuts) sigs

chnPargId :: Int -> Int
chnPargId arityIns = 4 + arityIns

-- scaleVolumeFactor :: E -> E
-- scaleVolumeFactor = (setRate Ir (C.midiVolumeFactor (pn 1)) * )

-- guis

--------------------------------------------------------
-- Osc listeners

newtype OscListenPorts = OscListenPorts (IM.IntMap Var)

instance Default OscListenPorts where
    def = OscListenPorts IM.empty

getOscPortVar :: Int -> State (OscListenPorts, Globals) Var
getOscPortVar portId = state $ \st@(OscListenPorts m, globals) -> case IM.lookup portId m of
        Just a  -> (a, st)
        Nothing -> onNothing m globals
    where
        onNothing m globals = (var, (OscListenPorts m1, newGlobals))
            where
                (var, newGlobals) = runState (allocOscPortVar portId) globals
                m1 = IM.insert portId var m


allocOscPortVar :: Int -> State Globals Var
allocOscPortVar oscPort = newGlobalVar PersistentGlobalVar Ir $ oscInit (fromIntegral oscPort)

----------------------------------------------------------
-- macros arguments

type MacrosInits = M.Map String MacrosInit

data MacrosInit
    = MacrosInitDouble { macrosInitName :: String, macrosInitValueDouble :: Double }
    | MacrosInitString { macrosInitName :: String, macrosInitValueString :: String }
    | MacrosInitInt    { macrosInitName :: String, macrosInitValueInt    :: Int  }
    deriving (Show, Eq, Ord)

initMacros :: MacrosInit -> State MacrosInits ()
initMacros macrosInit = modify $ \xs -> M.insert (macrosInitName macrosInit)  macrosInit xs

--------------------------------------------------------
-- Udo plugins

newtype UdoPlugin  = UdoPlugin { unUdoPlugin :: String }

addUdoPlugin :: UdoPlugin -> State [UdoPlugin] ()
addUdoPlugin a = modify (a :)

getUdoPluginNames :: [UdoPlugin] -> [String]
getUdoPluginNames xs = nub (fmap unUdoPlugin xs)

-- tabQueue

tabQueuePlugin  = UdoPlugin "tabQueue"
tabQueue2Plugin = UdoPlugin "tabQueue2"

----------------------------------------------------------
-- Steven Yi wonderful UDOs

zdfPlugin, solinaChorusPlugin, audaciouseqPlugin, adsr140Plugin, diodePlugin, korg35Plugin,
  zeroDelayConvolutionPlugin, analogDelayPlugin, distortionPlugin, envelopeFolollowerPlugin,
  flangerPlugin, freqShifterPlugin, loFiPlugin, panTremPlugin, monoTremPlugin, phaserPlugin,
  pitchShifterPlugin, pitchShifterDelayPlugin, reversePlugin, ringModulatorPlugin, stChorusPlugin,
  stereoPingPongDelayPlugin, tapeEchoPlugin, delay1kPlugin,
  ambiRowPlugin, ambiRowMp3Plugin, liveRowPlugin, liveRowsPlugin, tabQueuePlugin, tabQueue2Plugin :: UdoPlugin

zdfPlugin           = UdoPlugin "zdf"               -- Zero delay filters
solinaChorusPlugin  = UdoPlugin "solina_chorus"     -- solina chorus
audaciouseqPlugin   = UdoPlugin "audaciouseq"       -- audacious 10 band EQ
adsr140Plugin       = UdoPlugin "adsr140"           -- adsr with retriggering
diodePlugin         = UdoPlugin "diode"             -- diode ladder filter
korg35Plugin        = UdoPlugin "korg35"            -- korg 35 filter
zeroDelayConvolutionPlugin = UdoPlugin "zero-delay-convolution"  -- zero delay convolutio by Victor Lazzarini
pitchShifterDelayPlugin = UdoPlugin "PitchShifterDelay" -- pitch shifter delay

analogDelayPlugin = UdoPlugin "MultiFX/AnalogDelay"
distortionPlugin = UdoPlugin "MultiFX/Distortion"
envelopeFolollowerPlugin = UdoPlugin "MultiFX/EnvelopeFollower"
flangerPlugin = UdoPlugin "MultiFX/Flanger"
freqShifterPlugin = UdoPlugin "MultiFX/FreqShifter"
loFiPlugin = UdoPlugin "MultiFX/LoFi"
panTremPlugin = UdoPlugin "MultiFX/PanTrem"
monoTremPlugin = UdoPlugin "MultiFX/MonoTrem"
phaserPlugin = UdoPlugin "MultiFX/Phaser"
pitchShifterPlugin = UdoPlugin "MultiFX/PitchShifter"
reversePlugin = UdoPlugin "MultiFX/Reverse"
ringModulatorPlugin = UdoPlugin "MultiFX/RingModulator"
stChorusPlugin = UdoPlugin "MultiFX/StChorus"
stereoPingPongDelayPlugin = UdoPlugin "MultiFX/StereoPingPongDelay"

tapeEchoPlugin = UdoPlugin "MultiFX/TapeEcho"

delay1kPlugin = UdoPlugin "Utility/Delay1k"

liveRowPlugin = UdoPlugin "LiveRow"    -- live like trigger, mono
liveRowsPlugin = UdoPlugin "LiveRows"  --                    stereo

ambiRowPlugin = UdoPlugin "AmbiRow"        -- ambi trigger, wav
ambiRowMp3Plugin = UdoPlugin "AmbiRowMp3"  --               mp3