Haskell でオートマトン改

Data.Set を排して唯のリストで書き換えている。骨格はこんな感じ。

• Ord a 制約が不要となったため、オートマトンを Functor にできた。
• α-遷移(文字による遷移)とε-遷移の扱いをシンプルに。

NFA から DFA への変換の際、何が起きているかよく理解しよう。そうするときっと Functor であることも生きて奇麗に書けるのではないだろうか。

{-# LANGUAGE NoMonomorphismRestriction #-}

module FA where
import Data.List

-- Data
type Symbol = Char
type Alphabet = [Symbol]

-- Edge fromState toState
data Edge a = Edge a a deriving (Eq)

edgeStates (Edge q q') = [q, q']
edgeMatch r (Edge q q') = r == q

instance Functor Edge where
    fmap f (Edge q q') = Edge (f q) (f q')

instance (Show a) => Show (Edge a) where
    show (Edge q q') = show q ++ " => " ++ show q'

-- LEdge Edge Symbol
data LEdge a = LEdge (Edge a) Symbol deriving (Eq)
labelEdge (LEdge e c) = e
lMatch r c' (LEdge e c) = (c == c') && edgeMatch r e

instance Functor LEdge where
    fmap f (LEdge e c) = LEdge (fmap f e) c

instance (Show a) => Show (LEdge a) where
    show (LEdge (Edge q q') c) = show q ++ " " ++ show c ++ " => " ++ show q'

-- Type class Directed
class Directed d where
    initial :: d a -> a
    terminal :: d a -> a

instance Directed Edge where
    initial (Edge q _) = q
    terminal (Edge _ q') = q'

instance Directed LEdge where
    initial (LEdge e _) = initial e
    terminal (LEdge e _) = terminal e

-- Type class Reversal
class Reversal a where
    rev :: a -> a

instance Reversal ([] a) where
    rev = reverse

instance Reversal (Edge a) where
    rev (Edge q q') = Edge q' q

instance Reversal (LEdge a) where
    rev (LEdge e c) = LEdge (rev e) c

-- FA
type Transition a = [LEdge a]
type ETransition a = [Edge a]
-- Finite Automaton
data FA a = FA { states :: [a],
                 alphabet :: Alphabet,
                 trans :: Transition a,
                 etrans :: ETransition a,
                 starts :: [a],
                 finals :: [a] }

-- Constructor
makeDFA qs cs ts q0 fs = FA (nub qs) (nub cs) (nub ts) [] [q0] (nub fs)
makeNFA qs cs ts es q0s fs = FA (nub qs) (nub cs) (nub ts) (nub es) (nub q0s) (nub fs)

listCmp xs ys = length (xs `union` ys) == length xs

reachable :: Eq a => FA a -> FA a
reachable (FA qs cs ts es q0s fs) = mkfa (fixpoint' move' q0s listCmp)
    where 
      move rs = nub $ concat [ transits ts rs c | c <- cs ]
      ecl = eclosure es
      move' rs = nub (move rs ++ ecl rs)
      mkfa reach = FA reach cs ts' es' q0s fs'
          where 
            isReach q = q `elem` reach
            ts' = filter (all isReach . edgeStates . labelEdge) ts
            es' = filter (all isReach . edgeStates) es
            fs' = filter isReach fs

-- Query
size :: FA a -> Int
size (FA qs _ _ _ _ _) = length qs
isEFree = null
isComplete :: (Eq a) => FA a -> Bool
isComplete (FA qs cs ts _ _ _) = 
    all (not . null) [ transit ts q c | q <- qs, c <- cs ]
isString :: Eq a => [a] -> [a] -> Bool
isString cs = all (`elem` cs)

-- Operation
transit :: (Eq a) => Transition a -> a -> Symbol -> [a]
transit ts q c = map (terminal . labelEdge) $ filter (lMatch q c) ts
transit1 :: (Eq a) => Transition a -> a -> Symbol -> a
transit1 t q c = head (transit t q c)
transits :: Eq a => Transition a -> [a] -> Symbol -> [a]
transits ts rs c = nub $ concat [ transit ts r c | r <- rs ]
etransit :: (Eq a) => ETransition a -> a -> [a]
etransit e q = map terminal (filter (edgeMatch q) e)
-- Query
isDet :: Eq a => FA a -> Bool
isDet (FA qs cs ts es q0s fs) =
    length q0s <= 1 &&
    isEFree es &&
    all (<= 1) [ length (transit ts q c) | q <- qs, c <- cs ]

-- Operation
mapState f (FA qs cs ts es q0s fs) = FA qs' cs ts' es' q0s' fs'
    where
      qs' = map f qs
      ts' = map (fmap f) ts
      es' = map (fmap f) es
      q0s' = map f q0s
      fs' = map f fs

instance Functor FA where
    fmap = mapState

revFA (FA qs cs ts es q0s fs) = FA qs cs (map rev ts) (map rev es) fs q0s

instance Reversal (FA a) where
    rev = revFA

rename :: (Eq a1, Eq a2) => [a2] -> FA a1 -> FA a2
rename as fa@(FA qs _ _ _ _ _) = fmap conv fa
    where
      conv q = case lookup q (zip qs as) of
                 Just x -> x

gennames :: String -> [String]
gennames a = map (\x -> a ++ show x) [0..]
rename' :: (Eq a) => FA a -> FA String
rename' = rename (gennames "q")

-- return DFA
det :: Eq a => FA a -> FA [a]
det m@(FA qs cs ts es q0s fs) = iter di (notmarked di) []
    where
      di = [ (eclosure es q0s, False) ]
      isMarked (_, b) = b
      removeMark = map fst
      notmarked xs = removeMark (filter (not . isMarked) xs)
      maybeAdd us ds | us `elem` removeMark ds = ds
                     | otherwise = (us, False):ds
      ecl = eclosure es
      move = transits ts
      mark x xs =  (x, True): delete (x, False) xs
      q0s' = ecl q0s
      iter ds [] ts' = FA qs' cs ts' [] [q0s'] fs'
          where
            qs' = removeMark ds
            fs' = filter (any (`elem` fs)) qs'
      iter ds (t:ts) ts' = iter ds' (notmarked ds') ts''
          where
            ds' = foldl (\s c -> maybeAdd (ecl (move t c)) s) (mark t ds) cs
            ts'' = foldl (flip (:)) ts' [ LEdge (Edge t (ecl (move t c))) c | c <- cs ]

-- Minimization
minimize = det . reachable . rev . reachable . det . reachable . rev

-- Accept
accept :: (Eq a) => FA a -> [Symbol] -> Bool
-- DFA
accept m@(FA qs cs ts es q0s fs) str
    | isDet m && isString cs str = foldl (transit1 ts) (head q0s) str `elem` fs
-- NFA
accept m@(FA qs cs ts es q0s fs) str
    | isString cs str =
        any (`elem` fs) (fn (eclosure es q0s) str)
            where
              fn = foldl (\s c -> eclosure es (transits ts s c))