share/contrib/engineering-format.lisp

   1 ;; copyright 2014 by Robert Dodier
   2 ;; I release this work under terms of the GNU GPL
   3 ;; Small additions 2018 by Gunter Königsmann
   4
   5 ;; Format floats for display with exponent which is a multiple of 3.
   6 ;; fpprintprec is honored. The global flag engineering_format_floats
   7 ;; (true by default) enables this format which can be disabled for
   8 ;; certain number ranges using engineering_format_min and
   9 ;; engineering_format_max.
  10 ;;
  11 ;; If engineering format floats aren't welcome for numbers
  12 ;; between 0.01 and 1000 this can be signalled to engineering-format
  13 ;; by setting
  14 ;;
  15 ;;   engineering_format_min: .01$
  16 ;;   engineering_format_max: 1000$
  17 ;;
  18 ;; Example:
  19 ;;
  20 ;; load ("engineering-format.lisp");
  21 ;; for fpprintprec : 2 thru 6 do print (makelist (float(%pi) * 10^n, n, -10, 10));
  22 ;;
  23 ;; [310.0E-12, 3.1E-9, 31.0E-9, 310.0E-9, 3.1E-6, 31.0E-6, 310.0E-6, 3.1E-3,
  24 ;; 31.0E-3, 310.0E-3, 3.1E+0, 31.0E+0, 310.0E+0, 3.1E+3, 31.0E+3, 310.0E+3,
  25 ;; 3.1E+6, 31.0E+6, 310.0E+6, 3.1E+9, 31.0E+9]
  26 ;; [314.0E-12, 3.14E-9, 31.4E-9, 314.0E-9, 3.14E-6, 31.4E-6, 314.0E-6, 3.14E-3,
  27 ;; 31.4E-3, 314.0E-3, 3.14E+0, 31.4E+0, 314.0E+0, 3.14E+3, 31.4E+3, 314.0E+3,
  28 ;; 3.14E+6, 31.4E+6, 314.0E+6, 3.14E+9, 31.4E+9]
  29 ;; [314.2E-12, 3.142E-9, 31.42E-9, 314.2E-9, 3.142E-6, 31.42E-6, 314.2E-6,
  30 ;; 3.142E-3, 31.42E-3, 314.2E-3, 3.142E+0, 31.42E+0, 314.2E+0, 3.142E+3,
  31 ;; 31.42E+3, 314.2E+3, 3.142E+6, 31.42E+6, 314.2E+6, 3.142E+9, 31.42E+9]
  32 ;; [314.16E-12, 3.1416E-9, 31.416E-9, 314.16E-9, 3.1416E-6, 31.416E-6, 314.16E-6,
  33 ;; 3.1416E-3, 31.416E-3, 314.16E-3, 3.1416E+0, 31.416E+0, 314.16E+0, 3.1416E+3,
  34 ;; 31.416E+3, 314.16E+3, 3.1416E+6, 31.416E+6, 314.16E+6, 3.1416E+9, 31.416E+9]
  35 ;; [314.159E-12, 3.14159E-9, 31.4159E-9, 314.159E-9, 3.14159E-6, 31.4159E-6,
  36 ;; 314.159E-6, 3.14159E-3, 31.4159E-3, 314.159E-3, 3.14159E+0, 31.4159E+0,
  37 ;; 314.159E+0, 3.14159E+3, 31.4159E+3, 314.159E+3, 3.14159E+6, 31.4159E+6,
  38 ;; 314.159E+6, 3.14159E+9, 31.4159E+9]
  39
  40 (defmvar $engineering_format_floats t)
  41 (defmvar $engineering_format_min 0.0)
  42 (defmvar $engineering_format_max 0.0)
  43
  44 (defvar *debug-eng-format* nil
  45   "Set to non-NIL to enable some debugging prints for engineering format")
  46
  47 (defun engineering-format (x)
  48   (if (= x 0.0)
  49       (format nil "~e" x)
  50       (flet ((log10 (x)
  51                ;; Cmucl has an accurate implementation of log10, which
  52                ;; can be accessed via (log x 10).  For all other
  53                ;; lisps, we can use it too instead of doing
  54                ;; log(x)/log(10) which can cause an extra round-off.
  55                (let* ((integer-log (floor (log x 10.0))))
  56                  ;; Let n = integer-log.  If things worked correctly, then 10^n
  57                  ;; <= x < 10^(n+1).  However if some rounding errors occurred,
  58                  ;; it's possible that n is too small.  Check for that and adjust
  59                  ;; n appropriately.
  60                  ;;
  61                  ;; This assumes (expt 10d0 n) works accurately.  We can't do
  62                  ;; (expt 10 n) because (expt 10 -7) is actually slightly larger
  63                  ;; than 1d-7.
  64                  (unless (and (<= (expt 10d0 integer-log)
  65                                   x)
  66                               (< x (expt 10d0 (1+ integer-log))))
  67                    (incf integer-log))
  68                  integer-log)))
  69         (let* ((integer-log (log10 x))
  70                (scale (1+ (mod integer-log 3)))
  71                (effective-fpprintprec (if (= $fpprintprec 0) 16 $fpprintprec))
  72                (digits (1- effective-fpprintprec))
  73                (result (format nil "~,v,,ve" digits scale x)))
  74           (declare (special $fpprintprec))
  75           (flet ((maybe-fix-up-result ()
  76                    ;; Check that the printed result does what we want.  This
  77                    ;; accounts for some roundoff in lisp's format function.
  78                    ;; For example, with ecl, printing 1d5 produces the wrong
  79                    ;; thing despite ecl correctly computing correct integer-log
  80                    ;; of 5.  (format nil "~,v,,ve" 15 3 1d5) => 1000.0e2.  This
  81                    ;; should be 100.0e3.  The following code checks for this
  82                    ;; condition and tries to correct for it.
  83                    (let* (
  84                           ;; Find the location of the decimal point in the printed result.
  85                           (dot-posn (position #\. result :test #'char-equal))
  86                           ;; Find the value of the exponent in the printed result.
  87                           (expo (parse-integer result
  88                                                :start (1+ (position #\e result
  89                                                                     :test #'char-equal)))))
  90                      (unless (and (< dot-posn 4)
  91                                   (zerop (rem expo 3)))
  92                        (when *debug-eng-format*
  93                          (format t "Expo ~A posn ~A: Result is wrong:  ~A~%" expo dot-posn result))
  94
  95                        ;; For all the cases I've seen, if the exponent is not a
  96                        ;; multiple of 3, decrementing the scale by 1 will get
  97                        ;; lisp to print out the right thing.  Except ccl64:
  98                        ;; (format t "~,v,,ve" 15 2 1d10) => 10d+8.  The printed
  99                        ;; result isn't 1d10.
 100                        (setf result (format nil "~,v,,ve" digits (1- scale) x))
 101
 102                        (when *debug-eng-format*
 103                          (format t "New result: ~A~%" result))))))
 104
 105             (when *debug-eng-format*
 106               (format t "X = ~A log = ~A scale = ~A digits ~A result ~A~%"
 107                       x integer-log scale digits result))
 108
 109             (maybe-fix-up-result)
 110             result)))))
 111
 112 (let ((foo (symbol-function 'exploden)))
 113   (defun exploden (x)
 114     (if (and (floatp x) $engineering_format_floats
 115              (or (< (abs x) $engineering_format_min)
 116                  (> (abs x) $engineering_format_max)))
 117       (let ((s (engineering-format x)) s1)
 118         (declare (special *exploden-strip-float-zeros*))
 119         (setq s1 (if *exploden-strip-float-zeros* (or (strip-float-zeros s) s) s))
 120         (funcall foo s1))
 121       (funcall foo x))))