{-# OPTIONS_GHC -Wno-redundant-constraints -Wno-type-defaults #-} {- | Second assignment for IB016, semester spring 2017, 20 points (+bonus). == Task overview Your assignment is to implement a library for manipulating deterministic finite state machines/automata (abbreviated as DFA from now on). You are again provided with complete documentation and most of interface (type signatures) of the required functions. The data type of 'DFA' is also defined, but you can redefine it if you want (though you must keep its kind and meaning of its type parameters). For implementation of the transition function and internal structure of the automaton, you are free to choose from the following: * Map of maps: Both relatively easy to handle, and providing relatively fast lookup. Efficient for storing automata with sparse transition relation. Suggested option. * 2D array: Provides fast lookup and should be relatively easy to handle. Well suited for encoding of automata with total transition relation. You would need to learn arrays ahead of time (and beware, indexing by alphabet is tricky). * Transition function stored as a function: Allows lazy construction of unions and intersections. Probably the most functionally crazy version. * Something else: Use anything you fancy. We will test for functionality, not adherance to particular algorithms. In the case of 'toDot', the exact output formating is completely up to you. == Module and package constraints You can use any modules from the following packages: , and . == Tips and tricks * Use provided examples and 'drawDot' routine to help you debug your code. * It is recommended to look into documentation of , and . * You may want to use monadic operators for handling the occasional 'Maybe' values. * may be useful. * Detailed information about the necessary algorithms can be found in materials for or elsewhere on the Internet. -} -- Name: Name Surname -- UID: 123456 module AutomataSolution ( -- * Deterministic finite automaton type and construction (2 points) DFA, initial, accepting, toDFA, -- * Basic automata operations (3 points) states, alphabet, step, accepts, -- * Language operations and queries (10 points) total', total, complement, intersection, union, subset, empty, equal, -- * Bonus (+5 points) nonemptyWitness, -- * Drawing automata (5 points) toDot, drawDot, dfaToSVG, -- * Example automata example1, example2, example3, example4, example5 ) where import Data.Map ( Map, (!) ) import qualified Data.Map as Map import Data.Set ( Set, difference ) import qualified Data.Set as Set import System.Process ( readProcess ) import Control.Monad ( void ) import Data.List ( intercalate, groupBy, sort ) import Data.Foldable ( toList ) import Data.Function ( on ) (!?) :: Ord a => Map a b -> a -> Maybe b (!?) = flip Map.lookup -- ####### Deterministic finite automaton type and construction ####### -- | @DFA state alpha@ is deterministic finite automaton with states of type @state@ -- working with alphabet of (subset of) values of type @alpha@. -- -- An automaton is represented by its initial state, its transition function -- and its accepting states. -- Alphabet and set of all states is given implicitly as those occurring in the -- definition of the transition function. -- -- This is the suggested implementation, you may change it. -- If you choose to implement DFA differently, you have keep the type constructor -- and functions 'initial' and 'accepting' (can be standalone functions). -- You don't have to implement the Show instance in case it cannot be derived -- automatically (e.g. if you are representing the transition function as a function). data DFA state alpha = DFA { initial :: state -- ^ Initial state of an automaton. , transitions :: Map state (Map alpha state) -- state -> character -> state, not exported , accepting :: Set state -- ^ Set of accepting states of an automaton. } deriving ( Show ) -- | Build DFA from initial state, transtion function (which is expected to be -- deterministic, you don't need to check that) and a list of accepting states. toDFA :: (Ord state, Ord alpha) => state -> [(state, alpha, state)] -> [state] -> DFA state alpha toDFA ini trans acc = DFA { initial = ini , accepting = Set.fromList acc , transitions = enctrans } where enctrans = Map.fromList . map intmap . groupBy ((==) `on` fst) . sort $ map (\(s, a, t) -> (s, (a, t))) trans intmap xss@((s, _) : _) = (s, Map.fromList (map snd xss)) intmap _ = error "enctrans: invalid group" -- | Detect if languages of the automata are equal. instance (Ord state, Ord alpha) => Eq (DFA state alpha) where (==) = equal -- ####### Basic automata operations ####### -- | Get all states used in the transition function or defined as -- inntial or accepting. -- -- >>> states example2 -- fromList [1,2,3,4,5] states :: (Ord st, Ord a) => DFA st a -> Set st states dfa = ks `Set.union` vs `Set.union` Set.singleton (initial dfa) `Set.union` accepting dfa where ks = Set.fromList . Map.keys $ transitions dfa vs = Set.fromList . concatMap toList . toList $ transitions dfa -- | Get all alphabet characters used in the transition function. -- -- >>> alphabet example2 -- fromList "ab" alphabet :: (Ord st, Ord a) => DFA st a -> Set a alphabet dfa = Set.fromList . concatMap Map.keys . toList $ transitions dfa -- | Perform one step (transition) of the automaton. -- Given a state and a character, return a state to which the automaton would -- transfer or 'Nothing' if there is no such transition. step :: (Ord st, Ord a) => DFA st a -> st -> a -> Maybe st step dfa st a = (transitions dfa !? st) >>= (!? a) -- | Decides if given automaton accepts given string of characters. The string -- need not consist only of 'alphabet' characters of the automaton. -- -- >>> accepts example4 "abaab" -- True -- -- >>> accepts example4 "c" -- False -- -- >>> accepts example4 "" -- True -- -- >>> accepts example5 "aaa" -- False accepts :: (Ord st, Ord a) => DFA st a -> [a] -> Bool accepts dfa xss = case simulate (initial dfa) xss of Nothing -> False Just st -> Set.member st (accepting dfa) where simulate st [] = Just st simulate st (x:xs) = step dfa st x >>= \nst -> simulate nst xs -- ####### Language operations and queries ####### -- | Make the transition function total for the provided alphabet. This -- possibly adds additional characters for which all transitions have to be -- defined (mostly useful for other algorithms). -- -- @total' a alph@ will produce DFA @b@ which is equivalent to @a@ but for all -- states have transitions defined for all characters from @Set.union -- ('alphabet' a) alph@. total' :: (Ord st, Ord a) => DFA st a -> Set a -> DFA (Maybe st) a total' dfa al0 = DFA { initial = Just (initial dfa) , accepting = Set.map Just (accepting dfa) , transitions = merge (lift $ transitions dfa) fulltrans } where lift = Map.mapKeysMonotonic Just . fmap (fmap Just) st = toList $ states dfa al = toList $ al0 `Set.union` alphabet dfa fulltrans = Map.fromList $ [ (Just s, Map.fromList [ (a, Nothing) | a <- al ]) | s <- st ] ++ [ (Nothing, Map.fromList [ (a, Nothing) | a <- al ]) ] merge = Map.unionWith Map.union -- | Make transition function total for the characters of the automaton. -- -- It should hold that @total a = 'total'' a Set.empty@ total :: (Ord st, Ord a) => DFA st a -> DFA (Maybe st) a total dfa = total' dfa Set.empty -- | Produce an automaton accepting the complement language. -- Keep in mind the complementation algorithm requires the transition relation -- to be total. The state type of the result is up to your choice. -- -- It should hold that @(complement a) ``accepts`` x = not (a ``accepts`` x)@ complement :: (Ord st, Ord a) => DFA st a -> DFA (Maybe st) a complement = _complement . total _complement :: (Ord st, Ord a) => DFA st a -> DFA st a _complement dfa = dfa { accepting = states dfa `difference` accepting dfa } -- | Produce an autmaton accepting the intersection of languages of given automata. -- This can be implemented using the synchronous automata product. -- Transition relations need not be total for this algorithm to work. -- -- It should hold that @(a ``intersection`` b) ``accepts`` x = a ``accepts`` x && b ``accepts`` x@ intersection :: (Ord st1, Ord st2, Ord a) => DFA st1 a -> DFA st2 a -> DFA {- ?? -} (st1, st2) a intersection a b = _composition a b (&&) _composition :: (Ord st1, Ord st2, Ord a) => DFA st1 a -> DFA st2 a -> (Bool -> Bool -> Bool) -> DFA (st1, st2) a _composition a b accmerger = pre { accepting = Set.filter isAcc (states pre) } where alph = toList $ alphabet a `Set.union` alphabet b pre = DFA { accepting = Set.empty , initial = ini , transitions = mktrans (Q [] [ini]) Set.empty Map.empty } mktrans q0 seen trans = case pop q0 of Nothing -> trans Just (st, q) -> pushSuccs q seen trans st (succs st) succs (s1, s2) = [ (char, (ta, tb)) | char <- toList alph , ta <- mtl (transitions a !? s1 >>= (!? char)) , tb <- mtl (transitions b !? s2 >>= (!? char)) ] pushSuccs q seen trans _ [] = mktrans q seen trans pushSuccs q seen trans from ((c, to) : xs) | Set.member edge seen = pushSuccs q seen trans from xs | otherwise = pushSuccs (to `push` q) (edge `Set.insert` seen) (Map.insertWith Map.union from (Map.singleton c to) trans) from xs where edge = (from, c, to) mtl Nothing = [] mtl (Just x) = [x] ini = (initial a, initial b) isAcc (s1, s2) = Set.member s1 (accepting a) `accmerger` Set.member s2 (accepting b) -- | Produce an automaton accepting the union of languages of given automata. -- This can be implemented using the synchronous automata product. -- Automata need to be made total over union of their alphabets first. -- -- It should holds that @(a ``union`` b) ``accepts`` x = a ``accepts`` x || b ``accepts`` x@ union :: (Ord st1, Ord st2, Ord a) => DFA st1 a -> DFA st2 a -> DFA {- ?? -} (Maybe st1, Maybe st2) a union a b = _composition (total' a alph) (total' b alph) (||) where alph = alphabet a `Set.union` alphabet b -- | Detect if language of first automaton is subset of language of the second one. -- -- >>> subset example5 example4 -- True subset :: (Ord st1, Ord st2, Ord a) => DFA st1 a -> DFA st2 a -> Bool subset a b = empty (a `intersection` _complement (total' b (alphabet a))) -- | Detect if languages of the automata are equal. -- -- >>> equal example4 example5 -- False equal :: (Ord st1, Ord st2, Ord a) => DFA st1 a -> DFA st2 a -> Bool equal a b = a `subset` b && b `subset` a -- Amortized constant time functional queue used for implementation of 'empty' -- and '_composition' data Q a = Q [a] [a] deriving Show push :: a -> Q a -> Q a push x (Q xs ys) = Q (x:xs) ys pop :: Q a -> Maybe (a, Q a) pop (Q [] []) = Nothing pop (Q xs []) = pop (Q [] (reverse xs)) pop (Q xs (y:ys)) = Just (y, Q xs ys) -- | Detect if the language of the automaton is empty. -- -- >>> empty example3 -- True empty :: (Ord st, Ord a) => DFA st a -> Bool empty dfa = bfs (Q [] [ini]) (Set.fromList [ini]) where ini = initial dfa bfs q0 seen = case pop q0 of Nothing -> True Just (st, q) -> not (Set.member st (accepting dfa)) && addSuccs q seen (succs st) addSuccs q seen [] = bfs q seen addSuccs q seen (x:xs) | Set.member x seen = addSuccs q seen xs | otherwise = addSuccs (x `push` q) (x `Set.insert` seen) xs succs st = case transitions dfa !? st of Nothing -> [] Just m -> toList m -- ####### Bonus ####### -- | Return either @Nothing@ if language is empty, or -- a witness of nonemptiness (a word accepted by the automaton). nonemptyWitness :: (Ord st, Ord a) => DFA st a -> Maybe [a] nonemptyWitness = undefined -- ####### Drawing automata ####### -- | Convert the automaton to -- -- format. See the examples for how output should be encoded. -- -- >>> putStr (toDot example1) -- digraph dfa { -- rankdir = LR; -- init [label="", peripheries = 0]; -- n0 [label = "1", peripheries = 2]; -- n1 [label = "2", peripheries = 2]; -- n2 [label = "3"]; -- init -> n0; -- n0 -> n1 [label = "'a'"]; -- n0 -> n2 [label = "'b'"]; -- n2 -> n1 [label = "'a'"]; -- } -- -- >>> putStr (toDot example2) -- digraph dfa { -- rankdir = LR; -- init [label="", peripheries = 0]; -- n0 [label = "1"]; -- n1 [label = "2"]; -- n2 [label = "3", peripheries = 2]; -- n3 [label = "4"]; -- n4 [label = "5", peripheries = 2]; -- init -> n0; -- n0 -> n1 [label = "'a'"]; -- n0 -> n2 [label = "'b'"]; -- n2 -> n3 [label = "'a'"]; -- } -- -- Dot format tips and tricks: -- -- * To mark accepting states with double circles, use @peripheries = 2@. -- * Use @init@, an invisible state from which an arrow points to the initial state of the automaton. -- * Label the edges with the character they represent. -- * @rankdir = LR@ indicates that edges should be preferably drawn in horizontal direction (left to right). -- -- You can look at the examples to see what resulting automata can look like. toDot :: (Show st, Ord st, Show a, Ord a) => DFA st a -> String toDot dfa = start ++ intercalate "\n" (sts ++ es) ++ end where start = "digraph dfa {\nrankdir = LR;\ninit [label=\"\", peripheries = 0];\n" stsmap = Map.fromList . zipWith st [0..] . toList $ states dfa st i x = (x, ("n" ++ show i, "n" ++ show i ++ " [label = " ++ show (show x) ++ acc x ++ "];")) acc x = if Set.member x (accepting dfa) then ", peripheries = 2" else "" sts = map snd $ Map.elems stsmap es = (initArrow :) . map (uncurry e) . concatMap flatten . Map.toList $ transitions dfa flatten (x, m) = zip (repeat x) $ Map.toList m initArrow = "init -> " ++ fst (stsmap ! initial dfa) ++ ";" e s (a, s2) = fst (stsmap ! s) ++ " -> " ++ fst (stsmap ! s2) ++ " [label = " ++ show (show a) ++ "];" end = "\n}\n" -- | Display the automaton using the external dot program (requires graphviz). -- If you don't have dot installed you can either install it (graphviz should -- be in you distribution packages if you are on linux), or use X forwarding -- from aisa or other FI computer: @ssh -X aisa@. -- -- This function is already implemented for you. drawDot :: (Show st, Ord st, Show a, Ord a) => DFA st a -> IO () drawDot dfa = void $ readProcess "dot" [ "-Tx11" ] (toDot dfa) -- | Save automaton to SVG file. -- -- This function is already implemented for you. dfaToSVG :: (Show st, Ord st, Show a, Ord a) => DFA st a -> FilePath -> IO () dfaToSVG dfa file = readProcess "dot" [ "-Tsvg" ] (toDot dfa) >>= writeFile file -- ####### Example automata ####### -- | Simple example automaton -- -- <> example1 :: DFA Int Char example1 = toDFA 1 [(1, 'a', 2), (1, 'b', 3), (3, 'a', 2)] [1, 2] -- | Example automaton with dangling states -- -- <> example2 :: DFA Int Char example2 = toDFA 1 [(1, 'a', 2), (1, 'b', 3), (3, 'a', 4)] [5, 3] -- | Example of empty automaton -- -- <> example3 :: DFA Int Char example3 = toDFA 1 [(1, 'a', 2), (1, 'b', 3), (3, 'a', 4)] [5] -- | Example automaton which accepts { a, b }^* -- -- <> example4 :: DFA Int Char example4 = toDFA 1 [(1, 'a', 1), (1, 'b', 1)] [1] -- | Example automaton which accepts { aa }^* -- -- <> example5 :: DFA Int Char example5 = toDFA 1 [(1, 'a', 2), (2, 'a', 1)] [1]