path: root/tools/extract_lms_ordo.ml

(* Task 6 (2026-08-21-colitur-celebrant-rubrics-phase1): turns pdftotext's
   -layout dump of the Latin Mass Society's printed Ordo into
   test/fixtures/lms-ordo-2024-2025.sexp, one row per UNIVERSAL-calendar
   day (England & Wales diocesan variants are recorded as PRESENT via
   [has_diocesan_variant] but their own text is discarded -- see the
   fixture's own provenance header, and task-6-report.md's "how much of
   the Ordo's year is comparable" accounting, for why).

   NOT a general Ordo parser: hand-rolled against ONE PDF's own column
   layout (Author "Peter Day-Milne", Producer "LibreOffice 7.4", pdftotext
   1.6), verified line-by-line against the source before being trusted --
   see task-6-report.md for the full characterisation record (the
   opposite-prediction probe technique CLAUDE.md's "burned twice" note
   demands). Frozen deps forbid Str/regex; every match below is
   String.sub/index/split_on_char, the same discipline tools/
   bootstrap_sanctoral.ml's own hand-rolled INI reader already uses for
   someone else's format.

   THE KEY STRUCTURAL FACT this parser leans on, established during
   characterisation: every day's UNIVERSAL entry (the General Roman
   Calendar's own text) appears FIRST in reading order, before any
   diocesan variant block (which is introduced by a line ending in ':',
   e.g. "Westminster, Clifton, Plymouth:" or "In all Dioceses of ENGLAND
   and WALES ... follows:"). So the FIRST "Gl"/"Cr" token pair and the
   FIRST "Mass of ..."/roman-numeral-BVM line found within a day's block
   are ALWAYS the universal entry's own, even if the colon-boundary
   detection below is imperfect -- diocesan text can only ever appear
   AFTER, never before, so it cannot introduce a false FIRST match. This
   is why [scan_block] restricts its search to lines before the first
   colon-terminated line (belt), while the ordering argument above is the
   suspenders.

   Usage:
     pdftotext -layout docs/research/ordo/lms-ordo-2024-2025.pdf /tmp/lms.txt
     dune exec tools/extract_lms_ordo.exe -- /tmp/lms.txt \
       docs/research/ordo/lms-ordo-2024-2025.pdf \
       test/fixtures/lms-ordo-2024-2025.sexp *)

open Sexplib0.Sexp_conv
module Date = Colitur_kernel.Date

let die fmt = Printf.ksprintf (fun s -> prerr_endline ("extract_lms_ordo: " ^ s); exit 1) fmt

(* Mirrored, not shared, by test/test_lms_ordo.ml -- tools/ and test/ have
   no common .mli either could hang a shared type from, the same reasoning
   test_oracle.ml's own header gives for duplicating [sha256_of_file]. *)
type row = {
  date : string;  (** ISO-8601 *)
  weekday : string;
      (** As printed ("Sat", "Sun", ...) -- cross-checked below against
          [date]'s own computed weekday at extraction time (fatal on
          mismatch: the whole point of carrying both is to catch a date-
          resolution bug here, not paper over one). *)
  title : string;  (** the day's own title line: feast name, class, colour, votive codes *)
  formulary_override : string option;
      (** the literal "Mass of ..." text, when the universal block names
          one; [None] = the day says its own Mass. *)
  bvm_numeral : string option;
      (** "I".."V" when [formulary_override] is one of the five anchored
          "<N> Mass of BVM" lines (whole-line match, never a substring --
          see the module header on why "V Mass of BVM" must never be
          matched as a substring of "IV Mass of BVM"). *)
  gloria : bool option;  (** [None] only if genuinely not found -- reported, not silently dropped *)
  creed : bool option;
  has_diocesan_variant : bool;
      (** whether a diocese-specific block followed the universal one
          anywhere in this day's raw text (informational only -- see the
          module header on why correctness of the other fields does not
          depend on this being exact). *)
}
[@@deriving sexp]

(* --- tiny hand-rolled helpers, no Str/regex ------------------------------ *)

let split_ws s =
  String.split_on_char ' ' (String.map (fun c -> if c = '\t' then ' ' else c) s)
  |> List.filter (fun t -> t <> "")

let is_all_digits s = s <> "" && String.for_all (fun c -> c >= '0' && c <= '9') s

let has_prefix ~prefix s =
  String.length s >= String.length prefix && String.sub s 0 (String.length prefix) = prefix

let ends_with_colon s = s <> "" && s.[String.length s - 1] = ':'

let months =
  [| "January"; "February"; "March"; "April"; "May"; "June"; "July"; "August"; "September"; "October";
     "November"; "December" |]

let month_index name =
  let rec go i = if i >= Array.length months then None else if months.(i) = name then Some (i + 1) else go (i + 1) in
  go 0

let weekday_of_abbrev = function
  | "Sun" -> Some Date.Sun
  | "Mon" -> Some Date.Mon
  | "Tue" -> Some Date.Tue
  | "Wed" -> Some Date.Wed
  | "Thu" -> Some Date.Thu
  | "Fri" -> Some Date.Fri
  | "Sat" -> Some Date.Sat
  | _ -> None

(* Left-column codes (Abbreviations, "Left column": "+EW"/"+"/"Pl"/"Ind") --
   printed in a dedicated margin column that pdftotext -layout reproduces
   as literal leading tokens on an otherwise-ordinary content line. Strip
   ALL that appear (there can be two, "Pl Ind" together -- the 31 Dec/
   1 Jan examples in the source). *)
let strip_left_column tokens =
  let is_marker = function "Pl" | "Ind" | "+EW" | "+" -> true | _ -> false in
  let rec go = function t :: rest when is_marker t -> go rest | ts -> ts in
  go tokens

let bvm_numeral_strings = [ ("I", "I Mass of BVM"); ("II", "II Mass of BVM"); ("III", "III Mass of BVM");
                             ("IV", "IV Mass of BVM"); ("V", "V Mass of BVM") ]

(* Anchored WHOLE-LINE match against all five, never a substring test --
   this is the exact discipline the coordinator addendum records: "V Mass
   of BVM" is a substring of "IV Mass of BVM", so any check here MUST
   compare the full line, not search for the numeral's own string inside
   it. *)
let bvm_numeral_of_line line = List.assoc_opt line (List.map (fun (n, s) -> (s, n)) bvm_numeral_strings)

(* --- the day-block scanner ------------------------------------------------ *)

(* [lines]: this day's own raw continuation lines, marker-stripped and
   trimmed, title line NOT included (the title never carries Gl/Cr/"Mass
   of" itself in this source). Returns (formulary_override, bvm_numeral,
   gloria, creed, has_diocesan_variant), each derived from the portion
   BEFORE the first colon-terminated (diocesan) line -- see the module
   header for why this is belt-and-suspenders, not load-bearing on its
   own. *)
let scan_block lines =
  let rec universal_prefix = function
    | [] -> []
    | l :: _ when ends_with_colon l -> []
    | l :: rest -> l :: universal_prefix rest
  in
  let has_diocesan = List.exists ends_with_colon lines in
  let universal = universal_prefix lines in
  let formulary_override, bvm_numeral =
    let rec find = function
      | [] -> (None, None)
      | l :: rest -> (
          match bvm_numeral_of_line l with
          | Some n -> (Some l, Some n)
          | None -> if has_prefix ~prefix:"Mass of " l then (Some l, None) else find rest)
    in
    find universal
  in
  let all_tokens = List.concat_map split_ws universal in
  let rec find_flag word = function
    | prev :: (cur :: _ as rest) -> if cur = word then Some (prev <> "No") else find_flag word rest
    | [ cur ] -> if cur = word then Some true else None
    | [] -> None
  in
  (* [find_flag] needs a sentinel predecessor for a match at position 0
     (never observed in this source -- Gl/Cr always follow at least "No"
     or a preceding word on the same "Gl Cr Pr of ..." line -- but handled
     rather than assumed: a bare leading "Gl"/"Cr" with no "No" before it
     reads as [true], the same as any other non-"No" predecessor would). *)
  let gloria = find_flag "Gl" ("" :: all_tokens) in
  let creed = find_flag "Cr" ("" :: all_tokens) in
  (formulary_override, bvm_numeral, gloria, creed, has_diocesan)

(* --- the top-level line scan --------------------------------------------- *)

type block = { b_weekday : string; b_day : int; b_month : int; b_year : int; b_title : string; b_lines : string list }

let start_sentinel = [ "End"; "of"; "November"; "2024" ]

let is_stop_tail_line tokens =
  match tokens with tok :: _ -> String.length tok = 4 && is_all_digits tok | [] -> false

let is_month_header tokens =
  match tokens with
  | m :: rest when month_index m <> None -> List.for_all is_all_digits rest
  | _ -> false

let read_lines path =
  let ic = open_in path in
  let rec loop acc = match input_line ic with l -> loop (l :: acc) | exception End_of_file -> List.rev acc in
  let ls = loop [] in
  close_in ic;
  ls

let () =
  if Array.length Sys.argv <> 4 then
    die "usage: extract_lms_ordo <pdftotext-layout.txt> <source.pdf> <dest.sexp>";
  let txt_path = Sys.argv.(1) in
  let pdf_path = Sys.argv.(2) in
  let dest = Sys.argv.(3) in
  let all_lines = read_lines txt_path in
  let arr = Array.of_list all_lines in
  let n = Array.length arr in
  let trimmed i = String.trim arr.(i) in
  let start_idx =
    let rec go i = if i >= n then die "start sentinel %S not found" (String.concat " " start_sentinel)
      else if split_ws (trimmed i) = start_sentinel then i else go (i + 1)
    in
    go 0
  in
  let stop_idx =
    let rec go i =
      if i >= n then n else if is_stop_tail_line (split_ws (trimmed i)) then i else go (i + 1)
    in
    go (start_idx + 1)
  in
  Printf.printf "extract_lms_ordo: Ordo body lines %d..%d (of %d total)\n" start_idx stop_idx n;
  (* --- the scan: month/year tracker + block accumulator ------------------ *)
  let cur_month = ref 11 and cur_year = ref 2024 in
  let blocks = ref [] in
  let cur = ref None in
  let flush () = match !cur with Some b -> blocks := b :: !blocks; cur := None | None -> () in
  for i = start_idx + 1 to stop_idx - 1 do
    let raw = trimmed i in
    if raw = "" then ()
    else if String.length raw >= 1 && (let rec contains s sub =
              let ls = String.length s and lu = String.length sub in
              if lu = 0 then true else if ls < lu then false
              else if String.sub s 0 lu = sub then true
              else contains (String.sub s 1 (ls - 1)) sub
            in
            contains raw "Latin Mass Society Ordo")
    then () (* page footer *)
    else
      let toks = split_ws raw in
      if is_month_header toks then begin
        match toks with
        | m :: rest -> (
            match month_index m with
            | Some mi ->
                if mi <> !cur_month then begin
                  if mi < !cur_month then incr cur_year;
                  cur_month := mi
                end;
                (* an explicit 4-digit year token, when present, overrides
                   the transition inference outright -- belt and
                   suspenders, same reasoning as [scan_block] above *)
                List.iter (fun t -> if String.length t = 4 && is_all_digits t then cur_year := int_of_string t) rest
            | None -> ())
        | [] -> ()
      end
      else
        match toks with
        | wd :: dn :: _ when weekday_of_abbrev wd <> None && is_all_digits dn && int_of_string dn >= 1
                              && int_of_string dn <= 31 ->
            flush ();
            let title = String.concat " " (List.tl (List.tl toks)) in
            cur := Some { b_weekday = wd; b_day = int_of_string dn; b_month = !cur_month; b_year = !cur_year;
                          b_title = title; b_lines = [] }
        | _ -> (
            match !cur with
            | None -> ()
            | Some b ->
                let stripped = strip_left_column toks in
                if stripped = [] then ()
                else cur := Some { b with b_lines = b.b_lines @ [ String.concat " " stripped ] })
  done;
  flush ();
  let blocks = List.rev !blocks in
  Printf.printf "extract_lms_ordo: %d day-blocks parsed\n" (List.length blocks);
  let rows =
    List.map
      (fun b ->
        let date =
          match Date.make ~year:b.b_year ~month:b.b_month ~day:b.b_day with
          | Ok d -> d
          | Error e -> die "%s %d/%d/%d: %s" b.b_weekday b.b_year b.b_month b.b_day e
        in
        (match weekday_of_abbrev b.b_weekday with
        | Some w when w = Date.weekday date -> ()
        | Some _ ->
            die "%s: printed weekday %S does not match computed weekday %S -- date resolution bug"
              (Date.to_iso8601 date) b.b_weekday (Date.weekday_to_string (Date.weekday date))
        | None -> die "%s: unrecognised weekday abbreviation %S" (Date.to_iso8601 date) b.b_weekday);
        let formulary_override, bvm_numeral, gloria, creed, has_diocesan_variant = scan_block b.b_lines in
        { date = Date.to_iso8601 date; weekday = b.b_weekday; title = b.b_title; formulary_override; bvm_numeral;
          gloria; creed; has_diocesan_variant })
      blocks
  in
  let missing_gloria = List.filter (fun r -> r.gloria = None) rows in
  let missing_creed = List.filter (fun r -> r.creed = None) rows in
  if missing_gloria <> [] then
    Printf.printf "extract_lms_ordo: WARNING %d rows with no Gloria found: %s\n" (List.length missing_gloria)
      (String.concat ", " (List.map (fun r -> r.date) missing_gloria));
  if missing_creed <> [] then
    Printf.printf "extract_lms_ordo: WARNING %d rows with no Creed found: %s\n" (List.length missing_creed)
      (String.concat ", " (List.map (fun r -> r.date) missing_creed));
  let with_variant = List.length (List.filter (fun r -> r.has_diocesan_variant) rows) in
  let with_override = List.length (List.filter (fun r -> r.formulary_override <> None) rows) in
  let with_bvm = List.length (List.filter (fun r -> r.bvm_numeral <> None) rows) in
  Printf.printf "extract_lms_ordo: %d rows; %d with a diocesan variant present; %d with a formulary override; \
                  %d with a BVM roman numeral\n"
    (List.length rows) with_variant with_override with_bvm;
  (* --- provenance header + write ----------------------------------------- *)
  let sha256_of_file path =
    let cmd = Printf.sprintf "sha256sum %s" (Filename.quote path) in
    let ic = Unix.open_process_in cmd in
    let line = try input_line ic with End_of_file -> die "sha256sum produced no output for %s" path in
    (match Unix.close_process_in ic with Unix.WEXITED 0 -> () | _ -> die "sha256sum failed for %s" path);
    match String.index_opt line ' ' with Some i -> String.sub line 0 i | None -> die "unexpected sha256sum output: %S" line
  in
  let today () =
    let tm = Unix.gmtime (Unix.time ()) in
    Printf.sprintf "%04d-%02d-%02d" (tm.Unix.tm_year + 1900) (tm.Unix.tm_mon + 1) tm.Unix.tm_mday
  in
  let pdf_sha = sha256_of_file pdf_path in
  let header =
    Printf.sprintf
      {|; test/fixtures/lms-ordo-2024-2025.sexp -- Task 6 (2026-08-21-colitur-
; celebrant-rubrics-phase1)'s sixth validation layer: the Latin Mass
; Society's own printed Ordo, an England & Wales diocesan Ordo -- a
; lineage independent of Divinum Officium/missalemeum/lectio (layers 3-4)
; and of the electronic LT.txt transcription (layers 1-2/5): a physically
; printed, professionally-compiled liturgical calendar with its own ISBN.
;
; Generator: tools/extract_lms_ordo.ml -- do not hand-edit; re-run against
; a fresh pdftotext dump and commit the diff instead.
;
; Source: "The Ordo 2024-2025", compiled by Peter Day-Milne, The Latin
; Mass Society, 9 Mallow Street, London EC1Y 8RQ (title page and
; colophon, verified directly against the PDF's own extracted text --
; ISBN 9781739209636, Copyright (c) The Latin Mass Society, UK 2024).
; PDF metadata: Author "Peter Day-Milne", Producer "LibreOffice 7.4",
; CreationDate 2024-11-06, 140 pages.
; URL (identified 2026-08-22 via web search matching the PDF's own
; version number and filename to the publisher's own hosting path;
; NOT independently re-downloaded and byte-compared in this session --
; recorded honestly rather than presented as verified):
;   https://lms.org.uk/sites/default/files/u5374/ordo_2.21_2024-2025.pdf
;   (product page: https://lms.org.uk/product/latin-mass-society-ordo-2024-25)
; The local PDF (docs/research/ordo/lms-ordo-2024-2025.pdf) is gitignored
; (CLAUDE.md: "docs/ is gitignored"), so this header, not git, is this
; fixture's only record of where it came from.
; SHA-256 of docs/research/ordo/lms-ordo-2024-2025.pdf: %s
; Extracted (UTC): %s
; Exact commands:
;   pdftotext -layout docs/research/ordo/lms-ordo-2024-2025.pdf /tmp/lms.txt
;   dune exec tools/extract_lms_ordo.exe -- /tmp/lms.txt \
;     docs/research/ordo/lms-ordo-2024-2025.pdf test/fixtures/lms-ordo-2024-2025.sexp
;
; COVERAGE: %d day-rows, %s through %s (2024-11-27, "End of November 2024",
; through the day before a malformed trailing entry the extractor
; deliberately stops before -- see CHARACTERISATION below).
;
; CHARACTERISATION FINDINGS (Step 1, non-negotiable per the task brief --
; the extraordinaryform.org Ordo silently omitted St Lawrence's vigil on
; EVERY date it covered, which nearly produced a false corroboration
; during the RG 33 work; this Ordo was probed with the same discipline
; before a single divergence was adjudicated):
;
; 1. Gl/Cr are printed PER MASS-OPTION, not per day (confirmed: this PDF
;    alone -- not the multi-year corpus the task brief's own grep count
;    was measured against -- carries many more Gl/Cr pairs than day-rows,
;    because every diocesan variant repeats its own "Gl ... Cr ... Pr of
;    ..." line). This extractor resolves the day's OWN office by taking
;    the FIRST Gl/Cr pair in reading order, which the source's own layout
;    guarantees is the universal entry's (diocesan variants are always
;    introduced by a colon-terminated diocese-list line that comes AFTER
;    the universal block, never before -- checked structurally, not
;    assumed, in every sampled block during development).
;
; 2. OPPOSITE-PREDICTION PROBES against Rite_ef.Rubrics_ef.creed (RG
;    475-476), checked BEFORE trusting a single row of this fixture --
;    the technique CLAUDE.md records as the one that catches a source
;    silently omitting the very thing it is meant to witness:
;      2024-12-01 (Advent Sunday, RG 475(a)) -- Ordo "No Gl Cr" -> TRUE
;      2024-12-02 (ordinary Advent feria)    -- Ordo "Gl No Cr" -> FALSE
;      2024-12-26 (St Stephen, II class, but inside the Nativity octave,
;                  RG 475(d))                -- Ordo "Gl Cr"    -> TRUE
;      2025-08-15 (the Assumption, I class, RG 475(b))
;                                             -- Ordo "Gl Cr"    -> TRUE
;      2025-08-16 (St Joachim, II class, no Lord/BVM/apostle clause
;                  applies, RG 476(b))        -- Ordo "Gl No Cr" -> FALSE
;    All five predictions confirmed, both directions (TRUE and FALSE each
;    independently witnessed, including the Stephen/Joachim pair, which
;    are BOTH II-class non-Sunday saints and differ ONLY on the octave
;    question) -- this source is discriminating, not a constant, on the
;    Creed. See task-6-report.md for the full record.
;
; 3. The BVM-Saturday roman numeral (I-V, "Missae de sancta Maria in
;    sabbato", RG 309(a)) is anchored by WHOLE-LINE match against the five
;    literal strings below, NEVER by substring search: "V Mass of BVM" is
;    a substring of "IV Mass of BVM", so a naive `contains` check
;    misreads every fourth-Mass day as the fifth (the coordinator's own
;    misreading, recorded and retracted in commit 27b07b4 before this
;    task existed).
;
; 4. SCOPE EXCLUDED, quantified, not silently dropped:
;      - Diocesan variants: present on %d of %d days (%s%%) -- their own
;        text is read only far enough to set [has_diocesan_variant],
;        never compared, because colitur computes the UNIVERSAL General
;        Roman Calendar only, with no diocesan overlay loaded.
;      - The single malformed trailing entry ("2025 1   The OCTAVE DAY of
;        the NATIVITY..." printed with "Thu" wrapped onto the following
;        line and the year token "2025" where "2026" belongs -- a literal
;        duplicate, word for word, of the fixture's own already-extracted
;        2025-01-01 row) is excluded outright: the extractor's own stop
;        marker (a line whose first token is a bare 4-digit year) halts
;        the scan before it, so this fixture's last row is 2025-12-31.
;      - Front matter, the Abbreviations/Rubrical-Primer/Breviary sections,
;        and the "When may I say...?"/Appendix tail are never scanned at
;        all (the extractor's own start/stop sentinels bound it to the
;        Ordo proper, "End of November 2024" through the stop marker
;        above).
|}
      pdf_sha (today ()) (List.length rows)
      (match rows with r :: _ -> r.date | [] -> "?")
      (match List.rev rows with r :: _ -> r.date | [] -> "?")
      with_variant (List.length rows)
      (Printf.sprintf "%.1f" (100.0 *. float_of_int with_variant /. float_of_int (List.length rows)))
  in
  let body = Sexplib.Sexp.to_string_hum ~indent:2 (sexp_of_list sexp_of_row rows) in
  let oc = open_out dest in
  Fun.protect
    ~finally:(fun () -> close_out_noerr oc)
    (fun () ->
      output_string oc header;
      output_string oc body;
      output_string oc "\n");
  Printf.printf "extract_lms_ordo: wrote %d rows to %s\n" (List.length rows) dest