aboutsummaryrefslogtreecommitdiff
path: root/lib/kernel/calendar.ml
diff options
context:
space:
mode:
Diffstat (limited to 'lib/kernel/calendar.ml')
-rw-r--r--lib/kernel/calendar.ml133
1 files changed, 128 insertions, 5 deletions
diff --git a/lib/kernel/calendar.ml b/lib/kernel/calendar.ml
index 99992b3..98e9032 100644
--- a/lib/kernel/calendar.ml
+++ b/lib/kernel/calendar.ml
@@ -58,7 +58,20 @@ let year_bounds (rite : ('s, 'r) Rite.t) (y : int) : Date.t * Date.t =
[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.index)
+(* RG 33's third trigger, third stage: the set of (date, slug) pairs whose
+ vigil the rule suppresses, keyed by rata die. Empty for a rite whose
+ [vigil_feast] is the constant [None], and empty on the EF's own shipped
+ data -- see {!rg33_suppressed} for both. *)
+let no_suppression : (int, string list) Hashtbl.t = Hashtbl.create 1
+
+let is_suppressed (suppressed : (int, string list) Hashtbl.t) (date : Date.t)
+ (c : 'r Precedence.candidate) =
+ match Hashtbl.find_opt suppressed (Date.to_rata date) with
+ | None -> false
+ | Some slugs -> List.mem (Slug.to_string c.Precedence.cel.Celebration.slug) slugs
+
+let resolve_with_injected ?(suppressed = no_suppression) (rite : ('s, 'r) Rite.t)
+ (idx : 'r Layer.index)
(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
@@ -72,8 +85,22 @@ let resolve_with_injected (rite : ('s, 'r) Rite.t) (idx : 'r Layer.index)
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
+ (* RG 33: a suppressed vigil is not a losing candidate, it is not a
+ candidate at all -- "penitus omittitur". Filtering here rather than
+ leaving it to [disposition] is deliberate and is what the rubric says:
+ were it left in the contest it could still claim the day's single
+ commemoration slot (RG 111) ahead of a saint genuinely entitled to it,
+ which is precisely the defect the SECOND trigger's own fix corrected for
+ the Sunday case. Note this drops it from [omitted] too -- the
+ suppression is reported by {!build_day} instead, with its own reason, so
+ nothing vanishes unaccounted for. *)
+ let sanctoral =
+ match Hashtbl.length suppressed with
+ | 0 -> natural @ arrived
+ | _ -> List.filter (fun c -> not (is_suppressed suppressed date c)) (natural @ arrived)
+ in
let resolution =
- Precedence.resolve rite.Rite.rules ctx ~temporal:temporal_candidate ~sanctoral:(natural @ arrived)
+ Precedence.resolve rite.Rite.rules ctx ~temporal:temporal_candidate ~sanctoral
in
(temporal, ctx, resolution)
@@ -115,6 +142,13 @@ let unconverged_reason =
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)"
+(* RG 33: "Vigilia II aut III classis penitus omittitur... vel si festum cui
+ praemittitur in alium diem transferri aut ad commemorationem reduci
+ contingat." The vigil is not demoted or commemorated -- it is dropped
+ whole, which is what "penitus" says. *)
+let rg33_vigil_reason =
+ "omitted: the feast this vigil precedes does not keep its own day (RG 33)"
+
(* 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
@@ -273,13 +307,77 @@ let place_transfers (rite : ('s, 'r) Rite.t) (idx : 'r Layer.index) ~(start : Da
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]). *)
+(* RG 33's third omission trigger -- "vel si festum cui praemittitur in alium
+ diem transferri aut ad commemorationem reduci contingat" ("or if the feast
+ it precedes happens to be transferred to another day or reduced to a
+ commemoration"). See {!Precedence.rules.vigil_feast} for the contract and
+ for why the RITE names the feast instead of the kernel inferring it.
+
+ ONE PASS, NO FIXED POINT. Both halves of the clause reduce to the same
+ observable question -- is the named feast the OBSERVED office on the
+ following day? -- and the answer cannot depend on the vigil, because a
+ vigil is a candidate only on its own day and never on its feast's. So
+ resolving D+1 here WITHOUT applying this rule is exact, not an
+ approximation, and the recursion an eager reading would suggest (D asks
+ D+1, which asks D+2...) never arises. Contrast RG 96's transfers, which
+ genuinely do need [place_transfers]' iteration.
+
+ RUNS AFTER [place_transfers], and must: the whole point is to see the
+ post-transfer placement, so the [injected] table this receives is the
+ settled one.
+
+ D+1 MAY FALL OUTSIDE THE LITURGICAL YEAR -- the last day of the year is
+ resolved against the first day of the next, which [Layer.index] already
+ covers (it indexes [y-1; y; y+1]) and {!Rite.temporal} answers for any
+ in-domain date. Only the domain edge itself is refused, where [Date.add_days]
+ would leave the representable range; a vigil there keeps its office, the
+ same conservative direction the rest of this module takes at the boundary. *)
+let rg33_suppressed (rite : ('s, 'r) Rite.t) (idx : 'r Layer.index)
+ (injected : (int, 'r Precedence.candidate list) Hashtbl.t) (dates : Date.t array) :
+ (int, string list) Hashtbl.t =
+ let suppressed : (int, string list) Hashtbl.t = Hashtbl.create 8 in
+ Array.iter
+ (fun date ->
+ let candidates =
+ Layer.on_date idx 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 temporal = rite.Rite.temporal date in
+ let temporal_candidate =
+ { Precedence.cel = temporal.Temporal.office; origin = Precedence.Temporal }
+ in
+ (* The temporal cycle produces vigils too (the Ascension vigil is one),
+ so it is checked alongside the sanctoral candidates. *)
+ List.iter
+ (fun c ->
+ match rite.Rite.rules.Precedence.vigil_feast c with
+ | None -> ()
+ | Some feast ->
+ if Date.compare date domain_max_date < 0 then begin
+ let morrow = Date.add_days date 1 in
+ let _, _, r = resolve_with_injected rite idx injected morrow in
+ let observed = r.Precedence.observed.Precedence.cel.Celebration.slug in
+ if not (Slug.equal observed feast) then begin
+ let key = Date.to_rata date in
+ let slug = Slug.to_string c.Precedence.cel.Celebration.slug in
+ let prior = try Hashtbl.find suppressed key with Not_found -> [] in
+ Hashtbl.replace suppressed key (slug :: prior)
+ end
+ end)
+ (temporal_candidate :: (candidates @ arrived)))
+ dates;
+ suppressed
+
let build_day (rite : ('s, 'r) Rite.t) (idx : 'r Layer.index)
(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)
+ (suppressed : (int, string 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 temporal, _ctx, resolution = resolve_with_injected ~suppressed rite idx injected date in
let arrived = try Hashtbl.find injected (Date.to_rata date) with Not_found -> [] in
let transferred_in =
arrived
@@ -399,7 +497,7 @@ let build_day (rite : ('s, 'r) Rite.t) (idx : 'r Layer.index)
Major Litanies transfer as [Commemoration_only], and RG 96's search
guarantees a transferred FEAST an unblocked target. *)
let settled_at target slug =
- let _, _, target_resolution = resolve_with_injected rite idx injected target in
+ let _, _, target_resolution = resolve_with_injected ~suppressed rite idx injected target in
let matches (c : 'r Precedence.candidate) =
Slug.equal c.Precedence.cel.Celebration.slug slug
in
@@ -420,10 +518,30 @@ let build_day (rite : ('s, 'r) Rite.t) (idx : 'r Layer.index)
out_of_range_reason
else unconverged_reason
in
+ (* RG 33's third trigger removes the vigil from the contest entirely
+ ({!resolve_with_injected} filters it before {!Precedence.resolve} ever
+ sees it), so it cannot appear in [resolution.omitted] the way an
+ ordinary loser does. Re-derived here from the same table, with its own
+ reason, so that the day's accounting stays complete: every candidate the
+ date carries is still reported somewhere. *)
+ let rg33_omitted =
+ match Hashtbl.find_opt suppressed (Date.to_rata date) with
+ | None -> []
+ | Some slugs ->
+ let on_date =
+ Layer.on_date idx date |> List.map (fun (e : 'r Layer.entry) -> e.Layer.cel)
+ in
+ let temporal_office = temporal.Temporal.office in
+ (temporal_office :: (on_date @ List.map (fun c -> c.Precedence.cel) arrived))
+ |> List.filter (fun (cel : 'r Celebration.t) ->
+ List.mem (Slug.to_string cel.Celebration.slug) slugs)
+ |> List.map (fun cel -> (cel, rg33_vigil_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)))
+ @ rg33_omitted
in
{
Liturgical_day.date;
@@ -489,7 +607,12 @@ let year (rite : ('s, 'r) Rite.t) (layer : 'r Layer.t) (y : int) :
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
+ (* RG 33's third trigger, computed once for the whole year and AFTER
+ [place_transfers], because the question it asks -- did the vigil's feast
+ keep its own day? -- is only answerable against the settled placement.
+ See {!rg33_suppressed}. *)
+ let suppressed = rg33_suppressed rite idx injected dates in
+ Array.map (build_day rite idx assignment out_of_range injected suppressed transferred_out_of) dates
let day (rite : ('s, 'r) Rite.t) (layer : 'r Layer.t) (date : Date.t) :
('s, 'r) Liturgical_day.t =