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, two ranks: enough to exercise the type parameters without dragging in real liturgical logic Calendar itself does not compute. *) 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 = Hi | 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 Hi -> "hi" | Lo -> "lo" let rank_of_string = function "hi" -> Some Hi | "lo" -> Some Lo | _ -> None let vocab : (season, rank) Vocab.t = { Vocab.seasons = [ A; B ]; season_to_string; season_of_string; ranks = [ Hi; 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: Hi beats Lo; Temporal breaks a tie 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 Hi -> 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 | Hi -> 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 Hi stands 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:Hi 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 Hi, both Sanctoral); ties break on slug, so "day-winner" wins and "eclipsed" -- a Hi-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:Hi let eclipsed = entry ~month:12 ~day:20 ~slug:"eclipsed" ~rank:Hi 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 Hi; 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 Hi-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:Hi let transferable = entry ~month:1 ~day:10 ~slug:"transferable" ~rank:Hi let blocker_b = entry ~month:1 ~day:11 ~slug:"blocker-b" ~rank:Hi let blocker_c = entry ~month:1 ~day:12 ~slug:"blocker-c" ~rank:Hi (* RG 97-98: three Hi-rank entries coincide on 1 Feb. Sorted by band then slug (all three tie on band, since Fixture's [band] only reads rank): "collision-winner" < "transfer-a" < "transfer-b". The winner keeps 1 Feb; the other two -- both losers, both Hi, both [Transfer]-disposed -- must transfer in that same order. 2 and 3 Feb carry nothing of their own, so they are the two admissible days the pair must land on, consecutively, in that order: "transfer-a" (the higher-precedence loser) gets first claim on 2 Feb, pushing "transfer-b" to 3 Feb. *) let collision_winner = entry ~month:2 ~day:1 ~slug:"collision-winner" ~rank:Hi let transfer_a = entry ~month:2 ~day:1 ~slug:"transfer-a" ~rank:Hi let transfer_b = entry ~month:2 ~day:1 ~slug:"transfer-b" ~rank:Hi 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_a; transfer_b ] 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 Hi-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 <> None) (* 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 Hi 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 -> ""); (* Located by its own known origin date, not by "the first day with transferred_out set" -- layer_with_collision has more than one day that transfers something out (20 Dec's "eclipsed", 1 Feb's "transfer-b"), so that would silently pick up whichever happens to sort first in the array rather than proving THIS origin points at THIS landing. *) let origin = Array.to_list days |> List.find (fun d -> D.compare d.LD.date (mk 2027 1 10) = 0) in Alcotest.(check bool) "origin points at the landing date" true (origin.LD.transferred_out = Some landed.LD.date) (* Property 3: RG 97-98's ordering. Two Hi-rank losers coincide on 1 Feb (with "collision-winner" keeping the day); band ties, so slug order IS band order here, same convention Precedence.compare_by uses for real RG 91 entries that tie within one table slot. 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-precedence loser (transfer-a) claims 2 Feb first" "transfer-a" (observed_on (mk 2027 2 2)); Alcotest.(check string) "lower-precedence loser (transfer-b) 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-a appears exactly once in the year" 1 (count "transfer-a"); Alcotest.(check int) "transfer-b appears exactly once in the year" 1 (count "transfer-b") (* 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 "transfer guard records failure instead of looping" `Quick test_transfer_guard_records_failure_instead_of_looping ] )