;; lib/events/calendar.sx — civil date arithmetic + RRULE expansion in a window.
;;
;; Datetimes are integer "epoch minutes": days-since-1970-01-01 * 1440 plus
;; minute-of-day. Ordering, window bounds, and durations are plain integer
;; arithmetic. Civil <-> day-number conversion uses Howard Hinnant's algorithm
;; (exact, branch-free, correct for the proleptic Gregorian calendar).
;;
;; RRULE expansion is the bridge to Datalog: a recurring event expands to a
;; bounded list of occurrence dicts within an explicit (win-start, win-end)
;; window. Expansion is ALWAYS windowed — an RRULE without a window is an
;; infinite computation and is never permitted. Supported subset (RFC 5545):
;; FREQ=DAILY|WEEKLY|MONTHLY, INTERVAL, COUNT, UNTIL, BYDAY (weekly: weekday
;; numbers; monthly: {:ord N :wd W} ordinal weekdays), BYMONTHDAY (monthly,
;; negative = from month end). YEARLY and the rest are deferred.

;; ---- integer helpers ----

;; Floored integer division (modulo is already floored, so the remainder
;; subtraction makes the quotient exact and floor-correct for any sign).
(define ev-floor-div (fn (a b) (quotient (- a (modulo a b)) b)))

(define ev-or (fn (x d) (if (nil? x) d x)))

(define ev-filter-nil (fn (xs) (filter (fn (x) (not (nil? x))) xs)))

;; ---- civil date core (Hinnant) ----

;; Days since 1970-01-01 for civil (y, m, d). m in [1,12], d in [1,31].
(define
  ev-days-from-civil
  (fn
    (y0 m d)
    (let
      ((y (if (<= m 2) (- y0 1) y0)))
      (let
        ((era (ev-floor-div (if (>= y 0) y (- y 399)) 400)))
        (let
          ((yoe (- y (* era 400)))
            (doy
              (+
                (ev-floor-div
                  (+
                    (*
                      153
                      (+ m (if (> m 2) -3 9)))
                    2)
                  5)
                (- d 1))))
          (let
            ((doe (+ (* yoe 365) (ev-floor-div yoe 4) (- (ev-floor-div yoe 100)) doy)))
            (+ (* era 146097) doe -719468)))))))

;; Civil (y m d) list from a day-number.
(define
  ev-civil-from-days
  (fn
    (z0)
    (let
      ((z (+ z0 719468)))
      (let
        ((era (ev-floor-div (if (>= z 0) z (- z 146096)) 146097)))
        (let
          ((doe (- z (* era 146097))))
          (let
            ((yoe (ev-floor-div (+ (- doe (ev-floor-div doe 1460)) (ev-floor-div doe 36524) (- (ev-floor-div doe 146096))) 365)))
            (let
              ((y (+ yoe (* era 400)))
                (doy
                  (-
                    doe
                    (+
                      (* 365 yoe)
                      (ev-floor-div yoe 4)
                      (- (ev-floor-div yoe 100))))))
              (let
                ((mp (ev-floor-div (+ (* 5 doy) 2) 153)))
                (let
                  ((d (+ (- doy (ev-floor-div (+ (* 153 mp) 2) 5)) 1))
                    (m
                      (if
                        (< mp 10)
                        (+ mp 3)
                        (- mp 9))))
                  (list (if (<= m 2) (+ y 1) y) m d))))))))))

;; Weekday of a day-number: 0=Mon .. 6=Sun (1970-01-01 is Thursday = 3).
(define ev-weekday-of-days (fn (z) (modulo (+ z 3) 7)))

(define
  ev-days-in-month
  (fn
    (y m)
    (-
      (ev-days-from-civil
        (if (= m 12) (+ y 1) y)
        (if (= m 12) 1 (+ m 1))
        1)
      (ev-days-from-civil y m 1))))

;; Add k months to (y,m), returning (list y2 m2).
(define
  ev-add-months
  (fn
    (y m k)
    (let
      ((total (+ (* y 12) (- m 1) k)))
      (list
        (ev-floor-div total 12)
        (+ (modulo total 12) 1)))))

;; ---- datetime (epoch minutes) ----

(define
  ev-dt
  (fn
    (y m d hh mm)
    (+ (* (ev-days-from-civil y m d) 1440) (* hh 60) mm)))

(define ev-date (fn (y m d) (ev-dt y m d 0 0)))

(define ev-dt->days (fn (t) (ev-floor-div t 1440)))

(define ev-dt->civil (fn (t) (ev-civil-from-days (ev-dt->days t))))

(define ev-dt-weekday (fn (t) (ev-weekday-of-days (ev-dt->days t))))

(define ev-dt-tod (fn (t) (modulo t 1440)))

(define ev-civ-y (fn (c) (first c)))
(define ev-civ-m (fn (c) (first (rest c))))
(define ev-civ-d (fn (c) (first (rest (rest c)))))

;; ---- event + occurrence constructors ----

;; rrule is nil (single event) or a dict:
;;   {:freq :daily|:weekly|:monthly :interval N :count N|nil :until DT|nil
;;    :byday ...|nil :bymonthday (list 15 -1)|nil}
;;   weekly  :byday -> (list 0 2 4)            weekday numbers, 0=Mon
;;   monthly :byday -> (list {:ord 2 :wd 1})   nth weekday (ord<0 from end)
;;   monthly :bymonthday -> (list 15 -1)       day of month (negative from end)
(define ev-event (fn (id dtstart duration rrule capacity) {:duration duration :id id :dtstart dtstart :capacity capacity :rrule rrule}))

;; Event with EXDATE/RDATE exceptions. exdate/rdate are lists of epoch-minute
;; starts to exclude from / add to the expansion (RFC 5545 VEVENT properties).
(define
  ev-event-full
  (fn
    (id dtstart duration rrule capacity exdate rdate)
    {:duration duration
      :id id
      :dtstart dtstart
      :capacity capacity
      :rrule rrule
      :exdate exdate
      :rdate rdate}))

(define ev-occ (fn (id start dur) {:id id :start start :end (+ start dur)}))

;; ---- DAILY expansion ----
;; occ starts at dtstart; n counts every generated occurrence (window-
;; independent, so COUNT/UNTIL bound the rule, not the view). Emits only
;; occurrences inside [win-start, win-end].
(define
  ev-daily-loop
  (fn
    (id occ duration step count until dtstart win-start win-end acc n)
    (cond
      ((> occ win-end) acc)
      ((and (not (nil? count)) (>= n count)) acc)
      ((and (not (nil? until)) (> occ until)) acc)
      (else
        (begin
          (when (>= occ win-start) (append! acc (ev-occ id occ duration)))
          (ev-daily-loop
            id
            (+ occ step)
            duration
            step
            count
            until
            dtstart
            win-start
            win-end
            acc
            (+ n 1)))))))

;; ---- shared per-period emit ----
;; Walk a start-ascending list of candidate occurrence datetimes for one
;; period, generating (count toward COUNT) those >= dtstart within UNTIL, and
;; emitting those also inside the window. Returns the updated running n.
(define
  ev-emit-occs
  (fn
    (id occs duration count until dtstart win-start win-end acc n)
    (if
      (empty? occs)
      n
      (let
        ((occ (first occs)))
        (let
          ((generates? (and (>= occ dtstart) (or (nil? until) (<= occ until)) (or (nil? count) (< n count)))))
          (begin
            (when
              (and generates? (>= occ win-start) (<= occ win-end))
              (append! acc (ev-occ id occ duration)))
            (ev-emit-occs
              id
              (rest occs)
              duration
              count
              until
              dtstart
              win-start
              win-end
              acc
              (if generates? (+ n 1) n))))))))

;; ---- WEEKLY expansion ----
;; Iterate week by week from the Monday of dtstart's week; within each active
;; week emit each BYDAY (sorted). n counts every generated occurrence.

(define
  ev-week0-days
  (fn (dtstart) (- (ev-dt->days dtstart) (ev-dt-weekday dtstart))))

(define
  ev-byday-default
  (fn
    (byday dtstart)
    (if (nil? byday) (list (ev-dt-weekday dtstart)) (sort byday))))

(define
  ev-weekly-loop
  (fn
    (id
      week-days
      tod
      duration
      week-step
      bd
      count
      until
      dtstart
      win-start
      win-end
      acc
      n)
    (let
      ((week-start-dt (* week-days 1440)))
      (cond
        ((> week-start-dt win-end) acc)
        ((and (not (nil? count)) (>= n count)) acc)
        (else
          (let
            ((occs (map (fn (wd) (+ (* (+ week-days wd) 1440) tod)) bd)))
            (let
              ((n2 (ev-emit-occs id occs duration count until dtstart win-start win-end acc n)))
              (ev-weekly-loop
                id
                (+ week-days week-step)
                tod
                duration
                week-step
                bd
                count
                until
                dtstart
                win-start
                win-end
                acc
                n2))))))))

;; ---- MONTHLY expansion ----
;; Iterate month by month from dtstart's month, stepping by INTERVAL months.
;; Candidate days per month come from BYMONTHDAY, then ordinal BYDAY, else the
;; day-of-month of dtstart (skipped in months too short to contain it).

;; Resolve a BYMONTHDAY value to a valid day-of-month, or nil.
(define
  ev-resolve-monthday
  (fn
    (y m bmd)
    (let
      ((dim (ev-days-in-month y m)))
      (let
        ((day (if (< bmd 0) (+ dim 1 bmd) bmd)))
        (if (and (>= day 1) (<= day dim)) day nil)))))

;; Resolve an ordinal weekday {:ord :wd} to a day-of-month, or nil.
(define
  ev-resolve-nth-weekday
  (fn
    (y m ord wd)
    (let
      ((dim (ev-days-in-month y m)))
      (if
        (> ord 0)
        (let
          ((first-wd (ev-weekday-of-days (ev-days-from-civil y m 1))))
          (let
            ((day (+ 1 (modulo (- wd first-wd) 7) (* (- ord 1) 7))))
            (if (<= day dim) day nil)))
        (let
          ((last-wd (ev-weekday-of-days (ev-days-from-civil y m dim))))
          (let
            ((day (- dim (modulo (- last-wd wd) 7) (* (- (- ord) 1) 7))))
            (if (>= day 1) day nil)))))))

(define
  ev-month-candidates
  (fn
    (y m rrule dtstart)
    (let
      ((bmd (get rrule :bymonthday)) (byday (get rrule :byday)))
      (cond
        ((not (nil? bmd))
          (ev-filter-nil (map (fn (d) (ev-resolve-monthday y m d)) bmd)))
        ((not (nil? byday))
          (ev-filter-nil
            (map
              (fn
                (e)
                (ev-resolve-nth-weekday y m (get e :ord) (get e :wd)))
              byday)))
        (else
          (ev-filter-nil
            (list
              (ev-resolve-monthday y m (ev-civ-d (ev-dt->civil dtstart))))))))))

(define
  ev-monthly-loop
  (fn
    (id
      y
      m
      rrule
      duration
      tod
      interval
      count
      until
      dtstart
      win-start
      win-end
      acc
      n)
    (let
      ((month-start (ev-dt y m 1 0 0)))
      (cond
        ((> month-start win-end) acc)
        ((and (not (nil? count)) (>= n count)) acc)
        (else
          (let
            ((days (sort (ev-month-candidates y m rrule dtstart))))
            (let
              ((occs (map (fn (d) (+ (* (ev-days-from-civil y m d) 1440) tod)) days)))
              (let
                ((n2 (ev-emit-occs id occs duration count until dtstart win-start win-end acc n))
                  (nm (ev-add-months y m interval)))
                (ev-monthly-loop
                  id
                  (ev-civ-y nm)
                  (ev-civ-m nm)
                  rrule
                  duration
                  tod
                  interval
                  count
                  until
                  dtstart
                  win-start
                  win-end
                  acc
                  n2)))))))))

;; ---- top-level expansion ----
;; Raw expansion (RRULE / single event), before EXDATE/RDATE are applied.
;; Returns a list of occurrence dicts {:id :start :end} within the window.
(define
  ev-expand-base
  (fn
    (event win-start win-end)
    (let
      ((id (get event :id))
        (dtstart (get event :dtstart))
        (duration (get event :duration))
        (rrule (get event :rrule)))
      (if
        (nil? rrule)
        (if
          (and (>= dtstart win-start) (<= dtstart win-end))
          (list (ev-occ id dtstart duration))
          (list))
        (let
          ((freq (get rrule :freq))
            (interval (ev-or (get rrule :interval) 1))
            (count (get rrule :count))
            (until (get rrule :until))
            (byday (get rrule :byday))
            (acc (list)))
          (begin
            (cond
              ((= freq :daily)
                (ev-daily-loop
                  id
                  dtstart
                  duration
                  (* interval 1440)
                  count
                  until
                  dtstart
                  win-start
                  win-end
                  acc
                  0))
              ((= freq :weekly)
                (ev-weekly-loop
                  id
                  (ev-week0-days dtstart)
                  (ev-dt-tod dtstart)
                  duration
                  (* interval 7)
                  (ev-byday-default byday dtstart)
                  count
                  until
                  dtstart
                  win-start
                  win-end
                  acc
                  0))
              ((= freq :monthly)
                (let
                  ((civ (ev-dt->civil dtstart)))
                  (ev-monthly-loop
                    id
                    (ev-civ-y civ)
                    (ev-civ-m civ)
                    rrule
                    duration
                    (ev-dt-tod dtstart)
                    interval
                    count
                    until
                    dtstart
                    win-start
                    win-end
                    acc
                    0)))
              (else (error (str "ev-expand-base: unsupported freq: " freq))))
            acc))))))

;; ---- EXDATE / RDATE (RFC 5545 exceptions) ----
;; Applied AFTER raw expansion: RDATE adds explicit occurrences within the
;; window, EXDATE removes occurrences whose start matches (EXDATE wins over
;; RDATE). Both are VEVENT-level: (get event :exdate) / (get event :rdate) are
;; lists of epoch-minute starts; nil for plain events.

(define
  ev-num-member?
  (fn
    (n xs)
    (cond
      ((empty? xs) false)
      ((= n (first xs)) true)
      (else (ev-num-member? n (rest xs))))))

;; Drop duplicate-start occurrences from a start-sorted list (keep one).
(define
  ev-dedupe-by-start
  (fn
    (occs)
    (cond
      ((empty? occs) occs)
      ((empty? (rest occs)) occs)
      ((= (get (first occs) :start) (get (first (rest occs)) :start))
        (ev-dedupe-by-start (rest occs)))
      (else (cons (first occs) (ev-dedupe-by-start (rest occs)))))))

(define
  ev-apply-exceptions
  (fn
    (event base win-start win-end)
    (let
      ((id (get event :id))
        (duration (get event :duration))
        (exdate (ev-or (get event :exdate) (list)))
        (rdate (ev-or (get event :rdate) (list))))
      (let
        ((rdate-occs
           (reduce
             (fn
               (acc d)
               (if
                 (and (>= d win-start) (<= d win-end))
                 (cons (ev-occ id d duration) acc)
                 acc))
             (list)
             rdate)))
        (let
          ((no-ex
             (filter
               (fn (o) (not (ev-num-member? (get o :start) exdate)))
               (append base rdate-occs))))
          (ev-dedupe-by-start (ev-sort-occs no-ex)))))))

;; ---- per-occurrence overrides (RFC 5545 RECURRENCE-ID) ----
;; A single instance of a recurring series can be detached and rescheduled. The
;; event carries :overrides — a list of (orig-start {:start :duration}) — keyed
;; by the occurrence's ORIGINAL start. Applied after EXDATE/RDATE. A moved
;; instance whose new start leaves the window is dropped from this window (the
;; original slot is vacated); an instance moved INTO the window from outside is
;; out of scope for a windowed expansion (known stub limitation).

(define
  ev-assoc-lookup
  (fn
    (k pairs)
    (cond
      ((empty? pairs) nil)
      ((= (first (first pairs)) k) (first (rest (first pairs))))
      (else (ev-assoc-lookup k (rest pairs))))))

(define
  ev-apply-overrides
  (fn
    (id base overrides)
    (map
      (fn
        (o)
        (let
          ((ov (ev-assoc-lookup (get o :start) overrides)))
          (if (nil? ov) o (ev-occ id (get ov :start) (get ov :duration)))))
      base)))

;; Add an override that reschedules the occurrence originally at `orig-start`
;; to `new-start` with `new-duration`.
(define
  ev-with-override
  (fn
    (event orig-start new-start new-duration)
    (assoc
      event
      :overrides
      (cons
        (list orig-start {:start new-start :duration new-duration})
        (ev-or (get event :overrides) (list))))))

;; Naive (single time-domain) expansion: RRULE + EXDATE/RDATE + overrides.
(define
  ev-expand-naive
  (fn
    (event win-start win-end)
    (let
      ((excepted
         (ev-apply-exceptions
           event
           (ev-expand-base event win-start win-end)
           win-start
           win-end))
        (overrides (ev-or (get event :overrides) (list)))
        (id (get event :id)))
      (if
        (empty? overrides)
        excepted
        (filter
          (fn (o) (and (>= (get o :start) win-start) (<= (get o :start) win-end)))
          (ev-sort-occs (ev-apply-overrides id excepted overrides)))))))

;; Public entry point. A tz-aware event (`:tz` set) expands in local wall-clock
;; time and converts each occurrence to UTC (ev-expand-tz, timezone.sx); a plain
;; event expands naively in a single time domain. The window is UTC either way.
(define
  ev-expand
  (fn
    (event win-start win-end)
    (let
      ((tz (get event :tz)))
      (if
        (nil? tz)
        (ev-expand-naive event win-start win-end)
        (ev-expand-tz event tz win-start win-end)))))

;; ---- multi-event expansion (sorted by start) ----

;; Insertion of one occurrence into a start-ascending list.
(define
  ev-occ-insert
  (fn
    (o sorted)
    (cond
      ((empty? sorted) (list o))
      ((<= (get o :start) (get (first sorted) :start)) (cons o sorted))
      (else (cons (first sorted) (ev-occ-insert o (rest sorted)))))))

(define
  ev-sort-occs
  (fn (occs) (reduce (fn (acc o) (ev-occ-insert o acc)) (list) occs)))

;; Expand many events into one occurrence list, ascending by start.
(define
  ev-expand-all
  (fn
    (events win-start win-end)
    (let
      ((acc (list)))
      (begin
        (for-each
          (fn
            (ev)
            (for-each
              (fn (o) (append! acc o))
              (ev-expand ev win-start win-end)))
          events)
        (ev-sort-occs acc)))))