blob: 877da69fe11bdb2b379fe11fc0301fb459aa3508 (
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
|
(define-module (srfi srfi-19 alt util)
:use-module (srfi srfi-19 alt)
:use-module (srfi srfi-1)
:use-module (srfi srfi-26)
:use-module (srfi srfi-41)
:use-module (util)
)
(define-public (start-of-month date)
(set (day date) 0))
(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 (as-date date/-time)
(if (date? date/-time)
date/-time
(get-date date/-time)))
(define-public (as-time date/-time)
(if (datetime? date/-time)
(get-time date/-time)
#00:00:00))
(define-public (date/-time< a b)
(if (date< (as-date a) (as-date b))
#t
(time< (as-time a) (as-time b))))
(define-public date/-time<? date/-time<)
(define*-public (date->string date optional: (fmt "~Y-~m-~d"))
(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)))
(else (error "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"))
(with-output-to-string
(lambda ()
(fold (lambda (token state)
(case state
((#\~)
(case token
((#\~) (display "~"))
((#\H) (format #t "~2'0d" (hour date)))
((#\M) (format #t "~2'0d" (minute date)))
((#\S) (format #t "~2'0d" (second date)))
(else (error "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 date)
(date+ date (date day: 1)))
(define-public (remove-day date)
(date- date (date day: 1)))
|
