module CsoundExpr.Translator.Ftable 
    (toCsFtables, 
     ftableInfo,
     getFtablesFromInstr, getFtablesFromNote,
     setFtablesInInstr,   setFtablesInNote)     
where

import Data.List
import qualified Data.Map as Map

import CsoundExpr.Translator.ExprTree.Tree
import CsoundExpr.Translator.ExprTree.ExprTree
import CsoundExpr.Translator.Cs.Utils

import qualified CsoundExpr.Translator.Cs.CsTree     as La
import qualified CsoundExpr.Translator.Cs.CsoundFile as Cs

import CsoundExpr.Translator.Types


substFtablesGen :: (a -> [FtableId]) -> (FtableInfo -> a -> a) ->
                   a -> (a, [Cs.Ftable])
substFtablesGen toFtables fromFtables t = (fromFtables fs t, toCsFtables fs)
    where fs = Map.fromList $ zip (addFtempty $ nub $ toFtables t) [0..]
          addFtempty = let ft0 = (Pure, La.EmptyFtable)
                       in  (ft0 : ) . delete ft0


--------------------------------------------------------
-- translate ftables

toCsFtables :: FtableInfo -> [Cs.Ftable]
toCsFtables fs = map f $ filter ((/= 0 ) . snd) $ Map.toList fs
    where f ((_, ft), id) = Cs.Ftable id 
                            (Cs.FtableInits 0 (La.ftableSize ft))
                            (Cs.GEN (La.ftableGENId ft) $ 
                             map toGens $ La.ftableGENArgs ft)
          toGens (Node a _)
              | isFtable' $ exprOp $ exprTag a = Cs.ValueInt $ fs Map.! (ftableId a)
              | otherwise = toValue $ La.value $ exprOp $ exprTag a

--------------------------------------------------------
-- make ftableInfo

ftableInfo :: [FtableId] -> FtableInfo
ftableInfo = Map.fromList . flip zip [0..] . addFtempty . nub
    where addFtempty = let ft0 = (Pure, La.EmptyFtable)
                       in  (ft0 : ) . delete ft0


--------------------------------------------------------
-- extract ftables

getFtablesFromNote :: Note -> [FtableId]
getFtablesFromNote (_, _, x) = (subFtables =<< ) $ map f $ filter (La.isFtable . snd) x
    where f = mapSnd La.toFtable


getFtablesFromInstr :: Instr -> [FtableId]
getFtablesFromInstr = (getFtablesFromTree =<<)

getFtablesFromTree :: La.CsTree -> [FtableId]
getFtablesFromTree = (subFtables =<< ) . getFtables'
    where getFtables'  = map ftableId . filter p . foldTree (flip (:)) []
          p = isFtable' . exprOp . exprTag 

-----------------------------------------------------------
-- substitute ftables

setFtablesInNote :: FtableInfo -> Note -> Note
setFtablesInNote fs (t0, t1, vs) = (t0, t1, map f vs)
    where f x
            | La.isFtable $ snd x = let id = La.ValueInt $ (fs Map.!) $ mapSnd La.toFtable x
                                    in  (fst x, id)
            | otherwise = x
       

setFtablesInInstr :: FtableInfo -> Instr -> Instr
setFtablesInInstr fs = map (setFtablesInTree fs)


setFtablesInTree :: FtableInfo -> La.CsTree -> La.CsTree
setFtablesInTree fs = substTreeByFunc (f fs)
    where f fs (Node a _)
             | isFtable' $ exprOp $ exprTag a = Just $ toValueInt fs $ ftableId a
             | otherwise = Nothing

-----------------------------------------------------------
-- aux funs

subFtables :: FtableId -> [FtableId]
subFtables x = (x: ) $ (getFtablesFromTree =<<) $ La.ftableGENArgs $ snd x


ftableId :: Expr Id La.Rate La.CsExpr -> FtableId
ftableId a = (exprPurity a, La.toFtable $ La.value $ exprOp $ exprTag a)



isFtable' :: La.CsExpr -> Bool
isFtable' x = if La.isVal x
             then (La.isFtable $ La.value x)
             else False


toValueInt :: FtableInfo -> FtableId -> La.CsTree
toValueInt fs = mapType (const [La.I]) . La.int . (fs Map.! )