fst-0.9: FST/RegTypes.hs
{-
**************************************************************
* Filename : RegTypes.hs *
* Author : Markus Forsberg *
* d97forma@dtek.chalmers.se *
* Last Modified : 5 July, 2001 *
* Lines : 219 *
**************************************************************
-}
module FST.RegTypes ( Reg(..), -- data type for the regular expression
Combinators, -- Type class for Combinators.
(<|>), -- Union combinator
(|>), -- Concatenation combinator
(<&>), -- Intersection combinator
(<->), -- Minus combinator
s, -- Symbol
eps, -- Epsilon
empty, -- Empty
complement, -- Complement
star, -- Star
plus, -- Plus
allS, -- All Symbol
allToSymbols, -- transform the 'all' symbol to union over
-- alphabet.
allFree, -- free a regular expression from 'all'
-- symbols.
reversal, -- reverse a regular expression.
acceptEps, -- Does the regular expression accept epsilon?
Symbols, -- Type class for Symbols.
symbols -- Collect the symbols in a
-- regular expression.
) where
import Data.List (nub)
{- **********************************************************
* Data type for a regular expression. *
**********************************************************
-}
data Reg a = Empty | -- []
Epsilon | -- 0
All | -- ?
Symbol a | -- a
Reg a :|: Reg a | -- [ r1 | r2 ]
Reg a :.: Reg a | -- [ r1 r2 ]
Reg a :&: Reg a | -- [ r1 & r2 ]
Complement (Reg a) | -- ~[ r1 ]
Star (Reg a) -- [ r2 ]*
deriving (Eq)
{- **********************************************************
* Combinators. *
* The regular expressions are simplified while combined. *
**********************************************************
-}
infixl 5 |> -- Concatenation
infixl 4 <|> -- Union
infixl 3 <&> -- Intersection
infixl 3 <-> -- Set minus
class Combinators a where
(<|>) :: a -> a -> a -- Union
(|>) :: a -> a -> a -- Concatenation
star :: a -> a -- Kleene's star
plus :: a -> a -- Kleene's plus
empty :: a
instance Eq a => Combinators (Reg a) where
Empty <|> b = b -- [ [] | r1 ] = r1
a <|> Empty = a -- [ r1 | [] ] = r1
_ <|> (Star All) = Star All
(Star All) <|> _ = Star All
a1@(a :.: b) <|> a2@(c :.: d)
| a1 == a2 = a1
| a == c = a |> (b <|> d)
| b == d = (a <|> c) |> b
| otherwise = a1 :|: a2
a <|> b
| a == b = a -- [ r1 | r1 ] = r1
| otherwise = a :|: b
Empty |> _ = empty -- [ [] r1 ] = []
_ |> Empty = empty -- [ r1 [] ] = []
Epsilon |> b = b -- [ 0 r1 ] = r1
a |> Epsilon = a -- [ r1 0 ] = r1
a |> b = a :.: b
star (Star a) = star a -- [r1]** = [r1]*
star (Epsilon) = eps -- [0]* = 0
star (Empty) = eps -- [ [] ]* = 0
star a = Star a
plus a = a |> star a
empty = Empty
{- Intersection -}
(<&>) :: Eq a => Reg a -> Reg a -> Reg a
_ <&> Empty = Empty -- [ r1 & [] ] = []
Empty <&> _ = Empty -- [ [] & r1 ] = []
(Star All) <&> a = a
a <&> (Star All) = a
a <&> b
| a == b = a -- [ r1 & r1 ] = r1
| otherwise = a :&: b
{- Minus. Definition A - B = A & ~B -}
(<->) :: Eq a => Reg a -> Reg a -> Reg a
Empty <-> _ = empty -- [ [] - r1 ] = []
a <-> Empty = a -- [ r1 - [] ] = r1
a <-> b
| a == b = empty -- [ r1 - r1 ] = []
| otherwise = a <&> (complement b)
s :: a -> Reg a
s a = Symbol a
eps :: Reg a
eps = Epsilon
allS :: Reg a
allS = All
complement :: Eq a => Reg a -> Reg a
complement Empty = star allS -- ~[ [] ] = ?*
complement Epsilon = plus allS -- ~[ 0 ] = [? ?*]
complement (Star All) = empty
complement (Complement a) = a
complement a = Complement a
{- *******************************************************************
* allToSymbols: ? -> [a|..] with respect to an alphabet [a] *
* allFreeReg: Construct a ?-free regular expression with respect *
* to an alphabet [a] *
*******************************************************************
-}
allToSymbols :: Eq a => [a] -> Reg a
allToSymbols sigma = case sigma of
[] -> empty
ys -> foldr1 (:|:) [s a| a <- ys]
allFree :: Eq a => Reg a -> [a] -> Reg a
allFree (a :|: b) sigma = (allFree a sigma) :|: (allFree b sigma)
allFree (a :.: b) sigma = (allFree a sigma) :.: (allFree b sigma)
allFree (a :&: b) sigma = (allFree a sigma) :&: (allFree b sigma)
allFree (Complement a) sigma = Complement (allFree a sigma)
allFree (Star a) sigma = Star (allFree a sigma)
allFree (All) sigma = allToSymbols sigma
allFree r _ = r
{- **********************************************************
* reversal: reverse the language denoted by the regular *
* expression. *
**********************************************************
-}
reversal :: Eq a => Reg a -> Reg a
reversal (a :|: b) = (reversal a) :|: (reversal b)
reversal (a :.: b) = (reversal b) :.: (reversal a)
reversal (a :&: b) = (reversal a) :&: (reversal b)
reversal (Complement a) = Complement (reversal a)
reversal (Star a) = Star (reversal a)
reversal r = r
{- ***********************************************************
* acceptEps: Examines if a regular expression accepts *
* the empty string. *
***********************************************************
-}
acceptEps :: Eq a => Reg a -> Bool
acceptEps (Epsilon) = True
acceptEps (Star _) = True
acceptEps (a :|: b) = acceptEps a || acceptEps b
acceptEps (a :.: b) = acceptEps a && acceptEps b
acceptEps (a :&: b) = acceptEps a && acceptEps b
acceptEps (Complement a) = not (acceptEps a)
acceptEps _ = False
{- **********************************************************
* Symbols: type class for the collection of symbols in a *
* expression. *
**********************************************************
-}
class Symbols f where
symbols :: Eq a => f a -> [a]
instance Symbols Reg where
symbols (Symbol a) = [a]
symbols (a :.: b) = nub $ (symbols a) ++ (symbols b)
symbols (a :|: b) = nub $ (symbols a) ++ (symbols b)
symbols (a :&: b) = nub $ (symbols a) ++ (symbols b)
symbols (Complement a) = symbols a
symbols (Star a) = symbols a
symbols _ = []
{- **********************************************************
* Instance of Show (Reg a) *
**********************************************************
-}
instance Show a => Show (Reg a) where
show (Empty) = "[0 - 0]"
show (Epsilon) = "0"
show (Symbol a) = show a
show (All) = "?"
show (Complement a) = "~" ++ "[" ++ show a ++ "]"
show (Star a) = "[" ++ show a ++ "]* "
show (a :|: b) = "[" ++ show a ++ " | " ++ show b ++ "]"
show (a :.: b) = "[" ++ show a ++ " " ++ show b ++ "]"
show (a :&: b) = "[" ++ show a ++ " & " ++ show b ++ "]"