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.

4 files changed, 206 insertions, 1 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;
+  }
diff --git a/lib/kernel/precedence.mli b/lib/kernel/precedence.mli
new file mode 100644
index 0000000..d30e5c3
--- /dev/null
+++ b/lib/kernel/precedence.mli
@@ -0,0 +1,60 @@
+(** 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 rite-supplied functions, because the loser's fate depends on
+    the loser's own rank, not the winner's -- conflating them would resist
+    extension to a second rite. *)
+
+(** Which of the day's two office streams a candidate came from. *)
+type origin = Temporal | Sanctoral [@@deriving sexp]
+
+(** RG 111: an admitted commemoration's own standing, distinct from its rank. *)
+type privilege = Privileged | Ordinary [@@deriving sexp]
+
+(** What becomes of a losing candidate. *)
+type disposition =
+  | Omit  (** yields with no trace in the day's celebration *)
+  | Commemorate of privilege  (** kept as a commemoration of the observed day *)
+  | Transfer  (** moved to the next free day (RG 92-95) *)
+  | Repose  (** kept only in a votive/private sense; not commemorated today *)
+[@@deriving sexp]
+
+(** A celebration together with the office stream it was drawn from. Parameterised
+    by the rite's rank type only, matching {!Celebration.t}. *)
+type 'r candidate = { cel : 'r Celebration.t; origin : origin } [@@deriving sexp]
+
+(** The day a resolution is computed for. Parameterised by the rite's season
+    type only -- a context has no rank of its own. *)
+type 's context = { date : Date.t; season : 's; weekday : Date.weekday }
+
+(** The rite's three resolution functions. *)
+type ('s, 'r) rules = {
+  band : 's context -> 'r candidate -> int;
+      (** RG 91: orders candidates for the day; lower wins. *)
+  disposition : winner:'r candidate -> loser:'r candidate -> disposition;
+      (** RG 92-95: the loser's fate, which depends on the loser's own rank. *)
+  admit :
+    observed:'r candidate ->
+    ('r candidate * privilege) list ->
+    ('r candidate * privilege) list;
+      (** RG 108-111: how many commemorations are admitted, and in what order;
+          anything filtered out here is recorded in {!resolution.omitted}, not
+          dropped. *)
+}
+
+(** The outcome of resolving one day's candidates. *)
+type 'r resolution = {
+  observed : 'r candidate;
+  commemorations : ('r candidate * privilege) list;
+  deferred : 'r candidate list;
+  omitted : ('r candidate * string) list;  (** each with a reason *)
+}
+
+(** Total: the temporal candidate is passed separately, so there is no
+    empty-candidate case. Ties break on slug, so the result never depends on
+    input order. A [Commemoration_only] celebration is held out of the contest
+    and can never be [observed]. Every input candidate appears exactly once in
+    [observed], [commemorations], [deferred] or [omitted] — nothing is dropped
+    silently. *)
+val resolve :
+  ('s, 'r) rules -> 's context -> temporal:'r candidate ->
+  sanctoral:'r candidate list -> 'r resolution
diff --git a/test/test_colitur.ml b/test/test_colitur.ml
index ae58607..08282e6 100644
--- a/test/test_colitur.ml
+++ b/test/test_colitur.ml
@@ -2,4 +2,4 @@
 let () =
   Alcotest.run "colitur"
     [ Test_date.suite; Test_computus.suite; Test_colour.suite; Test_slug.suite; Test_names.suite;
-      Test_overlay.suite; Test_temporal_ef.suite; Test_validate.suite ]
+      Test_overlay.suite; Test_temporal_ef.suite; Test_validate.suite; Test_precedence.suite ]
diff --git a/test/test_precedence.ml b/test/test_precedence.ml
new file mode 100644
index 0000000..39be06c
--- /dev/null
+++ b/test/test_precedence.ml
@@ -0,0 +1,76 @@
+module P = Colitur_kernel.Precedence
+module Cel = Colitur_kernel.Celebration
+module S = Colitur_kernel.Slug
+module Col = Colitur_kernel.Colour
+module D = Colitur_kernel.Date
+
+type rank = Hi | Lo [@@deriving sexp]
+type season = Green [@@deriving sexp]
+
+let cand ?(origin = P.Sanctoral) ?(status = Cel.Feast) ~rank slug =
+  { P.cel = Cel.make ~slug:(S.of_string_exn slug) ~rank ~status ~colour:Col.White
+              ~layer:"base" (); origin }
+
+let ctx =
+  { P.date = (match D.make ~year:2026 ~month:7 ~day:15 with Ok d -> d | Error e -> failwith e);
+    season = Green; weekday = D.Wed }
+
+(* Band: Hi beats Lo. Temporal breaks a tie in its own favour. *)
+let rules =
+  { P.band = (fun _ c -> (match c.P.cel.Cel.rank with Hi -> 10 | Lo -> 20)
+                         - (match c.P.origin with P.Temporal -> 1 | P.Sanctoral -> 0));
+    disposition =
+      (fun ~winner:_ ~loser ->
+        match loser.P.cel.Cel.status with
+        | Cel.Commemoration_only -> P.Commemorate P.Ordinary
+        | Cel.Feast -> (match loser.P.cel.Cel.rank with
+                        | Hi -> P.Transfer
+                        | Lo -> P.Commemorate P.Ordinary));
+    admit = (fun ~observed:_ cs -> List.filteri (fun i _ -> i < 2) cs) }
+
+let slug_of c = S.to_string c.P.cel.Cel.slug
+
+let test_highest_band_wins () =
+  let r = P.resolve rules ctx ~temporal:(cand ~origin:P.Temporal ~rank:Lo "feria")
+            ~sanctoral:[ cand ~rank:Hi "big-feast" ] in
+  Alcotest.(check string) "feast wins" "big-feast" (slug_of r.P.observed)
+
+let test_temporal_wins_a_tie () =
+  let r = P.resolve rules ctx ~temporal:(cand ~origin:P.Temporal ~rank:Hi "sunday")
+            ~sanctoral:[ cand ~rank:Hi "saint" ] in
+  Alcotest.(check string) "temporal wins tie" "sunday" (slug_of r.P.observed)
+
+let test_loser_dispositions () =
+  let r = P.resolve rules ctx ~temporal:(cand ~origin:P.Temporal ~rank:Hi "sunday")
+            ~sanctoral:[ cand ~rank:Hi "transferable"; cand ~rank:Lo "commemorated" ] in
+  Alcotest.(check (list string)) "deferred" [ "transferable" ]
+    (List.map slug_of r.P.deferred);
+  Alcotest.(check (list string)) "commemorated" [ "commemorated" ]
+    (List.map (fun (c, _) -> slug_of c) r.P.commemorations)
+
+(* A commemoration-only entry can never be observed, even at a winning band. *)
+let test_commemoration_only_never_observed () =
+  let r = P.resolve rules ctx ~temporal:(cand ~origin:P.Temporal ~rank:Lo "feria")
+            ~sanctoral:[ cand ~rank:Hi ~status:Cel.Commemoration_only "suppressed" ] in
+  Alcotest.(check string) "feria still observed" "feria" (slug_of r.P.observed);
+  Alcotest.(check (list string)) "suppressed commemorated" [ "suppressed" ]
+    (List.map (fun (c, _) -> slug_of c) r.P.commemorations)
+
+(* Anything the admit limit drops is recorded in `omitted`, never dropped silently. *)
+let test_nothing_silently_lost () =
+  let r = P.resolve rules ctx ~temporal:(cand ~origin:P.Temporal ~rank:Hi "sunday")
+            ~sanctoral:[ cand ~rank:Lo "a"; cand ~rank:Lo "b"; cand ~rank:Lo "c" ] in
+  Alcotest.(check int) "two admitted" 2 (List.length r.P.commemorations);
+  Alcotest.(check int) "one recorded as omitted" 1 (List.length r.P.omitted);
+  let total = 1 + List.length r.P.commemorations + List.length r.P.deferred
+              + List.length r.P.omitted in
+  Alcotest.(check int) "every candidate accounted for" 4 total
+
+let suite =
+  ( "Precedence",
+    [ Alcotest.test_case "highest band wins" `Quick test_highest_band_wins;
+      Alcotest.test_case "temporal wins a tie" `Quick test_temporal_wins_a_tie;
+      Alcotest.test_case "loser dispositions" `Quick test_loser_dispositions;
+      Alcotest.test_case "commemoration-only never observed" `Quick
+        test_commemoration_only_never_observed;
+      Alcotest.test_case "nothing silently lost" `Quick test_nothing_silently_lost ] )