blob: 114f7b73e8560a7c3807b35968fc70a29b725950 (
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
|
(define-module (src date-utils)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-19)
#:export (lookup-start-date-for-week
lookup-end-date-for-week
next-week-with-year
previous-week-with-year
move-date-by-days
%week-start-lookup-data))
(define (move-date-by-days date days)
(let ((time-utc
(date->time-utc date))
(duration
(make-time time-duration
0
(* 24 60 60
days))))
(time-utc->date
(add-duration time-utc duration))))
(define (end-of-week-date date)
(let ((time-utc
(date->time-utc date))
(duration
(make-time time-duration
0
(- (* 24 60 60 7)
1))))
(time-utc->date
(add-duration time-utc duration))))
(define %week-start-lookup-data
(let* ((week-start-day 1) ; Monday
(start-year 2020)
(years (iota (+ 2
(- (date-year (current-date))
start-year))
start-year))
(first-week-mondays-by-year
(fold (lambda (year data)
(let* ((fourth-of-january
;; At least according to Wikipedia, the first week
;; of the year defined by ISO 8601 contains the
;; 4th of January
;; https://en.wikipedia.org/wiki/ISO_8601#Week_dates
(make-date 0 0 0 0 4 1 year 0))
(fourth-of-january-week-day
;; date-week-day starts on Sunday, so adjust the
;; numbering so that 0 is Monday, 1 is Tuesday,
;; ...
(modulo (- (date-week-day fourth-of-january)
1)
7)))
(cons
(cons year
(move-date-by-days fourth-of-january
(* fourth-of-january-week-day -1)))
data)))
'()
(append years
(list (+ 2 (date-year (current-date))))))))
(fold (lambda (year data)
(let ((first-week-monday
(assoc-ref first-week-mondays-by-year
year))
(time-for-first-week-monday-for-next-year
(date->time-utc
(assoc-ref first-week-mondays-by-year
(+ 1 year)))))
(cons (cons
year
(fold (lambda (week data)
(let ((start-date
(move-date-by-days
first-week-monday
(* 7
(- week 1)))))
(if (time>=? (date->time-utc start-date)
time-for-first-week-monday-for-next-year)
data
(cons (cons week start-date)
data))))
'()
(iota 53 1)))
data)))
'()
years)))
(define (lookup-start-date-for-week year week)
(assq-ref (assq-ref %week-start-lookup-data
year)
week))
(define (lookup-end-date-for-week year week)
(end-of-week-date
(assq-ref (assq-ref %week-start-lookup-data year)
week)))
(define (next-week-with-year year week)
(let* ((year-weeks
(assoc-ref %week-start-lookup-data
year))
(last-week
(apply max (map car year-weeks))))
(if (eq? week last-week)
(if (eq? year
(apply max
(map car %week-start-lookup-data)))
#f
(list (+ year 1)
1))
(list year
(+ week 1)))))
(define (previous-week-with-year year week)
(let* ((year-weeks
(assoc-ref %week-start-lookup-data
year)))
(if (eq? week 1)
(let ((previous-year-weeks
(assoc-ref %week-start-lookup-data
(- year 1))))
(if previous-year-weeks
(list (- year 1)
(apply max
(map car previous-year-weeks)))
#f))
(list year
(- week 1)))))
|