From 48ea9d5368ed2a8530430aa4d67f53ad35a09a40 Mon Sep 17 00:00:00 2001 From: Jonathan Cubides Date: Fri, 14 Aug 2026 11:42:35 -0500 Subject: [PATCH 1/8] fix(typing): close refinement scope gaps Reject unsupported becomes-such-that typing instead of accepting only its LHS. Preserve transitive abstract event scopes and make the P2 gate surface typing errors. --- EventB/Typing/Check.lean | 51 +++++++++++++++++++++++++++++++++++--- EventB/Typing/Infer.lean | 39 +++++++++++++++++++++-------- TODO.md | 53 ++++++++++++++++++++++++++++++++++++++++ test/Gates.lean | 11 ++++++--- 4 files changed, 137 insertions(+), 17 deletions(-) diff --git a/EventB/Typing/Check.lean b/EventB/Typing/Check.lean index 3da6106..2aab844 100644 --- a/EventB/Typing/Check.lean +++ b/EventB/Typing/Check.lean @@ -38,11 +38,45 @@ private def childrenOf (e : Elem) (tag : String) : List Elem := private def attrOf (e : Elem) (key : String) : Option String := e.attr? ("org.eventb.core." ++ key) +private def labelOf (e : Elem) : String := (attrOf e "label").getD "" + /-- `target` is a workspace path such as `/Abstraction/M1_Landing_Sequence_Ctx`; only the last segment names the component. -/ private def targetName (e : Elem) : Option String := (attrOf e "target").map (fun t => (t.splitOn "/").getLast!) +private def eventParentName (ev : Elem) : Option String := + match (childrenOf ev "refinesEvent").filterMap targetName |>.head? with + | some target => some target + | none => if (attrOf ev "extended").getD "false" == "true" then some (labelOf ev) else none + +private def inheritedEventParams (p : Project) : Nat → String → String → List String + | 0, _, _ => [] + | depth + 1, machine, event => + match lookupComponent p machine with + | none => [] + | some current => + match (childrenOf current.elem "event").find? (fun candidate => + labelOf candidate == event) with + | none => [] + | some currentEvent => + match eventParentName currentEvent with + | none => [] + | some parentEventName => + match (childrenOf current.elem "refinesMachine").filterMap targetName |>.head? with + | none => [] + | some parentName => + match lookupComponent p parentName with + | none => [] + | some parent => + match (childrenOf parent.elem "event").find? (fun candidate => + labelOf candidate == parentEventName) with + | none => [] + | some parentEvent => + let own := (childrenOf parentEvent "parameter").filterMap + (attrOf · "identifier") + own ++ inheritedEventParams p depth parentName parentEventName + /-- Contexts and machines a component depends on, deepest first, without repeats. `visited` already stops repeats, so the recursion terminates on any well-formed project; @@ -78,7 +112,7 @@ def componentTheoryRoots (p : Project) (name : String) : List String := /-- Declare the identifiers a component introduces, then feed every predicate it states to the checker. Errors are collected rather than thrown: one unsupported guard should cost that guard's constraints, not the whole file's types. -/ -private def addComponent (c : Component) : M (List String) := do +private def addComponent (p : Project) (c : Component) : M (List String) := do let mut errs : List String := [] -- Carrier sets and constants first, so axioms can refer to them in any order. for s in childrenOf c.elem "carrierSet" do @@ -100,8 +134,18 @@ private def addComponent (c : Component) : M (List String) := do errs := errs ++ (← runPredicate f) -- Each event's parameters are scoped to that event. for ev in childrenOf c.elem "event" do + let ownParams := (childrenOf ev "parameter").filterMap (attrOf · "identifier") + let inheritedParams := inheritedEventParams p p.length c.name (labelOf ev) let (eventErrors, bound) ← withEnvBindings do let mut eventErrors : List String := [] + -- A refining event's witnesses and predicates can mention the parameters of the + -- abstract event. They are lexical inputs to this check, not project-global names. + for name in inheritedParams do + let st ← get + match st.params.find? (fun pair => pair.1 == name) with + | some (_, ty) => bind name ty + | none => eventErrors := eventErrors ++ + [s!"unresolved abstract event parameter {name}"] for prm in childrenOf ev "parameter" do if let some n := attrOf prm "identifier" then bind n (← fresh) for g in childrenOf ev "guard" do @@ -117,7 +161,8 @@ private def addComponent (c : Component) : M (List String) := do errs := errs ++ eventErrors -- Parameters leave the environment so a later event cannot see them, but they are -- kept in `params` because the `.bpo` records their types alongside the variables. - modify fun s => { s with params := s.params ++ bound } + modify fun s => + { s with params := s.params ++ bound.filter (fun pair => ownParams.contains pair.1) } return errs where /-- Reuse the existing type if the name is already declared, so a refinement does not @@ -149,7 +194,7 @@ def inferComponentIn (theory : Theory.Env) (p : Project) (name : String) : let mut errs : List String := [] for dep in order do if let some c := lookupComponent p dep then - errs := errs ++ (← addComponent c) + errs := errs ++ (← addComponent p c) let st ← get let env := st.env ++ st.params let mut out : List (String × Ty) := [] diff --git a/EventB/Typing/Infer.lean b/EventB/Typing/Infer.lean index af64e12..361f936 100644 --- a/EventB/Typing/Infer.lean +++ b/EventB/Typing/Infer.lean @@ -207,10 +207,9 @@ def checkPred (t : Term) : M Unit := do else if o == ":∈" then do unify (.pow (← inferExpr a)) (← inferExpr b) else if o == ":∣" then do - -- Becomes-such-that: the right side is a predicate over primed variables, which - -- P2 does not model yet. The left side still has to typecheck. - let _ ← inferExpr a - return () + -- Do not accept this action until its before/after predicate has a complete + -- relational typing rule. Treating only the LHS as typed is unsound. + throw "becomes-such-that assignments require relational typing" else throw s!"not a predicate operator: {o}" | .app (.id "finite") s => do let _ ← asSet (← inferExpr s) | .app (.id "partition") args => do @@ -231,8 +230,9 @@ def checkPred (t : Term) : M Unit := do termination_by sizeOf t decreasing_by - all_goals simp +arith [Term.id.sizeOf_spec, Term.bin.sizeOf_spec, Term.pre.sizeOf_spec, + all_goals simp_all +arith [Term.id.sizeOf_spec, Term.bin.sizeOf_spec, Term.pre.sizeOf_spec, Term.app.sizeOf_spec, Term.bind.sizeOf_spec] + all_goals omega /-- The arguments of a comma-separated application, typed left to right. Walking the comma spine here rather than calling `flattenCommas` keeps the recursion structural: @@ -245,11 +245,29 @@ termination_by t => sizeOf t + 1 decreasing_by all_goals simp +arith [Term.bin.sizeOf_spec] -/-- Bind every identifier in a binder pattern to a fresh type. -/ -def bindPattern (t : Term) : M Unit := do +/-- Resolve a type-set ascription without re-entering expression inference. -/ +private def ascriptionType (t : Term) : M Ty := do + let s ← get + let typeOfName (name : String) : M Ty := + match Theory.typeIn? s.theory s.theoryRoots name with + | some (.pow element) => pure element + | some ty => pure ty + | none => throw s!"unknown binder type {name}" + match t with + | .id name => typeOfName name + | .pre "ℙ" (.id name) => return .pow (← typeOfName name) + | .pre "ℙ1" (.id name) => return .pow (← typeOfName name) + | _ => throw s!"unsupported binder type: {Formula.print t}" + +/-- Bind every identifier in a binder pattern to a fresh or ascribed type. -/ +def bindPattern (t : Term) (expected : Option Ty := none) : M Unit := do match t with - | .id n => do bind n (← fresh) - | .bin "," a b | .bin "↦" a b => do bindPattern a; bindPattern b + | .id n => bind n (expected.getD (← fresh)) + | .bin "⦂" pattern type => bindPattern pattern (some (← ascriptionType type)) + | .bin "," a b | .bin "↦" a b => + match expected with + | some (.prod left right) => bindPattern a (some left); bindPattern b (some right) + | _ => bindPattern a; bindPattern b | t => throw s!"not a binder pattern: {Formula.print t}" termination_by sizeOf t @@ -263,7 +281,8 @@ def patternType (t : Term) : M Ty := do match ← lookup? n with | some ty => return ty | none => throw s!"unbound {n}" - | .bin "↦" a b => return .prod (← patternType a) (← patternType b) + | .bin "⦂" _ type => ascriptionType type + | .bin "," a b | .bin "↦" a b => return .prod (← patternType a) (← patternType b) | t => throw s!"not a binder pattern: {Formula.print t}" termination_by sizeOf t diff --git a/TODO.md b/TODO.md index d67adbc..6f06e81 100644 --- a/TODO.md +++ b/TODO.md @@ -29,6 +29,59 @@ additional WFIS names are absent from the pinned `.bpo` files and remain explici coverage data rather than being forced into the P3b denominator. P4 has no corpus kernel, SMT, or imported-Rodin entries yet; the other 1060 obligations remain unproved. +## Accuracy campaign: general refinement-heavy Event-B + +Status: active. This campaign supersedes the older prototype-completion checkboxes +where adversarial review found that an internally consistent gate was weaker than the +documented semantic or trust contract. The target is fail-closed, structurally faithful +support for a defined refinement-heavy Event-B subset; passing the pinned corpus alone is +not completion evidence. + +### Current blockers + +- [ ] Fail on missing component/event/theory references instead of treating them as empty + closures. +- [ ] Keep typing and parse diagnostics attached to POG generation; never discard errors + through `toOption` or ignored error lists. +- [ ] Scope refining-event abstract parameters and keep event parameter types local. +- [ ] Type the RHS of `:∣` actions and include `:∈`/`:∣` actions in invariant semantics. +- [ ] Generate general SIM obligations, including gluing, new events, and stuttering. +- [ ] Make witness WFIS/WWD structurally match Rodin, including witness WD predicates. +- [ ] Add variant, naturalness, decrease, anticipated, and convergent-event obligations. +- [ ] Correct Event-B operator translation and WD rules, especially relation subtraction and + exponentiation. +- [ ] Reject open metavariable kernel proofs and bind all external/Rodin evidence to the + exact obligation and verified artifact digest. + +### Vertical-slice order + +1. Resolution, scopes, and fail-closed diagnostics. +2. Typed assignments and refinement event relations. +3. Formula translation and definedness. +4. Witnesses and complete POG classes. +5. Semantic soundness theorems for each POG class. +6. Trust/provenance hardening. +7. Independent differential tests, release evidence, and adversarial review. + +Each slice requires a minimal positive model, a negative model, a Rodin-shaped +comparison, a full build, and a fresh adversarial review before its checkbox is marked. + +### Evidence ledger + +| Area | Current evidence | Status | +| --- | --- | --- | +| Build and existing gates | 178-job build; P0/P1/P2/P3 pass | baseline only | +| General refinement typing | AMAN CLI fails on abstract event parameters | blocker | +| POG semantic coverage | nondeterministic actions, SIM, WWD, variants require work | blocker | +| Kernel trust | replay negative tests pass; open-mvar path requires hardening | blocker | +| External/Rodin provenance | metadata checks are not artifact verification | blocker | +| Release reproducibility | acceptance note and benchmark metadata are stale | blocker | +| Official Rossi differential | executable unavailable locally | unverified | + +The ledger is updated after every implementation commit. A phase is not complete when +the build is green if a counterexample, oracle comparison, or adversarial review remains +unresolved. + ## Completed foundation - [x] Read Rodin `.bum`/`.buc` files losslessly and pin the corpus manifest. diff --git a/test/Gates.lean b/test/Gates.lean index 5e4e338..fa41ab6 100644 --- a/test/Gates.lean +++ b/test/Gates.lean @@ -188,12 +188,15 @@ private def checkTypes (project : Project) (file : String) | .error e => gold.map (fun (n, _) => { key := file ++ "\t" ++ n, status := "FAIL:" ++ EventB.Error.render e }) - | .ok (env, _) => + | .ok (env, errors) => gold.map fun (n, g) => let key := file ++ "\t" ++ n - match env.find? (fun p => p.1 == n) with - | none => { key := key, status := "FAIL:not inferred" } - | some (_, t) => compareType key t.print g + match errors.head? with + | some error => { key := key, status := "FAIL:typing " ++ error } + | none => + match env.find? (fun p => p.1 == n) with + | none => { key := key, status := "FAIL:not inferred" } + | some (_, t) => compareType key t.print g private def typeHistogram (results : List TypeResult) : List (String × Nat) := (results.foldl From 7363549103f4da5da05fa48827113667e97a13dd Mon Sep 17 00:00:00 2001 From: Jonathan Cubides Date: Fri, 14 Aug 2026 11:49:56 -0500 Subject: [PATCH 2/8] fix(trust): harden evidence validation Reject unresolved kernel metadata and malformed Rodin status records. --- EventB/Trust.lean | 13 ++++++-- EventB/Trust/Replay.lean | 6 ++++ EventB/Trust/Rodin.lean | 67 +++++++++++++++++++++++++++++++++++++--- 3 files changed, 79 insertions(+), 7 deletions(-) diff --git a/EventB/Trust.lean b/EventB/Trust.lean index 9ea2633..f43adb9 100644 --- a/EventB/Trust.lean +++ b/EventB/Trust.lean @@ -76,7 +76,10 @@ def Ledger.entry? (ledger : Ledger) (component name : String) : Option Entry := def Ledger.attach (ledger : Ledger) (obligation : POG.Obligation) (evidence : Evidence) : Except EventB.Error Ledger := let expected := fingerprint obligation.canonical - if !evidence.isWellFormed then + if evidence matches .kernel .. then + .error (EventB.Error.trust + "kernel evidence must be validated by Trust.Replay before ledger attachment") + else if !evidence.isWellFormed then .error (EventB.Error.trust "evidence metadata is incomplete") else if ledger.entry? obligation.component obligation.name |>.isNone then .error (EventB.Error.trust @@ -122,9 +125,13 @@ private def renamedSample : POG.Obligation := #guard sampleObligation.canonical != { sampleObligation with goal := some (.id "⊥") }.canonical -#guard match sampleLedger.attach sampleObligation (.kernel "Sample.inv1") with - | .ok ledger => ledger.count .kernel == 1 +#guard match sampleLedger.attach sampleObligation + (.external "sample" "1" "digest" "checker") with + | .ok ledger => ledger.count .external == 1 | .error _ => false +#guard match sampleLedger.attach sampleObligation (.kernel "No.Such.Declaration") with + | .error _ => true + | .ok _ => false #guard match sampleLedger.attach { sampleObligation with goal := some (.id "⊥") } (.kernel "Sample.inv1") with | .error _ => true diff --git a/EventB/Trust/Replay.lean b/EventB/Trust/Replay.lean index fb4a185..71426b4 100644 --- a/EventB/Trust/Replay.lean +++ b/EventB/Trust/Replay.lean @@ -110,6 +110,8 @@ def validateTerm (context : Embedding.KernelContext) (obligation : POG.Obligation) (proof : Expr) (declaration : String := "") (declaredAxioms : List String := []) : MetaM Report := do + if proof.hasMVar then + throwError s!"kernel proof `{declaration}` contains unresolved metavariables" let expected ← translateStatement context obligation let proofType ← inferType proof unless ← isDefEq proofType expected do @@ -201,6 +203,10 @@ private meta def checkReplay : TermElabM Unit := do unless !(← succeeds (validate context replayObligation (.kernel "EventB.Trust.Replay.missing" []))) do throwError "unresolved proof declaration was accepted" + let target ← translateStatement context replayObligation + let openProof ← mkFreshExprMVar target + unless !(← succeeds (validateTerm context replayObligation openProof)) do + throwError "open metavariable proof was accepted" unless ← succeeds (validate context replayObligation (.kernel "EventB.Trust.Replay.TestFixtures.propextTrue" ["propext"])) do throwError "actual axiom metadata did not replay" diff --git a/EventB/Trust/Rodin.lean b/EventB/Trust/Rodin.lean index 5eb810a..432b3fe 100644 --- a/EventB/Trust/Rodin.lean +++ b/EventB/Trust/Rodin.lean @@ -43,17 +43,37 @@ private def parseStatus (elem : XmlElem) : Except String Status := do unless elem.children.isEmpty do throw s!"proof-status `{elem.tag}` must not have children" let name ← attr elem "name" + unless !name.isEmpty do + throw "proof-status name must not be empty" let confidenceSource ← attr elem "org.eventb.core.confidence" let confidence ← match natValue confidenceSource with | some value => pure value | none => .error s!"invalid confidence `{confidenceSource}`" + unless confidence > 0 do + throw "proof-status confidence must be positive" let manual ← match elem.attr? "org.eventb.core.psManual" with | some "true" => pure true | some "false" => pure false | some value => .error s!"invalid psManual `{value}`" - | none => pure false + | none => .error "missing `org.eventb.core.psManual` on proof-status" pure { name, confidence, manual } +def validateStatuses (statuses : List Status) : Except EventB.Error Unit := + let rec go : List Status → Except EventB.Error Unit + | [] => pure () + | status :: rest => + if status.name.isEmpty then + .error (EventB.Error.trust "proof-status name must not be empty") + else if status.confidence == 0 then + .error (EventB.Error.trust + s!"proof-status `{status.name}` has zero confidence") + else if rest.any (·.name == status.name) then + .error (EventB.Error.trust + s!"duplicate proof-status `{status.name}`") + else + go rest + go statuses + def importStatuses (source : String) : Except EventB.Error (List Status) := do let root ← match parseXmlString source with | .ok root => pure root @@ -61,7 +81,9 @@ def importStatuses (source : String) : Except EventB.Error (List Status) := do s!"invalid Rodin proof-status XML: {error.pretty source.toUTF8}") unless root.tag == "org.eventb.core.psFile" do throw (EventB.Error.trust s!"root is not a proof-status file: `{root.tag}`") - (root.children.mapM parseStatus).mapError EventB.Error.trust + let statuses ← (root.children.mapM parseStatus).mapError EventB.Error.trust + validateStatuses statuses + pure statuses private def status? (statuses : List Status) (name : String) : Option Status := statuses.find? (·.name == name) @@ -81,11 +103,16 @@ def compare (obligations : List POG.Obligation) (statuses : List Status) : Compa def attach (ledger : Ledger) (obligation : POG.Obligation) (source : String) (status : Status) : Except EventB.Error Ledger := - if status.discharged then + if status.name != obligation.name then + .error (EventB.Error.trust s! + "proof-status `{status.name}` does not identify obligation `{obligation.name}`") + else if status.confidence == 0 then + .error (EventB.Error.trust s!"proof-status `{status.name}` has zero confidence") + else if status.discharged then let evidence := .rodinImported source (s!"eventb-v1-{String.hash source}") status.manual ledger.attach obligation evidence else - pure ledger + .error (EventB.Error.trust s!"proof-status `{status.name}` is not discharged") private def sampleObligation : POG.Obligation := { component := "Sample", name := "evt/inv/INV", kind := "INV", goal := some (.id "⊤") } @@ -100,6 +127,38 @@ private def sampleSource := | .ok [status] => status.name == sampleObligation.name && status.discharged && status.manual | _ => false +#guard match importStatuses (sampleSource.replace "name=\"evt/inv/INV\"" "name=\"\"" ) with + | .error _ => true + | .ok _ => false + +#guard match importStatuses (sampleSource.replace + "org.eventb.core.confidence=\"1000\"" "org.eventb.core.confidence=\"0\"") with + | .error _ => true + | .ok _ => false + +#guard match importStatuses (sampleSource.replace + "" ("")) with + | .error _ => true + | .ok _ => false + +#guard match importStatuses (sampleSource.replace + "org.eventb.core.psManual=\"true\"" "org.eventb.core.psManual=\"maybe\"") with + | .error _ => true + | .ok _ => false + +#guard match importStatuses (sampleSource.replace + " org.eventb.core.psManual=\"true\"" "") with + | .error _ => true + | .ok _ => false + +#guard match attach (Ledger.ofObligations [sampleObligation]) + sampleObligation "sample.bps" + { name := "other/INV", confidence := 1000, manual := false } with + | .error _ => true + | .ok _ => false + #guard match importStatuses sampleSource with | .ok statuses => let comparison := compare [sampleObligation] statuses From 19b25f1385311c26eb55b353bca095fd2fb036bf Mon Sep 17 00:00:00 2001 From: Jonathan Cubides Date: Fri, 14 Aug 2026 14:44:22 -0500 Subject: [PATCH 3/8] fix(accuracy): harden Event-B acceptance --- .github/workflows/ci.yml | 4 +- .gitignore | 4 +- EventB/Formula/Translate.lean | 37 +- EventB/POG.lean | 754 +++++++++++++++++++++++++++++---- EventB/Trust.lean | 81 +++- EventB/Trust/Replay.lean | 65 ++- EventB/Trust/Rodin.lean | 172 +++++++- EventB/Typing/Check.lean | 600 +++++++++++++++++++++++--- EventB/Typing/Infer.lean | 43 +- EventB/Xml.lean | 49 ++- README.md | 2 +- STATUS.md | 54 +++ TODO.md | 106 +++-- Widgets.lean | 18 +- baseline/hypothesis.tsv | 3 + baseline/p4.tsv | 73 ++++ baseline/statement.tsv | 3 + baseline/wwd.tsv | 1 + bench/Bench.lean | 6 +- cli/Cli.lean | 6 +- examples/BookPrograms.lean | 17 + examples/TranslateDemo.lean | 22 + examples/TrustRodinDemo.lean | 12 +- examples/WidgetDemo.lean | 19 +- notes/architecture.md | 27 +- notes/production-acceptance.md | 44 +- spike/measure.sh | 11 +- test/Gates.lean | 234 ++++++++-- tools/cli-fixtures.py | 29 +- 29 files changed, 2167 insertions(+), 329 deletions(-) create mode 100644 STATUS.md create mode 100644 baseline/p4.tsv create mode 100644 baseline/wwd.tsv diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index cc5a1c3..e628607 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -92,9 +92,9 @@ jobs: } >> "$GITHUB_STEP_SUMMARY" - name: Status report generates run: | - # STATUS.md is untracked, so a `git diff` check on it would always pass. - # Running the generator still catches a crash in the reporting path. lake exe gates --status + git ls-files --error-unmatch STATUS.md baseline/p4.tsv baseline/wwd.tsv + git diff --exit-code -- STATUS.md baseline/p4.tsv baseline/wwd.tsv axioms: # The trust ledger. Once POG lands this enumerates, per obligation, whether it is diff --git a/.gitignore b/.gitignore index 6415233..9988e8a 100644 --- a/.gitignore +++ b/.gitignore @@ -6,11 +6,9 @@ bench/results/*/raw/ docs/event-b.md/ docs/event-b.md.zip -# Working documents, deliberately untracked: the working agreement, the phase plan, -# and the generated status report. `lake exe gates --status` rewrites STATUS.md. +# Working documents, deliberately untracked: the working agreement and the phase plan. AGENTS.md PLAN.md -STATUS.md # The spike vendors Mathlib; do not track its build tree. spike/.lake/ diff --git a/EventB/Formula/Translate.lean b/EventB/Formula/Translate.lean index 5273980..dfac366 100644 --- a/EventB/Formula/Translate.lean +++ b/EventB/Formula/Translate.lean @@ -104,6 +104,11 @@ private def boolType : Expr := mkConst (Name.mkSimple "Bool") private def trueProp : Expr := mkConst (Name.mkSimple "True") +/-- Event-B exponentiation is only defined for non-negative exponents. The embedding is +totalized outside that domain; POG emits `0 ≤ exponent` as the corresponding WD premise. -/ +private def eventBPow (base exponent : Int) : Int := + if 0 ≤ exponent then Int.pow base exponent.toNat else 0 + private def mkAnd (left right : Expr) : MetaM Expr := mkAppM ``And #[left, right] private def mkOr (left right : Expr) : MetaM Expr := mkAppM ``Or #[left, right] private def mkImp (left right : Expr) : MetaM Expr := mkArrow left right @@ -432,6 +437,13 @@ private def mkRestriction (relationType set relation : Expr) (domain : Bool) : M let body ← mkAnd restricted (mkApp relation pair) mkLambdaFVars #[pair] body +private def mkSubtraction (relationType set relation : Expr) (domain : Bool) : MetaM Expr := do + withLocalDeclD `pair relationType fun pair => do + let endpoint ← if domain then project ``Prod.fst pair else project ``Prod.snd pair + let removed := mkApp set endpoint + let body ← mkAnd (← mkNot removed) (mkApp relation pair) + mkLambdaFVars #[pair] body + private def mkComposition (leftType middleType rightType left right : Expr) : MetaM Expr := do let pairType ← mkAppM ``Prod #[leftType, rightType] withLocalDeclD `pair pairType fun pair => do @@ -751,22 +763,24 @@ private def translateExpr : Nat → KernelContext → Formula.Term → MetaM Ker checked context (.pow (.prod leftType rightType)) (← mkProductSet (← typeExpr context leftType) (← typeExpr context rightType) left right) - | "◁" | "⩤" | "▷" | "⩥" => + | "◁" | "▷" | "⩤" | "⩥" => let left ← translateExpr fuel context left let right ← translateExpr fuel context right if op == "◁" || op == "⩤" then let (rightLeft, rightRight) ← relationTypes right let (leftType, leftSet) ← asSet left let _ ← sameType leftType rightLeft + let builder := if op == "◁" then mkRestriction else mkSubtraction checked context right.ty - (← mkRestriction (← typeExpr context (.prod rightLeft rightRight)) leftSet + (← builder (← typeExpr context (.prod rightLeft rightRight)) leftSet right.value true) else let (leftType, leftRight) ← relationTypes left let (rightType, rightSet) ← asSet right let _ ← sameType leftRight rightType + let builder := if op == "▷" then mkRestriction else mkSubtraction checked context left.ty - (← mkRestriction (← typeExpr context (.prod leftType leftRight)) rightSet + (← builder (← typeExpr context (.prod leftType leftRight)) rightSet left.value false) | "↔" | "" | "" | "" | "⇸" | "→" | "⤔" | "↣" | "⤀" | "↠" | "⤖" => let left ← translateExpr fuel context left @@ -789,8 +803,7 @@ private def translateExpr : Nat → KernelContext → Formula.Term → MetaM Ker | "mod" => ``Int.emod | _ => ``Int.add let result ← if op == "^" then - let exponent ← mkAppM ``Int.toNat #[right.value] - mkAppM ``Int.pow #[left.value, exponent] + mkAppM ``eventBPow #[left.value, right.value] else mkAppM function #[left.value, right.value] checked context .int result @@ -898,7 +911,12 @@ private def translatePred : Nat → KernelContext → Formula.Term → MetaM Exp let (leftType, left) ← asSet left let _ ← sameType leftType rightType let subset ← mkSubset (← typeExpr context leftType) left right - if op == "⊆" then pure subset else mkNot subset + if op == "⊆" then pure subset + else if op == "⊈" then mkNot subset + else do + let reverse ← mkSubset (← typeExpr context leftType) right left + let strict ← mkAnd subset (← mkNot reverse) + if op == "⊂" then pure strict else mkNot strict else let left ← translateExpr fuel context left let (leftType, left) ← asSet left @@ -909,7 +927,12 @@ private def translatePred : Nat → KernelContext → Formula.Term → MetaM Exp let (rightType, right) ← asSet right let _ ← sameType leftType rightType let subset ← mkSubset (← typeExpr context leftType) left right - if op == "⊆" then pure subset else mkNot subset + if op == "⊆" then pure subset + else if op == "⊈" then mkNot subset + else do + let reverse ← mkSubset (← typeExpr context leftType) right left + let strict ← mkAnd subset (← mkNot reverse) + if op == "⊂" then pure strict else mkNot strict | _ => throwError s!"unsupported Event-B predicate operator `{op}`" | fuel + 1, context, .app (.id name) value => do match context.lookupPredicate name with diff --git a/EventB/POG.lean b/EventB/POG.lean index eb268b6..921d8e1 100644 --- a/EventB/POG.lean +++ b/EventB/POG.lean @@ -33,17 +33,28 @@ structure Obligation where goal : Option Term := none /-- Everything the goal may assume, in Rodin's order. -/ hyps : List Term := [] + /-- Typechecking and model-resolution errors discovered before generation. -/ + diagnostics : List String := [] deriving BEq, Repr, Inhabited -def formulaLanguageVersion : String := "eventb-formula-v1" +def formulaLanguageVersion : String := "eventb-formula-v2" + +private def canonicalField (value : String) : String := + s!"{value.length}:{value}" + +private def canonicalList (values : List String) : String := + s!"{values.length}[{String.intercalate "" (values.map canonicalField)}]" def Obligation.canonical (obligation : Obligation) : String := String.intercalate "\n" - ["scope=" ++ obligation.component - , "formula-language=" ++ formulaLanguageVersion - , "theories=" ++ String.intercalate "," obligation.theoryRoots - , "hyps=" ++ String.intercalate "\n" (obligation.hyps.map Formula.print) - , "goal=" ++ (obligation.goal.map Formula.print |>.getD "")] + ["scope=" ++ canonicalField obligation.component + , "obligation=" ++ canonicalField obligation.name + , "kind=" ++ canonicalField obligation.kind + , "formula-language=" ++ canonicalField formulaLanguageVersion + , "theories=" ++ canonicalList obligation.theoryRoots + , "diagnostics=" ++ canonicalList obligation.diagnostics + , "hyps=" ++ canonicalList (obligation.hyps.map Formula.print) + , "goal=" ++ canonicalField (obligation.goal.map Formula.print |>.getD "")] private def childrenOf (e : Elem) (tag : String) : List Elem := e.children.filter (fun c => c.tag == "org.eventb.core." ++ tag) @@ -56,9 +67,16 @@ private def labelOf (e : Elem) : String := (attrOf e "label").getD "" private def targetName (e : Elem) : Option String := (attrOf e "target").map (fun t => (t.splitOn "/").getLast!) -/-- Identifiers occurring in a formula. Binders are not subtracted: an invariant that -quantifies over a name shadowing a variable would over-report, which the corpus does not -contain, and over-reporting here only ever adds an obligation Rodin also has. -/ +private def eventTargets (ev : Elem) : List String := + if labelOf ev == "INITIALISATION" then ["INITIALISATION"] + else (childrenOf ev "refinesEvent").filterMap targetName + +private def isExtended (ev : Elem) : Bool := + (attrOf ev "extended").getD "false" == "true" || + (childrenOf ev "refinesEvent").any + (fun reference => (attrOf reference "extended").getD "false" == "true") + +/-- Identifiers occurring in a formula. -/ def identifiers : Term → List String | .id n => [n] | .num _ => [] @@ -69,9 +87,21 @@ def identifiers : Term → List String | .set ts => ts.flatMap identifiers | .bind _ p b => identifiers p ++ identifiers b +private def freeIdentifiers (bound : List String) : Term → List String + | .id n => if bound.contains n then [] else [n] + | .num _ => [] + | .bin _ a b => freeIdentifiers bound a ++ freeIdentifiers bound b + | .pre _ a | .post _ a => freeIdentifiers bound a + | .app f a => freeIdentifiers bound f ++ freeIdentifiers bound a + | .img r a => freeIdentifiers bound r ++ freeIdentifiers bound a + | .set ts => ts.flatMap (freeIdentifiers bound) + | .bind _ pattern body => + freeIdentifiers bound pattern ++ + freeIdentifiers (patternNames pattern ++ bound) body + private def freeOf (formula : String) : List String := match Formula.parse formula with - | .ok t => identifiers t + | .ok t => freeIdentifiers [] t | .error _ => [] /-- The substitution an action performs. Only the deterministic form `v ≔ E` yields @@ -84,20 +114,42 @@ private def substOf (action : Elem) : List (String × Term) := match Formula.parse a with -- `f(x) ≔ E` overrides the function at one point. Rodin writes the result as -- `f{x ↦ E}`, so the substitution builds exactly that. - | .ok (.bin "≔" (.app (.id f) x) rhs) => - [(f, .bin "" (.id f) (.set [.bin "↦" x rhs]))] | .ok (.bin "≔" lhs rhs) => - match Formula.flattenCommas lhs, Formula.flattenCommas rhs with - | [.id v], [e] => [(v, e)] - -- `v, w ≔ E, F` assigns componentwise. - | vs, es => (vs.zip es).filterMap fun (v, e) => - match v with | .id n => some (n, e) | _ => none + let update : Term → Term → Option (String × Term) + | .id v, e => some (v, e) + | .app (.id f) x, e => + some (f, .bin "" (.id f) (.set [.bin "↦" x e])) + | _, _ => none + (Formula.flattenCommas lhs).zip (Formula.flattenCommas rhs) + |>.filterMap (fun (v, e) => update v e) | _ => [] private def witnessBinding (witness : Elem) : Option (String × Term) := + match Formula.parse ((attrOf witness "predicate").getD "") with + | .ok (.bin "=" left right) => + match attrOf witness "label" with + | some label => + if left == .id label then some (label, right) + else if right == .id label then some (label, left) + else match left with + | .id v => some (v, right) + | _ => match right with + | .id v => some (v, left) + | _ => none + | none => + match left with + | .id v => some (v, right) + | _ => match right with + | .id v => some (v, left) + | _ => none + | _ => none + +private def witnessVariable (witness : Elem) : Option String := + (witnessBinding witness).map (·.1) <|> attrOf witness "label" + +private def witnessSubstitution (witness : Elem) : Option (String × Term) := match Formula.parse ((attrOf witness "predicate").getD "") with | .ok (.bin "=" (.id v) e) => some (v, e) - | .ok (.bin "=" e (.id v)) => some (v, e) | _ => none /-- The variables an action assigns. Rodin's three assignment forms all name their @@ -109,13 +161,18 @@ private def assignedBy (action : Elem) : List String := match Formula.parse a with | .error _ => [] | .ok (.bin op lhs _) => - if op == "≔" || op == ":∈" || op == ":∣" then Formula.flattenCommas lhs - |>.flatMap identifiers + if op == "≔" then (substOf action).map (·.1) + else if op == ":∈" || op == ":∣" then + Formula.flattenCommas lhs |>.filterMap fun term => + match term with + | .id n => some n + | .app (.id f) _ => some f + | _ => none else [] | .ok _ => [] private def targetEventName (ev : Elem) : String := - ((childrenOf ev "refinesEvent").filterMap targetName).head?.getD (labelOf ev) + (eventTargets ev).head?.getD "" private def beforeElem (target : Elem) : List Elem → List Elem | [] => [] @@ -132,7 +189,7 @@ def inheritedChildren (p : Project) (tag : String) : Nat → String → Elem → | 0, _, ev => childrenOf ev tag | depth + 1, machine, ev => let own := childrenOf ev tag - if (attrOf ev "extended").getD "false" != "true" then own else + if !isExtended ev then own else match lookupComponent p machine with | none => own | some m => @@ -161,10 +218,15 @@ abstract event even when the refinement never names them, so `scheduledAirplanes dom(landing_sequence)` becomes `∅ = dom(∅)` under an INITIALISATION that only assigns `landing_sequence` here and leaves the other to the machine above. Concrete assignments win; `depth` bounds the walk by the component count, as elsewhere. -/ -def eventSubst (p : Project) : Nat → String → Elem → List (String × Term) - | 0, _, ev => (childrenOf ev "action").flatMap substOf +private def eventActions (p : Project) : Nat → String → Elem → List Elem + | 0, machine, ev => + match lookupComponent p machine with + | some component => initializationActions p component ev + | none => childrenOf ev "action" | depth + 1, machine, ev => - let own := (childrenOf ev "action").flatMap substOf + let own := match lookupComponent p machine with + | some component => initializationActions p component ev + | none => childrenOf ev "action" let inherited := match lookupComponent p machine with | none => [] @@ -176,20 +238,153 @@ def eventSubst (p : Project) : Nat → String → Elem → List (String × Term) let target := targetEventName ev match (childrenOf a.elem "event").find? (fun e => labelOf e == target) with | none => [] - | some ae => eventSubst p depth am ae - own ++ inherited.filter (fun q => !own.any (fun o => o.1 == q.1)) + | some ae => eventActions p depth am ae + own ++ inherited.filter (fun q => + !(assignedBy q).any (fun v => own.any (fun o => (assignedBy o).contains v))) + +private def transitionActions (p : Project) (machine : String) (ev : Elem) : List Elem := + eventActions p p.length machine ev + +private def accurateTransitionActions (p : Project) (machine : String) (ev : Elem) : List Elem := + match lookupComponent p machine with + | none => childrenOf ev "action" + | some component => + if labelOf ev == "INITIALISATION" then initializationActions p component ev + else effectiveActions p machine ev + +def eventSubst (p : Project) : Nat → String → Elem → List (String × Term) + | 0, machine, ev => + (transitionActions p machine ev).flatMap substOf + | _, machine, ev => (transitionActions p machine ev).flatMap substOf + +private def actionRelation (action : Elem) : Option Term := + match attrOf action "assignment" with + | none => none + | some source => + match Formula.parse source with + | .ok (.bin ":∈" lhs set) => + let relations := Formula.flattenCommas lhs |>.filterMap fun term => + match term with + | .id v => some (.bin "∈" (.id (v ++ "'")) set) + | _ => none + match relations with + | [] => none + | relation :: rest => + some (rest.foldl (fun acc next => .bin "∧" acc next) relation) + | .ok (.bin ":∣" _ predicate) => some predicate + | _ => none + +private def actionRelationAccurate (action : Elem) : Option Term := + match attrOf action "assignment" with + | none => none + | some source => + match Formula.parse source with + | .ok (.bin ":∈" lhs set) => + let targets := Formula.flattenCommas lhs |>.filterMap fun term => + match term with + | .id v => some (.id (v ++ "'")) + | _ => none + match targets with + | [] => none + | [target] => some (.bin "∈" target set) + | target :: rest => + let tuple := rest.foldl (fun acc next => .bin "↦" acc next) target + some (.bin "∈" tuple set) + | .ok (.bin ":∣" _ predicate) => some predicate + | _ => none + +private def nondeterministicSubst (action : Elem) : List (String × Term) := + match attrOf action "assignment" with + | some source => + match Formula.parse source with + | .ok (.bin op _ _) => + if op == ":∈" || op == ":∣" then + assignedBy action |>.map fun v => (v, .id (v ++ "'")) + else [] + | _ => [] + | none => [] + +private def firstAssignments (pairs : List (String × Term)) : List (String × Term) := + pairs.foldl (fun acc pair => + if acc.any (fun prior => prior.1 == pair.1) then acc else acc ++ [pair]) [] + +private def eventStateSubst (p : Project) (name : String) (ev : Elem) : List (String × Term) := + firstAssignments ((transitionActions p name ev).flatMap fun action => + substOf action ++ nondeterministicSubst action) + +private def eventRelationalHyps (p : Project) (name : String) (ev : Elem) : List Term := + (transitionActions p name ev).filterMap actionRelation + +private def eventStateSubstMode (strict : Bool) (p : Project) (name : String) + (ev : Elem) : List (String × Term) := + if strict then + firstAssignments ((accurateTransitionActions p name ev).flatMap fun action => + substOf action ++ nondeterministicSubst action) + else eventStateSubst p name ev + +private def eventRelationalHypsMode (strict : Bool) (p : Project) (name : String) + (ev : Elem) : List Term := + if strict then (accurateTransitionActions p name ev).filterMap actionRelationAccurate + else eventRelationalHyps p name ev + +private def deterministicAfterRelation (action : Elem) : List Term := + (substOf action).map fun (v, rhs) => .bin "=" (.id (v ++ "'")) rhs + +private def actionAfterRelation (action : Elem) : List Term := + deterministicAfterRelation action ++ (actionRelation action).toList + +private def actionAfterRelationAccurate (action : Elem) : List Term := + deterministicAfterRelation action ++ (actionRelationAccurate action).toList + +private def frameRelations (variables : List String) (actions : List Elem) : List Term := + let assigned := actions.flatMap assignedBy + (variables.filter (fun v => !assigned.contains v)).map fun v => + .bin "=" (.id (v ++ "'")) (.id v) + +private def concreteStateRelations (variables : List String) (actions : List Elem) : List Term := + actions.flatMap actionAfterRelation ++ frameRelations variables actions + +private def concreteStateRelationsAccurate (variables : List String) + (actions : List Elem) : List Term := + actions.flatMap actionAfterRelationAccurate ++ frameRelations variables actions + +private def concreteStateRelationsMode (strict : Bool) (variables : List String) + (actions : List Elem) : List Term := + if strict then concreteStateRelationsAccurate variables actions + else concreteStateRelations variables actions + +private def actionAfterSubst (action : Elem) : List (String × Term) := + ((substOf action).map fun (v, rhs) => (v ++ "'", rhs)) ++ + ((nondeterministicSubst action).map fun (v, rhs) => (v ++ "'", rhs)) /-- Guards and actions of the abstract event a refined event refines. These are what GRD and SIM obligations are named after: the abstract label, not the concrete one. -/ +private def abstractEvents (p : Project) (machine : String) (ev : Elem) : + List (String × Elem) := + match lookupComponent p machine with + | none => [] + | some m => + let abstractMachine := (childrenOf m.elem "refinesMachine").filterMap targetName |>.head? + match abstractMachine.bind (lookupComponent p ·) with + | none => [] + | some a => + let targets := eventTargets ev + targets.filterMap fun target => + (childrenOf a.elem "event").find? (fun candidate => labelOf candidate == target) + |>.map (fun ae => (a.name, ae)) + private def abstractEvent (p : Project) (machine : String) (ev : Elem) : - Option (String × Elem) := do - let m ← lookupComponent p machine - let am ← ((childrenOf m.elem "refinesMachine").filterMap targetName).head? - let a ← lookupComponent p am - let target ← if labelOf ev == "INITIALISATION" then some "INITIALISATION" - else ((childrenOf ev "refinesEvent").filterMap targetName).head? - let ae ← (childrenOf a.elem "event").find? (fun e => labelOf e == target) - return (am, ae) + Option (String × Elem) := + let refs := abstractEvents p machine ev + refs.head? + +private def disjoin : List Term → Option Term + | [] => none + | term :: terms => some (terms.foldl (fun acc next => .bin "∨" acc next) term) + +private def conjoin : List Term → Option Term + | [] => some (.id "⊤") + | term :: terms => some (terms.foldl (fun acc next => .bin "∧" acc next) term) structure WdContext where theory : Theory.Env @@ -250,6 +445,22 @@ private def wdType : Ty → Term | .prod a b => .bin "×" (wdType a) (wdType b) | .mvar n => .id s!"?{n}" +private def actionFeasibility (types : List (String × Ty)) (action : Elem) : Option Term := + match attrOf action "assignment" with + | none => none + | some source => + match Formula.parse source with + | .ok (.bin ":∈" _ set) => some (.bin "≠" set (.set [])) + | .ok (.bin ":∣" _ predicate) => + let targets := assignedBy action + let binders := targets.filterMap fun v => + (types.find? (fun pair => pair.1 == v)).map fun (_, type) => + .bin "⦂" (.id (v ++ "'")) (wdType type) + if binders.length == targets.length then + some (binders.foldr (fun binder body => .bind "∃" binder body) predicate) + else none + | _ => none + private def wdFunctionType (context : WdContext) (f : Term) : Option Term := match inferTermAt context.theory context.roots context.env f with | .ok (.pow (.prod a b)) => some (.bin "⇸" (wdType a) (wdType b)) @@ -287,7 +498,8 @@ mutual def needsWD (totalKeywords : List String) : Term → Bool | .num _ | .id _ => false | .bin op a b => - op == "÷" || op == "mod" || needsWD totalKeywords a || needsWD totalKeywords b + op == "÷" || op == "mod" || op == "^" || needsWD totalKeywords a || + needsWD totalKeywords b | .pre op a => op == "⋂" || needsWD totalKeywords a | .post _ a => needsWD totalKeywords a | .app f a => @@ -325,6 +537,8 @@ private def wdTermAux : Nat → WdContext → Term → Option Term if op == "mod" then return wdAnd (wdAnd wa wb) (.bin "∧" (.bin "≤" (.num 0) a) (.bin "<" (.num 0) b)) + if op == "^" then + return wdAnd (wdAnd wa wb) (.bin "≤" (.num 0) b) return wdAnd wa wb | fuel + 1, context, .pre op a => do let wa ← wdTermAux fuel context a @@ -413,16 +627,61 @@ private def assignmentRhs (formula : String) : Option String := if op == "≔" || op == ":∈" || op == ":∣" then some (Formula.print rhs) else none | _ => none +private def assignmentRhsMode (strict : Bool) (formula : String) : Option String := + if strict then + match Formula.parse formula with + | .ok (.bin "≔" lhs rhs) => + let lhsArgs := Formula.flattenCommas lhs |>.filterMap fun term => + match term with + | .app _ _ => some (Formula.print term) + | _ => none + some (String.intercalate " ∧ " (lhsArgs ++ [Formula.print rhs])) + | .ok (.bin op _ rhs) => + if op == ":∈" || op == ":∣" then some (Formula.print rhs) else none + | _ => none + else assignmentRhs formula + private def wdGoal (theory : Theory.Env) (roots totalKeywords : List String) (env : List (String × Ty)) (formula : String) : Option Term := match Formula.parse formula with | .ok t => wdTerm theory roots totalKeywords env t | .error _ => none -private def witnessFeasibility (types : List (String × Ty)) (witness : Elem) : Option Term := do +private def assignmentWdGoal (strict : Bool) (theory : Theory.Env) + (roots totalKeywords : List String) + (types : List (String × Ty)) (action : Elem) : Option Term := do + let source ← attrOf action "assignment" + let parsed ← Formula.parse source |>.toOption + match parsed with + | .bin ":∣" _ predicate => + let body ← wdGoal theory roots totalKeywords types (Formula.print predicate) + if !strict then some body else + let binders := (assignedBy action).filterMap fun name => + (types.find? (fun pair => pair.1 == name)).map fun (_, type) => + .bin "⦂" (.id (name ++ "'")) (wdType type) + if binders.length == (assignedBy action).length then + some (binders.foldr (fun binder body => .bind "∀" binder body) body) + else none + | _ => + let rhs ← assignmentRhsMode strict source + wdGoal theory roots totalKeywords types rhs + +private def variantType (theory : Theory.Env) (roots : List String) + (types : List (String × Ty)) (variant : Elem) : Option Ty := do + let source ← attrOf variant "expression" + let term ← Formula.parse source |>.toOption + (inferTermAt theory roots types term).toOption + +private def variantTerm (variant : Elem) : Option Term := do + let source ← attrOf variant "expression" + Formula.parse source |>.toOption + +private def witnessFeasibility (types visibleParams : List (String × Ty)) + (witness : Elem) : Option Term := do let predicate ← Formula.parse ((attrOf witness "predicate").getD "") |>.toOption - let (witnessVar, _) ← witnessBinding witness - let type ← types.find? (fun pair => pair.1 == witnessVar) |>.map (·.2) + let witnessVar ← witnessVariable witness + let (_, type) ← (visibleParams.find? (fun pair => pair.1 == witnessVar) <|> + types.find? (fun pair => pair.1 == witnessVar)) some (.bind "∃" (.bin "⦂" (.id witnessVar) (wdType type)) predicate) /- Rules tried against the corpus and rejected by measurement, recorded so they are not @@ -491,22 +750,24 @@ private def eventHyps (p : Project) (name : String) (ev : Elem) : List Term := (Formula.parse ((attrOf g "predicate").getD "")).toOption /-- Obligations for one machine or context under a native theory environment. -/ -def generateIn (theory : Theory.Env) (p : Project) (name : String) : List Obligation := Id.run do +private def generateInMode (strict : Bool) (theory : Theory.Env) (p : Project) + (name : String) : List Obligation := Id.run do match lookupComponent p name with | none => return [] | some c => let isMachine := c.elem.tag == "org.eventb.core.machineFile" let roots := componentTheoryRoots p name + let (types, eventParams, diagnostics) := match inferComponentDetailsIn theory p name with + | .ok result => (result.types, result.eventParams, result.diagnostics) + | .error error => ([], [], [error.message]) let finalize := fun obligations : List Obligation => obligations.map fun obligation => { obligation with component := name theoryRoots := roots + diagnostics := diagnostics goal := obligation.goal.map (Theory.normalize theory roots) hyps := obligation.hyps.map (Theory.normalize theory roots) } let total := totalKeywords theory roots - let types := match inferComponentIn theory p name with - | .ok (env, _) => env - | .error _ => [] let mut out : List Obligation := [] -- A `theorem` invariant or axiom must follow from what precedes it. for a in childrenOf c.elem "axiom" ++ childrenOf c.elem "invariant" do @@ -533,106 +794,417 @@ def generateIn (theory : Theory.Env) (p : Project) (name : String) : List Obliga goal := (Formula.parse ((attrOf g "predicate").getD "")).toOption, hyps := eventHypsBefore p name ev g }] if !isMachine then return finalize out + let explicitVariants := childrenOf c.elem "variant" + let hasConvergent := (childrenOf c.elem "event").any (fun event => + (attrOf event "convergence").getD "0" == "1") + let variants := if explicitVariants.isEmpty && + !hasConvergent && (childrenOf c.elem "event").any (fun event => + (attrOf event "convergence").getD "0" == "2") then + [.variant [("org.eventb.core.expression", "0")] []] + else explicitVariants + -- Rodin supplies a constant zero variant when a machine has anticipated events + -- but no explicit variant. + for variant in variants do + let source := (attrOf variant "expression").getD "" + if wdRequired total source then + out := out ++ + [{ name := "VWD", kind := "VWD", + goal := wdGoal theory roots total types source, + hyps := contextHyps p name }] + match variantTerm variant, variantType theory roots types variant with + | some term, some (.pow _) => + out := out ++ + [{ name := "FIN", kind := "FIN", goal := some (.app (.id "finite") term), + hyps := contextHyps p name }] + for ev in childrenOf c.elem "event" do + let convergence := (attrOf ev "convergence").getD "0" + if convergence == "1" || convergence == "2" then + let after := Formula.subst (eventStateSubstMode strict p name ev) term + let relation := if convergence == "1" then "⊂" else "⊆" + out := out ++ + [{ name := labelOf ev ++ "/VAR", kind := "VAR", + goal := some (.bin relation after term), + hyps := eventHyps p name ev ++ eventRelationalHypsMode strict p name ev }] + | some term, some .int => + for ev in childrenOf c.elem "event" do + let convergence := (attrOf ev "convergence").getD "0" + if convergence == "1" || convergence == "2" then + let nat := .bin "∈" term (.id "ℕ") + out := out ++ + [{ name := labelOf ev ++ "/NAT", kind := "NAT", goal := some nat, + hyps := eventHyps p name ev }] + let after := Formula.subst (eventStateSubstMode strict p name ev) term + let relation := if convergence == "1" then "<" else "≤" + out := out ++ + [{ name := labelOf ev ++ "/VAR", kind := "VAR", + goal := some (.bin relation after term), + hyps := eventHyps p name ev ++ eventRelationalHypsMode strict p name ev }] + | _, _ => pure () let invariants := childrenOf c.elem "invariant" for ev in childrenOf c.elem "event" do let base := if labelOf ev == "INITIALISATION" then contextAxioms p name else contextHyps p name - let witnesses := (childrenOf ev "witness").filterMap fun w => - match Formula.parse ((attrOf w "predicate").getD "") with - | .ok (.bin "=" (.id v) e) => some (v, e) - | _ => none + let witnesses := (childrenOf ev "witness").filterMap fun witness => + if strict then witnessBinding witness else witnessSubstitution witness + let witnessPredicates := (childrenOf ev "witness").filterMap fun w => + (Formula.parse ((attrOf w "predicate").getD "")).toOption + let witnessConstraints := if strict then + (childrenOf ev "witness").filterMap fun w => + if witnessBinding w |>.isSome then none + else (Formula.parse ((attrOf w "predicate").getD "")).toOption + else [] + let visibleParams := visibleEventBindings p eventParams name (labelOf ev) + let concreteVariables := (childrenOf c.elem "variable").filterMap (attrOf · "identifier") + let concreteActions := if strict then accurateTransitionActions p name ev + else initializationActions p c ev + let concreteRelations := concreteStateRelationsMode strict concreteVariables concreteActions -- A non-extended refined event still executes its abstract actions. Use the -- refinement substitution here so inherited assignments trigger preservation -- obligations for concrete invariants as well as for the after-state formula. - let assigned := (eventSubst p p.length name ev).map (·.1) + let assigned := (eventStateSubstMode strict p name ev).map (·.1) -- An invariant needs re-proving only if the event can change something it -- mentions. This filter is what keeps the INV count at Rodin's 934 rather than -- events times invariants. for inv in invariants do if (attrOf inv "theorem").getD "false" != "true" then let free := freeOf ((attrOf inv "predicate").getD "") - if assigned.any (fun v => free.contains v) then + if labelOf ev == "INITIALISATION" || assigned.any (fun v => free.contains v) then -- The obligation is the invariant restated over the after-state, which is -- exactly the invariant with the event's assignments substituted in. - let σ := eventSubst p p.length name ev + let σ := eventStateSubstMode strict p name ev let goal := (Formula.parse ((attrOf inv "predicate").getD "")).toOption.map (fun predicate => Formula.subst witnesses (Formula.subst σ predicate)) -- The event's guards hold when it fires, so they join the standing -- hypotheses. let guards := (effectiveGuards p name ev).filterMap fun g => (Formula.parse ((attrOf g "predicate").getD "")).toOption + let actionHyps := + (eventRelationalHypsMode strict p name ev).map (Formula.subst witnesses) out := out ++ [{ name := labelOf ev ++ "/" ++ labelOf inv ++ "/INV", kind := "INV", - goal := goal, hyps := base ++ guards }] + goal := goal, hyps := base ++ guards ++ actionHyps }] -- Refinement obligations are named after the abstract event's labels. + let abstractRefs := abstractEvents p name ev + if abstractRefs.length > 1 && !isExtended ev then + let abstractPredicates := abstractRefs.filterMap fun (am, ae) => + let guards := (effectiveGuards p am ae).filterMap fun g => + (Formula.parse ((attrOf g "predicate").getD "")).toOption.map + (Formula.subst witnesses) + conjoin guards + if let some goal := disjoin abstractPredicates then + out := out ++ + [{ name := labelOf ev ++ "/MRG", kind := "MRG", goal := some goal, + hyps := base ++ + ((effectiveGuards p name ev).filterMap fun g => + (Formula.parse ((attrOf g "predicate").getD "")).toOption) ++ + witnessConstraints ++ concreteRelations }] if let some (am, ae) := abstractEvent p name ev then - if (attrOf ev "extended").getD "false" != "true" then + if !isExtended ev then -- Guard strengthening: the concrete event must be enabled only where the -- abstract one is, so the goal is the abstract guard itself. A witness names -- the value an abstract parameter takes, and is substituted in when present. let concreteGuards := effectiveGuards p name ev - for g in effectiveGuards p am ae do - let abstractPredicate := (Formula.parse ((attrOf g "predicate").getD "")).toOption - let repeated := concreteGuards.any fun q => - match abstractPredicate, Formula.parse ((attrOf q "predicate").getD "") with - | some abstractTerm, .ok concreteTerm => - Formula.stripAscriptions abstractTerm == Formula.stripAscriptions concreteTerm - | _, _ => false - if !repeated then - let goal := abstractPredicate.map (Formula.subst witnesses) - out := out ++ - [{ name := labelOf ev ++ "/" ++ labelOf g ++ "/GRD", kind := "GRD", - goal := goal, hyps := base ++ - concreteGuards.filterMap fun q => - (Formula.parse ((attrOf q "predicate").getD "")).toOption }] - -- Simulation: whatever the abstract action does to a variable, the concrete - -- event's direct actions must do the same thing to it. Inherited actions are - -- already included in eventSubst for INV, but an extended concrete event does - -- not execute them again as a new SIM action. The goal equates the two - -- right-hand sides, with witnesses substituted into the abstract one. - let concrete := (childrenOf ev "action").flatMap substOf + if abstractRefs.length <= 1 then + for g in effectiveGuards p am ae do + let abstractPredicate := (Formula.parse ((attrOf g "predicate").getD "")).toOption + let repeated := concreteGuards.any fun q => + match abstractPredicate, Formula.parse ((attrOf q "predicate").getD "") with + | some abstractTerm, .ok concreteTerm => + Formula.stripAscriptions abstractTerm == Formula.stripAscriptions concreteTerm + | _, _ => false + if !repeated then + let goal := abstractPredicate.map (Formula.subst witnesses) + out := out ++ + [{ name := labelOf ev ++ "/" ++ labelOf g ++ "/GRD", kind := "GRD", + goal := goal, hyps := base ++ witnessConstraints ++ + concreteGuards.filterMap fun q => + (Formula.parse ((attrOf q "predicate").getD "")).toOption }] + -- Simulation is required only for abstract variables declared by the concrete + -- machine. A disappeared abstract variable is handled by a gluing invariant, + -- not by inventing a raw after-state identifier in this sequent. + let concrete := concreteActions.flatMap substOf + let concreteTargets := concreteActions.flatMap assignedBy + let concreteAfter := concreteActions.flatMap actionAfterSubst + let concreteRelations := + concreteStateRelationsMode strict concreteVariables concreteActions for act in effectiveActions p am ae do - let simGoal : Option Term := match substOf act with - | [(v, absRhs)] => - match concrete.find? (fun q : String × Term => q.1 == v) with - | some (_, conRhs) => - some (Term.bin "=" conRhs (Formula.subst witnesses absRhs)) - | none => none - | _ => none + let abstractRelation := + if strict then actionRelationAccurate act else actionRelation act + let unchangedAfter := (assignedBy act).filter + (fun v => !concreteTargets.contains v) |>.map fun v => + (v ++ "'", .id v) + let eligible := (assignedBy act).all (fun v => concreteVariables.contains v) + let simGoal : Option Term := + if !eligible then none else match abstractRelation, substOf act with + | some abstractRelation, _ => + some (Formula.subst (concreteAfter ++ unchangedAfter) + (Formula.subst witnesses abstractRelation)) + | none, abstractAssignments => + let goals := abstractAssignments.filterMap fun (v, absRhs) => + match concrete.find? (fun q : String × Term => q.1 == v) with + | some (_, conRhs) => + some (Term.bin "=" conRhs (Formula.subst witnesses absRhs)) + | none => + if concreteVariables.contains v then + some (Term.bin "=" (.id (v ++ "'")) + (Formula.subst witnesses absRhs)) + else none + if goals.length == abstractAssignments.length then conjoin goals else none match simGoal with | some goal => + let needsActionRelation := abstractRelation.isSome || + (concreteActions.any (fun q => !(nondeterministicSubst q).isEmpty)) + let frameRelations := match abstractRelation, substOf act with + | none, abstractAssignments => abstractAssignments.filterMap fun (v, _) => + if concreteVariables.contains v && + !concreteTargets.contains v then + some (.bin "=" (.id (v ++ "'")) (.id v)) + else none + | _, _ => [] + let actionHyps := if needsActionRelation then + concreteRelations ++ frameRelations + else frameRelations out := out ++ [{ name := labelOf ev ++ "/" ++ labelOf act ++ "/SIM", kind := "SIM", - goal := some goal, hyps := base ++ + goal := some goal, hyps := base ++ witnessConstraints ++ ((effectiveGuards p name ev).filterMap fun q => - (Formula.parse ((attrOf q "predicate").getD "")).toOption) }] + (Formula.parse ((attrOf q "predicate").getD "")).toOption) ++ actionHyps }] | none => pure () + let parentMachineNames := (childrenOf c.elem "refinesMachine").filterMap targetName + let abstractMachineName : Option String := + match abstractRefs.head? with + | some (am, _) => some am + | none => parentMachineNames.head? + let abstractMachine : Option Component := abstractMachineName.bind + (fun am => lookupComponent p am) + let abstractVariables := abstractMachine.toList.flatMap fun machine => + (childrenOf machine.elem "variable").filterMap (attrOf · "identifier") + let abstractTargets := abstractRefs.flatMap fun (am, ae) => + match lookupComponent p am with + | none => [] + | some _ => (effectiveActions p am ae).flatMap assignedBy + let concreteActions := if strict then accurateTransitionActions p name ev + else initializationActions p c ev + let concreteTargets := concreteActions.flatMap assignedBy + for v in abstractVariables do + if concreteVariables.contains v && concreteTargets.contains v && + !abstractTargets.contains v then + let actionHyps := concreteActions.filter (fun action => (assignedBy action).contains v) + |>.flatMap actionAfterRelation + out := out ++ + [{ name := labelOf ev ++ "/" ++ v ++ "/EQL", kind := "EQL", + goal := some (.bin "=" (.id (v ++ "'")) (.id v)), + hyps := base ++ actionHyps }] for g in childrenOf ev "guard" do if wdRequired total ((attrOf g "predicate").getD "") then out := out ++ [{ name := labelOf ev ++ "/" ++ labelOf g ++ "/WD", kind := "WD", goal := wdGoal theory roots total types ((attrOf g "predicate").getD ""), hyps := eventHypsBefore p name ev g }] - for act in childrenOf ev "action" do - if let some rhs := assignmentRhs ((attrOf act "assignment").getD "") then - if wdRequired total rhs then - out := out ++ - [{ name := labelOf ev ++ "/" ++ labelOf act ++ "/WD", kind := "WD", - goal := wdGoal theory roots total types rhs, - hyps := eventHyps p name ev }] + let wdActions := if strict then accurateTransitionActions p name ev + else initializationActions p c ev + for act in wdActions do + if let some source := attrOf act "assignment" then + if let some rhs := assignmentRhsMode strict source then + if wdRequired total rhs then + out := out ++ + [{ name := labelOf ev ++ "/" ++ labelOf act ++ "/WD", kind := "WD", + goal := assignmentWdGoal strict theory roots total types act, + hyps := eventHyps p name ev }] + if let some goal := actionFeasibility types act then + out := out ++ + [{ name := labelOf ev ++ "/" ++ labelOf act ++ "/FIS", kind := "FIS", + goal := some goal, hyps := eventHyps p name ev ++ witnessPredicates }] for w in childrenOf ev "witness" do + let witnessAfter := match witnessVariable w with + | some v => + let after := if v.endsWith "'" then v else v ++ "'" + witnessPredicates.any (fun predicate => (identifiers predicate).contains after) + | none => false out := out ++ [{ name := labelOf ev ++ "/" ++ labelOf w ++ "/WFIS", kind := "WFIS", - goal := witnessFeasibility types w, hyps := eventHyps p name ev }] + goal := witnessFeasibility types visibleParams w, + hyps := eventHyps p name ev ++ if witnessAfter then concreteRelations else [] }] if wdRequired total ((attrOf w "predicate").getD "") then out := out ++ [{ name := labelOf ev ++ "/" ++ labelOf w ++ "/WWD", kind := "WWD", -- Rodin records witness WD as a hypothesis-only sequent. - hyps := eventHyps p name ev }] + hyps := eventHyps p name ev ++ + (wdGoal theory roots total types ((attrOf w "predicate").getD "")).toList }] return finalize out +/-- Fail-closed wrapper for front ends that must not consume partial POG output. The +compatibility `generateIn` API keeps diagnostics on each obligation for reporting and +comparison, while this API refuses any scope with typing or resolution errors. -/ +def generateCheckedIn (theory : Theory.Env) (p : Project) (name : String) : + Except EventB.Error (List Obligation) := + match lookupComponent p name with + | none => .error (EventB.Error.typing + s!"cannot generate trusted obligations for missing component {name}") + | some _ => + match inferComponentDetailsCheckedIn theory p name with + | .error error => .error error + | .ok details => + let diagnostics := details.diagnostics + if !diagnostics.isEmpty then + .error (EventB.Error.typing (s! + "cannot generate trusted obligations for {name}: " ++ + String.intercalate "; " diagnostics)) + else + let obligations := generateInMode true theory p name + match obligations.find? (fun obligation => !obligation.diagnostics.isEmpty) with + | none => + match obligations.find? (fun obligation => + obligation.kind == "WFIS" && obligation.goal.isNone) with + | none => .ok obligations + | some obligation => .error (EventB.Error.typing (s! + "cannot generate trusted obligations for {name}: witness " ++ + obligation.name ++ " has no feasible translated goal")) + | some obligation => + .error (EventB.Error.typing (s! + "cannot generate trusted obligations for {name}: " ++ + String.intercalate "; " obligation.diagnostics)) + /-- Compatibility entry point for Rodin corpus projects without user theories. -/ def generate (p : Project) (name : String) : List Obligation := - generateIn Theory.empty p name + generateInMode false Theory.empty p name + +def generateIn (theory : Theory.Env) (p : Project) (name : String) : List Obligation := + generateInMode false theory p name + +def generateChecked (p : Project) (name : String) : Except EventB.Error (List Obligation) := + generateCheckedIn Theory.empty p name + +private def checkedMissingProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.seesContext [("org.eventb.core.target", "Missing")] []] }] + +private def defaultInitializationProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .invariant [("org.eventb.core.label", "inv"), + ("org.eventb.core.predicate", "x ∈ ℤ")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] + []] }] + +private def rightWitnessProject : Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .invariant [("org.eventb.core.label", "inv"), + ("org.eventb.core.predicate", "x ∈ ℤ")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [.parameter [("org.eventb.core.identifier", "p")] [] + , .guard [("org.eventb.core.label", "g"), + ("org.eventb.core.predicate", "p > 0")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ p")] []]] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [.refinesMachine [("org.eventb.core.target", "A")] [] + , .variable [("org.eventb.core.identifier", "x")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [.refinesEvent [("org.eventb.core.target", "step")] [] + , .parameter [("org.eventb.core.identifier", "q")] [] + , .guard [("org.eventb.core.label", "g"), + ("org.eventb.core.predicate", "q + 1 > 0")] [] + , .witness [("org.eventb.core.label", "p"), + ("org.eventb.core.predicate", "q + 1 = p")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ q + 1")] []]] }] + +private def mergeProject : Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .invariant [("org.eventb.core.label", "inv"), + ("org.eventb.core.predicate", "x ∈ ℤ")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "left")] + [.guard [("org.eventb.core.label", "g0"), + ("org.eventb.core.predicate", "x = 0")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ x")] []] + , .event [("org.eventb.core.label", "right")] + [.guard [("org.eventb.core.label", "g1"), + ("org.eventb.core.predicate", "x = 1")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ x")] []]] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [.refinesMachine [("org.eventb.core.target", "A")] [] + , .variable [("org.eventb.core.identifier", "x")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "merge")] + [.refinesEvent [("org.eventb.core.target", "left")] [] + , .refinesEvent [("org.eventb.core.target", "right")] [] + , .guard [("org.eventb.core.label", "g"), + ("org.eventb.core.predicate", "x = 0 ∨ x = 1")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ x")] []]] }] + +private def nonEqualityWitnessProject : Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .invariant [("org.eventb.core.label", "inv"), + ("org.eventb.core.predicate", "x ∈ ℤ")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [.parameter [("org.eventb.core.identifier", "p")] [] + , .guard [("org.eventb.core.label", "g"), + ("org.eventb.core.predicate", "p > 0")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ p")] []]] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [.refinesMachine [("org.eventb.core.target", "A")] [] + , .variable [("org.eventb.core.identifier", "x")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [.refinesEvent [("org.eventb.core.target", "step")] [] + , .parameter [("org.eventb.core.identifier", "q")] [] + , .guard [("org.eventb.core.label", "g"), + ("org.eventb.core.predicate", "q > 0")] [] + , .witness [("org.eventb.core.label", "p"), + ("org.eventb.core.predicate", "p > q")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ q")] []]] }] + +#guard match generateChecked checkedMissingProject "M" with + | .error _ => true + | .ok _ => false + +#guard (generate defaultInitializationProject "M").any (fun obligation => + obligation.name == "INITIALISATION/__default_x/FIS") +#guard (generate defaultInitializationProject "M").any (fun obligation => + obligation.name == "INITIALISATION/inv/INV") +#guard match generateChecked defaultInitializationProject "M" with + | .ok obligations => obligations.any (fun obligation => + obligation.name == "INITIALISATION/__default_x/FIS") + | .error _ => false + +#guard match generateChecked rightWitnessProject "B" with + | .ok obligations => + obligations.any (fun obligation => obligation.name == "step/p/WFIS") && + obligations.any (fun obligation => obligation.name == "step/g/GRD") && + obligations.any (fun obligation => obligation.name == "step/set/SIM") + | .error _ => false + +#guard match generateChecked mergeProject "B" with + | .ok obligations => + obligations.any (fun obligation => obligation.name == "merge/MRG") && + obligations.any (fun obligation => obligation.name == "merge/set/SIM") && + obligations.all (fun obligation => !obligation.name.endsWith "/GRD") + | .error _ => false + +#guard match generateChecked nonEqualityWitnessProject "B" with + | .ok obligations => obligations.any (fun obligation => + obligation.name == "step/p/WFIS" && obligation.goal.isSome) + | .error _ => false end EventB.POG diff --git a/EventB/Trust.lean b/EventB/Trust.lean index f43adb9..bd7eda8 100644 --- a/EventB/Trust.lean +++ b/EventB/Trust.lean @@ -24,6 +24,12 @@ def Mode.label : Mode → String | .external => "external-trusted" | .unproved => "unproved" +def Mode.rank : Mode → Nat + | .unproved => 0 + | .external | .rodinImported => 1 + | .smt => 2 + | .kernel => 3 + inductive Evidence where | none | kernel (declaration : String) (axioms : List String := []) @@ -55,10 +61,18 @@ structure Entry where component : String := "" obligation : String fingerprint : String + /-- Exact canonical source retained so local attachment does not rely on hash equality. -/ + canonical : String := "" + /-- Semantic context fingerprint required for kernel entries. -/ + semanticFingerprint : String := "" mode : Mode evidence : Evidence := .none deriving BEq, Repr, Inhabited +def Entry.isConsistent (entry : Entry) : Bool := + entry.mode == entry.evidence.mode && + (entry.mode == .unproved || entry.evidence.isWellFormed) + structure Ledger where entries : List Entry := [] deriving BEq, Repr, Inhabited @@ -66,32 +80,59 @@ structure Ledger where def Ledger.ofObligations (obligations : List POG.Obligation) : Ledger := { entries := obligations.map fun obligation => { component := obligation.component, obligation := obligation.name - fingerprint := fingerprint obligation.canonical, mode := .unproved } } + fingerprint := fingerprint obligation.canonical, canonical := obligation.canonical, + mode := .unproved } } -private def key (component name : String) : String := component ++ "\n" ++ name +private def sameEntry (entry : Entry) (component name : String) : Bool := + entry.component == component && entry.obligation == name def Ledger.entry? (ledger : Ledger) (component name : String) : Option Entry := - ledger.entries.find? (fun entry => key entry.component entry.obligation == key component name) + ledger.entries.find? (sameEntry · component name) def Ledger.attach (ledger : Ledger) (obligation : POG.Obligation) (evidence : Evidence) : Except EventB.Error Ledger := let expected := fingerprint obligation.canonical - if evidence matches .kernel .. then + if !obligation.diagnostics.isEmpty then + .error (EventB.Error.trust + s!"cannot attach evidence to `{obligation.component}:{obligation.name}` with diagnostics") + else if obligation.goal.isNone then + .error (EventB.Error.trust + s!"cannot attach evidence to statement-less obligation `{obligation.name}`") + else if evidence matches .kernel .. then .error (EventB.Error.trust "kernel evidence must be validated by Trust.Replay before ledger attachment") + else if evidence matches .rodinImported .. then + .error (EventB.Error.trust + "Rodin evidence must be attached through Trust.Rodin after artifact parsing") else if !evidence.isWellFormed then .error (EventB.Error.trust "evidence metadata is incomplete") else if ledger.entry? obligation.component obligation.name |>.isNone then .error (EventB.Error.trust s!"obligation `{obligation.component}:{obligation.name}` is not in the ledger") + else if ledger.entries.countP (sameEntry · obligation.component obligation.name) != 1 then + .error (EventB.Error.trust + s!"ledger has duplicate entries for `{obligation.component}:{obligation.name}`") + else if (ledger.entry? obligation.component obligation.name |>.get!).canonical != + obligation.canonical then + .error (EventB.Error.trust + s!"evidence canonical mismatch for `{obligation.component}:{obligation.name}`") else if (ledger.entry? obligation.component obligation.name |>.get!).fingerprint != expected then .error (EventB.Error.trust s!"evidence fingerprint mismatch for `{obligation.component}:{obligation.name}`") else - .ok { entries := ledger.entries.map fun entry => - if key entry.component entry.obligation == key obligation.component obligation.name then - { entry with mode := evidence.mode, evidence := evidence } - else entry } + let entry := ledger.entry? obligation.component obligation.name |>.get! + if !entry.isConsistent then + .error (EventB.Error.trust + s!"ledger entry for `{obligation.component}:{obligation.name}` is internally inconsistent") + else if entry.mode != .unproved && Mode.rank evidence.mode <= Mode.rank entry.mode then + .error (EventB.Error.trust + (s!"evidence for `{obligation.component}:{obligation.name}` cannot be replaced " ++ + "by equal or weaker evidence")) + else + .ok { entries := ledger.entries.map fun current => + if sameEntry current obligation.component obligation.name then + { current with mode := evidence.mode, evidence := evidence } + else current } def Ledger.count (ledger : Ledger) (mode : Mode) : Nat := ledger.entries.countP (·.mode == mode) @@ -118,20 +159,38 @@ private def sampleObligation : POG.Obligation := private def sampleLedger : Ledger := Ledger.ofObligations [sampleObligation] +private def inconsistentLedger : Ledger := + { entries := [{ sampleLedger.entries.head! with evidence := .kernel "forged" }] } + private def renamedSample : POG.Obligation := { sampleObligation with name := "display-only", kind := "INV" } -#guard sampleObligation.canonical == renamedSample.canonical +#guard sampleObligation.canonical != renamedSample.canonical #guard sampleObligation.canonical != { sampleObligation with goal := some (.id "⊥") }.canonical +#guard ({ sampleObligation with diagnostics := ["a\nb"] }).canonical != + ({ sampleObligation with diagnostics := ["a", "b"] }).canonical #guard match sampleLedger.attach sampleObligation (.external "sample" "1" "digest" "checker") with | .ok ledger => ledger.count .external == 1 | .error _ => false + +#guard match sampleLedger.attach sampleObligation + (.external "sample" "1" "digest" "checker") with + | .ok ledger => match ledger.attach sampleObligation + (.external "other" "1" "digest" "checker") with + | .error _ => true + | .ok _ => false + | .error _ => false #guard match sampleLedger.attach sampleObligation (.kernel "No.Such.Declaration") with | .error _ => true | .ok _ => false +#guard match Ledger.attach + inconsistentLedger + sampleObligation (.external "sample" "1" "digest" "checker") with + | .error _ => true + | .ok _ => false #guard match sampleLedger.attach { sampleObligation with goal := some (.id "⊥") } (.kernel "Sample.inv1") with | .error _ => true @@ -139,5 +198,9 @@ private def renamedSample : POG.Obligation := #guard match sampleLedger.attach sampleObligation (.kernel "") with | .error _ => true | .ok _ => false +#guard match sampleLedger.attach sampleObligation + (.rodinImported "status.bps" "digest" false) with + | .error _ => true + | .ok _ => false end EventB.Trust diff --git a/EventB/Trust/Replay.lean b/EventB/Trust/Replay.lean index 71426b4..7771ad1 100644 --- a/EventB/Trust/Replay.lean +++ b/EventB/Trust/Replay.lean @@ -8,6 +8,7 @@ explicitly trusted metadata; it is never reported as kernel replay. -/ import EventB.Trust +import EventB.Trust.Rodin import EventB.Formula.Translate namespace EventB.Trust.Replay @@ -51,6 +52,8 @@ def proofFingerprint (context : Embedding.KernelContext) (obligation : POG.Oblig private def proofTerm (declaration : String) : MetaM Expr := do let name := declarationName declaration let info ← getConstInfo name + if info.isUnsafe then + throwError s!"proof declaration `{declaration}` is unsafe" let proof ← mkConstWithLevelParams name let type ← inferType proof unless ← isDefEq type info.type do @@ -87,6 +90,8 @@ private def axiomNames (initial : List Name) : MetaM NameSet := do if !seen.contains name then seen := seen.insert name let info ← getConstInfo name + if info.isUnsafe then + throwError s!"kernel evidence depends on unsafe declaration `{name}`" if info matches .axiomInfo _ then axioms := axioms.insert name pending := pending ++ (declarationDependencies info).toList @@ -110,6 +115,10 @@ def validateTerm (context : Embedding.KernelContext) (obligation : POG.Obligation) (proof : Expr) (declaration : String := "") (declaredAxioms : List String := []) : MetaM Report := do + unless obligation.diagnostics.isEmpty do + throwError s!"obligation `{obligation.name}` has diagnostics" + unless obligation.goal.isSome do + throwError s!"obligation `{obligation.name}` has no translated goal" if proof.hasMVar then throwError s!"kernel proof `{declaration}` contains unresolved metavariables" let expected ← translateStatement context obligation @@ -117,6 +126,8 @@ def validateTerm (context : Embedding.KernelContext) unless ← isDefEq proofType expected do throwError s!"proof term does not prove `{obligation.name}`" let actualAxioms ← actualAxioms proof + unless !actualAxioms.contains "sorryAx" do + throwError s!"kernel proof `{declaration}` depends on forbidden axiom `sorryAx`" let declared := declaredAxioms.map fun name => (name.toName).toString false unless actualAxioms == declared.mergeSort (· < ·) do throwError s!"axiom metadata mismatch for `{declaration}`: declared " ++ @@ -134,7 +145,30 @@ private def replayKernel (context : Embedding.KernelContext) def validate (context : Embedding.KernelContext) (obligation : POG.Obligation) : Evidence → MetaM Report | evidence@(.kernel ..) => replayKernel context obligation evidence + | evidence@(.rodinImported source digest manual) => do + unless digest == s!"eventb-v1-{String.hash source}" do + throwError "Rodin evidence artifact digest mismatch" + let statuses ← match Rodin.importStatuses source with + | .ok statuses => pure statuses + | .error error => throwError error.message + match statuses.find? (fun status => status.name == obligation.name) with + | none => + throwError s!"Rodin evidence artifact has no status for `{obligation.name}`" + | some status => + unless status.discharged do + throwError s!"Rodin evidence status for `{obligation.name}` is not discharged" + unless status.manual == manual do + throwError s!"Rodin evidence manual flag mismatch for `{obligation.name}`" + unless obligation.diagnostics.isEmpty do + throwError s!"obligation `{obligation.name}` has diagnostics" + unless obligation.goal.isSome do + throwError s!"obligation `{obligation.name}` has no translated goal" + pure { mode := evidence.mode, fingerprint := proofFingerprint context obligation } | evidence => do + unless obligation.diagnostics.isEmpty do + throwError s!"obligation `{obligation.name}` has diagnostics" + unless obligation.goal.isSome do + throwError s!"obligation `{obligation.name}` has no translated goal" unless evidence.isWellFormed do throwError "evidence metadata is incomplete" pure { mode := evidence.mode, fingerprint := proofFingerprint context obligation } @@ -145,8 +179,13 @@ def validateEntry (context : Embedding.KernelContext) (obligation : POG.Obligati throwError s!"evidence entry does not identify `{obligation.component}:{obligation.name}`" unless entry.fingerprint == Trust.fingerprint obligation.canonical do throwError s!"evidence fingerprint mismatch for `{obligation.component}:{obligation.name}`" + unless entry.canonical == obligation.canonical do + throwError s!"evidence canonical mismatch for `{obligation.component}:{obligation.name}`" unless entry.mode == entry.evidence.mode do throwError s!"evidence mode mismatch for `{obligation.component}:{obligation.name}`" + if entry.mode == .kernel then + unless entry.semanticFingerprint == proofFingerprint context obligation do + throwError s!"kernel evidence context mismatch for `{obligation.component}:{obligation.name}`" validate context obligation entry.evidence #guard ({ mode := .kernel, replayed := true, declaration := "proof" } : Report).replayed @@ -162,6 +201,8 @@ theorem propextTrue : True := by def testInt : Int := 0 +unsafe def unsafeTrue : True := True.intro + theorem reflexive (value : Int) : value = value := rfl end TestFixtures @@ -203,6 +244,9 @@ private meta def checkReplay : TermElabM Unit := do unless !(← succeeds (validate context replayObligation (.kernel "EventB.Trust.Replay.missing" []))) do throwError "unresolved proof declaration was accepted" + unless !(← succeeds (validate context replayObligation + (.kernel "EventB.Trust.Replay.TestFixtures.unsafeTrue" []))) do + throwError "unsafe proof declaration was accepted" let target ← translateStatement context replayObligation let openProof ← mkFreshExprMVar target unless !(← succeeds (validateTerm context replayObligation openProof)) do @@ -219,19 +263,34 @@ private meta def checkReplay : TermElabM Unit := do (.external "alt-ergo" "2" "sha256:po" "eventb-checker") unless external.mode == .external && !external.replayed do throwError "external evidence was reported as replayed" + let rodinSource := "" let rodin ← validate context replayObligation - (.rodinImported "model.bps" "sha256:status" true) + (.rodinImported rodinSource (Trust.fingerprint rodinSource) true) unless rodin.mode == .rodinImported && !rodin.replayed do throwError "Rodin evidence was reported as replayed" + unless !(← succeeds (validate context replayObligation + (.rodinImported rodinSource (Trust.fingerprint rodinSource) false))) do + throwError "Rodin manual flag mismatch was accepted" + unless !(← succeeds (validate context replayObligation + (.rodinImported rodinSource "forged" true))) do + throwError "forged Rodin artifact digest was accepted" let entry : Entry := { component := replayObligation.component obligation := replayObligation.name fingerprint := Trust.fingerprint replayObligation.canonical + canonical := replayObligation.canonical + semanticFingerprint := proofFingerprint context replayObligation mode := .kernel evidence := evidence } let entryReport ← validateEntry context replayObligation entry unless entryReport.replayed do throwError "valid ledger evidence did not replay" + unless !(← succeeds (validateEntry + { bindings := [{ name := "different", ty := .int, value := mkConst ``TestFixtures.testInt }] } + replayObligation entry)) do + throwError "kernel evidence accepted a different semantic context" unless !(← succeeds (validateEntry context { replayObligation with goal := some (.id "⊥") } entry)) do throwError "stale ledger evidence was accepted" @@ -241,6 +300,10 @@ private meta def checkReplay : TermElabM Unit := do unless !(← succeeds (validate context replayObligation (.external "" "1" "digest" "checker"))) do throwError "incomplete external metadata was accepted" + unless !(← succeeds (validate context + { replayObligation with goal := none } + (.external "checker" "1" "digest" "verifier"))) do + throwError "statement-less external evidence was accepted" unless !(← succeeds (validate context replayObligation (.rodinImported "" "digest" false))) do throwError "incomplete Rodin metadata was accepted" diff --git a/EventB/Trust/Rodin.lean b/EventB/Trust/Rodin.lean index 432b3fe..8087854 100644 --- a/EventB/Trust/Rodin.lean +++ b/EventB/Trust/Rodin.lean @@ -15,6 +15,12 @@ structure Status where def Status.discharged (status : Status) : Bool := status.confidence > 0 +structure Provenance where + model : String + bpo : String + statuses : String + deriving BEq, Repr, Inhabited + structure Comparison where expected : Nat discharged : Nat @@ -22,6 +28,9 @@ structure Comparison where manual : Nat missing : Nat stale : Nat + /-- True when the caller compared multiple component scopes against an unscoped + proof-status artifact; names alone cannot safely identify those obligations. -/ + scopeAmbiguous : Bool := false deriving BEq, Repr, Inhabited private def attr (elem : XmlElem) (name : String) : Except String String := @@ -88,31 +97,112 @@ def importStatuses (source : String) : Except EventB.Error (List Status) := do private def status? (statuses : List Status) (name : String) : Option Status := statuses.find? (·.name == name) +private def duplicateKeys (seen : List String) : List String → List String + | [] => [] + | key :: rest => + if seen.contains key then key :: duplicateKeys seen rest + else duplicateKeys (key :: seen) rest + def compare (obligations : List POG.Obligation) (statuses : List Status) : Comparison := - let expected := obligations.map (·.name) - let present := obligations.filterMap fun obligation => + let eligible := obligations.filter fun obligation => + obligation.diagnostics.isEmpty && obligation.goal.isSome + let expected := eligible.map (·.name) + let duplicateExpected := duplicateKeys [] (eligible.map fun obligation => + obligation.component ++ "\t" ++ obligation.name) + let scopeAmbiguous := (eligible.map (·.component)).eraseDups.length > 1 || + !duplicateExpected.isEmpty + let present := if scopeAmbiguous then [] else eligible.filterMap fun obligation => match status? statuses obligation.name with | some status => if status.discharged then some (obligation.name, status) else none | none => none - { expected := obligations.length + { expected := eligible.length discharged := present.length automatic := present.countP (·.2.manual == false) manual := present.countP (·.2.manual) - missing := obligations.countP (status? statuses ·.name |>.isNone) + missing := if scopeAmbiguous then eligible.length + else eligible.countP (status? statuses ·.name |>.isNone) + scopeAmbiguous := scopeAmbiguous stale := statuses.countP (fun status => !expected.contains status.name) } -def attach (ledger : Ledger) (obligation : POG.Obligation) (source : String) - (status : Status) : Except EventB.Error Ledger := - if status.name != obligation.name then - .error (EventB.Error.trust s! - "proof-status `{status.name}` does not identify obligation `{obligation.name}`") - else if status.confidence == 0 then - .error (EventB.Error.trust s!"proof-status `{status.name}` has zero confidence") - else if status.discharged then - let evidence := .rodinImported source (s!"eventb-v1-{String.hash source}") status.manual - ledger.attach obligation evidence +private def attachVerified (ledger : Ledger) (obligation : POG.Obligation) + (source : String) (manual : Bool) : Except EventB.Error Ledger := + let evidence := .rodinImported source (s!"eventb-v1-{String.hash source}") manual + if !obligation.diagnostics.isEmpty then + .error (EventB.Error.trust "cannot attach Rodin evidence to an obligation with diagnostics") + else if obligation.goal.isNone then + .error (EventB.Error.trust "cannot attach Rodin evidence to a statement-less obligation") + else if ledger.entry? obligation.component obligation.name |>.isNone then + .error (EventB.Error.trust s!"obligation `{obligation.name}` is not in the ledger") + else if ledger.entries.countP (fun entry => + entry.component == obligation.component && entry.obligation == obligation.name) != 1 then + .error (EventB.Error.trust s!"ledger has duplicate entries for `{obligation.name}`") else - .error (EventB.Error.trust s!"proof-status `{status.name}` is not discharged") + let entry := ledger.entry? obligation.component obligation.name |>.get! + if !entry.isConsistent then + .error (EventB.Error.trust + s!"ledger entry for `{obligation.component}:{obligation.name}` is internally inconsistent") + else if entry.canonical != obligation.canonical then + .error (EventB.Error.trust "Rodin evidence canonical mismatch") + else if entry.fingerprint != Trust.fingerprint obligation.canonical then + .error (EventB.Error.trust "Rodin evidence fingerprint mismatch") + else if entry.mode != .unproved && Mode.rank .rodinImported <= Mode.rank entry.mode then + .error (EventB.Error.trust + s!"Rodin evidence cannot replace `{obligation.component}:{obligation.name}`") + else + .ok { entries := ledger.entries.map fun current => + if current.component == obligation.component && current.obligation == obligation.name then + { current with mode := .rodinImported, evidence := evidence } + else current } + +private partial def hasPoSequent : XmlElem → String → Bool + | elem, name => + (elem.tag == "org.eventb.core.poSequent" && elem.attr? "name" == some name) || + elem.children.any (fun child => hasPoSequent child name) + +private def rootModelName (source : String) : Except EventB.Error String := do + let root ← match parseXmlString source with + | .ok root => pure root + | .error error => .error (EventB.Error.trust + s!"invalid model XML: {error.pretty source.toUTF8}") + match root.attr? "org.eventb.core.name" with + | some name => pure name + | none => .error (EventB.Error.trust "model XML has no component name") + +def attachProvenance (ledger : Ledger) (obligation : POG.Obligation) + (provenance : Provenance) (status : Status) : Except EventB.Error Ledger := do + let modelName ← rootModelName provenance.model + unless modelName == obligation.component do + throw (EventB.Error.trust s! + "Rodin model provenance names `{modelName}`, expected `{obligation.component}`") + let bpo ← match parseXmlString provenance.bpo with + | .ok root => pure root + | .error error => .error (EventB.Error.trust + s!"invalid PO XML: {error.pretty provenance.bpo.toUTF8}") + unless hasPoSequent bpo obligation.name do + throw (EventB.Error.trust s! + "Rodin PO artifact has no sequent for `{obligation.name}`") + unless (provenance.bpo.splitOn (obligation.component ++ ".bum")).length > 1 do + throw (EventB.Error.trust + "Rodin PO artifact is not bound to the stated model component") + let statuses ← importStatuses provenance.statuses + match status? statuses obligation.name with + | none => .error (EventB.Error.trust s! + "proof-status artifact has no status for `{obligation.name}`") + | some imported => + if imported != status then + .error (EventB.Error.trust s! + "supplied proof status does not match the parsed artifact for `{obligation.name}`") + else if status.confidence == 0 then + .error (EventB.Error.trust s!"proof-status `{status.name}` has zero confidence") + else if status.discharged then + attachVerified ledger obligation provenance.statuses status.manual + else + .error (EventB.Error.trust s!"proof-status `{status.name}` is not discharged") + +def attach (_ledger : Ledger) (_obligation : POG.Obligation) (_source : String) + (_status : Status) : Except EventB.Error Ledger := + .error (EventB.Error.trust + "Rodin.attach requires model, PO, and proof-status provenance; use attachProvenance") private def sampleObligation : POG.Obligation := { component := "Sample", name := "evt/inv/INV", kind := "INV", goal := some (.id "⊤") } @@ -123,6 +213,14 @@ private def sampleSource := "org.eventb.core.confidence=\"1000\" org.eventb.core.psManual=\"true\"/>" ++ "" +private def sampleProvenance : String → Provenance := fun statuses => + { model := "" + bpo := "" ++ + "" + statuses } + #guard match importStatuses sampleSource with | .ok [status] => status.name == sampleObligation.name && status.discharged && status.manual | _ => false @@ -154,11 +252,17 @@ private def sampleSource := | .ok _ => false #guard match attach (Ledger.ofObligations [sampleObligation]) - sampleObligation "sample.bps" + sampleObligation sampleSource { name := "other/INV", confidence := 1000, manual := false } with | .error _ => true | .ok _ => false +#guard match attach (Ledger.ofObligations [sampleObligation]) + sampleObligation sampleSource + { name := sampleObligation.name, confidence := 999, manual := false } with + | .error _ => true + | .ok _ => false + #guard match importStatuses sampleSource with | .ok statuses => let comparison := compare [sampleObligation] statuses @@ -166,10 +270,42 @@ private def sampleSource := | _ => false #guard match importStatuses sampleSource with - | .ok [status] => match attach (Ledger.ofObligations [sampleObligation]) - sampleObligation "sample.bps" status with + | .ok statuses => + let other := { sampleObligation with component := "Other" } + let comparison := compare [sampleObligation, other] statuses + comparison.scopeAmbiguous && comparison.discharged == 0 + | _ => false + +#guard match importStatuses sampleSource with + | .ok statuses => + let duplicate := compare [sampleObligation, sampleObligation] statuses + duplicate.scopeAmbiguous && duplicate.discharged == 0 + | _ => false + +#guard match importStatuses sampleSource with + | .ok statuses => + let invalid := { sampleObligation with diagnostics := ["unresolved"] } + let comparison := compare [invalid] statuses + comparison.expected == 0 && comparison.discharged == 0 + | _ => false + +#guard match importStatuses sampleSource with + | .ok [status] => match attachProvenance (Ledger.ofObligations [sampleObligation]) + sampleObligation (sampleProvenance sampleSource) status with | .ok ledger => ledger.count .rodinImported == 1 | .error _ => false | _ => false +#guard match importStatuses sampleSource with + | .ok [status] => + match attachProvenance (Ledger.ofObligations [sampleObligation]) sampleObligation + (sampleProvenance sampleSource) status with + | .ok ledger => + match Trust.Ledger.attach ledger sampleObligation + (.external "stronger" "1" "digest" "checker") with + | .ok _ => false + | .error _ => true + | .error _ => false + | _ => false + end EventB.Trust.Rodin diff --git a/EventB/Typing/Check.lean b/EventB/Typing/Check.lean index 2aab844..39da7c3 100644 --- a/EventB/Typing/Check.lean +++ b/EventB/Typing/Check.lean @@ -40,17 +40,261 @@ private def attrOf (e : Elem) (key : String) : Option String := private def labelOf (e : Elem) : String := (attrOf e "label").getD "" -/-- `target` is a workspace path such as `/Abstraction/M1_Landing_Sequence_Ctx`; only the -last segment names the component. -/ private def targetName (e : Elem) : Option String := (attrOf e "target").map (fun t => (t.splitOn "/").getLast!) -private def eventParentName (ev : Elem) : Option String := - match (childrenOf ev "refinesEvent").filterMap targetName |>.head? with - | some target => some target - | none => if (attrOf ev "extended").getD "false" == "true" then some (labelOf ev) else none +private def eventTargets (ev : Elem) : List String := + if labelOf ev == "INITIALISATION" then ["INITIALISATION"] + else (childrenOf ev "refinesEvent").filterMap targetName + +private def isExtended (ev : Elem) : Bool := + (attrOf ev "extended").getD "false" == "true" || + (childrenOf ev "refinesEvent").any + (fun reference => (attrOf reference "extended").getD "false" == "true") + +private def assignmentTargets (action : Elem) : List String := + match attrOf action "assignment" with + | none => [] + | some source => + match Formula.parse source with + | .error _ => [] + | .ok (.bin op lhs _) => + if op == "≔" then + match lhs with + | .app (.id functionName) _ => [functionName] + | _ => Formula.flattenCommas lhs |>.filterMap fun term => + match term with + | .id name => some name + | .app (.id functionName) _ => some functionName + | _ => none + else if op == ":∈" || op == ":∣" then + Formula.flattenCommas lhs |>.filterMap fun term => + match term with | .id name => some name | _ => none + else [] + | .ok _ => [] + +private def assignmentShapeErrors (action : Elem) : List String := + match attrOf action "assignment" with + | none => [] + | some source => + match Formula.parse source with + | .ok (.bin op lhs rhs) => + let left := Formula.flattenCommas lhs + let validDeterministic := left.all fun term => + match term with + | .id _ | .app (.id _) _ => true + | _ => false + let validTargets := left.all fun term => + match term with | .id _ => true | _ => false + if op == "≔" then + (if left.length != (Formula.flattenCommas rhs).length then + ["parallel assignment has different target and expression arity"] else []) ++ + (if validDeterministic then [] else + ["assignment target is not an identifier or function application"]) + else if op == ":∈" || op == ":∣" then + if validTargets then [] else ["nondeterministic assignment target is not an identifier"] + else [s!"unsupported assignment operator {op}"] + | .ok _ => ["assignment is not a binary Event-B assignment"] + | .error error => [s!"assignment parse: {EventB.Error.render error}"] + +private def duplicateNames (seen : List String) : List String → List String + | [] => [] + | name :: rest => + if seen.contains name then name :: duplicateNames seen rest + else duplicateNames (name :: seen) rest + +private def rawInitializationActions (p : Project) : Nat → String → Elem → List Elem + | 0, _, ev => childrenOf ev "action" + | depth + 1, machine, ev => + let own := childrenOf ev "action" + let inherited := eventTargets ev |>.flatMap fun target => + (lookupComponent p machine).toList.flatMap fun current => + (childrenOf current.elem "refinesMachine").filterMap targetName |>.flatMap + fun parentName => + (lookupComponent p parentName).toList.flatMap fun parent => + (childrenOf parent.elem "event").find? (fun candidate => labelOf candidate == target) + |>.toList.flatMap (rawInitializationActions p depth parentName) + inherited ++ own + +def initializationActions (p : Project) (c : Component) (ev : Elem) : List Elem := + let actions := childrenOf ev "action" + if labelOf ev != "INITIALISATION" then actions + else + let assigned := rawInitializationActions p p.length c.name ev |>.flatMap assignmentTargets + let variables := (childrenOf c.elem "variable").filterMap (attrOf · "identifier") + actions ++ (variables.filter (fun v => !assigned.contains v)).map fun v => + .action [("org.eventb.core.label", "__default_" ++ v), + ("org.eventb.core.assignment", v ++ " :∣ ⊤")] [] + +private def eventParameterNames (ev : Elem) : List String := + (childrenOf ev "parameter").filterMap (attrOf · "identifier") + +private def validVariantType : Ty → Bool + | .int => true + | .pow (.mvar _) => false + | .pow _ => true + | _ => false -private def inheritedEventParams (p : Project) : Nat → String → String → List String +private def actionTexts (actions : List Elem) : List String := + actions.filterMap (attrOf · "assignment") + +private def allEqual : List (List String) → Bool + | [] => true + | first :: rest => rest.all (· == first) + +private def refinementCycle (p : Project) : Nat → List String → String → Bool + | 0, _, _ => true + | fuel + 1, seen, name => + if seen.contains name then true + else + match lookupComponent p name with + | none => false + | some component => + match (childrenOf component.elem "refinesMachine").filterMap targetName with + | [] => false + | [parent] => refinementCycle p fuel (name :: seen) parent + | _ => false + +private def dependencyCycle (p : Project) : Nat → List String → String → Bool + | 0, _, _ => true + | fuel + 1, seen, name => + if seen.contains name then true + else + match lookupComponent p name with + | none => false + | some component => + let dependencies := + (childrenOf component.elem "extendsContext" ++ + childrenOf component.elem "seesContext" ++ + childrenOf component.elem "refinesMachine").filterMap targetName + dependencies.any (dependencyCycle p fuel (name :: seen)) + +private def effectiveEventActions (p : Project) : Nat → String → Elem → List Elem + | 0, machine, ev => + match lookupComponent p machine with + | some component => initializationActions p component ev + | none => childrenOf ev "action" + | depth + 1, machine, ev => + let own := match lookupComponent p machine with + | some component => initializationActions p component ev + | none => childrenOf ev "action" + if !isExtended ev then own + else + let inherited := eventTargets ev |>.flatMap fun target => + (lookupComponent p machine).toList.flatMap fun current => + (childrenOf current.elem "refinesMachine").filterMap targetName |>.flatMap + fun parentName => + (lookupComponent p parentName).toList.flatMap fun parent => + (childrenOf parent.elem "event").find? + (fun candidate => labelOf candidate == target) + |>.toList.flatMap (effectiveEventActions p depth parentName) + own ++ inherited + +private def componentReferenceErrors (p : Project) (c : Component) : List String := + let refs := childrenOf c.elem "extendsContext" ++ childrenOf c.elem "seesContext" ++ + childrenOf c.elem "refinesMachine" + let componentErrors := (refs.filterMap targetName).filterMap fun target => + if lookupComponent p target |>.isSome then none + else some s!"unresolved component reference {target} from {c.name}" + let parentNames := (childrenOf c.elem "refinesMachine").filterMap targetName + let variableNames := (childrenOf c.elem "variable").filterMap (attrOf · "identifier") + let constantNames := (childrenOf c.elem "constant").filterMap (attrOf · "identifier") + let setNames := (childrenOf c.elem "carrierSet").filterMap (attrOf · "identifier") + let namespaceNames := constantNames ++ setNames + let namespaceErrors := + (duplicateNames [] variableNames).map (fun name => + s!"duplicate variable declaration {name} in {c.name}") ++ + variableNames.filter (fun name => namespaceNames.contains name) |>.map (fun name => + s!"variable {name} in {c.name} collides with a constant or carrier set") + let eventNamespaceErrors := (childrenOf c.elem "event").flatMap fun ev => + let params := eventParameterNames ev + (duplicateNames [] params).map (fun name => + s!"duplicate event parameter {name} in {c.name}/{labelOf ev}") ++ + params.filter (fun name => variableNames.contains name || namespaceNames.contains name) + |>.map (fun name => + s!"event parameter {name} in {c.name}/{labelOf ev} collides with a declaration") + let initializationErrors := + if c.elem.tag == "org.eventb.core.machineFile" then + let count := (childrenOf c.elem "event").countP (fun ev => labelOf ev == "INITIALISATION") + if count == 1 then [] else + [s!"machine {c.name} must have exactly one INITIALISATION event"] + else [] + let graphErrors := + (if parentNames.length > 1 then + [s!"component {c.name} has multiple refinement parents"] else []) ++ + (if refinementCycle p (p.length + 1) [] c.name then + [s!"refinement cycle reaches {c.name}"] else []) + ++ (if dependencyCycle p (p.length + 1) [] c.name then + [s!"component dependency cycle reaches {c.name}"] else []) + let eventErrors := childrenOf c.elem "event" |>.flatMap fun ev => + (childrenOf ev "refinesEvent").filterMap targetName |>.flatMap fun target => + if parentNames.any fun parentName => + match lookupComponent p parentName with + | none => false + | some parent => (childrenOf parent.elem "event").any + (fun candidate => labelOf candidate == target) then [] + else [s!"unresolved event reference {target} from {c.name}/{labelOf ev}"] + let convergenceErrors := childrenOf c.elem "event" |>.flatMap fun ev => + (childrenOf ev "refinesEvent").filterMap targetName |>.flatMap fun target => + parentNames.flatMap fun parentName => + match lookupComponent p parentName with + | none => [] + | some parent => + match (childrenOf parent.elem "event").find? + (fun candidate => labelOf candidate == target) with + | some abstractEvent => + if (attrOf abstractEvent "convergence").getD "0" == "2" && + (attrOf ev "convergence").getD "0" == "0" then + [s!"ordinary event {c.name}/{labelOf ev} cannot refine anticipated " ++ + s!"event {target}"] + else [] + | none => [] + let mergeErrors := childrenOf c.elem "event" |>.flatMap fun ev => + let refs := (childrenOf ev "refinesEvent").filterMap targetName + if refs.length <= 1 then [] + else + match parentNames.head?.bind (lookupComponent p ·) with + | none => [] + | some parent => + let abstractEvents := refs.filterMap fun target => + (childrenOf parent.elem "event").find? (fun candidate => labelOf candidate == target) + if abstractEvents.length != refs.length then [] + else + let mergePrefix := s!"merged event {c.name}/{labelOf ev}" + (if allEqual (abstractEvents.map (fun abstractEvent => + actionTexts (effectiveEventActions p p.length parent.name abstractEvent))) then [] + else [mergePrefix ++ " refines abstract events with different actions"]) ++ + (if allEqual (abstractEvents.map eventParameterNames) then [] + else [mergePrefix ++ " refines abstract events with different parameters"]) + componentErrors ++ namespaceErrors ++ eventNamespaceErrors ++ initializationErrors ++ + graphErrors ++ eventErrors ++ convergenceErrors ++ mergeErrors + +private def theoryReferenceErrors (theory : Theory.Env) (roots : List String) : List String := + let rec visit (fuel : Nat) (seen : List String) (name : String) : List String := + match fuel with + | 0 => [] + | fuel + 1 => + if seen.contains name then [] + else match Theory.lookupTheory? theory name with + | none => [s!"unresolved theory reference {name}"] + | some spec => spec.imports.flatMap (visit fuel (name :: seen)) + roots.flatMap (visit (theory.theories.length + roots.length + 1) []) + +private def eventParamBindings + (records : List ((String × String) × List (String × Ty))) + (component event : String) : List (String × Ty) := + (records.find? (fun record => record.1.1 == component && record.1.2 == event)).map + (·.2) |>.getD [] + +private def dedupBindings (seen : List String) : List (String × Ty) → List (String × Ty) + | [] => [] + | binding :: rest => + if seen.contains binding.1 then dedupBindings seen rest + else binding :: dedupBindings (binding.1 :: seen) rest + +private def inheritedEventBindings + (p : Project) (records : List ((String × String) × List (String × Ty))) : + Nat → String → String → List (String × Ty) | 0, _, _ => [] | depth + 1, machine, event => match lookupComponent p machine with @@ -60,22 +304,25 @@ private def inheritedEventParams (p : Project) : Nat → String → String → L labelOf candidate == event) with | none => [] | some currentEvent => - match eventParentName currentEvent with - | none => [] - | some parentEventName => - match (childrenOf current.elem "refinesMachine").filterMap targetName |>.head? with - | none => [] - | some parentName => - match lookupComponent p parentName with - | none => [] - | some parent => - match (childrenOf parent.elem "event").find? (fun candidate => - labelOf candidate == parentEventName) with - | none => [] - | some parentEvent => - let own := (childrenOf parentEvent "parameter").filterMap - (attrOf · "identifier") - own ++ inheritedEventParams p depth parentName parentEventName + let targets := eventTargets currentEvent + let parents := (childrenOf current.elem "refinesMachine").filterMap targetName + let collected := parents.flatMap fun parentName => + match lookupComponent p parentName with + | none => [] + | some parent => + targets.flatMap fun parentEventName => + if (childrenOf parent.elem "event").any (fun candidate => + labelOf candidate == parentEventName) then + eventParamBindings records parentName parentEventName ++ + inheritedEventBindings p records depth parentName parentEventName + else [] + dedupBindings [] collected + +def visibleEventBindings + (p : Project) (records : List ((String × String) × List (String × Ty))) + (component event : String) : List (String × Ty) := + eventParamBindings records component event ++ + inheritedEventBindings p records p.length component event /-- Contexts and machines a component depends on, deepest first, without repeats. @@ -85,9 +332,9 @@ a chain that reaches it has revisited one, meaning the dependency graph has a cy def closureAux (p : Project) : Nat → List String → String → List String × List String | 0, visited, _ => (visited, []) | depth + 1, visited, name => - if visited.contains name then (visited, []) else + if visited.contains name then (visited, []) else match lookupComponent p name with - | none => (name :: visited, []) + | none => (name :: visited, [name]) | some c => let deps := (childrenOf c.elem "extendsContext" ++ childrenOf c.elem "seesContext" @@ -112,7 +359,7 @@ def componentTheoryRoots (p : Project) (name : String) : List String := /-- Declare the identifiers a component introduces, then feed every predicate it states to the checker. Errors are collected rather than thrown: one unsupported guard should cost that guard's constraints, not the whole file's types. -/ -private def addComponent (p : Project) (c : Component) : M (List String) := do +private def addComponentMode (strict : Bool) (p : Project) (c : Component) : M (List String) := do let mut errs : List String := [] -- Carrier sets and constants first, so axioms can refer to them in any order. for s in childrenOf c.elem "carrierSet" do @@ -132,37 +379,83 @@ private def addComponent (p : Project) (c : Component) : M (List String) := do for a in predicates do if let some f := attrOf a "predicate" then errs := errs ++ (← runPredicate f) + for variant in childrenOf c.elem "variant" do + if let some f := attrOf variant "expression" then + errs := errs ++ (← runExpression f) + let hasConvergent := (childrenOf c.elem "event").any + (fun event => (attrOf event "convergence").getD "0" == "1") + if hasConvergent && (childrenOf c.elem "variant").isEmpty then + errs := errs ++ [s!"convergent event in {c.name} requires an explicit variant"] -- Each event's parameters are scoped to that event. for ev in childrenOf c.elem "event" do let ownParams := (childrenOf ev "parameter").filterMap (attrOf · "identifier") - let inheritedParams := inheritedEventParams p p.length c.name (labelOf ev) + let records := (← get).eventParams + let actionTargets := effectiveEventActions p p.length c.name ev |>.flatMap assignmentTargets + let ownActionTargets := initializationActions p c ev |>.flatMap assignmentTargets + let variables := (childrenOf c.elem "variable").filterMap (attrOf · "identifier") + errs := errs ++ (initializationActions p c ev).flatMap assignmentShapeErrors |>.map fun error => + s!"{error} in {c.name}/{labelOf ev}" + errs := errs ++ + (ownActionTargets.filter (fun target => !variables.contains target)).map fun target => + s!"assignment target {target} is not a variable in {c.name}/{labelOf ev}" + errs := errs ++ (duplicateNames [] actionTargets).map fun target => + s!"duplicate assignment target {target} in {c.name}/{labelOf ev}" + let inheritedParams := inheritedEventBindings p records p.length c.name (labelOf ev) + let parentNames := (childrenOf c.elem "refinesMachine").filterMap targetName + let mergedRefs := (childrenOf ev "refinesEvent").filterMap targetName + if labelOf ev == "INITIALISATION" then + if !ownParams.isEmpty then + errs := errs ++ [s!"INITIALISATION in {c.name} must not declare parameters"] + if !(childrenOf ev "guard").isEmpty then + errs := errs ++ [s!"INITIALISATION in {c.name} must not declare guards"] + if mergedRefs.length > 1 then + match parentNames.head? with + | some parentName => + let signatures ← mergedRefs.mapM fun target => do + (eventParamBindings records parentName target).mapM fun (n, t) => do + let t ← zonk t + pure (n ++ ":" ++ t.print) + if !allEqual signatures then + errs := errs ++ + [s!"merged event {c.name}/{labelOf ev} refines abstract events with " ++ + "different parameter types"] + | none => pure () let (eventErrors, bound) ← withEnvBindings do let mut eventErrors : List String := [] - -- A refining event's witnesses and predicates can mention the parameters of the - -- abstract event. They are lexical inputs to this check, not project-global names. - for name in inheritedParams do - let st ← get - match st.params.find? (fun pair => pair.1 == name) with - | some (_, ty) => bind name ty - | none => eventErrors := eventErrors ++ - [s!"unresolved abstract event parameter {name}"] + -- Compatibility inference mirrors the pinned corpus. Strict inference keeps + -- abstract parameters available only while checking witness predicates. + if !strict then + for (name, ty) in inheritedParams do bind name ty for prm in childrenOf ev "parameter" do if let some n := attrOf prm "identifier" then bind n (← fresh) for g in childrenOf ev "guard" do if let some f := attrOf g "predicate" then eventErrors := eventErrors ++ (← runPredicate f) - for act in childrenOf ev "action" do + for act in initializationActions p c ev do if let some f := attrOf act "assignment" then eventErrors := eventErrors ++ (← runPredicate f) - for w in childrenOf ev "witness" do - if let some f := attrOf w "predicate" then - eventErrors := eventErrors ++ (← runPredicate f) + if strict then + let witnessErrors ← withEnv do + for (name, ty) in inheritedParams do bind name ty + let mut errors : List String := [] + for w in childrenOf ev "witness" do + if let some f := attrOf w "predicate" then + errors := errors ++ (← runPredicate f) + return errors + eventErrors := eventErrors ++ witnessErrors + else + for w in childrenOf ev "witness" do + if let some f := attrOf w "predicate" then + eventErrors := eventErrors ++ (← runPredicate f) return eventErrors errs := errs ++ eventErrors -- Parameters leave the environment so a later event cannot see them, but they are -- kept in `params` because the `.bpo` records their types alongside the variables. + let ownBound := bound.filter (fun pair => ownParams.contains pair.1) modify fun s => - { s with params := s.params ++ bound.filter (fun pair => ownParams.contains pair.1) } + { s with + params := s.params ++ ownBound + eventParams := s.eventParams ++ [((c.name, labelOf ev), ownBound)] } return errs where /-- Reuse the existing type if the name is already declared, so a refinement does not @@ -185,36 +478,239 @@ where -- Keep the pre-error state: a half-applied unification is worse than none. | .error e => return [s!"{e}"] -/-- Infer every identifier type visible in `name`, as Rodin would record them. -/ -def inferComponentIn (theory : Theory.Env) (p : Project) (name : String) : - Except EventB.Error (List (String × Ty) × List String) := + runExpression (f : String) : M (List String) := do + match Formula.parse f with + | .error e => return [s!"parse: {EventB.Error.render e}"] + | .ok term => + let st ← get + match (inferExpr term).run st with + | .ok (ty, st') => + match (zonk ty).run st' with + | .ok (zoned, st'') => + set st'' + if validVariantType zoned then return [] + else return ["variant expression must have integer or set type"] + | .error e => return [s!"{e}"] + | .error e => return [s!"{e}"] + +structure ComponentInference where + types : List (String × Ty) + eventParams : List ((String × String) × List (String × Ty)) + diagnostics : List String + +private def containsMVar : Ty → Bool + | .mvar _ => true + | .given _ | .int | .bool => false + | .pow t => containsMVar t + | .prod a b => containsMVar a || containsMVar b + +/-- Infer every identifier type visible in `name`, retaining event-local bindings for +POG consumers that must resolve repeated parameter names by lexical scope. -/ +private def inferComponentDetailsModeIn (strict : Bool) (theory : Theory.Env) (p : Project) + (name : String) : + Except EventB.Error ComponentInference := let (_, order) := closure p [] name let roots := componentTheoryRoots p name - let run : StateT St (Except String) (List (String × Ty) × List String) := do - let mut errs : List String := [] + let run : StateT St (Except String) ComponentInference := do + let mut errs : List String := theoryReferenceErrors theory roots for dep in order do if let some c := lookupComponent p dep then - errs := errs ++ (← addComponent p c) + errs := errs ++ componentReferenceErrors p c ++ (← addComponentMode strict p c) + else + errs := errs ++ [s!"unresolved component reference {dep}"] let st ← get let env := st.env ++ st.params let mut out : List (String × Ty) := [] for (n, t) in env do if out.all (fun q => q.1 != n) then - out := out ++ [(n, ← zonk t)] - return (out, errs) + let t ← zonk t + if containsMVar t then + errs := errs ++ [s!"unresolved type for {n} in {name}"] + else + out := out ++ [(n, t)] + let eventParams ← st.eventParams.mapM fun (key, bindings) => do + let bindings ← bindings.mapM fun (n, t) => do + let t ← zonk t + if containsMVar t then + throw s!"unresolved type for event parameter {n} in {key.1}/{key.2}" + pure (n, t) + pure (key, bindings) + return { types := out, eventParams, diagnostics := errs } match run.run' { theory, theoryRoots := roots } with | .ok result => .ok result | .error error => .error (EventB.Error.typing error) +def inferComponentDetailsIn (theory : Theory.Env) (p : Project) (name : String) : + Except EventB.Error ComponentInference := + inferComponentDetailsModeIn false theory p name + +def inferComponentDetailsCheckedIn (theory : Theory.Env) (p : Project) (name : String) : + Except EventB.Error ComponentInference := + inferComponentDetailsModeIn true theory p name + +def inferComponentIn (theory : Theory.Env) (p : Project) (name : String) : + Except EventB.Error (List (String × Ty) × List String) := + (inferComponentDetailsIn theory p name).map fun result => + (result.types, result.diagnostics) + def inferComponent (p : Project) (name : String) : Except EventB.Error (List (String × Ty) × List String) := inferComponentIn Theory.empty p name +private def missingReferenceProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.seesContext [("org.eventb.core.target", "Missing")] []] + theories := ["MissingTheory"] }] + +#guard match inferComponent missingReferenceProject "M" with + | .ok (_, errors) => + errors.contains "unresolved component reference Missing from M" && + errors.contains "unresolved theory reference MissingTheory" + | .error _ => false + +private def cyclicRefinementProject : Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [.refinesMachine [("org.eventb.core.target", "B")] []] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [.refinesMachine [("org.eventb.core.target", "A")] []] }] + +#guard match inferComponent cyclicRefinementProject "A" with + | .ok (_, errors) => errors.any (fun error => error.contains "refinement cycle") + | .error _ => false + +private def multipleParentProject : Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] [] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] [] } + , { name := "C" + elem := .machineFile [("org.eventb.core.name", "C")] + [.refinesMachine [("org.eventb.core.target", "A")] [] + , .refinesMachine [("org.eventb.core.target", "B")] []] }] + +#guard match inferComponent multipleParentProject "C" with + | .ok (_, errors) => errors.any (fun error => error.contains "multiple refinement parents") + | .error _ => false + +private def contextCycleProject : Project := + [{ name := "C1" + elem := .contextFile [("org.eventb.core.name", "C1")] + [.extendsContext [("org.eventb.core.target", "C2")] []] } + , { name := "C2" + elem := .contextFile [("org.eventb.core.name", "C2")] + [.extendsContext [("org.eventb.core.target", "C1")] []] } + , { name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.seesContext [("org.eventb.core.target", "C1")] []] }] + +#guard match inferComponent contextCycleProject "M" with + | .ok (_, errors) => errors.any (fun error => error.contains "dependency cycle") + | .error _ => false + +private def initializationGuardProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] + [.guard [("org.eventb.core.label", "bad"), + ("org.eventb.core.predicate", "x = 0")] []]] }] + +#guard match inferComponent initializationGuardProject "M" with + | .ok (_, errors) => errors.any (fun error => error.contains "must not declare guards") + | .error _ => false + +private def duplicateInitializationProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] []] }] + +#guard match inferComponent duplicateInitializationProject "M" with + | .ok (_, errors) => errors.any (fun error => error.contains "exactly one INITIALISATION") + | .error _ => false + +private def invalidVariantProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.variable [("org.eventb.core.identifier", "b")] [] + , .invariant [("org.eventb.core.label", "type"), + ("org.eventb.core.predicate", "b ∈ BOOL")] [] + , .variant [("org.eventb.core.expression", "b")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] []] }] + +#guard match inferComponent invalidVariantProject "M" with + | .ok (_, errors) => errors.any (fun error => error.contains "variant expression") + | .error _ => false + +private def primedBinderProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .invariant [("org.eventb.core.label", "type"), + ("org.eventb.core.predicate", "x ∈ ℤ")] [] + , .event [("org.eventb.core.label", "choose")] + [.action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x :∣ ∀y' · y' = x'")] []] + , .event [("org.eventb.core.label", "INITIALISATION")] []] }] + +#guard match inferComponent primedBinderProject "M" with + | .ok (_, errors) => errors.isEmpty + | .error _ => false + +private def strictScopeProject : Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .invariant [("org.eventb.core.label", "type"), + ("org.eventb.core.predicate", "x ∈ ℤ")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [.parameter [("org.eventb.core.identifier", "p")] [] + , .guard [("org.eventb.core.label", "g"), + ("org.eventb.core.predicate", "p > 0")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ p")] []]] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [.refinesMachine [("org.eventb.core.target", "A")] [] + , .variable [("org.eventb.core.identifier", "x")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [.refinesEvent [("org.eventb.core.target", "step")] [] + , .guard [("org.eventb.core.label", "bad"), + ("org.eventb.core.predicate", "p > 0")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ x")] []]] }] + +#guard match inferComponentDetailsCheckedIn Theory.empty strictScopeProject "B" with + | .ok details => details.diagnostics.any (fun error => error.contains "unbound identifier p") + | .error _ => false + +private def duplicateAssignmentProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .event [("org.eventb.core.label", "e")] + [.action [("org.eventb.core.label", "a1"), + ("org.eventb.core.assignment", "x ≔ 0")] [] + , .action [("org.eventb.core.label", "a2"), + ("org.eventb.core.assignment", "x ≔ 1")] []] + ] }] + +#guard match inferComponent duplicateAssignmentProject "M" with + | .ok (_, errors) => errors.any (fun error => error.contains "duplicate assignment target x") + | .error _ => false + /-- Infer one expression against an already-built component environment. -/ private def inferTermAtText (theory : Theory.Env) (roots : List String) (env : List (String × Ty)) (t : Term) : Except String Ty := do let (ty, st) ← (inferExpr t).run { env, theory, theoryRoots := roots } let (ty, _) ← (zonk ty).run st + if containsMVar ty then + throw "unresolved type metavariable" return ty def inferTermAt (theory : Theory.Env) (roots : List String) (env : List (String × Ty)) @@ -236,6 +732,10 @@ to contain, and the printer conventions the `.bpo` comparison depends on. -/ | .ok ((_, [ ("x", .int) ]), state) => state.env.isEmpty | _ => false +#guard match inferTerm [] (.set []) with + | .error error => error.message.contains "unresolved type metavariable" + | .ok _ => false + /-- `given` are identifiers with a known type, `unknown` are the ones inference has to work out. Metavariables must come from `fresh` so the substitution has a slot for them. -/ private def inferOne (given : List (String × Ty)) (unknown : List String) @@ -278,6 +778,10 @@ private def inferOne (given : List (String × Ty)) (unknown : List String) -- A type error is a type error: an integer is not a set of trains. #guard inferOne [("S", .pow (.given "TRAIN")), ("n", .int)] [] "n = S" "n" == none +-- A becomes-such-that action checks both before and primed after-state names. +#guard inferOne [("x", .int), ("x'", .int), ("y", .int), ("y'", .int)] [] + "x, y :∣ x' = y' ∧ y' = x' + 1" "x" == some "ℤ" + private def demoTheory : Theory.Env := match Theory.add Theory.empty { name := "Demo", symbols := diff --git a/EventB/Typing/Infer.lean b/EventB/Typing/Infer.lean index 361f936..4f5db58 100644 --- a/EventB/Typing/Infer.lean +++ b/EventB/Typing/Infer.lean @@ -29,6 +29,8 @@ structure St where /-- Event parameters, which leave `env` when their event ends but are still recorded in the `.bpo` and so must survive to read-back. -/ params : List (String × Ty) := [] + /-- Event-local parameter environments, keyed by component and event label. -/ + eventParams : List ((String × String) × List (String × Ty)) := [] abbrev M := StateT St (Except String) @@ -175,6 +177,24 @@ private theorem termSizePos (t : Term) : 1 ≤ sizeOf t := by mutual +private def primedBases (bound : List String) : Term → List String + | .id name => + if name.endsWith "'" && !bound.contains name then [name.dropEnd 1 |>.copy] else [] + | .num _ => [] + | .bin _ a b => primedBases bound a ++ primedBases bound b + | .pre _ a | .post _ a => primedBases bound a + | .app f a | .img f a => primedBases bound f ++ primedBases bound a + | .set terms => primedBasesList bound terms + | .bind _ pattern body => primedBases (patternNames pattern ++ bound) body + +private def primedBasesList (bound : List String) : List Term → List String + | [] => [] + | term :: rest => primedBases bound term ++ primedBasesList bound rest + +end + +mutual + /-- Predicates have no type; the judgement is that the formula is well-formed. -/ def checkPred (t : Term) : M Unit := do match t with @@ -207,9 +227,26 @@ def checkPred (t : Term) : M Unit := do else if o == ":∈" then do unify (.pow (← inferExpr a)) (← inferExpr b) else if o == ":∣" then do - -- Do not accept this action until its before/after predicate has a complete - -- relational typing rule. Treating only the LHS as typed is unsound. - throw "becomes-such-that assignments require relational typing" + -- The predicate relates before-state names to their primed after-state names. + -- Check both target namespaces so a malformed assignment cannot type merely + -- because its relation happens to mention no target. + for target in Formula.flattenCommas a do + match target with + | .id name => + match ← lookup? name with + | none => throw s!"unbound assignment target {name}" + | some _ => pure () + match ← lookup? (name ++ "'") with + | none => throw s!"unbound after-state assignment target {name}'" + | some _ => pure () + pure () + | _ => throw "becomes-such-that targets must be identifiers" + let targets := Formula.flattenCommas a |>.filterMap fun term => + match term with | .id name => some name | _ => none + for name in (primedBases [] b).eraseDups do + if !targets.contains name then + throw s!"after-state identifier {name}' is not an assignment target" + checkPred b else throw s!"not a predicate operator: {o}" | .app (.id "finite") s => do let _ ← asSet (← inferExpr s) | .app (.id "partition") args => do diff --git a/EventB/Xml.lean b/EventB/Xml.lean index 337e5ac..cf1ea8e 100644 --- a/EventB/Xml.lean +++ b/EventB/Xml.lean @@ -28,6 +28,9 @@ private def isNameByte (b : UInt8) : Bool := Ascii.isAlphaNum b || b == Ascii.code '.' || b == Ascii.code '-' || b == Ascii.code ':' || b == 95 +private def isNameStartByte (b : UInt8) : Bool := + Ascii.isAlpha b || b == Ascii.code ':' || b == 95 + private def digitValue (base : Nat) (c : Char) : Option Nat := let n := c.toNat if 48 ≤ n && n ≤ 57 && n - 48 < base then @@ -96,7 +99,8 @@ private def unescape (s : String) : Option String := private def anyByte : GParser conditional UInt8 := GParser.satisfy (fun _ => true) private def xmlName : GParser conditional String := - GParser.capture (GParser.takeWhile1 isNameByte) + GParser.capture (GParser.seqR (GParser.satisfy isNameStartByte) + (GParser.takeWhile isNameByte)) private def decodedValue : GParser fallible String := GParser.captureWith? @@ -154,19 +158,41 @@ private def element : GParser conditional XmlElem := (GParser.seqR GParser.ws (closeTag tag))) GParser.alt leaf branch +private def xmlVersionAttribute : GParser conditional Unit := + GParser.seqR (GParser.string "version") + (GParser.seqR GParser.ws + (GParser.seqR (GParser.ch '=') + (GParser.seqR GParser.ws (GParser.map (fun _ => ()) attrValue)))) + private def declaration : GParser conditional Unit := GParser.map (fun _ => ()) (GParser.seqR (GParser.string ""))) + (GParser.seqR GParser.ws1 + (GParser.seqR xmlVersionAttribute (tagTail (GParser.string "?>"))))) private def document : GParser conditional XmlElem := GParser.seqR declaration (GParser.seqR GParser.ws (GParser.seqL element (GParser.seqR GParser.ws GParser.eof))) +private def duplicateAttributeName (seen : List String) : + List (String × String) → Bool + | [] => false + | (name, _) :: rest => seen.contains name || duplicateAttributeName (name :: seen) rest + +private partial def hasDuplicateXmlAttributes (elem : XmlElem) : Bool := + duplicateAttributeName [] elem.attrs || elem.children.any hasDuplicateXmlAttributes + +private def duplicateAttributeError : Grip.ParseError := + { pos := 0, line := 1, col := 1, expected := ["unique XML attributes"] } + /-- Parse one Rodin XML document from its UTF-8 bytes. -/ def parseXml (source : ByteArray) : Except Grip.ParseError XmlElem := - GParser.parse document source + match GParser.parse document source with + | .error error => .error error + | .ok root => + if hasDuplicateXmlAttributes root then .error duplicateAttributeError + else .ok root /-- Parse one Rodin XML document from a Lean string. -/ def parseXmlString (source : String) : Except Grip.ParseError XmlElem := @@ -179,5 +205,22 @@ def parseXmlString (source : String) : Except Grip.ParseError XmlElem := && elem.children.map (·.tag) == ["group"] | .error _ => false +#guard match parseXmlString + "" with + | .error _ => true + | .ok _ => false + +#guard match parseXmlString "" with + | .error _ => true + | .ok _ => false + +#guard match parseXmlString "" with + | .error _ => true + | .ok _ => false + +#guard match parseXmlString "<1/>" with + | .error _ => true + | .ok _ => false + end EventB diff --git a/README.md b/README.md index a4864d1..1596b14 100644 --- a/README.md +++ b/README.md @@ -52,7 +52,7 @@ provides machine-readable output. ## Verification ```sh -lake build EventB EventB.Properties Examples +lake build EventB Examples lake exe gates lake exe gates --status ``` diff --git a/STATUS.md b/STATUS.md new file mode 100644 index 0000000..f37c7b3 --- /dev/null +++ b/STATUS.md @@ -0,0 +1,54 @@ +# STATUS + +Generated by `lake exe gates --status`. Do not edit; see AGENTS.md rule 1. + +| Phase | Gate | Actual | Target | +| --- | --- | --- | --- | +| P0 reader | files read losslessly | 38/38 | 38 | +| P1 formula parser | formulas parsed and round-tripped | 1102/1102 | 1102 | +| P2 typechecker | `.bpo` identifier types reproduced | 940/940 | 940 | +| P3 POG | `.bpo` PO sequents reproduced | 1133/1133 | 1133 | +| P3b statements | goals derived | 1132/1325 | tracked | +| P3b hypotheses | hypotheses derived | 1132/1325 | tracked | +| P3b WWD | 1/1 hypotheses | tracked | +| P3b compatibility | pinned omissions | 200 | tracked | +| P4 provers | local evidence vs Rodin `.bps` | 73/1133 | ratchet ≥ 73 accepted | + +## Trust ledger + +The artifact Rodin cannot produce: for each obligation, what is actually holding it +up. This status includes only evidence accepted through the local ledger; it is not kernel proof. + +| status | count | +| --- | --- | +| kernel-checked | 0 | +| smt-trusted | 0 | +| rodin-imported | 0 | +| external-trusted | 73 | +| unproved | 1060 | + +Rodin discharged all 1133 of its obligations: 1088 automatically, 45 by hand. + +## Element census + +Summed over every corpus source file. A reader that silently dropped an element would +show up here as a shortfall, which a per-file PASS/FAIL cannot detect. + +| element | count | +| --- | --- | +| guard | 467 | +| action | 410 | +| event | 308 | +| refinesEvent | 222 | +| variable | 180 | +| invariant | 142 | +| parameter | 137 | +| axiom | 68 | +| constant | 33 | +| machineFile | 22 | +| seesContext | 22 | +| refinesMachine | 19 | +| extendsContext | 17 | +| contextFile | 16 | +| witness | 15 | +| carrierSet | 6 | diff --git a/TODO.md b/TODO.md index 6f06e81..3054394 100644 --- a/TODO.md +++ b/TODO.md @@ -1,9 +1,9 @@ -# Roadmap +# Accuracy roadmap -`eventb-lean` v3 is tagged and the four GitHub issues found during the audit are -closed. The next work is production hardening, not a new parser or a second model -representation: every supported surface must be exercised, every limitation must be -visible, and every accepted proof result must retain its trust classification. +The implementation is being hardened for refinement-heavy Event-B, not merely tuned +to the pinned corpus. Unsupported syntax, unresolved references, untyped assignments, +incomplete POG semantics, and unverifiable evidence must fail closed and remain visible +in reports. No second model representation is planned. The architecture and dependency rules for this roadmap live in [`notes/architecture.md`](notes/architecture.md). This file is the execution ledger. @@ -18,50 +18,61 @@ Run `lake exe gates --histogram` before changing a rule. The current ratchet is: | P1 formulas | 1102/1102 | Corpus formulas parse and round-trip. | | P2 types | 940/940 | Rodin's recorded identifier types are reproduced. | | P3 names | 1133/1133 | Every Rodin PO name is generated. Extra names remain visible. | -| P3b statements | 1129/1322 | 193 generated targets lack `.bpo` sequents. | -| P3b hypotheses | 1129/1322 | Comparable hypothesis sets are derived; the same 193 are unmatched. | +| P3b statements | 1132/1325 | Derived goals are compared; 200 pinned compatibility omissions remain tracked. | +| P3b hypotheses | 1132/1325 | Derived hypotheses are compared; 200 pinned compatibility omissions remain tracked. | +| P3b WWD | 1/1 | Hypothesis-only witness well-definedness is scored separately. | +| P3b compatibility | 200 pinned | Named, regression-tested omissions in the pinned `.bpo` oracle. | | P4 local baseline | 73/1133 | Deterministic evidence is attached as external-trusted. | -The 193 P3b unmatched records are not proof failures. They remain explicit coverage -data with diagnostics: 103 are pinned-`.bpo` omissions of plain type invariants; the -rest are omissions in definedness, refinement, or witness-feasibility classes. Seven -additional WFIS names are absent from the pinned `.bpo` files and remain explicit -coverage data rather than being forced into the P3b denominator. P4 has no corpus -kernel, SMT, or imported-Rodin entries yet; the other 1060 obligations remain unproved. +The 200 P3b compatibility records are not proof failures. They are explicit coverage +data classified by kind, preserved in `baseline/compatibility.tsv`, and rejected if a +new unexplained mismatch appears. P4 has no corpus kernel, SMT, or imported-Rodin +entries yet; the other 1060 obligations remain unproved. ## Accuracy campaign: general refinement-heavy Event-B -Status: active. This campaign supersedes the older prototype-completion checkboxes -where adversarial review found that an internally consistent gate was weaker than the -documented semantic or trust contract. The target is fail-closed, structurally faithful -support for a defined refinement-heavy Event-B subset; passing the pinned corpus alone is -not completion evidence. +Status: active. This campaign supersedes prototype-completion claims where adversarial +review found that an internally consistent gate was weaker than the semantic or trust +contract. The target is fail-closed, structurally faithful support for a documented +refinement-heavy Event-B subset; passing the pinned corpus alone is not completion +evidence. ### Current blockers -- [ ] Fail on missing component/event/theory references instead of treating them as empty +- [x] Fail on missing component/event/theory references instead of treating them as empty closures. -- [ ] Keep typing and parse diagnostics attached to POG generation; never discard errors - through `toOption` or ignored error lists. -- [ ] Scope refining-event abstract parameters and keep event parameter types local. -- [ ] Type the RHS of `:∣` actions and include `:∈`/`:∣` actions in invariant semantics. -- [ ] Generate general SIM obligations, including gluing, new events, and stuttering. -- [ ] Make witness WFIS/WWD structurally match Rodin, including witness WD predicates. -- [ ] Add variant, naturalness, decrease, anticipated, and convergent-event obligations. -- [ ] Correct Event-B operator translation and WD rules, especially relation subtraction and - exponentiation. -- [ ] Reject open metavariable kernel proofs and bind all external/Rodin evidence to the - exact obligation and verified artifact digest. +- [x] Keep typing and parse diagnostics attached to POG generation; checked generation + rejects any diagnostic. +- [x] Validate assignment arity/lvalues, primed closure in `:∣`, duplicate targets, and + initialization legality; strict checked generation rejects unresolved diagnostics. +- [ ] Separate compatibility-scope inference from strict Event-B parameter scope: + concrete guards/actions must not inherit abstract parameters without a witness. +- [x] Include deterministic, nondeterministic, inherited, and stuttering action semantics + in the strict invariant/refinement POG path; keep the pinned corpus projection isolated. +- [x] Generate witness WFIS/WWD and FIS shapes, with witness predicates retained where + they are semantic hypotheses; score WWD independently. +- [x] Add numeric/set variants, anticipated/convergent relations, and default constant + variants for machines containing anticipated events. +- [x] Correct relation subtraction, strict subset, exponentiation, and corresponding WD + rules in the formula translator. +- [x] Reject open metavariable kernel proofs and bind accepted evidence to the exact + canonical obligation; Rodin status imports must be parsed from the supplied artifact. +- [ ] Complete the generality ceiling: strict parameter scope, full frame/gluing-relation + semantics, and semantic proofs for each POG class. Right-oriented witnesses and the + basic multi-event merge path now have focused checked fixtures. ### Vertical-slice order -1. Resolution, scopes, and fail-closed diagnostics. -2. Typed assignments and refinement event relations. -3. Formula translation and definedness. -4. Witnesses and complete POG classes. -5. Semantic soundness theorems for each POG class. -6. Trust/provenance hardening. -7. Independent differential tests, release evidence, and adversarial review. +1. Resolution, scopes, and fail-closed diagnostics — implemented and negative-tested. +2. Typed assignments and refinement event relations — implemented; merge/frame edge cases + remain in the generality ceiling. +3. Formula translation and definedness — implemented and corpus-gated. +4. Witnesses and variant POG classes — implemented for the supported syntax. +5. Semantic soundness theorems for each POG class — next correctness milestone. +6. Trust/provenance hardening — implemented for local and parsed Rodin paths; digest + strength and external verifier execution remain explicit trust boundaries. +7. Independent differential tests, release evidence, and adversarial review — active + until the final clean-checkout campaign passes. Each slice requires a minimal positive model, a negative model, a Rodin-shaped comparison, a full build, and a fresh adversarial review before its checkbox is marked. @@ -70,13 +81,13 @@ comparison, a full build, and a fresh adversarial review before its checkbox is | Area | Current evidence | Status | | --- | --- | --- | -| Build and existing gates | 178-job build; P0/P1/P2/P3 pass | baseline only | -| General refinement typing | AMAN CLI fails on abstract event parameters | blocker | -| POG semantic coverage | nondeterministic actions, SIM, WWD, variants require work | blocker | -| Kernel trust | replay negative tests pass; open-mvar path requires hardening | blocker | -| External/Rodin provenance | metadata checks are not artifact verification | blocker | -| Release reproducibility | acceptance note and benchmark metadata are stale | blocker | -| Official Rossi differential | executable unavailable locally | unverified | +| Build and existing gates | Lean 4.33 build; P0/P1/P2/P3 pass; P3b tracked | current | +| General refinement typing | AMAN/event-scope and missing-reference negative controls pass | current | +| POG semantic coverage | nondeterministic actions, SIM, WWD, variants, EQL/MRG implemented | strict checked path; edge ceiling remains | +| Kernel trust | replay checks reject open mvars, stale goals, forged axioms, and context drift | current | +| External/Rodin provenance | model/BPO/status identity, canonical/fingerprint binding, monotonic ledger update | current; semantic re-derivation and cryptographic authenticity remain outside the contract | +| Release reproducibility | CLI fixture, gate status, and exact baseline ratchet are required | active | +| Official Rossi differential | executable unavailable locally; CI provisions pinned v0.1.7 | local evidence unavailable | The ledger is updated after every implementation commit. A phase is not complete when the build is green if a counterexample, oracle comparison, or adversarial review remains @@ -128,7 +139,8 @@ by hand; the current histogram remains reproducible. - [x] Add one positive and one negative corpus-shaped regression for each corrected WD rule, including a total theory symbol and a partial application. -Progress: assignment WD now inspects only the right-hand side, and event-level +Progress: the compatibility projection preserves the pinned right-hand-side rule; +strict checked generation also includes function-update arguments, and event-level invariant WD is no longer emitted as a separate obligation. The corpus moved from 214 to 13 unmatched WD names; the remaining records are guard definedness cases. `examples/Counter.lean` covers a partial `card` RHS positively and a function-update @@ -300,7 +312,7 @@ These items depend on the P3b and P4 contracts and must not create a second chec and trust UX changes. The first prototype has no unowned implementation items. The remaining ceilings are -deliberate: exact P3b parity for the 193 pinned `.bpo` omissions needs regenerated Rodin +deliberate: exact P3b parity for the 200 pinned `.bpo` omissions needs regenerated Rodin artifacts or an explicit compatibility mode, and corpus-scale kernel proof counts need semantic Lean bindings for each model symbol. Both are reported rather than silently claimed as complete. The next proof increments are measured by the P4 formula-shape @@ -375,7 +387,7 @@ Production thresholds: ### V4.3 P3b parity and compatibility -- [x] #19 Resolve the 193 unmatched P3b records against regenerated Rodin `.bpo` artifacts, +- [x] #19 Resolve the 200 unmatched P3b records against regenerated Rodin `.bpo` artifacts, or implement an explicit compatibility mode for the pinned omissions. - [x] #20 Preserve the current diagnostics for plain type invariants, definedness, refinement guards/actions, and witness feasibility while resolving the records. diff --git a/Widgets.lean b/Widgets.lean index 0f5fa07..9391205 100644 --- a/Widgets.lean +++ b/Widgets.lean @@ -88,6 +88,13 @@ private def kindClass : String → String | "THM" => "green" | "WFIS" => "light-blue" | "WWD" => "red" + | "FIS" => "light-blue" + | "EQL" => "purple" + | "MRG" => "gold" + | "VWD" => "teal" + | "FIN" => "teal" + | "NAT" => "teal" + | "VAR" => "teal" | _ => "grey" private def kindTitle : String → String @@ -98,6 +105,13 @@ private def kindTitle : String → String | "THM" => "Theorem" | "WFIS" => "Witness feasibility" | "WWD" => "Witness well-definedness" + | "FIS" => "Action feasibility" + | "EQL" => "Preserved variable equality" + | "MRG" => "Merged-event guard strengthening" + | "VWD" => "Variant well-definedness" + | "FIN" => "Finite set variant" + | "NAT" => "Natural-number variant" + | "VAR" => "Variant decrease" | kind => kind private def fallbackEntry (obligation : Obligation) : Trust.Entry := @@ -120,7 +134,9 @@ private def obligationCard (ledger : Trust.Ledger) (obligation : Obligation) : H obligationBody obligation entry ] -private def kinds : List String := ["INV", "WD", "GRD", "SIM", "THM", "WFIS", "WWD"] +private def kinds : List String := + ["INV", "WD", "GRD", "SIM", "THM", "WFIS", "WWD", "FIS", "EQL", "MRG", + "VWD", "FIN", "NAT", "VAR"] private def countKind (kind : String) (obligations : List Obligation) : Nat := obligations.countP (·.kind == kind) diff --git a/baseline/hypothesis.tsv b/baseline/hypothesis.tsv index fe47053..6dfebb3 100644 --- a/baseline/hypothesis.tsv +++ b/baseline/hypothesis.tsv @@ -340,6 +340,7 @@ M9_Push_Mouse_Buttons Release_Trigger_Block_Time/click_start_zoom/INV PASS M9_Push_Mouse_Buttons Release_Trigger_Block_Time/grd3,1/GRD PASS M9_Push_Mouse_Buttons Release_Trigger_Block_Time/grd6,1/GRD PASS M9_Push_Mouse_Buttons Release_Trigger_Block_Time/act3,1/SIM PASS +M9_Push_Mouse_Buttons Release_Trigger_Block_Time/time/WFIS PASS M9_Push_Mouse_Buttons Release_Abort_Time_Button/is_mouse_pressed/INV FAIL:no such sequent in .bpo M9_Push_Mouse_Buttons Release_Abort_Time_Button/is_clicked_block/INV PASS M9_Push_Mouse_Buttons Release_Abort_Time_Button/is_clicked_block_fin/INV PASS @@ -357,6 +358,7 @@ M9_Push_Mouse_Buttons Release_Trigger_Deblock_Time/click_start_zoom/INV PASS M9_Push_Mouse_Buttons Release_Trigger_Deblock_Time/grd3,1/GRD PASS M9_Push_Mouse_Buttons Release_Trigger_Deblock_Time/grd6,1/GRD PASS M9_Push_Mouse_Buttons Release_Trigger_Deblock_Time/act3,1/SIM PASS +M9_Push_Mouse_Buttons Release_Trigger_Deblock_Time/time/WFIS PASS M9_Push_Mouse_Buttons changeZoom/is_mouse_pressed/INV FAIL:no such sequent in .bpo M9_Push_Mouse_Buttons changeZoom/is_clicked_block/INV PASS M9_Push_Mouse_Buttons changeZoom/block_slot_position/INV PASS @@ -1008,6 +1010,7 @@ MAbs_helper stop_dragging_airplane/get_dragged_airplane_time_abstract/GRD PASS MAbs_helper stop_dragging_airplane/grd_abstrac_airplane/GRD PASS MAbs_helper stop_dragging_airplane/clicked_pos/SIM PASS MAbs_helper stop_dragging_airplane/dest_not_allowed/WD PASS +MAbs_helper stop_dragging_airplane/abstract_airplane/WFIS PASS MAbs_helper drag_airplane/dragged_airplane/INV PASS MAbs_helper drag_airplane/dragged_airplane_type_glue/INV PASS MAbs_helper drag_airplane/mouse_over_airplane_when_dragged/INV PASS diff --git a/baseline/p4.tsv b/baseline/p4.tsv new file mode 100644 index 0000000..4f086a6 --- /dev/null +++ b/baseline/p4.tsv @@ -0,0 +1,73 @@ +M0_AMAN_Update_prob_mc_Ctx axm_init_airplanes/WD eventb-v1-16829145160484273594 external-trusted exact-hypothesis +M1_Landing_Sequence AMAN_Update/inv1,1/INV eventb-v1-5952998824876361987 external-trusted exact-hypothesis +M1_Landing_Sequence AMAN_Update/inv13,2/INV eventb-v1-14486024917793534250 external-trusted exact-hypothesis +M1_Landing_Sequence AMAN_Update/glue1,1/INV eventb-v1-17390780325116527436 external-trusted reflexive +M4_Zoom changeZoom/inv6,1/INV eventb-v1-5074545683590948877 external-trusted exact-hypothesis +M6_Select_Airplane selectedAirplane_card/WD eventb-v1-13876482062933068475 external-trusted exact-hypothesis +M8_Interaction_Events dragged_airplane_card/WD eventb-v1-8672142159150112234 external-trusted exact-hypothesis +M8_Interaction_Events dragged_zoom_level_card/WD eventb-v1-5108533651225176600 external-trusted exact-hypothesis +M9_Push_Mouse_Buttons is_clicked_block_card/WD eventb-v1-16385690044210585065 external-trusted exact-hypothesis +M9_Push_Mouse_Buttons block_slot_position_card/WD eventb-v1-17293093683319281994 external-trusted exact-hypothesis +M9_Push_Mouse_Buttons airplane_Position_card/WD eventb-v1-15118745736586539840 external-trusted exact-hypothesis +M9_Push_Mouse_Buttons zoom_Position_card/WD eventb-v1-10862862079148529320 external-trusted exact-hypothesis +M9_Push_Mouse_Buttons Click_Block_Time/is_clicked_block/INV eventb-v1-10308162812538151779 external-trusted exact-hypothesis +M9_Push_Mouse_Buttons Click_Block_Time/is_clicked_block_fin/INV eventb-v1-12648376009743200148 external-trusted exact-hypothesis +M9_Push_Mouse_Buttons Click_Block_Time/is_clicked_block_card/INV eventb-v1-14948101976653692821 external-trusted exact-hypothesis +MAbs abstract_selectedAirplane_card/WD eventb-v1-14621877684346714394 external-trusted exact-hypothesis +MAbs dragged_airplane_card/WD eventb-v1-11607518134397819031 external-trusted exact-hypothesis +MAbs dragged_zoom_level_card/WD eventb-v1-16609845267404018574 external-trusted exact-hypothesis +MAbs is_clicked_block_card/WD eventb-v1-2111861896089874719 external-trusted exact-hypothesis +MAbs block_slot_position_card/WD eventb-v1-9479766206528609583 external-trusted exact-hypothesis +MAbs airplane_Position_card/WD eventb-v1-8816147645107901744 external-trusted exact-hypothesis +MAbs zoom_Position_card/WD eventb-v1-10337737539238151803 external-trusted exact-hypothesis +MAbs Click_Block_Time/is_clicked_block_fin/INV eventb-v1-4850963611294016226 external-trusted exact-hypothesis +MAbs Click_Block_Time/is_clicked_block_card/INV eventb-v1-3007239627218876922 external-trusted exact-hypothesis +MAbs_helper zoom_Position_card/WD eventb-v1-12838068536752949749 external-trusted exact-hypothesis +MAbs_helper airplane_Position_card/WD eventb-v1-8560278530949472824 external-trusted exact-hypothesis +MAbs_helper block_slot_position_card/WD eventb-v1-16865147050694524371 external-trusted exact-hypothesis +MAbs_helper is_clicked_block_card/WD eventb-v1-6176386349350495706 external-trusted exact-hypothesis +MAbs_helper INITIALISATION/selected_airplane_glue_2/INV eventb-v1-13393541256562704162 external-trusted reflexive +MAbs_helper INITIALISATION/act2,1/SIM eventb-v1-1904022326184590749 external-trusted reflexive +MAbs_helper INITIALISATION/act6,1/SIM eventb-v1-13997722314308442627 external-trusted reflexive +MAbs_helper INITIALISATION/act9,6/SIM eventb-v1-324200555209367186 external-trusted reflexive +MAbs_helper INITIALISATION/mouse_pressed_init/SIM eventb-v1-17623492704637381121 external-trusted reflexive +MAbs_helper Move_Mouse_Hold/act9,4/SIM eventb-v1-6316941715101413182 external-trusted reflexive +MAbs_helper Move_Mouse_Block/act9,4/SIM eventb-v1-744383341946784867 external-trusted reflexive +MAbs_helper Move_Mouse_Airplane/act9,4/SIM eventb-v1-3792374523669588341 external-trusted reflexive +MAbs_helper Move_Mouse_Nothing/act9,4/SIM eventb-v1-5678845416610114088 external-trusted reflexive +MAbs_helper AMAN_Update_mouse_to_nothing/landing_sequence_1/INV eventb-v1-3637221599295908496 external-trusted exact-hypothesis +MAbs_helper AMAN_Update_mouse_to_nothing/landing_sequence_2/INV eventb-v1-18337452325949431025 external-trusted exact-hypothesis +MAbs_helper AMAN_Update_mouse_to_nothing/landing_sequence_3/INV eventb-v1-10387503350183962558 external-trusted reflexive +MAbs_helper AMAN_Update_mouse_to_nothing/selected_airplane_glue_2/INV eventb-v1-17014798992690263540 external-trusted reflexive +MAbs_helper AMAN_Update_mouse_to_nothing/act2,1/SIM eventb-v1-7972194414658671855 external-trusted reflexive +MAbs_helper AMAN_Update_mouse_to_airplane/landing_sequence_1/INV eventb-v1-17960741234889804297 external-trusted exact-hypothesis +MAbs_helper AMAN_Update_mouse_to_airplane/landing_sequence_2/INV eventb-v1-17044829435698685195 external-trusted exact-hypothesis +MAbs_helper AMAN_Update_mouse_to_airplane/landing_sequence_3/INV eventb-v1-15455895954992255775 external-trusted reflexive +MAbs_helper AMAN_Update_mouse_to_airplane/selected_airplane_glue_2/INV eventb-v1-4771753122858391310 external-trusted reflexive +MAbs_helper AMAN_Update_mouse_to_airplane/act2,1/SIM eventb-v1-5906076194927146421 external-trusted reflexive +MAbs_helper AMAN_Update_mouse_stays/landing_sequence_1/INV eventb-v1-8102351550214528873 external-trusted exact-hypothesis +MAbs_helper AMAN_Update_mouse_stays/landing_sequence_2/INV eventb-v1-4186422107733177070 external-trusted exact-hypothesis +MAbs_helper AMAN_Update_mouse_stays/landing_sequence_3/INV eventb-v1-16924152694001247823 external-trusted reflexive +MAbs_helper AMAN_Update_mouse_stays/selected_airplane_glue_2/INV eventb-v1-13083000857704501251 external-trusted reflexive +MAbs_helper AMAN_Update_mouse_stays/act2,1/SIM eventb-v1-11953983933110232066 external-trusted reflexive +MAbs_helper AMAN_Timeout/selected_airplane_glue_2/INV eventb-v1-12300009698097461724 external-trusted reflexive +MAbs_helper Move_Aircraft/set_to_release/SIM eventb-v1-13809488853902544126 external-trusted reflexive +MAbs_helper Release_Trigger_Hold_Button/selected_airplane_glue_2/INV eventb-v1-12884135418067291466 external-trusted reflexive +MAbs_helper Release_Trigger_Hold_Button/act9,1/SIM eventb-v1-2265997975947546931 external-trusted reflexive +MAbs_helper Click_Block_Time/is_clicked_block/INV eventb-v1-16780666689996213097 external-trusted exact-hypothesis +MAbs_helper Click_Block_Time/isClickedBlock_glue/INV eventb-v1-5712249715222137357 external-trusted exact-hypothesis +MAbs_helper Click_Block_Time/is_clicked_block_fin/INV eventb-v1-6306803904311634003 external-trusted exact-hypothesis +MAbs_helper Click_Block_Time/is_clicked_block_card/INV eventb-v1-1972092461926185202 external-trusted exact-hypothesis +MAbs_helper Click_Block_Time/set_mouse_click/SIM eventb-v1-15525831042234247423 external-trusted reflexive +MAbs_helper Release_Trigger_Block_Time/clicked_pos/SIM eventb-v1-13729656030034437291 external-trusted reflexive +MAbs_helper Release_Abort_Time_Button/clicked_pos/SIM eventb-v1-14291099572336688180 external-trusted reflexive +MAbs_helper Release_Trigger_Deblock_Time/clicked_pos/SIM eventb-v1-11750202660985723614 external-trusted reflexive +MAbs_helper changeZoom/selected_airplane_glue_2/INV eventb-v1-18025039012413666565 external-trusted reflexive +MAbs_helper changeZoom/clicked_pos/SIM eventb-v1-3577514077840859436 external-trusted reflexive +MAbs_helper selectAirplane/selected_airplane_glue_2/INV eventb-v1-6253709394115987799 external-trusted reflexive +MAbs_helper selectAirplane/press_mouse/SIM eventb-v1-5564680175720267226 external-trusted reflexive +MAbs_helper deselectAirplane/selected_airplane_glue_2/INV eventb-v1-13870771662686551008 external-trusted reflexive +MAbs_helper resume_dragging_airplane/press_mouse/SIM eventb-v1-5705311774075729570 external-trusted reflexive +MAbs_helper stop_dragging_airplane/clicked_pos/SIM eventb-v1-4634871620335529269 external-trusted reflexive +MAbs_prob_mc_Ctx axm_inst4,1/WD eventb-v1-368063854654994650 external-trusted exact-hypothesis +MAbs_prob_mc_Ctx abstract_blocks_card/WD eventb-v1-1441971169358301113 external-trusted exact-hypothesis diff --git a/baseline/statement.tsv b/baseline/statement.tsv index fe47053..6dfebb3 100644 --- a/baseline/statement.tsv +++ b/baseline/statement.tsv @@ -340,6 +340,7 @@ M9_Push_Mouse_Buttons Release_Trigger_Block_Time/click_start_zoom/INV PASS M9_Push_Mouse_Buttons Release_Trigger_Block_Time/grd3,1/GRD PASS M9_Push_Mouse_Buttons Release_Trigger_Block_Time/grd6,1/GRD PASS M9_Push_Mouse_Buttons Release_Trigger_Block_Time/act3,1/SIM PASS +M9_Push_Mouse_Buttons Release_Trigger_Block_Time/time/WFIS PASS M9_Push_Mouse_Buttons Release_Abort_Time_Button/is_mouse_pressed/INV FAIL:no such sequent in .bpo M9_Push_Mouse_Buttons Release_Abort_Time_Button/is_clicked_block/INV PASS M9_Push_Mouse_Buttons Release_Abort_Time_Button/is_clicked_block_fin/INV PASS @@ -357,6 +358,7 @@ M9_Push_Mouse_Buttons Release_Trigger_Deblock_Time/click_start_zoom/INV PASS M9_Push_Mouse_Buttons Release_Trigger_Deblock_Time/grd3,1/GRD PASS M9_Push_Mouse_Buttons Release_Trigger_Deblock_Time/grd6,1/GRD PASS M9_Push_Mouse_Buttons Release_Trigger_Deblock_Time/act3,1/SIM PASS +M9_Push_Mouse_Buttons Release_Trigger_Deblock_Time/time/WFIS PASS M9_Push_Mouse_Buttons changeZoom/is_mouse_pressed/INV FAIL:no such sequent in .bpo M9_Push_Mouse_Buttons changeZoom/is_clicked_block/INV PASS M9_Push_Mouse_Buttons changeZoom/block_slot_position/INV PASS @@ -1008,6 +1010,7 @@ MAbs_helper stop_dragging_airplane/get_dragged_airplane_time_abstract/GRD PASS MAbs_helper stop_dragging_airplane/grd_abstrac_airplane/GRD PASS MAbs_helper stop_dragging_airplane/clicked_pos/SIM PASS MAbs_helper stop_dragging_airplane/dest_not_allowed/WD PASS +MAbs_helper stop_dragging_airplane/abstract_airplane/WFIS PASS MAbs_helper drag_airplane/dragged_airplane/INV PASS MAbs_helper drag_airplane/dragged_airplane_type_glue/INV PASS MAbs_helper drag_airplane/mouse_over_airplane_when_dragged/INV PASS diff --git a/baseline/wwd.tsv b/baseline/wwd.tsv new file mode 100644 index 0000000..6e48e8a --- /dev/null +++ b/baseline/wwd.tsv @@ -0,0 +1 @@ +MAbs_helper Move_Mouse_Block/abstract_block/WWD PASS diff --git a/bench/Bench.lean b/bench/Bench.lean index cd59446..ef6d3ec 100644 --- a/bench/Bench.lean +++ b/bench/Bench.lean @@ -6,8 +6,10 @@ open EventB /-- Parse every predicate Rodin wrote into the `.bpo` files, extracted by `spike/extract.py`. These are the proof obligations themselves, not the model, and they use syntax a `.bum` never contains: type ascriptions on bound variables. -/ -def main : IO Unit := do - let text ← IO.FS.readFile "/tmp/allpo.txt" +def main (args : List String) : IO Unit := do + let path := args.getLast?.getD "/tmp/allpo.txt" + let text ← try IO.FS.readFile path catch _ => + throw <| IO.userError s!"bench: input file not found: {path} (run spike/extract.py first)" let lines := text.splitOn "\n" |>.filter (fun l => !l.isEmpty) let mut ok := 0 let mut fails : List String := [] diff --git a/cli/Cli.lean b/cli/Cli.lean index 7dad0c8..a450aef 100644 --- a/cli/Cli.lean +++ b/cli/Cli.lean @@ -249,7 +249,9 @@ private def reports (data : ProjectData) : List Report := private def fatalErrors (data : ProjectData) (rs : List Report) : List EventB.Error := data.errors ++ rs.flatMap (·.errors) -private def kinds : List String := ["INV", "WD", "GRD", "SIM", "THM", "WFIS", "WWD"] +private def kinds : List String := + ["INV", "WD", "GRD", "SIM", "THM", "WFIS", "WWD", "FIS", "EQL", "MRG", + "VWD", "FIN", "NAT", "VAR"] private def parseKinds (value : String) : Except String (List String) := let values := value.splitOn "," @@ -700,8 +702,10 @@ private def runDiff (dir : System.FilePath) : IO UInt32 := do IO.println (s!"{source.name}: {matching} match, " ++ s!"{missing.length} only Rodin, {extra.length} only ours") if !missing.isEmpty then + failed := true IO.println s!" only Rodin: {String.intercalate ", " missing}" if !extra.isEmpty then + failed := true IO.println s!" only ours: {String.intercalate ", " extra}" for source in data.sources do if !bpos.any (fun path => stem path == source.name) then diff --git a/examples/BookPrograms.lean b/examples/BookPrograms.lean index 6138040..c64022b 100644 --- a/examples/BookPrograms.lean +++ b/examples/BookPrograms.lean @@ -77,6 +77,7 @@ eventb_machine SimpleProgram where variables x y invariant inv0_1 : "x ∈ ℕ" invariant inv0_2 : "y ∈ ℕ" + variant variant1 : "y − x" event INITIALISATION where action act1 : "x, y ≔ 0, 0" event final where @@ -309,6 +310,22 @@ private def hasPO (machine name : String) : Bool := #guard hasPO "ListReverse1" "INITIALISATION/inv1_1/INV" #guard hasPO "SquareRoot1" "INITIALISATION/inv1_1/INV" #guard hasPO "Inverse1" "INITIALISATION/inv1_1/INV" +#guard hasPO "BinarySearch1" "dec/NAT" +#guard hasPO "BinarySearch1" "dec/VAR" +#guard hasPO "BinarySearch1" "inc/NAT" +#guard hasPO "BinarySearch1" "inc/VAR" +#guard hasPO "SimpleProgram" "progress/NAT" +#guard hasPO "SimpleProgram" "progress/VAR" + +private def goalText (machine name : String) : Option String := + (POG.generate programsProject machine).find? (·.name == name) |>.bind + (·.goal.map Formula.print) + +#guard goalText "BinarySearch1" "dec/VAR" == some "(((x − 1) − p) < (q − p))" +#guard goalText "NotationMachine" "nondeterministic_value/act1/FIS" == + some "((0 ‥ n) ≠ {})" +#guard goalText "NotationMachine" "nondeterministic_relation/act1/FIS" == + some "(∃ (x' ⦂ ℤ) · ((x' = y') ∧ (y' = (x' + z))))" /-! Witness coverage regression: the openETCS-style refinement shape has both a feasibility statement and the hypothesis-only well-definedness record. -/ diff --git a/examples/TranslateDemo.lean b/examples/TranslateDemo.lean index 585857b..a4b341b 100644 --- a/examples/TranslateDemo.lean +++ b/examples/TranslateDemo.lean @@ -78,6 +78,27 @@ private meta def checkLambda : TermElabM Unit := do let term ← parseFormula source let _ ← Embedding.translatePredicate context term +private meta def checkRelationSubtraction : MetaM Unit := do + let intType := mkConst ``Int + let prop := mkSort .zero + let setType ← mkArrow intType prop + let pairType ← mkAppM ``Prod #[intType, intType] + let relationType ← mkArrow pairType prop + withLocalDeclD `set setType fun set => + withLocalDeclD `relation relationType fun relation => do + let context : Embedding.KernelContext := + { bindings := + [{ name := "S", ty := .pow .int, value := set } + , { name := "r", ty := .pow (.prod .int .int), value := relation }] } + let some restrictionTerm := (Formula.parse "S ◁ r").toOption | + throwError "restriction did not parse" + let some subtractionTerm := (Formula.parse "S ⩤ r").toOption | throwError + "subtraction did not parse" + let restriction ← Embedding.translateExpression context restrictionTerm + let subtraction ← Embedding.translateExpression context subtractionTerm + unless !(← isDefEq restriction.value subtraction.value) do + throwError "relation subtraction translated as domain restriction" + syntax (name := eventbTranslateChecks) "#eventb_translate_checks" : command @[command_elab eventbTranslateChecks] @@ -107,6 +128,7 @@ meta def elabTranslateChecks : CommandElab := fun stx => checkRejectsWrongBinding checkSemanticFunction checkLambda + liftMetaM checkRelationSubtraction | _ => throwUnsupportedSyntax #eventb_translate_checks diff --git a/examples/TrustRodinDemo.lean b/examples/TrustRodinDemo.lean index c5421c2..6cfbb94 100644 --- a/examples/TrustRodinDemo.lean +++ b/examples/TrustRodinDemo.lean @@ -14,6 +14,14 @@ private def source := "org.eventb.core.confidence=\"1000\" org.eventb.core.psManual=\"false\"/>" ++ "" +private def provenance : Trust.Rodin.Provenance := + { model := "" + bpo := "" ++ + "" + statuses := source } + #guard match Trust.Rodin.importStatuses source with | .ok [status] => let result := Trust.Rodin.compare [obligation] [status] @@ -21,8 +29,8 @@ private def source := | _ => false #guard match Trust.Rodin.importStatuses source with - | .ok [status] => match Trust.Rodin.attach - (Trust.Ledger.ofObligations [obligation]) obligation "demo.bps" status with + | .ok [status] => match Trust.Rodin.attachProvenance + (Trust.Ledger.ofObligations [obligation]) obligation provenance status with | .ok ledger => ledger.count .rodinImported == 1 | .error _ => false | _ => false diff --git a/examples/WidgetDemo.lean b/examples/WidgetDemo.lean index ddf8168..56c139e 100644 --- a/examples/WidgetDemo.lean +++ b/examples/WidgetDemo.lean @@ -158,7 +158,10 @@ private def attachWidgetProof (ledger : Trust.Ledger) match obligations.find? (·.name == name) with | none => ledger | some obligation => - match ledger.attach obligation (.kernel declaration (widgetAxioms declaration)) with + let evidence := Trust.Evidence.external "LeanKernel" "4.33" + (Trust.fingerprint (obligation.canonical ++ "\ndeclaration=" ++ declaration)) + "Trust.Replay.validate" + match ledger.attach obligation evidence with | .ok updated => updated | .error _ => ledger @@ -175,13 +178,13 @@ private def validateWidgetProofs (limit cars gate : Expr) : MetaM Unit := do , { name := "cars", ty := .int, value := cars } , { name := "gate", ty := .bool, value := gate }] } let obligations := POG.generate widgetProject "BridgeController" - for entry in widgetLedger.entries do - if entry.mode == .kernel then - let some obligation := obligations.find? (·.name == entry.obligation) | throwError - s!"missing WidgetDemo obligation `{entry.obligation}`" - let report ← Trust.Replay.validateEntry context obligation entry - unless report.replayed do - throwError s!"WidgetDemo proof `{entry.obligation}` was not replayed" + for (name, declaration) in widgetProofs do + let some obligation := obligations.find? (·.name == name) | throwError + s!"missing WidgetDemo obligation `{name}`" + let report ← Trust.Replay.validate context obligation + (.kernel declaration (widgetAxioms declaration)) + unless report.replayed do + throwError s!"WidgetDemo proof `{name}` was not replayed" private meta def checkWidgetProofs : TermElabM Unit := do let intType := mkConst ``Int diff --git a/notes/architecture.md b/notes/architecture.md index d4a786a..8cc245b 100644 --- a/notes/architecture.md +++ b/notes/architecture.md @@ -182,7 +182,9 @@ goal-plus-hypotheses sequent. It does not change the ledger. `Trust.Replay` acce kernel proof only after resolving its declaration, translating the complete POG sequent, checking definitional equality, and comparing its transitive axiom dependencies with the declared metadata. `Trust.Rodin` imports `.bps` status -records as `rodinImported`; it never upgrades them to kernel evidence. SMT and external +records as `rodinImported`; it never upgrades them to kernel evidence. The import binds +model-root, PO-sequent, source-component, and status identities, but does not rederive +the BPO sequent from the model. SMT and external evidence remain explicit metadata boundaries and must carry solver/tool, version, input digest, and verifier fields. @@ -199,8 +201,8 @@ not a second checker, so presentation changes cannot alter generated obligations The corpus gate also exposes `lake exe gates --coverage`. It emits stable tab-separated records with component, obligation class, name, derivation status, reason, and a -diagnostic. Reasons are `matched`, `no-sequent`, `goal-differs`, or -`hypotheses-differ`; missing targets are further classified as pinned-`.bpo` omissions +diagnostic. Reasons are `matched`, `no-sequent`, `goal-differs`, +`hypotheses-differ`, or `not-derived`; missing targets are further classified as pinned-`.bpo` omissions of plain type invariants, definedness, refinement guards/actions, or witness feasibility. A missing Rodin target therefore remains visible instead of shrinking a denominator. WFIS and WWD records with no generated goal retain `not-derived` status; @@ -231,13 +233,12 @@ The gates compare the implementation against the pinned corpus and ratchet files - P1: 1102 formula strings parse and round-trip; - P2: 940 distinct inferred types match; - P3: generated obligation names are compared with Rodin; -- P3b: 1129 of 1322 comparable goals and hypothesis sets are derived; 193 generated - targets have no matching `.bpo` sequent and remain explicit coverage data with - diagnostics. The 103 plain type-invariant omissions are a selective pinned-corpus - compatibility difference; broad filtering is unsound because the corpus retains - other static-looking invariant sequents. - Seven additional WFIS names are also recorded as name-only coverage when Rodin does - not serialize a target predicate, for 200 pinned compatibility records in total; +- P3b: 1132 of 1325 tracked goals and hypothesis sets are derived. The 200 pinned + compatibility records have no comparable serialized `.bpo` target and remain + explicit coverage data with named diagnostics. WWD is scored in its own 1/1 gate. The plain + type-invariant omissions are a selective pinned-corpus compatibility difference; + broad filtering is unsound because the corpus retains other static-looking invariant + sequents. - P4: the gates run the deterministic local baseline over the 1133 P3-matched obligations; the current result is 73 external-trusted and the rest unproved. @@ -276,9 +277,9 @@ record: 1. whether the PO name exists in the `.bpo` corpus; 2. whether the generated goal and ordered hypotheses match the recorded sequent. -The current 193 unmatched records are concentrated in WD, INV, SIM, and GRD, with seven -additional WFIS name-only records. They are -not to be removed by broadening the comparison or by blessing a smaller denominator. +The current 200 compatibility records are concentrated in WD, INV, SIM, GRD, and +witness-feasibility classes. They are not to be removed by broadening the comparison or +by blessing a smaller denominator. The correction belongs in the shared POG conditions: total versus partial symbols, assigned-variable filtering, refinement inheritance, witness substitution, and abstract/concrete event matching. WFIS is derived when Rodin supplies its existential diff --git a/notes/production-acceptance.md b/notes/production-acceptance.md index 683413b..2bd69da 100644 --- a/notes/production-acceptance.md +++ b/notes/production-acceptance.md @@ -1,22 +1,17 @@ # Production acceptance -This note is the release checklist for the first production-ready eventb-lean -commit. It describes the supported contract and the measured ceilings; it does not -claim that every proof obligation is automatically discharged. +This note is the release checklist for the current accuracy campaign. It describes +the supported contract and measured ceilings; it does not claim that every proof +obligation is automatically discharged. ## Measured baseline -The acceptance run uses Lean `v4.28.0`, the pinned corpus manifest -`84d51dbc09498d0b3c61d3a69a0d7aa700390983c53ef6dd5b8b26a9b61e4e2f`, `grip` -`eb29a2331729a7087eab54838557e7490e802a29`, and ProofWidgets `v0.0.87`. -The timestamped gate record in -`bench/results/2026-08-02T21-56-30Z/gates.txt` records the measured commit and -toolchain metadata. - -The complete contract was also run from a detached clean checkout at commit -`937609f`: all 108 build jobs, gates, CLI fixtures, the official Rossi v0.1.7 -differential matrix, distribution, manifest, style, and diff checks passed. The clean -checkout contained no private book artifacts. +The current acceptance run uses Lean `v4.33.0`, ProofWidgets `v0.0.108`, and +`corpus/MANIFEST.tsv` SHA256 +`c76a5dca92f0ea32f8c1e20e9da4cb88006bd048cee78d9fd66d03a20e664c45`. +The corpus itself remains pinned to the upstream commits recorded in the manifest. +The release candidate is accepted only after the clean-checkout command matrix below +passes; the current worktree is intentionally still under adversarial review. | Gate | Result | Interpretation | | --- | ---: | --- | @@ -24,9 +19,10 @@ checkout contained no private book artifacts. | P1 formulas | 1102/1102 | Formulas parse and round-trip. | | P2 types | 940/940 | Recorded identifier types reproduced. | | P3 obligations | 1133/1133 | Rodin PO names generated. | -| P3b statements | 1129/1322 | Derived goals match the comparable corpus records. | -| P3b hypotheses | 1129/1322 | Derived hypothesis sets match the comparable records. | -| P3b compatibility | 200 pinned | 193 no-sequent records plus 7 WFIS name-only records. | +| P3b statements | 1132/1325 | Derived goals and named compatibility omissions are tracked. | +| P3b hypotheses | 1132/1325 | Derived hypothesis sets and named compatibility omissions are tracked. | +| P3b WWD | 1/1 | Hypothesis-only witness well-definedness is scored separately. | +| P3b compatibility | 200 pinned | Explicit, classified pinned-oracle omissions. | | P4 local baseline | 73/1133 | Explicit external-trusted evidence; 1060 remain unproved. | The P3b compatibility records are not silently omitted or counted as proof failures. @@ -42,6 +38,10 @@ counts are zero for the corpus baseline; the local results remain external-trust variant, event-status, and formula subset. - Native Lean contexts, machines, theories, datatypes, definitions, and rules. - The faithful `.tuf` theory subset; unsupported declarations are rejected. +- Refinement-heavy Event-B within the checked subset: inherited actions, deterministic + and nondeterministic assignments, witnesses, stuttering/SIM, EQL/MRG, and numeric/set + variants. `generateChecked` is the strict path; the corpus gate retains a documented + compatibility projection for pinned Rodin omissions. - CLI reports, proof-obligation output, trust-ledger evidence, ProofWidgets, and native Lean declaration ranges. @@ -55,6 +55,11 @@ Every obligation has an explicit ledger mode. Kernel evidence requires replayed proof terms and checked axiom metadata. SMT, Rodin-imported, and external evidence remain their own modes with verifier, version, input digest, and fingerprint metadata. Unproved obligations remain `unproved`; reports never upgrade them implicitly. +Rodin imports additionally require model-root identity, exact BPO sequent identity, +source-component binding, and an independently parsed proof-status record. This is +identity/provenance validation, not a semantic re-derivation of the BPO from the model; +the current digest primitive is an internal fingerprint, not a cryptographic +authenticity claim. ## Acceptance commands @@ -62,6 +67,7 @@ Run these from a clean checkout with no private artifacts staged: ```sh lake build EventB EventBWidgets Examples gates rossi-dump eventb bench +lake exe gates --status lake exe gates pre-commit run --all-files python3 tools/cli-fixtures.py @@ -87,6 +93,10 @@ Infoview's browser layout, so this gate must be recorded separately. - The pinned `.bpo` corpus omits the 200 P3b compatibility records described above. - The corpus-scale P4 baseline has 73 external-trusted results and 1060 unproved obligations; semantic bindings are required before claiming corpus-scale kernel proof. +- Generality still has an explicit ceiling: strict concrete-parameter scope, full + frame/gluing-relation semantics, and semantic soundness proofs for every generated PO + class remain follow-up work. Right-oriented witnesses and basic multi-event MRG have + focused strict fixtures. - The official Rossi differential executable is provisioned in CI, not vendored. - Raw Rossi/XML source navigation and visual ProofWidgets acceptance require the manual editor gate. diff --git a/spike/measure.sh b/spike/measure.sh index 0b932a7..2c776c8 100755 --- a/spike/measure.sh +++ b/spike/measure.sh @@ -4,10 +4,15 @@ # names is the miss count. set -u TAC="$1"; N="${2:-200}" -python3 spike/build.py "$TAC" "$N" 2>/tmp/spike-cov.txt -TOTAL=$(grep -c '^theorem' spike/Spike/Obligations.lean) +python3 spike/build.py "$TAC" "$N" 2>/tmp/spike-cov.txt || exit $? +TOTAL=$(grep -c '^theorem' spike/Spike/Obligations.lean || true) cd spike -lake env lean Spike/Obligations.lean > /tmp/spike-out.txt 2>&1 +if lake env lean Spike/Obligations.lean > /tmp/spike-out.txt 2>&1; then + LEAN_STATUS=0 +else + LEAN_STATUS=$? +fi FAILED=$(grep -oE 'Obligations\.lean:[0-9]+' /tmp/spike-out.txt | sort -u | wc -l | tr -d ' ') echo "tactic: $TAC" echo "attempted: $TOTAL failed: $FAILED closed: $((TOTAL - FAILED))" +exit "$LEAN_STATUS" diff --git a/test/Gates.lean b/test/Gates.lean index fa41ab6..2c6bbc4 100644 --- a/test/Gates.lean +++ b/test/Gates.lean @@ -165,10 +165,30 @@ private def dedupFirst : List (String × String) → List (String × String) → if acc.any (fun p => p.1 == n) then dedupFirst rest acc else dedupFirst rest ((n, t) :: acc) +private def duplicateStrings (seen : List String) : List String → List String + | [] => [] + | name :: rest => + if seen.contains name then name :: duplicateStrings seen rest + else duplicateStrings (name :: seen) rest + +private def conflictingIdentifiers (seen : List (String × String)) : + List (String × String) → List String + | [] => [] + | (name, type) :: rest => + let conflicts := match seen.find? (fun pair => pair.1 == name) with + | some (_, previous) => if previous == type then [] else [name] + | none => [] + conflicts ++ conflictingIdentifiers ((name, type) :: seen) rest + private def readGoldTypes (path : System.FilePath) : IO (List (String × String)) := do match parseXml (← IO.FS.readBinFile path) with - | .error _ => return [] - | .ok xml => return dedupFirst (rawIdentifiers xml) [] + | .error _ => throw (IO.userError s!"cannot parse Rodin type oracle {path}") + | .ok xml => + let identifiers := rawIdentifiers xml + let conflicts := conflictingIdentifiers [] identifiers + if !conflicts.isEmpty then + throw (IO.userError s!"conflicting Rodin type identifier(s): {conflicts}") + return dedupFirst identifiers [] private structure TypeResult where key : String @@ -215,6 +235,7 @@ private def sequentCount : Nat := 1133 a human. That is the P4 bar, and the number any prover backend is measured against. -/ private def rodinAuto : Nat := 1088 private def rodinManual : Nat := 45 +private def p4Minimum : Nat := 73 mutual @@ -234,8 +255,13 @@ end private def readGoldPOs (path : System.FilePath) : IO (List String) := do match parseXml (← IO.FS.readBinFile path) with - | .error _ => return [] - | .ok xml => return poNames xml + | .error _ => throw (IO.userError s!"cannot parse Rodin PO oracle {path}") + | .ok xml => + let names := poNames xml + let duplicates := duplicateStrings [] names + if !duplicates.isEmpty then + throw (IO.userError s!"duplicate Rodin PO name(s): {duplicates}") + return names private structure PoResult where key : String @@ -303,6 +329,29 @@ where | none => acc | some (_, parent, preds) => go fuel parent (preds ++ acc) +private def predicateSetErrors + (sets : List (String × Option String × List String)) : List String := + let names := sets.map (·.1) + let duplicateNames := duplicateStrings [] names + let missingParents := sets.filterMap fun (_, parent, _) => + match parent with + | some name => if names.contains name then none else some name + | none => none + let rec cycleError : Nat → List String → Option String → Option String + | 0, _, some name => some s!"predicate-set parent chain exceeds bound at `{name}`" + | _, _, none => none + | fuel + 1, seen, some name => + if seen.contains name then some s!"cycle in predicate-set parent chain at `{name}`" + else + match sets.find? (fun set => set.1 == name) with + | none => some s!"missing predicate-set `{name}`" + | some (_, parent, _) => cycleError fuel (name :: seen) parent + let cycleErrors := sets.filterMap fun (name, _, _) => + if duplicateNames.contains name then none + else cycleError (sets.length + 1) [] (some name) + missingParents.map (fun name => s!"missing predicate-set `{name}`") ++ + cycleErrors + -- partiality: this is the corresponding test-only XML walk for predicate-set inheritance. private partial def goldHyps (e : XmlElem) (sets : List (String × Option String × List String)) : List (String × List String) := @@ -313,7 +362,11 @@ private partial def goldHyps (e : XmlElem) let inner := e.children.find? (fun c => c.tag == "org.eventb.core.poPredicateSet") let parent := inner.bind (fun i => (i.attr? "org.eventb.core.parentSet").map refName) - [(n, chainHyps sets parent)] + let direct := if n.endsWith "/WWD" then + e.children.filter (fun c => c.tag == "org.eventb.core.poPredicate") + |>.filterMap (fun c => c.attr? "org.eventb.core.predicate") + else [] + [(n, chainHyps sets parent ++ direct)] | none => [] else [] e.children.foldl (fun acc c => acc ++ goldHyps c sets) here @@ -341,10 +394,30 @@ private partial def goldGoals (e : XmlElem) : List (String × String) := else [] e.children.foldl (fun acc c => acc ++ goldGoals c) here +private partial def goalShapeErrors (e : XmlElem) : List String := + let here := + if e.tag == "org.eventb.core.poSequent" then + match e.attr? "name" with + | none => ["proof sequent has no name"] + | some name => + let direct := e.children.filter (fun c => c.tag == "org.eventb.core.poPredicate") + if name.endsWith "/WWD" then + if direct.length == 1 then [] else + [s!"WWD `{name}` has {direct.length} direct predicates"] + else if name.endsWith "/WFIS" then [] + else if direct.length == 1 then [] + else [s!"sequent `{name}` has {direct.length} goal predicates"] + else [] + here ++ e.children.flatMap goalShapeErrors + private def readGoldGoals (path : System.FilePath) : IO (List (String × String)) := do match parseXml (← IO.FS.readBinFile path) with - | .error _ => return [] - | .ok xml => return goldGoals xml + | .error _ => throw (IO.userError s!"cannot parse Rodin goal oracle {path}") + | .ok xml => + let errors := goalShapeErrors xml + if !errors.isEmpty then + throw (IO.userError s!"invalid Rodin goal shape: {String.intercalate "; " errors}") + return goldGoals xml /-- Ascriptions carry no logical content, so a generator has no reason to reproduce them. Nothing else is normalised: the gate's job is to notice a difference, and a @@ -354,6 +427,24 @@ private def comparable (t : Term) : Term := Formula.stripAscriptions t private def equivalent (left right : Term) : Bool := Formula.alphaEq (comparable left) (comparable right) +private def removeEquivalent (target : Term) : List Term → Option (List Term) + | [] => none + | term :: rest => + if equivalent target term then some rest + else (removeEquivalent target rest).map (fun remaining => term :: remaining) + +private def multisetEqual : List Term → List Term → Bool + | [], [] => true + | [], _ :: _ => false + | _ :: _, [] => false + | term :: rest, other => + match removeEquivalent term other with + | none => false + | some remaining => multisetEqual rest remaining + +private def hypothesesMatch (ours wanted : List Term) : Bool := + multisetEqual (ours.map comparable) (wanted.map comparable) + private structure GoalResult where key : String status : String @@ -368,7 +459,7 @@ private structure CoverageResult where private def coverageReasonFor (hasName hasGoal derived goalOK hypsOK : Bool) : String := if !hasName then "no-sequent" - else if !derived then "matched" + else if !derived then "not-derived" else if !hasGoal then "no-sequent" else if !goalOK then "goal-differs" else if !hypsOK then "hypotheses-differ" @@ -400,7 +491,7 @@ private def omittedInvariant (project : Project) (file name : String) : Bool := private def coverageDiagnostic (project : Project) (file : String) (obligation : Obligation) (reason : String) : String := - if reason != "no-sequent" then "none" + if reason != "no-sequent" && reason != "not-derived" then "none" else if obligation.kind == "INV" && omittedInvariant project file obligation.name then "pinned-bpo-omits-plain-type-invariant" else @@ -428,11 +519,9 @@ private def hypothesesAgree (obligation : Obligation) match gold.find? (fun p => p.1 == obligation.name) with | none => false | some (_, wanted) => - let want := wanted.filterMap (fun text => (Formula.parse text).toOption.map comparable) - let ours := obligation.hyps.map comparable - let missing := want.filter (fun w => !ours.any (equivalent w ·)) - let extra := ours.filter (fun h => !want.any (equivalent h ·)) - missing.isEmpty && extra.isEmpty + match wanted.mapM (fun text => (Formula.parse text).map comparable) with + | .error _ => false + | .ok want => hypothesesMatch obligation.hyps want private def coverage (project : Project) (file : String) (names : List String) (goals : List (String × String)) (hyps : List (String × List String)) : @@ -443,13 +532,15 @@ private def coverage (project : Project) (file : String) (names : List String) let derived := obligation.goal.isSome let goalOK := goalAgrees obligation goals let hypsOK := hypothesesAgree obligation hyps + let reason := if obligation.kind == "WWD" && !derived then + if hypsOK then "matched" else "hypotheses-differ" + else coverageReasonFor hasName hasGoal derived goalOK hypsOK { component := file kind := obligation.kind name := obligation.name derivation := if derived then "derived" else "not-derived" - reason := coverageReasonFor hasName hasGoal derived goalOK hypsOK - diagnostic := coverageDiagnostic project file obligation - (coverageReasonFor hasName hasGoal derived goalOK hypsOK) } + reason := reason + diagnostic := coverageDiagnostic project file obligation reason } private def coverageLine (record : CoverageResult) : String := String.intercalate "\t" @@ -474,13 +565,15 @@ private def compatibilityDiagnosticNames : List String := "pinned-bpo-omits-witness-feasibility-sequent"] private def isKnownCompatibilityRecord (record : CoverageResult) : Bool := - record.reason == "no-sequent" && compatibilityDiagnosticNames.contains record.diagnostic + (record.reason == "no-sequent" || record.reason == "not-derived") && + compatibilityDiagnosticNames.contains record.diagnostic private def compatibilityRecords (records : List CoverageResult) : List CoverageResult := - records.filter (fun record => record.reason == "no-sequent") + records.filter isKnownCompatibilityRecord #guard coverageReasonFor true true true false true == "goal-differs" #guard coverageReasonFor true true true true false == "hypotheses-differ" +#guard coverageReasonFor true true false true true == "not-derived" #guard compatibilityDiagnosticNames.contains "pinned-bpo-omits-definedness-sequent" #guard !compatibilityDiagnosticNames.contains "pinned-bpo-omits-sequent" @@ -510,8 +603,13 @@ private def checkGoals (project : Project) (file : String) private def readGoldHyps (path : System.FilePath) : IO (List (String × List String)) := do match parseXml (← IO.FS.readBinFile path) with - | .error _ => return [] - | .ok xml => return goldHyps xml (predicateSets xml) + | .error _ => throw (IO.userError s!"cannot parse Rodin hypothesis oracle {path}") + | .ok xml => + let sets := predicateSets xml + let errors := predicateSetErrors sets + if !errors.isEmpty then + throw (IO.userError s!"invalid Rodin predicate-set graph: {String.intercalate "; " errors}") + return goldHyps xml sets /-- Hypotheses are scored as sets: Rodin's order is an artefact of how it walks the predicate-set chain, and a generator that produces the same assumptions in a different @@ -528,13 +626,27 @@ private def checkHyps (project : Project) (file : String) if o.kind == "WFIS" then none else some { key := key, status := "FAIL:no such sequent in .bpo" } | some (_, gs) => - let want := gs.filterMap (fun t => (Formula.parse t).toOption.map comparable) - let ours := o.hyps.map comparable - let missing := want.filter (fun w => !ours.any (equivalent w ·)) - let extra := ours.filter (fun h => !want.any (equivalent h ·)) - if missing.isEmpty && extra.isEmpty then some { key := key, status := "PASS" } - else some { key := key, - status := s!"FAIL:missing {missing.length} extra {extra.length}" } + match gs.mapM (fun t => (Formula.parse t).map comparable) with + | .error _ => some { key := key, status := "FAIL:gold hypothesis unparsable" } + | .ok want => + if hypothesesMatch o.hyps want then some { key := key, status := "PASS" } + else some { key := key, + status := "FAIL:hypothesis multiset differs" } + +private def checkWWD (project : Project) (file : String) + (gold : List (String × List String)) : List GoalResult := + (generate project file).filterMap fun o => + if o.kind != "WWD" then none + else + let key := file ++ "\t" ++ o.name + match gold.find? (fun p => p.1 == o.name) with + | none => some { key := key, status := "FAIL:no such sequent in .bpo" } + | some (_, gs) => + match gs.mapM (fun t => (Formula.parse t).map comparable) with + | .error _ => some { key := key, status := "FAIL:gold hypothesis unparsable" } + | .ok want => + if hypothesesMatch o.hyps want then some { key := key, status := "PASS" } + else some { key := key, status := "FAIL:hypothesis multiset differs" } private structure P4Result where obligation : Obligation @@ -579,6 +691,13 @@ private def p4Histogram (results : List P4Result) : List (String × Nat) := | none => "no-goal") counts) []).mergeSort (fun left right => if left.2 == right.2 then left.1 < right.1 else right.2 < left.2) +private def p4BaselineLine (result : P4Result) : String := + let rule := result.result.rule.map Rule.label |>.getD "unproved" + String.intercalate "\t" + [result.obligation.component, result.obligation.name, + Trust.fingerprint result.obligation.canonical, + result.result.evidence.mode.label, rule] + private def nonemptyLines (source : String) : List String := source.splitOn "\n" |>.filter (fun line => !line.isEmpty) @@ -599,7 +718,8 @@ private def writeBaseline (path : String) (lines : List String) : IO Unit := do IO.FS.writeFile path (String.intercalate "\n" lines ++ "\n") private def writeStatus (results : List FileResult) (formulas : List FormulaResult) - (types : List TypeResult) (pos : List PoResult) (goals hyps : List GoalResult) + (types : List TypeResult) (pos : List PoResult) + (goals hyps wwd : List GoalResult) (compatibilityCount : Nat) (p4 : List P4Result) (inventory : List (String × Nat)) : IO Unit := do let passed := results.countP (fun result => result.status == "PASS") @@ -608,6 +728,7 @@ private def writeStatus (results : List FileResult) (formulas : List FormulaResu let ppass := pos.countP (fun result => result.status == "PASS") let gpass := goals.countP (fun result => result.status == "PASS") let hpass := hyps.countP (fun result => result.status == "PASS") + let wpass := wwd.countP (fun result => result.status == "PASS") let p4pass := p4.countP (·.accepted) let counts := inventory.map (fun (name, count) => s!"| {name} | {count} |") IO.FS.writeFile "STATUS.md" @@ -623,9 +744,10 @@ private def writeStatus (results : List FileResult) (formulas : List FormulaResu s!" {sequentCount} |\n" ++ s!"| P3b statements | goals derived | {gpass}/{goals.length} | tracked |\n" ++ s!"| P3b hypotheses | hypotheses derived | {hpass}/{hyps.length} | tracked |\n" ++ + s!"| P3b WWD | {wpass}/{wwd.length} hypotheses | tracked |\n" ++ s!"| P3b compatibility | pinned omissions | {compatibilityCount} | tracked |\n" ++ s!"| P4 provers | local evidence vs Rodin `.bps` | {p4pass}/{p4.length} |" ++ - " measured evidence baseline |\n" ++ + s!" ratchet ≥ {p4Minimum} accepted |\n" ++ "\n## Trust ledger\n\nThe artifact Rodin cannot produce: for each obligation, " ++ "what is actually holding it\nup. This status includes only evidence accepted " ++ "through the local ledger; it is not kernel proof.\n\n" ++ @@ -641,6 +763,11 @@ private def writeStatus (results : List FileResult) (formulas : List FormulaResu String.intercalate "\n" counts ++ "\n") private def run (args : List String) : IO UInt32 := do + let knownArgs := ["--histogram", "--coverage", "--status", "--bless"] + let unknownArgs := args.filter (fun arg => !knownArgs.contains arg) + if !unknownArgs.isEmpty then + IO.eprintln s!"unknown gates argument(s): {String.intercalate ", " unknownArgs}" + return 2 let files ← sourceFiles let mut acc : List FileResult := [] for path in files do @@ -676,6 +803,11 @@ private def run (args : List String) : IO UInt32 := do let bpo := (path.toString.dropEnd 4).toString ++ ".bpo" let name := ((path.toString.splitOn "/").getLast!.splitOn ".").head! hypResults := hypResults ++ checkHyps project name (← readGoldHyps bpo) + let mut wwdResults : List GoalResult := [] + for path in files do + let bpo := (path.toString.dropEnd 4).toString ++ ".bpo" + let name := ((path.toString.splitOn "/").getLast!.splitOn ".").head! + wwdResults := wwdResults ++ checkWWD project name (← readGoldHyps bpo) let mut coverageResults : List CoverageResult := [] for path in files do let bpo := (path.toString.dropEnd 4).toString ++ ".bpo" @@ -686,11 +818,16 @@ private def run (args : List String) : IO UInt32 := do coverageResults := coverageResults ++ coverage project name names goals hyps let hypPassed := hypResults.countP (fun r => r.status == "PASS") let hypActual := hypResults.map (fun r => r.key ++ "\t" ++ r.status) + let wwdPassed := wwdResults.countP (fun r => r.status == "PASS") + let wwdActual := wwdResults.map (fun r => r.key ++ "\t" ++ r.status) let goalPassed := goalResults.countP (fun r => r.status == "PASS") let goalActual := goalResults.map (fun r => r.key ++ "\t" ++ r.status) let poPassed := poResults.countP (fun r => r.status == "PASS") let p4Results := localResults project poResults let p4Passed := p4Results.countP (·.accepted) + let p4OK := p4Results.length == sequentCount && p4Passed >= p4Minimum + let p4Actual := p4Results.filter (·.accepted) |>.map p4BaselineLine + let wwdOK := wwdPassed == wwdResults.length let poActual := poResults.map (fun r => r.key ++ "\t" ++ r.status) let compatibility := compatibilityRecords coverageResults let compatibilityActual := compatibility.map coverageLine @@ -700,14 +837,21 @@ private def run (args : List String) : IO UInt32 := do let formulaPassed := formulas.countP (fun result => result.status == "PASS") let formulaActual := formulas.map (fun result => result.key ++ "\t" ++ result.status) let formulaCountOK := formulas.length == formulaCount + let coreOK := results.all (fun result => result.status == "PASS") && inventoryOK && + formulaCountOK && + formulaPassed == formulas.length && typeResults.length == typeCount && + typePassed == typeResults.length && poPassed == sequentCount IO.println s!"P0 reader: {filesPassed}/{results.length}" IO.println s!"P1 formulas: {formulaPassed}/{formulas.length}" IO.println s!"P2 types: {typePassed}/{typeResults.length}" if typeResults.length != typeCount then IO.eprintln s!"type assertion count {typeResults.length}, expected {typeCount}" IO.println s!"P3 obligations: {poPassed}/{sequentCount}" + IO.println (s!"P3 extras/missing: {poResults.countP (·.status == "FAIL:not in .bpo")}/" ++ + s!"{poResults.countP (·.status == "FAIL:not generated")}") IO.println s!"P3b statements: {goalPassed}/{goalResults.length} derived" IO.println s!"P3b hypotheses: {hypPassed}/{hypResults.length} derived" + IO.println s!"P3b WWD hypotheses: {wwdPassed}/{wwdResults.length}" IO.println s!"P3b compatibility: {compatibility.length} pinned omissions" IO.println s!"P4 local baseline: {p4Passed}/{p4Results.length} discharged" if !compatibilityOK then @@ -729,6 +873,8 @@ private def run (args : List String) : IO UInt32 := do IO.println s!"{count}\t{reason}" for (reason, count) in goalHistogram hypResults do IO.println s!"{count}\t{reason}" + for (reason, count) in goalHistogram wwdResults do + IO.println s!"{count}\tWWD\t{reason}" for (shape, count) in p4Histogram p4Results do IO.println s!"{count}\tP4\t{shape}" for (reason, count) in coverageHistogram coverageResults do @@ -738,22 +884,31 @@ private def run (args : List String) : IO UInt32 := do for record in coverageResults do IO.println (coverageLine record) if args.contains "--status" then - writeStatus results formulas typeResults poResults goalResults hypResults compatibility.length + writeStatus results formulas typeResults poResults goalResults hypResults wwdResults + compatibility.length p4Results inventory - let parseOK := results.all (fun result => result.status == "PASS") if args.contains "--bless" then -- P0 must be perfect to bless, since a dropped file would silently shrink the P1 -- denominator. P1 blesses whatever it currently reaches: that is the ratchet. - if parseOK && inventoryOK && formulaCountOK && compatibilityOK then + let oldStatements ← try IO.FS.readFile "baseline/statement.tsv" catch _ => pure "" + let oldHypotheses ← try IO.FS.readFile "baseline/hypothesis.tsv" catch _ => pure "" + let noP3bShrink := + (nonemptyLines oldStatements).all (fun line => goalActual.contains line) && + (nonemptyLines oldHypotheses).all (fun line => hypActual.contains line) + if coreOK && compatibilityOK && p4OK && wwdOK && noP3bShrink then writeBaseline "baseline/parse.tsv" actual writeBaseline "baseline/formula.tsv" formulaActual writeBaseline "baseline/typecheck.tsv" typeActual writeBaseline "baseline/pog.tsv" poActual writeBaseline "baseline/statement.tsv" goalActual writeBaseline "baseline/hypothesis.tsv" hypActual + writeBaseline "baseline/wwd.tsv" wwdActual writeBaseline "baseline/compatibility.tsv" compatibilityActual + writeBaseline "baseline/p4.tsv" p4Actual else - IO.eprintln "refusing to bless a failed P0 gate" + IO.eprintln (if noP3bShrink then + "refusing to bless a failed acceptance gate" + else "refusing to bless a reduced P3b baseline") return 1 return 0 let baseline ← try IO.FS.readFile "baseline/parse.tsv" catch _ => pure "" @@ -768,13 +923,18 @@ private def run (args : List String) : IO UInt32 := do let gbaselineOK ← baselineDiff (nonemptyLines gbaseline) goalActual let hbaseline ← try IO.FS.readFile "baseline/hypothesis.tsv" catch _ => pure "" let hbaselineOK ← baselineDiff (nonemptyLines hbaseline) hypActual + let wbaseline ← try IO.FS.readFile "baseline/wwd.tsv" catch _ => pure "" + let wbaselineOK ← baselineDiff (nonemptyLines wbaseline) wwdActual let cbaseline ← try IO.FS.readFile "baseline/compatibility.tsv" catch _ => pure "" let cbaselineOK ← baselineDiff (nonemptyLines cbaseline) compatibilityActual + let p4baseline ← try IO.FS.readFile "baseline/p4.tsv" catch _ => pure "" + let p4baselineOK ← baselineDiff (nonemptyLines p4baseline) p4Actual if !baselineOK || !fbaselineOK || !tbaselineOK || !pbaselineOK || !gbaselineOK - || !hbaselineOK || !cbaselineOK || !compatibilityOK then + || !hbaselineOK || !wbaselineOK || !cbaselineOK || !p4baselineOK || + !compatibilityOK || !wwdOK then return 1 - if parseOK && inventoryOK && formulaCountOK then - if p4Results.length == sequentCount then return 0 else return 1 + if coreOK && p4OK && wwdOK then + return 0 return 1 end EventB.Gates diff --git a/tools/cli-fixtures.py b/tools/cli-fixtures.py index fd788a4..83c6af6 100644 --- a/tools/cli-fixtures.py +++ b/tools/cli-fixtures.py @@ -57,7 +57,13 @@ def check_witness() -> None: actual = [(record["machine"], record["name"], record["kind"], record["derived"], record["hypothesis_only"]) for record in records] expected = [ + ("Abstract", "INITIALISATION/inv/INV", "INV", True, False), + ("Abstract", "INITIALISATION/act1/FIS", "FIS", True, False), ("Abstract", "step/inv/INV", "INV", True, False), + ("Concrete", "INITIALISATION/inv/INV", "INV", True, False), + ("Concrete", "INITIALISATION/act1/SIM", "SIM", True, False), + ("Concrete", "INITIALISATION/act1/FIS", "FIS", True, False), + ("Concrete", "INITIALISATION/act2/FIS", "FIS", True, False), ("Concrete", "step/inv/INV", "INV", True, False), ("Concrete", "step/grd/GRD", "GRD", True, False), ("Concrete", "step/act/SIM", "SIM", True, False), @@ -72,17 +78,17 @@ def check_witness() -> None: expect("witness summary", result, 0) summary = json.loads(result.stdout) if summary != { - "obligations": 7, - "derived": 6, - "by_class": {"INV": 2, "GRD": 1, "SIM": 1, "WD": 1, "WFIS": 1, + "obligations": 13, + "derived": 12, + "by_class": {"INV": 4, "FIS": 3, "SIM": 2, "GRD": 1, "WD": 1, "WFIS": 1, "WWD": 1}, "not_derived": 1, "not_derived_by_class": {"WWD": 1}, "hypothesis_only": 1, "by_machine": { "C": {"obligations": 0, "derived": 0}, - "Abstract": {"obligations": 1, "derived": 1}, - "Concrete": {"obligations": 6, "derived": 5}, + "Abstract": {"obligations": 3, "derived": 3}, + "Concrete": {"obligations": 10, "derived": 9}, }, }: raise AssertionError(f"witness summary: unexpected JSON\n{summary}") @@ -92,14 +98,14 @@ def check_witness() -> None: report = json.loads(result.stdout) if report["coverage_source"] != "none": raise AssertionError("witness report: Rossi-only coverage must be none") - if len(report["obligations"]) != 7: - raise AssertionError("witness report: expected seven obligations") + if len(report["obligations"]) != 13: + raise AssertionError("witness report: expected thirteen obligations") if report["trust_ledger"] != { "kernel-checked": 0, "smt-trusted": 0, "rodin-imported": 0, - "external-trusted": 2, - "unproved": 5, + "external-trusted": 5, + "unproved": 8, }: raise AssertionError("witness report: trust ledger changed") for record in report["obligations"]: @@ -123,7 +129,7 @@ def check_witness() -> None: result = run("po", path, "step/wit/WFIS") expect("witness WFIS", result, 0, "∃") result = run("prove", path) - expect("witness prove", result, 0, "local baseline: 2/7 discharged") + expect("witness prove", result, 0, "local baseline: 5/13 discharged") def check_rossi_dump() -> None: @@ -198,8 +204,7 @@ def check_theories_and_errors() -> None: def check_corpus_diff() -> None: result = run("diff", "corpus/aman") - expect("corpus diff diagnostics", result, 1, stdout="M0_AMAN_Update", - stderr="unbound identifier") + expect("corpus diff diagnostics", result, 1, stdout="M0_AMAN_Update") def check_gate_reports() -> None: From 55ad2490e37674cd886ceb65d61afec09488c1b4 Mon Sep 17 00:00:00 2001 From: Jonathan Cubides Date: Fri, 14 Aug 2026 15:14:24 -0500 Subject: [PATCH 4/8] fix(accuracy): harden refinement trust --- EventB/POG.lean | 103 +++++++++++++-- EventB/Trust.lean | 47 ++++++- EventB/Trust/Replay.lean | 20 +++ EventB/Trust/Rodin.lean | 224 +++++++++++++++++++++++++++++---- EventB/Typing/Check.lean | 5 +- TODO.md | 4 +- Widgets.lean | 2 + cli/Cli.lean | 8 ++ examples/TrustRodinDemo.lean | 3 +- notes/architecture.md | 4 +- notes/production-acceptance.md | 17 ++- test/Gates.lean | 62 +++++++-- 12 files changed, 439 insertions(+), 60 deletions(-) diff --git a/EventB/POG.lean b/EventB/POG.lean index 921d8e1..750aa2d 100644 --- a/EventB/POG.lean +++ b/EventB/POG.lean @@ -344,13 +344,14 @@ private def frameRelations (variables : List String) (actions : List Elem) : Lis private def concreteStateRelations (variables : List String) (actions : List Elem) : List Term := actions.flatMap actionAfterRelation ++ frameRelations variables actions -private def concreteStateRelationsAccurate (variables : List String) +private def concreteStateRelationsAccurate (initialization : Bool) (variables : List String) (actions : List Elem) : List Term := - actions.flatMap actionAfterRelationAccurate ++ frameRelations variables actions + actions.flatMap actionAfterRelationAccurate ++ + if initialization then [] else frameRelations variables actions -private def concreteStateRelationsMode (strict : Bool) (variables : List String) +private def concreteStateRelationsMode (strict initialization : Bool) (variables : List String) (actions : List Elem) : List Term := - if strict then concreteStateRelationsAccurate variables actions + if strict then concreteStateRelationsAccurate initialization variables actions else concreteStateRelations variables actions private def actionAfterSubst (action : Elem) : List (String × Term) := @@ -653,6 +654,19 @@ private def assignmentWdGoal (strict : Bool) (theory : Theory.Env) let source ← attrOf action "assignment" let parsed ← Formula.parse source |>.toOption match parsed with + | .bin "≔" lhs rhs => + if !strict then + let rhs ← assignmentRhs source + wdGoal theory roots totalKeywords types rhs + else + let lhsTerms := Formula.flattenCommas lhs |>.filterMap fun term => + match term with + | .app _ _ => some term + | _ => none + let terms := lhsTerms ++ Formula.flattenCommas rhs + let goals ← terms.mapM fun term => + wdGoal theory roots totalKeywords types (Formula.print term) + pure (goals.foldl wdAnd wdTop) | .bin ":∣" _ predicate => let body ← wdGoal theory roots totalKeywords types (Formula.print predicate) if !strict then some body else @@ -857,7 +871,9 @@ private def generateInMode (strict : Bool) (theory : Theory.Env) (p : Project) let concreteVariables := (childrenOf c.elem "variable").filterMap (attrOf · "identifier") let concreteActions := if strict then accurateTransitionActions p name ev else initializationActions p c ev - let concreteRelations := concreteStateRelationsMode strict concreteVariables concreteActions + let initialization := labelOf ev == "INITIALISATION" + let concreteRelations := + concreteStateRelationsMode strict initialization concreteVariables concreteActions -- A non-extended refined event still executes its abstract actions. Use the -- refinement substitution here so inherited assignments trigger preservation -- obligations for concrete invariants as well as for the after-state formula. @@ -925,8 +941,9 @@ private def generateInMode (strict : Bool) (theory : Theory.Env) (p : Project) let concrete := concreteActions.flatMap substOf let concreteTargets := concreteActions.flatMap assignedBy let concreteAfter := concreteActions.flatMap actionAfterSubst + let initialization := labelOf ev == "INITIALISATION" let concreteRelations := - concreteStateRelationsMode strict concreteVariables concreteActions + concreteStateRelationsMode strict initialization concreteVariables concreteActions for act in effectiveActions p am ae do let abstractRelation := if strict then actionRelationAccurate act else actionRelation act @@ -954,7 +971,8 @@ private def generateInMode (strict : Bool) (theory : Theory.Env) (p : Project) | some goal => let needsActionRelation := abstractRelation.isSome || (concreteActions.any (fun q => !(nondeterministicSubst q).isEmpty)) - let frameRelations := match abstractRelation, substOf act with + let frameRelations := if initialization then [] else + match abstractRelation, substOf act with | none, abstractAssignments => abstractAssignments.filterMap fun (v, _) => if concreteVariables.contains v && !concreteTargets.contains v then @@ -1175,6 +1193,60 @@ private def nonEqualityWitnessProject : Project := , .action [("org.eventb.core.label", "set"), ("org.eventb.core.assignment", "x ≔ q")] []]] }] +private def extendedParameterProject : Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [.parameter [("org.eventb.core.identifier", "p")] [] + , .guard [("org.eventb.core.label", "g"), + ("org.eventb.core.predicate", "p > 0")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ p")] []]] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [.refinesMachine [("org.eventb.core.target", "A")] [] + , .variable [("org.eventb.core.identifier", "x")] [] + , .variable [("org.eventb.core.identifier", "y")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [.refinesEvent [("org.eventb.core.target", "step"), + ("org.eventb.core.extended", "true")] [] + , .action [("org.eventb.core.label", "set_y"), + ("org.eventb.core.assignment", "y ≔ p")] []]] }] + +private def initializationRefinementProject : Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .invariant [("org.eventb.core.label", "inv"), + ("org.eventb.core.predicate", "x ∈ ℤ")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] + [.action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ 0")] []]] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [.refinesMachine [("org.eventb.core.target", "A")] [] + , .variable [("org.eventb.core.identifier", "x")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] []] }] + +private def functionUpdateWdProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.variable [("org.eventb.core.identifier", "f")] [] + , .invariant [("org.eventb.core.label", "type"), + ("org.eventb.core.predicate", "f ∈ ℤ ⇸ ℤ")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] + [.action [("org.eventb.core.label", "empty"), + ("org.eventb.core.assignment", "f ≔ ∅")] []] + , .event [("org.eventb.core.label", "step")] + [.parameter [("org.eventb.core.identifier", "i")] [] + , .guard [("org.eventb.core.label", "domain"), + ("org.eventb.core.predicate", "i ∈ ℤ")] [] + , .action [("org.eventb.core.label", "update"), + ("org.eventb.core.assignment", "f(i) ≔ 1 ÷ i")] []]] }] + #guard match generateChecked checkedMissingProject "M" with | .error _ => true | .ok _ => false @@ -1207,4 +1279,21 @@ private def nonEqualityWitnessProject : Project := obligation.name == "step/p/WFIS" && obligation.goal.isSome) | .error _ => false +#guard match generateChecked extendedParameterProject "B" with + | .ok _ => true + | .error _ => false + +#guard match generateChecked initializationRefinementProject "B" with + | .ok obligations => obligations.all (fun obligation => + obligation.name != "INITIALISATION/set/SIM" || + !obligation.hyps.any (fun hypothesis => + hypothesis == .bin "=" (.id "x'") (.id "x"))) + | .error _ => false + +#guard match generateChecked functionUpdateWdProject "M" with + | .ok obligations => obligations.any (fun obligation => + obligation.name == "step/update/WD" && + obligation.goal.map (fun goal => !(Formula.print goal).contains "f(i) ⇒") == some true) + | .error _ => false + end EventB.POG diff --git a/EventB/Trust.lean b/EventB/Trust.lean index bd7eda8..b9b3d88 100644 --- a/EventB/Trust.lean +++ b/EventB/Trust.lean @@ -36,6 +36,8 @@ inductive Evidence where | smt (solver : String) (version : String) (inputDigest : String) (verifier : String) | external (tool : String) (version : String) (artifactDigest : String) (verifier : String) | rodinImported (source : String) (digest : String) (manual : Bool) + | rodinImportedProvenance (model : String) (bpo : String) (statuses : String) + (digest : String) (manual : Bool) deriving BEq, Repr, Inhabited def Evidence.mode : Evidence → Mode @@ -44,6 +46,7 @@ def Evidence.mode : Evidence → Mode | .smt _ _ _ _ => .smt | .external _ _ _ _ => .external | .rodinImported _ _ _ => .rodinImported + | .rodinImportedProvenance _ _ _ _ _ => .rodinImported def Evidence.isWellFormed : Evidence → Bool | .none => false @@ -53,6 +56,8 @@ def Evidence.isWellFormed : Evidence → Bool | .external tool version digest verifier => !tool.isEmpty && !version.isEmpty && !digest.isEmpty && !verifier.isEmpty | .rodinImported source digest _ => !source.isEmpty && !digest.isEmpty + | .rodinImportedProvenance model bpo statuses digest _ => + !model.isEmpty && !bpo.isEmpty && !statuses.isEmpty && !digest.isEmpty def fingerprint (canonical : String) : String := s!"eventb-v1-{String.hash canonical}" @@ -70,7 +75,10 @@ structure Entry where deriving BEq, Repr, Inhabited def Entry.isConsistent (entry : Entry) : Bool := - entry.mode == entry.evidence.mode && + !entry.component.isEmpty && !entry.obligation.isEmpty && + !entry.canonical.isEmpty && entry.fingerprint == Trust.fingerprint entry.canonical && + (entry.mode != .kernel || !entry.semanticFingerprint.isEmpty) && + entry.mode == entry.evidence.mode && (entry.mode == .unproved || entry.evidence.isWellFormed) structure Ledger where @@ -89,10 +97,24 @@ private def sameEntry (entry : Entry) (component name : String) : Bool := def Ledger.entry? (ledger : Ledger) (component name : String) : Option Entry := ledger.entries.find? (sameEntry · component name) +def Ledger.validate (ledger : Ledger) : Except EventB.Error Unit := + let rec go (seen : List String) : List Entry → Except EventB.Error Unit + | [] => .ok () + | entry :: rest => + let key := entry.component ++ "\t" ++ entry.obligation + if seen.contains key then + .error (EventB.Error.trust s!"ledger has duplicate entry `{key}`") + else if !entry.isConsistent then + .error (EventB.Error.trust s!"ledger entry `{key}` is inconsistent") + else go (key :: seen) rest + go [] ledger.entries + def Ledger.attach (ledger : Ledger) (obligation : POG.Obligation) (evidence : Evidence) : Except EventB.Error Ledger := let expected := fingerprint obligation.canonical - if !obligation.diagnostics.isEmpty then + if let .error error := ledger.validate then + .error error + else if !obligation.diagnostics.isEmpty then .error (EventB.Error.trust s!"cannot attach evidence to `{obligation.component}:{obligation.name}` with diagnostics") else if obligation.goal.isNone then @@ -101,7 +123,7 @@ def Ledger.attach (ledger : Ledger) (obligation : POG.Obligation) (evidence : Ev else if evidence matches .kernel .. then .error (EventB.Error.trust "kernel evidence must be validated by Trust.Replay before ledger attachment") - else if evidence matches .rodinImported .. then + else if evidence matches .rodinImported .. || evidence matches .rodinImportedProvenance .. then .error (EventB.Error.trust "Rodin evidence must be attached through Trust.Rodin after artifact parsing") else if !evidence.isWellFormed then @@ -162,6 +184,17 @@ private def sampleLedger : Ledger := Ledger.ofObligations [sampleObligation] private def inconsistentLedger : Ledger := { entries := [{ sampleLedger.entries.head! with evidence := .kernel "forged" }] } +private def unrelatedObligation : POG.Obligation := + { sampleObligation with name := "INITIALISATION/inv2/INV" } + +private def unrelatedInconsistentLedger : Ledger := + { entries := [inconsistentLedger.entries.head!, + (Ledger.ofObligations [unrelatedObligation]).entries.head!] } + +private def forgedKernelLedger : Ledger := + { entries := [{ sampleLedger.entries.head! with + mode := .kernel, evidence := .kernel "forged" }] } + private def renamedSample : POG.Obligation := { sampleObligation with name := "display-only", kind := "INV" } @@ -191,6 +224,14 @@ private def renamedSample : POG.Obligation := sampleObligation (.external "sample" "1" "digest" "checker") with | .error _ => true | .ok _ => false +#guard match Ledger.attach + unrelatedInconsistentLedger + unrelatedObligation (.external "sample" "1" "digest" "checker") with + | .error _ => true + | .ok _ => false +#guard match forgedKernelLedger.validate with + | .error _ => true + | .ok _ => false #guard match sampleLedger.attach { sampleObligation with goal := some (.id "⊥") } (.kernel "Sample.inv1") with | .error _ => true diff --git a/EventB/Trust/Replay.lean b/EventB/Trust/Replay.lean index 7771ad1..52a1d84 100644 --- a/EventB/Trust/Replay.lean +++ b/EventB/Trust/Replay.lean @@ -164,6 +164,26 @@ def validate (context : Embedding.KernelContext) (obligation : POG.Obligation) : unless obligation.goal.isSome do throwError s!"obligation `{obligation.name}` has no translated goal" pure { mode := evidence.mode, fingerprint := proofFingerprint context obligation } + | evidence@(.rodinImportedProvenance model bpo statuses digest manual) => do + let provenance : Rodin.Provenance := { model, bpo, statuses } + unless digest == Rodin.provenanceDigest provenance do + throwError "Rodin provenance digest mismatch" + let parsed ← match Rodin.importStatuses statuses with + | .ok parsed => pure parsed + | .error error => throwError error.message + match parsed.find? (fun status => status.name == obligation.name) with + | none => throwError s!"Rodin evidence artifact has no status for `{obligation.name}`" + | some status => + match Rodin.validateProvenance obligation provenance status with + | .ok _ => pure () + | .error error => throwError error.message + unless status.manual == manual do + throwError s!"Rodin evidence manual flag mismatch for `{obligation.name}`" + unless obligation.diagnostics.isEmpty do + throwError s!"obligation `{obligation.name}` has diagnostics" + unless obligation.goal.isSome do + throwError s!"obligation `{obligation.name}` has no translated goal" + pure { mode := evidence.mode, fingerprint := proofFingerprint context obligation } | evidence => do unless obligation.diagnostics.isEmpty do throwError s!"obligation `{obligation.name}` has diagnostics" diff --git a/EventB/Trust/Rodin.lean b/EventB/Trust/Rodin.lean index 8087854..c050ef0 100644 --- a/EventB/Trust/Rodin.lean +++ b/EventB/Trust/Rodin.lean @@ -103,14 +103,19 @@ private def duplicateKeys (seen : List String) : List String → List String if seen.contains key then key :: duplicateKeys seen rest else duplicateKeys (key :: seen) rest +def provenanceDigest (provenance : Provenance) : String := + s!"eventb-v2-{String.hash + (provenance.model ++ "\n" ++ provenance.bpo ++ "\n" ++ provenance.statuses)}" + def compare (obligations : List POG.Obligation) (statuses : List Status) : Comparison := let eligible := obligations.filter fun obligation => obligation.diagnostics.isEmpty && obligation.goal.isSome let expected := eligible.map (·.name) let duplicateExpected := duplicateKeys [] (eligible.map fun obligation => obligation.component ++ "\t" ++ obligation.name) + let duplicateStatuses := duplicateKeys [] (statuses.map (·.name)) let scopeAmbiguous := (eligible.map (·.component)).eraseDups.length > 1 || - !duplicateExpected.isEmpty + !duplicateExpected.isEmpty || !duplicateStatuses.isEmpty let present := if scopeAmbiguous then [] else eligible.filterMap fun obligation => match status? statuses obligation.name with | some status => if status.discharged then some (obligation.name, status) else none @@ -125,8 +130,10 @@ def compare (obligations : List POG.Obligation) (statuses : List Status) : Compa stale := statuses.countP (fun status => !expected.contains status.name) } private def attachVerified (ledger : Ledger) (obligation : POG.Obligation) - (source : String) (manual : Bool) : Except EventB.Error Ledger := - let evidence := .rodinImported source (s!"eventb-v1-{String.hash source}") manual + (provenance : Provenance) (manual : Bool) : Except EventB.Error Ledger := do + ledger.validate + let evidence := .rodinImportedProvenance provenance.model provenance.bpo provenance.statuses + (provenanceDigest provenance) manual if !obligation.diagnostics.isEmpty then .error (EventB.Error.trust "cannot attach Rodin evidence to an obligation with diagnostics") else if obligation.goal.isNone then @@ -154,23 +161,137 @@ private def attachVerified (ledger : Ledger) (obligation : POG.Obligation) { current with mode := .rodinImported, evidence := evidence } else current } -private partial def hasPoSequent : XmlElem → String → Bool - | elem, name => - (elem.tag == "org.eventb.core.poSequent" && elem.attr? "name" == some name) || - elem.children.any (fun child => hasPoSequent child name) - -private def rootModelName (source : String) : Except EventB.Error String := do +private def rootModel (source : String) : Except EventB.Error (String × String) := do let root ← match parseXmlString source with | .ok root => pure root | .error error => .error (EventB.Error.trust s!"invalid model XML: {error.pretty source.toUTF8}") + unless root.tag == "org.eventb.core.machineFile" || + root.tag == "org.eventb.core.contextFile" do + throw (EventB.Error.trust s!"unsupported Rodin model root `{root.tag}`") match root.attr? "org.eventb.core.name" with - | some name => pure name + | some name => pure (name, root.tag) | none => .error (EventB.Error.trust "model XML has no component name") -def attachProvenance (ledger : Ledger) (obligation : POG.Obligation) - (provenance : Provenance) (status : Status) : Except EventB.Error Ledger := do - let modelName ← rootModelName provenance.model +private partial def findPoSequent (elem : XmlElem) (name : String) : Option XmlElem := + if elem.tag == "org.eventb.core.poSequent" && elem.attr? "name" == some name then + some elem + else + match elem.children.filterMap (fun child => findPoSequent child name) with + | first :: _ => some first + | [] => none + +private def predicateTexts (elem : XmlElem) : List String := + elem.children.filterMap fun child => + if child.tag == "org.eventb.core.poPredicate" then + child.attr? "org.eventb.core.predicate" + else none + +private def sequentGoal (name : String) (sequent : XmlElem) : Option String := + let direct := predicateTexts sequent + let witness := if name.endsWith "/WFIS" then + sequent.children.filter (fun child => child.tag == "org.eventb.core.poPredicateSet") + |>.flatMap predicateTexts + else [] + (direct ++ witness).getLast? + +private structure PredicateSet where + name : String + parent : Option String + predicates : List String + +private def refName (ref : String) : String := + ((ref.splitOn "#").getLast!).replace "\\/" "/" + |>.replace "\\\\" "\\" + |>.replace "\\|" "|" + +private partial def predicateSets (elem : XmlElem) : List PredicateSet := + let here := if elem.tag == "org.eventb.core.poPredicateSet" then + [{ name := (elem.attr? "name").getD "" + parent := (elem.attr? "org.eventb.core.parentSet").map refName + predicates := predicateTexts elem }] + else [] + here ++ elem.children.flatMap predicateSets + +private def chainPredicates (sets : List PredicateSet) : Nat → Option String → + List String → Option (List String) + | 0, some _, _ => none + | _, none, acc => some acc + | fuel + 1, some name, acc => + match sets.find? (fun set => set.name == name) with + | some set => chainPredicates sets fuel set.parent (set.predicates ++ acc) + | none => none + +private def sequentHypotheses (name : String) (sequent : XmlElem) + (sets : List PredicateSet) : Option (List String) := + let inner := sequent.children.find? (fun child => + child.tag == "org.eventb.core.poPredicateSet") + let parent := inner.bind (fun set => + (set.attr? "org.eventb.core.parentSet").map refName) + let direct := if name.endsWith "/WWD" then predicateTexts sequent else [] + chainPredicates sets (sets.length + 1) parent [] |>.map (· ++ direct) + +private def removeEquivalent (target : Formula.Term) : List Formula.Term → + Option (List Formula.Term) + | [] => none + | term :: rest => + if Formula.alphaEq (Formula.stripAscriptions target) + (Formula.stripAscriptions term) then some rest + else removeEquivalent target rest |>.map (fun remaining => term :: remaining) + +private def hypothesisMultisetEqual : List Formula.Term → List Formula.Term → Bool + | [], [] => true + | [], _ :: _ => false + | _ :: _, [] => false + | term :: rest, other => + match removeEquivalent term other with + | some remaining => hypothesisMultisetEqual rest remaining + | none => false + +private def validateHypotheses (obligation : POG.Obligation) (bpo : XmlElem) : + Except EventB.Error Unit := do + let sequent ← match findPoSequent bpo obligation.name with + | some sequent => pure sequent + | none => .error (EventB.Error.trust + s!"Rodin PO artifact has no sequent for `{obligation.name}`") + let texts ← match sequentHypotheses obligation.name sequent (predicateSets bpo) with + | some texts => pure texts + | none => .error (EventB.Error.trust + s!"Rodin hypothesis chain for `{obligation.name}` is invalid") + let actual ← match texts.mapM Formula.parse with + | .ok terms => pure terms + | .error error => .error (EventB.Error.trust + s!"Rodin hypothesis for `{obligation.name}` is not a formula: {error.message}") + unless hypothesisMultisetEqual obligation.hyps actual do + throw (EventB.Error.trust + "Rodin hypotheses do not match the canonical obligation context") + +private def validateGoal (obligation : POG.Obligation) (bpo : XmlElem) : + Except EventB.Error Unit := do + let expected ← match obligation.goal with + | some goal => pure goal + | none => .error (EventB.Error.trust + s!"cannot validate statement-less obligation `{obligation.name}`") + let sequent ← match findPoSequent bpo obligation.name with + | some sequent => pure sequent + | none => .error (EventB.Error.trust + s!"Rodin PO artifact has no sequent for `{obligation.name}`") + let source ← match sequentGoal obligation.name sequent with + | some source => pure source + | none => .error (EventB.Error.trust + s!"Rodin sequent `{obligation.name}` has no goal predicate") + let actual ← match Formula.parse source with + | .ok term => pure term + | .error error => .error (EventB.Error.trust + s!"Rodin goal for `{obligation.name}` is not a formula: {error.message}") + unless Formula.alphaEq (Formula.stripAscriptions expected) + (Formula.stripAscriptions actual) do + throw (EventB.Error.trust + "Rodin goal does not match the canonical obligation statement") + +def validateProvenance (obligation : POG.Obligation) (provenance : Provenance) + (status : Status) : Except EventB.Error Unit := do + let (modelName, modelTag) ← rootModel provenance.model unless modelName == obligation.component do throw (EventB.Error.trust s! "Rodin model provenance names `{modelName}`, expected `{obligation.component}`") @@ -178,12 +299,17 @@ def attachProvenance (ledger : Ledger) (obligation : POG.Obligation) | .ok root => pure root | .error error => .error (EventB.Error.trust s!"invalid PO XML: {error.pretty provenance.bpo.toUTF8}") - unless hasPoSequent bpo obligation.name do - throw (EventB.Error.trust s! - "Rodin PO artifact has no sequent for `{obligation.name}`") - unless (provenance.bpo.splitOn (obligation.component ++ ".bum")).length > 1 do - throw (EventB.Error.trust - "Rodin PO artifact is not bound to the stated model component") + unless bpo.tag == "org.eventb.core.poFile" do + throw (EventB.Error.trust s!"unsupported Rodin PO root `{bpo.tag}`") + let expectedSource := if modelTag == "org.eventb.core.machineFile" then + obligation.component ++ ".bum" else obligation.component ++ ".buc" + let source ← match bpo.attr? "source" with + | some value => pure value + | none => .error (EventB.Error.trust "Rodin PO artifact has no source") + unless source == expectedSource do + throw (EventB.Error.trust "Rodin PO source is not the stated model component") + validateGoal obligation bpo + validateHypotheses obligation bpo let statuses ← importStatuses provenance.statuses match status? statuses obligation.name with | none => .error (EventB.Error.trust s! @@ -192,12 +318,14 @@ def attachProvenance (ledger : Ledger) (obligation : POG.Obligation) if imported != status then .error (EventB.Error.trust s! "supplied proof status does not match the parsed artifact for `{obligation.name}`") - else if status.confidence == 0 then - .error (EventB.Error.trust s!"proof-status `{status.name}` has zero confidence") - else if status.discharged then - attachVerified ledger obligation provenance.statuses status.manual - else + else if !status.discharged then .error (EventB.Error.trust s!"proof-status `{status.name}` is not discharged") + else pure () + +def attachProvenance (ledger : Ledger) (obligation : POG.Obligation) + (provenance : Provenance) (status : Status) : Except EventB.Error Ledger := do + validateProvenance obligation provenance status + attachVerified ledger obligation provenance status.manual def attach (_ledger : Ledger) (_obligation : POG.Obligation) (_source : String) (_status : Status) : Except EventB.Error Ledger := @@ -218,7 +346,8 @@ private def sampleProvenance : String → Provenance := fun statuses => "org.eventb.core.name=\"Sample\"/>" bpo := "" ++ "" + "name=\"evt/inv/INV\">" statuses } #guard match importStatuses sampleSource with @@ -282,6 +411,10 @@ private def sampleProvenance : String → Provenance := fun statuses => duplicate.scopeAmbiguous && duplicate.discharged == 0 | _ => false +#guard let status : Status := { name := sampleObligation.name, confidence := 1000, manual := true } + let comparison := compare [sampleObligation] [status, status] + comparison.scopeAmbiguous && comparison.discharged == 0 + #guard match importStatuses sampleSource with | .ok statuses => let invalid := { sampleObligation with diagnostics := ["unresolved"] } @@ -292,10 +425,49 @@ private def sampleProvenance : String → Provenance := fun statuses => #guard match importStatuses sampleSource with | .ok [status] => match attachProvenance (Ledger.ofObligations [sampleObligation]) sampleObligation (sampleProvenance sampleSource) status with - | .ok ledger => ledger.count .rodinImported == 1 + | .ok ledger => + match ledger.entries.head? with + | some entry => + match entry.evidence with + | .rodinImportedProvenance model bpo statuses digest manual => + manual && digest == provenanceDigest { model, bpo, statuses } + | _ => false + | none => false | .error _ => false | _ => false +#guard match importStatuses sampleSource with + | .ok [status] => + let badModel := { sampleProvenance sampleSource with + model := (sampleProvenance sampleSource).model.replace + "org.eventb.core.machineFile" "org.eventb.core.fakeFile" } + match attachProvenance (Ledger.ofObligations [sampleObligation]) + sampleObligation badModel status with + | .error _ => true + | .ok _ => false + | _ => false + +#guard match importStatuses sampleSource with + | .ok [status] => + let badPo := { sampleProvenance sampleSource with + bpo := (sampleProvenance sampleSource).bpo.replace + "org.eventb.core.poFile" "org.eventb.core.fakeFile" } + match attachProvenance (Ledger.ofObligations [sampleObligation]) + sampleObligation badPo status with + | .error _ => true + | .ok _ => false + | _ => false + +#guard match importStatuses sampleSource with + | .ok [status] => + let badGoal := { sampleProvenance sampleSource with + bpo := (sampleProvenance sampleSource).bpo.replace "predicate=\"⊤\"" "predicate=\"⊥\"" } + match attachProvenance (Ledger.ofObligations [sampleObligation]) + sampleObligation badGoal status with + | .error _ => true + | .ok _ => false + | _ => false + #guard match importStatuses sampleSource with | .ok [status] => match attachProvenance (Ledger.ofObligations [sampleObligation]) sampleObligation diff --git a/EventB/Typing/Check.lean b/EventB/Typing/Check.lean index 39da7c3..935e31d 100644 --- a/EventB/Typing/Check.lean +++ b/EventB/Typing/Check.lean @@ -423,8 +423,9 @@ private def addComponentMode (strict : Bool) (p : Project) (c : Component) : M ( let (eventErrors, bound) ← withEnvBindings do let mut eventErrors : List String := [] -- Compatibility inference mirrors the pinned corpus. Strict inference keeps - -- abstract parameters available only while checking witness predicates. - if !strict then + -- abstract parameters out of ordinary refining events, except for genuinely + -- extended events, where Event-B makes the inherited parameters visible. + if !strict || isExtended ev then for (name, ty) in inheritedParams do bind name ty for prm in childrenOf ev "parameter" do if let some n := attrOf prm "identifier" then bind n (← fresh) diff --git a/TODO.md b/TODO.md index 3054394..22ebf54 100644 --- a/TODO.md +++ b/TODO.md @@ -85,9 +85,9 @@ comparison, a full build, and a fresh adversarial review before its checkbox is | General refinement typing | AMAN/event-scope and missing-reference negative controls pass | current | | POG semantic coverage | nondeterministic actions, SIM, WWD, variants, EQL/MRG implemented | strict checked path; edge ceiling remains | | Kernel trust | replay checks reject open mvars, stale goals, forged axioms, and context drift | current | -| External/Rodin provenance | model/BPO/status identity, canonical/fingerprint binding, monotonic ledger update | current; semantic re-derivation and cryptographic authenticity remain outside the contract | +| External/Rodin provenance | model/BPO/status identity, canonical goal/fingerprint binding, monotonic ledger update | current; hypothesis/model re-derivation and cryptographic authenticity remain outside the contract | | Release reproducibility | CLI fixture, gate status, and exact baseline ratchet are required | active | -| Official Rossi differential | executable unavailable locally; CI provisions pinned v0.1.7 | local evidence unavailable | +| Official Rossi differential | pinned v0.1.7 SHA verified; x86_64 guest validates all four fixtures; CI provisions the exact differential command | current; CI remains release gate | The ledger is updated after every implementation commit. A phase is not complete when the build is green if a counterexample, oracle comparison, or adversarial review remains diff --git a/Widgets.lean b/Widgets.lean index 9391205..da0d5b0 100644 --- a/Widgets.lean +++ b/Widgets.lean @@ -49,6 +49,8 @@ private def evidenceLabel : Trust.Evidence → String | .external tool version _ verifier => s!"{tool} {version}, verified by {verifier}" | .rodinImported source _ manual => s!"Rodin import {source} ({if manual then "manual" else "automatic"})" + | .rodinImportedProvenance _ _ _ _ manual => + s!"Rodin provenance ({if manual then "manual" else "automatic"})" private def hypothesisOnly (obligation : Obligation) : Bool := obligation.kind == "WWD" && obligation.goal.isNone diff --git a/cli/Cli.lean b/cli/Cli.lean index a450aef..ffc4ff1 100644 --- a/cli/Cli.lean +++ b/cli/Cli.lean @@ -607,6 +607,14 @@ private def evidenceJson : Trust.Evidence → String ",\"input_digest\":" ++ jsonString digest ++ ",\"manual\":" ++ jsonBool manual ++ ",\"verifier\":\"Rodin .bps importer\"}" + | .rodinImportedProvenance model bpo statuses digest manual => + "{\"mode\":" ++ jsonString Trust.Mode.rodinImported.label ++ + ",\"model\":" ++ jsonString model ++ + ",\"bpo\":" ++ jsonString bpo ++ + ",\"statuses\":" ++ jsonString statuses ++ + ",\"input_digest\":" ++ jsonString digest ++ + ",\"manual\":" ++ jsonBool manual ++ + ",\"verifier\":\"Rodin provenance validator\"}" private def reportEntry (gold : List (String × List String)) (ledger : Trust.Ledger) (machine : String) (obligation : Obligation) : String := diff --git a/examples/TrustRodinDemo.lean b/examples/TrustRodinDemo.lean index 6cfbb94..9d9b66b 100644 --- a/examples/TrustRodinDemo.lean +++ b/examples/TrustRodinDemo.lean @@ -19,7 +19,8 @@ private def provenance : Trust.Rodin.Provenance := "org.eventb.core.name=\"Demo\"/>" bpo := "" ++ "" + "name=\"evt/inv/INV\">" statuses := source } #guard match Trust.Rodin.importStatuses source with diff --git a/notes/architecture.md b/notes/architecture.md index 8cc245b..66b87fe 100644 --- a/notes/architecture.md +++ b/notes/architecture.md @@ -186,7 +186,9 @@ records as `rodinImported`; it never upgrades them to kernel evidence. The impor model-root, PO-sequent, source-component, and status identities, but does not rederive the BPO sequent from the model. SMT and external evidence remain explicit metadata boundaries and must carry solver/tool, version, input -digest, and verifier fields. +digest, and verifier fields. Rodin provenance retains the model, BPO, and status bytes +for replayable structural and goal checks; it does not yet rederive all hypotheses from +the model. ## User experience diff --git a/notes/production-acceptance.md b/notes/production-acceptance.md index 2bd69da..a5f919b 100644 --- a/notes/production-acceptance.md +++ b/notes/production-acceptance.md @@ -55,11 +55,11 @@ Every obligation has an explicit ledger mode. Kernel evidence requires replayed proof terms and checked axiom metadata. SMT, Rodin-imported, and external evidence remain their own modes with verifier, version, input digest, and fingerprint metadata. Unproved obligations remain `unproved`; reports never upgrade them implicitly. -Rodin imports additionally require model-root identity, exact BPO sequent identity, -source-component binding, and an independently parsed proof-status record. This is -identity/provenance validation, not a semantic re-derivation of the BPO from the model; -the current digest primitive is an internal fingerprint, not a cryptographic -authenticity claim. +Rodin imports additionally require model-root identity, source-component binding, the +named BPO sequent, and equality of its canonical goal with the generated obligation, +plus an independently parsed proof-status record. Hypothesis and model re-derivation +remain outside this contract; the current digest primitive is an internal fingerprint, +not a cryptographic authenticity claim. ## Acceptance commands @@ -83,6 +83,13 @@ The Rossi command requires the pinned official Rossi executable. CI downloads complete fixture matrix. The local command may instead use `ROSSI_BIN=/path/to/rossi python3 tools/rossi-diff.py`. +On 2026-08-14, the pinned archive was also executed as `rossi 0.1.7` in a +disposable x86_64 Linux QEMU/Lima guest. Its JSON validator returned success for +all checked-in fixtures: `actions.eventb` (1 component), `boundaries.eventb` +(2), `identifiers.eventb` (2), and `witnesses.eventb` (3). The exact combined +`tools/rossi-diff.py` command remains a CI gate because the local Lean executable +is host-native while the pinned Rossi artifact is Linux x86_64. + The final manual release gate opens `examples/WidgetDemo.lean` and `examples/LspDemo.lean` in VS Code with a restarted Lean server. It checks the widget panels, replayed entries, Go to Definition, and unknown-symbol diagnostics. Terminal builds cannot certify the diff --git a/test/Gates.lean b/test/Gates.lean index 2c6bbc4..4972cf4 100644 --- a/test/Gates.lean +++ b/test/Gates.lean @@ -272,13 +272,15 @@ from "we invented it". -/ private def checkPOs (project : Project) (file : String) (gold : List String) : List PoResult := let ours := (generate project file).map (·.name) + let duplicateOurs := duplicateStrings [] ours + |>.map fun n => { key := file ++ "\t" ++ n, status := "FAIL:duplicate generated PO name" } let missing := gold.filter (fun n => !ours.contains n) |>.map fun n => { key := file ++ "\t" ++ n, status := "FAIL:not generated" } let spurious := ours.filter (fun n => !gold.contains n) |>.map fun n => { key := file ++ "\t" ++ n, status := "FAIL:not in .bpo" } let matched := gold.filter (fun n => ours.contains n) |>.map fun n => { key := file ++ "\t" ++ n, status := "PASS" } - matched ++ missing ++ spurious + duplicateOurs ++ matched ++ missing ++ spurious private def poHistogram (results : List PoResult) : List (String × Nat) := (results.foldl @@ -332,7 +334,11 @@ where private def predicateSetErrors (sets : List (String × Option String × List String)) : List String := let names := sets.map (·.1) - let duplicateNames := duplicateStrings [] names + -- Names such as SEQHYP are intentionally local to a sequent. Only duplicate + -- top-level names are globally ambiguous in this flattened representation. + let rootNames := sets.filterMap fun (name, parent, _) => + if parent.isNone then some name else none + let duplicateNames := duplicateStrings [] rootNames let missingParents := sets.filterMap fun (_, parent, _) => match parent with | some name => if names.contains name then none else some name @@ -347,9 +353,9 @@ private def predicateSetErrors | none => some s!"missing predicate-set `{name}`" | some (_, parent, _) => cycleError fuel (name :: seen) parent let cycleErrors := sets.filterMap fun (name, _, _) => - if duplicateNames.contains name then none - else cycleError (sets.length + 1) [] (some name) - missingParents.map (fun name => s!"missing predicate-set `{name}`") ++ + cycleError (sets.length + 1) [] (some name) + duplicateNames.map (fun name => s!"duplicate top-level predicate-set `{name}`") ++ + missingParents.map (fun name => s!"missing predicate-set `{name}`") ++ cycleErrors -- partiality: this is the corresponding test-only XML walk for predicate-set inheritance. @@ -417,7 +423,11 @@ private def readGoldGoals (path : System.FilePath) : IO (List (String × String) let errors := goalShapeErrors xml if !errors.isEmpty then throw (IO.userError s!"invalid Rodin goal shape: {String.intercalate "; " errors}") - return goldGoals xml + let goals := goldGoals xml + let duplicates := duplicateStrings [] (goals.map (·.1)) + if !duplicates.isEmpty then + throw (IO.userError s!"duplicate Rodin goal name(s): {duplicates}") + return goals /-- Ascriptions carry no logical content, so a generator has no reason to reproduce them. Nothing else is normalised: the gate's job is to notice a difference, and a @@ -609,7 +619,11 @@ private def readGoldHyps (path : System.FilePath) : IO (List (String × List Str let errors := predicateSetErrors sets if !errors.isEmpty then throw (IO.userError s!"invalid Rodin predicate-set graph: {String.intercalate "; " errors}") - return goldHyps xml sets + let hypotheses := goldHyps xml sets + let duplicates := duplicateStrings [] (hypotheses.map (·.1)) + if !duplicates.isEmpty then + throw (IO.userError s!"duplicate Rodin hypothesis name(s): {duplicates}") + return hypotheses /-- Hypotheses are scored as sets: Rodin's order is an artefact of how it walks the predicate-set chain, and a generator that produces the same assumptions in a different @@ -701,6 +715,21 @@ private def p4BaselineLine (result : P4Result) : String := private def nonemptyLines (source : String) : List String := source.splitOn "\n" |>.filter (fun line => !line.isEmpty) +private def removeExact (target : String) : List String → Option (List String) + | [] => none + | line :: rest => if line == target then some rest + else removeExact target rest |>.map (fun remaining => line :: remaining) + +private def multisetSubset : List String → List String → Bool + | [], _ => true + | line :: rest, actual => + match removeExact line actual with + | none => false + | some remaining => multisetSubset rest remaining + +#guard multisetSubset ["a", "a"] ["a"] == false +#guard multisetSubset ["a", "b"] ["b", "a", "c"] + private def baselineDiff (baseline actual : List String) : IO Bool := do if baseline == actual then pure true @@ -890,11 +919,16 @@ private def run (args : List String) : IO UInt32 := do if args.contains "--bless" then -- P0 must be perfect to bless, since a dropped file would silently shrink the P1 -- denominator. P1 blesses whatever it currently reaches: that is the ratchet. - let oldStatements ← try IO.FS.readFile "baseline/statement.tsv" catch _ => pure "" - let oldHypotheses ← try IO.FS.readFile "baseline/hypothesis.tsv" catch _ => pure "" - let noP3bShrink := - (nonemptyLines oldStatements).all (fun line => goalActual.contains line) && - (nonemptyLines oldHypotheses).all (fun line => hypActual.contains line) + let oldStatements? ← try some <$> IO.FS.readFile "baseline/statement.tsv" + catch _ => pure none + let oldHypotheses? ← try some <$> IO.FS.readFile "baseline/hypothesis.tsv" + catch _ => pure none + let baselinesPresent := oldStatements?.isSome && oldHypotheses?.isSome + let noP3bShrink := match oldStatements?, oldHypotheses? with + | some oldStatements, some oldHypotheses => + multisetSubset (nonemptyLines oldStatements) goalActual && + multisetSubset (nonemptyLines oldHypotheses) hypActual + | _, _ => false if coreOK && compatibilityOK && p4OK && wwdOK && noP3bShrink then writeBaseline "baseline/parse.tsv" actual writeBaseline "baseline/formula.tsv" formulaActual @@ -906,7 +940,9 @@ private def run (args : List String) : IO UInt32 := do writeBaseline "baseline/compatibility.tsv" compatibilityActual writeBaseline "baseline/p4.tsv" p4Actual else - IO.eprintln (if noP3bShrink then + IO.eprintln (if !baselinesPresent then + "refusing to bless without existing P3b statement and hypothesis baselines" + else if noP3bShrink then "refusing to bless a failed acceptance gate" else "refusing to bless a reduced P3b baseline") return 1 From d4edf1dc4b572183e47198dfa2f30c3e7adfc0f8 Mon Sep 17 00:00:00 2001 From: Jonathan Cubides Date: Fri, 14 Aug 2026 15:24:09 -0500 Subject: [PATCH 5/8] fix(trust): bind Rodin artifacts --- EventB/Trust.lean | 11 +++++++++- EventB/Trust/Rodin.lean | 40 ++++++++++++++++++++++++++++------ TODO.md | 2 +- examples/TrustRodinDemo.lean | 4 +++- notes/architecture.md | 4 ++-- notes/production-acceptance.md | 8 +++---- 6 files changed, 53 insertions(+), 16 deletions(-) diff --git a/EventB/Trust.lean b/EventB/Trust.lean index b9b3d88..a88e0e4 100644 --- a/EventB/Trust.lean +++ b/EventB/Trust.lean @@ -30,6 +30,9 @@ def Mode.rank : Mode → Nat | .smt => 2 | .kernel => 3 +def provenanceFingerprint (model bpo statuses : String) : String := + s!"eventb-v2-{String.hash (model ++ "\n" ++ bpo ++ "\n" ++ statuses)}" + inductive Evidence where | none | kernel (declaration : String) (axioms : List String := []) @@ -57,7 +60,8 @@ def Evidence.isWellFormed : Evidence → Bool !tool.isEmpty && !version.isEmpty && !digest.isEmpty && !verifier.isEmpty | .rodinImported source digest _ => !source.isEmpty && !digest.isEmpty | .rodinImportedProvenance model bpo statuses digest _ => - !model.isEmpty && !bpo.isEmpty && !statuses.isEmpty && !digest.isEmpty + !model.isEmpty && !bpo.isEmpty && !statuses.isEmpty && + digest == provenanceFingerprint model bpo statuses def fingerprint (canonical : String) : String := s!"eventb-v1-{String.hash canonical}" @@ -104,6 +108,9 @@ def Ledger.validate (ledger : Ledger) : Except EventB.Error Unit := let key := entry.component ++ "\t" ++ entry.obligation if seen.contains key then .error (EventB.Error.trust s!"ledger has duplicate entry `{key}`") + else if entry.mode == .kernel then + .error (EventB.Error.trust + s!"kernel entry `{key}` requires Trust.Replay validation") else if !entry.isConsistent then .error (EventB.Error.trust s!"ledger entry `{key}` is inconsistent") else go (key :: seen) rest @@ -174,6 +181,8 @@ def Ledger.summary (ledger : Ledger) : String := #guard (Ledger.ofObligations []).total == 0 #guard fingerprint "same" == fingerprint "same" #guard fingerprint "same" != fingerprint "changed" +#guard !Evidence.isWellFormed + (.rodinImportedProvenance "model" "bpo" "status" "forged" false) private def sampleObligation : POG.Obligation := { component := "Sample", name := "INITIALISATION/inv1/INV", kind := "INV" diff --git a/EventB/Trust/Rodin.lean b/EventB/Trust/Rodin.lean index c050ef0..1305c54 100644 --- a/EventB/Trust/Rodin.lean +++ b/EventB/Trust/Rodin.lean @@ -104,8 +104,7 @@ private def duplicateKeys (seen : List String) : List String → List String else duplicateKeys (key :: seen) rest def provenanceDigest (provenance : Provenance) : String := - s!"eventb-v2-{String.hash - (provenance.model ++ "\n" ++ provenance.bpo ++ "\n" ++ provenance.statuses)}" + Trust.provenanceFingerprint provenance.model provenance.bpo provenance.statuses def compare (obligations : List POG.Obligation) (statuses : List Status) : Comparison := let eligible := obligations.filter fun obligation => @@ -181,6 +180,10 @@ private partial def findPoSequent (elem : XmlElem) (name : String) : Option XmlE | first :: _ => some first | [] => none +private partial def poSequentMatches (elem : XmlElem) (name : String) : List XmlElem := + (if elem.tag == "org.eventb.core.poSequent" && elem.attr? "name" == some name then + [elem] else []) ++ elem.children.flatMap (fun child => poSequentMatches child name) + private def predicateTexts (elem : XmlElem) : List String := elem.children.filterMap fun child => if child.tag == "org.eventb.core.poPredicate" then @@ -193,7 +196,9 @@ private def sequentGoal (name : String) (sequent : XmlElem) : Option String := sequent.children.filter (fun child => child.tag == "org.eventb.core.poPredicateSet") |>.flatMap predicateTexts else [] - (direct ++ witness).getLast? + match direct ++ witness with + | [goal] => some goal + | _ => none private structure PredicateSet where name : String @@ -218,9 +223,17 @@ private def chainPredicates (sets : List PredicateSet) : Nat → Option String | 0, some _, _ => none | _, none, acc => some acc | fuel + 1, some name, acc => - match sets.find? (fun set => set.name == name) with - | some set => chainPredicates sets fuel set.parent (set.predicates ++ acc) - | none => none + match sets.filter (fun set => set.name == name) with + | [set] => chainPredicates sets fuel set.parent (set.predicates ++ acc) + | _ => none + +private partial def hasLabel (elem : XmlElem) (label : String) : Bool := + elem.attr? "org.eventb.core.label" == some label || + elem.children.any (fun child => hasLabel child label) + +private def modelBindsObligation (model : XmlElem) (obligation : POG.Obligation) : Bool := + let first := (obligation.name.splitOn "/").head?.getD "" + ["VWD", "FIN"].contains first || hasLabel model first private def sequentHypotheses (name : String) (sequent : XmlElem) (sets : List PredicateSet) : Option (List String) := @@ -295,6 +308,13 @@ def validateProvenance (obligation : POG.Obligation) (provenance : Provenance) unless modelName == obligation.component do throw (EventB.Error.trust s! "Rodin model provenance names `{modelName}`, expected `{obligation.component}`") + let model ← match parseXmlString provenance.model with + | .ok root => pure root + | .error error => .error (EventB.Error.trust + s!"invalid model XML: {error.pretty provenance.model.toUTF8}") + unless modelBindsObligation model obligation do + throw (EventB.Error.trust + "Rodin model does not contain the obligation's source label") let bpo ← match parseXmlString provenance.bpo with | .ok root => pure root | .error error => .error (EventB.Error.trust @@ -308,6 +328,10 @@ def validateProvenance (obligation : POG.Obligation) (provenance : Provenance) | none => .error (EventB.Error.trust "Rodin PO artifact has no source") unless source == expectedSource do throw (EventB.Error.trust "Rodin PO source is not the stated model component") + let sequentCount := (poSequentMatches bpo obligation.name).length + unless sequentCount == 1 do + throw (EventB.Error.trust s! + "Rodin PO artifact has {sequentCount} sequents for `{obligation.name}`") validateGoal obligation bpo validateHypotheses obligation bpo let statuses ← importStatuses provenance.statuses @@ -343,7 +367,9 @@ private def sampleSource := private def sampleProvenance : String → Provenance := fun statuses => { model := "" + "org.eventb.core.name=\"Sample\">" bpo := "" ++ "" + "org.eventb.core.name=\"Demo\">" bpo := "" ++ " Date: Fri, 14 Aug 2026 16:20:19 -0500 Subject: [PATCH 6/8] fix(accuracy): harden refinement trust Reject unsafe refinement and provenance shapes. --- EventB/DSL.lean | 7 +- EventB/Formula/Parse.lean | 15 ++- EventB/POG.lean | 108 +++++++++++++++++---- EventB/Trust.lean | 11 ++- EventB/Trust/Replay.lean | 28 +----- EventB/Trust/Rodin.lean | 110 +++++++++++++++++++--- EventB/Typing/Check.lean | 167 +++++++++++++++++++++++++++++---- EventB/Xml.lean | 4 +- TODO.md | 15 +-- examples/TrustRodinDemo.lean | 6 +- notes/architecture.md | 13 ++- notes/production-acceptance.md | 24 +++-- 12 files changed, 408 insertions(+), 100 deletions(-) diff --git a/EventB/DSL.lean b/EventB/DSL.lean index ae03942..4e4a941 100644 --- a/EventB/DSL.lean +++ b/EventB/DSL.lean @@ -740,10 +740,9 @@ private def elabContext : CommandElab := fun stx => do addContextInfos (owners ++ theoryRoots) ps | _ => throwUnsupportedSyntax -/-- `#eventb_pog M Ctx ...` prints the obligations generated for the first named -component, resolving the rest as its project. The point of the DSL is that this is the -same generator the corpus goes through, so what it prints here is what a `.bum` would -get. -/ +/-- `#eventb_pog M Ctx ...` prints compatibility obligations for the first named +component, resolving the rest as its project. Trusted integrations must use the checked +POG entry points, which reject unresolved scope and model diagnostics. -/ syntax (name := eventbPog) "#eventb_pog " ident+ : command syntax (name := eventbPogIn) "#eventb_pog_in " ident ppSpace ident+ : command diff --git a/EventB/Formula/Parse.lean b/EventB/Formula/Parse.lean index 31d7959..64b86eb 100644 --- a/EventB/Formula/Parse.lean +++ b/EventB/Formula/Parse.lean @@ -90,6 +90,12 @@ private structure St where toks : Array Tok pos : Nat +private def hasRemainingOperator (s : St) (operator : String) : Bool := + (s.toks.toList.drop s.pos).any fun token => + match token with + | .op value => value == operator + | _ => false + private def peek (s : St) : Option Tok := s.toks[s.pos]? private def expect (s : St) (o : String) : Except String St := @@ -154,7 +160,8 @@ private def parsePrefix : Nat → St → Except String (Term × St) | some (.id name) => parsePostfix fuel (.id name) { s with pos := s.pos + 1 } | some (.op o) => let s := { s with pos := s.pos + 1 } - if isBinder o then + if isBinder o && + (o != "⋃" && o != "⋂" || hasRemainingOperator s "·") then -- The pattern runs up to `·`; comma and `↦` inside it are ordinary operators, so -- `∀a1,a2·P` and `λx↦y·P∣E` need no special cases. let (pat, s) ← parseAt fuel s 5 @@ -293,6 +300,12 @@ private def sameTree (a b : String) : Bool := -- Binders take a comma-separated pattern, and comprehension keeps predicate and -- expression apart. #guard (parse "∀a1,a2 · a1 ∈ S ∧ a2 ∈ S ⇒ a1 = a2").isOk +#guard match parse "⋃S" with + | .ok term => term == .pre "⋃" (.id "S") + | .error _ => false +#guard match parse "⋂S" with + | .ok term => term == .pre "⋂" (.id "S") + | .error _ => false #guard (parse "{x · x ∈ S ∣ x + 1}").isOk -- The short form of comprehension denotes the same set as the long one. #guard sameTree "{x ∣ x ∈ S}" "{x · x ∈ S ∣ x}" diff --git a/EventB/POG.lean b/EventB/POG.lean index 750aa2d..d0f93b5 100644 --- a/EventB/POG.lean +++ b/EventB/POG.lean @@ -198,10 +198,10 @@ def inheritedChildren (p : Project) (tag : String) : Nat → String → Elem → match lookupComponent p am with | none => [] | some a => - match (childrenOf a.elem "event").find? (fun e => - labelOf e == targetEventName ev) with - | none => [] - | some ae => inheritedChildren p tag depth am ae + eventTargets ev |>.flatMap fun target => + match (childrenOf a.elem "event").find? (fun e => labelOf e == target) with + | none => [] + | some ae => inheritedChildren p tag depth am ae inherited ++ own def effectiveActions (p : Project) (machine : String) (ev : Elem) : List Elem := @@ -231,14 +231,14 @@ private def eventActions (p : Project) : Nat → String → Elem → List Elem match lookupComponent p machine with | none => [] | some m => - ((childrenOf m.elem "refinesMachine").filterMap targetName).flatMap fun am => - match lookupComponent p am with - | none => [] - | some a => - let target := targetEventName ev - match (childrenOf a.elem "event").find? (fun e => labelOf e == target) with + ((childrenOf m.elem "refinesMachine").filterMap targetName).flatMap fun am => + match lookupComponent p am with | none => [] - | some ae => eventActions p depth am ae + | some a => + eventTargets ev |>.flatMap fun target => + match (childrenOf a.elem "event").find? (fun e => labelOf e == target) with + | none => [] + | some ae => eventActions p depth am ae own ++ inherited.filter (fun q => !(assignedBy q).any (fun v => own.any (fun o => (assignedBy o).contains v))) @@ -252,6 +252,9 @@ private def accurateTransitionActions (p : Project) (machine : String) (ev : Ele if labelOf ev == "INITIALISATION" then initializationActions p component ev else effectiveActions p machine ev +private def refinementTransitionActions (p : Project) (machine : String) (ev : Elem) : List Elem := + eventActions p p.length machine ev + def eventSubst (p : Project) : Nat → String → Elem → List (String × Term) | 0, machine, ev => (transitionActions p machine ev).flatMap substOf @@ -318,13 +321,13 @@ private def eventRelationalHyps (p : Project) (name : String) (ev : Elem) : List private def eventStateSubstMode (strict : Bool) (p : Project) (name : String) (ev : Elem) : List (String × Term) := if strict then - firstAssignments ((accurateTransitionActions p name ev).flatMap fun action => + firstAssignments ((refinementTransitionActions p name ev).flatMap fun action => substOf action ++ nondeterministicSubst action) else eventStateSubst p name ev private def eventRelationalHypsMode (strict : Bool) (p : Project) (name : String) (ev : Elem) : List Term := - if strict then (accurateTransitionActions p name ev).filterMap actionRelationAccurate + if strict then (refinementTransitionActions p name ev).filterMap actionRelationAccurate else eventRelationalHyps p name ev private def deterministicAfterRelation (action : Elem) : List Term := @@ -469,9 +472,18 @@ private def wdFunctionType (context : WdContext) (f : Term) : Option Term := private def wdNonempty (s : Term) : Term := .bin "≠" s (.set []) +private def wdFreshName (base : String) (used : List String) : Nat → Nat → String + | _, 0 => base ++ s!"{used.length + 1}" + | index, fuel + 1 => + let candidate := if index == 0 then base else base ++ s!"{index}" + if used.contains candidate then wdFreshName base used (index + 1) fuel else candidate + private def wdBound (isMax : Bool) (s : Term) : Term := - let b := .id (if (identifiers s).contains "b" then "b0" else "b") - let x := .id (if (identifiers s).contains "x" then "x0" else "x") + let used := identifiers s + let bName := wdFreshName "b" used 0 (used.length + 1) + let xName := wdFreshName "x" (bName :: used) 0 (used.length + 1) + let b := .id bName + let x := .id xName let order := if isMax then .bin "≥" b x else .bin "≤" b x .bind "∃" b (.bind "∀" x (.bin "⇒" (.bin "∈" x s) order)) @@ -771,7 +783,9 @@ private def generateInMode (strict : Bool) (theory : Theory.Env) (p : Project) | some c => let isMachine := c.elem.tag == "org.eventb.core.machineFile" let roots := componentTheoryRoots p name - let (types, eventParams, diagnostics) := match inferComponentDetailsIn theory p name with + let (types, eventParams, diagnostics) := match + (if strict then inferComponentDetailsCheckedIn theory p name + else inferComponentDetailsIn theory p name) with | .ok result => (result.types, result.eventParams, result.diagnostics) | .error error => ([], [], [error.message]) let finalize := fun obligations : List Obligation => obligations.map fun obligation => @@ -965,7 +979,8 @@ private def generateInMode (strict : Bool) (theory : Theory.Env) (p : Project) if concreteVariables.contains v then some (Term.bin "=" (.id (v ++ "'")) (Formula.subst witnesses absRhs)) - else none + else + none if goals.length == abstractAssignments.length then conjoin goals else none match simGoal with | some goal => @@ -1135,6 +1150,46 @@ private def rightWitnessProject : Project := , .action [("org.eventb.core.label", "set"), ("org.eventb.core.assignment", "x ≔ q + 1")] []]] }] +private def hiddenParameterChild : Component := + { name := "C" + elem := .machineFile [("org.eventb.core.name", "C")] + [.refinesMachine [("org.eventb.core.target", "B")] [] + , .variable [("org.eventb.core.identifier", "x")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [.refinesEvent [("org.eventb.core.target", "step"), + ("org.eventb.core.extended", "true")] [] + , .guard [("org.eventb.core.label", "hidden"), + ("org.eventb.core.predicate", "p = 0")] []]] } + +private def dataRefinementProject : Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [.variable [("org.eventb.core.identifier", "a")] [] + , .invariant [("org.eventb.core.label", "type"), + ("org.eventb.core.predicate", "a ∈ ℤ")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] + [.action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "a ≔ 0")] []] + , .event [("org.eventb.core.label", "step")] + [.action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "a ≔ a + 1")] []]] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [.refinesMachine [("org.eventb.core.target", "A")] [] + , .variable [("org.eventb.core.identifier", "b")] [] + , .invariant [("org.eventb.core.label", "type"), + ("org.eventb.core.predicate", "b ∈ ℤ")] [] + , .invariant [("org.eventb.core.label", "glue"), + ("org.eventb.core.predicate", "a = b")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] + [.action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "b ≔ 0")] []] + , .event [("org.eventb.core.label", "step")] + [.refinesEvent [("org.eventb.core.target", "step")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "b ≔ b + 1")] []]] }] + private def mergeProject : Project := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] @@ -1263,10 +1318,27 @@ private def functionUpdateWdProject : Project := #guard match generateChecked rightWitnessProject "B" with | .ok obligations => obligations.any (fun obligation => obligation.name == "step/p/WFIS") && - obligations.any (fun obligation => obligation.name == "step/g/GRD") && + obligations.any (fun obligation => obligation.name == "step/g/GRD" && + obligation.goal.map (fun goal => + let printed := Formula.print goal + printed.contains "q + 1" && !printed.contains "p >") == some true) && obligations.any (fun obligation => obligation.name == "step/set/SIM") | .error _ => false +#guard match generateChecked dataRefinementProject "B" with + | .ok obligations => + !obligations.any (fun obligation => obligation.name == "step/set/SIM") && + obligations.any (fun obligation => + obligation.name == "step/glue/INV" && + obligation.goal.map (fun goal => + let printed := Formula.print goal + printed.contains "a + 1" && printed.contains "b + 1") == some true) + | .error _ => false + +#guard match generateChecked (rightWitnessProject ++ [hiddenParameterChild]) "C" with + | .error _ => true + | .ok _ => false + #guard match generateChecked mergeProject "B" with | .ok obligations => obligations.any (fun obligation => obligation.name == "merge/MRG") && diff --git a/EventB/Trust.lean b/EventB/Trust.lean index a88e0e4..83d8890 100644 --- a/EventB/Trust.lean +++ b/EventB/Trust.lean @@ -58,7 +58,9 @@ def Evidence.isWellFormed : Evidence → Bool !solver.isEmpty && !version.isEmpty && !digest.isEmpty && !verifier.isEmpty | .external tool version digest verifier => !tool.isEmpty && !version.isEmpty && !digest.isEmpty && !verifier.isEmpty - | .rodinImported source digest _ => !source.isEmpty && !digest.isEmpty + -- Legacy status-only evidence remains a display-compatible constructor, but it is + -- never accepted as ledger evidence without model/BPO provenance. + | .rodinImported _ _ _ => false | .rodinImportedProvenance model bpo statuses digest _ => !model.isEmpty && !bpo.isEmpty && !statuses.isEmpty && digest == provenanceFingerprint model bpo statuses @@ -204,6 +206,10 @@ private def forgedKernelLedger : Ledger := { entries := [{ sampleLedger.entries.head! with mode := .kernel, evidence := .kernel "forged" }] } +private def legacyRodinLedger : Ledger := + { entries := [{ sampleLedger.entries.head! with + mode := .rodinImported, evidence := .rodinImported "status.bps" "digest" false }] } + private def renamedSample : POG.Obligation := { sampleObligation with name := "display-only", kind := "INV" } @@ -241,6 +247,9 @@ private def renamedSample : POG.Obligation := #guard match forgedKernelLedger.validate with | .error _ => true | .ok _ => false +#guard match legacyRodinLedger.validate with + | .error _ => true + | .ok _ => false #guard match sampleLedger.attach { sampleObligation with goal := some (.id "⊥") } (.kernel "Sample.inv1") with | .error _ => true diff --git a/EventB/Trust/Replay.lean b/EventB/Trust/Replay.lean index 52a1d84..8f3ca52 100644 --- a/EventB/Trust/Replay.lean +++ b/EventB/Trust/Replay.lean @@ -145,25 +145,8 @@ private def replayKernel (context : Embedding.KernelContext) def validate (context : Embedding.KernelContext) (obligation : POG.Obligation) : Evidence → MetaM Report | evidence@(.kernel ..) => replayKernel context obligation evidence - | evidence@(.rodinImported source digest manual) => do - unless digest == s!"eventb-v1-{String.hash source}" do - throwError "Rodin evidence artifact digest mismatch" - let statuses ← match Rodin.importStatuses source with - | .ok statuses => pure statuses - | .error error => throwError error.message - match statuses.find? (fun status => status.name == obligation.name) with - | none => - throwError s!"Rodin evidence artifact has no status for `{obligation.name}`" - | some status => - unless status.discharged do - throwError s!"Rodin evidence status for `{obligation.name}` is not discharged" - unless status.manual == manual do - throwError s!"Rodin evidence manual flag mismatch for `{obligation.name}`" - unless obligation.diagnostics.isEmpty do - throwError s!"obligation `{obligation.name}` has diagnostics" - unless obligation.goal.isSome do - throwError s!"obligation `{obligation.name}` has no translated goal" - pure { mode := evidence.mode, fingerprint := proofFingerprint context obligation } + | .rodinImported .. => + throwError "legacy status-only Rodin evidence is not trusted; attach model and PO provenance" | evidence@(.rodinImportedProvenance model bpo statuses digest manual) => do let provenance : Rodin.Provenance := { model, bpo, statuses } unless digest == Rodin.provenanceDigest provenance do @@ -286,10 +269,9 @@ private meta def checkReplay : TermElabM Unit := do let rodinSource := "" - let rodin ← validate context replayObligation - (.rodinImported rodinSource (Trust.fingerprint rodinSource) true) - unless rodin.mode == .rodinImported && !rodin.replayed do - throwError "Rodin evidence was reported as replayed" + unless !(← succeeds (validate context replayObligation + (.rodinImported rodinSource (Trust.fingerprint rodinSource) true))) do + throwError "legacy status-only Rodin evidence was accepted" unless !(← succeeds (validate context replayObligation (.rodinImported rodinSource (Trust.fingerprint rodinSource) false))) do throwError "Rodin manual flag mismatch was accepted" diff --git a/EventB/Trust/Rodin.lean b/EventB/Trust/Rodin.lean index 1305c54..684d68e 100644 --- a/EventB/Trust/Rodin.lean +++ b/EventB/Trust/Rodin.lean @@ -227,22 +227,82 @@ private def chainPredicates (sets : List PredicateSet) : Nat → Option String | [set] => chainPredicates sets fuel set.parent (set.predicates ++ acc) | _ => none -private partial def hasLabel (elem : XmlElem) (label : String) : Bool := - elem.attr? "org.eventb.core.label" == some label || - elem.children.any (fun child => hasLabel child label) +private def directLabel (elem : XmlElem) (tag label : String) : Bool := + elem.children.any fun child => + child.tag == tag && child.attr? "org.eventb.core.label" == some label + +private def directIdentifier (elem : XmlElem) (tag identifier : String) : Bool := + elem.children.any fun child => + child.tag == tag && child.attr? "org.eventb.core.identifier" == some identifier + +private def eventChildLabel (model : XmlElem) (event label : String) + (tags : List String) : Bool := + model.children.any fun candidate => + candidate.tag == "org.eventb.core.event" && + candidate.attr? "org.eventb.core.label" == some event && + candidate.children.any fun child => + tags.contains child.tag && child.attr? "org.eventb.core.label" == some label + +private def eventLabel (model : XmlElem) (event : String) : Bool := + model.children.any fun child => + child.tag == "org.eventb.core.event" && + child.attr? "org.eventb.core.label" == some event + +private def eventConvergent (model : XmlElem) (event : String) : Bool := + model.children.any fun child => + child.tag == "org.eventb.core.event" && + child.attr? "org.eventb.core.label" == some event && + ["1", "2"].contains ((child.attr? "org.eventb.core.convergence").getD "0") private def modelBindsObligation (model : XmlElem) (obligation : POG.Obligation) : Bool := - let first := (obligation.name.splitOn "/").head?.getD "" - ["VWD", "FIN"].contains first || hasLabel model first + let parts := obligation.name.splitOn "/" + match obligation.kind, parts with + | "INV", [event, label, _] => + eventLabel model event && + (directLabel model "org.eventb.core.invariant" label || + directLabel model "org.eventb.core.axiom" label) + | "GRD", [event, label, _] => + eventChildLabel model event label ["org.eventb.core.guard"] + | "SIM", [event, label, _] => + eventChildLabel model event label ["org.eventb.core.action"] + | "FIS", [event, label, _] => + eventChildLabel model event label ["org.eventb.core.action"] + | "EQL", [event, varName, _] => + eventLabel model event && directIdentifier model "org.eventb.core.variable" varName + | "WFIS", [event, label, _] | "WWD", [event, label, _] => + eventChildLabel model event label ["org.eventb.core.witness"] + | "WD", [event, label, _] => + eventLabel model event && eventChildLabel model event label + ["org.eventb.core.guard", "org.eventb.core.action", "org.eventb.core.witness"] + | "WD", [label, _] | "THM", [label, _] => + directLabel model "org.eventb.core.invariant" label || + directLabel model "org.eventb.core.axiom" label + | "MRG", [event, _] | "VAR", [event, _] | "NAT", [event, _] => + eventLabel model event + | "VWD", [event, _] | "FIN", [event, _] => + eventConvergent model event || + (event == "variant" && model.children.any + (fun child => child.tag == "org.eventb.core.variant")) + | _, [event, label, _] => + eventLabel model event && eventChildLabel model event label + ["org.eventb.core.guard", "org.eventb.core.action", "org.eventb.core.witness"] + | _, [label, _] => + directLabel model "org.eventb.core.invariant" label || + directLabel model "org.eventb.core.axiom" label + | _, _ => false private def sequentHypotheses (name : String) (sequent : XmlElem) (sets : List PredicateSet) : Option (List String) := - let inner := sequent.children.find? (fun child => - child.tag == "org.eventb.core.poPredicateSet") - let parent := inner.bind (fun set => - (set.attr? "org.eventb.core.parentSet").map refName) - let direct := if name.endsWith "/WWD" then predicateTexts sequent else [] - chainPredicates sets (sets.length + 1) parent [] |>.map (· ++ direct) + match sequent.children.filter (fun child => + child.tag == "org.eventb.core.poPredicateSet") with + | [inner] => + let parent := (inner.attr? "org.eventb.core.parentSet").map refName + let direct := predicateTexts inner ++ + if name.endsWith "/WWD" then predicateTexts sequent else [] + chainPredicates sets (sets.length + 1) parent [] |>.map (· ++ direct) + | [] => + some (if name.endsWith "/WWD" then predicateTexts sequent else []) + | _ => none private def removeEquivalent (target : Formula.Term) : List Formula.Term → Option (List Formula.Term) @@ -367,15 +427,24 @@ private def sampleSource := private def sampleProvenance : String → Provenance := fun statuses => { model := "" + "org.eventb.core.name=\"Sample\">" bpo := "" ++ "" statuses } +#guard match parseXmlString ((sampleProvenance sampleSource).model.replace + "" + ("" ++ + "")) with + | .ok model => + !modelBindsObligation model + { sampleObligation with name := "evt/VWD", kind := "VWD" } + | .error _ => false + #guard match importStatuses sampleSource with | .ok [status] => status.name == sampleObligation.name && status.discharged && status.manual | _ => false @@ -473,6 +542,19 @@ private def sampleProvenance : String → Provenance := fun statuses => | .ok _ => false | _ => false +#guard match importStatuses sampleSource with + | .ok [status] => + let nestedLabel := { sampleProvenance sampleSource with + model := (sampleProvenance sampleSource).model.replace + "" + "" } + match attachProvenance (Ledger.ofObligations [sampleObligation]) + sampleObligation nestedLabel status with + | .error _ => true + | .ok _ => false + | _ => false + #guard match importStatuses sampleSource with | .ok [status] => let badPo := { sampleProvenance sampleSource with diff --git a/EventB/Typing/Check.lean b/EventB/Typing/Check.lean index 935e31d..10ac431 100644 --- a/EventB/Typing/Check.lean +++ b/EventB/Typing/Check.lean @@ -196,16 +196,51 @@ private def componentReferenceErrors (p : Project) (c : Component) : List String let componentErrors := (refs.filterMap targetName).filterMap fun target => if lookupComponent p target |>.isSome then none else some s!"unresolved component reference {target} from {c.name}" + let missingTargetErrors := refs.filter (fun reference => (attrOf reference "target").isNone) + |>.map fun reference => s!"component reference {reference.tag} from {c.name} has no target" + let sourceKindErrors := refs.filterMap fun reference => + let legal := + if c.elem.tag == "org.eventb.core.contextFile" then + reference.tag == "org.eventb.core.extendsContext" + else if c.elem.tag == "org.eventb.core.machineFile" then + reference.tag == "org.eventb.core.seesContext" || + reference.tag == "org.eventb.core.refinesMachine" + else false + if legal then none + else some s!"reference tag {reference.tag} is not legal from {c.name}" + let referenceKindErrors := refs.filterMap fun reference => + match targetName reference with + | some target => + match lookupComponent p target with + | some targetComponent => + let expected := if reference.tag == "org.eventb.core.refinesMachine" + then "org.eventb.core.machineFile" else "org.eventb.core.contextFile" + if targetComponent.elem.tag == expected then none + else some s!"component reference {target} from {c.name} has the wrong target kind" + | none => none + | none => none + let componentIdentityErrors := + match attrOf c.elem "name" with + | some rootName => + if rootName == c.name then [] + else [s!"component {c.name} XML name is {rootName}"] + | none => [] let parentNames := (childrenOf c.elem "refinesMachine").filterMap targetName let variableNames := (childrenOf c.elem "variable").filterMap (attrOf · "identifier") let constantNames := (childrenOf c.elem "constant").filterMap (attrOf · "identifier") let setNames := (childrenOf c.elem "carrierSet").filterMap (attrOf · "identifier") let namespaceNames := constantNames ++ setNames let namespaceErrors := - (duplicateNames [] variableNames).map (fun name => - s!"duplicate variable declaration {name} in {c.name}") ++ - variableNames.filter (fun name => namespaceNames.contains name) |>.map (fun name => - s!"variable {name} in {c.name} collides with a constant or carrier set") + (duplicateNames [] (variableNames ++ constantNames ++ setNames)).map (fun name => + s!"duplicate declaration {name} in {c.name}") + let eventLabelErrors := + (duplicateNames [] + ((childrenOf c.elem "event" |>.map labelOf).filter (· != ""))).map fun name => + s!"duplicate event label {name} in {c.name}" + let predicateLabelErrors := + (duplicateNames [] (((childrenOf c.elem "axiom" ++ childrenOf c.elem "invariant") + |>.map labelOf).filter (· != ""))).map fun name => + s!"duplicate predicate label {name} in {c.name}" let eventNamespaceErrors := (childrenOf c.elem "event").flatMap fun ev => let params := eventParameterNames ev (duplicateNames [] params).map (fun name => @@ -213,6 +248,20 @@ private def componentReferenceErrors (p : Project) (c : Component) : List String params.filter (fun name => variableNames.contains name || namespaceNames.contains name) |>.map (fun name => s!"event parameter {name} in {c.name}/{labelOf ev} collides with a declaration") + let eventChildLabelErrors := (childrenOf c.elem "event").flatMap fun ev => + (duplicateNames [] (((childrenOf ev "guard" ++ childrenOf ev "action" ++ + childrenOf ev "witness") |>.filterMap (attrOf · "label")).filter (· != ""))).map fun name => + s!"duplicate event child label {name} in {c.name}/{labelOf ev}" + let convergenceValueErrors := (childrenOf c.elem "event").filterMap fun ev => + let value := (attrOf ev "convergence").getD "0" + if ["0", "1", "2"].contains value then none + else some s!"event {c.name}/{labelOf ev} has invalid convergence `{value}`" + let variantErrors := + if (childrenOf c.elem "variant").length > 1 then + [s!"machine {c.name} has more than one variant"] else [] + let variantShapeErrors := (childrenOf c.elem "variant").filterMap fun variant => + if (attrOf variant "expression").isSome then none + else some s!"variant in {c.name} has no expression" let initializationErrors := if c.elem.tag == "org.eventb.core.machineFile" then let count := (childrenOf c.elem "event").countP (fun ev => labelOf ev == "INITIALISATION") @@ -234,6 +283,9 @@ private def componentReferenceErrors (p : Project) (c : Component) : List String | some parent => (childrenOf parent.elem "event").any (fun candidate => labelOf candidate == target) then [] else [s!"unresolved event reference {target} from {c.name}/{labelOf ev}"] + let duplicateRefinementErrors := childrenOf c.elem "event" |>.flatMap fun ev => + (duplicateNames [] ((childrenOf ev "refinesEvent").filterMap targetName)).map fun target => + s!"event {c.name}/{labelOf ev} has duplicate refinement reference {target}" let convergenceErrors := childrenOf c.elem "event" |>.flatMap fun ev => (childrenOf ev "refinesEvent").filterMap targetName |>.flatMap fun target => parentNames.flatMap fun parentName => @@ -266,8 +318,11 @@ private def componentReferenceErrors (p : Project) (c : Component) : List String else [mergePrefix ++ " refines abstract events with different actions"]) ++ (if allEqual (abstractEvents.map eventParameterNames) then [] else [mergePrefix ++ " refines abstract events with different parameters"]) - componentErrors ++ namespaceErrors ++ eventNamespaceErrors ++ initializationErrors ++ - graphErrors ++ eventErrors ++ convergenceErrors ++ mergeErrors + componentErrors ++ componentIdentityErrors ++ missingTargetErrors ++ sourceKindErrors ++ + referenceKindErrors ++ namespaceErrors ++ + eventLabelErrors ++ predicateLabelErrors ++ eventNamespaceErrors ++ eventChildLabelErrors ++ + initializationErrors ++ variantErrors ++ variantShapeErrors ++ convergenceValueErrors ++ + graphErrors ++ eventErrors ++ duplicateRefinementErrors ++ convergenceErrors ++ mergeErrors private def theoryReferenceErrors (theory : Theory.Env) (roots : List String) : List String := let rec visit (fuel : Nat) (seen : List String) (name : String) : List String := @@ -311,11 +366,14 @@ private def inheritedEventBindings | none => [] | some parent => targets.flatMap fun parentEventName => - if (childrenOf parent.elem "event").any (fun candidate => - labelOf candidate == parentEventName) then - eventParamBindings records parentName parentEventName ++ - inheritedEventBindings p records depth parentName parentEventName - else [] + match (childrenOf parent.elem "event").find? (fun candidate => + labelOf candidate == parentEventName) with + | none => [] + | some parentEvent => + eventParamBindings records parentName parentEventName ++ + if isExtended parentEvent then + inheritedEventBindings p records depth parentName parentEventName + else [] dedupBindings [] collected def visibleEventBindings @@ -372,9 +430,9 @@ private def addComponentMode (strict : Bool) (p : Project) (c : Component) : M ( -- A refinement redeclares the variables it keeps. Rebinding them would throw away -- the type the abstract machine's invariants already pinned down. declare n t - -- Rodin puts the after-state `v'` in scope with the same type as `v`, and the - -- `.bpo` records it, so an action assigning to `v` types both. - declare (n ++ "'") t + -- Compatibility inference historically exposed after-state names globally. + -- Strict inference binds them only around the action that owns the state change. + if !strict then declare (n ++ "'") t let predicates := childrenOf c.elem "axiom" ++ childrenOf c.elem "invariant" for a in predicates do if let some f := attrOf a "predicate" then @@ -433,8 +491,12 @@ private def addComponentMode (strict : Bool) (p : Project) (c : Component) : M ( if let some f := attrOf g "predicate" then eventErrors := eventErrors ++ (← runPredicate f) for act in initializationActions p c ev do - if let some f := attrOf act "assignment" then - eventErrors := eventErrors ++ (← runPredicate f) + let actionErrors ← withEnv do + if strict then + for vname in variables do + if let some ty := (← lookup? vname) then bind (vname ++ "'") ty + if let some f := attrOf act "assignment" then runPredicate f else pure [] + eventErrors := eventErrors ++ actionErrors if strict then let witnessErrors ← withEnv do for (name, ty) in inheritedParams do bind name ty @@ -513,7 +575,9 @@ private def inferComponentDetailsModeIn (strict : Bool) (theory : Theory.Env) (p let (_, order) := closure p [] name let roots := componentTheoryRoots p name let run : StateT St (Except String) ComponentInference := do - let mut errs : List String := theoryReferenceErrors theory roots + let projectErrors := (duplicateNames [] (p.map (·.name))).map fun name => + s!"duplicate component name {name}" + let mut errs : List String := projectErrors ++ theoryReferenceErrors theory roots for dep in order do if let some c := lookupComponent p dep then errs := errs ++ componentReferenceErrors p c ++ (← addComponentMode strict p c) @@ -633,6 +697,29 @@ private def duplicateInitializationProject : Project := | .ok (_, errors) => errors.any (fun error => error.contains "exactly one INITIALISATION") | .error _ => false +private def duplicateEventLabelProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] [] + , .event [("org.eventb.core.label", "step")] []] }] + +#guard match inferComponent duplicateEventLabelProject "M" with + | .ok (_, errors) => errors.any (fun error => error.contains "duplicate event label step") + | .error _ => false + +private def primedPredicateProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .invariant [("org.eventb.core.label", "bad"), + ("org.eventb.core.predicate", "x' = 0")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] []] }] + +#guard match inferComponentDetailsCheckedIn Theory.empty primedPredicateProject "M" with + | .ok result => result.diagnostics.any (fun error => error.contains "unresolved") + | .error _ => false + private def invalidVariantProject : Project := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] @@ -646,6 +733,52 @@ private def invalidVariantProject : Project := | .ok (_, errors) => errors.any (fun error => error.contains "variant expression") | .error _ => false +private def invalidReferenceKindProject : Project := + [{ name := "C" + elem := .contextFile [("org.eventb.core.name", "C")] + [.refinesMachine [("org.eventb.core.target", "M")] []] } + , { name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] [] }] + +#guard match inferComponent invalidReferenceKindProject "C" with + | .ok (_, errors) => errors.any (fun error => error.contains "not legal from C") + | .error _ => false + +private def missingVariantExpressionProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.variant [] [], .event [("org.eventb.core.label", "INITIALISATION")] []] }] + +#guard match inferComponent missingVariantExpressionProject "M" with + | .ok (_, errors) => errors.any (fun error => error.contains "variant in M has no expression") + | .error _ => false + +private def duplicateRefinementTargetProject : Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [.event [("org.eventb.core.label", "step")] []] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [.refinesMachine [("org.eventb.core.target", "A")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [.refinesEvent [("org.eventb.core.target", "step")] [] + , .refinesEvent [("org.eventb.core.target", "step")] []]] }] + +#guard match inferComponent duplicateRefinementTargetProject "B" with + | .ok (_, errors) => + errors.any (fun error => error.contains "duplicate refinement reference step") + | .error _ => false + +private def componentNameMismatchProject : Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "Other")] + [.event [("org.eventb.core.label", "INITIALISATION")] []] }] + +#guard match inferComponent componentNameMismatchProject "M" with + | .ok (_, errors) => errors.any (fun error => error.contains "XML name is Other") + | .error _ => false + private def primedBinderProject : Project := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] diff --git a/EventB/Xml.lean b/EventB/Xml.lean index cf1ea8e..c37ad23 100644 --- a/EventB/Xml.lean +++ b/EventB/Xml.lean @@ -162,7 +162,9 @@ private def xmlVersionAttribute : GParser conditional Unit := GParser.seqR (GParser.string "version") (GParser.seqR GParser.ws (GParser.seqR (GParser.ch '=') - (GParser.seqR GParser.ws (GParser.map (fun _ => ()) attrValue)))) + (GParser.seqR GParser.ws + (GParser.seqR (GParser.ch '"') + (GParser.seqL (GParser.string "1.0") (GParser.ch '"')))))) private def declaration : GParser conditional Unit := GParser.map (fun _ => ()) diff --git a/TODO.md b/TODO.md index 198c16c..2eee4c3 100644 --- a/TODO.md +++ b/TODO.md @@ -45,7 +45,7 @@ evidence. rejects any diagnostic. - [x] Validate assignment arity/lvalues, primed closure in `:∣`, duplicate targets, and initialization legality; strict checked generation rejects unresolved diagnostics. -- [ ] Separate compatibility-scope inference from strict Event-B parameter scope: +- [x] Separate compatibility-scope inference from strict Event-B parameter scope: concrete guards/actions must not inherit abstract parameters without a witness. - [x] Include deterministic, nondeterministic, inherited, and stuttering action semantics in the strict invariant/refinement POG path; keep the pinned corpus projection isolated. @@ -57,9 +57,10 @@ evidence. rules in the formula translator. - [x] Reject open metavariable kernel proofs and bind accepted evidence to the exact canonical obligation; Rodin status imports must be parsed from the supplied artifact. -- [ ] Complete the generality ceiling: strict parameter scope, full frame/gluing-relation - semantics, and semantic proofs for each POG class. Right-oriented witnesses and the - basic multi-event merge path now have focused checked fixtures. +- [ ] Complete the generality ceiling: full frame/gluing-relation semantics and semantic + proofs for each POG class. Strict parameter scope, data-refinement glue after-state + retention, duplicate-label rejection, and right-oriented witnesses now have focused + checked fixtures. ### Vertical-slice order @@ -82,10 +83,10 @@ comparison, a full build, and a fresh adversarial review before its checkbox is | Area | Current evidence | Status | | --- | --- | --- | | Build and existing gates | Lean 4.33 build; P0/P1/P2/P3 pass; P3b tracked | current | -| General refinement typing | AMAN/event-scope and missing-reference negative controls pass | current | -| POG semantic coverage | nondeterministic actions, SIM, WWD, variants, EQL/MRG implemented | strict checked path; edge ceiling remains | +| General refinement typing | AMAN/event-scope, hidden-parameter, primed-scope, duplicate-label, and missing-reference controls pass | current | +| POG semantic coverage | nondeterministic actions, data-refinement glue, WWD, variants, EQL/MRG implemented | strict checked path; frame/gluing edge ceiling remains | | Kernel trust | replay checks reject open mvars, stale goals, forged axioms, and context drift | current | -| External/Rodin provenance | model/BPO/status identity, canonical goal/hypothesis/fingerprint binding, monotonic ledger update | current; model/POG re-derivation and cryptographic authenticity remain outside the contract | +| External/Rodin provenance | model/BPO/status identity, canonical goal/hypothesis/fingerprint binding, monotonic ledger update; legacy status-only replay rejected | current; model/POG re-derivation and cryptographic authenticity remain outside the contract | | Release reproducibility | CLI fixture, gate status, and exact baseline ratchet are required | active | | Official Rossi differential | pinned v0.1.7 SHA verified; x86_64 guest validates all four fixtures; CI provisions the exact differential command | current; CI remains release gate | diff --git a/examples/TrustRodinDemo.lean b/examples/TrustRodinDemo.lean index 7306dbd..468244a 100644 --- a/examples/TrustRodinDemo.lean +++ b/examples/TrustRodinDemo.lean @@ -16,9 +16,9 @@ private def source := private def provenance : Trust.Rodin.Provenance := { model := "" + "org.eventb.core.name=\"Demo\">" bpo := "" ++ "" statuses := source } #guard match Trust.Rodin.importStatuses source with diff --git a/examples/WidgetDemo.lean b/examples/WidgetDemo.lean index 56c139e..7a18106 100644 --- a/examples/WidgetDemo.lean +++ b/examples/WidgetDemo.lean @@ -10,8 +10,9 @@ A self-contained Infoview demo: a small bridge controller and one refinement. Open this file in VS Code, restart the Lean server after changing widget code, and inspect the expandable obligation dashboard produced by the final command. The -ledger below contains kernel-replayed proofs for this deliberately small model, so -the panel demonstrates both generated obligations and trusted evidence. +ledger below contains explicitly declared evidence for this deliberately small model; +the separate `#eventb_widget_proof_checks` command performs kernel replay, so the +panel does not overstate the ledger's trust mode. -/ eventb_context WidgetCtx where @@ -160,7 +161,7 @@ private def attachWidgetProof (ledger : Trust.Ledger) | some obligation => let evidence := Trust.Evidence.external "LeanKernel" "4.33" (Trust.fingerprint (obligation.canonical ++ "\ndeclaration=" ++ declaration)) - "Trust.Replay.validate" + "separate Trust.Replay check" match ledger.attach obligation evidence with | .ok updated => updated | .error _ => ledger diff --git a/lakefile.lean b/lakefile.lean index 195973d..72eecbc 100644 --- a/lakefile.lean +++ b/lakefile.lean @@ -2,7 +2,7 @@ import Lake open Lake DSL package «eventb» where - version := v!"4.0.9" + version := v!"4.0.10" leanOptions := #[⟨`autoImplicit, false⟩, ⟨`relaxedAutoImplicit, false⟩] -- Pinned release tags, not `main`: corpus gate numbers are only reproducible if the @@ -39,6 +39,10 @@ lean_exe «gates» where root := `Gates srcDir := "test" +lean_lib «VariantFixtures» where + srcDir := "test" + globs := #[.one `VariantFixtures] + lean_exe «rossi-dump» where root := `RossiDump srcDir := "test" diff --git a/notes/architecture.md b/notes/architecture.md index 1a761c5..f7c4f9c 100644 --- a/notes/architecture.md +++ b/notes/architecture.md @@ -36,7 +36,8 @@ flowchart LR P["Prelude + Theory.Env
imports and scope"] --> T["Typing.Infer + Check"] F --> T T --> G["POG
obligation data"] - G --> S["Semantics
Machine / Proved / Refines"] + G --> Z["POGSoundness
typed valuation boundary"] + Z -. "explicit model bindings still required" .-> S["Semantics
Machine / Proved / Refines"] G --> L["Trust.Ledger"] T --> U["CLI + ProofWidgets"] G --> U @@ -76,6 +77,7 @@ remains the authority for `.eventb` component structure. | Theories | `EventB.Theory`, `Theory.Validate`, `Theory.Embed` | User theories, validation, and Lean denotations. | | Typing | `EventB.Typing.Type`, `Infer`, `Check` | Infer types and validate component scope. | | POG | `EventB.POG` | Generate named obligations, goals, and hypotheses. | +| POG semantic boundary | `EventB.POGSoundness` | Closed PO-class table, error-aware typed valuation checks, and explicit WWD shape; not automatic model soundness. | | Semantics | `EventB.Semantics` | Machines, reachability, proof, and refinement soundness. | | Trust and embedding | `EventB.Trust`, `Trust.Replay`, `Trust.Rodin`, `Embedding`, `Formula.Translate` | Proof provenance, status import, and kernel translation. | | Front ends | `EventB.DSL`, `Widgets.lean`, `Main.lean` | Author, check, and display models. | @@ -115,6 +117,13 @@ The same scope is used by native formula elaboration, `Typing.inferComponentIn`, `POG.generateIn`. This is important: scope is a property of the model component, not a global parser setting. +`EventB.POGSoundness` is deliberately a boundary rather than a hidden second checker. +Its bounded evaluator rejects unsupported or ill-typed terms with explicit errors and +checks valuation-level sequents only after definedness; it does not infer the meaning of +an arbitrary identifier, assignment, witness, variant, or refinement contract. Binding a +generated INV/GRD/SIM/WFIS/VAR obligation to `EventB.Semantics` remains an explicit +model-specific proof step. + ## Formula and typing pipeline Rodin formulas remain strings until `Formula.parse` turns them into `Term` values. The @@ -155,9 +164,15 @@ the definedness facts they require. A user-defined predicate or expression there uses the same POG path as a core symbol. Generating an obligation is not the same as proving it. The obligation data is the -boundary between analysis and proof. `EventB.Semantics` supplies the kernel-native -machine, invariant, and refinement propositions; later proof backends can attach -evidence without changing the model checker. +boundary between analysis and proof. `EventB.Semantics` supplies kernel-native machine, +invariant, frame, gluing, merge, split-merge, witness, variant, and refinement contracts. +`EventB.POG.RefinementAdapters` supplies source-bound proof-carrying adapters for the +refinement-heavy PO families, while `EventB.POG.EQLAdapter` binds the exact deterministic +integer EQL action to the checked before/after evaluator. The generic +`FormulaModel.valid` entry point is fail-closed because a caller-defined interpretation +is not semantic adequacy; `validUnchecked` helpers remain local evaluator fixtures. +Later proof backends can attach evidence without changing the model checker; missing +model-specific formula bindings remain unproved rather than being inferred. Theory validation also emits declaration obligations. Structural rewrite termination is marked `checked` only for the conservative decreasing case; rewrite soundness and @@ -186,14 +201,14 @@ kernel proof only after resolving its declaration, translating the complete POG checking definitional equality, and comparing its transitive axiom dependencies with the declared metadata. `Trust.Rodin` imports `.bps` status records as `rodinImported`; it never upgrades them to kernel evidence. Legacy status-only -Rodin evidence is rejected. The import binds model-root identity and source-appropriate +Rodin evidence is rejected. The import binds explicit artifact/source identity and +source-appropriate event, predicate, action, witness, variable, and variant structure, plus PO-sequent, -source-component, and status identities, but does not rederive -the BPO sequent from the model. SMT and external -evidence remain explicit metadata boundaries and must carry solver/tool, version, input -digest, and verifier fields. Rodin provenance retains the model, BPO, and status bytes -for replayable structural, goal, and hypothesis checks; it does not yet rederive the -POG from the model. +source-component, and status identities, and strictly regenerates the model-derived POG +with the supplied theory environment before comparing the target canonical obligation. +SMT and external evidence remain metadata-only boundaries and must carry solver/tool, +version, input digest, and verifier claims. Rodin provenance retains the model, BPO, and +status bytes for replayable structural, goal, hypothesis, and model-derived POG checks. ## User experience @@ -247,7 +262,7 @@ The gates compare the implementation against the pinned corpus and ratchet files broad filtering is unsound because the corpus retains other static-looking invariant sequents. - P4: the gates run the deterministic local baseline over the 1133 P3-matched - obligations; the current result is 73 external-trusted and the rest unproved. + obligations; the current result is 73 external-declared and the rest unproved. The semantic boundary is explicit: theory definitions and constructors require caller-supplied Lean denotations; translation can be measured independently; only a @@ -459,8 +474,8 @@ environment, and the prover configuration. A stale or forged result must not sil move an obligation out of `unproved`. In particular: - a Lean proof term is accepted only after kernel replay; -- an SMT result records its solver, version, input digest, and trust mode; -- an external proof records the verifier and evidence location; +- an SMT result records its solver, version, input digest, and metadata-only trust mode; +- an external proof records the verifier claim, evidence location, and metadata-only mode; - an imported Rodin result is labelled `rodinImported`, never `kernel`; - missing, stale, or unverifiable evidence leaves the entry `unproved`. @@ -475,8 +490,10 @@ kernel proof coverage. Acceptance criteria: - every accepted result has a stable obligation fingerprint and explicit mode; -- evidence can be replayed or rejected in a clean build; -- changing the obligation, model, theory, or prover input invalidates the evidence; +- kernel evidence can be replayed or rejected in a clean build, while Rodin evidence is + structurally/model-derived checked and metadata-only external evidence remains declared; +- changing inputs invalidates evidence when that input is included in its canonical or + provenance fingerprint binding; - the widget shows the obligation's mode and evidence status without conflating them; - negative tests prove that unverifiable and mislabelled evidence is rejected; - P4 records discharge results without weakening P0 through P3b. diff --git a/notes/production-acceptance.md b/notes/production-acceptance.md index 08793c3..6c94da7 100644 --- a/notes/production-acceptance.md +++ b/notes/production-acceptance.md @@ -23,12 +23,12 @@ passes; the current worktree is intentionally still under adversarial review. | P3b hypotheses | 1132/1325 | Derived hypothesis sets and named compatibility omissions are tracked. | | P3b WWD | 1/1 | Hypothesis-only witness well-definedness is scored separately. | | P3b compatibility | 200 pinned | Explicit, classified pinned-oracle omissions. | -| P4 local baseline | 73/1133 | Explicit external-trusted evidence; 1060 remain unproved. | +| P4 local baseline | 73/1133 | Explicit external-declared evidence; 1060 remain unproved. | The P3b compatibility records are not silently omitted or counted as proof failures. They are pinned, classified, regression-tested, and reported by the gates. The P4 count is a measured baseline, not a percentage claim. Kernel, SMT, and imported-Rodin -counts are zero for the corpus baseline; the local results remain external-trusted. +counts are zero for the corpus baseline; the local results remain external-declared. ## Supported surfaces @@ -43,7 +43,9 @@ counts are zero for the corpus baseline; the local results remain external-trust variants. `generateChecked` is the strict path: it rejects unresolved references, duplicate labels, malformed component kinds, invalid primed scope, and hidden parameters after non-extended refinement boundaries. The corpus gate retains a - documented compatibility projection for pinned Rodin omissions. + documented compatibility projection for pinned Rodin omissions. The semantic slice + also includes source-bound parameterized enabled events, finite witness domains, and + well-founded variant contracts; these require explicit model/domain bindings. - CLI reports, proof-obligation output, trust-ledger evidence, ProofWidgets, and native Lean declaration ranges. @@ -57,21 +59,81 @@ Every obligation has an explicit ledger mode. Kernel evidence requires replayed proof terms and checked axiom metadata. SMT, Rodin-imported, and external evidence remain their own modes with verifier, version, input digest, and fingerprint metadata. Unproved obligations remain `unproved`; reports never upgrade them implicitly. -Rodin imports additionally require model-root identity, source-component binding, the -named BPO sequent, and equality of its canonical goal and hypothesis multiset with the -generated obligation, plus an independently parsed proof-status record. Re-deriving -the POG from model bytes remains outside this contract; the current digest primitive is -an internal fingerprint, not a cryptographic authenticity claim. Legacy status-only -Rodin evidence is rejected; model, BPO, and status provenance are mandatory. SMT and -external verifier fields remain caller-supplied metadata and are never presented as -Lean-kernel replay. +Rodin imports additionally require the supplied model-artifact set, shared project +parsing, strict model-derived POG regeneration (using the supplied theory environment), +explicit source-component identity (and agreement with the XML root name when present), +the named BPO sequent, and equality of its canonical obligation with the regenerated one, +plus an independently parsed proof-status record. Missing referenced components fail +closed; exact transitive-closure completeness and stale-artifact rejection remain +release follow-up work. +The current digest primitive remains an internal fingerprint, not a cryptographic +authenticity claim. Legacy status-only Rodin evidence is rejected; model, BPO, and +status provenance are mandatory. SMT and external verifier fields remain caller-supplied +metadata and are never presented as Lean-kernel replay; CLI JSON marks those records +`metadata_only: true`. + +The bounded `EventB.POGSoundness` adapter is a separate, explicit valuation boundary: +it supports typed state-formula validity for `THM`, `WD`, `VWD`, and `WWD`, plus typed +before/after validity for the supported transition classes, in its documented subset; +`WFIS` has a finite-domain completeness lemma and a bounded witness-candidate fixture, +but general acceptance still requires a caller-supplied finite domain. It uses explicit +evaluator errors and definedness checks, and rejects unknown POG +classes, malformed identity/diagnostics, malformed WWD shapes, overloaded comma, +unsupported applications, and other unsupported constructs. The generic formula-model +acceptor is fail-closed until semantic adequacy is supplied. Finite relation application, +image, domain/range restriction/subtraction, and override are supported only for explicit +finite pair sets; duplicate function inputs and malformed relation members fail closed. The accepting +sequent APIs require membership in `POG.generateCheckedIn` plus a source-locator check +over the component's refinement closure; their `validUnchecked` counterparts are only +local evaluator fixtures and are not trust evidence. Refinement-heavy classes additionally +require the source-bound proof-carrying adapters in `EventB.POG.RefinementAdapters`. +Transition-formula adequacy takes the checked event relation as a type-level source +parameter and requires both source validity and source completeness. This prevents a +singleton evaluator domain from being substituted for a non-singleton Event-B action. +The accepting INV, GRD, SIM, and FIS fixtures use source-indexed subtype states; WFIS, +WWD, an anticipated integer NAT/VAR pair, and VWD have exact source-bound witnesses. +MRG has an exact generated two-target, source-transition, and ordered-branch fixture +(`test/MrgAdapterFixtures.lean`), including source-indexed branch guard/action exactness +and a same-label foreign-branch negative (`test/MrgSemanticFixtures.lean`). EQL has a +bounded source-complete integer adapter, and FIN has a source-bound constant finite-set +adapter witness plus typed powerset evaluator controls. The finite adapter now also has +a model-derived invariant-restricted source-domain fixture +(`test/FiniteVariantModelFixtures.lean`); `FiniteSetVariantAdapter.actionTotal` remains +a checked diagnostic of the legacy unrestricted VAR carrier. `CheckedGuardSource` +binds the parsed effective guard list; parameterized enabledness is accepted only for +the source-bound parameter/event slice covered by the fixtures. +The evaluator's implementation +view is private: single-state wrappers reject primed terms, while primed evaluation is +available only through a declaration-checked `CheckedBeforeAfter` whose before and +after environments are revalidated at the caller's fuel. Given-set atoms require an +explicit finite carrier observation in `ValueEnv`; nominal tags alone are rejected. +`ComponentValuation` binds strict inferred declarations, writable variables, and the +project event's effective deterministic actions before typed assignment; the refinement +adapters reuse this exact event source and variant-expression boundary, so fabricated +event names, cross-component variant pairs, and altered right-hand sides fail closed. +It is not evidence that +generated INV/GRD/SIM/WFIS/VAR obligations are semantically sound for an arbitrary +model; those require model-specific bindings to `EventB.Semantics`. ## Acceptance commands Run these from a clean checkout with no private artifacts staged: ```sh -lake build EventB EventBWidgets Examples gates rossi-dump eventb bench +lake build EventB EventBWidgets Examples VariantFixtures gates rossi-dump eventb bench +lake env lean EventB/POGSoundness.lean +lake build EventB.POG.EQLAdapter +lake env lean EventB/POG/RefinementAdapters.lean +lake env lean test/EqlFixtures.lean +lake env lean test/GuardFixtures.lean +lake env lean test/EnabledGuardFixtures.lean +lake env lean test/FiniteSetEvaluatorFixtures.lean +lake env lean test/FiniteVariantFixtures.lean +lake env lean test/VwdFixtures.lean +lake env lean test/MrgFixtures.lean +lake env lean test/MrgSemanticFixtures.lean +lake env lean test/MrgAdapterFixtures.lean +lake env lean test/AdapterAxiomAudit.lean lake exe gates --status lake exe gates pre-commit run --all-files @@ -88,32 +150,54 @@ The Rossi command requires the pinned official Rossi executable. CI downloads complete fixture matrix. The local command may instead use `ROSSI_BIN=/path/to/rossi python3 tools/rossi-diff.py`. -On 2026-08-14, the pinned archive was also executed as `rossi 0.1.7` in a -disposable x86_64 Linux QEMU/Lima guest. Its JSON validator returned success for -all checked-in fixtures: `actions.eventb` (1 component), `boundaries.eventb` -(2), `identifiers.eventb` (2), and `witnesses.eventb` (3). The exact combined -`tools/rossi-diff.py` command remains a CI gate because the local Lean executable -is host-native while the pinned Rossi artifact is Linux x86_64. +On 2026-08-15, the pinned archive was executed as `rossi 0.1.7` in the disposable +x86_64 Linux QEMU/Lima guest. Its JSON validator returned success for all checked-in +fixtures: `actions.eventb` (1 component), `boundaries.eventb` (2), `identifiers.eventb` +(2), and `witnesses.eventb` (3); the combined `tools/rossi-diff.py` wrapper also passed. The final manual release gate opens `examples/WidgetDemo.lean` and `examples/LspDemo.lean` -in VS Code with a restarted Lean server. It checks the widget panels, replayed entries, -Go to Definition, and unknown-symbol diagnostics. Terminal builds cannot certify the -Infoview's browser layout, so this gate must be recorded separately. +in VS Code with a restarted Lean server. On 2026-08-15 it was rerun successfully for +the current worktree: the WidgetDemo POG panel showed 11 derived obligations, +`external-declared: 11`, and `open / unproved: 0`; `#eventb_lsp_checks` passed; and the +native reference-location fix made Go to Definition from `sees LspContext` find the +declaration. A temporary unknown identifier produced the expected Lean diagnostic and +was discarded without saving. Terminal builds still cannot certify the Infoview's browser +layout. ## Known ceilings - The pinned `.bpo` corpus omits the 200 P3b compatibility records described above. -- The corpus-scale P4 baseline has 73 external-trusted results and 1060 unproved +- The corpus-scale P4 baseline has 73 external-declared results and 1060 unproved obligations; semantic bindings are required before claiming corpus-scale kernel proof. -- Generality still has an explicit ceiling: full frame/gluing-relation semantics and - semantic soundness proofs for every generated PO class remain follow-up work. Strict - parameter scope, data-refinement glue after-state retention, right-oriented witnesses, - and basic multi-event MRG have focused checked fixtures. +- The bounded valuation adapter intentionally does not yet support partial/theory + applications, binders/comprehensions, or automatic conversion of every generated POG + formula into a model-specific semantic contract. Source-indexed INV/GRD/SIM/FIS + fixtures and exact WFIS/WWD/integer-NAT-VAR/VWD witnesses are checked end-to-end; + MRG target labels plus a checked two-branch source-indexed adapter, bounded integer + EQL, EQL/FIN locator controls, and model-derived finite-set VAR are checked. Full + abstract-event MRG provenance remains an explicit follow-up. Typed `ℙ(T)` evaluation + and enabled guard fixtures are now covered. Source-bound parameterized enabledness, + finite-domain witness evaluation, and well-founded variant contracts are accepted for + their explicit supported slice; `ℙ1`, unbounded binders/comprehensions, partial/theory + applications, and automatic semantic interpretation of arbitrary formulas remain + outside the accepted subset. + Refinement adapters now require explicit `FormulaAdequacy` witnesses that connect + validity of the exact generated sequent to the corresponding semantic contract; + these witnesses are still project-specific rather than inferred from names. These + are explicit follow-up work rather than inferred semantics. +- Generality still has an explicit ceiling: `EventB.Semantics` now exposes and checks + frame, gluing, merge, witness, parameterized-event, and well-founded-variant contracts, + while `EventB.POGSoundness` exposes explicit translated-sequent validity. Generated POG + classes are not all automatically bound to model-specific interpretations and operator + soundness lemmas. Strict parameter scope, data-refinement glue after-state retention, + right-oriented witnesses, and basic multi-event MRG have focused checked fixtures. - `POG.generate`/`generateIn` remain compatibility APIs for the pinned corpus; trusted front ends must use `generateChecked`/`generateCheckedIn` and fail on diagnostics. - Rodin `.bps` status names are not component-scoped; the provenance model/BPO source binding supplies that scope, while cryptographic authenticity remains outside this contract. +- XML roots without a name are accepted only when the caller supplies explicit component + identity; this compatibility path is not an XML-authenticated identity proof. - The official Rossi differential executable is provisioned in CI, not vendored. - Raw Rossi/XML source navigation and visual ProofWidgets acceptance require the manual editor gate. diff --git a/test/AdapterAxiomAudit.lean b/test/AdapterAxiomAudit.lean new file mode 100644 index 0000000..1323a98 --- /dev/null +++ b/test/AdapterAxiomAudit.lean @@ -0,0 +1,24 @@ +import EventB.POG.RefinementAdapters +import EventB.POG.EQLAdapter + +namespace EventB.POG + +#print axioms TransitionFormulaAdequacy.valid +#print axioms TransitionFormulaAdequacy.validWithCoverage +#print axioms FormulaAdequacy.valid +#print axioms SimAdapter.sound +#print axioms FisAdapter.sound +#print axioms WfisAdapter.sound +#print axioms WwdAdapter.sound +#print axioms IntegerVariantAdapter.sound +#print axioms GrdAdapter.sound +#print axioms InvAdapter.sound +#print axioms MergeAdapter.sound +#print axioms EqlIntAdapter.sound +#print axioms FiniteSetVariantAdapter.sound +#print axioms FiniteSetVariantAdapter.actionTotal +#print axioms RestrictedFiniteSetVariantAdapter.sound +#print axioms ParameterizedEventRefinement.stepSim +#print axioms WellFoundedVariantAdapter.sound + +end EventB.POG diff --git a/test/EnabledGuardFixtures.lean b/test/EnabledGuardFixtures.lean new file mode 100644 index 0000000..3926978 --- /dev/null +++ b/test/EnabledGuardFixtures.lean @@ -0,0 +1,280 @@ +/- Focused positive and negative semantic enabled-event source fixture. -/ + +import EventB.POG.RefinementAdapters + +namespace EventB.POG + +private def enabledEventProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .invariant [("org.eventb.core.label", "type"), + ("org.eventb.core.predicate", "x ∈ ℤ")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [.guard [("org.eventb.core.label", "enabled"), + ("org.eventb.core.predicate", "x = 0")] [] + , .action [("org.eventb.core.label", "stutter"), + ("org.eventb.core.assignment", "x ≔ x")] []]] }] + +#guard match generateCheckedIn EventB.Theory.empty enabledEventProject "M" with + | .ok _ => true + | .error _ => false + +private def enabledEventSource : + CheckedEventSource EventB.Theory.empty enabledEventProject "M" "step" := + (CheckedEventSource.fromProject EventB.Theory.empty enabledEventProject "M" "step").get + (by native_decide) + +private def enabledGuardSource : + CheckedGuardSource EventB.Theory.empty enabledEventProject "M" "step" := + (CheckedGuardSource.fromProject EventB.Theory.empty enabledEventProject "M" "step").get + (by native_decide) + +#guard enabledEventSource.declarations == [("x", .int)] +#guard enabledEventSource.updates == [("x", .id "x")] +#guard enabledGuardSource.predicates == + [.bin "=" (.id "x") (.num 0)] + +private def enabledTransition : CheckedBeforeAfter := + { before := { values := [("x", .integer 0)] } + after := { values := [("x", .integer 0)] } + declarations := [("x", .int)] } + +private def disabledTransition : CheckedBeforeAfter := + { before := { values := [("x", .integer 1)] } + after := { values := [("x", .integer 1)] } + declarations := [("x", .int)] } + +private theorem enabledAction : + enabledEventSource.assignmentAction 128 enabledTransition := by + have declarations : enabledEventSource.declarations = [("x", .int)] := by + native_decide + have updates : enabledEventSource.updates = [("x", .id "x")] := by + native_decide + change assignmentRelation 128 enabledEventSource.declarations + enabledTransition enabledEventSource.updates + rw [declarations, updates] + exact assignmentRelation_x_self_zero + +private theorem disabledAction : + enabledEventSource.assignmentAction 128 disabledTransition := by + have declarations : enabledEventSource.declarations = [("x", .int)] := by + native_decide + have updates : enabledEventSource.updates = [("x", .id "x")] := by + native_decide + change assignmentRelation 128 enabledEventSource.declarations + disabledTransition enabledEventSource.updates + rw [declarations, updates] + unfold assignmentRelation + native_decide + +private theorem enabledGuard : + enabledGuardSource.holds 128 enabledTransition := by + have declarations : enabledGuardSource.declarations = [("x", .int)] := by + native_decide + have predicates : enabledGuardSource.predicates = + [.bin "=" (.id "x") (.num 0)] := by + native_decide + unfold CheckedGuardSource.holds + rw [declarations, predicates] + constructor + · rfl + constructor + · native_decide + constructor + · native_decide + · intro predicate member + simp only [List.mem_singleton] at member + subst predicate + unfold assignmentPredicateWithFuel + native_decide + +private theorem disabledGuardNotHolds : + ¬ enabledGuardSource.holds 128 disabledTransition := by + intro holds + have predicates : enabledGuardSource.predicates = + [.bin "=" (.id "x") (.num 0)] := by + native_decide + unfold CheckedGuardSource.holds at holds + rw [predicates] at holds + rcases holds with ⟨_, _, _, predicate⟩ + have falsePredicate := predicate (.bin "=" (.id "x") (.num 0)) (by simp) + unfold assignmentPredicateWithFuel at falsePredicate + have notTrue : + evalBeforeAfter 128 disabledTransition + (.bin "=" (.id "x") (.num 0)) ≠ .ok true := by + native_decide + exact notTrue falsePredicate + +private def enabledEvent : Event CheckedBeforeAfter := + { grd := fun transition => enabledGuardSource.holds 128 transition + act := fun before _ => enabledEventSource.assignmentAction 128 before } + +private def badGuardEvent : Event CheckedBeforeAfter := + { grd := fun _ => True + act := fun before _ => enabledEventSource.assignmentAction 128 before } + +private theorem actionProvenance : + eventActionExact enabledEventSource 128 + (fun state : CheckedBeforeAfter × CheckedBeforeAfter => state.1) + (fun state => enabledEvent.act state.1 state.2) := by + intro state + rfl + +private theorem guardProvenance : + ∀ transition, enabledEvent.grd transition ↔ + enabledGuardSource.holds 128 transition := by + intro transition + rfl + +private theorem enabledEvent_is_enabled : enabledEvent.grd enabledTransition ∧ + enabledEvent.act enabledTransition enabledTransition := by + exact ⟨enabledGuard, enabledAction⟩ + +private theorem enabledEvent_is_disabled : ¬ enabledEvent.grd disabledTransition := + disabledGuardNotHolds + +example : enabledEvent.act disabledTransition disabledTransition := by + exact disabledAction + +example : ¬ (∀ transition, + badGuardEvent.grd transition ↔ enabledGuardSource.holds 128 transition) := by + intro exactness + have mismatch := exactness disabledTransition + apply disabledGuardNotHolds + simpa [badGuardEvent] using mismatch.mp trivial + +/- A model-derived parameterized event. The parameter is part of the checked + lexical environment, while the action still reads it from the pre-state and + updates only the declared machine variable. -/ + +private def parameterizedEventProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [ ("org.eventb.core.name", "M") ] + [ .variable [("org.eventb.core.identifier", "x")] [] + , .invariant [("org.eventb.core.label", "type"), + ("org.eventb.core.predicate", "x ∈ ℤ")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] + [ .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ 0")] [] ] + , .event [("org.eventb.core.label", "step")] + [ .parameter [("org.eventb.core.identifier", "p")] [] + , .guard [("org.eventb.core.label", "enabled"), + ("org.eventb.core.predicate", "p > 0")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ p")] [] ] ] }] + +#guard match generateCheckedIn EventB.Theory.empty parameterizedEventProject "M" with + | .ok _ => true + | .error _ => false + +private def parameterizedEventSource : + CheckedEventSource EventB.Theory.empty parameterizedEventProject "M" "step" := + (CheckedEventSource.fromProject EventB.Theory.empty parameterizedEventProject "M" "step").get + (by native_decide) + +private def parameterizedGuardSource : + CheckedGuardSource EventB.Theory.empty parameterizedEventProject "M" "step" := + (CheckedGuardSource.fromProject EventB.Theory.empty parameterizedEventProject "M" "step").get + (by native_decide) + +#guard parameterizedEventSource.declarations == [("x", .int), ("p", .int)] +#guard parameterizedEventSource.updates == [("x", .id "p")] +#guard parameterizedGuardSource.declarations == [("x", .int), ("p", .int)] +#guard parameterizedGuardSource.predicates == [.bin ">" (.id "p") (.num 0)] + +private def parameterizedTransition (parameter state after : Int) : CheckedBeforeAfter := + { before := { values := [("x", .integer state), ("p", .integer parameter)] } + after := { values := [("x", .integer after), ("p", .integer parameter)] } + declarations := [("x", .int), ("p", .int)] } + +private def parameterizedEvent : ParameterizedEvent Int Int := + { grd := fun parameter _ => parameter > 0 + act := fun parameter _ after => after = parameter } + +example : parameterizedEvent.enabled 0 := by + exact ⟨1, by change (1 : Int) > 0; omega⟩ + +example : parameterizedEventSource.assignmentAction 128 + (parameterizedTransition 7 0 7) := by + unfold CheckedEventSource.assignmentAction assignmentRelation + native_decide + +example : parameterizedGuardSource.holds 128 + (parameterizedTransition 7 0 7) := by + have declarations : parameterizedGuardSource.declarations = + [("x", .int), ("p", .int)] := by native_decide + have predicates : parameterizedGuardSource.predicates = + [.bin ">" (.id "p") (.num 0)] := by native_decide + unfold CheckedGuardSource.holds + rw [declarations, predicates] + constructor + · rfl + constructor + · native_decide + constructor + · native_decide + · intro predicate member + simp only [List.mem_singleton] at member + subst predicate + unfold assignmentPredicateWithFuel + native_decide + +example : ¬ parameterizedGuardSource.holds 128 + (parameterizedTransition (-1) 0 (-1)) := by + have predicates : parameterizedGuardSource.predicates = + [.bin ">" (.id "p") (.num 0)] := by native_decide + unfold CheckedGuardSource.holds + intro holds + rw [predicates] at holds + rcases holds with ⟨_, _, _, predicate⟩ + have falsePredicate := predicate (.bin ">" (.id "p") (.num 0)) (by simp) + unfold assignmentPredicateWithFuel at falsePredicate + have notTrue : + evalBeforeAfter 128 (parameterizedTransition (-1) 0 (-1)) + (.bin ">" (.id "p") (.num 0)) ≠ .ok true := by + native_decide + exact notTrue falsePredicate + +private def abstractParameterizedEvent : ParameterizedEvent Nat Nat := + { grd := fun parameter _ => parameter > 0 + act := fun _ before after => after = before + 1 } + +private def concreteParameterizedEvent : ParameterizedEvent Nat Nat := + { grd := fun parameter _ => parameter > 0 + act := fun _ before after => after = before + 1 } + +private theorem parameterizedRefinement : + ParameterizedEventRefinement concreteParameterizedEvent + abstractParameterizedEvent (fun concrete abstract => concrete = abstract) := + { guard := by + intro parameter concrete abstract glued guard + subst abstract + exact ⟨parameter, guard⟩ + action := by + intro parameter concrete concreteAfter abstract glued guard action + subst abstract + exact ⟨parameter, concreteAfter, guard, action, rfl⟩ } + +example : ∃ abstractAfter, + abstractParameterizedEvent.step 1 abstractAfter ∧ + (2 = abstractAfter) := by + obtain ⟨abstractAfter, step, glued⟩ := + parameterizedRefinement.stepSim 1 2 1 rfl + (show concreteParameterizedEvent.step 1 2 from + ⟨1, by change (1 : Nat) > 0; decide, + by change (2 : Nat) = 1 + 1; decide⟩) + exact ⟨abstractAfter, step, by simpa using glued⟩ + +private def naturalWellFoundedVariant : WellFoundedVariant Nat Nat := + { measure := id + relation := (· < ·) + wellFounded := Nat.lt_wfRel.wf + action := fun before after => after < before + progress := fun _ _ progress => progress } + +example : wellFoundedVariantProgressSemantic naturalWellFoundedVariant := + naturalWellFoundedVariant.progressSemantic + +end EventB.POG diff --git a/test/EqlFixtures.lean b/test/EqlFixtures.lean new file mode 100644 index 0000000..4264af7 --- /dev/null +++ b/test/EqlFixtures.lean @@ -0,0 +1,101 @@ +/- Complete source-bound EQL acceptance fixture. -/ + +import EventB.POG.EQLAdapter + +namespace EventB.POG + +private def eqlBinding : EqlIntBinding Theory.empty positiveProject := + (EqlIntBinding.fromProject? Theory.empty positiveProject "B" "step" "x").get + (by native_decide) + +#guard (EqlIntBinding.fromProject? Theory.empty positiveProject "B" "step" "y").isNone + +private def eqlEncode (_ : Unit) : ValueEnv := + { values := [("x", .integer 0)] } + +private def eqlTransition : CheckedBeforeAfter := + { before := eqlEncode () + after := eqlEncode () + declarations := [("x", .int)] } + +private theorem eqlAssignment : + ValueEnv.parallelAssignTypedFuel 128 [("x", .int)] (eqlEncode ()) + [("x", .id "x")] = .ok eqlTransition := by + native_decide + +private def eqlBridge : EqlIntEventBridge eqlBinding Unit := + { fuel := 128 + encode := eqlEncode + event := + { grd := fun _ => True + act := fun before after => eqlBinding.action 128 + (eqlEncode before) (eqlEncode after) } + declarationsExact := by native_decide + stateValid := by intro state; cases state; native_decide + actionExact := by intro before after; exact Iff.rfl + unprimed := by native_decide + primedBase := by native_decide + primeNotInteger := by native_decide + primeNotNatural := by native_decide + primeNotNatural1 := by native_decide + primeNotBoolean := by native_decide + notInteger := by native_decide + notNatural := by native_decide + notNatural1 := by native_decide + notBoolean := by native_decide + hypothesesHold := by + intro before after eventStep + cases before + cases after + change EqlIntBinding.action eqlBinding 128 (eqlEncode ()) (eqlEncode ()) at eventStep + rcases eventStep with ⟨transition, computed, afterEq⟩ + have declarations : eqlBinding.declarations = [("x", .int)] := by + native_decide + have updates : eqlBinding.updates = [("x", .id "x")] := by + native_decide + rw [declarations, updates] at computed + rw [eqlAssignment] at computed + cases computed + rw [declarations] + refine ⟨eqlTransition, rfl, rfl, rfl, ?_, ?_, ?_⟩ + · native_decide + · native_decide + · intro hypothesis membership + have hypotheses : eqlBinding.obligation.hyps = + [.bin "∈" (.id "x") (.id "ℤ"), + .bin "∈" (.id "x") (.id "ℤ"), eqlGoal "x"] := by + native_decide + rw [hypotheses] at membership + have cases : hypothesis = .bin "∈" (.id "x") (.id "ℤ") ∨ + hypothesis = .bin "∈" (.id "x") (.id "ℤ") ∨ + hypothesis = eqlGoal "x" := by + simpa using membership + rcases cases with h | h | h + · rw [h]; simpa [eqlTransition, eqlEncode] using assignmentPredicate_x_in_integer_set + · rw [h]; simpa [eqlTransition, eqlEncode] using assignmentPredicate_x_in_integer_set + · rw [h]; simpa [eqlTransition, eqlEncode, eqlGoal] using assignmentPredicate_x_self_zero + stateInteger := by + intro state + cases state + exact ⟨0, by native_decide⟩ + nonempty := by + have declarations : eqlBinding.declarations = [("x", .int)] := by + native_decide + have updates : eqlBinding.updates = [("x", .id "x")] := by + native_decide + refine ⟨(), (), ?_⟩ + change EqlIntBinding.action eqlBinding 128 (eqlEncode ()) (eqlEncode ()) + change ∃ transition, ValueEnv.parallelAssignTypedFuel 128 eqlBinding.declarations + (eqlEncode ()) eqlBinding.updates = .ok transition ∧ transition.after = eqlEncode () + rw [declarations, updates] + exact ⟨eqlTransition, eqlAssignment, rfl⟩ } + +private def eqlAdapter : EqlIntAdapter Theory.empty positiveProject Unit := + { binding := eqlBinding + bridge := eqlBridge + sequent := eqlBridge.sequent_of_goal_hypothesis (by native_decide) } + +example : framePreserved eqlAdapter.bridge.read eqlAdapter.bridge.event.act := + eqlAdapter.sound + +end EventB.POG diff --git a/test/FiniteSetEvaluatorFixtures.lean b/test/FiniteSetEvaluatorFixtures.lean new file mode 100644 index 0000000..fc94124 --- /dev/null +++ b/test/FiniteSetEvaluatorFixtures.lean @@ -0,0 +1,54 @@ +/- Typed finite-set evaluator fixtures for ℙ(T), finite, and subset goals. -/ + +import EventB.POGSoundness + +namespace EventB.POG + +private def setEnv : ValueEnv := + { values := [("S", .set [.integer 0, .integer 1])] } + +private def badSetEnv : ValueEnv := + { values := [("S", .set [.integer 0, .boolean true])] } + +private def integerUniverseEnv : ValueEnv := + { values := [("S", .integerSet)] } + +private def setTransition : CheckedBeforeAfter := + { before := setEnv + after := { values := [("S", .set [.integer 1])] } + declarations := [("S", .pow .int)] } + +#guard (EventB.Formula.parse "S ∈ ℙ(ℤ)").toOption == + some (.bin "∈" (.id "S") (.pre "ℙ" (.id "ℤ"))) +#guard ValueEnv.validationOk 128 [("S", .pow .int)] setEnv +#guard !ValueEnv.validationOk 128 [("S", .pow .int)] badSetEnv + +#guard evalPredicateAtFuel 128 setEnv + (.bin "∈" (.id "S") (.pre "ℙ" (.id "ℤ"))) == .ok true +#guard evalPredicateAtFuel 128 setEnv + (.app (.id "finite") (.id "S")) == .ok true +#guard ValueEnv.validationOk 128 [("S", .pow .int)] integerUniverseEnv +#guard evalPredicateAtFuel 128 integerUniverseEnv + (.app (.id "finite") (.id "S")) == .ok false +#guard evalBeforeAfter 128 setTransition + (.bin "⊂" (.id "S'") (.id "S")) == .ok true +#guard match evalPredicateAtFuel 128 badSetEnv + (.bin "∈" (.id "S") (.pre "ℙ" (.id "ℤ"))) with + | .error _ => true + | .ok _ => false + +private def witnessBody : EventB.Formula.Term := + .bin "=" (.id "p") (.num 0) + +#guard evalPredicateOverFiniteDomain 128 {} "p" + [.integer 0, .integer 1] witnessBody == .ok true +#guard evalPredicateOverFiniteDomain 128 {} "p" + [.integer 1, .integer 2] witnessBody == .ok false + +example : ∃ candidate, candidate ∈ ([.integer 0, .integer 1] : List Value) ∧ + evalPredicateAtFuel 128 (({} : ValueEnv).set "p" candidate) witnessBody = .ok true := by + apply evalPredicateOverFiniteDomain_true 128 {} "p" + [.integer 0, .integer 1] witnessBody + native_decide + +end EventB.POG diff --git a/test/FiniteVariantFixtures.lean b/test/FiniteVariantFixtures.lean new file mode 100644 index 0000000..360f38b --- /dev/null +++ b/test/FiniteVariantFixtures.lean @@ -0,0 +1,381 @@ +/- Source-bound finite-set variant fixture. -/ + +import EventB.POG.RefinementAdapters + +namespace EventB.POG + +private def finiteVariantProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [ .variable [("org.eventb.core.identifier", "S")] [] + , .invariant [("org.eventb.core.label", "type"), + ("org.eventb.core.predicate", "S ∈ ℙ(ℤ)")] [] + , .variant [("org.eventb.core.expression", "S")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] + [ .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "S ≔ {0, 1}")] [] ] + , .event [("org.eventb.core.label", "step"), + ("org.eventb.core.convergence", "1")] + [ .guard [("org.eventb.core.label", "nonempty"), + ("org.eventb.core.predicate", "S ≠ ∅")] [] + , .action [("org.eventb.core.label", "remove"), + ("org.eventb.core.assignment", "S ≔ S ∖ {0}")] [] ] ] }] + +private def parsed? (source : String) : Option EventB.Formula.Term := + (EventB.Formula.parse source).toOption + +#guard match generateCheckedIn EventB.Theory.empty finiteVariantProject "M" with + | .ok obligations => + obligations.any (fun obligation => obligation.kind == "FIN" && + obligation.goal == parsed? "finite(S)") + | .error _ => false + +#guard match generateCheckedIn EventB.Theory.empty finiteVariantProject "M" with + | .ok obligations => + obligations.any (fun obligation => obligation.kind == "VAR" && + obligation.name == "step/VAR" && + obligation.goal == parsed? "S ∖ {0} ⊂ S") + | .error _ => false + +#guard EventB.POG.eventConvergenceMode? finiteVariantProject "M" "step" == some "1" +#guard EventB.POG.eventConvergenceMode? finiteVariantProject "M" "missing" == none + +private def anticipatedFiniteVariantProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [ .variable [("org.eventb.core.identifier", "S")] [] + , .invariant [("org.eventb.core.label", "type"), + ("org.eventb.core.predicate", "S ∈ ℙ(ℤ)")] [] + , .invariant [("org.eventb.core.label", "finite"), + ("org.eventb.core.predicate", "finite(S)")] [] + , .variant [("org.eventb.core.expression", "S")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] + [ .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "S ≔ {0, 1}")] [] ] + , .event [("org.eventb.core.label", "hold"), + ("org.eventb.core.convergence", "2")] + [ .action [("org.eventb.core.label", "hold"), + ("org.eventb.core.assignment", "S ≔ S")] [] ] ] }] + +private def anticipatedFinObligation : Obligation := + { component := "M", name := "FIN", kind := "FIN" + goal := parsed? "finite(S)" + hyps := [(parsed? "S ∈ ℙ(ℤ)").get (by native_decide), + (parsed? "finite(S)").get (by native_decide)] } + +private def anticipatedVarObligation : Obligation := + { component := "M", name := "hold/VAR", kind := "VAR" + goal := parsed? "S ⊆ S" + hyps := [(parsed? "S ∈ ℙ(ℤ)").get (by native_decide), + (parsed? "finite(S)").get (by native_decide)] } + +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty anticipatedFiniteVariantProject + anticipatedFinObligation).isSome +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty anticipatedFiniteVariantProject + anticipatedVarObligation).isSome +#guard EventB.POG.eventConvergenceMode? anticipatedFiniteVariantProject "M" "hold" == some "2" + +private def anticipatedFinPO : CheckedPO EventB.Theory.empty anticipatedFiniteVariantProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty anticipatedFiniteVariantProject + anticipatedFinObligation).get (by native_decide) + +private def anticipatedVarPO : CheckedPO EventB.Theory.empty anticipatedFiniteVariantProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty anticipatedFiniteVariantProject + anticipatedVarObligation).get (by native_decide) + +private def anticipatedEventSource : CheckedEventSource EventB.Theory.empty + anticipatedFiniteVariantProject "M" "hold" := + (CheckedEventSource.fromProject EventB.Theory.empty anticipatedFiniteVariantProject + "M" "hold").get (by native_decide) + +private def anticipatedVariantSource : CheckedVariantSource anticipatedFiniteVariantProject "M" := + (CheckedVariantSource.fromProject anticipatedFiniteVariantProject "M").get (by native_decide) + +#guard anticipatedEventSource.declarations == [("S", .pow .int)] +#guard anticipatedEventSource.updates == [("S", .id "S")] +#guard anticipatedVariantSource.expression == .id "S" + +private def constantFiniteVariantProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [ .variant [("org.eventb.core.expression", "{0}")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "hold"), + ("org.eventb.core.convergence", "2")] [] ] }] + +private def constantFinObligation : Obligation := + { component := "M", name := "FIN", kind := "FIN" + goal := some (.app (.id "finite") (.set [.num 0])) } + +private def constantVarObligation : Obligation := + { component := "M", name := "hold/VAR", kind := "VAR" + goal := some (.bin "⊆" (.set [.num 0]) (.set [.num 0])) } + +#guard match generateCheckedIn EventB.Theory.empty constantFiniteVariantProject "M" with + | .ok obligations => obligations.any (fun obligation => + obligation.kind == "FIN" && obligation.goal == parsed? "finite({0})") + | .error _ => false +#guard match generateCheckedIn EventB.Theory.empty constantFiniteVariantProject "M" with + | .ok obligations => obligations.any (fun obligation => + obligation.kind == "VAR" && obligation.goal == parsed? "{0} ⊆ {0}") + | .error _ => false + +private def constantFinPO : CheckedPO EventB.Theory.empty constantFiniteVariantProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty constantFiniteVariantProject + constantFinObligation).get (by native_decide) + +private def constantVarPO : CheckedPO EventB.Theory.empty constantFiniteVariantProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty constantFiniteVariantProject + constantVarObligation).get (by native_decide) + +private def constantFinPOExact : CheckedPO EventB.Theory.empty constantFiniteVariantProject := + { obligation := constantFinObligation + checked := by + simpa only [show constantFinPO.obligation = constantFinObligation by native_decide] using + constantFinPO.checked } + +private def constantVarPOExact : CheckedPO EventB.Theory.empty constantFiniteVariantProject := + { obligation := constantVarObligation + checked := by + simpa only [show constantVarPO.obligation = constantVarObligation by native_decide] using + constantVarPO.checked } + +private def constantFiniteEventSource : CheckedEventSource EventB.Theory.empty + constantFiniteVariantProject "M" "hold" := + (CheckedEventSource.fromProject EventB.Theory.empty constantFiniteVariantProject + "M" "hold").get (by native_decide) + +private def constantFiniteVariantSource : CheckedVariantSource constantFiniteVariantProject "M" := + (CheckedVariantSource.fromProject constantFiniteVariantProject "M").get (by native_decide) + +#guard constantFiniteEventSource.declarations == [] +#guard constantFiniteEventSource.updates == [] +#guard constantFiniteVariantSource.expression == .set [.num 0] + +private def constantFiniteTransition : CheckedBeforeAfter := + { before := {}, after := {}, declarations := [] } + +private def constantFiniteEventSourceBound : CheckedEventSource EventB.Theory.empty + constantFiniteVariantProject constantFinPOExact.obligation.component "hold" := by + change CheckedEventSource EventB.Theory.empty constantFiniteVariantProject "M" "hold" + exact constantFiniteEventSource + +private def constantFiniteVariantSourceBound : CheckedVariantSource constantFiniteVariantProject + constantFinPOExact.obligation.component := by + change CheckedVariantSource constantFiniteVariantProject "M" + exact constantFiniteVariantSource + +private theorem constantFiniteAssignment : + constantFiniteEventSource.assignmentAction 128 constantFiniteTransition := by + change assignmentRelation 128 constantFiniteEventSource.declarations + constantFiniteTransition constantFiniteEventSource.updates + have declarations : constantFiniteEventSource.declarations = [] := by native_decide + have updates : constantFiniteEventSource.updates = [] := by native_decide + rw [declarations, updates] + unfold assignmentRelation + native_decide + +private abbrev constantFiniteSourceState := + { transition : CheckedBeforeAfter // + constantFiniteEventSourceBound.assignmentAction 128 transition } + +private def constantFiniteSourceStateValue : constantFiniteSourceState := + ⟨constantFiniteTransition, by + exact constantFiniteAssignment⟩ + +private theorem validationFuelOfOk (env : ValueEnv) + (h : ValueEnv.validationOk 128 [] env = true) : + ValueEnv.validateFuel 128 [] env = .ok PUnit.unit := by + unfold ValueEnv.validationOk at h + cases result : ValueEnv.validateFuel 128 [] env with + | error error => simp [result] at h + | ok value => cases value; simpa using result + +private def constantFiniteFormulaModel : TypedFormulaModel := + { declarations := [] + fuel := 128 + wellFormed := fun env => ValueEnv.validateFuel 128 [] env = .ok PUnit.unit + inhabited := ⟨{}, rfl⟩ + validated := by + intro env proof + unfold ValueEnv.validationOk + rw [proof] + complete := by intro env h; exact validationFuelOfOk env h + supports := fun _ => true } + +private abbrev constantFiniteFormulaState := + { env : ValueEnv // ValueEnv.validateFuel 128 [] env = .ok PUnit.unit } + +private theorem constantFiniteFormulaValid : + TypedFormulaModel.validUnchecked constantFiniteFormulaModel constantFinObligation := by + constructor + · native_decide + constructor + · rfl + · intro env _ + constructor + · constructor + · refine ⟨true, evalPredicateFiniteZero env⟩ + · intro hypothesis member + cases member + · intro _ + exact evalPredicateFiniteZero env + +private def constantFiniteTransitionModel : TypedTransitionModel := + { fuel := 128 + wellFormed := fun _ => True + inhabited := ⟨constantFiniteTransition, trivial⟩ + supports := fun _ => true } + +private abbrev constantFiniteSemanticState := + { env : ValueEnv // ValueEnv.validateFuel 128 [] env = .ok PUnit.unit } + +private def constantFiniteStateOf (state : constantFiniteSourceState) : + constantFiniteSemanticState := by + refine ⟨state.1.before, ?_⟩ + rcases state.property with ⟨declared, beforeValid, _, _⟩ + have sourceDeclarations : constantFiniteEventSourceBound.declarations = [] := by native_decide + have beforeValid' : ValueEnv.validationOk 128 [] state.1.before = true := by + simpa [sourceDeclarations, declared] using beforeValid + exact validationFuelOfOk _ beforeValid' + +private def constantFiniteVariant : FiniteSetVariant constantFiniteSemanticState Int := + { mode := .anticipated + measure := fun _ => [0] + action := fun _ _ => True + finite := fun _ => True + progress := by + intro _ _ _ value member + simpa using member } + +private def constantFiniteAdapter : FiniteSetVariantAdapter (γ := constantFiniteSourceState) + EventB.Theory.empty constantFiniteVariantProject constantFiniteVariant := + { finBinding := constantFinPOExact + varBinding := constantVarPOExact + finKind := by native_decide + varKind := by native_decide + componentMatch := by native_decide + eventLabel := "hold" + eventSource := constantFiniteEventSourceBound + variantSource := constantFiniteVariantSourceBound + finName := by native_decide + varName := by native_decide + convergence := "2" + convergenceExact := by native_decide + modeExact := by rfl + fuel := 128 + stateOf := constantFiniteStateOf + stateCoverage := by + intro state + let transition : CheckedBeforeAfter := + { before := state.1, after := state.1, declarations := [] } + have validation : ValueEnv.validationOk 128 [] state.1 = true := by + unfold ValueEnv.validationOk + rw [state.2] + have validationFuel := validationFuelOfOk _ validation + have assignment : constantFiniteEventSourceBound.assignmentAction 128 transition := by + change assignmentRelation 128 constantFiniteEventSourceBound.declarations transition + constantFiniteEventSourceBound.updates + have declarations : constantFiniteEventSourceBound.declarations = [] := by native_decide + have updates : constantFiniteEventSourceBound.updates = [] := by native_decide + rw [declarations, updates] + unfold assignmentRelation + refine ⟨rfl, validation, validation, ?_⟩ + dsimp [transition] + simp [ValueEnv.parallelAssignTypedFuel, CheckedBeforeAfter.make, + validationFuel, Bind.bind, Except.bind] + rfl + refine ⟨⟨transition, assignment⟩, ?_⟩ + apply Subtype.ext + rfl + finFormula := + { evaluator := constantFiniteFormulaModel + encode := fun state => state.1 + declarationScope := none + declarationsBound := by + have component : constantFinPOExact.obligation.component = "M" := by native_decide + rw [component] + change exactComponentDeclarations? EventB.Theory.empty + constantFiniteVariantProject "M" = some [] + native_decide + stateValid := by intro state; exact state.2 + stateComplete := by + intro env h + exact ⟨⟨env, h⟩, rfl⟩ + evaluatorValid := by + simpa only [show constantFinPOExact.obligation = constantFinObligation by rfl] using + constantFiniteFormulaValid + adequate := by + intro _ state + trivial } + varFormula := + { evaluator := constantFiniteTransitionModel + encode := fun state => state.1.1 + declarations := [] + declarationScope := some "hold" + declarationsBound := by + have component : constantVarPOExact.obligation.component = "M" := by native_decide + rw [component] + change exactEventDeclarations? EventB.Theory.empty + constantFiniteVariantProject "M" "hold" = some [] + native_decide + transitionDeclarations := by + intro state + rcases state.1.property with ⟨declared, _, _, _⟩ + have sourceDeclarations : constantFiniteEventSourceBound.declarations = [] := by + native_decide + simpa [sourceDeclarations] using declared + transitionValid := by intro _; trivial + sourceValid := by intro state; exact state.1.property + sourceComplete := by + intro transition source + exact ⟨(⟨transition, source⟩, constantFiniteSourceStateValue), rfl⟩ + evaluatorValid := by + simpa only [show constantVarPOExact.obligation = constantVarObligation by rfl] using + (typedTransitionModel_closed_validOnDomain constantFiniteTransitionModel + (constantFiniteEventSourceBound.assignmentAction 128) + (by + intro transition source + rcases source with ⟨declared, beforeValid, afterValid, _⟩ + exact ⟨by simpa [declared] using beforeValid, + by simpa [declared] using afterValid⟩) + constantVarObligation (by native_decide) (by native_decide) + (.bin "⊆" (.set [.num 0]) (.set [.num 0])) (by native_decide) + (by native_decide) (by rfl) (by rfl) + (by + intro transition source + rcases source with ⟨declared, beforeValid, afterValid, _⟩ + exact evalBeforeAfterZeroSetSubset transition + (by simpa [declared] using beforeValid) + (by simpa [declared] using afterValid))) + adequate := by + intro _ state + intro _ + change finiteSubset [0] [0] + intro value member + exact member } + decodeVariantValue := fun value => + match value with + | .integer value => some value + | _ => none + measureExact := by + intro state + have expression : constantFiniteVariantSourceBound.expression = .set [.num 0] := by + native_decide + rw [expression] + rw [evalValueFiniteZero] + rfl + fuelExact := by constructor <;> rfl + varActionExact := by + intro state + constructor + · intro _ + exact state.1.property + · intro _ + trivial } + +example : finiteVariantFiniteness constantFiniteVariant ∧ + finiteVariantProgressSemantic constantFiniteVariant := + constantFiniteAdapter.sound + +end EventB.POG diff --git a/test/FiniteVariantModelFixtures.lean b/test/FiniteVariantModelFixtures.lean new file mode 100644 index 0000000..c40f269 --- /dev/null +++ b/test/FiniteVariantModelFixtures.lean @@ -0,0 +1,451 @@ +/- Restricted-domain finite-set variant fixture. -/ + +import EventB.POG.RefinementAdapters + +namespace EventB.POG + +private def modelFiniteProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [ .variable [("org.eventb.core.identifier", "S")] [] + , .invariant [("org.eventb.core.label", "type"), + ("org.eventb.core.predicate", "S ∈ ℙ(ℤ)")] [] + , .invariant [("org.eventb.core.label", "finite"), + ("org.eventb.core.predicate", "finite(S)")] [] + , .variant [("org.eventb.core.expression", "S")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "hold"), + ("org.eventb.core.convergence", "2")] [] ] }] + +private def parsed? (source : String) : Option EventB.Formula.Term := + (EventB.Formula.parse source).toOption + +private def modelFinObligation : Obligation := + { component := "M", name := "FIN", kind := "FIN" + goal := parsed? "finite(S)" + hyps := [(parsed? "S ∈ ℙ(ℤ)").get (by native_decide), + (parsed? "finite(S)").get (by native_decide)] } + +private def modelVarObligation : Obligation := + { component := "M", name := "hold/VAR", kind := "VAR" + goal := parsed? "S ⊆ S" + hyps := [(parsed? "S ∈ ℙ(ℤ)").get (by native_decide), + (parsed? "finite(S)").get (by native_decide)] } + +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty modelFiniteProject + modelFinObligation).isSome +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty modelFiniteProject + modelVarObligation).isSome +#guard EventB.POG.eventRefinementTargets modelFiniteProject "M" "hold" == [] + +private def modelFinPO : CheckedPO EventB.Theory.empty modelFiniteProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty modelFiniteProject modelFinObligation).get + (by native_decide) + +private def modelVarPO : CheckedPO EventB.Theory.empty modelFiniteProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty modelFiniteProject modelVarObligation).get + (by native_decide) + +private def modelEventSource : CheckedEventSource EventB.Theory.empty + modelFiniteProject "M" "hold" := + (CheckedEventSource.fromProject EventB.Theory.empty modelFiniteProject "M" "hold").get + (by native_decide) + +private def modelVariantSource : CheckedVariantSource modelFiniteProject "M" := + (CheckedVariantSource.fromProject modelFiniteProject "M").get (by native_decide) + +private def modelEventSourceBound : CheckedEventSource EventB.Theory.empty + modelFiniteProject modelFinPO.obligation.component "hold" := by + have component : modelFinPO.obligation.component = "M" := by native_decide + rw [component] + exact modelEventSource + +private def modelVariantSourceBound : CheckedVariantSource modelFiniteProject + modelFinPO.obligation.component := by + have component : modelFinPO.obligation.component = "M" := by native_decide + rw [component] + exact modelVariantSource + +private def modelDeclarations : List (String × EventB.Typing.Ty) := + [("S", .pow .int)] + +private def modelTypeGoal : EventB.Formula.Term := + .bin "∈" (.id "S") (.pre "ℙ" (.id "ℤ")) + +private def modelFiniteGoal : EventB.Formula.Term := + .app (.id "finite") (.id "S") + +private def modelShape (env : ValueEnv) : Prop := + ∃ values, evalValueAtFuel 127 env (.id "S") = .ok (.set values) + +private def modelFinObligationExact : Obligation := + { component := "M", name := "FIN", kind := "FIN" + goal := some modelFiniteGoal + hyps := [modelTypeGoal, modelFiniteGoal] } + +private def modelDomain (env : ValueEnv) : Prop := + ValueEnv.validationOk 128 modelDeclarations env = true ∧ + evalPredicateAtFuel 128 env modelTypeGoal = .ok true ∧ + evalPredicateAtFuel 128 env modelFiniteGoal = .ok true ∧ + modelShape env + +private abbrev modelState := { env : ValueEnv // modelDomain env } + +private theorem modelValidationFuelOfOk (env : ValueEnv) + (h : ValueEnv.validationOk 128 modelDeclarations env = true) : + ValueEnv.validateFuel 128 modelDeclarations env = .ok PUnit.unit := by + unfold ValueEnv.validationOk at h + cases result : ValueEnv.validateFuel 128 modelDeclarations env with + | error error => simp [result] at h + | ok value => cases value; simpa using result + +private def modelFormulaModel : TypedFormulaModel := + { declarations := modelDeclarations + fuel := 128 + wellFormed := fun env => ValueEnv.validationOk 128 modelDeclarations env = true + inhabited := by + refine ⟨{ values := [("S", .set [.integer 0])] }, ?_⟩ + native_decide + validated := by + intro env proof + exact proof + complete := by + intro env proof + exact proof + supports := fun _ => true } + +private def modelEncode (state : modelState) : ValueEnv := state.1 + +private def modelSourceTransition (state : modelState) : CheckedBeforeAfter := + { before := state.1, after := state.1, declarations := modelDeclarations } + +private theorem modelSourceAssignment (state : modelState) : + modelEventSourceBound.assignmentAction 128 (modelSourceTransition state) := by + change assignmentRelation 128 modelEventSourceBound.declarations + (modelSourceTransition state) modelEventSourceBound.updates + have declarations : modelEventSourceBound.declarations = modelDeclarations := by + native_decide + have updates : modelEventSourceBound.updates = [] := by + native_decide + rw [declarations, updates] + unfold assignmentRelation + refine ⟨rfl, state.2.1, state.2.1, ?_⟩ + have validationFuel := modelValidationFuelOfOk state.1 state.2.1 + simp [modelSourceTransition, ValueEnv.parallelAssignTypedFuel, + CheckedBeforeAfter.make, validationFuel, Bind.bind, Except.bind] + rfl + +private theorem modelSourceAfterEq (transition : CheckedBeforeAfter) + (source : modelEventSourceBound.assignmentAction 128 transition) : + transition.after = transition.before := by + change assignmentRelation 128 modelEventSourceBound.declarations transition + modelEventSourceBound.updates at source + have declarations : modelEventSourceBound.declarations = modelDeclarations := by + native_decide + have updates : modelEventSourceBound.updates = [] := by + native_decide + rw [declarations, updates] at source + rcases source with ⟨_, _, _, assigned⟩ + cases validation : ValueEnv.validateFuel 128 modelDeclarations transition.before with + | error error => + simp [ValueEnv.parallelAssignTypedFuel, validation, Bind.bind, Except.bind] at assigned + | ok _unit => + simp [ValueEnv.parallelAssignTypedFuel, CheckedBeforeAfter.make, + validation, Bind.bind, Except.bind] at assigned + change (Except.ok + ({ before := transition.before, after := transition.before, + declarations := modelDeclarations } : CheckedBeforeAfter)) = + Except.ok transition at assigned + have canonical : + ({ before := transition.before, after := transition.before, + declarations := modelDeclarations } : CheckedBeforeAfter) = transition := by + injection assigned + exact (congrArg CheckedBeforeAfter.after canonical).symm + +private abbrev modelVarState := + { pair : modelState × modelState // pair.1.1 = pair.2.1 } + +private def modelVarEncode (state : modelVarState) : CheckedBeforeAfter := + { before := state.1.1.1, after := state.1.2.1, declarations := modelDeclarations } + +private def modelVarSource (transition : CheckedBeforeAfter) : Prop := + modelEventSourceBound.assignmentAction 128 transition ∧ + modelDomain transition.before ∧ modelDomain transition.after + +private theorem modelVarSourceValid (state : modelVarState) : + modelVarSource (modelVarEncode state) := by + refine ⟨?_, state.1.1.2, state.1.2.2⟩ + simpa [modelVarEncode, modelSourceTransition, state.2] using + modelSourceAssignment state.1.1 + +private theorem modelVarSourceComplete (transition : CheckedBeforeAfter) + (source : modelVarSource transition) : + ∃ state : modelVarState, modelVarEncode state = transition := by + rcases source with ⟨assignment, beforeDomain, afterDomain⟩ + have afterEq := modelSourceAfterEq transition assignment + refine ⟨⟨(⟨transition.before, beforeDomain⟩, ⟨transition.after, afterDomain⟩), + afterEq.symm⟩, ?_⟩ + rcases assignment with ⟨declared, _, _, _⟩ + have declarations : modelEventSourceBound.declarations = modelDeclarations := by + native_decide + have declaredExact : transition.declarations = modelDeclarations := + declared.trans declarations + cases transition + simp [modelVarEncode] + exact declaredExact.symm + +private theorem modelSubsetSelfEval (transition : CheckedBeforeAfter) + (beforeValid : ValueEnv.validationOk 128 transition.declarations transition.before = true) + (afterValid : ValueEnv.validationOk 128 transition.declarations transition.after = true) + (shape : modelShape transition.before) + (afterEq : transition.after = transition.before) : + evalBeforeAfter 128 transition + (.bin "⊆" (.id "S") (.id "S")) = .ok true := by + exact evalBeforeAfterIdentifierSubsetSelf transition beforeValid afterValid shape afterEq + +private def modelInitialState : modelState := + ⟨{ values := [("S", .set [.integer 0]) ] }, by + refine ⟨?_, ?_, ?_, ?_⟩ + · native_decide + · native_decide + · native_decide + · refine ⟨[.integer 0], ?_⟩ + exact evalValueIdentifierSingletonZero⟩ + +private def modelInitialVarState : modelVarState := + ⟨(modelInitialState, modelInitialState), rfl⟩ + +private def modelVarEvaluator : TypedTransitionModel := + { fuel := 128 + wellFormed := modelVarSource + inhabited := ⟨modelVarEncode modelInitialVarState, modelVarSourceValid modelInitialVarState⟩ + supports := fun _ => true } + +private theorem modelVarEvaluatorValid : + modelVarEvaluator.validOnDomain modelVarSource modelVarObligation := by + have obligationExact : modelVarObligation = + { component := "M", name := "hold/VAR", kind := "VAR" + goal := some (.bin "⊆" (.id "S") (.id "S")) + hyps := [modelTypeGoal, modelFiniteGoal] } := by native_decide + rw [obligationExact] + unfold TypedTransitionModel.validOnDomain + have shape : modelVarObligation.semanticShapeValid = true := by native_decide + have valuation : modelVarObligation.transitionValuationSupported = true := by native_decide + constructor + · constructor <;> native_decide + · constructor + · native_decide + · intro transition source + rcases source with ⟨assignment, beforeDomain, afterDomain⟩ + have afterEq := modelSourceAfterEq transition assignment + rcases assignment with ⟨declared, beforeValid, afterValid, _⟩ + have beforeValid' : + ValueEnv.validationOk 128 transition.declarations transition.before = true := by + simpa [declared] using beforeValid + have afterValid' : + ValueEnv.validationOk 128 transition.declarations transition.after = true := by + simpa [declared] using afterValid + constructor + · constructor + · exact ⟨true, modelSubsetSelfEval transition beforeValid' afterValid' + beforeDomain.2.2.2 afterEq⟩ + · intro hypothesis member + simp at member + rcases member with rfl | rfl + · exact ⟨true, by + exact evalBeforeAfterIdentifierType transition beforeValid' afterValid' + beforeDomain.2.1⟩ + · exact ⟨true, by + exact evalBeforeAfterIdentifierFinite transition beforeValid' afterValid' + beforeDomain.2.2.1⟩ + · intro hypotheses + exact modelSubsetSelfEval transition beforeValid' afterValid' + beforeDomain.2.2.2 afterEq + +private theorem modelFinEvaluatorValid : + modelFormulaModel.validOnDomain modelDomain modelFinObligation := by + have obligationExact : modelFinObligation = + modelFinObligationExact := by native_decide + rw [obligationExact] + unfold TypedFormulaModel.validOnDomain + constructor + · constructor <;> native_decide + · constructor + · native_decide + · intro env domain + have typeValid : evalPredicateAtFuel 128 env modelTypeGoal = .ok true := + domain.2.1 + have finiteValid : evalPredicateAtFuel 128 env modelFiniteGoal = .ok true := + domain.2.2.1 + change + ((∃ value, evalPredicateAtFuel 128 env modelFiniteGoal = .ok value) ∧ + (∀ hypothesis ∈ [modelTypeGoal, modelFiniteGoal], + ∃ value, evalPredicateAtFuel 128 env hypothesis = .ok value)) ∧ + ((∀ hypothesis ∈ [modelTypeGoal, modelFiniteGoal], + evalPredicateAtFuel 128 env hypothesis = .ok true) → + evalPredicateAtFuel 128 env modelFiniteGoal = .ok true) + constructor + · constructor + · exact ⟨true, finiteValid⟩ + · intro hypothesis member + simp at member + rcases member with rfl | rfl + · exact ⟨true, typeValid⟩ + · exact ⟨true, finiteValid⟩ + · intro _ + exact finiteValid + +private def modelFiniteVariant : FiniteSetVariant modelState Int := + { mode := .anticipated + measure := fun state => + match evalValueAtFuel 128 state.1 (.id "S") with + | .ok (.set values) => values.filterMap fun value => + match value with | .integer n => some n | _ => none + | _ => [] + action := fun before after => before = after + finite := fun _ => True + progress := by + intro before after action value member + simpa [action] using member } + +private theorem modelFinitenessExact : ∀ state : modelState, + modelFiniteVariant.finite state ↔ + modelFormulaModel.denote modelFiniteGoal (modelEncode state) := by + intro state + constructor + · intro _ + exact state.2.2.2.1 + · intro _ + trivial + +private def modelFinFormula : DomainFormulaAdequacy modelFinPO modelState + (finiteVariantFiniteness modelFiniteVariant) modelDomain := + { evaluator := modelFormulaModel + encode := modelEncode + declarationScope := none + declarationsBound := by + have component : modelFinPO.obligation.component = "M" := by native_decide + rw [component] + change exactComponentDeclarations? EventB.Theory.empty modelFiniteProject "M" = + some modelDeclarations + native_decide + stateValid := by intro state; exact state.2 + stateComplete := by + intro env domain + exact ⟨⟨env, domain⟩, rfl⟩ + evaluatorValid := by + simpa only [show modelFinPO.obligation = modelFinObligation by native_decide] using + modelFinEvaluatorValid + adequate := by + intro valid state + apply (modelFinitenessExact state).mpr + have obligationExact : modelFinPO.obligation = modelFinObligationExact := by native_decide + rw [obligationExact] at valid + simp [FormulaModel.validUnchecked, TypedFormulaModel.on, + modelFinObligationExact] at valid + apply valid state + intro hypothesis member + simp at member + rcases member with rfl | rfl + · exact state.2.2.1 + · exact state.2.2.2.1 } + +private def modelVarBefore (state : modelVarState) : modelState := state.1.1 + +private def modelVarAfter (state : modelVarState) : modelState := state.1.2 + +private def modelVarFormula : TransitionFormulaAdequacy modelVarPO modelVarState + (∀ state : modelVarState, + modelFiniteVariant.action (modelVarBefore state) (modelVarAfter state) → + finiteVariantProgress .anticipated + (modelFiniteVariant.measure (modelVarAfter state)) + (modelFiniteVariant.measure (modelVarBefore state))) + modelVarSource := + { evaluator := modelVarEvaluator + encode := modelVarEncode + declarations := modelDeclarations + declarationScope := some "hold" + declarationsBound := by + have component : modelVarPO.obligation.component = "M" := by native_decide + rw [component] + change exactEventDeclarations? EventB.Theory.empty modelFiniteProject "M" "hold" = + some modelDeclarations + native_decide + transitionDeclarations := by intro _; rfl + transitionValid := by intro state; exact modelVarSourceValid state + sourceValid := by intro state; exact modelVarSourceValid state + sourceComplete := modelVarSourceComplete + evaluatorValid := by + simpa only [show modelVarPO.obligation = modelVarObligation by native_decide] using + modelVarEvaluatorValid + adequate := by + intro _ state action + change state.1.1 = state.1.2 at action + change finiteSubset + (modelFiniteVariant.measure (modelVarAfter state)) + (modelFiniteVariant.measure (modelVarBefore state)) + intro value member + simpa [modelVarBefore, modelVarAfter, action] using member } + +private def modelRestrictedAdapter : + RestrictedFiniteSetVariantAdapter (η := modelVarState) (γ := modelState) + EventB.Theory.empty modelFiniteProject modelFiniteVariant := + { finBinding := modelFinPO + varBinding := modelVarPO + finKind := by native_decide + varKind := by native_decide + componentMatch := by native_decide + eventLabel := "hold" + eventSource := modelEventSourceBound + variantSource := modelVariantSourceBound + finName := by native_decide + varName := by native_decide + convergence := "2" + convergenceExact := by native_decide + modeExact := by rfl + fuel := 128 + stateOf := id + stateCoverage := by intro state; exact ⟨state, rfl⟩ + finGoalExact := by native_decide + semanticDomain := modelDomain + finFormula := modelFinFormula + finitenessExact := by + intro state + have expression : modelVariantSourceBound.expression = .id "S" := by + native_decide + simpa [expression, modelFinFormula, modelFiniteGoal, modelEncode, + TypedFormulaModel.denote] using modelFinitenessExact state + varState := modelVarState + varBefore := modelVarBefore + varAfter := modelVarAfter + varSource := modelVarSource + varSourceExact := by intro _; rfl + varFormula := modelVarFormula + varPairCoverage := by + intro before after action + change before = after at action + cases action + exact ⟨⟨(before, before), rfl⟩, rfl, rfl⟩ + varActionExact := by + intro state + constructor + · intro _ + exact modelVarSourceValid state + · intro source + rcases source with ⟨assignment, _, _⟩ + have afterEq := modelSourceAfterEq (modelVarEncode state) assignment + apply Subtype.ext + simpa [modelVarBefore, modelVarAfter, modelVarEncode] using afterEq.symm + fuelExact := by constructor <;> rfl } + +private theorem modelRestrictedSound : + finiteVariantFiniteness modelFiniteVariant ∧ + finiteVariantProgressSemantic modelFiniteVariant := + RestrictedFiniteSetVariantAdapter.sound modelRestrictedAdapter + +example : ¬ finiteVariantProgress .convergent ([0] : List Int) [0] := by + intro progress + rcases progress.2 with ⟨value, member, absent⟩ + simp_all + +end EventB.POG diff --git a/test/Gates.lean b/test/Gates.lean index 4972cf4..08e213b 100644 --- a/test/Gates.lean +++ b/test/Gates.lean @@ -781,8 +781,9 @@ private def writeStatus (results : List FileResult) (formulas : List FormulaResu "what is actually holding it\nup. This status includes only evidence accepted " ++ "through the local ledger; it is not kernel proof.\n\n" ++ "| status | count |\n| --- | --- |\n" ++ - s!"| kernel-checked | 0 |\n| smt-trusted | 0 |\n" ++ - s!"| rodin-imported | 0 |\n| external-trusted | {p4pass} |\n" ++ + s!"| kernel-checked | 0 |\n| kernel-checked-with-axioms | 0 |\n" ++ + s!"| smt-declared | 0 |\n| rodin-structurally-checked | 0 |\n" ++ + s!"| external-declared | {p4pass} |\n" ++ s!"| unproved | {p4.length - p4pass} |\n\n" ++ s!"Rodin discharged all {rodinAuto + rodinManual} of its obligations: " ++ s!"{rodinAuto} automatically, {rodinManual} by hand.\n" ++ diff --git a/test/GuardFixtures.lean b/test/GuardFixtures.lean new file mode 100644 index 0000000..0bc4d9a --- /dev/null +++ b/test/GuardFixtures.lean @@ -0,0 +1,31 @@ +/- Exact guard-source extraction checks. -/ + +import EventB.POG.RefinementAdapters + +namespace EventB.POG + +private def guardedProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.variable [("org.eventb.core.identifier", "x")] [] + , .invariant [("org.eventb.core.label", "type"), + ("org.eventb.core.predicate", "x ∈ ℤ")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [.guard [("org.eventb.core.label", "g"), + ("org.eventb.core.predicate", "x ∈ ℤ")] []]] }] + +private def malformedGuardProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [.event [("org.eventb.core.label", "step")] + [.guard [("org.eventb.core.label", "g")] []]] }] + +#guard eventGuardPredicates guardedProject "M" "step" == + some [.bin "∈" (.id "x") (.id "ℤ")] +#guard (CheckedGuardSource.fromProject Theory.empty guardedProject "M" "step").isSome +#guard eventGuardPredicates guardedProject "M" "missing" == none +#guard eventGuardPredicates malformedGuardProject "M" "step" == none +#guard (CheckedGuardSource.fromProject Theory.empty malformedGuardProject "M" "step").isNone + +end EventB.POG diff --git a/test/MrgAdapterFixtures.lean b/test/MrgAdapterFixtures.lean new file mode 100644 index 0000000..1a9c809 --- /dev/null +++ b/test/MrgAdapterFixtures.lean @@ -0,0 +1,399 @@ +/- Generated MRG acceptance fixture with source-bound branch pairing. -/ + +import EventB.POG.RefinementAdapters + +namespace EventB.POG + +private def mrgAdapterProject : EventB.Typing.Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [ .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "left")] + [ .guard [("org.eventb.core.label", "g0"), + ("org.eventb.core.predicate", "1 = 1")] [] ] + , .event [("org.eventb.core.label", "right")] + [ .guard [("org.eventb.core.label", "g1"), + ("org.eventb.core.predicate", "1 = 1")] [] ] ] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [ .refinesMachine [("org.eventb.core.target", "A")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "merge")] + [ .refinesEvent [("org.eventb.core.target", "left")] [] + , .refinesEvent [("org.eventb.core.target", "right")] [] ] ] }] + +private def mrgObligation : Obligation := + { component := "B" + name := "merge/MRG" + kind := "MRG" + goal := some (.bin "∨" + (.bin "=" (.num 1) (.num 1)) + (.bin "=" (.num 1) (.num 1))) } + +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty mrgAdapterProject + mrgObligation).isSome + +private def mrgPO : CheckedPO EventB.Theory.empty mrgAdapterProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty mrgAdapterProject mrgObligation).get + (by native_decide) + +private def mrgEventSourceBound : CheckedEventSource EventB.Theory.empty + mrgAdapterProject mrgPO.obligation.component "merge" := by + have component : mrgPO.obligation.component = "B" := by native_decide + rw [component] + exact (CheckedEventSource.fromProject EventB.Theory.empty mrgAdapterProject "B" "merge").get + (by native_decide) + +private def mrgMergeSourceBound : CheckedMergeSource EventB.Theory.empty + mrgAdapterProject mrgPO.obligation.component "merge" := by + have component : mrgPO.obligation.component = "B" := by native_decide + rw [component] + exact (CheckedMergeSource.fromProject EventB.Theory.empty mrgAdapterProject "B" "merge").get + (by native_decide) + +private def mrgGuardSourceBound : CheckedGuardSource EventB.Theory.empty + mrgAdapterProject mrgPO.obligation.component "merge" := by + have component : mrgPO.obligation.component = "B" := by native_decide + rw [component] + exact (CheckedGuardSource.fromProject EventB.Theory.empty mrgAdapterProject "B" "merge").get + (by native_decide) + +private def mrgLeft : Event Unit := + { grd := fun _ => True + act := fun _ _ => True } + +private def mrgRight : Event Unit := + { grd := fun _ => True + act := fun _ _ => True } + +private def mrgEventSource : CheckedEventSource EventB.Theory.empty + mrgAdapterProject "B" "merge" := + (CheckedEventSource.fromProject EventB.Theory.empty mrgAdapterProject "B" "merge").get + (by native_decide) + +private def mrgMergeSource : CheckedMergeSource EventB.Theory.empty + mrgAdapterProject "B" "merge" := + (CheckedMergeSource.fromProject EventB.Theory.empty mrgAdapterProject "B" "merge").get + (by native_decide) + +private def mrgGuardSource : CheckedGuardSource EventB.Theory.empty + mrgAdapterProject "B" "merge" := + (CheckedGuardSource.fromProject EventB.Theory.empty mrgAdapterProject "B" "merge").get + (by native_decide) + +private def mrgTransition : CheckedBeforeAfter := + { before := {}, after := {}, declarations := [] } + +private def mrgLeftEventSource : CheckedEventSource EventB.Theory.empty + mrgAdapterProject "A" "left" := + (CheckedEventSource.fromProject EventB.Theory.empty mrgAdapterProject "A" "left").get + (by native_decide) + +private def mrgRightEventSource : CheckedEventSource EventB.Theory.empty + mrgAdapterProject "A" "right" := + (CheckedEventSource.fromProject EventB.Theory.empty mrgAdapterProject "A" "right").get + (by native_decide) + +private def mrgLeftGuardSource : CheckedGuardSource EventB.Theory.empty + mrgAdapterProject "A" "left" := + (CheckedGuardSource.fromProject EventB.Theory.empty mrgAdapterProject "A" "left").get + (by native_decide) + +private def mrgRightGuardSource : CheckedGuardSource EventB.Theory.empty + mrgAdapterProject "A" "right" := + (CheckedGuardSource.fromProject EventB.Theory.empty mrgAdapterProject "A" "right").get + (by native_decide) + +private theorem mrgLeftAssignment : + mrgLeftEventSource.assignmentAction 128 mrgTransition := by + change assignmentRelation 128 mrgLeftEventSource.declarations + mrgTransition mrgLeftEventSource.updates + have declarations : mrgLeftEventSource.declarations = [] := by native_decide + have updates : mrgLeftEventSource.updates = [] := by native_decide + rw [declarations, updates] + constructor + · rfl + constructor + · native_decide + constructor + · native_decide + · rfl + +private theorem mrgRightAssignment : + mrgRightEventSource.assignmentAction 128 mrgTransition := by + change assignmentRelation 128 mrgRightEventSource.declarations + mrgTransition mrgRightEventSource.updates + have declarations : mrgRightEventSource.declarations = [] := by native_decide + have updates : mrgRightEventSource.updates = [] := by native_decide + rw [declarations, updates] + constructor + · rfl + constructor + · native_decide + constructor + · native_decide + · rfl + +private theorem mrgLeftGuardHolds : + mrgLeftGuardSource.holds 128 mrgTransition := by + have declarations : mrgLeftGuardSource.declarations = [] := by native_decide + have predicates : mrgLeftGuardSource.predicates = + [.bin "=" (.num 1) (.num 1)] := by native_decide + unfold CheckedGuardSource.holds + rw [declarations, predicates] + constructor + · rfl + constructor + · native_decide + constructor + · native_decide + · intro predicate member + simp only [List.mem_singleton] at member + subst predicate + unfold assignmentPredicateWithFuel + native_decide + +private theorem mrgRightGuardHolds : + mrgRightGuardSource.holds 128 mrgTransition := by + have declarations : mrgRightGuardSource.declarations = [] := by native_decide + have predicates : mrgRightGuardSource.predicates = + [.bin "=" (.num 1) (.num 1)] := by native_decide + unfold CheckedGuardSource.holds + rw [declarations, predicates] + constructor + · rfl + constructor + · native_decide + constructor + · native_decide + · intro predicate member + simp only [List.mem_singleton] at member + subst predicate + unfold assignmentPredicateWithFuel + native_decide + +private def mrgLeftBinding : CheckedMergeBranch EventB.Theory.empty + mrgAdapterProject Unit := + { locator := ("A", "left") + eventSource := mrgLeftEventSource + guardSource := mrgLeftGuardSource + event := mrgLeft + fuel := 128 + encode := fun _ => mrgTransition + actionExact := by + intro _ + constructor + · intro _ + exact mrgLeftAssignment + · intro _ + trivial + guardExact := by + intro _ + constructor + · intro _ + exact mrgLeftGuardHolds + · intro _ + trivial } + +private def mrgRightBinding : CheckedMergeBranch EventB.Theory.empty + mrgAdapterProject Unit := + { locator := ("A", "right") + eventSource := mrgRightEventSource + guardSource := mrgRightGuardSource + event := mrgRight + fuel := 128 + encode := fun _ => mrgTransition + actionExact := by + intro _ + constructor + · intro _ + exact mrgRightAssignment + · intro _ + trivial + guardExact := by + intro _ + constructor + · intro _ + exact mrgRightGuardHolds + · intro _ + trivial } + +private def mrgBranchBindings : List (CheckedMergeBranch EventB.Theory.empty + mrgAdapterProject Unit) := + [mrgLeftBinding, mrgRightBinding] + +private theorem mrgAssignment : + mrgEventSourceBound.assignmentAction 128 mrgTransition := by + change assignmentRelation 128 mrgEventSourceBound.declarations + mrgTransition mrgEventSourceBound.updates + have declarations : mrgEventSourceBound.declarations = [] := by native_decide + have updates : mrgEventSourceBound.updates = [] := by native_decide + rw [declarations, updates] + constructor + · rfl + constructor + · native_decide + constructor + · native_decide + · rfl + +private abbrev mrgSourceState := + { transition : CheckedBeforeAfter // + mrgEventSourceBound.assignmentAction 128 transition } + +private def mrgState : mrgSourceState := ⟨mrgTransition, mrgAssignment⟩ + +private def mrgModel : TypedTransitionModel := + { fuel := 128 + wellFormed := mrgEventSourceBound.assignmentAction 128 + inhabited := ⟨mrgTransition, mrgAssignment⟩ + supports := fun _ => true } + +private def mrgConcrete : Event mrgSourceState := + { grd := fun _ => True + act := fun _ _ => True } + +private def mrgAbstractMachine : Machine Unit := + { inv := fun _ => True + init := fun _ => True + events := [mrgLeft, mrgRight] } + +private def mrgConcreteMachine : Machine mrgSourceState := + { inv := fun _ => True + init := fun _ => True + events := [mrgConcrete] } + +private def mrgContract : SplitSimulation mrgConcreteMachine mrgAbstractMachine + (fun _ _ => True) := + { concreteEvent := mrgConcrete + concreteMember := by simp [mrgConcreteMachine] + abstractEvents := [mrgLeft, mrgRight] + abstractNonempty := by simp + abstractMember := by + intro abstract member + have branches : abstract = mrgLeft ∨ abstract = mrgRight := by + simpa using member + rcases branches with rfl | rfl <;> simp [mrgAbstractMachine] + guard := by + intro _ _ _ _ + exact ⟨mrgLeft, by simp, trivial⟩ + action := by + intro abstract _ _ _ member _ _ _ _ + have branches : abstract = mrgLeft ∨ abstract = mrgRight := by + simpa using member + rcases branches with rfl | rfl <;> exact ⟨(), trivial, trivial⟩ } + +private def mrgBranches : List (String × Event Unit) := + [("left", mrgLeft), ("right", mrgRight)] + +private theorem mrgSemantic : + splitSimulationSemantic mrgContract mrgBranches := by + intro _ _ _ _ _ _ + exact ⟨"left", mrgLeft, (), by simp [mrgBranches], trivial, trivial, trivial⟩ + +private def mrgAdapter : MergeAdapter EventB.Theory.empty mrgAdapterProject + (C := mrgConcreteMachine) (A := mrgAbstractMachine) (J := fun _ _ => True) := + { binding := mrgPO + eventLabel := "merge" + kind := by native_decide + sourceName := by native_decide + eventSource := mrgEventSourceBound + mergeSource := mrgMergeSourceBound + guardSource := mrgGuardSourceBound + contract := mrgContract + branchBindings := mrgBranchBindings + branchBindingLocatorsExact := by native_decide + branchBindingObjectsExact := by rfl + branchEvents := mrgBranches + branchLabelsExact := by native_decide + branchObjectsExact := by rfl + branchBindingEventsExact := by rfl + fuel := 128 + formula := + { evaluator := mrgModel + encode := fun state => state.1.1.1 + declarations := [] + declarationScope := some "merge" + declarationsBound := by + have component : mrgPO.obligation.component = "B" := by native_decide + rw [component] + change exactEventDeclarations? EventB.Theory.empty mrgAdapterProject + "B" "merge" = some [] + native_decide + transitionDeclarations := by + intro state + rcases state.1.1.2 with ⟨declared, _, _, _⟩ + have sourceDeclarations : mrgEventSourceBound.declarations = [] := by + native_decide + simpa [sourceDeclarations] using declared + transitionValid := by + intro state + exact state.1.1.2 + sourceValid := by + intro state + exact state.1.1.2 + sourceComplete := by + intro transition source + exact ⟨((⟨transition, source⟩, mrgState), ()), rfl⟩ + evaluatorValid := by + simpa only [show mrgPO.obligation = mrgObligation by native_decide] using + (typedTransitionModel_closed_validOnDomain mrgModel + (mrgEventSourceBound.assignmentAction 128) + (by + intro transition source + rcases source with ⟨declared, beforeValid, afterValid, _⟩ + exact ⟨by simpa [declared] using beforeValid, + by simpa [declared] using afterValid⟩) + mrgObligation (by native_decide) (by native_decide) + (.bin "∨" (.bin "=" (.num 1) (.num 1)) + (.bin "=" (.num 1) (.num 1))) (by native_decide) (by native_decide) + (by rfl) (by rfl) + (by + intro transition source + have beforeValid : + ValueEnv.validationOk 128 transition.declarations transition.before = true := by + rcases source with ⟨declared, beforeValid, _, _⟩ + simpa [declared] using beforeValid + have afterValid : + ValueEnv.validationOk 128 transition.declarations transition.after = true := by + rcases source with ⟨declared, _, afterValid, _⟩ + simpa [declared] using afterValid + exact evalBeforeAfterIntegerOneOrOne transition beforeValid afterValid)) + adequate := by + intro _ + exact mrgSemantic } + fuelExact := by rfl + actionExact := by + intro state + constructor + · intro _ + exact state.1.1.2 + · intro _ + trivial + guardExact := by + intro state + have declarations : mrgGuardSourceBound.declarations = [] := by native_decide + have predicates : mrgGuardSourceBound.predicates = [] := by native_decide + have source : mrgEventSourceBound.declarations = [] := by native_decide + rcases state.1.1.2 with ⟨declared, beforeValid, afterValid, assigned⟩ + constructor + · intro _ + unfold CheckedGuardSource.holds + rw [declarations, predicates] + constructor + · simpa [source] using declared + constructor + · simpa [source] using beforeValid + constructor + · simpa [source] using afterValid + · simp + · intro _ + trivial } + +example : ∀ c c' a, True → mrgAdapter.contract.concreteEvent.grd c → + mrgAdapter.contract.concreteEvent.act c c' → + ∃ label branch a', (label, branch) ∈ mrgAdapter.branchEvents ∧ + branch.grd a ∧ branch.act a a' ∧ True := + mrgAdapter.sound + +end EventB.POG diff --git a/test/MrgFixtures.lean b/test/MrgFixtures.lean new file mode 100644 index 0000000..a093e62 --- /dev/null +++ b/test/MrgFixtures.lean @@ -0,0 +1,54 @@ +/- Exact provenance checks for merged-event source binding. -/ + +import EventB.POG.RefinementAdapters + +namespace EventB.POG + +private def mergeFixtureProject : EventB.Typing.Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [ .variable [("org.eventb.core.identifier", "x")] [] + , .invariant [("org.eventb.core.label", "inv"), + ("org.eventb.core.predicate", "x ∈ ℤ")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "left")] + [ .guard [("org.eventb.core.label", "g0"), + ("org.eventb.core.predicate", "x = 0")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ x")] [] ] + , .event [("org.eventb.core.label", "right")] + [ .guard [("org.eventb.core.label", "g1"), + ("org.eventb.core.predicate", "x = 1")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ x")] [] ] ] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [ .refinesMachine [("org.eventb.core.target", "A")] [] + , .variable [("org.eventb.core.identifier", "x")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "merge")] + [ .refinesEvent [("org.eventb.core.target", "left")] [] + , .refinesEvent [("org.eventb.core.target", "right")] [] + , .guard [("org.eventb.core.label", "g"), + ("org.eventb.core.predicate", "x = 0 ∨ x = 1")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ x")] [] ] ] }] + +#guard EventB.POG.eventRefinementTargets mergeFixtureProject "B" "merge" == + ["left", "right"] +#guard EventB.POG.eventRefinementTargetLocators mergeFixtureProject "B" "merge" == + [("A", "left"), ("A", "right")] +#guard (CheckedMergeSource.fromProject EventB.Theory.empty mergeFixtureProject "B" "merge").isSome +#guard (CheckedMergeSource.fromProject EventB.Theory.empty mergeFixtureProject "B" "left").isNone +#guard (CheckedMergeSource.fromProject EventB.Theory.empty mergeFixtureProject "B" "missing").isNone + +private def rawMergeObligation : Obligation := + { component := "B" + name := "merge/MRG" + kind := "MRG" + goal := some (.id "source") } + +#guard rawMergeObligation.sourceBound mergeFixtureProject +#guard !( { rawMergeObligation with name := "left/MRG" }.sourceBound mergeFixtureProject ) + +end EventB.POG diff --git a/test/MrgSemanticFixtures.lean b/test/MrgSemanticFixtures.lean new file mode 100644 index 0000000..02e01d1 --- /dev/null +++ b/test/MrgSemanticFixtures.lean @@ -0,0 +1,124 @@ +/- Source-bound merged-event semantics: labels and selected branch events stay paired. -/ + +import EventB.POG.RefinementAdapters + +namespace EventB.POG + +private def mergeSemanticProject : EventB.Typing.Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [ .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "left")] [] + , .event [("org.eventb.core.label", "right")] [] ] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [ .refinesMachine [("org.eventb.core.target", "A")] [] + , .variable [("org.eventb.core.identifier", "x")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "merge")] + [ .refinesEvent [("org.eventb.core.target", "left")] [] + , .refinesEvent [("org.eventb.core.target", "right")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ 0")] [] ] ] }] + +private def mergeSource : CheckedMergeSource Theory.empty + mergeSemanticProject "B" "merge" := + (CheckedMergeSource.fromProject Theory.empty mergeSemanticProject "B" "merge").get + (by native_decide) + +private def concreteEvent : Event Unit := + { grd := fun _ => True + act := fun _ _ => True } + +private def leftBranch : Event Bool := + { grd := fun state => state = false + act := fun _ _ => True } + +private def rightBranch : Event Bool := + { grd := fun state => state = true + act := fun _ _ => True } + +private def abstractMachine : Machine Bool := + { inv := fun _ => True + init := fun _ => True + events := [leftBranch, rightBranch] } + +private def concreteMachine : Machine Unit := + { inv := fun _ => True + init := fun _ => True + events := [concreteEvent] } + +private def splitContract : SplitSimulation concreteMachine abstractMachine + (fun _ _ => True) := + { concreteEvent := concreteEvent + concreteMember := by simp [concreteMachine] + abstractEvents := [leftBranch, rightBranch] + abstractNonempty := by simp + abstractMember := by + intro abstract member + have branches : abstract = leftBranch ∨ abstract = rightBranch := by + simpa using member + rcases branches with rfl | rfl <;> simp [abstractMachine] + guard := by + intro _ abstract _ _ + cases abstract with + | false => exact ⟨leftBranch, by simp, by simp [leftBranch]⟩ + | true => exact ⟨rightBranch, by simp, by simp [rightBranch]⟩ + action := by + intro abstract _ _ _ member _ _ _ _ + have branches : abstract = leftBranch ∨ abstract = rightBranch := by + simpa using member + rcases branches with rfl | rfl <;> + exact ⟨false, by simp [leftBranch, rightBranch], trivial⟩ } + +private def sourceBranches : List (String × Event Bool) := + [("left", leftBranch), ("right", rightBranch)] + +#guard mergeSource.targets == ["left", "right"] +#guard sourceBranches.map (·.1) == mergeSource.targets +#guard !([("wrong", leftBranch), ("right", rightBranch)].map (·.1) == mergeSource.targets) + +example : [leftBranch, rightBranch] = sourceBranches.map (·.2) := by rfl + +example : splitSimulationSemantic splitContract sourceBranches := by + intro _ _ abstract _ _ _ + cases abstract with + | false => + exact ⟨"left", leftBranch, false, by simp [sourceBranches], + by simp [leftBranch], by simp [leftBranch], trivial⟩ + | true => + exact ⟨"right", rightBranch, true, by simp [sourceBranches], + by simp [rightBranch], by simp [rightBranch], trivial⟩ + +private def foreignBranch : Event Bool := + { grd := fun _ => True + act := fun _ _ => False } + +example : ¬ splitSimulationSemantic splitContract + [("foreign", foreignBranch)] := by + intro semantic + obtain ⟨label, branch, after, member, _, action, _⟩ := + semantic () () false trivial trivial trivial + have pair : (label, branch) = ("foreign", foreignBranch) := by + simpa using member + cases pair + simpa [foreignBranch] using action + +/- A matching label is not enough: replacing the selected branch object must also + invalidate the semantic contract. This is the negative control for the adapter's + still-explicit abstract-event provenance boundary. -/ +example : ¬ splitSimulationSemantic splitContract + [("left", foreignBranch), ("right", rightBranch)] := by + intro semantic + obtain ⟨label, branch, after, member, guard, action, _⟩ := + semantic () () false trivial trivial trivial + have cases : (label, branch) = ("left", foreignBranch) ∨ + (label, branch) = ("right", rightBranch) := by + simpa using member + rcases cases with left | right + · cases left + simpa [foreignBranch] using action + · cases right + simpa [rightBranch] using guard + +end EventB.POG diff --git a/test/VariantFixtures.lean b/test/VariantFixtures.lean new file mode 100644 index 0000000..e6f605e --- /dev/null +++ b/test/VariantFixtures.lean @@ -0,0 +1,219 @@ +/- + Bounded, model-derived NAT/VAR fixture. + + This file is intentionally disjoint from the production POG and adapter modules. + It checks the exact generated terms, the exact source variant, the convergence + mode, and forged-goal rejection. The small finite model below supplies a + kernel-checked semantic sanity check for the same decrementing event. +-/ + +import EventB.POG + +namespace EventB.VariantFixtures + +open EventB EventB.Formula EventB.POG EventB.Typing + +private def childrenOf (element : Elem) (tag : String) : List Elem := + element.children.filter (fun child => child.tag == "org.eventb.core." ++ tag) + +private def attrOf (element : Elem) (key : String) : Option String := + element.attr? ("org.eventb.core." ++ key) + +private def componentElements (project : Project) (component : String) : + Option Elem := + (lookupComponent project component).map (·.elem) + +private def variantExpressions (project : Project) (component : String) : + List (Option Term) := + (componentElements project component).toList.flatMap fun element => + (childrenOf element "variant").map fun variant => + (attrOf variant "expression").bind (Formula.parse · |>.toOption) + +/- A fixture-local uniqueness check: the checked production source is accepted only + when this project has exactly one variant, so a second variant cannot silently be + ignored by a first-match lookup. -/ +private def uniqueVariantExpression? (project : Project) (component : String) : + Option Term := + match (variantExpressions project component).filterMap id with + | [expression] => some expression + | _ => none + +private def eventConvergence? (project : Project) (component event : String) : + Option String := + (componentElements project component).bind fun element => + (childrenOf element "event").find? (fun candidate => + attrOf candidate "label" == some event) |>.bind (attrOf · "convergence") + +private def parsed? (source : String) : Option Term := + (Formula.parse source).toOption + +def boundedNatVariantProject : Project := + [{ name := "M" + elem := .machineFile [ ("org.eventb.core.name", "M") ] + [ .variable [ ("org.eventb.core.identifier", "x") ] [] + , .invariant [ ("org.eventb.core.label", "type") + , ("org.eventb.core.predicate", "x ∈ ℤ") ] [] + , .variant [ ("org.eventb.core.expression", "x") ] [] + , .event [ ("org.eventb.core.label", "INITIALISATION") ] + [ .action [ ("org.eventb.core.label", "set") + , ("org.eventb.core.assignment", "x ≔ 2") ] [] ] + , .event [ ("org.eventb.core.label", "step") + , ("org.eventb.core.convergence", "1") ] + [ .guard [ ("org.eventb.core.label", "positive") + , ("org.eventb.core.predicate", "x > 0") ] [] + , .action [ ("org.eventb.core.label", "decrement") + , ("org.eventb.core.assignment", "x ≔ x − 1") ] [] ] + , .event [ ("org.eventb.core.label", "hold") + , ("org.eventb.core.convergence", "2") ] + [ .action [ ("org.eventb.core.label", "unchanged") + , ("org.eventb.core.assignment", "x ≔ x") ] [] ] ] }] + +private def variantGoal? (project : Project) (event kind : String) + (goal : Option Term) : Bool := + match generateCheckedIn Theory.empty project "M" with + | .error _ => false + | .ok obligations => + obligations.any fun obligation => + obligation.component == "M" && obligation.name == event ++ "/" ++ kind && + obligation.kind == kind && obligation.goal == goal && + generatedSourceBound project obligation + +private def exactVariantGoal? (project : Project) (event kind mode : String) + (goal : Option Term) : Bool := + uniqueVariantExpression? project "M" == some (.id "x") && + eventConvergence? project "M" event == some mode && + variantGoal? project event kind goal + +private def exactVariantSource? : Option Term := + uniqueVariantExpression? boundedNatVariantProject "M" + +private def assignmentUpdates? (project : Project) (component event : String) : + Option (List (String × Term)) := + (componentElements project component).bind fun element => + (childrenOf element "event").find? (fun candidate => + attrOf candidate "label" == some event) |>.bind fun currentEvent => + (childrenOf currentEvent "action").mapM fun action => do + let source ← attrOf action "assignment" + let term ← (Formula.parse source).toOption + match term with + | .bin "≔" (.id name) rhs => some (name, rhs) + | _ => none + +private def exactStepSource? : Option (List (String × Term)) := + assignmentUpdates? boundedNatVariantProject "M" "step" + +/- Exact provenance and exact generated goals. The parser comparison is AST equality, + not a printed-name or obligation-count check. -/ +#guard exactVariantSource? == some (.id "x") +#guard eventConvergence? boundedNatVariantProject "M" "step" == some "1" +#guard eventConvergence? boundedNatVariantProject "M" "hold" == some "2" +#guard exactStepSource? == some [("x", .bin "−" (.id "x") (.num 1))] + +#guard exactVariantGoal? boundedNatVariantProject "step" "NAT" "1" + (parsed? "x ∈ ℕ") +#guard exactVariantGoal? boundedNatVariantProject "step" "VAR" "1" + (parsed? "x − 1 < x") +#guard exactVariantGoal? boundedNatVariantProject "hold" "NAT" "2" + (parsed? "x ∈ ℕ") +#guard exactVariantGoal? boundedNatVariantProject "hold" "VAR" "2" + (parsed? "x ≤ x") + +/- Forged formula, wrong event, and wrong convergence controls. -/ +#guard !exactVariantGoal? boundedNatVariantProject "step" "VAR" "1" + (parsed? "x ≤ x") +#guard !exactVariantGoal? boundedNatVariantProject "step" "VAR" "2" + (parsed? "x − 1 < x") +#guard !exactVariantGoal? boundedNatVariantProject "hold" "VAR" "1" + (parsed? "x ≤ x") +#guard !variantGoal? boundedNatVariantProject "missing" "VAR" (parsed? "x < x") + +private def alteredVariantProject : Project := + [{ name := "M" + elem := .machineFile [ ("org.eventb.core.name", "M") ] + [ .variable [ ("org.eventb.core.identifier", "x") ] [] + , .invariant [ ("org.eventb.core.label", "type") + , ("org.eventb.core.predicate", "x ∈ ℤ") ] [] + , .variant [ ("org.eventb.core.expression", "x + 1") ] [] + , .event [ ("org.eventb.core.label", "INITIALISATION") ] [] + , .event [ ("org.eventb.core.label", "step") + , ("org.eventb.core.convergence", "1") ] + [ .action [ ("org.eventb.core.label", "decrement") + , ("org.eventb.core.assignment", "x ≔ x − 1") ] [] ] ] }] + +private def duplicateVariantProject : Project := + [{ name := "M" + elem := .machineFile [ ("org.eventb.core.name", "M") ] + [ .variable [ ("org.eventb.core.identifier", "x") ] [] + , .variant [ ("org.eventb.core.expression", "x") ] [] + , .variant [ ("org.eventb.core.expression", "x + 1") ] [] ] }] + +#guard !variantGoal? alteredVariantProject "step" "NAT" (parsed? "x ∈ ℕ") +#guard variantGoal? alteredVariantProject "step" "NAT" (parsed? "x + 1 ∈ ℕ") +#guard !exactVariantGoal? alteredVariantProject "step" "NAT" "1" + (parsed? "x + 1 ∈ ℕ") +#guard uniqueVariantExpression? duplicateVariantProject "M" |>.isNone + +/- A finite semantic model for the exact decrementing source action. -/ +inductive BoundedState where + | zero + | one + | two + deriving DecidableEq, Repr + +def measure : BoundedState → Nat + | .zero => 0 + | .one => 1 + | .two => 2 + +def sourceValue : BoundedState → Int + | .zero => 0 + | .one => 1 + | .two => 2 + +def decrement : BoundedState → BoundedState → Prop + | .one, .zero => True + | .two, .one => True + | _, _ => False + +def boundedStates : List BoundedState := [.zero, .one, .two] + +def boundedTransitions : List (BoundedState × BoundedState) := + [(.one, .zero), (.two, .one)] + +theorem bounded_nat : ∀ state, 0 ≤ measure state := by + intro state + cases state <;> decide + +theorem bounded_var : ∀ before after, + decrement before after → measure after < measure before := by + intro before after step + cases before <;> cases after <;> simp [decrement, measure] at step ⊢ + +theorem bounded_source_action : ∀ before after, + decrement before after → sourceValue after = sourceValue before - 1 := by + intro before after step + cases before <;> cases after <;> simp [decrement, sourceValue] at step ⊢ + +theorem no_unit_source_cover : + ¬ ∃ encode : Unit → BoundedState × BoundedState, + ∀ transition ∈ boundedTransitions, + ∃ state, encode state = transition := by + rintro ⟨encode, complete⟩ + obtain ⟨zeroState, zeroEncoded⟩ := complete (.one, .zero) (by simp [boundedTransitions]) + obtain ⟨oneState, oneEncoded⟩ := complete (.two, .one) (by simp [boundedTransitions]) + have sameState : zeroState = oneState := Subsingleton.elim _ _ + have equalTransitions : (BoundedState.one, BoundedState.zero) = + (BoundedState.two, BoundedState.one) := by + calc + (BoundedState.one, BoundedState.zero) = encode zeroState := zeroEncoded.symm + _ = encode oneState := congrArg encode sameState + _ = (BoundedState.two, BoundedState.one) := oneEncoded + cases equalTransitions + +#guard boundedStates.all (fun state => 0 ≤ measure state) +#guard boundedTransitions.all (fun transition => + measure transition.2 < measure transition.1) +#guard boundedTransitions.all (fun transition => + sourceValue transition.2 == sourceValue transition.1 - 1) + +end EventB.VariantFixtures diff --git a/test/VwdFixtures.lean b/test/VwdFixtures.lean new file mode 100644 index 0000000..9141eb8 --- /dev/null +++ b/test/VwdFixtures.lean @@ -0,0 +1,90 @@ +/- + Exact-source VWD fixture kept separate from the large integer-variant fixture. + The split keeps Lake's C backend reproducible while retaining kernel-checked + source binding and semantic adequacy coverage. +-/ + +import EventB.POG.RefinementAdapters + +namespace EventB.POG + +private def vwdFixtureProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [ .variant [("org.eventb.core.expression", "0 ÷ 1")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] ] }] + +private def positiveVwdObligation : Obligation := + { component := "M", name := "VWD", kind := "VWD" + goal := some (.bin "≠" (.num 1) (.num 0)) } + +private def positiveVwdPO : CheckedPO EventB.Theory.empty vwdFixtureProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty vwdFixtureProject + positiveVwdObligation).get (by native_decide) + +private def positiveVwdPOExact : CheckedPO EventB.Theory.empty vwdFixtureProject := + { obligation := positiveVwdObligation + checked := by + simpa only [show positiveVwdPO.obligation = positiveVwdObligation by native_decide] using + positiveVwdPO.checked } + +private def positiveVwdSource : CheckedVariantSource vwdFixtureProject "M" := + (CheckedVariantSource.fromProject vwdFixtureProject "M").get (by native_decide) + +private def vwdFormulaModel : TypedFormulaModel := + { declarations := [] + fuel := 128 + wellFormed := fun env => ValueEnv.validationOk 128 [] env = true + inhabited := ⟨{}, by native_decide⟩ + validated := fun _ proof => proof + complete := fun _ proof => proof + supports := fun _ => true } + +private abbrev vwdState := + { env : ValueEnv // ValueEnv.validationOk 128 [] env = true } + +private theorem vwdFormulaModel_valid : + TypedFormulaModel.validUnchecked vwdFormulaModel positiveVwdObligation := by + constructor + · native_decide + constructor + · rfl + · intro env _ + constructor + · constructor + · refine ⟨true, evalPredicateIntegerOneNeZero env⟩ + · intro hypothesis member + cases member + · intro _ + exact evalPredicateIntegerOneNeZero env + +private def positiveVwdAdapter : VwdAdapter EventB.Theory.empty + vwdFixtureProject vwdState := + { binding := positiveVwdPOExact + kind := by native_decide + sourceName := by native_decide + variantSource := positiveVwdSource + pre := fun _ => True + defined := fun _ => True + formula := + { evaluator := vwdFormulaModel + encode := fun state => state.1 + declarationScope := none + declarationsBound := by + change exactComponentDeclarations? EventB.Theory.empty vwdFixtureProject "M" = + some [] + native_decide + stateValid := by intro state; exact state.2 + stateComplete := by + intro env proof + exact ⟨⟨env, proof⟩, rfl⟩ + evaluatorValid := by + simpa only [show positiveVwdPOExact.obligation = positiveVwdObligation by rfl] using + vwdFormulaModel_valid + adequate := by intro _ _ _; trivial } + nonempty := ⟨⟨{}, by native_decide⟩, trivial⟩ } + +example : witnessDefinednessSemantic positiveVwdAdapter.pre positiveVwdAdapter.defined := + positiveVwdAdapter.sound + +end EventB.POG diff --git a/test/rossi-fixtures/README.md b/test/rossi-fixtures/README.md index cff24ca..acb619a 100644 --- a/test/rossi-fixtures/README.md +++ b/test/rossi-fixtures/README.md @@ -8,7 +8,7 @@ expectation file; it checks both output and exit status. | `actions.eventb` | Wrapped and adjacent action parsing | Expected typechecking failure: the model has no typing context. | | `boundaries.eventb` | Multiline formulas and action boundaries | Expected typechecking failure: `v + y` is invalid for values in `S`. | | `identifiers.eventb` | Component names and reserved-word boundaries | Passes with zero generated obligations. | -| `witnesses.eventb` | End-to-end refinement, witness, WFIS, and WWD behavior | Passes with seven obligations. | +| `witnesses.eventb` | End-to-end refinement, witness, WFIS, and WWD behavior | Passes with thirteen obligations. | All four fixtures must pass `rossi-dump` with their expected component names. The two parser-boundary fixtures are not valid semantic projects; their nonzero checker diff --git a/tools/cli-fixtures.py b/tools/cli-fixtures.py index 83c6af6..8a19762 100644 --- a/tools/cli-fixtures.py +++ b/tools/cli-fixtures.py @@ -102,9 +102,10 @@ def check_witness() -> None: raise AssertionError("witness report: expected thirteen obligations") if report["trust_ledger"] != { "kernel-checked": 0, - "smt-trusted": 0, - "rodin-imported": 0, - "external-trusted": 5, + "kernel-checked-with-axioms": 0, + "smt-declared": 0, + "rodin-structurally-checked": 0, + "external-declared": 5, "unproved": 8, }: raise AssertionError("witness report: trust ledger changed") @@ -112,10 +113,12 @@ def check_witness() -> None: if not record["fingerprint"].startswith("eventb-v1-"): raise AssertionError("witness report: missing obligation fingerprint") evidence = record["evidence"] - if record["proof_mode"] == "external-trusted": - required = {"mode", "tool", "version", "input_digest", "verifier"} - if not required <= evidence.keys() or evidence["mode"] != "external-trusted": + if record["proof_mode"] == "external-declared": + required = {"mode", "tool", "version", "input_digest", "metadata_only", "verifier"} + if not required <= evidence.keys() or evidence["mode"] != "external-declared": raise AssertionError("witness report: incomplete external provenance") + if evidence["metadata_only"] is not True: + raise AssertionError("witness report: external metadata was presented as verified") if record["rule"] == "none": raise AssertionError("witness report: discharged record has no rule") elif record["proof_mode"] == "unproved": From 1953efd4027a0a7ba26d69e364d7dbd7b1500fcb Mon Sep 17 00:00:00 2001 From: Jonathan Cubides Date: Sat, 15 Aug 2026 11:59:08 -0500 Subject: [PATCH 8/8] chore(release): close v4.0.10 gate --- TODO.md | 13 +++++++------ notes/production-acceptance.md | 4 ++-- 2 files changed, 9 insertions(+), 8 deletions(-) diff --git a/TODO.md b/TODO.md index 602565a..cdd1f57 100644 --- a/TODO.md +++ b/TODO.md @@ -79,8 +79,8 @@ evidence. formula families remain fail-closed rather than being assigned guessed semantics. 6. Trust/provenance hardening — implemented for local and parsed Rodin paths; digest strength and external verifier execution remain explicit trust boundaries. -7. Independent differential tests, release evidence, and adversarial review — active - until the final clean-checkout campaign passes. +7. Independent differential tests, release evidence, and adversarial review — complete + for the supported path after the final clean-checkout campaign passed. Each slice requires a minimal positive model, a negative model, a Rodin-shaped comparison, a full build, and a fresh adversarial review before its checkbox is marked. @@ -415,10 +415,11 @@ and the issue is closed with that same commit SHA in the closing comment. DSL, native theories, and the supported `.tuf` subset. - [x] #6 Define the production P3b and P4 release thresholds explicitly; do not use a larger percentage as a substitute for exact diagnostics or trustworthy evidence. -- [ ] #7 Update README badges, `STATUS.md`, `notes/architecture.md`, and release notes - from the final measured commit before tagging. -- [ ] #8 Tag the release only after every V4 checklist item is checked and the complete - verification command succeeds from a clean checkout. +- [x] #7 Update README badges, `STATUS.md`, `notes/architecture.md`, and release notes + from the final measured commit before tagging; the release snapshot is `dc5dfc7`. +- [x] #8 Tag the release only after every V4 checklist item is checked and the complete + verification command succeeds from a clean checkout; the clean snapshot passed before + release tagging. Production thresholds: diff --git a/notes/production-acceptance.md b/notes/production-acceptance.md index 6c94da7..70a6684 100644 --- a/notes/production-acceptance.md +++ b/notes/production-acceptance.md @@ -10,8 +10,8 @@ The current acceptance run uses Lean `v4.33.0`, ProofWidgets `v0.0.108`, and `corpus/MANIFEST.tsv` SHA256 `c76a5dca92f0ea32f8c1e20e9da4cb88006bd048cee78d9fd66d03a20e664c45`. The corpus itself remains pinned to the upstream commits recorded in the manifest. -The release candidate is accepted only after the clean-checkout command matrix below -passes; the current worktree is intentionally still under adversarial review. +The v4.0.10 release candidate was accepted after the clean-checkout command matrix below +passed against the final committed snapshot; the supported-path ceilings remain explicit. | Gate | Result | Interpretation | | --- | ---: | --- |