```{-
**************************************************************
* 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 ++ "]"
```