Last active
January 28, 2026 09:17
-
-
Save stassats/ab2a5ffc895587a80e7bc4867c1f7e84 to your computer and use it in GitHub Desktop.
float to ratio test
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| (defun floats-around (float) | |
| (multiple-value-bind (sig exp) (integer-decode-float float) | |
| (let* ((prev-float (if (= sig (ash 1 (1- (float-digits float)))) | |
| (scale-float (float (1- (ash 1 (float-digits float))) float) (1- exp)) | |
| (scale-float (float (1- sig) float) exp))) | |
| (next-float (scale-float (float (1+ sig) float) exp))) | |
| (values prev-float next-float sig)))) | |
| (defun check-ratio-to-float (ratio type) | |
| (declare (ratio ratio)) | |
| (let* ((result (float ratio type)) | |
| (new-ratio (rational result))) | |
| (multiple-value-bind (prev-float next-float sig) (floats-around result) | |
| (let* ((error (abs (- ratio new-ratio))) | |
| (error-prev (abs (- ratio (rational prev-float)))) | |
| (error-next (abs (- ratio (rational next-float))))) | |
| (cond | |
| ((< error-next error) | |
| (error "(float ~a ~a) = ~a, while ~a is closer" ratio type result next-float)) | |
| ((< error-prev error) | |
| (error "(float ~a ~a) = ~a, while ~a is closer" ratio type result prev-float)) | |
| ((or (= error error-prev) (= error error-next)) | |
| (unless (evenp sig) | |
| (error "(float ~a ~a) = ~a, not rounded to even" ratio type result)))))))) | |
| (defun test () | |
| (let ((*random-state* (make-random-state t))) | |
| (loop repeat 20000 | |
| do | |
| (let* ((n-bits (random 1075)) | |
| (d-bits (random 1075)) | |
| (num (random (ash 1 n-bits))) | |
| (den (max 1 (random (ash 1 d-bits)))) | |
| (ratio (/ num den))) | |
| (when (typep ratio 'ratio) | |
| (handler-case (progn | |
| (check-ratio-to-float ratio 1f0) | |
| (check-ratio-to-float ratio 1d0)) | |
| (floating-point-overflow ()) | |
| (floating-point-underflow ()))))))) |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment