content: -- Written by David J. Sankel (camior@gmail.com)
  --
  -- License: Public Domain
  --
  -- Illustrates an algorithm to that converts a regular expression that uses
  -- a difference operator (-) in to an equivalent one that does not.
  --
  -- Most ideas taken from http://home.chello.no/~mgrsby/sgmlintr/file0005.htm
  --
  
  import List
  
  data Regex a = Term a |
                 Lambda | -- This is the 0-length string
                 Phi |    -- Recognizes no strings ( 0 )
                 Rep (Regex a) |  -- Kleen Star (*)
                 Or (Regex a) (Regex a) | -- Or (+)
                 Sub (Regex a) (Regex a) | -- Regex Subtraction (-)
                 Seq (Regex a) (Regex a) -- Sequence (ab)
    deriving (Eq,Show)
  
  -- Character set notation [asdf]
  charset s = foldr Or Phi (map Term s)
  -- Convenient seq notation "asdf"
  string s = foldr Seq Lambda (map Term s)
  
  -- Simple function used below
  removeFirst p []  = []
  removeFirst p (a:as) | p a = as
                       | otherwise = a:(removeFirst p as)
  
  -- Takes a Regex and returns it without Subs.
  removeMinuses (Term a) = Term a
  removeMinuses Lambda = Lambda
  removeMinuses Phi = Phi
  removeMinuses (Rep a)= Rep a
  removeMinuses (Or a b)= (Or a b)
  removeMinuses (Seq a b)= (Seq a b)
  removeMinuses e@(Sub a b) =
   let
     symbs = symbols e
     -- all (symbol,derivative) pairs
     derivatives = [(s,simplify $ derivative s e) | s <- symbs ]
     -- The delta function applied
     deltae = delta e
     -- Whether or not a (symbol,derivative)'s derivitive component is
     -- equal to our original formula
     loopCondition = (\(a,b) -> b == (simplify e))
     -- Maybe a (symbol,derivative) pair where the derivative is the same as our
     -- original expression
     loopedDerivative = find loopCondition derivatives
     -- all (symbol,derivative) pairs except for loopedDerivative
     derivativesMinusLooped = removeFirst loopCondition derivatives
     -- To understand the following: draw out a tree on a piece of paper.
     -- We are invoking the identity: R = (\Sigma_a aDaR) + \delta R.
     -- The loop condition recalls that if DaR = R then
     --   R = aDaR + stuff -> R = aR + stuff -> R = a*(stuff)
     result = case loopedDerivative of
       Nothing -> Or (foldr Or Phi [ (Seq (Term sym) (removeMinuses reg)) | (sym,reg) <- derivatives ]) deltae
       Just (sym,_) -> (Seq (Rep (Term sym))
                            (Or (foldr Or Phi [ (Seq (Term sym) (removeMinuses reg)) | (sym,reg) <- derivativesMinusLooped ]) deltae ) )
   in
     simplify result
  
  -- Takes a Regex and returns an equivalent one somewhat simplified.
  simplify (Term a) = (Term a)
  simplify Lambda = Lambda
  simplify Phi = Phi
  simplify (Rep a) = let a_s = simplify a
                     in case a_s of
                          Lambda -> Lambda
                          Phi -> Lambda
                          _ -> (Rep a_s)
  simplify (Or a b) = let a_s = simplify a
                          b_s = simplify b
                      in case (a_s,b_s) of
                           (_,Phi)-> a_s
                           (Phi,_) -> b_s
                           (Lambda,Lambda) -> Lambda
                           (_,Lambda) | delta a_s == Lambda -> a_s
                                      | otherwise -> (Or a_s b_s)
                           (Lambda,_) | delta b_s == Lambda -> b_s
                                      | otherwise -> (Or a_s b_s)
                           _ -> (Or a_s b_s)
  simplify (Seq a b) = let a_s = simplify a
                           b_s = simplify b
                       in case (a_s,b_s) of
                            (_,Lambda)-> a_s
                            (Lambda,_) -> b_s
                            (_,Phi)-> Phi
                            (Phi,_) -> Phi
                            _ -> (Seq a_s b_s)
  simplify (Sub a b) = let a_s = simplify a
                           b_s = simplify b
                       in case (a_s,b_s) of
                            (Lambda,Lambda) -> Phi
                            (_,Lambda) | delta a_s == Phi -> a_s
                                       | otherwise -> (Sub a_s b_s)
                            (Lambda,_) | delta b_s == Phi -> Lambda
                                       | otherwise -> Phi
                            (Phi,_) -> Phi
                            (_,Phi) -> a_s
                            _ -> (Sub a_s b_s)
  
  -- Special Regex delta function.
  -- See http://home.chello.no/~mgrsby/sgmlintr/file0004.htm
  delta :: (Eq a) => (Regex a) -> (Regex a)
  delta (Term a) = Phi
  delta (Lambda) = Lambda
  delta (Phi) = Phi
  delta (Or a b) | ((delta a) == Phi) &&
                   ((delta b) == Phi) = Phi
                 | otherwise = Lambda
  delta (Sub a b) | ((delta a) == Lambda) &&
                    ((delta b) == Phi) = Lambda
                  | otherwise = Phi
  delta (Seq a b) | ((delta a) == Lambda) &&
                    ((delta b) == Lambda) = Lambda
                  | otherwise = Phi
  delta (Rep _) = Lambda
  
  -- Special Regex derivative function.
  -- See http://home.chello.no/~mgrsby/sgmlintr/file0004.htm
  derivative :: (Eq a) => a -> Regex a -> Regex a
  derivative a (Term b) | a == b = Lambda
                        | otherwise = Phi
  derivative a Lambda = Phi
  derivative a Phi = Phi
  derivative a (Or b c) = Or (derivative a b) (derivative a c)
  derivative a (Sub b c) = Sub (derivative a b) (derivative a c)
  derivative a (Seq b c) = let dab = (derivative a b)
                               dac = (derivative a c)
                           in Or (Seq dab c)
                                 (Seq (delta b) dac)
  derivative a (Rep b) = Seq (derivative a b) (Rep b)
  
  -- The symbols that a regex is over
  symbols (Term a) = [a]
  symbols (Rep a) = symbols a
  symbols (Or a b) = nub $ symbols a ++ symbols b
  symbols (Sub a b) = nub $ symbols a ++ symbols b
  symbols (Seq a b) = nub $ symbols a ++ symbols b
  symbols _ = []
  
  -- Shows a Regex in compact form. For example: (a+b+c)d*
  compactShow :: Regex Char -> String
  compactShow (Term a) = [a]
  compactShow Lambda = "\\"
  compactShow Phi = "0"
  compactShow (Rep (Term a)) = a:"*"
  compactShow (Rep a) = "(" ++ (compactShow a) ++ ")*"
  compactShow (Sub a b ) = (compactShow a) ++ "-" ++ (compactShow b)
  compactShow (Or (Term a) (Term b) ) = [a] ++ "+" ++ [b]
  compactShow (Or (Term a) b@(Or _ _) ) = [a] ++ "+" ++ (compactShow b)
  compactShow (Or a@(Or _ _) (Term b) ) = (compactShow a) ++ "+" ++ [b]
  compactShow (Or a@(Or _ _) b@(Or _ _) ) = (compactShow a) ++ "+" ++ (compactShow b)
  compactShow (Or a b@(Or _ _) ) = "(" ++ (compactShow a) ++ ")+" ++ (compactShow b)
  compactShow (Or a b ) = "(" ++ (compactShow a) ++ ")+(" ++ (compactShow b) ++ ")"
  compactShow (Seq (Term a) (Term b) ) = [a] ++ [b]
  compactShow (Seq (Term a) b@(Seq _ _) ) = [a] ++ (compactShow b)
  compactShow (Seq (Term a) b@(Rep _) ) = [a] ++ (compactShow b)
  compactShow (Seq a@(Seq _ _) b@(Seq _ _) ) = (compactShow a) ++ (compactShow b)
  compactShow (Seq a b ) = "(" ++ (compactShow a) ++ ")" ++ "(" ++ (compactShow b) ++ ")"
  
  -- Example that requires loop detection. Taken From:
  --  http://home.chello.no/~mgrsby/sgmlintr/file0005.htm
  -- (a+b)* - aa*
  test = Sub (Rep (Or (Term 'a') (Term 'b') )) (Seq (Term 'a') (Rep (Term 'a')) )
  -- a-b
  test2 = Sub (Term 'a') (Term 'b')
  -- (a+b) - b
  test3 = Sub (Or (Term 'a') (Term 'b')) (Term 'b')
  -- (a+b)c - b
  test4 = Sub (Seq (Or (Term 'a') (Term 'b')) (Term 'c')) (Term 'b')
  -- (b*(a+b)c) - b
  test5 = Sub (Seq (Rep (Term 'b'))(Seq (Or (Term 'a') (Term 'b')) (Term 'c'))) (Term 'b')
  -- Some normal looking string regexes.
  test6 = Sub (Rep (charset "abcdefghijklmnopqrstuvwxyz")) (string "hello")
  test7 = Sub (Rep (charset "abcdef")) (string "fad")
  test8 = Sub (Rep (charset "abcdef")) (string "db")
  -- Simplified Case of above
  test9 = Sub (Rep (charset "abcdef")) (string "b")
  
  