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