Haskell でオートマトン(5)

状態の合成を扱えるよう、定義を少し変更して、正規演算の和集合演算を書いてみた。
リスト内包表記だと直積がエレガント。教科書の定義そのままに書ける。

まだテストしてないけどとりあえず。

data State = State String | State2 (State, State) deriving (Eq, Show)

union :: Dfa -> Dfa -> Dfa
--union = undefined
union m1 m2 = Dfa states alphabet transit start accept where
    qs1 = statesOf m1
    qs2 = statesOf m2
    states = [ State2 (r1, r2) | r1 <- qs1, r2 <- qs2 ]
    alphabet = alphabetOf m1 -- fixme
    start = State2 (startOf m1, startOf m2)
    accept = [ State2 (r1, r2) | r1 <- qs1, r2 <- qs2, (elem r1 (acceptOf m1)) || (elem r2 (acceptOf m2))]
    transit = [ ((State2 (r1, r2), a), State2 ((transitDfa m1 r1 a), (transitDfa m2 r2 a))) | r1 <- qs1, r2 <- qs2, a <- alphabet ]

前に Common Lisp で書いた Union との比較。今なら Common Lisp でももっと簡潔に書けるように気を配るだろうけど。

;; union
(defmethod union-fa ((m1 dfa) (m2 dfa))
  (loop
     with dfa = (make-instance 'dfa
                               :states nil
                               :alphabet (union (alphabet-of m1) (alphabet-of m2))
                               :start (combine-state (start-state-of m1) (start-state-of m2))
                               :accept nil)
     for (s1 . s2) in (cartesian-product (states-of m1) (states-of m2))
     for s = (combine-state s1 s2)
     if (or (member s1 (accept-states-of m1) :test #'state=)
            (member s2 (accept-states-of m2) :test #'state=))
     do (push s (accept-states-of dfa))
     do
       (push s (states-of dfa))
       (loop for a in (alphabet-of dfa) do
            (setf (transit dfa s a) (combine-state (transit m1 s1 a) (transit m2 s2 a))))
     finally
       (return (rename dfa))))