module Automaton where

import ParseTree 
import Data.List (nub, union, elemIndex, intersect, (\\), partition)
import Data.Maybe (fromJust)
import Debug.Trace

data ATrans a b 
    = Trans (Symbol a) ([b]) b
    | ETrans b b 
    deriving Eq
allStates :: Eq b => [ATrans a b] -> [b] 
allStates transes = nub (concatMap allS transes)
    where 
      allS (Trans _ ss s) = s:ss
      allS (ETrans s1 s2) = [s1,s2]

allSymbols :: [ATrans a b] -> [(Symbol a, Int)] 
allSymbols transes = nub (concatMap allS transes)
    where 
      allS (Trans c ss _ ) = [(c,length ss)]
      allS _               = []

showLeft (Trans (Constructor c _) ss s) 
    = if length ss > 0 then 
              c++"("++implode "," (map show ss)++")"
          else 
              c 

showLeft (ETrans s1 s2) = show s1
    
instance Show b => Show (ATrans a b) where
    show (t@(Trans (Constructor c _) ss s))
        = showLeft t++" ===> "++show s
    show (ETrans s1 s2) 
        = show s1 ++ " =e=> " ++ show s2
    showList xs = \s -> concat [showN x++"\n"| x <- xs] ++ s 
        where lengthL = length.showLeft
              n = maximum $ map lengthL xs
              showN (t@(Trans (Constructor c _) ss s)) 
                  = showLeft t++replicate (n-lengthL t) ' ' ++ " ===> " ++ show s                    
              showN (t@(ETrans s1 s2)) = showLeft t ++ replicate (n-lengthL t) ' ' ++ " =e=> " ++ show s2

-- removeDeadStates :: Eq b => ([ATrans a b], [b]) -> ([ATrans a b], [b])
removeDeadStates (trss, fstates) = 
    let astates = widenFix fstates 
    in ( filter (\(Trans _ ss s) -> s `elem` astates 
                                    && all (`elem` astates) ss) trss,
         fstates )
    where 
      widenAState astates = 
          foldr union astates $ map (\(Trans c ss s) -> 
                                          if s `elem` astates then
                                              ss
                                          else
                                              []) trss
      widenFix astates = 
          let astates' = widenAState astates 
          in if length astates' == length astates then
                 astates'
             else 
                 widenFix astates'

minimize :: Eq b => ([ATrans a b], [b]) -> ([ATrans a Int], [Int])
minimize (trss, fstates) = 
    let stgroup = divideFix [ fstates, states \\ fstates ]
    in removeDeadStates$numberize$ ( newTranses stgroup, newFinals stgroup )
    where
      groupingBy eq list = f eq list
          where 
            f eq (x:xs) = let (ls,rs) = partition (eq x) xs 
                          in (x:ls):groupingBy eq rs
            f eq []     = []
      without i (s:ss) | i == 0 = ss
                       | i  > 0 = s:without (i-1) ss
      without i []              = [] 
      states = allStates trss
      equiv (sts:stgroup) q | q `elem` sts = sts
                            | otherwise    = equiv stgroup q         
      isSameGroup stgroup q1 q2 = 
          any (\sts -> q1 `elem` sts && q2 `elem` sts) stgroup
      willBeSameGroup stgroup q1 q2 =
          isSameGroup stgroup q1 q2
          && all allMatched transQ1s
          where
            transQ1s = filter (\(Trans c ss s)->q1 `elem` ss) trss
            transQ2s = filter (\(Trans c ss s)->q2 `elem` ss) trss
            sameExcept (s:ss) (s':ss') | s == s' = sameExcept ss ss'
                                       | s /= s' =
                                           if s == q1 && s' == q2 then
                                               ss == ss'
                                           else
                                               False
            sameExcept [] [] = True
            sameExcept _ _   = False
            allMatched (Trans c ss s) = 
                all (\(Trans c' ss' s') ->
                         not( c == c' ) ||
                         not( sameExcept ss ss' ) ||
                            isSameGroup stgroup s s' ) transQ2s
      divide stgroup = groupingBy (willBeSameGroup stgroup) states
      divideFix stgroup = 
          let stgroup' = divide stgroup 
          in if length stgroup' == length stgroup then
                 stgroup'
             else
                 divideFix stgroup' 
      newTranses stgroup = 
          nub $ map (\(Trans c ss s) -> 
                         Trans c (map (equiv stgroup) ss) (equiv stgroup s)) trss
      newFinals stgroup = 
          nub $ map (equiv stgroup) fstates


numberize :: Eq b => ([ATrans a b], [b]) -> ([ATrans a Int], [Int])
numberize (trss, fstates) = 
    (map conv trss, map conv_s fstates)
    where
      states = allStates trss
      conv_s s = fromJust ( elemIndex s states ) 
      conv (Trans c ss s) = 
          Trans c (map conv_s ss) (conv_s s) 

determinize :: Eq b => ([ATrans a b],[b]) -> ([ATrans a [b]],[[b]])
determinize (trss, fstates) = 
    let (dstates', dtrss') = determinizeStep [] []
    in (dtrss', filter (\ds -> not$null$fstates `intersect` ds) dstates')  
    where
      symbolns = allSymbols trss 
      filtSymb symb transs = 
          filter (\(Trans c _ _) -> c == symb) transs
      fetch n dstates = 
          foldr (\_ r -> do qs <- r 
                            q  <- dstates
                            return $ q:qs) [[]] [1..n]
      getTransStates symb qs = 
          concatMap (\(Trans c ss s) ->
                         if all (\(s,q) -> elem s q) $ zip ss qs then
                             [s] 
                         else 
                             []) $ filtSymb symb trss
      determinizeStep dstates dtrss = 
          let -- dsdtr :: [( [b], ATrans a [b] ) ] 
              dsdtr = do (symb, n) <- symbolns
                         qs        <- fetch n dstates
                         return (let s = getTransStates symb qs
                                 in (s , Trans symb qs s))
              dstates' = foldr (\a r->union [a] r) dstates (map fst dsdtr)
              dtrss'   = foldr (\a r->union [a] r) dtrss (map snd dsdtr)
          in if length dtrss == length dtrss' then
                 (dstates',dtrss') 
             else 
                 determinizeStep dstates' dtrss'
                 



-- Reduction Algorithm
-- based on TATA Chapter 1, page 23
--
-- Current Buttle-Neck      
reduceTrans :: Eq b => [ATrans a b] -> [ATrans a b]
reduceTrans trss = widenMarkedFix [] [] trss
    where
      widenMarked marked [] proc rest flag 
          | marked `seq` proc `seq` rest `seq` True = 
              (marked, proc, rest, flag)
      widenMarked marked (t@(Trans c ss s) : ts) proc rest flag 
          | marked `seq` proc `seq` rest `seq` True = 
              if all (\s -> elem s marked) ss then
                  if elem s marked then 
                      widenMarked marked ts (t:proc) rest flag
                  else                  
                      widenMarked (s:marked) ts (t:proc) rest True
              else
                  widenMarked marked ts proc (t:rest) flag         
      widenMarkedFix marked proc rest 
          | marked `seq` proc `seq` True = 
              let (marked', proc', rest', flag) = widenMarked marked rest proc [] False
              in if flag then -- Something is added to "marked"
                     widenMarkedFix marked' proc' rest'
                 else         -- or Not
                     proc'
      


-- Remove all epsilon-transitions
killAllEps :: Eq b => [ATrans a b] -> [ATrans a b]
killAllEps trans = killalleps (epsClosure$epss trans) (trss trans)
    where
      epss (ETrans s1 s2:ts) = ETrans s1 s2:epss ts
      epss (Trans _ _ _:ts)  = epss ts
      epss []                = []
      trss (ETrans _ _:ts)   = trss ts
      trss (Trans c ss s:ts) = Trans c ss s:trss ts
      trss []                = []
      epsClosure epss = map (\s1 -> (s1,widenClosureFix (s1,[s1]))) (nub $ lstates epss)
          where lstates (ETrans s1 s2:ts) = s1:lstates ts
                lstates []                = []
                widenClosureFix (s,ss) = 
                    let ss' = widenClosure (s,ss) epss 
                    in if length ss == length ss' then
                           ss'
                       else
                           widenClosureFix (s,ss')
                widenClosure (s,ss) [] = ss
                widenClosure (s,ss) (ETrans s1 s2:ts) 
                    = if elem s1 ss && not (elem s2 ss) then
                          widenClosure (s,s2:ss) ts
                      else
                          widenClosure (s,ss) ts
      killalleps ecls []   = []
      killalleps ecls (Trans c ss s:trss) =
          case lookup s ecls of
            Nothing -> 
                Trans c ss s:killalleps ecls trss
            Just ts ->
                map (\t -> Trans c ss t) ts++killalleps ecls trss
