module RegEx where
import List (inits, tails, nub)

--------------------
-- Definition and simulation of DFAs
--------------------

--------------------
-- Ver. 1: using numbers and characters for states and symbols
-- We need to keep the subsets corresponding to actual definition

data (Eq s, Eq a) =>        -- given s and a are symbols, DFA is:
  DFA s a = DFA ([s],       -- * set of states
                 [a],       -- * input alphabet
                  s->a->s,  -- * transition function
                  s,        -- * initial state
                 [s])       -- * final states

checkDFA (DFA (qs, sig, d, q, f))
  = all (`elem` qs) 
        (q : f ++ [ d q a | q <- qs, a <- sig ])

runDFA m@(DFA (qs, sig, d, q, f)) str 
  = if checkDFA m then foldl d q str `elem` f 
                  else error "bad DFA"

--------------------
-- Ver. 2: using enumerated types, things are much simpler

rundfa d q f str = foldl d q str `elem` f

data Alpha = A | B      deriving (Eq,Show)
data State = S | T | U  deriving (Eq,Show)

d S A = S
d S B = T
d T A = U
d T B = T
d U A = T
d U B = U


--------------------
-- Testing for DFAs (NB: initial & final states are baked in here)

test = rundfa d S [S,T] . map r
       where r 'A' = A; r 'B' = B


--------------------
-- Regular expressions

data RE = Null | Epsi | Lit Char | Alt RE RE | Cat RE RE | Star RE

foldre n e l a c s  Null     = n
foldre n e l a c s  Epsi     = e
foldre n e l a c s (Lit x)   = l x
foldre n e l a c s (Alt r t) = a (foldre n e l a c s r) (foldre n e l a c s t)
foldre n e l a c s (Cat r t) = c (foldre n e l a c s r) (foldre n e l a c s t)
foldre n e l a c s (Star r)  = s (foldre n e l a c s r)

lst = foldre [] [""] sing alt (dzw (++)) star

prt = foldre "0" "e" (:[]) (inf "|") (inf "") (++"*")

inf o l r = concat ["(",l,o,r,")"]

-- parameter functions for list semantics (see also dzw below)

sing c = [[c]]

alt [] bs = bs
alt (a:as) bs = a : alt bs as

star r = "" : dzw (++) r (star r)


-- long-winded recursive version: compare to folded lst above

list  Null   = []
list  Epsi   = [""]
list (Lit a) = [[a]]
-- list (Alt r s) = list r ++ list s		-- NB: this fails if R is infinite
list (Alt r s) = alt (list r) (list s)
list (Cat r s) = dzw (++) (list r) (list s)
list (Star r)  = star (list r)

-- attempt at recursive version of "direct-to-predicate" semantics

dtp  Null     = const False
dtp  Epsi     = (== "")
dtp (Lit a)   = (==[a])
dtp (Alt r t) = dtp r ||| dtp t
dtp (Cat r t) = any (dtp r &^& dtp t) . splits
dtp (Star r)  = null ||| dtp (Cat r (Star r))	-- this tends to loop ...

(|||) p q x = p x || q x
(&^&) p q (a,b) = p a && q b

splits xs = zip (inits xs) (tails xs)


--------------------
-- Testing for REs

t1 = Star (Alt (Lit 'a') (Cat (Lit 'a') (Lit 'b')))
t2 = Cat t1 (Star (Lit 'c'))
t3 = Star (Cat (Star t1) (Star t2))

try = take 30 . nub . lst

--------------------
-- dzw (diagonal zipWith), based on Ross Paterson's (//)

-- why is the argument flip on dzw necessary??

dzw f ys xs = concat ([zipWith (flip f) xs  (reverse ys') | ys' <- inits ys] ++
                      [zipWith (flip f) xs' (reverse ys)  | xs' <- tails (tail xs)])

(//) :: [a] -> [b] -> [(a,b)]
xs // ys = concat ([zip xs  (reverse ys') | ys' <- inits ys] ++
                   [zip xs' (reverse ys)  | xs' <- tails (tail xs)])


--------------------
-- Mark Jones' version of diag: merge lists of (even infinite) lists fairly

diag  = concat . foldr skew [] . map (map (:[]))
        where skew []     ys = ys
              skew (x:xs) ys = x : lzw (++) xs ys

lzw f (x:xs) (y:ys) = f x y : lzw f xs ys
lzw f []     ys     = ys
lzw f xs     []     = xs