再帰的な Migemo 検索

最近 youtube のデータベースを Scheme で作っています。ただ、データベースはかなり大きくなってきたものの、検索エンジンの実装は、経験が無かったためずっと後回しにしていました。

Migemo (C/Migemo ライブラリ) が使えそうなことは Winamp 等の実験で分かってましたので、あとは AND 検索とか OR 検索とかの仕組みを考えたいわけです。

例えば、特定の二人が一緒に登場するものを検索したいとすると、それぞれの名前の部分を OR で並べて検索できると便利そうですよね:

(AND (OR "gaki" "risa")
     (OR "kame" "eri"))

より厳密を期すため、次のように式を組みたい場合もあるでしょう:

(AND (OR "gaki" (AND "risa" (NOT "risako")))
     (OR "kame" (AND "eri"  (NOT "erika"))))

このように AND 式の中に OR 式があり、その中に AND 式があり、さらにその中に NOT 式がある、というような入れ子構造を処理する方法といえば、と考えた時、「それって Lisp じゃん」ということに気付きました。

ネストされたリスト構造に、マッピングによって再帰的に関数を適用する、あのエレガントなスタイルです。

(define youtube-search/db
  (let ((m #f))                         ; migemo object
    (define (match-type type)
      (lambda (x)
        (and (pair? x)
             (symbol? (car x))
             (string=? type
                       (string-upcase
                        (symbol->string (car x)))))))
    (define and? (match-type "AND"))
    (define or?  (match-type "OR"))
    (define not? (match-type "NOT"))
    (define rxp? (fun byte-regexp? regexp?))
    ;; Compiles search string into regexp object
    (define (regexp/m query)
      (cond ((string? query) (m query)) ; migemize string
            ((rxp? query) query)
            ((and? query)
             (map regexp/m (cdr query))) ; strip off the 'AND operator
            ((or? query)
             (cons (car query) (map regexp/m (cdr query))))
            ((not? query)               ; unary operator
             (list (car query) (regexp/m (cadr query))))
            ((list? query)
             (map regexp/m query))
            (else #f)))                 ; error!
    (define (match query info)
      (cond ((rxp? query)
             (or (regexp-match query (lookup 'title info))
                 (regexp-match query (lookup 'desc info))))
            ((or? query)
             (ormap (cut match <> info) (cdr query)))
            ((not? query)
             (not (match (cadr query) info)))
            ((list? query)
             (andmap (cut match <> info) query))
            (else #f)))
    (lambda (query)
      (unless m
        (set! m ((dynamic-require "migemo.ss" 'migemo))))
      (if (eq? query 'done)
          (set! m (m 'done))
          (filter-db (cute match (regexp/m query) <>))))))

ここまで書いてしまったところで再び気付きました。「これって SICP 4 章で出てきたやつだ」

一瞬で次のように書き換えました:

(define youtube-search/db
  (let ((m #f))                         ; migemo object
    (define (match-type type)
      (lambda (x)
        (and (pair? x)
             (symbol? (car x))
             (string=? type
                       (string-upcase
                        (symbol->string (car x)))))))
    (define and? (match-type "AND"))
    (define or?  (match-type "OR"))
    (define not? (match-type "NOT"))
    (define rxp? (fun byte-regexp? regexp?))
    (define (compile query)
      (cond ((rxp? query)
             (lambda (info)
               (or (regexp-match query (lookup 'title info))
                   (regexp-match query (lookup 'desc info)))))
            ((string? query)
             (compile (m query)))       ; migemize string
            ((and? query)
             (let ((procs (map compile (cdr query))))
               (lambda (info)
                 (andmap (cut <> info) procs))))
            ((or? query)
             (let ((procs (map compile (cdr query))))
               (lambda (info)
                 (ormap (cut <> info) procs))))
            ((not? query)               ; unary operator
             (complement (compile (cadr query))))
            ((list? query)
             (compile (cons 'and query)))
            (else #f)))                 ; error!
    (lambda (query)
      (unless m
        (set! m ((dynamic-require "migemo.ss" 'migemo))))
      (if (eq? query 'done)
          (set! m (m 'done))
          (filter-db (compile query))))))

検索文字列の正規表現化と DB 検索の両関数を一つに統合した、というのが変更点です。

どちらも基底条件 (rxp? の時) における演算の上に論理的な演算を被せていくことで、ネストされた式を再帰的に解いている点は同じです。

ただ、最初のバージョンでは DB のレコードごとに検索式の構文解析が行われていたのに対し、後者では初めに compile した時点で完全に解析が終了しています。何千・何万回と一回の違いですから、もの凄い効率化になっているわけです。

ちなみに、関係無いんですが、動画のリストを出力する関数は以下のようになっています:

(define (youtube-vids->html file vids)
  (let ((vids (mapfilter youtube-video vids)))
    (and (pair? vids)
         (call-with-output-file file
           (lambda (out)
             ((send-reply out)
              (html:html
               (html:head
                (html:meta "Content-Type" "text/html; charset=utf-8")
                (html:link (@ (rel "stylesheet") (href "youtube.css")))
                (html:javascript (@ (src "youtube.js"))))
               (html:body
                (html:javascript
                 "var vids="
                 (lambda (_)
                   (json-write
                    (map (lambda (info)
                           (let ((vid  (car info))
                                 (info (cute lookup <> (cdr info)))
                                 (item (hash)))
                             (for-each
                              item
                              '(vid title user desc watch thumb flv)
                              (list vid
                                    (info 'title)
                                    (info 'user)
                                    (info 'desc)
                                    (watch-url vid)
                                    (thumb-url vid)
                                    (video-url vid (info 't))))
                             item))
                         vids)
                    out))
                 ";")))))
           'replace)
         'done)))

詳細は措いて、この関数のかっこいい個所を発表させていただきます。ここです:

(for-each item
          (list of keys)
          (list of values))

item はハッシュ表なんですが、これだけでハッシュ表に情報を登録できているんです。

本来

(lambda (key value)
  (hash-table-put! item key value))

とするところが `item' だけで済んでいるわけです。Applicable Hashtable というものを使っています。

参考までに、Common Lisp:

#'(lambda (key value)
    (setf (gethash key item) value))

Arc:

(fn (k v) (= (item k) v))

となるでしょうか。

追記:
Arc だとこういう方法もありますね:

(fill-table
  (table)
  `(k1 ,v1 ... kn ,vn))

さて、肝心の C/Migemo ライブラリのラッパーモジュールなんですが、ちょっと自分でも理解していない問題があり、てきとうな実装です。API 関数の定義部分だけでも参考にしてください:

(module migemo mzscheme
  (provide migemo)

  (require "prelude.ss"
           (lib "2.ss" "srfi")
           "ffi.ss"
           "iconv.ss")

  (define main-dict "c:\\MAIN-DICT-DIR\\migemo-dict")
  (define user-dict "c:\\USER-DICT-DIR\\user-dict")

  (define MIGEMO_DICTID_MIGEMO 1)
  (define MIGEMO_OPINDEX_NEST_IN 1)

  (define-api migemo
    (migemo_open (_string -> _pointer))
    (migemo_close (_pointer -> _void))
    (migemo_query (_pointer _string -> _bytes))
    (migemo_release (_pointer _bytes -> _void))
    (migemo_load (_pointer _int _string -> _int))
    (migemo_is_enable (_pointer -> _int))
    (migemo_get_operator (_pointer _int -> _string))
    (migemo_set_operator (_pointer _int _string -> _int)))

  (define (debug x who)
    (printf "[~a] ~a~%" who x)
    x)

  (define (chars->branches chars)
    (string->bytes/utf-8
      (format "(?:~a)"
              (mapconcat identity
                         (string->list chars)
                         "|"))))

  (define (open-migemo dict)
    (and-let* ((m (migemo_open dict)))
      (lambda (k)
        (case k
          ((done) (migemo_close m) #f)
          ((load) (lambda (id dict)
                    (migemo_load m id dict)))
          ((set-op) (lambda (id op)
                      (migemo_set_operator m id op)))
          ((release) (lambda (p) (migemo_release m p)))
          ((query) (lambda (q) (migemo_query m q)))))))

  (define (migemo)
    (and-let* ((m (open-migemo main-dict))
               (c->u (iconv "CP932" "UTF-8")))
      ((m 'load) MIGEMO_DICTID_MIGEMO user-dict)
      ((m 'set-op) MIGEMO_OPINDEX_NEST_IN "(?i:")
      (lambda (str)
        (if (eq? str 'done)
            (begin (c->u 'done)
                   (m 'done))
            (let ((p ((m 'query) str)))
              (begin0
                  (byte-regexp
                   (debug
                    (regexp-replace* #rx"\\[(.+?)\\]"
                                     (c->u p)
                                     (lambda (_ chars)
                                       (chars->branches
                                        (bytes->string/utf-8 chars))))
                    'regexp))
                ((m 'release) p))))))))