Common Lisp Programming

treemap

赤黒木 (red-black tree) とスプレー木 (splay tree) を使って連想配列を実装したライブラリです。アルゴリズムの詳しい説明は以下に示す拙作のページをお読みくださいませ。

• Algorithms with Python
• 赤黒木 [1], [2]
• スプレー木 [1]

●インストール

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

• treemap.lisp
• treemap.asd
• treemap_tst.lisp
• treemap_tst.asd

●仕様

• パッケージ名 :treemap
• クラス名: treemap (赤黒木)
• コンストラクタ: make-treemap elt= elt< => treemap
• クラス名: splaytree (スプレー木)
• コンストラクタ: make-splaytree elt= elt< => splaytree
• elt= x y には x と y が等しいとき真を返す述語を、elt< x y には x が y より小さいとき真を返す述語を渡す。
• treemap-p tm => t or nil
  引数 tm の型が treemap であれば真を返す
• splaytree-p tm => t or nil
  引数 tm の型が splaytree であれば真を返す

• 共通の操作メソッド
• tree-emptyp tm => t or nil
  連想配列 tm が空であれば真を返す。そうでなければ偽を返す。
• tree-count tm => integer
  連想配列 tm の要素数を返す。
• tree-clear tm => 0
  連想配列 tm を空にする。
• tree-exists tm key => t or nil
  連想配列 tm にキー key が存在すれば真を返す。そうでなければ偽を返す。
• tree-get tm key => value
  連想配列 tm にキー key が存在すればその値 value を取得する。key が見つからない場合は nil を返す。
• tree-max tm, tree-min tm => (key . value)
  連想配列 tm の最大 (または最小) のキー key とその値 value を求める。
  返り値は (key . value) で、tm が空の場合は偽を返す。
• tree-set tm key value => t or nil
連想配列 tm にキー key とその値 value を追加する。新しく key と value を追加したときは真を返す。
key が存在する場合、既存の値を value に更新して偽を返す。
• tree-push tm key value => t or nil
連想配列 tm にキー key の値 xs が存在する場合、その値を (cons value xs) に書き換えて偽を返す。
key が存在しない場合、tm に key とリスト (value) を追加して真を返す。
• tree-pop tm key => value
  連想配列 tm のキー key の値がリスト xs の場合、(car xs) を返して、値を (cdr xs) に書き換える。
  それ以外の場合は何もせずに偽を返す。
• tree-del tm key => t or nil
  連想配列 tm からキー key とその値を削除して真を返す。key が見つからない場合は偽を返す。
• tree-max-del tm => t or nil
  tree-min-del tm => => t or nil
  連想配列 tm から最大 (または最小) のキーとその値を削除して真を返す。tm が空の場合は偽を返す。
• tree-mapc tm fn => nil
  連想配列 tm のキー key と値 value に関数 fn を適用する。fn の第 1 引数が key で、第 2 引数が value になる。
• tree-fold-left tm a fn => obj
  tree-fold-right tm a fn => obj
  連想配列 tm の畳み込みを行う。left は左部分木から、right は右部分木から行う。
  関数 fn の第 1 引数が累積値、第 2 引数が key で、第 3 引数が value になる。

●簡単なテスト

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

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

(TREEMAP-P (SETQ TS (MAKE-TREEMAP #'STRING= #'STRING<)))
=> T OK

(TREE-EMPTYP TS)
=> T OK

(TREE-COUNT TS)
=> 0 OK

(PROGN
 (SETQ KS '(foo bar baz oops)
       VS '(10 20 30 40))
 (MAPC (LAMBDA (K V) (TREE-SET TS K V)) KS VS)
 (TREE-COUNT TS))
=> 4 OK

(TREE-EMPTYP TS)
=> NIL OK

(MAPCAR (LAMBDA (K) (TREE-EXISTS TS K)) '(foo Foo))
=> (T NIL) OK

(MAPCAR (LAMBDA (K) (TREE-EXISTS TS K)) KS)
=> (T T T T) OK

(MAPCAR (LAMBDA (K) (TREE-GET TS K)) '(foo Foo))
=> (10 NIL) OK

(MAPCAR (LAMBDA (K) (TREE-GET TS K)) KS)
=> (10 20 30 40) OK

(TREE-MIN TS)
=> (bar . 20) OK

(TREE-MAX TS)
=> (oops . 40) OK

(LET ((A NIL))
  (TREE-MAPC TS (LAMBDA (K V) (PUSH (CONS K V) A)))
  (REVERSE A))
=> ((bar . 20) (baz . 30) (foo . 10) (oops . 40)) OK

(TREE-FOLD-RIGHT TS NIL (LAMBDA (A K V) (CONS (CONS K V) A)))
=> ((bar . 20) (baz . 30) (foo . 10) (oops . 40)) OK

(TREE-FOLD-LEFT TS NIL (LAMBDA (A K V) (CONS (CONS K V) A)))
=> ((oops . 40) (foo . 10) (baz . 30) (bar . 20)) OK

(TREE-MAX-DEL TS)
=> T OK

(TREE-COUNT TS)
=> 3 OK

(TREE-MAX TS)
=> (foo . 10) OK

(TREE-MIN-DEL TS)
=> T OK

(TREE-COUNT TS)
=> 2 OK

(TREE-MIN TS)
=> (baz . 30) OK

(TREE-DEL TS foo)
=> T OK

(TREE-COUNT TS)
=> 1 OK

(TREE-MIN TS)
=> (baz . 30) OK

(TREE-MAX TS)
=> (baz . 30) OK

(TREE-DEL TS baz)
=> T OK

(TREE-COUNT TS)
=> 0 OK

(TREE-EMPTYP TS)
=> T OK

(TREE-MAX TS)
=> NIL OK

(TREE-MIN TS)
=> NIL OK

(PROGN (MAPC (LAMBDA (K V) (TREE-PUSH TS K V)) KS VS) (TREE-COUNT TS))
=> 4 OK

(TREE-PUSH TS Foo 0)
=> T OK

(TREE-COUNT TS)
=> 5 OK

(TREE-GET TS Foo)
=> (0) OK

(TREE-PUSH TS Foo 1)
=> NIL OK

(TREE-COUNT TS)
=> 5 OK

(TREE-GET TS Foo)
=> (1 0) OK

(TREE-POP TS Foo)
=> 1 OK

(TREE-POP TS Foo)
=> 0 OK

(TREE-POP TS Foo)
=> NIL OK

(TREE-COUNT TS)
=> 5 OK

(TREE-DEL TS Foo)
=> T OK

(TREE-COUNT TS)
=> 4 OK

(TREE-CLEAR TS)
=> 0 OK

(TREE-COUNT TS)
=> 0 OK

(TREE-EMPTYP TS)
=> T OK

(SPLAYTREE-P (SETQ TS (MAKE-SPLAYTREE #'STRING= #'STRING<)))
=> T OK

;;; テスト結果は treemap と同じなので省略

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

●簡単なテスト (その２)

;;;
;;; testrbtree.lisp : 赤黒木のテスト
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :utils)
(use-package :utils)
(require :treemap)
(use-package :treemap)

;;; 赤黒木のチェック
(defun check-rbtree (node)
  (cond
   ((treemap::node-emptyp node) 0)
   (t
    (when (treemap::node-redp node)
      (when (or (treemap::node-redp (treemap::node-left node))
                (treemap::node-redp (treemap::node-right node)))
        (error "treemap error1")))
    (let ((a (check-rbtree (treemap::node-left node)))
          (b (check-rbtree (treemap::node-right node))))
      (when (/= a b)
        (error "treemap error2"))
      (when (treemap::node-blackp node)
        (incf a))
      a))))

(defun test-sub (xs)
  (let ((a (make-treemap #'= #'<)))
    (print "insert")
    (dolist (x xs)
      (tree-set a x t)
      (check-rbtree (treemap::tree-root a)))
    (print (tree-emptyp a))
    (print (tree-count a))
    (print "search")
    (dolist (x xs)
      (if (not (tree-get a x))
          (error "test search error")))
    (print "delete")
    (dolist (x xs)
         (tree-del a x)
         (check-rbtree (treemap::tree-root a)))
    (print (tree-emptyp a))
    (print (tree-count a))))

(defun test (n)
  (print "昇順")
  (test-sub (iota n))
  (print "逆順")
  (test-sub (nreverse (iota n)))
  (print "ランダム")
  (test-sub (tabulate (lambda (x) (random 1d0)) n)))

;;;
;;; 表示
;;;
(defun print-rb-tree (n node)
  (unless (treemap::node-emptyp node)
    (print-rb-tree (1+ n) (treemap::node-left node))
    (dotimes (x n) (princ "  "))
    (format t "(~A, ~A)~%" (treemap::node-key node) (treemap::node-color node))
    (print-rb-tree (1+ n) (treemap::node-right node))))

(defun print-tree (tm)
  (format t "--------~%")
  (print-rb-tree 0 (treemap::tree-root tm)))

(defun test1 (xs)
  (let ((a (make-treemap #'= #'<)))
    (dolist (x xs)
      (tree-set a x t)
      (print-tree a))
    (dolist (x xs)
      (format t "~A~%" (tree-exists a x)))
    (dolist (x xs)
      (tree-del a x)
      (print-tree a))))

(load "testrbtree.lisp")
T

*(test 10000)

"昇順"
"insert"
NIL
10000
"search"
"delete"
T
0
"逆順"
"insert"
NIL
10000
"search"
"delete"
T
0
"ランダム"
"insert"
NIL
10000
"search"
"delete"
T
0
0

* (test1 (iota 8))
--------
(0, BLACK)
--------
(0, BLACK)
  (1, RED)
--------
  (0, RED)
(1, BLACK)
  (2, RED)
--------
  (0, BLACK)
(1, BLACK)
  (2, BLACK)
    (3, RED)
--------
  (0, BLACK)
(1, BLACK)
    (2, RED)
  (3, BLACK)
    (4, RED)
--------
  (0, BLACK)
(1, BLACK)
    (2, BLACK)
  (3, RED)
    (4, BLACK)
      (5, RED)
--------
  (0, BLACK)
(1, BLACK)
    (2, BLACK)
  (3, RED)
      (4, RED)
    (5, BLACK)
      (6, RED)
--------
    (0, BLACK)
  (1, RED)
    (2, BLACK)
(3, BLACK)
    (4, BLACK)
  (5, RED)
    (6, BLACK)
      (7, RED)
T
T
T
T
T
T
T
T
--------
  (1, BLACK)
    (2, RED)
(3, BLACK)
    (4, BLACK)
  (5, RED)
    (6, BLACK)
      (7, RED)
--------
  (2, BLACK)
(3, BLACK)
    (4, BLACK)
  (5, RED)
    (6, BLACK)
      (7, RED)
--------
  (3, BLACK)
    (4, RED)
(5, BLACK)
  (6, BLACK)
    (7, RED)
--------
  (4, BLACK)
(5, BLACK)
  (6, BLACK)
    (7, RED)
--------
  (5, BLACK)
(6, BLACK)
  (7, BLACK)
--------
(6, BLACK)
  (7, RED)
--------
(7, BLACK)
--------
NIL

;;;
;;; testsplay.lisp : スプレー木のテスト
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(require :utils)
(use-package :utils)
(require :treemap)
(use-package :treemap)

(defun test-sub (xs)
  (let ((a (make-splaytree #'= #'<)))
    (print "insert")
    (dolist (x xs)
      (tree-set a x t))
    (print (tree-emptyp a))
    (print (tree-count a))
    (print "search")
    (dolist (x xs)
      (if (not (tree-get a x))
          (error "test search error")))
    (print "delete")
    (dolist (x xs)
         (tree-del a x))
    (print (tree-emptyp a))
    (print (tree-count a))))

(defun test (n)
  (print "昇順")
  (test-sub (iota n))
  (print "逆順")
  (test-sub (nreverse (iota n)))
  (print "ランダム")
  (test-sub (tabulate (lambda (x) (random 1d0)) n)))

;;;
;;; 表示
;;;
(defun print-splay-tree (n node)
  (unless (null node)
    (print-splay-tree (1+ n) (treemap::node-left node))
    (dotimes (x n) (princ "  "))
    (format t "(~A, ~A)~%" (treemap::node-key node) (treemap::node-value node))
    (print-splay-tree (1+ n) (treemap::node-right node))))

(defun print-tree (tm)
  (format t "--------~%")
  (print-splay-tree 0 (treemap::tree-root tm)))

(defun test1 (xs)
  (let ((a (make-splaytree #'= #'<)))
    (dolist (x xs)
      (tree-set a x t)
      (print-tree a))
    (dolist (x xs)
      (format t "~A~%" (tree-exists a x))
      (print-tree a))
    (dolist (x xs)
      (tree-del a x)
      (print-tree a))))

(load "testsplay.lisp")
T

* (test 10000)

"昇順"
"insert"
NIL
10000
"search"
"delete"
T
0
"逆順"
"insert"
NIL
10000
"search"
"delete"
T
0
"ランダム"
"insert"
NIL
10000
"search"
"delete"
T
0
0

* (test1 (iota 8))
--------
(0, T)
--------
  (0, T)
(1, T)
--------
    (0, T)
  (1, T)
(2, T)
--------
      (0, T)
    (1, T)
  (2, T)
(3, T)
--------
        (0, T)
      (1, T)
    (2, T)
  (3, T)
(4, T)
--------
          (0, T)
        (1, T)
      (2, T)
    (3, T)
  (4, T)
(5, T)
--------
            (0, T)
          (1, T)
        (2, T)
      (3, T)
    (4, T)
  (5, T)
(6, T)
--------
              (0, T)
            (1, T)
          (2, T)
        (3, T)
      (4, T)
    (5, T)
  (6, T)
(7, T)
T
--------
(0, T)
        (1, T)
      (2, T)
        (3, T)
    (4, T)
      (5, T)
  (6, T)
    (7, T)
T
--------
  (0, T)
(1, T)
    (2, T)
      (3, T)
  (4, T)
      (5, T)
    (6, T)
      (7, T)
T
--------
    (0, T)
  (1, T)
(2, T)
    (3, T)
  (4, T)
      (5, T)
    (6, T)
      (7, T)
T
--------
      (0, T)
    (1, T)
  (2, T)
(3, T)
  (4, T)
      (5, T)
    (6, T)
      (7, T)
T
--------
        (0, T)
      (1, T)
    (2, T)
  (3, T)
(4, T)
    (5, T)
  (6, T)
    (7, T)
T
--------
          (0, T)
        (1, T)
      (2, T)
    (3, T)
  (4, T)
(5, T)
  (6, T)
    (7, T)
T
--------
            (0, T)
          (1, T)
        (2, T)
      (3, T)
    (4, T)
  (5, T)
(6, T)
  (7, T)
T
--------
              (0, T)
            (1, T)
          (2, T)
        (3, T)
      (4, T)
    (5, T)
  (6, T)
(7, T)
--------
      (1, T)
    (2, T)
      (3, T)
  (4, T)
    (5, T)
(6, T)
  (7, T)
--------
  (2, T)
    (3, T)
(4, T)
    (5, T)
  (6, T)
    (7, T)
--------
  (3, T)
(4, T)
    (5, T)
  (6, T)
    (7, T)
--------
(4, T)
    (5, T)
  (6, T)
    (7, T)
--------
  (5, T)
(6, T)
  (7, T)
--------
(6, T)
  (7, T)
--------
(7, T)
--------
NIL

●サンプルプログラム

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

;;; リストの比較 (xs と ys は同じ長さ)
(defun list< (xs ys)
  (cond
   ((null xs) nil)
   ((< (car xs) (car ys)) t)
   ((> (car xs) (car ys)) nil)
   (t
    (list< (cdr xs) (cdr ys)))))

;;; 点 (x y z) を作る
(defun make-point ()
  (list (random 100) (random 100) (random 100)))

;;;
;;; 異なる点を n 個作る
;;;

;;; 線形探索
(defun make-data (n)
  (do ((a nil))
      ((zerop n) a)
      (let ((xs (make-point)))
        (unless (member xs a :test #'equal)
          (decf n)
          (push xs a)))))

;;; ハッシュ
(defun make-data-hash (n)
  (do ((a (make-hash-table :test #'equal)))
      ((zerop n) a)
      (let ((xs (make-point)))
        (unless (gethash xs a)
          (decf n)
          (setf (gethash xs a) t)))))

;;; 赤黒木
(defun make-data-rbtree (n)
  (do ((a (make-treemap #'equal #'list<)))
      ((zerop n) a)
      (let ((xs (make-point)))
        (unless (tree-exists a xs)
          (decf n)
          (tree-set a xs t)))))

;;; スプレー木
(defun make-data-splay (n)
  (do ((a (make-splaytree #'equal #'list<)))
      ((zerop n) a)
      (let ((xs (make-point)))
        (unless (tree-exists a xs)
          (decf n)
          (tree-set a xs t)))))

     表 : 実行結果 (単位 : 秒)

   個数    : 10000 : 20000 :  40000
-----------+-------+-------+--------
 線形探索  : 0.629 : 2.500 : 10.240
 ハッシュ  : 0.003 : 0.007 :  0.011
  赤黒木   : 0.030 : 0.050 :  0.120
スプレー木 : 0.030 : 0.060 :  0.169

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

●プログラムリスト

;;;
;;; treemap.lisp : 連想配列 (赤黒木, スプレー木)
;;;
;;; Copyright (C) 2023 Makoto Hiroi
;;;
;;; Released under the MIT license
;;; https://opensource.org/license/mit/
;;;
(provide :treemap)
(defpackage :treemap (:use :cl))
(in-package :treemap)
(export '(make-treemap
          make-splaytree
          treemap-p
          splaytree-p
          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))

;;; 作業用メソッド
(defgeneric node-emptyp (node))
(defgeneric rotate-left (node))
(defgeneric rotate-right (node))
(defgeneric node-search-max (node))
(defgeneric node-search-min (node))

;;;
;;; スプレー木
;;;

;;; 節の定義 (終端は nil)
(defclass snode ()
  ((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)))

;;; 終端か？
;;; (高階関数で使用, 操作関数は null でチェック)
(defmethod node-emptyp ((node snode)) (null node))
(defmethod node-emptyp ((node null)) t)

;;;
;;; splay 操作関数
;;;

;;; 右回転
(defmethod rotate-right ((node snode))
  (let ((lnode (node-left node)))
    (setf (node-left node) (node-right lnode)
          (node-right lnode) node)
    lnode))

;;; 左回転
(defmethod rotate-left ((node snode))
  (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 'snode)) ; 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))

;;;
;;; 探索
;;;

;;; 最大値の探索
(defmethod node-search-max ((node snode))
  (let* ((wnode (make-instance 'snode)) ; 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))

;;; 最小値の探索
(defmethod node-search-min ((node snode))
  (let* ((wnode (make-instance 'snode)) ; 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 (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 splaytree ()
  ((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-splaytree (elt= elt<)
  (make-instance 'splaytree :elt= elt= :elt< elt<))

;;; 型述語
(defun splaytree-p (x) (typep x 'splaytree))

;;; 木は空か？
(defmethod tree-emptyp ((tm splaytree)) (null (tree-root tm)))

;;; 木の要素数を返す
(defmethod tree-count ((tm splaytree)) (tree-size tm))

;;; 木を空にする
(defmethod tree-clear ((tm splaytree))
  (setf (tree-root tm) nil
        (tree-size tm) 0))

;;; 木に key があるか？
(defmethod tree-exists ((tm splaytree) 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 splaytree) 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 splaytree))
  (with-slots
   (root) tm
   (unless (null root)
     (setf root (node-search-max root))
     (cons (node-key root) (node-value root)))))

;;; 最小のキーとその値を求める
(defmethod tree-min ((tm splaytree))
  (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 splaytree) key value)
  (with-slots
   (root size elt= elt<) tm
   (cond
    ((null root)
     ;; 最初のデータ
     (setf root (make-instance 'snode :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 'snode :key key :value value)))
         (setf root (insert-new-node root node elt<)))
       (incf size)
       t))))))

;;; キーの値に value を push する
(defmethod tree-push ((tm splaytree) key value)
  (with-slots
   (root size elt= elt<) tm
   (cond
    ((null root)
     ;; 最初のデータ
     (setf root (make-instance 'snode :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 'snode :key key :value (list value))))
         (setf root (insert-new-node root node elt<)))
       (incf size)
       t))))))

;;; キーの値からデータを pop する
(defmethod tree-pop ((tm splaytree) 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 splaytree) 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 splaytree))
  (unless (tree-emptyp tm)
    (let ((node (node-search-max (tree-root tm))))
      (setf (tree-root tm) (node-left node))
      (decf (tree-size tm))
      t)))

;;; 最小のキーと値を削除
(defmethod tree-min-del ((tm splaytree))
  (unless (tree-emptyp tm)
    (let ((node (node-search-min (tree-root tm))))
      (setf (tree-root tm) (node-right node))
      (decf (tree-size tm))
      t)))

;;; 巡回
(defmethod tree-mapc ((tm splaytree) fn)
  (node-traverse fn (tree-root tm)))

;;; 左部分木から畳み込む
(defmethod tree-fold-left ((tm splaytree) a fn)
  (node-fold-left fn a (tree-root tm)))

;;; 右部分木から畳み込む
(defmethod tree-fold-right ((tm splaytree) a fn)
  (node-fold-right fn a (tree-root tm)))

;;;
;;; 赤黒木
;;;

;;; 終端
(defvar empty nil)

;;; 節の定義
(defclass rbnode (snode)
  ((color :accessor node-color :initform 'red  :initarg :color)))

;;; 終端の生成
(defun make-empty ()
  (when (null empty)
    (setf empty
          (make-instance 'rbnode :color 'black)))
  empty)

;;; 終端のチェック
(defmethod node-emptyp ((node rbnode)) (eq node empty))

;;; 色のチェック
(defun node-blackp (node) (eq (node-color node) 'black))
(defun node-redp (node) (eq (node-color node) 'red))

;;;
;;; バランスの修正処理
;;;

;;; 右回転
(defmethod rotate-right ((node rbnode))
  (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))

;;; 左回転
(defmethod rotate-left ((node rbnode))
  (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 を返す
(defmethod node-search-min ((node rbnode))
  (if (node-emptyp (node-left node))
      node
    (node-search-min (node-left node))))

;;; 最大のキーを持つ node を返す
(defmethod node-search-max ((node rbnode))
  (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 'rbnode :key key :value x :left empty :right empty) 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 'rbnode :key key :value (list x) :left empty :right empty) 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)))))

;;;
;;; 連想配列 (赤黒木) の定義
;;;
(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<))

;;; 型述語
(defun treemap-p (x) (typep x 'treemap))

;;; 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)))

リスト : treemap.asd

(defsystem "treemap"
  :description "tree mapping (red-black tree, splay tree)"
  :version "0.1.0"
  :author "Makoto Hiroi"
  :license "MIT"
  :depends-on ()
  :in-order-to ((test-op (test-op :treemap_tst)))
  :components ((:file "treemap")))

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

(defvar ts nil)
(defvar ks nil)
(defvar vs nil)

(defun test-sub ()
  (run (tree-emptyp ts) t)
  (run (tree-count ts) 0)
  (run (progn
         (setq ks '("foo" "bar" "baz" "oops")
               vs '(10 20 30 40))
         (mapc (lambda (k v) (tree-set ts k v)) ks vs)
         (tree-count ts))
       4)
  (run (tree-emptyp ts) nil)
  (run (mapcar (lambda (k) (tree-exists ts k)) '("foo" "Foo")) '(t nil))
  (run (mapcar (lambda (k) (tree-exists ts k)) ks) '(t t t t))
  (run (mapcar (lambda (k) (tree-get ts k)) '("foo" "Foo")) '(10 nil))
  (run (mapcar (lambda (k) (tree-get ts k)) ks) '(10 20 30 40))
  (run (tree-min ts) '("bar" . 20))
  (run (tree-max ts) '("oops" . 40))
  (run (let ((a nil))
         (tree-mapc ts (lambda (k v) (push (cons k v) a)))
         (reverse a))
       '(("bar" . 20) ("baz" . 30) ("foo" . 10) ("oops" . 40)))
  (run (tree-fold-right ts nil (lambda (a k v) (cons (cons k v) a)))
       '(("bar" . 20) ("baz" . 30) ("foo" . 10) ("oops" . 40)))
  (run (tree-fold-left ts nil (lambda (a k v) (cons (cons k v) a)))
       (reverse '(("bar" . 20) ("baz" . 30) ("foo" . 10) ("oops" . 40))))
  (run (tree-max-del ts) t)
  (run (tree-count ts) 3)
  (run (tree-max ts) '("foo" . 10))
  (run (tree-min-del ts) t)
  (run (tree-count ts) 2)
  (run (tree-min ts) '("baz" . 30))
  (run (tree-del ts "foo") t)
  (run (tree-count ts) 1)
  (run (tree-min ts) '("baz" . 30))
  (run (tree-max ts) '("baz" . 30))
  (run (tree-del ts "baz") t)
  (run (tree-count ts) 0)
  (run (tree-emptyp ts) t)
  (run (tree-max ts) nil)
  (run (tree-min ts) nil)
  (run (progn
         (mapc (lambda (k v) (tree-push ts k v)) ks vs)
         (tree-count ts))
       4)
  (run (tree-push ts "Foo" 0) t)
  (run (tree-count ts) 5)
  (run (tree-get ts "Foo") '(0))
  (run (tree-push ts "Foo" 1) nil)
  (run (tree-count ts) 5)
  (run (tree-get ts "Foo") '(1 0))
  (run (tree-pop ts "Foo") 1)
  (run (tree-pop ts "Foo") 0)
  (run (tree-pop ts "Foo") nil)
  (run (tree-count ts) 5)
  (run (tree-del ts "Foo") t)
  (run (tree-count ts) 4)
  (run (tree-clear ts) 0)
  (run (tree-count ts) 0)
  (run (tree-emptyp ts) t))

(defun test ()
  (initial)
  (run (treemap-p (setq ts (make-treemap #'string= #'string<))) t)
  (test-sub)
  (run (splaytree-p (setq ts (make-splaytree #'string= #'string<))) t)
  (test-sub)
  (final))

リスト : treemap_tst.asd

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