coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

events: MONTHLY RRULE expansion (bymonthday + ordinal byday) + 13 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 44s
Details

Browse Source 
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>
This commit is contained in:
giles
2026-06-06 23:52:39 +00:00
parent 797c5f9147
commit 70aea21601
5 changed files with 354 additions and 61 deletions
Download Patch File Download Diff File Expand all files Collapse all files

260
lib/events/calendar.sx
View File

@@ -9,8 +9,9 @@
;; 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, INTERVAL, COUNT, UNTIL, BYDAY (weekly). MONTHLY and the
;; rest are deferred.
;; 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 ----
@@ -20,6 +21,8 @@
(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].
@@ -83,6 +86,28 @@
;; 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
@@ -101,11 +126,18 @@
(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 :interval N :count N|nil :until DT|nil
;; :byday (list 0 2 4)|nil} ; byday weekday numbers, 0=Mon
;; {: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)}))
@@ -138,10 +170,40 @@
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) whose datetime is >= dtstart and inside the
;; window. n counts every generated occurrence >= dtstart for COUNT.
;; 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
@@ -153,37 +215,6 @@
(byday dtstart)
(if (nil? byday) (list (ev-dt-weekday dtstart)) (sort byday))))
(define
ev-weekly-bd-loop
(fn
(id week-days tod duration bd count until dtstart win-start win-end acc n)
(if
(empty? bd)
n
(let
((wd (first bd)))
(let
((occ (+ (* (+ week-days wd) 1440) tod)))
(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-weekly-bd-loop
id
week-days
tod
duration
(rest bd)
count
until
dtstart
win-start
win-end
acc
(if generates? (+ n 1) n)))))))))
(define
ev-weekly-loop
(fn
@@ -207,21 +238,126 @@
((and (not (nil? count)) (>= n count)) acc)
(else
(let
((n2 (ev-weekly-bd-loop id week-days tod duration bd 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)))))))
((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.
@@ -277,6 +413,24 @@
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))))))