お気楽 Common Lisp プログラミング入門

heap

「ヒープ (heap)」は「半順序木 (partial ordered tree)」と呼ばれる木構造の一種で、普通は二分木を使った二分ヒープのことを指します。ヒープを利用すると、最小値をすぐに見つけることができ、新しくデータを挿入する場合も、高々要素の個数 (n) の対数 (log₂ n) に比例する程度の時間で済みます。

ヒープは配列を使って簡単に実装することができます。また、二分木を使ったヒープの実装では Leftist Heap と Skew Heap というアルゴリズムがあります。今回のライブラリ heap には 3 種類のヒープが実装されています。アルゴリズムの詳しい説明は、以下の拙作のページをお読みくださいませ。

Common Lisp 入門:
ヒープとハフマン符号
Haskell 入門:
ヒープ (2), (Leftist Heap, Skew Heap)

●インストール

アーカイブファイル minlib.tar.gz をインストールする、またはプログラムリストにある以下の 4 つのファイルを、~/common-lisp/ 以下の適当なサブディレクトリ (たとえば heap など) に配置してください。

heap.lisp
heap.asd
heap_tst.lisp
heap_tst.asd

●仕様

パッケージ名 :heap
コンストラクタとデータ型

make-heap => heap
heap (配列を使った実装) を生成する
make-liftist-heap => liftist-heap
Listist Heap を生成する
make-skew-heap => skew-heap
Skew Heap を生成する
キーワード引数

:key, 比較するデータを取得する (デフォルトは identity)
:elt>, elt> x y は x が y より大きいとき真を返す (make-heap のみ, デフォルトは >)
:elt<, elt< x y は x が y より小さいとき真を返す (デフォルトは <)

型述語

heap-p h => t or nil
引数 h が heap 型であれば真を返す
liftist-heap-p h => t or nil
引数 h が liftist-heap 型であれば真を返す
skew-heap-p h => t or nil
引数 h が skew-heap 型であれば真を返す

共通の操作メソッド
heap-push h x
ヒープ h にデータ x を追加する
heap-pop h
ヒープ h からデータを取り出す
heap-peek h
ヒープ h の先頭データを参照する
heap-copy h
ヒープ h をコピーする (heap 型は遅い)
heap-merge h1 h2
ヒープ h1 と h2 を併合 (merge) した新しいヒープを返す (heap 型は遅い)
heap-count h
ヒープ h に格納されている要素数を返す
heap-clear h
ヒープ h を空にする
heap-emptyp h
ヒープ h が空ならば真を返す

●簡単なテスト

* (asdf:test-system :heap)
; compiling file ... 略 ...

----- test start -----

(HEAP-P (SETQ H (MAKE-HEAP)))
=> T OK

(HEAP-EMPTYP H)
=> T OK

(HEAP-COUNT H)
=> 0 OK

(DOLIST (X '(5 6 4 7 3 8 2 9 1 0) (HEAP-COUNT H)) (HEAP-PUSH H X))
=> 10 OK

(HEAP-EMPTYP H)
=> NIL OK

(HEAP-PEEK H)
=> 0 OK

(DO ((A NIL)) ((HEAP-EMPTYP H) (REVERSE A)) (PUSH (HEAP-POP H) A))
=> (0 1 2 3 4 5 6 7 8 9) OK

(HEAP-EMPTYP H)
=> T OK

(HEAP-COUNT H)
=> 0 OK

(HEAP-P (SETQ H (MAKE-HEAP KEY #'CAR ELT> #'<)))
=> T OK

(HEAP-EMPTYP H)
=> T OK

(HEAP-COUNT H)
=> 0 OK

(DOLIST
    (X '((5 A) (6 B) (4 C) (7 D) (0 E) (3 F) (8 G) (2 H) (9 I) (1 J))
       (HEAP-COUNT H))
  (HEAP-PUSH H X))
=> 10 OK

(HEAP-EMPTYP H)
=> NIL OK

(HEAP-PEEK H)
=> (9 I) OK

(DO ((A NIL)) ((HEAP-EMPTYP H) (REVERSE A)) (PUSH (HEAP-POP H) A))
=> ((9 I) (8 G) (7 D) (6 B) (5 A) (4 C) (3 F) (2 H) (1 J) (0 E)) OK

(HEAP-EMPTYP H)
=> T OK

(HEAP-COUNT H)
=> 0 OK

(HEAP-P (SETQ H1 (MAKE-HEAP)))
=> T OK

(HEAP-P (SETQ H2 (MAKE-HEAP)))
=> T OK

(DOLIST (X '(2 4 0 8 6) (HEAP-COUNT H1)) (HEAP-PUSH H1 X))
=> 5 OK

(DOLIST (X '(3 1 5 9 7) (HEAP-COUNT H2)) (HEAP-PUSH H2 X))
=> 5 OK

(HEAP-COUNT (SETQ H3 (HEAP-MERGE H1 H2)))
=> 10 OK

(DO ((A NIL)) ((HEAP-EMPTYP H3) (REVERSE A)) (PUSH (HEAP-POP H3) A))
=> (0 1 2 3 4 5 6 7 8 9) OK

(LEFTIST-HEAP-P (SETQ H (MAKE-LEFTIST-HEAP)))
=> T OK

; 結果は heap と同じなので省略

(LEFTIST-HEAP-P (SETQ H (MAKE-LEFTIST-HEAP KEY #'CAR ELT< #'>)))
=> T OK

; 結果は heap と同じなので省略

(LEFTIST-HEAP-P (SETQ H1 (MAKE-LEFTIST-HEAP)))
=> T OK

(LEFTIST-HEAP-P (SETQ H2 (MAKE-LEFTIST-HEAP)))
=> T OK

; 結果は heap と同じなので省略

(SKEW-HEAP-P (SETQ H (MAKE-SKEW-HEAP)))
=> T OK

; 結果は leftist-heap と同じなので省略

----- test end -----
TEST: 72
OK: 72
NG: 0
ERR: 0
T

●サンプルプログラム

;;;
;;; sample_heap.lisp : サンプルプログラム
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :utils)
(use-package :utils)
(require :heap)
(use-package :heap)

;;; 簡単なテスト (その２)
(defun test-sub (h buff)
  (let (s e)
    (setq s (get-internal-run-time))
    (dotimes (i (length buff))
      (heap-push h (aref buff i)))
    (do ((x (heap-pop h)))
        ((heap-emptyp h))
        (when (> x (heap-peek h))
          (error "test-pop error"))
        (setf x (heap-pop h)))
    (setq e (get-internal-run-time))
    (format t "~f~%" (float (/ (- e s) internal-time-units-per-second)))))

(defun test (n)
  (let ((buff (make-array n)))
    (dotimes (i n) (setf (aref buff i) (random 1d0)))
    (format t "----- heap test -----~%")
    (test-sub (make-heap) buff)
    (format t "----- leftist heap test -----~%")
    (test-sub (make-leftist-heap) buff)
    (format t "----- skew heap test -----~%")
    (test-sub (make-skew-heap) buff)))

;;;
;;; ソート
;;;

;;; データの生成
(defun make-data (n)
  (do ((n n (1- n))
       (a nil))
      ((zerop n) a)
      (push (random 1d0) a)))

;;; ヒープソート
(defun heap-sort (xs)
  (let ((h (make-heap :elt> #'<)))
    (dolist (x xs) (heap-push h x))
    (do ((a nil))
        ((heap-emptyp h) a)
        (push (heap-pop h) a))))

(defun leftist-heap-sort (xs)
  (let ((h (make-leftist-heap :elt< #'>)))
    (dolist (x xs) (heap-push h x))
    (do ((a nil))
        ((heap-emptyp h) a)
        (push (heap-pop h) a))))

(defun skew-heap-sort (xs)
  (let ((h (make-skew-heap :elt< #'<)))
    (dolist (x xs) (heap-push h x))
    (do ((a nil))
        ((heap-emptyp h) a)
        (push (heap-pop h) a))))

;;; イントロソート (quick sort + heap sort)
(defun intro-sort (xs &optional (depth 0))
  (cond
   ((null (cdr xs)) xs)
   ((> depth 18)
    (heap-sort xs))
   (t
    (multiple-value-bind
     (ys zs)
     (partition (lambda (x) (< x (car xs))) (cdr xs))
     (append (intro-sort ys (1+ depth))
             (cons (car xs) (intro-sort zs (1+ depth))))))))

(defun test-sort-sub (func data)
  (let ((s (get-internal-run-time)) e)
    (funcall func data)
    (setf e (get-internal-run-time))
    (float (/ (- e s) internal-time-units-per-second))))

(defun test-sort (n)
  (let ((data (make-data n))
        (fs (list #'heap-sort #'leftist-heap-sort #'skew-heap-sort #'intro-sort)))
    (format t "----- random data -----~%")
    (dolist (f fs)
      (format t "~f " (test-sort-sub f data)))
    (format t "~%----- sort data -----~%")
    (setf data (sort data #'<))
    (dolist (f fs)
      (format t "~f " (test-sort-sub f data)))
    (format t "~%----- reverse data -----~%")
    (setf data (reverse data))
    (dolist (f fs)
      (format t "~f " (test-sort-sub f data)))))

* (load "sample_heap.lisp")
T

* (test 100000)
----- heap test -----
0.226559
----- leftist heap test -----
0.302942
----- skew heap test -----
0.255162
NIL

* (test 200000)
----- heap test -----
0.506039
----- leftist heap test -----
0.725579
----- skew heap test -----
0.514637
NIL

* (test 400000)
----- heap test -----
1.159445
----- leftist heap test -----
1.671449
----- skew heap test -----
1.363209
NIL

* (test-sort 100000)
----- random data -----
0.236255 0.293327 0.232409 0.100099
----- sort data -----
0.296272 0.034602 0.264311 0.328634
----- reverse data -----
0.203358 0.359678 0.010844 0.241006
NIL

* (test-sort 200000)
----- random data -----
0.53167 0.751211 0.559291 0.239769
----- sort data -----
0.659985 0.059906 0.760565 0.833823
----- reverse data -----
0.438872 0.825665 0.021632 0.525916
NIL

* (test-sort 400000)
----- random data -----
1.177686 1.72241 1.4076 0.593926
----- sort data -----
1.473107 0.139375 1.808519 1.984675
----- reverse data -----
0.953541 2.044576 0.073662 1.847195
NIL

実行環境 : SBCL 2.1.11, Ubunts 22.04 (WSL2), Intel Core i5-6200U 2.30GHz

●プログラムリスト

;;;
;;; heap.lisp : ヒープ
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :heap)
(defpackage :heap (:use :cl))
(in-package :heap)
(export '(make-heap
          heap-p
          make-leftist-heap
          leftist-heap-p
          make-skew-heap
          skew-heap-p
          heap-push
          heap-pop
          heap-peek
          heap-copy
          heap-merge
          heap-count
          heap-clear
          heap-emptyp))

;;; 総称関数の定義
(defgeneric heap-push (h x))
(defgeneric heap-pop (h))
(defgeneric heap-peek (h))
(defgeneric heap-copy (h))
(defgeneric heap-merge (h1 h2))
(defgeneric heap-count (h))
(defgeneric heap-clear (h))
(defgeneric heap-emptyp (h))

;;; 定義
(defstruct heap
  (buff (make-array 256 :fill-pointer 0 :adjustable t))
  (key  #'identity)
  (elt> #'>))

;;;
;;; 作業用関数
;;;

;;; 要素の比較
(defun elt> (h x y)
  (funcall (heap-elt> h)
           (funcall (heap-key h) (aref (heap-buff h) x))
           (funcall (heap-key h) (aref (heap-buff h) y))))

;;; 要素の交換
(defun swap (buff x y)
  (psetf (aref buff x) (aref buff y)
         (aref buff y) (aref buff x)))

;;; ヒープの構築
(defun upheap (h n)
  (do ((p (floor (1- n) 2) (floor (1- n) 2)))
      ((or (minusp p) (not (elt> h p n))))
      (swap (heap-buff h) p n)
      (setf n p)))

;;; ヒープの再構築
(defun downheap (h n nums)
  (do ((c (+ (* n 2) 1) (+ (* n 2) 1)))
      ((>= c nums))
      (when (and (< (1+ c) nums) (elt> h c (1+ c)))
        (incf c))
      (when (not (elt> h n c))
        (return))
      (swap (heap-buff h) n c)
      (setf n c)))

;;;
;;; 操作関数の定義
;;;

;;; 空か
(defmethod heap-emptyp ((h heap))
  (zerop (fill-pointer (heap-buff h))))

;;; 要素数
(defmethod heap-count ((h heap))
  (fill-pointer (heap-buff h)))

;;; クリア
(defmethod heap-clear ((h heap))
  (setf (fill-pointer (heap-buff h)) 0))

;;; データの追加
(defmethod heap-push ((h heap) x)
  (vector-push-extend x (heap-buff h))
  (upheap h (- (heap-count h) 1)))

;;; 先頭データの参照
(defmethod heap-peek ((h heap))
  (if (heap-emptyp h)
      (error "heap : heap is empty")
    (aref (heap-buff h) 0)))

;;; データの取り出し
(defmethod heap-pop ((h heap))
  (prog1
      (heap-peek h)
    (unless (heap-emptyp h)
      (let ((buff (heap-buff h)))
        (setf (aref buff 0) (vector-pop buff))
        (downheap h 0 (fill-pointer buff))))))

;;; コピー
(defmethod heap-copy ((h heap))
  (let ((newheap (make-heap ::key (heap-key h) :elt> (heap-elt> h))))
    (dotimes (i (heap-count h) newheap)
      (heap-push newheap (aref (heap-buff h) i)))))

;;; ヒープのマージ (遅い)
(defmethod heap-merge ((h1 heap) (h2 heap))
  (unless (and (eq (heap-key h1) (heap-key h2))
               (eq (heap-elt> h1) (heap-elt> h2)))
    (error "heap-merge, can not merge"))
  (let ((h3 (heap-copy h1)))
    (dotimes (i (heap-count h2) h3)
      (heap-push h3 (aref (heap-buff h2) i)))))

;;;
;;; Leftist Heap
;;;

;;; 節の定義, 終端は nil
(defstruct lnode item rank left right)

;;; マージ
(defun merge-lnode-sub (x hs1 hs2)
  (let ((r1 (if (null hs1) 0 (lnode-rank hs1)))
        (r2 (if (null hs2) 0 (lnode-rank hs2))))
    (if (>= r1 r2)
        (make-lnode :item x :rank (1+ r2) :left hs1 :right hs2)
      (make-lnode :item x :rank (1+ r1) :left hs2 :right hs1))))

(defun merge-lnode (hs1 hs2 key elt<)
  (cond
   ((null hs1) hs2)
   ((null hs2) hs1)
   (t
    (let ((x (lnode-item hs1))
          (y (lnode-item hs2)))
      (if (funcall elt< (funcall key x) (funcall key y))
          (merge-lnode-sub x (lnode-left hs1) (merge-lnode (lnode-right hs1) hs2 key elt<))
        (merge-lnode-sub y (lnode-left hs2) (merge-lnode (lnode-right hs2) hs1 key elt<)))))))

;;; 型の定義
(defstruct leftist-heap
  (root nil) (size 0) (key #'identity) (elt< #'<))

;;; ヒープは空か
(defmethod heap-emptyp ((h leftist-heap))
  (null (leftist-heap-root h)))

;;; 要素数を求める
(defmethod heap-count ((h leftist-heap))
  (leftist-heap-size h))

;;; ヒープを空にする
(defmethod heap-clear ((h leftist-heap))
  (setf (leftist-heap-root h) nil
        (leftist-heap-size h) 0))

;;; コピー
(defmethod heap-copy ((h leftist-heap)) (copy-leftist-heap h))

;;; 挿入
(defmethod heap-push ((h leftist-heap) x)
  (setf (leftist-heap-root h)
        (merge-lnode (make-lnode :item x :rank 1 :left nil :right nil)
                     (leftist-heap-root h)
                     (leftist-heap-key h)
                     (leftist-heap-elt< h)))
  (incf (leftist-heap-size h)))

;;; 最小値を取り出す
(defmethod heap-pop ((h leftist-heap))
  (when (heap-emptyp h)
    (error "Leftist Heap is empty"))
  (let ((root (leftist-heap-root h)))
    (prog1
        (lnode-item root)
      (setf (leftist-heap-root h)
            (merge-lnode (lnode-left root)
                         (lnode-right root)
                         (leftist-heap-key h)
                         (leftist-heap-elt< h)))
      (decf (leftist-heap-size h)))))

;;; 最小値を求める
(defmethod heap-peek ((h leftist-heap))
  (when (heap-emptyp h)
    (error "Leftist Heap is empty"))
  (lnode-item (leftist-heap-root h)))

;;; ヒープのマージ
(defmethod heap-merge ((h1 leftist-heap) (h2 leftist-heap))
  (let ((key (leftist-heap-key h1))
        (elt< (leftist-heap-elt< h1)))
    (unless (and (eq (leftist-heap-key h2) key)
                 (eq (leftist-heap-elt< h2) elt<))
      (error "heap-merge, can not merge"))
    (let ((h3 (make-leftist-heap :key key :elt< elt<)))
      (setf (leftist-heap-root h3)
            (merge-lnode (leftist-heap-root h1)
                         (leftist-heap-root h2)
                         key
                         elt<)
            (leftist-heap-size h3)
            (+ (heap-count h1) (heap-count h2)))
      h3)))

;;;
;;; Skew Heap
;;;

;;; 節の定義, 終端は nil
(defstruct snode item left right)

;;; マージ
(defun merge-snode (hs1 hs2 key elt<)
  (cond
   ((null hs2) hs1)
   ((null hs1) hs2)
   (t
    (let ((x (snode-item hs1))
          (y (snode-item hs2)))
      (if (funcall elt< (funcall key x) (funcall key y))
          (make-snode :item x
                      :left (merge-snode (snode-right hs1) hs2 key elt<)
                      :right (snode-left hs1))
        (make-snode :item y
                    :left (merge-snode (snode-right hs2) hs1 key elt<)
                    :right (snode-left hs2)))))))

;;; 型の定義
(defstruct skew-heap
  (root nil) (size 0) (key #'identity) (elt< #'<))

;;; キューは空か？
(defmethod heap-emptyp ((h skew-heap))
  (null (skew-heap-root h)))

;;; 要素数を求める
(defmethod heap-count ((h skew-heap))
  (skew-heap-size h))

;;; キューを空にする
(defmethod heap-clear ((h skew-heap))
  (setf (skew-heap-root h) nil
        (skew-heap-size h) 0))

;;; コピー
(defmethod heap-copy ((h skew-heap)) (copy-skew-heap h))

;;; 挿入
(defmethod heap-push ((h skew-heap) x)
  (setf (skew-heap-root h)
        (merge-snode (make-snode :item x :left nil :right nil)
                     (skew-heap-root h)
                     (skew-heap-key h)
                     (skew-heap-elt< h)))
  (incf (skew-heap-size h)))

;;; 最小値を取り出す
(defmethod heap-pop ((h skew-heap))
  (when (heap-emptyp h)
    (error "Skew Heap is empty"))
  (let ((root (skew-heap-root h)))
    (prog1
        (snode-item root)
      (setf (skew-heap-root h)
            (merge-snode (snode-left root)
                         (snode-right root)
                         (skew-heap-key h)
                         (skew-heap-elt< h)))
      (decf (skew-heap-size h)))))

;;; 最小値を求める
(defmethod heap-peek ((h skew-heap))
  (when (heap-emptyp h)
    (error "Skew Heap is empty"))
  (snode-item (skew-heap-root h)))

;;; ヒープのマージ
(defmethod heap-merge ((h1 skew-heap) (h2 skew-heap))
  (let ((key (skew-heap-key h1))
        (elt< (skew-heap-elt< h1)))
    (unless (and (eq (skew-heap-key h2) key)
                 (eq (skew-heap-elt< h2) elt<))
      (error "heap-merge, can not merge"))
    (let ((h3 (make-skew-heap :key key :elt< elt<)))
      (setf (skew-heap-root h3)
            (merge-snode (skew-heap-root h1)
                         (skew-heap-root h2)
                         key
                         elt<)
            (skew-heap-size h3)
            (+ (heap-count h1) (heap-count h2)))
      h3)))

リスト : heap.asd

(defsystem :heap
  :description "Heap (プライオリティキュー)"
  :version "0.1.0"
  :author "Makoto Hiroi"
  :license "MIT"
  :depends-on ()
  :in-order-to ((test-op (test-op :heap_tst)))
  :components ((:file "heap")))

;;;
;;; heap_tst.lisp : heap のテスト
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :heap_tst)
(defpackage :heap_tst (:use :cl :mintst :heap))
(in-package :heap_tst)
(export '(test))

(defvar h nil)
(defvar h1 nil)
(defvar h2 nil)
(defvar h3 nil)

(defun test-sub1 ()
  (run (heap-emptyp h) t)
  (run (heap-count h) 0)
  (run (dolist (x '(5 6 4 7 3 8 2 9 1 0) (heap-count h)) (heap-push h x)) 10)
  (run (heap-emptyp h) nil)
  (run (heap-peek h) 0)
  (run (do ((a nil))
           ((heap-emptyp h) (reverse a))
           (push (heap-pop h) a))
       '(0 1 2 3 4 5 6 7 8 9))
  (run (heap-emptyp h) t)
  (run (heap-count h) 0))

(defun test-sub2 ()
  (run (heap-emptyp h) t)
  (run (heap-count h) 0)
  (run (dolist (x '((5 a) (6 b) (4 c) (7 d) (0 e)
                    (3 f) (8 g) (2 h) (9 i) (1 j))
                  (heap-count h))
         (heap-push h x))
       10)
  (run (heap-emptyp h) nil)
  (run (heap-peek h) '(9 i))
  (run (do ((a nil))
           ((heap-emptyp h) (reverse a))
           (push (heap-pop h) a))
       '((9 I) (8 G) (7 D) (6 B) (5 A)
         (4 C) (3 F) (2 H) (1 J) (0 E)))
  (run (heap-emptyp h) t)
  (run (heap-count h) 0))

(defun test-sub3 ()
  (run (dolist (x '(2 4 0 8 6) (heap-count h1)) (heap-push h1 x)) 5)
  (run (dolist (x '(3 1 5 9 7) (heap-count h2)) (heap-push h2 x)) 5)
  (run (heap-count (setq h3 (heap-merge h1 h2))) 10)
  (run (do ((a nil))
           ((heap-emptyp h3) (reverse a))
           (push (heap-pop h3) a))
       '(0 1 2 3 4 5 6 7 8 9)))

(defun test ()
  (initial)
  (run (heap-p (setq h (make-heap))) t)
  (test-sub1)
  (run (heap-p (setq h (make-heap :key #'car :elt> #'<))) t)
  (test-sub2)
  (run (heap-p (setq h1 (make-heap))) t)
  (run (heap-p (setq h2 (make-heap))) t)
  (test-sub3)
  ;;
  (run (leftist-heap-p (setq h (make-leftist-heap))) t)
  (test-sub1)
  (run (leftist-heap-p (setq h (make-leftist-heap :key #'car :elt< #'>))) t)
  (test-sub2)
  (run (leftist-heap-p (setq h1 (make-leftist-heap))) t)
  (run (leftist-heap-p (setq h2 (make-leftist-heap))) t)
  (test-sub3)
  ;;
  (run (skew-heap-p (setq h (make-skew-heap))) t)
  (test-sub1)
  (run (skew-heap-p (setq h (make-skew-heap :key #'car :elt< #'>))) t)
  (test-sub2)
  (run (skew-heap-p (setq h1 (make-skew-heap))) t)
  (run (skew-heap-p (setq h2 (make-skew-heap))) t)
  (test-sub3)
  (final))

リスト : heap_tst.asd

(defsystem :heap_tst
  :description "test for heap"
  :version "0.1.0"
  :author "Makoto Hiroi"
  :license "MIT"
  :depends-on (:mintst :heap)
  :components ((:file "heap_tst"))
  :perform (test-op (o s) (symbol-call :heap_tst :test)))

Common Lisp Programming

お気楽 Common Lisp プログラミング入門 : 自作ライブラリ編

heap

●インストール

●仕様

●簡単なテスト

●サンプルプログラム

●プログラムリスト