rose-ash/lib/events/availability.sx

;; 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?" (ev-next-free probes candidate slots with the same rule).

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

(define
  ev-dedup-sorted
  (fn
    (xs)
    (cond
      ((empty? xs) xs)
      ((empty? (rest xs)) xs)
      ((= (first xs) (first (rest xs))) (ev-dedup-sorted (rest xs)))
      (else (cons (first xs) (ev-dedup-sorted (rest 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))))))

;; ---- next-free slot search ----
;; The earliest start s >= `after` such that [s, s+duration) is entirely free
;; for `actor` and ends at or before `horizon`, or nil if none. The earliest
;; such slot must begin either at `after` or immediately after some busy
;; interval ends (classic interval packing), so those are the only candidates
;; we probe — each probe reuses the busy_in rule via ev-free?.

(define
  ev-first-free
  (fn
    (db actor cands duration horizon)
    (cond
      ((empty? cands) nil)
      (else
        (let
          ((s (first cands)))
          (if
            (and
              (<= (+ s duration) horizon)
              (ev-free? db actor s (+ s duration)))
            s
            (ev-first-free db actor (rest cands) duration horizon)))))))

(define
  ev-next-free
  (fn
    (db actor after duration horizon)
    (let
      ((ends (filter (fn (e) (>= e after)) (map (fn (iv) (first (rest iv))) (ev-busy db actor)))))
      (ev-first-free
        db
        actor
        (ev-dedup-sorted (sort (cons after ends)))
        duration
        horizon))))