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

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

Save.

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