読者です 読者をやめる 読者になる 読者になる

DoubleArray: common lisp用の検索関数

common lisp sbcl

doar-0.0.6のmkdoarコマンドで保存したDoubleArrayデータをロードして検索が行えるcommon lispの関数群を作成して、動かしてみた。

検索速度的には、文字列を終始バイト列として扱うことを前提とすれば、C++版に比べて3倍程度遅いだけ(?)なので、まあ許容範囲内だった。※ ただし、検索の度に「文字列->バイト列」の変換(sb-ext:string-to-octets)を行った場合、さらに5倍程度遅くなった。文字列変換コストは結構高い。

組み込みのgethash関数と比べた場合、検索速度はほぼ同じだったが、使用メモリはDoubleArrayの方が4倍程度少ない*1、と結構差が出た。

性能的には十分使えそうな感じだ。


ただ、やはりバイト列としての文字列はcommon lisp(sbcl)では扱いにくいと思う。
そもそも、その辺りのことは(おそらく)言語仕様で定められていないので、実装依存になるし、バイトの文字列のための便利な関数といったものも少ない(with-input-from-stringとかも(array character)にしか使えないし)
全てをバイト文字列でまかなうことも無理なので、結局バイト文字列とcharacter文字列の相互変換(両方を意識すること)が各所で必要になってくる*2
効率性をある程度諦めれば、いろいろやりようはあるのだろうが...。


こういった点では、Cのポインタが羨ましい。あれだと、バイト列としての文字列が(自分的には)自然、かつ効率的に扱えるのに...*3


あと蛇足だが、自分の環境のsbclのmost-positive-fixnumが、#x1FFFFFFFだということを、今日知った。てっきり#x7FFFFFFFまで(fixnumで)表現可能かと思っていたので、少しショック。

ソースコード

common lisp版は、ライブラリとしてまとめるかどうかは未定だが、後で使う可能性はあるので、現状のソースを載せておく。
sbclの他に、一応clispでも動作することを確認してある。

;;;;;;;;;;;;;;;;;;;;;;
;;;; doar-0.0.6用 ;;;;
;;; sbclとclisp用

(defpackage :doar
  (:use :common-lisp)
  (:shadow :load :search)
  (:export :doar
           :load
           :string-to-octets
           :octets-to-string
           :search
           :string-search
           :common-prefix-search))
(in-package :doar)

(defstruct (doar (:conc-name ""))
  (flag #*0 :type simple-bit-vector)     
  (tind #() :type (simple-array fixnum)) 
  (base #() :type (simple-array fixnum)) 
  (chck #() :type (simple-array (unsigned-byte 8)))
  (tail #() :type (simple-array (unsigned-byte 8))))
;; if flag[idx]==0
;;   base[idx]+code  ==> next-idx  
;;   code == chck[next-idx]  ## verify movement
;; else 
;;   ## base[idx] is leaf-node
;;   base[idx]       ==> ID 
;;    ## and ##
;;   tind[base[idx]] ==> index to tail
;;   break
;; end

(defmacro a.when (expr &body body)
  `(let ((it ,expr))
     (when it
       ,@body)))

;;;;;;;;;;;;
;;; load ;;;
(defun to-fixnum (num) (ldb (byte 29 0) num))
(defun highest-bit (num) (ldb (byte 1 31) num))

(defun load (path)
  (with-open-file (in8 path :element-type '(unsigned-byte 8))
    (with-open-file (in32 path :element-type '(unsigned-byte 32))
      (let* ((node-size #1=(read-byte in32))
             (tind-size #1#)
             (tail-size #1#)
             (tind-array (make-array tind-size :element-type '(unsigned-byte 32)))
             (base-array (make-array node-size :element-type '(unsigned-byte 32)))
             (chck-array (make-array node-size :element-type '(unsigned-byte 8)))
             (tail-array (make-array tail-size :element-type '(unsigned-byte 8))))
        (read-sequence tind-array in32) (file-position in32 (+ 3 tind-size))
        (read-sequence base-array in32) (file-position in8 #2=(* 4 (+ 3 tind-size node-size)))
        (read-sequence chck-array in8)  (file-position in8 (+ #2# node-size))
        (read-sequence tail-array in8)

        (make-doar 
         :tind (make-array tind-size :element-type 'fixnum 
                                     :initial-contents tind-array)
         :base (make-array node-size :element-type 'fixnum 
                                     :initial-contents (map 'vector #'to-fixnum base-array))
         :flag (make-array node-size :element-type 'bit 
                                     :initial-contents (map 'vector #'highest-bit base-array))
         :chck chck-array
         :tail tail-array)))))

;;;;;;;;;;;;;;
;;; search ;;;
(defvar *fastest* '(optimize (speed 3) (debug 0) (compilation-speed 0) (safety 0)))
(declaim (inline next-index get-id tail-index not-leaf? 
                 key-exists? key-including?
                 string-to-octets octets-to-string
                 string-search)
         #.*fastest*)

(defun string-to-octets (string)
  #+sbcl  (sb-ext:string-to-octets string)
  #+clisp (ext:convert-string-to-bytes string charset:utf-8))

(defun octets-to-string (octets)
  #+sbcl  (sb-ext:octets-to-string octets)
  #+clisp (ext:convert-string-from-bytes octets charset:utf-8))


(defmacro with-doar-abbrev ((doar) &body body)
  ;; MEMO: もともとは、symbol-macroletを使っていたが、
  ;;       構造体へのアクセスだけで、全体の1/4くらいの時間を使っていたので、letに変更した。
  `(let ((base (base ,doar)) (chck (chck ,doar))
         (tind (tind ,doar)) (tail (tail ,doar))
         (flag (flag ,doar)))
     ,@body))

(defun get-id (node) node)
(defun tail-index (node tind) (aref tind node))
(defun next-index (base-node code) (+ base-node code))
(defun not-leaf? (node bits) (zerop (sbit bits node)))

(defun key-exists? (key  beg1 end1 
                    tail beg2 end2 &aux (end2 (min end2 (+ beg2 (- end1 beg1) 1))))
  (and (zerop (aref tail (1- end2)))
       (common-lisp:search key tail :start1 beg1 :start2 beg2 :end2 end2)))

(defun key-including? (key beg1 end1 tail beg2)
  (do ((i beg1 (1+ i)) (j beg2 (1+ j)))
      ((zerop (aref tail j)) i)
    (declare (fixnum i j))
    (when (or (= i end1)
              (/= (aref key i) (aref tail j)))
      (return-from key-including? nil))))
       
(declaim (ftype (function ((simple-array (unsigned-byte 8)) doar) (or NULL fixnum)) search))
(defun search (key doar &aux (len (length key)))
  (with-doar-abbrev (doar)
    (let ((tail-len (length tail)))
      (do* ((i 0 (the fixnum (1+ i)))
            (node (aref base 0))
            (code (aref key 0) (if (= len i) 0 (aref key i)))
            (next #1=(next-index node code) #1#))
           ((zerop code) (and (zerop  (aref chck next))
                              (get-id (aref base next))))
        (setf node (aref base next))
        (unless (and (= code (aref chck next))
                     (cond ((not-leaf? next flag) t) ; next loop
                           ((key-exists? key (1+ i) len tail (tail-index node tind) tail-len)
                            (return-from search (get-id node)))))
          (return-from search nil))))))

(defun string-search (string doar)
  (search (string-to-octets string) doar))
;; [ex]
;; (defvar *doar* (load "/..."))
;; (search (string-to-octets "日本") *doar*)
;; --> 199297
;; (string-search "日本" *doar*)
;; --> 199297


;; XXX: 未整理
(declaim (ftype (function ((simple-array (unsigned-byte 8)) doar) list)
                common-prefix-search))
(defun common-prefix-search (key doar &aux (len (length key)) acc)
  (with-doar-abbrev (doar)
    (do* ((i 0 (the fixnum (1+ i)))
          (node (aref base 0))
          (code (aref key 0) (if (= len i) 0 (aref key i)))
          (next #1=(next-index node code) #1#))
         ((zerop code) (and (zerop  (aref chck next))
                            (push `(,i . ,(get-id (aref base next))) acc))
                       (nreverse acc))
      (when (and (/= i 0)
                 (zerop (aref chck #2=(next-index node 0))))
        (push `(,i . ,(get-id (aref base #2#))) acc))

      (unless (= code (aref chck next))
        (return-from common-prefix-search (nreverse acc)))
      (setf node (aref base next))  
      (unless (not-leaf? next flag)
        (a.when (key-including? key (1+ i) len tail (tail-index node tind))
          (push `(,it . ,(get-id node)) acc))
        (return-from common-prefix-search (nreverse acc))))))
;; [ex]
;; (common-prefix-search (string-to-octets "日本") *doar*)
;; --> ((3 . 198846) (6 . 199297))

*1:前回扱ったIPADICデータの場合

*2:また、sbclの場合は、character文字列(array character)とバイト文字列(array (unsigned-byte 8) )に加えて、sb-alienパッケージで操作可能な生のメモリ領域上のバイト文字列もある

*3:"文字"の列としての文字列は扱いにくいけど