{- |
Left-biased finite transducers
-}
module FST.LBFT (
  module FST.Transducer,

  -- * Types
  LBFT (..),

  -- * Compile functions
  compileToLBFT,
  compileToTransducer
  ) where

import Data.List (delete,nub,(\\))
import Control.Monad.State 

import FST.EpsilonFreeT
import FST.RRegTypes
import FST.Transducer
import FST.Utils (merge,remove)
import qualified FST.AutomatonInterface as A

-- | Data type for a LBFT (left-biased finite transducer)
data LBFT a = LBFT {
                     trans   :: TTransitionTable a,
                     initS   :: StateTy,
                     finalS  :: [StateTy],
                     alpha   :: Sigma a,
                     lastS   :: StateTy
                   }

-- | LBFT functions
instance TransducerFunctions LBFT where
  states                  = (map fst).trans
  isFinal t s             = elem s (finals t)
  initials t              = [initS t]
  finals                  = finalS
  transitionTable         = trans
  transitionList t s      = case (lookup s (trans t)) of
                              Just xs -> xs
                              _       -> []
  transitionsU t (s,a)    = map (\((_,c),s1) -> (c,s1)) $
                            filter (\((b,_),_) -> a == b) $ transitionList t s
  transitionsD t (s,a)    = map (\((c,_),s1) -> (c,s1)) $
                            filter (\((_,b),_) -> a == b) $ transitionList t s
  lastState               = lastS
  firstState              = minimum.states
  alphabet                = alpha

-- | Does the LBFT accept epsilon?
acceptEpsilon :: LBFT a -> Bool
acceptEpsilon lbft = isFinal lbft (initialLBFT lbft)

-- | Get the initial state of a LBFT
initialLBFT :: LBFT a -> StateTy
initialLBFT = initS

-- | Compile a regular relation to a LBFT
compileToLBFT :: Ord a => RReg a -> Sigma a -> LBFT a
compileToLBFT reg sigma = evalState (build reg (nub (sigma++symbols reg))) 0

-- | Compile a regular relation to an minimal, useful and
-- deterministic transducer, using the LBFT algorithm while building.
compileToTransducer :: Ord a => RReg a -> Sigma a -> Transducer a
compileToTransducer reg sigma = encode $ compileToLBFT reg sigma

fetchState :: State StateTy StateTy
fetchState = do
  state <- get
  put (state + 1)
  return state

-- | Build a LBFT from a regular relation
build :: Ord a => RReg a -> Sigma a -> State StateTy (LBFT a)
build (EmptyR) sigma = do
  s <- fetchState
  return $ LBFT {
    trans  = [(s, [])],
    initS  = s,
    finalS = [],
    alpha  = sigma,
    lastS  = s
    }

build (Relation a b) sigma = do
  s1 <- fetchState
  s2 <- fetchState
  return $ LBFT {
    trans  = [(s1, [((a, b), s2)]), (s2, [])],
    initS  = s1,
    finalS = [s2],
    alpha  = sigma,
    lastS  = s2
    }

build (Identity r1) sigma = do
  s <- fetchState
  let auto   = A.compileNFA r1 sigma s
      nTrans = [(s1, map (\(a,s2) -> ((S a, S a), s2)) (A.transitionList auto s1))
               | s1 <- A.states auto ]
  put (A.lastState auto + 1)
  return $ LBFT {
    trans  = nTrans,
    initS  = head (A.initials auto),
    finalS = A.finals auto,
    alpha  = sigma,
    lastS  = A.lastState auto
    }

build (ProductR r1 r2) sigma = do
  lbft1 <- build r1 sigma
  lbft2 <- build r2 sigma
  s <- fetchState
  let transUnion  = (remove (initialLBFT lbft1) (trans lbft1)) ++
                    (remove (initialLBFT lbft2) (trans lbft2))
      transConc   = let t = (transitionList lbft2 (initialLBFT lbft2))
                    in [ (f,t) | f <- finals lbft1 ]
      transInit   = [(s, transitionList lbft1 (initialLBFT lbft1) ++
                         listEps lbft1 (transitionList lbft2 (initialLBFT lbft2)))]
      fs  = finals lbft2 ++ listEps lbft2 (finals lbft1) ++
            [ s | acceptEpsilon lbft1 && acceptEpsilon lbft2 ]
  return $ LBFT {
    trans  = transInit ++ merge transConc transUnion,
    finalS = fs \\ [(initialLBFT lbft1),(initialLBFT lbft2)],
    alpha  = sigma,
    initS  = s,
    lastS   = s
    }
  
build (UnionR r1 r2) sigma = do
  lbft1 <- build r1 sigma
  lbft2 <- build r2 sigma
  s <- fetchState
  let transUnion  = (remove (initialLBFT lbft1) (trans lbft1)) ++
                    (remove (initialLBFT lbft2) (trans lbft2))
      transInit   = [(s, transitionList lbft1 (initialLBFT lbft1) ++
                         transitionList lbft2 (initialLBFT lbft2))]
      fs          = finals lbft1 ++ finals lbft2 ++
                    [ s | acceptEpsilon lbft1 || acceptEpsilon lbft2 ]
  return $ LBFT {
    trans  = transInit ++ transUnion,
    finalS = fs \\ [(initialLBFT lbft1), (initialLBFT lbft2)],
    alpha  = sigma,
    initS  = s,
    lastS  = s
    }

build (StarR r1) sigma = do
  lbft1 <- build r1 sigma
  s <- fetchState
  let transUnion  = remove (initialLBFT lbft1) (trans lbft1)
      transLoop   = let t = transitionList lbft1 (initialLBFT lbft1)
                    in (s,t) : [(f,t) | f <- finals lbft1]
  return $ LBFT {
    trans   = merge transLoop transUnion,
    finalS  = s:(delete (initialLBFT lbft1) (finals lbft1)),
    alpha   = sigma,
    initS   = s,
    lastS   = s
    }

build (Cross r1 r2) sigma = do
  s <- fetchState
  let auto1 = A.compileNFA r1 sigma s
      auto2 = A.compileNFA r2 sigma s
      (trTable,fs) = cross auto1 auto2
                     ([],[(A.initial auto1,A.initial auto2)]) ([],[])
      lbft = decode $ rename trTable sigma
             [(A.initial auto1,A.initial auto2)] fs s
  put (lastState lbft + 1)
  return lbft
  where cross _ _ (_,[]) result = result
        cross auto1 auto2 (done,((s1,s2):undone)) (tr,fs) =
         let tl = combine auto1 auto2 (A.transitionList auto1 s1)
                                      (A.transitionList auto2 s2) (s1,s2)
             nSts = (map snd tl) \\ ((s1,s2):done)
          in cross auto1 auto2 ((s1,s2):done,nSts++undone) (((s1,s2),tl):tr,
               if (A.isFinal auto1 s1 && A.isFinal auto2 s2) then
                                ((s1,s2):fs) else fs)
        combine _ _ [] [] _       = []
        combine _ _ xs [] (_,s2)  = [((S a,Eps),(s1,s2)) | (a,s1) <- xs]
        combine _ _ [] ys (s1,_)  = [((Eps,S b),(s1,s2)) | (b,s2) <- ys]
        combine auto1 auto2 xs ys (s1,s2)
         = [((S a, S b), (s3,s4)) | (a,s3) <- xs, (b,s4) <- ys] ++
           (if (A.isFinal auto1 s1) then [((Eps,S b),(s1,s4)) | (b,s4) <- ys]
             else []) ++
           (if (A.isFinal auto2 s2) then [((S a,Eps),(s3,s2)) | (a,s3) <- xs]
             else [])

build (Comp r1 r2) sigma = do
  lbft1 <- build r1 sigma
  lbft2 <- build r2 sigma
  let minS1 = firstState lbft1
      minS2 = firstState lbft2
      name (s1,s2) = (lastState lbft2 - minS2 +1) *
                     (s1 - minS1) + s2 - minS2 + minS1
      nS = name (lastState lbft1,lastState lbft2) +1
      transInit = (nS,[ ((a, d), name (s1,s2))
                      | ((a, b), s1) <- ((Eps, Eps),initialLBFT lbft1):transitionList lbft1 (initialLBFT lbft1)
                      , ((c, d), s2) <- ((Eps,Eps),initialLBFT lbft2):transitionList lbft2 (initialLBFT lbft2)
                      , ((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) <- trans lbft1
                   , (s2,tl2) <- trans lbft2
                   , s1 /= initialLBFT lbft1 || s2 /= initialLBFT lbft2]
      transUnion = transInit : transTable
      fs  = [ nS | acceptEpsilon lbft1 && acceptEpsilon lbft2 ]
            ++ 
            [ name (f1,f2) | f1 <- finals lbft1, f2 <- finals lbft2 ]
  put (nS + 1)
  return $ decode $ epsilonfree $ encode $
    LBFT {
      trans  = merge [ (s, []) | s <- fs ] transUnion,
      finalS = fs,
      alpha  = sigma,
      initS  = nS,
      lastS   = nS
      }

instance TConvertable LBFT where
  encode lbft = rename (trans lbft) (alphabet lbft) (initials lbft)
                       (finals lbft) (firstState lbft)
  decode t     = LBFT {
    trans  = transitionTable t,
    initS  = head (initials t),
    finalS = finals t,
    alpha  = alphabet t,
    lastS  = lastState t
    }

instance (Eq a,Show a) => Show (LBFT a) where
  show t = unlines [
    "Transitions:"
    , aux (trans t)
    , "Number of States   => "   ++ show (length (trans t))
    , "Initial            => "   ++ show (initialLBFT t)
    , "Finals             => "   ++ show (finals t)
    ] where
    aux xs = unlines [ show s ++ " => " ++ show tl | (s, tl) <- xs ]

-- | If the LBFT accepts epsilon, return second argument
listEps :: LBFT a -> [b] -> [b]
listEps lbft xs
 | acceptEpsilon lbft = xs
 | otherwise          = []