import List(union,nub,nubBy,(\\),partition) data Q = Q0 | Q1 | Q2 | Q3 | Q4 | Q5 deriving (Eq, Enum, Show) data S = A | B -- list with all states states :: [Q] states = [Q0 .. Q5] -- alphabet alphabet :: [S] alphabet = [A,B] delta :: Q -> S -> Q delta Q0 A = Q1 delta Q0 B = Q2 delta Q1 A = Q3 delta Q1 B = Q4 delta Q2 A = Q4 delta Q2 B = Q3 delta Q3 A = Q5 delta Q3 B = Q5 delta Q4 A = Q5 delta Q4 B = Q5 delta Q5 A = Q5 delta Q5 B = Q5 final :: Q -> Bool final Q1 = True final Q2 = True final Q5 = True final _ = False -- swap in pairs swap :: (a,a) -> (a,a) swap (p,q) = (q,p) -- equality in pairs: order doesn't matter here pair_eq :: Eq a => (a,a) -> (a,a) -> Bool pair_eq p q = p == q || p == swap q pair_elem_eq :: Eq a => (a,a) -> (a,a) -> Bool pair_elem_eq (p,q) (r,s) = r == p || r == q || s == p || s == q -- applies a function to each element of the pair map_pair :: (a -> b -> c) -> (a,a) -> b -> (c,c) map_pair f (p,q) x = (f p x, f q x) -- test if any element in xs is equal to (f p) elemBy :: (a -> a -> Bool) -> a -> [a] -> Bool elemBy f p xs = any (f p) xs -- all possible pairs of states without repetition all_pairs :: [(Q,Q)] all_pairs = [ (p,q) | p <- states, q <- [p .. ], p /= q] -- tests to distinguish if one state is final but not the other dist :: (Q,Q) -> Bool dist (p,q) = final p && not(final q) || final q && not(final p) -- equiv ss pps dds gives the equivalent states -- ss are all the symbols in the alphabet -- pps are the pairs of states still to check if distinguishable -- dds are all pairs of states already found distinguishable equiv :: [S] -> [(Q,Q)] -> [(Q,Q)] -> [(Q,Q)] equiv ss pps dds = let dqs = [ pq | pq <- pps, any (\pp -> elemBy pair_eq pp dds) (map (map_pair delta pq) ss)] nds = union dds dqs nps = pps \\ dqs in if not (null dqs) then equiv ss nps nds else pps -- if we instead return nds we give all distinguishable pairs -- group the pairs into classes group_classes :: Eq a => [(a,a)] -> [[a]] group_classes [] = [] group_classes (pp:pps) = let (pqs,nps) = partition (pair_elem_eq pp) (pp:pps) (ps,qs) = unzip pqs ss = nub (ps ++ qs) in ss : group_classes nps -- add the classes with just one state add_single :: Eq a => [a] -> [[a]] -> [[a]] add_single ss pps = map (:[]) (ss \\ concat pps) ++ pps (base_dist,rest) = partition dist all_pairs -- returns all equivalent classes equiv_classes :: [[Q]] equiv_classes = add_single states (group_classes (equiv alphabet rest base_dist))