Transducer.hs

import Data.Maybe
import Data.List

import Control.Monad

type State = Int

data TransitionKey a = Epsilon | Key a | Other | Wildcard deriving (Eq, Show)

type Transition a      = (State, (TransitionKey a, TransitionKey a))
type TransitionTable a = [(State, Transition a)]

data Transducer a = Transducer State [State] (TransitionTable a)

lookupM :: (Eq a, MonadPlus m) => a -> [(a, b)] -> m b
lookupM key [] = mzero
lookupM key ((a, b):xs)
    | key == a  = return b `mplus` lookupM key xs
    | otherwise = lookupM key xs

keyToList :: TransitionKey a -> a -> [a]
keyToList Epsilon  _ = []
keyToList (Key c)  _ = [c]
keyToList Wildcard c = [c]
keyToList Other    c = [c]

follow :: [a] -> a -> Transition a -> (State, [a])
follow outS c (s, (inp, Wildcard)) = (s, outS ++ keyToList inp c)
follow outS c (s, (inp, Other))    = (s, outS ++ keyToList inp c)
follow outS c (s, (_, Epsilon))    = (s, outS)
follow outS _ (s, (_, Key c))      = (s, outS ++ [c])

followEpsilon :: [a] -> Transition a -> (State, [a])
followEpsilon outS (s, (_, Wildcard)) = (s, outS)
followEpsilon outS (s, (_, Epsilon))  = (s, outS)
followEpsilon outS (s, (_, Key c))    = (s, outS ++ [c])

revFollow :: [a] -> a -> Transition a -> (State, [a])
revFollow outS c (s, (Wildcard, out)) = (s, outS ++ keyToList out c)
revFollow outS c (s, (Other, out))    = (s, outS ++ keyToList out c)
revFollow outS c (s, (Epsilon, _))    = (s, outS)
revFollow outS _ (s, (Key c, _))      = (s, outS ++ [c])

revFollowEpsilon :: [a] -> Transition a -> (State, [a])
revFollowEpsilon outS (s, (Wildcard, _)) = (s, outS)
revFollowEpsilon outS (s, (Epsilon, _))  = (s, outS)
revFollowEpsilon outS (s, (Key c, _))    = (s, outS ++ [c])

transitionInput :: Transition a -> TransitionKey a
transitionInput = fst . snd

transitionOutput :: Transition a -> TransitionKey a
transitionOutput = snd . snd

start :: Transducer a -> State
start (Transducer s _ _) = s

terminalIn :: State -> Transducer a -> Bool
state `terminalIn` (Transducer _ terminals _) = state `elem` terminals

transitionTable :: Transducer a -> TransitionTable a
transitionTable (Transducer _ _ t) = t

search :: Eq a =>
          (Transition a -> TransitionKey a)
              -> State
              -> TransitionTable a
              -> TransitionKey a
              -> [Transition a]
search f s table key = filter ((== key) . f) $ lookupM s table

findTransitions :: Eq a => (Transition a -> TransitionKey a) -> Transducer a -> State -> a -> [Transition a]
findTransitions f fst s char
    | null normal = research Other
    | otherwise   = normal
    where normal   = concatMap research [Key char, Wildcard]
          research = search f s (transitionTable fst)

transitions :: Eq a => Transducer a -> State -> a -> [Transition a]
transitions = findTransitions transitionInput

revTransitions :: Eq a => Transducer a -> State -> a -> [Transition a]
revTransitions = findTransitions transitionOutput

findEpsilonTransitions :: Eq a => (Transition a -> TransitionKey a) -> Transducer a -> State -> [Transition a]
findEpsilonTransitions f fst s = search f s (transitionTable fst) Epsilon

epsilonTransitions :: Eq a => Transducer a -> State -> [Transition a]
epsilonTransitions = findEpsilonTransitions transitionInput

revEpsilonTransitions :: Eq a => Transducer a -> State -> [Transition a]
revEpsilonTransitions = findEpsilonTransitions transitionOutput

runFST :: Eq a =>
         ([a] -> a -> Transition a -> (State, [a])) -> -- follow
         ([a] -> Transition a -> (State, [a])) -> -- followEpsilon
         (Transducer a -> State -> a -> [Transition a]) ->  -- transitions
         (Transducer a -> State -> [Transition a]) -> -- epsilonTransitions
         Transducer a -> [a] -> [[a]]

runFST follow followEpsilon transitions epsilonTransitions f =
    map snd . filter ((`terminalIn` f) . fst) . finalStates
        where finalStates = foldM nextStates (start f, [])
              nextStates (s, out) c = epsilon nexts
                  where nexts = map (follow out c) (transitions f s c)
              epsilon []  = []
              epsilon set = set ++ epsilon nexts
                  where nexts = concatMap (\(s, out) -> map (followEpsilon out) $ epsilonTransitions f s)
                                set

evalFST :: Eq a => Transducer a -> [a] -> [[a]]
evalFST = runFST follow followEpsilon transitions epsilonTransitions

revEvalFST :: Eq a => Transducer a -> [a] -> [[a]]
revEvalFST = runFST revFollow revFollowEpsilon revTransitions revEpsilonTransitions

defaultTr :: a -> State -> State -> (State, Transition a)
defaultTr c from to = (from, (to, (Key c, Key c)))

tr :: (a, a) -> State -> State -> (State, Transition a)
tr (inp, out) from to = (from, (to, (Key inp, Key out)))

epsTrans :: a -> State -> State -> (State, Transition a)
epsTrans out from to = (from, (to, (Epsilon, Key out)))

revEpsTrans :: a -> State -> State -> (State, Transition a)
revEpsTrans inp from to = (from, (to, (Key inp, Epsilon)))

data Test = C Char | Noun | Verb | Sg | Pl deriving (Show, Eq)
testFST :: Transducer Test
testFST = Transducer
            0
            [5, 6, 12, 14, 17, 18]
            [defaultTr   (C 'c') 0 1
            ,defaultTr   (C 'a') 1 2
            ,defaultTr   (C 't') 2 3
            ,epsTrans    Noun 3 4
            ,tr          (C 's', Pl) 4 5
            ,epsTrans    Sg 4 6
            ,defaultTr   (C 'w') 0 7
            ,defaultTr   (C 'a') 7 8
            ,defaultTr   (C 't') 8 9
            ,defaultTr   (C 'c') 9 10
            ,defaultTr   (C 'h') 10 11
            ,epsTrans    Verb 11 12
            ,revEpsTrans (C 'e') 12 13
            ,tr          (C 's', Sg) 13 14
            ,epsTrans    Noun 11 15
            ,epsTrans    Sg 15 18
            ,revEpsTrans (C 'e') 15 16
            ,tr          (C 's', Pl) 16 17
            ]

doubleAs :: Transducer Char
doubleAs = Transducer
           0
           [0]
           [defaultTr 'a' 0 1
           ,epsTrans  'a' 1 0]

doubleAs' :: Transducer Char
doubleAs' = Transducer
           0
           [0]
           [defaultTr 'a' 0 1
           ,epsTrans  'a' 1 0
           ,(0, (0, (Other, Other)))]

rem6s :: Transducer Char
rem6s = Transducer
        0
        [0, 1]
        [defaultTr '6' 0 1
        ,revEpsTrans '6' 1 1
        ,(0, (0, (Other, Other)))
        ,(1, (0, (Other, Other)))]