(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)))))