module Updatability (updatabilityChecker) where

import ParseTree
import Automaton
import Data.Maybe (isJust, fromJust)
import Data.List  (elemIndex, nub)
import Control.Monad.State 

import Debug.Trace

data ContTree a 
    = CNode String [ContTree a]
    | CLeaf a
    deriving Show

data MTrans a = MTrans (ContTree a , a ) 
                deriving Show
data AState b
    = QAll
    | QFunc  String                -- function name
    | QTFunc String (SymbolTree b) -- function name & subtree
    deriving (Eq, Show) 


--updatabilityChecker :: ParseTree a -> String -> SymbolTree a -> ([ATrans a Int], [Int])
updatabilityChecker tdecls fname vcompl = 
   minimize $ 
     numberize $ determinize $ 
        removeDeadStates $ toAutomata fname tdecls vcompl


extractFname (SNode (Function f _) _) = f

convert_ct (SNode (Constructor c a) cs) = CNode c (map convert_ct cs)
convert_ct (SNode (Variable v a) vs)    = CLeaf v 

substitute_c :: Eq a => ContTree a -> [(a,b)] -> b -> ContTree b
substitute_c (CNode c cs) bind b = CNode c (map (\c -> substitute_c c bind b) cs)
substitute_c (CLeaf v) bind    b = CLeaf $ case lookup v bind of
                                           Just v' -> v'
                                           Nothing -> b

varName (SNode (Variable v _) _) = v

toAutomata :: String -> ParseTree a -> SymbolTree a -> ([ATrans a Int], [Int])
toAutomata fname tdecls vcompl = 
    let trs'   = evalState (newtrs trs) (length states+1)
        ctrs'  = convert_contr tdecls (fromJust$elemIndex QAll states)
    in ( killAllEps (trs'++ctrs'), [fromJust (elemIndex astate states)] )
    where trs    = updatability tdecls vcompl
          astate = QTFunc fname vcompl
          newtrs trs = 
              do ts <- mapM conv_tr trs
                 return $ concat ts
          states = nub $ (QAll:allStatesM trs)
          allStatesM trs = concatMap (\(MTrans (ct,c)) -> c:statesM ct) trs
          statesM (CNode c cs) = concatMap statesM cs
          statesM (CLeaf v)    = [v]
          conv_tr (MTrans (ct,q)) = 
              do (ts,i) <- conv ct
                 return $ ETrans i (fromJust(elemIndex q states)):ts
          conv (CNode s cs) =
              do i <- get
                 put (i+1)
                 qsp <- mapM conv cs
                 (tss, qs) <- return $ unzip qsp 
                 return $ (Trans (Constructor s undefined) qs i:concat tss, i)
          conv (CLeaf v) =
              do i <- get 
                 put (i+1)
                 j <- return $ fromJust (elemIndex v states)
                 return $ ([ETrans j i],i)
          convert_contr tdecls qallInd = 
              map ctrans contrs
              where
                contrs = filter (\(c,n) -> isOrg c) $ allConstructors tdecls
                ctrans (Constructor c a, n) = 
                    Trans (Constructor c a) (replicate n qallInd) qallInd
                isOrg (Constructor c a) | head c == '_' = False
                                        | head c == '#' = False
                                        | otherwise     = True


updatability :: ParseTree a -> SymbolTree a -> [MTrans (AState a)]
updatability tdecls vcompl = 
    updatabilityT (filter isTupled tdecls) vcompl
                       ++updatabilityInj (filter (not.isTupled) tdecls)
    where
      isTupled :: Declaration a -> Bool
      isTupled tdecl = isTupledE (rhs tdecl)                                    
      isTupledE exp = case exp of 
                        SNode (Constructor c a) [c1,c2] 
                            | c == "#" -> True
                        _ ->  False
      firstArg  (SNode (Constructor c a) [c1,c2]) = c1
      secondArg (SNode (Constructor c a) [c1,c2]) = c2
      hasSecondArg wl bind = isJust (lookup (varName (secondArg wl)) bind)      
      updatabilityT tdecls vcompl = 
          case vcompl of 
            SNode (Constructor c a) cs ->
                upds tdecls vcompl ++ concatMap (updatabilityT tdecls) cs
      upds tdecls vcompl = concatMap (upd vcompl) tdecls
      upd vcompl tdecl = 
          case patternMatch (secondArg (rhs tdecl)) vcompl of 
            Nothing   -> []
            Just bind ->
                let fname = let SNode (Function f _) _ = lhs tdecl in f
                    bq = map (\(wl,wr) ->
                                  if isTupledE wl then -- TFuncall
                                      (varName (firstArg wl),
                                       QTFunc (extractFname wr)
                                                  (substitute (secondArg wl) bind))
                                  else
                                      (varName wl, QFunc (extractFname wr))) $ wclause tdecl
                    bq' = bq ++ map (\(Variable v _) -> (v, QAll)) (leftVars tdecl)
                    ct  = convert_ct (firstArg (rhs tdecl))
                in [MTrans (substitute_c ct bq' QAll, QTFunc fname vcompl)]
                

      
updatabilityInj :: ParseTree a -> [MTrans (AState a)]
updatabilityInj tdecls  = 
    map match tdecls 
    where            
      match tdecl =
         let fname = let SNode (Function f _) _ = lhs tdecl in f
             w  = wclause tdecl
             bq = map (\(wl,wr) -> (varName wl, QFunc (extractFname wr))) w 
             ct = convert_ct (rhs tdecl)
         in MTrans (substitute_c ct bq QAll, QFunc fname)
              
            