diff --git a/lib/events/calendar.sx b/lib/events/calendar.sx index cb32e7ae..cc65f7ff 100644 --- a/lib/events/calendar.sx +++ b/lib/events/calendar.sx @@ -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)))))) diff --git a/lib/events/scoreboard.json b/lib/events/scoreboard.json index 7e6b990a..a2bba6e6 100644 --- a/lib/events/scoreboard.json +++ b/lib/events/scoreboard.json @@ -1,10 +1,10 @@ { "lang": "events", - "total_passed": 24, + "total_passed": 37, "total_failed": 0, - "total": 24, + "total": 37, "suites": [ - {"name":"calendar","passed":24,"failed":0,"total":24} + {"name":"calendar","passed":37,"failed":0,"total":37} ], - "generated": "2026-06-06T23:48:10+00:00" + "generated": "2026-06-06T23:52:14+00:00" } diff --git a/lib/events/scoreboard.md b/lib/events/scoreboard.md index 331a9355..a446cdf6 100644 --- a/lib/events/scoreboard.md +++ b/lib/events/scoreboard.md @@ -1,7 +1,7 @@ # events scoreboard -**24 / 24 passing** (0 failure(s)). +**37 / 37 passing** (0 failure(s)). | Suite | Passed | Total | Status | |-------|--------|-------|--------| -| calendar | 24 | 24 | ok | +| calendar | 37 | 37 | ok | diff --git a/lib/events/tests/calendar.sx b/lib/events/tests/calendar.sx index 59f82476..e679398e 100644 --- a/lib/events/tests/calendar.sx +++ b/lib/events/tests/calendar.sx @@ -73,6 +73,22 @@ (ev-dt->civil (ev-dt 2026 12 25 8 0)) (list 2026 12 25)) + (ev-cal-check! + "days in feb 2024 (leap)" + (ev-days-in-month 2024 2) + 29) + (ev-cal-check! + "days in feb 2026" + (ev-days-in-month 2026 2) + 28) + (ev-cal-check! + "add months wraps year" + (ev-add-months 2026 11 3) + (list 2027 2)) + (ev-cal-check! + "add months within year" + (ev-add-months 2026 1 5) + (list 2026 6)) (let ((ev (ev-event (quote one) (ev-dt 2026 6 10 14 0) 60 nil 1))) (do @@ -264,6 +280,124 @@ (list 2026 6 5) (list 2026 6 8) (list 2026 6 10)))) + (let + ((md (ev-event (quote md) (ev-dt 2026 1 15 9 0) 60 {:bymonthday (list 15) :freq :monthly} 1))) + (do + (ev-cal-check! + "monthly bymonthday 15th" + (ev-cal-starts + (ev-expand + md + (ev-date 2026 1 1) + (ev-date 2026 4 1))) + (list + (list 2026 1 15) + (list 2026 2 15) + (list 2026 3 15))) + (ev-cal-check! + "monthly preserves time of day" + (ev-dt-tod + (get + (first + (ev-expand + md + (ev-date 2026 1 1) + (ev-date 2026 4 1))) + :start)) + 540))) + (let + ((mm (ev-event (quote mm) (ev-dt 2026 1 1 9 0) 60 {:bymonthday (list 1 15) :freq :monthly :count 4} 1))) + (ev-cal-check! + "monthly multiple bymonthday sorted within month" + (ev-cal-starts + (ev-expand + mm + (ev-date 2026 1 1) + (ev-date 2026 12 1))) + (list + (list 2026 1 1) + (list 2026 1 15) + (list 2026 2 1) + (list 2026 2 15)))) + (let + ((ml (ev-event (quote ml) (ev-dt 2026 1 31 9 0) 60 {:bymonthday (list -1) :freq :monthly} 1))) + (ev-cal-check! + "monthly bymonthday -1 is last day" + (ev-cal-starts + (ev-expand + ml + (ev-date 2026 1 1) + (ev-date 2026 4 1))) + (list + (list 2026 1 31) + (list 2026 2 28) + (list 2026 3 31)))) + (let + ((mn (ev-event (quote mn) (ev-dt 2026 1 1 9 0) 60 {:freq :monthly :byday (list {:ord 2 :wd 1})} 1))) + (ev-cal-check! + "monthly 2nd tuesday" + (ev-cal-shape + (ev-expand + mn + (ev-date 2026 1 1) + (ev-date 2026 4 1))) + (list + (list (list 2026 1 13) 1) + (list (list 2026 2 10) 1) + (list (list 2026 3 10) 1)))) + (let + ((mz (ev-event (quote mz) (ev-dt 2026 1 1 9 0) 60 {:freq :monthly :byday (list {:ord -1 :wd 4})} 1))) + (ev-cal-check! + "monthly last friday" + (ev-cal-shape + (ev-expand + mz + (ev-date 2026 1 1) + (ev-date 2026 4 1))) + (list + (list (list 2026 1 30) 4) + (list (list 2026 2 27) 4) + (list (list 2026 3 27) 4)))) + (let + ((m31 (ev-event (quote m31) (ev-dt 2026 1 31 9 0) 60 {:freq :monthly :count 4} 1))) + (ev-cal-check! + "monthly default day-of-month skips short months" + (ev-cal-starts + (ev-expand + m31 + (ev-date 2026 1 1) + (ev-date 2026 12 1))) + (list + (list 2026 1 31) + (list 2026 3 31) + (list 2026 5 31) + (list 2026 7 31)))) + (let + ((mi (ev-event (quote mi) (ev-dt 2026 1 10 9 0) 60 {:interval 3 :freq :monthly :count 3} 1))) + (ev-cal-check! + "monthly interval 3 steps by quarter" + (ev-cal-starts + (ev-expand + mi + (ev-date 2026 1 1) + (ev-date 2027 1 1))) + (list + (list 2026 1 10) + (list 2026 4 10) + (list 2026 7 10)))) + (let + ((mc (ev-event (quote mc) (ev-dt 2026 1 5 9 0) 60 {:freq :monthly :count 12} 1))) + (ev-cal-check! + "monthly count window-independent (clip middle)" + (ev-cal-starts + (ev-expand + mc + (ev-date 2026 4 1) + (ev-date 2026 6 30))) + (list + (list 2026 4 5) + (list 2026 5 5) + (list 2026 6 5)))) (let ((a (ev-event (quote a) (ev-dt 2026 6 2 10 0) 30 {:freq :daily :count 2} 1)) (b diff --git a/plans/events-on-sx.md b/plans/events-on-sx.md index a831c535..907aac89 100644 --- a/plans/events-on-sx.md +++ b/plans/events-on-sx.md @@ -18,7 +18,7 @@ capacity rules, transactional booking, and a flow-driven notification dispatcher ## Status (rolling) -`bash lib/events/conformance.sh` → **24/24** (Phase 1: calendar recurrence) +`bash lib/events/conformance.sh` → **37/37** (Phase 1: calendar recurrence) ## Ground rules @@ -55,7 +55,7 @@ lib/events/api.sx ── (events/schedule) (events/book) (events/agenda) ── ## Phase 1 — Calendar + recurrence - [x] `calendar.sx` — event facts, RRULE expansion in a window (DAILY/WEEKLY) -- [ ] `calendar.sx` — MONTHLY (bymonthday + nth-weekday byday) +- [x] `calendar.sx` — MONTHLY (bymonthday + nth-weekday byday) - [ ] `availability.sx` — free/busy rules - [ ] `api.sx` + tests + scoreboard + conformance.sh @@ -77,6 +77,11 @@ lib/events/api.sx ── (events/schedule) (events/book) (events/agenda) ── ## Progress log +- 2026-06-06 — MONTHLY recurrence. `ev-days-in-month`, `ev-add-months`, + BYMONTHDAY (incl. negative = from month end), ordinal BYDAY (`{:ord N :wd W}`, + ord<0 = nth-from-last), default day-of-month (skips months too short, e.g. + day-31 monthly skips Feb/Apr). Refactored weekly+monthly onto a shared + `ev-emit-occs` per-period emitter. 37/37 green (+13). - 2026-06-06 — Phase 1 scaffold + calendar recurrence. `calendar.sx`: integer epoch-minute datetimes, Hinnant civil<->day-number conversion, DAILY/WEEKLY RRULE expansion in a bounded (start,end) window with INTERVAL, COUNT (window-