summaryrefslogtreecommitdiff
path: root/lib/kernel/precedence.ml
diff options
context:
space:
mode:
authorLukasz Kasprzak <lukas@labunix.xyz>2026-08-12 11:38:35 +0200
committerLukasz Kasprzak <lukas@labunix.xyz>2026-08-12 11:38:35 +0200
commite19adb9c7ea369cafe76e7eff50e9248a4a954d0 (patch)
tree57824e121606286ebdf8fff68439986dd3300eae /lib/kernel/precedence.ml
parent0506388da160a15ceddb0cea1a697d737103d5c4 (diff)
parent36df2bd0af9a555a09334e14b0d89118be1dbbc0 (diff)
downloadcolitur-e19adb9c7ea369cafe76e7eff50e9248a4a954d0.tar.gz
colitur-e19adb9c7ea369cafe76e7eff50e9248a4a954d0.zip
Merge branch 'ef-plan3': Plan 3, the EF resolution engine
Adds the rite-parameterised Precedence resolver, Liturgical_day, Rite, and Calendar (year as the primitive, because transfers need whole-year knowledge), the full EF precedence ruleset (RG 91's 28-entry table, occurrence RG 92-95, commemorations RG 108-111, transfers RG 96-98), 322 bootstrapped sanctoral entries, colitur day <year>, and validation layers 3-5. Layer 3 diffs 16801 days against lectio; layer 4 diffs 730 days against missalemeum; layer 5 pins ~30 dates on the known-tricky years. Both comparison layers carry cited allow-lists that name the governing RG paragraph and which engine is right. The oracle layer earned its place immediately: Holy Thursday was violet in colitur and lectio alike, because colitur's data was bootstrapped from lectio and both carried the same error. Only an independent source could see it. RG 128(b) and RG 122 name it white.
Diffstat (limited to 'lib/kernel/precedence.ml')
-rw-r--r--lib/kernel/precedence.ml69
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;
+ }