/usr/share/common-lisp/source/kmrcl/btree.lisp is in cl-kmrcl 1.106-1.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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))))))
|