types.lisp

   1 (in-package :trees)
   2
   3 \f
   4 ;;; tree nodes
   5
   6 ;;; Structures give better performance than CLOS.
   7
   8 (defstruct (tree-node
   9              (:conc-name)
  10              (:constructor make-tree-node (datum))
  11              (:copier nil))
  12   (left nil :type (or null tree-node))
  13   (right nil :type (or null tree-node))
  14   (rank 1 :type fixnum)
  15   (datum nil))
  16
  17 (defstruct (avl-tree-node
  18              (:conc-name)
  19              (:constructor make-avl-node (datum))
  20              (:copier nil)
  21              (:include tree-node))
  22   (balance-info 0 :type (integer -2 2)))
  23
  24 (defconstant +avl-equal+ 0)
  25 (defconstant +avl-leans-left+ -1)
  26 (defconstant +avl-leans-right+ +1)
  27 (defconstant +avl-falls-left+ -2)
  28 (defconstant +avl-falls-right+ +2)
  29
  30 (deftype red-black-color ()
  31   "Keywords denoting red-black tree colors."
  32   '(member :red :black))
  33
  34 (defstruct (red-black-tree-node
  35              (:conc-name)
  36              (:constructor make-red-black-node (datum))
  37              (:copier nil)
  38              (:include tree-node))
  39   (color :red :type red-black-color))
  40
  41 (defstruct (aa-tree-node
  42              (:conc-name)
  43              (:constructor make-aa-node (datum))
  44              (:copier nil)
  45              (:include tree-node))
  46   (level 1 :type fixnum))
  47 \f
  48 ;;; trees
  49
  50 #+sbcl
  51 (defclass binary-tree (sequence standard-object)
  52   ((test :initform #1=(error "missing arg")
  53          :initarg :test
  54          :type 'function
  55          :reader test)
  56    (key :initform #1#
  57         :initarg :key
  58         :type 'function
  59         :reader key)
  60    (pred :initform #1#
  61          :initarg :pred
  62          :type 'function
  63          :reader pred)
  64    (size :initform 0
  65          :initarg :size
  66          :type 'fixnum
  67          :accessor size)
  68    (root :initform nil
  69          :initarg :root
  70          :type '(or null tree-node)
  71          :accessor root)
  72    (modcount :initform 0
  73              :initarg :modcount
  74              :type 'fixnum
  75              :accessor modcount)
  76    (nodegen :initform #1#
  77             :initarg :nodegen
  78             :type 'function
  79             :reader nodegen)
  80    (rebalance/insert :initform nil
  81                      :initarg :rebalance/insert
  82                      :type '(or null function)
  83                      :reader rebalance/insert)
  84    (rebalance/delete :initform nil
  85                      :initarg :rebalance/delete
  86                      :type '(or null function)
  87                      :reader rebalance/delete)))
  88
  89 #+sbcl
  90 (defun %make-binary-tree (pred key test nodegen rebalance/insert rebalance/delete)
  91   (make-instance 'binary-tree :pred pred :key key :test test :nodegen nodegen
  92                               :rebalance/insert rebalance/insert
  93                               :rebalance/delete rebalance/delete))
  94
  95 #-sbcl
  96 (defstruct (binary-tree
  97              (:conc-name)
  98              (:constructor %make-binary-tree (pred key test
  99                                                    nodegen
 100                                                    rebalance/insert
 101                                                    rebalance/delete))
 102              (:copier nil))
 103   (test #1=(error "missing arg") :type function :read-only t)
 104   (key #1# :type function :read-only t)
 105   (pred #1# :type function :read-only t)
 106   (size 0 :type fixnum)
 107   (root nil :type (or null tree-node))
 108   (modcount 0 :type fixnum)
 109   (nodegen #1# :type function :read-only t)
 110   (rebalance/insert nil :type (or null function) :read-only t)
 111   (rebalance/delete nil :type (or null function) :read-only t))