1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
(* 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 ->
temporal:'r candidate ->
('r candidate * privilege * int) list ->
('r candidate * privilege) list;
(** the trailing [int] on each input triple is that candidate's own
[band] value, computed once by {!resolve} below (a rite's [admit]
has no [context] of its own to compute it with) -- see [resolve]'s
own comment for why this is a KERNEL-level policy, not a rite-
specific rule threaded in as data. *)
vigil_feast : 'r candidate -> Slug.t option;
(** RG 33's third omission trigger: the slug of the feast this candidate
is a vigil OF, when the rite subjects that vigil to omission;
[None] for every other candidate. See the .mli for the contract and
for why the kernel asks the rite to NAME the feast rather than infer
it. *)
}
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
(* RG 113 (EF; docs/research/rules-register.md §4 "Commemorations"): "in
admittendis et ordinandis aliis commemorationibus, servetur ordo
tabellae praecedentiae" -- admitting AND ordering commemorations both
run on the rite's own table of precedence, the same [band] already
used above to pick [observed]. Computed here, once, generically (a
rite's own [admit] has no [ctx] of its own to call [band] with) rather
than inside every rite's [admit] separately -- a kernel-level POLICY
("commemorations are ordered by the rite's own band"), not a
rite-specific RULE baked into the kernel: the actual [band] function,
and whether a rite's [admit] even uses the value it is handed, both
stay entirely rite-supplied. *)
let comms_by_precedence = List.map (fun (c, p) -> (c, p, rules.band ctx c)) comms in
let admitted = rules.admit ~observed ~temporal comms_by_precedence 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;
}
|
