naoya_t:コンビネータパーサで遊んでみる

先日ふつケルを読み終えて、こういうのSchemeで作れないかな、とか思ったり思わなかったりしていたところに、

　Ruiさんが Gauche 用のコンビネータパーサを作ってくれた

ので早速使ってみることにした。

MeCab の出力をパースしてみよう

MeCab は

ゴーシュは町の活動写真館でセロを弾く係りでした。

のような日本語文を

ゴーシュ    名詞,一般,*,*,*,*,*
は       助詞,係助詞,*,*,*,*,は,ハ,ワ
町       名詞,一般,*,*,*,*,町,マチ,マチ
の       助詞,連体化,*,*,*,*,の,ノ,ノ
活動      名詞,サ変接続,*,*,*,*,活動,カツドウ,カツドー
写真      名詞,一般,*,*,*,*,写真,シャシン,シャシン
館       名詞,接尾,一般,*,*,*,館,カン,カン
で       助詞,格助詞,一般,*,*,*,で,デ,デ
セロ      名詞,一般,*,*,*,*,セロ,セロ,セロ
を       助詞,格助詞,一般,*,*,*,を,ヲ,ヲ
弾く      動詞,自立,*,*,五段・カ行イ音便,基本形,弾く,ヒク,ヒク
係り      名詞,一般,*,*,*,*,係り,カカリ,カカリ
でし      助動詞,*,*,*,特殊・デス,連用形,です,デシ,デシ
た       助動詞,*,*,*,特殊・タ,基本形,た,タ,タ
。       記号,句点,*,*,*,*,。,。,。
EOS

のように形態素に分解してくれる。

まずはこの出力テキストのパースから：

(use peg)

(define mecab-parser
  (let* ((%surface ($do (chars ($many ($none-of #[\t]) 1))
                        ($return (string->symbol (list->string chars)))))
         (%field ($do (chars ($many ($none-of #[,\n]) 1))
                      ($return (string->symbol (list->string chars)))))
         (%line ($do (surface %surface)
                     tab
                     (feature ($sep-by %field ($char #\,)))
                     newline
                     ($return (cons surface feature))))
         (%eos ($seq ($string "EOS") newline)))
    ($do (lines ($many %line))
         %eos
         ($return lines))))

(define morphemes (parse-string mecab-parser 
"ゴーシュ   名詞,一般,*,*,*,*,*
は       助詞,係助詞,*,*,*,*,は,ハ,ワ
町       名詞,一般,*,*,*,*,町,マチ,マチ
の       助詞,連体化,*,*,*,*,の,ノ,ノ
活動      名詞,サ変接続,*,*,*,*,活動,カツドウ,カツドー
写真      名詞,一般,*,*,*,*,写真,シャシン,シャシン
館       名詞,接尾,一般,*,*,*,館,カン,カン
で       助詞,格助詞,一般,*,*,*,で,デ,デ
セロ      名詞,一般,*,*,*,*,セロ,セロ,セロ
を       助詞,格助詞,一般,*,*,*,を,ヲ,ヲ
弾く      動詞,自立,*,*,五段・カ行イ音便,基本形,弾く,ヒク,ヒク
係り      名詞,一般,*,*,*,*,係り,カカリ,カカリ
でし      助動詞,*,*,*,特殊・デス,連用形,です,デシ,デシ
た       助動詞,*,*,*,特殊・タ,基本形,た,タ,タ
。       記号,句点,*,*,*,*,。,。,。
EOS
")

結果 (morphemes) はこんな感じ：

((ゴーシュ 名詞 一般 * * * * *)
 (は 助詞 係助詞 * * * * は ハ ワ)
 (町 名詞 一般 * * * * 町 マチ マチ)
 (の 助詞 連体化 * * * * の ノ ノ)
 (活動 名詞 サ変接続 * * * * 活動 カツドウ カツドー)
 (写真 名詞 一般 * * * * 写真 シャシン シャシン)
 (館 名詞 接尾 一般 * * * 館 カン カン)
 (で 助詞 格助詞 一般 * * * で デ デ)
 (セロ 名詞 一般 * * * * セロ セロ セロ)
 (を 助詞 格助詞 一般 * * * を ヲ ヲ)
 (弾く 動詞 自立 * * 五段・カ行イ音便 基本形 弾く ヒク ヒク)
 (係り 名詞 一般 * * * * 係り カカリ カカリ)
 (でし 助動詞 * * * 特殊・デス 連用形 です デシ デシ)
 (た 助動詞 * * * 特殊・タ 基本形 た タ タ)
 (。 記号 句点 * * * * 。 。 。))

パースする対象は文字列でなくてもいい

こうして得たリストをさらにパースしてみたい。

まずは文節単位に区切ってみよう。

たとえばこんな記述でパースしたいのだが：

(define %名詞   ($品詞 '名詞))
(define %記号   ($品詞 '記号))
(define %形容詞 ($品詞 '形容詞))
(define %連体詞 ($品詞 '連体詞))
(define %助動詞 ($品詞 '助動詞))
(define %助詞   ($品詞 '助詞))
(define %副詞   ($品詞 '副詞))
(define %動詞   ($品詞 '動詞))
(define %接続詞 ($品詞 '接続詞))
(define %接頭詞 ($品詞 '接頭詞))
(define %句点   ($表層形 '。))
(define %読点   ($表層形 '、))

(define %sentence
  (let* ((%v ($do (v ($many %動詞 1 2))
                  (aux ($many %助動詞 0 2))
                  (p ($many %助詞 0 2))
                  ($return (list 'v v aux p))))
         (%n ($do
                  (n ($many %名詞 1))
                  (p ($many ($or %助動詞 %助詞) 0 2))
                  ($return (list 'n n p))))
         (%adj ($do (mod ($or %連体詞 %形容詞))
                    ($return (list 'adj mod))))
         (%adv ($do (mod %副詞)
                    ($return (list 'adv mod))))
         (%seg ($or %n %v %adj %adv)))
    ($do (segs ($many %seg 1))
         ($optional %句点)
         ($return (list 'sentence segs)))))

ここで

(define ($表層形 x)
  ($do (m ($satisfy (lambda (m) (eq? (m-surface m) x)) x))
       ($return m)))

(define ($品詞 x)
  ($do (m ($satisfy (lambda (m) (eq? (m-hinshi m) x)) x))
       ($return m)))

(define (m-surface m) (car m))
(define (m-hinshi m) (cadr m))

１段目のパースで得たリストを、コンビネータパーサが扱えるストリームに変換

(define (make-morpheme-stream morphemes)
  (let loop ((l morphemes) (pos 0))
    (lambda ()
      (if (null? l)
          (let loop () (values #f pos loop))
          (values (car l)
                  pos
                  (loop (cdr l) (+ pos 1)))))))

parse-string を一部改造して parse-morphemes を定義

(define (parse-morphemes parse morphemes)
  (define (error->string err)
    (case (failure-type err)
      ((message)  (failure-message err))
      ((expect)   (failure-message err))
      ((unexpect) (format #f "unexpected: ~a" (failure-message err)))))
  (let1 r (parse (make-morpheme-stream morphemes))
    (if (parse-success? r)
      (semantic-value-finalize! (result-value r))
      (raise (make-condition <parse-error>
               'position (failure-position r)
               'message (error->string r))))))

あとは

(define (parse-sentence s)
  (parse-morphemes %sentence s))

でパースが可能。

結果を見てみよう：

(define (print-sentence s)
  (define (print-seg seg)
    (let ((type (car seg)))
      (case type
        ((n)
         (let ((n (cadr seg))
               (p (caddr seg)))
           (format "[~a] ~a ~a"
                   type
                   (string-join (map m-surface-str n) "+")
                   (string-join (map m-surface-str p) "."))))
        ((v)
         (let ((v (cadr seg))
               (aux (caddr seg))
               (p (caddr seg)))
           (format "[~a] ~a ~a ~a"
                   type
                   (string-join (map m-surface-str v) "+")
                   (string-join (map m-surface-str aux) ".")
                   (string-join (map m-surface-str p) "."))))
        ((adj adv)
         (let ((a (cadr seg)))
           (format "[a] ~a" (m-surface-str a))))
        (else
         (format "? ~a" seg)))))
  (map print (map print-seg (cadr s))))

(print-sentence (parse-sentence result))

[n] ゴーシュ は
[n] 町 の
[n] 活動+写真+館 で
[n] セロ を
[v] 弾く 
[n] 係り でし.た

《たぶん続く》