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

きくらげ観察日記

好きなことを、適当に。

Gaucheで優先度付きキュー

Gauche

Gaucheの練習。

実は何気に優先度付きキューの実装は初めてだったので、ツリーを配列で管理したほうが楽ということを知らずに若干手こずりました。

(define-class <priority-queue> ()
  ((queue-vector :init-keyword :queue-vector :accessor queue-vector)
   (size :init-keyword :size :accessor size)
   (item<? :init-keyword :item<? :getter get-<?)))

(define (parent-index index) (floor (/ index 2)))
(define (left-index index) (* index 2))
(define (right-index index) (+ (* index 2) 1))
(define root-index 1)

(define (make-priority-queue :key (max-size 20) (item<? <))
  (make <priority-queue>
    :queue-vector (make-vector max-size)
    :size 0
    :item<? item<?))

;;; queueに要素を追加する。
;;; また、内部で確保しているvectorのサイズが足りなくなった場合は、確保し直す。
(define (pq-add-to-last! queue item)
  (define vec (queue-vector queue))
  (define len (vector-length vec))
  (if (<= len (+ (size queue) 1))
      (set! (queue-vector queue) (vector-copy vec 0 (* 2 len))))
  (inc! (size queue))
  (set! (ref (queue-vector queue) (size queue)) item)) ; 1オリジン(0番目は使ってない)

;;; vecのn番目とm番目の要素を入れ替える
(define (vector-swap! vec n m)
  (define item-n (ref vec n))
  (define item-m (ref vec m))
  (set! (ref vec n) item-m)
  (set! (ref vec m) item-n))

;;; index番目の要素がその親より大きかった場合入れ替え、親に対して同様の処理を実行
(define (up-heap queue index)
  (if (<= index 1)
      (undefined) ; ルート要素にたどり着いた
      (let* ((pindex (parent-index index))
             (item (ref (queue-vector queue) index))
             (pitem (ref (queue-vector queue) pindex)))
        (if ((get-<? queue) pitem item)
            (begin
              (vector-swap! (queue-vector queue) index pindex)
              (up-heap queue pindex))))))

;;; index番目の要素がその子より小さかった場合入れ替え、子に対して同様の処理を実行
(define (down-heap queue index)
  (define vec (queue-vector queue))
  (define lindex (left-index index))
  (define rindex (right-index index))
  (define len (size queue))
  (define item<? (get-<? queue))
  (cond
   ((< len lindex) ; 葉にたどり着いた
    (undefined))
   ((< len rindex) ; 左にしか要素がない
    (if (item<? (ref vec index) (ref vec lindex))
        (vector-swap! vec lindex index)))
   ((item<? (ref vec lindex) (ref vec rindex))
    (if (item<? (ref vec index) (ref vec rindex)) ; 右のほうが要素が大きい
        (begin
          (vector-swap! vec rindex index)
          (down-heap queue rindex))))
   (else
    (if (item<? (ref vec index) (ref vec lindex)) ; 左の要素 >= 右の要素
        (begin
          (vector-swap! vec lindex index)
          (down-heap queue lindex))))))

(define (pq-empty? queue)
  (<= (size queue) 0))

;;; queueに要素を挿入する
(define (pq-insert-item! queue item)
  (pq-add-to-last! queue item)
  (up-heap queue (size queue)))

;;; queueから要素を取り出す
(define (pq-dequeue-item! queue)
  (if (<= (size queue) 0)
      (error "empty queue")
      (let ((root (ref (queue-vector queue) root-index))
            (last (ref (queue-vector queue) (size queue))))
        (dec! (size queue))
        (set! (ref (queue-vector queue) root-index) last)
        (down-heap queue root-index)
        root)))

キューの作成時にitem<?を指定することによって、どういった順で取り出すのかを指定できるようになっています。

実行例:

(define (show-example items :optional (item<? <))
  (define queue
    (let ((queue (make-priority-queue :item<? item<?)))
      (map (lambda (item)
             (pq-insert-item! queue item))
           items)
      queue))
  (define after
    (reverse
     (let loop ((results '()))
       (if (pq-empty? queue)
           results
           (loop (cons (pq-dequeue-item! queue) results))))))
  (format #t "before: ~s\n" items)
  (format #t "after:  ~s\n" after))


(show-example '(1 4 2 5 3))
;; before: (1 4 2 5 3)
;; after:  (5 4 3 2 1)

(show-example '(1 4 2 5 3) >)
;; before: (1 4 2 5 3)
;; after:  (1 2 3 4 5)

(show-example '("hoge" "fuga" "foo") string>?)
;; before: ("hoge" "fuga" "foo")
;; after:  ("foo" "fuga" "hoge")

(show-example '("banana" "apple" "strawberry") string>?)
;; before: ("banana" "apple" "strawberry")
;; after:  ("apple" "banana" "strawberry")

(show-example '("banana" "apple" "strawberry")
              (lambda (x y) (< (string-length x) (string-length y))))
;; before: ("banana" "apple" "strawberry")
;; after:  ("strawberry" "banana" "apple")

実行時間の計測もしてみました

(use data.random)
(use gauche.time)
(define generate-random (integers$ 100000000))

(define (bench n)
  ;; +10してるのは特に意味はない(+1以上ならok)
  (define queue (make-priority-queue :max-size (+ n 10)))
  (dolist (i (iota n))
    (pq-insert-item! queue (generate-random)))
  (dolist (i (iota n))
    (pq-dequeue-item! queue)))

(time-this 1 (lambda () (bench 100)))
;; #<time-result 1 times/  0.003 real/  0.000 user/  0.000 sys>

(time-this 1 (lambda () (bench 1000)))
;; #<time-result 1 times/  0.039 real/  0.040 user/  0.000 sys>

(time-this 1 (lambda () (bench 10000)))
;; #<time-result 1 times/  0.520 real/  0.520 user/  0.000 sys>

(time-this 1 (lambda () (bench 100000)))
;; #<time-result 1 times/  7.824 real/ 10.910 user/  0.000 sys>

要素の追加に平均O(1), 先頭要素のdequeueに平均O(logn)かかりますので、計算時間の増え方としてはだいたい(かなり大雑把ですが)

(一つ前の結果 + 定数) * 10

くらいになってくれるはずですので、まあこんなもんでしょう。

それにしても遅い……。