module Transform where import List import Auxfuns import PP import qualified NFAe as Ne import NFAe (eclosure) import qualified NFA as N import qualified DFA as D import RegExp import PrintDFA import PrintNFAe import PrintRegExp import Graphviz import Control.Monad.State unionDFA :: (Ord q1, Ord q2) => D.DFA q1 s -> D.DFA q2 s -> D.DFA (q1, q2) s unionDFA (D.DFA { D.states = bigQ1, D.symbols = sigma, D.delta = d1, D.start = q10, D.final = f1}) (D.DFA { D.states = bigQ2, D.delta = d2, D.start = q20, D.final = f2}) = D.DFA { D.states = [(q1,q2) | q1 <- bigQ1, q2 <- bigQ2], D.symbols = sigma, D.delta = \ (q1,q2) a -> (d1 q1 a, d2 q2 a), D.start = (q10,q20), D.final = canonical $ [(q1,q2) | q1 <- f1, q2 <- bigQ2] ++ [(q1,q2) | q1 <- bigQ1, q2 <- f2]} intersectionDFA :: (Ord q1, Ord q2) => D.DFA q1 s -> D.DFA q2 s -> D.DFA (q1, q2) s intersectionDFA (D.DFA { D.states = bigQ1, D.symbols = sigma, D.delta = d1, D.start = q10, D.final = f1}) (D.DFA { D.states = bigQ2, D.delta = d2, D.start = q20, D.final = f2}) = D.DFA { D.states = [(q1,q2) | q1 <- bigQ1, q2 <- bigQ2], D.symbols = sigma, D.delta = \ (q1,q2) a -> (d1 q1 a, d2 q2 a), D.start = (q10,q20), D.final = canonical $ [(q1,q2) | q1 <- f1, q2 <- f2]} nfaToDfa :: (Ord q) => N.NFA q s -> D.DFA [q] s nfaToDfa (N.NFA {N.states = bigQ, N.symbols = sigma, N.delta = d, N.start = q0, N.final = f}) = D.DFA { D.states = powerSet bigQ, D.symbols = sigma, D.delta = \ps a -> canonical $ concat $ [d p a | p <- ps], D.start = [q0], D.final = [qs | qs <- powerSet bigQ, not $ null $ intersect qs f]} nfaeToDfa :: (Ord q) => Ne.NFAe q s -> D.DFA [q] s nfaeToDfa (Ne.NFAe {Ne.states = bigQ, Ne.symbols = sigma, Ne.delta = d, Ne.start = q0, Ne.final = f}) = D.DFA { D.states = powerSet bigQ, D.symbols = sigma, D.delta = \ps a -> eclosure bigQ d $ canonical $ concat $ [d p (Just a) | p <- ps], D.start = eclosure bigQ d [q0], D.final = [qs | qs <- powerSet bigQ, not $ null $ intersect qs f]} concatNFAe :: (Ord q1) => Ne.NFAe q1 s -> Ne.NFAe q2 s -> Ne.NFAe (Either q1 q2) s concatNFAe (Ne.NFAe {Ne.states = bigQ1, Ne.symbols = sigma, Ne.delta = d1, Ne.start = q10, Ne.final = f1}) (Ne.NFAe {Ne.states = bigQ2, Ne.delta = d2, Ne.start = q20, Ne.final = f2}) = Ne.NFAe { Ne.states = (map Left bigQ1) ++ (map Right bigQ2), Ne.symbols = sigma, Ne.delta = d, Ne.start = Left q10, Ne.final = map Right f2} where d (Left q) (Just a) = map Left $ d1 q (Just a) d (Left q) Nothing | q `elem` f1 = (Right q20) : (map Left $ d1 q Nothing) | otherwise = map Left $ d1 q Nothing d (Right q) ae = map Right $ d2 q ae starNFAe :: (Ord q) => Ne.NFAe q s -> Ne.NFAe (Either () q) s starNFAe (Ne.NFAe {Ne.states = bigQ, Ne.symbols = sigma, Ne.delta = d, Ne.start = q0, Ne.final = f}) = Ne.NFAe {Ne.states = (Left ()):map Right bigQ, Ne.symbols = sigma, Ne.delta = d', Ne.start = Left (), Ne.final = [Left ()]} where d' (Left ()) Nothing = [Right q0] d' (Right q) (Just a) = map Right (d q (Just a)) d' (Right q) Nothing | q `elem` f = (Left ()):(map Right $ d q Nothing) | otherwise = map Right $ d q Nothing reachableDFA :: (Ord q) => D.DFA q s -> D.DFA q s reachableDFA (m@(D.DFA {D.symbols = sigma, D.delta = d, D.start = q0, D.final = f})) = m { D.states = newQ, D.final = filter (`elem` newQ) f } where newQ = reach d sigma [] [q0] reach :: (Ord q) => (q -> s -> q) -> [s] -> [q] -> [q] -> [q] reach d sigma visited [] = visited reach d sigma visited (q:qs) | q `elem` visited = reach d sigma visited qs | otherwise = reach d sigma (q:visited) (qs ++ [d q a | a <- sigma]) lookup' x al = case lookup x al of Just y -> y Nothing -> error "lookup'" renameDFA m@(D.DFA { D.states = bigQ, D.delta = d, D.start = q0, D.final = f} ) = let alist = zip bigQ [1..] inverse = map (\(a,b) -> (b,a)) alist bigq' = map snd alist d' q a = lookup' (d (lookup' q inverse) a) alist q0' = lookup' q0 alist f' = map (\q -> lookup' q alist) f in m { D.states = bigq', D.delta = d', D.start = q0', D.final = f' } ---------------------------------------------------------- new:: State Int Int new = do { n <- get; put(n+1); return n} reToNFAe :: Ord a => RegExp a -> (Ne.NFAe Int a) reToNFAe r = evalState (do { start <- new ; final <- new ; edges <- help (start,r,final) [] ; let h ((s,x),f) = [s,f] -- project states g ((s,Just x),f) = [x] -- project alphabet g ((s,Nothing),f) = [] states = canonical (concat (map h edges)) sigma = canonical (concat (map g edges)) delta x y = canonical [ c | ((a,b),c) <- edges, (a,b) == (x,y)] ; return (Ne.NFAe states sigma delta start [final]) }) 1 help :: (Int,RegExp a,Int) -> [((Int,Maybe a),Int)] -> State Int [((Int,Maybe a),Int)] help (s,Lambda,f) edges = return(((s,Nothing),f):edges) help (s,One c,f) edges = return(((s,Just c),f):edges) help (s,Union x y,f) a0 = do { a1 <- help (s,y,f) a0; help (s,x,f) a1 } help (s,Cat x y,f) a0 = do { m <- new; a1 <- help (s,x,m) a0; help (m,y,f) a1} help (s,Star x,f) a0 = do { m <- new ; a1 <- help (m,x,m) a0 ; a2 <- help (s,Lambda,m) a1 ; help (m,Lambda,f) a2 } data Close q s = Close [q] (Ne.NFAe q s) close xs (d@(Ne.NFAe states syms delta s f)) = Close (eclosure states delta xs) d instance (Eq q,Show q,Show s) => Graph (Close q s) where nodes (Close xs t) = map f pairs where pairs = zip (Ne.states t) [0..] f (q,n) = (n,show q,stateColor t q) stateColor t q | elem q xs = Blue stateColor t q | q == (Ne.start t) = Green stateColor t q | elem q (Ne.final t) = Red stateColor t q = None edges (Close xs t) = [(n,m,sh s,None) | (q1,n) <- pairs , s <- Nothing : (map Just (Ne.symbols t)) , m <- locate q1 s ] where pairs = zip (Ne.states t) [0..] find q = case lookup q pairs of {Just n -> n} locate q1 s = map find (Ne.delta t q1 s) sh Nothing = "^" sh (Just z) = show z