平衡木 : プログラムリスト
●AA 木
;;;
;;; aatree.lsp : 連想配列 (平衡木, AA tree, CLOS 用)
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
(provide :aatree)
(defpackage :aatree (:use :cl))
(in-package :aatree)
(export '(make-treemap
tree-emptyp
tree-count
tree-clear
tree-exists
tree-get
tree-max
tree-min
tree-set
tree-push
tree-pop
tree-del
tree-max-del
tree-min-del
tree-mapc
tree-fold-left
tree-fold-right))
;;; メソッドの宣言
(defgeneric tree-emptyp (tm))
(defgeneric tree-count (tm))
(defgeneric tree-clear (tm))
(defgeneric tree-exists (tm k))
(defgeneric tree-get (tm k))
(defgeneric tree-max (tm))
(defgeneric tree-min (tm))
(defgeneric tree-set (tm k v))
(defgeneric tree-push (tm k v))
(defgeneric tree-pop (tm k))
(defgeneric tree-del (tm k))
(defgeneric tree-max-del (tm))
(defgeneric tree-min-del (tm))
(defgeneric tree-mapc (tm fn))
(defgeneric tree-fold-left (tm a fn))
(defgeneric tree-fold-right (tm a fn))
;;;
;;; 節の定義
;;;
(defclass node ()
((key :accessor node-key :initform nil :initarg :key)
(value :accessor node-value :initform nil :initarg :value)
(height :accessor node-height :initform 1 :initarg :height)
(left :accessor node-left :initform nil :initarg :left)
(right :accessor node-right :initform nil :initarg :right)))
;;; 終端
(defvar empty nil)
;;; 終端の生成
(defun make-empty ()
(when (null empty)
(setf empty (make-instance 'node)
(node-height empty) 0
(node-left empty) empty
(node-right empty) empty))
empty)
;;; 終端のチェック
(defun node-emptyp (node) (eq node empty))
;;;
;;; AA tree のバランス調整
;;;
;;; 右回転
(defun rotate-right (node)
(let ((lnode (node-left node)))
(setf (node-left node) (node-right lnode)
(node-right lnode) node)
lnode))
;;; 左回転
(defun rotate-left (node)
(let ((rnode (node-right node)))
(setf (node-right node) (node-left rnode)
(node-left rnode) node)
rnode))
;;; 左の子が赤の場合
(defun skew (node)
(if (/= (node-height (node-left node)) (node-height node))
node
(rotate-right node)))
;;; 右の孫節が赤の場合
(defun split (node)
(when (= (node-height node)
(node-height (node-right (node-right node))))
(setf node (rotate-left node)
(node-height node) (+ (node-height node) 1)))
node)
;;; 削除したときのバランスチェックと修正
(defun delete-balance (node)
(let ((h (- (node-height node) 1)))
(cond
((or (< (node-height (node-left node)) h)
(< (node-height (node-right node)) h))
(setf (node-height node) h)
(when (> (node-height (node-right node)) h)
(setf (node-height (node-right node)) h))
(setf node (skew node)
(node-right node) (skew (node-right node))
(node-right (node-right node)) (skew (node-right (node-right node)))
node (split node)
(node-right node) (split (node-right node)))))
node))
;;;
;;; 探索
;;;
;;; x と等しいキーを持つ node を返す
(defun node-search (node x elt= elt<)
(cond
((node-emptyp node) empty) ; キーが見つからない場合は空の木を返す
((funcall elt= (node-key node) x) node)
((funcall elt< x (node-key node))
(node-search (node-left node) x elt= elt<))
(t
(node-search (node-right node) x elt= elt<))))
;;; 最小のキーを持つ node を返す
(defun node-search-min (node)
(if (node-emptyp (node-left node))
node
(node-search-min (node-left node))))
;;; 最大のキーを持つ node を返す
(defun node-search-max (node)
(if (node-emptyp (node-right node))
node
(node-search-max (node-right node))))
;;;
;;; 挿入
;;;
;;; キー x と値 vを挿入する
(defun node-insert (node x v elt= elt<)
(cond
((node-emptyp node)
;; 新しい node を挿入する
(make-instance 'node :key x :value v :left empty :right empty))
((funcall elt= (node-key node) x)
;; x と等しいキーがある
(setf (node-value node) v)
(throw 'key-found nil))
((funcall elt< x (node-key node))
(setf (node-left node)
(node-insert (node-left node) x v elt= elt<))
(split (skew node)))
(t
(setf (node-right node)
(node-insert (node-right node) x v elt= elt<))
(split (skew node)))))
;;; キー x の値 (リスト) に v を push する
(defun node-push (node x v elt= elt<)
(cond
((node-emptyp node)
;; 新しい node を挿入する (値は (list v) になる)
(make-instance 'node :key x :value (list v) :left empty :right empty))
((funcall elt= (node-key node) x)
;; x と等しいキーがある
(setf (node-value node) (cons v (node-value node)))
(throw 'key-found nil))
((funcall elt< x (node-key node))
(setf (node-left node)
(node-push (node-left node) x v elt= elt<))
(split (skew node)))
(t
(setf (node-right node)
(node-push (node-right node) x v elt= elt<))
(split (skew node)))))
;;;
;;; 削除
;;;
;;; 最大のキーとその値を削除
(defun node-delete-max (node)
(cond
((node-emptyp (node-right node)) (node-left node))
(t
(setf (node-right node)
(node-delete-max (node-right node)))
(delete-balance node))))
;;; 最小のキーとその値を削除
(defun node-delete-min (node)
(cond
((node-emptyp (node-left node)) (node-right node))
(t
(setf (node-left node)
(node-delete-min (node-left node)))
(delete-balance node))))
;;; キー key と等しい node を削除
(defun node-delete (node key elt= elt<)
(cond
((node-emptyp node)
;; キーが見つからない
(throw 'key-not-found nil))
((funcall elt= key (node-key node))
;; キーを発見
(cond
((node-emptyp (node-left node)) (node-right node))
((node-emptyp (node-right node)) (node-left node))
(t
(let ((del-node (node-search-min (node-right node))))
(setf (node-key node) (node-key del-node)
(node-value node) (node-value del-node)
(node-right node) (node-delete-min (node-right node)))
(delete-balance node)))))
((funcall elt< key (node-key node))
(setf (node-left node)
(node-delete (node-left node) key elt= elt<))
(delete-balance node))
(t
(setf (node-right node)
(node-delete (node-right node) key elt= elt<))
(delete-balance node))))
;;;
;;; 高階関数
;;;
;;; 巡回
(defun node-traverse (func node)
(cond
((not (node-emptyp node))
(node-traverse func (node-left node))
(funcall func (node-key node) (node-value node))
(node-traverse func (node-right node)))))
;;; 畳み込み (左部分木から)
(defun node-fold-left (func a node)
(if (node-emptyp node)
a
(let ((b (node-fold-left func a (node-left node))))
(node-fold-left func (funcall func b (node-key node) (node-value node)) (node-right node)))))
;;; 畳み込み (右部分木から)
(defun node-fold-right (func a node)
(if (node-emptyp node)
a
(let ((b (node-fold-right func a (node-right node))))
(node-fold-right func (funcall func b (node-key node) (node-value node)) (node-left node)))))
;;;
;;; treemap の定義
;;;
(defclass treemap ()
((root :accessor tree-root :initform nil :initarg :root)
(size :accessor tree-size :initform 0 :initarg :size)
(elt= :accessor tree-elt= :initform nil :initarg :elt=)
(elt< :accessor tree-elt< :initform nil :initarg :elt<)))
;;; コンストラクタ
(defun make-treemap (elt= elt<)
(make-instance 'treemap :root (make-empty) :elt= elt= :elt< elt<))
;;; treemap は空か？
(defmethod tree-emptyp ((tm treemap)) (node-emptyp (tree-root tm)))
;;; treemap のデータ数を返す
(defmethod tree-count ((tm treemap)) (tree-size tm))
;;; treemap を空にする
(defmethod tree-clear ((tm treemap))
(setf (tree-root tm) empty
(tree-size tm) 0))
;;; キーが存在すれば t を返す
(defmethod tree-exists ((tm treemap) key)
(not (node-emptyp (node-search (tree-root tm) key (tree-elt= tm) (tree-elt< tm)))))
;;; キーの値を返す (見つからない場合は nil を返す)
(defmethod tree-get ((tm treemap) key)
(node-value (node-search (tree-root tm) key (tree-elt= tm) (tree-elt< tm))))
;;; 最大の (key . val) を返す
(defmethod tree-max ((tm treemap))
(if (tree-emptyp tm)
nil
(let ((node (node-search-max (tree-root tm))))
(cons (node-key node) (node-value node)))))
;;; 最小の (key . val) を返す
(defmethod tree-min ((tm treemap))
(if (tree-emptyp tm)
nil
(let ((node (node-search-min (tree-root tm))))
(cons (node-key node) (node-value node)))))
;;; キーと値をセットする
;;; 新規追加の場合は t を返す。同じキーを見つけたら、値を書き換えて nil を返す
(defmethod tree-set ((tm treemap) key value)
(catch 'key-found
(setf (tree-root tm)
(node-insert (tree-root tm) key value (tree-elt= tm) (tree-elt< tm)))
(incf (tree-size tm))
t))
;;; キーが新規の場合、キーの値に (list value) を追加して t を返す
;;; キーが存在する場合、その先頭に value を追加して nil を返す
(defmethod tree-push ((tm treemap) key value)
(catch 'key-found
(setf (tree-root tm)
(node-push (tree-root tm) key value (tree-elt= tm) (tree-elt< tm)))
(incf (tree-size tm))
t))
;;; キーが存在して値がリストの場合、リストからデータを pop する
;;; それ以外は nil を返す
(defmethod tree-pop ((tm treemap) key)
(let ((node (node-search (tree-root tm) key (tree-elt= tm) (tree-elt< tm))))
(when (consp (node-value node))
(pop (node-value node)))))
;;; キーとその値を削除して t を返す
;;; キーが見つからない場合は nil を返す
(defmethod tree-del ((tm treemap) key)
(catch 'key-not-found
(setf (tree-root tm)
(node-delete (tree-root tm) key (tree-elt= tm) (tree-elt< tm)))
(decf (tree-size tm))
t))
;;; 最大の key, value を削除して t を返す
(defmethod tree-max-del ((tm treemap))
(unless (tree-emptyp tm)
(setf (tree-root tm) (node-delete-max (tree-root tm)))
(decf (tree-size tm))
t))
;;; 最小の key, value を削除して t を返す
(defmethod tree-min-del ((tm treemap))
(unless (tree-emptyp tm)
(setf (tree-root tm) (node-delete-min (tree-root tm)))
(decf (tree-size tm))
t))
;;; キーと値に関数 fn を適用する
(defmethod tree-mapc ((tm treemap) fn)
(node-traverse fn (tree-root tm)))
;;; 左部分木からの畳み込み
(defmethod tree-fold-left ((tm treemap) a fn)
(node-fold-left fn a (tree-root tm)))
;;; 右部分木からの畳み込み
(defmethod tree-fold-right ((tm treemap) a fn)
(node-fold-right fn a (tree-root tm)))
●赤黒木
;;;
;;; rbtree.lsp : 連想配列 (赤黒木, CLOS 版)
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
(provide :rbtree)
(defpackage :rbtree (:use :cl))
(in-package :rbtree)
(export '(make-treemap
tree-emptyp
tree-count
tree-clear
tree-exists
tree-get
tree-max
tree-min
tree-set
tree-push
tree-pop
tree-del
tree-max-del
tree-min-del
tree-mapc
tree-fold-left
tree-fold-right))
;;; メソッドの宣言
(defgeneric tree-emptyp (tm))
(defgeneric tree-count (tm))
(defgeneric tree-clear (tm))
(defgeneric tree-exists (tm k))
(defgeneric tree-get (tm k))
(defgeneric tree-max (tm))
(defgeneric tree-min (tm))
(defgeneric tree-set (tm k v))
(defgeneric tree-push (tm k v))
(defgeneric tree-pop (tm k))
(defgeneric tree-del (tm k))
(defgeneric tree-max-del (tm))
(defgeneric tree-min-del (tm))
(defgeneric tree-mapc (tm fn))
(defgeneric tree-fold-left (tm a fn))
(defgeneric tree-fold-right (tm a fn))
;;; 終端
(defvar empty nil)
;;;
;;; 節の定義
;;;
(defclass node ()
((key :accessor node-key :initform nil :initarg :key)
(value :accessor node-value :initform nil :initarg :value)
(color :accessor node-color :initform 'red :initarg :color)
(left :accessor node-left :initform empty :initarg :left)
(right :accessor node-right :initform empty :initarg :right)))
;;; 終端の生成
(defun make-empty ()
(when (null empty)
(setf empty
(make-instance 'node :color 'black :left nil :right nil)))
empty)
;;; 終端のチェック
(defun node-emptyp (node) (eq node empty))
;;; 色のチェック
(defun node-blackp (node) (eq (node-color node) 'black))
(defun node-redp (node) (eq (node-color node) 'red))
;;;
;;; バランスの修正処理
;;;
;;; 右回転
(defun rotate-right (node)
(let ((lnode (node-left node)))
(setf (node-left node) (node-right lnode)
(node-right lnode) node
(node-color lnode) (node-color node)
(node-color node) 'red)
lnode))
;;; 左回転
(defun rotate-left (node)
(let ((rnode (node-right node)))
(setf (node-right node) (node-left rnode)
(node-left rnode) node
(node-color rnode) (node-color node)
(node-color node) 'red)
rnode))
;;; 4node の分割
(defun node-split (node)
(setf (node-color node) 'red
(node-color (node-left node)) 'black
(node-color (node-right node)) 'black))
;;; 左部分木の修正
(defun balance-insert-left (node flag)
(unless flag
(when (node-blackp node)
(setf flag t)
;; 左(赤)の子に赤があるか
(when (node-redp (node-right (node-left node)))
(setf (node-left node)
(rotate-left (node-left node))))
(when (node-redp (node-left (node-left node)))
;; 赤が 2 つ続く
(if (node-redp (node-right node))
(progn
(node-split node)
(setf flag nil))
(setf node (rotate-right node))))))
(values node flag))
(defun balance-delete-left (node flag)
(unless flag
(cond
((and (node-blackp (node-left (node-right node)))
(node-blackp (node-right (node-right node))))
;; right is 2 node
(cond
((node-blackp (node-right node))
;; node is 2 node
(setf (node-color (node-right node)) 'red)
(when (node-blackp node)
(return-from balance-delete-left (values node nil)))
(setf (node-color node) 'black))
(t
;; node is 3 node
(setf node (rotate-left node)
(node-left node) (balance-delete-left (node-left node) nil)))))
(t
;; right is 3, 4 node
(when (node-redp (node-left (node-right node)))
(setf (node-right node) (rotate-right (node-right node))))
(setf node (rotate-left node)
(node-color (node-left node)) 'black
(node-color (node-right node)) 'black))))
(values node t))
;;; 右部分木の修正
(defun balance-insert-right (node flag)
(unless flag
(when (node-blackp node)
(setf flag t)
;; 右(赤)の子に赤があるか
(when (node-redp (node-left (node-right node)))
(setf (node-right node)
(rotate-right (node-right node))))
(when (node-redp (node-right (node-right node)))
;; 赤が 2 つ続く
(if (node-redp (node-left node))
(progn
(node-split node)
(setf flag nil))
(setf node (rotate-left node))))))
(values node flag))
(defun balance-delete-right (node flag)
(unless flag
(cond
((and (node-blackp (node-left (node-left node)))
(node-blackp (node-right (node-left node))))
(cond
((node-blackp (node-left node))
;; left is 2 node
(setf (node-color (node-left node)) 'red)
(when (node-blackp node)
(return-from balance-delete-right (values node nil)))
(setf (node-color node) 'black))
(t
(setf node (rotate-right node)
(node-right node) (balance-delete-right (node-right node) nil)))))
(t
;; node is 3, 4 node
(when (node-redp (node-right (node-left node)))
(setf (node-left node)
(rotate-left (node-left node))))
(setf node (rotate-right node)
(node-color (node-right node)) 'black
(node-color (node-left node)) 'black))))
(values node t))
;;;
;;; 探索
;;;
(defun node-search (node key elt= elt<)
(cond
((node-emptyp node) empty)
((funcall elt= key (node-key node)) node)
((funcall elt< key (node-key node))
(node-search (node-left node) key elt= elt<))
(t
(node-search (node-right node) key elt= elt<))))
;;; 最小のキーを持つ node を返す
(defun node-search-min (node)
(if (node-emptyp (node-left node))
node
(node-search-min (node-left node))))
;;; 最大のキーを持つ node を返す
(defun node-search-max (node)
(if (node-emptyp (node-right node))
node
(node-search-max (node-right node))))
;;;
;;; 挿入
;;;
(defun node-insert (node key x elt= elt<)
(cond
((node-emptyp node)
;; 新しい節を挿入する
(values (make-instance 'node :key key :value x) nil))
((funcall elt= key (node-key node))
;; 同じキーを見つけたので値を書き換える
(setf (node-value node) x)
(throw 'key-found nil))
((funcall elt< key (node-key node))
;; 左部分木をたどる
(multiple-value-bind
(node1 flag)
(node-insert (node-left node) key x elt= elt<)
(setf (node-left node) node1)
(multiple-value-setq (node1 flag) (balance-insert-left node flag))
(values node1 flag)))
(t
;; 右部分木をたどる
(multiple-value-bind
(node1 flag)
(node-insert (node-right node) key x elt= elt<)
(setf (node-right node) node1)
(multiple-value-setq (node1 flag) (balance-insert-right node flag))
(values node1 flag)))))
(defun node-push (node key x elt= elt<)
(cond
((node-emptyp node)
;; 新しい節を挿入する
(values (make-instance 'node :key key :value (list x)) nil))
((funcall elt= key (node-key node))
;; 同じキーを見つけたので値を書き換える
(setf (node-value node) (cons x (node-value node)))
(throw 'key-found nil))
((funcall elt< key (node-key node))
;; 左部分木をたどる
(multiple-value-bind
(node1 flag)
(node-push (node-left node) key x elt= elt<)
(setf (node-left node) node1)
(multiple-value-setq (node1 flag) (balance-insert-left node flag))
(values node1 flag)))
(t
;; 右部分木をたどる
(multiple-value-bind
(node1 flag)
(node-push (node-right node) key x elt= elt<)
(setf (node-right node) node1)
(multiple-value-setq (node1 flag) (balance-insert-right node flag))
(values node1 flag)))))
;;;
;;; 削除
;;;
;;; 最大のキーとその値を削除
(defun node-delete-max (node)
(cond
((node-emptyp (node-right node))
(cond
((node-emptyp (node-left node))
(values empty (node-redp node)))
(t
(setf (node-color (node-left node)) 'black)
(values (node-left node) t))))
(t
(multiple-value-bind
(node1 flag)
(node-delete-max (node-right node))
(setf (node-right node) node1)
(multiple-value-setq (node1 flag) (balance-delete-right node flag))
(values node1 flag)))))
;;; 最小のキーとその値を削除
(defun node-delete-min (node)
(cond
((node-emptyp (node-left node))
(cond
((node-emptyp (node-right node))
(values empty (node-redp node)))
(t
(setf (node-color (node-right node)) 'black)
(values (node-right node) t))))
(t
(multiple-value-bind
(node1 flag)
(node-delete-min (node-left node))
(setf (node-left node) node1)
(multiple-value-setq (node1 flag) (balance-delete-left node flag))
(values node1 flag)))))
;;; キー key と等しい node を削除
(defun node-delete (node key elt= elt<)
(cond
((node-emptyp node)
(throw 'key-not-found nil))
((funcall elt= key (node-key node))
(cond
((and (node-emptyp (node-left node))
(node-emptyp (node-right node)))
(values empty (node-redp node)))
((node-emptyp (node-right node))
(setf (node-color (node-left node)) 'black)
(values (node-left node) t))
((node-emptyp (node-left node))
(setf (node-color (node-right node)) 'black)
(values (node-right node) t))
(t
(let ((del-node (node-search-min (node-right node))))
(setf (node-key node) (node-key del-node)
(node-value node) (node-value del-node))
(multiple-value-bind
(node1 flag)
(node-delete-min (node-right node))
(setf (node-right node) node1)
(multiple-value-setq (node1 flag) (balance-delete-right node flag))
(values node1 flag))))))
((funcall elt< key (node-key node))
(multiple-value-bind
(node1 flag)
(node-delete (node-left node) key elt= elt<)
(setf (node-left node) node1)
(multiple-value-setq (node1 flag) (balance-delete-left node flag))
(values node1 flag)))
(t
(multiple-value-bind
(node1 flag)
(node-delete (node-right node) key elt= elt<)
(setf (node-right node) node1)
(multiple-value-setq (node1 flag) (balance-delete-right node flag))
(values node1 flag)))))
;;;
;;; 高階関数
;;;
;;; 巡回
(defun node-traverse (func node)
(cond
((not (node-emptyp node))
(node-traverse func (node-left node))
(funcall func (node-key node) (node-value node))
(node-traverse func (node-right node)))))
;;; 畳み込み (左部分木から)
(defun node-fold-left (func a node)
(if (node-emptyp node)
a
(let ((b (node-fold-left func a (node-left node))))
(node-fold-left func (funcall func b (node-key node) (node-value node)) (node-right node)))))
;;; 畳み込み (右部分木から)
(defun node-fold-right (func a node)
(if (node-emptyp node)
a
(let ((b (node-fold-right func a (node-right node))))
(node-fold-right func (funcall func b (node-key node) (node-value node)) (node-left node)))))
;;;
;;; 連想配列 (赤黒木) の定義
;;;
(defclass treemap ()
((root :accessor tree-root :initform nil :initarg :root)
(size :accessor tree-size :initform 0 :initarg :size)
(elt= :accessor tree-elt= :initform nil :initarg :elt=)
(elt< :accessor tree-elt< :initform nil :initarg :elt<)))
;;; コンストラクタ
(defun make-treemap (elt= elt<)
(make-instance 'treemap :root (make-empty) :elt= elt= :elt< elt<))
;;; treemap は空か？
(defmethod tree-emptyp ((tm treemap)) (node-emptyp (tree-root tm)))
;;; treemap のデータ数を返す
(defmethod tree-count ((tm treemap)) (tree-size tm))
;;; treemap を空にする
(defmethod tree-clear ((tm treemap))
(setf (tree-root tm) empty
(tree-size tm) 0))
;;; キーが存在すれば t を返す
(defmethod tree-exists ((tm treemap) key)
(not (node-emptyp (node-search (tree-root tm) key (tree-elt= tm) (tree-elt< tm)))))
;;; キーの値を返す (見つからない場合は nil を返す)
(defmethod tree-get ((tm treemap) key)
(node-value (node-search (tree-root tm) key (tree-elt= tm) (tree-elt< tm))))
;;; 最大の (key . val) を返す
(defmethod tree-max ((tm treemap))
(if (tree-emptyp tm)
nil
(let ((node (node-search-max (tree-root tm))))
(cons (node-key node) (node-value node)))))
;;; 最小の (key . val) を返す
(defmethod tree-min ((tm treemap))
(if (tree-emptyp tm)
nil
(let ((node (node-search-min (tree-root tm))))
(cons (node-key node) (node-value node)))))
;;; キーと値をセットする
;;; 新規追加の場合は t を返す。同じキーを見つけたら、値を書き換えて nil を返す
(defmethod tree-set ((tm treemap) key value)
(catch 'key-found
(setf (tree-root tm) (node-insert (tree-root tm) key value (tree-elt= tm) (tree-elt< tm))
(node-color (tree-root tm)) 'black)
(incf (tree-size tm))
t))
;;; キーが新規の場合、キーの値に (list value) を追加して t を返す
;;; キーが存在する場合、その先頭に value を追加して nil を返す
(defmethod tree-push ((tm treemap) key value)
(catch 'key-found
(setf (tree-root tm) (node-push (tree-root tm) key value (tree-elt= tm) (tree-elt< tm))
(node-color (tree-root tm)) 'black)
(incf (tree-size tm))
t))
;;; キーが存在して値がリストの場合、リストからデータを pop する
;;; それ以外は nil を返す
(defmethod tree-pop ((tm treemap) key)
(let ((node (node-search (tree-root tm) key (tree-elt= tm) (tree-elt< tm))))
(when (consp (node-value node))
(pop (node-value node)))))
;;; キーとその値を削除して t を返す
;;; キーが見つからない場合は nil を返す
(defmethod tree-del ((tm treemap) key)
(catch 'key-not-found
(setf (tree-root tm) (node-delete (tree-root tm) key (tree-elt= tm) (tree-elt< tm))
(node-color (tree-root tm)) 'black)
(decf (tree-size tm))
t))
;;; 最大の key, value を削除して t を返す
(defmethod tree-max-del ((tm treemap))
(unless (tree-emptyp tm)
(setf (tree-root tm) (node-delete-max (tree-root tm)))
(decf (tree-size tm))
t))
;;; 最小の key, value を削除して t を返す
(defmethod tree-min-del ((tm treemap))
(unless (tree-emptyp tm)
(setf (tree-root tm) (node-delete-min (tree-root tm)))
(decf (tree-size tm))
t))
;;; キーと値に関数 fn を適用する
(defmethod tree-mapc ((tm treemap) fn)
(node-traverse fn (tree-root tm)))
;;; 左部分木からの畳み込み
(defmethod tree-fold-left ((tm treemap) a fn)
(node-fold-left fn a (tree-root tm)))
;;; 右部分木からの畳み込み
(defmethod tree-fold-right ((tm treemap) a fn)
(node-fold-right fn a (tree-root tm)))
●スプレー木
;;;
;;; splay.lsp : スプレー木 (Top Down Splay, CLOS 用)
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
(provide :splay)
(defpackage :splay (:use :cl))
(in-package :splay)
(export '(make-treemap
tree-emptyp
tree-count
tree-clear
tree-exists
tree-get
tree-max
tree-min
tree-set
tree-push
tree-pop
tree-del
tree-max-del
tree-min-del
tree-mapc
tree-fold-left
tree-fold-right))
;;; メソッドの定義
(defgeneric tree-emptyp (tm))
(defgeneric tree-count (tm))
(defgeneric tree-clear (tm))
(defgeneric tree-exists (tm k))
(defgeneric tree-get (tm k))
(defgeneric tree-max (tm))
(defgeneric tree-min (tm))
(defgeneric tree-set (tm k v))
(defgeneric tree-push (tm k v))
(defgeneric tree-pop (tm k))
(defgeneric tree-del (tm k))
(defgeneric tree-max-del (tm))
(defgeneric tree-min-del (tm))
(defgeneric tree-mapc (tm fn))
(defgeneric tree-fold-left (tm a fn))
(defgeneric tree-fold-right (tm a fn))
;;;
;;; 節の定義 (終端は nil)
;;;
(defclass node ()
((key :accessor node-key :initform nil :initarg :key)
(value :accessor node-value :initform nil :initarg :value)
(left :accessor node-left :initform nil :initarg :left)
(right :accessor node-right :initform nil :initarg :right)))
;;;
;;; splay 操作関数
;;;
;;; 右回転
(defun rotate-right (node)
(let ((lnode (node-left node)))
(setf (node-left node) (node-right lnode)
(node-right lnode) node)
lnode))
;;; 左回転
(defun rotate-left (node)
(let ((rnode (node-right node)))
(setf (node-right node) (node-left rnode)
(node-left rnode) node)
rnode))
;;; Top-Down Splay
(defun node-splay (node key elt= elt<)
(let* ((wnode (make-instance 'node)) ; Splay 作業用セル
(rnode wnode) ; rnode は右部分木になる節を追加する
(lnode wnode)) ; lnode は左部分木になる節を追加する
(loop
(cond
((funcall elt= key (node-key node)) (return))
((funcall elt< key (node-key node))
;; node は右部分木になる
(cond
((null (node-left node)) (return))
((funcall elt< key (node-key (node-left node)))
;; 右回転
(setf node (rotate-right node))
(when (null (node-left node)) (return))))
(setf (node-left rnode) node
rnode node
node (node-left node)))
(t
;; node は左部分木になる
(cond
((null (node-right node)) (return))
((funcall elt< (node-key (node-right node)) key)
;; 左回転
(setf node (rotate-left node))
(when (null (node-right node)) (return))))
(setf (node-right lnode) node
lnode node
node (node-right node)))))
(setf (node-left rnode) (node-right node)
(node-right lnode) (node-left node)
(node-left node) (node-right wnode)
(node-right node) (node-left wnode))
node))
;;;
;;; 探索
;;;
;;; 最大値の探索
(defun node-search-max (node)
(let* ((wnode (make-instance 'node)) ; Splay 作業用セル
(lnode wnode)) ; lnode は左部分木になる節を追加する
(loop
(when (null (node-right node)) (return))
;; node は左部分木になる
;; 左回転
(setf node (rotate-left node))
(when (null (node-right node)) (return))
(setf (node-right lnode) node
lnode node
node (node-right node)))
(setf (node-right lnode) (node-left node)
(node-left node) (node-right wnode))
node))
;;; 最小値の探索
(defun node-search-min (node)
(let* ((wnode (make-instance 'node)) ; Splay 作業用セル
(rnode wnode)) ; rnode は右部分木になる節を追加する
(loop
(when (null (node-left node)) (return))
;; node は右部分木になる
;; 右回転
(setf node (rotate-right node))
(when (null (node-left node)) (return))
(setf (node-left rnode) node
rnode node
node (node-left node)))
(setf (node-left rnode) (node-right node)
(node-right node) (node-left wnode))
node))
;;;
;;; 高階関数
;;;
;;; 巡回
(defun node-traverse (fn node)
(cond
(node
(node-traverse fn (node-left node))
(funcall fn (node-key node) (node-value node))
(node-traverse fn (node-right node)))))
;;; 畳み込み
(defun node-fold-left (func a node)
(if (null node)
a
(let ((b (node-fold-left func a (node-left node))))
(node-fold-left func (funcall func b (node-key node) (node-value node)) (node-right node)))))
(defun node-fold-right (func a node)
(if (null node)
a
(let ((b (node-fold-right func a (node-right node))))
(node-fold-right func (funcall func b (node-key node) (node-value node)) (node-left node)))))
;;;
;;; 連想配列 (スプレイ木)
;;;
(defclass treemap ()
((root :accessor tree-root :initform nil :initarg :root)
(size :accessor tree-size :initform 0 :initarg :size)
(elt= :accessor tree-elt= :initform nil :initarg :elt=)
(elt< :accessor tree-elt< :initform nil :initarg :elt<)))
;;; コンストラクタ
(defun make-treemap (elt= elt<)
(make-instance 'treemap :elt= elt= :elt< elt<))
;;; 木は空か？
(defmethod tree-emptyp ((tm treemap)) (null (tree-root tm)))
;;; 木の要素数を返す
(defmethod tree-count ((tm treemap)) (tree-size tm))
;;; 木を空にする
(defmethod tree-clear ((tm treemap))
(setf (tree-root tm) nil
(tree-size tm) 0))
;;; 木に key があるか？
(defmethod tree-exists ((tm treemap) key)
(with-slots
(root elt= elt<) tm
(unless (null root)
(setf root (node-splay root key elt= elt<))
(funcall elt= key (node-key root)))))
;;; キーの値を求める
(defmethod tree-get ((tm treemap) key)
(with-slots
(root elt= elt<) tm
(unless (null root)
(setf root (node-splay root key elt= elt<))
(when (funcall elt= key (node-key root))
(node-value root)))))
;;; 最大のキーとその値を求める
(defmethod tree-max ((tm treemap))
(with-slots
(root) tm
(unless (null root)
(setf root (node-search-max root))
(cons (node-key root) (node-value root)))))
;;; 最小のキーとその値を求める
(defmethod tree-min ((tm treemap))
(with-slots
(root) tm
(unless (null root)
(setf root (node-search-min root))
(cons (node-key root) (node-value root)))))
;;; root に新しい node を追加する
(defun insert-new-node (root node elt<)
(if (funcall elt< (node-key node) (node-key root))
(setf (node-left node) (node-left root)
(node-right node) root
(node-left root) nil)
(setf (node-left node) root
(node-right node) (node-right root)
(node-right root) nil))
node)
;;; キーと値を挿入する
(defmethod tree-set ((tm treemap) key value)
(with-slots
(root size elt= elt<) tm
(cond
((null root)
;; 最初のデータ
(setf root (make-instance 'node :key key :value value))
(incf size)
t)
(t
(setf root (node-splay root key elt= elt<))
(cond
((funcall elt= key (node-key root))
;; 同じキーを発見
(setf (node-value root) value)
nil)
(t
;; 新規追加
(let ((node (make-instance 'node :key key :value value)))
(setf root (insert-new-node root node elt<)))
(incf size)
t))))))
;;; キーの値に value を push する
(defmethod tree-push ((tm treemap) key value)
(with-slots
(root size elt= elt<) tm
(cond
((null root)
;; 最初のデータ
(setf root (make-instance 'node :key key :value (list value)))
(incf size)
t)
(t
(setf root (node-splay root key elt= elt<))
(cond
((funcall elt= key (node-key root))
;; 同じキーを発見
(setf (node-value root) (cons value (node-value root)))
nil)
(t
;; 新規追加
(let ((node (make-instance 'node :key key :value (list value))))
(setf root (insert-new-node root node elt<)))
(incf size)
t))))))
;;; キーの値からデータを pop する
(defmethod tree-pop ((tm treemap) key)
(with-slots
(root elt= elt<) tm
(unless (null root)
(setf root (node-splay root key elt= elt<))
(when (and (funcall elt= key (node-key root))
(consp (node-value root)))
(pop (node-value root))))))
;;; 木から key とその値を削除する
(defmethod tree-del ((tm treemap) key)
(with-slots
(root size elt= elt<) tm
(unless (null root)
(setf root (node-splay root key elt= elt<))
(when (funcall elt= key (node-key root))
(cond
((null (node-left root))
(setf root (node-right root)))
((null (node-right root))
(setf root (node-left root)))
(t
(let ((node (node-splay (node-left root) key elt= elt<)))
(setf (node-right node) (node-right root)
root node))))
(decf size)
t))))
;;; 最大のキーと値を削除
(defmethod tree-max-del ((tm treemap))
(unless (tree-emptyp tm)
(let ((node (node-search-max (tree-root tm))))
(setf (tree-root tm) (node-left node))
(decf (tree-size tm))
(cons (node-key node) (node-value node)))))
;;; 最小のキーと値を削除
(defmethod tree-min-del ((tm treemap))
(unless (tree-emptyp tm)
(let ((node (node-search-min (tree-root tm))))
(setf (tree-root tm) (node-right node))
(decf (tree-size tm))
(cons (node-key node) (node-value node)))))
;;; 巡回
(defmethod tree-mapc ((tm treemap) fn)
(node-traverse fn (tree-root tm)))
;;; 左部分木から畳み込む
(defmethod tree-fold-left ((tm treemap) a fn)
(node-fold-left fn a (tree-root tm)))
;;; 右部分木から畳み込む
(defmethod tree-fold-right ((tm treemap) a fn)
(node-fold-right fn a (tree-root tm)))