btree.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*-
   2 ;;;; *************************************************************************
   3 ;;;; FILE IDENTIFICATION
   4 ;;;;
   5 ;;;; Name:          btree.lisp
   6 ;;;; Purpose:       Binary tree search function
   7 ;;;; Programmer:    Kevin M. Rosenberg
   8 ;;;; Date Started:  Mar 2010
   9 ;;;;
  10 ;;;; This file, part of KMRCL, is Copyright (c) 2010 by Kevin M. Rosenberg
  11 ;;;;
  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 ;;;; *************************************************************************
  16
  17 (in-package #:kmrcl)
  18
  19 (defmacro def-string-tricmp (fn simple)
  20   "Defines a string tri-valued compare function.
  21 Can choose optimized version for simple-string."
  22   `(defun ,fn (a b)
  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))
  32            (blen (length b)))
  33        (declare (fixnum alen blen))
  34        (dotimes (i alen)
  35          (declare (fixnum i))
  36          (when (>= i 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)))
  41            (cond
  42              ((char-lessp ac bc)
  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
  47        (when (= alen blen)
  48          (return-from ,fn (values 0 alen)))
  49        ;; B is greater than A length, so A is less
  50        (values -1 alen))))
  51
  52 (def-string-tricmp string-tricmp nil)
  53 (def-string-tricmp simple-string-tricmp t)
  54
  55 (defun number-tricmp (a b)
  56   "Compares two numbers. Returns -1 if a<b, 0 if a=b, +1 if b>a."
  57   (declare (real a b)
  58            (optimize (speed 3) (space 0) (debug 0) (compilation-speed 0)))
  59   (cond
  60     ((< a b) -1)
  61     ((> a b) 1)
  62     (t 0)))
  63
  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."
  67   (declare (number a b)
  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))
  72     (cond
  73       ((< a-mag2 b-mag2) -1)
  74       ((> a-mag2 b-mag2) 1)
  75       (t 0))))
  76
  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)))
  83   (unless test
  84     (setq test
  85           (etypecase key-val
  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))
  93         (last (1- len))
  94         (pos (floor len 2))
  95         (last-width 0 width)
  96         (last2-width last-width last-width)
  97         (width (1+ (ceiling pos 2)) (ceiling width 2))
  98         (count 1 (1+ count))
  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))
 105         (when trace
 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))
 109     (when trace
 110       (format trace "~A ~A ~A ~A ~A~%" cur pos width last-width cmp))
 111     (case cmp
 112       (-1
 113        ;; str < cur
 114        (decf pos width)
 115        (when (minusp pos) (setq pos 0)))
 116       (1
 117        ;; str > cur
 118        (incf pos width)
 119        (when (> pos last) (setq pos last))))))