Fox.hs

module Fox where

-- http://blog.sigfpe.com/2007/01/foxs-ubiquitous-free-derivative-pt-2.html
--
import           Prelude                 hiding ( (<*>) )
import           Data.List

data RE a
  = Symbol a
  | Star (RE a)
  | Sum [RE a]
  | Prod [RE a]
  deriving (Eq, Show, Ord)

zero :: RE a
zero = Sum []
one :: RE a
one = Prod []

(<*>) :: RE a -> RE a -> RE a
a <*> b = Prod [a, b]
(<+>) :: RE a -> RE a -> RE a
a <+> b = Sum [a, b]

splits :: [a] -> [([a], [a])]
splits []       = []
splits (a : as) = ([], a : as) : map f (splits as) where f (x, y) = (a : x, y)

simplify :: Ord a => RE a -> RE a
simplify a = let b = simplify' a in if a == b then b else simplify b where
  simplify' (Prod [a])               = a
  simplify' (Prod a) | zero `elem` a = zero
  simplify' (Prod (a : b))           = case a of
    Prod x -> Prod $ x ++ map simplify b
    a      -> Prod $ filter (/= one) $ map simplify (a : b)

  simplify' (Sum [a    ]) = a
  simplify' (Sum (a : b)) = case a of
    Sum x -> Sum $ x ++ map simplify b
    a     -> Sum $ nub $ sort $ filter (/= zero) $ map simplify (a : b)

  simplify' (Star a) = Star (simplify a)
  simplify' a        = a


re :: [a] -> RE a
re x = Prod $ map Symbol x


acceptsEmpty :: RE a -> Bool
acceptsEmpty (Symbol _) = False
acceptsEmpty (Star   _) = True
acceptsEmpty (Sum    l) = any acceptsEmpty l
acceptsEmpty (Prod   l) = all acceptsEmpty l


mcbride :: Eq a1 => (RE a1 -> RE a2) -> (RE a1 -> RE a2) -> a1 -> RE a1 -> RE a2
mcbride _ _ a (Symbol a') = if a == a' then one else zero
mcbride c j a (Sum    p ) = Sum $ map (mcbride c j a) p
mcbride _ _ _ (Prod   []) = zero
mcbride c j a (Prod   x ) = Sum $ map f (splits x)
  where f (x, y : ys) = Prod $ map c x ++ [mcbride c j a y] ++ map j ys
mcbride c j a (Star p) = c (Star p) <*> mcbride c j a p <*> j (Star p)


delta :: RE a1 -> RE a2
delta p = if acceptsEmpty p then one else zero

leibniz, fox_l, fox_r, brzozowski_l :: (Ord a, Eq a) => a -> RE a -> RE a
leibniz a p = simplify $ mcbride id id a p
fox_l a p = simplify $ mcbride id (const (one)) a p
fox_r a p = simplify $ mcbride (const (one)) id a p
brzozowski_r :: Ord a => a -> RE a -> RE a
brzozowski_l a p = simplify $ mcbride delta id a p
brzozowski_r a p = simplify $ mcbride id delta a p

matches :: (Foldable t, Ord a) => RE a -> t a -> Bool
matches re s = acceptsEmpty (matches' re s)
  where matches' re as = foldl (flip brzozowski_l) re as


--
--
ex1 :: RE Char
ex1 = (re "abc") <+> (Star (re "b") <*> Symbol 'c')
test1, test2 :: [Bool]
test1 = map (matches ex1) ["abc", "bbc", "bbbbc", "abbbbc"]
test2 = map (matches (brzozowski_r 'c' ex1)) ["abc", "bbc", "ab", "bbbbb"]


ex3 :: RE Char
ex3 = re "abracad" <*> Star (re "a") <*> re "bra"
test3 :: [Bool]
test3 = map (matches ex3) ["abracadabra", "abracadaaaaabra"]

ex4 :: RE Char
ex4 = leibniz 'r' ex3
test4 :: [Bool]
test4 =
  map (matches ex4) ["abracadabra", "abacadabra", "abracaaaaadaba", "abacadaba"]

ex5 :: RE Char
ex5 =
  simplify
    $ fox_r '('
    $ fox_l ')'
    $ let digits = Star (Sum (map Symbol "0123456789"))
      in  re "x = (" <*> digits <*> re "+" <*> digits <*> re ");" <+> Star
            (re " ")
test5 :: [Bool]
test5 = map (matches ex5) ["1+2", "7-4"]