Score.hs

module CsoundExpr.Translator.Score
    (foldScores)
where

import Data.List
import Data.Function


import Temporal.Media(EventList(..))

import qualified Data.Map as Map

import CsoundExpr.Translator.ExprTree.Tree
import CsoundExpr.Translator.ExprTree.ExprTree
import CsoundExpr.Translator.ExprTree.ExprTree (Purity(..), exprTag)

import CsoundExpr.Translator.Cs.CsTree
import CsoundExpr.Translator.Cs.Utils

import CsoundExpr.Translator.Types


-- import Debug.Trace
-- debug msg x = trace (msg ++ " : " ++ show x) x


type NodeId   = (Int, [Int])
type PfieldId = (Int, IsStringPfield)

type IsStringPfield = Bool


-- | all values in given instrument node
type NodeSlice = (NodeId, [ValueId])

foldScores :: EventList Dur Instr -> [(Instr, [Note])]
foldScores x = zip instrs vals
    where instrs = zipWith substPfields ids rawInstrs
          (ids, vals) = unzip $ map (foldVals . formValues) sco
          rawInstrs   = map (thd . head) sco
          sco         = scoreList x


--scoreList :: Events Instr -> [[(Time, Time, Instr)]]
--scoreList = groupBy ((liftPredicateToList equalStructure) `on` thd) . 
--            sortBy (compare `on` thd) . toList

scoreList :: EventList Dur Instr -> [[(Time, Dur, Instr)]]
scoreList = iterScoreList [] . toList
    where iterScoreList res s = 
		case s of
		    []     -> res
		    (x:xs) -> let (x1, x2) = partition (pred x) xs
			      in  iterScoreList (res ++ [x : x1]) x2
	  pred = liftPredicateToList equalStructure `on` thd
	  toList (EventList _ xs) = xs


foldVals :: [(Time, Time, [(NodeId, ValueId)])] -> ([(NodeId, PfieldId)], [Note])
foldVals xs = (i, subst3 (valList v) xs)
    where (i, v) = assignPfieldIds $ filter (isPfield . snd) $ alignValuesByNodes xs 
          subst3 ys xs = [(a, b, y) | (y, (a, b, _)) <- zip ys xs]
          valList [] = repeat []
          valList xs = transpose xs


isPfield :: [ValueId] -> Bool
isPfield   = p . nub
    where p x = case x of
                    (x0 : x1 : _) -> True
                    _             -> False


alignValuesByNodes :: [(Time, Time, [(NodeId, ValueId)])] -> [NodeSlice]
alignValuesByNodes = map select . transpose . map thd
    where select x = (fst $ head x, map snd x)


substPfields :: [(NodeId, PfieldId)] -> Instr -> Instr
substPfields ids instr = foldl f instr ids  -- zip ids [4..]
    where f xs ((id0, id), n) =
              substListElem id0 (substTreeById id (p n) (xs !! id0)) xs
          p (id, isStr) 
            | isStr     = mapType (const [S]) $ param id
            | otherwise = mapType (const [I]) $ param id
             


substListElem :: Int -> a -> [a] -> [a]
substListElem id x xs = take id xs ++ [x] ++ drop (id+1) xs


             
formValues :: [(Time, Time, Instr)] -> [(Time, Time, [(NodeId, ValueId)])]
formValues = map f . sortBy p
    where f (t, d, expr) = (t, d, toVals expr)
          p (a1, b1, _) (a2, b2, _)
              | a1 < a2              = LT
              | a1 == a2 && a1 < a2  = LT
              | a1 == a2 && a1 == a2 = EQ
              | otherwise            = GT



toVals :: Instr -> [(NodeId, ValueId)]
toVals = (addId0 =<< ) . zip [0..] . map getVals
    where getVals  = map (mapSnd value') . filter (isVal . exprOp . exprTag . snd) . toIdList
          value' x = (exprPurity x, value $ exprOp $ exprTag x)
          addId0 (id0, xs) = [((id0, ids), vs) | (ids, vs) <- xs]
          

assignPfieldIds :: [NodeSlice] -> ([(NodeId, PfieldId)], [[ValueId]])
assignPfieldIds xs = (zip (map fst xs) (zip ids isStr), orderValsWithIds ids vals)
    where ids   = map (+4) $ numerate $ map snd xs
          isStr = map (isStringValueId . head . snd) xs
          vals  = map snd xs
	  


orderValsWithIds :: [Int] -> [[ValueId]] -> [[ValueId]]
orderValsWithIds ids vals = map snd $ sortOn fst $ nubOn fst $ zip ids vals


sortOn :: Ord b => (a -> b) -> [a] -> [a]
sortOn f = sortBy (compare `on` f)

nubOn :: Eq b => (a -> b) -> [a] -> [a]
nubOn f = nubBy ((==) `on` f)


isStringValueId :: ValueId -> Bool
isStringValueId (_, v) = isString v 


-- numerate : 
--   assigns numbers to unique elements of list
--   (it's for (ExprTree -> ExprSeq) optimisation, 
--   pfields with the same values should have same pfield ids)

numerate :: Ord b => [b] -> [Int]
numerate = fst . foldl f ([], Map.empty) 
    where f (s, m) b 
              | Map.member b m = (s ++ [m Map.! b], m)
              | otherwise      = (s ++ [id], mNew)
              where id = Map.size m
                    mNew = Map.insert b id m