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
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
|
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.vigil_feast = (fun _ -> None); 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:_ ~temporal:_ cs ->
List.filteri (fun i _ -> i < 2) cs |> List.map (fun (c, p, (_ : int)) -> (c, p))) }
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
-- and each input candidate lands in exactly one bucket, not zero or two. *)
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
let bucketed =
(slug_of r.P.observed
:: List.map (fun (c, _) -> slug_of c) r.P.commemorations)
@ List.map slug_of r.P.deferred
@ List.map (fun (c, _) -> slug_of c) r.P.omitted
in
Alcotest.(check (slist string compare)) "every candidate appears exactly once"
[ "a"; "b"; "c"; "sunday" ] bucketed;
Alcotest.(check int) "two admitted" 2 (List.length r.P.commemorations)
(* The result must not depend on the order sanctoral candidates arrive in;
ties break on slug, not on list position. *)
let test_order_independent () =
let a = cand ~rank:Lo "a" and b = cand ~rank:Lo "b" and c = cand ~rank:Lo "c" in
let t = cand ~origin:P.Temporal ~rank:Hi "sunday" in
let observed_for sanctoral = slug_of (P.resolve rules ctx ~temporal:t ~sanctoral).P.observed in
let comms_for sanctoral =
List.map (fun (x, _) -> slug_of x) (P.resolve rules ctx ~temporal:t ~sanctoral).P.commemorations
in
List.iter
(fun perm ->
Alcotest.(check string) "same observed" (observed_for [ a; b; c ]) (observed_for perm);
Alcotest.(check (list string)) "same commemorations" (comms_for [ a; b; c ]) (comms_for perm))
[ [ c; b; a ]; [ b; a; c ]; [ c; a; b ] ]
(* The case the "pass temporal separately" design exists to make safe: a day
with no sanctoral candidate at all. *)
let test_temporal_only_day () =
let r = P.resolve rules ctx ~temporal:(cand ~origin:P.Temporal ~rank:Lo "feria")
~sanctoral:[] in
Alcotest.(check string) "feria observed" "feria" (slug_of r.P.observed);
Alcotest.(check int) "no commemorations" 0 (List.length r.P.commemorations);
Alcotest.(check int) "nothing deferred" 0 (List.length r.P.deferred);
Alcotest.(check int) "nothing omitted" 0 (List.length r.P.omitted)
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;
Alcotest.test_case "order independent" `Quick test_order_independent;
Alcotest.test_case "temporal-only day" `Quick test_temporal_only_day ] )
|
