path: root/lib/kernel/calendar.ml

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

(* A rite-supplied [transfer_target] is trusted to search strictly forward
   (rite.mli), but nothing stops it naming a date past the end of the
   liturgical year it was asked about -- e.g. an I-class feast impeded in
   the last days before Advent I, whose first admissible day genuinely
   falls in the following liturgical year's own territory (unproven to
   occur in the real EF calendar, but not something this module can rule
   out by construction). [place_transfers] never injects such a target: the
   [dates] array is exactly what [year]/[build_day] walk to produce the
   result, so a candidate placed outside it would be [observed]/
   [transferred_in] nowhere in the output at all -- gone, not merely
   mis-filed, and silently so, contradicting [calendar.mli]'s "never
   silently dropped". This reason makes that failure mode visible instead. *)
let out_of_range_reason = "omitted: transfer target falls outside the liturgical year (RG 96)"

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

   Every [Precedence.Transfer]-*and*-[Precedence.Repose]-disposed loser lands
   in [resolution.deferred] together -- [Precedence.resolve]'s own fold
   matches them as one case, [Transfer | Repose -> ... :: defs ...] -- and
   everything gathered below is routed through
   [rite.transfer_target], i.e. RG 96's next-admissible-day search. That is
   only correct for [Transfer]. [Repose] denotes RG 100-102's *repositio*
   (perpetual impediment, reassigned to the next appropriate day and treated
   as proper) -- a distinct rubric this module does not implement. It is
   documented here rather than split into a second mechanism because nothing
   currently produces [Repose]: the design spec records it as "declared, not
   exercised" (§1.3) -- the EF ruleset (Tasks 7-9) returns it for nothing;
   perpetual impediment arises from proper/diocesan calendars, which are
   overlay content, out of this plan's scope. If a future rite's rules ever
   do return [Repose], it would silently take the RG 96 path here, which
   would be wrong -- worth knowing before that day, not discovering it then.

   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.

   [~start ~stop] bound the [transfer_target] a placement is allowed to
   settle on: outside that range it goes into [out_of_range] instead of
   [assignment], permanently (never retried -- [transfer_target] is a pure
   function of a candidate's own permanent origin and the occupancy state,
   so asking it again would only recompute the same out-of-range answer). *)
let place_transfers (rite : ('s, 'r) Rite.t) (idx : 'r Layer.by_date) ~(start : Date.t)
    ~(stop : Date.t) (dates : Date.t array) :
    (string, Date.t * Date.t) Hashtbl.t
    * (string, 'r Precedence.candidate) Hashtbl.t
    * (string, Date.t * Date.t) 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 out_of_range : (string, Date.t * Date.t) Hashtbl.t = Hashtbl.create 4 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, and not
         already known unplaceable -- [out_of_range] gets the same
         permanent exclusion [assignment] does, for the same reason), 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) ->
            let slug = Slug.to_string c.Precedence.cel.Celebration.slug in
            if Hashtbl.mem out_of_range slug then false
            else
              match Hashtbl.find_opt assignment 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
               if Date.compare target start < 0 || Date.compare target stop > 0 then
                 Hashtbl.replace out_of_range slug (origin, target)
               else begin
                 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
    end
  done;
  (assignment, candidate_by_slug, out_of_range)

(* 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] (whichever candidates' settled
   placements originated here -- RG 97-98 lets that be more than one; see
   [Liturgical_day.transferred_out]). *)
let build_day (rite : ('s, 'r) Rite.t) (idx : 'r Layer.by_date)
    (assignment : (string, Date.t * Date.t) Hashtbl.t)
    (out_of_range : (string, Date.t * Date.t) Hashtbl.t)
    (injected : (int, 'r Precedence.candidate list) Hashtbl.t)
    (transferred_out_of : (int, ('r Celebration.t * Date.t) list) 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 Hashtbl.find transferred_out_of (Date.to_rata date) with Not_found -> []
  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. it is stuck in [out_of_range], or the
     guard above was hit before it 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
    if Hashtbl.mem out_of_range slug then true
    else
      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 reason_for c =
    if Hashtbl.mem out_of_range (Slug.to_string c.Precedence.cel.Celebration.slug) then
      out_of_range_reason
    else unconverged_reason
  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, reason_for c)))
  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, out_of_range = place_transfers rite idx ~start ~stop dates in
  let injected = injected_index_of_assignment assignment candidate_by_slug in
  let transferred_out_of : (int, ('r Celebration.t * Date.t) list) Hashtbl.t = Hashtbl.create 16 in
  Hashtbl.iter
    (fun slug (origin, target) ->
      let cel = (Hashtbl.find candidate_by_slug slug).Precedence.cel in
      let key = Date.to_rata origin in
      Hashtbl.replace transferred_out_of key
        ((cel, target) :: (try Hashtbl.find transferred_out_of key with Not_found -> [])))
    assignment;
  (* Canonicalise each day's departures: the accumulation above walks
     [assignment] via [Hashtbl.iter], whose bucket order is not guaranteed
     stable across runs (OCaml's hash seed can be randomised via
     OCAMLRUNPARAM=R), so a day with more than one departure -- RG 97-98's
     coinciding-feasts case -- would otherwise report them in a
     run-dependent order: an environment read, in a kernel whose invariants
     forbid one. [Layer.index_by_date] guards against exactly this by
     re-sorting each date bucket after building it (layer.ml); same fix,
     same reason. Sorted by target date -- which, for a correctly-converged
     year, is also RG 97-98's own order: the higher-precedence loser claims
     the earlier admissible day -- ties (not expected, but not assumed
     impossible) broken on slug. *)
  let by_target_then_slug (c1, t1) (c2, t2) =
    let dc = Date.compare t1 t2 in
    if dc <> 0 then dc else Slug.compare c1.Celebration.slug c2.Celebration.slug
  in
  Hashtbl.iter
    (fun k v -> Hashtbl.replace transferred_out_of k (List.sort by_target_then_slug v))
    transferred_out_of;
  Array.map (build_day rite idx assignment out_of_range 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)