(* Resolution across a whole liturgical year. See calendar.mli for the architectural rationale (why [year] is the primitive and [day] derived). *) (* The kernel's domain floor and ceiling (Date.make's documented 1583..9999 bound). Both are always constructible -- in-range by definition -- so neither of these can itself raise. *) let domain_min_date = match Date.make ~year:1583 ~month:1 ~day:1 with Ok d -> d | Error e -> failwith e let domain_max_date = match Date.make ~year:9999 ~month:12 ~day:31 with Ok d -> d | Error e -> failwith e (* [start, stop] for the liturgical year opening in civil year [y], clamped at both ends of the domain rather than calling [rite.year_start] on a civil year outside 1583..9999. Top: at [y] = 9999, [rite.year_start (y + 1)] would ask for civil year 10000 -- out of Date's domain (Plan 2 shipped exactly this bug in Validate). Clamp [stop] to 31 December 9999 instead: the final liturgical year comes back truncated, not un-computable. Bottom: symmetric case, reachable only through [day] below. A date in civil year 1583 before that year's own [rite.year_start] genuinely belongs to the liturgical year that opened in civil year 1582 for an Advent-anchored rite -- but [rite.year_start 1582] is equally out of domain. [day] only ever decrements a valid date's own (in-domain) civil year by at most one, so [y] = 1582 is the sole way this branch is reached. Clamp [start] to 1 January 1583: "year 1582" becomes the truncated stretch from the domain floor up to the day before [rite.year_start 1583], which is exactly the sliver a date there needs. [y] itself is clamped once, up front, to [1582, 9999] -- not left to each branch's own guard. Task 5's review found that guarding [start] and [stop] independently protected only one of their two [rite.year_start] calls each: [start]'s guard (["y < 1583"]) leaves [stop]'s "y + 1" call unguarded at the bottom (["year 999"] still called [year_start 1000], out of domain), and [stop]'s guard (["y >= 9999"]) leaves [start]'s call unguarded at the top (["year 100000"] still called [year_start 100000]). Neither is reachable through [day] (see calendar.mli), but [year] is public, and a direct out-of-contract call must not raise either. Clamping [y] once closes both gaps with one check instead of two. *) let year_bounds (rite : ('s, 'r) Rite.t) (y : int) : Date.t * Date.t = let y = max 1582 (min 9999 y) in let start = if y < 1583 then domain_min_date else rite.Rite.year_start y in let stop = if y >= 9999 then domain_max_date else Date.add_days (rite.Rite.year_start (y + 1)) (-1) in (start, stop) (* RG 91's contest for one date: the temporal office against every sanctoral entry whose Date_spec resolves to it, plus whatever the placement pass below has [injected] there so far (a celebration transferred in from an impeded day elsewhere). [Layer.on_date] is keyed on exactly (month, day), which for a [Fixed] spec -- the only form Plan 2 ships -- is the same test as resolving the spec against [date]'s own year and comparing, so no separate filter is needed here. [injected] is keyed by [Date.to_rata] rather than [Date.t] directly: [Date.t] carries no [compare]-respecting hash, and rata-die is already the canonical total order this module uses for date arithmetic. *) let resolve_with_injected (rite : ('s, 'r) Rite.t) (idx : 'r Layer.by_date) (injected : (int, 'r Precedence.candidate list) Hashtbl.t) (date : Date.t) : ('s, 'r) Temporal.t * 's Precedence.context * 'r Precedence.resolution = let temporal = rite.Rite.temporal date in let temporal_candidate = { Precedence.cel = temporal.Temporal.office; origin = Precedence.Temporal } in let natural = Layer.on_date idx ~month:(Date.month date) ~day:(Date.day date) |> List.map (fun (e : 'r Layer.entry) -> { Precedence.cel = e.Layer.cel; origin = Precedence.Sanctoral }) in let arrived = try Hashtbl.find injected (Date.to_rata date) with Not_found -> [] in let ctx = { Precedence.date; season = temporal.Temporal.season; weekday = temporal.Temporal.weekday } in let resolution = Precedence.resolve rite.Rite.rules ctx ~temporal:temporal_candidate ~sanctoral:(natural @ arrived) in (temporal, ctx, resolution) (* What Precedence.resolve currently reports as observed on [date], given the placements decided so far -- this is exactly the [occupant] callback Rite.transfer_target's search walks forward with (rite.mli explains why that judgement has to come from the rite, not from here). *) let occupant_of (rite : ('s, 'r) Rite.t) (idx : 'r Layer.by_date) (injected : (int, 'r Precedence.candidate list) Hashtbl.t) (date : Date.t) : 'r Celebration.t = let _, _, resolution = resolve_with_injected rite idx injected date in resolution.Precedence.observed.Precedence.cel (* Hard guard on the placement fixed point (spec §2.4): every genuine transfer moves a celebration strictly forward and the celebration set is finite, so the round below always empties [deferred] within a handful of rounds in practice (an RG 97-98 collision of N feasts on one date costs at most N-1 extra rounds -- each round resolves the winner of whatever pile-up occurred and re-defers the rest, one fewer each time). 64 is not tuned to that bound; it is a defensive ceiling nothing in the 1962 calendar comes close to, so that a rite/data combination this module has not anticipated fails as a recorded, inspectable [omitted] reason (below) instead of hanging the CLI. *) let max_transfer_rounds = 64 let unconverged_reason = "omitted: transfer placement did not converge within max_transfer_rounds (RG 96-98)" (* Rebuilds the per-date injection index from [assignment] (slug -> (origin, target)) fresh each round, rather than accumulating it incrementally as candidates are placed. A candidate re-deferred in a later round (its first target turned out to already be claimed by a higher-band rival, see [place_transfers]) must vacate its old target date entirely, not merely gain a second one; rebuilding from a slug-keyed map, which holds exactly one entry per candidate, gives that for free. An append-only structure would instead leave the stale placement behind forever, and the round loop would never see [deferred] empty out. *) let injected_index_of_assignment (assignment : (string, Date.t * Date.t) Hashtbl.t) (candidate_by_slug : (string, 'r Precedence.candidate) Hashtbl.t) : (int, 'r Precedence.candidate list) Hashtbl.t = let tbl : (int, 'r Precedence.candidate list) Hashtbl.t = Hashtbl.create 16 in Hashtbl.iter (fun slug (_origin, target) -> let key = Date.to_rata target in let c = Hashtbl.find candidate_by_slug slug in Hashtbl.replace tbl key (c :: (try Hashtbl.find tbl key with Not_found -> []))) assignment; tbl (* The placement pass itself (spec §2.4 steps 1-4; step 5, recording transferred_in/out, is [year]'s job once this reaches a fixed point). Each round: gather every currently-deferred candidate across the whole year (fresh, against this round's [injected] state -- a candidate already placed and now winning its target is no longer a loser anywhere and so will not reappear here); if none, the fixed point is reached. Otherwise sort ALL of them by band -- RG 97-98: this is the global ordering that decides who transfers first when I-class feasts coincide -- ties break on slug, same convention as Precedence.compare_by, so placement never depends on the layer's own entry order. Then place each in turn, in that order. [claimed_this_round] is what makes the sort actually decide anything: it starts empty every round and gains one entry per candidate placed so far THIS round, and [occupant_with_claims] reports a claimed date as occupied by whoever claimed it, layered on top of [injected] (last round's settled state, frozen for the round -- see [injected_index_of_assignment] for why that has to stay frozen rather than being updated in place). Without it, every candidate in a round would search against the exact same snapshot and a same-date collision would only be caught (and only one side of it corrected) on re-resolution next round, one collision layer per round -- RG 97-98's own ordering would still come out right in the end, but only by accident of Precedence.resolve's own internal tie-break repeating this module's, not because this module's sort ever decided anything. Layering the claims instead means a same-round collision is resolved in the one round it is found, in the sorted order, and the earlier RG 97-98 test pins exactly that: it fails on "claims 2 Feb first" without this. *) let place_transfers (rite : ('s, 'r) Rite.t) (idx : 'r Layer.by_date) (dates : Date.t array) : (string, Date.t * Date.t) Hashtbl.t * (string, 'r Precedence.candidate) Hashtbl.t = let assignment : (string, Date.t * Date.t) Hashtbl.t = Hashtbl.create 16 in let candidate_by_slug : (string, 'r Precedence.candidate) Hashtbl.t = Hashtbl.create 16 in let compare_deferred (_, ctx1, c1) (_, ctx2, c2) = let b1 = rite.Rite.rules.Precedence.band ctx1 c1 in let b2 = rite.Rite.rules.Precedence.band ctx2 c2 in if b1 <> b2 then Int.compare b1 b2 else Slug.compare c1.Precedence.cel.Celebration.slug c2.Precedence.cel.Celebration.slug in let round = ref 0 in let converged = ref false in let guard_hit = ref false in while (not !converged) && not !guard_hit do incr round; if !round > max_transfer_rounds then guard_hit := true else begin let injected = injected_index_of_assignment assignment candidate_by_slug in let raw = Array.to_list dates |> List.concat_map (fun date -> let _, ctx, resolution = resolve_with_injected rite idx injected date in List.map (fun c -> (date, ctx, c)) resolution.Precedence.deferred) in (* [raw] rediscovers every candidate's *permanent* natural loss at its origin every round -- the layer entry never moves, so a candidate already settled elsewhere still shows up losing at the date it was always going to lose at. Left unfiltered, that stale sighting gets placed again right next to the candidate's own already-settled self, which -- because a placed candidate's own rank makes it look "occupied" to a fresh search starting from its original origin -- oscillates between two dates forever, never reaching [deferred = []] (confirmed by removing this filter: "transferable" lands on 14 Jan instead of 13 in test_transfer_moves_and_does_not_duplicate, not merely "doesn't converge" -- the bug is a wrong answer, not only a hang). A sighting is genuinely actionable only if the candidate has never been placed yet (first time seen), or if it is losing exactly at the date it is *currently* assigned to (a fresh RG 97-98 bump: something else also landed there and out-ranked it) -- any other date is the stale, permanent one and is dropped. *) let deferred = List.filter (fun (date, _ctx, c) -> match Hashtbl.find_opt assignment (Slug.to_string c.Precedence.cel.Celebration.slug) with | None -> true | Some (_, target) -> Date.compare date target = 0) raw in if deferred = [] then converged := true else begin let claimed_this_round : (int, 'r Precedence.candidate) Hashtbl.t = Hashtbl.create 4 in let occupant_with_claims d = match Hashtbl.find_opt claimed_this_round (Date.to_rata d) with | Some c -> c.Precedence.cel | None -> occupant_of rite idx injected d in List.stable_sort compare_deferred deferred |> List.iter (fun (origin, _ctx, c) -> let target = rite.Rite.transfer_target c origin occupant_with_claims in let slug = Slug.to_string c.Precedence.cel.Celebration.slug in Hashtbl.replace claimed_this_round (Date.to_rata target) c; Hashtbl.replace assignment slug (origin, target); Hashtbl.replace candidate_by_slug slug c) end end done; (assignment, candidate_by_slug) (* The final build of one day, once placement has reached its fixed point (or exhausted the guard): resolve against the settled [injected] state, then layer on [transferred_in] (this date received an injected candidate that went on to win) and [transferred_out] (some candidate's settled placement originated here). [transferred_out] is a single [Date.t option] (Liturgical_day.mli), so it cannot represent two different celebrations leaving the same origin day for two different destinations. [transferred_out_of] is built with last-write-wins for that (unreached) case; RG 97-98 collisions still report correctly because what actually matters -- each celebration landing on its own, correctly-ordered day, exactly once -- is carried by [observed]/[transferred_in], not by this pointer. *) let build_day (rite : ('s, 'r) Rite.t) (idx : 'r Layer.by_date) (assignment : (string, Date.t * Date.t) Hashtbl.t) (injected : (int, 'r Precedence.candidate list) Hashtbl.t) (transferred_out_of : (int, Date.t) Hashtbl.t) (date : Date.t) : ('s, 'r) Liturgical_day.t = let temporal, _ctx, resolution = resolve_with_injected rite idx injected date in let arrived = try Hashtbl.find injected (Date.to_rata date) with Not_found -> [] in let transferred_in = arrived |> List.find_opt (fun c -> Slug.equal c.Precedence.cel.Celebration.slug resolution.Precedence.observed.Precedence.cel.Celebration.slug) |> Option.map (fun c -> c.Precedence.cel) in let transferred_out = try Some (Hashtbl.find transferred_out_of (Date.to_rata date)) with Not_found -> None in (* [resolution.deferred] here is NOT "the placement pass never got to these": it is the origin day's own permanent, structural loss -- the layer entry that lost the RG 91 contest here never moves, so a candidate successfully placed somewhere else still shows up losing at the exact date it was always going to lose at (this is the same fact [place_transfers]'s round loop has to filter around, see its comment). A [deferred] sighting only belongs in [omitted] if it was never actually settled anywhere -- i.e. the guard above was hit before this candidate reached a day it wins. Settled elsewhere means genuinely accounted for via [observed]/[transferred_in] on the day it landed and [transferred_out] here, not via [omitted] too -- double-booking it in both would fail Task 12's "appears exactly once" reading of this day alone. *) let unresolved c = let slug = Slug.to_string c.Precedence.cel.Celebration.slug in match Hashtbl.find_opt assignment slug with | None -> true | Some (_, target) -> not (Slug.equal (occupant_of rite idx injected target).Celebration.slug c.Precedence.cel.Celebration.slug) in let omitted = List.map (fun (c, reason) -> (c.Precedence.cel, reason)) resolution.Precedence.omitted @ (resolution.Precedence.deferred |> List.filter unresolved |> List.map (fun c -> (c.Precedence.cel, unconverged_reason))) in { Liturgical_day.date; rite = rite.Rite.id; temporal; observed = resolution.Precedence.observed.Precedence.cel; commemorations = List.map (fun (c, p) -> (c.Precedence.cel, p)) resolution.Precedence.commemorations; transferred_in; transferred_out; omitted; citations = []; } let year (rite : ('s, 'r) Rite.t) (layer : 'r Layer.t) (y : int) : ('s, 'r) Liturgical_day.t array = let idx = Layer.index_by_date layer in let start, stop = year_bounds rite y in (* [max 0]: defends [Array.init] against a negative length, which would otherwise arise for a rite whose [year_start] lands exactly on the domain floor (start clamps to the same date, giving [stop] a day before it). Not reachable through [day] -- see calendar.mli -- but [year] is public, and a direct out-of-contract call must not raise either. *) let n = max 0 (Date.to_rata stop - Date.to_rata start + 1) in let dates = Array.init n (fun i -> Date.add_days start i) in let assignment, candidate_by_slug = place_transfers rite idx dates in let injected = injected_index_of_assignment assignment candidate_by_slug in let transferred_out_of : (int, Date.t) Hashtbl.t = Hashtbl.create 16 in Hashtbl.iter (fun _slug (origin, target) -> Hashtbl.replace transferred_out_of (Date.to_rata origin) target) assignment; Array.map (build_day rite idx assignment injected transferred_out_of) dates let day (rite : ('s, 'r) Rite.t) (layer : 'r Layer.t) (date : Date.t) : ('s, 'r) Liturgical_day.t = let cy = Date.year date in let y = if Date.compare date (rite.Rite.year_start cy) >= 0 then cy else cy - 1 in let start, _ = year_bounds rite y in (year rite layer y).(Date.to_rata date - Date.to_rata start)