;;; This setup generator is primarily meant to test hashing numbers under EQUALP
;;; predicate and stress-test scenarios where floats and rationals overlap or
;;; can overlap under various hasing assumptions.
;;;
;;; Recommended profiles:
;;;
;;; :AVERAGE - hashing real numbers (50% rationals, 50% floats)
;;; :TYPICAL - 25% fixnums, 25% bignums, 25% uuids (fixnum), 25% small floats
;;; :DYADIC  - rational and float numbers that can be exactly coerced under =
;;; 
;;; Remaining profiles:
;;;
;;; :FIXNUM, :BIGNUM, :RATIO, :DOUBLE, :SINGLE, :FLOAT, :COMPLEX-FLOAT,
;;; :COMPLEX-RATIO - indivisual number types (randomized, without nudging)
;;; 
;;; :PETITE - small doubles and small fixnums (avoids bignums and collisions).
;;;
;;; :COLLIDE - rationals that are in binary80 range but exceed the precision of
;;; binary64. Implementations representing LONG-FLOAT as a type that is bigger
;;; than DOUBLE-FLOAT, and which hash such rationals by casting to LONG-FLOAT
;;; and then to DOUBLE-FLOAT, will observe here degraded performance because all
;;; values collapse to either infinity or 0.
;;; 
;;; :BEYOND-COLLISION - similar to the above, but rationals exceed the precision
;;; of binary128, so implementations recognizing that will avoid the collapse.
;;; 
;;; :EVERYTHING combines profiles average, typical, dyadaic and complex numbers.
(defun setup-number (&key (table-size 300)
                       (table-test #'equalp)
                       (n-keys (expt 2 16))
                       (prefill 0)
                       (profile :all)
                     &aux (nasty-fixnum (expt 2 53)))
  (setq *table* (make-hash-table :test table-test :size table-size))
  (setq *value* (random 89))
  (labels ((s (x)
             (ecase (random 2) (0 x) (1 (- x))))
           (rand (min max)
             "random number [min,max]"
             (+ (random (+ (- max min) 1)) min))
           ;; Randomized rationals
           (gen-fixnum ()
             (rand most-negative-fixnum most-positive-fixnum))
           (gen-bignum ()
             (s (rand (1+ most-positive-fixnum) (expt 2 128))))
           (gen-ratio ()                ; 25% chance each
             (ecase (random 4)
               (0 (/ (gen-fixnum) (gen-fixnum)))
               (1 (/ (gen-bignum) (gen-fixnum)))
               (2 (/ (gen-fixnum) (gen-bignum)))
               (3 (/ (gen-bignum) (gen-bignum)))))
           (random-rational ()
             (ecase (random 3)
               (0 (gen-fixnum))
               (1 (gen-bignum))
               (2 (gen-ratio))))
           ;; Randomized floats (small fractions and large integers)
           (gen-float-small ()
             (ecase (random 4)
               (0 (s (random 20.0s0)))
               (1 (s (random 20.0f0)))
               (2 (s (random 20.0d0)))
               (3 (s (random 20.0l0)))))
           (gen-float-large ()
             (ecase (random 4)
               (0 (s (random most-positive-short-float)))
               (1 (s (random most-positive-single-float)))
               (2 (s (random most-positive-double-float)))
               (3 (s (random most-positive-long-float)))))
           (random-float ()
             (ecase (random 2)
               (0 (gen-float-small))
               (1 (gen-float-large))))
           (random-single ()
             (ecase (random 2)
               (0 (s (random 20.0f0)))
               (1 (s (random most-positive-single-float)))))
           (random-double ()
             (ecase (random 2)
               (0 (s (random 20.0d0)))
               (1 (s (random most-positive-double-float)))))
           ;; Randomized complexes (smoke)
           (random-complex-float ()
             (complex (random-float) (random-float)))
           (random-complex-ratio ()
             (complex (random-rational) (random-rational)))
           (random-complex ()
             (ecase (random 2)
               (0 (random-complex-float))
               (1 (random-complex-ratio))))
           ;; Small numbers (avoid bignums, tests float/fixnum)
           (random-petite ()
             (ecase (random 2)
               (0 (s (random 20.0d0)))
               (1 (s (random (expt 2 28))))))
           ;; Consecutive fixnums exceeding binary64 mantissa (2^53)
           (gen-nasty-fixnum () (incf nasty-fixnum))
           ;; We subtract fraction bits from the exponent to not overflow it.
           ;;
           ;; Only SINGLE-FLOAT and DOUBLE-FLOAT usually agree between different
           ;; implementations and architectures, so otherwise we must to be wary
           ;; of comparing apples to oranges. That said these are just numbers,
           ;; so comparing how implementations with different precisions combat
           ;; them is still valuable even when the underlying types differ.
           ;;
           ;; SHORT-FLOAT may be represented as FLOAT16, FLOAT32
           ;; SINGLE-FLOAT is likely represented as FLOAT32
           ;; DOUBLE-FLOAT is likely represented as FLOAT64
           ;; LONG-FLOAT may be represented as FLOAT64, FLOAT80 or FLOAT128
           ;; ARBITRARY-PRECISION-FLOAT (CLISP) could be FLOAT256
           ;; 
           ;; Helpers below are used to construct bignums that overlap with
           ;; floats of the specified type. Care is taken to not sample numbers
           ;; that are representable by floats with lower precision. That means
           ;; in practice, that from float64 upwards
           ;;
           ;;   mantissa * 2^exponent - bignum
           ;;   mantissa / 2^exponent - x/bign
           ;; 
           ;; SHORT-FLOAT, SINGLE-FLOAT and ARBITRARY-PRECISION-FLOAT are now
           ;; included for the reference, same for AUX-FLOAT-16, AUX-FLOAT-32
           ;; and AUX-FLOAT-256. Currently we don't test these.
           ;;
           ;; LONG-FLOAT and FLOAT80/FLOAT128 types are tested optionally.
           (aux-float (mantissa-bits exponent-bits min-exponent)
             (let ((fraction-bits (1- mantissa-bits))
                   (max-exponent (1- (expt 2 (1- exponent-bits)))))
               (decf max-exponent fraction-bits)
               (values (rand 1 (1- (expt 2 mantissa-bits)))
                       (expt 2 (rand min-exponent max-exponent)))))
           (aux-float-known (name)
             (ecase name
               #+ (or) (:binary16  (aux-float  11 5  0))
               #+ (or) (:binary32  (aux-float  24 8  16))
               (:binary64  (aux-float  53 11 128))
               (:binary80  (aux-float  64 15 1024))
               #+ (or) (:binary128 (aux-float 113 15 1024))
               #+ (or) (:binary256 (aux-float 237 19 16384))))
           ;; These are float-shaped rationals that should hash differently. A
           ;; good candidate for comparing implementations between each other.
           (gen-bignum/dfloat ()
             (multiple-value-bind (mantissa exponent)
                 (aux-float-known :binary64)
               (s (* mantissa exponent))))
           (gen-ratio/dfloat ()
             (multiple-value-bind (mantissa exponent)
                 (aux-float-known :binary64)
               (s (/ mantissa exponent))))
           ;; Using :BINARY80 is a safe bet for LONG-FLOAT (float80 is a subset
           ;; of float128). Note that if we hash as doubles, all values in this
           ;; range are first downcast to zero or infinity - in other they are
           ;; good to stress-test implementaions, but not good as a benchmark.
           (gen-bignum/lfloat ()
             (multiple-value-bind (mantissa exponent)
                 (aux-float-known :binary80)
               (s (* mantissa exponent))))
           (gen-ratio/lfloat ()
             (multiple-value-bind (mantissa exponent)
                 (aux-float-known :binary80)
               (s (/ mantissa exponent))))
           ;; These float minimally exceed :BINARY128 in precision while keeping
           ;; the mantissa in the precision of :BINARY64 -- this is a good test
           ;; for float-shaped rationals beyond existing float ranges.
           (gen-bignum/xfloat ()
             (multiple-value-bind (mantissa exponent) (aux-float 53 16 16384)
               (s (* mantissa exponent))))
           (gen-ratio/xfloat ()
             (multiple-value-bind (mantissa exponent) (aux-float 53 16 16384)
               (s (/ mantissa exponent))))
           ;; Instead of computing things again, we constructs exact floats from
           ;; rationals that have exact float value :3.
           (gen-dfloat/bignum () (s (float (gen-bignum/dfloat) 1.0d0)))
           (gen-dfloat/ratio  () (s (float (gen-ratio/dfloat)  1.0d0))))
    (setq *keys*
          (loop repeat n-keys
                for key = (ecase profile
                            ;; 50/50 rationals vs floats (all kinds)
                            (:average
                             (ecase (random 2)
                               (0 (random-rational))
                               (1 (random-float))))
                            ;; fixnums, uuids, small floats, (expt 2 N) bignums
                            (:typical
                             (ecase (random 4)
                               (0 (gen-fixnum))
                               (1 (gen-bignum/dfloat))
                               (2 (gen-nasty-fixnum))
                               (3 (gen-float-small))))
                            ;; Stess tests overlapping representations
                            (:dyadic
                             (ecase (random 5)
                               (0 (gen-fixnum))
                               (1 (gen-bignum/dfloat))
                               (2 (gen-ratio/dfloat))
                               (3 (gen-dfloat/bignum))
                               (4 (gen-dfloat/ratio))))
                            ;; Stress test scenarios where LONG-FLOAT after cast
                            ;; to DOUBLE-FLOAT is either 0 or infinity. This
                            ;; test is interesting only for implementations that
                            ;; have different LONG-FLOAT; otherwise they fast
                            ;; forward to hashing bignums and ratios directly
                            ;; and then this test is === :BEYOND-COLLISION.
                            (:collide
                             (ecase (random 2)
                               (0 (gen-bignum/lfloat))
                               (1 (gen-ratio/lfloat))))
                            ;; Similar to the above, but values are above long
                            ;; float precision, so a sufficiently smart runtime
                            ;; will avoid the trap and produce quality hashes.
                            (:beyond-collision
                             (ecase (random 2)
                               (0 (gen-bignum/xfloat))
                               (1 (gen-ratio/xfloat))))
                            ;; Individual types without any nudging
                            (:fixnum  (gen-fixnum))
                            (:bignum  (gen-bignum))
                            (:ratio   (gen-ratio))
                            (:float   (random-float))
                            (:double  (random-double))
                            (:single  (random-single))
                            (:petite  (random-petite))
                            (:complex-float (random-complex-float))
                            (:complex-ratio (random-complex-ratio))
                            ;; EVERYTHING (almost :3)
                            (:everything
                             (ecase (random 10)
                               (0 (random-rational))
                               (1 (random-float))
                               (2 (random-complex))
                               (3 (gen-nasty-fixnum))
                               (4 (gen-bignum/dfloat))
                               (5 (gen-bignum/xfloat))
                               (6 (gen-ratio/dfloat))
                               (7 (gen-ratio/xfloat))
                               (8 (gen-dfloat/bignum))
                               (9 (gen-dfloat/ratio)))))
                collect key
                do (unless (zerop prefill)
                     (decf prefill)
                     (setf (gethash key *table*) *value*))))))