NFA -> DFA(3)
いろいろ参考にしながら何とか NFA -> DFA の変換まで書いた。
- 状態とアルファベットを型変数とできた。また、集合は集合として Data.Set を使った。個人的に満足。
- 以下のような書き方ができることを知ったのが収穫。これが分からず、MultiParameterTypeClass とか ScopedTypeVariables とか、明後日の方向を調査していた。
class FA fa where states :: fa a b -> Set a
- ループと手続き型言語用に書かれたアルゴリズムを再帰に書き直す方法がいまいちうまくできていない。CL だと普通にloopマクロが使えるのだけど。
- foldl とかzipが使えて幸せ。
- Haskell にマクロが無いのが残念だ。わたしの腕の問題だけど、ボイラープレートが無くせない。マクロなら、、
- Haskell の識別子にはせめて「-」ハイフンが使えるべき。キャメルノーテーション、カッコわるい。
- Test.QuickCheck を使わなくちゃ。DFA -> NFA -> DFA としても受理する文字列が変わらない、とか、rename 前後で受理する文字列が変わらない、とか、常に成り立つ性質を探す必要がある。
- Functor を使いたい。
参考
コード
そのうち github へ。
{- by @quasicrane 2012/05/03 -} module FA where import qualified Test.HUnit as Test import qualified Data.Set as S import Data.Set (Set,member,notMember,elems,singleton,empty,fromList) import Data.Char import Test.QuickCheck class FA fa where states :: fa a b -> Set a alphabet :: fa a b -> Set b start :: fa a b -> a final :: fa a b -> Set a size :: fa a b -> Int size a = S.size (states a) stateMap :: (Ord a1, Ord a2, Ord b) => (a1 -> a2) -> fa a1 b -> fa a2 b rename :: (Ord a1, Ord a2, Ord b) => [a2] -> fa a1 b -> fa a2 b rename as fa = stateMap conv fa where conv = \q -> case (lookup q (zip (elems (states fa)) as)) of Just x -> x -- 狭義の DFA data DFA a b = DFA (Set a) -- 状態の有限集合。 (Set b) -- アルファベット。文字の集合。 (a -> b -> a) -- 遷移関数。 a -- 初期状態。 (Set a) -- 受理状態の集合。状態の部分集合。 -- NFA data NFA a b = NFA (Set a) -- 状態の有限集合。 (Set b) -- アルファベット。文字の集合。 (a -> b -> Set a) -- 遷移関数。 (a -> Set a) -- ε-遷移関数。 a -- 初期状態。 (Set a) -- 受理状態の集合。状態の部分集合。 instance FA DFA where states (DFA qset _ _ _ _) = qset alphabet (DFA _ cset _ _ _) = cset start (DFA _ _ _ q0 _) = q0 final (DFA _ _ _ _ fset) = fset stateMap f (DFA qset cset d q0 fset) = DFA qset' cset d' q0' fset' where qset' = S.map f qset d' = mkdelta [ ((f q, a), f (d q a)) | q <- elems qset, a <- elems cset ] q0' = f q0 fset' = S.map f fset instance FA NFA where states(NFA qset _ _ _ _ _) = qset alphabet (NFA _ cset _ _ _ _) = cset start (NFA _ _ _ _ q0 _) = q0 final (NFA _ _ _ _ _ fset) = fset stateMap f (NFA qset cset d e q0 fset) = NFA qset' cset d' e' q0' fset' where qset' = S.map f qset d' = mkdelta' [ ((f q, a), elems (S.map f (d q a))) | q <- elems qset, a <- elems cset ] e' = mkepsilon [ (f q, elems (S.map f (e q))) | q <- elems qset ] q0' = f q0 fset' = S.map f fset showDFA (DFA qset cset d q0 fset) = "DFA\n " ++ "States: " ++ show (elems qset) ++ "\nq0: " ++ show (q0) ++ "\nfs: " ++ show (elems fset) ++ "\ndelta: \n" ++ concat (map mkstr table) where table = [ (q, a, d q a) | q <- elems qset, a <- elems cset ] mkstr (q, a, r) = "\t" ++ (show q) ++ " " ++ (show a) ++ " => " ++ (show r) ++ "\n" instance (Show a, Show b) => Show (DFA a b) where show = showDFA showNFA (NFA qset cset d e q0 fset) = "NFA\n" ++ "States:\t" ++ show (elems qset) ++ "\nq0:\t" ++ show (q0) ++ "\nfs:\t" ++ show (elems fset) ++ "\ndelta:\n" ++ concat (map mkstr table) ++ concat (map mkstre etable) where table = [ (q, a, d q a) | q <- elems qset, a <- elems cset ] mkstr (q, a, r) = "\t" ++ (show q) ++ " " ++ (show a) ++ " => " ++ (show r) ++ "\n" etable = [ (q, e q) | q <- elems qset, a <- elems cset ] mkstre (q, r) = "\t" ++ (show q) ++ " e => " ++ (show r) ++ "\n" instance (Show a, Show b) => Show (NFA a b) where show = showNFA -- construct S.Set from list mkset a = fromList a mkdelta alist = \q c -> case lookup (q, c) alist of Just q' -> q' Nothing -> error ("Invalid transition") mkdelta' alist = \q c -> case lookup (q, c) alist of Just q' -> mkset q' Nothing -> empty mkepsilon alist = \q -> case lookup q alist of Just q' -> mkset q' Nothing -> empty -- TODO ; validation makeDFA qs cs alist q0 fs = DFA (mkset qs) (mkset cs) (mkdelta alist) q0 (mkset fs) makeNFA qs cs alist e q0 fs = NFA (mkset qs) (mkset cs) (mkdelta' alist) (mkepsilon e) q0 (mkset fs) accept (DFA qset cset d q0 fset) str = accept' q0 str where accept' q [] = member q fset accept' q (s:ss) = accept' (d q s) ss dfaUnion (DFA qset1 cset1 d1 q1 fset1) (DFA qset2 cset2 d2 q2 fset2) | (cset1 == cset2) = DFA qset cset d q0 fset where qs1' = elems qset1 qs2' = elems qset2 qset = mkset [ (r1, r2) | r1 <- qs1', r2 <- qs2' ] cset = cset1 -- same alphabet q0 = (q1, q2) fset = mkset [ (r1, r2) | r1 <- qs1', r2 <- qs2', (member r1 fset1) || (member r2 fset2)] d = mkdelta [ (((r1, r2), a), (d1 r1 a, d2 r2 a)) | r1 <- qs1', r2 <- qs2', a <- elems cset] -- generate states like ["p0", "p1", ..] gennames prefix = map (\x -> prefix ++ show x) [0..] rename' a = rename (gennames "q") a powerset [] = [[]] powerset (x:xs) = yss ++ map (x:) yss where yss = powerset xs subset qset = map mkset $ powerset $ elems qset eclosure e rset = f (elems rset) rset where f [] res = res f (t:ts) res = g (elems (e t)) ts res g [] ts res = f ts res g (u:us) ts res = if (notMember u res) then g us (u:ts) (S.insert u res) else g us ts res move d rset c = S.unions [ d r c | r <- elems rset ] convNFAToDFA (NFA qset cset d e q0 fset) = iter di (unmarked di) [] where ecl = eclosure e move' = move d extractState = S.map fst isMarked (_, b) = b mark s set = S.insert (s, True) (S.delete (s, False) set) unmarkedSet set = extractState (S.filter (not . isMarked) set) unmarked set = elems (unmarkedSet set) mayAddState uset dset | member uset (extractState dset) = dset | otherwise = S.insert (uset, False) dset q0' = ecl (singleton q0) di = singleton (q0', False) cs' = elems cset iter dset [] alist = DFA qset' cset (mkdelta alist) q0' fset' where qset' = extractState dset fset' = S.filter (\q -> any (\r -> member r fset) (elems q)) qset' iter dset (t:ts) alist = iter dset' (unmarked dset') alist' where dset' = foldl (\s c -> mayAddState (ecl (move' t c)) s) (mark t dset) cs' alist' = alist ++ [ ((t, c), ecl (move' t c)) | c <- cs' ]
