1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: 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
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
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.
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
38 (per-mille (code-char 2030))
40 ;; picture string syntax only
42 (pattern-separator #\
;) ;active
44 ;; output syntax only:
49 (defstruct (picture (:conc-name
"PIC/"))
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
)
66 (df/pattern-separator df
)))
69 (let ((result (make-array 10))
70 (start (char-code (df/zero-digit df
))))
74 (setf (elt result i
) (code-char (+ start i
))))
77 (defun find-decimal-format (format-name)
78 (declare (ignore format-name
))
80 (make-decimal-format))
82 (xpath-sys:define-xpath-function
/eager
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
)
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
)
104 (unless (and positive
(not erroneous
))
105 (xpath:xpath-error
"invalid pattern separators"))
107 (setf negative
(concatenate 'string
108 (string (df/minus-sign df
))
110 (values (parse-sub-picture positive df
)
111 (parse-sub-picture negative df
))))
113 (defmacro df
/case
(df form
&rest clauses
)
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))
125 for i from start below end
126 for c
= (elt picture i
)
127 until
(eql c
(df/decimal-separator df
))
130 (df/grouping-separator
131 (push 0 integer-part-grouping-positions
))
133 (when integer-part-grouping-positions
134 (incf (car integer-part-grouping-positions
))))
136 (when integer-part-grouping-positions
137 (incf (car integer-part-grouping-positions
)))
138 (incf minimum-integer-part-size
)))
142 for pos in integer-part-grouping-positions
143 for accum
= pos then
(+ accum pos
)
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))
153 for i from start below end
154 for c
= (elt picture i
)
157 (df/grouping-separator
158 (push current-grouping fractional-part-grouping-positions
))
160 (incf current-grouping
)
161 (incf maximum-fractional-part-size
))
163 (incf current-grouping
)
164 (incf minimum-fractional-part-size
)
165 (incf maximum-fractional-part-size
))
166 (df/decimal-separator
))
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
)))
178 (xpath:xpath-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
))))
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
))
195 (defun infinityp (value)
196 (eq value
:infinity
))
198 (defun format-number (value positive-picture negative-picture df
)
199 (if (xpath::nan-p value
)
201 (let ((picture (if (minusp value
) negative-picture positive-picture
)))
202 (if (infinityp value
)
206 (pic/suffix picture
))
207 (format-ordinary-number value picture df
)))))
209 (defun format-number-~f
(number picture df
)
210 (let* ((str (format nil
"~,vF"
211 (pic/maximum-fractional-part-size picture
)
213 (str (string-trim (string (df/zero-digit df
)) str
)) ;for 0.0
214 (digits (df/digits df
)))
218 (df/decimal-separator df
)
219 (elt digits
(- (char-code x
) #.
(char-code #\
0)))))
222 (defun make-grouping-test (positions)
224 (let ((first (car positions
)))
226 for expected
= first then
(+ expected first
)
228 always
(eql pos expected
))))
229 (let ((first (car positions
)))
231 (and (plusp x
) (zerop (mod x first
)))))
233 (and (plusp x
) (find x positions
)))))
235 (defun format-ordinary-number (value picture df
)
236 (let* ((adjusted-number
238 ((pic/percentp picture
)
240 ((pic/per-mille-p picture
)
244 (str (format-number-~f
(abs adjusted-number
) picture df
))
245 (left (position (df/decimal-separator df
) str
))
246 (right (1- (- (length str
) left
)))
247 (wanted-left (max left
(pic/minimum-integer-part-size picture
)))
248 (wanted-right (max right
(pic/minimum-fractional-part-size picture
)))
249 (zero (df/zero-digit df
))
250 (left-test (make-grouping-test
251 (pic/integer-part-grouping-positions picture
)))
252 (right-test (make-grouping-test
253 (pic/fractional-part-grouping-positions picture
))))
254 (with-output-to-string (s)
255 (write-string (pic/prefix picture
) s
)
257 for i from
(1- wanted-left
) downto
0
258 for index from
(- left wanted-left
)
261 (write-char (elt str index
) s
)
263 (when (funcall left-test i
)
264 (write-char (df/grouping-separator df
) s
)))
265 (when (plusp wanted-right
)
266 (write-char (df/decimal-separator df
) s
)
268 for i from
0 below wanted-right
269 for index from
(+ left
1)
271 (when (funcall right-test i
)
272 (write-char (df/grouping-separator df
) s
))
274 (write-char (elt str index
) s
)
275 (write-char zero s
))))
276 (write-string (pic/suffix picture
) s
))))