aboutsummaryrefslogtreecommitdiff
path: root/lib/kernel/calendar.ml
diff options
context:
space:
mode:
authorLukasz Kasprzak <lukas@labunix.xyz>2026-08-11 21:29:13 +0200
committerLukasz Kasprzak <lukas@labunix.xyz>2026-08-11 21:29:13 +0200
commit1d6be4ac281e62accfb905b137b3c6b494183ee4 (patch)
tree20e34ee8773db4cbcb8f06a29835a087a5219b8a /lib/kernel/calendar.ml
parentf15e44dd4c1b871c2daeb952b1c8c848274ea1f1 (diff)
downloadcolitur-1d6be4ac281e62accfb905b137b3c6b494183ee4.tar.gz
colitur-1d6be4ac281e62accfb905b137b3c6b494183ee4.zip
kernel(calendar): fix multi-departure loss, band-order gap, off-array targets
Four findings from Task 6 review, addressed on top of f15e44d. 1. transferred_out was a single Date.t option, so when RG 97-98 collides three or more feasts on one date (more than one loser), only the last one Hashtbl.iter happened to visit survived -- a genuinely lost move, and which one survived depended on OCaml's hash seed (OCAMLRUNPARAM=R), an environment read a kernel invariant forbids. RG 97-98 says coinciding feasts transfer "in order" -- plural -- so the type was wrong, not the fixture: transferred_out is now (Celebration.t * Date.t) list. transferred_in stays a single option, deliberately: a day receives at most one arrival (RG 96 sends each departure to the next non-I/II-class day, and the first to arrive occupies it). The per-day list is canonicalised (sorted by target date, then slug) after accumulation, the same fix layer.ml already applies to its own date-bucket index and for the same reason. Verified clean across 15 runs under OCAMLRUNPARAM=R; disabling the canonicalisation step showed the raw order genuinely flip between seeds, confirming the fix is load-bearing. 2. Every deferred candidate in the fixture was the same rank, so compare_deferred's band branch was unreachable and reversing it broke nothing -- the RG 97-98 test was pinning slug order, not band order. The fixture now has three ranks (Hi1 outranks Hi2, both transfer, both outrank Lo), with slugs chosen so band order and slug order disagree. Reversing the band comparison now fails the test on "higher-band loser claims 2 Feb first", received the wrong slug instead. 3. A transfer_target free to name any date could place a candidate outside the liturgical year's own start/stop bounds: invisible to year/build_day, so it would be observed nowhere and, since its origin's re-resolution would report it as settled, omitted nowhere either -- genuinely gone, contradicting calendar.mli's "never silently dropped". place_transfers now checks the range on every placement and routes an out-of-range one to a permanent-exclusion table instead of assignment, with its own cited omitted reason. 4. Precedence.resolve folds Transfer and Repose into one deferred case, and place_transfers routed all of it through transfer_target (RG 96's search), which is only correct for Transfer. Repose is RG 100-102's repositio, a distinct rubric this module does not implement. Documented rather than split into a second mechanism: nothing in the EF ruleset returns Repose (design spec section 1.3, "declared, not exercised"), so the gap is latent, not a live bug. Two new tests (origin records every departure; transfer target outside year is recorded not lost); the RG 97-98 test's fixture and assertions rewritten for finding 2.
Diffstat (limited to 'lib/kernel/calendar.ml')
-rw-r--r--lib/kernel/calendar.ml157
1 files changed, 116 insertions, 41 deletions
diff --git a/lib/kernel/calendar.ml b/lib/kernel/calendar.ml
index 1ad45a1..5d3572c 100644
--- a/lib/kernel/calendar.ml
+++ b/lib/kernel/calendar.ml
@@ -101,6 +101,20 @@ 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
@@ -125,6 +139,22 @@ let injected_index_of_assignment (assignment : (string, Date.t * Date.t) Hashtbl
(* 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
@@ -148,11 +178,21 @@ let injected_index_of_assignment (assignment : (string, Date.t * Date.t) Hashtbl
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 =
+ 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
@@ -185,16 +225,22 @@ let place_transfers (rite : ('s, 'r) Rite.t) (idx : 'r Layer.by_date) (dates : D
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. *)
+ 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) ->
- match Hashtbl.find_opt assignment (Slug.to_string c.Precedence.cel.Celebration.slug) with
- | None -> true
- | Some (_, target) -> Date.compare date target = 0)
+ 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
@@ -209,31 +255,30 @@ let place_transfers (rite : ('s, 'r) Rite.t) (idx : 'r Layer.by_date) (dates : D
|> 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)
+ 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)
+ (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] (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. *)
+ 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, Date.t) Hashtbl.t) (date : Date.t) : ('s, 'r) Liturgical_day.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 =
@@ -244,7 +289,7 @@ let build_day (rite : ('s, 'r) Rite.t) (idx : 'r Layer.by_date)
|> 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
+ 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
@@ -253,23 +298,30 @@ let build_day (rite : ('s, 'r) Rite.t) (idx : 'r Layer.by_date)
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. *)
+ 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
- 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)
+ 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, unconverged_reason)))
+ |> List.map (fun c -> (c.Precedence.cel, reason_for c)))
in
{
Liturgical_day.date;
@@ -296,13 +348,36 @@ let year (rite : ('s, 'r) Rite.t) (layer : 'r Layer.t) (y : int) :
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 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, Date.t) Hashtbl.t = Hashtbl.create 16 in
+ let transferred_out_of : (int, ('r Celebration.t * Date.t) list) Hashtbl.t = Hashtbl.create 16 in
Hashtbl.iter
- (fun _slug (origin, target) -> Hashtbl.replace transferred_out_of (Date.to_rata origin) target)
+ (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;
- Array.map (build_day rite idx assignment injected transferred_out_of) dates
+ (* 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 =