eqv1/2 and next-after

scratch-eqv-next-after.lisp

;; This buffer is for notes you don't want to save, and for Lisp evaluation.
;; If you want to create a file, visit that file with C-x C-f,
;; then enter the text in that file's own buffer.

(in-package #:cl-user)

;;; <http://en.wikipedia.org/wiki/Logical_biconditional>

(defmacro eqv1 (&rest forms)
  (or (null forms)
      (let ((cdr (cdr forms)))
        (or (null cdr)
            (let* ((sym1 (gensym))
                   (sym2 (gensym))
                   (eqv1 `(let ((,sym1 ,(car forms))
                                (,sym2 ,(car cdr)))
                            (or (and ,sym1 ,sym2)
                                (and (not ,sym1) (not ,sym2)))))
                   (cddr (cdr cdr)))
              (if cddr
                  `(eqv1 ,eqv1 ,@cddr)
                  eqv1))))))

(defmacro eqv2 (&rest forms)
  (let ((syms (mapcar (lambda (form)
                        (declare (ignore form))
                        (gensym))
                      forms)))
    `(let ,(mapcar #'list syms forms)
       (or (and ,@syms)
           (and ,@(mapcar (lambda (sym) `(not ,sym)) syms))))))

;;; <http://golang.org/src/pkg/math/nextafter.go>
;;; this actually has a metric ton of possible behaviours with regards to
;;; the four different standard float formats, (un)normalized floats and
;;; implementation-dependent NaNs, not to mention an efficient
;;; implementation could probably do away with SCALE-FLOAT juggling

(defun next-after (float direction)
  (cond
    ;; TODO: portably detect NaN?
    ((or (excl::nan-p float) (excl::nan-p direction))
     (etypecase float
       (single-float excl:*nan-single*)
       (double-float excl:*nan-double*)))
    ((= float direction)
     float)
    ((= float 0)
     (if (> direction float)
         (etypecase float
           (single-float least-positive-single-float)
           (double-float least-positive-double-float))
         (etypecase float
           (single-float least-negative-single-float)
           (double-float least-negative-double-float))))
    (T
     (multiple-value-bind (significant exponent integer-sign)
         (integer-decode-float float)
       (incf significant (if (eqv2 (> direction float) (>= float 0)) 1 -1))
       (* integer-sign (scale-float (float significant float) exponent))))))