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
|
(* 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;
}
|
