module Language.HaLex.Minimize (
minimizeDfa
, stdMinimizeDfa
, minimizeExp
, minimizeNdfa
, reverseDfa
, reverseDfaAsDfa
, reverseNdfa
) where
import Data.List
import Language.HaLex.Util
import Language.HaLex.Dfa
import Language.HaLex.Ndfa
import Language.HaLex.FaOperations
minimizeDfa :: (Eq sy, Ord st)
=> Dfa st sy
-> Dfa [[st]] sy
minimizeDfa = ndfa2dfa . reverseDfa . ndfa2dfa . reverseDfa
minimizeNdfa :: (Eq sy, Ord st)
=> Ndfa st sy
-> Dfa [[st]] sy
minimizeNdfa = ndfa2dfa . reverseDfa . ndfa2dfa . reverseNdfa
stdMinimizeDfa :: (Ord st, Ord sy)
=> Dfa st sy
-> Dfa [st] sy
stdMinimizeDfa dfa = ttDfa2Dfa (vs,und,bl ss ,z',list)
where a = removeinaccessible dfa
Dfa vs qs ss zs ds = a
dist = distinguishable a
und = undistinguishable a dist
tt = [ (q,v,z) | q <- qs , v <- vs , z <- [ds q v] ]
list = nub [ (bl x , y , bl z ) | (x,y,z) <- tt , bl x /= [] , bl z/= [] ]
z' = nub (filter (/=[]) (map bl zs))
bl x = concat ([] : (filter (x `elem`) und))
undistinguishable :: Eq st => Dfa st sy -> [(st,st)] -> [[st]]
undistinguishable (Dfa _ qs _ _ _) dist =
eraseintersect [ i : [j | j <- qs , ne(i,j) , ne (j,i), j/= i ] | i <- qs ]
where ne p = not (p `elem` dist)
eraseintersect :: Eq a => [[a]] -> [[a]]
eraseintersect [] = []
eraseintersect (x:xs) | (concat . map (x `intersect`)) xs == [] = x : eraseintersect xs
| otherwise = eraseintersect xs
distinguishable :: Eq st => Dfa st sy -> [(st,st)]
distinguishable (Dfa vs qs _ zs delta) = limit (\x -> nub (x ++ nthdist qs x)) (fstdist qs)
where fstdist [] = []
fstdist (x:xs) = [(x,a) | a <- xs , (x `elem` zs) /= (a `elem` zs) ] ++ fstdist xs
nthdist [] _ = []
nthdist (a:as) dist = [ (a,b) | b <- qs , x <- vs , move2Disting (a,b) x dist ]
++ nthdist as dist
move2Disting (a,b) x dist = (delta a x , delta b x) `elem` dist
removeinaccessible dfa@(Dfa v s i f d) = Dfa v states i (f `intersect` states) d
where states = nub (i:(flowdown [i] (transitionTableDfa dfa)))
flowdown zz ss = limit (\ x -> nub(x ++ nextlevel ss x)) (nextlevel ss zz)
nextlevel ss zz = (nub . concat) [ next z ss | z <- zz ]
next z = concat . map (\(a,_,c) -> if a == z then [c] else [])
removeinaccessible' a = ndfa2dfa . dfa2ndfa $ a
minimizeExp :: Ord st
=> Dfa st sy
-> Dfa [st] sy
minimizeExp (Dfa t lst si lsf d) = Dfa t l (head (filter (\x->elem si x) l))
(filter (\x->intersect x lsf /= []) l) ndelta
where (a,b)=partition f lst
f x = elem x lsf
l = (minaux lst d t) [a,b]
ndelta st s | elem st l = rfind (d (head st) s) l
| otherwise = []
rfind :: Eq a => a -> [[a]] -> [a]
rfind _ []=[]
rfind x (h:t)| elem x h = h
| otherwise = rfind x t
minaux :: (Ord a) => [a] -> (a -> b -> a) -> [b] -> [[a]] -> [[a]]
minaux lst d simb p | p == p' = p
| otherwise = minaux lst d simb p'
where p' =concatMap (partes lst d simb p []) p
partes :: Eq a => [a] -> (a -> b -> a) -> [b] -> [[a]] -> [a] -> [a] -> [[a]]
partes _ _ _ _ _ [] =[]
partes _ _ _ _ ac [h] | elem h ac = []
| otherwise = [[h]]
partes lst d simb p ac (h:hs) |(elem h ac) = partes lst d simb p ac hs
|otherwise = ([h]++r):(partes lst d simb p (ac++r) hs)
where r = raux hs
raux []=[]
raux (x:xs) | (comparaDelta lst d simb p h x) = x:(raux xs)
| otherwise = raux xs
mesmoGrupo :: Eq a => [a] -> [[a]] -> a -> a -> Bool
mesmoGrupo lst [] s t = (elem s lst) == (elem t lst)
mesmoGrupo lst (h:t) x y | ((elem x h) && (elem y h)) = True
| otherwise = mesmoGrupo lst t x y
comparaDelta :: Eq a => [a] -> (a -> b -> a) -> [b] -> [[a]] -> a -> a -> Bool
comparaDelta lst d simb p s t= and (map (comparaDeltaSimb lst d p s t) simb)
comparaDeltaSimb :: Eq a => [a] -> (a -> b -> a) -> [[a]] -> a -> a -> b -> Bool
comparaDeltaSimb lst d p s t v = mesmoGrupo lst p s' t'
where s' = d s v
t' = d t v
reverseDfa :: Eq st
=> Dfa st sy
-> Ndfa st sy
reverseDfa (Dfa v qs s z delta) = Ndfa v qs z [s] delta'
where delta' st (Just sy) = [ q | q <- qs
, delta q sy == st ]
delta' st Nothing = []
reverseNdfa :: Eq st
=> Ndfa st sy
-> Ndfa st sy
reverseNdfa (Ndfa v qs s z delta) = Ndfa v qs z s delta'
where delta' st sy = [ q | q <- qs
, st `elem` delta q sy ]
reverseDfaAsDfa :: (Ord st , Eq sy)
=> Dfa st sy
-> Dfa [st] sy
reverseDfaAsDfa = ndfa2dfa . reverseDfa