マルチキークイックソート
「Sorting and Searching Strings」で説明されているマルチキークイックソートの実装。
詳細はリンク先を参照。
マルチキークイックソート
- 文字列の配列のソートが高速に行える
- URL("http://...")の配列のような接頭部分の重複率が高い文字列配列の場合でも性能が低下しにくい
- クイックソート + 基数ソート、のような感じ？
ソート方法
基本的には通常のクイックソートと似ていて「ピボット要素*1を選んで、配列を分割する」といったことを繰り返す。
ただし、クイックソートは各段階で配列を二分割(ピボット要素よりも大きいか小さいか*2 )し、そのための比較には要素(文字列)全体を用いるのに対して、マルチキークイックソートでは、配列は三分割(ピボット要素よりも大きいか小さいか、それとも等しいか)され、そのための比較には文字列全体ではなく(各段階で)一文字のみ、が用いられる点が異なる(と思う)。
※ マルチキークイックソートでは「初めは0番目の文字を使って配列を三分割、次は1番目の文字を使ってさらに三分割、その次は2番目の文字を使って、...」というようなことが繰り返される。
以下、その擬似コード的なもの。
;; マルチキークイックソート ;; - array: ソート対象の文字列配列 ;; - start: 開始位置 ;; - end: 終端位置 ;; - depth: 分割に用いられる文字の位置。0(先頭)から始まる (defun sort (array start end &optional (depth 0)) (if (<= (- end start) 1) array ; ソート範囲に要素が一つ以下しかない場合は終了 ;;; 分割と再帰ソート ;; 分割 (multiple-value-bind (less-start less-end ; ピボットより小さい要素が集められている範囲 ※ less-end == eql-start eql-start eql-end ; ピボットと等しい要素が集められている範囲 greater-start greater-end) ; ピボットより大きい要素が集められている範囲 ※ eql-end == greater-start (partition array start end depth) ; 配列を三つに分割 ;; 再帰 (sort array less-start less-end depth) ; <領域を再帰的にソート (unless (eos? (aref array eql-start) depth) (sort array eql-start eql-end (1+ depth))) ; =領域は比較に用いる文字位置を一つ進めて、再帰的にソート (sort array greater-start greater-end depth)))) ; >領域を再帰的にソート ;; 文字列の終端に達しているかどうか (defun eos? (string index) (>= index (length string))) ;; 分割関数 (defun partition (array start end depth) (let ((pivot (select-pivot array start end depth))) ; ピボット要素(文字列)を何らかの方法で選択する ;; 配列[start..end]を(何らかの方法で)以下のように三つの領域に分割する ;; - depth番目の文字がピボットのdepth番目の文字より小さい要素は、配列の前方にまとめる ;; - depth番目の文字がピボットのdepth番目の文字と等しい要素は、配列の中央にまとめる ;; - depth番目の文字がピボットのdepth番目の文字より大きい要素は、配列の後方にまとめる ;; 分割した各領域の開始位置と終端位置を返す (values less-start less-end eql-start eql-end greater-start greater-end)))
SBCLのsort関数との比較
マルチキークイックソートとSBCLのsort関数(多分クイックソート。違うかも...)を処理速度を比べてみる。
マルチキークイックソートの実装は末尾を参照。
ソート用のデータには、MeCabのサイトで配布されているIPADICに登録されている単語リストを用いる。
#################### ### 単語リストの用意 # 辞書解凍 ※ mecab-ipadic...tar.gzは既にダウンロード済みと仮定する $ tar zxvf mecab-ipadic-2.7.0-20070801.tar.gz # 単語名取り出し $ cut -d, -f1 mecab-ipadic-2.7.0-20070801/*.csv | nkf -w | LC_ALL=C sort > words $ head words Tシャツ £ \ ¨ ´ × × × ÷ Α
;;;;;;;;;;;;;; ;;; 補助関数定義 & データ用意 ;; ファイルの各行をリストとして読み込む関数 (defun read-lines (filepath) (with-open-file (in filepath) (loop FOR line = (read-line in nil nil) WHILE line COLLECT line))) ;; 配列をシャッフルする関数 (defun shuffle (ary) (loop REPEAT 2 DO (loop FOR i FROM 0 BELOW (length ary) DO (rotatef (aref ary i) (aref ary (random (length ary)))))) ary) ;;;; ;; データ読み込み & シャッフル (defvar *words* (shuffle (coerce (read-lines "words") 'vector))) (subseq *words* 0 10) --> #("折り返せん" "角島" "宇部西線" "照ろ" "月浜" "西湊新田" "松根" "降霜" "助右衛門" "振る舞っ") (length *words*) --> 392126 ; 約40万要素
;;;;;;;;; ;;;; 比較 ;;;; - sbcl-1.0.40 ;; SBCLのsort関数 (let ((words (copy-seq *words*))) (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0)) (simple-vector words)) (time (length (sort words (lambda (a b) (declare ((simple-array character) a b)) (string< a b)))))) Evaluation took: 2.912 seconds of real time 2.892181 seconds of total run time (2.892181 user, 0.000000 system) 99.31% CPU 5,808,074,898 processor cycles 0 bytes consed --> 392126 ;; マルチキークイックソート ※ 実装は末尾を参照 (let ((words (copy-seq *words*))) (declare (optimize (speed 3) (safety 0) (debug 0) (compilation-speed 0)) (simple-vector words)) (time (length (mqsort:sort words)))) Evaluation took: 0.390 seconds of real time 0.388024 seconds of total run time (0.388024 user, 0.000000 system) 99.49% CPU 776,883,744 processor cycles 0 bytes consed --> 392126
実装
以下、実装ソースコード。
このコメント無し版はhttp://github.com/sile/mqsortにバージョン0.0.1としてあがっている。
まだ未整理。
(defpackage mqsort (:use :common-lisp) (:shadow :common-lisp sort) (:export sort)) (in-package :mqsort) ;;;;;;;;;;;;;;;;;;; ;;;; スペシャル変数 ;; optimize宣言用 (defvar *fastest* '(optimize (speed 3) (safety 0) (debug 0))) (defvar *interface* '(optimize (speed 3) (safety 1) (debug 1))) ;;;;;;;;;;; ;;;; 型定義 (deftype array-index () `(mod ,array-dimension-limit)) ; 配列添字用の数値型 (deftype most-efficient-string () '(simple-array character)) ; SBCLで効率良く扱える文字列の型 ;;;;;;;;;;;;;;;;;;; ;;;; インライン宣言 (declaim (inline sort sv-sort partition set-pivot-at-front swap-range swap-if-greater)) ;;;;;;;;;;;;;;;; ;;;; マクロ/関数 ;; コンパイル時の警告出力を抑制する (defmacro muffle (exp) `(locally (declare #+SBCL (sb-ext:muffle-conditions sb-ext:compiler-note)) ,exp)) ;; 型情報付きのsvref (defmacro sref (vector index) `(the most-efficient-string (svref ,vector ,index))) ;; 配列(ary)のstart1から始まる要素とstart2から始まる要素をcount分だけ入れ替える (defun swap-range (ary &key start1 start2 count) (loop REPEAT count FOR i OF-TYPE array-index FROM start1 FOR j OF-TYPE array-index FROM start2 DO (rotatef (sref ary i) (sref ary j)))) ;; もしary[x] < ary[y]なら両者を交換する (2要素ソート) (defun swap-if-greater (ary x y depth) (when (string> (sref ary x) (sref ary y) :start1 depth :start2 depth) (rotatef (sref ary x) (sref ary y))) ary) ;; 分割に用いられるピボット要素を選択して、対象領域の先頭(= ary[beg])にセットする (defun set-pivot-at-front (ary beg end depth) (flet ((code (i &aux (s (sref ary i))) (if (>= depth (length s)) -1 (char-code (char s depth)))) (set-pivot (pos) (rotatef (sref ary beg) (sref ary pos)))) (declare (inline code set-pivot)) ;; ary[beg..end]の先頭、中央、末尾の三要素を比較して、その中央値をピボットとする (let* ((mid (+ beg (floor (- end beg) 2))) (las (1- end)) (a (code beg)) (b (code mid)) (c (code las))) (if (< a b) (when (< a c) (if (< b c) (set-pivot mid) (set-pivot las))) (if (< b c) (set-pivot mid) (unless (< a c) (set-pivot las))))))) ;; ary[beg..end]を三つに分割する (defun partition (ary beg end depth) (flet ((code (i &aux (s (sref ary i))) (if (>= depth (length s)) -1 (char-code (char s depth))))) (declare (inline code)) (set-pivot-at-front ary beg end depth) ; ピボット要素の選択 (let* ((pivot (code beg)) (ls-front (1+ beg)) (ls-last (1+ beg)) (gt-front (1- end)) (gt-last (1- end))) (declare (array-index ls-front ls-last gt-front gt-last)) ;; 分割ループ ;; - この段階では、配列を以下の四つに分割する ;; -- 1] 前方: ピボットと等しい要素 ;; -- 2] 中央左: ピボットより小さい要素 ;; -- 3] 中央右: ピボットより大きい要素 ;; -- 4] 後方: ピボットと等しい要素 ;; - ループを抜けた後に、1と4が併合され中央に移動されることで、三分割となる (loop ;; ピボットより大きい要素を前方から探索する (loop WHILE (<= ls-last gt-front) FOR code = (code ls-last) WHILE (<= code pivot) DO (when (= code pivot) ;; 途中で見つけたピボットと等しい要素は前方に寄せる (rotatef (sref ary ls-front) (sref ary ls-last)) (incf ls-front)) (incf ls-last)) ;; ピボットより小さい要素を後方から探索する (loop WHILE (<= ls-last gt-front) FOR code = (code gt-front) WHILE (>= code pivot) DO (when (= code pivot) ;; 途中で見つけたピボットと等しい要素は後方に寄せる (rotatef (sref ary gt-front) (sref ary gt-last)) (decf gt-last)) (decf gt-front)) (when (> ls-last gt-front) ; 小なり探索と大なり探索が交差したらループ終了 (return)) ;; 前方にある大なり要素と後方にある小なり要素を交換する (rotatef (sref ary ls-last) (sref ary gt-front)) (incf ls-last) (decf gt-front)) ;; 四分割した領域の両端を中央に移動して、三分割にする (let ((ls-beg ls-front) (ls-end ls-last) (gt-beg ls-last) (gt-end (1+ gt-last))) (let ((len (min (- ls-beg beg) (- ls-end ls-beg)))) (swap-range ary :start1 beg :start2 (- ls-end len) :count len)) ; 前方の等値要素を中央に (let ((len (min (- end gt-end) (- gt-end gt-beg)))) (swap-range ary :start1 gt-beg :start2 (- end len) :count len)) ; 後方の等値要素を中央に (values (+ beg (- ls-end ls-beg)) ; 小なり領域の終端 = 等値領域の始端 (- end (- gt-end gt-beg))))))) ; 等値領域の終端 = 大なり領域の始端 ;; 文字列の配列(simple-vector)をソートする (defun sv-sort-impl (ary beg end depth &aux (len (- end beg))) (declare #.*fastest* (array-index beg end depth)) (if (<= len 2) (if (= len 2) (swap-if-greater ary beg (1+ beg) depth) ; 範囲が2なら専用の関数でソートを行う(処理速度向上のため) ary) ; 範囲が1以下ならソート不要 ;; 分割 & 再帰ソート (multiple-value-bind (eql-beg eql-end) (partition ary beg end depth) ; 分割 (sv-sort-impl ary beg eql-beg depth) ; 小なり領域再帰 (when (< depth (length (sref ary eql-beg))) (sv-sort-impl ary eql-beg eql-end (1+ depth))) ; 等値領域再帰 (sv-sort-impl ary eql-end end depth)))) ; 大なり領域再帰 ;; ソート関数 (defun sv-sort(ary) (sv-sort-impl ary 0 (length ary) 0)) ;; ソート関数 ;; str-arrayをsimple-vector型に確実に変換して、sv-sort関数に渡す ;; ※ str-arrayの各要素が文字列型かどうかのチェックを行っていないので不完全 (defun sort (str-array) (declare #.*interface* (vector str-array)) (etypecase str-array (simple-vector (sv-sort str-array)) (vector (muffle (sv-sort (coerce str-array 'simple-vector))))))
