{- | Transducers and their functions -} module FST.Transducer ( module FST.TransducerTypes, -- * Types Transducer, TConvertable (decode, encode), -- * Transducer construction construct, -- * Actions on transducers 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 type for a transducer 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 state initial :: Transducer a -> StateTy initial = head . initials -- | Set first state to null nullFirstState :: Transducer a -> Transducer a nullFirstState transducer = transducer { firstS = 0 } -- | Get transition as a list of states transitions :: Eq a => Transducer a -> (StateTy,Relation a) -> [StateTy] transitions transducer (s,r) = [ r2 | (r1, r2) <- transitionList transducer s, r == r1 ] -- | Construct a transducer 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 } -- | Type class TConvertable class TConvertable f where encode :: Eq a => f a -> Transducer a decode :: Eq a => Transducer a -> f a -- | Convert transducer labelled with something other than states to a Transducer 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) -- | Product of two transducers 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 } -- | Union of two transducers 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 } -- | Kleene star of two transducers 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 } -- | Compose two transducers 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 } -- | Does a transducer accept epsilon acceptEpsilon :: Transducer a -> Bool acceptEpsilon transducer = isFinal transducer (initial transducer) -- | If the transducer accepts epsilon, return second argument listEps :: Transducer a -> [b] -> [b] listEps transducer xs = if acceptEpsilon transducer then xs else [] -- | Show a transducer 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)"