coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
9adeff14314e2c6efd5419395bd0e1da8288bf76
rose-ash/lib/events/tests/availability.sx
giles 4674b797cb
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 35s
Details
events: next-free slot search + 6 tests 
ev-next-free finds the earliest free slot >= after for a duration within a
horizon, probing 'after' + busy-interval ends via the busy_in rule (ev-free?).
Finds gaps, skips too-short gaps, half-open at edges. 59/59 green.

Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
2026-06-07 00:49:42 +00:00

332 lines
8.8 KiB
Plaintext
Raw Blame History

This file contains ambiguous Unicode characters
This file contains Unicode characters that might be confused with other characters. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.
;; lib/events/tests/availability.sx — free/busy + conflict rules on Datalog.
(define ev-av-pass 0)
(define ev-av-fail 0)
(define ev-av-failures (list))
(define
ev-av-check!
(fn
(name got expected)
(if
(= got expected)
(set! ev-av-pass (+ ev-av-pass 1))
(do
(set! ev-av-fail (+ ev-av-fail 1))
(append!
ev-av-failures
(str name "\n expected: " expected "\n got: " got))))))
;; Fixture: three occurrences on 2026-06-01.
;; standup 09:00–09:30 review 09:15–10:15 (overlaps standup)
;; lunch 12:00–13:00
(define
ev-av-occs
(fn
()
(list
(ev-occ
(quote standup)
(ev-dt 2026 6 1 9 0)
30)
(ev-occ
(quote review)
(ev-dt 2026 6 1 9 15)
60)
(ev-occ
(quote lunch)
(ev-dt 2026 6 1 12 0)
60))))
(define ev-av-key (fn (id start) (str id "@" start)))
;; alice: standup + review (overlap → conflict). bob: lunch only.
(define
ev-av-db
(fn
()
(ev-avail-db
(ev-av-occs)
(list
(list
(quote alice)
(ev-av-key
(quote standup)
(ev-dt 2026 6 1 9 0)))
(list
(quote alice)
(ev-av-key
(quote review)
(ev-dt 2026 6 1 9 15)))
(list
(quote bob)
(ev-av-key
(quote lunch)
(ev-dt 2026 6 1 12 0)))))))
;; Disjoint fixture for slot search: 09:00–10:00 then 10:30–11:30 (a 30m gap).
(define
ev-av-gap-db
(fn
()
(ev-avail-db
(list
(ev-occ
(quote a)
(ev-dt 2026 6 1 9 0)
60)
(ev-occ
(quote b)
(ev-dt 2026 6 1 10 30)
60))
(list
(list
(quote sam)
(ev-av-key
(quote a)
(ev-dt 2026 6 1 9 0)))
(list
(quote sam)
(ev-av-key
(quote b)
(ev-dt 2026 6 1 10 30)))))))
(define
ev-av-run-all!
(fn
()
(let
((db (ev-av-db)))
(do
(ev-av-check!
"busy lists alice committed intervals ascending"
(ev-busy db (quote alice))
(list
(list
(ev-dt 2026 6 1 9 0)
(ev-dt 2026 6 1 9 30))
(list
(ev-dt 2026 6 1 9 15)
(ev-dt 2026 6 1 10 15))))
(ev-av-check!
"busy lists bob single interval"
(ev-busy db (quote bob))
(list
(list
(ev-dt 2026 6 1 12 0)
(ev-dt 2026 6 1 13 0))))
(ev-av-check!
"busy empty for unknown actor"
(ev-busy db (quote carol))
(list))
(ev-av-check!
"alice has an overlap conflict"
(ev-has-conflict? db (quote alice))
true)
(ev-av-check!
"alice conflict reported once (canonical pair)"
(len (ev-conflicts db (quote alice)))
1)
(ev-av-check!
"bob has no conflict"
(ev-has-conflict? db (quote bob))
false)
(ev-av-check!
"non-overlapping bookings do not conflict"
(ev-has-conflict?
(ev-avail-db
(list
(ev-occ
(quote a)
(ev-dt
2026
6
1
9
0)
30)
(ev-occ
(quote b)
(ev-dt
2026
6
1
9
30)
30))
(list
(list
(quote dave)
(ev-av-key
(quote a)
(ev-dt
2026
6
1
9
0)))
(list
(quote dave)
(ev-av-key
(quote b)
(ev-dt
2026
6
1
9
30)))))
(quote dave))
false)
(ev-av-check!
"alice free in an empty window"
(ev-free?
db
(quote alice)
(ev-dt 2026 6 1 13 0)
(ev-dt 2026 6 1 14 0))
true)
(ev-av-check!
"alice not free overlapping a booking"
(ev-free?
db
(quote alice)
(ev-dt 2026 6 1 9 20)
(ev-dt 2026 6 1 9 40))
false)
(ev-av-check!
"free? is half-open at the trailing edge"
(ev-free?
db
(quote alice)
(ev-dt 2026 6 1 10 15)
(ev-dt 2026 6 1 11 0))
true)
(ev-av-check!
"free? is half-open at the leading edge"
(ev-free?
db
(quote bob)
(ev-dt 2026 6 1 11 0)
(ev-dt 2026 6 1 12 0))
true)
(ev-av-check!
"free? false when window straddles a booking edge"
(ev-free?
db
(quote bob)
(ev-dt 2026 6 1 11 0)
(ev-dt 2026 6 1 12 1))
false)
(ev-av-check!
"free? query leaves db reusable (no leaked qwindow)"
(do
(ev-free?
db
(quote alice)
(ev-dt 2026 6 1 9 0)
(ev-dt 2026 6 1 9 30))
(ev-busy db (quote bob)))
(list
(list
(ev-dt 2026 6 1 12 0)
(ev-dt 2026 6 1 13 0))))
(let
((gdb (ev-av-gap-db)))
(do
(ev-av-check!
"next-free finds the gap between bookings"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 9 0)
30
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 10 0))
(ev-av-check!
"next-free skips a gap too short for the duration"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 9 0)
60
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 11 30))
(ev-av-check!
"next-free returns `after` when already free"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 14 0)
60
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 14 0))
(ev-av-check!
"next-free returns nil when nothing fits before horizon"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 9 0)
120
(ev-dt 2026 6 1 11 0))
nil)
(ev-av-check!
"next-free for actor with no bookings is `after`"
(ev-next-free
gdb
(quote nobody)
(ev-dt 2026 6 1 9 0)
60
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 9 0))
(ev-av-check!
"next-free at exact edge of a booking (half-open)"
(ev-next-free
gdb
(quote sam)
(ev-dt 2026 6 1 10 0)
30
(ev-dt 2026 6 1 18 0))
(ev-dt 2026 6 1 10 0))))
(let
((daily (ev-expand (ev-event (quote class) (ev-dt 2026 6 1 9 0) 60 {:freq :daily :count 3} 1) (ev-date 2026 6 1) (ev-date 2026 7 1))))
(let
((db2 (ev-avail-db daily (map (fn (o) (list (quote sam) (ev-occ-key o))) daily))))
(do
(ev-av-check!
"expanded daily occurrences become busy intervals"
(len (ev-busy db2 (quote sam)))
3)
(ev-av-check!
"no conflicts among disjoint daily occurrences"
(ev-has-conflict? db2 (quote sam))
false)
(ev-av-check!
"busy on day two of the series"
(ev-free?
db2
(quote sam)
(ev-dt
2026
6
2
9
30)
(ev-dt
2026
6
2
9
45))
false))))))))
(define
ev-availability-tests-run!
(fn
()
(do
(set! ev-av-pass 0)
(set! ev-av-fail 0)
(set! ev-av-failures (list))
(ev-av-run-all!)
{:failures ev-av-failures :total (+ ev-av-pass ev-av-fail) :passed ev-av-pass :failed ev-av-fail})))
Reference in New Issue View Git Blame Copy Permalink