CLでねじれヒープ

何かしらコードを書いていないと元々無い腕がなまるので、「関数プログラミングの楽しみ」を読みながらねじれヒープをHaskellからLispに移植してみました。

;;Define basic types
(defclass <tree> () ())
(defclass <null> (<tree>) ())
(defclass <fork> (<tree>)
  ((item  :initarg :item  :accessor item)
   (left  :type '<tree> :initarg :left  :accessor left)
   (right :type '<tree> :initarg :right :accessor right)))


(defun Fork (x a b)
  (make-instance '<fork>
                 :item x
                 :left a
                 :right b))

(defun Null-Tree ()
  (make-instance '<null>))

(defmethod is-leaf ((fork <fork>))
  (and (is-empty (left fork))
       (is-empty (right fork))))

;;is-Empty
(defmethod is-empty ((fork <null>))
  t)

(defmethod is-empty ((fork <fork>))
  nil)

(defmethod min-elem ((fork <fork>))
  (item fork))

(defmethod delete-elem ((fork <fork>))
  (merge-forks (left fork) (right fork)))

(defmethod insert (x (a <tree>))
  (merge-forks (Fork x (Null-Tree) (Null-Tree))
               a))

(defmethod merge-forks ((a <tree>) (b <null>))
  a)

(defmethod merge-forks ((a <null>) (b <tree>))
  b)

(defmethod join-forks ((a <fork>) (b <tree>))
  (Fork (item a)
        (right a)
        (merge-forks (left a) b)))

(defmethod merge-forks ((a <tree>) (b <tree>))
  (if (<= (min-elem a) (min-elem b))
    (join-forks a b)
    (join-forks b a)))

;;Print tree
(defmethod tree->string ((a <fork>))
  (if (is-leaf a)
    (format nil "~A" (item a))
    (format nil
            "[~A ~A ~A]"
            (item a)
            (tree->string (left a))
            (tree->string (right a)))))

(defmethod tree->string ((a <null>)) "[]")

(defun create-heap (number-list)
  (let ((tree (Fork (car number-list)
                    (Null-Tree) (Null-Tree))))
    (loop for val in (cdr number-list)
          do
          (setf tree (insert val tree)))
    tree))

(defun heap-test (n)
  (let ((tree (Fork 1 (Null-Tree) (Null-Tree))))
    (loop for val from 2 upto n
          do
          (progn 
            (setf tree (insert val tree))
            (format t "~A~%"
                    (tree->string tree))))
    tree))

こんな感じで、ちゃんと紹介されている挿入の流れにそって動作しているのが確認できます。

CL-USER(46): (heap-test 7)
[1 [] 2]
[1 2 3]
[1 3 [2 [] 4]]
[1 [2 [] 4] [3 [] 5]]
[1 [3 [] 5] [2 4 6]]
[1 [2 4 6] [3 5 7]]

CL-USER(4): (tree->string (create-heap '(1 2 5 6 2 4 7)))
"[1 [2 6 4] [2 5 7]]"

それにしても、こういう木構造をターミナル内で綺麗に視覚化するのが大変でなりません。手をぬいて一行で出力するのが一番楽ですねぇ..何か良い方法をご存知の形はコメントをいただけると幸いです。