aboutsummaryrefslogtreecommitdiff
path: root/test/test_calendar.ml
diff options
context:
space:
mode:
Diffstat (limited to 'test/test_calendar.ml')
-rw-r--r--test/test_calendar.ml447
1 files changed, 447 insertions, 0 deletions
diff --git a/test/test_calendar.ml b/test/test_calendar.ml
new file mode 100644
index 0000000..505994e
--- /dev/null
+++ b/test/test_calendar.ml
@@ -0,0 +1,447 @@
+module C = Colitur_kernel.Calendar
+module D = Colitur_kernel.Date
+module LD = Colitur_kernel.Liturgical_day
+module Cel = Colitur_kernel.Celebration
+module Sl = Colitur_kernel.Slug
+module Rite = Colitur_kernel.Rite
+
+let mk y m d = match D.make ~year:y ~month:m ~day:d with Ok t -> t | Error e -> failwith e
+
+(* A synthetic rite -- not EF -- so Calendar's behaviour is proven against the
+ abstraction, not against EF's own real (and much larger) data. Two
+ seasons, three ranks: enough to exercise the type parameters without
+ dragging in real liturgical logic Calendar itself does not compute.
+
+ Three ranks, not two: Task 6 review finding 2. With only one
+ Transfer-disposed rank, every deferred candidate ties on [band] and
+ [compare_deferred]'s [b1 <> b2] branch (the one RG 97-98 actually depends
+ on -- coinciding I-class feasts transfer in TABLE order, not slug order)
+ was unreachable; reversing it broke no test. [Hi1] outranks [Hi2], both
+ outrank [Lo], both are [Transfer]-disposed -- so two colliding
+ transferables can now differ by band, not only by slug. *)
+module Fixture = struct
+ module Vocab = Colitur_kernel.Vocab
+ module Colour = Colitur_kernel.Colour
+ module Temporal = Colitur_kernel.Temporal
+ module P = Colitur_kernel.Precedence
+ module Layer = Colitur_kernel.Layer
+ module Date_spec = Colitur_kernel.Date_spec
+
+ type season = A | B
+ type rank = Hi1 | Hi2 | Lo
+
+ let season_to_string = function A -> "a" | B -> "b"
+ let season_of_string = function "a" -> Some A | "b" -> Some B | _ -> None
+ let rank_to_string = function Hi1 -> "hi1" | Hi2 -> "hi2" | Lo -> "lo"
+ let rank_of_string = function "hi1" -> Some Hi1 | "hi2" -> Some Hi2 | "lo" -> Some Lo | _ -> None
+
+ let vocab : (season, rank) Vocab.t =
+ { Vocab.seasons = [ A; B ]; season_to_string; season_of_string;
+ ranks = [ Hi1; Hi2; Lo ]; rank_to_string; rank_of_string }
+
+ let weekday_index d =
+ match D.weekday d with
+ | D.Sun -> 0 | D.Mon -> 1 | D.Tue -> 2 | D.Wed -> 3
+ | D.Thu -> 4 | D.Fri -> 5 | D.Sat -> 6
+
+ let sunday_on_or_before d = D.add_days d (-(weekday_index d))
+
+ (* Advent-anchored, mirroring the real EF rite's own RG-71 "Sunday nearest
+ 30 November" rule (rite_ef/temporal_ef.ml's [advent_start]) rather than
+ a Jan-1 year start: that shape is what makes the year-below-the-date's-
+ own-civil-year case in [Calendar.day] genuinely reachable, so the domain
+ -floor test below exercises something real. *)
+ let year_start y = D.add_days (sunday_on_or_before (mk y 12 24)) (-21)
+
+ (* Not liturgically meaningful -- Calendar does not check season
+ contiguity (that is Validate's job); this just proves the season type
+ parameter is actually threaded through. *)
+ let season date = if D.month date < 6 then A else B
+
+ (* One office per day, uniquely named by date so distinct days never
+ collide on slug. *)
+ let office date =
+ let slug = Printf.sprintf "feria-%04d-%02d-%02d" (D.year date) (D.month date) (D.day date) in
+ Cel.make ~slug:(Sl.of_string_exn slug) ~rank:Lo ~colour:Colour.Green ~layer:"synthetic-temporal" ()
+
+ let temporal date : (season, rank) Temporal.t =
+ { Temporal.season = season date; week = None; weekday = D.weekday date; office = office date }
+
+ (* Band: Hi1 beats Hi2 beats Lo; Temporal breaks a tie against a Lo-rank
+ Sanctoral entry in its own favour -- the same convention
+ test_precedence.ml uses. *)
+ let band (_ : season P.context) (c : rank P.candidate) =
+ (match c.P.cel.Cel.rank with Hi1 -> 5 | Hi2 -> 10 | Lo -> 20)
+ - (match c.P.origin with P.Temporal -> 1 | P.Sanctoral -> 0)
+
+ let disposition ~winner:_ ~(loser : rank P.candidate) =
+ match loser.P.cel.Cel.rank with Lo -> P.Commemorate P.Ordinary | Hi1 | Hi2 -> P.Transfer
+
+ (* Admits at most one commemoration -- mirrors test_precedence.ml's own
+ example and, unlike "admit everything", actually gives the accounting
+ test below a genuine Precedence-native omission (distinct from a
+ deferred one) to exercise. *)
+ let rules : (season, rank) P.rules =
+ { P.band; disposition; admit = (fun ~observed:_ cs -> List.filteri (fun i _ -> i < 1) cs) }
+
+ (* RG 96, generic form: search forward from the day after [origin] for the
+ first day whose occupant is not "blocking" -- in this synthetic
+ vocabulary Hi1/Hi2 stand in for I/II class, Lo for everything else (the
+ same convention [band] already uses). No Annunciation-style
+ starting-point override: that exception is EF-specific (RG 96) and
+ belongs to the real rite (Task 11, pinned by Task 17's golden years),
+ not to this abstraction-level fixture, which only has to prove
+ Calendar's placement mechanism, not EF's own rubrics. *)
+ let transfer_target (_ : rank P.candidate) (origin : D.t) (occupant : D.t -> rank Cel.t) : D.t =
+ let rec search d = if (occupant d).Cel.rank = Lo then d else search (D.add_days d 1) in
+ search (D.add_days origin 1)
+
+ let rite : (season, rank) Rite.t =
+ { Rite.id = "synthetic-calendar"; vocab; year_start; temporal; anchors = (fun _ -> []);
+ rules; season_runs = [ A; B ]; transfer_target }
+
+ let entry ~month ~day ~slug ~rank =
+ { Layer.date = (match Date_spec.fixed ~month ~day with Ok d -> d | Error e -> failwith e);
+ cel = Cel.make ~slug:(Sl.of_string_exn slug) ~rank ~colour:Colour.White
+ ~layer:"synthetic-sanctoral" () }
+
+ let big_feast = entry ~month:12 ~day:8 ~slug:"big-feast" ~rank:Hi1
+ let commem_worthy = entry ~month:12 ~day:15 ~slug:"commem-worthy" ~rank:Lo
+
+ (* 20 Dec: four sanctoral entries on one date, for the full-accounting test.
+ "day-winner" and "eclipsed" tie on band (both Hi1, both Sanctoral);
+ ties break on slug, so "day-winner" wins and "eclipsed" -- a Hi1-rank
+ loser -- is [Transfer]-disposed, landing in [deferred]. "loser-a" and
+ "loser-b" are both Lo, both [Commemorate]-disposed, but [admit] only
+ keeps one: the other lands in Precedence's own [omitted] ("admission
+ limit reached"), distinct from "eclipsed"'s deferred reason. Four
+ candidates, three different fates -- observed, one specific omission
+ reason, two more. *)
+ let day_winner = entry ~month:12 ~day:20 ~slug:"day-winner" ~rank:Hi1
+ let eclipsed = entry ~month:12 ~day:20 ~slug:"eclipsed" ~rank:Hi1
+ let loser_a = entry ~month:12 ~day:20 ~slug:"loser-a" ~rank:Lo
+ let loser_b = entry ~month:12 ~day:20 ~slug:"loser-b" ~rank:Lo
+
+ let layer =
+ Layer.of_entries ~id:"synthetic" ~name:"Synthetic sanctoral"
+ [ big_feast; commem_worthy; day_winner; eclipsed; loser_a; loser_b ]
+
+ (* RG 96 (Task 6): "transferable" is impeded on 10 Jan by "blocker-a" (both
+ Hi1; ties break on slug, "blocker-a" < "transferable", so "blocker-a"
+ wins and "transferable" is the loser). 11 and 12 Jan are ALSO occupied
+ by their own uncontested Hi1-rank entries, so the placement search must
+ walk past more than one ineligible day, not just try origin+1 and stop.
+ 13 Jan carries nothing, so the feria (Lo) is the first admissible day. *)
+ let blocker_a = entry ~month:1 ~day:10 ~slug:"blocker-a" ~rank:Hi1
+ let transferable = entry ~month:1 ~day:10 ~slug:"transferable" ~rank:Hi1
+ let blocker_b = entry ~month:1 ~day:11 ~slug:"blocker-b" ~rank:Hi1
+ let blocker_c = entry ~month:1 ~day:12 ~slug:"blocker-c" ~rank:Hi1
+
+ (* RG 97-98: three entries coincide on 1 Feb, spanning both Transfer-
+ disposed ranks so band order and slug order genuinely disagree (Task 6
+ review finding 2). "collision-winner" and "transfer-hi1" both tie at
+ the BETTER band (Hi1, 5); "transfer-hi2" is at the WORSE band (Hi2,
+ 10). Within the Hi1 tie, slug decides: "collision-winner" < "transfer-
+ hi1", so "collision-winner" keeps 1 Feb. Of the two losers,
+ "transfer-hi1" (band 5) outranks "transfer-hi2" (band 10) -- by BAND,
+ not by slug: "transfer-b" (transfer-hi2's slug) sorts alphabetically
+ *before* "transfer-z" (transfer-hi1's slug). A sort that used slug
+ instead of band, or compared band backwards, would place "transfer-b"
+ on 2 Feb instead of "transfer-z" -- exactly the wrong-order failure
+ mode finding 2 flagged as unreachable in the old two-Hi-rank fixture.
+ 2 and 3 Feb carry nothing of their own, so they are the two admissible
+ days the pair must land on, consecutively, in band order:
+ "transfer-hi1" claims 2 Feb, pushing "transfer-hi2" to 3 Feb. *)
+ let collision_winner = entry ~month:2 ~day:1 ~slug:"collision-winner" ~rank:Hi1
+ let transfer_hi1 = entry ~month:2 ~day:1 ~slug:"transfer-z" ~rank:Hi1
+ let transfer_hi2 = entry ~month:2 ~day:1 ~slug:"transfer-b" ~rank:Hi2
+
+ let layer_with_collision =
+ Layer.of_entries ~id:"synthetic-with-collision" ~name:"Synthetic sanctoral (with collisions)"
+ [ big_feast; commem_worthy; day_winner; eclipsed; loser_a; loser_b;
+ blocker_a; transferable; blocker_b; blocker_c;
+ collision_winner; transfer_hi1; transfer_hi2 ]
+
+ let liturgical_year_of date =
+ let cy = D.year date in
+ if D.compare date (year_start cy) >= 0 then cy else cy - 1
+end
+
+let test_year_covers_every_day () =
+ let days = C.year Fixture.rite Fixture.layer 2026 in
+ let first = days.(0) and last = days.(Array.length days - 1) in
+ Alcotest.(check string) "starts at year_start" "2026-11-29" (D.to_iso8601 first.LD.date);
+ Alcotest.(check bool) "ends the day before next year_start" true
+ (D.compare last.LD.date (D.add_days (Fixture.rite.Rite.year_start 2027) (-1)) = 0);
+ (* every consecutive pair is exactly one day apart: no gaps, no duplicates *)
+ Array.iteri
+ (fun i d ->
+ if i > 0 then
+ Alcotest.(check int) "consecutive" 1
+ (D.to_rata d.LD.date - D.to_rata days.(i - 1).LD.date))
+ days
+
+let test_day_agrees_with_year () =
+ List.iter
+ (fun (y, m, dd) ->
+ let date = mk y m dd in
+ let from_day = C.day Fixture.rite Fixture.layer date in
+ let ys = C.year Fixture.rite Fixture.layer (Fixture.liturgical_year_of date) in
+ let from_year = Array.to_list ys |> List.find (fun d -> D.compare d.LD.date date = 0) in
+ Alcotest.(check string) "same observed"
+ (Sl.to_string from_year.LD.observed.Cel.slug)
+ (Sl.to_string from_day.LD.observed.Cel.slug))
+ [ (2026, 12, 1); (2027, 3, 15); (2027, 7, 4) ]
+
+(* Two entries in the layer, per the brief: one that outranks the feria and
+ one that does not. Both sit on their own date so each assertion below
+ pins one behaviour without the other candidate muddying it. *)
+let test_sanctoral_outranks_feria_becomes_observed () =
+ let days = C.year Fixture.rite Fixture.layer 2026 in
+ let date = mk 2026 12 8 in
+ let d = Array.to_list days |> List.find (fun d -> D.compare d.LD.date date = 0) in
+ Alcotest.(check string) "big-feast observed" "big-feast" (Sl.to_string d.LD.observed.Cel.slug)
+
+let test_lower_ranked_sanctoral_is_commemorated () =
+ let days = C.year Fixture.rite Fixture.layer 2026 in
+ let date = mk 2026 12 15 in
+ let d = Array.to_list days |> List.find (fun d -> D.compare d.LD.date date = 0) in
+ let expected_feria = Sl.to_string (Fixture.office date).Cel.slug in
+ Alcotest.(check string) "feria still observed" expected_feria (Sl.to_string d.LD.observed.Cel.slug);
+ Alcotest.(check (list string)) "commem-worthy commemorated" [ "commem-worthy" ]
+ (List.map (fun (c, _) -> Sl.to_string c.Cel.slug) d.LD.commemorations)
+
+(* Register/design lesson (Plan 2's Validate 9999 bug): [year_start (y + 1)]
+ at the top of the domain must not raise. Calling [C.year ... 9999] here
+ directly (no [try]) is itself part of the pin -- if the clamp regressed,
+ this call would raise and the test would error rather than fail cleanly. *)
+let test_year_9999_does_not_raise () =
+ let days = C.year Fixture.rite Fixture.layer 9999 in
+ Alcotest.(check bool) "non-empty" true (Array.length days > 0);
+ Alcotest.(check string) "starts at year_start 9999"
+ (D.to_iso8601 (Fixture.rite.Rite.year_start 9999))
+ (D.to_iso8601 days.(0).LD.date);
+ Alcotest.(check string) "ends at the domain ceiling" "9999-12-31"
+ (D.to_iso8601 days.(Array.length days - 1).LD.date)
+
+(* The symmetric case at the bottom: 1 January 1583 is the domain's earliest
+ representable date, and Fixture's Advent-anchored [year_start] puts it
+ well before that civil year's own year_start -- so [day] must resolve it
+ via the [y] = 1582 branch without calling [year_start 1582] (out of
+ domain). Checks identity (the date's own feria), not merely that
+ something came back. *)
+let test_day_near_domain_floor_does_not_raise () =
+ let date = mk 1583 1 1 in
+ let d = C.day Fixture.rite Fixture.layer date in
+ Alcotest.(check string) "returns the queried date" "1583-01-01" (D.to_iso8601 d.LD.date);
+ Alcotest.(check string) "observed is the day's own feria"
+ (Sl.to_string (Fixture.office date).Cel.slug) (Sl.to_string d.LD.observed.Cel.slug)
+
+(* Full-day accounting through the whole Calendar pipeline (Layer -> Calendar
+ -> Liturgical_day), not just Precedence in isolation: every candidate fed
+ in for 20 Dec 2026 -- the feria plus Fixture's four colliding sanctoral
+ entries -- is accounted for exactly once across
+ observed/commemorations/omitted/transferred_out. Checked as a slug SET
+ (Alcotest.slist), matching test_precedence.ml's own "nothing silently
+ lost" test: a length-only check would pass even if one slug were
+ duplicated into two buckets and another dropped, which this project has
+ shipped before (register finding).
+
+ "eclipsed" -- the Hi1-rank loser on 20 Dec -- no longer sits in [omitted]
+ here (that was Task 5's honest placeholder, before Task 6 existed to
+ place it): RG 95 gives an I-class loser the right of translation, so it
+ is genuinely gone from this day's own accounting, and its departure is
+ what [transferred_out] records instead. [test_transfer_moves_and_does_not_duplicate]
+ below is what actually pins where it lands. *)
+let test_full_day_accounting () =
+ let date = mk 2026 12 20 in
+ let d = C.day Fixture.rite Fixture.layer date in
+ let feria_slug = Sl.to_string (Fixture.office date).Cel.slug in
+ let bucketed =
+ (Sl.to_string d.LD.observed.Cel.slug
+ :: List.map (fun (c, _) -> Sl.to_string c.Cel.slug) d.LD.commemorations)
+ @ List.map (fun (c, _) -> Sl.to_string c.Cel.slug) d.LD.omitted
+ in
+ Alcotest.(check (slist string compare)) "every non-transferred candidate appears exactly once"
+ [ feria_slug; "day-winner"; "loser-a"; "loser-b" ]
+ bucketed;
+ (* Identity within [omitted]: "loser-a"/"loser-b" -- the ones Precedence's
+ own [admit] dropped for exceeding the commemoration limit, not RG 96-98
+ translation -- must carry that specific reason. Without this, a bug
+ that dropped [resolution.omitted]'s own reasons would still pass the
+ slug-set check above. *)
+ let reason_of slug =
+ d.LD.omitted |> List.find (fun (c, _) -> Sl.to_string c.Cel.slug = slug) |> snd
+ in
+ Alcotest.(check string) "loser-a carries Precedence's own admission-limit reason"
+ "omitted: admission limit reached" (reason_of "loser-a");
+ (* Not "eclipsed is absent from bucketed" -- the [slist] check just above
+ already guarantees that (a 5-element set would fail it), so re-asserting
+ absence from the same list would be checking something already proven,
+ not something new. What IS new here: this day positively records that a
+ transfer happened, via a different field entirely. *)
+ Alcotest.(check bool) "20 Dec records that something transferred out" true
+ (d.LD.transferred_out <> [])
+
+(* Task 6's placement pass (RG 96-98), properties 1 and 2: a transferred
+ celebration appears exactly once in the whole year -- transfer moves, not
+ duplicates -- and [transferred_in]/[transferred_out] are set on the two
+ ends of the move and point at each other. "transferable" is impeded on 10
+ Jan by "blocker-a" (same band, tie-broken by slug), and 11-12 Jan are also
+ occupied by their own uncontested Hi1 entries, so this also proves the
+ search walks past more than one ineligible day rather than only trying
+ origin+1. *)
+let test_transfer_moves_and_does_not_duplicate () =
+ let days = C.year Fixture.rite Fixture.layer_with_collision 2026 in
+ let occurrences =
+ Array.to_list days
+ |> List.filter (fun d -> Sl.to_string d.LD.observed.Cel.slug = "transferable")
+ in
+ Alcotest.(check int) "appears exactly once" 1 (List.length occurrences);
+ let landed = List.hd occurrences in
+ Alcotest.(check string) "lands on the first day past the blocked run (13 Jan 2027)"
+ "2027-01-13" (D.to_iso8601 landed.LD.date);
+ Alcotest.(check bool) "marked as transferred in" true (landed.LD.transferred_in <> None);
+ Alcotest.(check string) "the arriving celebration is itself \"transferable\""
+ "transferable"
+ (match landed.LD.transferred_in with
+ | Some c -> Sl.to_string c.Cel.slug
+ | None -> "<none>");
+ (* Located by its own known origin date, not by "the first day with
+ transferred_out <> []" -- layer_with_collision has more than one day
+ that transfers something out (20 Dec's "eclipsed", 1 Feb's two losers),
+ so that would silently pick up whichever happens to sort first in the
+ array rather than proving THIS origin points at THIS landing. Its own
+ origin has exactly one departure -- unlike 1 Feb below -- so a single
+ pair pins it. *)
+ let origin = Array.to_list days |> List.find (fun d -> D.compare d.LD.date (mk 2027 1 10) = 0) in
+ Alcotest.(check int) "exactly one departure recorded at the origin" 1
+ (List.length origin.LD.transferred_out);
+ let departed_cel, departed_to = List.hd origin.LD.transferred_out in
+ Alcotest.(check string) "the departed celebration is \"transferable\"" "transferable"
+ (Sl.to_string departed_cel.Cel.slug);
+ Alcotest.(check string) "it points at the landing date" (D.to_iso8601 landed.LD.date)
+ (D.to_iso8601 departed_to)
+
+(* Property 3: RG 97-98's ordering, genuinely by band (Task 6 review finding
+ 2) -- see the [layer_with_collision] comment for how the fixture is built
+ so band order and slug order actively disagree here: "transfer-hi1"
+ (slug "transfer-z", band 5) must claim 2 Feb before "transfer-hi2" (slug
+ "transfer-b", band 10), even though "transfer-b" sorts alphabetically
+ first. Checked by DATE, not by "b landed one day after a" -- Task 5's
+ review flagged exactly that style of check as satisfiable by construction
+ (an Array.init built from add_days would pass it trivially); asserting
+ the literal landing dates independently is what actually exercises the
+ placement order. *)
+let test_two_colliding_transferables_land_in_band_order () =
+ let days = C.year Fixture.rite Fixture.layer_with_collision 2026 in
+ let observed_on date =
+ Array.to_list days
+ |> List.find (fun d -> D.compare d.LD.date date = 0)
+ |> fun d -> Sl.to_string d.LD.observed.Cel.slug
+ in
+ Alcotest.(check string) "collision-winner keeps 1 Feb" "collision-winner"
+ (observed_on (mk 2027 2 1));
+ Alcotest.(check string) "higher-band loser (transfer-z, Hi1) claims 2 Feb first" "transfer-z"
+ (observed_on (mk 2027 2 2));
+ Alcotest.(check string) "lower-band loser (transfer-b, Hi2) is pushed to 3 Feb" "transfer-b"
+ (observed_on (mk 2027 2 3));
+ let count slug =
+ Array.to_list days
+ |> List.filter (fun d -> Sl.to_string d.LD.observed.Cel.slug = slug)
+ |> List.length
+ in
+ Alcotest.(check int) "transfer-z appears exactly once in the year" 1 (count "transfer-z");
+ Alcotest.(check int) "transfer-b appears exactly once in the year" 1 (count "transfer-b")
+
+(* Task 6 review finding 1: RG 97-98 says coinciding I-class feasts transfer
+ "in order" -- plural -- so 1 Feb's origin must record BOTH departures
+ ("transfer-z" -> 2 Feb, "transfer-b" -> 3 Feb), not just one. The
+ original [Date.t option] could only ever hold one; with three entries
+ colliding on the same date it silently dropped whichever [Hashtbl.iter]
+ visited last, which depends on OCaml's hash seed (OCAMLRUNPARAM=R) -- an
+ environment read in a kernel whose invariants forbid one. Sorting both
+ sides before comparing makes this assertion itself independent of
+ [transferred_out]'s own (now canonicalised, but not part of the
+ contract) internal order. *)
+let test_origin_records_every_departure () =
+ let days = C.year Fixture.rite Fixture.layer_with_collision 2026 in
+ let origin = Array.to_list days |> List.find (fun d -> D.compare d.LD.date (mk 2027 2 1) = 0) in
+ let departures =
+ origin.LD.transferred_out
+ |> List.map (fun (c, target) -> (Sl.to_string c.Cel.slug, D.to_iso8601 target))
+ |> List.sort compare
+ in
+ Alcotest.(check (list (pair string string)))
+ "both losers' departures are recorded, order-independently"
+ (List.sort compare [ ("transfer-z", "2027-02-02"); ("transfer-b", "2027-02-03") ])
+ departures
+
+(* Task 6 review finding 3: a rite whose [transfer_target] names a date
+ outside the liturgical year's own [start, stop] must not make the
+ candidate vanish. "eclipsed" is impeded on 20 Dec as usual, but this
+ rite's search jumps 5000 days forward -- far past [stop] -- instead of
+ walking to the next admissible day. It must never become [observed]
+ anywhere in the array (there is nowhere in the array for it to land),
+ and its origin must record the specific out-of-range reason, not the
+ generic non-convergence one (this placement decides on round 1; the
+ round guard is never even approached). *)
+let test_transfer_target_outside_year_is_recorded_not_lost () =
+ let stray_rite =
+ { Fixture.rite with Rite.transfer_target = (fun _ origin _ -> D.add_days origin 5000) }
+ in
+ let days = C.year stray_rite Fixture.layer 2026 in
+ let observed_anywhere =
+ Array.to_list days |> List.exists (fun d -> Sl.to_string d.LD.observed.Cel.slug = "eclipsed")
+ in
+ Alcotest.(check bool) "never becomes observed anywhere in the year" false observed_anywhere;
+ let origin = Array.to_list days |> List.find (fun d -> D.compare d.LD.date (mk 2026 12 20) = 0) in
+ let reason_of slug =
+ origin.LD.omitted |> List.find (fun (c, _) -> Sl.to_string c.Cel.slug = slug) |> snd
+ in
+ Alcotest.(check string) "recorded with the out-of-range reason, not silently dropped"
+ "omitted: transfer target falls outside the liturgical year (RG 96)" (reason_of "eclipsed")
+
+(* Termination is a correctness requirement (brief): a rite whose
+ [transfer_target] always answers with the impeded day itself (never
+ strictly forward, so the pass can never reach a fixed point) must not
+ hang the computation. It has to hit [max_transfer_rounds] and come back
+ with the stuck candidate recorded as omitted -- not dropped, not looping
+ forever. Using plain [Fixture.layer] (20 Dec's "eclipsed" is the stuck
+ candidate) is enough; this is about the guard firing, not about any
+ particular collision shape. *)
+let test_transfer_guard_records_failure_instead_of_looping () =
+ let broken_rite = { Fixture.rite with Rite.transfer_target = (fun _ origin _ -> origin) } in
+ let days = C.year broken_rite Fixture.layer 2026 in
+ let stuck =
+ Array.to_list days
+ |> List.exists (fun d ->
+ List.exists
+ (fun (_, reason) ->
+ reason = "omitted: transfer placement did not converge within max_transfer_rounds (RG 96-98)")
+ d.LD.omitted)
+ in
+ Alcotest.(check bool) "non-convergence is recorded rather than silently dropped or hung" true stuck
+
+let suite =
+ ( "Calendar",
+ [ Alcotest.test_case "year covers every day" `Quick test_year_covers_every_day;
+ Alcotest.test_case "day agrees with year" `Quick test_day_agrees_with_year;
+ Alcotest.test_case "outranking sanctoral becomes observed" `Quick
+ test_sanctoral_outranks_feria_becomes_observed;
+ Alcotest.test_case "lower-ranked sanctoral is commemorated" `Quick
+ test_lower_ranked_sanctoral_is_commemorated;
+ Alcotest.test_case "year 9999 does not raise" `Quick test_year_9999_does_not_raise;
+ Alcotest.test_case "day near the domain floor does not raise" `Quick
+ test_day_near_domain_floor_does_not_raise;
+ Alcotest.test_case "full day accounting" `Quick test_full_day_accounting;
+ Alcotest.test_case "transfer moves and does not duplicate" `Quick
+ test_transfer_moves_and_does_not_duplicate;
+ Alcotest.test_case "two colliding transferables land in band order" `Quick
+ test_two_colliding_transferables_land_in_band_order;
+ Alcotest.test_case "origin records every departure" `Quick
+ test_origin_records_every_departure;
+ Alcotest.test_case "transfer target outside year is recorded not lost" `Quick
+ test_transfer_target_outside_year_is_recorded_not_lost;
+ Alcotest.test_case "transfer guard records failure instead of looping" `Quick
+ test_transfer_guard_records_failure_instead_of_looping ] )