blob: 3da1d7095817e049072c402b301036f5b5895a17 (
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
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
|
(define-module (datetime util)
:use-module (datetime)
:use-module ((srfi srfi-1) :select (fold))
:use-module (srfi srfi-26)
:use-module (srfi srfi-41)
:use-module (util)
)
(define-public (start-of-month date)
(set (day date) 1))
(define-public (parse-freeform-date str)
(let* (((year month day) (map string->number (string-split str #\-))))
(date year: year month: month day: day)
))
(define-public (day-stream start-day)
(stream-iterate (cut date+ <> #0-0-1)
start-day))
(define-public (month-stream start-day)
(stream-iterate (cut date+ <> #0-1-0)
start-day))
(define-public (time-min a b)
(if (time<? a b) a b))
(define-public (time-max a b)
(if (time<? a b) b a))
;; https://projecteuclid.org/euclid.acta/1485888738
;; 1. Begel.
;; J sei die Zahl des Jahrhunderts,
;; K die Jahrszahl innerhalb desselben,
;; m die Zahl des Monats,
;; q die Zahl des Monatstags,
;; h die Zahl des Wochentags;
(define (zeller J K m q)
(modulo (+ q
(floor-quotient (* 13 (1+ m))
5)
K
(floor-quotient K 4)
5
(- J))
7))
;; 0 indexed, starting at sunday.
(define-public (week-day date)
(let* ((J K (floor/ (year date) 100))
(m (month date)))
(if (memv m '(1 2))
(zeller J (1- K) (+ m 12) (day date))
(zeller J K (month date) (day date)))))
(define-many define-public
(sun) 0
(mon) 1
(tue) 2
(wed) 3
(thu) 4
(fri) 5
(sat) 6
)
(define*-public (week-day-name week-day-number optional: truncate-to)
;; TODO internationalization
(let ((str
(case* week-day-number
[(sun 7) "Söndag"]
[(mon) "Måndag"]
[(tue) "Tisdag"]
[(wed) "Onsdag"]
[(thu) "Torsdag"]
[(fri) "Fredag"]
[(sat) "Lördag"]
[else (error 'argument-error "No day ~a in week" week-day-number)])))
(if truncate-to
(string-take str truncate-to)
str)))
(define*-public (date->string date optional: (fmt "~Y-~m-~d") key: allow-unknown?)
(with-output-to-string
(lambda ()
(fold (lambda (token state)
(case state
((#\~)
(case token
((#\~) (display "~"))
((#\Y) (format #t "~4'0d" (year date)))
((#\m) (format #t "~2'0d" (month date)))
((#\d) (format #t "~2'0d" (day date)))
((#\1) (format #t "~4'0d-~2'0d-~2'0d"
(year date) (month date) (day date)))
((#\a) (display (week-day-name (week-day date))))
(else (unless allow-unknown?
(error 'date->string "Invalid format token ~a" token))))
#f)
(else (unless (char=? #\~ token) (display token)) token)))
#f
(string->list fmt)))))
(define*-public (time->string time optional: (fmt "~H:~M:~S") key: allow-unknown?)
(with-output-to-string
(lambda ()
(fold (lambda (token state)
(case state
((#\~)
(case token
((#\~) (display "~"))
((#\H) (format #t "~2'0d" (hour time)))
((#\M) (format #t "~2'0d" (minute time)))
((#\S) (format #t "~2'0d" (second time)))
;; ((#\z) (when (utc? time) (display "Z")))
(else (unless allow-unknown?
(error 'time->string "Invalid format token ~a" token))))
#f)
(else (unless (char=? #\~ token) (display token)) token)))
#f
(string->list fmt)))))
;; @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 (date/-time<? s2-begin s1-end)
(date/-time<? s1-begin s2-end))
;; B
(and (date/-time<? s1-begin s2-end)
(date/-time<? s2-begin s1-end))
;; C
(and (date/-time<? s1-begin s2-begin)
(date/-time<? s2-end s1-end))
;; D
(and (date/-time<? s2-begin s1-begin)
(date/-time<? s1-end s2-end))))
(define-public (add-day d)
(date+ d (date day: 1)))
(define-public (remove-day d)
(date- d (date day: 1)))
;; Checks if @var{datetime} is within the date
;; given by @var{base-date}.
;; TODO test time zones
;; date x datetime → bool
;; (define-public (in-day? base-date date/-time)
;; (date< base-date (as-date date/-time) (date+ base-date (date day: 1))))
(define-public (in-date-range? start-date end-date)
(lambda (date)
(date<= start-date date end-date)))
|
