path: root/sql/decimals.lisp

;;; DECIMALS
;;
;; A decimal number parser and formatting package for Common Lisp.
;;
;; Author: Teemu Likonen <tlikonen@iki.fi>
;;
;; License: Public domain
;;
;; This program is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.

(defpackage #:decimals
  (:use #:cl)
  (:export #:round-half-away-from-zero
           #:format-decimal-number
           #:parse-decimal-number
           #:decimal-parse-error
           #:define-decimal-formatter))

(in-package #:decimals)


(defun round-half-away-from-zero (number &optional (divisor 1))

  "Divide _number_ by _divisor_ and round the result to the nearest integer.
If the result is half-way between two integers round away from zero. Two
values are returned: quotient and remainder.

This is similar to `cl:round` function except that `cl:round` rounds to
an even integer when number is exactly between two integers. Examples:

    (round-half-away-from-zero 3/2) => 2, -1/2
    (round 3/2)                     => 2, -1/2

    (round-half-away-from-zero 5/2) => 3, -1/2
    (round 5/2)                     => 2, 1/2"

  (if (zerop number)
      (values 0 0)
      (let ((quotient (if (plusp number)
                          (floor (+ (/ number divisor) 1/2))
                          (ceiling (- (/ number divisor) 1/2)))))
        (values quotient (- number (* quotient divisor))))))


(defun divide-into-groups (string &key (separator #\Space) (from-end nil)
                           (group-digits 3))

  (assert (and (integerp group-digits)
               (plusp group-digits))
          (group-digits)
          "The GROUP-DIGITS argument must be a positive integer")

  (setf separator (princ-to-string separator))

  (if (zerop (length separator))
      string
      (flet ((make-groups (string separator)
               (loop :with length := (length string)
                     :with result := (make-array length :element-type 'character
                                                 :fill-pointer 0 :adjustable t)
                     :for c :across string
                     :for i :upfrom 1
                     :do (vector-push-extend c result)
                     :if (and (zerop (rem i group-digits))
                              (< i length))
                     :do (loop :for c :across separator
                               :do (vector-push-extend c result))
                     :finally (return result))))

        (if from-end
            (nreverse (make-groups (reverse string) (reverse separator)))
            (make-groups string separator)))))


(defun decimal-round-split (number &key
                            (round-magnitude 0)
                            (rounder #'round-half-away-from-zero)
                            (positive-sign #\+)
                            (negative-sign #\-)
                            (zero-sign nil))

  (assert (integerp round-magnitude) (round-magnitude)
          "ROUND-MAGNITUDE argument must be an integer.")

  (when (floatp number)
    (setf number (rational number)))

  (let ((divisor (expt 10 round-magnitude)))
    (setf number (* divisor (funcall rounder number divisor))))

  (let ((sign (cond ((plusp number) (or positive-sign ""))
                    ((minusp number) (or negative-sign ""))
                    (t (or zero-sign "")))))

    (multiple-value-bind (integer fractional)
        (truncate (abs number))
      (let ((fractional-string
             (with-output-to-string (out)
               (loop :with next := fractional
                     :with remainder
                     :repeat (abs round-magnitude)
                     :until (zerop next)
                     :do
                     (setf (values next remainder) (truncate (* next 10)))
                     (princ next out)
                     (setf next remainder)))))
        (list (princ-to-string sign)
              (princ-to-string integer)
              fractional-string)))))


(defun string-align (string width &key (side :left) (char #\Space))
  (if (>= (length string) width)
      string
      (let ((result (make-string width :initial-element char)))
        (ecase side
          (:left (replace result string))
          (:right (replace result string
                           :start1 (- width (length string))))))))


(defun format-decimal-number (number &key
                              (round-magnitude 0)
                              (rounder #'round-half-away-from-zero)
                              (decimal-separator #\.)
                              (integer-group-separator nil)
                              (integer-group-digits 3)
                              (integer-minimum-width 0)
                              (integer-pad-char #\Space)
                              (fractional-group-separator nil)
                              (fractional-group-digits 3)
                              (fractional-minimum-width 0)
                              (fractional-pad-char #\Space)
                              (show-trailing-zeros nil)
                              (positive-sign nil)
                              (negative-sign #\-)
                              (zero-sign nil))

  "Apply specified decimal number formatting rules to _number_ and
return a formatted string.

The second return value is (almost) the same formatted string divided
into four strings. It's a list of four strings: sign, integer part,
decimal separator and fractional part. Formatting arguments
_integer-minimum-width_ and _fractional-minimum-width_ do not apply to
the second return value. Everything else does.

_Number_ must be of type `real`. This function uses `rational` types
internally. If the given _number_ is a `float` it is first turned into
`rational` by calling `cl:rational`.

Formatting rules are specified with keyword arguments, as described
below. The default value is in parentheses.

  * `round-magnitude (0)`

    This is the order of magnitude used for rounding. The value must be
    an integer and it is interpreted as a power of 10.

  * `show-trailing-zeros (nil)`

    If the value is non-nil print all trailing zeros in fractional part.
    Examples:

        (format-decimal-number 1/5 :round-magnitude -3
                               :show-trailing-zeros nil)
        => \"0.2\"

        (format-decimal-number 1/5 :round-magnitude -3
                               :show-trailing-zeros t)
        => \"0.200\"

  * `rounder (#'round-half-away-from-zero)`

    The value must be a function (or a symbol naming a function). It is
    used to round the number to the specified round magnitude. The
    function must work like `cl:truncate`, `cl:floor`, `cl:ceiling` and
    `cl:round`, that is, take two arguments, a number and a divisor, and
    return the quotient as the first value.

    This package introduces another rounding function,
    `round-half-away-from-zero`, which is used by default. See its
    documentation for more information.

  * `decimal-separator (#\\.)`

    If the value is non-nil the `princ` output of the value will be
    added between integer and fractional parts. Probably the most useful
    types are `character` and `string`.

  * `integer-group-separator    (nil)`
  * `fractional-group-separator (nil)`

    If the value is non-nil the digits in integer or fractional parts
    are put in groups. The `princ` output of the value will be added
    between digit groups.

  * `integer-group-digits    (3)`
  * `fractional-group-digits (3)`

    The value is a positive integer defining the number of digits in
    groups.

  * `integer-minimum-width    (0)`
  * `fractional-minimum-width (0)`

    Format integer or fractional part using minimum of this amount of
    characters, possibly using some padding characters (see below).
    _positive-sign_, _negative-sign_ or _zero-sign_ (see below) is
    included when calculating the width of the integer part. Similarly
    _decimal-separator_ is included when calculating the width of the
    fractional part.

  * `integer-pad-char    (#\\Space)`
  * `fractional-pad-char (#\\Space)`

    The value is the padding character which is used to fill
    _integer-minimum-width_ or _fractional-minimum-width_.

  * `positive-sign (nil)`
  * `negative-sign (#\\-)`
  * `zero-sign     (nil)`

    If values are non-nil these are used as the leading sign for
    positive, negative and zero numbers. The `princ` output of the value
    is used."

  (destructuring-bind (sign integer fractional)
      (decimal-round-split number
                           :round-magnitude round-magnitude
                           :rounder rounder
                           :positive-sign positive-sign
                           :negative-sign negative-sign
                           :zero-sign zero-sign)

    (setf decimal-separator (if decimal-separator
                                (princ-to-string decimal-separator)
                                "")
          integer (divide-into-groups
                   integer
                   :separator (or integer-group-separator "")
                   :group-digits integer-group-digits
                   :from-end t)
          fractional (divide-into-groups
                      (if (and show-trailing-zeros
                               (plusp (- (- (length fractional))
                                         round-magnitude)))
                          (replace (make-string (abs round-magnitude)
                                                :initial-element #\0)
                                   fractional)
                          fractional)
                      :separator (or fractional-group-separator "")
                      :group-digits fractional-group-digits
                      :from-end nil))

    (values
     (concatenate
      'string
      (string-align (concatenate 'string sign integer)
                    integer-minimum-width
                    :side :right :char integer-pad-char)
      (string-align (if (plusp (length fractional))
                        (concatenate 'string decimal-separator fractional)
                        "")
                    fractional-minimum-width
                    :side :left :char fractional-pad-char))
     (list sign integer decimal-separator fractional))))


(defmacro define-decimal-formatter (name &body keyword-arguments)

  "Define a decimal number formatter function to use with the `~/`
directive of `cl:format`. The valid format is this:

    (define-decimal-formatter name
      (:keyword form)
      ...)

_Name_ is the symbol that names the function. _Keyword_ must be a valid
keyword argument for the `format-decimal-number` function (see its
documentation for more information). _Form_ is evaluated and the value
is used with the _keyword_ argument. Macro's side effect is that global
function _name_ is defined. It can be used with the `~/` directive of
`cl:format` function.

Examples:

    (define-decimal-formatter my-formatter
      (:round-magnitude -6)
      (:decimal-separator \",\")
      (:integer-group-separator \" \")
      (:integer-minimum-width 4)
      (:fractional-group-separator \" \")
      (:fractional-minimum-width 10)
      (:show-trailing-zeros t))
    => MY-FORMATTER

    (format nil \"~/my-formatter/\" 10/6)
    => \"   1,666 667  \"

    (format nil \"~/my-formatter/\" 100/8)
    => \"  12,500 000  \"

The `~/` directive function call can optionally take up to three
arguments to override the defaults:

    ~round-magnitude,integer-minimum-width,fractional-minimum-width/FUNCTION/

For example:

    (format nil \"~-2,3,4/my-formatter/\" 10/6)
    => \"  1,67 \""

  (let ((key-arg (gensym)))
    `(let ((,key-arg (list ,@(loop :for (keyword value) :in keyword-arguments
                                   :do (assert (keywordp keyword) (keyword)
                                               "Keyword required.")
                                   :collect keyword :collect value))))

       (defun ,name (stream number &optional colon-p at-sign-p
                     round-magnitude integer-minimum-width
                     fractional-minimum-width)
         (declare (ignore colon-p at-sign-p))

         (let ((args (copy-list ,key-arg)))
           (when round-magnitude
             (setf (getf args :round-magnitude)
                   round-magnitude))
           (when integer-minimum-width
             (setf (getf args :integer-minimum-width)
                   integer-minimum-width))
           (when fractional-minimum-width
             (setf (getf args :fractional-minimum-width)
                   fractional-minimum-width))
           (princ (apply #'format-decimal-number number args) stream))))))


(defun number-string-to-integer (string)
  (handler-case (parse-integer string)
    (parse-error () nil)))


(defun number-string-to-fractional (string)
  (when (every #'digit-char-p string)
    (setf string (string-right-trim "0" string))
    (handler-case (/ (parse-integer string)
                     (expt 10 (length string)))
      (parse-error () nil))))


(define-condition decimal-parse-error (parse-error)
  nil
  (:report "Not a valid decimal number string.")
  (:documentation
   "Function `parse-decimal-number` signals this condition when it
couldn't parse a decimal number from string."))


(defun parse-decimal-number (string &key
                             (decimal-separator #\.)
                             (positive-sign #\+)
                             (negative-sign #\-)
                             (start 0) (end nil))

  "Examine _string_ (or its substring from _start_ to _end_) for a
decimal number. Assume that the decimal number is exact and return it as
a rational number.

Rules for parsing: First all leading and trailing `#\\Space` characters
are stripped. The resulting string may start with a _positive-sign_ or a
_negative-sign_ character. The latter causes this function to assume a
negative number. The following characters in the string must include one
or more digit characters and it may include one _decimal-separator_
character which separates integer and fractional parts. All other
characters are illegal. If these rules are not met a
`decimal-parse-error` condition is signaled.

Examples:

    (parse-decimal-number \"0.2\")  => 1/5
    (parse-decimal-number \".2\")   => 1/5
    (parse-decimal-number \"+3.\")  => 3
    (parse-decimal-number \" -7 \") => -7

    (parse-decimal-number \"−12,345\"
                          :decimal-separator #\\,
                          :negative-sign #\\−)
    => -2469/200"

  (setf string (string-trim " " (subseq string start end)))
  (if (not (plusp (length string)))
      (error 'decimal-parse-error)
      (let ((sign 1))
        (cond ((char= (aref string 0) negative-sign)
               (setf sign -1
                     string (subseq string 1)))
              ((char= (aref string 0) positive-sign)
               (setf string (subseq string 1))))

        (if (and (every (lambda (item)
                          (or (digit-char-p item)
                              (char= item decimal-separator)))
                        string)
                 (some #'digit-char-p string)
                 (<= 0 (count decimal-separator string) 1))

            (let ((pos (position decimal-separator string)))
              (* sign
                 (+ (or (number-string-to-integer (subseq string 0 pos))
                        0)
                    (if pos
                        (or (number-string-to-fractional
                             (subseq string (1+ pos)))
                            0)
                        0))))

            (error 'decimal-parse-error)))))