cubical-transport-hott-lean4/CubicalTransport/PropertyTest.lean

/-
  CubicalTransport.PropertyTest
  ============================
  Phase D.1 — property-based tests on the Rust-backed cubical evaluator.
  Each check exercises a specific axiom from `FFI_COMPLETENESS.md`'s
  table, across a handful of shapes chosen to cover the interesting
  structural cases.

  Tests are organized by axiom family:
    · eval β-rules (app / papp / fst / snd)
    · normalize idempotence (DimExpr, FaceFormula)
    · determinism (same input → same output on repeated calls)
    · readback roundtrip for canonical λ-forms

  Output: pass/fail per property + final tally.  Invoked via the
  `cubical-test` exe; see `CubicalTest.lean` for wiring.
-/

import CubicalTransport.Readback
import CubicalTransport.FFI

namespace CubicalTransportPropertyTest

-- ── Summarisers (reuse from FFITest but private to this module) ────────────

def cvalSummary : CVal → String
  | .vneu (.nvar s) => s!"nvar({s})"
  | .vneu (.napp _ _) => "napp(...)"
  | .vneu (.nfst _)   => "nfst(...)"
  | .vneu (.nsnd _)   => "nsnd(...)"
  | .vneu _           => "vneu(<other>)"
  | .vlam _ x _       => s!"vlam({x})"
  | .vplam _ i _      => s!"vplam({i.name})"
  | .vpair _ _        => "vpair"
  | _                 => "<other>"

/-- A single property result — description + pass/fail + optional note. -/
structure PropResult where
  name : String
  passed : Bool
  note : String := ""

def check (name : String) (cond : Bool) (note : String := "") : PropResult :=
  { name, passed := cond, note }

-- ── Property: eval β on λ is correct for a family of inputs ────────────────

def prop_lambda_beta : List PropResult := Id.run do
  -- `(λx. x) a` should reduce to whatever `a` evaluates to.
  -- We test with `a` being a free variable (a neutral).
  let mut results := []
  let args := ["a", "b", "hello", "longname", "a_b_c"]
  for arg in args do
    let term := CTerm.app (.lam "x" (.var "x")) (.var arg)
    let v := eval .nil term
    let expected := s!"nvar({arg})"
    let actual := cvalSummary v
    results := check s!"(λx. x) {arg} ⇓ {arg}" (actual == expected) "" :: results
  return results.reverse

-- ── Property: nested λ applies correctly ───────────────────────────────────

def prop_nested_lambda : List PropResult := Id.run do
  -- `(λx. λy. x) a b` ⇓ a
  let term := CTerm.app
    (.app (.lam "x" (.lam "y" (.var "x"))) (.var "a")) (.var "b")
  let v := eval .nil term
  let r := check "(λx. λy. x) a b ⇓ a" (cvalSummary v == "nvar(a)")
  -- `(λx. λy. y) a b` ⇓ b
  let term2 := CTerm.app
    (.app (.lam "x" (.lam "y" (.var "y"))) (.var "a")) (.var "b")
  let v2 := eval .nil term2
  let r2 := check "(λx. λy. y) a b ⇓ b" (cvalSummary v2 == "nvar(b)")
  return [r, r2]

-- ── Property: Σ β-rules ────────────────────────────────────────────────────

def prop_sigma_beta : List PropResult := Id.run do
  let mut results := []
  -- (a, b).fst ⇓ a for various a, b.
  let pairs := [("a", "b"), ("x", "y"), ("one", "two")]
  for (a, b) in pairs do
    let fst_v := eval .nil (.fst (.pair (.var a) (.var b)))
    let snd_v := eval .nil (.snd (.pair (.var a) (.var b)))
    results := check s!"({a}, {b}).fst ⇓ {a}"
      (cvalSummary fst_v == s!"nvar({a})") :: results
    results := check s!"({a}, {b}).snd ⇓ {b}"
      (cvalSummary snd_v == s!"nvar({b})") :: results
  return results.reverse

-- ── Property: eval is deterministic ────────────────────────────────────────

def prop_eval_deterministic : List PropResult := Id.run do
  let terms : List CTerm := [
    .var "x",
    .lam "x" (.var "x"),
    .app (.lam "x" (.var "x")) (.var "y"),
    .pair (.var "a") (.var "b"),
    .fst (.pair (.var "a") (.var "b")),
  ]
  let mut results := []
  for t in terms do
    let v1 := cvalSummary (eval .nil t)
    let v2 := cvalSummary (eval .nil t)
    let v3 := cvalSummary (eval .nil t)
    results := check s!"eval deterministic: {v1}" (v1 == v2 && v2 == v3) :: results
  return results.reverse

-- ── Property: DimExpr.normalize idempotence ────────────────────────────────

def dimExprToStr : DimExpr → String
  | .zero      => "zero"
  | .one       => "one"
  | .var i     => s!"var({i.name})"
  | .inv r     => s!"inv({dimExprToStr r})"
  | .meet a b  => s!"meet({dimExprToStr a},{dimExprToStr b})"
  | .join a b  => s!"join({dimExprToStr a},{dimExprToStr b})"

def prop_dimexpr_normalize_idempotent : List PropResult := Id.run do
  let exprs : List DimExpr := [
    .zero, .one,
    .var ⟨"i"⟩,
    .inv .zero, .inv .one,
    .inv (.var ⟨"i"⟩),
    .inv (.inv (.var ⟨"i"⟩)),
    .meet (.var ⟨"i"⟩) .one,
    .join .zero (.var ⟨"j"⟩),
    .inv (.meet (.var ⟨"i"⟩) (.inv .zero)),
  ]
  let mut results := []
  for e in exprs do
    let n1 := DimExpr.normalize e
    let n2 := DimExpr.normalize n1
    let s1 := dimExprToStr n1
    let s2 := dimExprToStr n2
    results := check s!"normalize idempotent: {dimExprToStr e} → {s1}"
      (s1 == s2) :: results
  return results.reverse

-- ── Property: DimExpr.normalize literal reductions ─────────────────────────

def prop_dimexpr_literals : List PropResult := Id.run do
  [ check "normalize(.inv .zero) = .one"
      (dimExprToStr (DimExpr.normalize (.inv .zero)) == "one"),
    check "normalize(.inv .one) = .zero"
      (dimExprToStr (DimExpr.normalize (.inv .one)) == "zero"),
    check "normalize(.inv (.inv .zero)) = .zero"
      (dimExprToStr (DimExpr.normalize (.inv (.inv .zero))) == "zero"),
    check "normalize(.inv (.inv (.inv .zero))) = .one"
      (dimExprToStr (DimExpr.normalize (.inv (.inv (.inv .zero)))) == "one"),
    check "normalize(.inv (.var i)) = .inv (.var i)  [no reduction]"
      (dimExprToStr (DimExpr.normalize (.inv (.var ⟨"i"⟩))) == "inv(var(i))"),
    check "normalize(.inv (.inv (.var i))) = .var i  [double-neg cancel]"
      (dimExprToStr (DimExpr.normalize (.inv (.inv (.var ⟨"i"⟩)))) == "var(i)") ]

-- ── Property: FaceFormula.normalize absorption laws ────────────────────────

def faceToStr : FaceFormula → String
  | .bot       => "bot"
  | .top       => "top"
  | .eq0 i     => s!"eq0({i.name})"
  | .eq1 i     => s!"eq1({i.name})"
  | .meet a b  => s!"meet({faceToStr a},{faceToStr b})"
  | .join a b  => s!"join({faceToStr a},{faceToStr b})"

def prop_face_absorption : List PropResult := Id.run do
  let eq0i : FaceFormula := .eq0 ⟨"i"⟩
  let eq1i : FaceFormula := .eq1 ⟨"i"⟩
  [ check "meet .top φ = φ"
      (faceToStr (FaceFormula.normalize (.meet .top eq0i)) == "eq0(i)"),
    check "meet φ .top = φ"
      (faceToStr (FaceFormula.normalize (.meet eq0i .top)) == "eq0(i)"),
    check "meet .bot _ = .bot"
      (faceToStr (FaceFormula.normalize (.meet .bot eq0i)) == "bot"),
    check "meet _ .bot = .bot"
      (faceToStr (FaceFormula.normalize (.meet eq0i .bot)) == "bot"),
    check "join .bot φ = φ"
      (faceToStr (FaceFormula.normalize (.join .bot eq1i)) == "eq1(i)"),
    check "join φ .bot = φ"
      (faceToStr (FaceFormula.normalize (.join eq1i .bot)) == "eq1(i)"),
    check "join .top _ = .top"
      (faceToStr (FaceFormula.normalize (.join .top eq0i)) == "top"),
    check "join _ .top = .top"
      (faceToStr (FaceFormula.normalize (.join eq0i .top)) == "top"),
    check "meet nested absorption"
      (faceToStr (FaceFormula.normalize
         (.meet (.meet .top eq0i) (.meet .top eq1i))) == "meet(eq0(i),eq1(i))") ]

-- ── Property: readback roundtrip for closed λ-forms ────────────────────────

def ctermShape : CTerm → String
  | .var x        => s!"var({x})"
  | .lam x _      => s!"lam({x},...)"
  | .app _ _      => "app(...)"
  | .plam i _     => s!"plam({i.name},...)"
  | .pair _ _     => "pair(...)"
  | .fst _        => "fst(...)"
  | .snd _        => "snd(...)"
  | _             => "<other>"

def prop_readback_lambda_roundtrip : List PropResult := Id.run do
  -- Closed λ-forms — readback of evaluation should preserve outer shape.
  let terms : List CTerm := [
    .lam "x" (.var "x"),
    .lam "f" (.lam "x" (.app (.var "f") (.var "x"))),
    .pair (.var "a") (.var "b"),
  ]
  let mut results := []
  for t in terms do
    let v := eval .nil t
    let back := readback v
    let original := ctermShape t
    let recovered := ctermShape back
    results := check s!"readback preserves shape: {original}"
      (original == recovered) :: results
  return results.reverse

-- ── Orchestration ──────────────────────────────────────────────────────────

def allProperties : List (String × List PropResult) :=
  [ ("λ β-rule",              prop_lambda_beta),
    ("nested λ",              prop_nested_lambda),
    ("Σ β-rules",             prop_sigma_beta),
    ("eval determinism",      prop_eval_deterministic),
    ("DimExpr idempotence",   prop_dimexpr_normalize_idempotent),
    ("DimExpr literals",      prop_dimexpr_literals),
    ("Face absorption",       prop_face_absorption),
    ("readback roundtrip",    prop_readback_lambda_roundtrip) ]

def runProperties : IO UInt32 := do
  IO.println "── Cubical-transport property-based tests ──"
  let mut totalFails : UInt32 := 0
  let mut totalRun : Nat := 0
  for (family, results) in allProperties do
    let fails := results.filter (fun r => !r.passed)
    let n := results.length
    let k := fails.length
    totalRun := totalRun + n
    totalFails := totalFails + k.toUInt32
    if k == 0 then
      IO.println s!"  ✅ {family}: {n}/{n}"
    else
      IO.println s!"  ❌ {family}: {n - k}/{n}"
      for r in fails do
        IO.println s!"       — {r.name}"
  IO.println s!"── {totalRun - totalFails.toNat} / {totalRun} properties passed ──"
  return totalFails

end CubicalTransportPropertyTest