Common Lisp で実装された全文検索エンジン Montezuma

Common Lisp で実装された全文検索エンジン Montezuma を動かす。

MeCab を使った analyzer を実装して、日本語を扱えるところまで確認した。

タイトルやボディ等の構造を持った文書も扱える。検索は and, or, not, 部分一致等結構柔軟。ただし、範囲検索(2010-4-26〜2010-9-26のような)はできない。しっかりちゃんと動く。十分実務に使えると思った。

(eval-when (:compile-toplevel :load-toplevel :execute)
  (require :montezuma))

(defpackage :try-montezuma
    (:use :cl))

(in-package :try-montezuma)

;;; MeCab
(defun run-mecab (stream)
  (with-output-to-string (out)
    (sb-ext:run-program "mecab" nil :search t :input stream :output out)))

(defgeneric mecabaku (input)
  (:method ((stream stream))
    (with-input-from-string (in (run-mecab stream))
      (loop for i = (read-line in)
            until (string= "EOS" i) collect (collect-mecabu-output i))))
  (:method ((string string))
    (with-input-from-string (stream string)
      (mecabaku stream))))

(defmacro collect-mecabu-output-macro ()
  (let ((x '(表層形 品詞 品詞細分類1 品詞細分類2 品詞細分類3 活用形 活用型 原形 読み 発音)))
    `(defun collect-mecabu-output (one-line)
       (ppcre:register-groups-bind ,x
           ("(.*)\\t([^,]+),([^,]+),([^,]+),([^,]+),([^,]+),([^,]+)(?:,([^,]+),([^,]+),([^,]+))?"
            one-line)
         (list ,@(loop for i in x
                       append `(',i ,i)))))))
(collect-mecabu-output-macro)

;;(mecabaku "桜が咲いた。Hello")
;;(loop for i in (mecabaku "桜が咲いた。") collect (getf i '原形))
;; => ("桜" "が" "咲く" "た" "。")

;;; tokenizer
(defclass mecab-tokenizer (montezuma::tokenizer)
  ((tokens :initform :unbound)
   (position :initform 0)))

(defmethod montezuma::next-token :before ((self mecab-tokenizer))
  (with-slots (montezuma::input tokens) self
    (when (eq tokens :unbound)
      (setf tokens (mecabaku montezuma::input)))))

(defmethod montezuma::next-token ((self mecab-tokenizer))
  (with-slots (tokens position) self
    (let ((token (pop tokens)))
      (if token
          (let* ((表層形 (getf token '表層形))
                 (new-position (+ position (length 表層形)))
                 (token (or (getf token '原形) 表層形)))
            (prog1 (montezuma::make-token
                    (montezuma::normalize self token)
                    position new-position)
              (setf position new-position)))
          nil))))

(defmethod montezuma::normalize ((self mecab-tokenizer) str)
  str)

;;; analyzer
(defclass mecab-analyzer (montezuma::standard-analyzer)
  ())

(defmethod montezuma::token-stream ((self mecab-analyzer) field string-or-stream)
  (declare (ignore field))
  (reduce (lambda (acc x) (make-instance x :input acc))
          '(mecab-tokenizer
            montezuma::lowercase-filter
            montezuma::stop-filter)
          :initial-value string-or-stream))

;;; index 作成
(defparameter *index*
  (make-instance 'montezuma:index
                 :path "/tmp/montezuma"
                 :analyzer (make-instance 'mecab-analyzer)))

;;; 使ってみる。
(loop for i in '("貘の鼻は長い。" "亀の甲羅は固い。" "This is a new document to be indexed"
                 (("title" . "Programming Lisp")
                  ("content" . "car cdr cons loop is"))
                 (("title" . "Programming Forth")
                  ("content" . "dup swap is")))
      do (montezuma:add-document-to-index *index* i))
(loop for i in '("貘" "の" "甲羅" "長い" "貘の鼻" "貘 鼻 長さ"
                 "this" "to be indexed" "is"
                 "title:Lisp" "Lisp")
      collect (montezuma:search-each
                   *index* i (lambda (doc score)
                               (print (list i doc score)))))

;; + をつけると must
(loop for i in '("title:Lisp"
                 "title:Lisp content:xaxa" ; or
                 "title:Lisp +content:car" ; and
                 "title:Lisp +content:xaxa" ; and
                 "title:\"Programming Forth\"" ; フレーズ
                 )
      for acc = nil
      collect (progn
                (montezuma:search-each
                 *index* i
                 (lambda (doc score)
                   (push (montezuma:document-value (montezuma:get-document *index* doc)
                                                   "content")
                         acc)))
                acc))