From 34155b65860404099c8e178dc7c7db0a919c607a Mon Sep 17 00:00:00 2001 From: "Kevin M. Rosenberg" Date: Sun, 18 Apr 2010 10:08:18 -0600 Subject: [PATCH] Binary tree search and unsigned int io functions * btree.lisp: New file providing binary tree search for sorted vectors * tests.list: Add tests for binary tree search * mop.lisp: Change pushed cl:*features* to be in KMRCL package, not KEYWORD * attrib-class.lisp: Use new mop *feature* names for reader conditionals * io.lisp: Add def-unsigned-int-io, along with function definitions for binary io of 2 through 8 byte unsigned ints. --- btree.lisp | 119 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 119 insertions(+) create mode 100644 btree.lisp diff --git a/btree.lisp b/btree.lisp new file mode 100644 index 0000000..1291dd7 --- /dev/null +++ b/btree.lisp @@ -0,0 +1,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 aa. ~ +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 aa." + (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 aa." + (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)))))) -- 2.34.1