diff options
Diffstat (limited to 'test')
| -rw-r--r-- | test/test_calendar.ml | 5 | ||||
| -rw-r--r-- | test/test_precedence.ml | 4 | ||||
| -rw-r--r-- | test/test_precedence_ef.ml | 85 | ||||
| -rw-r--r-- | test/test_validate.ml | 15 |
4 files changed, 86 insertions, 23 deletions
diff --git a/test/test_calendar.ml b/test/test_calendar.ml index 8770017..93cd0bb 100644 --- a/test/test_calendar.ml +++ b/test/test_calendar.ml @@ -82,7 +82,10 @@ module Fixture = struct test below a genuine Precedence-native omission (distinct from a deferred one) to exercise. *) let rules : (season, rank) P.rules = - { P.band; disposition; admit = (fun ~observed:_ ~temporal:_ cs -> List.filteri (fun i _ -> i < 1) cs) } + { P.band; disposition; + admit = + (fun ~observed:_ ~temporal:_ cs -> + List.filteri (fun i _ -> i < 1) cs |> List.map (fun (c, p, (_ : int)) -> (c, p))) } (* RG 96, generic form: search forward from the day after [origin] for the first day whose occupant is not "blocking" -- in this synthetic diff --git a/test/test_precedence.ml b/test/test_precedence.ml index ff75baa..ce75ab6 100644 --- a/test/test_precedence.ml +++ b/test/test_precedence.ml @@ -26,7 +26,9 @@ let rules = | Cel.Feast -> (match loser.P.cel.Cel.rank with | Hi -> P.Transfer | Lo -> P.Commemorate P.Ordinary)); - admit = (fun ~observed:_ ~temporal:_ cs -> List.filteri (fun i _ -> i < 2) cs) } + admit = + (fun ~observed:_ ~temporal:_ cs -> + List.filteri (fun i _ -> i < 2) cs |> List.map (fun (c, p, (_ : int)) -> (c, p))) } let slug_of c = S.to_string c.P.cel.Cel.slug diff --git a/test/test_precedence_ef.ml b/test/test_precedence_ef.ml index 8465870..ca623d2 100644 --- a/test/test_precedence_ef.ml +++ b/test/test_precedence_ef.ml @@ -290,7 +290,7 @@ let test_all_souls_yields_to_sunday () = let rules = { P.band = (fun c cd -> PE.band c cd); disposition = (fun ~winner:_ ~loser:_ -> P.Omit); - admit = (fun ~observed:_ ~temporal:_ cs -> cs) } + admit = (fun ~observed:_ ~temporal:_ cs -> List.map (fun (c, p, (_ : int)) -> (c, p)) cs) } in let resolution = P.resolve rules day_ctx ~temporal:sunday ~sanctoral:[ all_souls ] in Alcotest.(check string) "the Sunday is observed, not All Souls" @@ -822,6 +822,22 @@ let observed_class3 = cand ~rank:V.Class3 "ef-some-class3-day" let slugs_of admitted = List.map (fun (c, _) -> S.to_string c.P.cel.Cel.slug) admitted +(* [admit_cases] below (Task B, ef-rg16a) needs a precedence-order [int] on + every comms triple -- {!Precedence.rules.admit}'s new parameter, RG 113 + (docs/research/rules-register.md §4, "RG 113"). This table's own header + comment states its purpose: isolate [admit]'s own selection/count logic + from {!PE.band}'s occurrence-table classification, so every candidate + here is built from a synthetic slug ("ef-ordinary-hi" etc.) that matches + none of [band]'s 28 real branches -- calling the REAL [PE.band] on them + would collapse every one to {!PE.unclassified} (the same tied value), + destroying the table's ability to distinguish rows at all. [order_of_rank] + is a TEST-ONLY stand-in, reproducing exactly the relative order the + previous [dignity] function gave (RG 8's rank cardinal, lower first) -- + so every existing expectation below still holds unchanged; only the + tuple shape gained this third field. *) +let order_of_rank = function V.Class1 -> 10 | V.Class2 -> 20 | V.Class3 -> 30 | V.Class4 -> 40 +let po c p = (c, p, order_of_rank c.P.cel.Cel.rank) + (* Real-data shapes for the fix round's own RG16(a)/[admit] interaction (below): a Feast of the Lord (subject Lord, Class2, sanctoral) as [observed], oracle-confirmed real slugs/ranks rather than hand-typed @@ -853,28 +869,28 @@ let admit_cases = [ (* RG 111 (§4): "I class: none save one privileged." *) ( "I-class day, only an ordinary commemoration due -> none admitted", observed_class1, observed_class1, - [ (ordinary_hi, P.Ordinary) ], + [ po ordinary_hi P.Ordinary ], [] ); ( "I-class day, ordinary + privileged both due -> only the privileged \ one, regardless of the ordinary one's higher dignity", observed_class1, observed_class1, - [ (ordinary_hi, P.Ordinary); (privileged_lo, P.Privileged) ], + [ po ordinary_hi P.Ordinary; po privileged_lo P.Privileged ], [ "ef-privileged-lo" ] ); ( "I-class day, two privileged due -> only the higher-dignity one (still \ just \"one\")", observed_class1, observed_class1, - [ (privileged_lo, P.Privileged); (privileged_hi, P.Privileged) ], + [ po privileged_lo P.Privileged; po privileged_hi P.Privileged ], [ "ef-privileged-hi" ] ); (* RG 111: "II-class Sundays: one (dropped if a privileged one is due)." *) ( "II-class Sunday, only an ordinary commemoration due -> it is admitted", observed_class2_sunday, observed_class2_sunday, - [ (ordinary_hi, P.Ordinary) ], + [ po ordinary_hi P.Ordinary ], [ "ef-ordinary-hi" ] ); ( "II-class Sunday, ordinary (higher dignity) + privileged (lower \ dignity) both due -> the PRIVILEGED one is admitted, the ordinary \ one dropped despite outranking it", observed_class2_sunday, observed_class2_sunday, - [ (ordinary_hi, P.Ordinary); (privileged_lo, P.Privileged) ], + [ po ordinary_hi P.Ordinary; po privileged_lo P.Privileged ], [ "ef-privileged-lo" ] ); (* RG 111(b)'s own rank floor ("scilicet DE FESTO II CLASSIS"), fix round 1 F7: a Class3 ORDINARY candidate -- no privileged rival due, @@ -886,7 +902,7 @@ let admit_cases = ( "II-class Sunday, sole candidate is an ORDINARY Class3 (not \ \"de festo II classis\") -> admitted nothing, not the best available", observed_class2_sunday, observed_class2_sunday, - [ (ordinary_class3, P.Ordinary) ], + [ po ordinary_class3 P.Ordinary ], [] ); (* RG 111: "other II class: one" -- no privilege override, the exact asymmetry the brief and precedence_ef.ml's own [admit] comment flag: @@ -895,21 +911,21 @@ let admit_cases = ( "other II-class day, only an ordinary commemoration due -> it is \ admitted", observed_class2_other, observed_class2_other, - [ (ordinary_hi, P.Ordinary) ], + [ po ordinary_hi P.Ordinary ], [ "ef-ordinary-hi" ] ); ( "other II-class day, same ordinary+privileged pair as the Sunday row \ above -> the ORDINARY one wins on pure dignity this time, the \ privileged one dropped", observed_class2_other, observed_class2_other, - [ (ordinary_hi, P.Ordinary); (privileged_lo, P.Privileged) ], + [ po ordinary_hi P.Ordinary; po privileged_lo P.Privileged ], [ "ef-ordinary-hi" ] ); (* RG 111: "III-IV class: at most two" -- three candidates due, top two by dignity admitted, the third (lowest dignity) dropped. *) ( "III-class day, three commemorations due -> the top two by dignity, \ not merely \"two of them\"", observed_class3, observed_class3, - [ (ordinary_hi, P.Ordinary); (privileged_lo, P.Privileged); - (ordinary_lowest, P.Ordinary) ], + [ po ordinary_hi P.Ordinary; po privileged_lo P.Privileged; + po ordinary_lowest P.Ordinary ], [ "ef-ordinary-hi"; "ef-privileged-lo" ] ); (* Fix round 1, item 2 (RG16(a) task review): the CRITICAL witness for [~temporal]. RG 16(a)'s own text -- the winning Feast of the Lord @@ -928,7 +944,7 @@ let admit_cases = TEMPORAL candidate is a II-class Sunday -> the RG111(b) rank floor \ still applies, admits nothing (Sixtus, Class3, has no standing)", lord_winner, an_ordinary_sunday, - [ (sixtus, P.Ordinary) ], + [ po sixtus P.Ordinary ], [] ); (* The control, same pair as the row above with [observed] = [temporal] (no displacement -- an ordinary WEEKDAY, not a Sunday): "other II @@ -941,7 +957,7 @@ let admit_cases = = observed, not a Sunday) -> \"other II class: one\", Sixtus IS \ admitted", lord_winner, lord_winner, - [ (sixtus, P.Ordinary) ], + [ po sixtus P.Ordinary ], [ "pope-sixtus-ii-felicissimus-and-agapitus-martyrs" ] ) ] @@ -953,7 +969,7 @@ let admit_cases = two-candidate row where either order already happens to be sorted. *) let test_admit_order_independent () = let comms = - [ (ordinary_hi, P.Ordinary); (privileged_lo, P.Privileged); (ordinary_lowest, P.Ordinary) ] + [ po ordinary_hi P.Ordinary; po privileged_lo P.Privileged; po ordinary_lowest P.Ordinary ] in let forward = slugs_of (PE.admit ~observed:observed_class3 ~temporal:observed_class3 comms) in let reversed = @@ -962,6 +978,39 @@ let test_admit_order_independent () = Alcotest.(check (list string)) "reversed input admits the same candidates" forward reversed +(* RG 113 teeth (Task B, ef-rg16a): two SAME-rank candidates whose slug order + DISAGREES with their band/precedence order -- "aa-worse-precedence" sorts + first alphabetically but is given the WORSE (higher) precedence int, + "zz-better-precedence" sorts last alphabetically but the BETTER (lower) + one. Both are [Class3] (same RG 8 "dignity", so a version of [admit] that + silently reverted to sorting by [rank] then slug -- the exact pre-fix + shape this task replaced -- would pick "aa-worse-precedence" here, the + OPPOSITE of what this asserts. A real RG 91 [band] value never actually + produces this exact pairing against these two synthetic slugs (see + [admit_cases]'s own header on why this table uses synthetic, non-band- + classifiable slugs) -- the precedence ints are supplied directly, the + same [po]/explicit-order convention this file already uses, standing in + for whatever real [band] would compute. This is what proves [admit] + actually consults the passed-in precedence value rather than merely + accepting one as a matter of new type-checking. *) +let order_tiebreak_alpha_first_worse = cand ~rank:V.Class2 "aa-worse-precedence" +let order_tiebreak_alpha_last_better = cand ~rank:V.Class2 "zz-better-precedence" + +(* [observed_class2_other]: "other II class: one" admits exactly ONE, by + precedence order alone (no privilege override, no rank floor) -- unlike + the III-class row [test_admit_order_independent] reuses, which admits + TWO out of two offered here and so cannot distinguish "picked by + precedence" from "picked both anyway". *) +let test_admit_uses_precedence_not_slug_when_they_disagree () = + let comms = + [ (order_tiebreak_alpha_first_worse, P.Ordinary, 90); + (order_tiebreak_alpha_last_better, P.Ordinary, 10) ] + in + Alcotest.(check (list string)) + "the BETTER-precedence candidate is admitted even though it sorts LAST alphabetically" + [ "zz-better-precedence" ] + (slugs_of (PE.admit ~observed:observed_class2_other ~temporal:observed_class2_other comms)) + (* The brief: "a case proving that what the limit drops is reported in omitted rather than vanishing" -- three end-to-end proofs, wired with the REAL [PE.band], [PE.disposition] and [PE.admit] together (not a stub, so @@ -1181,7 +1230,10 @@ let test_all_souls_transfers_end_to_end () = origin = P.Temporal } in let all_souls = cand ~origin:P.Sanctoral ~layer:PE.universal_layer "ef-all-souls" in - let rules = { P.band = PE.band; disposition = PE.disposition; admit = (fun ~observed:_ ~temporal:_ cs -> cs) } in + let rules = + { P.band = PE.band; disposition = PE.disposition; + admit = (fun ~observed:_ ~temporal:_ cs -> List.map (fun (c, p, (_ : int)) -> (c, p)) cs) } + in let resolution = P.resolve rules day_ctx ~temporal:sunday ~sanctoral:[ all_souls ] in Alcotest.(check (list string)) "All Souls is deferred (transferred), not omitted or commemorated" [ "ef-all-souls" ] @@ -1378,6 +1430,9 @@ let suite = admit_cases @ [ Alcotest.test_case "admit is order-independent (III-class, 3 candidates)" `Quick test_admit_order_independent; + Alcotest.test_case + "RG113: admit picks by precedence order, not slug, when they disagree" `Quick + test_admit_uses_precedence_not_slug_when_they_disagree; Alcotest.test_case "I-class day: full drop reported in omitted, not vanished" `Quick test_i_class_day_drops_into_omitted; Alcotest.test_case "II-class Sunday: second loser dropped into omitted" `Quick diff --git a/test/test_validate.ml b/test/test_validate.ml index 42c58f5..501dd2e 100644 --- a/test/test_validate.ml +++ b/test/test_validate.ml @@ -377,7 +377,9 @@ module Synthetic = struct let dup_rules : (season, rank) P.rules = { P.band = (fun _ c -> match c.P.origin with P.Temporal -> 0 | P.Sanctoral -> 10); disposition = (fun ~winner:_ ~loser:_ -> P.Commemorate P.Ordinary); - admit = (fun ~observed:_ ~temporal:_ cs -> List.map (fun (c, p) -> ({ c with P.origin = c.P.origin }, p)) cs) } + admit = + (fun ~observed:_ ~temporal:_ cs -> + List.map (fun (c, p, (_ : int)) -> ({ c with P.origin = c.P.origin }, p)) cs) } (* "unconverged": two entries collide on one date (6 June), both beating the temporal office and tied with each other, so slug decides: @@ -416,7 +418,7 @@ module Synthetic = struct disposition = (fun ~winner:_ ~loser -> match loser.P.cel.Cel.rank with R1 -> P.Transfer | R2 -> P.Commemorate P.Ordinary); - admit = (fun ~observed:_ ~temporal:_ cs -> cs) } + admit = (fun ~observed:_ ~temporal:_ cs -> List.map (fun (c, p, (_ : int)) -> (c, p)) cs) } let guard_transfer_target (_ : rank P.candidate) (origin : D.t) (_ : D.t -> rank Cel.t) = origin @@ -434,7 +436,7 @@ module Synthetic = struct let adm_c_entry = mk_entry ~month:9 ~day:9 ~slug:"adm-c" ~rank:R2 let adm_layer = Layer.of_entries ~id:"adm" ~name:"adm" [ adm_a_entry; adm_b_entry; adm_c_entry ] - let adm_compare_slug (c1, _) (c2, _) = Slug.compare c1.P.cel.Cel.slug c2.P.cel.Cel.slug + let adm_compare_slug (c1, _, _) (c2, _, _) = Slug.compare c1.P.cel.Cel.slug c2.P.cel.Cel.slug let rec adm_take n = function | [] -> [] @@ -446,7 +448,8 @@ module Synthetic = struct admit = (fun ~observed:_ ~temporal:_ cs -> let sorted = List.stable_sort adm_compare_slug cs in - if List.length sorted mod 2 = 1 then adm_take 2 sorted else adm_take 1 sorted) } + let taken = if List.length sorted mod 2 = 1 then adm_take 2 sorted else adm_take 1 sorted in + List.map (fun (c, p, (_ : int)) -> (c, p)) taken) } (* "observed": two DIFFERENT layer entries sharing one slug -- a realistic data mistake (a renamed or duplicated entry), not prevented by @@ -475,7 +478,7 @@ module Synthetic = struct disposition = (fun ~winner:_ ~loser -> match loser.P.cel.Cel.rank with R1 -> P.Transfer | R2 -> P.Commemorate P.Ordinary); - admit = (fun ~observed:_ ~temporal:_ cs -> cs) } + admit = (fun ~observed:_ ~temporal:_ cs -> List.map (fun (c, p, (_ : int)) -> (c, p)) cs) } let collide_d2 = match D.make ~year:2026 ~month:2 ~day:10 with Ok d -> d | Error e -> failwith e let collide_transfer_target (_ : rank P.candidate) (_ : D.t) (_ : D.t -> rank Cel.t) = collide_d2 @@ -492,7 +495,7 @@ module Synthetic = struct let clean_sanctoral_rules : (season, rank) P.rules = { P.band = (fun _ c -> match c.P.origin with P.Temporal -> 0 | P.Sanctoral -> 10); disposition = (fun ~winner:_ ~loser:_ -> P.Commemorate P.Ordinary); - admit = (fun ~observed:_ ~temporal:_ cs -> cs) } + admit = (fun ~observed:_ ~temporal:_ cs -> List.map (fun (c, p, (_ : int)) -> (c, p)) cs) } end open Synthetic |