regexp.hs

import Control.Applicative ((<$>), (<*), (*>))
import Control.Monad (liftM2)

import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set, singleton, unions, empty)
import qualified Data.Set as Set
import Data.List (intercalate)
import qualified Data.List as List

import Text.Printf (printf)

data RegExp = REAlpha Char
              | REEmp | REEps | REAll
              | RECat RegExp RegExp
              | REOr RegExp RegExp | REStar RegExp
  deriving (Show, Eq, Ord)  

type State = String

type DFA = (Set State, Set Char, Map (State, Char) State, State, Set State)
-- respectively, (states, alphabet, transition, initial, finals)

type Monoid = (Set String, Map (String, String) String)

joinS :: Ord a => Set (Set a) -> Set a
joinS = unions . Set.toList

liftS  :: (Ord a, Ord b) => (a -> Set b) -> Set a -> Set b
liftS f xs = joinS $ Set.map f xs

liftS2 :: (Ord a, Ord b, Ord c) => (a -> b -> Set c) -> Set a -> Set b -> Set c
liftS2 f xs ys = Set.unions $ liftM2 f (Set.toList xs) (Set.toList ys)

cartProdS :: (Ord a, Ord b) => Set a -> Set b -> Set (a, b)
cartProdS s1 s2 = Set.fromList [(x, y) | x <- Set.toList s1, y <- Set.toList s2]

unMap :: Ord k => Map k a -> k -> a
unMap dic x =
    case Map.lookup x dic of
      Just v  -> v

accepts :: String -> DFA -> Bool
accepts [] (states, alpha, delta, x0, finals) = Set.member x0 finals
accepts (w:ws) m = accepts ws (states, alpha, delta, x', finals)
  where x' = unMap delta (x0, w)
        (states, alpha, delta, x0, finals) = m

priority :: RegExp -> Int
priority (REAlpha a) = 0
priority REEmp = 0
priority REEps = 0
priority REAll = 0
priority (REStar r)  = 1
priority (RECat r s) = 2
priority (REOr r s)  = 3

printRE' :: RegExp -> Int -> String
printRE' r n =
  if priority r >= n then printf "(%s)" s else s
    where s = printRE r

printRE :: RegExp -> String
printRE (REAlpha a) = show a
printRE REEmp = "{}"
printRE REEps = "e"
printRE REAll = "."
printRE (REStar r)  = printf "%s*" (printRE' r 2)
printRE (RECat r s) = printf "%s%s" (printRE' r 3) (printRE' s 2)
printRE (REOr r s)  = printf "%s|%s" (printRE' r 4) (printRE' s 3)

printREs :: Set RegExp -> String 
printREs rs = "{" ++ intercalate ", " (map printRE $ Set.toList rs) ++ "}"

hasEps :: RegExp -> Bool
hasEps (REAlpha a) = False
hasEps REEmp = False
hasEps REEps = True
hasEps REAll = True
hasEps (REStar r)  = True
hasEps (RECat r s) = hasEps r && hasEps s
hasEps (REOr r s)  = hasEps r || hasEps s

haveEps :: Set RegExp -> Bool
haveEps rs = any hasEps rs

diff :: Char -> RegExp -> Set RegExp
diff a (REAlpha b) =
  if a == b then singleton REEps else empty
diff a REEmp = empty
diff a REEps = empty
diff a REAll = singleton REAll
diff a (REStar r) =
  Set.map (`RECat` (REStar r)) $ diff a r
diff a (RECat r s) =
  if hasEps r then Set.union xs (diff a s) else xs
  where xs = Set.map (`RECat` s) $ diff a r
diff a (REOr r s) =
  Set.union (diff a r) (diff a s)

diffs :: Char -> Set RegExp -> Set RegExp
diffs a rs = liftS (diff a) rs

reToDFA' :: Set Char -> Set RegExp -> (Set State, Map (State, Char) State, Set State)
                     -> (Set State, Map (State, Char) State, Set State)
reToDFA' alpha rs (states, delta, finals) =
  if Set.member s states then (states, delta, finals) else (states2, delta2, finals2)
  where s = printREs rs
        states' = Set.insert s states
        finals' = if haveEps rs then Set.insert s finals else finals
        (states2, delta2, finals2) = foldr step (states', delta, finals') alpha
        step c (st,dt,fn) = (st1,dt1,fn1)
          where rs' = diffs c rs
                s'  = printREs rs'
                dt' = Map.insert (s, c) s' dt
                (st1, dt1, fn1) = reToDFA' alpha rs' (st, dt', fn)

reToDFA :: Set Char -> RegExp -> DFA
reToDFA alpha r = (states, alpha, delta, x0, finals)
  where (states, delta, finals) = reToDFA' alpha rs0 (Set.empty, Map.empty, Set.empty)
        rs0 = Set.singleton r
        x0  = printREs rs0

simplify :: DFA -> DFA
simplify (states, alpha, delta, x0, finals) = (states', alpha, delta', x0', finals')
  where n = Set.size states
        states'_l = map show [1..n]
        states'   = Set.fromList states'_l
        dic     = Map.fromList $ zip (Set.toList states) states'_l
        delta'  = Map.map (unMap dic) $ Map.mapKeys (\(s, a) -> (unMap dic s, a)) $ delta
        finals' = Set.map (unMap dic) finals
        x0'     = unMap dic x0

negation :: DFA -> DFA
negation (states, alpha, delta, x0, finals) = (states, alpha, delta, x0, finals')
  where finals' = states Set.\\ finals

intersection :: DFA -> DFA -> DFA
intersection (states1, alpha1, delta1, x1, finals1) (states2, alpha2, delta2, x2, finals2)
  = if alpha1 == alpha2 then (states', alpha1, delta', x', finals') else undefined
  where states' = Set.map show $ cartProdS states1 states2
        delta'  = Map.fromList [((show (s, t), a), show (s', t')) | ((s, a), s') <- Map.assocs delta1,
                                                                    ((t, b), t') <- Map.assocs delta2, a == b]
        x'      = show (x1, x2)
        finals' = Set.map show $ cartProdS finals1 finals2

--union :: DFA -> DFA -> DFA
--union (states1, alpha1, delta1, x1, finals1) (states2, alpha2, delta2, x2, finals2)
--  = if alpha1 == alpha2 then (states', delta', x', finals') else undefined
--  where states' = Set.map show $ cartProdS states1 states2
--        delta'  = Map.fromList [((show (s, t), a), show (s', t')) | ((s, a), s') <- Map.assocs delta1,
--                                                                    ((t, b), t') <- Map.assocs delta2, a == b]
--        x'      = show (x1, x2)
--        finals' = Set.union (Set.map show $ cartProdS states1 finals2) (Set.map show $ cartProdS finals1 states2)

difference :: DFA -> DFA -> DFA
difference m m' = intersection m (negation m')

size :: DFA -> Int
size (states, alpha, delta, x0, finals) = Set.size states

--includes :: DFA -> DFA -> Bool
--includes m m' = isEmpty $ difference m' m

--isEmpty :: DFA -> Bool
--isEmpty m =
--  where (states, delta, x0, finals) = m
--        n = size m

--forwardTrans :: DFA -> Set State -> Set State
--forwardTrans (states, delta, x0, finals) ss =
--  joinS $ Set.map (\s -> [A, B]) ss

minimize :: DFA -> DFA
minimize (states, alpha, delta, x0, finals) = minimize' (states, alpha, delta, x0, finals) indist
  where indist   = Set.union (cartProdS finals finals) (cartProdS cofinals cofinals)
        cofinals = Set.difference states finals

takeAny :: (a -> Bool) -> Set a -> Maybe a
takeAny f s = if Set.size s' == 0 then Nothing else Just $ Set.findMin s'
  where s' = Set.filter f s

minimize' :: DFA -> Set (State, State) -> DFA
minimize' (states, alpha, delta, x0, finals) indist =
  case takeAny (\(p, q) -> not $ all (\a -> Set.member (move p a, move q a) indist) alpha) indist of
    Just (p, q) -> minimize' (states, alpha, delta, x0, finals) (Set.delete (p, q) indist)
    Nothing -> (states', alpha, delta', x0', finals')
      where states' = Set.map (collapse indist) states
            delta'  = Map.mapKeys (\(p, a) -> (collapse indist p, a)) $ Map.map (collapse indist) delta
            x0'     = collapse indist x0
            finals' = Set.map (collapse indist) finals
  where move p a = unMap delta (p, a)

collapse :: Ord a => Set (a, a) -> a -> a
collapse eq x = y
  where (y, _) = Set.findMin $ Set.filter (\(p,q) -> Set.member (p,q) eq && q == x) eq

--transMon :: DFA -> Monoid

--transMon' :: DFA -> Set (Map State State) -> Monoid
--transMon' (states, delta, x0, finals)


compose :: (Ord a, Ord b) => Map a b -> Map b c -> Map a c
compose d1 d2 = Map.map (\y -> unMap d2 y) d1 

--aa = RECat (REAlpha A) (REAlpha A)
--re = RECat (REStar aa) aa
--m  = reToDFA re
--m' = simplify m

al = Set.fromList ['0', '1']
st = Set.fromList ["a", "b", "c", "d", "e", "f", "g", "h"]
dl = Map.fromList [(("a", '0'), "b"), (("a", '1'), "f"), (("b", '0'), "g"), (("b", '1'), "c"),
                   (("c", '0'), "a"), (("c", '1'), "c"), (("d", '0'), "c"), (("d", '1'), "g"),
                   (("e", '0'), "h"), (("e", '1'), "f"), (("f", '0'), "c"), (("f", '1'), "g"),
                   (("g", '0'), "g"), (("g", '1'), "e"), (("h", '0'), "g"), (("h", '1'), "c")]
s  = "a"
f  = Set.fromList ["c"]
m = (st, al, dl, s, f)