pairing heap

ちょっとヒープ(優先順位付きキュー)を使いたくなったので、実装。

とりあえずは、実装が簡単な(かつ性能が良いらしい)pairing-heapを選択。

一群の関数は、後で他のものに変更しやすいようにpackageにまとめておく。

;;; package
(defpackage :pairing-heap
  (:use :cl)
  (:shadow :push :pop)
  (:export :make-heap
	   :push  
	   :pop
	   :empty?))
(in-package :pairing-heap)

;;; struct
(defstruct heap 
  node
  (test #'<)) ; 比較関数

(defstruct node
  element
  childs)     ; nodeのリスト

;;; internal function
;; nodeをマージ
(defun merge-node (n1 n2 <)
  (cond ((null n1) n2)
	((null n2) n1)
	(t (if (funcall < #1=(node-element n1) #2=(node-element n2))
	       (make-node :element #1# :childs (cons n2 (node-childs n1)))
	     (make-node :element #2# :childs (cons n1 (node-childs n2)))))))

;; nodeのリストをマージ
(defun merge-pairs (nodes <)
  (if (null (cdr nodes))
      (car nodes)
    (destructuring-bind (first second . rest) nodes
      (merge-node (merge-node first second <) 
		  (merge-pairs rest <)
		  <))))

;;; external function
(defun push (element heap) 
  (setf (heap-node heap) (merge-node (make-node :element element) 
				     (heap-node heap) 
				     (heap-test heap)))
  heap)

(defun pop (heap)
  (let ((root (heap-node heap)))
    (when root
      (prog1 (node-element root)
	(setf (heap-node heap) (merge-pairs (node-childs root) (heap-test heap)))))))

(defun empty? (heap)
  (null (heap-node heap)))

これで終了。


ついでに、graphviz用の関数も定義しておく。

(defparameter *heap-ppd* (copy-pprint-dispatch))

(set-pprint-dispatch 'heap
  (lambda (stream heap)
    (unless (null (heap-node heap))
      (princ (heap-node heap) stream)))
  0
  *heap-ppd*)

(set-pprint-dispatch 'node
  (lambda (stream node)
    (with-slots (element childs) node
      (format stream "~:{~A -> ~A;~%~}~{~A~}" 
	      (mapcar (lambda (child) `(,element ,(node-element child))) childs)
	      childs)))
  0
  *heap-ppd*)

;;; この出力をdotコマンドに渡す。 ex. `dot -Tgif -o heap.gif heap.dot`
(defun dot-print (heap &optional (stream *standard-output*))
  (let ((*print-pretty* t)
	(*print-pprint-dispatch* *heap-ppd*))
    (format stream "digraph pairing_heap {~%~A}" heap)))


試しに、以下のコードを元に、いくつか画像(ヒープ1〜)を作成してみてみる。

;; dotファイルを作成
(with-open-file (out "heap.dot" :direction :output :if-exists :supersede)
 (let ((heap (make-heap)))
   ;; 0〜31までの数値をheapに追加
   (dotimes (i 32)
     (push i heap))
   ;; (pop heap) ※ ヒープ2以降はこのコメントアウトを外す
   ;; (pop heap) ※ ヒープ3以降はこのコメントアウトを外す
   ;; (pop heap) ※ ヒープ4以降はこのコメントアウトを外す
   (dot-print heap out)))

ヒープ1


ヒープ2: pop 一回


ヒープ3: pop 二回


ヒープ4: pop 三回

pairing-heapは、要素の追加(push)時よりも削除(pop)時に多くのことをしているのだが、それが上の画像にも表れていて面白い。
ヒープ1では、要素0の下に残りの要素がつながっているだけだが、要素を削除するごとに2段目(?)の要素群のマージが行われ、その度にヒープ階層が深くなっていっている*1
ちなみに、この例では、0から順番に要素を追加しているので、このような形となっているが、逆順に追加していった場合は、要素がソートされたただのリストの形となる(削除も先頭から順に行われるだけ)。

*1:ルートノード以下の各ヒープが、-端のものを除き-ランクの等しいbinomial-treeの形をしているのも、-アルゴリズムからして(多分)当然ではあるが-面白い。