source: project/release/3/srfi-19/trunk/srfi-19-period.scm @ 12029

Last change on this file since 12029 was 12029, checked in by Kon Lovett, 13 years ago

Save.

File size: 12.2 KB
Line 
1;;;; srfi-19-period.scm
2;;;; Chicken port, Kon Lovett, Apr '07
3
4(eval-when (compile)
5  (declare
6    (not usual-integrations
7      + - * /
8      remainder quotient modulo
9      expt
10      abs
11      round floor truncate
12      number? integer? inexact?
13      zero? negative? positive?
14      = <= >= < >
15      inexact->exact exact->inexact
16      char-alphabetic? char-numeric?
17      number->string string->number
18      string-length string-append
19      string->list list->string)
20    (inline)
21    (generic)
22    (no-procedure-checks)
23    (no-bound-checks)
24    (export
25      time-period?
26      time-period-null?
27      time-period=?
28      time-period<?
29      time-period>?
30      time-period<=?
31      time-period>=?
32      time-period-type
33      time-period-begin
34      time-period-end
35      time-period-last
36      time-period-length
37      make-null-time-period
38      make-time-period
39      copy-time-period
40      time-period-contains/period?
41      time-period-contains/time?
42      time-period-contains/date?
43      time-period-contains?
44      time-period-intersects?
45      time-period-intersection
46      time-period-union
47      time-period-span
48      time-period-shift
49      time-period-shift!
50      time-period-preceding
51      time-period-succeeding) ) )
52
53(use srfi-8
54    srfi-19-core)
55
56;;;
57
58(include "srfi-19-common")
59
60;;; Time Period
61
62(define-record-type/unsafe-inline-unchecked time-period
63  (%make-time-period beg end)
64  %time-period?
65  (beg %time-period-begin)
66  (end %time-period-end) )
67
68(define-inline (%check-time-period loc obj)
69  (##sys#check-structure obj 'time-period loc) )
70
71(define-record-printer (time-period per out)
72  (fprintf out "#,(time-period ~A ~A)" (%time-period-begin per) (%time-period-end per)) )
73
74(define-reader-ctor 'time-period %make-time-period)
75
76(define (tm:time-period-binop-check loc obj1 obj2)
77  (%check-time-period loc obj1)
78  (%check-time-period loc obj2) )
79
80(define (tm:time-period-type per)
81   (%time-type (%time-period-begin per)) )
82
83(define (tm:time-period-null? per)
84  (tm:time<=? (%time-period-end per) (%time-period-begin per)) )
85
86(define (tm:as-empty-time-period per)
87  (%make-time-period
88    (tm:as-empty-time (%time-period-begin per))
89    (tm:as-empty-time (%time-period-end per))) )
90
91(define (tm:ensure-compatible-time loc t1 t2)
92  (let ([tt1 (%time-type t1)]
93        [tt2 (%time-type t2)]
94        [errtt
95          (lambda ()
96            (error loc "incompatible clock-types" t1 t2))])
97    (if (eq? tt1 tt2)
98      t2
99      (let ([ntime (tm:as-empty-time t1)])
100        (case tt1
101          [(time-tai)
102            (case tt2
103              [(time-utc)       (tm:time-utc->time-tai t2 ntime)]
104              [(time-monotonic) (tm:time-monotonic->time-tai t2 ntime)]
105              [else
106                (errtt)])]
107          [(time-utc)
108            (case tt2
109              [(time-tai)       (tm:time-tai->time-utc t2 ntime)]
110              [(time-monotonic) (tm:time-monotonic->time-utc t2 ntime)]
111              [else
112                (errtt)])]
113          [(time-monotonic)
114            (case tt2
115              [(time-utc) (tm:time-utc->time-monotonic t2 ntime)]
116              [(time-tai) (tm:time-tai->time-monotonic t2 ntime)]
117              [else
118                (errtt)])]
119          [else
120            (errtt)]))) ) )
121
122(define (tm:ensure-compatible-date tim dat loc)
123  (case (%time-type tim)
124    [(time-utc)       (date->time-utc dat)]
125    [(time-tai)       (date->time-tai dat)]
126    [(time-monotonic) (date->time-monotonic dat)]
127    [else
128      (error loc "incompatible clock type" tim)]) )
129
130#;
131(define (tm:time-compare loc per1 per2)
132  (tm:time-period-binop-check loc per1 per2)
133  (tm:time-period-subtract per1 per2) )
134
135
136(define (tm:time-period=? per1 per2)
137  (and
138    (tm:time=? (%time-period-begin per1) (%time-period-begin per2))
139    (tm:time=? (%time-period-end per1) (%time-period-end per2))) )
140
141(define (tm:time-points-within? b1 e1 b2 e2)
142  ;Assume b1 <= e1 & b2 <= e2
143  (and (tm:time<=? b1 b2) (tm:time<=? e2 e1)) )
144
145(define (tm:time-period-contains/period? loc per1 per2)
146  (and
147    (not (tm:time-period-null? per1))
148    (let ([tper
149            (if (eq? (tm:time-period-type per1) (tm:time-period-type per2))
150              per2
151              (%make-time-period
152                (tm:ensure-compatible-time loc (%time-period-begin per1) (%time-period-begin per2))
153                (tm:ensure-compatible-time loc (%time-period-end per1) (%time-period-end per2))))])
154      (tm:time-points-within?
155        (%time-period-begin per1) (%time-period-end per1)
156        (%time-period-begin tper) (%time-period-end tper)) ) ) )
157
158(define (tm:time-period-contains/time? loc per tim)
159  (and
160    (not (tm:time-period-null? per))
161    (let ([tpt (tm:ensure-compatible-time loc (%time-period-begin per) tim)])
162      (tm:time-points-within? (%time-period-begin per) (%time-period-end per) tpt tpt) ) ) )
163
164(define (tm:time-period-contains/date? loc per dat)
165  (tm:time-period-contains/time?
166    loc per (tm:ensure-compatible-date loc (%time-period-begin per) dat)) )
167
168(define (tm:time-point-intersection b1 e1 b2 e2)
169  (values (tm:time-max b1 b2) (tm:time-min e1 e2)) )
170
171(define (tm:time-point-union-values b1 e1 b2 e2)
172  (values (tm:time-min b1 b2) (tm:time-max e1 e2)) )
173
174(define (tm:time-period-intersection-values per1 per2 loc)
175  (and
176    (not (or (tm:time-period-null? per1) (tm:time-period-null? per2)))
177    (let ([b1 (%time-period-begin per1)]
178          [e1 (%time-period-end per1)])
179      (let ([b2 (tm:ensure-compatible-time loc b1 (%time-period-begin per2))]
180            [e2 (tm:ensure-compatible-time loc e1 (%time-period-end per2))])
181        (tm:time-point-intersection b1 e1 b2 e2) ) ) ) )
182
183(define (tm:time-period-shift per-in dur per-out)
184  (tm:add-duration (%time-period-begin per-in) dur (%time-period-begin per-out))
185  (tm:add-duration (%time-period-end per-in) dur (%time-period-end per-out))
186  per-out )
187
188;;
189
190(define time-period? %time-period?)
191
192(define (time-period-begin prd)
193  (%check-time-period 'time-period-begin prd)
194  (%time-period-begin prd) )
195
196(define (time-period-end prd)
197  (%check-time-period 'time-period-end prd)
198  (%time-period-end prd) )
199
200(define (make-null-time-period . args)
201  (let-optionals args ((timtyp (default-date-clock-type)))
202    (tm:as-empty-time-period (tm:make-empty-time timtyp)) ) )
203
204(define (make-time-period beg end . args)
205  (let-optionals args ((timtyp (default-date-clock-type)))
206    (cond
207      [(number? beg)
208        (set! beg (seconds->time/type beg timtyp))]
209      [(date? beg)
210        (set! beg (date->time beg timtyp))])
211    (%check-time 'make-time-period beg)
212    (when (eq? 'time-duration (%time-type beg))
213      (error 'make-time-period "invalid time" beg))
214    (cond
215      [(number? end)
216        (set! end (seconds->time/type end 'time-duration))]
217      [(date? end)
218        (set! end (tm:ensure-compatible-date 'make-time-period beg end))])
219    (%check-time 'make-time-period end)
220    (when (eq? 'time-duration (%time-type end))
221      (set! end (tm:add-duration beg end (tm:as-empty-time beg))))
222    (%make-time-period
223      beg
224      (tm:ensure-compatible-time 'make-time-period beg end)) ) )
225
226(define (copy-time-period per)
227  (%check-time-period 'copy-time-period per)
228  (%make-time-period (copy-time (%time-period-begin per)) (copy-time (%time-period-end per))) )
229
230(define (time-period-type per)
231  (%check-time-period 'time-period-type per)
232  (tm:time-period-type per) )
233
234(define (time-period-null? per)
235  (%check-time-period 'time-period-null? per)
236  (tm:time-period-null? per) )
237
238(define (time-period=? per1 per2)
239  (tm:time-period-binop-check 'time-period=? per1 per2)
240  (tm:time-period=? per1 per2) )
241
242(define (time-period<? per1 per2)
243  (tm:time-period-binop-check 'time-period<? per1 per2)
244  (tm:time<? (%time-period-end per1) (%time-period-begin per2)) )
245
246(define (time-period>? per1 per2)
247  (tm:time-period-binop-check 'time-period>? per1 per2)
248  (tm:time>? (%time-period-begin per1) (%time-period-end per2)) )
249
250(define (time-period<=? per1 per2)
251  (tm:time-period-binop-check 'time-period<=? per1 per2)
252  (tm:time<=? (%time-period-end per1) (%time-period-begin per2)) )
253
254(define (time-period>=? per1 per2)
255  (tm:time-period-binop-check 'time-period>=? per1 per2)
256  (tm:time>=? (%time-period-begin per1) (%time-period-end per2)) )
257
258(define (time-period-preceding per1 per2)
259  (tm:time-period-binop-check 'time-period-preceding per1 per2)
260  (and (tm:time<=? (%time-period-begin per1) (%time-period-begin per2))
261       (make-time-period (%time-period-begin per1) (%time-period-begin per2)) ) )
262
263(define (time-period-succeeding per1 per2)
264  (tm:time-period-binop-check 'time-period-succeeding per1 per2)
265  (and (tm:time>=? (%time-period-end per1) (%time-period-end per2))
266       (make-time-period (%time-period-end per2) (%time-period-end per1)) ) )
267
268(define (time-period-last per)
269  (%check-time-period 'time-period-last per)
270  (let ([end (%time-period-end per)])
271    (tm:subtract-duration end ONE-NANOSECOND-DURATION (tm:as-empty-time end)) ) )
272
273(define (time-period-length per)
274  (%check-time-period 'time-period-length per)
275  (let ([dur (tm:make-empty-time time-duration)])
276    (if (tm:time-period-null? per)
277      dur
278      (tm:time-difference
279        (%time-period-begin per) (%time-period-end per) dur)) ) )
280
281(define (time-period-contains/period? per1 per2)
282  (%check-time-period 'time-period-contains/period? per1)
283  (%check-time-period 'time-period-contains/period? per2)
284  (tm:time-period-contains/period? 'time-period-contains/period? per1 per2) )
285
286(define (time-period-contains/time? per tim)
287  (%check-time-period 'time-period-contains/time? per)
288  (%check-time 'time-period-contains/time? tim)
289  (tm:time-period-contains/time? 'time-period-contains/time? per tim) )
290
291(define (time-period-contains/date? per dat)
292  (%check-time-period 'time-period-contains/date? per)
293  (tm:check-date 'time-period-contains/date? dat)
294  (tm:time-period-contains/date? 'time-period-contains/date? per dat) )
295
296(define (time-period-contains? per obj)
297  (%check-time-period 'time-period-contains? per)
298  (cond
299    [(time-period? obj)
300      (tm:time-period-contains/period? 'time-period-contains? per obj)]
301    [(time? obj)
302      (tm:time-period-contains/time? 'time-period-contains? per obj)]
303    [(date? obj)
304      (tm:time-period-contains/date? 'time-period-contains? per obj)]
305    [else
306      (error 'time-period-contains? "invalid time object" obj)]) )
307
308(define (time-period-intersects? per1 per2)
309  (%check-time-period 'time-period-intersects? per1)
310  (%check-time-period 'time-period-intersects? per2)
311  (receive [bi ei] (tm:time-period-intersection-values 'time-period-intersects? per1 per2)
312    (tm:time<=? bi ei) ) )
313
314(define (time-period-intersection per1 per2)
315  (%check-time-period 'time-period-intersection per1)
316  (%check-time-period 'time-period-intersection per2)
317  (receive [bi ei] (tm:time-period-intersection-values 'time-period-intersection per1 per2)
318    (and (tm:time<=? bi ei)
319         (%make-time-period bi ei)) ) )
320
321(define (time-period-union per1 per2)
322  (%check-time-period 'time-period-union per1)
323  (%check-time-period 'time-period-union per2)
324  (let ([b1 (%time-period-begin per1)]
325        [e1 (%time-period-end per1)])
326      (let ([b2 (tm:ensure-compatible-time 'time-period-union b1 (time-period-begin per2))]
327            [e2 (tm:ensure-compatible-time 'time-period-union e1 (time-period-end per2))])
328        (receive [bi ei] (tm:time-point-intersection b1 e1 b2 e2)
329          (and (tm:time<=? bi ei)
330               (receive [bu eu] (tm:time-point-union-values b1 e1 b2 e2)
331                 (%make-time-period bu eu))) ) ) ) )
332
333(define (time-period-span per1 per2)
334  (%check-time-period 'time-period-span per1)
335  (%check-time-period 'time-period-span per2)
336  (let ([b1 (%time-period-begin per1)]
337        [e1 (%time-period-end per1)])
338    (receive [bu eu]
339        (tm:time-point-union-values
340          b1 e1
341          (tm:ensure-compatible-time 'time-period-span b1 (%time-period-begin per2))
342          (tm:ensure-compatible-time 'time-period-span e1 (%time-period-end per2)))
343      (%make-time-period bu eu) ) ) )
344
345(define (time-period-shift per dur)
346  (%check-time-period 'time-period-shift per)
347  (%check-time 'time-period-shift dur)
348  (tm:duration-check 'time-period-shift dur)
349  (tm:time-period-shift per dur (tm:as-empty-time-period per)) )
350
351(define (time-period-shift! per dur)
352  (%check-time-period 'time-period-shift! per)
353  (%check-time 'time-period-shift! dur)
354  (tm:duration-check 'time-period-shift! dur)
355  (tm:time-period-shift per dur per) )
Note: See TracBrowser for help on using the repository browser.