toktok-0.5: Toktok/Transducer.hs

-- | This is the module defining the transducer.
-- a transducer is build from a Trie with added sandhis.
module Toktok.Transducer where

import Data.Map (Map)
import Data.Monoid
import qualified Data.Map as Map
import Data.List(isPrefixOf)
import Data.Char(isUpper, toLower)

import Toktok.Lattice ((<:), Lattice)
import Toktok.Sandhi 
import Toktok.Stack
import Toktok.Trie
import qualified Toktok.Stack as Stack

data Transducer 
   = Trans Bool                  --  Acceptance
           (Map Char Transducer) -- Deterministic part
           [Sandhi]              -- Non deterministic part

-- | Build a transducer from a trie and a list of sandhis...
mkTransducer :: Trie -> [Sandhi] -> Transducer
mkTransducer t sandhis = case mkTransducer' t sandhis "" of
                           (t,Stack []) -> t
                           _      -> error "Non empty stack"

mkTransducer' :: Trie -> [Sandhi] -> String -> (Transducer, Stack Sandhi)
mkTransducer' (Trie b trieMap) sandhis pref
   = (Trans b newMap (Stack.head oldStack), newStack)
   where intermediateMap 
            = Map.mapWithKey (\ k t -> mkTransducer' t sandhis (k:pref)) trieMap
         newMap = fmap fst intermediateMap
         oldStack = mconcat $ map snd $ Map.elems intermediateMap
         newStack = merge (Stack.pop oldStack) createStack
         -- Sandhi are applied only if we are at the end of a word
         goodSandhis = if b 
                        then filter (\(Sandhi u _ _) -> u `isPrefixOf` pref) sandhis
                        else []
         sandhiToStack s@(Sandhi u _ _) = Stack.singleton (length u) s
         createStack = mconcat $ map sandhiToStack goodSandhis

-- | In this algorithm, we segment the input in the folowing way
-- input = ¬pref ++ suf 
-- or input = ¬pref ++ c ++ suf
-- where pref is the already processed part.
applyTransducer :: Transducer -> String -> Lattice String
applyTransducer rootT = apply' rootT []
   where -- first, if we have consumed all the input
         apply' (Trans True  _ _) pref [] = [[reverse pref]]
         apply' (Trans False _ _) pref [] = []
         -- then, if the state is final
         apply' (Trans True  trie sandhis) pref suf
            = (reverse pref <: apply' rootT "" suf)
           ++ continueWithTrie    trie    pref suf
           ++ continueWithSandhis sandhis pref suf
         -- then if the state is not final...
         apply' (Trans False trie sandhis) pref suf
            = continueWithTrie    trie    pref suf
           ++ continueWithSandhis sandhis pref suf
         -- continue processing using (deterministic) trie
         continueWithTrie trieMap pref (c:suf)
            =  case Map.lookup c trieMap of
                    Nothing -> []
                    Just t' -> apply' t' (c:pref) suf
           ++ if isUpper c
               then case Map.lookup (toLower c) trieMap of
                         Nothing -> []
                         Just t' -> apply' t' (toLower c:pref) suf
               else []
         -- continue processing using sandhis
         continueWithSandhis [] _ _ = []      -- processed all sandhis
         continueWithSandhis sandhis pref suf
            = concatMap (\ s -> applySandhi s pref suf) sandhis
         applySandhi (Sandhi u v w) pref suf | w `isPrefixOf` suf
            = (reverse $ u ++ pref) <: (apply' (access v rootT) (reverse v) suf')
            where suf' = drop (length w) suf


-- | Access a state in a transducter, ignoring sandhis and intermediate
-- final states.
access :: String -> Transducer -> Transducer
access [] t = t
access (c:cs) (Trans _ map _) 
   = case Map.lookup c map of
      Nothing -> undefined
      Just t' -> access cs t'