module Language.HaLex.Dfa (
Dfa (..)
, dfaaccept
, dfawalk
, ttDfa2Dfa
, dfa2tdfa
, transitionsFromTo
, destinationsFrom
, transitionTableDfa
, reachedStatesFrom
, beautifyDfa
, renameDfa
, showDfaDelta
, beautifyDfaWithSyncSt
, dfaIO
, sizeDfa
, dfadeadstates
, isStDead
, isStSync
, numberOutgoingArrows
, numberIncomingArrows
) where
import Data.List
import Language.HaLex.Util
data Dfa st sy = Dfa [sy]
[st]
st
[st]
(st -> sy -> st)
dfawalk :: (st -> sy -> st)
-> st
-> [sy]
-> st
dfawalk delta s [] = s
dfawalk delta s (x:xs) = dfawalk delta (delta s x) xs
dfaaccept' :: Eq st
=> Dfa st sy
-> [sy]
-> Bool
dfaaccept' (Dfa v q s z delta) simb = (dfawalk delta s simb) `elem` z
dfaaccept :: Eq st
=> Dfa st sy
-> [sy]
-> Bool
dfaaccept (Dfa v q s z delta) simb = (foldl delta s simb) `elem` z
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
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')
dfaIO :: (Show st , Show sy)
=> (Dfa st sy)
-> String
-> IO ()
dfaIO afd modulename =
writeFile (modulename ++ ".hs")
("module " ++ modulename ++ " where\n\nimport Dfa\n\n"
++ (show afd))
transitionsFromTo :: Eq st
=> (st -> sy -> st)
-> [sy]
-> st
-> st
-> [sy]
transitionsFromTo delta vs o d = [ v
| v <- vs
, delta o v == d
]
destinationsFrom :: (st -> sy -> st)
-> [sy]
-> st
-> [st]
destinationsFrom delta vs o = [ delta o v | v <- vs ]
reachedStatesFrom :: (Eq [st], Ord st)
=> (st -> sy -> st)
-> [sy]
-> st
-> [st]
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))
transitionTableDfa :: (Ord st, Ord sy)
=> Dfa st sy
-> [(st,sy,st)]
transitionTableDfa (Dfa v q s z delta) = sort [ ( aq , av , delta aq av)
| aq <- q
, av <- v
]
ttDfa2Dfa :: (Eq st, Eq sy)
=> ([sy],[st],st,[st],[(st,sy,st)])
-> Dfa st sy
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
beautifyDfaWithSyncSt :: Eq st
=> Dfa [st] sy
-> Dfa [Int] sy
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
-> [([st],[Int])]
giveNumber [] i = []
giveNumber (h:t) i | h == [] = giveNumber t i
| otherwise = (h,[i]) : giveNumber t (i+1)
type TableDfa st = [(st, [st])]
stsDfa = map fst
stsRHS = map snd
allstsTable = concat . stsRHS
dfa2tdfa :: (Eq st, Ord sy)
=> Dfa st sy
-> TableDfa st
dfa2tdfa (Dfa v q s z delta) = limit (dfa2tdfaStep delta v') tbFstRow
where v' = sort v
tbFstRow = consRows delta [s] v'
dfa2tdfaStep :: Eq st
=> (st -> sy -> st)
-> [sy]
-> TableDfa st
-> TableDfa st
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
renameDfa :: (Ord st, Ord sy)
=> Dfa st sy
-> Int
-> Dfa Int sy
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
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)
beautifyDfa :: (Ord st, Ord sy) => Dfa st sy -> Dfa Int sy
beautifyDfa dfa = renameDfa dfa 1
dfadeadstates :: Ord st
=> Dfa st sy
-> [st]
dfadeadstates (Dfa v qs s z d) = filter (isStDead d v z) qs
sizeDfa :: Dfa st sy -> Int
sizeDfa (Dfa _ q _ _ _) = length q
isStDead :: Ord st
=> (st -> sy -> st)
-> [sy]
-> [st]
-> st
-> Bool
isStDead d v z st = reachedStatesFrom d v st `intersect` z == []
isStSync :: Eq st
=> (st -> sy -> st)
-> [sy]
-> [st]
-> st
-> Bool
isStSync d vs z st = and qs
where qs = [ st == dfawalk d st [v]
| v <- vs
]
numberIncomingArrows :: Eq st
=> (st -> sy -> st)
-> [sy]
-> [st]
-> st
-> Int
numberIncomingArrows d vs qs dest = length [ q
| v <- vs
, q <- qs
, d q v == dest
]
numberOutgoingArrows :: (st -> sy -> st)
-> [sy]
-> st
-> Int
numberOutgoingArrows d v o = length $ destinationsFrom d v o