/[cl-l10n]/cl-l10n/utils.lisp
ViewVC logotype

Contents of /cl-l10n/utils.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.10 - (show annotations)
Thu Jun 15 20:23:07 2006 UTC (7 years, 10 months ago) by alendvai
Branch: MAIN
CVS Tags: HEAD
Changes since 1.9: +9 -0 lines
Added missing strcat-separated-by function
1 ;;; -*- Mode: LISP; Syntax: ANSI-Common-Lisp; Base: 10 -*-
2 ;; See the file LICENCE for licence information.
3 (in-package #:cl-l10n)
4
5 ;; Macros
6 ;;;;;;;;;;;
7
8 ;; dont worry it's nothing like if*
9 (defmacro or* (&rest vals)
10 "(or* (string= foo a b) (char= foo b)) ==
11 (or (string= foo a) (string= foo b) (char= foo b))"
12 `(or ,@(mappend #'(lambda (x)
13 (destructuring-bind (test val &rest args) x
14 (if (singlep args)
15 `((,test ,val ,@args))
16 (mapcar #'(lambda (y)
17 `(,test ,val ,y))
18 args))))
19 vals)))
20
21
22 ;; Functions
23 ;;;;;;;;;;;;;;
24 (defun mappend (fn &rest lists)
25 (apply #'append (apply #'mapcar fn lists)))
26
27 (defun required-arg (name)
28 (error "~A is a required argument" name))
29
30 (defvar *whitespace* (list #\Space #\Tab))
31
32 (defun strcat-separated-by (separator &rest args)
33 (iter (for el in args)
34 (unless el
35 (next-iteration))
36 (unless (first-time-p)
37 (collect separator into components))
38 (collect el into components)
39 (finally (return (apply #'strcat components)))))
40
41 (defun trim (string &optional (bag *whitespace*))
42 (string-trim bag string))
43
44 (defun group (list n)
45 (assert (> n 0))
46 (labels ((rec (source acc)
47 (let ((rest (nthcdr n source)))
48 (if (consp rest)
49 (rec rest (cons (subseq source 0 n) acc))
50 (nreverse (cons source acc))))))
51 (if list (rec list nil) nil)))
52
53 (defun winner (test get seq)
54 (if (null seq)
55 nil
56 (let* ((val (elt seq 0))
57 (res (funcall get val)))
58 (dolist (x (subseq seq 1) (values val res))
59 (let ((call (funcall get x)))
60 (when (funcall test call res)
61 (setf res call
62 val x)))))))
63
64 (defun float-part (float)
65 (if (zerop float)
66 ""
67 (multiple-value-call 'extract-float-part (flonum-to-digits float))))
68
69 (defun extract-float-part (dp-pos aft)
70 (let ((length (length aft)))
71 (if (> dp-pos length)
72 ""
73 (with-output-to-string (x)
74 (cond ((minusp dp-pos)
75 (dotimes (z (abs dp-pos))
76 (princ 0 x))
77 (princ aft x))
78 (t (princ (subseq aft dp-pos)
79 x)))))))
80
81 ;; From sbcl sources (src/code/print.lisp)
82 (defconstant single-float-min-e
83 (nth-value 1 (decode-float least-positive-single-float)))
84 (defconstant double-float-min-e
85 (nth-value 1 (decode-float least-positive-double-float)))
86
87 (defun flonum-to-digits (v)
88 (let ((print-base 10) ; B
89 (float-radix 2) ; b
90 (float-digits (float-digits v)) ; p
91 (digit-characters "0123456789")
92 (min-e
93 (etypecase v
94 (single-float single-float-min-e)
95 (double-float double-float-min-e))))
96 (multiple-value-bind (f e)
97 (integer-decode-float v)
98 (let ((high-ok (evenp f))
99 (low-ok (evenp f))
100 (result (make-array 50 :element-type 'base-char
101 :fill-pointer 0 :adjustable t)))
102 (labels ((scale (r s m+ m-)
103 (do ((k 0 (1+ k))
104 (s s (* s print-base)))
105 ((not (or (> (+ r m+) s)
106 (and high-ok (= (+ r m+) s))))
107 (do ((k k (1- k))
108 (r r (* r print-base))
109 (m+ m+ (* m+ print-base))
110 (m- m- (* m- print-base)))
111 ((not (or (< (* (+ r m+) print-base) s)
112 (and (not high-ok) (= (* (+ r m+) print-base) s))))
113 (values k (generate r s m+ m-)))))))
114 (generate (r s m+ m-)
115 (let (d tc1 tc2)
116 (tagbody
117 loop
118 (setf (values d r) (truncate (* r print-base) s))
119 (setf m+ (* m+ print-base))
120 (setf m- (* m- print-base))
121 (setf tc1 (or (< r m-) (and low-ok (= r m-))))
122 (setf tc2 (or (> (+ r m+) s)
123 (and high-ok (= (+ r m+) s))))
124 (when (or tc1 tc2)
125 (go end))
126 (vector-push-extend (char digit-characters d) result)
127 (go loop)
128 end
129 (let ((d (cond
130 ((and (not tc1) tc2) (1+ d))
131 ((and tc1 (not tc2)) d)
132 (t ; (and tc1 tc2)
133 (if (< (* r 2) s) d (1+ d))))))
134 (vector-push-extend (char digit-characters d) result)
135 (return-from generate result))))))
136 (if (>= e 0)
137 (if (/= f (expt float-radix (1- float-digits)))
138 (let ((be (expt float-radix e)))
139 (scale (* f be 2) 2 be be))
140 (let* ((be (expt float-radix e))
141 (be1 (* be float-radix)))
142 (scale (* f be1 2) (* float-radix 2) be1 be)))
143 (if (or (= e min-e) (/= f (expt float-radix (1- float-digits))))
144 (scale (* f 2) (* (expt float-radix (- e)) 2) 1 1)
145 (scale (* f float-radix 2)
146 (* (expt float-radix (- 1 e)) 2) float-radix 1))))))))
147
148 #+(or)
149 (defun flonum-to-digits (v &optional position relativep)
150 (let ((print-base 10) ; B
151 (float-radix 2) ; b
152 (float-digits (float-digits v)) ; p
153 (digit-characters "0123456789")
154 (min-e
155 (etypecase v
156 (single-float single-float-min-e)
157 (double-float double-float-min-e))))
158 (multiple-value-bind (f e)
159 (integer-decode-float v)
160 (let (;; FIXME: these even tests assume normal IEEE rounding
161 ;; mode. I wonder if we should cater for non-normal?
162 (high-ok (evenp f))
163 (low-ok (evenp f))
164 (result (make-array 50 :element-type 'base-char
165 :fill-pointer 0 :adjustable t)))
166 (labels ((scale (r s m+ m-)
167 (do ((k 0 (1+ k))
168 (s s (* s print-base)))
169 ((not (or (> (+ r m+) s)
170 (and high-ok (= (+ r m+) s))))
171 (do ((k k (1- k))
172 (r r (* r print-base))
173 (m+ m+ (* m+ print-base))
174 (m- m- (* m- print-base)))
175 ((not (or (< (* (+ r m+) print-base) s)
176 (and (not high-ok)
177 (= (* (+ r m+) print-base) s))))
178 (values k (generate r s m+ m-)))))))
179 (generate (r s m+ m-)
180 (let (d tc1 tc2)
181 (tagbody
182 loop
183 (setf (values d r) (truncate (* r print-base) s))
184 (setf m+ (* m+ print-base))
185 (setf m- (* m- print-base))
186 (setf tc1 (or (< r m-) (and low-ok (= r m-))))
187 (setf tc2 (or (> (+ r m+) s)
188 (and high-ok (= (+ r m+) s))))
189 (when (or tc1 tc2)
190 (go end))
191 (vector-push-extend (char digit-characters d) result)
192 (go loop)
193 end
194 (let ((d (cond
195 ((and (not tc1) tc2) (1+ d))
196 ((and tc1 (not tc2)) d)
197 (t ; (and tc1 tc2)
198 (if (< (* r 2) s) d (1+ d))))))
199 (vector-push-extend (char digit-characters d) result)
200 (return-from generate result)))))
201 (initialize ()
202 (let (r s m+ m-)
203 (if (>= e 0)
204 (let* ((be (expt float-radix e))
205 (be1 (* be float-radix)))
206 (if (/= f (expt float-radix (1- float-digits)))
207 (setf r (* f be 2)
208 s 2
209 m+ be
210 m- be)
211 (setf r (* f be1 2)
212 s (* float-radix 2)
213 m+ be1
214 m- be)))
215 (if (or (= e min-e)
216 (/= f (expt float-radix (1- float-digits))))
217 (setf r (* f 2)
218 s (* (expt float-radix (- e)) 2)
219 m+ 1
220 m- 1)
221 (setf r (* f float-radix 2)
222 s (* (expt float-radix (- 1 e)) 2)
223 m+ float-radix
224 m- 1)))
225 (when position
226 (when relativep
227 (assert (> position 0))
228 (do ((k 0 (1+ k))
229 ;; running out of letters here
230 (l 1 (* l print-base)))
231 ((>= (* s l) (+ r m+))
232 ;; k is now \hat{k}
233 (if (< (+ r (* s (/ (expt print-base (- k position)) 2)))
234 (* s (expt print-base k)))
235 (setf position (- k position))
236 (setf position (- k position 1))))))
237 (let ((low (max m- (/ (* s (expt print-base position)) 2)))
238 (high (max m+ (/ (* s (expt print-base position)) 2))))
239 (when (<= m- low)
240 (setf m- low)
241 (setf low-ok t))
242 (when (<= m+ high)
243 (setf m+ high)
244 (setf high-ok t))))
245 (values r s m+ m-))))
246 (multiple-value-bind (r s m+ m-) (initialize)
247 (scale r s m+ m-)))))))
248 ;; EOF

  ViewVC Help
Powered by ViewVC 1.1.5