format-number.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: 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 #x2030))
  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 (lname uri stylesheet &optional (errorp t))
  78   (or (gethash (cons lname uri)
  79                (stylesheet-decimal-formats stylesheet))
  80       (when errorp
  81         (xslt-error "decimal format not found: ~A/~A" lname uri))))
  82
  83 (defun (setf find-decimal-format) (newval lname uri stylesheet)
  84   (setf (gethash (cons lname uri)
  85                  (stylesheet-decimal-formats stylesheet))
  86         newval))
  87
  88 (defun decimal-format= (a b)
  89   (every (lambda (accessor)
  90            (equal (funcall accessor a)
  91                   (funcall accessor b)))
  92          (list #'df/decimal-separator
  93                #'df/grouping-separator
  94                #'df/zero-digit
  95                #'df/percent
  96                #'df/per-mille
  97                #'df/digit
  98                #'df/pattern-separator
  99                #'df/infinity
 100                #'df/nan
 101                #'df/minus-sign)))
 102
 103 (xpath-sys:define-xpath-function/lazy
 104     xslt :format-number
 105     (value picture &optional format-name)
 106   (let ((namespaces *namespaces*))
 107     (lambda (ctx)
 108       (let ((df
 109              (if format-name
 110                  (let ((qname (xpath:string-value (funcall format-name ctx))))
 111                    (multiple-value-bind (local-name uri)
 112                        (decode-qname/runtime qname namespaces nil)
 113                      (find-decimal-format local-name
 114                                           (or uri "")
 115                                           *stylesheet*)))
 116                  (find-decimal-format "" "" *stylesheet*))))
 117         (multiple-value-bind (pos neg)
 118             (parse-picture (xpath:string-value (funcall picture ctx)) df)
 119           (format-number (float (xpath:number-value (funcall value ctx))
 120                                 1.0d0)
 121                          pos
 122                          neg
 123                          df))))))
 124
 125 (defun test-format-number (value picture)
 126   (let ((df (make-decimal-format)))
 127     (multiple-value-bind (pos neg)
 128         (parse-picture picture df)
 129       (format-number value pos neg df))))
 130
 131 (defun parse-picture (picture df)
 132   (destructuring-bind (&optional positive negative &rest erroneous)
 133       (split-sequence:split-sequence
 134        (df/pattern-separator df)
 135        picture)
 136     (unless (and positive (not erroneous))
 137       (xpath:xpath-error "invalid pattern separators"))
 138     (unless negative
 139       (setf negative (concatenate 'string
 140                                   (string (df/minus-sign df))
 141                                   positive)))
 142     (values (parse-sub-picture positive df)
 143             (parse-sub-picture negative df))))
 144
 145 (defmacro df/case (df form &rest clauses)
 146   `(let ((.form ,form)
 147          (.df ,df))
 148      (cond
 149        ,@(loop
 150             for (accessor . body) in clauses
 151             collect `((eql (,accessor .df) .form) ,@body)))))
 152
 153 (defun parse-integer-picture (picture df start end)
 154   (let ((integer-part-grouping-positions '())
 155         (minimum-integer-part-size 0)
 156         (zero-digit-p nil))
 157     (loop
 158        for i from start below end
 159        for c = (elt picture i)
 160        until (eql c (df/decimal-separator df))
 161        do
 162          (df/case df c
 163            (df/grouping-separator
 164             (push 0 integer-part-grouping-positions))
 165            (df/digit
 166             (when zero-digit-p
 167               (xslt-error
 168                "digit not allowed after zero-digit in integer picture"))
 169             (when integer-part-grouping-positions
 170               (incf (car integer-part-grouping-positions))))
 171            (df/zero-digit
 172             (setf zero-digit-p t)
 173             (when integer-part-grouping-positions
 174               (incf (car integer-part-grouping-positions)))
 175             (incf minimum-integer-part-size)))
 176        finally
 177          (when integer-part-grouping-positions
 178            ;; zzz I wrote the above algorithm based on the XSLT 2.0 spec,
 179            ;; only to find out that the test suite doesn't want
 180            ;; multiple INTEGER-PART-GROUPING-POSITIONS.  Sun says
 181            ;; that only the last one is used:
 182            ;; http://java.sun.com/j2se/1.3/docs/api/java/text/DecimalFormat.html
 183            (setf integer-part-grouping-positions
 184                  (list (car integer-part-grouping-positions))))
 185          (return (values (1+ i)
 186                          (loop
 187                             for pos in integer-part-grouping-positions
 188                             for accum = pos then (+ accum pos)
 189                             collect accum)
 190                          minimum-integer-part-size)))))
 191
 192 (defun parse-fractional-picture (picture df start end)
 193   (let ((fractional-part-grouping-positions '())
 194         (minimum-fractional-part-size 0)
 195         (maximum-fractional-part-size 0)
 196         (current-grouping 0)
 197         (digitp nil))
 198     (loop
 199        for i from start below end
 200        for c = (elt picture i)
 201        do
 202          (df/case df c
 203            (df/grouping-separator
 204             (push current-grouping fractional-part-grouping-positions))
 205            (df/digit
 206             (setf digitp t)
 207             (incf current-grouping)
 208             (incf maximum-fractional-part-size))
 209            (df/zero-digit
 210             (when digitp
 211               (xslt-error
 212                "zero-digit not allowed after digit in fractional picture"))
 213             (incf current-grouping)
 214             (incf minimum-fractional-part-size)
 215             (incf maximum-fractional-part-size))
 216            (df/decimal-separator
 217             (xslt-error "multiple decimal separators found")))
 218        finally
 219          (return (values (nreverse fractional-part-grouping-positions)
 220                          minimum-fractional-part-size
 221                          maximum-fractional-part-size)))))
 222
 223 (defun parse-sub-picture (picture df)
 224   (let ((active (df/active-characters df)))
 225     (flet ((activep (x) (find x active)))
 226       (let ((start (position-if #'activep picture))
 227             (last (position-if #'activep picture :from-end t)))
 228         (unless start
 229           (setf start (length picture))
 230           (setf last start)
 231           (setf picture (format nil "~A~A" picture (df/zero-digit df))))
 232         (let* ((end (1+ last))
 233                (result (make-picture
 234                          :percentp (find (df/percent df) picture)
 235                          :per-mille-p (find (df/per-mille df) picture)
 236                          :prefix (subseq picture 0 start)
 237                          :suffix (subseq picture end))))
 238           (setf (values start
 239                         (pic/integer-part-grouping-positions result)
 240                         (pic/minimum-integer-part-size result))
 241                 (parse-integer-picture picture df start end))
 242           (setf (values (pic/fractional-part-grouping-positions result)
 243                         (pic/minimum-fractional-part-size result)
 244                         (pic/maximum-fractional-part-size result))
 245                 (parse-fractional-picture picture df start end))
 246           result)))))
 247
 248 (defun format-number (value positive-picture negative-picture df)
 249   (if (xpath::nan-p value)
 250       (df/nan df)
 251       (let ((picture (if (minusp value) negative-picture positive-picture)))
 252         (if (xpath::inf-p value)
 253             (concatenate 'string
 254                          (pic/prefix picture)
 255                          (df/infinity df)
 256                          (pic/suffix picture))
 257             (format-ordinary-number value picture df)))))
 258
 259 (defun format-number-~f (number picture df)
 260   (let* ((str (format nil "~,vF"
 261                       (pic/maximum-fractional-part-size picture)
 262                       number))
 263          (str (string-trim (string (df/zero-digit df)) str)) ;for 0.0
 264          (digits (df/digits df)))
 265     (map 'string
 266          (lambda (x)
 267            (if (eql x #\.)
 268                (df/decimal-separator df)
 269                (elt digits (- (char-code x) #.(char-code #\0)))))
 270          str)))
 271
 272 (defun make-grouping-test (positions)
 273   (if (and positions
 274            (let ((first (car positions)))
 275              (loop
 276                 for expected = first then (+ expected first)
 277                 for pos in positions
 278                 always (eql pos expected))))
 279       (let ((first (car positions)))
 280         (lambda (x)
 281           (and (plusp x) (zerop (mod x first)))))
 282       (lambda (x)
 283         (and (plusp x) (find x positions)))))
 284
 285 (defun format-ordinary-number (value picture df)
 286   (let* ((adjusted-number
 287           (cond
 288             ((pic/percentp picture)
 289              (* value 100))
 290             ((pic/per-mille-p picture)
 291              (* value 1000))
 292             (t
 293              value)))
 294          (str (format-number-~f (abs adjusted-number) picture df))
 295          (left (position (df/decimal-separator df) str))
 296          (right (1- (- (length str) left)))
 297          (wanted-left (max left (pic/minimum-integer-part-size picture)))
 298          (wanted-right (max right (pic/minimum-fractional-part-size picture)))
 299          (zero (df/zero-digit df))
 300          (left-test (make-grouping-test
 301                      (pic/integer-part-grouping-positions picture)))
 302          (right-test (make-grouping-test
 303                       (pic/fractional-part-grouping-positions picture))))
 304     (with-output-to-string (s)
 305       (write-string (pic/prefix picture) s)
 306       (loop
 307          for i from (1- wanted-left) downto 0
 308          for index from (- left wanted-left)
 309          do
 310            (if (< i left)
 311                (write-char (elt str index) s)
 312                (write-char zero s))
 313            (when (funcall left-test i)
 314              (write-char (df/grouping-separator df) s)))
 315       (when (plusp wanted-right)
 316         (write-char (df/decimal-separator df) s)
 317         (loop
 318            for i from 0 below wanted-right
 319            for index from (+ left 1)
 320            do
 321              (when (funcall right-test i)
 322                (write-char (df/grouping-separator df) s))
 323              (if (< i right)
 324                  (write-char (elt str index) s)
 325                  (write-char zero s))))
 326       (write-string (pic/suffix picture) s))))