diff options
| -rw-r--r-- | lib/kernel/temporal.ml | 5 | ||||
| -rw-r--r-- | lib/kernel/temporal.mli | 8 | ||||
| -rw-r--r-- | lib/rites/rite_ef/temporal_ef.ml | 261 | ||||
| -rw-r--r-- | lib/rites/rite_ef/temporal_ef.mli | 15 | ||||
| -rw-r--r-- | test/cli.t | 4 | ||||
| -rw-r--r-- | test/test_temporal_ef.ml | 139 |
6 files changed, 317 insertions, 115 deletions
diff --git a/lib/kernel/temporal.ml b/lib/kernel/temporal.ml index a34eeb0..878c6e9 100644 --- a/lib/kernel/temporal.ml +++ b/lib/kernel/temporal.ml @@ -4,7 +4,10 @@ open Sexplib0.Sexp_conv the temporal cycle's own office for it. *) type ('s, 'r) t = { season : 's; - week : int option; (** [None] for named days outside a numbered week *) + week : int option; + (** [None] exactly when the date falls outside every numbered week the + rite defines; a named day inside a numbered season run still + carries that run's week -- see temporal.mli. *) weekday : Date.weekday; office : 'r Celebration.t; } diff --git a/lib/kernel/temporal.mli b/lib/kernel/temporal.mli index 055f9aa..9113dba 100644 --- a/lib/kernel/temporal.mli +++ b/lib/kernel/temporal.mli @@ -2,7 +2,13 @@ the temporal cycle's own office for it. *) type ('s, 'r) t = { season : 's; - week : int option; (** [None] for named days outside a numbered week *) + week : int option; + (** [None] exactly when the date falls outside every numbered week the + rite defines (e.g. a season with no week numbering at all, or a + transitional span between two numbered runs). A day being *named* + is not by itself a reason for [None]: a named day that sits inside + a numbered season run must carry that run's week the same as any + other day in it. *) weekday : Date.weekday; office : 'r Celebration.t; } diff --git a/lib/rites/rite_ef/temporal_ef.ml b/lib/rites/rite_ef/temporal_ef.ml index 4147278..52a9adb 100644 --- a/lib/rites/rite_ef/temporal_ef.ml +++ b/lib/rites/rite_ef/temporal_ef.ml @@ -59,67 +59,56 @@ let same a b = Date.compare a b = 0 Sunday (RG 91 entry 6), Ash Wednesday (RG 91 entry 7), and the days within the Octave of the Nativity (RG 63-70, RG 91 entry 17). - Returns (season, slug, colour, rank, week). *) + Returns (season, slug, colour, rank). Deliberately NOT week: an earlier + version carried an explicit week option here, hand-set on some branches + (Passion/Palm Sunday, Easter, Low Sunday, Pentecost and its Vigil, Christ + the King) and left at [None] on others (Ascension and its Vigil, Corpus + Christi, Sacred Heart) even though those sit inside a numbered season run + just the same -- a manual-convention bug the guarding property could not + even detect (see test_temporal_ef.ml's history). [temporal] now calls + [week] itself for every day, named or not, which makes "a named day inside + a run carries that run's week" hold by construction instead of by + remembering to set it here. *) let named d = let y = Date.year d in let easter = Computus.gregorian_easter y in let off n = Date.add_days easter n in let m = Date.month d and dd = Date.day d in - if m = 12 && dd = 25 then Some (Christmastide, "ef-nativity", Colour.White, Class1, None) + if m = 12 && dd = 25 then Some (Christmastide, "ef-nativity", Colour.White, Class1) else if m = 12 && dd = 24 then (* RG 91 entry 5: the Vigil of the Nativity is I class. lectio has no slug for it, so this key has no lectionary entry until Plan 3 fills it. *) - Some (Advent, "ef-nativity-vigil", Colour.Violet, Class1, None) + Some (Advent, "ef-nativity-vigil", Colour.Violet, Class1) else if m = 12 && (dd = 29 || dd = 30 || dd = 31) then (* Days within the Octave of the Nativity; 26-28 Dec are Stephen, John and the Innocents, hence sanctoral (Plan 3). Colitur slugs -- lectionary gap. *) - Some (Christmastide, Printf.sprintf "ef-nativity-octave-day-%d" (dd - 24), Colour.White, Class2, None) + Some (Christmastide, Printf.sprintf "ef-nativity-octave-day-%d" (dd - 24), Colour.White, Class2) else if m = 1 && dd = 1 then (* RG 91 entry 5: 1 Jan is the Octave Day of the Nativity, the same table entry as the Nativity vigil above. *) - Some (Christmastide, "ef-circumcision", Colour.White, Class1, None) - else if m = 1 && dd = 6 then Some (Christmastide, "ef-epiphany", Colour.White, Class1, None) + Some (Christmastide, "ef-circumcision", Colour.White, Class1) + else if m = 1 && dd = 6 then Some (Christmastide, "ef-epiphany", Colour.White, Class1) else if same d (off (-46)) then - Some (Lent, "ef-ash-wednesday", Colour.Violet, Class1, None) (* RG 91 entry 7 *) + Some (Lent, "ef-ash-wednesday", Colour.Violet, Class1) (* RG 91 entry 7 *) else if same d (off (-14)) then - Some (Passiontide, "ef-passion-sunday", Colour.Violet, Class1, Some 1) (* RG 91 entry 6 *) + Some (Passiontide, "ef-passion-sunday", Colour.Violet, Class1) (* RG 91 entry 6 *) else if same d (off (-7)) then - Some (Passiontide, "ef-palm-sunday", Colour.Violet, Class1, Some 2) (* RG 91 entry 6 *) - else if same d easter then Some (Paschaltide, "ef-easter-sunday", Colour.White, Class1, Some 1) + Some (Passiontide, "ef-palm-sunday", Colour.Violet, Class1) (* RG 91 entry 6 *) + else if same d easter then Some (Paschaltide, "ef-easter-sunday", Colour.White, Class1) else if same d (off 7) then - Some (Paschaltide, "ef-low-sunday", Colour.White, Class1, Some 2) (* RG 91 entry 6 *) + Some (Paschaltide, "ef-low-sunday", Colour.White, Class1) (* RG 91 entry 6 *) else if same d (off 38) then (* RG 91 entry 21: II-class vigil. It is also Rogation Wednesday; with no precedence framework until Plan 3, temporal emits the higher-ranked vigil and the Rogation commemoration waits for RG 108-111. *) - Some (Paschaltide, "ef-ascension-vigil", Colour.White, Class2, None) - else if same d (off 39) then Some (Paschaltide, "ef-ascension", Colour.White, Class1, None) - else if same d (off 48) then - (* Carries week 7 -- the same week as the Friday before it -- for - consistency with the other named Sundays here (Easter, Low Sunday, - Trinity below): a named day inside a season run must not interrupt the - run's week continuity. Not an RG rule, an internal-consistency one; - this was [None] until the Validate invariant harness (Task 14) caught - the resulting jump on the following Monday. *) - Some (Paschaltide, "ef-pentecost-vigil", Colour.Red, Class1, Some 7) (* RG 91 entry 9 *) - else if same d (off 49) then - (* Carries week 8, for the same reason as the Vigil just above. *) - Some (Paschaltide, "ef-pentecost", Colour.Red, Class1, Some 8) - else if same d (off 56) then Some (Time_after_pentecost, "ef-trinity", Colour.White, Class1, Some 1) - else if same d (off 60) then - Some (Time_after_pentecost, "ef-corpus-christi", Colour.White, Class1, None) - else if same d (off 68) then - Some (Time_after_pentecost, "ef-sacred-heart", Colour.White, Class1, None) - else if same d (christ_the_king y) then - (* Carries its computed week number too, for the same internal-consistency - reason as Pentecost above -- caught by the same Validate finding. - Unlike Pentecost this isn't a fixed Easter-offset, so it can't be a - literal; [week] below computes it but is defined later in this file and - can't be called from here, so the same expression is inlined here. - test_named_week_agrees_with_week pins the two together. *) - let pentecost = off 49 in - Some (Time_after_pentecost, "ef-christ-the-king", Colour.White, Class1, - Some ((Date.to_rata d - Date.to_rata pentecost) / 7)) + Some (Paschaltide, "ef-ascension-vigil", Colour.White, Class2) + else if same d (off 39) then Some (Paschaltide, "ef-ascension", Colour.White, Class1) + else if same d (off 48) then Some (Paschaltide, "ef-pentecost-vigil", Colour.Red, Class1) (* RG 91 entry 9 *) + else if same d (off 49) then Some (Paschaltide, "ef-pentecost", Colour.Red, Class1) + else if same d (off 56) then Some (Time_after_pentecost, "ef-trinity", Colour.White, Class1) + else if same d (off 60) then Some (Time_after_pentecost, "ef-corpus-christi", Colour.White, Class1) + else if same d (off 68) then Some (Time_after_pentecost, "ef-sacred-heart", Colour.White, Class1) + else if same d (christ_the_king y) then Some (Time_after_pentecost, "ef-christ-the-king", Colour.White, Class1) else None let days_between a b = Date.to_rata b - Date.to_rata a @@ -150,6 +139,12 @@ let week_origin s y = | Paschaltide -> Some easter | Time_after_pentecost -> Some (Date.add_days easter 49) (* Pentecost *) +(* [week] is total and defined for every date, named or not: a named day + inside a numbered season run carries that run's week by calling this same + function, not by a separately hand-set value (see [named]'s docstring + above). It naturally returns [None] for Christmastide (no season-wide + numbering) and for the handful of proper-Mass days between Ash Wednesday + and Lent I that precede any run's origin. *) let week d = let s = season d in match week_origin s (Date.year d) with @@ -159,6 +154,56 @@ let week d = let n = match s with Time_after_pentecost -> n | _ -> n + 1 in if n < 1 then None else Some n +(* Christmastide has no numbered weeks ([week_origin] returns [None]), so the + generic <season>-<week>-<weekday> ferial fallback below would collapse + every feria to literal week "0" -- and because colitur's Christmastide + spans 25 Dec - 13 Jan (RG 72-73, the deliberate divergence from lectio), + the same weekday recurs two or three times across that span, producing + duplicate slugs within a single liturgical year (register finding 1). + Four sub-stretches, each given a key that cannot collide with the others: + + - 26-28 Dec (between the Nativity and its Octave days, which are named + above): lectio has no narrower key here either, so this keeps its + existing "ef-christmas-0-<weekday>" key unchanged -- nothing to lose by + changing it, and nothing gained. + - 2-5 Jan (between the Octave Day and Epiphany): lectio *also* collapses + this to "ef-christmas-0-<weekday>", indistinguishable from the stretch + above in lectio's own data. colitur cannot preserve a distinction lectio + doesn't make, so this becomes "ef-christmas-1-<weekday>" -- a + colitur-only key and a lectionary gap for the Plan 3 bootstrap to fill, + exactly like the Nativity vigil and octave-day keys above. + - 7-13 Jan, split in two by the *actual* first-Sunday-after-Epiphany + origin ([week_origin Time_after_epiphany], which by construction always + falls somewhere in this window -- see that function's own comment): + - from the origin Sunday through 13 Jan: this genuinely is week 1 of + Time after Epiphany, just still inside Christmastide by season + (RG 72-73). lectio keys it "ef-time-after-epiphany-1-<weekday>", the + same key [sunday_slug] already gives the Sunday in this window -- + and it is the *same computation* the ordinary Time-after-Epiphany + ferial fallback below will give the rest of that same + Sunday-to-Saturday week once the season turns on 14 Jan, so this + cannot collide with it (a fixed 7-day week has each weekday once). + - 7 Jan through the day *before* the origin (0-6 days, only present + when Epiphany does not fall on a Saturday): these genuinely precede + week 1 -- treating them as week 1 too, as a naive calendar-range + read of lectio's behaviour would, collides with the days named just + above, because they are exactly 7 days before them for whichever + weekdays they cover (verified empirically: reusing "week 1" here + produced duplicates in most years, not merely an edge case). No + lectio key to preserve either way, so this is its own colitur-only + "ef-christmas-2-<weekday>" -- a further lectionary gap. *) +let christmastide_feria_slug d = + let y = Date.year d in + let m = Date.month d and dd = Date.day d in + let w = Date.weekday_to_string (Date.weekday d) in + if m = 12 && dd >= 26 && dd <= 28 then Some (Printf.sprintf "ef-christmas-0-%s" w) + else if m = 1 && dd >= 2 && dd <= 5 then Some (Printf.sprintf "ef-christmas-1-%s" w) + else if m = 1 && dd >= 7 && dd <= 13 then + match week_origin Time_after_epiphany y with + | Some origin when Date.compare d origin >= 0 -> Some (Printf.sprintf "ef-time-after-epiphany-1-%s" w) + | _ -> Some (Printf.sprintf "ef-christmas-2-%s" w) + else None + (* Sunday slugs. These are lectionary keys: they use [season_slug_word], and for Christmastide they keep lectio's keys even though colitur's season differs (spec §4.4 -- slugs are opaque keys, not truth). *) @@ -206,7 +251,20 @@ let sunday_slug d = let id = "ef" -(* The third Sunday of September: the Ember week's anchor. *) +(* The third Sunday of September: the Ember week's anchor. + + This specific date-derivation rule is one of the more contested points in + the 1962 calendar: pre-1955 practice tied the September Ember days to the + week following the Exaltation of the Holy Cross (14 Sept) instead. The two + rules only disagree when 1 September is a Monday -- 2025 is such a year -- + and the primary-source scan available to this project does not contain an + explicit numbered-paragraph statement of either rule (searched; see + register §3 "Ember days"), so this citation is deliberately left at the + rank rules only (RG 91 entries 18/22, cited on [ember] below), not the + date-derivation rule itself: a wrong citation is worse than none. + Empirically: for 2025 this rule gives 24/26/27 September, confirmed + against an independent oracle; the Holy-Cross rule would give 17/19/20 + September instead. See register §3 for the full note. *) let third_sunday_of_september y = let sep1 = mk y 9 1 in let first_sunday = Date.add_days sep1 ((7 - weekday_index sep1) mod 7) in @@ -215,7 +273,13 @@ let third_sunday_of_september y = (* Ember days: Wednesday, Friday and Saturday after the anchoring Sunday. RG 91 entry 18 makes the Advent, Lent and September sets II class; entry 22 excepts the Lenten set from the III-class Lenten ferias. The Whitsun set - falls inside the I-class Pentecost octave and takes its rank. *) + falls inside the I-class Pentecost octave and takes its rank. + + The September and Advent sets match lectio's own Ember slugs. The Lent and + Whitsun (Pentecost) sets do not -- lectio has no Ember slug for either, so + "ef-lent-ember-*" and "ef-pentecost-ember-*" are colitur-only keys and a + lectionary gap for the Plan 3 bootstrap to fill (spec §4.4), the same + status as the Nativity vigil and the Rogation days below. *) let ember d = let y = Date.year d in let easter = Computus.gregorian_easter y in @@ -249,12 +313,19 @@ let privileged_feria d = let n = days_between easter d in (n >= -6 && n <= -1) || (n >= 1 && n <= 6) || (n >= 50 && n <= 55) +(* RG 117 enumerates the five colours (white, red, green, violet, black); + RG 127 assigns green and RG 128 violet to the seasons de Tempore below. + White's own specific paragraph (the "B) De colore albo" section, between + 117 and 123) was not pinned by the primary-source search available here -- + left uncited rather than guessed; see register §3 "Colours". *) let season_colour = function - | Advent | Septuagesima | Lent | Passiontide -> Colour.Violet + | Advent | Septuagesima | Lent | Passiontide -> Colour.Violet (* RG 128 *) | Christmastide | Paschaltide -> Colour.White - | Time_after_epiphany | Time_after_pentecost -> Colour.Green + | Time_after_epiphany | Time_after_pentecost -> Colour.Green (* RG 127 *) -(* Gaudete (Advent III) and Laetare (Lent IV) are rose. *) +(* Gaudete (Advent III) and Laetare (Lent IV) are rose: RG 131, "may be used... + for the Office and Mass of that Sunday only" -- an indult over the + season's violet, not a season colour of its own. *) let is_rose_sunday d s = let y = Date.year d in match s with @@ -290,14 +361,20 @@ let temporal d = { Colitur_kernel.Temporal.season; week; weekday; office } in match named d with - | Some (season, slug, colour, rank, week) -> build ~season ~slug ~colour ~rank ~week + | Some (season, slug, colour, rank) -> build ~season ~slug ~colour ~rank ~week:(week d) | None -> ( - (* Rogations: RG 80/87, Monday and Tuesday before Ascension. The - Wednesday is the Ascension vigil (see Task 11). RG 88: "de Litaniis - minoribus nihil fit in Officio" -- the Office (hence the day's rank) - is unchanged by the Rogation; only the Mass is proper. No RG 91 table - entry elevates these days, so they take the ordinary ferial rank of - their season via [ferial_rank] rather than a fixed class. *) + (* Rogations (the Minor Litanies only -- RG 87, Monday and Tuesday + before Ascension). The Major Litanies (25 April, RG 80) are a fixed + date and are not yet computed; they arrive with Plan 3's sanctoral + (register §6). The Wednesday here is the Ascension vigil (see Task + 11). RG 88: "de Litaniis minoribus nihil fit in Officio" -- the + Office (hence the day's rank) is unchanged by the Rogation; only the + Mass is proper. No RG 91 table entry elevates these days, so they + take the ordinary ferial rank of their season via [ferial_rank] + rather than a fixed class. lectio has no Rogation slug at all, so + "ef-rogation-monday"/"-tuesday" are colitur-only keys and a + lectionary gap for Plan 3, like the Ember and Nativity-vigil keys + above. *) let rogation = days_between easter d in if rogation = 36 || rogation = 37 then build ~season:s @@ -312,30 +389,66 @@ let temporal d = let colour = if is_rose_sunday d s then Colour.Rose else season_colour s in (* RG 11-12: Sundays of Advent, Lent, Passiontide, Easter, Low Sunday and Pentecost are I class; all others II. The I-class - ones are already named above, so anything reaching here is - II class except the remaining Advent and Lent Sundays. *) - let rank = match s with Advent | Lent | Passiontide -> Class1 | _ -> Class2 in + ones are already named above -- Passiontide has only two + Sundays and both are named, so no Passiontide Sunday ever + reaches this fallback -- leaving II class here except the + remaining Advent and Lent Sundays. *) + let rank = match s with Advent | Lent -> Class1 | _ -> Class2 in build ~season:s ~slug ~colour ~rank ~week:(week d) - | None -> - (* The days between Ash Wednesday and Lent I have proper Masses - and belong to no numbered week. *) - let after_ashes = days_between easter d in - if after_ashes >= -45 && after_ashes <= -43 then - build ~season:s - ~slug:(Printf.sprintf "ef-lent-after-ashes-%s" (weekday_word d)) - ~colour:Colour.Violet ~rank:Class3 ~week:None - else - let colour = - (* The Pentecost octave weekdays are red, not Paschaltide's white. *) - if days_between easter d >= 50 && days_between easter d <= 55 then Colour.Red - else season_colour s - in - let week_n = week d in - let slug = - Printf.sprintf "ef-%s-%d-%s" (season_slug_word s) - (Option.value week_n ~default:0) (weekday_word d) - in - build ~season:s ~slug ~colour ~rank:(ferial_rank d s) ~week:week_n)) + | None -> ( + match christmastide_feria_slug d with + | Some slug -> + build ~season:s ~slug ~colour:(season_colour s) ~rank:(ferial_rank d s) ~week:(week d) + | None -> + (* The days between Ash Wednesday and Lent I have proper + Masses and belong to no numbered week. *) + let after_ashes = days_between easter d in + if after_ashes >= -45 && after_ashes <= -43 then + build ~season:s + ~slug:(Printf.sprintf "ef-lent-after-ashes-%s" (weekday_word d)) + ~colour:Colour.Violet ~rank:Class3 ~week:None + else + let colour = + (* The Pentecost octave weekdays are red, not Paschaltide's white. *) + if days_between easter d >= 50 && days_between easter d <= 55 then Colour.Red + else season_colour s + in + let week_n = week d in + let slug = + Printf.sprintf "ef-%s-%d-%s" (season_slug_word s) + (Option.value week_n ~default:0) (weekday_word d) + in + build ~season:s ~slug ~colour ~rank:(ferial_rank d s) ~week:week_n))) + +(* Independent restatement of [named]'s fixed and Easter-relative dates, + paired with the slug each should carry, for civil year [y]. Deliberately + NOT derived from [named] itself -- consumed by [Validate]'s anchor- + agreement check (design spec §5.7), which exists precisely to catch an + accidental single-site drift (e.g. Ascension's [off 39] silently becoming + [off 40]) that both sides moving together would hide. *) +let anchors y = + let easter = Computus.gregorian_easter y in + let off n = Date.add_days easter n in + [ ("ef-nativity", mk y 12 25); + ("ef-nativity-vigil", mk y 12 24); + ("ef-nativity-octave-day-5", mk y 12 29); + ("ef-nativity-octave-day-6", mk y 12 30); + ("ef-nativity-octave-day-7", mk y 12 31); + ("ef-circumcision", mk y 1 1); + ("ef-epiphany", mk y 1 6); + ("ef-ash-wednesday", off (-46)); + ("ef-passion-sunday", off (-14)); + ("ef-palm-sunday", off (-7)); + ("ef-easter-sunday", off 0); + ("ef-low-sunday", off 7); + ("ef-ascension-vigil", off 38); + ("ef-ascension", off 39); + ("ef-pentecost-vigil", off 48); + ("ef-pentecost", off 49); + ("ef-trinity", off 56); + ("ef-corpus-christi", off 60); + ("ef-sacred-heart", off 68); + ("ef-christ-the-king", christ_the_king y) ] (* Compile-time check that this module satisfies the kernel's rite contract. *) module _ : Colitur_kernel.Temporal.RITE = struct diff --git a/lib/rites/rite_ef/temporal_ef.mli b/lib/rites/rite_ef/temporal_ef.mli index ddfcac2..a07ffa2 100644 --- a/lib/rites/rite_ef/temporal_ef.mli +++ b/lib/rites/rite_ef/temporal_ef.mli @@ -15,9 +15,11 @@ val season : Date.t -> Vocab_ef.season val christ_the_king : int -> Date.t (** The named temporal days: I-class feasts of the Lord, vigils, and days within - the Octave of the Nativity. Returns (season, slug, colour, rank, week). *) -val named : - Date.t -> (Vocab_ef.season * string * Colour.t * Vocab_ef.rank * int option) option + the Octave of the Nativity. Returns (season, slug, colour, rank). Carries + no week of its own -- {!temporal} computes it uniformly via {!week} for + every day, named or not, so a named day inside a numbered season run + always carries that run's week. *) +val named : Date.t -> (Vocab_ef.season * string * Colour.t * Vocab_ef.rank) option (** The Sunday on which week 1 of a season begins, in civil year [y]. [None] for [Christmastide], which has no numbered weeks. *) @@ -35,3 +37,10 @@ val id : string (** Total over 1583..9999: every date yields exactly one temporal identity. *) val temporal : Date.t -> (Vocab_ef.season, Vocab_ef.rank) Temporal.t + +(** Independent restatement of {!named}'s fixed and Easter-relative dates for + civil year [y], paired with the slug each should carry. Feeds + {!Colitur_kernel.Validate.run}'s anchor-agreement check; not derived from + {!named}, so an accidental single-site drift in an offset is caught + rather than left invisible. *) +val anchors : int -> (string * Date.t) list @@ -24,8 +24,8 @@ The EF temporal cycle for a year, one line per day: $ colitur temporal 2026 | head -3 2026-01-01 thursday christmastide ef-circumcision class-1 white - 2026-01-02 friday christmastide ef-christmas-0-friday class-4 white - 2026-01-03 saturday christmastide ef-christmas-0-saturday class-4 white + 2026-01-02 friday christmastide ef-christmas-1-friday class-4 white + 2026-01-03 saturday christmastide ef-christmas-1-saturday class-4 white $ colitur temporal 2026 | wc -l 365 diff --git a/test/test_temporal_ef.ml b/test/test_temporal_ef.ml index f99626c..2ad93e8 100644 --- a/test/test_temporal_ef.ml +++ b/test/test_temporal_ef.ml @@ -55,7 +55,7 @@ let test_seasons () = Alcotest.(check string) "Trinity 31 May 2026" "time-after-pentecost" (season_str (d 2026 5 31)) let named_slug dt = match T.named dt with - | Some (_, slug, _, _, _) -> slug + | Some (_, slug, _, _) -> slug | None -> "<none>" let test_named_feasts () = @@ -132,10 +132,12 @@ let test_week_sunday_slug_agree () = (fun n -> let dt = D.add_days pentecost (7 * n) in let slug = sunday_slug_of dt in - let embedded = Scanf.sscanf slug "ef-time-after-pentecost-sunday-%d" (fun k -> k) in - Alcotest.(check (option int)) - (Printf.sprintf "week %d after Pentecost matches slug" n) - (Some embedded) (T.week dt)) + match Scanf.sscanf_opt slug "ef-time-after-pentecost-sunday-%d" (fun k -> k) with + | None -> Alcotest.failf "slug %S did not match the expected ...-sunday-N pattern" slug + | Some embedded -> + Alcotest.(check (option int)) + (Printf.sprintf "week %d after Pentecost matches slug" n) + (Some embedded) (T.week dt)) [ 1; 5; 10; 15; 20 ] (* The resumed-Sunday tail: when Easter is early there are more than 23 Sundays @@ -162,16 +164,40 @@ let test_resumed_sundays () = in Alcotest.(check bool) "2035 has resumed Epiphany Sundays" true (resumed <> []) -(* Regression for a Task 14 Validate finding: named's own explicit week - numbers (Easter, Low Sunday, Passion/Palm Sunday, Trinity, Pentecost and - its Vigil, Christ the King) must agree with what [week] independently - computes for the same date -- omitting or mis-stating one breaks week - continuity across that day. A general property over every day of many - years, not point assertions on the three days the bug was found on, so the - same drift cannot silently reappear in a future addition to [named]. *) -let prop_named_week_agrees_with_week = +module Cel = Colitur_kernel.Celebration +module Sl = Colitur_kernel.Slug +module Colr = Colitur_kernel.Colour + +let office dt = (T.temporal dt).Colitur_kernel.Temporal.office +let slug_of dt = Sl.to_string (office dt).Cel.slug +let rank_of dt = V.rank_to_string (office dt).Cel.rank +let colour_of dt = Colr.to_string (office dt).Cel.colour +let temporal_week dt = (T.temporal dt).Colitur_kernel.Temporal.week + +(* Regression for a Task 14 Validate finding, reworked (register finding 4): + [named] no longer carries its own week at all -- [temporal] computes it + uniformly via [week] for every day, named or not -- so "a named day inside + a numbered season run carries that run's week" now holds by construction + rather than by a hand-set value on some branches and not others. These four + sat inside a numbered run (Paschaltide week 6, Time after Pentecost weeks 1 + and 2 respectively) but carried [None] under the old convention-based + version; each assertion below would have failed against it (first to fail: + Ascension Vigil, expected [Some 6], got [None]). *) +let test_named_days_carry_their_week () = + Alcotest.(check (option int)) "Ascension Vigil carries week 6" (Some 6) (temporal_week (d 2026 5 13)); + Alcotest.(check (option int)) "Ascension carries week 6" (Some 6) (temporal_week (d 2026 5 14)); + Alcotest.(check (option int)) "Corpus Christi carries week 1" (Some 1) (temporal_week (d 2026 6 4)); + Alcotest.(check (option int)) "Sacred Heart carries week 2" (Some 2) (temporal_week (d 2026 6 12)) + +(* The total replacement for the old property: with [week] removed from + [named]'s own return type, "the day's week" has exactly one source, so this + can be asserted for *every* day, not merely wherever [named] happened to + supply an explicit value -- the old version's [| _ -> true] escape hatch + for every unnamed and every None-week day is gone, and with it the reason + that version could not detect an omission. *) +let prop_temporal_week_matches_week = QCheck.Test.make ~count:200 - ~name:"named's explicit week agrees with week, wherever named gives one" + ~name:"temporal's week always equals week, for every day of the year" (QCheck.int_range 1583 9998) (fun y -> let start = d y 1 1 in @@ -181,22 +207,10 @@ let prop_named_week_agrees_with_week = i >= n || let dt = D.add_days start i in - (match T.named dt with - | Some (_, _, _, _, Some w) -> T.week dt = Some w - | _ -> true) - && check (i + 1) + temporal_week dt = T.week dt && check (i + 1) in check 0) -module Cel = Colitur_kernel.Celebration -module Sl = Colitur_kernel.Slug -module Colr = Colitur_kernel.Colour - -let office dt = (T.temporal dt).Colitur_kernel.Temporal.office -let slug_of dt = Sl.to_string (office dt).Cel.slug -let rank_of dt = V.rank_to_string (office dt).Cel.rank -let colour_of dt = Colr.to_string (office dt).Cel.colour - let test_ferial_slugs_and_ranks () = (* Ferias key on season-week-weekday, matching lectio's lectionary keys. *) Alcotest.(check string) "Lent feria" "ef-lent-3-monday" (slug_of (d 2026 3 9)); @@ -271,15 +285,69 @@ let test_colours () = Alcotest.(check string) "Gaudete is rose" "rose" (colour_of (d 2026 12 13)); Alcotest.(check string) "Laetare is rose" "rose" (colour_of (d 2026 3 15)) +(* Register finding 1 / controller finding A: Christmastide's ferial fallback + used to collapse every day to literal week "0" (no numbered weeks in + Christmastide), and because colitur's Christmastide spans 25 Dec - 13 Jan, + the same weekday recurred and collided. 2026: Easter 5 Apr, Epiphany + (6 Jan) is a Tuesday, so the actual first-Sunday-after-Epiphany origin is + 11 Jan -- exercising all four sub-stretches of the fix. *) +let test_christmastide_feria_slugs () = + Alcotest.(check string) "26 Dec (Sat)" "ef-christmas-0-saturday" (slug_of (d 2026 12 26)); + Alcotest.(check string) "28 Dec (Mon)" "ef-christmas-0-monday" (slug_of (d 2026 12 28)); + Alcotest.(check string) "2 Jan (Fri)" "ef-christmas-1-friday" (slug_of (d 2026 1 2)); + Alcotest.(check string) "5 Jan (Mon)" "ef-christmas-1-monday" (slug_of (d 2026 1 5)); + (* 7-10 Jan precede the actual origin Sunday (11 Jan): colitur-only, not + lectio's "week 1" key, precisely to avoid colliding with 12-13 Jan below. *) + Alcotest.(check string) "7 Jan (Wed, before the origin)" "ef-christmas-2-wednesday" (slug_of (d 2026 1 7)); + Alcotest.(check string) "10 Jan (Sat, before the origin)" "ef-christmas-2-saturday" (slug_of (d 2026 1 10)); + (* 12-13 Jan are on/after the origin: genuinely week 1, lectio's key. *) + Alcotest.(check string) "12 Jan (Mon, on/after the origin)" "ef-time-after-epiphany-1-monday" + (slug_of (d 2026 1 12)); + Alcotest.(check string) "13 Jan (Tue, on/after the origin)" "ef-time-after-epiphany-1-tuesday" + (slug_of (d 2026 1 13)) + +(* The general property behind the fix above: no two dates in one liturgical + year may share a slug, except the deliberate resumed-Sunday reuse (see + test_resumed_sundays). Random years across the whole domain, not just + 2026 -- the original bug (controller finding A) was found by grepping one + year's CLI output for duplicates, and other years could hide others. *) +let is_resumable_sunday_slug s = + let prefix = "ef-time-after-epiphany-sunday-" in + String.length s > String.length prefix && String.sub s 0 (String.length prefix) = prefix + +let prop_slugs_unique_within_liturgical_year = + QCheck.Test.make ~count:200 + ~name:"no two dates in one liturgical year share a slug, apart from the resumed-Sunday reuse" + (QCheck.int_range 1583 9998) + (fun y -> + let start = T.year_start y in + let stop = D.add_days (T.year_start (y + 1)) (-1) in + let n = D.to_rata stop - D.to_rata start + 1 in + let seen = Hashtbl.create 512 in + let rec check i = + i >= n + || + let s = slug_of (D.add_days start i) in + (is_resumable_sunday_slug s + || (not (Hashtbl.mem seen s)) + && ( + Hashtbl.replace seen s (); + true)) + && check (i + 1) + in + check 0) + let test_totality () = - (* Every day of 2026 yields an office, and every slug is well-formed. *) + (* Every day of 2026 yields an office without raising. Not a slug + re-validation -- Slug.t is a private string validated on construction, + so round-tripping to_string/of_string on an existing value is a + tautology (the same vacuous check Validate's own comment identifies and + explains for the same reason). This still has value: it forces full + evaluation of [temporal] across a whole year and would fail if any day + in it raised. *) let jan1 = d 2026 1 1 in for i = 0 to 364 do - let dt = D.add_days jan1 i in - let s = slug_of dt in - match Sl.of_string s with - | Ok _ -> () - | Error e -> Alcotest.failf "%s: %s" (D.to_iso8601 dt) e + ignore (T.temporal (D.add_days jan1 i)) done let suite_extra = @@ -297,6 +365,8 @@ let suite_extra = Alcotest.test_case "ember days" `Quick test_ember_days; Alcotest.test_case "rogations" `Quick test_rogations; Alcotest.test_case "colours" `Quick test_colours; + Alcotest.test_case "christmastide feria slugs" `Quick test_christmastide_feria_slugs; + Alcotest.test_case "named days carry their week" `Quick test_named_days_carry_their_week; Alcotest.test_case "totality" `Quick test_totality ] let suite = @@ -304,4 +374,5 @@ let suite = [ Alcotest.test_case "vocab roundtrips" `Quick test_vocab_roundtrips; Alcotest.test_case "slug words" `Quick test_slug_words ] @ suite_extra - @ List.map QCheck_alcotest.to_alcotest [ prop_named_week_agrees_with_week ] ) + @ List.map QCheck_alcotest.to_alcotest + [ prop_temporal_week_matches_week; prop_slugs_unique_within_liturgical_year ] ) |