diff options
| -rw-r--r-- | lib/kernel/precedence.ml | 69 | ||||
| -rw-r--r-- | lib/kernel/precedence.mli | 60 | ||||
| -rw-r--r-- | test/test_colitur.ml | 2 | ||||
| -rw-r--r-- | test/test_precedence.ml | 76 |
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 ] ) |