source: trunk/ccl/library/splay-tree.lisp @ 1171

Last change on this file since 1171 was 1171, checked in by gb, 15 years ago

Add MAP-SPLAY-TREE-KEYS-AND-VALUES.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 7.2 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2003 Clozure Associates
4;;;   This file is part of OpenMCL. 
5;;;
6;;;   OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7;;;   License , known as the LLGPL and distributed with OpenMCL as the
8;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
9;;;   which is distributed with OpenMCL as the file "LGPL".  Where these
10;;;   conflict, the preamble takes precedence. 
11;;;
12;;;   OpenMCL is referenced in the preamble as the "LIBRARY."
13;;;
14;;;   The LLGPL is also available online at
15;;;   http://opensource.franz.com/preamble.html
16
17(in-package "CCL")
18
19
20;;; A (partial) implementation of SPLAY-TREEs, which are binary trees
21;;; that reorganize themselves so that the most recently accessed keys
22;;; cluster near the tree's root.
23
24(defstruct (tree-node
25             (:constructor make-tree-node (key value)))
26  key
27  value
28  left                                  ; the child < this key, or NIL
29  right                                 ; the child > this key, or NIL
30  parent                                ; we're the root if NIL.   
31  )
32
33(defmethod print-object ((node tree-node) stream)
34  (print-unreadable-object (node stream :type t :identity t)
35    (let* ((*print-circle* t))
36      (format stream "~s -> ~s" (tree-node-key node) (tree-node-value node)))))
37
38
39(defun tree-node-is-leaf (n)
40  (and (null (tree-node-left n))
41       (null (tree-node-right n))))
42
43(defun tree-node-is-root (n)
44  (null (tree-node-parent n)))
45
46;;; Is node the left child of its parent ?
47(defun tree-node-is-left (n)
48  (let* ((parent (tree-node-parent n)))
49    (and parent (eq n (tree-node-left parent)))))
50
51(defun tree-node-is-right (n)
52  (let* ((parent (tree-node-parent n)))
53    (and parent (eq n (tree-node-right parent)))))
54
55(defun tree-node-set-right (node newright)
56  (when (setf (tree-node-right node) newright)
57    (setf (tree-node-parent newright) node)))
58
59(defun tree-node-set-left (node newleft)
60  (when (setf (tree-node-left node) newleft)
61    (setf (tree-node-parent newleft) node)))             
62
63(defun tree-node-replace-child (node old new)
64  (if (eq old (tree-node-left node))
65    (tree-node-set-left node new)
66    (tree-node-set-right node new)))
67
68(defstruct (splay-tree (:constructor %make-splay-tree))
69  (root nil :type (or null splay-tree-node))
70  equal                                 ; true if x = y
71  less                                  ; true if x < y
72  (count 0)
73  )
74
75(defmethod print-object ((tree splay-tree) stream)
76  (print-unreadable-object (tree stream :type t :identity t)
77    (format stream "count = ~d, root = ~s"
78            (splay-tree-count tree)
79            (splay-tree-root tree))))
80           
81
82
83;;; Returns tree-node or NIL
84(defun binary-tree-get (tree key)
85  (do* ((equal (splay-tree-equal tree))
86        (less (splay-tree-less tree))
87        (node (splay-tree-root tree)))
88       ((null node))
89    (let* ((node-key (tree-node-key node)))
90      (if (funcall equal key node-key)
91        (return node)
92        (if (funcall less key node-key)
93          (setq node (tree-node-left node))
94          (setq node (tree-node-right node)))))))
95
96;;; No node with matching key exists in the tree
97(defun binary-tree-insert (tree node)
98  (let* ((root (splay-tree-root tree)))
99    (if (null root)
100      (setf (splay-tree-root tree) node)
101      (do* ((less (splay-tree-less tree))
102            (key (tree-node-key node))
103            (current root)
104            (parent nil))
105           ((null current)
106            (if (funcall less key (tree-node-key parent))
107              (tree-node-set-left parent node)
108              (tree-node-set-right parent node)))
109        (setq parent current)
110        (if (funcall less key (tree-node-key current))
111          (setq current (tree-node-left current))
112          (setq current (tree-node-right current))))))
113  (incf (splay-tree-count tree)))
114   
115           
116;;; Replace the node's parent with the node itself, updating the
117;;; affected children so that the binary tree remains properly
118;;; ordered.
119(defun binary-tree-rotate (tree node)
120  (when (and node (not (tree-node-is-root node)))
121    (let* ((parent (tree-node-parent node))
122           (grandparent (if parent (tree-node-parent parent)))
123           (was-left (tree-node-is-left node)))
124      (if grandparent
125        (tree-node-replace-child grandparent parent node)
126        (setf (splay-tree-root tree) node
127              (tree-node-parent node) nil))
128      (if was-left
129        (progn
130          (tree-node-set-left parent (tree-node-right node))
131          (tree-node-set-right node parent))
132        (progn
133          (tree-node-set-right parent (tree-node-left node))
134          (tree-node-set-left node parent))))))
135
136;;; Keep rotating the node (and maybe its parent) until the node's the
137;;; root of tree.
138(defun splay-tree-splay (tree node)
139  (when node
140    (do* ()
141         ((tree-node-is-root node))
142      (let* ((parent (tree-node-parent node))
143             (grandparent (tree-node-parent parent)))
144        (cond ((null grandparent)
145               (binary-tree-rotate tree node)) ; node is now root
146              ((eq (tree-node-is-left node)
147                   (tree-node-is-left parent))
148               (binary-tree-rotate tree parent)
149               (binary-tree-rotate tree node))
150              (t
151               (binary-tree-rotate tree node)
152               (binary-tree-rotate tree node)))))))
153
154
155;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
156;;;
157;;; The more-or-less public API follows.
158;;;
159;;; I suppose that we should support DELETE as well, and perhaps
160;;; UPDATE (find the node and modify its key in place.)  For now,
161;;; SPLAY-TREE-PUT assumes that no node with a matching key exists.
162;;; Access to the tree has to be serialized by the caller.
163
164(defun splay-tree-get (tree key &optional default)
165  (let* ((node (binary-tree-get tree key)))
166    (if node
167      (progn
168        (splay-tree-splay tree node)
169        (tree-node-value node))
170      default)))
171
172(defun splay-tree-put (tree key value)
173  (let* ((node (make-tree-node key value)))
174    (binary-tree-insert tree node)
175    (splay-tree-splay tree node)
176    value))
177
178;;; Note that the tree wants two comparison functions.  This may
179;;; increase the chance that builtin CL functions can be used; a tree
180;;; whose keys are real numbers could use #'= and #'<, for instance.
181;;; Using two comparison functions is (at best) only slightly better
182;;; than insisting that a single comparison function return (values
183;;; equal less), or (member -1 0 1), or some other convention.
184
185(defun make-splay-tree (equal less)
186  (check-type equal function)
187  (check-type less function)
188  (%make-splay-tree :equal equal :less less))
189
190;;; Do an inorder traversal of the splay tree, applying function F
191;;; to the value of each node.
192
193(defun map-splay-tree (tree f)
194  (labels ((map-tree-node (node)
195             (when node
196               (map-tree-node (tree-node-left node))
197               (funcall f (tree-node-value node))
198               (map-tree-node (tree-node-right node)))))
199    (map-tree-node (splay-tree-root tree))))
200
201(defun map-splay-tree-keys-and-values (tree f)
202  (labels ((map-tree-node (node)
203             (when node
204               (map-tree-node (tree-node-left node))
205               (funcall f (tree-node-key node) (tree-node-value node))
206               (map-tree-node (tree-node-right node)))))
207    (map-tree-node (splay-tree-root tree)))) 
Note: See TracBrowser for help on using the repository browser.