sql/decimals.lisp

   1 ;;; DECIMALS
   2 ;;
   3 ;; A decimal number parser and formatting package for Common Lisp.
   4 ;;
   5 ;; Author: Teemu Likonen <tlikonen@iki.fi>
   6 ;;
   7 ;; License: Public domain
   8 ;;
   9 ;; This program is distributed in the hope that it will be useful, but
  10 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
  12
  13 (defpackage #:decimals
  14   (:use #:cl)
  15   (:export #:round-half-away-from-zero
  16            #:format-decimal-number
  17            #:parse-decimal-number
  18            #:decimal-parse-error
  19            #:define-decimal-formatter))
  20
  21 (in-package #:decimals)
  22
  23
  24 (defun round-half-away-from-zero (number &optional (divisor 1))
  25
  26   "Divide _number_ by _divisor_ and round the result to the nearest integer.
  27 If the result is half-way between two integers round away from zero. Two
  28 values are returned: quotient and remainder.
  29
  30 This is similar to `cl:round` function except that `cl:round` rounds to
  31 an even integer when number is exactly between two integers. Examples:
  32
  33     (round-half-away-from-zero 3/2) => 2, -1/2
  34     (round 3/2)                     => 2, -1/2
  35
  36     (round-half-away-from-zero 5/2) => 3, -1/2
  37     (round 5/2)                     => 2, 1/2"
  38
  39   (if (zerop number)
  40       (values 0 0)
  41       (let ((quotient (if (plusp number)
  42                           (floor (+ (/ number divisor) 1/2))
  43                           (ceiling (- (/ number divisor) 1/2)))))
  44         (values quotient (- number (* quotient divisor))))))
  45
  46
  47 (defun divide-into-groups (string &key (separator #\Space) (from-end nil)
  48                            (group-digits 3))
  49
  50   (assert (and (integerp group-digits)
  51                (plusp group-digits))
  52           (group-digits)
  53           "The GROUP-DIGITS argument must be a positive integer")
  54
  55   (setf separator (princ-to-string separator))
  56
  57   (if (zerop (length separator))
  58       string
  59       (flet ((make-groups (string separator)
  60                (loop :with length := (length string)
  61                      :with result := (make-array length :element-type 'character
  62                                                  :fill-pointer 0 :adjustable t)
  63                      :for c :across string
  64                      :for i :upfrom 1
  65                      :do (vector-push-extend c result)
  66                      :if (and (zerop (rem i group-digits))
  67                               (< i length))
  68                      :do (loop :for c :across separator
  69                                :do (vector-push-extend c result))
  70                      :finally (return result))))
  71
  72         (if from-end
  73             (nreverse (make-groups (reverse string) (reverse separator)))
  74             (make-groups string separator)))))
  75
  76
  77 (defun decimal-round-split (number &key
  78                             (round-magnitude 0)
  79                             (rounder #'round-half-away-from-zero)
  80                             (positive-sign #\+)
  81                             (negative-sign #\-)
  82                             (zero-sign nil))
  83
  84   (assert (integerp round-magnitude) (round-magnitude)
  85           "ROUND-MAGNITUDE argument must be an integer.")
  86
  87   (when (floatp number)
  88     (setf number (rational number)))
  89
  90   (let ((divisor (expt 10 round-magnitude)))
  91     (setf number (* divisor (funcall rounder number divisor))))
  92
  93   (let ((sign (cond ((plusp number) (or positive-sign ""))
  94                     ((minusp number) (or negative-sign ""))
  95                     (t (or zero-sign "")))))
  96
  97     (multiple-value-bind (integer fractional)
  98         (truncate (abs number))
  99       (let ((fractional-string
 100              (with-output-to-string (out)
 101                (loop :with next := fractional
 102                      :with remainder
 103                      :repeat (abs round-magnitude)
 104                      :until (zerop next)
 105                      :do
 106                      (setf (values next remainder) (truncate (* next 10)))
 107                      (princ next out)
 108                      (setf next remainder)))))
 109         (list (princ-to-string sign)
 110               (princ-to-string integer)
 111               fractional-string)))))
 112
 113
 114 (defun string-align (string width &key (side :left) (char #\Space))
 115   (if (>= (length string) width)
 116       string
 117       (let ((result (make-string width :initial-element char)))
 118         (ecase side
 119           (:left (replace result string))
 120           (:right (replace result string
 121                            :start1 (- width (length string))))))))
 122
 123
 124 (defun format-decimal-number (number &key
 125                               (round-magnitude 0)
 126                               (rounder #'round-half-away-from-zero)
 127                               (decimal-separator #\.)
 128                               (integer-group-separator nil)
 129                               (integer-group-digits 3)
 130                               (integer-minimum-width 0)
 131                               (integer-pad-char #\Space)
 132                               (fractional-group-separator nil)
 133                               (fractional-group-digits 3)
 134                               (fractional-minimum-width 0)
 135                               (fractional-pad-char #\Space)
 136                               (show-trailing-zeros nil)
 137                               (positive-sign nil)
 138                               (negative-sign #\-)
 139                               (zero-sign nil))
 140
 141   "Apply specified decimal number formatting rules to _number_ and
 142 return a formatted string.
 143
 144 The second return value is (almost) the same formatted string divided
 145 into four strings. It's a list of four strings: sign, integer part,
 146 decimal separator and fractional part. Formatting arguments
 147 _integer-minimum-width_ and _fractional-minimum-width_ do not apply to
 148 the second return value. Everything else does.
 149
 150 _Number_ must be of type `real`. This function uses `rational` types
 151 internally. If the given _number_ is a `float` it is first turned into
 152 `rational` by calling `cl:rational`.
 153
 154 Formatting rules are specified with keyword arguments, as described
 155 below. The default value is in parentheses.
 156
 157   * `round-magnitude (0)`
 158
 159     This is the order of magnitude used for rounding. The value must be
 160     an integer and it is interpreted as a power of 10.
 161
 162   * `show-trailing-zeros (nil)`
 163
 164     If the value is non-nil print all trailing zeros in fractional part.
 165     Examples:
 166
 167         (format-decimal-number 1/5 :round-magnitude -3
 168                                :show-trailing-zeros nil)
 169         => \"0.2\"
 170
 171         (format-decimal-number 1/5 :round-magnitude -3
 172                                :show-trailing-zeros t)
 173         => \"0.200\"
 174
 175   * `rounder (#'round-half-away-from-zero)`
 176
 177     The value must be a function (or a symbol naming a function). It is
 178     used to round the number to the specified round magnitude. The
 179     function must work like `cl:truncate`, `cl:floor`, `cl:ceiling` and
 180     `cl:round`, that is, take two arguments, a number and a divisor, and
 181     return the quotient as the first value.
 182
 183     This package introduces another rounding function,
 184     `round-half-away-from-zero`, which is used by default. See its
 185     documentation for more information.
 186
 187   * `decimal-separator (#\\.)`
 188
 189     If the value is non-nil the `princ` output of the value will be
 190     added between integer and fractional parts. Probably the most useful
 191     types are `character` and `string`.
 192
 193   * `integer-group-separator    (nil)`
 194   * `fractional-group-separator (nil)`
 195
 196     If the value is non-nil the digits in integer or fractional parts
 197     are put in groups. The `princ` output of the value will be added
 198     between digit groups.
 199
 200   * `integer-group-digits    (3)`
 201   * `fractional-group-digits (3)`
 202
 203     The value is a positive integer defining the number of digits in
 204     groups.
 205
 206   * `integer-minimum-width    (0)`
 207   * `fractional-minimum-width (0)`
 208
 209     Format integer or fractional part using minimum of this amount of
 210     characters, possibly using some padding characters (see below).
 211     _positive-sign_, _negative-sign_ or _zero-sign_ (see below) is
 212     included when calculating the width of the integer part. Similarly
 213     _decimal-separator_ is included when calculating the width of the
 214     fractional part.
 215
 216   * `integer-pad-char    (#\\Space)`
 217   * `fractional-pad-char (#\\Space)`
 218
 219     The value is the padding character which is used to fill
 220     _integer-minimum-width_ or _fractional-minimum-width_.
 221
 222   * `positive-sign (nil)`
 223   * `negative-sign (#\\-)`
 224   * `zero-sign     (nil)`
 225
 226     If values are non-nil these are used as the leading sign for
 227     positive, negative and zero numbers. The `princ` output of the value
 228     is used."
 229
 230   (destructuring-bind (sign integer fractional)
 231       (decimal-round-split number
 232                            :round-magnitude round-magnitude
 233                            :rounder rounder
 234                            :positive-sign positive-sign
 235                            :negative-sign negative-sign
 236                            :zero-sign zero-sign)
 237
 238     (setf decimal-separator (if decimal-separator
 239                                 (princ-to-string decimal-separator)
 240                                 "")
 241           integer (divide-into-groups
 242                    integer
 243                    :separator (or integer-group-separator "")
 244                    :group-digits integer-group-digits
 245                    :from-end t)
 246           fractional (divide-into-groups
 247                       (if (and show-trailing-zeros
 248                                (plusp (- (- (length fractional))
 249                                          round-magnitude)))
 250                           (replace (make-string (abs round-magnitude)
 251                                                 :initial-element #\0)
 252                                    fractional)
 253                           fractional)
 254                       :separator (or fractional-group-separator "")
 255                       :group-digits fractional-group-digits
 256                       :from-end nil))
 257
 258     (values
 259      (concatenate
 260       'string
 261       (string-align (concatenate 'string sign integer)
 262                     integer-minimum-width
 263                     :side :right :char integer-pad-char)
 264       (string-align (if (plusp (length fractional))
 265                         (concatenate 'string decimal-separator fractional)
 266                         "")
 267                     fractional-minimum-width
 268                     :side :left :char fractional-pad-char))
 269      (list sign integer decimal-separator fractional))))
 270
 271
 272 (defmacro define-decimal-formatter (name &body keyword-arguments)
 273
 274   "Define a decimal number formatter function to use with the `~/`
 275 directive of `cl:format`. The valid format is this:
 276
 277     (define-decimal-formatter name
 278       (:keyword form)
 279       ...)
 280
 281 _Name_ is the symbol that names the function. _Keyword_ must be a valid
 282 keyword argument for the `format-decimal-number` function (see its
 283 documentation for more information). _Form_ is evaluated and the value
 284 is used with the _keyword_ argument. Macro's side effect is that global
 285 function _name_ is defined. It can be used with the `~/` directive of
 286 `cl:format` function.
 287
 288 Examples:
 289
 290     (define-decimal-formatter my-formatter
 291       (:round-magnitude -6)
 292       (:decimal-separator \",\")
 293       (:integer-group-separator \" \")
 294       (:integer-minimum-width 4)
 295       (:fractional-group-separator \" \")
 296       (:fractional-minimum-width 10)
 297       (:show-trailing-zeros t))
 298     => MY-FORMATTER
 299
 300     (format nil \"~/my-formatter/\" 10/6)
 301     => \"   1,666 667  \"
 302
 303     (format nil \"~/my-formatter/\" 100/8)
 304     => \"  12,500 000  \"
 305
 306 The `~/` directive function call can optionally take up to three
 307 arguments to override the defaults:
 308
 309     ~round-magnitude,integer-minimum-width,fractional-minimum-width/FUNCTION/
 310
 311 For example:
 312
 313     (format nil \"~-2,3,4/my-formatter/\" 10/6)
 314     => \"  1,67 \""
 315
 316   (let ((key-arg (gensym)))
 317     `(let ((,key-arg (list ,@(loop :for (keyword value) :in keyword-arguments
 318                                    :do (assert (keywordp keyword) (keyword)
 319                                                "Keyword required.")
 320                                    :collect keyword :collect value))))
 321
 322        (defun ,name (stream number &optional colon-p at-sign-p
 323                      round-magnitude integer-minimum-width
 324                      fractional-minimum-width)
 325          (declare (ignore colon-p at-sign-p))
 326
 327          (let ((args (copy-list ,key-arg)))
 328            (when round-magnitude
 329              (setf (getf args :round-magnitude)
 330                    round-magnitude))
 331            (when integer-minimum-width
 332              (setf (getf args :integer-minimum-width)
 333                    integer-minimum-width))
 334            (when fractional-minimum-width
 335              (setf (getf args :fractional-minimum-width)
 336                    fractional-minimum-width))
 337            (princ (apply #'format-decimal-number number args) stream))))))
 338
 339
 340 (defun number-string-to-integer (string)
 341   (handler-case (parse-integer string)
 342     (parse-error () nil)))
 343
 344
 345 (defun number-string-to-fractional (string)
 346   (when (every #'digit-char-p string)
 347     (setf string (string-right-trim "0" string))
 348     (handler-case (/ (parse-integer string)
 349                      (expt 10 (length string)))
 350       (parse-error () nil))))
 351
 352
 353 (define-condition decimal-parse-error (parse-error)
 354   nil
 355   (:report "Not a valid decimal number string.")
 356   (:documentation
 357    "Function `parse-decimal-number` signals this condition when it
 358 couldn't parse a decimal number from string."))
 359
 360
 361 (defun parse-decimal-number (string &key
 362                              (decimal-separator #\.)
 363                              (positive-sign #\+)
 364                              (negative-sign #\-)
 365                              (start 0) (end nil))
 366
 367   "Examine _string_ (or its substring from _start_ to _end_) for a
 368 decimal number. Assume that the decimal number is exact and return it as
 369 a rational number.
 370
 371 Rules for parsing: First all leading and trailing `#\\Space` characters
 372 are stripped. The resulting string may start with a _positive-sign_ or a
 373 _negative-sign_ character. The latter causes this function to assume a
 374 negative number. The following characters in the string must include one
 375 or more digit characters and it may include one _decimal-separator_
 376 character which separates integer and fractional parts. All other
 377 characters are illegal. If these rules are not met a
 378 `decimal-parse-error` condition is signaled.
 379
 380 Examples:
 381
 382     (parse-decimal-number \"0.2\")  => 1/5
 383     (parse-decimal-number \".2\")   => 1/5
 384     (parse-decimal-number \"+3.\")  => 3
 385     (parse-decimal-number \" -7 \") => -7
 386
 387     (parse-decimal-number \"−12,345\"
 388                           :decimal-separator #\\,
 389                           :negative-sign #\\−)
 390     => -2469/200"
 391
 392   (setf string (string-trim " " (subseq string start end)))
 393   (if (not (plusp (length string)))
 394       (error 'decimal-parse-error)
 395       (let ((sign 1))
 396         (cond ((char= (aref string 0) negative-sign)
 397                (setf sign -1
 398                      string (subseq string 1)))
 399               ((char= (aref string 0) positive-sign)
 400                (setf string (subseq string 1))))
 401
 402         (if (and (every (lambda (item)
 403                           (or (digit-char-p item)
 404                               (char= item decimal-separator)))
 405                         string)
 406                  (some #'digit-char-p string)
 407                  (<= 0 (count decimal-separator string) 1))
 408
 409             (let ((pos (position decimal-separator string)))
 410               (* sign
 411                  (+ (or (number-string-to-integer (subseq string 0 pos))
 412                         0)
 413                     (if pos
 414                         (or (number-string-to-fractional
 415                              (subseq string (1+ pos)))
 416                             0)
 417                         0))))
 418
 419             (error 'decimal-parse-error)))))