module FST.Transducer ( module FST.TransducerTypes,
Transducer,
construct,
TConvertable,
decode,
encode,
rename,
initial,
transitions,
nullFirstState,
productT,
unionT,
starT,
compositionT,
showTransducer
) where
import FST.TransducerTypes
import FST.Utils (tagging,remove,merge)
import Data.Maybe (fromJust)
import Data.List ((\\),nub,delete)
data Transducer a = Transducer {
stateTrans :: TTransitionTable a,
initS :: InitialStates,
finalStates :: FinalStates,
alpha :: Sigma a,
firstS :: FirstState,
lastS :: LastState
}
deriving (Show,Read)
instance TransducerFunctions Transducer where
states = (map fst).stateTrans
isFinal a s = elem s (finalStates a)
initials = initS
finals = finalStates
transitionTable = stateTrans
transitionList a s = case (lookup s (stateTrans a)) of
Just xs -> xs
_ -> []
transitionsU auto (s,a) = map (\((_,c),s1) -> (c,s1)) $
filter (\((b,_),_) -> a == b) (transitionList auto s)
transitionsD auto (s,a) = map (\((c,_),s1) -> (c,s1)) $
filter (\((_,b),_) -> a == b) (transitionList auto s)
lastState = lastS
firstState = firstS
alphabet = alpha
initial :: Transducer a -> State
initial = head.initials
nullFirstState :: Transducer a -> Transducer a
nullFirstState transducer = transducer {firstS = 0}
transitions :: Eq a => Transducer a -> (State,Relation a) -> [State]
transitions transducer (s,r) = map snd $ filter (\(r1,_) -> r == r1)
(transitionList transducer s)
construct :: (State,State) -> TTransitionTable a -> Sigma a ->
InitialStates -> FinalStates -> Transducer a
construct bs table sigma is fs = Transducer {
stateTrans = table,
initS = is,
finalStates = fs,
firstS = fst bs,
lastS = snd bs,
alpha = sigma
}
class TConvertable f where
encode :: Eq a => f a -> Transducer a
decode :: Eq a => Transducer a -> f a
rename :: Eq b => [(b,[(Relation a,b)])] -> Sigma a -> [b] -> [b] ->
State -> Transducer a
rename tTable sigma initS fs s
= let (maxS,table) = tagging (map fst tTable) s
nI = map (\b -> lookupState b table) initS
nfs = map (\b -> lookupState b table) fs
nTrans = renameTable tTable table
in construct (s,maxS) nTrans sigma nI nfs
where lookupState st tab = fromJust $ lookup st tab
renameTable [] _ = []
renameTable ((b,tl):tll) table
= let s1 = lookupState b table
ntl = map (\(a,b1) -> (a,lookupState b1 table)) tl
in (s1,ntl):renameTable tll table
renameT :: Transducer a -> Transducer a -> (Transducer a,Transducer a,State)
renameT transducer1 transducer2 = let tr2 = rename
(transitionTable transducer2)
(alphabet transducer2)
(initials transducer2)
(finals transducer2)
(lastState transducer1 +1)
in (transducer1,tr2,lastState tr2 +1)
productT :: Eq a => Transducer a -> Transducer a -> Transducer a
productT transducer1 transducer2 = productT' $ renameT transducer1
transducer2
where productT' (t1,t2,s) =
let transUnion = (remove (initial t1) (transitionTable t1)) ++
(remove (initial t2) (transitionTable t2))
transConc = let t = (transitionList t2 (initial t2)) in
[(f,t)| f <- (finals t1)]
transInit = [(s, transitionList t1 (initial t1) ++
listEps t1 (transitionList t2 (initial t2)))]
fs = finals t2 ++ listEps t2 (finals t1) ++
if (acceptEpsilon t1 && acceptEpsilon t2)
then [s] else []
in Transducer
{
stateTrans = transInit ++ merge transConc transUnion,
finalStates = fs \\ [(initial t1),(initial t2)],
alpha = nub $ alphabet t1 ++ alphabet t2,
initS = [s],
firstS = firstState t1,
lastS = s
}
unionT :: Eq a => Transducer a -> Transducer a -> Transducer a
unionT transducer1 transducer2 = unionT' $ renameT transducer1 transducer2
where unionT' (t1,t2,s) =
let transUnion = (remove (initial t1) (transitionTable t1)) ++
(remove (initial t2) (transitionTable t2))
transInit = [(s, transitionList t1 (initial t1) ++
transitionList t2 (initial t2))]
fs = finals t1 ++ finals t2 ++
if (acceptEpsilon t1 || acceptEpsilon t2)
then [s] else []
in Transducer
{
stateTrans = transInit ++ transUnion,
finalStates = fs \\ [(initial t1),(initial t2)],
alpha = nub $ alphabet t1 ++ alphabet t2,
initS = [s],
firstS = firstState t1,
lastS = s
}
starT :: Eq a => Transducer a -> Transducer a
starT t1
= let s = lastState t1 +1
transUnion = remove (initial t1) (transitionTable t1)
transLoop = let t = transitionList t1 (initial t1) in
(s,t): [(f,t) | f <- finals t1]
in Transducer {
stateTrans = merge transLoop transUnion,
finalStates = (s:(delete (initial t1) (finals t1))),
alpha = alphabet t1,
initS = [s],
firstS = firstState t1,
lastS = s
}
compositionT :: Eq a => Transducer a -> Transducer a -> Transducer a
compositionT t1 t2 =
let minS1 = firstState t1
minS2 = firstState t2
name (s1,s2) = (lastState t2 minS2 +1) *
(s1 minS1) + s2 minS2 + minS1
nS = name (lastState t1,lastState t2) +1
transInit = (nS,[((a,d),name (s1,s2)) |
((a,b),s1) <- ((Eps,Eps),initial t1):transitionList
t1 (initial t1),
((c,d),s2) <- ((Eps,Eps),initial t2):transitionList
t2 (initial t2),
((a,b) /= (Eps,Eps)) || ((c,d) /= (Eps,Eps)),
b == c])
transTable = [(name (s1,s2),[((a,d),name (s3,s4)) | ((a,b),s3) <- ((Eps,Eps),s1):tl1,
((c,d),s4) <- ((Eps,Eps),s2):tl2,
((a,b) /= (Eps,Eps)) || ((c,d) /= (Eps,Eps)),
b == c]) |
(s1,tl1) <- transitionTable t1,
(s2,tl2) <- transitionTable t2,
s1 /= initial t1 ||
s2 /= initial t2
]
transUnion = transInit:transTable
fs = (if (acceptEpsilon t1 && acceptEpsilon t2)
then [nS] else []) ++
[name (f1,f2)| f1 <- finals t1,
f2 <- finals t2]
in Transducer
{
stateTrans = merge [(s,[]) | s <- fs] transUnion,
finalStates = fs,
alpha = nub $ alphabet t1 ++ alphabet t2 ,
initS = [nS],
firstS = min (firstState t1) (firstState t2),
lastS = nS
}
acceptEpsilon :: Transducer a -> Bool
acceptEpsilon transducer = isFinal transducer (initial transducer)
listEps :: Transducer a -> [b] -> [b]
listEps transducer xs
| acceptEpsilon transducer = xs
| otherwise = []
showTransducer :: Show a => Transducer a -> String
showTransducer transducer
= "\n>>>> Transducer Construction <<<<" ++
"\n\nTransitions:\n" ++ aux (stateTrans transducer) ++
"\nNumber of States => " ++ show (length (transitionTable transducer)) ++
"\nNumber of Transitions => " ++ show (sum [length tl | (s,tl) <- transitionTable transducer]) ++
"\nAlphabet => " ++ show (alphabet transducer) ++
"\nInitials => " ++ show (initials transducer) ++
"\nFinals => " ++ show (finals transducer) ++ "\n"
where aux [] = []
aux ((s,tl):xs) = show s ++" => " ++ aux2 tl ++ "\n" ++ aux xs
aux2 [] = []
aux2 ((r,s):tl) = "( " ++ showR r ++ " ," ++ show s ++") " ++ aux2 tl
showR (S a, S b) = "(" ++ show a ++":" ++ show b ++ ")"
showR (S a, Eps) = "(" ++ show a ++":eps)"
showR (Eps, S b) = "(eps:" ++ show b ++ ")"
showR (Eps, Eps) = "(eps:eps)"