{- $Id: PPT.hs,v 1.20.2.31 2009/02/20 18:00:02 orlov Exp $ -}
{- vim: set syntax=haskell expandtab tabstop=4: -}

module PPT (
 Tree(..),
 getTid, ppt
) where

import Prelude
import List (partition)
import Maybe (mapMaybe)
import XSG

------------------------------ DATA ------------------------------
type Tid   = Index

type Tids  = [Tid]

type Needs = Tids

data Tree = LEAF Exps | NODE State [(Subst, Tree)]

------------------------------ SHOW ------------------------------
instance MyShow Tree where
 myShow (LEAF es    ) = "LEAF\n  "++(myShow es)++"\n\n"
 myShow (NODE st brs) = "NODE\n"++(shiftStr "  " $ myShow st)++"\n"++
                      (myShow brs)

instance MyShow (Subst, Tree) where
 myShow (s, tree) = (myShow s)++" :=> "++(myShow tree)
  
instance MyShow [(Subst, Tree)] where
 myShow trs = concatMap myShow trs

------------------------------ TIDS ------------------------------
getTid :: Term -> Tid
getTid (((L idx):_):=_) = idx

findTerm :: Tid -> Terms -> (Term, Terms)
findTerm ti ts = (t, ts')
 where ([t], ts') = partition ((ti==) . getTid) ts

mkTids :: Vars -> Terms -> Tids
mkTids vs ts = [getTid t | t@(vs':=_) <- ts, (not.null) (vs'*.vs)]

mkNeeds :: Needs -> State -> Needs
mkNeeds nds (ts, cd, res) = nds+.(mkTids (vs1+.vs2) ts)
 where vs1 = getTopLVars cd
       vs2 = getLVars res

------------------------------ PPT -------------------------------
ppt :: Prog -> Exps -> Index -> Tree
ppt prog arg idx = eval prog st (mkNeeds [] st) idx1
 where main = head prog
       res  = fresh (funcCoarity main) L idx2
       st   = ([res:=(funcName main, arg)], [], v2e res)
--       idx1:idx2:_ = newIdxs idx 
       idx2:idx1:_ = newIdxs idx 

eval :: Prog -> State -> Needs -> Index -> Tree
eval prog st@(_ , _ , res) []       idx = LEAF res
eval prog st@(ts, cd, res) (ti:nds) idx = NODE st (map g ssts')
 where (vs:=(fN, arg), ts') = findTerm ti ts
       FUNC _ vsB body = findFunc fN prog idx1
       ssts  = mapMaybe (evalState . f) (body/.(mkSubst vsB arg))
       ssts' = filter isNoYVars ssts
       f (tsB,cdB,resB)=(tsB++ts',cdB++cd,res)/.(mkSubst vs resB)
       g (s, st) = (s, eval prog st (mkNeeds nds st) idx2)
--       idx1:idx2:_ = newIdxs idx
       idx1@(i:is) = idx
       idx2 = (i+1):is

evalState :: State -> Maybe (Subst, State)
evalState (ts, cd, res) =
 do (sW, sL, sX) <- fmap unmixSubst (mgu cd)
    let (ts', res') = (ts, res)/.sW/.sX
        sLX = renaming X (getLVars sX)
        sWX = renaming X (getWVars sX)
        renaming f = map (\v -> v:->(v2e $ mkVar v))
         where mkVar (W idx) = f idx
               mkVar (L idx) = f idx
               mkVar (X idx) = f idx
    return $ (sX/.sLX, (ts', v2e (sL++sLX), res'))/.sWX

isNoYVars :: (Subst, State) -> Bool
isNoYVars (_, (_, _, res)) = getYVars res == []