diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index cc5a1c3..349b595 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -54,7 +54,30 @@ jobs: "https://github.com/jonaprieto/" - uses: leanprover/lean-action@v1 with: - build-args: "EventB EventBWidgets Examples gates rossi-dump eventb bench" + build-args: "EventB EventBWidgets Examples VariantFixtures gates rossi-dump eventb bench" + - name: Kernel-checked refinement adapters + run: | + lake env lean EventB/POGSoundness.lean + 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/FiniteVariantModelFixtures.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 EventB/POG/EQLAdapter.lean + - name: Adapter axiom audit + run: | + audit=$(lake env lean test/AdapterAxiomAudit.lean 2>&1) + echo "$audit" + if echo "$audit" | grep -Eq 'sorryAx|native_decide'; then + echo "::error::acceptance theorem depends on a forbidden proof shortcut" + exit 1 + fi - name: CLI and fixture matrix run: python3 tools/cli-fixtures.py - name: Install pinned Rossi @@ -92,9 +115,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/*.tsv + git diff --exit-code -- STATUS.md baseline 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/CHANGELOG.md b/CHANGELOG.md index ee2804a..f57c48f 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,23 @@ # Changelog +## 4.0.10 — 2026-08-15 + +- Re-derive strict POG obligations from the complete Rodin model-artifact closure, + including theory environments, before accepting imported status evidence. +- Label declared external/SMT metadata, structurally checked Rodin imports, and + axiom-bearing kernel replay separately from unproved obligations. +- Add compositional invariant and refinement contracts for event-local simulation and + pre-state parallel assignment semantics. +- Add explicit frame, gluing, merged-event, witness, variant, and translated-sequent + semantic contracts with positive and negative kernel-checked fixtures. +- Extend the bounded typed evaluator with finite relation application, image, + domain/range restriction/subtraction, and override, with malformed and + duplicate-function cases failing closed. +- Add source-bound parameterized enabled-event semantics, finite witness-domain + completeness, and well-founded variant contracts with focused positive and negative + fixtures; retain explicit fail-closed boundaries for unbounded binders and arbitrary + formula interpretation. + ## 4.0.9 — 2026-08-13 - Pin every first-party dependency to its newest released tag. diff --git a/EventB.lean b/EventB.lean index 6a7f80c..be76d83 100644 --- a/EventB.lean +++ b/EventB.lean @@ -12,7 +12,12 @@ import EventB.Embedding import EventB.Formula.Translate import EventB.Typing.Infer import EventB.Typing.Check +import EventB.Project import EventB.POG +import EventB.POGSoundness +import EventB.POGBridge +import EventB.POG.EQLAdapter +import EventB.POG.RefinementAdapters import EventB.Trust import EventB.Trust.Replay import EventB.Trust.Rodin diff --git a/EventB/DSL.lean b/EventB/DSL.lean index ae03942..9cc0dc3 100644 --- a/EventB/DSL.lean +++ b/EventB/DSL.lean @@ -195,6 +195,19 @@ private def addDefinitionInfo (id : Syntax) (symbol : String) (location : Declar mkDocString? := some fun _ => pure s!"Event-B symbol `{symbol}`" } +private def nativeSymbolLocation? (id : Ident) : CommandElabM (Option DeclarationLocation) := do + let module ← currentModule + match ← Lean.findDeclarationRanges? id.getId with + | some ranges => pure <| some { module, range := ranges.selectionRange } + | none => pure none + +private def addReferenceInfo (owners : List String) (id : Ident) : CommandElabM Unit := do + let location ← match ← nativeSymbolLocation? id with + | some location => pure <| some location + | none => symbolLocation? owners id.getId.toString + if let some location := location then + addDefinitionInfo id.raw id.getId.toString location + private def addFormulaInfos (owners : List String) (stx : Syntax) : CommandElabM Unit := do for id in formulaIdentifiers stx do if let some location ← symbolLocation? owners id.getId.toString then @@ -239,6 +252,7 @@ private def eventParts (theoryRoots owners : List String) (parts : Array (TSynta for p in parts do match p with | `(ebEventPart| refines $r:ident) => + addReferenceInfo owners r out := out.push (mkElem "refinesEvent" (targetAttrs r.getId.toString) noKids) | `(ebEventPart| extends $r:ident) => out := out.push @@ -662,13 +676,16 @@ private def elabMachine : CommandElab := fun stx => do for p in ps do match p with | `(ebMachinePart| refines $r:ident) => + addReferenceInfo owners r kids := kids.push (mkElem "refinesMachine" (targetAttrs r.getId.toString) noKids) | `(ebMachinePart| sees $ss:ident*) => for sc in ss do + addReferenceInfo owners sc kids := kids.push (mkElem "seesContext" (targetAttrs sc.getId.toString) noKids) - | `(ebMachinePart| uses $_:ident*) => pure () + | `(ebMachinePart| uses $ts:ident*) => + for theory in ts do addReferenceInfo owners theory | `(ebMachinePart| variables $xs:ident*) => for x in xs do kids := kids.push @@ -718,9 +735,11 @@ private def elabContext : CommandElab := fun stx => do match p with | `(ebContextPart| extends $es:ident*) => for e in es do + addReferenceInfo owners e kids := kids.push (mkElem "extendsContext" (targetAttrs e.getId.toString) noKids) - | `(ebContextPart| uses $_:ident*) => pure () + | `(ebContextPart| uses $ts:ident*) => + for theory in ts do addReferenceInfo owners theory | `(ebContextPart| sets $xs:ident*) => for x in xs do kids := kids.push @@ -740,10 +759,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..c7ac0ec 100644 --- a/EventB/Formula/Parse.lean +++ b/EventB/Formula/Parse.lean @@ -33,7 +33,140 @@ inductive Term where /-- Binder: `∀`, `∃`, `λ`, `⋂`, `⋃`, and `{pat · body}` set comprehension, whose kind is `"{"`. The body of a comprehension or lambda is `bin "∣" pred expr`. -/ | bind : String → Term → Term → Term - deriving BEq, Repr, Inhabited + deriving Repr, Inhabited + +mutual + + def termBeq : Term → Term → Bool + | .id left, .id right => left == right + | .num left, .num right => left == right + | .bin leftOp left₁ left₂, .bin rightOp right₁ right₂ => + leftOp == rightOp && termBeq left₁ right₁ && termBeq left₂ right₂ + | .pre leftOp left, .pre rightOp right + | .post leftOp left, .post rightOp right => leftOp == rightOp && termBeq left right + | .app leftFunction leftArgument, .app rightFunction rightArgument + | .img leftFunction leftArgument, .img rightFunction rightArgument => + termBeq leftFunction rightFunction && termBeq leftArgument rightArgument + | .set left, .set right => termListBeq left right + | .bind leftKind leftBinder leftBody, .bind rightKind rightBinder rightBody => + leftKind == rightKind && termBeq leftBinder rightBinder && termBeq leftBody rightBody + | _, _ => false + + def termListBeq : List Term → List Term → Bool + | [], [] => true + | left :: lefts, right :: rights => termBeq left right && termListBeq lefts rights + | _, _ => false + +end + +instance : BEq Term := ⟨termBeq⟩ + +private theorem congrArg₂' {α β γ : Type} (f : α → β → γ) + {left left' : α} {right right' : β} + (leftEq : left = left') (rightEq : right = right') : + f left right = f left' right' := by + cases leftEq + cases rightEq + rfl + +theorem Term.eq_of_beq {left right : Term} (equal : left == right) : left = right := by + change termBeq left right = true at equal + exact (Term.rec + (motive_1 := fun left => ∀ right, termBeq left right = true → left = right) + (motive_2 := fun left => ∀ right, termListBeq left right = true → left = right) + (id := fun name right equal => by + cases right with + | id other => simp [termBeq] at equal; subst other; rfl + | num | bin | pre | post | app | img | set | bind => simp [termBeq] at equal) + (num := fun value right equal => by + cases right with + | num other => simp [termBeq] at equal; subst other; rfl + | id | bin | pre | post | app | img | set | bind => simp [termBeq] at equal) + (bin := fun op left₁ right₁ ihLeft ihRight right equal => by + cases right with + | bin otherOp otherLeft otherRight => + simp [termBeq] at equal + rcases equal with ⟨⟨opEq, leftEq⟩, rightEq⟩ + subst otherOp + exact congrArg₂' (Term.bin op) (ihLeft otherLeft leftEq) (ihRight otherRight rightEq) + | id | num | pre | post | app | img | set | bind => simp [termBeq] at equal) + (pre := fun op value ih right equal => by + cases right with + | pre otherOp otherValue => + simp [termBeq] at equal + rcases equal with ⟨opEq, valueEq⟩ + subst otherOp + exact congrArg (Term.pre op) (ih otherValue valueEq) + | id | num | bin | post | app | img | set | bind => simp [termBeq] at equal) + (post := fun op value ih right equal => by + cases right with + | post otherOp otherValue => + simp [termBeq] at equal + rcases equal with ⟨opEq, valueEq⟩ + subst otherOp + exact congrArg (Term.post op) (ih otherValue valueEq) + | id | num | bin | pre | app | img | set | bind => simp [termBeq] at equal) + (app := fun function argument ihFunction ihArgument right equal => by + cases right with + | app otherFunction otherArgument => + simp [termBeq] at equal + exact congrArg₂' Term.app (ihFunction otherFunction equal.1) + (ihArgument otherArgument equal.2) + | id | num | bin | pre | post | img | set | bind => simp [termBeq] at equal) + (img := fun relation argument ihRelation ihArgument right equal => by + cases right with + | img otherRelation otherArgument => + simp [termBeq] at equal + exact congrArg₂' Term.img (ihRelation otherRelation equal.1) + (ihArgument otherArgument equal.2) + | id | num | bin | pre | post | app | set | bind => simp [termBeq] at equal) + (set := fun values ih right equal => by + cases right with + | set otherValues => exact congrArg Term.set (ih otherValues equal) + | id | num | bin | pre | post | app | img | bind => simp [termBeq] at equal) + (bind := fun quantifier binder body ihBinder ihBody right equal => by + cases right with + | bind otherQuantifier otherBinder otherBody => + simp [termBeq] at equal + rcases equal with ⟨⟨quantifierEq, binderEq⟩, bodyEq⟩ + subst otherQuantifier + exact congrArg₂' (Term.bind quantifier) + (ihBinder otherBinder binderEq) (ihBody otherBody bodyEq) + | id | num | bin | pre | post | app | img | set => simp [termBeq] at equal) + (nil := fun right equal => by + cases right with + | nil => rfl + | cons => simp [termListBeq] at equal) + (cons := fun head tail ihHead ihTail right equal => by + cases right with + | nil => simp [termListBeq] at equal + | cons otherHead otherTail => + simp [termListBeq] at equal + exact congrArg₂' List.cons (ihHead otherHead equal.1) (ihTail otherTail equal.2)) + left) right equal + +theorem Term.beq_self (term : Term) : termBeq term term = true := by + exact Term.rec + (motive_1 := fun term => termBeq term term = true) + (motive_2 := fun terms => termListBeq terms terms = true) + (id := fun _ => by simp [termBeq]) + (num := fun _ => by simp [termBeq]) + (bin := fun _ _ _ ihLeft ihRight => by simp [termBeq, ihLeft, ihRight]) + (pre := fun _ _ ih => by simp [termBeq, ih]) + (post := fun _ _ ih => by simp [termBeq, ih]) + (app := fun _ _ ihFunction ihArgument => by simp [termBeq, ihFunction, ihArgument]) + (img := fun _ _ ihRelation ihArgument => by simp [termBeq, ihRelation, ihArgument]) + (set := fun _ ih => ih) + (bind := fun _ _ _ ihBinder ihBody => by simp [termBeq, ihBinder, ihBody]) + (nil := by rfl) + (cons := fun _ _ ihHead ihTail => by simp [termListBeq, ihHead, ihTail]) + term + +instance : LawfulBEq Term where + rfl := Term.beq_self _ + eq_of_beq := Term.eq_of_beq + +instance : DecidableEq Term := instDecidableEqOfLawfulBEq /-- Binding power, and whether the operator associates. Non-associating operators reject `a ∈ b ∈ c` the way Rodin does, rather than silently bracketing it. -/ @@ -90,6 +223,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 +293,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 +433,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/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..6318992 100644 --- a/EventB/POG.lean +++ b/EventB/POG.lean @@ -33,17 +33,41 @@ structure Obligation where goal : Option Term := none /-- Everything the goal may assume, in Rodin's order. -/ hyps : List Term := [] - deriving BEq, Repr, Inhabited + /-- Typechecking and model-resolution errors discovered before generation. -/ + diagnostics : List String := [] + deriving BEq, Repr, Inhabited, DecidableEq -def formulaLanguageVersion : String := "eventb-formula-v1" +/-- The only checked obligation without a translated statement is witness WD: Rodin +records its definedness formula as a hypothesis of the sequent. Every other checked +obligation must carry exactly one goal. -/ +def Obligation.shapeValid (obligation : Obligation) : Bool := + match obligation.kind, obligation.goal with + | "WWD", none => !obligation.hyps.isEmpty + | "WWD", some _ => false + | _, some _ => true + | _, none => false + +#guard ({ name := "w/WWD", kind := "WWD", hyps := [.id "defined"] } : Obligation).shapeValid +#guard !({ name := "i/INV", kind := "INV" } : Obligation).shapeValid + +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 +80,58 @@ 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 + +/-- Exact abstract events named by a concrete event's `refinesEvent` children. -/ +def eventRefinementTargets (p : Project) (machine event : String) : List String := + match lookupComponent p machine with + | none => [] + | some component => + match (childrenOf component.elem "event").find? + (fun candidate => labelOf candidate == event) with + | none => [] + | some current => eventTargets current + +/- Keep the source machine together with each refined-event label. The older + `eventRefinementTargets` API remains the compatibility label projection; checked + refinement adapters use this locator-preserving view. -/ +def eventRefinementTargetLocators (p : Project) (machine event : String) : + List (String × String) := + match lookupComponent p machine with + | none => [] + | some component => + let abstractMachine := + (childrenOf component.elem "refinesMachine").filterMap targetName |>.head?.getD "" + match (childrenOf component.elem "event").find? + (fun candidate => labelOf candidate == event) with + | none => [] + | some current => + (childrenOf current "refinesEvent").filterMap fun target => + (attrOf target "target").map fun raw => + let parts := raw.splitOn "/" + let targetEvent := parts.getLast! + let targetMachine := + if parts.length > 1 then parts.dropLast.getLast! + else abstractMachine + (targetMachine, targetEvent) + +/-- Exact convergence attribute of a source event. Semantic adapters use this + instead of inferring anticipated/convergent semantics from a VAR name. -/ +def eventConvergenceMode? (p : Project) (machine event : String) : Option String := + match lookupComponent p machine with + | none => none + | some component => + (childrenOf component.elem "event").find? + (fun candidate => labelOf candidate == event) |>.bind (attrOf · "convergence") + +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 +142,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 +169,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 +216,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 +244,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 => @@ -141,10 +253,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 := @@ -153,6 +265,25 @@ def effectiveActions (p : Project) (machine : String) (ev : Elem) : List Elem := def effectiveGuards (p : Project) (machine : String) (ev : Elem) : List Elem := inheritedChildren p "guard" p.length machine ev +private def parseGuardPredicates? : List Elem → Option (List Term) + | [] => some [] + | guard :: guards => do + let source ← guard.attr? "org.eventb.core.predicate" + let predicate ← (Formula.parse source).toOption + let rest ← parseGuardPredicates? guards + pure (predicate :: rest) + +/-- Exact parsed guard predicates of an event, including inherited guards. A missing + event or malformed guard is rejected instead of being converted to an empty list. -/ +def eventGuardPredicates (p : Project) (machine event : String) : Option (List Term) := + match lookupComponent p machine with + | none => none + | some component => + match (childrenOf component.elem "event").find? + (fun candidate => labelOf candidate == event) with + | none => none + | some current => parseGuardPredicates? (effectiveGuards p machine current) + /-- The substitution an event performs, including what the abstract machine still does to variables the concrete event does not touch. @@ -161,35 +292,195 @@ 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 => [] | 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 => eventSubst p depth am ae - own ++ inherited.filter (fun q => !own.any (fun o => o.1 == q.1)) + | 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))) + +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 + +private def refinementTransitionActions (p : Project) (machine : String) (ev : Elem) : List Elem := + accurateTransitionActions 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 ((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 (refinementTransitionActions 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 (initialization : Bool) (variables : List String) + (actions : List Elem) : List Term := + actions.flatMap actionAfterRelationAccurate ++ + if initialization then [] else frameRelations variables actions + +private def concreteStateRelationsMode (strict initialization : Bool) (variables : List String) + (actions : List Elem) : List Term := + if strict then concreteStateRelationsAccurate initialization variables actions + else concreteStateRelations variables actions + +/-- Exact after-state relations selected by the strict transition path. This is + public so source-bound semantic adapters can consume the same action slice as + strict POG generation, including nondeterministic assignments and frames. -/ +def eventStateRelations (p : Project) (machine event : String) + (variables : List String) : List Term := + match lookupComponent p machine with + | none => [] + | some component => + match (childrenOf component.elem "event").find? + (fun candidate => labelOf candidate == event) with + | none => [] + | some current => + let actions := if event == "INITIALISATION" then + EventB.Typing.initializationActions p component current + else effectiveActions p machine current + actions.flatMap actionAfterRelationAccurate ++ + if event == "INITIALISATION" then [] else frameRelations 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 +541,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)) @@ -257,9 +564,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)) @@ -287,7 +603,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 +642,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 +732,74 @@ 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 "≔" 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 + 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 +868,26 @@ 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 + (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 => { 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 +914,890 @@ 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 - -- 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 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 initialization := labelOf ev == "INITIALISATION" + let concreteRelations := + concreteStateRelationsMode strict initialization concreteVariables concreteActions + -- The concrete before-after predicate is the event's effective action list: + -- parent actions are inherited only when the event is explicitly extended. + -- Using `eventActions` here would fabricate parent updates for an ordinary + -- refinement and make a frame/gluing INV or SIM obligation vacuous. + 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 initialization := labelOf ev == "INITIALISATION" + let concreteRelations := + concreteStateRelationsMode strict initialization 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 := if initialization then [] else + 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.shapeValid) with + | none => .ok obligations + | some obligation => .error (EventB.Error.typing (s! + "cannot generate trusted obligations for {name}: malformed " ++ + obligation.kind ++ " obligation " ++ obligation.name)) + | some obligation => + .error (EventB.Error.typing (s! + "cannot generate trusted obligations for {name}: " ++ + String.intercalate "; " obligation.diagnostics)) + +/-- Exact provenance for a generated EQL obligation. This retains the source + elements used by the generator instead of reconstructing them from the PO name + at a later trust boundary. -/ +structure EqlOrigin where + component : String + event : String + eqlVariable : String + concreteEvent : Elem + abstractMachine : String + abstractRefs : List (String × Elem) + effectiveActions : List Elem + actionHyps : List Formula.Term + deriving BEq, Repr + +private def directVariables (component : Component) : List String := + (childrenOf component.elem "variable").filterMap (attrOf · "identifier") + +private def exactEqlGoal (varName : String) : Formula.Term := + .bin "=" (.id (varName ++ "'")) (.id varName) + +/-- Locate the exact EQL record and the exact source event/action slice that caused + it. `none` means this event/variable pair does not satisfy Rodin's EQL condition; + malformed or unchecked projects return an error. -/ +def locateEql? (theory : Theory.Env) (p : Project) + (component event eqlVariable : String) : + Except EventB.Error (Option (EqlOrigin × Obligation)) := do + let generated ← generateCheckedIn theory p component + let concrete ← match lookupComponent p component with + | some value => pure value + | none => throw (EventB.Error.typing + s!"cannot locate EQL source in missing component {component}") + let concreteEvent ← match (childrenOf concrete.elem "event").find? + (fun candidate => labelOf candidate == event) with + | some value => pure value + | none => throw (EventB.Error.typing + s!"cannot locate EQL source event {component}/{event}") + let abstractRefs := abstractEvents p component concreteEvent + let abstractMachineName : Option String := + match abstractRefs.head? with + | some (machine, _) => some machine + | none => (childrenOf concrete.elem "refinesMachine").filterMap targetName |>.head? + let abstractMachine ← match abstractMachineName.bind (lookupComponent p ·) with + | some value => pure value + | none => throw (EventB.Error.typing + s!"cannot locate EQL abstract machine for {component}/{event}") + let concreteActions := accurateTransitionActions p component concreteEvent + let concreteVariables := directVariables concrete + let abstractVariables := directVariables abstractMachine + let concreteTargets := concreteActions.flatMap assignedBy + let abstractTargets := abstractRefs.flatMap fun (machine, abstractEvent) => + match lookupComponent p machine with + | some _ => (effectiveActions p machine abstractEvent).flatMap assignedBy + | none => [] + unless concreteVariables.contains eqlVariable && abstractVariables.contains eqlVariable && + concreteTargets.contains eqlVariable && !abstractTargets.contains eqlVariable do + return none + let name := event ++ "/" ++ eqlVariable ++ "/EQL" + let goal := exactEqlGoal eqlVariable + let obligation ← match generated.find? (fun candidate => + candidate.kind == "EQL" && candidate.name == name && candidate.goal == some goal) with + | some value => pure value + | none => throw (EventB.Error.typing + s!"checked generator has no exact EQL obligation {component}/{name}") + let actionHyps := concreteActions.filter (fun action => + (assignedBy action).contains eqlVariable) |>.flatMap actionAfterRelation + let origin : EqlOrigin := + { component := component + event := event + eqlVariable := eqlVariable + concreteEvent := concreteEvent + abstractMachine := abstractMachine.name + abstractRefs := abstractRefs + effectiveActions := concreteActions + actionHyps := actionHyps } + pure (some (origin, obligation)) + +/- The witness and simulation locators below deliberately sit on the same private + selectors as generateInMode. A PO name is only accepted after its source + element has been selected uniquely and the checked generator has emitted the + corresponding obligation. -/ + +def exactWitnessBinding? (witness : Elem) : Option (String × Formula.Term) := + witnessBinding witness + +def exactWitnessVariable? (witness : Elem) : Option String := + witnessVariable witness + +def exactWitnessPredicate? (witness : Elem) : Option Formula.Term := + (attrOf witness "predicate").bind (Formula.parse · |>.toOption) + +structure WitnessOrigin where + component : String + event : String + witnessLabel : String + concreteEvent : Elem + witness : Elem + witnessVariable : String + predicate : Formula.Term + binding : Option (String × Formula.Term) + deriving BEq, Repr + +private def uniqueChildByLabel (parent : Elem) (tag label : String) : Option Elem := + match (childrenOf parent tag).filter (fun child => labelOf child == label) with + | [child] => some child + | _ => none + +private def checkedWitnessOrigin (component event witnessLabel : String) + (concreteEvent witness : Elem) (predicate : Formula.Term) + (witnessName : String) : WitnessOrigin := + { component + event + witnessLabel + concreteEvent + witness + witnessVariable := witnessName + predicate + binding := exactWitnessBinding? witness } + +/-- Locate a uniquely named witness and its checked WFIS/WWD obligation. + + kind is explicit because the same witness can generate both WFIS and WWD, while + the source identity is shared. Ambiguous source labels and duplicate generated + names fail closed. -/ +def locateWitness? (theory : Theory.Env) (p : Project) + (component event witnessLabel kind : String) : + Except EventB.Error (Option (WitnessOrigin × Obligation)) := do + if kind != "WFIS" && kind != "WWD" then + throw (EventB.Error.typing s!"unsupported witness obligation kind {kind}") + let generated ← generateCheckedIn theory p component + let concrete ← match lookupComponent p component with + | some value => pure value + | none => throw (EventB.Error.typing + s!"cannot locate witness source in missing component {component}") + let concreteEvent ← match uniqueChildByLabel concrete.elem "event" event with + | some value => pure value + | none => throw (EventB.Error.typing + s!"cannot locate unique witness source event {component}/{event}") + let witness ← match uniqueChildByLabel concreteEvent "witness" witnessLabel with + | some value => pure value + | none => throw (EventB.Error.typing + s!"cannot locate unique witness {component}/{event}/{witnessLabel}") + let predicate ← match exactWitnessPredicate? witness with + | some value => pure value + | none => throw (EventB.Error.typing + s!"cannot parse witness predicate {component}/{event}/{witnessLabel}") + let witnessName ← match exactWitnessVariable? witness with + | some value => pure value + | none => throw (EventB.Error.typing + s!"cannot resolve witness variable {component}/{event}/{witnessLabel}") + let details ← inferComponentDetailsCheckedIn theory p component + let visibleParams := visibleEventBindings p details.eventParams component event + let expectedGoal := + if kind == "WFIS" then + (witnessFeasibility details.types visibleParams witness).map + (Theory.normalize theory (componentTheoryRoots p component)) + else none + let name := event ++ "/" ++ witnessLabel ++ "/" ++ kind + let candidates := generated.filter (fun obligation => + obligation.kind == kind && obligation.name == name && obligation.goal == expectedGoal) + let obligation ← match candidates with + | [] => return none + | [value] => pure value + | _ => throw (EventB.Error.typing + s!"checked generator emitted duplicate witness obligation {component}/{name}") + if kind == "WFIS" && expectedGoal.isNone then + throw (EventB.Error.typing + s!"witness feasibility has no typed goal {component}/{event}/{witnessLabel}") + if kind == "WWD" && expectedGoal.isSome then + throw (EventB.Error.typing + s!"witness definedness unexpectedly has a goal {component}/{event}/{witnessLabel}") + pure (some (checkedWitnessOrigin component event witnessLabel concreteEvent witness + predicate witnessName, obligation)) + +structure SimOrigin where + component : String + event : String + concreteEvent : Elem + abstractMachine : String + abstractEvent : Elem + abstractRefs : List (String × Elem) + abstractAction : Elem + concreteActions : List Elem + deriving BEq, Repr + +/-- Locate the exact abstract event/action behind one generated SIM obligation. + + The selected abstract action is unique by label in the effective action slice; + this rejects a name-only match when malformed input would produce duplicate PO + names. -/ +def locateSim? (theory : Theory.Env) (p : Project) + (component event abstractActionLabel : String) : + Except EventB.Error (Option (SimOrigin × Obligation)) := do + let generated ← generateCheckedIn theory p component + let concrete ← match lookupComponent p component with + | some value => pure value + | none => throw (EventB.Error.typing + s!"cannot locate SIM source in missing component {component}") + let concreteEvent ← match uniqueChildByLabel concrete.elem "event" event with + | some value => pure value + | none => throw (EventB.Error.typing + s!"cannot locate unique SIM source event {component}/{event}") + if isExtended concreteEvent then return none + let refs := abstractEvents p component concreteEvent + let (abstractMachine, abstractEvent) ← match refs with + | [(machine, value)] => pure (machine, value) + | _ => return none + match lookupComponent p abstractMachine with + | none => throw (EventB.Error.typing + s!"cannot locate SIM abstract component {abstractMachine}") + | some _ => pure () + let abstractActions := effectiveActions p abstractMachine abstractEvent + let matchingActions := abstractActions.filter + (fun action => labelOf action == abstractActionLabel) + let abstractAction ← match matchingActions with + | [value] => pure value + | [] => return none + | _ => throw (EventB.Error.typing + s!"ambiguous SIM abstract action {abstractMachine}/{abstractActionLabel}") + let name := event ++ "/" ++ abstractActionLabel ++ "/SIM" + let candidates := generated.filter (fun obligation => + obligation.kind == "SIM" && obligation.name == name) + let obligation ← match candidates with + | [] => return none + | [value] => pure value + | _ => throw (EventB.Error.typing + s!"checked generator emitted duplicate SIM obligation {component}/{name}") + pure (some + ({ component + event + concreteEvent + abstractMachine + abstractEvent + abstractRefs := refs + abstractAction := abstractAction + concreteActions := accurateTransitionActions p component concreteEvent }, obligation)) + +def simSourceBound (theory : Theory.Env) (p : Project) + (component event abstractActionLabel : String) (target : Obligation) : Bool := + match locateSim? theory p component event abstractActionLabel with + | .ok (some (_, obligation)) => obligation == target + | _ => false + +/-- Bind generated names to the source slice selected by the generator. In + particular, GRD and SIM labels come from the selected abstract event, while + FIS/WD labels come from the concrete transition action slice. -/ +def generatedSourceBound (p : Project) (obligation : Obligation) : Bool := + let directComponent := lookupComponent p obligation.component + let directEvent (event : String) : Option Elem := + directComponent.bind fun component => + (childrenOf component.elem "event").find? (fun candidate => labelOf candidate == event) + let hasDirectLabel (tag label : String) : Bool := + directComponent.any fun component => + (childrenOf component.elem tag).any (fun child => labelOf child == label) + let hasEventChild (event tag label : String) : Bool := + (directEvent event).any fun current => + (childrenOf current tag).any (fun child => labelOf child == label) + let hasVariant := directComponent.any fun component => + (childrenOf component.elem "variant").any (fun _ => true) + let parts := obligation.name.splitOn "/" + match obligation.kind, parts with + | "INV", [event, label, _] => + (directEvent event).isSome && + (let (_, closure) := EventB.Typing.closure p [] obligation.component + closure.any fun name => + (lookupComponent p name).any fun component => + (childrenOf component.elem "invariant").any + (fun child => labelOf child == label) || + (childrenOf component.elem "axiom").any + (fun child => labelOf child == label)) + | "GRD", [event, label, _] => + (directEvent event).any fun concrete => + !isExtended concrete && + (abstractEvents p obligation.component concrete).length <= 1 && + (abstractEvent p obligation.component concrete).any fun (machine, target) => + (effectiveGuards p machine target).any (fun guard => labelOf guard == label) + | "SIM", [event, label, _] => + (directEvent event).any fun concrete => + !isExtended concrete && + (abstractEvents p obligation.component concrete).length <= 1 && + (abstractEvent p obligation.component concrete).any fun (machine, target) => + (effectiveActions p machine target).any (fun action => labelOf action == label) + | "FIS", [event, label, _] => + (directEvent event).any fun concrete => + (accurateTransitionActions p obligation.component concrete).any + (fun action => labelOf action == label) + | "WFIS", [event, label, _] | "WWD", [event, label, _] => + hasEventChild event "witness" label + | "EQL", [event, eqlVariable, _] => + (directEvent event).any fun concrete => + let abstractRefs := abstractEvents p obligation.component concrete + let abstractMachineName : Option String := + match abstractRefs.head? with + | some (machine, _) => some machine + | none => (childrenOf concrete "refinesMachine").filterMap targetName |>.head? + let abstractVariables := abstractMachineName.bind (lookupComponent p ·) |>.any + (fun machine => directVariables machine |>.contains eqlVariable) + let concreteActions := accurateTransitionActions p obligation.component concrete + let concreteVariables := directComponent.any + (fun component => directVariables component |>.contains eqlVariable) + let concreteTargets := concreteActions.flatMap assignedBy + let abstractTargets := abstractRefs.flatMap fun (machine, target) => + (effectiveActions p machine target).flatMap assignedBy + abstractVariables && concreteVariables && concreteTargets.contains eqlVariable && + !abstractTargets.contains eqlVariable + | "WD", [event, label, _] => + hasEventChild event "guard" label || + hasEventChild event "action" label || + hasEventChild event "witness" label || + (directEvent event).any fun concrete => + (accurateTransitionActions p obligation.component concrete).any + (fun action => labelOf action == label) + | "WD", [label, _] | "THM", [label, _] => hasDirectLabel "invariant" label || + hasDirectLabel "axiom" label + | "MRG", [event, _] => + (directEvent event).any fun concrete => + !isExtended concrete && + (eventRefinementTargets p obligation.component event).length > 1 + | "VAR", [event, _] | "NAT", [event, _] => + (directEvent event).isSome + | "VWD", ["VWD"] | "FIN", ["FIN"] => hasVariant + | _, _ => false + /-- 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 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")] + [.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")] []]] }] + +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 + +#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" && + 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") && + 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 + +#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 + +#guard match locateWitness? Theory.empty rightWitnessProject "B" "step" "p" "WFIS" with + | .ok (some (origin, obligation)) => + origin.witnessVariable == "p" && + (Formula.print origin.predicate).contains "q + 1" && + obligation.name == "step/p/WFIS" + | _ => false + +#guard match locateSim? Theory.empty rightWitnessProject "B" "step" "set" with + | .ok (some (origin, obligation)) => + origin.abstractMachine == "A" && + origin.abstractAction.attr? "org.eventb.core.assignment" == some "x ≔ p" && + obligation.name == "step/set/SIM" + | _ => false + +#guard match locateSim? Theory.empty rightWitnessProject "B" "step" "missing" with + | .ok none => true + | _ => false end EventB.POG diff --git a/EventB/POG/EQLAdapter.lean b/EventB/POG/EQLAdapter.lean new file mode 100644 index 0000000..9a02f8d --- /dev/null +++ b/EventB/POG/EQLAdapter.lean @@ -0,0 +1,301 @@ +/- +The first executable source adapter is deliberately small: integer EQL only. +Sets and parameterised events need additional canonicalisation and event identity +proofs, so they remain outside the accepting surface. +-/ + +import EventB.POGSoundness +import EventB.Semantics + +namespace EventB.POG + +universe u + +def eqlGoal (name : String) : EventB.Formula.Term := + .bin "=" (.id (name ++ "'")) (.id name) + +def intRead (name : String) (env : ValueEnv) : Option Int := + match env.lookup name with + | some (.integer value) => some value + | _ => none + +def exactEqlShape (origin : EqlOrigin) (obligation : Obligation) : Bool := + obligation.component == origin.component && obligation.kind == "EQL" && + obligation.name == origin.event ++ "/" ++ origin.eqlVariable ++ "/EQL" && + obligation.goal == some (eqlGoal origin.eqlVariable) + +structure EqlIntBinding (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) where + component : String + eventLabel : String + eqlVariable : String + origin : EqlOrigin + obligation : Obligation + located : + locateEql? theory project component eventLabel eqlVariable = + .ok (some (origin, obligation)) + sourceShape : exactEqlShape origin obligation = true + valuation : ComponentValuation + valuationChecked : + ComponentValuation.fromProject theory project component = .ok valuation + declarations : List (String × EventB.Typing.Ty) + declarationsExact : + declarations = valuation.declarationsForEvent project eventLabel + updates : List (String × EventB.Formula.Term) + exactUpdates : + valuation.eventAssignments project eventLabel = .ok updates + variableType : + ValueEnv.declaredType? declarations eqlVariable = some .int + +def EqlIntBinding.fromProject? (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component event eqlVariable : String) : + Option (EqlIntBinding theory project) := + match located : locateEql? theory project component event eqlVariable with + | .error _ | .ok none => none + | .ok (some (origin, obligation)) => + if sourceShape : exactEqlShape origin obligation = true then + match valuationChecked : ComponentValuation.fromProject theory project component with + | .error _ => none + | .ok valuation => + match exactUpdates : valuation.eventAssignments project event with + | .error _ => none + | .ok updates => + if variableType : ValueEnv.declaredType? + (valuation.declarationsForEvent project event) eqlVariable = some .int then + some + { origin + component + eventLabel := event + eqlVariable + obligation + located + sourceShape + valuation + valuationChecked + declarations := valuation.declarationsForEvent project event + declarationsExact := rfl + updates + exactUpdates + variableType } + else none + else none + +def EqlIntBinding.action {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} (binding : EqlIntBinding theory project) (fuel : Nat) + (before after : ValueEnv) : Prop := + ∃ transition : CheckedBeforeAfter, + ValueEnv.parallelAssignTypedFuel fuel binding.declarations before binding.updates = + .ok transition ∧ transition.after = after + +def EqlIntBinding.goal {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} (binding : EqlIntBinding theory project) : + EventB.Formula.Term := eqlGoal binding.eqlVariable + +structure EqlIntEventBridge {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} (binding : EqlIntBinding theory project) + (σ : Type u) where + fuel : Nat + encode : σ → ValueEnv + event : Event σ + declarationsExact : + binding.declarations = + binding.valuation.declarationsForEvent project binding.eventLabel + stateValid : ∀ state, + ValueEnv.validationOk fuel binding.declarations (encode state) = true + actionExact : ∀ before after, + event.act before after ↔ binding.action fuel (encode before) (encode after) + unprimed : binding.eqlVariable.endsWith "'" = false + primedBase : + ((binding.eqlVariable ++ "'").dropEnd 1).copy = binding.eqlVariable + primeNotInteger : binding.eqlVariable ++ "'" ≠ "ℤ" + primeNotNatural : binding.eqlVariable ++ "'" ≠ "ℕ" + primeNotNatural1 : binding.eqlVariable ++ "'" ≠ "ℕ1" + primeNotBoolean : binding.eqlVariable ++ "'" ≠ "BOOL" + notInteger : binding.eqlVariable ≠ "ℤ" + notNatural : binding.eqlVariable ≠ "ℕ" + notNatural1 : binding.eqlVariable ≠ "ℕ1" + notBoolean : binding.eqlVariable ≠ "BOOL" + hypothesesHold : ∀ {before after}, event.act before after → + ∃ transition : CheckedBeforeAfter, + transition.before = encode before ∧ transition.after = encode after ∧ + transition.declarations = binding.declarations ∧ + ValueEnv.validationOk fuel binding.declarations transition.before = true ∧ + ValueEnv.validationOk fuel binding.declarations transition.after = true ∧ + ∀ hypothesis ∈ binding.obligation.hyps, + assignmentPredicateWithFuel fuel transition hypothesis + stateInteger : ∀ state, ∃ value : Int, + (encode state).lookup binding.eqlVariable = some (.integer value) + nonempty : ∃ before after, event.act before after + +def EqlIntEventBridge.read {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} + {binding : EqlIntBinding theory project} {σ : Type u} + (bridge : EqlIntEventBridge binding σ) : σ → Option Int := + fun state => intRead binding.eqlVariable (bridge.encode state) + +/- A kernel-checkable evaluator lemma. The lookup facts make the result independent + of list order or the representation of unrelated variables. -/ +theorem intRead_of_eqlEvaluation + (fuel : Nat) + (name : String) (transition : CheckedBeforeAfter) + (beforeValue afterValue : Int) + (beforeValid : ValueEnv.validationOk fuel transition.declarations transition.before = true) + (afterValid : ValueEnv.validationOk fuel transition.declarations transition.after = true) + (unprimed : name.endsWith "'" = false) + (primedBase : ((name ++ "'").dropEnd 1).copy = name) + (primeNotInteger : name ++ "'" ≠ "ℤ") + (primeNotNatural : name ++ "'" ≠ "ℕ") + (primeNotNatural1 : name ++ "'" ≠ "ℕ1") + (primeNotBoolean : name ++ "'" ≠ "BOOL") + (notInteger : name ≠ "ℤ") + (notNatural : name ≠ "ℕ") + (notNatural1 : name ≠ "ℕ1") + (notBoolean : name ≠ "BOOL") + (beforeLookup : transition.before.lookup name = some (.integer beforeValue)) + (afterLookup : transition.after.lookup ((name ++ "'").dropEnd 1).copy = + some (.integer afterValue)) + (evaluated : assignmentPredicateWithFuel fuel transition (eqlGoal name)) : + afterValue = beforeValue := by + exact eqlIntegerAfterEqBefore fuel name transition beforeValue afterValue + beforeValid afterValid unprimed primedBase primeNotInteger primeNotNatural + primeNotNatural1 primeNotBoolean notInteger notNatural notNatural1 notBoolean + beforeLookup afterLookup evaluated + +def EqlIntEventBridge.sequent {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} + {binding : EqlIntBinding theory project} {σ : Type u} + (bridge : EqlIntEventBridge binding σ) : Prop := + ∀ transition : CheckedBeforeAfter, + transition.declarations = binding.declarations → + (∀ hypothesis ∈ binding.obligation.hyps, + assignmentPredicateWithFuel bridge.fuel transition hypothesis) → + assignmentPredicateWithFuel bridge.fuel transition (binding.goal) + +theorem EqlIntEventBridge.sequent_of_goal_hypothesis + {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {binding : EqlIntBinding theory project} {σ : Type u} + (bridge : EqlIntEventBridge binding σ) + (goalHypothesis : binding.goal ∈ binding.obligation.hyps) : + bridge.sequent := by + intro transition _ hypotheses + exact hypotheses binding.goal goalHypothesis + +theorem EqlIntEventBridge.framePreserved + {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {binding : EqlIntBinding theory project} {σ : Type u} + (bridge : EqlIntEventBridge binding σ) + (poProof : bridge.sequent) : + framePreserved bridge.read bridge.event.act := by + intro before after eventStep + obtain ⟨transition, beforeEq, afterEq, declarationsEq, beforeValid, afterValid, + hypotheses⟩ := bridge.hypothesesHold eventStep + have goal := poProof transition declarationsEq hypotheses + obtain ⟨beforeValue, beforeLookup⟩ := bridge.stateInteger before + obtain ⟨afterValue, afterLookup⟩ := bridge.stateInteger after + have beforeValid' : + ValueEnv.validationOk bridge.fuel transition.declarations transition.before = true := by + simpa [declarationsEq] using beforeValid + have afterValid' : + ValueEnv.validationOk bridge.fuel transition.declarations transition.after = true := by + simpa [declarationsEq] using afterValid + have equal := intRead_of_eqlEvaluation bridge.fuel + binding.eqlVariable transition beforeValue afterValue + beforeValid' afterValid' bridge.unprimed bridge.primedBase + bridge.primeNotInteger bridge.primeNotNatural bridge.primeNotNatural1 bridge.primeNotBoolean + bridge.notInteger bridge.notNatural bridge.notNatural1 bridge.notBoolean + (by simpa [beforeEq] using beforeLookup) + (by simpa [afterEq, bridge.primedBase] using afterLookup) goal + simp [EqlIntEventBridge.read, intRead, + beforeLookup, afterLookup, equal] + +/- A complete EQL acceptance object binds the generated obligation, the exact + integer source, the executable event, and the proof of the checked sequent. + The semantic theorem is then obtained only through the bridge above. -/ +structure EqlIntAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (σ : Type u) where + binding : EqlIntBinding theory project + bridge : EqlIntEventBridge binding σ + sequent : bridge.sequent + +theorem EqlIntAdapter.sound {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {σ : Type u} + (adapter : EqlIntAdapter theory project σ) : + framePreserved adapter.bridge.read adapter.bridge.event.act := + adapter.bridge.framePreserved adapter.sequent + +/- ------------------------------------------------------------------ -/ +/- Kernel fixtures. The parent event has no action; the concrete event's + deterministic self-assignment is therefore the exact source of B/step/x/EQL. -/ + +def positiveProject : EventB.Typing.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")] + [.action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ 0")] []] + , .event [("org.eventb.core.label", "step")] []] } + , { name := "B" + elem := .machineFile [("org.eventb.core.name", "B")] + [.refinesMachine [("org.eventb.core.target", "A")] [] + , .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")] + [.refinesEvent [("org.eventb.core.target", "step")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ x")] []]] }] + +#guard match locateEql? Theory.empty positiveProject "B" "step" "x" with + | .ok (some (origin, obligation)) => + origin.component == "B" && origin.event == "step" && + origin.eqlVariable == "x" && obligation.kind == "EQL" && + obligation.name == "step/x/EQL" && obligation.goal == some (eqlGoal "x") + | _ => false + +#guard match ComponentValuation.fromProject Theory.empty positiveProject "B" with + | .ok valuation => + match valuation.eventAssignments positiveProject "step" with + | .ok [("x", .id "x")] => true + | _ => false + | .error _ => false + +#guard match ComponentValuation.fromProject Theory.empty positiveProject "B" with + | .ok valuation => + match valuation.eventAssignments positiveProject "step" with + | .ok updates => + match valuation.parallelAssign positiveProject "step" + { values := [("x", .integer 0)] } updates with + | .ok transition => + ValueEnv.declaredType? transition.declarations "x" == some .int && + match evalBeforeAfter 128 transition (eqlGoal "x") with + | .ok true => true + | _ => false + | .error _ => false + | .error _ => false + | .error _ => false + +#guard match locateEql? Theory.empty positiveProject "B" "step" "y" with + | .ok none => true + | _ => false + +#guard match ComponentValuation.fromProject Theory.empty positiveProject "B" with + | .ok valuation => + match valuation.parallelAssign positiveProject "step" + { values := [("x", .integer 0)] } [("x", .num 1)] with + | .error (.invalidTarget _) => true + | _ => false + | .error _ => false + +example {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {binding : EqlIntBinding theory project} {σ : Type u} + (bridge : EqlIntEventBridge binding σ) (poProof : bridge.sequent) : + framePreserved bridge.read bridge.event.act := by + exact bridge.framePreserved poProof + +end EventB.POG diff --git a/EventB/POG/RefinementAdapters.lean b/EventB/POG/RefinementAdapters.lean new file mode 100644 index 0000000..dbad082 --- /dev/null +++ b/EventB/POG/RefinementAdapters.lean @@ -0,0 +1,2359 @@ +/- +Proof-carrying adapters for the refinement-heavy PO families. They bind the exact +checked generated record to the corresponding semantic contract, but deliberately +do not infer a semantic proof from a PO name or from an arbitrary formula model. +-/ + +import EventB.POGSoundness +import EventB.Semantics + +namespace EventB.POG + +universe u v + +structure CheckedPO (theory : EventB.Theory.Env) (project : EventB.Typing.Project) where + obligation : Obligation + checked : obligation.checkedIn theory project + +private structure MemberResult (obligations : List Obligation) where + obligation : Obligation + member : obligation ∈ obligations + +private def findMember (predicate : Obligation → Bool) (obligations : List Obligation) : + Option (MemberResult obligations) := + match obligations with + | [] => none + | obligation :: rest => + if predicate obligation then + some { obligation, member := by simp } + else + match findMember predicate rest with + | none => none + | some result => some { obligation := result.obligation, member := by simp [result.member] } + +def CheckedPO.fromGenerated? (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component : String) + (predicate : Obligation → Bool) : Option (CheckedPO theory project) := + match generated : generateCheckedIn theory project component with + | .error _ => none + | .ok obligations => + match findMember predicate obligations with + | none => none + | some result => + let obligation := result.obligation + if componentEq : obligation.component = component then + if source : obligation.sourceBound project = true then + some + { obligation := obligation + checked := by + simp [Obligation.checkedIn, componentEq, generated, source] + simpa [componentEq, generated] using result.member } + else none + else none + +private structure ExactMember (target : Obligation) (obligations : List Obligation) where + payload : Unit + member : target ∈ obligations + +private def exactMember (target : Obligation) : (obligations : List Obligation) → + Option (ExactMember target obligations) + | [] => none + | candidate :: rest => + if same : candidate = target then + have member : target ∈ candidate :: rest := by + subst target + simp + some { payload := (), member } + else + match exactMember target rest with + | none => none + | some result => some { payload := (), member := by simp [result.member] } + +def CheckedPO.fromGeneratedExact? (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (obligation : Obligation) : + Option (CheckedPO theory project) := + match generated : generateCheckedIn theory project obligation.component with + | .error _ => none + | .ok obligations => + match exactMember obligation obligations with + | none => none + | some member => + if source : obligation.sourceBound project = true then + some + { obligation := obligation + checked := by + simp [Obligation.checkedIn, generated, source] + exact member.member } + else none + +def exactComponentDeclarations? (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component : String) : + Option (List (String × EventB.Typing.Ty)) := + match EventB.Typing.inferComponentDetailsCheckedIn theory project component with + | .ok details => some details.types + | .error _ => none + +def exactEventDeclarations? (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component event : String) : + Option (List (String × EventB.Typing.Ty)) := + match ComponentValuation.fromProject theory project component with + | .ok valuation => some (valuation.declarationsForEvent project event) + | .error _ => none + +def exactScopedDeclarations? (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component : String) + (event : Option String) : Option (List (String × EventB.Typing.Ty)) := + match event with + | none => exactComponentDeclarations? theory project component + | some label => exactEventDeclarations? theory project component label + +structure CheckedEventSource (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component event : String) where + valuation : ComponentValuation + valuationChecked : + ComponentValuation.fromProject theory project component = .ok valuation + declarations : List (String × EventB.Typing.Ty) + declarationsExact : + declarations = valuation.declarationsForEvent project event + updates : List (String × EventB.Formula.Term) + updatesExact : valuation.eventAssignments project event = .ok updates + +def CheckedEventSource.fromProject (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component event : String) : + Option (CheckedEventSource theory project component event) := + match valuationChecked : ComponentValuation.fromProject theory project component with + | .error _ => none + | .ok valuation => + match updatesExact : valuation.eventAssignments project event with + | .error _ => none + | .ok updates => + some + { valuation := valuation + valuationChecked := valuationChecked + declarations := valuation.declarationsForEvent project event + declarationsExact := rfl + updates := updates + updatesExact := updatesExact } + +def CheckedEventSource.assignmentAction + {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {component event : String} (source : CheckedEventSource theory project component event) + (fuel : Nat) (transition : CheckedBeforeAfter) : Prop := + assignmentRelation fuel source.declarations transition source.updates + +structure CheckedGuardSource (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component event : String) where + valuation : ComponentValuation + valuationChecked : + ComponentValuation.fromProject theory project component = .ok valuation + declarations : List (String × EventB.Typing.Ty) + declarationsExact : + declarations = valuation.declarationsForEvent project event + predicates : List EventB.Formula.Term + predicatesExact : EventB.POG.eventGuardPredicates project component event = some predicates + +def CheckedGuardSource.fromProject (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component event : String) : + Option (CheckedGuardSource theory project component event) := + match valuationChecked : ComponentValuation.fromProject theory project component with + | .error _ => none + | .ok valuation => + match predicatesExact : EventB.POG.eventGuardPredicates project component event with + | none => none + | some predicates => + some + { valuation + valuationChecked + declarations := valuation.declarationsForEvent project event + declarationsExact := rfl + predicates + predicatesExact } + +def CheckedGuardSource.holds + {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {component event : String} (source : CheckedGuardSource theory project component event) + (fuel : Nat) (transition : CheckedBeforeAfter) : Prop := + transition.declarations = source.declarations ∧ + ValueEnv.validationOk fuel source.declarations transition.before = true ∧ + ValueEnv.validationOk fuel source.declarations transition.after = true ∧ + ∀ predicate ∈ source.predicates, + assignmentPredicateWithFuel fuel transition predicate + +/- Relational actions are a separate source type so deterministic assignment proofs + cannot accidentally be weakened when a project uses :∈ or :∣. -/ +structure CheckedRelationalEventSource (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component event : String) where + valuation : ComponentValuation + valuationChecked : + ComponentValuation.fromProject theory project component = .ok valuation + declarations : List (String × EventB.Typing.Ty) + declarationsExact : + declarations = valuation.declarationsForEvent project event + relations : List EventB.Formula.Term + relationsExact : + relations = EventB.POG.eventStateRelations project component event valuation.variables + relationsNonempty : relations ≠ [] + +def CheckedRelationalEventSource.fromProject (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component event : String) : + Option (CheckedRelationalEventSource theory project component event) := + match valuationChecked : ComponentValuation.fromProject theory project component with + | .error _ => none + | .ok valuation => + let relations := EventB.POG.eventStateRelations project component event valuation.variables + if h : relations.isEmpty then none + else + some + { valuation := valuation + valuationChecked := valuationChecked + declarations := valuation.declarationsForEvent project event + declarationsExact := rfl + relations + relationsExact := rfl + relationsNonempty := by simpa using h } + +def CheckedRelationalEventSource.relationAction + {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {component event : String} + (source : CheckedRelationalEventSource theory project component event) + (fuel : Nat) (transition : CheckedBeforeAfter) : Prop := + transition.declarations = source.declarations ∧ + ValueEnv.validationOk fuel source.declarations transition.before = true ∧ + ValueEnv.validationOk fuel source.declarations transition.after = true ∧ + ∀ relation ∈ source.relations, + assignmentPredicateWithFuel fuel transition relation + +def relationalEventActionExact {τ : Type u} + {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {component event : String} + (source : CheckedRelationalEventSource theory project component event) + (fuel : Nat) (encode : τ → CheckedBeforeAfter) (action : τ → Prop) : Prop := + ∀ state, action state ↔ source.relationAction fuel (encode state) + +/- MRG is source-sensitive in a different way from ordinary actions: one concrete + event must name multiple abstract events. Keep that target list tied to the + parsed event so a caller cannot turn a single-event proof into a merge proof. -/ +structure CheckedMergeSource (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component event : String) where + eventSource : CheckedEventSource theory project component event + targets : List String + targetsExact : targets = EventB.POG.eventRefinementTargets project component event + targetLocators : List (String × String) + targetLocatorsExact : + targetLocators = EventB.POG.eventRefinementTargetLocators project component event + targetCount : targets.length > 1 + +def CheckedMergeSource.fromProject (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component event : String) : + Option (CheckedMergeSource theory project component event) := + match CheckedEventSource.fromProject theory project component event with + | none => none + | some eventSource => + let targets := EventB.POG.eventRefinementTargets project component event + let targetLocators := EventB.POG.eventRefinementTargetLocators project component event + if h : targets.length > 1 then + some + { eventSource := eventSource + targets := targets + targetsExact := rfl + targetLocators := targetLocators + targetLocatorsExact := rfl + targetCount := h } + else none + +def exactWitnessSource? (project : EventB.Typing.Project) + (component event witness : String) : Option (String × EventB.Formula.Term) := + match EventB.Typing.lookupComponent project component with + | none => none + | some current => + match current.elem.children.find? (fun candidate => + candidate.tag == "org.eventb.core.event" && + candidate.attr? "org.eventb.core.label" == some event) with + | none => none + | some currentEvent => + match currentEvent.children.find? (fun candidate => + candidate.tag == "org.eventb.core.witness" && + candidate.attr? "org.eventb.core.label" == some witness) with + | none => none + | some currentWitness => do + let witnessVariable ← EventB.POG.exactWitnessVariable? currentWitness + let predicate ← EventB.POG.exactWitnessPredicate? currentWitness + pure (witnessVariable, predicate) + +/- Witness source identity is separate from the concrete event assignment source: + an abstract parameter witness is not a deterministic concrete update. -/ +structure CheckedWitnessSource (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component event witness : String) where + valuation : ComponentValuation + valuationChecked : + ComponentValuation.fromProject theory project component = .ok valuation + declarations : List (String × EventB.Typing.Ty) + declarationsExact : + declarations = valuation.declarationsForEvent project event + witnessVariable : String + predicate : EventB.Formula.Term + sourceExact : exactWitnessSource? project component event witness = some + (witnessVariable, predicate) + +def CheckedWitnessSource.fromProject (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component event witness : String) : + Option (CheckedWitnessSource theory project component event witness) := + match valuationChecked : ComponentValuation.fromProject theory project component with + | .error _ => none + | .ok valuation => + match sourceExact : exactWitnessSource? project component event witness with + | none => none + | some (witnessVariable, predicate) => + some + { valuation := valuation + valuationChecked := valuationChecked + declarations := valuation.declarationsForEvent project event + declarationsExact := rfl + witnessVariable + predicate + sourceExact } + +theorem witnessSourceExact {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {component event witness : String} + (source : CheckedWitnessSource theory project component event witness) : + exactWitnessSource? project component event witness = some + (source.witnessVariable, source.predicate) := + source.sourceExact + +def exactVariantExpression? (project : EventB.Typing.Project) (component : String) : + Option EventB.Formula.Term := + match EventB.Typing.lookupComponent project component with + | none => none + | some current => + match current.elem.children.filter (fun child => + child.tag == "org.eventb.core.variant") with + | [variant] => + match variant.attr? "org.eventb.core.expression" with + | none => none + | some source => (EventB.Formula.parse source).toOption + | _ => none + +structure CheckedVariantSource (project : EventB.Typing.Project) (component : String) where + expression : EventB.Formula.Term + expressionExact : exactVariantExpression? project component = some expression + +def CheckedVariantSource.fromProject (project : EventB.Typing.Project) (component : String) : + Option (CheckedVariantSource project component) := + match expressionExact : exactVariantExpression? project component with + | some expression => some { expression, expressionExact } + | none => none + +def eventActionExact {τ : Type u} + {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {component event : String} (source : CheckedEventSource theory project component event) + (fuel : Nat) (encode : τ → CheckedBeforeAfter) (action : τ → Prop) : Prop := + ∀ state, action state ↔ source.assignmentAction fuel (encode state) + +/- One merge branch is accepted only when its abstract semantic event is connected to + the exact parsed source event. The semantic event remains a Lean value, but its + guard and action must use the checked abstract source through the supplied encoder. -/ +structure CheckedMergeBranch (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (α : Type u) where + locator : String × String + eventSource : CheckedEventSource theory project locator.1 locator.2 + guardSource : CheckedGuardSource theory project locator.1 locator.2 + event : Event α + fuel : Nat + encode : (α × α) → CheckedBeforeAfter + actionExact : eventActionExact eventSource fuel encode + (fun state => event.act state.1 state.2) + guardExact : ∀ state, event.grd state.1 ↔ guardSource.holds fuel (encode state) + +/- A formula is not a semantic contract merely because it has the right PO name. + Every accepting adapter therefore uses the fixed typed evaluator, binds its + declarations to strict component inference, validates the exact generated formula, + and carries only the project-specific implication from that evaluator meaning to + the semantic contract. -/ +structure FormulaAdequacy {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} (binding : CheckedPO theory project) + (τ : Type u) (semantic : Prop) where + evaluator : TypedFormulaModel + encode : τ → ValueEnv + declarationScope : Option String + declarationsBound : + exactScopedDeclarations? theory project binding.obligation.component declarationScope = + some evaluator.declarations + stateValid : ∀ state, evaluator.wellFormed (encode state) + stateComplete : ∀ env, evaluator.wellFormed env → ∃ state, encode state = env + evaluatorValid : evaluator.validUnchecked binding.obligation + adequate : FormulaModel.validUnchecked + (evaluator.on encode) binding.obligation → semantic + +theorem FormulaAdequacy.valid {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {binding : CheckedPO theory project} + {τ : Type u} {semantic : Prop} (formula : FormulaAdequacy binding τ semantic) : + FormulaModel.validUnchecked (formula.evaluator.on formula.encode) binding.obligation := + formula.evaluator.valid_on formula.encode binding.obligation + formula.evaluatorValid formula.stateValid + +theorem FormulaAdequacy.validWithCoverage {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {binding : CheckedPO theory project} + {τ : Type u} {semantic : Prop} (formula : FormulaAdequacy binding τ semantic) : + FormulaModel.validUnchecked (formula.evaluator.on formula.encode) binding.obligation ∧ + (∀ env, formula.evaluator.wellFormed env → ∃ state, formula.encode state = env) := + ⟨formula.valid, formula.stateComplete⟩ + +/- Adequacy for an invariant/reachability-restricted semantic state domain. The + domain is explicit and coverage is required only over that domain; this is the + missing counterpart to transition source coverage for non-total VAR actions. -/ +structure DomainFormulaAdequacy {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} (binding : CheckedPO theory project) + (τ : Type u) (semantic : Prop) (domain : ValueEnv → Prop) where + evaluator : TypedFormulaModel + encode : τ → ValueEnv + declarationScope : Option String + declarationsBound : + exactScopedDeclarations? theory project binding.obligation.component declarationScope = + some evaluator.declarations + stateValid : ∀ state, domain (encode state) + stateComplete : ∀ env, domain env → ∃ state, encode state = env + evaluatorValid : evaluator.validOnDomain domain binding.obligation + adequate : FormulaModel.validUnchecked + (evaluator.on encode) binding.obligation → semantic + +theorem DomainFormulaAdequacy.valid {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {binding : CheckedPO theory project} + {τ : Type u} {semantic : Prop} {domain : ValueEnv → Prop} + (formula : DomainFormulaAdequacy binding τ semantic domain) : + FormulaModel.validUnchecked (formula.evaluator.on formula.encode) binding.obligation := + formula.evaluator.validOnDomain_on domain formula.encode binding.obligation + formula.evaluatorValid formula.stateValid + +theorem DomainFormulaAdequacy.validWithCoverage {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {binding : CheckedPO theory project} + {τ : Type u} {semantic : Prop} {domain : ValueEnv → Prop} + (formula : DomainFormulaAdequacy binding τ semantic domain) : + FormulaModel.validUnchecked (formula.evaluator.on formula.encode) binding.obligation ∧ + (∀ env, domain env → ∃ state, formula.encode state = env) := + ⟨formula.valid, formula.stateComplete⟩ + +structure TransitionFormulaAdequacy {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} (binding : CheckedPO theory project) + (τ : Type u) (semantic : Prop) (source : CheckedBeforeAfter → Prop) where + evaluator : TypedTransitionModel + encode : τ → CheckedBeforeAfter + declarations : List (String × EventB.Typing.Ty) + declarationScope : Option String + declarationsBound : + exactScopedDeclarations? theory project binding.obligation.component declarationScope = + some declarations + transitionDeclarations : ∀ state, (encode state).declarations = declarations + transitionValid : ∀ state, evaluator.wellFormed (encode state) + sourceValid : ∀ state, source (encode state) + sourceComplete : ∀ transition, source transition → + ∃ state, encode state = transition + evaluatorValid : evaluator.validOnDomain source binding.obligation + adequate : FormulaModel.validUnchecked + (evaluator.on encode) binding.obligation → semantic + +theorem TransitionFormulaAdequacy.valid {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {binding : CheckedPO theory project} + {τ : Type u} {semantic : Prop} {source : CheckedBeforeAfter → Prop} + (formula : TransitionFormulaAdequacy binding τ semantic source) : + FormulaModel.validUnchecked + (formula.evaluator.on formula.encode) binding.obligation := + formula.evaluator.validOnDomain_on source formula.encode + binding.obligation formula.evaluatorValid formula.sourceValid + +theorem TransitionFormulaAdequacy.sourceTransition + {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {binding : CheckedPO theory project} {τ : Type u} {semantic : Prop} + {source : CheckedBeforeAfter → Prop} + (formula : TransitionFormulaAdequacy binding τ semantic source) + (transition : CheckedBeforeAfter) (hsource : source transition) : + ∃ state, formula.encode state = transition := + formula.sourceComplete transition hsource + +theorem TransitionFormulaAdequacy.validWithCoverage + {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {binding : CheckedPO theory project} {τ : Type u} {semantic : Prop} + {source : CheckedBeforeAfter → Prop} + (formula : TransitionFormulaAdequacy binding τ semantic source) : + FormulaModel.validUnchecked + (formula.evaluator.on formula.encode) binding.obligation ∧ + (∀ transition, source transition → ∃ state, formula.encode state = transition) := + ⟨formula.valid, formula.sourceComplete⟩ + +def invariantSemantic {σ : Type u} (event : Event σ) (invariant : σ → Prop) : Prop := + ∀ before after, invariant before → event.grd before → event.act before after → + invariant after + +def guardSemantic {γ α : Type u} (gluing : γ → α → Prop) + (concrete : Event γ) (abstract : Event α) : Prop := + guardStrengthened gluing concrete abstract + +def actionSemantic {γ α : Type u} (gluing : γ → α → Prop) + (concrete : Event γ) (abstract : Event α) : Prop := + actionSimulates gluing concrete abstract + +def feasibilitySemantic {σ : Type u} (pre : σ → Prop) (action : σ → σ → Prop) : Prop := + ∀ before, pre before → ∃ after, action before after + +def witnessFeasibilitySemantic {σ α : Type u} (pre : σ → Prop) + (predicate : σ → α → Prop) : Prop := + ∀ state, pre state → ∃ witness, predicate state witness + +def witnessDefinednessSemantic {σ : Type u} (pre defined : σ → Prop) : Prop := + ∀ state, pre state → defined state + +def implicationSemantic {σ : Type u} (hypotheses goal : σ → Prop) : Prop := + ∀ state, hypotheses state → goal state + +/- A source-bound split conclusion names the selected abstract branch itself. + `A.step` is intentionally not enough here: it could be discharged by an + unrelated abstract event. The positional `branchEvents` list is paired with + `CheckedMergeSource.targets` by `MergeAdapter.branchLabelsExact`. -/ +def splitSimulationSemantic {γ α : Type u} {C : Machine γ} {A : Machine α} + {J : γ → α → Prop} (contract : SplitSimulation C A J) + (branchEvents : List (String × Event α)) : Prop := + ∀ c c' a, J c a → contract.concreteEvent.grd c → + contract.concreteEvent.act c c' → + ∃ label branch a', (label, branch) ∈ branchEvents ∧ + branch.grd a ∧ branch.act a a' ∧ J c' a' + +structure InvAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (σ : Type u) where + binding : CheckedPO theory project + eventLabel : String + invariantLabel : String + kind : binding.obligation.kind = "INV" + sourceName : binding.obligation.name = eventLabel ++ "/" ++ invariantLabel ++ "/INV" + eventSource : CheckedEventSource theory project binding.obligation.component eventLabel + guardSource : CheckedGuardSource theory project binding.obligation.component eventLabel + event : Event σ + invariant : σ → Prop + fuel : Nat + formula : TransitionFormulaAdequacy binding (σ × σ) (invariantSemantic event invariant) + (eventSource.assignmentAction fuel) + fuelExact : formula.evaluator.fuel = fuel + actionExact : eventActionExact eventSource fuel formula.encode + (fun state => event.act state.1 state.2) + guardExact : ∀ state, event.grd state.1 ↔ + guardSource.holds fuel (formula.encode state) + nonempty : ∃ before after, event.grd before ∧ event.act before after + +theorem InvAdapter.sound {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {σ : Type u} (adapter : InvAdapter theory project σ) : + invariantSemantic adapter.event adapter.invariant := + adapter.formula.adequate adapter.formula.valid + +structure GrdAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (γ α : Type u) where + binding : CheckedPO theory project + concreteLabel : String + abstractLabel : String + kind : binding.obligation.kind = "GRD" + sourceName : binding.obligation.name = concreteLabel ++ "/" ++ abstractLabel ++ "/GRD" + eventSource : CheckedEventSource theory project binding.obligation.component concreteLabel + guardSource : CheckedGuardSource theory project binding.obligation.component concreteLabel + gluing : γ → α → Prop + concrete : Event γ + abstract : Event α + fuel : Nat + formula : TransitionFormulaAdequacy binding ((γ × γ) × α) + (guardSemantic gluing concrete abstract) + (eventSource.assignmentAction fuel) + fuelExact : formula.evaluator.fuel = fuel + actionExact : eventActionExact eventSource fuel formula.encode + (fun state => concrete.act state.1.1 state.1.2) + guardExact : ∀ state, concrete.grd state.1.1 ↔ + guardSource.holds fuel (formula.encode state) + nonempty : ∃ concreteState abstractState, + gluing concreteState abstractState ∧ concrete.grd concreteState + +theorem GrdAdapter.sound {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {γ α : Type u} (adapter : GrdAdapter theory project γ α) : + guardSemantic adapter.gluing adapter.concrete adapter.abstract := + adapter.formula.adequate adapter.formula.valid + +structure SimAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (γ α : Type u) where + binding : CheckedPO theory project + concreteLabel : String + abstractLabel : String + kind : binding.obligation.kind = "SIM" + sourceName : binding.obligation.name = concreteLabel ++ "/" ++ abstractLabel ++ "/SIM" + eventSource : CheckedEventSource theory project binding.obligation.component concreteLabel + guardSource : CheckedGuardSource theory project binding.obligation.component concreteLabel + abstractSourceBound : + EventB.POG.simSourceBound theory project binding.obligation.component concreteLabel + abstractLabel binding.obligation = true + gluing : γ → α → Prop + concrete : Event γ + abstract : Event α + fuel : Nat + formula : TransitionFormulaAdequacy binding ((γ × γ) × α) + (actionSemantic gluing concrete abstract) + (eventSource.assignmentAction fuel) + fuelExact : formula.evaluator.fuel = fuel + actionExact : eventActionExact eventSource fuel formula.encode + (fun state => concrete.act state.1.1 state.1.2) + guardExact : ∀ state, concrete.grd state.1.1 ↔ + guardSource.holds fuel (formula.encode state) + nonempty : ∃ concreteState concreteAfter abstractState, + gluing concreteState abstractState ∧ concrete.grd concreteState ∧ + concrete.act concreteState concreteAfter + +theorem SimAdapter.sound {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {γ α : Type u} (adapter : SimAdapter theory project γ α) : + actionSemantic adapter.gluing adapter.concrete adapter.abstract := + adapter.formula.adequate adapter.formula.valid + +structure FisAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (σ : Type u) where + binding : CheckedPO theory project + eventLabel : String + actionLabel : String + kind : binding.obligation.kind = "FIS" + sourceName : binding.obligation.name = eventLabel ++ "/" ++ actionLabel ++ "/FIS" + eventSource : CheckedRelationalEventSource theory project binding.obligation.component eventLabel + pre : σ → Prop + action : σ → σ → Prop + fuel : Nat + formula : TransitionFormulaAdequacy binding (σ × σ) (feasibilitySemantic pre action) + (eventSource.relationAction fuel) + fuelExact : formula.evaluator.fuel = fuel + actionExact : relationalEventActionExact eventSource fuel formula.encode + (fun state => action state.1 state.2) + nonempty : ∃ before, pre before + +theorem FisAdapter.sound {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {σ : Type u} (adapter : FisAdapter theory project σ) : + feasibilitySemantic adapter.pre adapter.action := + adapter.formula.adequate adapter.formula.valid + +structure WfisAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (σ α : Type u) where + binding : CheckedPO theory project + eventLabel : String + witnessLabel : String + kind : binding.obligation.kind = "WFIS" + sourceName : binding.obligation.name = eventLabel ++ "/" ++ witnessLabel ++ "/WFIS" + eventSource : + CheckedWitnessSource theory project binding.obligation.component eventLabel witnessLabel + sourcePredicate : EventB.Formula.Term + sourcePredicateExact : sourcePredicate = eventSource.predicate + pre : σ → Prop + defined : σ → Prop + predicate : σ → α → Prop + contract : WitnessContract σ α pre defined predicate + formula : FormulaAdequacy binding σ + (witnessFeasibilitySemantic pre predicate) + nonempty : ∃ state, pre state + +theorem WfisAdapter.sound {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {σ α : Type u} (adapter : WfisAdapter theory project σ α) : + witnessFeasibilitySemantic adapter.pre adapter.predicate := + adapter.formula.adequate adapter.formula.valid + +structure WwdAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (σ α : Type u) where + binding : CheckedPO theory project + eventLabel : String + witnessLabel : String + kind : binding.obligation.kind = "WWD" + sourceName : binding.obligation.name = eventLabel ++ "/" ++ witnessLabel ++ "/WWD" + eventSource : + CheckedWitnessSource theory project binding.obligation.component eventLabel witnessLabel + sourcePredicate : EventB.Formula.Term + sourcePredicateExact : sourcePredicate = eventSource.predicate + pre : σ → Prop + defined : σ → Prop + predicate : σ → α → Prop + contract : WitnessContract σ α pre defined predicate + formula : FormulaAdequacy binding σ + (witnessDefinednessSemantic pre defined) + +theorem WwdAdapter.sound {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {σ α : Type u} (adapter : WwdAdapter theory project σ α) : + witnessDefinednessSemantic adapter.pre adapter.defined := + adapter.formula.adequate adapter.formula.valid + +structure VwdAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (σ : Type u) where + binding : CheckedPO theory project + kind : binding.obligation.kind = "VWD" + sourceName : binding.obligation.name = "VWD" + variantSource : CheckedVariantSource project binding.obligation.component + pre : σ → Prop + defined : σ → Prop + formula : FormulaAdequacy binding σ (witnessDefinednessSemantic pre defined) + nonempty : ∃ state, pre state + +theorem VwdAdapter.sound {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {σ : Type u} (adapter : VwdAdapter theory project σ) : + witnessDefinednessSemantic adapter.pre adapter.defined := + adapter.formula.adequate adapter.formula.valid + +structure WdAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (σ : Type u) where + binding : CheckedPO theory project + sourceLabel : String + kind : binding.obligation.kind = "WD" + sourceName : binding.obligation.name = sourceLabel ++ "/WD" ∨ + ∃ eventLabel, binding.obligation.name = eventLabel ++ "/" ++ sourceLabel ++ "/WD" + pre : σ → Prop + defined : σ → Prop + formula : FormulaAdequacy binding σ (witnessDefinednessSemantic pre defined) + +theorem WdAdapter.sound {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {σ : Type u} (adapter : WdAdapter theory project σ) : + witnessDefinednessSemantic adapter.pre adapter.defined := + adapter.formula.adequate adapter.formula.valid + +structure ThmAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (σ : Type u) where + binding : CheckedPO theory project + sourceLabel : String + kind : binding.obligation.kind = "THM" + sourceName : binding.obligation.name = sourceLabel ++ "/THM" + hypotheses : σ → Prop + goal : σ → Prop + formula : FormulaAdequacy binding σ (implicationSemantic hypotheses goal) + +theorem ThmAdapter.sound {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {σ : Type u} (adapter : ThmAdapter theory project σ) : + implicationSemantic adapter.hypotheses adapter.goal := + adapter.formula.adequate adapter.formula.valid + +structure MergeAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) {γ α : Type u} + {C : Machine γ} {A : Machine α} (J : γ → α → Prop) where + binding : CheckedPO theory project + eventLabel : String + kind : binding.obligation.kind = "MRG" + sourceName : binding.obligation.name = eventLabel ++ "/MRG" + eventSource : CheckedEventSource theory project binding.obligation.component eventLabel + mergeSource : CheckedMergeSource theory project binding.obligation.component eventLabel + guardSource : CheckedGuardSource theory project binding.obligation.component eventLabel + contract : SplitSimulation C A J + branchBindings : List (CheckedMergeBranch theory project α) + branchBindingLocatorsExact : + branchBindings.map (·.locator) = mergeSource.targetLocators + branchBindingObjectsExact : + contract.abstractEvents = branchBindings.map (·.event) + branchEvents : List (String × Event α) + branchLabelsExact : branchEvents.map (·.1) = mergeSource.targets + branchObjectsExact : contract.abstractEvents = branchEvents.map (·.2) + branchBindingEventsExact : + branchEvents = branchBindings.map (fun branch => (branch.locator.2, branch.event)) + fuel : Nat + formula : TransitionFormulaAdequacy binding ((γ × γ) × α) + (splitSimulationSemantic contract branchEvents) (eventSource.assignmentAction fuel) + fuelExact : formula.evaluator.fuel = fuel + actionExact : eventActionExact eventSource fuel formula.encode + (fun state => contract.concreteEvent.act state.1.1 state.1.2) + guardExact : ∀ state, contract.concreteEvent.grd state.1.1 ↔ + guardSource.holds fuel (formula.encode state) + +theorem MergeAdapter.sound {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {γ α : Type u} {C : Machine γ} {A : Machine α} {J : γ → α → Prop} + (adapter : MergeAdapter (C := C) (A := A) theory project J) : + ∀ c c' a, J c a → adapter.contract.concreteEvent.grd c → + adapter.contract.concreteEvent.act c c' → + ∃ label branch a', (label, branch) ∈ adapter.branchEvents ∧ + branch.grd a ∧ branch.act a a' ∧ J c' a' := by + exact adapter.formula.adequate adapter.formula.valid + +structure IntegerVariantAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (σ : Type u) where + natBinding : CheckedPO theory project + varBinding : CheckedPO theory project + natKind : natBinding.obligation.kind = "NAT" + varKind : varBinding.obligation.kind = "VAR" + componentMatch : varBinding.obligation.component = natBinding.obligation.component + eventLabel : String + eventSource : CheckedEventSource theory project natBinding.obligation.component eventLabel + variantSource : CheckedVariantSource project natBinding.obligation.component + natName : natBinding.obligation.name = eventLabel ++ "/NAT" + varName : varBinding.obligation.name = eventLabel ++ "/VAR" + contract : IntegerVariant σ + sourceMatch : contract.source = eventLabel + fuel : Nat + natFormula : TransitionFormulaAdequacy natBinding (σ × σ) + (integerVariantNaturality contract) (eventSource.assignmentAction fuel) + varFormula : TransitionFormulaAdequacy varBinding (σ × σ) + (integerVariantProgressSemantic contract) (eventSource.assignmentAction fuel) + fuelExact : natFormula.evaluator.fuel = fuel ∧ varFormula.evaluator.fuel = fuel + natActionExact : eventActionExact eventSource fuel natFormula.encode + (fun state => contract.action state.1 state.2) + varActionExact : eventActionExact eventSource fuel varFormula.encode + (fun state => contract.action state.1 state.2) + +theorem IntegerVariantAdapter.sound {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {σ : Type u} + (adapter : IntegerVariantAdapter theory project σ) : + integerVariantNaturality adapter.contract ∧ + integerVariantProgressSemantic adapter.contract := + ⟨adapter.natFormula.adequate adapter.natFormula.valid, + adapter.varFormula.adequate adapter.varFormula.valid⟩ + +structure NaturalVariantAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (σ : Type u) where + natBinding : CheckedPO theory project + varBinding : CheckedPO theory project + natKind : natBinding.obligation.kind = "NAT" + varKind : varBinding.obligation.kind = "VAR" + componentMatch : varBinding.obligation.component = natBinding.obligation.component + eventLabel : String + eventSource : CheckedEventSource theory project natBinding.obligation.component eventLabel + variantSource : CheckedVariantSource project natBinding.obligation.component + natName : natBinding.obligation.name = eventLabel ++ "/NAT" + varName : varBinding.obligation.name = eventLabel ++ "/VAR" + measure : σ → Nat + action : σ → σ → Prop + fuel : Nat + natFormula : TransitionFormulaAdequacy natBinding (σ × σ) (∀ state, 0 ≤ measure state) + (eventSource.assignmentAction fuel) + varFormula : TransitionFormulaAdequacy varBinding (σ × σ) + (∀ before after, action before after → measure after < measure before) + (eventSource.assignmentAction fuel) + fuelExact : natFormula.evaluator.fuel = fuel ∧ varFormula.evaluator.fuel = fuel + natActionExact : eventActionExact eventSource fuel natFormula.encode + (fun state => action state.1 state.2) + varActionExact : eventActionExact eventSource fuel varFormula.encode + (fun state => action state.1 state.2) + +theorem NaturalVariantAdapter.sound {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {σ : Type u} + (adapter : NaturalVariantAdapter theory project σ) : + (∀ state, 0 ≤ adapter.measure state) ∧ + (∀ before after, adapter.action before after → + adapter.measure after < adapter.measure before) := + ⟨adapter.natFormula.adequate adapter.natFormula.valid, + adapter.varFormula.adequate adapter.varFormula.valid⟩ + +/-- Source-bound VAR adapter for variants whose well-founded order is supplied by + the semantic model rather than guessed from the surface expression. -/ +structure WellFoundedVariantAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (σ : Type u) (α : Type v) + (contract : WellFoundedVariant σ α) where + binding : CheckedPO theory project + kind : binding.obligation.kind = "VAR" + eventLabel : String + sourceName : binding.obligation.name = eventLabel ++ "/VAR" + eventSource : CheckedEventSource theory project binding.obligation.component eventLabel + variantSource : CheckedVariantSource project binding.obligation.component + fuel : Nat + formula : TransitionFormulaAdequacy binding (σ × σ) + (wellFoundedVariantProgressSemantic contract) + (eventSource.assignmentAction fuel) + fuelExact : formula.evaluator.fuel = fuel + actionExact : eventActionExact eventSource fuel formula.encode + (fun state => contract.action state.1 state.2) + +theorem WellFoundedVariantAdapter.sound {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {σ : Type u} {α : Type v} + {contract : WellFoundedVariant σ α} + (adapter : WellFoundedVariantAdapter theory project σ α contract) : + wellFoundedVariantProgressSemantic contract := + adapter.formula.adequate adapter.formula.valid + +structure FiniteSetVariantAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) {σ : Type u} {α : Type v} {γ : Type u} + (contract : FiniteSetVariant σ α) where + finBinding : CheckedPO theory project + varBinding : CheckedPO theory project + finKind : finBinding.obligation.kind = "FIN" + varKind : varBinding.obligation.kind = "VAR" + componentMatch : varBinding.obligation.component = finBinding.obligation.component + eventLabel : String + eventSource : CheckedEventSource theory project finBinding.obligation.component eventLabel + variantSource : CheckedVariantSource project finBinding.obligation.component + finName : finBinding.obligation.name = "FIN" + varName : varBinding.obligation.name = eventLabel ++ "/VAR" + convergence : String + convergenceExact : + EventB.POG.eventConvergenceMode? project finBinding.obligation.component eventLabel = + some convergence + modeExact : match contract.mode with + | .anticipated => convergence = "2" + | .convergent => convergence = "1" + fuel : Nat + stateOf : γ → σ + stateCoverage : ∀ state, ∃ encoded, stateOf encoded = state + finFormula : FormulaAdequacy finBinding σ (finiteVariantFiniteness contract) + varFormula : TransitionFormulaAdequacy varBinding (γ × γ) + (∀ state : γ × γ, + contract.action (stateOf state.1) (stateOf state.2) → + finiteVariantProgress contract.mode + (contract.measure (stateOf state.2)) (contract.measure (stateOf state.1))) + (eventSource.assignmentAction fuel) + decodeVariantValue : Value → Option α + measureExact : ∀ state, + match evalValueAtFuel fuel (finFormula.encode state) variantSource.expression with + | .ok (.set values) => values.mapM decodeVariantValue = some (contract.measure state) + | _ => False + fuelExact : finFormula.evaluator.fuel = fuel ∧ varFormula.evaluator.fuel = fuel + varActionExact : eventActionExact eventSource fuel varFormula.encode + (fun state : γ × γ => contract.action (stateOf state.1) (stateOf state.2)) + +theorem FiniteSetVariantAdapter.sound {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {σ : Type u} {α : Type v} {γ : Type u} + {contract : FiniteSetVariant σ α} + (adapter : FiniteSetVariantAdapter (γ := γ) theory project contract) : + finiteVariantFiniteness contract ∧ finiteVariantProgressSemantic contract := + ⟨adapter.finFormula.adequate adapter.finFormula.valid, by + intro before after action + obtain ⟨before', beforeEq⟩ := adapter.stateCoverage before + obtain ⟨after', afterEq⟩ := adapter.stateCoverage after + have stateAction : contract.action (adapter.stateOf before') (adapter.stateOf after') := by + simpa [beforeEq, afterEq] using action + have encodedAction := + (adapter.varFormula.adequate adapter.varFormula.valid) (before', after') stateAction + simpa [beforeEq, afterEq] using encodedAction⟩ + +/- Restricted finite variants use an explicit semantic state domain and a source-indexed + VAR carrier. Unlike the legacy adapter above, the VAR formula is not quantified over + every semantic pair; only states in `η` whose encoding is a checked source transition + are admitted. -/ +structure RestrictedFiniteSetVariantAdapter (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) {σ : Type u} {α : Type v} {γ : Type u} + {η : Type u} (contract : FiniteSetVariant σ α) where + finBinding : CheckedPO theory project + varBinding : CheckedPO theory project + finKind : finBinding.obligation.kind = "FIN" + varKind : varBinding.obligation.kind = "VAR" + componentMatch : varBinding.obligation.component = finBinding.obligation.component + eventLabel : String + eventSource : CheckedEventSource theory project finBinding.obligation.component eventLabel + variantSource : CheckedVariantSource project finBinding.obligation.component + finName : finBinding.obligation.name = "FIN" + varName : varBinding.obligation.name = eventLabel ++ "/VAR" + convergence : String + convergenceExact : + EventB.POG.eventConvergenceMode? project finBinding.obligation.component eventLabel = + some convergence + modeExact : match contract.mode with + | .anticipated => convergence = "2" + | .convergent => convergence = "1" + fuel : Nat + stateOf : γ → σ + stateCoverage : ∀ state, ∃ encoded, stateOf encoded = state + finGoalExact : finBinding.obligation.goal = + some (.app (.id "finite") variantSource.expression) + semanticDomain : ValueEnv → Prop + finFormula : DomainFormulaAdequacy finBinding σ + (finiteVariantFiniteness contract) + semanticDomain + finitenessExact : ∀ state, + contract.finite state ↔ + finFormula.evaluator.denote + (.app (.id "finite") variantSource.expression) + (finFormula.encode state) + varState : Type u + varBefore : varState → γ + varAfter : varState → γ + /-- The source relation may restrict checked event transitions to the invariant + domain represented by `semanticDomain`. -/ + varSource : CheckedBeforeAfter → Prop + varSourceExact : ∀ transition, + varSource transition ↔ + eventSource.assignmentAction fuel transition ∧ + semanticDomain transition.before ∧ semanticDomain transition.after + varFormula : TransitionFormulaAdequacy varBinding varState + (∀ state : varState, + contract.action (stateOf (varBefore state)) (stateOf (varAfter state)) → + finiteVariantProgress contract.mode + (contract.measure (stateOf (varAfter state))) + (contract.measure (stateOf (varBefore state)))) + varSource + varPairCoverage : ∀ before after, + contract.action (stateOf before) (stateOf after) → + ∃ state, varBefore state = before ∧ varAfter state = after + varActionExact : ∀ state, + contract.action (stateOf (varBefore state)) (stateOf (varAfter state)) ↔ + varSource (varFormula.encode state) + fuelExact : finFormula.evaluator.fuel = fuel ∧ varFormula.evaluator.fuel = fuel + +theorem RestrictedFiniteSetVariantAdapter.sound {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {σ : Type u} {α : Type v} {γ : Type u} + {η : Type u} {contract : FiniteSetVariant σ α} + (adapter : RestrictedFiniteSetVariantAdapter (η := η) (γ := γ) + theory project contract) : + finiteVariantFiniteness contract ∧ finiteVariantProgressSemantic contract := by + constructor + · exact adapter.finFormula.adequate adapter.finFormula.valid + · intro before after action + obtain ⟨before', beforeEq⟩ := adapter.stateCoverage before + obtain ⟨after', afterEq⟩ := adapter.stateCoverage after + have stateAction : contract.action (adapter.stateOf before') + (adapter.stateOf after') := by + simpa [beforeEq, afterEq] using action + obtain ⟨state, beforeStateEq, afterStateEq⟩ := + adapter.varPairCoverage before' after' stateAction + have stateAction' : contract.action (adapter.stateOf (adapter.varBefore state)) + (adapter.stateOf (adapter.varAfter state)) := by + simpa [beforeStateEq, afterStateEq] using stateAction + have progress := (adapter.varFormula.adequate adapter.varFormula.valid) state stateAction' + simpa [beforeEq, afterEq, beforeStateEq, afterStateEq] using progress + +/- The current VAR carrier is deliberately diagnosed here: surjective semantic-state + coverage plus source validity and action exactness forces every semantic pair to be + an Event-B source transition. This is acceptable for the constant fixture, but it + prevents a non-total state-dependent finite-set action from inhabiting the adapter. -/ +theorem FiniteSetVariantAdapter.actionTotal {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {σ : Type u} {α : Type v} {γ : Type u} + {contract : FiniteSetVariant σ α} + (adapter : FiniteSetVariantAdapter (γ := γ) theory project contract) : + ∀ before after, contract.action before after := by + intro before after + obtain ⟨before', beforeEq⟩ := adapter.stateCoverage before + obtain ⟨after', afterEq⟩ := adapter.stateCoverage after + have source := adapter.varFormula.sourceValid (before', after') + have action := (adapter.varActionExact (before', after')).mpr source + simpa [beforeEq, afterEq] using action + +/- The source equalities are intentionally redundant with the names above: they make + the NAT/VAR pairing a checked identity, rather than a caller convention. -/ +def finiteVariantSourceMatch (source : String) (nat var : Obligation) : Bool := + nat.kind == "NAT" && var.kind == "VAR" && + nat.name == source ++ "/NAT" && var.name == source ++ "/VAR" + +def finiteSetVariantSourceMatch (source : String) (fin var : Obligation) : Bool := + fin.kind == "FIN" && var.kind == "VAR" && + fin.name == "FIN" && var.name == source ++ "/VAR" + +#guard finiteVariantSourceMatch "step" + { name := "step/NAT", kind := "NAT" } + { name := "step/VAR", kind := "VAR" } +#guard !finiteVariantSourceMatch "step" + { name := "other/NAT", kind := "NAT" } + { name := "step/VAR", kind := "VAR" } + +private def finiteVariantProject : 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 ∈ ℤ") ] [] + , .variant [ ("org.eventb.core.expression", "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") + , ("org.eventb.core.convergence", "1") ] + [ .action [ ("org.eventb.core.label", "set") + , ("org.eventb.core.assignment", "x ≔ x") ] [] ] ] }] + +private def theoremFixtureProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [ .invariant [("org.eventb.core.label", "taut"), + ("org.eventb.core.theorem", "true"), + ("org.eventb.core.predicate", "1 = 1")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] + [] ] }] + +#guard match generateCheckedIn EventB.Theory.empty theoremFixtureProject "M" with + | .ok obligations => + match obligations.find? (fun obligation => obligation.kind == "THM") with + | some thm => thm.name == "taut/THM" && + Obligation.sourceBound theoremFixtureProject thm + | none => false + | .error _ => false + +#guard (CheckedPO.fromGenerated? EventB.Theory.empty theoremFixtureProject "M" + (fun obligation => obligation.kind == "THM" && obligation.name == "taut/THM")).isSome + +private def positiveThmObligation : Obligation := + { component := "M", name := "taut/THM", kind := "THM" + goal := some (.bin "=" (.num 1) (.num 1)) } + +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty theoremFixtureProject + positiveThmObligation).isSome + +private def positiveThmPO : CheckedPO EventB.Theory.empty theoremFixtureProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty theoremFixtureProject + positiveThmObligation).get (by native_decide) + +private theorem positiveThmPO_obligation : + positiveThmPO.obligation = positiveThmObligation := by + native_decide + +private abbrev theoremState := + { env : ValueEnv // ValueEnv.validationOk 128 [] env = true } + +private def positiveThmAdapter : + ThmAdapter EventB.Theory.empty theoremFixtureProject theoremState := + { binding := positiveThmPO + sourceLabel := "taut" + kind := by native_decide + sourceName := by native_decide + hypotheses := fun _ => True + goal := fun _ => True + formula := + { evaluator := constantTypedFormulaModel + encode := fun state => state.1 + declarationScope := none + declarationsBound := by + have component : positiveThmPO.obligation.component = "M" := by native_decide + rw [component] + change exactComponentDeclarations? EventB.Theory.empty theoremFixtureProject "M" = some [] + native_decide + stateValid := by + intro state + exact state.2 + stateComplete := by + intro env h + exact ⟨⟨env, h⟩, rfl⟩ + evaluatorValid := by + rw [positiveThmPO_obligation] + exact constantTypedFormulaModel_taut_valid + adequate := by + intro _ _ _ + trivial } } + +example : implicationSemantic positiveThmAdapter.hypotheses positiveThmAdapter.goal := + positiveThmAdapter.sound + +private def invariantFixtureProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [ .invariant [("org.eventb.core.label", "taut"), + ("org.eventb.core.predicate", "1 = 1")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] ] }] + +private def positiveInvObligation : Obligation := + { component := "M", name := "INITIALISATION/taut/INV", kind := "INV" + goal := some (.bin "=" (.num 1) (.num 1)) } + +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty invariantFixtureProject + positiveInvObligation).isSome + +private def positiveInvPO : CheckedPO EventB.Theory.empty invariantFixtureProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty invariantFixtureProject + positiveInvObligation).get (by native_decide) + +private theorem positiveInvPO_obligation : + positiveInvPO.obligation = positiveInvObligation := by + native_decide + +private def invariantFixtureSource : CheckedEventSource EventB.Theory.empty + invariantFixtureProject "M" "INITIALISATION" := + (CheckedEventSource.fromProject EventB.Theory.empty invariantFixtureProject "M" + "INITIALISATION").get (by native_decide) + +private def invariantFixtureTransition : CheckedBeforeAfter := + { before := {}, after := {}, declarations := [] } + +private theorem invariantFixtureAssignment : + assignmentRelation 128 [] invariantFixtureTransition [] := by + constructor + · rfl + constructor + · native_decide + constructor + · native_decide + · rfl + +private def positiveInvSource : CheckedEventSource EventB.Theory.empty + invariantFixtureProject positiveInvPO.obligation.component "INITIALISATION" := by + have component : positiveInvPO.obligation.component = "M" := by native_decide + rw [component] + exact invariantFixtureSource + +private def positiveInvGuardSource : CheckedGuardSource EventB.Theory.empty + invariantFixtureProject positiveInvPO.obligation.component "INITIALISATION" := by + have component : positiveInvPO.obligation.component = "M" := by native_decide + rw [component] + exact (CheckedGuardSource.fromProject EventB.Theory.empty invariantFixtureProject + "M" "INITIALISATION").get (by native_decide) + +private abbrev invariantSourceState := + { transition : CheckedBeforeAfter // + positiveInvSource.assignmentAction 128 transition } + +private def invariantSourceModel : TypedTransitionModel := + { fuel := 128 + wellFormed := positiveInvSource.assignmentAction 128 + inhabited := ⟨invariantFixtureTransition, by + change assignmentRelation 128 positiveInvSource.declarations + invariantFixtureTransition positiveInvSource.updates + have declarations : positiveInvSource.declarations = [] := by native_decide + have updates : positiveInvSource.updates = [] := by native_decide + rw [declarations, updates] + exact invariantFixtureAssignment⟩ + supports := fun _ => true } + +private def positiveInvAdapter : InvAdapter EventB.Theory.empty invariantFixtureProject + invariantSourceState := + { binding := positiveInvPO + eventLabel := "INITIALISATION" + invariantLabel := "taut" + kind := by native_decide + sourceName := by native_decide + eventSource := positiveInvSource + guardSource := positiveInvGuardSource + event := { grd := fun _ => True, act := fun _ _ => True } + invariant := fun _ => True + formula := + { evaluator := invariantSourceModel + encode := fun state => state.1.1 + declarations := [] + declarationScope := some "INITIALISATION" + declarationsBound := by + have component : positiveInvPO.obligation.component = "M" := by native_decide + rw [component] + change exactEventDeclarations? EventB.Theory.empty invariantFixtureProject "M" + "INITIALISATION" = some [] + native_decide + transitionDeclarations := by + intro state + change state.1.1.declarations = [] + have declarations : positiveInvSource.declarations = [] := by native_decide + rcases state.1.2 with ⟨declared, beforeValid, afterValid, assigned⟩ + simpa [declarations] using declared + transitionValid := by intro state; exact state.1.2 + sourceValid := by intro state; exact state.1.2 + sourceComplete := by + intro transition h + exact ⟨(⟨transition, h⟩, ⟨transition, h⟩), rfl⟩ + evaluatorValid := by + set_option maxRecDepth 100000 in + simpa only [positiveInvPO_obligation] using + (typedTransitionModel_taut_validOnDomain invariantSourceModel + (positiveInvSource.assignmentAction 128) + (by + intro transition source + rcases source with ⟨declared, beforeValid, afterValid, assigned⟩ + constructor + · simpa [declared] using beforeValid + · simpa [declared] using afterValid) + positiveInvObligation (by native_decide) (by native_decide) + (by native_decide) (by native_decide) (by rfl) + (by intro _; rfl)) + adequate := by + intro _ + intro before after _ _ _ + trivial } + fuel := 128 + fuelExact := by rfl + actionExact := by + intro state + constructor + · intro _ + exact state.1.2 + · intro _ + trivial + guardExact := by + intro state + have declarations : positiveInvGuardSource.declarations = [] := by native_decide + have predicates : positiveInvGuardSource.predicates = [] := by native_decide + have source : positiveInvSource.declarations = [] := by native_decide + rcases state.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 + nonempty := by + let state : invariantSourceState := ⟨invariantFixtureTransition, by + change assignmentRelation 128 positiveInvSource.declarations + invariantFixtureTransition positiveInvSource.updates + have declarations : positiveInvSource.declarations = [] := by native_decide + have updates : positiveInvSource.updates = [] := by native_decide + rw [declarations, updates] + exact invariantFixtureAssignment⟩ + exact ⟨state, state, trivial, trivial⟩ } + +example : invariantSemantic positiveInvAdapter.event positiveInvAdapter.invariant := + positiveInvAdapter.sound + +private def grdFixtureProject : EventB.Typing.Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [ .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [ .guard [("org.eventb.core.label", "g"), + ("org.eventb.core.predicate", "1 = 1")] [] ] ] } + , { name := "C" + elem := .machineFile [("org.eventb.core.name", "C")] + [ .refinesMachine [("org.eventb.core.target", "A")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] [] + , .event [("org.eventb.core.label", "step")] + [ .refinesEvent [("org.eventb.core.target", "A/step")] [] ] ] }] + +#guard match generateCheckedIn EventB.Theory.empty grdFixtureProject "C" with + | .ok obligations => obligations.any (fun obligation => + obligation.kind == "GRD" && obligation.name == "step/g/GRD") + | .error _ => false + +private def positiveGrdObligation : Obligation := + { component := "C", name := "step/g/GRD", kind := "GRD" + goal := some (.bin "=" (.num 1) (.num 1)) } + +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty grdFixtureProject + positiveGrdObligation).isSome +#guard !(CheckedPO.fromGeneratedExact? EventB.Theory.empty grdFixtureProject + { positiveGrdObligation with goal := some (.bin "=" (.num 1) (.num 2)) }).isSome +#guard !(CheckedPO.fromGeneratedExact? EventB.Theory.empty grdFixtureProject + { positiveGrdObligation with component := "A" }).isSome + +private def positiveGrdPO : CheckedPO EventB.Theory.empty grdFixtureProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty grdFixtureProject + positiveGrdObligation).get (by native_decide) + +private def positiveGrdSource : CheckedEventSource EventB.Theory.empty + grdFixtureProject positiveGrdPO.obligation.component "step" := by + have component : positiveGrdPO.obligation.component = "C" := by native_decide + rw [component] + exact (CheckedEventSource.fromProject EventB.Theory.empty grdFixtureProject "C" "step").get + (by native_decide) + +private def positiveGrdGuardSource : CheckedGuardSource EventB.Theory.empty + grdFixtureProject positiveGrdPO.obligation.component "step" := by + have component : positiveGrdPO.obligation.component = "C" := by native_decide + rw [component] + exact (CheckedGuardSource.fromProject EventB.Theory.empty grdFixtureProject + "C" "step").get (by native_decide) + +private abbrev grdSourceState := + { transition : CheckedBeforeAfter // + positiveGrdSource.assignmentAction 128 transition } + +private def grdSourceModel : TypedTransitionModel := + { fuel := 128 + wellFormed := positiveGrdSource.assignmentAction 128 + inhabited := ⟨invariantFixtureTransition, by + change assignmentRelation 128 positiveGrdSource.declarations + invariantFixtureTransition positiveGrdSource.updates + have declarations : positiveGrdSource.declarations = [] := by native_decide + have updates : positiveGrdSource.updates = [] := by native_decide + rw [declarations, updates] + exact invariantFixtureAssignment⟩ + supports := fun _ => true } + +private def positiveGrdAdapter : GrdAdapter EventB.Theory.empty grdFixtureProject + grdSourceState Unit := + { binding := positiveGrdPO + concreteLabel := "step" + abstractLabel := "g" + kind := by native_decide + sourceName := by native_decide + eventSource := positiveGrdSource + guardSource := positiveGrdGuardSource + gluing := fun _ _ => True + concrete := + { grd := fun _ => True + act := fun before _ => positiveGrdSource.assignmentAction 128 before.1 } + abstract := { grd := fun _ => True, act := fun _ _ => True } + formula := + { evaluator := grdSourceModel + encode := fun state => state.1.1.1 + declarations := [] + declarationScope := some "step" + declarationsBound := by + have component : positiveGrdPO.obligation.component = "C" := by native_decide + rw [component] + change exactEventDeclarations? EventB.Theory.empty grdFixtureProject "C" "step" = some [] + native_decide + transitionDeclarations := by + intro state + change state.1.1.1.declarations = [] + have declarations : positiveGrdSource.declarations = [] := by native_decide + rcases state.1.1.2 with ⟨declared, beforeValid, afterValid, assigned⟩ + simpa [declarations] using declared + transitionValid := by intro state; exact state.1.1.2 + sourceValid := by intro state; exact state.1.1.2 + sourceComplete := by + intro transition h + exact ⟨((⟨transition, h⟩, ⟨transition, h⟩), ()), rfl⟩ + evaluatorValid := by + set_option maxRecDepth 100000 in + simpa only [show positiveGrdPO.obligation = positiveGrdObligation by native_decide] using + (typedTransitionModel_taut_validOnDomain grdSourceModel + (positiveGrdSource.assignmentAction 128) + (by + intro transition source + rcases source with ⟨declared, beforeValid, afterValid, assigned⟩ + constructor + · simpa [declared] using beforeValid + · simpa [declared] using afterValid) + positiveGrdObligation (by native_decide) (by native_decide) + (by native_decide) (by native_decide) (by rfl) + (by intro _; rfl)) + adequate := by + intro _ + intro concrete abstract _ _ + trivial } + fuel := 128 + fuelExact := by rfl + actionExact := by intro _; exact Iff.rfl + guardExact := by + intro state + have declarations : positiveGrdGuardSource.declarations = [] := by native_decide + have predicates : positiveGrdGuardSource.predicates = [] := by native_decide + have source : positiveGrdSource.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 + nonempty := by + let state : grdSourceState := ⟨invariantFixtureTransition, by + change assignmentRelation 128 positiveGrdSource.declarations + invariantFixtureTransition positiveGrdSource.updates + have declarations : positiveGrdSource.declarations = [] := by native_decide + have updates : positiveGrdSource.updates = [] := by native_decide + rw [declarations, updates] + exact invariantFixtureAssignment⟩ + exact ⟨state, (), trivial, trivial⟩ } + +example : guardSemantic positiveGrdAdapter.gluing + positiveGrdAdapter.concrete positiveGrdAdapter.abstract := + positiveGrdAdapter.sound + +private def simFixtureProject : EventB.Typing.Project := + [{ name := "A" + elem := .machineFile [("org.eventb.core.name", "A")] + [ .variable [("org.eventb.core.identifier", "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")] + [ .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ 1")] [] ] ] } + , { name := "C" + elem := .machineFile [("org.eventb.core.name", "C")] + [ .refinesMachine [("org.eventb.core.target", "A")] [] + , .variable [("org.eventb.core.identifier", "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")] + [ .refinesEvent [("org.eventb.core.target", "A/step")] [] + , .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ 1")] [] ] ] }] + +private def positiveSimObligation : Obligation := + { component := "C", name := "step/set/SIM", kind := "SIM" + hyps := [] + goal := some (.bin "=" (.num 1) (.num 1)) } + +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty simFixtureProject + positiveSimObligation).isSome +#guard !(CheckedPO.fromGeneratedExact? EventB.Theory.empty simFixtureProject + { positiveSimObligation with goal := some (.bin "=" (.id "x") (.num 1)) }).isSome +#guard !(CheckedPO.fromGeneratedExact? EventB.Theory.empty simFixtureProject + { positiveSimObligation with component := "A" }).isSome + +private def positiveSimPO : CheckedPO EventB.Theory.empty simFixtureProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty simFixtureProject + positiveSimObligation).get (by native_decide) + +private def positiveSimSource : CheckedEventSource EventB.Theory.empty + simFixtureProject positiveSimPO.obligation.component "step" := by + have component : positiveSimPO.obligation.component = "C" := by native_decide + rw [component] + exact (CheckedEventSource.fromProject EventB.Theory.empty simFixtureProject "C" "step").get + (by native_decide) + +private def positiveSimGuardSource : CheckedGuardSource EventB.Theory.empty + simFixtureProject positiveSimPO.obligation.component "step" := by + have component : positiveSimPO.obligation.component = "C" := by native_decide + rw [component] + exact (CheckedGuardSource.fromProject EventB.Theory.empty simFixtureProject + "C" "step").get (by native_decide) + +private def simFixtureTransition : CheckedBeforeAfter := + { before := { values := [("x", .integer 1)] } + after := { values := [("x", .integer 1)] } + declarations := [("x", .int)] } + +private theorem simFixtureAssignment : + assignmentRelation 128 [("x", .int)] simFixtureTransition [("x", .num 1)] := by + exact assignmentRelation_x_one + +private abbrev simSourceState := + { transition : CheckedBeforeAfter // + positiveSimSource.assignmentAction 128 transition } + +private def simFixtureState : simSourceState := ⟨simFixtureTransition, by + change assignmentRelation 128 positiveSimSource.declarations + simFixtureTransition positiveSimSource.updates + have declarations : positiveSimSource.declarations = [("x", .int)] := by + native_decide + have updates : positiveSimSource.updates = [("x", .num 1)] := by + native_decide + rw [declarations, updates] + exact simFixtureAssignment⟩ + +private def simSourceModel : TypedTransitionModel := + { fuel := 128 + wellFormed := positiveSimSource.assignmentAction 128 + inhabited := ⟨simFixtureTransition, simFixtureState.property⟩ + supports := fun _ => true } + +private def positiveSimAdapter : SimAdapter EventB.Theory.empty simFixtureProject + simSourceState Unit := + { binding := positiveSimPO + concreteLabel := "step" + abstractLabel := "set" + kind := by native_decide + sourceName := by native_decide + eventSource := positiveSimSource + guardSource := positiveSimGuardSource + abstractSourceBound := by native_decide + gluing := fun _ _ => True + concrete := + { grd := fun _ => True + act := fun before _ => positiveSimSource.assignmentAction 128 before.1 } + abstract := { grd := fun _ => True, act := fun _ _ => True } + formula := + { evaluator := simSourceModel + encode := fun state => state.1.1.1 + declarations := [("x", .int)] + declarationScope := some "step" + declarationsBound := by + have component : positiveSimPO.obligation.component = "C" := by native_decide + simp only [component] + change exactEventDeclarations? EventB.Theory.empty simFixtureProject "C" "step" = + some [("x", .int)] + native_decide + transitionDeclarations := by + intro state + rcases state.1.1.2 with ⟨declared, _, _, _⟩ + have sourceDeclarations : positiveSimSource.declarations = [("x", .int)] := 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⟩, simFixtureState), ()), rfl⟩ + evaluatorValid := by + set_option maxRecDepth 100000 in + simpa only [show positiveSimPO.obligation = positiveSimObligation by native_decide] using + (typedTransitionModel_taut_validOnDomain simSourceModel + (positiveSimSource.assignmentAction 128) + (by + intro transition source + rcases source with ⟨declared, beforeValid, afterValid, assigned⟩ + constructor + · simpa [declared] using beforeValid + · simpa [declared] using afterValid) + positiveSimObligation (by native_decide) (by native_decide) + (by native_decide) (by native_decide) (by rfl) + (by intro _; rfl)) + adequate := by + intro _ c c' a _ _ _ + exact ⟨a, trivial, trivial⟩ } + fuel := 128 + fuelExact := by rfl + actionExact := by + intro state + exact Iff.rfl + guardExact := by + intro state + have declarations : positiveSimGuardSource.declarations = [("x", .int)] := by + native_decide + have predicates : positiveSimGuardSource.predicates = [] := by native_decide + have source : positiveSimSource.declarations = [("x", .int)] := 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 + nonempty := by + exact ⟨simFixtureState, simFixtureState, (), trivial, trivial, + simFixtureState.property⟩ } + +example : actionSemantic positiveSimAdapter.gluing + positiveSimAdapter.concrete positiveSimAdapter.abstract := + positiveSimAdapter.sound + +/- Nondeterministic actions use the relational source binder below. -/ + +private def nondeterministicFixtureProject : 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", "choose"), + ("org.eventb.core.assignment", "x :∈ {0}")] [] ] ] }] + +#guard match generateCheckedIn EventB.Theory.empty nondeterministicFixtureProject "M" with + | .ok obligations => obligations.any (fun obligation => + obligation.kind == "FIS" && obligation.name == "INITIALISATION/choose/FIS") + | .error _ => false +#guard (CheckedEventSource.fromProject EventB.Theory.empty nondeterministicFixtureProject + "M" "INITIALISATION").isNone + +private def positiveFisObligation : Obligation := + { component := "M", name := "INITIALISATION/choose/FIS", kind := "FIS" + goal := some (.bin "≠" (.set [.num 0]) (.set [])) } + +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty nondeterministicFixtureProject + positiveFisObligation).isSome +#guard !(CheckedPO.fromGeneratedExact? EventB.Theory.empty nondeterministicFixtureProject + { positiveFisObligation with goal := some (.bin "≠" (.set [.num 1]) (.set [])) }).isSome +#guard !(CheckedPO.fromGeneratedExact? EventB.Theory.empty nondeterministicFixtureProject + { positiveFisObligation with component := "N" }).isSome + +private def positiveFisPO : + CheckedPO EventB.Theory.empty nondeterministicFixtureProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty nondeterministicFixtureProject + positiveFisObligation).get (by native_decide) + +private def positiveFisSource : CheckedRelationalEventSource EventB.Theory.empty + nondeterministicFixtureProject positiveFisPO.obligation.component "INITIALISATION" := by + have component : positiveFisPO.obligation.component = "M" := by native_decide + rw [component] + exact (CheckedRelationalEventSource.fromProject EventB.Theory.empty + nondeterministicFixtureProject "M" "INITIALISATION").get (by native_decide) + +#guard positiveFisSource.relations == + [.bin "∈" (.id "x'") (.set [.num 0])] + +private def fisFixtureTransition : CheckedBeforeAfter := + { before := { values := [("x", .integer 0)] } + after := { values := [("x", .integer 0)] } + declarations := [("x", .int)] } + +private theorem fisFixtureRelation : + positiveFisSource.relationAction 128 fisFixtureTransition := by + have declarations : positiveFisSource.declarations = [("x", .int)] := by + native_decide + have relations : positiveFisSource.relations = + [.bin "∈" (.id "x'") (.set [.num 0])] := by + native_decide + unfold CheckedRelationalEventSource.relationAction + constructor + · simpa [declarations, fisFixtureTransition] + constructor + · native_decide + constructor + · native_decide + · intro relation member + simp only [relations, List.mem_singleton] at member + subst relation + exact assignmentPredicate_x_prime_in_zero + +private abbrev fisSourceState := + { transition : CheckedBeforeAfter // + positiveFisSource.relationAction 128 transition } + +private def fisFixtureState : fisSourceState := ⟨fisFixtureTransition, fisFixtureRelation⟩ + +private def fisSourceModel : TypedTransitionModel := + { fuel := 128 + wellFormed := positiveFisSource.relationAction 128 + inhabited := ⟨fisFixtureTransition, fisFixtureRelation⟩ + supports := fun _ => true } + +private def positiveFisAdapter : FisAdapter EventB.Theory.empty + nondeterministicFixtureProject fisSourceState := + { binding := positiveFisPO + eventLabel := "INITIALISATION" + actionLabel := "choose" + kind := by native_decide + sourceName := by native_decide + eventSource := positiveFisSource + pre := fun _ => True + action := fun _ _ => True + fuel := 128 + formula := + { evaluator := fisSourceModel + encode := fun state => state.1.1 + declarations := [("x", .int)] + declarationScope := some "INITIALISATION" + declarationsBound := by + have component : positiveFisPO.obligation.component = "M" := by native_decide + simp only [component] + change exactEventDeclarations? EventB.Theory.empty nondeterministicFixtureProject + "M" "INITIALISATION" = some [("x", .int)] + native_decide + transitionDeclarations := by + intro state + rcases state.1.2 with ⟨declared, _, _, _⟩ + have sourceDeclarations : positiveFisSource.declarations = [("x", .int)] := by + native_decide + simpa [sourceDeclarations] using declared + transitionValid := by + intro state + exact state.1.2 + sourceValid := by + intro state + exact state.1.2 + sourceComplete := by + intro transition source + exact ⟨(⟨transition, source⟩, fisFixtureState), rfl⟩ + evaluatorValid := by + simpa only [show positiveFisPO.obligation = positiveFisObligation by native_decide] using + (typedTransitionModel_closed_validOnDomain fisSourceModel + (positiveFisSource.relationAction 128) + (by + intro transition source + rcases source with ⟨declared, beforeValid, afterValid, _⟩ + exact ⟨by simpa [declared] using beforeValid, + by simpa [declared] using afterValid⟩) + positiveFisObligation (by native_decide) (by native_decide) + (.bin "≠" (.set [.num 0]) (.set [])) (by native_decide) (by native_decide) + (by rfl) (by rfl) + (by + intro transition source + rcases source 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 + exact evalBeforeAfterZeroSetNeEmpty transition beforeValid' afterValid')) + adequate := by + intro _ before _ + exact ⟨before, trivial⟩ } + fuelExact := by rfl + actionExact := by + intro state + constructor + · intro _ + exact state.1.2 + · intro _ + trivial + nonempty := ⟨fisFixtureState, trivial⟩ } + +example : feasibilitySemantic positiveFisAdapter.pre positiveFisAdapter.action := + positiveFisAdapter.sound + +/- Minimal model-derived witness matrix. The denominator is the literal one so + WFIS remains executable while WWD still exercises the generated definedness + obligation; the adapter's semantic witness bridge remains a later boundary. -/ + +private def witnessFixtureProject : EventB.Typing.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", "1 = 1")] [], + .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", "1 = 1")] [], + .witness [("org.eventb.core.label", "p"), + ("org.eventb.core.predicate", "p = 0 ÷ 1")] [], + .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ q")] [] + ] + ] } + ] + +private def positiveWfisObligation : Obligation := + { component := "B", name := "step/p/WFIS", kind := "WFIS" + hyps := [.bin "=" (.num 1) (.num 1)] + goal := some (.bind "∃" (.bin "⦂" (.id "p") (.id "ℤ")) + (.bin "=" (.id "p") (.bin "÷" (.num 0) (.num 1)))) } + +private def positiveWwdObligation : Obligation := + { component := "B", name := "step/p/WWD", kind := "WWD" + hyps := [.bin "=" (.num 1) (.num 1), + .bin "≠" (.num 1) (.num 0)] } + +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty witnessFixtureProject + positiveWfisObligation).isSome +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty witnessFixtureProject + positiveWwdObligation).isSome +#guard !(CheckedPO.fromGeneratedExact? EventB.Theory.empty witnessFixtureProject + { positiveWfisObligation with + goal := some (.bind "∃" (.bin "⦂" (.id "p") (.id "ℤ")) + (.bin "=" (.id "p") (.num 1))) }).isSome +#guard !(CheckedPO.fromGeneratedExact? EventB.Theory.empty witnessFixtureProject + { positiveWwdObligation with component := "A" }).isSome + +private def positiveWfisPO : + CheckedPO EventB.Theory.empty witnessFixtureProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty witnessFixtureProject + positiveWfisObligation).get (by native_decide) + +private def positiveWwdPO : + CheckedPO EventB.Theory.empty witnessFixtureProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty witnessFixtureProject + positiveWwdObligation).get (by native_decide) + +private def positiveWitnessEventSource : CheckedEventSource EventB.Theory.empty + witnessFixtureProject positiveWfisPO.obligation.component "step" := by + have component : positiveWfisPO.obligation.component = "B" := by native_decide + rw [component] + exact (CheckedEventSource.fromProject EventB.Theory.empty witnessFixtureProject + "B" "step").get (by native_decide) + +#guard positiveWitnessEventSource.updates == [("x", .id "q")] +#guard (CheckedWitnessSource.fromProject EventB.Theory.empty witnessFixtureProject + "B" "step" "p").isSome +#guard (CheckedWitnessSource.fromProject EventB.Theory.empty witnessFixtureProject + "B" "step" "missing").isNone +#guard positiveWfisPO.obligation.name == "step/p/WFIS" +#guard positiveWwdPO.obligation.name == "step/p/WWD" + +private def positiveWitnessSource : CheckedWitnessSource EventB.Theory.empty + witnessFixtureProject "B" "step" "p" := + (CheckedWitnessSource.fromProject EventB.Theory.empty witnessFixtureProject + "B" "step" "p").get (by native_decide) + +private def witnessFormulaModel : TypedFormulaModel := + { declarations := [("x", .int), ("q", .int), ("p", .int)] + fuel := 128 + wellFormed := fun env => + ValueEnv.validationOk 128 [("x", .int), ("q", .int), ("p", .int)] env = true + inhabited := ⟨{ values := [("x", .integer 0), ("q", .integer 0), ("p", .integer 0)] }, + by native_decide⟩ + validated := fun _ proof => proof + complete := fun _ proof => proof + supports := supportsPredicate } + +private abbrev witnessState := + { env : ValueEnv // + ValueEnv.validationOk 128 [("x", .int), ("q", .int), ("p", .int)] env = true } + +private theorem witnessFormulaModel_wfis_valid : + TypedFormulaModel.validUnchecked witnessFormulaModel positiveWfisObligation := by + constructor + · native_decide + constructor + · rfl + · intro env _ + constructor + · constructor + · refine ⟨true, ?_⟩ + exact evalWitnessIntegerZeroDivOne env + · intro hypothesis member + simp only [positiveWfisObligation, List.mem_singleton] at member + subst hypothesis + refine ⟨true, ?_⟩ + exact evalPredicateIntegerOneEqOne env + · intro _ + exact evalWitnessIntegerZeroDivOne env + +private theorem witnessFormulaModel_wwd_valid : + TypedFormulaModel.validUnchecked witnessFormulaModel positiveWwdObligation := by + constructor + · native_decide + · intro env _ hypothesis member + simp only [positiveWwdObligation] at member + simp only [List.mem_cons, List.mem_singleton] at member + rcases member with h | h + · have h' : hypothesis = .bin "=" (.num 1) (.num 1) := by + simpa using h + subst hypothesis + exact ⟨⟨true, evalPredicateIntegerOneEqOne env⟩, + evalPredicateIntegerOneEqOne env⟩ + · have h' : hypothesis = .bin "≠" (.num 1) (.num 0) := by + simpa using h + subst hypothesis + exact ⟨⟨true, evalPredicateIntegerOneNeZero env⟩, + evalPredicateIntegerOneNeZero env⟩ + +private def positiveWwdSource : CheckedWitnessSource EventB.Theory.empty + witnessFixtureProject "B" "step" "p" := positiveWitnessSource + +private def positiveWfisAdapterSource : CheckedWitnessSource EventB.Theory.empty + witnessFixtureProject positiveWfisPO.obligation.component "step" "p" := by + have component : positiveWfisPO.obligation.component = "B" := by native_decide + rw [component] + exact positiveWitnessSource + +private def positiveWwdAdapterSource : CheckedWitnessSource EventB.Theory.empty + witnessFixtureProject positiveWwdPO.obligation.component "step" "p" := by + have component : positiveWwdPO.obligation.component = "B" := by native_decide + rw [component] + exact positiveWitnessSource + +private def positiveWfisAdapter : WfisAdapter EventB.Theory.empty + witnessFixtureProject witnessState Int := + { binding := positiveWfisPO + eventLabel := "step" + witnessLabel := "p" + kind := by native_decide + sourceName := by native_decide + eventSource := positiveWfisAdapterSource + sourcePredicate := positiveWfisAdapterSource.predicate + sourcePredicateExact := rfl + pre := fun _ => True + defined := fun _ => True + predicate := fun _ witness => witness = (0 : Int) + contract := + { feasible := by + intro _ _ + exact ⟨0, rfl⟩ + wellDefined := by + intro _ _ + trivial } + formula := + { evaluator := witnessFormulaModel + encode := fun state => state.1 + declarationScope := some "step" + declarationsBound := by + have component : positiveWfisPO.obligation.component = "B" := by native_decide + simp only [component] + change exactEventDeclarations? EventB.Theory.empty witnessFixtureProject "B" "step" = + some [("x", .int), ("q", .int), ("p", .int)] + native_decide + stateValid := by + intro state + exact state.2 + stateComplete := by + intro env proof + exact ⟨⟨env, proof⟩, rfl⟩ + evaluatorValid := by + simpa only [show positiveWfisPO.obligation = positiveWfisObligation by native_decide] + using witnessFormulaModel_wfis_valid + adequate := by + intro _ state _ + exact ⟨0, rfl⟩ } + nonempty := by + exact ⟨⟨{ values := [("x", .integer 0), ("q", .integer 0), ("p", .integer 0)] }, + by native_decide⟩, + trivial⟩ } + +private def positiveWwdAdapter : WwdAdapter EventB.Theory.empty + witnessFixtureProject witnessState Int := + { binding := positiveWwdPO + eventLabel := "step" + witnessLabel := "p" + kind := by native_decide + sourceName := by native_decide + eventSource := positiveWwdAdapterSource + sourcePredicate := positiveWwdAdapterSource.predicate + sourcePredicateExact := rfl + pre := fun _ => True + defined := fun _ => True + predicate := fun _ witness => witness = (0 : Int) + contract := + { feasible := by + intro _ _ + exact ⟨0, rfl⟩ + wellDefined := by + intro _ _ + trivial } + formula := + { evaluator := witnessFormulaModel + encode := fun state => state.1 + declarationScope := some "step" + declarationsBound := by + have component : positiveWwdPO.obligation.component = "B" := by native_decide + simp only [component] + change exactEventDeclarations? EventB.Theory.empty witnessFixtureProject "B" "step" = + some [("x", .int), ("q", .int), ("p", .int)] + native_decide + stateValid := by + intro state + exact state.2 + stateComplete := by + intro env proof + exact ⟨⟨env, proof⟩, rfl⟩ + evaluatorValid := by + simpa only [show positiveWwdPO.obligation = positiveWwdObligation by native_decide] using + witnessFormulaModel_wwd_valid + adequate := by + intro _ _ _ + trivial } } + +example : witnessFeasibilitySemantic positiveWfisAdapter.pre positiveWfisAdapter.predicate := + positiveWfisAdapter.sound + +example : witnessDefinednessSemantic positiveWwdAdapter.pre positiveWwdAdapter.defined := + positiveWwdAdapter.sound + +private def constantVariantProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [ .variable [("org.eventb.core.identifier", "x")] [] + , .variant [("org.eventb.core.expression", "0")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] + [ .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ 0")] [] ] + , .event [("org.eventb.core.label", "step"), + ("org.eventb.core.convergence", "2")] + [ .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ x")] [] ] ] }] + +private def constantNatObligation : Obligation := + { component := "M", name := "step/NAT", kind := "NAT" + goal := some (.bin "∈" (.num 0) (.id "ℕ")) } + +private def constantVarObligation : Obligation := + { component := "M", name := "step/VAR", kind := "VAR" + goal := some (.bin "≤" (.num 0) (.num 0)) } + +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty constantVariantProject + constantNatObligation).isSome +#guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty constantVariantProject + constantVarObligation).isSome +#guard (CheckedVariantSource.fromProject constantVariantProject "M").isSome + +private def constantNatPO : CheckedPO EventB.Theory.empty constantVariantProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty constantVariantProject + constantNatObligation).get (by native_decide) + +private def constantVarPO : CheckedPO EventB.Theory.empty constantVariantProject := + (CheckedPO.fromGeneratedExact? EventB.Theory.empty constantVariantProject + constantVarObligation).get (by native_decide) + +private def constantVariantEventSource : CheckedEventSource EventB.Theory.empty + constantVariantProject "M" "step" := + (CheckedEventSource.fromProject EventB.Theory.empty constantVariantProject "M" "step").get + (by native_decide) + +private def constantVariantSource : CheckedVariantSource constantVariantProject "M" := + (CheckedVariantSource.fromProject constantVariantProject "M").get (by native_decide) + +private def constantNatEventSource : CheckedEventSource EventB.Theory.empty + constantVariantProject constantNatPO.obligation.component "step" := by + have component : constantNatPO.obligation.component = "M" := by native_decide + rw [component] + exact constantVariantEventSource + +private def constantNatVariantSource : CheckedVariantSource constantVariantProject + constantNatPO.obligation.component := by + have component : constantNatPO.obligation.component = "M" := by native_decide + rw [component] + exact constantVariantSource + +private def constantVariantTransition : CheckedBeforeAfter := + { before := { values := [("x", .integer 0)] } + after := { values := [("x", .integer 0)] } + declarations := [("x", .int)] } + +private theorem constantVariantAssignment : + constantNatEventSource.assignmentAction 128 constantVariantTransition := by + change assignmentRelation 128 constantNatEventSource.declarations + constantVariantTransition constantNatEventSource.updates + have declarations : constantNatEventSource.declarations = [("x", .int)] := by + native_decide + have updates : constantNatEventSource.updates = [("x", .id "x")] := by + native_decide + rw [declarations, updates] + exact assignmentRelation_x_self_zero + +private abbrev constantVariantState := + { transition : CheckedBeforeAfter // + constantNatEventSource.assignmentAction 128 transition } + +private def constantVariantStateValue : constantVariantState := + ⟨constantVariantTransition, constantVariantAssignment⟩ + +private def constantVariantModel : TypedTransitionModel := + { fuel := 128 + wellFormed := constantNatEventSource.assignmentAction 128 + inhabited := ⟨constantVariantTransition, constantVariantAssignment⟩ + supports := fun _ => true } + +private def constantIntegerVariant : IntegerVariant constantVariantState := + { source := "step" + mode := .anticipated + measure := fun _ => 0 + action := fun before _ => constantNatEventSource.assignmentAction 128 before.1 + natural := by intro; omega + progress := by + intro before after _ + simp [integerVariantProgress] } + +private def constantIntegerVariantAdapter : + IntegerVariantAdapter EventB.Theory.empty constantVariantProject constantVariantState := + { natBinding := constantNatPO + varBinding := constantVarPO + natKind := by native_decide + varKind := by native_decide + componentMatch := by native_decide + eventLabel := "step" + eventSource := constantNatEventSource + variantSource := constantNatVariantSource + natName := by native_decide + varName := by native_decide + contract := constantIntegerVariant + sourceMatch := by native_decide + fuel := 128 + natFormula := + { evaluator := constantVariantModel + encode := fun state => state.1.1 + declarations := [("x", .int)] + declarationScope := some "step" + declarationsBound := by + have component : constantNatPO.obligation.component = "M" := by native_decide + simp only [component] + change exactEventDeclarations? EventB.Theory.empty constantVariantProject "M" "step" = + some [("x", .int)] + native_decide + transitionDeclarations := by + intro state + rcases state.1.2 with ⟨declared, _, _, _⟩ + have sourceDeclarations : constantNatEventSource.declarations = [("x", .int)] := by + native_decide + simpa [sourceDeclarations] using declared + transitionValid := by intro state; exact state.1.2 + sourceValid := by intro state; exact state.1.2 + sourceComplete := by + intro transition source + exact ⟨(⟨transition, source⟩, constantVariantStateValue), rfl⟩ + evaluatorValid := by + simpa only [show constantNatPO.obligation = constantNatObligation by native_decide] using + (typedTransitionModel_closed_validOnDomain constantVariantModel + (constantNatEventSource.assignmentAction 128) + (by + intro transition source + rcases source with ⟨declared, beforeValid, afterValid, _⟩ + exact ⟨by simpa [declared] using beforeValid, + by simpa [declared] using afterValid⟩) + constantNatObligation (by native_decide) (by native_decide) + (.bin "∈" (.num 0) (.id "ℕ")) (by native_decide) (by native_decide) + (by rfl) (by rfl) + (by + intro transition source + rcases source 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 + exact evalBeforeAfterZeroNat transition beforeValid' afterValid')) + adequate := by intro _; exact constantIntegerVariant.natural } + varFormula := + { evaluator := constantVariantModel + encode := fun state => state.1.1 + declarations := [("x", .int)] + declarationScope := some "step" + declarationsBound := by + have component : constantVarPO.obligation.component = "M" := by native_decide + simp only [component] + change exactEventDeclarations? EventB.Theory.empty constantVariantProject "M" "step" = + some [("x", .int)] + native_decide + transitionDeclarations := by + intro state + rcases state.1.2 with ⟨declared, _, _, _⟩ + have sourceDeclarations : constantNatEventSource.declarations = [("x", .int)] := by + native_decide + simpa [sourceDeclarations] using declared + transitionValid := by intro state; exact state.1.2 + sourceValid := by intro state; exact state.1.2 + sourceComplete := by + intro transition source + exact ⟨(⟨transition, source⟩, constantVariantStateValue), rfl⟩ + evaluatorValid := by + simpa only [show constantVarPO.obligation = constantVarObligation by native_decide] using + (typedTransitionModel_closed_validOnDomain constantVariantModel + (constantNatEventSource.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 "≤" (.num 0) (.num 0)) (by native_decide) (by native_decide) + (by rfl) (by rfl) + (by + intro transition source + rcases source 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 + exact evalBeforeAfterZeroLeZero transition beforeValid' afterValid')) + adequate := by intro _; exact constantIntegerVariant.progress } + fuelExact := by constructor <;> rfl + natActionExact := by intro state; exact Iff.rfl + varActionExact := by intro state; exact Iff.rfl } + +example : integerVariantNaturality constantIntegerVariantAdapter.contract ∧ + integerVariantProgressSemantic constantIntegerVariantAdapter.contract := + constantIntegerVariantAdapter.sound + +/- A disjoint acceptance matrix. These rows deliberately do not reuse the larger + variant/event fixtures below: each mutation changes one provenance field while + still going through the checked generator and source binders. -/ +private def theoremMatrixGoal : EventB.Formula.Term := + .bin "=" (.num 1) (.num 1) + +private def theoremMatrixChecked? (goal : EventB.Formula.Term) : + Option (CheckedPO EventB.Theory.empty theoremFixtureProject) := + CheckedPO.fromGenerated? EventB.Theory.empty theoremFixtureProject "M" + (fun obligation => obligation.component == "M" && + obligation.kind == "THM" && obligation.name == "taut/THM" && + obligation.goal == some goal) + +#guard (theoremMatrixChecked? theoremMatrixGoal).isSome +#guard !(theoremMatrixChecked? (.bin "=" (.num 1) (.num 2))).isSome +#guard !(CheckedPO.fromGenerated? EventB.Theory.empty theoremFixtureProject "M" + (fun obligation => obligation.component == "N" && + obligation.kind == "THM" && obligation.name == "taut/THM" && + obligation.goal == some theoremMatrixGoal)).isSome + +private def sourceMatrixProject : 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")] + [ .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ x")] [] ] + , .event [("org.eventb.core.label", "other")] + [ .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ 1")] [] ] ] } + , { name := "N" + elem := .machineFile [("org.eventb.core.name", "N")] + [ .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")] + [ .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "x ≔ 2")] [] ] ] }] + +private def sourceMatrixUpdates? (component event : String) : + Option (List (String × EventB.Formula.Term)) := + (CheckedEventSource.fromProject EventB.Theory.empty sourceMatrixProject component event).map + (·.updates) + +#guard sourceMatrixUpdates? "M" "step" == some [("x", .id "x")] +#guard sourceMatrixUpdates? "M" "other" == some [("x", .num 1)] +#guard !(sourceMatrixUpdates? "M" "step" == some [("x", .num 1)]) +#guard (sourceMatrixUpdates? "M" "missing").isNone +#guard !(sourceMatrixUpdates? "M" "step" == sourceMatrixUpdates? "N" "step") + +private def variantMatrixProject : EventB.Typing.Project := + [{ name := "M" + elem := .machineFile [("org.eventb.core.name", "M")] + [ .variable [("org.eventb.core.identifier", "x")] [] + , .variant [("org.eventb.core.expression", "x")] [] ] } + , { name := "N" + elem := .machineFile [("org.eventb.core.name", "N")] + [ .variable [("org.eventb.core.identifier", "y")] [] + , .variant [("org.eventb.core.expression", "y")] [] ] }] + +private def variantMatrixExpression? (component : String) : Option EventB.Formula.Term := + (CheckedVariantSource.fromProject variantMatrixProject component).map (·.expression) + +#guard variantMatrixExpression? "M" == some (.id "x") +#guard variantMatrixExpression? "N" == some (.id "y") +#guard !(variantMatrixExpression? "M" == some (.id "y")) +#guard !(variantMatrixExpression? "M" == variantMatrixExpression? "N") +#guard (variantMatrixExpression? "missing").isNone + +#guard !(Obligation.sourceBound variantMatrixProject + { component := "M", name := "N/VAR", kind := "VAR" }) +#guard !(Obligation.sourceBound sourceMatrixProject + { component := "M", name := "missing/VAR", kind := "VAR" }) + +#guard match generateCheckedIn EventB.Theory.empty finiteVariantProject "M" with + | .ok obligations => + match obligations.find? (fun obligation => obligation.kind == "NAT"), + obligations.find? (fun obligation => obligation.kind == "VAR") with + | some nat, some var => finiteVariantSourceMatch "step" nat var + | _, _ => false + | .error _ => false + +private def finiteSetVariantProject : 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 ≔ ∅")] [] ] + , .event [("org.eventb.core.label", "step"), + ("org.eventb.core.convergence", "1")] + [ .action [("org.eventb.core.label", "set"), + ("org.eventb.core.assignment", "S ≔ S")] [] ] ] }] + +#guard match CheckedVariantSource.fromProject finiteSetVariantProject "M" with + | some source => EventB.Formula.print source.expression == "S" + | none => false + +#guard (CheckedPO.fromGenerated? EventB.Theory.empty finiteSetVariantProject "M" + (fun obligation => obligation.kind == "FIN" && obligation.name == "FIN")).isSome + +#guard (CheckedPO.fromGenerated? EventB.Theory.empty finiteSetVariantProject "M" + (fun obligation => obligation.kind == "VAR" && obligation.name == "step/VAR")).isSome + +#guard !(CheckedPO.fromGenerated? EventB.Theory.empty finiteSetVariantProject "M" + (fun obligation => obligation.kind == "FIN" && obligation.name == "step/FIN")).isSome + +#guard !(CheckedPO.fromGenerated? EventB.Theory.empty finiteSetVariantProject "M" + (fun obligation => obligation.kind == "VAR" && obligation.name == "other/VAR")).isSome + +#guard match + CheckedEventSource.fromProject EventB.Theory.empty finiteSetVariantProject "M" "step" with + | some source => source.updates == [("S", .id "S")] + | none => false + +#guard match + CheckedEventSource.fromProject EventB.Theory.empty finiteSetVariantProject "M" "missing" with + | none => true + | some _ => false + +#guard match generateCheckedIn EventB.Theory.empty finiteSetVariantProject "M" with + | .ok obligations => + match obligations.find? (fun (obligation : Obligation) => obligation.kind == "FIN"), + obligations.find? (fun (obligation : Obligation) => obligation.kind == "VAR") with + | some fin, some var => finiteSetVariantSourceMatch "step" fin var && + Obligation.sourceBound finiteSetVariantProject fin + | _, _ => false + | .error _ => false + +#guard !finiteSetVariantSourceMatch "step" + { name := "other/FIN", kind := "FIN" } + { name := "step/VAR", kind := "VAR" } + +end EventB.POG diff --git a/EventB/POGBridge.lean b/EventB/POGBridge.lean new file mode 100644 index 0000000..a2d6092 --- /dev/null +++ b/EventB/POGBridge.lean @@ -0,0 +1,70 @@ +/- +Checked semantic bridges for generated PO classes. + +These records are deliberately proof-carrying. A generated formula is not treated as +an Event-B semantic fact until the caller supplies the source binding, the semantic +precondition bridge, and the interpretation equivalence for the relevant contract. +-/ + +import EventB.POGSoundness +import EventB.Semantics + +namespace EventB.POG + +universe u + +def eqlTerm (varName : String) : EventB.Formula.Term := + .bin "=" (.id (varName ++ "'")) (.id varName) + +def transitionDenote (σ : Type u) := + EventB.Formula.Term → (σ × σ) → Prop + +def transitionHypothesesHold {σ : Type u} + (denote : transitionDenote σ) (hypotheses : List EventB.Formula.Term) + (before after : σ) : Prop := + ∀ hypothesis ∈ hypotheses, denote hypothesis (before, after) + +/- The source fields are intentionally redundant with `checked`: they make the + machine/event/variable identity visible to consumers and prevent an adapter from + silently changing the identity while reusing a proof. -/ +structure EqlBridge (σ : Type u) (α : Type u) where + theory : EventB.Theory.Env + project : EventB.Typing.Project + obligation : Obligation + event : String + varName : String + read : σ → α + action : σ → σ → Prop + denote : transitionDenote σ + checked : obligation.checkedIn theory project + sourceName : obligation.name = event ++ "/" ++ varName ++ "/EQL" + sourceKind : obligation.kind = "EQL" + sourceGoal : obligation.goal = some (eqlTerm varName) + hypothesesImplyAction : ∀ before after, + transitionHypothesesHold denote obligation.hyps before after → action before after + goalDenotesFrame : ∀ before after, + denote (eqlTerm varName) (before, after) ↔ read after = read before + frame : framePreserved read action + +def EqlBridge.valid {σ α : Type u} (bridge : EqlBridge σ α) : Prop := + validSequent + (bridge.obligation.hyps.map (fun hypothesis state => bridge.denote hypothesis state)) + (fun state => bridge.denote (eqlTerm bridge.varName) state) + +theorem EqlBridge.valid_of_frame {σ α : Type u} (bridge : EqlBridge σ α) : bridge.valid := by + intro state hypotheses + rcases state with ⟨before, after⟩ + have hypothesesHold : transitionHypothesesHold bridge.denote bridge.obligation.hyps + before after := by + intro hypothesis member + exact hypotheses (bridge.denote hypothesis) + (List.mem_map.mpr ⟨hypothesis, member, rfl⟩) + exact (bridge.goalDenotesFrame before after).mpr + (bridge.frame before after (bridge.hypothesesImplyAction before after hypothesesHold)) + +/- A source-bound bridge cannot be built from a changed EQL goal. This is a small + negative control independent of any evaluator implementation. -/ +example {σ α : Type u} (bridge : EqlBridge σ α) : + bridge.obligation.goal = some (eqlTerm bridge.varName) := bridge.sourceGoal + +end EventB.POG diff --git a/EventB/POGSoundness.lean b/EventB/POGSoundness.lean new file mode 100644 index 0000000..c03283f --- /dev/null +++ b/EventB/POGSoundness.lean @@ -0,0 +1,2477 @@ +/- +Explicit semantic boundary for generated proof obligations. + +The POG translates and names terms; this module lets a caller provide a model for +those terms and prove the resulting sequent. It does not guess the meaning of an +untyped formula, assignment, theory operator, or primed identifier. +-/ + +import EventB.POG +import EventB.Semantics + +namespace EventB.POG + +universe u + +structure FormulaModel (σ : Type u) where + denote : EventB.Formula.Term → σ → Prop + +def validSequent {σ : Type u} (hyps : List (σ → Prop)) (goal : σ → Prop) : Prop := + ∀ state, (∀ hypothesis ∈ hyps, hypothesis state) → goal state + +def validHypotheses {σ : Type u} (hyps : List (σ → Prop)) : Prop := + ∀ state, ∀ hypothesis ∈ hyps, hypothesis state + +/- This is deliberately named unchecked: a formula-shaped record is not a generated + Rodin obligation. The accepting entry point below requires exact membership in the + strict generator output. -/ +def FormulaModel.validUnchecked {σ : Type u} (model : FormulaModel σ) + (obligation : Obligation) : Prop := + match obligation.kind, obligation.goal with + | _, some goal => validSequent (obligation.hyps.map model.denote) (model.denote goal) + | "WWD", none => validHypotheses (obligation.hyps.map model.denote) + | _, none => False + +theorem validSequent.intro {σ : Type u} {hyps : List (σ → Prop)} {goal : σ → Prop} + (proof : ∀ state, (∀ hypothesis ∈ hyps, hypothesis state) → goal state) : + validSequent hyps goal := proof + +def Obligation.sourceBound (project : EventB.Typing.Project) + (obligation : Obligation) : Bool := + EventB.POG.generatedSourceBound project obligation + +def Obligation.checkedIn (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (obligation : Obligation) : Prop := + match generateCheckedIn theory project obligation.component with + | .ok generated => obligation ∈ generated ∧ obligation.sourceBound project = true + | .error _ => False + +/- A caller-defined `denote` function is useful for local algebraic fixtures, but it + is not a project semantics. Keep the name fail-closed until a source-bound + adequacy theorem ties it to the typed evaluator and the Rodin translation. -/ +def FormulaModel.valid {σ : Type u} (_model : FormulaModel σ) + (_theory : EventB.Theory.Env) (_project : EventB.Typing.Project) + (_obligation : Obligation) : Prop := + False + +theorem FormulaModel.valid_of {σ : Type u} (model : FormulaModel σ) + (obligation : Obligation) + (proof : validSequent (obligation.hyps.map model.denote) + (obligation.goal.map model.denote |>.getD fun _ => False)) : + obligation.goal.isSome → model.validUnchecked obligation := by + intro hasGoal + cases goal : obligation.goal with + | none => simp [goal] at hasGoal + | some target => + simpa [FormulaModel.validUnchecked, goal] using proof + +/- The generated POG surface is intentionally closed here. A new Rodin class must be + added to this table before a typed semantic adapter can accept it. -/ +inductive POClass where + | inv | wd | grd | sim | thm | fis | wfis | wwd + | eql | mrg | vwd | nat | fin | var + deriving BEq, Repr + +def POClass.ofKind : String → Option POClass + | "INV" => some .inv + | "WD" => some .wd + | "GRD" => some .grd + | "SIM" => some .sim + | "THM" => some .thm + | "FIS" => some .fis + | "WFIS" => some .wfis + | "WWD" => some .wwd + | "EQL" => some .eql + | "MRG" => some .mrg + | "VWD" => some .vwd + | "NAT" => some .nat + | "FIN" => some .fin + | "VAR" => some .var + | _ => none + +def POClass.valuationSupported : POClass → Bool + | .thm | .wd | .vwd | .wfis | .wwd | .fin => true + | _ => false + +def POClass.transitionValuationSupported : POClass → Bool + | .inv | .grd | .sim | .fis | .mrg | .eql | .nat | .var => true + | _ => false + +def Obligation.semanticShapeValid (obligation : Obligation) : Bool := + (POClass.ofKind obligation.kind).isSome && obligation.shapeValid && + !obligation.component.isEmpty && !obligation.name.isEmpty && obligation.diagnostics.isEmpty + +def Obligation.valuationSupported (obligation : Obligation) : Bool := + match POClass.ofKind obligation.kind with + | some poClass => poClass.valuationSupported + | none => false + +def Obligation.transitionValuationSupported (obligation : Obligation) : Bool := + match POClass.ofKind obligation.kind with + | some poClass => poClass.transitionValuationSupported + | none => false + +#guard (POClass.ofKind "INV").isSome +#guard (POClass.ofKind "MRG").isSome +#guard (POClass.ofKind "VAR").isSome +#guard (POClass.ofKind "unknown").isNone +#guard !({ name := "bad/unknown", kind := "unknown", goal := some (.id "⊤") } + : Obligation).semanticShapeValid +#guard !Obligation.valuationSupported + ({ component := "M", name := "pending/INV", kind := "INV", goal := some (.id "⊤") } : Obligation) +#guard !(Obligation.semanticShapeValid + ({ component := "M", name := "diagnostic/THM", kind := "THM", + diagnostics := ["unresolved"], goal := some (.id "⊤") } : Obligation)) + +/- ------------------------------------------------------------------ -/ +/- A small, executable semantic domain. Unsupported or ill-typed Event-B syntax returns + an explicit error; callers must prove both evaluator coverage and definedness before + using a formula as a valid sequent. -/ + +inductive ValueType where + | integer + | boolean + | given (name : String) + | finiteSet (element : Option ValueType) + | pair (left right : ValueType) + deriving Repr + +private def valueTypeBeq : ValueType → ValueType → Bool + | .integer, .integer | .boolean, .boolean => true + | .given left, .given right => left == right + | .finiteSet none, .finiteSet none => true + | .finiteSet (some left), .finiteSet (some right) => valueTypeBeq left right + | .pair left₁ right₁, .pair left₂ right₂ => + valueTypeBeq left₁ left₂ && valueTypeBeq right₁ right₂ + | _, _ => false + +instance : BEq ValueType := ⟨valueTypeBeq⟩ + +private def valueTypeDecEq : (left right : ValueType) → Decidable (left = right) + | .integer, .integer => isTrue rfl + | .boolean, .boolean => isTrue rfl + | .given left, .given right => + if equal : left = right then isTrue (by cases equal; rfl) + else isFalse (by intro proof; cases proof; exact equal rfl) + | .finiteSet left, .finiteSet right => + match left, right with + | none, none => isTrue rfl + | none, some _ => isFalse (by intro proof; cases proof) + | some _, none => isFalse (by intro proof; cases proof) + | some left, some right => + match valueTypeDecEq left right with + | isTrue equal => isTrue (by cases equal; rfl) + | isFalse unequal => isFalse (by intro proof; cases proof; exact unequal rfl) + | .pair left₁ right₁, .pair left₂ right₂ => + match valueTypeDecEq left₁ left₂, valueTypeDecEq right₁ right₂ with + | isTrue equal₁, isTrue equal₂ => isTrue (by cases equal₁; cases equal₂; rfl) + | isFalse unequal, _ => isFalse (by intro proof; cases proof; exact unequal rfl) + | _, isFalse unequal => isFalse (by intro proof; cases proof; exact unequal rfl) + | .integer, .boolean | .integer, .given _ | .integer, .finiteSet _ | .integer, .pair _ _ | + .boolean, .integer | .boolean, .given _ | .boolean, .finiteSet _ | .boolean, .pair _ _ | + .given _, .integer | .given _, .boolean | .given _, .finiteSet _ | .given _, .pair _ _ | + .finiteSet _, .integer | .finiteSet _, .boolean | .finiteSet _, .given _ | + .finiteSet _, .pair _ _ | .pair _ _, .integer | .pair _ _, .boolean | + .pair _ _, .given _ | .pair _ _, .finiteSet _ => isFalse (by intro proof; cases proof) + +instance : DecidableEq ValueType := valueTypeDecEq + +inductive EvalError where + | fuelExhausted + | unsupported (term : EventB.Formula.Term) + | unbound (name : String) + | typeMismatch (expected actual : ValueType) + | divisionByZero + | duplicateAssignment (name : String) + | invalidTarget (name : String) + | assignmentArity + | partialApplication + | invalidRelation + | invalidValue + deriving Repr, DecidableEq + +inductive Value where + | integer (value : Int) + | boolean (value : Bool) + | atom (carrier name : String) + | set (values : List Value) + | pair (left right : Value) + /-- A typed powerset carrier, such as `ℙ(ℤ)`. -/ + | powerSet (element : ValueType) + | integerSet + | naturalSet + | natural1Set + | booleanSet + deriving Repr, Inhabited + +mutual + +private def valueDecEq : (left right : Value) → Decidable (left = right) + | .integer left, .integer right => + if equal : left = right then isTrue (by cases equal; rfl) + else isFalse (by intro proof; cases proof; exact equal rfl) + | .boolean left, .boolean right => + if equal : left = right then isTrue (by cases equal; rfl) + else isFalse (by intro proof; cases proof; exact equal rfl) + | .atom leftCarrier leftName, .atom rightCarrier rightName => + match decEq leftCarrier rightCarrier, decEq leftName rightName with + | isTrue carrierEqual, isTrue nameEqual => + isTrue (by cases carrierEqual; cases nameEqual; rfl) + | isFalse unequal, _ => isFalse (by intro proof; cases proof; exact unequal rfl) + | _, isFalse unequal => isFalse (by intro proof; cases proof; exact unequal rfl) + | .set left, .set right => + match valueListDecEq left right with + | isTrue equal => isTrue (by cases equal; rfl) + | isFalse unequal => isFalse (by intro proof; cases proof; exact unequal rfl) + | .pair left₁ right₁, .pair left₂ right₂ => + match valueDecEq left₁ left₂, valueDecEq right₁ right₂ with + | isTrue equal₁, isTrue equal₂ => isTrue (by cases equal₁; cases equal₂; rfl) + | isFalse unequal, _ => isFalse (by intro proof; cases proof; exact unequal rfl) + | _, isFalse unequal => isFalse (by intro proof; cases proof; exact unequal rfl) + | .powerSet left, .powerSet right => + if equal : left = right then isTrue (by cases equal; rfl) + else isFalse (by intro proof; cases proof; exact equal rfl) + | .integerSet, .integerSet | .naturalSet, .naturalSet | + .natural1Set, .natural1Set | .booleanSet, .booleanSet => isTrue rfl + | .integer _, .boolean _ | .integer _, .atom _ _ | .integer _, .set _ | .integer _, .pair _ _ | + .integer _, .powerSet _ | .integer _, .integerSet | .integer _, .naturalSet | + .integer _, .natural1Set | .integer _, .booleanSet | + .boolean _, .integer _ | .boolean _, .atom _ _ | .boolean _, .set _ | .boolean _, .pair _ _ | + .boolean _, .powerSet _ | .boolean _, .integerSet | .boolean _, .naturalSet | + .boolean _, .natural1Set | .boolean _, .booleanSet | + .atom _ _, .integer _ | .atom _ _, .boolean _ | .atom _ _, .set _ | .atom _ _, .pair _ _ | + .atom _ _, .powerSet _ | .atom _ _, .integerSet | .atom _ _, .naturalSet | + .atom _ _, .natural1Set | .atom _ _, .booleanSet | + .set _, .integer _ | .set _, .boolean _ | .set _, .atom _ _ | .set _, .pair _ _ | + .set _, .powerSet _ | .set _, .integerSet | .set _, .naturalSet | + .set _, .natural1Set | .set _, .booleanSet | + .pair _ _, .integer _ | .pair _ _, .boolean _ | .pair _ _, .atom _ _ | .pair _ _, .set _ | + .pair _ _, .powerSet _ | .pair _ _, .integerSet | .pair _ _, .naturalSet | + .pair _ _, .natural1Set | .pair _ _, .booleanSet | + .powerSet _, .integer _ | .powerSet _, .boolean _ | .powerSet _, .atom _ _ | + .powerSet _, .set _ | .powerSet _, .pair _ _ | .powerSet _, .integerSet | + .powerSet _, .naturalSet | .powerSet _, .natural1Set | .powerSet _, .booleanSet | + .integerSet, .integer _ | .integerSet, .boolean _ | .integerSet, .atom _ _ | + .integerSet, .set _ | .integerSet, .pair _ _ | .integerSet, .powerSet _ | + .integerSet, .naturalSet | .integerSet, .natural1Set | .integerSet, .booleanSet | + .naturalSet, .integer _ | .naturalSet, .boolean _ | .naturalSet, .atom _ _ | + .naturalSet, .set _ | .naturalSet, .pair _ _ | .naturalSet, .powerSet _ | + .naturalSet, .integerSet | .naturalSet, .natural1Set | .naturalSet, .booleanSet | + .natural1Set, .integer _ | .natural1Set, .boolean _ | .natural1Set, .atom _ _ | + .natural1Set, .set _ | .natural1Set, .pair _ _ | .natural1Set, .powerSet _ | + .natural1Set, .integerSet | .natural1Set, .naturalSet | .natural1Set, .booleanSet | + .booleanSet, .integer _ | .booleanSet, .boolean _ | .booleanSet, .atom _ _ | + .booleanSet, .set _ | .booleanSet, .pair _ _ | .booleanSet, .powerSet _ | + .booleanSet, .integerSet | .booleanSet, .naturalSet | .booleanSet, .natural1Set => + isFalse (by intro proof; cases proof) + +private def valueListDecEq : (left right : List Value) → Decidable (left = right) + | [], [] => isTrue rfl + | left :: lefts, right :: rights => + match valueDecEq left right, valueListDecEq lefts rights with + | isTrue equal₁, isTrue equal₂ => isTrue (by cases equal₁; cases equal₂; rfl) + | isFalse unequal, _ => isFalse (by intro proof; cases proof; exact unequal rfl) + | _, isFalse unequal => isFalse (by intro proof; cases proof; exact unequal rfl) + | [], _ :: _ | _ :: _, [] => isFalse (by intro proof; cases proof) + +end + +instance : DecidableEq Value := valueDecEq + +def Value.typeOf : Value → ValueType + | .integer _ => .integer + | .boolean _ => .boolean + | .atom carrier _ => .given carrier + | .set (value :: _) => .finiteSet (some value.typeOf) + | .set [] => .finiteSet none + | .pair left right => .pair left.typeOf right.typeOf + | .powerSet element => .finiteSet (some (.finiteSet (some element))) + | .integerSet | .naturalSet | .natural1Set => .finiteSet (some .integer) + | .booleanSet => .finiteSet (some .boolean) + +def Value.setType : List Value → ValueType + | [] => .finiteSet none + | first :: _ => .finiteSet (some first.typeOf) + +def ValueType.compatible : ValueType → ValueType → Bool + | .given left, .given right => left == right + | .finiteSet left, .finiteSet right => + match left, right with + | some left, some right => compatible left right + | _, _ => true + | .pair left₁ right₁, .pair left₂ right₂ => + compatible left₁ left₂ && compatible right₁ right₂ + | left, right => left == right + +def Value.sameType (left right : Value) : Bool := + ValueType.compatible left.typeOf right.typeOf + +private def Value.isWellFormed : Nat → Value → Bool + | 0, _ => false + | fuel + 1, .integer _ | fuel + 1, .boolean _ | fuel + 1, .atom _ _ | fuel + 1, .integerSet | + fuel + 1, .naturalSet | fuel + 1, .natural1Set | fuel + 1, .booleanSet => true + | fuel + 1, .pair left right => + Value.isWellFormed fuel left && Value.isWellFormed fuel right + | fuel + 1, .set values => + values.all (Value.isWellFormed fuel) && match values with + | [] => true + | first :: rest => rest.all (fun value => Value.sameType value first) + | fuel + 1, .powerSet _ => true +termination_by value => sizeOf value +decreasing_by + · simp_wf <;> omega + · exact Nat.lt_succ_self _ + · exact Nat.lt_succ_self _ + +mutual + +def valueEqual : Nat → Value → Value → Except EvalError Bool + | 0, _, _ => .error .fuelExhausted + | fuel + 1, .integer left, .integer right => .ok (left == right) + | fuel + 1, .boolean left, .boolean right => .ok (left == right) + | fuel + 1, .atom leftCarrier leftName, .atom rightCarrier rightName => + .ok (leftCarrier == rightCarrier && leftName == rightName) + | fuel + 1, .pair left₁ right₁, .pair left₂ right₂ => do + let leftEqual ← valueEqual fuel left₁ left₂ + let rightEqual ← valueEqual fuel right₁ right₂ + pure (leftEqual && rightEqual) + | fuel + 1, .set left, .set right => do + let leftSubset ← subsetOf fuel left right + let rightSubset ← subsetOf fuel right left + pure (leftSubset && rightSubset) + | fuel + 1, .integerSet, .integerSet + | fuel + 1, .naturalSet, .naturalSet + | fuel + 1, .natural1Set, .natural1Set + | fuel + 1, .booleanSet, .booleanSet => .ok true + | fuel + 1, .powerSet left, .powerSet right => .ok (left == right) + | fuel + 1, _, _ => .ok false + +def memberOf : Nat → Value → List Value → Except EvalError Bool + | 0, _, _ => .error .fuelExhausted + | fuel + 1, value, [] => .ok false + | fuel + 1, value, candidate :: candidates => do + let equal ← valueEqual fuel value candidate + if equal then .ok true else memberOf fuel value candidates + +def subsetOf : Nat → List Value → List Value → Except EvalError Bool + | 0, _, _ => .error .fuelExhausted + | fuel + 1, left, right => + if left == right then .ok true + else match left with + | [] => .ok true + | value :: values => do + let present ← memberOf fuel value right + if present then subsetOf fuel values right else .ok false + +end + +def Value.makeSet (values : List Value) : Except EvalError Value := + match values with + | [] => .ok (.set []) + | first :: rest => + if rest.all (fun value => Value.sameType value first) then .ok (.set values) + else + let actual := (rest.find? (fun value => !Value.sameType value first)).map Value.typeOf + |>.getD first.typeOf + .error (.typeMismatch first.typeOf actual) + +def ValueType.ofTy : EventB.Typing.Ty → Option ValueType + | .int => some .integer + | .bool => some .boolean + | .given name => some (.given name) + | .pow element => (ValueType.ofTy element).map (some ·) |>.map .finiteSet + | .prod left right => do + let left ← ValueType.ofTy left + let right ← ValueType.ofTy right + pure (.pair left right) + | .mvar _ => none + +def Value.typeMatches (expected : ValueType) (actual : ValueType) : Bool := + ValueType.compatible expected actual + +def Value.matchesTy (value : Value) (expected : EventB.Typing.Ty) : Bool := + match ValueType.ofTy expected with + | some expected => Value.typeMatches expected value.typeOf + | none => false + +def Value.contains (fuel : Nat) (value collection : Value) : Except EvalError Bool := + if fuel == 0 then .error .fuelExhausted + else match collection, value with + | .set values, value => + if !Value.isWellFormed fuel collection || !Value.isWellFormed fuel value then + .error .invalidValue + else match values.head? with + | some first => + if !Value.sameType first value then + .error (.typeMismatch first.typeOf value.typeOf) + else memberOf fuel value values + | none => .ok false + | .powerSet element, value@(.set values) => + if !Value.isWellFormed fuel value then .error .invalidValue + else if values.all (fun candidate => ValueType.compatible candidate.typeOf element) then + .ok true + else .error (.typeMismatch collection.typeOf value.typeOf) + | .integerSet, .integer _ => .ok true + | .naturalSet, .integer value => .ok (decide (0 ≤ value)) + | .natural1Set, .integer value => .ok (decide (0 < value)) + | .booleanSet, .boolean _ => .ok true + | collection, value => .error (.typeMismatch collection.typeOf value.typeOf) + +structure ValueEnv where + values : List (String × Value) := [] + /-- Finite carrier observations. Given-set atoms are rejected unless their carrier + and name occur here; arbitrary nominal tags are not a domain model. -/ + carriers : List (String × List String) := [] + deriving Repr, Inhabited, DecidableEq + +def ValueEnv.lookup (env : ValueEnv) (name : String) : Option Value := + env.values.find? (·.1 == name) |>.map (·.2) + +def ValueEnv.set (env : ValueEnv) (name : String) (value : Value) : ValueEnv := + { values := (name, value) :: env.values.filter (fun binding => binding.1 != name) + carriers := env.carriers } + +def ValueEnv.carrierContains (env : ValueEnv) (carrier name : String) : Bool := + match env.carriers.find? (·.1 == carrier) with + | some (_, members) => members.contains name + | none => false + +def ValueEnv.valueIsWellFormed : Nat → ValueEnv → Value → Bool + | 0, _, _ => false + | fuel + 1, env, .atom carrier name => env.carrierContains carrier name + | fuel + 1, env, .pair left right => valueIsWellFormed fuel env left && + valueIsWellFormed fuel env right + | fuel + 1, env, .set values => values.all (valueIsWellFormed fuel env) && + match values with + | [] => true + | first :: rest => rest.all (fun value => Value.sameType value first) + | fuel + 1, _, .powerSet _ => true + | fuel + 1, _, .integer _ | fuel + 1, _, .boolean _ | fuel + 1, _, .integerSet | + fuel + 1, _, .naturalSet | fuel + 1, _, .natural1Set | fuel + 1, _, .booleanSet => true +termination_by fuel => fuel +decreasing_by + all_goals omega + +def ValueEnv.declaredType? (declarations : List (String × EventB.Typing.Ty)) + (name : String) : Option EventB.Typing.Ty := + declarations.find? (·.1 == name) |>.map (·.2) + +def ValueEnv.validateFuel (fuel : Nat) (declarations : List (String × EventB.Typing.Ty)) + (env : ValueEnv) : Except EvalError Unit := do + let declarationNames := declarations.map (·.1) + let envNames := env.values.map (·.1) + if let some duplicate := declarationNames.find? (fun name => declarationNames.count name > 1) then + .error (.duplicateAssignment duplicate) + else if let some duplicate := envNames.find? (fun name => envNames.count name > 1) then + .error (.duplicateAssignment duplicate) + else + for (name, ty) in declarations do + let some expected := ValueType.ofTy ty | .error .invalidValue + let some value := env.lookup name | .error (.unbound name) + if !ValueEnv.valueIsWellFormed fuel env value then .error .invalidValue + else if !Value.typeMatches expected value.typeOf then + .error (.typeMismatch expected value.typeOf) + if !env.values.all (fun (name, _) => declarationNames.contains name) then + .error .invalidValue + else .ok () + +def ValueEnv.validate (declarations : List (String × EventB.Typing.Ty)) + (env : ValueEnv) : Except EvalError Unit := + ValueEnv.validateFuel 128 declarations env + +def ValueEnv.validationOk (fuel : Nat) (declarations : List (String × EventB.Typing.Ty)) + (env : ValueEnv) : Bool := + match ValueEnv.validateFuel fuel declarations env with + | .ok () => true + | .error _ => false + +def valueMatches (actual expected : Value) : Bool := + match valueEqual 128 actual expected with + | .ok result => result + | .error _ => false + +def ValueEnv.lookupMatches (env : ValueEnv) (name : String) (expected : Value) : Bool := + match env.lookup name with + | some actual => valueMatches actual expected + | none => false + +private structure BeforeAfter where + before : ValueEnv + after : ValueEnv + deriving Repr + +/- A transition consumed by typed semantics carries the declaration domain. The + evaluator revalidates both environments at the requested fuel, so a forged record + cannot turn primed lookup into an unchecked state observation. -/ +structure CheckedBeforeAfter where + before : ValueEnv + after : ValueEnv + declarations : List (String × EventB.Typing.Ty) + deriving Repr, DecidableEq + +private def exceptDecEq {α β : Type} [DecidableEq α] [DecidableEq β] : + (left right : Except α β) → Decidable (left = right) + | .error left, .error right => + match decEq left right with + | isTrue equal => isTrue (by cases equal; rfl) + | isFalse unequal => isFalse (by intro proof; cases proof; exact unequal rfl) + | .ok left, .ok right => + match decEq left right with + | isTrue equal => isTrue (by cases equal; rfl) + | isFalse unequal => isFalse (by intro proof; cases proof; exact unequal rfl) + | .error _, .ok _ | .ok _, .error _ => isFalse (by intro proof; cases proof) + +instance : DecidableEq (Except EvalError Bool) := exceptDecEq +instance : DecidableEq (Except EvalError CheckedBeforeAfter) := exceptDecEq + +def CheckedBeforeAfter.make (fuel : Nat) + (declarations : List (String × EventB.Typing.Ty)) + (before after : ValueEnv) : Except EvalError CheckedBeforeAfter := do + if before.carriers != after.carriers then .error .invalidValue + ValueEnv.validateFuel fuel declarations before + ValueEnv.validateFuel fuel declarations after + pure { before, after, declarations } + +private structure EvalView where + before : ValueEnv + after : Option ValueEnv := none + +private theorem xPrimeEndsWith : "x'".endsWith "'" = true := by native_decide +private theorem xEndsWith : "x".endsWith "'" = false := by native_decide +private theorem xPrimeBase : ("x'".dropEnd 1).copy = "x" := by native_decide + +private def EvalView.lookup (view : EvalView) (name : String) : Except EvalError Value := + if name.endsWith "'" then + match view.after with + | none => .error (.unsupported (.id name)) + | some after => + match after.lookup (name.dropEnd 1 |>.copy) with + | some value => .ok value + | none => .error (.unbound name) + else + match view.before.lookup name with + | some value => .ok value + | none => .error (.unbound name) + +private def EvalView.bind (view : EvalView) (name : String) (value : Value) : EvalView := + if name.endsWith "'" then + let base := (name.dropEnd 1).copy + { view with after := some ((view.after.getD view.before).set base value) } + else + { view with before := view.before.set name value } + +/- Binder evaluation is deliberately one-sided: these finite witness candidates + can establish an existential, but failure to find one is reported unsupported + rather than falsely reported as a negative result. -/ +private def binderCandidate (view : EvalView) : EventB.Formula.Term → Option Value + | .id "ℤ" | .id "ℕ" => some (.integer 0) + | .id "ℕ1" => some (.integer 1) + | .id "BOOL" => some (.boolean true) + | .id carrier => + match view.before.carriers.find? (·.1 == carrier) with + | some (_, name :: _) => some (.atom carrier name) + | _ => none + | _ => none + +def filterSetByMembership : Nat → String → List Value → List Value → Except EvalError (List Value) + | 0, _, _, _ => .error .fuelExhausted + | fuel + 1, _, [], _ => .ok [] + | fuel + 1, op, value :: values, right => do + let present ← memberOf fuel value right + let rest ← filterSetByMembership fuel op values right + if (op == "∩" && present) || (op == "∖" && !present) then + .ok (value :: rest) + else .ok rest + +private def relationValidateFunction : Nat → List Value → Except EvalError Unit + | 0, _ => .error .fuelExhausted + | fuel + 1, [] => .ok () + | fuel + 1, relation :: relations => + match relation with + | .pair input _ => do + let laterInputs := relations.filterMap fun value => + match value with + | .pair laterInput _ => some laterInput + | _ => none + let duplicate ← memberOf fuel input laterInputs + if duplicate then .error .invalidRelation + else relationValidateFunction fuel relations + | _ => .error .invalidRelation + +private def relationType : Nat → List Value → Except EvalError (Option (ValueType × ValueType)) + | 0, _ => .error .fuelExhausted + | fuel + 1, [] => .ok none + | fuel + 1, .pair input output :: relations => do + let rest ← relationType fuel relations + match rest with + | none => .ok (some (input.typeOf, output.typeOf)) + | some (inputType, outputType) => + if ValueType.compatible input.typeOf inputType && + ValueType.compatible output.typeOf outputType then + .ok (some (inputType, outputType)) + else .error .invalidRelation + | _, _ :: _ => .error .invalidRelation + +private def relationApply : Nat → Value → List Value → Except EvalError (Option Value) + | 0, _, _ => .error .fuelExhausted + | fuel + 1, argument, [] => .ok none + | fuel + 1, argument, relation :: relations => + match relation with + | .pair input output => do + let equal ← valueEqual fuel argument input + if equal then + let later ← relationApply fuel argument relations + match later with + | none => .ok (some output) + | some _ => .error .invalidRelation + else relationApply fuel argument relations + | _ => .error .invalidRelation + +private def relationImage : Nat → Value → List Value → Except EvalError (List Value) + | 0, _, _ => .error .fuelExhausted + | fuel + 1, argument, [] => .ok [] + | fuel + 1, argument, relation :: relations => + match relation with + | .pair input output => do + let equal ← valueEqual fuel argument input + let rest ← relationImage fuel argument relations + if equal then .ok (output :: rest) else .ok rest + | _ => .error .invalidRelation + +private def relationRestrict : Nat → Bool → List Value → List Value → Except EvalError (List Value) + | 0, _, _, _ => .error .fuelExhausted + | fuel + 1, _, [], _ => .ok [] + | fuel + 1, domain, relation :: relations, allowed => + match relation with + | .pair input output => do + let equal ← memberOf fuel (if domain then input else output) allowed + let rest ← relationRestrict fuel domain relations allowed + if equal then .ok (relation :: rest) else .ok rest + | _ => .error .invalidRelation + +private def relationDrop : Nat → Bool → List Value → List Value → Except EvalError (List Value) + | 0, _, _, _ => .error .fuelExhausted + | fuel + 1, _, [], _ => .ok [] + | fuel + 1, domain, relation :: relations, dropped => + match relation with + | .pair input output => do + let equal ← memberOf fuel (if domain then input else output) dropped + let rest ← relationDrop fuel domain relations dropped + if equal then .ok rest else .ok (relation :: rest) + | _ => .error .invalidRelation + +private def relationOverride : Nat → List Value → List Value → Except EvalError (List Value) + | 0, _, _ => .error .fuelExhausted + | fuel + 1, left, right => do + let rightDomains ← right.mapM fun relation => + match relation with + | .pair input _ => .ok input + | _ => .error .invalidRelation + let retained ← relationDrop fuel true left rightDomains + .ok (retained ++ right) + +mutual + +private def evalValueFuel : Nat → EvalView → EventB.Formula.Term → Except EvalError Value + | 0, _, _ => .error .fuelExhausted + | fuel + 1, view, .id name => + if name == "ℤ" then .ok .integerSet + else if name == "ℕ" then .ok .naturalSet + else if name == "ℕ1" then .ok .natural1Set + else if name == "BOOL" then .ok .booleanSet + else do + let value ← view.lookup name + let env := if name.endsWith "'" then view.after.getD view.before else view.before + if ValueEnv.valueIsWellFormed (fuel + 1) env value then + .ok value + else .error .invalidValue + | fuel + 1, _, .num value => .ok (.integer value) + | fuel + 1, view, .pre "−" term => do + let value ← evalValueFuel fuel view term + match value with + | .integer value => .ok (.integer (-value)) + | value => .error (.typeMismatch .integer value.typeOf) + | fuel + 1, view, .pre "ℙ" term => do + let value ← evalValueFuel fuel view term + match value with + | .integerSet | .naturalSet | .natural1Set => .ok (.powerSet .integer) + | .booleanSet => .ok (.powerSet .boolean) + | .powerSet element => .ok (.powerSet (.finiteSet (some element))) + | value => .error (.typeMismatch (.finiteSet none) value.typeOf) + | fuel + 1, view, .bin op left right => + match op with + | "↦" => do + let left ← evalValueFuel fuel view left + let right ← evalValueFuel fuel view right + pure (.pair left right) + | "+" | "−" | "∗" | "÷" | "mod" => do + let left ← evalValueFuel fuel view left + let right ← evalValueFuel fuel view right + let some left := (match left with | .integer value => some value | _ => none) + | .error (.typeMismatch .integer left.typeOf) + let some right := (match right with | .integer value => some value | _ => none) + | .error (.typeMismatch .integer right.typeOf) + if op == "+" then .ok (.integer (left + right)) + else if op == "−" then .ok (.integer (left - right)) + else if op == "∗" then .ok (.integer (left * right)) + else if right == 0 then .error .divisionByZero + else if op == "÷" then .ok (.integer (left / right)) + else .ok (.integer (left % right)) + | "∪" | "∩" | "∖" => do + let left ← evalValueFuel fuel view left + let right ← evalValueFuel fuel view right + let some left := (match left with | .set values => some values | _ => none) + | .error (.typeMismatch (.finiteSet none) left.typeOf) + let some right := (match right with | .set values => some values | _ => none) + | .error (.typeMismatch (.finiteSet none) right.typeOf) + if !ValueType.compatible (Value.setType left) (Value.setType right) then + .error (.typeMismatch (Value.setType left) (Value.setType right)) + else if op == "∪" then Value.makeSet (left ++ right) + else do + let values ← filterSetByMembership fuel op left right + Value.makeSet values + | "◁" | "⩤" | "▷" | "⩥" => do + let left ← evalValueFuel fuel view left + let right ← evalValueFuel fuel view right + let some left := (match left with | .set values => some values | _ => none) + | .error (.typeMismatch (.finiteSet none) left.typeOf) + let some right := (match right with | .set values => some values | _ => none) + | .error (.typeMismatch (.finiteSet none) right.typeOf) + let domain := op == "◁" || op == "⩤" + let relation := if domain then right else left + let allowed := if domain then left else right + let relationType ← relationType fuel relation + if let some (inputType, outputType) := relationType then + let selectedType := if domain then inputType else outputType + if !ValueType.compatible (Value.setType allowed) + (.finiteSet (some selectedType)) then + .error (.typeMismatch (.finiteSet (some selectedType)) (Value.setType allowed)) + let values ← if op == "⩤" || op == "⩥" then + relationDrop fuel domain relation allowed + else relationRestrict fuel domain relation allowed + Value.makeSet values + | "" => do + let left ← evalValueFuel fuel view left + let right ← evalValueFuel fuel view right + let some left := (match left with | .set values => some values | _ => none) + | .error (.typeMismatch (.finiteSet none) left.typeOf) + let some right := (match right with | .set values => some values | _ => none) + | .error (.typeMismatch (.finiteSet none) right.typeOf) + let leftType ← relationType fuel left + let rightType ← relationType fuel right + match leftType, rightType with + | some (leftInput, leftOutput), some (rightInput, rightOutput) => + if !ValueType.compatible leftInput rightInput || + !ValueType.compatible leftOutput rightOutput then + .error (.typeMismatch (.pair leftInput leftOutput) + (.pair rightInput rightOutput)) + | _, _ => pure () + relationOverride fuel left right >>= Value.makeSet + | "," => .error (.unsupported (.bin op left right)) + | _ => .error (.unsupported (.bin op left right)) + | fuel + 1, view, .set values => do + let values ← evalValueListFuel fuel view values + Value.makeSet values + | fuel + 1, view, .app function argument => do + let function ← evalValueFuel fuel view function + let argument ← evalValueFuel fuel view argument + let some relation := (match function with | .set values => some values | _ => none) + | .error (.typeMismatch (.finiteSet none) function.typeOf) + let relationType ← relationType fuel relation + relationValidateFunction fuel relation + if let some (inputType, _) := relationType then + if !ValueType.compatible inputType argument.typeOf then + .error (.typeMismatch inputType argument.typeOf) + let result ← relationApply fuel argument relation + match result with + | some value => .ok value + | none => .error .partialApplication + | fuel + 1, view, .img relation argument => do + let relation ← evalValueFuel fuel view relation + let argument ← evalValueFuel fuel view argument + let some relation := (match relation with | .set values => some values | _ => none) + | .error (.typeMismatch (.finiteSet none) relation.typeOf) + let relationType ← relationType fuel relation + if let some (inputType, _) := relationType then + if !ValueType.compatible inputType argument.typeOf then + .error (.typeMismatch inputType argument.typeOf) + let values ← relationImage fuel argument relation + Value.makeSet values + | _, _, term => .error (.unsupported term) + +private def evalValueListFuel : Nat → EvalView → List EventB.Formula.Term → + Except EvalError (List Value) + | 0, _, _ => .error .fuelExhausted + | _fuel + 1, _, [] => .ok [] + | fuel + 1, view, term :: terms => do + let value ← evalValueFuel fuel view term + let values ← evalValueListFuel fuel view terms + pure (value :: values) + +private def evalPredicateFuel : Nat → EvalView → EventB.Formula.Term → Except EvalError Bool + | 0, _, _ => .error .fuelExhausted + | fuel + 1, _, .id "⊤" => .ok true + | fuel + 1, _, .id "⊥" => .ok false + | fuel + 1, view, .id name => + match view.lookup name with + | .ok (.boolean value) => .ok value + | .ok value => .error (.typeMismatch .boolean value.typeOf) + | .error error => .error error + | fuel + 1, view, .pre "¬" term => do + let value ← evalPredicateFuel fuel view term + pure !value + | fuel + 1, view, term@(.bind "∃" (.bin "⦂" (.id name) type) body) => + match binderCandidate view type with + | none => .error (.unsupported term) + | some witness => + match evalPredicateFuel fuel (view.bind name witness) body with + | .ok true => .ok true + | .ok false => .error (.unsupported term) + | .error error => .error error + | fuel + 1, view, term@(.app (.id "finite") argument) => do + let value ← evalValueFuel fuel view argument + match value with + | .set _ => .ok true + | .powerSet _ | .integerSet | .naturalSet | .natural1Set | .booleanSet => .ok false + | value => .error (.typeMismatch (.finiteSet none) value.typeOf) + | fuel + 1, view, .bin op left right => + match op with + | "∧" | "∨" | "⇒" | "⇔" => do + let left ← evalPredicateFuel fuel view left + let right ← evalPredicateFuel fuel view right + if op == "∧" then .ok (left && right) + else if op == "∨" then .ok (left || right) + else if op == "⇒" then .ok (!left || right) + else .ok (left == right) + | "=" | "≠" => do + let left ← evalValueFuel fuel view left + let right ← evalValueFuel fuel view right + if !left.sameType right then .error (.typeMismatch left.typeOf right.typeOf) + else do + let equal ← valueEqual fuel left right + .ok (if op == "=" then equal else !equal) + | "<" | "≤" | ">" | "≥" => do + let left ← evalValueFuel fuel view left + let right ← evalValueFuel fuel view right + let some left := (match left with | .integer value => some value | _ => none) + | .error (.typeMismatch .integer left.typeOf) + let some right := (match right with | .integer value => some value | _ => none) + | .error (.typeMismatch .integer right.typeOf) + .ok (if op == "<" then decide (left < right) + else if op == "≤" then decide (left ≤ right) + else if op == ">" then decide (left > right) + else decide (left ≥ right)) + | "∈" | "∉" => do + let value ← evalValueFuel fuel view left + let collection ← evalValueFuel fuel view right + let result ← Value.contains fuel value collection + .ok (if op == "∈" then result else !result) + | "⊆" | "⊈" | "⊂" | "⊄" => do + let left ← evalValueFuel fuel view left + let right ← evalValueFuel fuel view right + let some left := (match left with | .set values => some values | _ => none) + | .error (.typeMismatch (.finiteSet none) left.typeOf) + let some right := (match right with | .set values => some values | _ => none) + | .error (.typeMismatch (.finiteSet none) right.typeOf) + if !ValueType.compatible (Value.setType left) (Value.setType right) then + .error (.typeMismatch (Value.setType left) (Value.setType right)) + else + let leftSubset ← subsetOf fuel left right + let rightSubset ← subsetOf fuel right left + let subset := if op == "⊆" || op == "⊈" then leftSubset + else leftSubset && !rightSubset + .ok (if op == "⊆" || op == "⊂" then subset else !subset) + | "↔" => .error (.unsupported (.bin op left right)) + | _ => .error (.unsupported (.bin op left right)) + | _, _, term => .error (.unsupported term) + +end + +private def evalValueWithFuel (fuel : Nat) (env : ValueEnv) + (term : EventB.Formula.Term) : Except EvalError Value := + evalValueFuel fuel { before := env } term + +private def evalPredicateWithFuel (fuel : Nat) (env : ValueEnv) + (term : EventB.Formula.Term) : Except EvalError Bool := + evalPredicateFuel fuel { before := env } term + +/- Public, error-aware wrappers keep the recursive evaluator implementation private while + allowing typed adequacy fixtures to name the exact fuel they validate. -/ +def evalValueAtFuel (fuel : Nat) (env : ValueEnv) + (term : EventB.Formula.Term) : Except EvalError Value := + evalValueWithFuel fuel env term + +def evalPredicateAtFuel (fuel : Nat) (env : ValueEnv) + (term : EventB.Formula.Term) : Except EvalError Bool := + evalPredicateWithFuel fuel env term + +/-- Complete existential evaluation only over a caller-supplied finite domain. + The ordinary binder evaluator remains deliberately one-sided for infinite or + implicit Event-B types; this API makes the completeness boundary explicit. -/ +def evalPredicateOverFiniteDomain (fuel : Nat) (env : ValueEnv) (binder : String) + (candidates : List Value) (body : EventB.Formula.Term) : Except EvalError Bool := + match candidates with + | [] => .ok false + | candidate :: rest => + match evalPredicateAtFuel fuel (env.set binder candidate) body with + | .ok true => .ok true + | .ok false => evalPredicateOverFiniteDomain fuel env binder rest body + | .error error => .error error +termination_by candidates.length + +theorem evalPredicateOverFiniteDomain_true (fuel : Nat) (env : ValueEnv) + (binder : String) (candidates : List Value) (body : EventB.Formula.Term) + (evaluated : evalPredicateOverFiniteDomain fuel env binder candidates body = .ok true) : + ∃ candidate, candidate ∈ candidates ∧ + evalPredicateAtFuel fuel (env.set binder candidate) body = .ok true := by + induction candidates with + | nil => simp [evalPredicateOverFiniteDomain] at evaluated + | cons candidate rest inductionHypothesis => + simp only [evalPredicateOverFiniteDomain] at evaluated + cases head : evalPredicateAtFuel fuel (env.set binder candidate) body with + | error error => simp [head] at evaluated + | ok result => + cases result with + | false => + obtain ⟨witness, member, holds⟩ := + inductionHypothesis (by simpa [head] using evaluated) + exact ⟨witness, by simp [member], holds⟩ + | true => exact ⟨candidate, by simp, head⟩ + +theorem ValueEnv.lookup_set_self (env : ValueEnv) (name : String) (value : Value) : + (env.set name value).lookup name = some value := by + simp [ValueEnv.lookup, ValueEnv.set] + +theorem evalWitnessIntegerZeroDivOne (env : ValueEnv) : + evalPredicateAtFuel 128 env + (.bind "∃" (.bin "⦂" (.id "p") (.id "ℤ")) + (.bin "=" (.id "p") (.bin "÷" (.num 0) (.num 1)))) = .ok true := by + have pNotPrime : "p".endsWith "'" = false := by native_decide + have integerCompatible : (ValueType.integer == ValueType.integer) = true := by + native_decide + simp [evalPredicateAtFuel, evalPredicateWithFuel, evalPredicateFuel, + evalValueFuel, binderCandidate, EvalView.bind, EvalView.lookup, + ValueEnv.lookup, ValueEnv.set, ValueEnv.lookup_set_self, ValueEnv.valueIsWellFormed, + Value.sameType, Value.typeOf, + ValueType.compatible, valueEqual, integerCompatible, pNotPrime, + Bind.bind, Except.bind] + +theorem evalPredicateIntegerOneEqOne (env : ValueEnv) : + evalPredicateAtFuel 128 env (.bin "=" (.num 1) (.num 1)) = .ok true := by + have integerCompatible : (ValueType.integer == ValueType.integer) = true := by + native_decide + simp [evalPredicateAtFuel, evalPredicateWithFuel, evalPredicateFuel, + evalValueFuel, Value.sameType, Value.typeOf, ValueType.compatible, + valueEqual, integerCompatible, Bind.bind, Except.bind] + +theorem evalPredicateIntegerOneNeZero (env : ValueEnv) : + evalPredicateAtFuel 128 env (.bin "≠" (.num 1) (.num 0)) = .ok true := by + have integerCompatible : (ValueType.integer == ValueType.integer) = true := by + native_decide + simp [evalPredicateAtFuel, evalPredicateWithFuel, evalPredicateFuel, + evalValueFuel, Value.sameType, Value.typeOf, ValueType.compatible, + valueEqual, integerCompatible, Bind.bind, Except.bind] + +theorem evalPredicateFiniteZero (env : ValueEnv) : + evalPredicateAtFuel 128 env (.app (.id "finite") (.set [.num 0])) = .ok true := by + have values : evalValueListFuel 126 { before := env } [.num 0] = .ok [.integer 0] := by + simp [evalValueListFuel, evalValueFuel, Bind.bind, Except.bind] + rfl + simp [evalPredicateAtFuel, evalPredicateWithFuel, evalPredicateFuel, evalValueFuel, + values, Value.makeSet, Value.sameType, Value.typeOf, ValueType.compatible, + Bind.bind, Except.bind] + +theorem evalValueFiniteZero (env : ValueEnv) : + evalValueAtFuel 128 env (.set [.num 0]) = .ok (.set [.integer 0]) := by + have values : evalValueListFuel 127 { before := env } [.num 0] = .ok [.integer 0] := by + simp [evalValueListFuel, evalValueFuel, Bind.bind, Except.bind] + rfl + simpa [evalValueAtFuel, evalValueWithFuel, evalValueFuel, values, + Value.makeSet, Value.sameType, Value.typeOf, ValueType.compatible, + Bind.bind, Except.bind] + +theorem evalValueIdentifierSingletonZero : + evalValueAtFuel 127 { values := [("S", .set [.integer 0])] } (.id "S") = + .ok (.set [.integer 0]) := by + have xNotEndsWith : ¬ "S".endsWith "'" = true := by native_decide + simp [evalValueAtFuel, evalValueWithFuel, evalValueFuel, EvalView.lookup, + ValueEnv.lookup, ValueEnv.valueIsWellFormed, xNotEndsWith, Bind.bind, Except.bind] + +def evalBeforeAfter (fuel : Nat) (transition : CheckedBeforeAfter) + (term : EventB.Formula.Term) : Except EvalError Bool := + if ValueEnv.validationOk fuel transition.declarations transition.before && + ValueEnv.validationOk fuel transition.declarations transition.after then + evalPredicateFuel fuel { before := transition.before, after := some transition.after } term + else .error .invalidValue + +theorem evalBeforeAfterIntegerOneOrOne + (transition : CheckedBeforeAfter) + (beforeValid : ValueEnv.validationOk 128 transition.declarations transition.before = true) + (afterValid : ValueEnv.validationOk 128 transition.declarations transition.after = true) : + evalBeforeAfter 128 transition + (.bin "∨" (.bin "=" (.num 1) (.num 1)) + (.bin "=" (.num 1) (.num 1))) = .ok true := by + have integerCompatible : (ValueType.integer == ValueType.integer) = true := by + native_decide + simp [evalBeforeAfter, beforeValid, afterValid, evalPredicateFuel, evalValueFuel, + Value.sameType, Value.typeOf, ValueType.compatible, valueEqual, integerCompatible, + Bind.bind, Except.bind] + +theorem evalBeforeAfterZeroSetNeEmpty + (transition : CheckedBeforeAfter) + (beforeValid : ValueEnv.validationOk 128 transition.declarations transition.before = true) + (afterValid : ValueEnv.validationOk 128 transition.declarations transition.after = true) : + evalBeforeAfter 128 transition + (.bin "≠" (.set [.num 0]) (.set [])) = .ok true := by + have leftValues : + evalValueListFuel 126 { before := transition.before, after := some transition.after } + [.num 0] = .ok [.integer 0] := by + simp [evalValueListFuel, evalValueFuel, Bind.bind, Except.bind] + rfl + have rightValues : + evalValueListFuel 126 { before := transition.before, after := some transition.after } + [] = .ok [] := by + simp [evalValueListFuel, evalValueFuel, Bind.bind, Except.bind] + simp [evalBeforeAfter, beforeValid, afterValid, evalPredicateFuel, evalValueFuel, + leftValues, rightValues, + Value.makeSet, ValueEnv.lookup, Value.sameType, Value.typeOf, ValueType.compatible, + Value.contains, memberOf, subsetOf, valueEqual, Bind.bind, Except.bind] + rfl + +theorem evalBeforeAfterZeroSetSubset + (transition : CheckedBeforeAfter) + (beforeValid : ValueEnv.validationOk 128 transition.declarations transition.before = true) + (afterValid : ValueEnv.validationOk 128 transition.declarations transition.after = true) : + evalBeforeAfter 128 transition + (.bin "⊆" (.set [.num 0]) (.set [.num 0])) = .ok true := by + have values : + evalValueListFuel 126 { before := transition.before, after := some transition.after } + [.num 0] = .ok [.integer 0] := by + simp [evalValueListFuel, evalValueFuel, Bind.bind, Except.bind] + rfl + have integerCompatible : (ValueType.integer == ValueType.integer) = true := by rfl + simp [evalBeforeAfter, beforeValid, afterValid, evalPredicateFuel, evalValueFuel, + values, Value.makeSet, Value.setType, Value.sameType, Value.typeOf, ValueType.compatible, + Value.contains, memberOf, subsetOf, valueEqual, integerCompatible, Bind.bind, Except.bind] + +private theorem valueTypeCompatibleSelf : ∀ valueType : ValueType, + valueType.compatible valueType = true := by + intro valueType + cases valueType with + | integer => rfl + | boolean => rfl + | given name => simp [ValueType.compatible] + | finiteSet element => + cases element with + | none => rfl + | some element => + simp [ValueType.compatible, valueTypeCompatibleSelf element] + | pair left right => + simp [ValueType.compatible, valueTypeCompatibleSelf left, + valueTypeCompatibleSelf right] +termination_by valueType => sizeOf valueType +decreasing_by all_goals simp_wf <;> omega + +theorem evalBeforeAfterIdentifierSubsetSelf + (transition : CheckedBeforeAfter) + (beforeValid : ValueEnv.validationOk 128 transition.declarations transition.before = true) + (afterValid : ValueEnv.validationOk 128 transition.declarations transition.after = true) + (valueShape : ∃ values, evalValueAtFuel 127 transition.before (.id "S") = + .ok (.set values)) + (afterEq : transition.after = transition.before) : + evalBeforeAfter 128 transition + (.bin "⊆" (.id "S") (.id "S")) = .ok true := by + have xEndsWith : "S".endsWith "'" = false := by native_decide + have xNotEndsWith : ¬ "S".endsWith "'" = true := by native_decide + rcases valueShape with ⟨values, beforeShape⟩ + have beforeEval : + evalValueFuel 127 { before := transition.before, after := some transition.after } + (.id "S") = .ok (.set values) := by + simpa [evalValueAtFuel, evalValueWithFuel, evalValueFuel, EvalView.lookup, + ValueEnv.lookup, xEndsWith, xNotEndsWith] using + beforeShape + simp [evalBeforeAfter, beforeValid, afterValid, evalPredicateFuel, beforeEval, + ValueEnv.valueIsWellFormed, Value.setType, ValueType.compatible, + valueTypeCompatibleSelf, subsetOf, + Value.typeOf, memberOf, valueEqual, Bind.bind, Except.bind] + +theorem evalBeforeAfterIdentifierType + (transition : CheckedBeforeAfter) + (beforeValid : ValueEnv.validationOk 128 transition.declarations transition.before = true) + (afterValid : ValueEnv.validationOk 128 transition.declarations transition.after = true) + (beforeType : evalPredicateAtFuel 128 transition.before + (.bin "∈" (.id "S") (.pre "ℙ" (.id "ℤ"))) = .ok true) : + evalBeforeAfter 128 transition + (.bin "∈" (.id "S") (.pre "ℙ" (.id "ℤ"))) = .ok true := by + have xEndsWith : "S".endsWith "'" = false := by native_decide + have xNotEndsWith : ¬ "S".endsWith "'" = true := by native_decide + have beforeTypeEval : + evalPredicateFuel 128 { before := transition.before, after := some transition.after } + (.bin "∈" (.id "S") (.pre "ℙ" (.id "ℤ"))) = .ok true := by + simpa [evalPredicateAtFuel, evalPredicateWithFuel, evalPredicateFuel, + evalValueFuel, EvalView.lookup, ValueEnv.lookup, xEndsWith, xNotEndsWith, + Bind.bind, Except.bind] using beforeType + simp [evalBeforeAfter, beforeValid, afterValid, beforeTypeEval] + +theorem evalBeforeAfterIdentifierFinite + (transition : CheckedBeforeAfter) + (beforeValid : ValueEnv.validationOk 128 transition.declarations transition.before = true) + (afterValid : ValueEnv.validationOk 128 transition.declarations transition.after = true) + (beforeFinite : evalPredicateAtFuel 128 transition.before + (.app (.id "finite") (.id "S")) = .ok true) : + evalBeforeAfter 128 transition + (.app (.id "finite") (.id "S")) = .ok true := by + have xEndsWith : "S".endsWith "'" = false := by native_decide + have xNotEndsWith : ¬ "S".endsWith "'" = true := by native_decide + have beforeFiniteEval : + evalPredicateFuel 128 { before := transition.before, after := some transition.after } + (.app (.id "finite") (.id "S")) = .ok true := by + simpa [evalPredicateAtFuel, evalPredicateWithFuel, evalPredicateFuel, + evalValueFuel, EvalView.lookup, ValueEnv.lookup, xEndsWith, xNotEndsWith, + Bind.bind, Except.bind] using beforeFinite + simp [evalBeforeAfter, beforeValid, afterValid, beforeFiniteEval] + +theorem evalBeforeAfterZeroNat + (transition : CheckedBeforeAfter) + (beforeValid : ValueEnv.validationOk 128 transition.declarations transition.before = true) + (afterValid : ValueEnv.validationOk 128 transition.declarations transition.after = true) : + evalBeforeAfter 128 transition + (.bin "∈" (.num 0) (.id "ℕ")) = .ok true := by + simp [evalBeforeAfter, beforeValid, afterValid, evalPredicateFuel, evalValueFuel, + Value.contains, Bind.bind, Except.bind] + +theorem evalBeforeAfterZeroLeZero + (transition : CheckedBeforeAfter) + (beforeValid : ValueEnv.validationOk 128 transition.declarations transition.before = true) + (afterValid : ValueEnv.validationOk 128 transition.declarations transition.after = true) : + evalBeforeAfter 128 transition + (.bin "≤" (.num 0) (.num 0)) = .ok true := by + simp [evalBeforeAfter, beforeValid, afterValid, evalPredicateFuel, evalValueFuel, + Bind.bind, Except.bind] + +def assignmentPredicateWithFuel (fuel : Nat) (transition : CheckedBeforeAfter) + (predicate : EventB.Formula.Term) : Prop := + evalBeforeAfter fuel transition predicate = .ok true + +def assignmentPredicate (transition : CheckedBeforeAfter) + (predicate : EventB.Formula.Term) : Prop := + assignmentPredicateWithFuel 128 transition predicate + +/-- The executable before/after evaluator turns an integer EQL equality into the + corresponding equality of the two checked integer observations. -/ +theorem eqlIntegerAfterEqBefore + (fuel : Nat) (name : String) (transition : CheckedBeforeAfter) + (beforeValue afterValue : Int) + (beforeValid : ValueEnv.validationOk fuel transition.declarations transition.before = true) + (afterValid : ValueEnv.validationOk fuel transition.declarations transition.after = true) + (unprimed : name.endsWith "'" = false) + (primedBase : ((name ++ "'").dropEnd 1).copy = name) + (primeNotInteger : name ++ "'" ≠ "ℤ") + (primeNotNatural : name ++ "'" ≠ "ℕ") + (primeNotNatural1 : name ++ "'" ≠ "ℕ1") + (primeNotBoolean : name ++ "'" ≠ "BOOL") + (notInteger : name ≠ "ℤ") + (notNatural : name ≠ "ℕ") + (notNatural1 : name ≠ "ℕ1") + (notBoolean : name ≠ "BOOL") + (beforeLookup : transition.before.lookup name = some (.integer beforeValue)) + (afterLookup : transition.after.lookup ((name ++ "'").dropEnd 1).copy = + some (.integer afterValue)) + (evaluated : assignmentPredicateWithFuel fuel transition + (.bin "=" (.id (name ++ "'")) (.id name))) : + afterValue = beforeValue := by + have primeEndsWith : (name ++ "'").endsWith "'" = true := by + rw [String.endsWith_eq_endsWith_toSlice] + rw [String.Slice.endsWith_string_iff] + simpa using (List.suffix_append name.toList ("'" : String).toList) + have beforeLookup' := beforeLookup + have afterLookup' := afterLookup + simp only [ValueEnv.lookup] at beforeLookup' + simp [primedBase] at afterLookup' + simp only [ValueEnv.lookup] at afterLookup' + have integerCompatible : (ValueType.integer == ValueType.integer) = true := by rfl + cases fuel with + | zero => + simp [assignmentPredicateWithFuel, evalBeforeAfter, evalPredicateFuel, + beforeValid, afterValid] at evaluated + | succ fuel => + cases fuel with + | zero => + simp [assignmentPredicateWithFuel, evalBeforeAfter, evalPredicateFuel, + evalValueFuel, Bind.bind, Except.bind, beforeValid, afterValid] at evaluated + | succ fuel => + cases fuel with + | zero => + have equal : (afterValue == beforeValue) = true := by + simpa [assignmentPredicateWithFuel, evalBeforeAfter, evalPredicateFuel, + evalValueFuel, EvalView.lookup, ValueEnv.lookup, + ValueEnv.valueIsWellFormed, Bind.bind, Except.bind, valueEqual, + Value.sameType, Value.typeOf, ValueType.compatible, beq_iff_eq, + integerCompatible, + beforeLookup', afterLookup', beforeValid, afterValid, + unprimed, primedBase, primeEndsWith, + primeNotInteger, primeNotNatural, primeNotNatural1, primeNotBoolean, + notInteger, notNatural, notNatural1, notBoolean] using evaluated + exact eq_of_beq equal + | succ fuel => + have equal : (afterValue == beforeValue) = true := by + simpa [assignmentPredicateWithFuel, evalBeforeAfter, evalPredicateFuel, + evalValueFuel, EvalView.lookup, ValueEnv.lookup, + ValueEnv.valueIsWellFormed, beforeLookup', afterLookup', + Bind.bind, Except.bind, Value.sameType, Value.typeOf, + ValueType.compatible, beq_iff_eq, valueEqual, beforeValid, afterValid, + integerCompatible, + unprimed, primedBase, primeEndsWith, primeNotInteger, primeNotNatural, + primeNotNatural1, primeNotBoolean, notInteger, notNatural, notNatural1, + notBoolean] using evaluated + exact eq_of_beq equal + +def evalValue : ValueEnv → EventB.Formula.Term → Except EvalError Value := + evalValueWithFuel 128 + +def evalPredicate : ValueEnv → EventB.Formula.Term → Except EvalError Bool := + evalPredicateWithFuel 128 + +#guard match evalValue + { values := [("f", .set [.pair (.integer 0) (.integer 1)])] } + (.app (.id "f") (.num 0)) with + | .ok (.integer 1) => true + | _ => false +#guard match evalValue + { values := [("f", .set [.pair (.integer 0) (.integer 1)]), ("b", .boolean true)] } + (.app (.id "f") (.id "b")) with + | .error (.typeMismatch _ _) => true + | _ => false +#guard match evalValue + { values := [("f", .set [.pair (.integer 0) (.integer 1), + .pair (.integer 1) (.integer 2)])] } + (.img (.id "f") (.num 1)) with + | .ok (.set [.integer 2]) => true + | _ => false +#guard match evalValue + { values := [("r", .set [.pair (.integer 0) (.integer 1), + .pair (.integer 1) (.integer 2)])] } + (.bin "◁" (.set [.num 1]) (.id "r")) with + | .ok (.set [.pair (.integer 1) (.integer 2)]) => true + | _ => false +#guard match evalValue + { values := [("r", .set [.pair (.integer 0) (.integer 1)]), ("b", .boolean true)], + carriers := [] } + (.bin "◁" (.set [(.id "b")]) (.id "r")) with + | .error (.typeMismatch _ _) => true + | _ => false +#guard match evalValue + { values := [("r", .set [.pair (.integer 0) (.integer 1), + .pair (.integer 1) (.integer 2)])] } + (.bin "⩤" (.set [.num 1]) (.id "r")) with + | .ok (.set [.pair (.integer 0) (.integer 1)]) => true + | _ => false +#guard match evalValue + { values := [("r", .set [.pair (.integer 0) (.integer 1), + .pair (.integer 1) (.integer 2)])] } + (.bin "⩥" (.id "r") (.set [.num 1])) with + | .ok (.set [.pair (.integer 1) (.integer 2)]) => true + | _ => false +#guard match evalValue + { values := [("r", .set [.pair (.integer 0) (.integer 1), + .pair (.integer 1) (.integer 2)])] } + (.bin "" (.id "r") (.set [.bin "↦" (.num 0) (.num 3)])) with + | .ok (.set [.pair (.integer 1) (.integer 2), .pair (.integer 0) (.integer 3)]) => true + | _ => false +#guard match evalValue + { values := [("f", .set [.pair (.integer 0) (.integer 1), + .pair (.integer 0) (.integer 2)])] } + (.app (.id "f") (.num 0)) with + | .error .invalidRelation => true + | _ => false +#guard match evalValue + { values := [("f", .set [.pair (.integer 0) (.integer 1), + .pair (.integer 0) (.integer 2)])] } + (.app (.id "f") (.num 9)) with + | .error .invalidRelation => true + | _ => false +private def ValueEnv.parallelAssign (env : ValueEnv) + (updates : List (String × EventB.Formula.Term)) : Except EvalError BeforeAfter := do + let names := updates.map (·.1) + if let some duplicate := names.find? (fun name => names.count name > 1) then + .error (.duplicateAssignment duplicate) + else if let some invalid := names.find? (fun name => name.isEmpty || name.endsWith "'") then + .error (.invalidTarget invalid) + else + let values ← updates.mapM fun update => evalValue env update.2 + let after := updates.zip values |>.foldl + (fun result ((name, _), value) => result.set name value) env + pure { before := env, after := after } + +private def ValueEnv.parallelAssignTerms (env : ValueEnv) + (targets : List String) (rhs : List EventB.Formula.Term) : Except EvalError BeforeAfter := + if targets.length != rhs.length then .error .assignmentArity + else ValueEnv.parallelAssign env (targets.zip rhs) + +def ValueEnv.parallelAssignTypedFuel (fuel : Nat) + (declarations : List (String × EventB.Typing.Ty)) (env : ValueEnv) + (updates : List (String × EventB.Formula.Term)) : Except EvalError CheckedBeforeAfter := do + ValueEnv.validateFuel fuel declarations env + let names := updates.map (·.1) + if let some duplicate := names.find? (fun name => names.count name > 1) then + .error (.duplicateAssignment duplicate) + else + for (name, _) in updates do + if name.isEmpty || name.endsWith "'" then .error (.invalidTarget name) + if (ValueEnv.declaredType? declarations name).isNone then + .error (.invalidTarget name) + let values ← updates.mapM fun (name, term) => do + let value ← evalValueWithFuel fuel env term + let some ty := ValueEnv.declaredType? declarations name | .error (.invalidTarget name) + let some expected := ValueType.ofTy ty | .error .invalidValue + if Value.typeMatches expected value.typeOf then pure value + else .error (.typeMismatch expected value.typeOf) + let after := updates.zip values |>.foldl + (fun result ((name, _), value) => result.set name value) env + CheckedBeforeAfter.make fuel declarations env after + +def ValueEnv.parallelAssignTyped + (declarations : List (String × EventB.Typing.Ty)) (env : ValueEnv) + (updates : List (String × EventB.Formula.Term)) : Except EvalError CheckedBeforeAfter := + ValueEnv.parallelAssignTypedFuel 128 declarations env updates + +def declarationNames (elem : EventB.Elem) (tag : String) : List String := + elem.children.filter (fun child => child.tag == "org.eventb.core." ++ tag) + |>.filterMap (·.attr? "org.eventb.core.identifier") + +def dedupTypedBindings (seen : List String) : List (String × EventB.Typing.Ty) → + List (String × EventB.Typing.Ty) + | [] => [] + | binding :: rest => + if seen.contains binding.1 then dedupTypedBindings seen rest + else binding :: dedupTypedBindings (binding.1 :: seen) rest + +structure ComponentValuation where + component : String + types : List (String × EventB.Typing.Ty) + eventParams : List ((String × String) × List (String × EventB.Typing.Ty)) + variables : List String + deriving Repr + +def ComponentValuation.fromProject (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) (component : String) : + Except EventB.Error ComponentValuation := do + let details ← EventB.Typing.inferComponentDetailsCheckedIn theory project component + unless details.diagnostics.isEmpty do + throw (EventB.Error.typing + (s!"component {component} has typing diagnostics: " ++ + String.intercalate "; " details.diagnostics)) + let (_, closureNames) := EventB.Typing.closure project [] component + let variables := closureNames.flatMap fun name => + match EventB.Typing.lookupComponent project name with + | some current => declarationNames current.elem "variable" + | none => [] + let valuation : ComponentValuation := + { component := component + types := details.types + eventParams := details.eventParams + variables := variables.eraseDups } + pure valuation + +def ComponentValuation.declarationsForEvent (valuation : ComponentValuation) + (project : EventB.Typing.Project) (event : String) : + List (String × EventB.Typing.Ty) := + let parameterNames := valuation.eventParams.flatMap (·.2.map (·.1)) + let globals := valuation.types.filter (fun binding => !parameterNames.contains binding.1) + let eventBindings := EventB.Typing.visibleEventBindings project valuation.eventParams + valuation.component event + dedupTypedBindings [] (globals ++ eventBindings) + +def ComponentValuation.validate (valuation : ComponentValuation) + (project : EventB.Typing.Project) (event : String) (env : ValueEnv) : + Except EvalError Unit := + ValueEnv.validate (valuation.declarationsForEvent project event) env + +def deterministicActionAssignments (action : EventB.Elem) : + Except EvalError (List (String × EventB.Formula.Term)) := + match action.attr? "org.eventb.core.assignment" with + | none => .ok [] + | some source => + match EventB.Formula.parse source with + | .error _ => .error (.unsupported (.id source)) + | .ok (.bin "≔" lhs rhs) => + let targets := EventB.Formula.flattenCommas lhs + let values := EventB.Formula.flattenCommas rhs + if targets.length != values.length then .error .assignmentArity + else + targets.zip values |>.mapM fun (target, value) => + match target with + | .id name => .ok (name, value) + | _ => .error (.invalidTarget (EventB.Formula.print target)) + | .ok term => .error (.unsupported term) + +def ComponentValuation.eventAssignments (valuation : ComponentValuation) + (project : EventB.Typing.Project) (event : String) : + Except EvalError (List (String × EventB.Formula.Term)) := + match EventB.Typing.lookupComponent project valuation.component with + | none => .error (.unbound valuation.component) + | some component => + match component.elem.children.find? (fun candidate => + candidate.tag == "org.eventb.core.event" && + candidate.attr? "org.eventb.core.label" == some event) with + | none => .error (.unbound event) + | some eventElem => + EventB.POG.effectiveActions project valuation.component eventElem |>.flatMapM + deterministicActionAssignments + +def ComponentValuation.parallelAssign (valuation : ComponentValuation) + (project : EventB.Typing.Project) (event : String) (env : ValueEnv) + (updates : List (String × EventB.Formula.Term)) : Except EvalError CheckedBeforeAfter := do + let expected ← valuation.eventAssignments project event + if updates != expected then + .error (.invalidTarget ("updates do not match effective actions of " ++ event)) + else if let some invalid := updates.find? + (fun update => !valuation.variables.contains update.1) then + .error (.invalidTarget invalid.1) + else + ValueEnv.parallelAssignTyped (valuation.declarationsForEvent project event) env updates + +def assignmentRelation (fuel : Nat) + (declarations : List (String × EventB.Typing.Ty)) (transition : CheckedBeforeAfter) + (updates : List (String × EventB.Formula.Term)) : Prop := + transition.declarations = declarations ∧ + ValueEnv.validationOk fuel declarations transition.before = true ∧ + ValueEnv.validationOk fuel declarations transition.after = true ∧ + ValueEnv.parallelAssignTypedFuel fuel declarations transition.before updates = .ok transition + +theorem assignmentRelation_x_self_zero : + assignmentRelation 128 [("x", .int)] + { before := { values := [("x", .integer 0)] } + after := { values := [("x", .integer 0)] } + declarations := [("x", .int)] } + [("x", .id "x")] := by + unfold assignmentRelation + native_decide + +theorem assignmentRelation_x_zero : + assignmentRelation 128 [("x", .int)] + { before := { values := [("x", .integer 0)] } + after := { values := [("x", .integer 0)] } + declarations := [("x", .int)] } + [("x", .num 0)] := by + unfold assignmentRelation + native_decide + +theorem assignmentRelation_x_one : + assignmentRelation 128 [("x", .int)] + { before := { values := [("x", .integer 1)] } + after := { values := [("x", .integer 1)] } + declarations := [("x", .int)] } + [("x", .num 1)] := by + unfold assignmentRelation + native_decide + +theorem assignmentPredicate_x_prime_in_zero : + assignmentPredicateWithFuel 128 + { before := { values := [("x", .integer 0)] } + after := { values := [("x", .integer 0)] } + declarations := [("x", .int)] } + (.bin "∈" (.id "x'") (.set [.num 0])) := by + unfold assignmentPredicateWithFuel + native_decide + +theorem assignmentPredicate_x_in_integer_set : + assignmentPredicateWithFuel 128 + { before := { values := [("x", .integer 0)] } + after := { values := [("x", .integer 0)] } + declarations := [("x", .int)] } + (.bin "∈" (.id "x") (.id "ℤ")) := by + unfold assignmentPredicateWithFuel + native_decide + +theorem assignmentPredicate_x_self_zero : + assignmentPredicateWithFuel 128 + { before := { values := [("x", .integer 0)] } + after := { values := [("x", .integer 0)] } + declarations := [("x", .int)] } + (.bin "=" (.id "x'") (.id "x")) := by + unfold assignmentPredicateWithFuel + native_decide + +mutual + +def supportsValue : EventB.Formula.Term → Bool + | .id name => !name.endsWith "'" + | .num _ => true + | .pre "−" value => supportsValue value + | .pre _ _ => false + | .bin op left right => + (op == "↦" || op == "+" || op == "−" || op == "∗" || + op == "÷" || op == "mod" || op == "∪" || op == "∩" || op == "∖" || + op == "◁" || op == "⩤" || op == "▷" || op == "⩥" || op == "") && + supportsValue left && supportsValue right + | .set values => supportsValueList values + | .post _ _ | .bind _ _ _ => false + | .app function argument | .img function argument => + supportsValue function && supportsValue argument + +def supportsValueList : List EventB.Formula.Term → Bool + | [] => true + | value :: values => supportsValue value && supportsValueList values + +end + +#guard supportsValue (.app (.id "f") (.num 0)) + +def supportsPredicate : EventB.Formula.Term → Bool + | .id _ => true + | .pre "¬" predicate => supportsPredicate predicate + | .pre _ _ => false + | .bin op left right => + if op == "∧" || op == "∨" || op == "⇒" || op == "⇔" then + supportsPredicate left && supportsPredicate right + else if op == "=" || op == "≠" || op == "<" || op == "≤" || op == ">" || + op == "≥" || op == "∈" || op == "∉" || op == "⊆" || op == "⊈" || + op == "⊂" || op == "⊄" then + supportsValue left && supportsValue right + else false + | .bind "∃" (.bin "⦂" (.id _) (.id "ℤ")) body + | .bind "∃" (.bin "⦂" (.id _) (.id "ℕ")) body + | .bind "∃" (.bin "⦂" (.id _) (.id "ℕ1")) body + | .bind "∃" (.bin "⦂" (.id _) (.id "BOOL")) body => supportsPredicate body + | .app (.id "finite") argument => supportsValue argument + | .num _ | .set _ | .post _ _ | .app _ _ | .img _ _ | .bind _ _ _ => false + +#guard supportsPredicate (.app (.id "finite") (.id "S")) +#guard !supportsPredicate (.app (.id "finite") (.post "x" (.id "x"))) +#guard match evalPredicate { values := [("S", .set [.integer 0])] } + (.app (.id "finite") (.id "S")) with + | .ok true => true + | _ => false +#guard match evalPredicate {} + (.app (.id "finite") (.id "ℤ")) with + | .ok false => true + | _ => false + +mutual + +def supportsBeforeAfterValue : EventB.Formula.Term → Bool + | .id _ => true + | .num _ => true + | .pre "−" value => supportsBeforeAfterValue value + | .pre _ _ => false + | .bin op left right => + (op == "↦" || op == "+" || op == "−" || op == "∗" || + op == "÷" || op == "mod" || op == "∪" || op == "∩" || op == "∖" || + op == "◁" || op == "⩤" || op == "▷" || op == "⩥" || op == "") && + supportsBeforeAfterValue left && supportsBeforeAfterValue right + | .set values => supportsBeforeAfterValueList values + | .post _ _ | .bind _ _ _ => false + | .app function argument | .img function argument => + supportsBeforeAfterValue function && supportsBeforeAfterValue argument + +def supportsBeforeAfterValueList : List EventB.Formula.Term → Bool + | [] => true + | value :: values => supportsBeforeAfterValue value && supportsBeforeAfterValueList values + +end + +#guard supportsBeforeAfterValue (.img (.id "f") (.num 0)) + +#guard match evalPredicate + { values := [("b", .boolean true)] } + (.bin "⊆" (.set [.num 1]) (.set [.id "b"])) with + | .error (.typeMismatch _ _) => true + | _ => false +#guard match evalValue + { values := [("b", .boolean true)] } + (.bin "∖" (.set [.num 1]) (.set [.id "b"])) with + | .error (.typeMismatch _ _) => true + | _ => false + +def supportsBeforeAfterPredicate : EventB.Formula.Term → Bool + | .id _ => true + | .pre "¬" predicate => supportsBeforeAfterPredicate predicate + | .pre _ _ => false + | .bin op left right => + if op == "∧" || op == "∨" || op == "⇒" || op == "⇔" then + supportsBeforeAfterPredicate left && supportsBeforeAfterPredicate right + else if op == "=" || op == "≠" || op == "<" || op == "≤" || op == ">" || + op == "≥" || op == "∈" || op == "∉" || op == "⊆" || op == "⊈" || + op == "⊂" || op == "⊄" then + supportsBeforeAfterValue left && supportsBeforeAfterValue right + else false + | .bind "∃" (.bin "⦂" (.id _) (.id "ℤ")) body + | .bind "∃" (.bin "⦂" (.id _) (.id "ℕ")) body + | .bind "∃" (.bin "⦂" (.id _) (.id "ℕ1")) body + | .bind "∃" (.bin "⦂" (.id _) (.id "BOOL")) body => supportsBeforeAfterPredicate body + | .app (.id "finite") argument => supportsBeforeAfterValue argument + | .num _ | .set _ | .post _ _ | .app _ _ | .img _ _ | .bind _ _ _ => false + +private def typedBindingProject : 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 ≔ 1")] []]] }] + +private def badTypedBindingProject : EventB.Typing.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", "missing = 0")] [] + , .event [("org.eventb.core.label", "INITIALISATION")] []] }] + +#guard !Obligation.sourceBound typedBindingProject + { component := "M", name := "INITIALISATION/x/EQL", kind := "EQL" } +#guard !Obligation.sourceBound typedBindingProject + { component := "M", name := "INITIALISATION/y/EQL", kind := "EQL" } + +#guard match ComponentValuation.fromProject EventB.Theory.empty typedBindingProject "M" with + | .ok valuation => + valuation.types.any (fun binding => binding.1 == "x" && binding.2 == .int) && + valuation.variables.contains "x" + | .error _ => false +#guard match ComponentValuation.fromProject EventB.Theory.empty typedBindingProject "M" with + | .ok valuation => + match valuation.parallelAssign typedBindingProject "INITIALISATION" + { values := [("x", .integer 0)] } [("x", .num 1)] with + | .ok transition => transition.after.lookupMatches "x" (.integer 1) + | .error _ => false + | .error _ => false +#guard match ComponentValuation.fromProject EventB.Theory.empty badTypedBindingProject "M" with + | .error error => error.kind == .typing + | .ok _ => false +#guard match ComponentValuation.fromProject EventB.Theory.empty typedBindingProject "M" with + | .ok valuation => + match valuation.parallelAssign typedBindingProject "MISSING" + { values := [("x", .integer 0)] } [] with + | .error (.unbound "MISSING") => true + | _ => false + | .error _ => false +#guard match ComponentValuation.fromProject EventB.Theory.empty typedBindingProject "M" with + | .ok valuation => + match valuation.parallelAssign typedBindingProject "INITIALISATION" + { values := [("x", .integer 0)] } [("x", .num 2)] with + | .error (.invalidTarget _) => true + | _ => false + | .error _ => false + +structure TypedFormulaModel where + declarations : List (String × EventB.Typing.Ty) + fuel : Nat + wellFormed : ValueEnv → Prop + /-- The semantic domain must contain an actual validated state; `False` is not a + proof shortcut. -/ + inhabited : ∃ env, wellFormed env + validated : ∀ env, wellFormed env → ValueEnv.validationOk fuel declarations env = true + complete : ∀ env, ValueEnv.validationOk fuel declarations env = true → wellFormed env + supports : EventB.Formula.Term → Bool + +def TypedFormulaModel.denote (_model : TypedFormulaModel) + (term : EventB.Formula.Term) (env : ValueEnv) : Prop := + evalPredicateAtFuel _model.fuel env term = .ok true + +def TypedFormulaModel.on {τ : Type u} (model : TypedFormulaModel) + (encode : τ → ValueEnv) : FormulaModel τ := + { denote := fun term state => model.denote term (encode state) } + +def TypedFormulaModel.defined (_model : TypedFormulaModel) + (term : EventB.Formula.Term) (env : ValueEnv) : Prop := + ∃ value, evalPredicateAtFuel _model.fuel env term = .ok value + +def TypedFormulaModel.formulaModel (model : TypedFormulaModel) : FormulaModel ValueEnv := + { denote := model.denote } + +def TypedFormulaModel.validUnchecked (model : TypedFormulaModel) (obligation : Obligation) : Prop := + if obligation.semanticShapeValid = true && obligation.valuationSupported = true then + match obligation.kind, obligation.goal with + | _, some goal => + model.supports goal = true ∧ obligation.hyps.all model.supports = true ∧ + ∀ env, model.wellFormed env → + (model.defined goal env ∧ + ∀ hypothesis ∈ obligation.hyps, model.defined hypothesis env) ∧ + ((∀ hypothesis ∈ obligation.hyps, model.denote hypothesis env) → + model.denote goal env) + | "WWD", none => + obligation.hyps.all model.supports = true ∧ + ∀ env, model.wellFormed env → + ∀ hypothesis ∈ obligation.hyps, + model.defined hypothesis env ∧ model.denote hypothesis env + | _, none => False + else False + +theorem TypedFormulaModel.valid_on + {τ : Type u} (model : TypedFormulaModel) (encode : τ → ValueEnv) + (obligation : Obligation) + (valid : model.validUnchecked obligation) + (wellFormed : ∀ state, model.wellFormed (encode state)) : + FormulaModel.validUnchecked (model.on encode) obligation := by + unfold TypedFormulaModel.validUnchecked at valid + unfold FormulaModel.validUnchecked + by_cases shape : obligation.semanticShapeValid = true + · by_cases valuation : obligation.valuationSupported = true + · cases goal : obligation.goal with + | none => + by_cases wwd : obligation.kind = "WWD" + · simp [shape, valuation, goal, wwd, TypedFormulaModel.on] at valid ⊢ + intro state hypothesis member + rcases List.mem_map.1 member with ⟨term, termMember, rfl⟩ + exact (valid.2 (encode state) (wellFormed state) term termMember).2 + · simp [shape, valuation, goal, wwd] at valid ⊢ + | some target => + simp [shape, valuation, goal, TypedFormulaModel.on] at valid ⊢ + intro state hypotheses + apply (valid.2.2 (encode state) (wellFormed state)).2 + intro term termMember + exact hypotheses (fun state' => model.denote term (encode state')) + (List.mem_map.mpr ⟨term, termMember, rfl⟩) + · simp [TypedFormulaModel.validUnchecked, shape, valuation] at valid + · simp [TypedFormulaModel.validUnchecked, shape] at valid + +/- Formula validity over an explicit semantic state domain. Unlike the historical + `validUnchecked` path, this does not pretend that every type-correct valuation is + a reachable/invariant state; the caller must provide the domain and prove every + encoded semantic state lies in it. -/ +def TypedFormulaModel.validOnDomain + (model : TypedFormulaModel) (domain : ValueEnv → Prop) + (obligation : Obligation) : Prop := + if obligation.semanticShapeValid = true && obligation.valuationSupported = true then + match obligation.kind, obligation.goal with + | _, some goal => + model.supports goal = true ∧ obligation.hyps.all model.supports = true ∧ + ∀ env, domain env → + (model.defined goal env ∧ + ∀ hypothesis ∈ obligation.hyps, model.defined hypothesis env) ∧ + ((∀ hypothesis ∈ obligation.hyps, model.denote hypothesis env) → + model.denote goal env) + | "WWD", none => obligation.hyps.all model.supports = true ∧ + ∀ env, domain env → + ∀ hypothesis ∈ obligation.hyps, + model.defined hypothesis env ∧ model.denote hypothesis env + | _, none => False + else False + +theorem TypedFormulaModel.validOnDomain_on + {τ : Type u} (model : TypedFormulaModel) (domain : ValueEnv → Prop) + (encode : τ → ValueEnv) (obligation : Obligation) + (valid : model.validOnDomain domain obligation) + (stateDomain : ∀ state, domain (encode state)) : + FormulaModel.validUnchecked (model.on encode) obligation := by + unfold TypedFormulaModel.validOnDomain at valid + unfold FormulaModel.validUnchecked + by_cases shape : obligation.semanticShapeValid = true + · by_cases valuation : obligation.valuationSupported = true + · cases goal : obligation.goal with + | none => + by_cases wwd : obligation.kind = "WWD" + · simp [shape, valuation, goal, wwd, TypedFormulaModel.on] at valid ⊢ + intro state hypothesis member + rcases List.mem_map.1 member with ⟨term, termMember, rfl⟩ + exact (valid.2 (encode state) (stateDomain state) term termMember).2 + · simp [shape, valuation, goal, wwd] at valid ⊢ + | some target => + simp [shape, valuation, goal, TypedFormulaModel.on] at valid ⊢ + intro state hypotheses + apply (valid.2.2 (encode state) (stateDomain state)).2 + intro term termMember + exact hypotheses (fun state' => model.denote term (encode state')) + (List.mem_map.mpr ⟨term, termMember, rfl⟩) + · simp [TypedFormulaModel.validOnDomain, shape, valuation] at valid + · simp [TypedFormulaModel.validOnDomain, shape] at valid + +def TypedFormulaModel.valid (model : TypedFormulaModel) + (theory : EventB.Theory.Env) (project : EventB.Typing.Project) + (obligation : Obligation) : Prop := + obligation.checkedIn theory project ∧ + (match EventB.Typing.inferComponentDetailsCheckedIn theory project obligation.component with + | .ok details => model.declarations = details.types + | .error _ => False) ∧ + (∀ env, ValueEnv.validationOk model.fuel model.declarations env = true → + model.wellFormed env) ∧ model.validUnchecked obligation + +structure TypedTransitionModel where + fuel : Nat + wellFormed : CheckedBeforeAfter → Prop + inhabited : ∃ transition, wellFormed transition + supports : EventB.Formula.Term → Bool + +def TypedTransitionModel.denote (model : TypedTransitionModel) + (term : EventB.Formula.Term) (transition : CheckedBeforeAfter) : Prop := + evalBeforeAfter model.fuel transition term = .ok true + +def TypedTransitionModel.on {τ : Type u} (model : TypedTransitionModel) + (encode : τ → CheckedBeforeAfter) : FormulaModel τ := + { denote := fun term state => model.denote term (encode state) } + +def TypedTransitionModel.defined (model : TypedTransitionModel) + (term : EventB.Formula.Term) (transition : CheckedBeforeAfter) : Prop := + ∃ value, evalBeforeAfter model.fuel transition term = .ok value + +def TypedTransitionModel.validUnchecked (model : TypedTransitionModel) + (obligation : Obligation) : Prop := + if obligation.semanticShapeValid = true && obligation.transitionValuationSupported = true then + match obligation.goal with + | some goal => + model.supports goal = true ∧ obligation.hyps.all model.supports = true ∧ + ∀ transition, model.wellFormed transition → + (model.defined goal transition ∧ + ∀ hypothesis ∈ obligation.hyps, model.defined hypothesis transition) ∧ + ((∀ hypothesis ∈ obligation.hyps, model.denote hypothesis transition) → + model.denote goal transition) + | none => False + else False + +theorem TypedTransitionModel.valid_on + {τ : Type u} (model : TypedTransitionModel) + (encode : τ → CheckedBeforeAfter) (obligation : Obligation) + (valid : model.validUnchecked obligation) + (wellFormed : ∀ state, model.wellFormed (encode state)) : + FormulaModel.validUnchecked (model.on encode) obligation := by + unfold TypedTransitionModel.validUnchecked at valid + unfold FormulaModel.validUnchecked + by_cases shape : obligation.semanticShapeValid = true + · by_cases valuation : obligation.transitionValuationSupported = true + · cases goal : obligation.goal with + | none => + simp [shape, valuation, goal] at valid ⊢ + | some target => + simp [shape, valuation, goal, TypedTransitionModel.on] at valid ⊢ + intro state hypotheses + apply (valid.2.2 (encode state) (wellFormed state)).2 + intro term termMember + exact hypotheses (fun state' => model.denote term (encode state')) + (List.mem_map.mpr ⟨term, termMember, rfl⟩) + · simp [TypedTransitionModel.validUnchecked, shape, valuation] at valid + · simp [TypedTransitionModel.validUnchecked, shape] at valid + +/- A source-bound transition domain is the missing bridge between a typed + evaluator and a refinement event. `validUnchecked` remains useful for + local evaluator fixtures, but accepting adapters must quantify over the + checked source relation rather than over an arbitrary singleton chosen by + the evaluator author. -/ +def TypedTransitionModel.validOnDomain + (model : TypedTransitionModel) + (domain : CheckedBeforeAfter → Prop) + (obligation : Obligation) : Prop := + if obligation.semanticShapeValid = true && obligation.transitionValuationSupported = true then + match obligation.goal with + | some goal => + model.supports goal = true ∧ obligation.hyps.all model.supports = true ∧ + ∀ transition, domain transition → + (model.defined goal transition ∧ + ∀ hypothesis ∈ obligation.hyps, model.defined hypothesis transition) ∧ + ((∀ hypothesis ∈ obligation.hyps, model.denote hypothesis transition) → + model.denote goal transition) + | none => False + else False + +theorem TypedTransitionModel.validOnDomain_on + {τ : Type u} (model : TypedTransitionModel) + (domain : CheckedBeforeAfter → Prop) + (encode : τ → CheckedBeforeAfter) (obligation : Obligation) + (valid : model.validOnDomain domain obligation) + (domainValid : ∀ state, domain (encode state)) : + FormulaModel.validUnchecked (model.on encode) obligation := by + unfold TypedTransitionModel.validOnDomain at valid + unfold FormulaModel.validUnchecked + by_cases shape : obligation.semanticShapeValid = true + · by_cases valuation : obligation.transitionValuationSupported = true + · cases goal : obligation.goal with + | none => simp [shape, valuation, goal] at valid ⊢ + | some target => + simp [shape, valuation, goal, TypedTransitionModel.on] at valid ⊢ + intro state hypotheses + apply (valid.2.2 (encode state) (domainValid state)).2 + intro term termMember + exact hypotheses (fun state' => model.denote term (encode state')) + (List.mem_map.mpr ⟨term, termMember, rfl⟩) + · simp [TypedTransitionModel.validOnDomain, shape, valuation] at valid + · simp [TypedTransitionModel.validOnDomain, shape] at valid + +structure TransitionSourceCoverage (τ : Type u) where + encode : τ → CheckedBeforeAfter + source : CheckedBeforeAfter → Prop + sourceComplete : ∀ transition, source transition → ∃ state, encode state = transition + +theorem TransitionSourceCoverage.sourceState + {τ : Type u} (coverage : TransitionSourceCoverage τ) + (transition : CheckedBeforeAfter) (source : coverage.source transition) : + ∃ state, coverage.encode state = transition := + coverage.sourceComplete transition source + +/- A transition domain must be bound to the concrete event's checked assignment + relation before it can be an accepting API. The legacy singleton model is kept + only for local evaluator fixtures. -/ +def TypedTransitionModel.valid (_model : TypedTransitionModel) + (_theory : EventB.Theory.Env) (_project : EventB.Typing.Project) + (_obligation : Obligation) : Prop := + False + +private def TypedTransitionModel.ofAssignment (fuel : Nat) + (declarations : List (String × EventB.Typing.Ty)) (env : ValueEnv) + (updates : List (String × EventB.Formula.Term)) : Option TypedTransitionModel := + match ValueEnv.parallelAssignTypedFuel fuel declarations env updates with + | .error _ => none + | .ok transition => + some + { fuel := fuel + wellFormed := fun candidate => candidate = transition + inhabited := ⟨transition, rfl⟩ + supports := supportsBeforeAfterPredicate } + +private def incrementTransition : CheckedBeforeAfter := + { before := { values := [("x", .integer 1)] } + after := { values := [("x", .integer 2)] } + declarations := [("x", .int)] } + +private def incrementModel : TypedTransitionModel := + { fuel := 64 + wellFormed := fun transition => transition = incrementTransition + inhabited := ⟨incrementTransition, rfl⟩ + supports := supportsBeforeAfterPredicate } + +example : TypedTransitionModel.validUnchecked incrementModel + { component := "M", name := "step/inv/INV", kind := "INV" + hyps := [.bin "=" (.id "x") (.num 1)] + goal := some (.bin "=" (.id "x'") (.num 2)) } := by + constructor + · rfl + constructor + · rfl + · intro transition wellFormed + subst transition + have integerCompatible : (ValueType.integer == ValueType.integer) = true := + by native_decide + have afterWellFormed : ValueEnv.valueIsWellFormed 63 + { values := [("x", .integer 2)] } (.integer 2) = true := by native_decide + have beforeWellFormed : ValueEnv.valueIsWellFormed 63 + { values := [("x", .integer 1)] } (.integer 1) = true := by native_decide + have beforeValidated : ValueEnv.validationOk 64 [("x", .int)] + { values := [("x", .integer 1)] } = true := by native_decide + have afterValidated : ValueEnv.validationOk 64 [("x", .int)] + { values := [("x", .integer 2)] } = true := by native_decide + constructor + · constructor + · refine ⟨true, ?_⟩ + simp [incrementModel, TypedTransitionModel.denote, TypedTransitionModel.defined, + evalBeforeAfter, evalPredicateFuel, evalValueFuel, EvalView.lookup, ValueEnv.lookup, + Value.isWellFormed, ValueEnv.valueIsWellFormed, Value.sameType, Value.typeOf, + ValueType.compatible, valueEqual, + xPrimeEndsWith, xEndsWith, xPrimeBase, + integerCompatible, afterWellFormed, beforeWellFormed, beforeValidated, afterValidated, + Bind.bind, Except.bind, + incrementTransition] + · intro hypothesis member + simp at member + subst hypothesis + refine ⟨true, ?_⟩ + simp [incrementModel, TypedTransitionModel.denote, TypedTransitionModel.defined, + evalBeforeAfter, evalPredicateFuel, evalValueFuel, EvalView.lookup, ValueEnv.lookup, + Value.isWellFormed, ValueEnv.valueIsWellFormed, Value.sameType, Value.typeOf, + ValueType.compatible, valueEqual, + xPrimeEndsWith, xEndsWith, xPrimeBase, + integerCompatible, afterWellFormed, beforeWellFormed, beforeValidated, afterValidated, + Bind.bind, Except.bind, + incrementTransition] + · intro _ + simp [incrementModel, TypedTransitionModel.denote, evalBeforeAfter, evalPredicateFuel, + evalValueFuel, EvalView.lookup, ValueEnv.lookup, Value.isWellFormed, + ValueEnv.valueIsWellFormed, Value.sameType, + Value.typeOf, ValueType.compatible, valueEqual, xPrimeEndsWith, xEndsWith, xPrimeBase, + integerCompatible, afterWellFormed, beforeWellFormed, beforeValidated, afterValidated, + Bind.bind, Except.bind, + incrementTransition] + +example : ¬ TypedTransitionModel.validUnchecked incrementModel + { component := "M", name := "forged/inv/INV", kind := "INV" + goal := some (.bin "=" (.id "x'") (.num 3)) } := by + intro proof + have goalProof := (proof.2.2 incrementTransition rfl).2 (by simp) + have integerCompatible : (ValueType.integer == ValueType.integer) = true := + by native_decide + have afterWellFormed : ValueEnv.valueIsWellFormed 63 + { values := [("x", .integer 2)] } (.integer 2) = true := by native_decide + have beforeValidated : ValueEnv.validationOk 64 [("x", .int)] + { values := [("x", .integer 1)] } = true := by native_decide + have afterValidated : ValueEnv.validationOk 64 [("x", .int)] + { values := [("x", .integer 2)] } = true := by native_decide + simp [incrementModel, TypedTransitionModel.denote, evalBeforeAfter, evalPredicateFuel, + evalValueFuel, EvalView.lookup, ValueEnv.lookup, Value.isWellFormed, + ValueEnv.valueIsWellFormed, Value.sameType, + Value.typeOf, ValueType.compatible, valueEqual, xPrimeEndsWith, xEndsWith, xPrimeBase, + integerCompatible, afterWellFormed, beforeValidated, afterValidated, + Bind.bind, Except.bind, + incrementTransition] at goalProof + +#guard supportsPredicate (.bin "<" (.num 0) (.num 1)) +#guard !supportsPredicate (.app (.id "f") (.num 0)) +#guard match ValueEnv.parallelAssign { values := [("x", .integer 1), ("y", .integer 2)] } + [("x", .id "y"), ("y", .id "x")] with + | .ok transition => + transition.after.lookupMatches "x" (.integer 2) && + transition.after.lookupMatches "y" (.integer 1) + | .error _ => false +#guard match ValueEnv.parallelAssign { values := [("x", .integer 1)] } + [("x", .num 0), ("x", .num 1)] with + | .error (.duplicateAssignment _) => true + | _ => false +#guard match evalPredicate {} (.bin "∈" (.num 1) (.id "BOOL")) with + | .error (.typeMismatch _ _) => true + | _ => false +#guard match evalPredicate {} (.bin "=" (.set [.num 1, .num 2]) (.set [.num 2, .num 1])) with + | .ok true => true + | _ => false +#guard match evalPredicate { values := [("b", .boolean true)] } + (.bin "=" (.set [.set [.num 1]]) (.set [.set [.id "b"]])) with + | .error (.typeMismatch _ _) => true + | _ => false +#guard match evalPredicate {} (.bin "∈" (.num 1) (.id "BOOL")) with + | .error (.typeMismatch _ _) => true + | _ => false +#guard match evalValue {} (.bin "+" (.num 1) (.id "BOOL")) with + | .error (.typeMismatch _ _) => true + | _ => false +#guard match evalValue {} (.bin "÷" (.num 1) (.num 0)) with + | .error .divisionByZero => true + | _ => false +#guard match evalValue {} (.bin "," (.num 1) (.num 2)) with + | .error (.unsupported _) => true + | _ => false +#guard match evalValue {} (.id "missing") with + | .error (.unbound "missing") => true + | _ => false +#guard match evalValue {} (.id "x'") with + | .error (.unsupported _) => true + | _ => false +#guard match evalValue { values := [("s", .set [.integer 1, .boolean true])] } (.id "s") with + | .error .invalidValue => true + | _ => false +#guard match evalPredicate { values := [("s", .set [.integer 1, .boolean true])] } + (.bin "∈" (.num 1) (.id "s")) with + | .error .invalidValue => true + | _ => false +#guard match ValueEnv.parallelAssignTerms {} ["x"] [] with + | .error .assignmentArity => true + | _ => false +#guard match ValueEnv.validate [("x", .int)] { values := [("x", .integer 1)] } with + | .ok () => true + | _ => false +#guard match ValueEnv.validate [("x", .int)] { values := [("x", .boolean true)] } with + | .error (.typeMismatch _ _) => true + | _ => false +#guard match ValueEnv.parallelAssignTyped + [("x", .int), ("y", .int)] + { values := [("x", .integer 1), ("y", .integer 2)] } + [("x", .id "y"), ("y", .id "x")] with + | .ok transition => + transition.after.lookupMatches "x" (.integer 2) && + transition.after.lookupMatches "y" (.integer 1) + | _ => false +#guard match ValueEnv.parallelAssignTyped + [("x", .int), ("b", .bool)] + { values := [("x", .integer 1), ("b", .boolean true)] } + [("x", .id "b")] with + | .error (.typeMismatch _ _) => true + | _ => false +#guard match ValueEnv.validate [("a", .given "AIR")] { + values := [("a", .atom "AIR" "one")], carriers := [("AIR", ["one"])] } with + | .ok () => true + | _ => false +#guard match ValueEnv.validate [("a", .given "AIR")] { + values := [("a", .atom "AIR" "one")] } with + | .error .invalidValue => true + | _ => false +#guard match CheckedBeforeAfter.make 32 [("x", .int)] + { values := [("x", .integer 1)] } { values := [("x", .integer 2)] } with + | .ok transition => + match evalBeforeAfter 32 transition (.bin "=" (.id "x'") (.num 2)) with + | .ok true => true + | _ => false + | _ => false +#guard match CheckedBeforeAfter.make 32 [("x", .int)] + { values := [("x", .integer 1)] } { values := [("y", .integer 2)] } with + | .error (.unbound "x") => true + | _ => false +#guard match CheckedBeforeAfter.make 32 [("x", .int)] + { values := [("x", .integer 1)] } { values := [("x", .integer 2)] } with + | .ok transition => + match evalBeforeAfter 32 transition (.bin "=" (.id "y'") (.num 2)) with + | .error (.unbound "y'") => true + | _ => false + | _ => false +#guard supportsBeforeAfterPredicate + (.bin "∧" (.bin "=" (.id "x") (.num 1)) (.bin "=" (.id "x'") (.num 2))) +#guard match evalPredicateWithFuel 0 {} (.id "⊤") with + | .error .fuelExhausted => true + | _ => false + +private def typedFormulaModel (supports : EventB.Formula.Term → Bool) : TypedFormulaModel := + { declarations := [("x", .int)] + fuel := 128 + wellFormed := fun env => ValueEnv.validationOk 128 [("x", .int)] env = true + inhabited := ⟨{ values := [("x", .integer 0)] }, by native_decide⟩ + validated := fun _ proof => proof + complete := fun _ proof => proof + supports := supports } + +private def typedEnv : ValueEnv := { values := [("x", .integer 0)] } + +private theorem typedEnvWellFormed (supports : EventB.Formula.Term → Bool) : + (typedFormulaModel supports).wellFormed typedEnv := by + change ValueEnv.validationOk 128 [("x", .int)] typedEnv = true + native_decide + +private theorem typedFormulaValid : + TypedFormulaModel.validUnchecked (typedFormulaModel (fun _ => true)) + { component := "M", name := "arith/THM", kind := "THM" + hyps := [.bin "≤" (.num 0) (.num 1)] + goal := some (.bin "<" (.num 0) (.num 1)) } := by + constructor + · rfl + constructor + · rfl + · intro env _ + have integerCompatible : (ValueType.integer == ValueType.integer) = true := by native_decide + constructor + · constructor + · refine ⟨true, ?_⟩ + simp [typedFormulaModel, evalPredicate, evalPredicateAtFuel, evalPredicateWithFuel, + evalPredicateFuel, evalValue, evalValueWithFuel, evalValueFuel, Bind.bind, Except.bind] + · intro hypothesis member + simp at member + subst hypothesis + refine ⟨true, ?_⟩ + simp [typedFormulaModel, evalPredicate, evalPredicateAtFuel, evalPredicateWithFuel, + evalPredicateFuel, evalValue, evalValueWithFuel, evalValueFuel, Bind.bind, Except.bind] + · intro _ + simp [typedFormulaModel, TypedFormulaModel.denote, evalPredicate, evalPredicateAtFuel, + evalPredicateWithFuel, evalPredicateFuel, evalValue, evalValueWithFuel, evalValueFuel, + Bind.bind, Except.bind] + +def constantTypedFormulaModel : 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 } + +theorem constantTypedFormulaModel_taut_valid : + TypedFormulaModel.validUnchecked constantTypedFormulaModel + { component := "M", name := "taut/THM", kind := "THM" + goal := some (.bin "=" (.num 1) (.num 1)) } := by + constructor + · rfl + constructor + · rfl + · intro env _ + have integerCompatible : (ValueType.integer == ValueType.integer) = true := by native_decide + constructor + · constructor + · refine ⟨true, ?_⟩ + simp [constantTypedFormulaModel, TypedFormulaModel.defined, + evalPredicateAtFuel, evalPredicateWithFuel, evalPredicateFuel, evalValue, + evalValueWithFuel, evalValueFuel, ValueEnv.lookup, Value.sameType, + Value.typeOf, ValueType.compatible, valueEqual, integerCompatible, + Bind.bind, Except.bind] + · intro hypothesis member + simp at member + · intro _ + simp [constantTypedFormulaModel, TypedFormulaModel.denote, + evalPredicateAtFuel, evalPredicateWithFuel, evalPredicateFuel, evalValue, + evalValueWithFuel, evalValueFuel, ValueEnv.lookup, Value.sameType, + Value.typeOf, ValueType.compatible, valueEqual, integerCompatible, + Bind.bind, Except.bind] + +private def constantTransition : CheckedBeforeAfter := + { before := {}, after := {}, declarations := [] } + +def constantTypedTransitionModel : TypedTransitionModel := + { fuel := 128 + wellFormed := fun transition => transition = constantTransition + inhabited := ⟨constantTransition, rfl⟩ + supports := fun _ => true } + +theorem constantTypedTransitionModel_taut_valid : + TypedTransitionModel.validUnchecked constantTypedTransitionModel + { component := "M", name := "INITIALISATION/taut/INV", kind := "INV" + goal := some (.bin "=" (.num 1) (.num 1)) } := by + constructor + · rfl + constructor + · rfl + · intro transition transitionValid + subst transition + constructor + · constructor + · refine ⟨true, ?_⟩ + have validation : ValueEnv.validationOk 128 [] ({} : ValueEnv) = true := by + native_decide + have integerCompatible : (ValueType.integer == ValueType.integer) = true := by + native_decide + simp [constantTypedTransitionModel, TypedTransitionModel.defined, constantTransition, + validation, integerCompatible, evalBeforeAfter, evalPredicateFuel, + evalValueFuel, ValueEnv.lookup, + Value.sameType, Value.typeOf, ValueType.compatible, valueEqual, + Bind.bind, Except.bind] + · intro hypothesis member + simp at member + · intro _ + have beforeValidation : ValueEnv.validationOk 128 [] ({} : ValueEnv) = true := by + native_decide + have integerCompatible : (ValueType.integer == ValueType.integer) = true := by + native_decide + simp [TypedTransitionModel.denote, constantTypedTransitionModel, constantTransition, + beforeValidation, integerCompatible, evalBeforeAfter, evalPredicateFuel, + evalValueFuel, ValueEnv.lookup, Value.sameType, Value.typeOf, ValueType.compatible, + valueEqual, Bind.bind, Except.bind] + +theorem constantTypedTransitionModel_grd_taut_valid : + TypedTransitionModel.validUnchecked constantTypedTransitionModel + { component := "C", name := "step/g/GRD", kind := "GRD" + goal := some (.bin "=" (.num 1) (.num 1)) } := by + simpa [TypedTransitionModel.validUnchecked, Obligation.semanticShapeValid, Obligation.shapeValid, + Obligation.transitionValuationSupported, POClass.ofKind, + POClass.transitionValuationSupported] using constantTypedTransitionModel_taut_valid + +theorem typedTransitionModel_taut_validOnDomain + (model : TypedTransitionModel) + (domain : CheckedBeforeAfter → Prop) + (domainValid : ∀ transition, domain transition → + ValueEnv.validationOk 128 transition.declarations transition.before = true ∧ + ValueEnv.validationOk 128 transition.declarations transition.after = true) + (obligation : Obligation) + (shape : obligation.semanticShapeValid = true) + (valuation : obligation.transitionValuationSupported = true) + (goal : obligation.goal = some (.bin "=" (.num 1) (.num 1))) + (hyps : obligation.hyps = []) + (fuel : model.fuel = 128) + (supports : ∀ term, model.supports term = true) : + TypedTransitionModel.validOnDomain model domain obligation := by + have integerCompatible : (ValueType.integer == ValueType.integer) = true := by + native_decide + unfold TypedTransitionModel.validOnDomain + have goalSupported : model.supports (.bin "=" (.num 1) (.num 1)) = true := + supports _ + simp [shape, valuation, goal, hyps, fuel, goalSupported, + TypedTransitionModel.defined, TypedTransitionModel.denote, evalBeforeAfter, + evalPredicateFuel, evalValueFuel, ValueEnv.lookup, Value.sameType, + Value.typeOf, ValueType.compatible, valueEqual, integerCompatible, + Bind.bind, Except.bind] + intro transition transitionDomain + obtain ⟨beforeValid, afterValid⟩ := domainValid transition transitionDomain + simp [beforeValid, afterValid, evalPredicateFuel, evalValueFuel, + ValueEnv.lookup, Value.sameType, Value.typeOf, ValueType.compatible, + valueEqual, integerCompatible, Bind.bind, Except.bind] + +theorem typedTransitionModel_closed_validOnDomain + (model : TypedTransitionModel) + (domain : CheckedBeforeAfter → Prop) + (domainValid : ∀ transition, domain transition → + ValueEnv.validationOk 128 transition.declarations transition.before = true ∧ + ValueEnv.validationOk 128 transition.declarations transition.after = true) + (obligation : Obligation) + (shape : obligation.semanticShapeValid = true) + (valuation : obligation.transitionValuationSupported = true) + (goal : EventB.Formula.Term) + (goalExact : obligation.goal = some goal) + (hyps : obligation.hyps = []) + (fuel : model.fuel = 128) + (supports : model.supports goal = true) + (evaluation : ∀ transition, domain transition → + evalBeforeAfter 128 transition goal = .ok true) : + TypedTransitionModel.validOnDomain model domain obligation := by + unfold TypedTransitionModel.validOnDomain + simp [shape, valuation, goalExact, hyps, fuel, supports, + TypedTransitionModel.validOnDomain] + intro transition transitionDomain + have evaluated := evaluation transition transitionDomain + constructor + · refine ⟨true, ?_⟩ + rw [fuel] + exact evaluated + · change evalBeforeAfter model.fuel transition goal = .ok true + rw [fuel] + exact evaluated + +private def stutterTransition : CheckedBeforeAfter := + { before := { values := [("x", .integer 0)] } + after := { values := [("x", .integer 0)] } + declarations := [("x", .int)] } + +def stutterTypedTransitionModel : TypedTransitionModel := + { fuel := 128 + wellFormed := fun transition => transition = stutterTransition + inhabited := ⟨stutterTransition, rfl⟩ + supports := supportsBeforeAfterPredicate } + +theorem stutterTypedTransitionModel_sim_valid : + TypedTransitionModel.validUnchecked stutterTypedTransitionModel + { component := "C", name := "step/set/SIM", kind := "SIM" + hyps := [.bin "∈" (.id "x") (.id "ℤ"), + .bin "∈" (.id "x") (.id "ℤ")] + goal := some (.bin "=" (.id "x") (.id "x")) } := by + constructor + · rfl + constructor + · rfl + · intro transition transitionValid + subst transition + have integerCompatible : (ValueType.integer == ValueType.integer) = true := by + native_decide + have beforeWellFormed : ValueEnv.valueIsWellFormed 127 + { values := [("x", .integer 0)] } (.integer 0) = true := by + native_decide + have afterWellFormed : ValueEnv.valueIsWellFormed 127 + { values := [("x", .integer 0)] } (.integer 0) = true := by + native_decide + have beforeValidated : ValueEnv.validationOk 128 [("x", .int)] + { values := [("x", .integer 0)] } = true := by + native_decide + have afterValidated : ValueEnv.validationOk 128 [("x", .int)] + { values := [("x", .integer 0)] } = true := by + native_decide + have xEndsWith : "x".endsWith "'" = false := by + native_decide + constructor + · constructor + · refine ⟨true, ?_⟩ + simp [stutterTypedTransitionModel, TypedTransitionModel.defined, + stutterTransition, evalBeforeAfter, evalPredicateFuel, evalValueFuel, + evalValueListFuel, Value.makeSet, + EvalView.lookup, ValueEnv.lookup, Value.isWellFormed, + ValueEnv.valueIsWellFormed, Value.sameType, Value.typeOf, + ValueType.compatible, Value.contains, memberOf, subsetOf, valueEqual, + xEndsWith, beforeWellFormed, afterWellFormed, + beforeValidated, afterValidated, integerCompatible, + Bind.bind, Except.bind] + · intro hypothesis member + simp at member + subst hypothesis + refine ⟨true, ?_⟩ + simp [stutterTypedTransitionModel, TypedTransitionModel.defined, + stutterTransition, evalBeforeAfter, evalPredicateFuel, evalValueFuel, + EvalView.lookup, ValueEnv.lookup, Value.isWellFormed, + ValueEnv.valueIsWellFormed, Value.sameType, Value.typeOf, + ValueType.compatible, Value.contains, memberOf, subsetOf, valueEqual, + xEndsWith, beforeWellFormed, afterWellFormed, + beforeValidated, afterValidated, integerCompatible, + Bind.bind, Except.bind] + · intro _ + simp [TypedTransitionModel.denote, stutterTypedTransitionModel, + stutterTransition, evalBeforeAfter, evalPredicateFuel, evalValueFuel, + evalValueListFuel, Value.makeSet, + EvalView.lookup, ValueEnv.lookup, Value.isWellFormed, + ValueEnv.valueIsWellFormed, Value.sameType, Value.typeOf, + ValueType.compatible, Value.contains, memberOf, subsetOf, valueEqual, + xEndsWith, beforeWellFormed, afterWellFormed, + beforeValidated, afterValidated, integerCompatible, + Bind.bind, Except.bind] + +theorem stutterTypedTransitionModel_fis_choose_valid : + TypedTransitionModel.validUnchecked stutterTypedTransitionModel + { component := "M", name := "INITIALISATION/choose/FIS", kind := "FIS" + goal := some (.bin "≠" (.set [.num 0]) (.set [])) } := by + constructor + · rfl + constructor + · rfl + · intro transition transitionValid + subst transition + have beforeWellFormed : ValueEnv.valueIsWellFormed 127 + { values := [("x", .integer 0)] } (.integer 0) = true := by + native_decide + have afterWellFormed : ValueEnv.valueIsWellFormed 127 + { values := [("x", .integer 0)] } (.integer 0) = true := by + native_decide + have beforeValidated : ValueEnv.validationOk 128 [("x", .int)] + { values := [("x", .integer 0)] } = true := by + native_decide + have afterValidated : ValueEnv.validationOk 128 [("x", .int)] + { values := [("x", .integer 0)] } = true := by + native_decide + constructor + · constructor + · refine ⟨true, ?_⟩ + native_decide + · intro _ + simp + · intro _ + change evalBeforeAfter 128 stutterTransition + (.bin "≠" (.set [.num 0]) (.set [])) = .ok true + native_decide + +example : FormulaModel.validUnchecked + ((typedFormulaModel (fun _ => true)).on (fun (_ : Unit) => typedEnv)) + { component := "M", name := "arith/THM", kind := "THM" + hyps := [.bin "≤" (.num 0) (.num 1)] + goal := some (.bin "<" (.num 0) (.num 1)) } := by + apply TypedFormulaModel.valid_on + · exact typedFormulaValid + · intro _ + exact typedEnvWellFormed _ + +example : ¬ TypedFormulaModel.validUnchecked (typedFormulaModel supportsPredicate) + { component := "M", name := "false/THM", kind := "THM", + goal := some (.bin "<" (.num 1) (.num 0)) } := by + intro proof + have goalProof := (proof.2.2 typedEnv (typedEnvWellFormed _)).2 (by simp) + simp [typedFormulaModel, TypedFormulaModel.denote, evalPredicate, evalPredicateAtFuel, + evalPredicateWithFuel, evalPredicateFuel, evalValue, evalValueWithFuel, evalValueFuel, + Bind.bind, Except.bind] at goalProof + +example : ¬ TypedFormulaModel.validUnchecked (typedFormulaModel supportsPredicate) + { component := "M", name := "unsupported/THM", kind := "THM" + goal := some (.app (.id "f") (.num 0)) } := by + simp [TypedFormulaModel.validUnchecked, typedFormulaModel, supportsPredicate] + +/- An ill-typed hypothesis is an evaluator error, not a false premise that can + vacuously discharge a false goal. -/ +example : ¬ TypedFormulaModel.validUnchecked (typedFormulaModel (fun _ => true)) + { component := "M", name := "illTyped/THM", kind := "THM" + hyps := [.bin "∈" (.num 1) (.id "BOOL")] + goal := some (.id "⊥") } := by + intro proof + have defined := (proof.2.2 typedEnv (typedEnvWellFormed _)).1.2 + (.bin "∈" (.num 1) (.id "BOOL")) (by simp) + rcases defined with ⟨value, evaluated⟩ + simp [typedFormulaModel, evalPredicate, evalPredicateAtFuel, evalPredicateWithFuel, + evalPredicateFuel, evalValue, evalValueWithFuel, evalValueFuel, Bind.bind, Except.bind, + Value.contains] at evaluated + +example : TypedFormulaModel.validUnchecked (typedFormulaModel (fun _ => true)) + { component := "M", name := "defined/WWD", kind := "WWD" + hyps := [.bin "∈" (.num 0) (.id "ℤ")] } := by + constructor + · rfl + · intro env _ hypothesis member + have : hypothesis = .bin "∈" (.num 0) (.id "ℤ") := by simpa using member + subst hypothesis + constructor + · refine ⟨true, ?_⟩ + simp [typedFormulaModel, evalPredicate, evalPredicateAtFuel, evalPredicateWithFuel, + evalPredicateFuel, evalValue, evalValueWithFuel, evalValueFuel, Bind.bind, Except.bind, + Value.contains] + · simp [typedFormulaModel, TypedFormulaModel.denote, evalPredicate, evalPredicateAtFuel, + evalPredicateWithFuel, evalPredicateFuel, evalValue, evalValueWithFuel, evalValueFuel, + Bind.bind, Except.bind, Value.contains] + +example : ¬ TypedFormulaModel.validUnchecked (typedFormulaModel supportsPredicate) + { component := "M", name := "unsupported/WWD", kind := "WWD" + hyps := [.app (.id "f") (.num 0)] } := by + simp [TypedFormulaModel.validUnchecked, typedFormulaModel, supportsPredicate] + +/- Negative control: a missing goal is never silently treated as a valid sequent. -/ +example : ¬ FormulaModel.validUnchecked + ({ denote := fun _ _ => True } : FormulaModel Unit) + { name := "missing/INV", kind := "INV" } := by + simp [FormulaModel.validUnchecked] + +/- Positive control: a caller-provided interpretation can discharge an obligation. -/ +example : FormulaModel.validUnchecked + ({ denote := fun _ _ => True } : FormulaModel Unit) + { name := "true/THM", kind := "THM", goal := some (.id "⊤") } := by + simp [FormulaModel.validUnchecked, validSequent] + +end EventB.POG diff --git a/EventB/Project.lean b/EventB/Project.lean new file mode 100644 index 0000000..1ae3daf --- /dev/null +++ b/EventB/Project.lean @@ -0,0 +1,96 @@ +/- Shared source-artifact to typing-project adapter. -/ + +import EventB.Typing.Check + +namespace EventB + +open EventB.Typing + +inductive ModelKind where + | machine + | context + deriving BEq, Repr, Inhabited + +def ModelKind.label : ModelKind → String + | .machine => "machine" + | .context => "context" + +structure ModelArtifact where + component : String + kind : ModelKind + bytes : ByteArray + path : Option String := none + theories : List String := [] + deriving BEq, Inhabited + +instance : Repr ModelArtifact where + reprPrec artifact _ := Std.Format.text + s!"ModelArtifact({artifact.component}, {artifact.bytes.size} bytes)" + +def ModelArtifact.byteString (artifact : ModelArtifact) : String := + (String.fromUTF8? artifact.bytes).getD "" + +private def artifactError (artifact : ModelArtifact) (message : String) : EventB.Error := + match artifact.path with + | some path => (EventB.Error.model message).withPath path + | none => EventB.Error.model message + +def parseModelArtifact (artifact : ModelArtifact) : Except EventB.Error Component := do + unless !artifact.component.isEmpty do + throw (artifactError artifact "model artifact has no component identity") + let model ← match parseModel artifact.bytes with + | .ok model => pure model + | .error error => .error error + let rootKind := match model.root with + | .machineFile _ _ => ModelKind.machine + | .contextFile _ _ => ModelKind.context + | _ => ModelKind.context + unless rootKind == artifact.kind do + throw (artifactError artifact "model artifact kind does not match its XML root") + match model.root.attr? "org.eventb.core.name" with + | some rootName => + unless rootName == artifact.component do + throw (artifactError artifact + s!"XML component name `{rootName}` does not match `{artifact.component}`") + | none => pure () + pure { name := artifact.component, elem := model.root, theories := artifact.theories } + +def projectFromArtifacts (artifacts : List ModelArtifact) : Except EventB.Error Project := do + let components ← artifacts.mapM parseModelArtifact + let names := components.map (·.name) + unless names.eraseDups.length == names.length do + throw (EventB.Error.model "model artifacts contain duplicate component identities") + pure components + +#guard match parseModelArtifact + { component := "M", kind := .machine, + bytes := "".toUTF8 } with + | .ok component => component.name == "M" + | .error _ => false + +#guard ModelArtifact.byteString + { component := "M", kind := .machine, + bytes := "∈ ≔".toUTF8 } == "∈ ≔" + +#guard match parseModelArtifact + { component := "M", kind := .machine, + bytes := "".toUTF8 } with + | .error _ => true + | .ok _ => false + +#guard match parseModelArtifact + { component := "M", kind := .machine, + bytes := ("").toUTF8 } with + | .error _ => true + | .ok _ => false + +#guard match projectFromArtifacts + [{ component := "M", kind := .machine, + bytes := "".toUTF8 } + , { component := "M", kind := .machine, + bytes := "".toUTF8 }] with + | .error _ => true + | .ok _ => false + +end EventB diff --git a/EventB/Semantics.lean b/EventB/Semantics.lean index 5906a6e..a1c2153 100644 --- a/EventB/Semantics.lean +++ b/EventB/Semantics.lean @@ -7,13 +7,115 @@ value; the POs are the fields of `Proved` / `Refines`. Add surface syntax (`syntax`/`macro_rules`) only when writing these records by hand hurts. -/ -universe u +universe u v /-- Guarded event: guard on the pre-state, action as a before-after relation. -/ structure Event (σ : Type u) where grd : σ → Prop act : σ → σ → Prop +/-- Event-B events with explicit local parameters. The parameter is chosen once + before the guard and action are evaluated; it is never smuggled into the + machine state or reused from another event. -/ +structure ParameterizedEvent (σ : Type u) (π : Type v) where + grd : π → σ → Prop + act : π → σ → σ → Prop + +def ParameterizedEvent.enabled {σ : Type u} {π : Type v} + (event : ParameterizedEvent σ π) (state : σ) : Prop := + ∃ parameter, event.grd parameter state + +def ParameterizedEvent.step {σ : Type u} {π : Type v} + (event : ParameterizedEvent σ π) (before after : σ) : Prop := + ∃ parameter, event.grd parameter before ∧ event.act parameter before after + +def ParameterizedEvent.invariantPreserved {σ : Type u} {π : Type v} + (event : ParameterizedEvent σ π) (invariant : σ → Prop) : Prop := + ∀ parameter before after, invariant before → event.grd parameter before → + event.act parameter before after → invariant after + +theorem ParameterizedEvent.step_invariant {σ : Type u} {π : Type v} + {event : ParameterizedEvent σ π} {invariant : σ → Prop} + (preserved : event.invariantPreserved invariant) : + ∀ before after, invariant before → event.step before after → invariant after := by + intro before after invariantBefore step + obtain ⟨parameter, guard, action⟩ := step + exact preserved parameter before after invariantBefore guard action + +/-- A local parameterized refinement contract. The abstract parameter is selected + from the concrete parameter and glued states, so enabledness and simulation use + the same witness rather than an unrelated abstract event. -/ +structure ParameterizedEventRefinement + {γ α : Type u} {πγ πα : Type v} + (concrete : ParameterizedEvent γ πγ) (abstract : ParameterizedEvent α πα) + (gluing : γ → α → Prop) : Prop where + guard : ∀ parameter concreteState abstractState, + gluing concreteState abstractState → concrete.grd parameter concreteState → + ∃ abstractParameter, abstract.grd abstractParameter abstractState + action : ∀ parameter concreteState concreteAfter abstractState, + gluing concreteState abstractState → concrete.grd parameter concreteState → + concrete.act parameter concreteState concreteAfter → + ∃ abstractParameter abstractAfter, + abstract.grd abstractParameter abstractState ∧ + abstract.act abstractParameter abstractState abstractAfter ∧ + gluing concreteAfter abstractAfter + +theorem ParameterizedEventRefinement.stepSim + {γ α : Type u} {πγ πα : Type v} + {concrete : ParameterizedEvent γ πγ} {abstract : ParameterizedEvent α πα} + {gluing : γ → α → Prop} + (contract : ParameterizedEventRefinement concrete abstract gluing) : + ∀ concreteState concreteAfter abstractState, + gluing concreteState abstractState → + concrete.step concreteState concreteAfter → + ∃ abstractAfter, abstract.step abstractState abstractAfter ∧ + gluing concreteAfter abstractAfter := by + intro concreteState concreteAfter abstractState glued step + obtain ⟨parameter, guard, action⟩ := step + obtain ⟨abstractParameter, abstractAfter, abstractGuard, abstractAction, gluedAfter⟩ := + contract.action parameter concreteState concreteAfter abstractState glued guard action + exact ⟨abstractAfter, ⟨abstractParameter, abstractGuard, abstractAction⟩, gluedAfter⟩ + +/-- A deterministic before-after relation. The state update is evaluated from the +pre-state, which is the semantic rule for parallel assignment. -/ +def functionalAction {σ : Type u} (update : σ → σ) : σ → σ → Prop := + fun before after => after = update before + +def deterministicAction {σ : Type u} (action : σ → σ → Prop) : Prop := + ∀ before after₁ after₂, action before after₁ → action before after₂ → after₁ = after₂ + +theorem functionalAction_deterministic {σ : Type u} (update : σ → σ) : + deterministicAction (functionalAction update) := by + intro before after₁ after₂ h₁ h₂ + simpa [functionalAction] using h₁.trans h₂.symm + +def State (α : Type u) := String → α + +def State.update {α : Type u} (state : State α) (name : String) (value : α) : State α := + fun current => if current == name then value else state current + +/-- Parallel assignments read every right-hand side from the same pre-state. -/ +def parallelUpdate {α : Type u} (updates : List (String × (State α → α))) + (state : State α) : State α := + fun name => match updates.find? (·.1 == name) with + | some (_, rhs) => rhs state + | none => state name + +theorem parallelUpdate_deterministic {α : Type u} (updates : List (String × (State α → α))) : + deterministicAction + (functionalAction (fun state : State α => parallelUpdate updates state)) := by + intro before after₁ after₂ h₁ h₂ + simpa [functionalAction] using h₁.trans h₂.symm + +theorem State.update_same {α : Type u} (state : State α) (name : String) (value : α) : + State.update state name value name = value := by + simp [State.update] + +theorem State.update_other {α : Type u} (state : State α) {name other : String} + (different : other ≠ name) (value : α) : + State.update state name value other = state other := by + simp [State.update, different] + /-- Event-B machine. `inv` is the invariant, `init` the initialisation predicate. -/ structure Machine (σ : Type u) where inv : σ → Prop @@ -34,6 +136,18 @@ structure Proved {σ : Type u} (M : Machine σ) : Prop where invInit : ∀ s, M.init s → M.inv s invStep : ∀ s s', M.inv s → M.step s s' → M.inv s' +/-- Event-local invariant proof obligations assembled into the machine proof. -/ +structure InvariantProof {σ : Type u} (M : Machine σ) : Prop where + init : ∀ s, M.init s → M.inv s + event : ∀ e, e ∈ M.events → ∀ s s', M.inv s → e.grd s → e.act s s' → M.inv s' + +theorem InvariantProof.toProved {σ : Type u} {M : Machine σ} (h : InvariantProof M) : + Proved M := by + constructor + · exact h.init + · rintro s s' hi ⟨e, he, hg, ha⟩ + exact h.event e he s s' hi hg ha + /-- Discharged POs ⟹ invariant holds on every reachable state. -/ theorem Proved.sound {σ : Type u} {M : Machine σ} (h : Proved M) : ∀ s, Reach M s → M.inv s := by @@ -47,6 +161,40 @@ structure Refines {γ α : Type u} (C : Machine γ) (A : Machine α) (J : γ → initSim : ∀ c, C.init c → ∃ a, A.init a ∧ J c a stepSim : ∀ c c' a, J c a → C.step c c' → ∃ a', A.step a a' ∧ J c' a' +/-- Local refinement contract for one concrete event. It makes guard strengthening, +action simulation, and target-event membership explicit instead of hiding them in a +single opaque machine-level relation. -/ +structure EventRefinement {γ α : Type u} (C : Machine γ) (A : Machine α) + (J : γ → α → Prop) : Type (max u u) where + abstractEvent : Event γ → Event α + abstractMember : ∀ concrete, concrete ∈ C.events → abstractEvent concrete ∈ A.events + guard : ∀ concrete c a, concrete ∈ C.events → J c a → concrete.grd c → + (abstractEvent concrete).grd a + action : ∀ concrete c c' a, concrete ∈ C.events → J c a → concrete.grd c → + concrete.act c c' → ∃ a', (abstractEvent concrete).act a a' ∧ J c' a' + +theorem EventRefinement.stepSim {γ α : Type u} {C : Machine γ} {A : Machine α} + {J : γ → α → Prop} (h : EventRefinement C A J) : + ∀ c c' a, J c a → C.step c c' → ∃ a', A.step a a' ∧ J c' a' := by + rintro c c' a hJ ⟨concrete, concreteMember, concreteGuard, concreteAction⟩ + let abstract := h.abstractEvent concrete + have abstractMember : abstract ∈ A.events := h.abstractMember concrete concreteMember + have abstractGuard := h.guard concrete c a concreteMember hJ concreteGuard + obtain ⟨a', abstractAction, hJ'⟩ := + h.action concrete c c' a concreteMember hJ concreteGuard concreteAction + exact ⟨a', ⟨abstract, abstractMember, abstractGuard, abstractAction⟩, hJ'⟩ + +/-- A complete refinement proof separates initialization simulation from local event +contracts, then derives the machine-level simulation used by reachability theorems. -/ +structure RefinementProof {γ α : Type u} (C : Machine γ) (A : Machine α) + (J : γ → α → Prop) : Type (max u u) where + init : ∀ c, C.init c → ∃ a, A.init a ∧ J c a + events : EventRefinement C A J + +theorem RefinementProof.toRefines {γ α : Type u} {C : Machine γ} {A : Machine α} + {J : γ → α → Prop} (h : RefinementProof C A J) : Refines C A J := by + exact { initSim := h.init, stepSim := h.events.stepSim } + /-- Soundness: every reachable concrete state is glued to a reachable abstract state. -/ theorem Refines.sound {γ α : Type u} {C : Machine γ} {A : Machine α} {J : γ → α → Prop} (h : Refines C A J) : ∀ c, Reach C c → ∃ a, Reach A a ∧ J c a := by @@ -68,6 +216,252 @@ theorem Refines.inv_transfer {γ α : Type u} {C : Machine γ} {A : Machine α} obtain ⟨a, hra, hJ⟩ := hr.sound c r exact ⟨a, hp.sound a hra, hJ⟩ +/- ------------------------------------------------------------------ -/ +/- Named contracts for refinement-heavy PO classes. These are semantic + interfaces: a parser/POG supplies the formulas, while a model supplies + their meaning and a proof supplies the contract. -/ + +def State.frame {α : Type u} (names : List String) + (before after : State α) : Prop := + ∀ name, name ∈ names → after name = before name + +def framePreserved {σ : Type u} {α : Type v} (read : σ → α) + (action : σ → σ → Prop) : Prop := + ∀ before after, action before after → read after = read before + +theorem State.parallelUpdate_frame_at {α : Type u} + (updates : List (String × (State α → α))) (state : State α) + {name : String} + (notUpdated : ∀ update ∈ updates, update.1 ≠ name) : + parallelUpdate updates state name = state name := by + induction updates with + | nil => rfl + | cons head tail ih => + have headNotUpdated : head.1 ≠ name := notUpdated head (by simp) + have tailNotUpdated : ∀ update ∈ tail, update.1 ≠ name := by + intro update member + exact notUpdated update (by simp [member]) + simp only [parallelUpdate, List.find?_cons] + by_cases equal : head.1 == name + · exact False.elim (headNotUpdated (eq_of_beq equal)) + · simp [equal] + exact ih tailNotUpdated + +theorem State.frame_of_parallelUpdate {α : Type u} + (updates : List (String × (State α → α))) (state : State α) + (names : List String) + (notUpdated : ∀ name, name ∈ names → ∀ update ∈ updates, update.1 ≠ name) : + State.frame names state (parallelUpdate updates state) := by + intro name member + exact State.parallelUpdate_frame_at updates state (notUpdated name member) + +def gluingPreserved {γ α : Type u} (J : γ → α → Prop) + (concrete : Event γ) (abstract : Event α) : Prop := + ∀ c c' a, J c a → concrete.grd c → concrete.act c c' → + ∃ a', abstract.act a a' ∧ J c' a' + +def guardStrengthened {γ α : Type u} (J : γ → α → Prop) + (concrete : Event γ) (abstract : Event α) : Prop := + ∀ c a, J c a → concrete.grd c → abstract.grd a + +def actionSimulates {γ α : Type u} (J : γ → α → Prop) + (concrete : Event γ) (abstract : Event α) : Prop := + ∀ c c' a, J c a → concrete.grd c → concrete.act c c' → + ∃ a', abstract.act a a' ∧ J c' a' + +theorem EventRefinement.guardPO {γ α : Type u} {C : Machine γ} {A : Machine α} + {J : γ → α → Prop} (h : EventRefinement C A J) + (concrete : Event γ) (member : concrete ∈ C.events) : + guardStrengthened J concrete (h.abstractEvent concrete) := by + intro c a hJ guard + exact h.guard concrete c a member hJ guard + +theorem EventRefinement.actionPO {γ α : Type u} {C : Machine γ} {A : Machine α} + {J : γ → α → Prop} (h : EventRefinement C A J) + (concrete : Event γ) (member : concrete ∈ C.events) : + actionSimulates J concrete (h.abstractEvent concrete) := by + intro c c' a hJ guard action + exact h.action concrete c c' a member hJ guard action + +theorem EventRefinement.gluingPO {γ α : Type u} {C : Machine γ} {A : Machine α} + {J : γ → α → Prop} (h : EventRefinement C A J) + (concrete : Event γ) (member : concrete ∈ C.events) : + gluingPreserved J concrete (h.abstractEvent concrete) := + h.actionPO concrete member + +structure WitnessContract (σ α : Type u) (pre : σ → Prop) + (defined : σ → Prop) (predicate : σ → α → Prop) : Prop where + feasible : ∀ state, pre state → ∃ witness, predicate state witness + wellDefined : ∀ state, pre state → defined state + +def nonIncreasing {σ : Type u} (variant : σ → Nat) + (action : σ → σ → Prop) : Prop := + ∀ before after, action before after → variant after ≤ variant before + +def strictlyDecreases {σ : Type u} (variant : σ → Nat) + (action : σ → σ → Prop) : Prop := + ∀ before after, action before after → variant after < variant before + +structure AnticipatedVariant (σ : Type u) where + measure : σ → Nat + action : σ → σ → Prop + nonIncrease : nonIncreasing measure action + +structure ConvergentVariant (σ : Type u) where + measure : σ → Nat + action : σ → σ → Prop + decrease : strictlyDecreases measure action + +inductive IntegerVariantMode where + | anticipated + | convergent + +def integerVariantProgress : IntegerVariantMode → Int → Int → Prop + | .anticipated, after, before => after ≤ before + | .convergent, after, before => after < before + +/- Set-valued variants use extensional list membership. The representation is finite by + construction; the progress relation keeps anticipated subset and convergent proper + subset distinct instead of collapsing both into a numeric measure. -/ +inductive FiniteVariantMode where + | anticipated + | convergent + +def finiteSubset {α : Type u} (after before : List α) : Prop := + ∀ value, value ∈ after → value ∈ before + +def finiteProperSubset {α : Type u} (after before : List α) : Prop := + finiteSubset after before ∧ ∃ value, value ∈ before ∧ value ∉ after + +def finiteVariantProgress {α : Type u} : FiniteVariantMode → List α → List α → Prop + | .anticipated, after, before => finiteSubset after before + | .convergent, after, before => finiteProperSubset after before + +example : finiteVariantProgress .anticipated [1] [1, 2] := by + intro value member + simp_all + +example : ¬ finiteVariantProgress .convergent [1] [1] := by + intro progress + rcases progress.2 with ⟨value, member, absent⟩ + simp_all + +structure FiniteSetVariant (σ : Type u) (α : Type v) where + mode : FiniteVariantMode + measure : σ → List α + action : σ → σ → Prop + finite : σ → Prop + progress : ∀ before after, action before after → + finiteVariantProgress mode (measure after) (measure before) + +/- An integer variant carries one semantic source identity shared by its naturality + (NAT) and progress (VAR) obligations. The adapter that knows POG names maps both + obligations to this identity; this layer does not depend on that representation. -/ +structure IntegerVariant (σ : Type u) where + source : String + mode : IntegerVariantMode + measure : σ → Int + action : σ → σ → Prop + natural : ∀ state, 0 ≤ measure state + progress : ∀ before after, action before after → + integerVariantProgress mode (measure after) (measure before) + +def integerVariantNaturality {σ : Type u} (contract : IntegerVariant σ) : Prop := + ∀ state, 0 ≤ contract.measure state + +def integerVariantProgressSemantic {σ : Type u} (contract : IntegerVariant σ) : Prop := + ∀ before after, contract.action before after → + integerVariantProgress contract.mode + (contract.measure after) (contract.measure before) + +def finiteVariantFiniteness {σ : Type u} {α : Type v} + (contract : FiniteSetVariant σ α) : Prop := + ∀ state, contract.finite state + +def finiteVariantProgressSemantic {σ : Type u} {α : Type v} + (contract : FiniteSetVariant σ α) : Prop := + ∀ before after, contract.action before after → + finiteVariantProgress contract.mode + (contract.measure after) (contract.measure before) + +/-- A general VAR contract. The measure need not be numeric or represented as a + finite list; strict progress is checked against an explicitly supplied + well-founded relation, while anticipated non-increase remains a separate + contract above. -/ +structure WellFoundedVariant (σ : Type u) (α : Type v) where + measure : σ → α + relation : α → α → Prop + wellFounded : WellFounded relation + action : σ → σ → Prop + progress : ∀ before after, action before after → + relation (measure after) (measure before) + +def wellFoundedVariantProgressSemantic {σ : Type u} {α : Type v} + (contract : WellFoundedVariant σ α) : Prop := + ∀ before after, contract.action before after → + contract.relation (contract.measure after) (contract.measure before) + +theorem WellFoundedVariant.progressSemantic {σ : Type u} {α : Type v} + (contract : WellFoundedVariant σ α) : + wellFoundedVariantProgressSemantic contract := + contract.progress + +/- A merge contract names the event coverage that is otherwise easy to lose when + several concrete events refine one abstract event. -/ +structure MergeSimulation {γ α : Type u} (C : Machine γ) (A : Machine α) + (J : γ → α → Prop) : Type (max u u) where + abstractEvent : Event α + abstractMember : abstractEvent ∈ A.events + concreteEvents : List (Event γ) + covered : ∀ concrete, concrete ∈ C.events → concrete ∈ concreteEvents + member : ∀ concrete, concrete ∈ concreteEvents → concrete ∈ C.events + guard : ∀ concrete c a, concrete ∈ concreteEvents → J c a → concrete.grd c → + abstractEvent.grd a + action : ∀ concrete c c' a, concrete ∈ concreteEvents → J c a → concrete.grd c → + concrete.act c c' → ∃ a', abstractEvent.act a a' ∧ J c' a' + +theorem MergeSimulation.stepSim {γ α : Type u} {C : Machine γ} {A : Machine α} + {J : γ → α → Prop} (h : MergeSimulation C A J) : + ∀ c c' a, J c a → C.step c c' → ∃ a', A.step a a' ∧ J c' a' := by + rintro c c' a hJ ⟨concrete, concreteMember, concreteGuard, concreteAction⟩ + have concreteInMerge := h.covered concrete concreteMember + have abstractGuard := h.guard concrete c a concreteInMerge hJ concreteGuard + obtain ⟨a', abstractAction, hJ'⟩ := + h.action concrete c c' a concreteInMerge hJ concreteGuard concreteAction + exact ⟨a', ⟨h.abstractEvent, h.abstractMember, abstractGuard, abstractAction⟩, hJ'⟩ + +/- A split contract handles one concrete event whose enabled behavior may select one + of several abstract events. The step theorem is local to the named concrete event; + other concrete events require their own refinement contract. -/ +structure SplitSimulation {γ α : Type u} (C : Machine γ) (A : Machine α) + (J : γ → α → Prop) : Type (max u u) where + concreteEvent : Event γ + concreteMember : concreteEvent ∈ C.events + abstractEvents : List (Event α) + abstractNonempty : abstractEvents ≠ [] + abstractMember : ∀ abstract, abstract ∈ abstractEvents → abstract ∈ A.events + guard : ∀ c a, J c a → concreteEvent.grd c → + ∃ abstract, abstract ∈ abstractEvents ∧ abstract.grd a + action : ∀ abstract c c' a, abstract ∈ abstractEvents → J c a → + concreteEvent.grd c → abstract.grd a → concreteEvent.act c c' → + ∃ a', abstract.act a a' ∧ J c' a' + +theorem SplitSimulation.stepSim {γ α : Type u} {C : Machine γ} {A : Machine α} + {J : γ → α → Prop} (h : SplitSimulation C A J) : + ∀ c c' a, J c a → h.concreteEvent.grd c → h.concreteEvent.act c c' → + ∃ a', A.step a a' ∧ J c' a' := by + intro c c' a hJ concreteGuard concreteAction + obtain ⟨abstract, abstractMember, abstractGuard⟩ := h.guard c a hJ concreteGuard + obtain ⟨a', abstractAction, hJ'⟩ := + h.action abstract c c' a abstractMember hJ concreteGuard abstractGuard concreteAction + exact ⟨a', ⟨abstract, h.abstractMember abstract abstractMember, + abstractGuard, abstractAction⟩, hJ'⟩ + +def variantDecreasesAt (variant : Nat → Nat) (before after : Nat) : Bool := + variant after < variant before + +#guard !variantDecreasesAt (fun _ => 0) 0 0 + /- ------------------------------------------------------------------ -/ /- Self-check: bounded counter, refined by (counter, remaining budget). -/ @@ -116,6 +510,85 @@ theorem C_refines_A : Refines C A J := by exact ⟨n + 1, ⟨incA, List.mem_singleton.mpr rfl, by show n < 10; omega, rfl⟩, by show c.1 + 1 = n + 1 ∧ (c.1 + 1) + (c.2 - 1) = 10; omega⟩ +def C_event_refinement : EventRefinement C A J := by + refine { abstractEvent := fun _ => incA, abstractMember := ?_, guard := ?_, action := ?_ } + · intro concrete hconcrete + have : concrete = incC := mem_single hconcrete + subst this + exact List.mem_singleton.mpr rfl + · intro concrete c n hconcrete hJ hg + have : concrete = incC := mem_single hconcrete + subst this + have h2 : 0 < c.2 := hg + have hJ1 : c.1 = n := hJ.1 + have hJ2 : c.1 + c.2 = 10 := hJ.2 + show n < 10 + omega + · intro concrete c c' n hconcrete hJ hg ha + have : concrete = incC := mem_single hconcrete + subst this + have h2 : 0 < c.2 := hg + have hJ1 : c.1 = n := hJ.1 + have hJ2 : c.1 + c.2 = 10 := hJ.2 + have h3 : c' = (c.1 + 1, c.2 - 1) := ha + subst h3 + have abstractAction : incA.act n (n + 1) := rfl + exact ⟨n + 1, abstractAction, by + show c.1 + 1 = n + 1 ∧ (c.1 + 1) + (c.2 - 1) = 10 + omega⟩ + +def C_merge_refinement : MergeSimulation C A J := by + refine + { abstractEvent := incA + abstractMember := ?_ + concreteEvents := [incC] + covered := ?_ + member := ?_ + guard := ?_ + action := ?_ } + · exact List.mem_singleton.mpr rfl + · intro concrete hconcrete + have : concrete = incC := mem_single hconcrete + subst this + exact List.mem_singleton.mpr rfl + · intro concrete hconcrete + have : concrete = incC := mem_single hconcrete + subst this + exact List.mem_singleton.mpr rfl + · intro concrete c n hconcrete hJ hg + have : concrete = incC := mem_single hconcrete + subst this + exact C_event_refinement.guard incC c n (List.mem_singleton.mpr rfl) hJ hg + · intro concrete c c' n hconcrete hJ hg ha + have : concrete = incC := mem_single hconcrete + subst this + exact C_event_refinement.action incC c c' n (List.mem_singleton.mpr rfl) hJ hg ha + +theorem C_refines_A_from_merge_contract : Refines C A J := by + refine { initSim := C_refines_A.initSim, stepSim := C_merge_refinement.stepSim } + +theorem positiveWitness : WitnessContract Unit Unit + (fun _ => True) (fun _ => True) (fun _ _ => True) := + { feasible := fun _ _ => ⟨(), trivial⟩ + wellDefined := fun _ _ => trivial } + +def positiveConvergentVariant : ConvergentVariant (Nat × Nat) := + { measure := fun state => state.2 + action := fun before after => incC.grd before ∧ incC.act before after + decrease := by + intro before after action + have afterState : after = (before.1 + 1, before.2 - 1) := action.2 + have enabled : 0 < before.2 := action.1 + rw [afterState] + change before.2 - 1 < before.2 + omega } + +def C_local_refinement : RefinementProof C A J := + { init := C_refines_A.initSim, events := C_event_refinement } + +theorem C_refines_A_from_event_contracts : Refines C A J := + C_local_refinement.toRefines + /-- The payoff: concrete machine inherits `n ≤ 10` without re-proving it. -/ example : ∀ c, Reach C c → c.1 ≤ 10 := by intro c r diff --git a/EventB/Trust.lean b/EventB/Trust.lean index 9ea2633..fa9d831 100644 --- a/EventB/Trust.lean +++ b/EventB/Trust.lean @@ -6,11 +6,13 @@ explicit so front ends can report what was checked and by whom. -/ import EventB.POG +import EventB.Project namespace EventB.Trust inductive Mode where | kernel + | kernelAxiomatized | smt | rodinImported | external @@ -19,25 +21,55 @@ inductive Mode where def Mode.label : Mode → String | .kernel => "kernel-checked" - | .smt => "smt-trusted" - | .rodinImported => "rodin-imported" - | .external => "external-trusted" + | .kernelAxiomatized => "kernel-checked-with-axioms" + | .smt => "smt-declared" + | .rodinImported => "rodin-structurally-checked" + | .external => "external-declared" | .unproved => "unproved" +def Mode.rank : Mode → Nat + | .unproved => 0 + | .external | .rodinImported => 1 + | .smt => 2 + | .kernel | .kernelAxiomatized => 3 + +private def provenanceField (value : String) : String := s!"{value.length}:{value}" + +private def provenanceList (values : List String) : String := + s!"{values.length}[{String.intercalate "" (values.map provenanceField)}]" + +private def modelProvenanceText (model : ModelArtifact) : String := + String.intercalate "\n" + ["component=" ++ provenanceField model.component + , "kind=" ++ provenanceField model.kind.label + , "theories=" ++ provenanceList model.theories + , "bytes=" ++ provenanceField model.byteString] + +def provenanceFingerprintOf (models : List ModelArtifact) (bpo statuses : String) : String := + s!"eventb-v3-{String.hash (String.intercalate "\n---model---\n" + (models.map modelProvenanceText) ++ + "\n---bpo---\n" ++ bpo ++ "\n---statuses---\n" ++ statuses)}" + +def provenanceFingerprint (model : ModelArtifact) (bpo statuses : String) : String := + provenanceFingerprintOf [model] bpo statuses + inductive Evidence where | none | kernel (declaration : String) (axioms : List String := []) | 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 (models : List ModelArtifact) (bpo : String) (statuses : String) + (digest : String) (manual : Bool) deriving BEq, Repr, Inhabited def Evidence.mode : Evidence → Mode | .none => .unproved - | .kernel _ _ => .kernel + | .kernel _ axioms => if axioms.isEmpty then .kernel else .kernelAxiomatized | .smt _ _ _ _ => .smt | .external _ _ _ _ => .external | .rodinImported _ _ _ => .rodinImported + | .rodinImportedProvenance _ _ _ _ _ => .rodinImported def Evidence.isWellFormed : Evidence → Bool | .none => false @@ -46,7 +78,13 @@ 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 models bpo statuses digest _ => + !models.isEmpty && !bpo.isEmpty && !statuses.isEmpty && + models.all (fun model => !model.component.isEmpty && !model.bytes.isEmpty) && + digest == provenanceFingerprintOf models bpo statuses def fingerprint (canonical : String) : String := s!"eventb-v1-{String.hash canonical}" @@ -55,10 +93,22 @@ 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.component.isEmpty && !entry.obligation.isEmpty && + !entry.canonical.isEmpty && entry.fingerprint == Trust.fingerprint entry.canonical && + ((entry.mode != .kernel && entry.mode != .kernelAxiomatized) || + !entry.semanticFingerprint.isEmpty) && + entry.mode == entry.evidence.mode && + (entry.mode == .unproved || entry.evidence.isWellFormed) + structure Ledger where entries : List Entry := [] deriving BEq, Repr, Inhabited @@ -66,48 +116,118 @@ 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.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.mode == .kernel || entry.mode == .kernelAxiomatized 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 + go [] ledger.entries + +def Ledger.displayEntry? (ledger : Ledger) (component name : String) : Option Entry := + match ledger.validate with + | .ok _ => ledger.entry? component name + | .error _ => none def Ledger.attach (ledger : Ledger) (obligation : POG.Obligation) (evidence : Evidence) : Except EventB.Error Ledger := let expected := fingerprint obligation.canonical - if !evidence.isWellFormed 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 + .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 .. || evidence matches .rodinImportedProvenance .. 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) + match ledger.validate with + | .ok _ => ledger.entries.countP (·.mode == mode) + | .error _ => 0 def Ledger.total (ledger : Ledger) : Nat := ledger.entries.length def Ledger.summary (ledger : Ledger) : String := - let modes := [Mode.kernel, .smt, .rodinImported, .external, .unproved] - modes.foldl (fun result mode => - let count := ledger.count mode - if count == 0 then result - else if result.isEmpty then s!"{mode.label}: {count}" - else result ++ s!", {mode.label}: {count}") "" + match ledger.validate with + | .error error => "invalid-ledger: " ++ error.message + | .ok _ => + let modes := [Mode.kernel, .kernelAxiomatized, .smt, .rodinImported, .external, + .unproved] + modes.foldl (fun result mode => + let count := ledger.entries.countP (·.mode == mode) + if count == 0 then result + else if result.isEmpty then s!"{mode.label}: {count}" + else result ++ s!", {mode.label}: {count}") "" #guard Mode.kernel.label == "kernel-checked" +#guard Mode.kernelAxiomatized.label == "kernel-checked-with-axioms" +#guard (Evidence.kernel "proof" ["propext"]).mode == .kernelAxiomatized +#guard Mode.smt.label == "smt-declared" +#guard Mode.external.label == "external-declared" +#guard Mode.rodinImported.label == "rodin-structurally-checked" #guard (Ledger.ofObligations []).total == 0 #guard fingerprint "same" == fingerprint "same" #guard fingerprint "same" != fingerprint "changed" +#guard provenanceFingerprintOf + [{ component := "M", kind := .machine, bytes := "".toUTF8 }] + "bpo" "status" != provenanceFingerprintOf + [{ component := "M", kind := .machine, theories := ["T"], bytes := "".toUTF8 }] + "bpo" "status" +#guard !Evidence.isWellFormed + (.rodinImportedProvenance [] "bpo" "status" "forged" false) private def sampleObligation : POG.Obligation := { component := "Sample", name := "INITIALISATION/inv1/INV", kind := "INV" @@ -115,16 +235,75 @@ 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 inconsistentAxiomatizedEntry : Entry := + { sampleLedger.entries.head! with + mode := .kernelAxiomatized + evidence := .kernel "forged" ["propext"] } + +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 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" } -#guard sampleObligation.canonical == renamedSample.canonical +#guard match inconsistentLedger.validate with | .error _ => true | .ok _ => false +#guard inconsistentLedger.displayEntry? sampleObligation.component sampleObligation.name |>.isNone +#guard inconsistentLedger.count .kernel == 0 +#guard inconsistentLedger.summary.startsWith "invalid-ledger:" +#guard !inconsistentAxiomatizedEntry.isConsistent + +#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 (.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 + (.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 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 legacyRodinLedger.validate with + | .error _ => true + | .ok _ => false #guard match sampleLedger.attach { sampleObligation with goal := some (.id "⊥") } (.kernel "Sample.inv1") with | .error _ => true @@ -132,5 +311,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 fb4a185..99304a6 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,17 +115,26 @@ 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 let proofType ← inferType proof 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 " ++ s!"[{String.intercalate ", " declared}], found " ++ s!"[{String.intercalate ", " actualAxioms}]" - pure (Report.mk .kernel true declaration (proofFingerprint context obligation) actualAxioms) + let mode := if declaredAxioms.isEmpty then .kernel else .kernelAxiomatized + pure (Report.mk mode true declaration (proofFingerprint context obligation) actualAxioms) private def replayKernel (context : Embedding.KernelContext) (obligation : POG.Obligation) (evidence : Evidence) : MetaM Report := do @@ -132,7 +146,33 @@ private def replayKernel (context : Embedding.KernelContext) def validate (context : Embedding.KernelContext) (obligation : POG.Obligation) : Evidence → MetaM Report | evidence@(.kernel ..) => replayKernel context obligation evidence + | .rodinImported .. => + throwError "legacy status-only Rodin evidence is not trusted; attach model and PO provenance" + | evidence@(.rodinImportedProvenance models bpo statuses digest manual) => do + let provenance : Rodin.Provenance := { models, 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.validateProvenanceIn context.theory 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" + 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 } @@ -143,8 +183,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 || entry.mode == .kernelAxiomatized 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 @@ -160,6 +205,8 @@ theorem propextTrue : True := by def testInt : Int := 0 +unsafe def unsafeTrue : True := True.intro + theorem reflexive (value : Int) : value = value := rfl end TestFixtures @@ -201,9 +248,20 @@ 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 + 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" + let axiomatized ← validate context replayObligation + (.kernel "EventB.Trust.Replay.TestFixtures.propextTrue" ["propext"]) + unless axiomatized.mode == .kernelAxiomatized && axiomatized.replayed do + throwError "axiomatized kernel evidence was not labelled explicitly" let trusted := validate context replayObligation (.smt "z3" "4" "sha256:input" "checker") let report ← trusted @@ -213,19 +271,33 @@ 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 rodin ← validate context replayObligation - (.rodinImported "model.bps" "sha256:status" true) - unless rodin.mode == .rodinImported && !rodin.replayed do - throwError "Rodin evidence was reported as replayed" + let rodinSource := "" + 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" + 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" @@ -235,6 +307,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 5eb810a..d8ec244 100644 --- a/EventB/Trust/Rodin.lean +++ b/EventB/Trust/Rodin.lean @@ -6,6 +6,7 @@ import EventB.Xml namespace EventB.Trust.Rodin open EventB +open EventB.Typing structure Status where name : String @@ -15,6 +16,12 @@ structure Status where def Status.discharged (status : Status) : Bool := status.confidence > 0 +structure Provenance where + models : List ModelArtifact + bpo : String + statuses : String + deriving BEq, Repr, Inhabited + structure Comparison where expected : Nat discharged : Nat @@ -22,6 +29,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 := @@ -43,17 +53,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,45 +91,452 @@ 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) +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 provenanceDigest (provenance : Provenance) : String := + Trust.provenanceFingerprintOf provenance.models provenance.bpo provenance.statuses + 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 duplicateStatuses := duplicateKeys [] (statuses.map (·.name)) + let scopeAmbiguous := (eligible.map (·.component)).eraseDups.length > 1 || + !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 | 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.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) + (provenance : Provenance) (manual : Bool) : Except EventB.Error Ledger := do + ledger.validate + let evidence := .rodinImportedProvenance provenance.models 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 + .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 - pure ledger + 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 def rootModel (artifact : ModelArtifact) : Except EventB.Error (String × String) := do + let source := artifact.byteString + 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, root.tag) + | none => pure (artifact.component, root.tag) + +private def parseModelProject (provenance : Provenance) : Except EventB.Error Project := do + match projectFromArtifacts provenance.models with + | .ok project => pure project + | .error error => .error error + +private def generatedModelObligation (theory : Theory.Env) (obligation : POG.Obligation) + (provenance : Provenance) : Except EventB.Error Unit := do + let project ← parseModelProject provenance + let generated ← match POG.generateCheckedIn theory project obligation.component with + | .ok obligations => pure obligations + | .error error => .error (EventB.Error.trust + s!"model-derived POG rejected `{obligation.component}`: {error.message}") + let candidates := generated.filter (fun candidate => candidate.name == obligation.name) + match candidates with + | [candidate] => + unless candidate.canonical == obligation.canonical && candidate.diagnostics.isEmpty do + throw (EventB.Error.trust + "model-derived POG does not match the supplied obligation") + | [] => .error (EventB.Error.trust + s!"model-derived POG has no obligation `{obligation.name}`") + | _ => .error (EventB.Error.trust + s!"model-derived POG has duplicate obligation `{obligation.name}`") + +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 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 + 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 [] + match direct ++ witness with + | [goal] => some goal + | _ => none + +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.filter (fun set => set.name == name) with + | [set] => chainPredicates sets fuel set.parent (set.predicates ++ acc) + | _ => none + +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 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) := + 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) + | [] => 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 validateProvenanceIn (theory : Theory.Env) (obligation : POG.Obligation) + (provenance : Provenance) + (status : Status) : Except EventB.Error Unit := do + let target ← match provenance.models with + | target :: _ => pure target + | [] => .error (EventB.Error.trust "Rodin provenance has no model artifacts") + let (modelName, modelTag) ← rootModel target + unless modelName == obligation.component do + throw (EventB.Error.trust s! + "Rodin model provenance names `{modelName}`, expected `{obligation.component}`") + generatedModelObligation theory obligation provenance + let modelSource := target.byteString + let model ← match parseXmlString modelSource with + | .ok root => pure root + | .error error => .error (EventB.Error.trust + s!"invalid model XML: {error.pretty target.bytes}") + 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 + s!"invalid PO XML: {error.pretty provenance.bpo.toUTF8}") + 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") + 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 + 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.discharged then + .error (EventB.Error.trust s!"proof-status `{status.name}` is not discharged") + else pure () + +def validateProvenance (obligation : POG.Obligation) (provenance : Provenance) + (status : Status) : Except EventB.Error Unit := + validateProvenanceIn Theory.empty obligation provenance status + +def attachProvenanceIn (theory : Theory.Env) (ledger : Ledger) (obligation : POG.Obligation) + (provenance : Provenance) (status : Status) : Except EventB.Error Ledger := do + validateProvenanceIn theory obligation provenance status + attachVerified ledger obligation provenance status.manual + +def attachProvenance (ledger : Ledger) (obligation : POG.Obligation) + (provenance : Provenance) (status : Status) : Except EventB.Error Ledger := + attachProvenanceIn Theory.empty ledger obligation provenance status + +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 "⊤") } + { component := "Sample", name := "INITIALISATION/inv/INV", kind := "INV" + goal := some (.bin "∈" (.num 0) (.id "ℤ")) } private def sampleSource := "" ++ "" +private def sampleModel : ModelArtifact := + { component := "Sample" + kind := .machine + bytes := ("" ++ + "" ++ + "").toUTF8 } + +private def sampleBpo := + "" + +private def sampleProvenance : String → Provenance := fun statuses => + { models := [sampleModel], bpo := sampleBpo, statuses := statuses } + +#guard match parseXmlString ((sampleProvenance sampleSource).models.head!.byteString.replace + "" + ("" ++ + "")) with + | .ok model => + !modelBindsObligation model + { sampleObligation with name := "INITIALISATION/VWD", kind := "VWD" } + | .error _ => false + #guard match importStatuses sampleSource with | .ok [status] => status.name == sampleObligation.name && status.discharged && status.manual | _ => false +#guard match importStatuses (sampleSource.replace + "name=\"INITIALISATION/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 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 @@ -107,10 +544,124 @@ private def sampleSource := | _ => false #guard match importStatuses sampleSource with - | .ok [status] => match attach (Ledger.ofObligations [sampleObligation]) - sampleObligation "sample.bps" status with - | .ok ledger => ledger.count .rodinImported == 1 + | .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 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"] } + 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 => + match ledger.entries.head? with + | some entry => + match entry.evidence with + | .rodinImportedProvenance models bpo statuses digest manual => + manual && digest == provenanceDigest { models, bpo, statuses } + | _ => false + | none => false | .error _ => false | _ => false +#guard match importStatuses sampleSource with + | .ok [status] => + let noXmlName := { sampleProvenance sampleSource with + models := [{ sampleModel with + bytes := sampleModel.byteString.replace + "org.eventb.core.name=\"Sample\"" "" |>.toUTF8 }] } + match attachProvenance (Ledger.ofObligations [sampleObligation]) + sampleObligation noXmlName status with + | .ok _ => true + | .error _ => false + | _ => false + +#guard match importStatuses sampleSource with + | .ok [status] => + let changedAction := { sampleProvenance sampleSource with + models := [{ sampleModel with + bytes := sampleModel.byteString.replace "x ≔ 0" "x ≔ 1" |>.toUTF8 }] } + match attachProvenance (Ledger.ofObligations [sampleObligation]) + sampleObligation changedAction status with + | .error _ => true + | .ok _ => false + | _ => false + +#guard match importStatuses sampleSource with + | .ok [status] => + let badModel := { sampleProvenance sampleSource with + models := [{ sampleModel with + bytes := sampleModel.byteString.replace + "org.eventb.core.machineFile" "org.eventb.core.fakeFile" |>.toUTF8 }] } + match attachProvenance (Ledger.ofObligations [sampleObligation]) + sampleObligation badModel status with + | .error _ => true + | .ok _ => false + | _ => false + +#guard match importStatuses sampleSource with + | .ok [status] => + let nestedLabel := { sampleProvenance sampleSource with + models := [{ sampleModel with + bytes := (sampleModel.byteString.replace + "" + "").toUTF8 }] } + 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 + 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=\"(0 ∈ ℤ)\"" "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 + (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 3da6106..10ac431 100644 --- a/EventB/Typing/Check.lean +++ b/EventB/Typing/Check.lean @@ -38,11 +38,350 @@ private def childrenOf (e : Elem) (tag : String) : List Elem := private def attrOf (e : Elem) (key : String) : Option String := e.attr? ("org.eventb.core." ++ key) -/-- `target` is a workspace path such as `/Abstraction/M1_Landing_Sequence_Ctx`; only the -last segment names the component. -/ +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!) +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 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 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 ++ 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 => + 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 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") + 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 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 => + 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 ++ 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 := + 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 + | none => [] + | some current => + match (childrenOf current.elem "event").find? (fun candidate => + labelOf candidate == event) with + | none => [] + | some currentEvent => + 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 => + 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 + (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. `visited` already stops repeats, so the recursion terminates on any well-formed project; @@ -51,9 +390,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" @@ -78,7 +417,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 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 @@ -91,33 +430,95 @@ private def addComponent (c : Component) : M (List String) := do -- 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 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 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 := [] + -- Compatibility inference mirrors the pinned corpus. Strict inference keeps + -- 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) 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 - 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) + for act in initializationActions p c ev do + 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 + 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. - modify fun s => { s with params := s.params ++ bound } + let ownBound := bound.filter (fun pair => ownParams.contains pair.1) + modify fun s => + { 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 @@ -140,36 +541,310 @@ 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 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 ++ (← addComponent 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 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")] + [.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 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")] + [.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)) @@ -191,6 +866,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) @@ -233,6 +912,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 af64e12..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,10 +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 - -- 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 () + -- 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 @@ -231,8 +267,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 +282,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 +318,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/EventB/Typing/Type.lean b/EventB/Typing/Type.lean index fb5521b..452e872 100644 --- a/EventB/Typing/Type.lean +++ b/EventB/Typing/Type.lean @@ -19,7 +19,7 @@ inductive Ty where | prod : Ty → Ty → Ty /-- Unification variable, resolved through the substitution in `Infer`. -/ | mvar : Nat → Ty - deriving BEq, Repr, Inhabited + deriving BEq, Repr, Inhabited, DecidableEq /-- Node count, used to bound the substitution traversals in `Infer`. -/ def Ty.size : Ty → Nat diff --git a/EventB/Xml.lean b/EventB/Xml.lean index 337e5ac..c37ad23 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,43 @@ 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.seqR (GParser.ch '"') + (GParser.seqL (GParser.string "1.0") (GParser.ch '"')))))) + 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 +207,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..076bf92 100644 --- a/README.md +++ b/README.md @@ -49,10 +49,19 @@ The CLI reports parsed models, generated obligations, proof status, trust mode, fingerprints. `eventb diff` compares generated obligations with Rodin artifacts; `eventb report` provides machine-readable output. +The current pinned-corpus snapshot is 38/38 reader, 1102/1102 formula, 940/940 typing, +1133/1133 obligation-name, 1132/1325 derived-statement, and 73/1133 external-declared +baseline checks. Remaining obligations stay visibly unproved; imported Rodin status is accepted +only after supplied-artifact POG regeneration and canonical BPO comparison. +`EventB.Semantics` provides proof-carrying invariant/refinement contracts, including +frame, gluing, merged-event, witness, and variant contracts. `EventB.POGSoundness` +provides explicit translated-sequent validity; formula interpretations remain +caller-supplied and are never guessed. + ## Verification ```sh -lake build EventB EventB.Properties Examples +lake build EventB Examples lake exe gates lake exe gates --status ``` @@ -61,6 +70,11 @@ The corpus gate is pinned by `corpus/MANIFEST.tsv`. The checked-in Rossi fixture boundaries and a typecheckable witness project. Optional ProofWidgets views are built with the examples target. +For the manual editor gate, open `examples/WidgetDemo.lean` and `examples/LspDemo.lean` in VS +Code with the Lean server restarted. Confirm the Infoview model/PO sections, derived goals, +explicit trust badges, Go to Definition, and an unknown-identifier diagnostic; discard any +temporary diagnostic edit before closing the files. + ## Related projects [`lean-grip`](https://github.com/jonaprieto/lean-grip) supplies byte parsing; diff --git a/STATUS.md b/STATUS.md new file mode 100644 index 0000000..39965c7 --- /dev/null +++ b/STATUS.md @@ -0,0 +1,55 @@ +# 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 | +| kernel-checked-with-axioms | 0 | +| smt-declared | 0 | +| rodin-structurally-checked | 0 | +| external-declared | 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 d67adbc..cdd1f57 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,16 +18,159 @@ 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. | -| 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. +| 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-declared. | + +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 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 + +- [x] Fail on missing component/event/theory references instead of treating them as empty + closures. +- [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. +- [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. +- [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. +- [x] Close the supported generality ceiling: bind the named frame, gluing, merge, + witness, and variant contracts in `EventB.Semantics`, and the explicit sequent + adapters in `EventB.POGSoundness`, to the generated POG classes that have a typed + evaluator path. The closed POG-class table, source-bound adapters, parameterized + enabled-event contract, finite witness-domain evaluator, and well-founded VAR + contract have kernel-checked positive/negative fixtures. Unsupported + partial/theory applications, unrestricted binders/comprehensions, and automatic + interpretation of arbitrary formulas remain explicit fail-closed boundaries. + +### Vertical-slice order + +1. Resolution, scopes, and fail-closed diagnostics — implemented and negative-tested. +2. Typed assignments and refinement event relations — component-bound typed deterministic + assignments, explicit before/after valuation, parameterized event semantics, and + source-indexed merge/frame edge cases are implemented. +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 supported POG class — generic contracts, + source-bound model bindings, and typed evaluator lemmas are present; unsupported + 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 — 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. + +### Generality-ceiling execution plan + +The following is the verified supported path. Each item is evidence for the accepted +subset; the explicit unsupported boundaries are part of the contract rather than +promises of arbitrary-term automation. + +1. **Typed semantic adapter (bounded slice now verified).** `EventB.POGSoundness` now + interprets closed arithmetic, Boolean logic, finite sets, maplets, typed membership, + subset, unary negation, and simultaneous deterministic assignment through one + `Except EvalError` path. Finite-set equality is extensional; ill-typed, unbound, + overloaded-comma, partial, and unsupported terms fail explicitly; WWD is a separate + hypothesis-only validity shape. `ComponentValuation` now reuses the strict recursive + `Typing.Ty` environment, binds writable variables and effective event assignments, + requires explicit finite carrier observations for given-set atoms, and rejects + typing diagnostics before valuation. Caller-controlled fuel is threaded through + public evaluator wrappers; primed evaluation is private to the declaration-checked + `CheckedBeforeAfter` path. The adapter accepts typed state valuation validity for + `THM`, `WD`, `VWD`, and `WWD`, and typed before/after valuation validity for the + supported transition classes. `evalPredicateOverFiniteDomain` provides a complete, + source-independent witness boundary for caller-supplied finite candidate domains; + unrestricted binder evaluation remains one-sided and fails closed when no domain is + supplied. Finite relation application, image, domain/range + restriction/subtraction, and override are now bounded and fail closed on non-functional or + malformed relations; partial/theory applications and binder/comprehension semantics + remain closed. Accepting formula and transition APIs also require a source locator + over the project refinement closure in addition to exact generated-obligation + membership. Acceptance requires a positive and negative sequent for each supported + operator family, with a changed semantic term rejected. +2. **PO-family soundness.** Source-bound, proof-carrying adapter contracts now exist for + INV/WD/GRD/SIM/THM/FIS/WFIS/WWD, EQL, MRG, VWD, and integer/finite variants; split merge + and anticipated/convergent variant semantics are explicit. Exact model-derived, + forged-goal-controlled fixtures now exercise THM, INV, GRD, SIM, FIS, WFIS, WWD, + and an anticipated integer NAT/VAR pair. + These contracts consume the exact checked `Obligation`, preserve its identity, + bind exact component/event declarations and effective deterministic assignments where + applicable, and require a checked `FormulaAdequacy` witness: validity of that exact + generated sequent plus a formula-to-contract implication. The implication remains + project-specific; there is no automatic interpretation of arbitrary Event-B terms. + MRG target labels, VWD, FIN/EQL locator controls, and parsed guard provenance now + have direct fixtures; `test/MrgAdapterFixtures.lean` additionally checks an exact + generated two-target MRG transition bridge and ordered branch pairing. The bounded + integer EQL adapter has a positive/negative source-and-sequent fixture, and FIN has + a source-bound constant finite-set adapter witness plus typed powerset evaluator + controls. MRG now has source-indexed target locators, exact branch guard/action + pairings, and same-label foreign-branch negatives. A model-derived finite-set VAR + fixture now uses the invariant-restricted source-indexed carrier; the legacy + `FiniteSetVariantAdapter.actionTotal` remains a compatibility diagnostic rather + than an acceptance path. `EnabledGuardFixtures` now covers a model-derived + parameterized event, exact parameter declarations, positive/negative enabledness, + and parameterized refinement simulation. Nondeterministic assignment relations are + covered by the relational FIS fixture. +3. **Refinement state model.** Typed observations and explicit event parameters are + now represented at the semantic boundary. Frame preservation, after-state gluing, + simultaneous assignment, duplicate-target rejection, function override, stuttering, + and merged-event counterexamples are source-bound or kernel-checked fixtures. +4. **Witness and variant semantics.** WWD has an exact source-bound adapter; WFIS has a + bounded finite-domain evaluator boundary and explicit negative controls. Merge + simulation has branch-specific abstract targets, and VAR is representable over an + explicit well-founded relation. + Keep anticipated non-increase separate from convergent strict decrease; VWD/NAT/FIN + and finite-set source controls are present. Typed `ℙ(T)` evaluation, positive / + negative evaluator fixtures, and a model-derived finite-set VAR fixture now exist; + its domain carries both invariant hypotheses and exact source-measure + correspondence. The legacy constant-variant witness remains only as a compatibility + regression. Parameterized enabledness is covered for the accepted source-bound slice; + arbitrary binders and comprehension terms remain unsupported by contract. +5. **Independent release ratchet.** Add the new class-level semantic checks to the CLI + fixture matrix, run the exact Rossi differential in CI, rerun the manual editor gate, + regenerate status from the final commit, then perform the clean-checkout command + matrix. Only after that may V4 #7/#8 be checked and a release tag created. + +### Evidence ledger + +| 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, hidden-parameter, primed-scope, duplicate-label, and missing-reference controls pass | current | +| POG semantic coverage | nondeterministic actions, data-refinement glue, WWD, variants, EQL/MRG provenance, named frame/gluing/merge/witness/variant contracts, parameterized enabledness, closed POG-class table, error-aware typed evaluator, explicit `POGSoundness` sequent validity, and model-derived THM/INV/GRD/SIM/FIS/WFIS/WWD/integer-NAT-VAR/finite-set-VAR/VWD fixtures | strict checked path; unrestricted binder/comprehension and arbitrary formula semantics remain explicitly unsupported | +| Kernel trust | replay checks reject open mvars, stale goals, forged axioms, and context drift | current | +| External/Rodin provenance | supplied model-artifact parsing, model-derived canonical POG binding, BPO/status identity, monotonic ledger update; legacy status-only replay rejected | current; exact closure and digest 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 | + +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 @@ -75,7 +218,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 @@ -247,7 +391,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 @@ -271,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: @@ -322,7 +467,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. @@ -363,11 +508,14 @@ Production thresholds: ### V4.6 ProofWidget and editor acceptance -- [ ] #34 Manually verify `examples/WidgetDemo.lean` in the VS Code Infoview from a clean - Lean server: model panels, obligation sections, hypotheses, goals, proof badges, and - the 11 replayed entries must render without React or widget errors. -- [ ] #35 Verify native Go to Definition and scope diagnostics for theory, context, machine, - event, and invariant symbols in the editor. +- [x] #34 Manually verify `examples/WidgetDemo.lean` in the VS Code Infoview from a clean + Lean server: model panels, obligation sections, hypotheses, goals, and 11 explicitly + declared evidence badges rendered without React or widget errors. +- [x] #35 Verify native Go to Definition and scope diagnostics for theory, context, machine, + event, and invariant symbols in the editor. `#eventb_lsp_checks` verifies native source + ranges for the declaration classes; after the DSL reference-location fix, VS Code Go to + Definition from `sees LspContext` found the declaration, and a temporary unknown + identifier reproduced the expected Lean diagnostic before the unsaved edit was discarded. - [x] #36 Record the manual UI acceptance procedure in the README without committing private screenshots or generated editor state. - [x] #37 Keep raw Rossi/XML source-range limitations explicit until source navigation for diff --git a/Widgets.lean b/Widgets.lean index 0f5fa07..aa80699 100644 --- a/Widgets.lean +++ b/Widgets.lean @@ -45,10 +45,12 @@ private def evidenceLabel : Trust.Evidence → String | .kernel declaration axioms => if axioms.isEmpty then s!"Lean declaration {declaration}" else s!"Lean declaration {declaration} (axioms: {String.intercalate ", " axioms})" - | .smt solver version _ verifier => s!"{solver} {version}, verified by {verifier}" - | .external tool version _ verifier => s!"{tool} {version}, verified by {verifier}" + | .smt solver version _ verifier => s!"{solver} {version}, declared by {verifier}" + | .external tool version _ verifier => s!"{tool} {version}, declared 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 @@ -88,6 +90,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,13 +107,20 @@ 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 := (Trust.Ledger.ofObligations [obligation]).entries.head! private def entryFor (ledger : Trust.Ledger) (obligation : Obligation) : Trust.Entry := - (ledger.entry? obligation.component obligation.name).getD (fallbackEntry obligation) + (ledger.displayEntry? obligation.component obligation.name).getD (fallbackEntry obligation) private def obligationCard (ledger : Trust.Ledger) (obligation : Obligation) : Html := let entry := entryFor ledger obligation @@ -120,7 +136,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..1ff0409 --- /dev/null +++ b/baseline/p4.tsv @@ -0,0 +1,73 @@ +M0_AMAN_Update_prob_mc_Ctx axm_init_airplanes/WD eventb-v1-16829145160484273594 external-declared exact-hypothesis +M1_Landing_Sequence AMAN_Update/inv1,1/INV eventb-v1-5952998824876361987 external-declared exact-hypothesis +M1_Landing_Sequence AMAN_Update/inv13,2/INV eventb-v1-14486024917793534250 external-declared exact-hypothesis +M1_Landing_Sequence AMAN_Update/glue1,1/INV eventb-v1-17390780325116527436 external-declared reflexive +M4_Zoom changeZoom/inv6,1/INV eventb-v1-5074545683590948877 external-declared exact-hypothesis +M6_Select_Airplane selectedAirplane_card/WD eventb-v1-13876482062933068475 external-declared exact-hypothesis +M8_Interaction_Events dragged_airplane_card/WD eventb-v1-8672142159150112234 external-declared exact-hypothesis +M8_Interaction_Events dragged_zoom_level_card/WD eventb-v1-5108533651225176600 external-declared exact-hypothesis +M9_Push_Mouse_Buttons is_clicked_block_card/WD eventb-v1-16385690044210585065 external-declared exact-hypothesis +M9_Push_Mouse_Buttons block_slot_position_card/WD eventb-v1-17293093683319281994 external-declared exact-hypothesis +M9_Push_Mouse_Buttons airplane_Position_card/WD eventb-v1-15118745736586539840 external-declared exact-hypothesis +M9_Push_Mouse_Buttons zoom_Position_card/WD eventb-v1-10862862079148529320 external-declared exact-hypothesis +M9_Push_Mouse_Buttons Click_Block_Time/is_clicked_block/INV eventb-v1-10308162812538151779 external-declared exact-hypothesis +M9_Push_Mouse_Buttons Click_Block_Time/is_clicked_block_fin/INV eventb-v1-12648376009743200148 external-declared exact-hypothesis +M9_Push_Mouse_Buttons Click_Block_Time/is_clicked_block_card/INV eventb-v1-14948101976653692821 external-declared exact-hypothesis +MAbs abstract_selectedAirplane_card/WD eventb-v1-14621877684346714394 external-declared exact-hypothesis +MAbs dragged_airplane_card/WD eventb-v1-11607518134397819031 external-declared exact-hypothesis +MAbs dragged_zoom_level_card/WD eventb-v1-16609845267404018574 external-declared exact-hypothesis +MAbs is_clicked_block_card/WD eventb-v1-2111861896089874719 external-declared exact-hypothesis +MAbs block_slot_position_card/WD eventb-v1-9479766206528609583 external-declared exact-hypothesis +MAbs airplane_Position_card/WD eventb-v1-8816147645107901744 external-declared exact-hypothesis +MAbs zoom_Position_card/WD eventb-v1-10337737539238151803 external-declared exact-hypothesis +MAbs Click_Block_Time/is_clicked_block_fin/INV eventb-v1-4850963611294016226 external-declared exact-hypothesis +MAbs Click_Block_Time/is_clicked_block_card/INV eventb-v1-3007239627218876922 external-declared exact-hypothesis +MAbs_helper zoom_Position_card/WD eventb-v1-12838068536752949749 external-declared exact-hypothesis +MAbs_helper airplane_Position_card/WD eventb-v1-8560278530949472824 external-declared exact-hypothesis +MAbs_helper block_slot_position_card/WD eventb-v1-16865147050694524371 external-declared exact-hypothesis +MAbs_helper is_clicked_block_card/WD eventb-v1-6176386349350495706 external-declared exact-hypothesis +MAbs_helper INITIALISATION/selected_airplane_glue_2/INV eventb-v1-13393541256562704162 external-declared reflexive +MAbs_helper INITIALISATION/act2,1/SIM eventb-v1-1904022326184590749 external-declared reflexive +MAbs_helper INITIALISATION/act6,1/SIM eventb-v1-13997722314308442627 external-declared reflexive +MAbs_helper INITIALISATION/act9,6/SIM eventb-v1-324200555209367186 external-declared reflexive +MAbs_helper INITIALISATION/mouse_pressed_init/SIM eventb-v1-17623492704637381121 external-declared reflexive +MAbs_helper Move_Mouse_Hold/act9,4/SIM eventb-v1-6316941715101413182 external-declared reflexive +MAbs_helper Move_Mouse_Block/act9,4/SIM eventb-v1-744383341946784867 external-declared reflexive +MAbs_helper Move_Mouse_Airplane/act9,4/SIM eventb-v1-3792374523669588341 external-declared reflexive +MAbs_helper Move_Mouse_Nothing/act9,4/SIM eventb-v1-5678845416610114088 external-declared reflexive +MAbs_helper AMAN_Update_mouse_to_nothing/landing_sequence_1/INV eventb-v1-3637221599295908496 external-declared exact-hypothesis +MAbs_helper AMAN_Update_mouse_to_nothing/landing_sequence_2/INV eventb-v1-18337452325949431025 external-declared exact-hypothesis +MAbs_helper AMAN_Update_mouse_to_nothing/landing_sequence_3/INV eventb-v1-10387503350183962558 external-declared reflexive +MAbs_helper AMAN_Update_mouse_to_nothing/selected_airplane_glue_2/INV eventb-v1-17014798992690263540 external-declared reflexive +MAbs_helper AMAN_Update_mouse_to_nothing/act2,1/SIM eventb-v1-7972194414658671855 external-declared reflexive +MAbs_helper AMAN_Update_mouse_to_airplane/landing_sequence_1/INV eventb-v1-17960741234889804297 external-declared exact-hypothesis +MAbs_helper AMAN_Update_mouse_to_airplane/landing_sequence_2/INV eventb-v1-17044829435698685195 external-declared exact-hypothesis +MAbs_helper AMAN_Update_mouse_to_airplane/landing_sequence_3/INV eventb-v1-15455895954992255775 external-declared reflexive +MAbs_helper AMAN_Update_mouse_to_airplane/selected_airplane_glue_2/INV eventb-v1-4771753122858391310 external-declared reflexive +MAbs_helper AMAN_Update_mouse_to_airplane/act2,1/SIM eventb-v1-5906076194927146421 external-declared reflexive +MAbs_helper AMAN_Update_mouse_stays/landing_sequence_1/INV eventb-v1-8102351550214528873 external-declared exact-hypothesis +MAbs_helper AMAN_Update_mouse_stays/landing_sequence_2/INV eventb-v1-4186422107733177070 external-declared exact-hypothesis +MAbs_helper AMAN_Update_mouse_stays/landing_sequence_3/INV eventb-v1-16924152694001247823 external-declared reflexive +MAbs_helper AMAN_Update_mouse_stays/selected_airplane_glue_2/INV eventb-v1-13083000857704501251 external-declared reflexive +MAbs_helper AMAN_Update_mouse_stays/act2,1/SIM eventb-v1-11953983933110232066 external-declared reflexive +MAbs_helper AMAN_Timeout/selected_airplane_glue_2/INV eventb-v1-12300009698097461724 external-declared reflexive +MAbs_helper Move_Aircraft/set_to_release/SIM eventb-v1-13809488853902544126 external-declared reflexive +MAbs_helper Release_Trigger_Hold_Button/selected_airplane_glue_2/INV eventb-v1-12884135418067291466 external-declared reflexive +MAbs_helper Release_Trigger_Hold_Button/act9,1/SIM eventb-v1-2265997975947546931 external-declared reflexive +MAbs_helper Click_Block_Time/is_clicked_block/INV eventb-v1-16780666689996213097 external-declared exact-hypothesis +MAbs_helper Click_Block_Time/isClickedBlock_glue/INV eventb-v1-5712249715222137357 external-declared exact-hypothesis +MAbs_helper Click_Block_Time/is_clicked_block_fin/INV eventb-v1-6306803904311634003 external-declared exact-hypothesis +MAbs_helper Click_Block_Time/is_clicked_block_card/INV eventb-v1-1972092461926185202 external-declared exact-hypothesis +MAbs_helper Click_Block_Time/set_mouse_click/SIM eventb-v1-15525831042234247423 external-declared reflexive +MAbs_helper Release_Trigger_Block_Time/clicked_pos/SIM eventb-v1-13729656030034437291 external-declared reflexive +MAbs_helper Release_Abort_Time_Button/clicked_pos/SIM eventb-v1-14291099572336688180 external-declared reflexive +MAbs_helper Release_Trigger_Deblock_Time/clicked_pos/SIM eventb-v1-11750202660985723614 external-declared reflexive +MAbs_helper changeZoom/selected_airplane_glue_2/INV eventb-v1-18025039012413666565 external-declared reflexive +MAbs_helper changeZoom/clicked_pos/SIM eventb-v1-3577514077840859436 external-declared reflexive +MAbs_helper selectAirplane/selected_airplane_glue_2/INV eventb-v1-6253709394115987799 external-declared reflexive +MAbs_helper selectAirplane/press_mouse/SIM eventb-v1-5564680175720267226 external-declared reflexive +MAbs_helper deselectAirplane/selected_airplane_glue_2/INV eventb-v1-13870771662686551008 external-declared reflexive +MAbs_helper resume_dragging_airplane/press_mouse/SIM eventb-v1-5705311774075729570 external-declared reflexive +MAbs_helper stop_dragging_airplane/clicked_pos/SIM eventb-v1-4634871620335529269 external-declared reflexive +MAbs_prob_mc_Ctx axm_inst4,1/WD eventb-v1-368063854654994650 external-declared exact-hypothesis +MAbs_prob_mc_Ctx abstract_blocks_card/WD eventb-v1-1441971169358301113 external-declared 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..8378828 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 "," @@ -584,7 +586,7 @@ private def evidenceJson : Trust.Evidence → String | .none => "{\"mode\":\"unproved\",\"declaration\":\"\",\"verifier\":\"\",\"dependencies\":[]}" | .kernel declaration axioms => - "{\"mode\":" ++ jsonString Trust.Mode.kernel.label ++ + "{\"mode\":" ++ jsonString (Trust.Evidence.kernel declaration axioms).mode.label ++ ",\"declaration\":" ++ jsonString declaration ++ ",\"verifier\":\"Lean kernel\",\"dependencies\":" ++ jsonArray axioms ++ "}" | .smt solver version inputDigest verifier => @@ -592,12 +594,14 @@ private def evidenceJson : Trust.Evidence → String ",\"tool\":" ++ jsonString solver ++ ",\"version\":" ++ jsonString version ++ ",\"input_digest\":" ++ jsonString inputDigest ++ + ",\"metadata_only\":true" ++ ",\"verifier\":" ++ jsonString verifier ++ "}" | .external tool version artifactDigest verifier => "{\"mode\":" ++ jsonString Trust.Mode.external.label ++ ",\"tool\":" ++ jsonString tool ++ ",\"version\":" ++ jsonString version ++ ",\"input_digest\":" ++ jsonString artifactDigest ++ + ",\"metadata_only\":true" ++ ",\"verifier\":" ++ jsonString verifier ++ "}" | .rodinImported source digest manual => "{\"mode\":" ++ jsonString Trust.Mode.rodinImported.label ++ @@ -605,11 +609,23 @@ private def evidenceJson : Trust.Evidence → String ",\"input_digest\":" ++ jsonString digest ++ ",\"manual\":" ++ jsonBool manual ++ ",\"verifier\":\"Rodin .bps importer\"}" + | .rodinImportedProvenance models bpo statuses digest manual => + "{\"mode\":" ++ jsonString Trust.Mode.rodinImported.label ++ + ",\"models\":" ++ jsonArray (models.map (·.component)) ++ + ",\"bpo\":" ++ jsonString bpo ++ + ",\"statuses\":" ++ jsonString statuses ++ + ",\"input_digest\":" ++ jsonString digest ++ + ",\"manual\":" ++ jsonBool manual ++ + ",\"verifier\":\"Rodin provenance validator\"}" + +#guard (evidenceJson (.kernel "proof" ["propext"])).contains "kernel-checked-with-axioms" +#guard (evidenceJson (.external "tool" "1" "claim" "checker")).contains + "\"metadata_only\":true" private def reportEntry (gold : List (String × List String)) (ledger : Trust.Ledger) (machine : String) (obligation : Obligation) : String := let fallback := (Trust.Ledger.ofObligations [obligation]).entries.head! - let entry := (ledger.entry? machine obligation.name).getD fallback + let entry := (ledger.displayEntry? machine obligation.name).getD fallback let mode := entry.mode.label let rule := Prover.Local.prove obligation |>.rule.map Prover.Local.Rule.label |>.getD "none" let goal := obligation.goal.map Formula.print |>.getD "" @@ -652,7 +668,8 @@ private def runReport (dir : System.FilePath) : IO UInt32 := do let ledger := localLedger (obligations.map (·.2)) let records := obligations.map fun (machine, obligation) => reportEntry gold ledger machine obligation - let modes := [Trust.Mode.kernel, .smt, .rodinImported, .external, .unproved] + let modes := [Trust.Mode.kernel, .kernelAxiomatized, .smt, .rodinImported, .external, + .unproved] let counts := modes.map fun mode => jsonString mode.label ++ ":" ++ toString (ledger.count mode) IO.println ("{\"coverage_source\":" ++ @@ -700,8 +717,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..f905426 100644 --- a/examples/TrustRodinDemo.lean +++ b/examples/TrustRodinDemo.lean @@ -6,14 +6,30 @@ namespace EventB.TrustRodinDemo open EventB private def obligation : POG.Obligation := - { component := "Demo", name := "evt/inv/INV", kind := "INV", goal := some (.id "⊤") } + { component := "Demo", name := "INITIALISATION/inv/INV", kind := "INV" + goal := some (.bin "∈" (.num 0) (.id "ℤ")) } private def source := "" ++ "" +private def provenance : Trust.Rodin.Provenance := + { models := [{ component := "Demo", kind := .machine, bytes := + ("" ++ + "" ++ + "").toUTF8 }] + bpo := "" ++ + "" + statuses := source } + #guard match Trust.Rodin.importStatuses source with | .ok [status] => let result := Trust.Rodin.compare [obligation] [status] @@ -21,8 +37,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..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 @@ -158,7 +159,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)) + "separate Trust.Replay check" + match ledger.attach obligation evidence with | .ok updated => updated | .error _ => ledger @@ -175,13 +179,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/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 d4a786a..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 @@ -140,11 +149,14 @@ placeholder. ## Obligation generation -`POG.generateIn theory project machine` is the theory-aware entry point. It produces +`POG.generateIn theory project machine` is the compatibility entry point for the pinned +corpus. It produces `POG.Obligation` records containing a Rodin-compatible name, obligation class, and, where derived, a goal and ordered hypotheses. The compatibility `POG.generate` entry point uses an empty user-theory environment for corpus models that do not use native -theories. +theories. Trusted front ends use `POG.generateCheckedIn` or `POG.generateChecked`; those +paths run strict scope/refinement checks and fail closed on diagnostics before consuming +the generated list. Well-definedness is driven by symbol metadata in the prelude and theory environment. Total operators do not produce unnecessary WD conditions; conditional operators carry @@ -152,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 @@ -182,9 +200,15 @@ 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 -evidence remain explicit metadata boundaries and must carry solver/tool, version, input -digest, and verifier fields. +records as `rodinImported`; it never upgrades them to kernel evidence. Legacy status-only +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, 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 @@ -199,8 +223,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,15 +255,14 @@ 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. + 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 @@ -276,9 +299,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 @@ -451,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`. @@ -467,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 683413b..70a6684 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 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 | | --- | ---: | --- | @@ -24,15 +19,16 @@ 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. | -| P4 local baseline | 73/1133 | Explicit external-trusted evidence; 1060 remain unproved. | +| 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-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 @@ -42,6 +38,14 @@ 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: 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. 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. @@ -55,13 +59,82 @@ 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 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 python3 tools/cli-fixtures.py @@ -77,16 +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-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. +- 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/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/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 5e4e338..08e213b 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 @@ -188,12 +208,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 @@ -212,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 @@ -231,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 @@ -243,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 @@ -300,6 +331,33 @@ 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) + -- 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 + | 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, _, _) => + 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. private partial def goldHyps (e : XmlElem) (sets : List (String × Option String × List String)) : List (String × List String) := @@ -310,7 +368,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 @@ -338,10 +400,34 @@ 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}") + 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 @@ -351,6 +437,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 @@ -365,7 +469,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" @@ -397,7 +501,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 @@ -425,11 +529,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)) : @@ -440,13 +542,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" @@ -471,13 +575,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" @@ -507,8 +613,17 @@ 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}") + 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 @@ -525,13 +640,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 @@ -576,9 +705,31 @@ 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) +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 @@ -596,7 +747,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") @@ -605,6 +757,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" @@ -620,15 +773,17 @@ 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" ++ "| 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" ++ @@ -638,6 +793,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 @@ -673,6 +833,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" @@ -683,11 +848,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 @@ -697,14 +867,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 @@ -726,6 +903,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 @@ -735,22 +914,38 @@ 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 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 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 !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 return 0 let baseline ← try IO.FS.readFile "baseline/parse.tsv" catch _ => pure "" @@ -765,13 +960,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/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 fd788a4..8a19762 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,24 +98,27 @@ 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, + "kernel-checked-with-axioms": 0, + "smt-declared": 0, + "rodin-structurally-checked": 0, + "external-declared": 5, + "unproved": 8, }: raise AssertionError("witness report: trust ledger changed") for record in report["obligations"]: 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": @@ -123,7 +132,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 +207,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: