blob: 928f9abbf28abd6ffc5f1fc304c0f7da5ac1c83c (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
|
(define-module (srfi srfi-19 util)
#:use-module (srfi srfi-9 gnu)
#:use-module (srfi srfi-19)
#:use-module (srfi srfi-19 setters)
#:use-module (srfi srfi-41)
#:export (copy-date
drop-time! drop-time
in-day? today?
;; seconds minutes hours days weeks
;; time-add
make-duration
time->string
add-day remove-day))
#;
(define (copy-date date)
"Returns a copy of the given date structure"
(let* ((date-type (@@ (srfi srfi-19) date))
(access (lambda (field) ((record-accessor date-type field) date))))
(apply make-date (map access (record-type-fields date-type)))))
(define (drop-time! date)
"Sets the hour, minute, second and nanosecond attribute of date to 0."
(set! (hour date) 0)
(set! (minute date) 0)
(set! (second date) 0)
(set! (nanosecond date) 0)
date)
(define (drop-time date)
"Returns a copy of date; with the hour, minute, second and nanosecond
attribute set to 0. Can also be seen as \"Start of day\""
(set-fields date
((date-hour) 0)
((date-minute) 0)
((date-second) 0)
((date-nanosecond) 0)))
(define-public (start-of-day* time)
(date->time-utc (drop-time (time-utc->date time))))
(define (make-duration s)
(make-time time-duration 0 s))
(define (in-day? day-date time)
(let* ((now (date->time-utc (drop-time day-date)))
(then (add-duration now (make-duration (* 60 60 24)))))
(and (time<=? now time)
(time<=? time then))))
(define (today? time)
(in-day? (current-date) time))
(define* (time->string time #:optional (format "~1 ~3"))
(date->string (time-utc->date time) format))
(define (add-day time)
(add-duration time (make-duration (* 60 60 24))))
(define (remove-day time)
(add-duration time (make-duration (- (* 60 60 24)))))
;; @verbatim
;; A B C D E ¬F
;; |s1| : |s2| : |s1| : |s2| : : |s1|
;; | | : | | : | ||s2| : |s1|| | : |s1||s2| : | |
;; | ||s2| : |s1|| | : | || | : | || | : | || | :
;; | | : | | : | || | : | || | : | || | : |s2|
;; | | : | | : | | : | | : : | |
;; @end verbatim
;;
;; E is covered by both case A and B.
(define-public (timespan-overlaps? s1-begin s1-end s2-begin s2-end)
"Return whetever or not two timespans overlap."
(or
;; A
(and (time<? s2-begin s1-end)
(time<? s1-begin s2-end))
;; B
(and (time<? s1-begin s2-end)
(time<? s2-begin s1-end))
;; C
(and (time<? s1-begin s2-begin)
(time<? s2-end s1-end))
;; D
(and (time<? s2-begin s1-begin)
(time<? s1-end s2-end))))
(define-public (normalize-date date)
(time-utc->date (date->time-utc date)
(zone-offset date)))
;; Returns a stream of date objects, one day appart, staring from start-day.
(define-public (day-stream start-day)
(stream-iterate
(lambda (d)
(set! (day d) (1+ (day d)))
(normalize-date d))
start-day))
|
