fst-0.10.0.0: FST/RRegTypes.hs

{- |
Functions for constructing a simplified regular relation.
-}
module FST.RRegTypes ( 
  module FST.RegTypes,
  -- * Types
  RReg(..),
  -- * Combinators
  (<*>), (<.>),
  -- * Constructors
  idR, r,
  ) where

import FST.RegTypes
import FST.TransducerTypes (Symbol(..))

import Data.List (nub)

-- | Datatype for a regular relations
data RReg a =
    Cross    (Reg a)    (Reg a)        -- ^ Cross product     
  | Comp     (RReg a)   (RReg a)       -- ^ Composition       
  | ProductR (RReg a)   (RReg a)       -- ^ Concatenation     
  | UnionR   (RReg a)   (RReg a)       -- ^ Union             
  | StarR    (RReg a)                  -- ^ Kleene star       
  | Identity (Reg a)                   -- ^ Identity relation 
  | Relation (Symbol a) (Symbol a)     -- ^ (a:b)             
  | EmptyR                             -- ^ Empty language    
  deriving (Eq)

instance Eq a => Combinators (RReg a) where
  -- Union
  EmptyR <|> r2     = r2                                    -- [ r1 | [] ] = r1
  r1     <|> EmptyR = r1                                    -- [ [] | r2 ] = r2
  r1     <|> r2     = if r1 == r2 then r1 else UnionR r1 r2 -- [ r1 | r1 ] = r1

  -- Concatenation
  EmptyR  |> _      = EmptyR  -- [ [] r2 ] = []
  _       |> EmptyR = EmptyR  -- [ r1 [] ] = []
  r1      |> r2     = ProductR r1 r2

  -- Kleene's star
  star (StarR r1)   = star r1 -- [ r1* ]* = r1*
  star r1           = StarR r1

  -- Kleene's plus
  plus r1           = r1 |> star r1
  empty             = EmptyR

infixl 2 <*>
infixl 1 <.>

-- | Cross product operator
(<*>) :: Eq a => Reg a -> Reg a -> RReg a
(<*>) = Cross

-- | Composition operator
(<.>) :: Eq a => RReg a -> RReg a -> RReg a
(<.>) = Comp

-- | Identity relation
idR :: Eq a => Reg a -> RReg a
idR = Identity

-- | Relation
r :: Eq a => a -> a -> RReg a
r a b = Relation (S a) (S b)

instance Symbols RReg where
  symbols (Cross r1 r2)    = nub $ symbols r1 ++ symbols r2
  symbols (Comp r1 r2)     = nub $ symbols r1 ++ symbols r2
  symbols (ProductR r1 r2) = nub $ symbols r1 ++ symbols r2
  symbols (UnionR r1 r2)   = nub $ symbols r1 ++ symbols r2
  symbols (StarR r1)       = symbols r1
  symbols (Identity r1)    = symbols r1
  symbols (Relation a b)   = let sym (S c) = [c]
                                 sym  _    = []
                             in nub $ sym a ++ sym b
  symbols _                = []

instance Show a => Show (RReg a) where
 show (Cross r1 r2)    = "[ " ++ show r1 ++ " .x. " ++ show r2 ++ " ]"
 show (Comp r1 r2)     = "[ " ++ show r1 ++ " .o. " ++ show r2 ++ " ]"
 show (UnionR r1 r2)   = "[ " ++ show r1 ++ " | " ++ show r2 ++ " ]"
 show (ProductR r1 r2) = "[ " ++ show r1 ++ " " ++ show r2 ++ " ]"
 show (Identity r)     = show r
 show (StarR r)        = "[ " ++ show r ++ " ]*"
 show (Relation a b)   = "[ " ++ show a ++":"++show b ++" ]"
 show EmptyR           = "[]"