events: availability.sx — free/busy + conflict detection on Datalog + 16 tests
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m1s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m1s
occurrence/booking EDB; rules busy/conflict (canonical pair, half-open overlap)/busy_in. API ev-busy, ev-conflicts, ev-has-conflict?, ev-free? (transient qwindow). Integrates with calendar expansion. 53/53 green. Co-Authored-By: Claude Opus 4.8 (1M context) <noreply@anthropic.com>
This commit is contained in:
131
lib/events/availability.sx
Normal file
131
lib/events/availability.sx
Normal file
@@ -0,0 +1,131 @@
|
||||
;; lib/events/availability.sx — free/busy + conflict detection on Datalog.
|
||||
;;
|
||||
;; Availability is per-actor and is forward-chained Datalog over two EDB
|
||||
;; relations:
|
||||
;;
|
||||
;; (occurrence Key EventId Start End) ; an expanded calendar occurrence
|
||||
;; (booking Actor Key) ; actor attends/holds that occurrence
|
||||
;;
|
||||
;; The derived relations are the whole policy:
|
||||
;;
|
||||
;; busy(A,S,E) — A is committed for [S,E) (a booked occurrence)
|
||||
;; conflict(A,O1,O2) — A double-booked into two overlapping occurrences
|
||||
;; busy_in(A,QS,QE) — A is busy somewhere inside query window [QS,QE)
|
||||
;;
|
||||
;; Intervals are half-open [Start,End) in epoch minutes (see calendar.sx), so
|
||||
;; adjacent slots (E == next start) do NOT conflict. Conflict pairs are
|
||||
;; canonical (O1 < O2 by key) so each overlap is reported once. The same `busy`
|
||||
;; rule answers "is A free in [QS,QE)?" (busy_in is empty) and feeds "when is A
|
||||
;; next free?" — same rules, different bindings.
|
||||
|
||||
;; A stable key for an occurrence dict {:id :start :end}.
|
||||
(define ev-occ-key (fn (occ) (str (get occ :id) "@" (get occ :start))))
|
||||
|
||||
(define
|
||||
ev-occurrence-fact
|
||||
(fn
|
||||
(occ)
|
||||
(list
|
||||
(quote occurrence)
|
||||
(ev-occ-key occ)
|
||||
(get occ :id)
|
||||
(get occ :start)
|
||||
(get occ :end))))
|
||||
|
||||
(define ev-occurrence-facts (fn (occs) (map ev-occurrence-fact occs)))
|
||||
|
||||
(define ev-booking-fact (fn (actor key) (list (quote booking) actor key)))
|
||||
|
||||
(define ev-qwindow-fact (fn (qs qe) (list (quote qwindow) qs qe)))
|
||||
|
||||
;; Range restriction: each comparison's variables are bound by an earlier
|
||||
;; positive literal (qwindow / busy precede the < tests). Conflict uses
|
||||
;; (< O1 O2) on the keys so each overlapping pair is reported once.
|
||||
(define
|
||||
ev-avail-rules
|
||||
(quote
|
||||
((busy A S E <- (booking A O) (occurrence O _ S E))
|
||||
(conflict
|
||||
A
|
||||
O1
|
||||
O2
|
||||
<-
|
||||
(booking A O1)
|
||||
(booking A O2)
|
||||
(occurrence O1 _ S1 E1)
|
||||
(occurrence O2 _ S2 E2)
|
||||
(< O1 O2)
|
||||
(< S1 E2)
|
||||
(< S2 E1))
|
||||
(busy_in A QS QE <- (qwindow QS QE) (busy A S E) (< S QE) (< QS E)))))
|
||||
|
||||
;; Build a Datalog db from EDB facts under the availability ruleset.
|
||||
(define ev-build-avail (fn (facts) (dl-program-data facts ev-avail-rules)))
|
||||
|
||||
;; Convenience: build a db from occurrence dicts + booking pairs.
|
||||
;; bookings is a list of (actor key) pairs.
|
||||
(define
|
||||
ev-avail-db
|
||||
(fn
|
||||
(occs bookings)
|
||||
(ev-build-avail
|
||||
(append
|
||||
(ev-occurrence-facts occs)
|
||||
(map
|
||||
(fn (b) (ev-booking-fact (first b) (first (rest b))))
|
||||
bookings)))))
|
||||
|
||||
;; Helper: insertion sort a list of (S E ...) lists ascending by S then E.
|
||||
(define
|
||||
ev-list-before?
|
||||
(fn
|
||||
(a b)
|
||||
(cond
|
||||
((< (first a) (first b)) true)
|
||||
((> (first a) (first b)) false)
|
||||
(else (< (first (rest a)) (first (rest b)))))))
|
||||
|
||||
(define
|
||||
ev-list-insert
|
||||
(fn
|
||||
(x sorted)
|
||||
(cond
|
||||
((empty? sorted) (list x))
|
||||
((ev-list-before? x (first sorted)) (cons x sorted))
|
||||
(else (cons (first sorted) (ev-list-insert x (rest sorted)))))))
|
||||
|
||||
(define
|
||||
ev-sort-lists
|
||||
(fn (xs) (reduce (fn (acc x) (ev-list-insert x acc)) (list) xs)))
|
||||
|
||||
;; All busy intervals (list S E) for an actor, ascending by start.
|
||||
(define
|
||||
ev-busy
|
||||
(fn
|
||||
(db actor)
|
||||
(let
|
||||
((rows (dl-query db (list (quote busy) actor (quote S) (quote E)))))
|
||||
(ev-sort-lists (map (fn (b) (list (get b :S) (get b :E))) rows)))))
|
||||
|
||||
;; Distinct conflicting occurrence-key pairs for an actor (each pair once).
|
||||
(define
|
||||
ev-conflicts
|
||||
(fn
|
||||
(db actor)
|
||||
(dl-query db (list (quote conflict) actor (quote O1) (quote O2)))))
|
||||
|
||||
(define
|
||||
ev-has-conflict?
|
||||
(fn (db actor) (> (len (ev-conflicts db actor)) 0)))
|
||||
|
||||
;; Is `actor` free across the whole window [qs,qe)? (no booked occurrence
|
||||
;; overlaps it). Asserts a transient qwindow fact, queries, retracts.
|
||||
(define
|
||||
ev-free?
|
||||
(fn
|
||||
(db actor qs qe)
|
||||
(do
|
||||
(dl-assert! db (ev-qwindow-fact qs qe))
|
||||
(let
|
||||
((rows (dl-query db (list (quote busy_in) actor (quote QS) (quote QE)))))
|
||||
(begin (dl-retract! db (ev-qwindow-fact qs qe)) (empty? rows))))))
|
||||
@@ -16,8 +16,10 @@ PRELOADS=(
|
||||
lib/datalog/api.sx
|
||||
lib/datalog/magic.sx
|
||||
lib/events/calendar.sx
|
||||
lib/events/availability.sx
|
||||
)
|
||||
|
||||
SUITES=(
|
||||
"calendar:lib/events/tests/calendar.sx:(ev-calendar-tests-run!)"
|
||||
"availability:lib/events/tests/availability.sx:(ev-availability-tests-run!)"
|
||||
)
|
||||
|
||||
@@ -1,10 +1,11 @@
|
||||
{
|
||||
"lang": "events",
|
||||
"total_passed": 37,
|
||||
"total_passed": 53,
|
||||
"total_failed": 0,
|
||||
"total": 37,
|
||||
"total": 53,
|
||||
"suites": [
|
||||
{"name":"calendar","passed":37,"failed":0,"total":37}
|
||||
{"name":"calendar","passed":37,"failed":0,"total":37},
|
||||
{"name":"availability","passed":16,"failed":0,"total":16}
|
||||
],
|
||||
"generated": "2026-06-06T23:52:14+00:00"
|
||||
"generated": "2026-06-07T00:21:06+00:00"
|
||||
}
|
||||
|
||||
@@ -1,7 +1,8 @@
|
||||
# events scoreboard
|
||||
|
||||
**37 / 37 passing** (0 failure(s)).
|
||||
**53 / 53 passing** (0 failure(s)).
|
||||
|
||||
| Suite | Passed | Total | Status |
|
||||
|-------|--------|-------|--------|
|
||||
| calendar | 37 | 37 | ok |
|
||||
| availability | 16 | 16 | ok |
|
||||
|
||||
247
lib/events/tests/availability.sx
Normal file
247
lib/events/tests/availability.sx
Normal file
@@ -0,0 +1,247 @@
|
||||
;; 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)))))))
|
||||
|
||||
(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
|
||||
((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
Block a user