HaLeX-1.1: HaLeX_lib/Language/HaLex/Dfa.hs
{-# LANGUAGE FlexibleContexts #-}
-----------------------------------------------------------------------------
-- |
-- Module : Language.HaLex.Dfa
-- Copyright : (c) Jooo Saraiva 2001,2002,2003,2004,2005
-- License : LGPL
--
-- Maintainer : jas@di.uminho.pt
-- Stability : provisional
-- Portability : portable
--
-- Deterministic Finite Automata in Haskell.
--
-- Code Included in the Lecture Notes on
-- Language Processing (with a functional flavour).
--
-----------------------------------------------------------------------------
module Language.HaLex.Dfa (
-- * Data type
Dfa (..)
-- * Acceptance
, dfaaccept
, dfawalk
-- * Transformation
, ttDfa2Dfa
, dfa2tdfa
-- * Transitions
, transitionsFromTo
, destinationsFrom
, transitionTableDfa
, reachedStatesFrom
-- * Printing
, beautifyDfa
, renameDfa
, showDfaDelta
, beautifyDfaWithSyncSt
, dfaIO
-- * Properties of 'Dfa'
, sizeDfa
, dfadeadstates
-- * Properties of States
, isStDead
, isStSync
, numberOutgoingArrows
, numberIncomingArrows
) where
import Data.List
import Language.HaLex.Util
-----------------------------------------------------------------------------
-- * Data type with the acceptance function
-- | The type of Deterministic Finite Automata parameterized with
-- the type @st@ of states and @sy@ of symbols.
data Dfa st sy = Dfa [sy] -- Vocabulary
[st] -- Finite set of states
st -- The start state
[st] -- The set of final states
(st -> sy -> st) -- Transition Function
-----------------------------------------------------------------------------
-- * Acceptance
-- | Execute the transition function of a 'Dfa' on an initial state
-- and list of input symbol. Return the final state when all input
-- symbols have been consumed.
dfawalk :: (st -> sy -> st) -- ^ Transition function
-> st -- ^ Initial state
-> [sy] -- ^ Input symbols
-> st -- ^ Final state
dfawalk delta s [] = s
dfawalk delta s (x:xs) = dfawalk delta (delta s x) xs
-- | Test whether the given automaton accepts the given list of
-- input symbols.
dfaaccept' :: Eq st
=> Dfa st sy -- ^ Automaton
-> [sy] -- ^ Input symbols
-> Bool
dfaaccept' (Dfa v q s z delta) simb = (dfawalk delta s simb) `elem` z
-- | Test whether the given automaton accepts the given list of
-- input symbols (expressed as a fold).
dfaaccept :: Eq st
=> Dfa st sy -- ^ Automaton
-> [sy] -- ^ Input symbols
-> Bool
dfaaccept (Dfa v q s z delta) simb = (foldl delta s simb) `elem` z
-----------------------------------------------------------------------------
-- * Printing
-- | Print a 'Dfa' as a Haskell function.
instance (Show st, Show sy) => Show (Dfa st sy) where
showsPrec p (Dfa v q s z delta) =
showString ("dfa = Dfa v q s z delta") .
showString ("\n where \n\t v = ") .
showList v .
showString ("\n\t q = ") .
showList q .
showString ("\n\t s = ") .
shows s .
showString ("\n\t z = ") .
showList z .
showString ("\n\t -- delta :: st -> sy -> st \n") .
showDfaDelta q v delta
-- | Helper function to show the transition function of a 'Dfa'.
showDfaDelta :: (Show st, Show sy)
=> [st] -> [sy] -> (st -> sy -> st) -> [Char] -> [Char]
showDfaDelta q v d = foldr (.) (showChar '\n') f
where
f = zipWith3 showF m n q'
(m,n) = unzip l
q' = map (uncurry d) l
l = [(a,b) | a <- q , b <- v]
showF st sy st' = showString("\t delta ") .
shows st .
showChar(' ') .
shows sy .
showString(" = ") .
shows st' .
showChar('\n')
-- | Write a 'Dfa' to a Haskell module in a file.
dfaIO :: (Show st , Show sy)
=> (Dfa st sy) -- ^ Automaton
-> String -- ^ Haskell module name
-> IO ()
dfaIO afd modulename =
writeFile (modulename ++ ".hs")
("module " ++ modulename ++ " where\n\nimport Dfa\n\n"
++ (show afd))
-----------------------------------------------------------------------------
-- * Transitions
-- | Compute the labels with the same (giving) origin and destination states
transitionsFromTo :: Eq st
=> (st -> sy -> st) -- ^ Transition function
-> [sy] -- ^ Vocabulary
-> st -- ^ Origin
-> st -- ^ Destination
-> [sy] -- ^ Labels
transitionsFromTo delta vs o d = [ v
| v <- vs
, delta o v == d
]
-- | Compute the destination states giving the origin state
destinationsFrom :: (st -> sy -> st) -- ^ Tansition Function
-> [sy] -- ^ Vocabulary
-> st -- ^ Origin
-> [st] -- ^ Destination States
destinationsFrom delta vs o = [ delta o v | v <- vs ]
-- | Compute the states that can be reached from a state
-- according to a given transition function and vocabulary
reachedStatesFrom :: (Eq [st], Ord st)
=> (st -> sy -> st) -- ^ Transition function
-> [sy] -- ^ Vocabulary
-> st -- ^ Origin
-> [st] -- ^ Reached states
reachedStatesFrom d v origin = origin : qs
where qs = limit stPath' (destinationsFrom d v origin)
stPath' = stPath d v
stPath :: Ord st => (st -> sy -> st) -> [sy] -> [st] -> [st]
stPath d v sts = sort $ nub $
(sts ++ (concat $ map (destinationsFrom d v) sts))
-----------------------------------------------------------------------------
-- * Transformation
-- | Produce the transition table of a given 'Dfa'.
-- Given a 'Dfa', it returns a list of triples of the form
-- @
-- (Origin,Symbol,Destination)
-- @
-- defining all the transitions of the 'Dfa'.
--
transitionTableDfa :: (Ord st, Ord sy)
=> Dfa st sy -- ^ Automaton
-> [(st,sy,st)] -- ^ Transition table
transitionTableDfa (Dfa v q s z delta) = sort [ ( aq , av , delta aq av)
| aq <- q
, av <- v
]
-- | Reconstruct a 'Dfa' from a transition table.
-- Given an automaton expressed by a transition table
-- (ie a list of triples of the form
-- @
-- (Origin,Symbol,Destination)
-- @
-- it constructs a 'Dfa'. The other elements of the
-- input tuple are the vocabulary, a set of
-- states, an initial state, and a set of
-- final states.
ttDfa2Dfa :: (Eq st, Eq sy)
=> ([sy],[st],st,[st],[(st,sy,st)]) -- ^ Tuple-based Automaton
-> Dfa st sy -- ^ Automaton
ttDfa2Dfa (vs,qs,s,z,ld) = Dfa vs qs s z d
where d st sy = lookUptt st sy ld
lookUptt q v ((a,b,c) : []) = c
lookUptt q v ((a,b,c) : xs) | q == a && v == b = c
| otherwise = lookUptt q v xs
--
-- Beautify the Automata States
--
beautifyDfaWithSyncSt :: Eq st
=> Dfa [st] sy -- ^ Original Automaton
-> Dfa [Int] sy -- ^ Beautified Automaton (states as integers)
beautifyDfaWithSyncSt (Dfa v q s z delta) = (Dfa v q' s' z' delta')
where qaux = (giveNumber q 1) ++ [([],[])]
q' = map snd qaux
s' = lookupSt s qaux
z' = getNewFinalSt z qaux
delta' st' sy' = lookupSt (delta (lookupNewSt st' qaux) sy') qaux
lookupSt :: Eq st => st -> [(st,[Int])] -> [Int]
lookupSt s (h:t) | fst h == s = snd h
| otherwise = lookupSt s t
lookupNewSt :: [Int] -> [(st,[Int])] -> st
lookupNewSt s (h:t) | snd h == s = fst h
| otherwise = lookupNewSt s t
getNewFinalSt :: Eq st => [st] -> [(st,[Int])] -> [[Int]]
getNewFinalSt [] qaux = []
getNewFinalSt (h:t) qaux = (lookupSt h qaux) : getNewFinalSt t qaux
giveNumber :: Eq st
=> [[st]]
-> Int -- ^ Initial number
-> [([st],[Int])] -- ^ ??
giveNumber [] i = []
giveNumber (h:t) i | h == [] = giveNumber t i
| otherwise = (h,[i]) : giveNumber t (i+1)
-- | Type of Table-based Deterministic Finite Automata.
--
type TableDfa st = [(st, [st])]
stsDfa = map fst
stsRHS = map snd
allstsTable = concat . stsRHS
-- | Dfa to a Table-based Dfa
--
dfa2tdfa :: (Eq st, Ord sy)
=> Dfa st sy -- ^ Automaton
-> TableDfa st -- ^ Transition table
dfa2tdfa (Dfa v q s z delta) = limit (dfa2tdfaStep delta v') tbFstRow
where v' = sort v
tbFstRow = consRows delta [s] v'
-- | Add rows to a table-based Dfa, given a Dfa transition function
-- and its vocabulary.
dfa2tdfaStep :: Eq st
=> (st -> sy -> st) -- ^ Transition function
-> [sy] -- ^ Vocabulary
-> TableDfa st -- ^ Table-based Dfa
-> TableDfa st -- ^ Table-based Dfa with additional rows.
dfa2tdfaStep delta alfabet tb = tb `union` (consRows delta newSts alfabet)
where newSts = ((nub . allstsTable) tb) <-> (stsDfa tb)
consRows :: (st -> sy -> st) -> [st] -> [sy] -> TableDfa st
consRows delta [] alfabet = []
consRows delta (q:qs) alfabet = (q , oneRow delta q alfabet) :
(consRows delta qs alfabet)
oneRow :: (st -> sy -> st) -> st -> [sy] -> [st]
oneRow delta st alfabet = map (delta st) alfabet
-- | Renames a 'Dfa'.
-- It renames a DFA in such a way that the renaming of two isomorphic DFA
-- returns the same DFA.
-- It is the basis for the equivalence test for minimized DFA.
--
renameDfa :: (Ord st, Ord sy)
=> Dfa st sy -- ^ Automaton
-> Int -- ^ Initial state ID
-> Dfa Int sy -- ^ Renamed automaton
renameDfa dfa@(Dfa v q s z delta) istid = Dfa v' q' s' z' delta'
where v' = sort v
q' = sort $ map snd newSts
tb = dfa2tdfa dfa
s' = istid
newSts = newStsOfTable tb s'
z' = sort $ map snd (filter (\(a,b) -> a `elem` z) newSts)
delta' newSt sy = lookupNewSts delta newSt sy newSts
--
-- Giving new names to the Dfa states
--
newStsOfTable :: Eq st => TableDfa st -> Int -> [(st,Int)]
newStsOfTable tb ini = newStsOfTableAux tb [(fst $ head tb,ini)]
newStsOfTableAux :: Eq a => [(b,[a])] -> [(a,Int)] -> [(a,Int)]
newStsOfTableAux [] newSt = newSt
newStsOfTableAux ((st,sts):t) newSt = newSt''
where newSt' = procrhsSts sts newSt
newSt'' = newStsOfTableAux t newSt'
procrhsSts :: Eq a => [a] -> [(a,Int)] -> [(a,Int)]
procrhsSts [] newSt = newSt
procrhsSts (st:sts) newSt
| st `elem` (map fst newSt) = procrhsSts sts newSt
| otherwise = newSt'
where newSt' = procrhsSts sts ((st,( snd $ head newSt) + 1) : newSt)
lookupNewSts delta newSt sy newSts = getNewSt newOldSt newSts
where newOldSt = delta (getOldSt newSt newSts) sy
getNewSt oldSt newSts = snd $ head (filter (\(a,b) -> a == oldSt) newSts)
getOldSt newSt newSts = fst $ head (filter (\(a,b) -> b == newSt) newSts)
-- | Beautify a 'Dfa' by assigning (natural) numbers to states.
beautifyDfa :: (Ord st, Ord sy) => Dfa st sy -> Dfa Int sy
beautifyDfa dfa = renameDfa dfa 1
-----------------------------------------------------------------------------
-- * Properties of 'Dfa'
-- | Compute the dead states of a 'Dfa'
--
dfadeadstates :: Ord st
=> Dfa st sy -- ^ Automaton
-> [st] -- ^ Dead states
dfadeadstates (Dfa v qs s z d) = filter (isStDead d v z) qs
-- | Compute the size of a deterministic finite automaton.
-- The size of an automaton is the number of its states.
sizeDfa :: Dfa st sy -> Int
sizeDfa (Dfa _ q _ _ _) = length q
-----------------------------------------------------------------------------
-- * Properties of States
-- | Checks whether a state is dead or not.
--
-- One state is dead when it is not possible to reach a final state from it.
-- (probably we should consider that it has to be reachable from the
-- initial state, as well)
isStDead :: Ord st
=> (st -> sy -> st) -- ^ Transition Function
-> [sy] -- ^ Vocabulary
-> [st] -- ^ Set of Final States
-> st -- ^ State
-> Bool
isStDead d v z st = reachedStatesFrom d v st `intersect` z == []
-- | Checks whether a state is a sync state or not
--
-- A sync state is a state that has transitions to itself for all
-- symbols of the vocabulary
isStSync :: Eq st
=> (st -> sy -> st) -- ^ Transition Function
-> [sy] -- ^ Vocabulary
-> [st] -- ^ Set of Final States
-> st -- ^ State
-> Bool
isStSync d vs z st = and qs
where qs = [ st == dfawalk d st [v]
| v <- vs
]
-- | Compute the number of incoming arrows for a given state
--
numberIncomingArrows :: Eq st
=> (st -> sy -> st) -- ^ Transition Function
-> [sy] -- ^ Vocabulary
-> [st] -- ^ Set of States
-> st -- ^ Destination
-> Int -- ^ Number of Arrows
numberIncomingArrows d vs qs dest = length [ q
| v <- vs
, q <- qs
, d q v == dest
]
-- | Compute the number of outgoing arrows for a given state
numberOutgoingArrows :: (st -> sy -> st) -- ^ Transition Function
-> [sy] -- ^ Vocabulary
-> st -- ^ Origin
-> Int -- ^ Number of Arrows
numberOutgoingArrows d v o = length $ destinationsFrom d v o