#lang typed/racket/base

(require racket/flonum
         racket/performance-hint)

(provide flonum->bit-field bit-field->flonum
         flonum->fields fields->flonum
         flonum->sig+exp sig+exp->flonum
         flonum->ordinal ordinal->flonum
         flstep flnext flprev flonums-between
         flulp)

(: flonum->bit-field (Flonum -> Natural))
(define (flonum->bit-field x)
  (flbit-field x 0 64))

(: bit-field->flonum (Integer -> Flonum))
(define (bit-field->flonum i)
  (cond [(and (i . >= . 0) (i . <= . #xffffffffffffffff))
         (floating-point-bytes->real (integer->integer-bytes i 8 #f))]
        [else
         (raise-argument-error 'bit-field->flonum "Integer in [0 .. #xffffffffffffffff]" i)]))

(define implicit-leading-one (arithmetic-shift 1 52))
(define max-significand (- implicit-leading-one 1))
(define max-exponent 2047)
(define max-signed-exponent 1023)
(define min-signed-exponent -1074)

(: flonum->fields (Flonum -> (Values (U 0 1) Index Natural)))
(define (flonum->fields x)
  (values (if (zero? (flbit-field x 63 64)) 0 1)
          (assert (flbit-field x 52 63) index?)
          (flbit-field x 0 52)))

(: fields->flonum (Integer Integer Integer -> Flonum))
(define (fields->flonum s e m)
  (cond [(not (or (= s 0) (= s 1)))
         (raise-argument-error 'fields->flonum "(U 0 1)" 0 s e m)]
        [(or (e . < . 0) (e . > . max-exponent))
         (raise-argument-error 'fields->flonum (format "Natural <= ~e" max-exponent) 1 s e m)]
        [(or (m . < . 0) (m . > . max-significand))
         (raise-argument-error 'fields->flonum (format "Natural <= ~a" max-significand) 2 s e m)]
        [else
         (bit-field->flonum (bitwise-ior (arithmetic-shift s 63)
                                         (arithmetic-shift e 52)
                                         m))]))

(: flonum->sig+exp (Flonum -> (Values Integer Fixnum)))
(define (flonum->sig+exp x)
  (define-values (s e m) (flonum->fields x))
  (let-values ([(sig exp)  (if (= e 0)
                               (values m -1074)
                               (values (bitwise-ior m implicit-leading-one)
                                       (assert (- e 1075) fixnum?)))])
    (values (if (zero? s) sig (- sig)) exp)))

(: sig+exp->flonum (Integer Integer -> Flonum))
(define (sig+exp->flonum sig exp)
  (cond [(= sig 0)  0.0]
        [(exp . > . max-signed-exponent)  (if (sig . < . 0) -inf.0 +inf.0)]
        [(exp . < . min-signed-exponent)  (if (sig . < . 0) -0.0 0.0)]
        [else  (real->double-flonum (* sig (expt 2 exp)))]))

(: flonum->ordinal (Flonum -> Integer))
(define (flonum->ordinal x)
  (cond [(x . fl< . 0.0)  (- (flbit-field (fl- 0.0 x) 0 64))]
        [else             (flbit-field (flabs x) 0 64)])) ; abs for -0.0

(: ordinal->flonum (Integer -> Flonum))
(define (ordinal->flonum i)
  (cond [(and (i . >= . #x-7fffffffffffffff) (i . <= . #x7fffffffffffffff))
         (cond [(i . < . 0)  (fl- 0.0 (bit-field->flonum (- i)))]
               [else         (bit-field->flonum i)])]
        [else
         (raise-argument-error
          'ordinal->flonum "Integer in [#x-7fffffffffffffff .. #x7fffffffffffffff]" i)]))

(define +inf-ordinal (flonum->ordinal +inf.0))
(define -inf-ordinal (flonum->ordinal -inf.0))

(: flstep (Flonum Integer -> Flonum))
(define (flstep x n)
  (cond [(not (and (x . fl>= . -inf.0) (x . fl<= . +inf.0)))  +nan.0]
        [(and (fl= x +inf.0) (n . >= . 0))  +inf.0]
        [(and (fl= x -inf.0) (n . <= . 0))  -inf.0]
        [else  (define i (+ n (flonum->ordinal x)))
               (cond [(i . < . -inf-ordinal)  -inf.0]
                     [(i . > . +inf-ordinal)  +inf.0]
                     [else  (ordinal->flonum i)])]))

(begin-encourage-inline
  
  (: flnext (Flonum -> Flonum))
  (define (flnext x) (flstep x 1))
  
  (: flprev (Flonum -> Flonum))
  (define (flprev x) (flstep x -1))
  
  )  ; begin-encourage-inline

(: flonum->chunks (-> Flonum (Values Integer Integer)))
(define (flonum->chunks x)
  (define neg? (fl< x 0.0))
  (define ax (flabs x))
  (if neg?
      (values (- (flbit-field ax 0 32)) (- (flbit-field ax 32 64)))
      (values (flbit-field ax 0 32) (flbit-field ax 32 64))))

(: flonums-between (Flonum Flonum -> Integer))
(define (flonums-between x y)
  (define-values (xlo xhi) (flonum->chunks x))
  (define-values (ylo yhi) (flonum->chunks y))
  (+ (arithmetic-shift (- yhi xhi) 32) (- ylo xlo)))
  
(: flulp (Flonum -> (U Flonum-Nan Nonnegative-Flonum)))
(define (flulp x)
  (let ([x  (flabs x)])
    (cond [(fl= x +inf.0)  +nan.0]
          [(eqv? x +nan.0)  +nan.0]
          [(fl= x 0.0)  0.0]
          [else
           (define ulp (flabs (fl- (flnext x) x)))
           (cond [(fl= ulp +inf.0)  (flabs (fl- x (flprev x)))]
                 [else  ulp])])))
