1 files changed, 133 insertions, 0 deletions
diff --git a/src/date-utils.scm b/src/date-utils.scm
new file mode 100644
index 0000000..b977f13
--- /dev/null
+++ b/src/date-utils.scm
@@ -0,0 +1,133 @@
+(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
+         (years (iota (+ 2
+                         (- (date-year (current-date))
+                            2019))
+                      2019))
+         (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)))))