implemented node-p for stripping-node
[xuriella.git] / format-number.lisp
blob693f4da68086eaa3870e02494a72ee1a51747733
1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
3 ;;; Copyright (c) 2008 David Lichteblau, Ivan Shvedunov.
4 ;;; All rights reserved.
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.
30 (in-package :xuriella)
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))
40 ;; picture string syntax only
41 (digit #\#) ;active
42 (pattern-separator #\;) ;active
44 ;; output syntax only:
45 (infinity "Infinity")
46 (nan "NaN")
47 (minus-sign #\-))
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)
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)))
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
74 (setf (elt result i) (code-char (+ start i))))
75 result))
77 (defun find-decimal-format (format-name)
78 (declare (ignore format-name))
79 ;; fixme
80 (make-decimal-format))
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))))
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))))
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))))
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)))))
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))
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)))))
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)
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)))))
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)))))
195 (defun nanp (value)
196 ;; fixme
197 (eq value :nan))
199 (defun infinityp (value)
200 (eq value :infinity))
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)))))
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)))
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)))))
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))
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
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)
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))))