giles
70aea21601
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 44s
BYMONTHDAY (negative = from end), ordinal BYDAY ({:ord :wd}, last-weekday),
default day-of-month skipping short months. Weekly+monthly share ev-emit-occs.
37/37 green.
Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
469 lines
14 KiB
Plaintext
469 lines
14 KiB
Plaintext
;; 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}))
|
|
|
|
(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 ----
|
|
;; Returns a list of occurrence dicts {:id :start :end} within the window.
|
|
(define
|
|
ev-expand
|
|
(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: unsupported freq: " freq))))
|
|
acc))))))
|
|
|
|
;; ---- 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)))))
|