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