module Complement (showDeclInfo, deriveComplement) where

import ParseTree
import Automaton

import Data.List
import Data.Maybe

import Debug.Trace



-- Automata for Branches
data AState a 
    = FromF (Symbol a)  -- From function call 
    | FromD Int         -- FromD 4 means the 4th decl of program
    | FromV  
    | Temp  Int         -- Automatically Generated State Symbols
    | Times (AState a) (AState a)

instance Eq (AState a) where
    (==) (FromF f1) (FromF f2)       = f1 == f2
    (==) (FromD d1) (FromD d2)       = d1 == d2
    (==) (Temp  t1) (Temp  t2)       = t1 == t2
    (==) FromV FromV                 = True
    (==) (Times a1 b1) (Times a2 b2) = (a1 == a2) && (b1 == b2)
    (==) _ _                         = False

-- data ATrans a
--     = Trans  (Symbol a) ([AState a]) (AState a) 
--    | ETrans (AState a) (AState a)


instance Show (AState a) where
    show (FromF (Function f _)) = "_"++f
    show (FromD i)              = "d"++show i
    show (FromV)                = "q*"
    show (Temp i)               = "q"++show i
    show (Times s1 s2)          = "<"++show s1++","++show s2++">"



deriveComplement :: ParseTree a -> ParseTree a
deriveComplement decls = decls''
    where
      timedtrans = generateTranses decls
      decls'  = makeComplement decls timedtrans
      decls'' = makeItSmall decls decls' timedtrans

makeItSmall :: [Declaration a] -> [Declaration a] -> [ATrans a (AState a)] -> [Declaration a]
makeItSmall decls decls' timedtrans = decls''
    where
      fsymbols = defSymbols decls
      fgrouped = map (\f -> (f, branchIDsOf f decls)) fsymbols
      decls''    = foldr (\(f,fids) r ->
                            makeSmall fids r) decls' fgrouped
      -- Smallize with Extract Constructor
      --- 1. Check constructor is Singleton 
      ---    and(    view branches are not overwrapped with the branch
      ---         or cmpl branches are not overwrapped with the branch) 
      --  2. Remove It
      makeSmall fids decls' = mks fids decls' (generateTranses decls')
          where
            fbranches'  = map (\a -> decls' !! a) fids
            isSingleton i ds' = let SNode s ss = rhs(ds' !! i)
                                in  length ss == 1 && isConstructor s
            isConstructor (Constructor c _) = True
            isConstructor _                 = False
            removeContr (SNode (Constructor c _) [s]) = s
            removeContr s             = trace (show s) $ s
            removeContrD (Decl (l,r,w) n) = Decl (l,removeContr r,w) n
            noOverwrapView i = all (\j -> not(isOverwrap i j timedtrans) || i==j) fids
            noOverwrapCmpl i tt' = all (\j ->  not(isOverwrap i j tt') || i==j) fids
            repl ds' i = map (\(d,j) -> if i==j then removeContrD d else d) $
                              zip ds' [0..]
            mks (i:is) ds' tt' =  
                if isSingleton i ds' then
                    if noOverwrapView i then 
                        mks fids (repl ds' i) tt'
                    else 
                        let ds'' = repl ds' i 
                            tt'' = generateTranses ds'' 
                        in if False {- noOverwrapCmpl i tt'' -} then 
                               mks fids ds'' tt''
                           else
                               mks is ds' tt'
                else
                    mks is ds' tt'
            mks [] ds' tt' = ds'
                        

-- Make a Complement
makeComplement decls timedtrans = decls'
    where
      fsymbols = defSymbols decls
      fgrouped  = map (\f -> (f, unzip$bOf f decls)) fsymbols
      -- Note that fids is ordered
      fgrouped' = map (\(f,(fbranches,fids))->(f,makeCmpl f fbranches fids,fids)) fgrouped
      uo_decls' = concat $ map (\(_,fbrs,fids) -> zip fbrs fids) fgrouped'
      decls'    = map fst $ sortBy cmp uo_decls'
          where cmp (_,i) (_,i') | i <  i' = LT
                                 | i >  i' = GT
                                 | i == i' = EQ
      -- Make a complement for f's branches
      -- 1. Check called function symbols and lost variables
      -- 2. Check the magic number 
      -- 3. From the big number to small number, we check overwrap
      --       From early decralated one to lately decralated one, 
      --           we group the function among which all its ranges are not overwrapped 
      -- 4. Sort as original 
      makeCmpl f fbranches fids =
          map (\(l,r)->Decl (l,r,[]) (-1)) $ zip (mkLHS fbranches) (mkRHS fss)
          where calleds    = map (calledFuncs) fbranches
                calleds_ni = map (filter (\f@(SNode s ss) ->
                                              not$isInjective s decls timedtrans)) calleds
                lostss     = map (\d -> map (\s->SNode s [])$lostVars d) fbranches
                numbers    = map number fbranches
                comp (cs,ls,n,o,f) (cs',ls',n',o',f') 
                    | length cs+length ls < length cs'+length ls'  = LT
                    | length cs+length ls > length cs'+length ls'  = GT
                    | n <  n' = LT
                    | n >  n' = GT
                    | n == n' = EQ                         
                eq a b = comp a b == EQ 
                zipped  = zip5 calleds_ni lostss numbers fids fbranches
                fss     = groupBy eq$reverse$sortBy comp$ zipped
                renameToCmpl (Function f s) = (Function ("_"++f) s)
                renameTop (SNode s ps)      = SNode (renameToCmpl s) ps
                mkLHS fbranches = map (renameTop.lhs) fbranches
                mkRHS fss       = map mkrhs $ sortBy origOrd $ concat cmapped 
                    where
                      mkrhs ((cs,ls,_,_,f),c) = 
                          SNode (Constructor c undefined) (map renameTop cs++ls) 
                      origOrd ((_,_,_,i,_),_) ((_,_,_,i',_),_) | i <  i'  = LT
                                                               | i >  i'  = GT
                                                               | i == i'  = EQ
                      cname i = "_B_"++show f++"_"++show i
                      cmapped = map (\(fs,i)->map (\c -> (c,cname i)) fs)$
                                    zip cgroup [0..] 
                      cgroup  = mkConst fss
                      mkConst (fs:fss) = let (fco, fdropped) = mkc [] fs [] 
                                         in if null fdropped then
                                                fco:mkConst fss
                                            else 
                                                fco:mkConst (fdropped:fss)
                      mkConst []       = []
                      mkc fco ((c,l,n,i,f):fs) fdropped = 
                          if all (\(_,_,_,i',_) -> not$isOverwrap i i' timedtrans) fco then
                              mkc ((c,l,n,i,f):fco) fs fdropped
                          else 
                              mkc fco fs ((c,l,n,i,f):fdropped)
                      mkc fco [] fdropped               = (fco, fdropped)

-- Injectivity Test
isInjective f decls timedtrans = isInj f []
    where 
      lostVarCheck f decls = all (\d -> null(lostVars d)) $ branchesOf f decls 
      overwrapCheck f decls = 
          all (\(x,y)->not(isOverwrap x y timedtrans)) $
                  [ (x,y) | x <- bids, y <- bids, x /= y ]              
          where bids = branchIDsOf f decls 
      isInj f checked = 
          if elem f checked then
              True
          else if lostVarCheck f decls && overwrapCheck f decls then
              let (c,r) = 
                      foldr (\d (ci,r) ->
                                 if r then 
                                     (foldr (\a (c,r) ->
                                                 if r then 
                                                     (a:c, isInj a c)
                                                 else
                                                     (c,False)) (ci,True) $
                                      calledSymbols d)
                                     else
                                         (ci,False)) (f:checked, True) $ branchesOf f decls
              in r
          else
              False

showForEach ls f = concat $ map f ls

showDeclInfo decls = 
    showTitle "Injectivity"++ "\n" ++
    showInjectivity decls timedtrans ++ "\n" ++
    showTitle "Overwrap"++"\n" ++
    showOverwrapInfo decls timedtrans ++ "\n" ++
    showTitle "Input"++"\n"++
    show decls++"\n"++
    showTitle "Complement"++"\n" ++
    show decls' ++ "\n" ++
    showTitle "Smaller Complement"++"\n" ++
    show (makeItSmall decls decls' timedtrans) ++ "\n"++
    showTitle "Automaton?^2"++"\n"++
    "#Overwrapped State: " ++ show(length timedtrans) ++ "\n" ++
    "#States           : " ++ show(length states) ++ "\n\n"
--    showTitle "Transitions For Range Check"++"\n" ++
--    show (generateSingleTranses decls) ++ "\n" 
--    showTitle "Transitions For Overwrap Check"++"\n" ++
--    show timedtrans
    where timedtrans = generateTranses decls
          decls' = makeComplement decls timedtrans
          states = nub $ sts timedtrans
              where sts (Trans c ss s:ts) = s:ss++sts ts
                    sts []                = []
          showTitle s = take 80$"== " ++ s ++ " " ++ cycle "="

-- Show Injectivity
showInjectivity decls timedtrans =
    showForEach functions 
        (\f -> show f ++ ": " ++ showTF(isInjective f decls timedtrans) ++ "\n")
    where 
      functions  = defSymbols decls
      showTF True  = "Injective"
      showTF False = "Non-Injective"
      

-- Show Overwrap Information 
showOverwrapInfo decls timedtrans =
    replicate maxLength ' ' ++ " | "++showForEach declIDs (\j -> fillOrTrank 2 (show j)++" ") ++"\n"++
    replicate maxLength '-' ++ "-+-"++showForEach declIDs (\j -> "---") ++ "\n"++
    showForEach declIDs (\i ->
          fmSymbols !! i ++ " | "++
              showForEach declIDs (\j ->
                  showTF (isOverwrap i j timedtrans)++"  ")++"\n")
    where
      maxID      = length decls
      preSymbols = map (\(d,i) -> show (defSymbol d) ++ "(" ++ show i ++ ")" )$zip decls [0..]
      maxLength  = maximum $ map length preSymbols
--      fmSymbols  = map (\s ->s ++ replicate (maxLength-length s) ' ') preSymbols
      fmSymbols = map (take maxLength.(++cycle " ")) preSymbols
      fillOrTrank n ls = if length ls > n then
                           take n ls
                         else 
                             fillOrTrank n (ls++" ")
      declIDs    = [0 .. (maxID-1)]
      showTF True  = "X"
      showTF False = "_"

-- Overwrap Checking!
isOverwrap decID1 decID2 timedtrans = findState timedtrans
    where
      state = FromD decID1 `Times` FromD decID2
      findState [] = False
      findState (Trans c ss s:tr) = 
          if s == state then True
          else               findState tr

-- Times all Transitions
-- We assume trss have no epsilon-transitions
--
-- I shold write more effcient one.
timesTrans :: [ATrans a (AState a)] -> [ATrans a (AState a)]
timesTrans trss = reduceTrans$concat $ map (\c -> ctimes (ctrans c trss)) (nub$cons trss)
    where 
      cons (Trans c ss s:ts) = c:cons ts
      cons []                = []
      ctrans c (Trans c' ss s:ts) = 
          if c == c' then
              Trans c ss s:ctrans c ts
          else
              ctrans c ts
      ctrans c [] = []
      ctimes ctr = concat $ map (\t -> ctime1 t ctr) ctr 
          where ctime1 (t@(Trans c ss s)) (Trans c' ss' s':ts) = 
                    Trans c (zipWith Times ss ss') (Times s s'):ctime1 t ts
                ctime1 t [] = []

generateTranses decls = filter filtBB$timesTrans$generateSingleTranses decls   
    where
      filtBB (Trans c ss (Times (FromD _) (FromD _))) = True
      filtBB _                                       = False
                 

generateSingleTranses decls = killAllEps$ gt decls 0 0
    where 
      genTransC ((c,n):cs) = (Trans c (replicate n FromV) FromV):genTransC cs
      genTransC []         = []
      genTransD dcl_id tree m = 
          let (c,tr,m') = gtd tree m
          in (ETrans c (FromD dcl_id):tr, m')
          where gtd (SNode s ss) m = 
                    case s of 
                      Variable v _ -> (FromV  ,  [], m)
                      Function f _ -> (FromF s,  [], m)
                      Constructor c _ -> -- I shold use state monad
                          let (cs,tr,m') = foldr (\a (cs,tr,m')-> 
                                                      let (c,t,m'') = gtd a m'
                                                      in  (c:cs,t++tr,m'')) ([],[],m) ss
                          in (Temp m', Trans s cs (Temp m'):tr, m'+1 )
      -- n: #declaration, m: magic number for automatically generated states
      gt dcls n m = 
          case dcls of
            []     -> genTransC (allConstructors decls)
            (d:ds) -> 
                let (ts,m') = genTransD n (rhs d) m 
                in (ETrans (FromD n) (FromF$defSymbol d)):ts++gt ds (n+1) m'
                    