path: root/test/test_calendar.ml

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.vigil_feast = (fun _ -> None); band; disposition;
      admit =
        (fun ~observed:_ ~temporal:_ cs ->
          List.filteri (fun i _ -> i < 1) cs |> List.map (fun (c, p, (_ : int)) -> (c, p))) }

  (* 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)

  (* No fixture here exercises citations or the formulary -- readings is a
     harmless constant [(None, [])], the same role [empty_layer] plays for
     the sanctoral side. *)
  let readings ~observed:_ ~temporal:_ ~date:_ ~temporal_at:_ = (None, [])

  (* No fixture here exercises the Creed rubric either -- a rite that has
     not implemented it returns [false] explicitly, {!Rite.t.creed}'s own
     documented default. *)
  let creed ~temporal:_ ~observed:_ ~date:_ = false

  let rite : (season, rank) Rite.t =
    { Rite.id = "synthetic-calendar"; vocab; year_start; temporal; anchors = (fun _ -> []);
      (* Not a Roman rite, but a Rite.t must supply SOME Easter now that
         movable Date_spec variants exist. The Gregorian one is as good as
         any for a fixture; nothing here is Easter-relative, so the value
         is never actually read. *)
      easter = Colitur_kernel.Computus.gregorian_easter;
      (* Not a Roman rite either, so no bissextile-doubling convention:
         identity, {!Rite.t.fixed_key}'s own documented default. *)
      fixed_key = (fun d -> Some (D.month d, D.day d));
      rules; season_runs = [ A; B ]; transfer_target; readings; creed }

  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

(* ef-major-litanies task, fix round 1 (F1) -- a regression test for a
   THIRD settlement channel `build_day`'s own `settled_at` had to learn to
   recognise: a transferred candidate that reaches its target and is then
   CAPPED OUT there by the target day's own RG 111 admission-count limit
   (not `observed`, not surviving as a `commemoration` -- the two channels
   the first version of this fix checked), rather than settling cleanly.
   Missing it reproduces the exact original bug ONE LEVEL FURTHER OUT: the
   origin wrongly reports the transferred candidate as
   `unconverged_reason`, even though placement genuinely converged.

   Unreachable on real EF data ALONE (the Major Litanies, RG 80, are the
   only privileged `Commemoration_only` candidate real data carries, and
   no second one can ever coincide with Easter+2) -- reproduced here the
   same way the fix-round review did: one synthetic privileged
   `Commemoration_only` candidate, added directly to the REAL EF layer
   (not a hand-built synthetic rite -- this bug is about the real Litanies
   candidate's own real transfer, so the real rite is the honest fixture),
   on the real Litanies' own real 2011 transfer target (26 April -- Easter
   2011 = 24 April, so 25 April is Easter Monday, RG 80's second trigger,
   landing on Easter+2 = 26 April), with a slug ("aaa-probe") sorting
   ahead of "major-litanies" so it wins {!Rite_ef.Precedence_ef.admit}'s
   Class1 "one privileged commemoration only" selection there, capping the
   Litanies out. *)
let real_ef_layer_for_transfer_probes =
  match Colitur_kernel.Layer.load Rite_ef.Vocab_ef.rank_of_sexp "../data/ef/sanctoral.sexp" with
  | Error e -> failwith ("../data/ef/sanctoral.sexp: " ^ e)
  | Ok layer -> (
      match Colitur_kernel.Overlay.load Rite_ef.Vocab_ef.rank_of_sexp "../data/ef/adjustments.sexp" with
      | Error e -> failwith ("../data/ef/adjustments.sexp: " ^ e)
      | Ok overlay ->
          let layer, diagnostics = Colitur_kernel.Overlay.apply layer overlay in
          if diagnostics <> [] then failwith "unexpected overlay diagnostics loading the real EF layer";
          layer)

(* [Rite_ef.context] takes [~lectionary] (fix round 1, coordinator review) --
   caller-supplied, same as the sanctoral layer above. *)
let real_ef_lectionary_for_transfer_probes =
  match Colitur_kernel.Lectionary.load "../data/ef/lectionary.sexp" with
  | Error e -> failwith ("../data/ef/lectionary.sexp: " ^ e)
  | Ok l -> l

(* The Commons (data/ef/commons.sexp) travel the same caller-supplied seam
   as the lectionary above, and [~commons] is required rather than defaulted
   so that no caller can silently run with none -- nothing in layers 3-5
   compares reading citations, so a rite quietly missing its Commons would
   be invisible. Loaded here even where this file asserts nothing about
   readings, so that the rite under test is the same one bin/main.ml
   assembles. *)
let real_ef_commons_for_transfer_probes =
  match Rite_ef.Lectionary_ef.Commons.load "../data/ef/commons.sexp" with
  | Error e -> failwith ("../data/ef/commons.sexp: " ^ e)
  | Ok c -> c

let test_transferred_commemoration_only_capped_out_at_target_settles_cleanly () =
  let probe_date =
    match Colitur_kernel.Date_spec.fixed ~month:4 ~day:26 with Ok d -> d | Error e -> failwith e
  in
  let probe =
    { Colitur_kernel.Layer.date = probe_date;
      cel =
        Cel.make ~slug:(Sl.of_string_exn "aaa-probe") ~rank:Rite_ef.Vocab_ef.Class1
          ~status:Cel.Commemoration_only ~colour:Colitur_kernel.Colour.White
          ~subject:Colitur_kernel.Subject.Saint ~layer:"synthetic-probe" ()
    }
  in
  let augmented_layer = Colitur_kernel.Layer.set real_ef_layer_for_transfer_probes probe in
  (* Liturgical year "2010" (Advent 2010 -- eve of Advent 2011) covers both
     25 and 26 April 2011. *)
  let year =
    C.year
      (Rite_ef.context ~lectionary:real_ef_lectionary_for_transfer_probes
         ~commons:real_ef_commons_for_transfer_probes)
      augmented_layer 2010
  in
  let find_date target =
    match Array.to_list year |> List.find_opt (fun d -> D.compare d.LD.date target = 0) with
    | Some d -> d
    | None -> failwith "date not found in resolved year"
  in
  let origin = find_date (mk 2011 4 25) and target = find_date (mk 2011 4 26) in
  let slug_s (c : Rite_ef.Vocab_ef.rank Cel.t) = Sl.to_string c.Cel.slug in
  Alcotest.(check string) "2011-04-25 is Easter Monday, RG80's second trigger" "ef-easter-1-monday"
    (slug_s origin.LD.observed);
  let omitted_s d = List.map (fun (c, r) -> (slug_s c, r)) d.LD.omitted in
  Alcotest.(check (list (pair string string))) "origin: major-litanies is NOT in [omitted] at all -- it \
    genuinely, cleanly transferred away, no false 'did not converge'" []
    (List.filter (fun (s, _) -> s = "major-litanies") (omitted_s origin));
  let contains_substring s ~needle =
    let ls = String.length s and ln = String.length needle in
    let rec at i = i + ln <= ls && (String.sub s i ln = needle || at (i + 1)) in
    ln = 0 || at 0
  in
  Alcotest.(check (list (pair string string))) "origin: no [omitted] entry anywhere claims non-convergence \
    (the exact regression this test guards against, stated directly rather than only via the slug check \
    above)" []
    (List.filter (fun (_, r) -> contains_substring r ~needle:"did not converge") (omitted_s origin));
  Alcotest.(check (list string)) "origin: [transferred_out] still correctly names major-litanies -> target"
    [ "major-litanies->2011-04-26" ]
    (List.map
       (fun (c, d) -> Printf.sprintf "%s->%s" (slug_s c) (D.to_iso8601 d))
       origin.LD.transferred_out);
  Alcotest.(check (list string)) "target: aaa-probe wins the Class1 privileged slot (sorts ahead of \
    major-litanies at the tied [unclassified] band)" [ "aaa-probe" ]
    (List.map (fun (c, _) -> slug_s c) target.LD.commemorations);
  Alcotest.(check bool) "target: major-litanies is capped out into [omitted] there, with the REAL \
    admission-limit reason, not lost and not mislabelled" true
    (List.mem ("major-litanies", "omitted: admission limit reached") (List.map (fun (c,r) -> (slug_s c, r)) target.LD.omitted))

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;
      Alcotest.test_case
        "ef-major-litanies fix round 1 (F1): a transferred candidate capped out at its own target settles \
         cleanly, no false 'did not converge'"
        `Quick test_transferred_commemoration_only_capped_out_at_target_settles_cleanly ] )