xnum.lisp

;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-

;;; Copyright (c) 2007 Ivan Shvedunov. All rights reserved.
;;; Copyright (c) 2007 David Lichteblau. All rights reserved.

;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(in-package :xpath)

;; mock IEEE 754 support (to become proper IEEE 754 emulation module someday)

(defmacro with-float-traps-masked ((&optional) &body body)
  `(progn ,@body))

(defvar +nan+ :nan)

(deftype xnum () '(or number (member :nan :inf :-inf)))

(defun xnum-p (value)
  (typep value 'xnum))

(defun nan-p (xnum) (eq xnum :nan))

(defun x-zerop (xnum) (and (numberp xnum) (zerop xnum)))

(defun x-plusp (xnum) (or (eq xnum :inf) (and (numberp xnum) (plusp xnum))))

(defun x-minusp (xnum) (or (eq xnum :-inf) (and (numberp xnum) (minusp xnum))))

(defun inf-p (num) (or (eq num :inf) (eq num :-inf)))

(defun finite-p (num) (numberp num))

(defun compare-numbers (op a b) ; FIXME: this func too hairy
  (and (not (nan-p a))
       (not (nan-p b))
       (labels ((v= () (or (eq a b) (and (numbers-p) (= (coerce a 'double-float) (coerce b 'double-float)))))
                (numbers-p () (and (numberp a) (numberp b)))
                (v<= () (or (eq a :-inf) (eq b :inf) (and (numbers-p) (< a b))))
                (v>= () (or (eq a :inf) (eq b :-inf) (and (numbers-p) (> a b)))))
         (case op
           (equal (v=))
           (< (and (not (v=)) (v<=)))
           (<= (or (v=) (v<=)))
           (> (and (not (v=)) (v>=)))
           (>= (or (v=) (v>=)))))))

(defun xnum-/ (a b)
  (cond ((or (nan-p a) (nan-p b)) :nan)
        ((and (inf-p a) (inf-p b)) :nan)
        ((and (x-zerop a) (x-zerop b)) :nan)
        ((eq a :inf) (if (x-plusp b) :inf :-inf))
        ((eq a :-inf) (if (x-plusp b) :-inf :inf))
        ((inf-p b) 0)
        ((x-zerop b) (if (x-plusp a) :inf :-inf))
        (t (/ a b))))

(defun xnum-* (a b)
  (cond ((or (nan-p a) (nan-p b)) :nan)
        ((and (inf-p a) (x-zerop b)) :nan)
        ((and (x-zerop a) (inf-p b)) :nan)
        ((and (finite-p a) (finite-p b)) (* a b))
        ((and (x-plusp a) (x-plusp b)) :inf)
        ((and (x-minusp a) (x-minusp b)) :inf)
        (t :-inf)))

(defun xnum-+ (a b)
  (cond ((or (nan-p a) (nan-p b)) :nan)
        ((and (eq a :inf) (eq b :-inf)) :nan)
        ((and (eq a :-inf) (eq b :inf)) :nan)
        ((and (finite-p a) (finite-p b)) (+ a b))
        ((or (eq a :inf) (eq b :inf)) :inf)
        (t :-inf)))

(defun xnum-- (a &optional b)
  (cond ((or (nan-p a) (nan-p b)) :nan)
        ((and (null b) (eq a :inf)) :-inf)
        ((and (null b) (eq a :-inf)) :inf)
        ((null b) (- a))
        ((and (finite-p a) (finite-p b)) (- a b))
        ((eq a b) :nan)
        ((or (eq a :inf) (eq b :-inf)) :inf)
        (t :-inf)))

(defun xnum-mod (a b)
  (cond ((or (nan-p a) (nan-p b) (inf-p a) (x-zerop b)) :nan)
        ((inf-p b) a)
        (t (rem a b))))

;; Round to an integer, not a float.  But pass NaN and infinity through.
(defun round-to-integer (a)
  (xnum-round a))

(defun xnum-round (a)
  (if (or (nan-p a) (inf-p a))
      a
      (multiple-value-bind (ceiling rem)
          (ceiling a)
        (if (= rem -0.5)
            ceiling
            (round a)))))

(defun xnum-ceiling (a)
  (if (or (nan-p a) (inf-p a))
      a
      (ceiling a)))

(defun xnum-floor (a)
  (if (or (nan-p a) (inf-p a))
      a
      (floor a)))

(defun preprocess-number-str (str)
  (cond ((position #\e str) (string-replace str "e" "d"))
        ((position #\d str) str)
        ((string= str ".") "")
        ((position #\. str) (concat str "d0"))
        (t str)))

(defun parse-xnum (str)
  (handler-case
      (parse-number:parse-number
       (preprocess-number-str (trim str)))
    ;; cannot use IGNORE-ERRORS here because PARSE-NUMBER::INVALID-NUMBER is
    ;; not an ERROR
    ((or error parse-number::invalid-number) ()
      :nan)))

(defun xnum->string (xnum)
  ;; FIXME: this is not quite correct
  (case xnum
    (:nan "NaN")
    (:inf "Infinity")
    (:-inf "-Infinity")
    (t (cl-ppcre:regex-replace "\\.?0*$" (string-replace (format nil "~f" xnum) "d" "e") ""))))

;; TODO: converting to string
(deftest test-xnum
  (assert* (xnum-p 1)
           (xnum-p -1d0)
           (xnum-p 3/5)
           (xnum-p :inf)
           (xnum-p :-inf)
           (xnum-p :nan)
           (compare-numbers 'equal :inf :inf)
           (compare-numbers 'equal :-inf :-inf)
           (compare-numbers '< :-inf :inf)
           (compare-numbers '<= :-inf :inf)
           (compare-numbers '> :inf :-inf)
           (compare-numbers '>= :inf :-inf)
           (compare-numbers '< :-inf 42)
           (compare-numbers '> :inf 42)
           (compare-numbers '<= :-inf 42)
           (compare-numbers '>= :inf 42)
           (compare-numbers 'equal 1/10000 0.0001d0))
  (loop for op in '(equal < > <= >=)
        do (assert* (not (compare-numbers op :nan :nan))
                    (not (compare-numbers op :nan :inf))
                    (not (compare-numbers op :inf :nan))
                    (not (compare-numbers op :nan :-inf))
                    (not (compare-numbers op :-inf :nan))
                    (not (compare-numbers op :nan 42))
                    (not (compare-numbers op :nan -42))
                    (not (compare-numbers op 42 :nan))
                    (not (compare-numbers op :nan "34"))))
  (assert-equal* 42 (parse-xnum "42") ;; FIXME: double-float?
                 -1 (parse-xnum "-1")
                 5 (parse-xnum "   5  ")
                 :nan (parse-xnum "abc")
                 :nan (parse-xnum ""))
  (assert (< (abs (- 2.3d2 (parse-xnum "  2.3e+2  "))) 1e-7))  ;; FIXME
  (assert-equal* :inf (xnum-/ 1 0d0)
                 :-inf (xnum-/ -1 0)
                 0 (xnum-/ 42 :inf)
                 0 (xnum-/ 42d0 :-inf)
                 42 (xnum-/ 84 2)
                 :nan (xnum-/ 0 0)
                 :nan (xnum-/ :inf :inf)
                 :nan (xnum-/ :-inf :-inf)
                 :nan (xnum-/ :-inf :inf)
                 :nan (xnum-/ :inf :-inf)
                 42 (xnum-* 21 2)
                 0 (xnum-* 0 0)
                 :inf (xnum-* :inf 42)
                 :inf (xnum-* 42 :inf)
                 :inf (xnum-* :inf :inf)
                 :inf (xnum-* :-inf :-inf)
                 :-inf (xnum-* :-inf :inf)
                 :-inf (xnum-* 42 :-inf)
                 :-inf (xnum-* :-inf 42)
                 :nan (xnum-* 0 :inf)
                 :nan (xnum-* 0 :-inf)
                 :nan (xnum-* :inf 0)
                 :nan (xnum-* :-inf 0)
                 :nan (xnum-* 0 :inf)
                 :nan (xnum-* 0 :-inf)
                 42 (xnum-+ 20 22)
                 :inf (xnum-+ :inf :inf)
                 :inf (xnum-+ 42 :inf)
                 :inf (xnum-+ :inf 42)
                 :-inf (xnum-+ 42 :-inf)
                 :-inf (xnum-+ :-inf 42)
                 :-inf (xnum-+ :-inf :-inf)
                 :nan (xnum-+ :-inf :inf)
                 :nan (xnum-+ :inf :-inf)
                 -42 (xnum-- 42)
                 :-inf (xnum-- :inf)
                 :inf (xnum-- :-inf)
                 42 (xnum-- 100 58)
                 :inf (xnum-- 1 :-inf)
                 :inf (xnum-- :inf 1)
                 :-inf (xnum-- :-inf 1)
                 :-inf (xnum-- 1 :inf)
                 :nan (xnum-- :inf :inf)
                 :nan (xnum-- :-inf :-inf)
                 :nan (xnum-- :nan)
                 42 (xnum-mod 142 100)
                 42 (xnum-mod 42 :inf)
                 42 (xnum-mod 42 :-inf)
                 -42 (xnum-mod -42 :inf)
                 -42 (xnum-mod -42 :-inf)
                 :nan (xnum-mod :inf :-inf)
                 :nan (xnum-mod :-inf :inf)
                 :nan (xnum-mod :-inf 42)
                 :nan (xnum-mod :inf 42)
                 :nan (xnum-mod 0 0)
                 :nan (xnum-mod 42 0)
                 2 (xnum-round 1.6)
                 :nan (xnum-round :nan)
                 :inf (xnum-round :inf)
                 :-inf (xnum-round :-inf)
                 1 (xnum-floor 1.6)
                 :nan (xnum-floor :nan)
                 :inf (xnum-floor :inf)
                 :-inf (xnum-floor :-inf)
                 2 (xnum-ceiling 1.6)
                 :nan (xnum-ceiling :nan)
                 :inf (xnum-ceiling :inf)
                 :-inf (xnum-ceiling :-inf))
  (loop for op in '(xnum-/ xnum-* xnum-+ xnum-- xnum-mod)
        do (assert-equal*
                  :nan (funcall op :nan :nan)
                  :nan (funcall op :nan 42)
                  :nan (funcall op 42 :nan)))
  (assert-equal* "42" (xnum->string 42)
                 "-42" (xnum->string -42)
                 "NaN" (xnum->string :nan)
                 "Infinity" (xnum->string :inf)
                 "-Infinity" (xnum->string :-inf)))