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