diff options
| author | Lukasz Kasprzak <lukas@labunix.xyz> | 2026-08-12 11:38:35 +0200 |
|---|---|---|
| committer | Lukasz Kasprzak <lukas@labunix.xyz> | 2026-08-12 11:38:35 +0200 |
| commit | e19adb9c7ea369cafe76e7eff50e9248a4a954d0 (patch) | |
| tree | 57824e121606286ebdf8fff68439986dd3300eae /test/test_calendar.ml | |
| parent | 0506388da160a15ceddb0cea1a697d737103d5c4 (diff) | |
| parent | 36df2bd0af9a555a09334e14b0d89118be1dbbc0 (diff) | |
| download | colitur-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 'test/test_calendar.ml')
| -rw-r--r-- | test/test_calendar.ml | 447 |
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 ] ) |
