format-number.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2
   3 ;;; Copyright (c) 2008 David Lichteblau, Ivan Shvedunov.
   4 ;;; All rights reserved.
   5
   6 ;;; Redistribution and use in source and binary forms, with or without
   7 ;;; modification, are permitted provided that the following conditions
   8 ;;; are met:
   9 ;;;
  10 ;;;   * Redistributions of source code must retain the above copyright
  11 ;;;     notice, this list of conditions and the following disclaimer.
  12 ;;;
  13 ;;;   * Redistributions in binary form must reproduce the above
  14 ;;;     copyright notice, this list of conditions and the following
  15 ;;;     disclaimer in the documentation and/or other materials
  16 ;;;     provided with the distribution.
  17 ;;;
  18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  21 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  29
  30 (in-package :xuriella)
  31
  32 (defstruct (decimal-format (:conc-name "DF/"))
  33   ;; picture string and output syntax:
  34   (decimal-separator #\.)               ;active
  35   (grouping-separator #\,)              ;active
  36   (zero-digit #\0)                      ;active
  37   (percent #\%)
  38   (per-mille (code-char 2030))
  39
  40   ;; picture string syntax only
  41   (digit #\#)                           ;active
  42   (pattern-separator #\;)               ;active
  43
  44   ;; output syntax only:
  45   (infinity "Infinity")
  46   (nan "NaN")
  47   (minus-sign #\-))
  48
  49 (defstruct (picture (:conc-name "PIC/"))
  50   percentp
  51   per-mille-p
  52   prefix
  53   suffix
  54   integer-part-grouping-positions
  55   minimum-integer-part-size
  56   fractional-part-grouping-positions
  57   minimum-fractional-part-size
  58   maximum-fractional-part-size)
  59
  60 (defun df/active-characters (df)
  61   (format nil "~C~C~C~C~C"
  62           (df/decimal-separator df)
  63           (df/grouping-separator df)
  64           (df/zero-digit df)
  65           (df/digit df)
  66           (df/pattern-separator df)))
  67
  68 (defun df/digits (df)
  69   (let ((result (make-array 10))
  70         (start (char-code (df/zero-digit df))))
  71     (loop
  72        for i from 0 below 10
  73        do
  74          (setf (elt result i) (code-char (+ start i))))
  75     result))
  76
  77 (defun find-decimal-format (format-name)
  78   (declare (ignore format-name))
  79   ;; fixme
  80   (make-decimal-format))
  81
  82 (xpath::define-xpath-function/eager
  83     :format-number
  84     (value picture &optional format-name)
  85   (let ((df (find-decimal-format format-name)))
  86     (multiple-value-bind (pos neg)
  87         (parse-picture (xpath:string-value picture) df)
  88       (format-number (xpath:number-value value)
  89                      pos
  90                      neg
  91                      df))))
  92
  93 (defun test-format-number (value picture)
  94   (let ((df (make-decimal-format)))
  95     (multiple-value-bind (pos neg)
  96         (parse-picture picture df)
  97       (format-number value pos neg df))))
  98
  99 (defun parse-picture (picture df)
 100   (destructuring-bind (&optional positive negative &rest erroneous)
 101       (split-sequence:split-sequence
 102        (df/pattern-separator df)
 103        picture)
 104     (unless (and positive (not erroneous))
 105       (error "invalid pattern separators"))
 106     (unless negative
 107       (setf negative (concatenate 'string
 108                                   (string (df/minus-sign df))
 109                                   positive)))
 110     (values (parse-sub-picture positive df)
 111             (parse-sub-picture negative df))))
 112
 113 (defmacro df/case (df form &rest clauses)
 114   `(let ((.form ,form)
 115          (.df ,df))
 116      (cond
 117        ,@(loop
 118             for (accessor . body) in clauses
 119             collect `((eql (,accessor .df) .form) ,@body)))))
 120
 121 (defun parse-integer-picture (picture df start end)
 122   (let ((integer-part-grouping-positions '())
 123         (minimum-integer-part-size 0))
 124     (loop
 125        for i from start below end
 126        for c = (elt picture i)
 127        until (eql c (df/decimal-separator df))
 128        do
 129          (df/case df c
 130            (df/grouping-separator
 131             (push 0 integer-part-grouping-positions))
 132            (df/digit
 133             (when integer-part-grouping-positions
 134               (incf (car integer-part-grouping-positions))))
 135            (df/zero-digit
 136             (when integer-part-grouping-positions
 137               (incf (car integer-part-grouping-positions)))
 138             (incf minimum-integer-part-size)))
 139        finally
 140          (return (values i
 141                          (loop
 142                             for pos in integer-part-grouping-positions
 143                             for accum = pos then (+ accum pos)
 144                             collect accum)
 145                          minimum-integer-part-size)))))
 146
 147 (defun parse-fractional-picture (picture df start end)
 148   (let ((fractional-part-grouping-positions '())
 149         (minimum-fractional-part-size 0)
 150         (maximum-fractional-part-size 0)
 151         (current-grouping 0))
 152     (loop
 153        for i from start below end
 154        for c = (elt picture i)
 155        do
 156          (df/case df c
 157            (df/grouping-separator
 158             (push current-grouping fractional-part-grouping-positions))
 159            (df/digit
 160             (incf current-grouping)
 161             (incf maximum-fractional-part-size))
 162            (df/zero-digit
 163             (incf current-grouping)
 164             (incf minimum-fractional-part-size)
 165             (incf maximum-fractional-part-size))
 166            (df/decimal-separator))
 167        finally
 168          (return (values (nreverse fractional-part-grouping-positions)
 169                          minimum-fractional-part-size
 170                          maximum-fractional-part-size)))))
 171
 172 (defun parse-sub-picture (picture df)
 173   (let ((active (df/active-characters df)))
 174     (flet ((activep (x) (find x active)))
 175       (let ((start (position-if #'activep picture))
 176             (last (position-if #'activep picture :from-end t)))
 177         (unless start
 178           (error "no digit-sign or zero-digit sign found"))
 179         (let* ((end (1+ last))
 180                (result (make-picture
 181                          :percentp (find (df/percent df) picture)
 182                          :per-mille-p (find (df/per-mille df) picture)
 183                          :prefix (subseq picture 0 start)
 184                          :suffix (subseq picture end))))
 185           (setf (values start
 186                         (pic/integer-part-grouping-positions result)
 187                         (pic/minimum-integer-part-size result))
 188                 (parse-integer-picture picture df start end))
 189           (setf (values (pic/fractional-part-grouping-positions result)
 190                         (pic/minimum-fractional-part-size result)
 191                         (pic/maximum-fractional-part-size result))
 192                 (parse-fractional-picture picture df start end))
 193           result)))))
 194
 195 (defun nanp (value)
 196   ;; fixme
 197   (eq value :nan))
 198
 199 (defun infinityp (value)
 200   (eq value :infinity))
 201
 202 (defun format-number (value positive-picture negative-picture df)
 203   (if (nanp value)
 204       (df/nan df)
 205       (let ((picture (if (minusp value) negative-picture positive-picture)))
 206         (if (infinityp value)
 207             (concatenate 'string
 208                          (pic/prefix picture)
 209                          (df/infinity df)
 210                          (pic/suffix picture))
 211             (format-ordinary-number value picture df)))))
 212
 213 (defun format-number-~f (number picture df)
 214   (let* ((str (format nil "~,vF"
 215                       (pic/maximum-fractional-part-size picture)
 216                       number))
 217          (str (string-trim (string (df/zero-digit df)) str)) ;for 0.0
 218          (digits (df/digits df)))
 219     (map 'string
 220          (lambda (x)
 221            (if (eql x #\.)
 222                (df/decimal-separator df)
 223                (elt digits (- (char-code x) #.(char-code #\0)))))
 224          str)))
 225
 226 (defun make-grouping-test (positions)
 227   (if (and positions
 228            (let ((first (car positions)))
 229              (loop
 230                 for expected = first then (+ expected first)
 231                 for pos in positions
 232                 always (eql pos expected))))
 233       (let ((first (car positions)))
 234         (lambda (x)
 235           (and (plusp x) (zerop (mod x first)))))
 236       (lambda (x)
 237         (and (plusp x) (find x positions)))))
 238
 239 (defun format-ordinary-number (value picture df)
 240   (let* ((adjusted-number
 241           (cond
 242             ((pic/percentp picture)
 243              (* value 100))
 244             ((pic/per-mille-p picture)
 245              (* value 1000))
 246             (t
 247              value)))
 248          (str (format-number-~f (abs adjusted-number) picture df))
 249          (left (position (df/decimal-separator df) str))
 250          (right (1- (- (length str) left)))
 251          (wanted-left (max left (pic/minimum-integer-part-size picture)))
 252          (wanted-right (max right (pic/minimum-fractional-part-size picture)))
 253          (zero (df/zero-digit df))
 254          (left-test (make-grouping-test
 255                      (pic/integer-part-grouping-positions picture)))
 256          (right-test (make-grouping-test
 257                       (pic/fractional-part-grouping-positions picture))))
 258     (with-output-to-string (s)
 259       (write-string (pic/prefix picture) s)
 260       (loop
 261          for i from (1- wanted-left) downto 0
 262          for index from 0
 263          do
 264            (if (< i left)
 265                (write-char (elt str index) s)
 266                (write-char zero s))
 267            (when (funcall left-test i)
 268              (write-char (df/grouping-separator df) s)))
 269       (when (plusp wanted-right)
 270         (write-char (df/decimal-separator df) s)
 271         (loop
 272            for i from 0 below wanted-right
 273            for index from (+ left 1)
 274            do
 275              (when (funcall right-test i)
 276                (write-char (df/grouping-separator df) s))
 277              (if (< i right)
 278                  (write-char (elt str index) s)
 279                  (write-char zero s))))
 280       (write-string (pic/suffix picture) s))))