kernel(precedence): rite-parameterised resolver

Three rite-supplied functions, not one: band (who wins, RG 91), disposition
(what happens to the loser, RG 92-95) and admit (how many commemorations are
admitted, RG 111). The loser's fate depends on the loser's own rank, so
conflating them would resist extension.

resolve takes the temporal candidate separately from the sanctoral list, which
makes it total by construction. Every candidate lands in exactly one of
observed, commemorations, deferred or omitted -- nothing is dropped silently,
which is what makes the no-celebration-lost invariant checkable.

1 files changed, 69 insertions, 0 deletions

diff --git a/lib/kernel/precedence.ml b/lib/kernel/precedence.ml
new file mode 100644
index 0000000..05ad69f
--- /dev/null
+++ b/lib/kernel/precedence.ml
@@ -0,0 +1,69 @@
+(* The rite-parameterised resolver. RG 91 says who wins; RG 92-95 says what
+   happens to the loser; RG 108-111 says how many commemorations are admitted.
+   Three separate functions, because the loser's fate depends on the loser's own
+   rank, not the winner's. *)
+open Sexplib0.Sexp_conv
+
+type origin = Temporal | Sanctoral [@@deriving sexp]
+type privilege = Privileged | Ordinary [@@deriving sexp]
+type disposition = Omit | Commemorate of privilege | Transfer | Repose [@@deriving sexp]
+
+type 'r candidate = { cel : 'r Celebration.t; origin : origin } [@@deriving sexp]
+
+type 's context = { date : Date.t; season : 's; weekday : Date.weekday }
+
+type ('s, 'r) rules = {
+  band : 's context -> 'r candidate -> int;
+  disposition : winner:'r candidate -> loser:'r candidate -> disposition;
+  admit :
+    observed:'r candidate ->
+    ('r candidate * privilege) list ->
+    ('r candidate * privilege) list;
+}
+
+type 'r resolution = {
+  observed : 'r candidate;
+  commemorations : ('r candidate * privilege) list;
+  deferred : 'r candidate list;
+  omitted : ('r candidate * string) list;
+}
+
+(* Ties break on slug so the result never depends on input order. *)
+let compare_by rules ctx a b =
+  let ba = rules.band ctx a and bb = rules.band ctx b in
+  if ba <> bb then Int.compare ba bb
+  else Slug.compare a.cel.Celebration.slug b.cel.Celebration.slug
+
+let resolve rules ctx ~temporal ~sanctoral =
+  (* A commemoration-only entry can never be observed (see Celebration.status),
+     so it is held out of the contest entirely rather than relying on its band. *)
+  let eligible, forced_comm =
+    List.partition
+      (fun c -> c.cel.Celebration.status = Celebration.Feast)
+      sanctoral
+  in
+  let sorted = List.stable_sort (compare_by rules ctx) (temporal :: eligible) in
+  let observed = List.hd sorted in
+  let losers = List.tl sorted @ forced_comm in
+  let comms, deferred, omitted =
+    List.fold_left
+      (fun (comms, defs, omits) l ->
+        match rules.disposition ~winner:observed ~loser:l with
+        | Commemorate p -> ((l, p) :: comms, defs, omits)
+        | Transfer | Repose -> (comms, l :: defs, omits)
+        | Omit -> (comms, defs, (l, "omitted: yielded to a higher day") :: omits))
+      ([], [], []) losers
+  in
+  let comms = List.rev comms and deferred = List.rev deferred in
+  let admitted = rules.admit ~observed comms in
+  let dropped =
+    List.filter (fun c -> not (List.exists (fun a -> fst a == fst c) admitted)) comms
+  in
+  {
+    observed;
+    commemorations = admitted;
+    deferred;
+    omitted =
+      List.rev omitted
+      @ List.map (fun (c, _) -> (c, "omitted: admission limit reached")) dropped;
+  }