module FST.Transducer (
module FST.TransducerTypes,
Transducer,
TConvertable (decode, encode),
construct,
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 = s `elem` finalStates a
initials = initS
finals = finalStates
transitionTable = stateTrans
transitionList a s = case lookup s (stateTrans a) of
Just xs -> xs
_ -> []
transitionsU auto (s,a) = [ (c, s1)
| ((b, c), s1) <- transitionList auto s, a == b ]
transitionsD auto (s,a) = [ (b, s1)
| ((b, c), s1) <- transitionList auto s, a == c ]
lastState = lastS
firstState = firstS
alphabet = alpha
initial :: Transducer a -> StateTy
initial = head . initials
nullFirstState :: Transducer a -> Transducer a
nullFirstState transducer = transducer { firstS = 0 }
transitions :: Eq a => Transducer a -> (StateTy,Relation a) -> [StateTy]
transitions transducer (s,r) =
[ r2 | (r1, r2) <- transitionList transducer s, r == r1 ]
construct :: (StateTy, StateTy) -> TTransitionTable a -> Sigma a ->
InitialStates -> FinalStates -> Transducer a
construct (first, last) table sigma is fs =
Transducer {
stateTrans = table,
initS = is,
finalStates = fs,
firstS = first,
lastS = last,
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] ->
StateTy -> Transducer a
rename tTable sigma initS fs s
= let (maxS, table) = tagging (map fst tTable) s
nI = map (`lookupState` table) initS
nfs = map (`lookupState` 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 = [ (a, lookupState b table) | (a, b) <- tl ]
in (s1,ntl):renameTable tll table
renameT :: Transducer a -> Transducer a -> (Transducer a,Transducer a,StateTy)
renameT transd1 transd2 = (transd1, tr2, lastState tr2 + 1) where
tr2 = rename (transitionTable transd2)
(alphabet transd2) (initials transd2)
(finals transd2) (lastState transd1 + 1)
productT :: Eq a => Transducer a -> Transducer a -> Transducer a
productT transd1 transd2 = productT' (renameT transd1 transd2) 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) ++
[ s | acceptEpsilon t1 && acceptEpsilon t2]
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 ++ [ s | acceptEpsilon t1 || acceptEpsilon t2 ]
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 = [ nS | acceptEpsilon t1 && acceptEpsilon t2 ] ++
[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 = if acceptEpsilon transducer then xs else []
showTransducer :: Show a => Transducer a -> String
showTransducer transducer = unlines
[ "Transitions:"
, aux (stateTrans transducer)
, "Number of States => " ++ show (length (transitionTable transducer))
, "Number of Transitions => " ++ show (sum [length tl | (s,tl) <- transitionTable transducer])
, "Alphabet => " ++ show (alphabet transducer)
, "Initials => " ++ show (initials transducer)
, "Finals => " ++ show (finals transducer)
]
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)"