HaLeX-1.3.0: HaLeX_lib/Language/HaLex/FaOperations.hs
-----------------------------------------------------------------------------
-- |
-- Module : Language.HaLex.FaOperations
-- Copyright : (c) João Saraiva 2001,2002,2003,2004,2005,2017,2025
-- License : LGPL
--
-- Maintainer : saraiva@di.uminho.pt
-- Stability : provisional
-- Portability : portable
--
-- Functions manipulating Finite Automata (DFA and NDFA)
--
-- Code Included in the Lecture Notes on
-- Language Processing (with a functional flavour).
--
-----------------------------------------------------------------------------
module Language.HaLex.FaOperations (
ndfa2dfa
, dfa2ndfa
, ndfa2ct
, CT
, lookupCT
, stsDfa
, concatNdfa
, unionNdfa
, starNdfa
, plusNdfa
, expNdfa
, unionDfa
, concatDfa
, starDfa
, plusDfa
) where
import Data.List
import Language.HaLex.Util
import Language.HaLex.Dfa
import Language.HaLex.Ndfa
--
-- | Making a 'Dfa' from a 'Ndfa'
--
-- | The states of a 'Dfa' resulting from a 'Ndfa' are sets of
-- states of the 'Ndfa'
type StDfa st = [st]
-- | A transition table will be used to transform a 'Ndfa' into a 'Dfa'
--
type CT st = TableDfa (StDfa st) -- [( StDfa st, [StDfa st])]
stsDfa :: CT st -> [StDfa st]
stsDfa = map fst
stsRHS :: CT st -> [[StDfa st]]
stsRHS = map snd
allSts :: Eq st => CT st -> [StDfa st]
allSts = nub . concat . stsRHS
-- | From a 'Ndfa' to a 'Dfa'
--
ndfa2dfa :: (Ord st,Eq sy)
=> Ndfa st sy -- ^ Nondterminitic Finite Automaton
-> Dfa [st] sy -- ^ Deterministic Finite Automaton
ndfa2dfa ndfa@(Ndfa v q s z delta) = (Dfa v' q' s' z' delta')
where tt = ndfa2ct ndfa
v' = v
q' = stsDfa tt
s' = fst (head tt)
z' = finalStatesDfa q' z
delta' st sy = lookupCT st sy tt v
finalStatesDfa :: Eq st => [StDfa st] -> [st] -> [StDfa st]
finalStatesDfa [] _ = []
finalStatesDfa (q:qs) z | (not . null) (q `intersect` z) = q : finalStatesDfa qs z
| otherwise = finalStatesDfa qs z
-- | Lookup the Transition Table 'CT' of a the resulting 'Dfa'
--
lookupCT :: (Eq st, Eq sy)
=> StDfa st -- ^ Origin state of the 'Dfa'
-> sy -- ^ Symbol
-> CT st -- ^ Transition Table of the 'Dfa'
-> [sy] -- ^ Vocabulary
-> StDfa st -- ^ Destination state of the 'Dfa'
lookupCT st sy [] v = []
lookupCT st sy (q:qs) v | (fst q == st) = (snd q) !! col
| otherwise = lookupCT st sy qs v
where (Just col) = elemIndex sy v
-- | Compute the 'Dfa' transition table giving a 'Ndfa'
--
ndfa2ct :: Ord st
=> Ndfa st sy -- ^ Nondterminitic Finite Automaton
-> CT st -- ^ Transition Table
ndfa2ct (Ndfa v q s z delta) = limit (ndfa2dfaStep delta v) ttFstRow
where ttFstRow = newRows delta [epsilon_closure delta s] v
ndfa2dfaStep :: Ord st => (st -> (Maybe sy) -> [st]) -> [sy] -> CT st -> CT st
ndfa2dfaStep delta alfabet ct = nub (ct `union` newRows delta newSts alfabet)
where newSts = (allSts ct) <-> (stsDfa ct)
newRows :: Ord st => (st -> (Maybe sy) -> [st]) -> [StDfa st] -> [sy] -> CT st
newRows delta sts alfabet = map (\ st -> (st, newRow delta st alfabet)) sts
newRow :: Ord st => (st -> (Maybe sy) -> [st]) -> (StDfa st) -> [sy] -> [StDfa st]
newRow delta sts alfabet = map (\ v -> sort (ndfawalk delta sts [v])) alfabet
ndfa2ct' :: Ord st => Ndfa st sy -> CT st
ndfa2ct' (Ndfa v q s z delta) =
fst $ ndfa2ctstep' delta v [] [fstState] []
where fstState = epsilon_closure delta s
ndfa2ctstep' :: Ord st
=> (st -> Maybe sy -> [st]) -> [sy] -> CT st
-> [StDfa st] -> [StDfa st] -> (CT st , [StDfa st])
ndfa2ctstep' delta v ct [] done = (ct , done )
ndfa2ctstep' delta v ct (st:sts) done = (ct'' , done'')
where done' = st : done
newRow' = (st , newRow delta st v)
ct' = newRow' : ct
newSts = (snd newRow') <-> done'
worker = sts ++ newSts
(ct'' , done'' ) = ndfa2ctstep' delta v ct' worker done'
-- | Making a 'Ndfa' from a 'Dfa'
--
dfa2ndfa :: Dfa st sy -> Ndfa st sy
dfa2ndfa (Dfa v q s z delta) = (Ndfa v q [s] z delta')
where delta' q (Just a) = [delta q a]
delta' q Nothing = []
-----------------------------------------------------------------------------
-- * Combining Finite Automata
-- | Concatenation of Ndfa's
--
concatNdfa :: (Eq a, Eq b) => Ndfa b a -> Ndfa b a -> Ndfa b a
concatNdfa (Ndfa vp qp sp zp dp) (Ndfa vq qq sq zq dq) = Ndfa v' q' s' z' d'
where v' = vp `union` vq
q' = qp `union` qq
s' = sp
z' = zq
d' q | q `elem` zp = dp' q
| q `elem` qp = dp q
| otherwise = dq q
where dp' q Nothing = (dp q Nothing) `union` sq
dp' q sy = dp q sy
-- | Union of 'Ndfa'
--
unionNdfa :: (Eq a, Eq b) => Ndfa b a -> Ndfa b a -> Ndfa b a
unionNdfa (Ndfa vp qp sp zp dp) (Ndfa vq qq sq zq dq) = Ndfa v' q' s' z' d'
where v' = vp `union` vq
q' = qp `union` qq
s' = sp `union` sq
z' = zp `union` zq
d' q | q `elem` qp = dp q
| q `elem` qq = dq q
-- | Star of 'Ndfa'
--
starNdfa :: Eq st => Ndfa st sy -> Ndfa st sy
starNdfa (Ndfa v qs s z d) = Ndfa v qs s z d'
where d' q | q `elem` s = ds' q
| q `elem` z = dz' q
| otherwise = d q
where ds' q Nothing = z `union` (d q Nothing)
ds' q sy = d q sy
dz' q Nothing = s `union` (d q Nothing)
dz' q sy = d q sy
-- | Plus of 'Ndfa'
--
plusNdfa :: Eq st => Ndfa st sy -> Ndfa st sy
plusNdfa (Ndfa v qs s z d) = Ndfa v qs s z d'
where d' q | q `elem` z = dz' q
| otherwise = d q
where dz' q Nothing = s `union` (d q Nothing)
dz' q sy = d q sy
-- | Exponenciation of 'Ndfa'
--
expNdfa :: (Eq st,Eq sy) => Ndfa st sy -> Int -> Ndfa Int sy
expNdfa ndfa n = expNdfa' (renameNdfa ndfa 1) n
expNdfa' :: Eq sy => Ndfa Int sy -> Int -> Ndfa Int sy
expNdfa' ndfa 1 = ndfa
expNdfa' ndfa i = concatNdfa ndfa (expNdfa' ndfa (i-1))
-- | Concatenation of 'Dfa'
--
concatDfa :: (Eq a, Eq b) => Dfa b a -> Dfa b a -> Ndfa b a
concatDfa (Dfa vp qp sp zp dp) (Dfa vq qq sq zq dq) = Ndfa v' q' s' z' d'
where v' = vp `union` vq
s' = [sp]
z' = zq
q' = qp `union` qq
d' q | q `elem` zp = dz' q
| q `elem` qp = dp' q
| q `elem` qq = dq' q
where dz' q Nothing = [sq]
dz' q (Just y) | y `elem` vp = [dp q y]
| otherwise = []
dp' q Nothing = []
dp' q (Just y) | y `elem` vp = [dp q y]
| otherwise = []
dq' q Nothing = []
dq' q (Just y) | y `elem` vq = [dq q y]
| otherwise = []
-- | Union of 'Dfa'
--
unionDfa :: (Eq a, Eq b) => Dfa b a -> Dfa b a -> Ndfa b a
unionDfa (Dfa vp qp sp zp dp) (Dfa vq qq sq zq dq) = Ndfa v' q' s' z' d'
where v' = vp `union` vq
q' = qp `union` qq
s' = [sp,sq]
z' = zp ++ zq
d' _ Nothing = []
d' q (Just sy) | q `elem` qp && sy `elem` vp = [dp q sy]
| q `elem` qq && sy `elem` vq = [dq q sy]
| otherwise = []
-- | Star 'Dfa'
--
starDfa :: Eq st => Dfa st sy -> Ndfa st sy
starDfa (Dfa v q s z d) = Ndfa v q [s] z d'
where d' q | q == s = ds' q
| q `elem` z = dz' q
| otherwise = dd' q
where ds' q Nothing = z
ds' q (Just y) = [d q y]
dz' q Nothing = [s]
dz' q (Just y) = [d q y]
dd' q (Just y) = [d q y]
dd' _ _ = []
-- | Plus pf 'Dfa'
--
plusDfa :: Eq st => Dfa st sy -> Ndfa st sy
plusDfa (Dfa v q s z d) = Ndfa v q [s] z d'
where d' q | q `elem` z = dz' q
| otherwise = dd' q
where dz' q Nothing = [s]
dz' q (Just y) = [d q y]
dd' q (Just y) = [d q y]
dd' _ _ = []