module FST.RegTypes (
Combinators (
(<|>), (|>), star, plus, empty
),
Symbols (symbols),
Reg(..),
(<&>), (<->),
complement, reversal, allFree,
s, eps, allS,
allToSymbols,
acceptEps,
) where
import Data.List (nub)
data Reg a =
Empty
| Epsilon
| All
| Symbol a
| Reg a :|: Reg a
| Reg a :.: Reg a
| Reg a :&: Reg a
| Complement (Reg a)
| Star (Reg a)
deriving (Eq)
infixl 4 <|>
infixl 5 |>
infixl 3 <&>
infixl 3 <->
class Combinators a where
(<|>) :: a -> a -> a
(|>) :: a -> a -> a
star :: a -> a
plus :: a -> a
empty :: a
instance Eq a => Combinators (Reg a) where
Empty <|> b = b
a <|> Empty = a
_ <|> Star All = Star All
Star All <|> _ = Star All
a@(a1 :.: a2) <|> b@(b1 :.: b2)
| a == b = a
| a1 == b1 = a1 |> (a2 <|> b2)
| a2 == b2 = (a1 <|> b1) |> a2
| otherwise = a :|: b
a <|> b = if a == b then a else a :|: b
Empty |> _ = empty
_ |> Empty = empty
Epsilon |> b = b
a |> Epsilon = a
a |> b = a :.: b
star (Star a) = star a
star (Epsilon) = eps
star (Empty) = eps
star a = Star a
plus a = a |> star a
empty = Empty
(<&>) :: Eq a => Reg a -> Reg a -> Reg a
_ <&> Empty = Empty
Empty <&> _ = Empty
Star All <&> a = a
a <&> Star All = a
a <&> b
| a == b = a
| otherwise = a :&: b
(<->) :: Eq a => Reg a -> Reg a -> Reg a
Empty <-> _ = empty
a <-> Empty = a
a <-> b
| a == b = empty
| 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
complement (Star All) = empty
complement (Complement a) = a
complement a = Complement a
allToSymbols :: Eq a => [a] -> Reg a
allToSymbols [] = empty
allToSymbols ys = foldr1 (:|:) (map s 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 :: 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 :: 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
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 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 ++ "]"