1
;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2
;;;; *************************************************************************
3
;;;; FILE IDENTIFICATION
6
;;;; Purpose: Binary tree search function
7
;;;; Programmer: Kevin M. Rosenberg
8
;;;; Date Started: Mar 2010
10
;;;; This file, part of KMRCL, is Copyright (c) 2010 by Kevin M. Rosenberg
12
;;;; KMRCL users are granted the rights to distribute and use this software
13
;;;; as governed by the terms of the Lisp Lesser GNU Public License
14
;;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL.
15
;;;; *************************************************************************
19
(defmacro def-string-tricmp (fn simple)
20
"Defines a string tri-valued compare function.
21
Can choose optimized version for simple-string."
23
,(format nil "Compares two ~Astrings. Returns (VALUES CMP MAX-MATCHED). ~
24
CMP is -1 if a<b, 0 if a=b, +1 if b>a. ~
25
MAX-MATCHED is maximum numbers of letters of A ~
26
successfully compared."
27
(if simple "simple " ""))
28
(declare ,(if simple '(simple-string a b) '(string a b))
29
(optimize (speed 3) (safety 0) (debug 0)
30
(compilation-speed 0) (space 0)))
31
(let ((alen (length a))
33
(declare (fixnum alen blen))
37
;; At this point, A and B have matched, but A has more letters and B does not
38
(return-from ,fn (values 1 i)))
39
(let ((ac (,(if simple 'schar 'char) a i))
40
(bc (,(if simple 'schar 'char) b i)))
43
(return-from ,fn (values -1 i)))
44
((char-greaterp ac bc)
45
(return-from ,fn (values 1 i))))))
46
;; At this point, A and B are equal up to the length of A
48
(return-from ,fn (values 0 alen)))
49
;; B is greater than A length, so A is less
52
(def-string-tricmp string-tricmp nil)
53
(def-string-tricmp simple-string-tricmp t)
55
(defun number-tricmp (a b)
56
"Compares two numbers. Returns -1 if a<b, 0 if a=b, +1 if b>a."
58
(optimize (speed 3) (space 0) (debug 0) (compilation-speed 0)))
64
(defun complex-number-tricmp (a b)
65
"Compares the magnitude of two complex numbers.
66
Returns -1 if a<b, 0 if a=b, +1 if b>a."
68
(optimize (speed 3) (space 0) (debug 0) (compilation-speed 0)))
69
(let ((a-mag2 (+ (* (realpart a) (realpart a)) (* (imagpart a) (imagpart a))))
70
(b-mag2 (+ (* (realpart b) (realpart b)) (* (imagpart b) (imagpart b)))))
71
(declare (real a-mag2 b-mag2))
73
((< a-mag2 b-mag2) -1)
77
(defun sorted-vector-find (key-val sorted-vector &key test key trace)
78
"Finds index of element in sorted vector using a binary tree search. ~
79
Order log2(N). Returns (VALUES POS LAST-VALUE LAST-POS COUNT).
80
POS is NIL if not found."
81
(declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
82
(compilation-speed 0)))
86
(simple-string #'simple-string-tricmp)
87
(string #'string-tricmp)
88
(complex #'complex-number-tricmp)
89
(number #'number-tricmp))))
90
(when (zerop (length sorted-vector))
91
(return-from sorted-vector-find (values nil nil nil 0)))
92
(do* ((len (length sorted-vector))
96
(last2-width last-width last-width)
97
(width (1+ (ceiling pos 2)) (ceiling width 2))
99
(cur-raw (aref sorted-vector pos)
100
(aref sorted-vector pos))
101
(cur (if key (funcall key cur-raw) cur-raw)
102
(if key (funcall key cur-raw) cur-raw))
103
(cmp (funcall test key-val cur) (funcall test key-val cur)))
104
((or (zerop cmp) (= 1 last2-width))
106
(format trace "~A ~A ~A ~A ~A~%" cur pos width last-width cmp))
107
(values (if (zerop cmp) pos nil) cur-raw pos count))
108
(declare (fixnum len last pos last-width width count cmp))
110
(format trace "~A ~A ~A ~A ~A~%" cur pos width last-width cmp))
115
(when (minusp pos) (setq pos 0)))
119
(when (> pos last) (setq pos last))))))
added
removed
btree.lisp
