events: MONTHLY RRULE expansion (bymonthday + ordinal byday) + 13 tests
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>
This commit is contained in:
2026-06-06 23:52:39 +00:00
parent 797c5f9147
commit 70aea21601
5 changed files with 354 additions and 61 deletions

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

View File

@@ -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"
}

View File

@@ -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 |

View File

@@ -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