source: project/release/5/srfi-19/tags/4.1.0/srfi-19-period.scm @ 38113

Last change on this file since 38113 was 38113, checked in by Kon Lovett, 8 months ago

rel 4.1.0

File size: 13.1 KB
Line 
1;;;; srfi-19-period.scm
2;;;; Chicken port, Kon Lovett, Apr '07
3
4;;Issues
5;;
6;; - time-period-null handling is poor.
7;;
8;; - Use a half-closed interval - [begin end)? Currently [B E]!
9
10(include "chicken-primitive-object-inlines")
11
12(module srfi-19-period
13
14(;export
15  time-period?
16  check-time-period
17  error-time-period
18  #;time-period-null?
19  time-period-compare
20  time-period=?
21  time-period<?
22  time-period>?
23  time-period<=?
24  time-period>=?
25  time-period-type
26  time-period-begin
27  time-period-end
28  time-period-last
29  time-period-length
30  #;make-null-time-period
31  make-time-period
32  copy-time-period
33  time-period-contains/period?
34  time-period-contains/time?
35  time-period-contains/date?
36  time-period-contains?
37  time-period-intersects?
38  time-period-intersection
39  time-period-union
40  time-period-span
41  time-period-shift
42  time-period-shift!
43  time-period-preceding
44  time-period-succeeding)
45
46(import scheme)
47(import (chicken base))
48(import (only (chicken format) format))
49(import (only (chicken read-syntax) define-reader-ctor))
50(import record-variants)
51(import type-checks)
52(import type-errors)
53(import srfi-19-core)
54
55;;;
56
57(include "srfi-19-common")
58
59;;;
60
61(define ONE-NANOSECOND-DURATION (one-nanosecond-duration))
62
63;;;
64
65(define (error-time-object loc obj)
66  (error-argument-type loc obj "time object") )
67
68(define (error-incompatible-clock-type loc obj)
69  (signal-type-error loc "incompatible clock type" obj) )
70
71(define (error-incompatible-clock-types loc obj1 obj2)
72  (signal-type-error loc "incompatible clock types" obj1 obj2) )
73
74;;;
75
76(define (tm:time-point-within? b1 e1 b2 e2)
77  (and (tm:time<=? b1 b2) (tm:time<=? e2 e1)) )
78
79;can return an inverted period
80(define (tm:time-point-intersection b1 e1 b2 e2)
81  (values (tm:time-max b1 b2) (tm:time-min e1 e2)) )
82
83;cannot return an inverted period
84(define (tm:time-point-union b1 e1 b2 e2)
85  (values (tm:time-min b1 b2) (tm:time-max e1 e2)) )
86
87;;; Time Period
88
89;#| ;dependency
90(define-constant time-period 'time-period)
91(define-record-type-variant time-period (unchecked #;inline unsafe)
92  (%make-time-period beg end)
93  %time-period?
94  (beg %time-period-begin)
95  (end %time-period-end) )
96;|#
97#; ;no dependency
98(define-record-type time-period
99  (%make-time-period beg end)
100  %time-period?
101  (beg %time-period-begin)
102  (end %time-period-end) )
103
104(define-check+error-type time-period %time-period?)
105
106(define-record-printer (time-period per out)
107  (format out
108    "#,(time-period ~A ~A)"
109    (%time-period-begin per)
110    (%time-period-end per)) )
111
112(define-reader-ctor 'time-period
113  (lambda (beg end)
114    (%make-time-period beg end)))
115
116(define (check-time-period-binop loc obj1 obj2)
117  (check-time-period loc obj1)
118  (check-time-period loc obj2) )
119
120(define (tm:time-period-type per)
121  (tm:time-type (%time-period-begin per)))
122
123#; ;BAD IDEA
124(define (tm:time-period-null? per)
125  (tm:time<=? (%time-period-end per) (%time-period-begin per)) )
126
127(define (tm:make-time-period-zero obj)
128  (let ((tt (if (time-period? obj) (tm:time-period-type obj) obj)))
129    (%make-time-period (zero-time tt) (zero-time tt)) ) )
130
131(define (tm:ensure-compatible-time loc t1 t2)
132  (let ((tt1 (tm:time-type t1))
133        (tt2 (tm:time-type t2)))
134    (define (errtt) (error-incompatible-clock-types loc t1 t2))
135    (if (eq? tt1 tt2)
136      t2
137      (let ((ntime (tm:any-time)))
138        (case tt1
139          ((tai)
140            (case tt2
141              ((utc)        (tm:time-utc->time-tai t2 ntime))
142              ((monotonic)  (tm:time-monotonic->time-tai t2 ntime))
143              (else
144               (errtt))))
145          ((utc)
146            (case tt2
147              ((tai)        (tm:time-tai->time-utc t2 ntime))
148              ((monotonic)  (tm:time-monotonic->time-utc t2 ntime))
149              (else
150               (errtt))))
151          ((monotonic)
152            (case tt2
153              ((utc)        (tm:time-utc->time-monotonic t2 ntime))
154              ((tai)        (tm:time-tai->time-monotonic t2 ntime))
155              (else
156               (errtt))))
157          (else
158           (errtt)) ) ) ) ) )
159
160(define (tm:ensure-compatible-time-period-begin loc per1 per2)
161  (tm:ensure-compatible-time loc
162    (%time-period-begin per1)
163    (%time-period-begin per2)) )
164
165(define (tm:ensure-compatible-time-period-end loc per1 per2)
166  (tm:ensure-compatible-time loc
167    (%time-period-end per1)
168      (%time-period-end per2)) )
169
170(define (tm:ensure-compatible-date loc tim dat)
171  (or
172    (tm:date->time dat (tm:time-type tim))
173    (error-incompatible-clock-type loc tim)) )
174
175(define (tm:time-period-type=? per1 per2)
176  (eq? (tm:time-period-type per1) (tm:time-period-type per2)) )
177
178(define (tm:time-period=? per1 per2)
179  (and (tm:time=? (%time-period-begin per1) (%time-period-begin per2))
180       (tm:time=? (%time-period-end per1) (%time-period-end per2))) )
181
182(define (tm:time-period-contains/period? loc per1 per2)
183  (let ((tper
184          (if (tm:time-period-type=? per1 per2)
185            per2
186            (%make-time-period
187              (tm:ensure-compatible-time-period-begin loc per1 per2)
188              (tm:ensure-compatible-time-period-end loc per1 per2)) ) ) )
189    (tm:time-point-within?
190     (%time-period-begin per1) (%time-period-end per1)
191     (%time-period-begin tper) (%time-period-end tper)) ) )
192
193(define (tm:time-period-contains/time? loc per tim)
194  (let ((tpt (tm:ensure-compatible-time loc (%time-period-begin per) tim)))
195    (tm:time-point-within? (%time-period-begin per) (%time-period-end per) tpt tpt) ) )
196
197(define (tm:time-period-contains/date? loc per dat)
198  (tm:time-period-contains/time?
199    loc per (tm:ensure-compatible-date loc (%time-period-begin per) dat)) )
200
201(define (tm:time-period-shift perin dur perout)
202  (tm:add-duration (%time-period-begin perin) dur (%time-period-begin perout))
203  (tm:add-duration (%time-period-end perin) dur (%time-period-end perout))
204  perout )
205
206#; ;FIXME - should take into account span
207(define (tm:time-period-subtract per1 per2)
208  (let ((diff (- (%time-period-begin per1) (%time-period-begin per2))))
209    (if (zero? diff)
210      (- (%time-period-end per1) (%time-period-end per2))
211      diff ) ) )
212
213;;
214
215#; ;BAD IDEA
216(define (make-null-time-period . args)
217  (let-optionals args ((tt (default-date-clock-type)))
218    (tm:make-time-period-zero tt) ) )
219
220#; ;BAD IDEA
221(define (time-period-null? per)
222  (check-time-period 'time-period-null? per)
223  (tm:time-period-null? per) )
224
225(define (make-time-period beg end . args)
226  (let-optionals args ((tt (default-date-clock-type)))
227    (check-clock-type 'make-time-period tt)
228    ;
229    (cond
230      ((real? beg)  (set! beg (tm:seconds->time beg tt)) )
231      ((date? beg)  (set! beg (tm:date->time beg tt)) ) )
232    (check-time 'make-time-period beg 'begin)
233    (when (tm:time-has-type? (tm:time-type beg) 'duration)
234      (error-clock-type 'make-time-period beg 'begin))
235    ;
236    (cond
237      ((real? end)  (set! end (tm:seconds->time end 'duration)) )
238      ((date? end)  (set! end (tm:ensure-compatible-date 'make-time-period beg end)) ) )
239    (check-time 'make-time-period end 'end)
240    (when (tm:time-has-type? (tm:time-type end) 'duration)
241      (set! end (tm:add-duration beg end (tm:as-some-time beg))))
242    ;
243    (when (tm:time<? end beg)
244      (signal-type-error 'make-time-period "inverted time period" beg end) )
245    ;
246    (%make-time-period beg (tm:ensure-compatible-time 'make-time-period beg end)) ) )
247
248(define (time-period? obj) (%time-period? obj))
249
250(define (copy-time-period per)
251  (check-time-period 'copy-time-period per)
252  (%make-time-period
253    (tm:copy-time (%time-period-begin per))
254    (tm:copy-time (%time-period-end per))) )
255
256(define (time-period-type per)
257  (tm:time-period-type (check-time-period 'time-period-type per)) )
258
259(define (time-period-begin per)
260  (%time-period-begin (check-time-period 'time-period-begin per)) )
261
262(define (time-period-end per)
263  (%time-period-end (check-time-period 'time-period-end per)) )
264
265(define (time-period-compare per1 per2)
266  (check-time-period-binop 'time-period-compare per1 per2)
267  (cond
268    ((tm:time<? (%time-period-end per1) (%time-period-begin per2))
269      -1)
270    ((tm:time-period=? per1 per2)
271      0)
272    (else
273      1) )
274  #;
275  (let ((diff (tm:time-period-subtract per1 per2)))
276    (cond ((negative? diff) -1)
277          ((zero? diff)     0)
278          (else             1 ) ) ) )
279
280(define (time-period=? per1 per2)
281  (check-time-period-binop 'time-period=? per1 per2)
282  (tm:time-period=? per1 per2) )
283
284(define (time-period<? per1 per2)
285  (check-time-period-binop 'time-period<? per1 per2)
286  (tm:time<? (%time-period-end per1) (%time-period-begin per2)) )
287
288(define (time-period>? per1 per2)
289  (check-time-period-binop 'time-period>? per1 per2)
290  (tm:time>? (%time-period-begin per1) (%time-period-end per2)) )
291
292(define (time-period<=? per1 per2)
293  (check-time-period-binop 'time-period<=? per1 per2)
294  (tm:time<=? (%time-period-end per1) (%time-period-begin per2)) )
295
296(define (time-period>=? per1 per2)
297  (check-time-period-binop 'time-period>=? per1 per2)
298  (tm:time>=? (%time-period-begin per1) (%time-period-end per2)) )
299
300(define (time-period-preceding per1 per2)
301  (check-time-period-binop 'time-period-preceding per1 per2)
302  (and
303    (tm:time<=? (%time-period-begin per1) (%time-period-begin per2))
304    (make-time-period (%time-period-begin per1) (%time-period-begin per2)) ) )
305
306(define (time-period-succeeding per1 per2)
307  (check-time-period-binop 'time-period-succeeding per1 per2)
308  (and
309    (tm:time>=? (%time-period-end per1) (%time-period-end per2))
310    (make-time-period (%time-period-end per2) (%time-period-end per1)) ) )
311
312(define (time-period-last per)
313  (check-time-period 'time-period-last per)
314  (let ((end (%time-period-end per)))
315    (tm:subtract-duration end ONE-NANOSECOND-DURATION (tm:as-some-time end)) ) )
316
317(define (time-period-length per)
318  (check-time-period 'time-period-length per)
319  (let ((dur (zero-time 'duration)))
320    (tm:time-difference (%time-period-begin per) (%time-period-end per) dur)
321    #; ;BAD IDEA
322    (if (tm:time-period-null? per)
323      dur
324      (tm:time-difference (%time-period-begin per) (%time-period-end per) dur)) ) )
325
326(define (time-period-contains/period? per1 per2)
327  (tm:time-period-contains/period? 'time-period-contains/period?
328    (check-time-period 'time-period-contains/period? per1)
329    (check-time-period 'time-period-contains/period? per2)) )
330
331(define (time-period-contains/time? per tim)
332  (tm:time-period-contains/time? 'time-period-contains/time?
333    (check-time-period 'time-period-contains/time? per)
334    (check-time 'time-period-contains/time? tim)) )
335
336(define (time-period-contains/date? per dat)
337  (tm:time-period-contains/date? 'time-period-contains/date?
338    (check-time-period 'time-period-contains/date? per)
339    (check-date 'time-period-contains/date? dat)) )
340
341(define (time-period-contains? per obj)
342  (check-time-period 'time-period-contains? per)
343  (cond
344    ((time-period? obj)
345      (tm:time-period-contains/period? 'time-period-contains? per obj))
346    ((time? obj)
347      (tm:time-period-contains/time? 'time-period-contains? per obj))
348    ((date? obj)
349      (tm:time-period-contains/date? 'time-period-contains? per obj))
350    (else
351      (error-time-object 'time-period-contains? obj))) )
352
353;#f when no intersection (inverted period)
354(define (time-period-intersects? per1 per2)
355  (->boolean (time-period-intersection per1 per2)) )
356
357;#f when no overlap
358(define (time-period-intersection per1 per2)
359  (check-time-period 'time-period-intersection per1)
360  (check-time-period 'time-period-intersection per2)
361  (let ((b1 (%time-period-begin per1))
362        (e1 (%time-period-end per1)))
363    (let ((b2 (tm:ensure-compatible-time 'time-period-intersection
364                b1 (%time-period-begin per2)))
365          (e2 (tm:ensure-compatible-time 'time-period-intersection
366                e1 (%time-period-end per2))))
367      (receive (bi ei) (tm:time-point-intersection b1 e1 b2 e2)
368        (and (tm:time<=? bi ei)
369             (%make-time-period bi ei)) ) ) ) )
370
371;#f when no overlap
372(define (time-period-union per1 per2)
373  (check-time-period 'time-period-union per1)
374  (check-time-period 'time-period-union per2)
375  (let ((b1 (%time-period-begin per1))
376        (e1 (%time-period-end per1)))
377    (let ((b2 (tm:ensure-compatible-time 'time-period-union b1 (time-period-begin per2)))
378          (e2 (tm:ensure-compatible-time 'time-period-union e1 (time-period-end per2))))
379      (receive (bi ei) (tm:time-point-intersection b1 e1 b2 e2)
380        (and (tm:time<=? bi ei)
381             (receive (bu eu) (tm:time-point-union b1 e1 b2 e2)
382               (%make-time-period bu eu) ) ) ) ) ) )
383
384(define (time-period-span per1 per2)
385  (check-time-period 'time-period-span per1)
386  (check-time-period 'time-period-span per2)
387  (let ((b1 (%time-period-begin per1))
388        (e1 (%time-period-end per1)))
389    (let ((b2 (tm:ensure-compatible-time 'time-period-span b1 (%time-period-begin per2)))
390          (e2 (tm:ensure-compatible-time 'time-period-span e1 (%time-period-end per2))))
391    (receive (bu eu) (tm:time-point-union b1 e1 b2 e2)
392      (%make-time-period bu eu) ) ) ) )
393
394(define (time-period-shift per dur)
395  (check-time-period 'time-period-shift per)
396  (check-duration 'time-period-shift dur)
397  (tm:time-period-shift per dur (tm:make-time-period-zero per)) )
398
399(define (time-period-shift! per dur)
400  (check-time-period 'time-period-shift! per)
401  (check-duration 'time-period-shift! dur)
402  (tm:time-period-shift per dur per) )
403
404) ;srfi-19-period
Note: See TracBrowser for help on using the repository browser.