diff --git a/EventB/DSL.lean b/EventB/DSL.lean index 9cc0dc3..d400a72 100644 --- a/EventB/DSL.lean +++ b/EventB/DSL.lean @@ -43,7 +43,11 @@ initialize theoryExtension : SimplePersistentEnvExtension Theory.Spec (Array The addImportedFn := Array.flatMap id } -private def theoryEnvironment (env : Environment) : Theory.Env := +private +def theoryEnvironment + (env : Environment) + : Theory.Env + := { theories := Theory.core :: (theoryExtension.getState env).toList } declare_syntax_cat ebLabelled @@ -86,7 +90,12 @@ syntax "constants " ident+ : ebContextPart syntax "axiom " ebLabelled : ebContextPart /-- Attribute list for a labelled child: `@[label] formula`. -/ -private def labelledAttrs (attr label formula : String) (isThm : Bool) : TSyntax `term := +private +def labelledAttrs + (attr label formula : String) + (isThm : Bool) + : TSyntax `term + := if isThm then Unhygienic.run `([("org.eventb.core.label", $(quote label)), ($(quote attr), $(quote formula)), ("org.eventb.core.theorem", "true")]) @@ -94,17 +103,34 @@ private def labelledAttrs (attr label formula : String) (isThm : Bool) : TSyntax Unhygienic.run `([("org.eventb.core.label", $(quote label)), ($(quote attr), $(quote formula))]) -private def identAttrs (name : String) : TSyntax `term := +private +def identAttrs + (name : String) + : TSyntax `term + := Unhygienic.run `([("org.eventb.core.identifier", $(quote name))]) -private def targetAttrs (name : String) : TSyntax `term := +private +def targetAttrs + (name : String) + : TSyntax `term + := Unhygienic.run `([("org.eventb.core.target", $(quote name))]) -private def extendedTargetAttrs (name : String) : TSyntax `term := +private +def extendedTargetAttrs + (name : String) + : TSyntax `term + := Unhygienic.run `([("org.eventb.core.target", $(quote name)), ("org.eventb.core.extended", "true")]) -private def eventAttrs (label : String) (conv : Option String) : TSyntax `term := +private +def eventAttrs + (label : String) + (conv : Option String) + : TSyntax `term + := match conv with | none => Unhygienic.run `([("org.eventb.core.label", $(quote label))]) | some s => @@ -115,15 +141,28 @@ private def eventAttrs (label : String) (conv : Option String) : TSyntax `term : private def noKids : TSyntax `term := Unhygienic.run `(([] : List EventB.Elem)) -private def symbolName (owner symbol : String) : Name := +private +def symbolName + (owner symbol : String) + : Name + := Name.mkSimple ("EventB.DSL.symbol." ++ owner ++ "." ++ symbol) -private def addSymbolRange (owner : String) (id : Syntax) : CommandElabM Unit := do +private +def addSymbolRange + (owner : String) + (id : Syntax) + : CommandElabM Unit + := do let some range ← getDeclarationRange? id | return Lean.addDeclarationRanges (symbolName owner id.getId.toString) { range := range, selectionRange := range } -private def sourceRangeOf (stx : Syntax) : CommandElabM EventB.SourceRange := do +private +def sourceRangeOf + (stx : Syntax) + : CommandElabM EventB.SourceRange + := do let file ← getFileName match ← getDeclarationRange? stx with | some range => @@ -134,10 +173,17 @@ private def sourceRangeOf (stx : Syntax) : CommandElabM EventB.SourceRange := do return { file := file, beginPos, finishPos } | none => return EventB.SourceRange.synthetic file -private def baseSymbol (symbol : String) : String := +private +def baseSymbol + (symbol : String) + : String + := if symbol.endsWith "'" then (symbol.dropEnd 1).copy else symbol -private def currentModule : CommandElabM Name := do +private +def currentModule + : CommandElabM Name + := do let fileName ← getFileName try let path ← liftIO <| IO.FS.realPath (System.FilePath.mk fileName) @@ -145,8 +191,12 @@ private def currentModule : CommandElabM Name := do catch _ => getMainModule -private def symbolLocation? (owners : List String) (symbol : String) : - CommandElabM (Option DeclarationLocation) := do +private +def symbolLocation? + (owners : List String) + (symbol : String) + : CommandElabM (Option DeclarationLocation) + := do let module ← currentModule let symbol := baseSymbol symbol for owner in owners do @@ -154,17 +204,29 @@ private def symbolLocation? (owners : List String) (symbol : String) : return some { module, range := ranges.selectionRange } return none -private def formulaIdentifiersAux : Nat → Syntax → List Syntax +private +def formulaIdentifiersAux + : Nat → -- fuel, bounds syntax-tree recursion + Syntax → -- syntax node to scan for idents + List Syntax | 0, _ => [] | fuel + 1, stx => if stx.isIdent then [stx] else stx.getArgs.toList.flatMap (formulaIdentifiersAux fuel) -private def formulaIdentifiers (stx : Syntax) : List Syntax := +private +def formulaIdentifiers + (stx : Syntax) + : List Syntax + := -- Formula syntax is shallow; the bound keeps this metadata walk executable. formulaIdentifiersAux 1024 stx -private def freeFormulaIdentifiers (bound : List String) : Formula.Term → List String +private +def freeFormulaIdentifiers + (bound : List String) + : Formula.Term → + List String | .id n => if bound.contains n then [] else [n] | .num _ => [] | .bin _ a b => freeFormulaIdentifiers bound a ++ freeFormulaIdentifiers bound b @@ -175,15 +237,25 @@ private def freeFormulaIdentifiers (bound : List String) : Formula.Term → List let bound' := Formula.patternNames pattern ++ bound freeFormulaIdentifiers bound' pattern ++ freeFormulaIdentifiers bound' body -private def checkScope (theoryRoots owners : List String) (stx : Syntax) (term : Formula.Term) : - CommandElabM Unit := do +private +def checkScope + (theoryRoots owners : List String) + (stx : Syntax) + (term : Formula.Term) + : CommandElabM Unit + := do let theory := theoryEnvironment (← getEnv) for name in (freeFormulaIdentifiers [] term).eraseDups do if !Theory.isIdentifierIn theory theoryRoots name && (← symbolLocation? owners name).isNone then throwErrorAt stx s!"unknown Event-B identifier `{name}`" -private def addDefinitionInfo (id : Syntax) (symbol : String) (location : DeclarationLocation) : - CommandElabM Unit := do +private +def addDefinitionInfo + (id : Syntax) + (symbol : String) + (location : DeclarationLocation) + : CommandElabM Unit + := do pushInfoLeaf <| .ofDelabTermInfo { elaborator := `EventB.DSL stx := id @@ -195,58 +267,106 @@ 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 +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 +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 +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 addDefinitionInfo id id.getId.toString location /-- Reject anything that is not an Event-B formula, at elaboration time. -/ -private def checkFormula (theoryRoots owners : List String) (stx : Syntax) (s : String) : - CommandElabM Unit := do +private +def checkFormula + (theoryRoots owners : List String) + (stx : Syntax) + (s : String) + : CommandElabM Unit + := do match Formula.parse s with | .ok term => checkScope theoryRoots owners stx term | .error e => throwErrorAt stx s!"not an Event-B formula: {e}" -private def formulaText (f : TSyntax `ebFormula) : String := +private +def formulaText + (f : TSyntax `ebFormula) + : String + := match f with | `(ebFormula| $s:str) => s.getString | _ => f.raw.prettyPrint.pretty -private def labelledOf : TSyntax `ebLabelled → CommandElabM (String × String × Syntax × Bool) +private +def labelledOf + : TSyntax `ebLabelled → + CommandElabM (String × String × Syntax × Bool) | `(ebLabelled| $l:ident : $f:ebFormula) => pure (l.getId.toString, formulaText f, f.raw, false) | `(ebLabelled| theorem $l:ident : $f:ebFormula) => pure (l.getId.toString, formulaText f, f.raw, true) | stx => throwErrorAt stx "expected `label : formula`" -private def mkElem (ctor : String) (attrs kids : TSyntax `term) : TSyntax `term := +private +def mkElem + (ctor : String) + (attrs kids : TSyntax `term) + : TSyntax `term + := Unhygienic.run `($(mkIdent ("EventB.Elem." ++ ctor : String).toName) $attrs $kids) -private def listOf (ts : Array (TSyntax `term)) : TSyntax `term := +private +def listOf + (ts : Array (TSyntax `term)) + : TSyntax `term + := Unhygienic.run `([$ts,*]) -private def rootsName (name : Ident) : Ident := +private +def rootsName + (name : Ident) + : Ident + := mkIdent (Name.mkSimple (name.getId.toString ++ "_theories")) -private def defineRoots (name : Ident) (roots : List String) : CommandElabM Unit := do +private +def defineRoots + (name : Ident) + (roots : List String) + : CommandElabM Unit + := do let rootTerms := listOf (roots.toArray.map quote) elabCommand (← `(def $(rootsName name) : List String := $rootTerms)) -private def eventParts (theoryRoots owners : List String) (parts : Array (TSyntax `ebEventPart)) : - CommandElabM (Array (TSyntax `term) × Option String) := do +private +def eventParts + (theoryRoots owners : List String) + (parts : Array (TSyntax `ebEventPart)) + : CommandElabM (Array (TSyntax `term) × Option String) + := do let mut out := #[] let mut conv : Option String := none for p in parts do @@ -279,8 +399,13 @@ private def eventParts (theoryRoots owners : List String) (parts : Array (TSynta | stx => throwErrorAt stx "unexpected event clause" return (out, conv) -private def eventOf (owner : String) (theoryRoots owners : List String) (stx : TSyntax `ebEvent) : - CommandElabM (TSyntax `term) := do +private +def eventOf + (owner : String) + (theoryRoots owners : List String) + (stx : TSyntax `ebEvent) + : CommandElabM (TSyntax `term) + := do match stx with | `(ebEvent| event $n:ident where $ps:ebEventPart*) => do addSymbolRange owner n.raw @@ -295,8 +420,13 @@ private def eventOf (owner : String) (theoryRoots owners : List String) (stx : T return mkElem "event" attrs (listOf kids) | other => throwErrorAt other "expected an event" -private def addEventInfos (owner : String) (owners : List String) - (stx : TSyntax `ebEvent) : CommandElabM Unit := do +private +def addEventInfos + (owner : String) + (owners : List String) + (stx : TSyntax `ebEvent) + : CommandElabM Unit + := do match stx with | `(ebEvent| event $n:ident where $ps:ebEventPart*) => let eventOwner := owner ++ "." ++ n.getId.toString @@ -314,8 +444,13 @@ private def addEventInfos (owner : String) (owners : List String) | _ => pure () | other => throwErrorAt other "expected an event" -private def addMachineInfos (owner : String) (owners : List String) - (parts : Array (TSyntax `ebMachinePart)) : CommandElabM Unit := do +private +def addMachineInfos + (owner : String) + (owners : List String) + (parts : Array (TSyntax `ebMachinePart)) + : CommandElabM Unit + := do for p in parts do match p with | `(ebMachinePart| invariant $l:ebLabelled) => @@ -331,8 +466,12 @@ private def addMachineInfos (owner : String) (owners : List String) | `(ebMachinePart| $e:ebEvent) => addEventInfos owner owners e | _ => pure () -private def addContextInfos (owners : List String) - (parts : Array (TSyntax `ebContextPart)) : CommandElabM Unit := do +private +def addContextInfos + (owners : List String) + (parts : Array (TSyntax `ebContextPart)) + : CommandElabM Unit + := do for p in parts do match p with | `(ebContextPart| axiom $l:ebLabelled) => @@ -369,15 +508,27 @@ syntax "theorem " ident " type_parameters " ident+ "where " str : ebTheoryPart syntax (name := eventbTheory) "eventb_theory " ident "where " ebTheoryPart* : command -private def theoryTy (stx : Syntax) : EventB.Typing.Ty := +private +def theoryTy + (stx : Syntax) + : EventB.Typing.Ty + := (EventB.Typing.Ty.parse stx.getId.toString).getD (.given stx.getId.toString) -private def theoryFormula (stx : Syntax) (source : String) : CommandElabM Formula.Term := do +private +def theoryFormula + (stx : Syntax) + (source : String) + : CommandElabM Formula.Term + := do match Formula.parse source with | .ok term => pure term | .error error => throwErrorAt stx s!"not an Event-B theory formula: {error}" -private def mkTyTerm : EventB.Typing.Ty → TSyntax `term +private +def mkTyTerm + : EventB.Typing.Ty → + TSyntax `term | .int => Unhygienic.run `(EventB.Typing.Ty.int) | .bool => Unhygienic.run `(EventB.Typing.Ty.bool) | .given name => Unhygienic.run `(EventB.Typing.Ty.given $(quote name)) @@ -386,27 +537,43 @@ private def mkTyTerm : EventB.Typing.Ty → TSyntax `term | .prod left right => Unhygienic.run `(EventB.Typing.Ty.prod $(mkTyTerm left) $(mkTyTerm right)) -private def mkSymbolKind (kind : SymbolKind) : TSyntax `term := +private +def mkSymbolKind + (kind : SymbolKind) + : TSyntax `term + := match kind with | .carrierSet => Unhygienic.run `(EventB.Prelude.SymbolKind.carrierSet) | .constant => Unhygienic.run `(EventB.Prelude.SymbolKind.constant) | .predicate => Unhygienic.run `(EventB.Prelude.SymbolKind.predicate) | .expression => Unhygienic.run `(EventB.Prelude.SymbolKind.expression) -private def mkApplication (application : Option ApplicationKind) : TSyntax `term := +private +def mkApplication + (application : Option ApplicationKind) + : TSyntax `term + := match application with | none => Unhygienic.run `(none) | some .total => Unhygienic.run `(some EventB.Prelude.ApplicationKind.total) | some .wellDefined => Unhygienic.run `(some EventB.Prelude.ApplicationKind.wellDefined) -private def mkDefinedness (rule : Definedness) : TSyntax `term := +private +def mkDefinedness + (rule : Definedness) + : TSyntax `term + := match rule with | .finite => Unhygienic.run `(EventB.Prelude.Definedness.finite) | .nonempty => Unhygienic.run `(EventB.Prelude.Definedness.nonempty) | .lowerBound => Unhygienic.run `(EventB.Prelude.Definedness.lowerBound) | .upperBound => Unhygienic.run `(EventB.Prelude.Definedness.upperBound) -private def mkSymbolTerm (symbol : Symbol) : TSyntax `term := +private +def mkSymbolTerm + (symbol : Symbol) + : TSyntax `term + := let type := match symbol.type with | none => Unhygienic.run `(none) | some type => Unhygienic.run `(some $(mkTyTerm type)) @@ -421,22 +588,37 @@ private def mkSymbolTerm (symbol : Symbol) : TSyntax `term := Unhygienic.run `(EventB.Prelude.Symbol.mk $(quote symbol.name) $(mkSymbolKind symbol.kind) $type $(quote symbol.description) $(mkApplication symbol.application) $definedness $id $source) -private def mkFormulaTerm (term : Formula.Term) : TSyntax `term := +private +def mkFormulaTerm + (term : Formula.Term) + : TSyntax `term + := let source := Formula.print term Unhygienic.run `(match EventB.Formula.parse $(quote source) with | .ok value => value | .error _ => EventB.Formula.Term.id "") -private def mkTypedParameter (parameter : String × EventB.Typing.Ty) : TSyntax `term := +private +def mkTypedParameter + (parameter : String × EventB.Typing.Ty) + : TSyntax `term + := let name := parameter.1 let type := parameter.2 Unhygienic.run `(($(quote name), $(mkTyTerm type))) -private def mkConstructorTerm (constructor : Theory.Constructor) : TSyntax `term := +private +def mkConstructorTerm + (constructor : Theory.Constructor) + : TSyntax `term + := let arguments := listOf (constructor.arguments.toArray.map mkTyTerm) Unhygienic.run `(EventB.Theory.Constructor.mk $(quote constructor.name) $arguments) -private def mkDeclarationTerm : Theory.Declaration → TSyntax `term +private +def mkDeclarationTerm + : Theory.Declaration → + TSyntax `term | Theory.Declaration.dataType dataDecl => let parameters := listOf (dataDecl.parameters.toArray.map quote) let constructors := listOf (dataDecl.constructors.toArray.map mkConstructorTerm) @@ -480,21 +662,41 @@ private def mkDeclarationTerm : Theory.Declaration → TSyntax `term (EventB.Theory.Rule.mk $(quote rule.name) $kind $parameters $premises $lhs $rhs $conclusion $(listOf (rule.typeParameters.toArray.map quote)))) -private def mkSpecTerm (spec : Theory.Spec) : TSyntax `term := +private +def mkSpecTerm + (spec : Theory.Spec) + : TSyntax `term + := let importNames := listOf (spec.imports.toArray.map quote) let symbols := listOf (spec.symbols.toArray.map mkSymbolTerm) let declarations := listOf (spec.declarations.toArray.map mkDeclarationTerm) Unhygienic.run `(EventB.Theory.Spec.mk $(quote spec.name) $importNames $symbols $declarations) -private def theorySymbol (name : String) (kind : SymbolKind) (type : Option Ty) - (application : Option ApplicationKind) : Symbol := +private +def theorySymbol + (name : String) + (kind : SymbolKind) + (type : Option Ty) + (application : Option ApplicationKind) + : Symbol + := { name, kind, type, description := s!"Native Event-B theory symbol `{name}`.", application, id := SymbolId.unqualified name, source := EventB.SourceRange.synthetic } -private def symbolAt (stx : Syntax) (symbol : Symbol) : CommandElabM Symbol := do +private +def symbolAt + (stx : Syntax) + (symbol : Symbol) + : CommandElabM Symbol + := do return { symbol with source := ← sourceRangeOf stx } -private def defineTheory (name : Ident) (body : TSyntax `term) : CommandElabM Unit := do +private +def defineTheory + (name : Ident) + (body : TSyntax `term) + : CommandElabM Unit + := do elabCommand (← `(def $name : EventB.Theory.Spec := $body)) @[command_elab eventbTheory] @@ -649,7 +851,12 @@ private def elabTheory : CommandElab := fun stx => do /-- Emit `def : EventB.Elem := `, so the model is an ordinary Lean value that the generator and the typechecker consume unchanged. -/ -private def define (name : Ident) (body : TSyntax `term) : CommandElabM Unit := do +private +def define + (name : Ident) + (body : TSyntax `term) + : CommandElabM Unit + := do elabCommand (← `(def $name : EventB.Elem := $body)) @[command_elab eventbMachine] diff --git a/EventB/Embedding.lean b/EventB/Embedding.lean index 6118936..fd06f16 100644 --- a/EventB/Embedding.lean +++ b/EventB/Embedding.lean @@ -15,7 +15,11 @@ abbrev EventSet (α : Type) := α → Prop structure Signature where carrier : String → Type -private def typeOf? (signature : Signature) : Typing.Ty → Option Type +private +def typeOf? + (signature : Signature) + : Typing.Ty → + Option Type | .given name => some (signature.carrier name) | .int => some Int | .bool => some Bool @@ -26,13 +30,25 @@ private def typeOf? (signature : Signature) : Typing.Ty → Option Type return left × right | .mvar _ => none -def type? (signature : Signature) (type : Typing.Ty) : Option Type := +def type? + (signature : Signature) + (type : Typing.Ty) + : Option Type + := typeOf? signature type -def symbolType? (signature : Signature) (symbol : Prelude.Symbol) : Option Type := +def symbolType? + (signature : Signature) + (symbol : Prelude.Symbol) + : Option Type + := symbol.type.bind (type? signature) -def embeddable (signature : Signature) (env : Theory.Env) : List String := +def embeddable + (signature : Signature) + (env : Theory.Env) + : List String + := env.theories.flatMap fun theory => theory.symbols.filterMap fun symbol => if symbol.type.isSome && (symbolType? signature symbol).isNone then diff --git a/EventB/Error.lean b/EventB/Error.lean index 11aac78..eb9f5a9 100644 --- a/EventB/Error.lean +++ b/EventB/Error.lean @@ -46,16 +46,29 @@ def io (message : String) : Error := { kind := .io, message } def cli (message : String) : Error := { kind := .cli, message } -def withPath (error : Error) (path : String) : Error := +def withPath + (error : Error) + (path : String) + : Error + := { error with path := some path } -def withContext (error : Error) (context : String) : Error := +def withContext + (error : Error) + (context : String) + : Error + := { error with context := context :: error.context } -def render (error : Error) : String := +def render + (error : Error) + : String + := String.intercalate ": " (error.path.toList ++ error.context.reverse ++ [error.message]) -instance : ToString Error where +instance + : ToString Error + where toString := render end Error diff --git a/EventB/Formula/Lex.lean b/EventB/Formula/Lex.lean index 4c5a751..fa14498 100644 --- a/EventB/Formula/Lex.lean +++ b/EventB/Formula/Lex.lean @@ -19,14 +19,18 @@ inductive Tok where | op : String → Tok deriving BEq, Repr, Inhabited -def Tok.render : Tok → String +def Tok.render + : Tok → + String | .id s => s | .num n => toString n | .op s => s /-- Alias to canonical spelling. Longest match wins, so order here does not matter, but every canonical operator must also map to itself. -/ -def operators : List (String × String) := +def operators + : List (String × String) + := -- Predicate calculus. [("⇔", "⇔"), ("<=>", "⇔"), ("⇒", "⇒"), ("=>", "⇒"), ("∧", "∧"), ("&", "∧"), ("∨", "∨"), ("or", "∨"), ("¬", "¬"), ("not", "¬"), @@ -75,7 +79,9 @@ def operators : List (String × String) := /-- Longest first, so `<<:` is never read as `<` followed by `<:`. Held as a `Char` list per alias because the scanner works on `List Char`, and sorted once: re-sorting a 130-entry table on every token turned the corpus scan into minutes. -/ -def operatorTable : Array (List Char × String) := +def operatorTable + : Array (List Char × String) + := (operators.mergeSort (fun a b => b.1.length < a.1.length)).map (fun (alias, canon) => (alias.toList, canon)) |>.toArray @@ -84,7 +90,11 @@ private def isIdentRest (c : Char) : Bool := c.isAlphanum || c == '_' || c == '\ /-- Operator aliases spelled with letters (`or`, `mod`, `NAT`) must not swallow the head of an identifier: `order` is one name, not `or` followed by `der`. -/ -private def aliasFits (alias rest : List Char) : Bool := +private +def aliasFits + (alias rest : List Char) + : Bool + := if alias.all isIdentRest then match rest.drop alias.length with | c :: _ => !isIdentRest c @@ -92,8 +102,12 @@ private def aliasFits (alias rest : List Char) : Bool := else true -private def matchOperator (table : Array (List Char × String)) (cs : List Char) : - Option (String × List Char) := +private +def matchOperator + (table : Array (List Char × String)) + (cs : List Char) + : Option (String × List Char) + := table.findSome? fun (a, canon) => -- `!a.isEmpty` is load-bearing: an empty alias matches everywhere and consumes -- nothing, so the scanner would spin forever on the first character. @@ -113,8 +127,13 @@ private def matchOperator (table : Array (List Char × String)) (cs : List Char) -- This is the obligation grip discharges by construction: its graded parsers track in -- the type whether a parser can consume nothing, so `many (pure x)` fails to compile -- rather than hanging. A lexer built on grip would need no fuel here. -private def go (table : Array (List Char × String)) (acc : List Tok) : - Nat → List Char → Except String (List Tok) +private +def go + (table : Array (List Char × String)) + (acc : List Tok) + : Nat → -- fuel, seeded at input length + List Char → -- remaining characters to lex + Except String (List Tok) | _, [] => .ok acc.reverse | 0, _ => .error "lexer made no progress" | fuel + 1, c :: cs => @@ -140,7 +159,10 @@ private def go (table : Array (List Char × String)) (acc : List Tok) : /-- `mod` is the only word-shaped operator Rodin treats as infix; the rest of the word operators (`card`, `dom`, `bool`, ...) are ordinary identifiers applied to an argument, so the lexer leaves them alone. -/ -def lex (s : String) : Except EventB.Error (List Tok) := +def lex + (s : String) + : Except EventB.Error (List Tok) + := let cs := s.toList (go operatorTable [] cs.length cs).mapError EventB.Error.formula diff --git a/EventB/Formula/Parse.lean b/EventB/Formula/Parse.lean index c7ac0ec..d0330ea 100644 --- a/EventB/Formula/Parse.lean +++ b/EventB/Formula/Parse.lean @@ -61,15 +61,25 @@ 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 +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 +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) @@ -145,7 +155,10 @@ theorem Term.eq_of_beq {left right : Term} (equal : left == right) : left = righ 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 +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) @@ -162,7 +175,9 @@ theorem Term.beq_self (term : Term) : termBeq term term = true := by (cons := fun _ _ ihHead ihTail => by simp [termListBeq, ihHead, ihTail]) term -instance : LawfulBEq Term where +instance + : LawfulBEq Term + where rfl := Term.beq_self _ eq_of_beq := Term.eq_of_beq @@ -205,17 +220,26 @@ private def infixLevel : String → Option Level /-- Prefix operators. `ℙ`/`ℙ1` take a parenthesised argument but parse as any other prefix, and the unary minus binds tighter than every infix operator. -/ -private def prefixPower : String → Option Nat +private +def prefixPower + : String → + Option Nat | "¬" => some 16 | "−" => some 85 | "ℙ" | "ℙ1" | "⋂" | "⋃" => some 95 | _ => none -private def isBinder (s : String) : Bool := +private +def isBinder + (s : String) + : Bool + := s == "∀" || s == "∃" || s == "λ" || s == "⋂" || s == "⋃" /-- `{a, b, c}` parses as nested commas; the set node wants the elements. -/ -def flattenCommas : Term → List Term +def flattenCommas + : Term → + List Term | .bin "," a b => flattenCommas a ++ flattenCommas b | t => [t] @@ -223,7 +247,12 @@ private structure St where toks : Array Tok pos : Nat -private def hasRemainingOperator (s : St) (operator : String) : Bool := +private +def hasRemainingOperator + (s : St) + (operator : String) + : Bool + := (s.toks.toList.drop s.pos).any fun token => match token with | .op value => value == operator @@ -231,7 +260,12 @@ private def hasRemainingOperator (s : St) (operator : String) : Bool := private def peek (s : St) : Option Tok := s.toks[s.pos]? -private def expect (s : St) (o : String) : Except String St := +private +def expect + (s : St) + (o : String) + : Except String St + := match peek s with | some (.op x) => if x == o then .ok { s with pos := s.pos + 1 } else .error s!"expected {o}, found {x}" @@ -246,7 +280,12 @@ mutual -- says the position advances. `fuel` states the bound: seeded at the token count, it -- can only run out if some branch consumed nothing. Same obligation as in `Lex`, and -- the same note applies: grip's graded parsers discharge it by construction. -private def parseAt : Nat → St → Nat → Except String (Term × St) +private +def parseAt + : Nat → -- fuel, decremented per token + St → -- parser state + Nat → -- minimum binding power + Except String (Term × St) | 0, _, _ => .error "parser made no progress" | fuel + 1, s, minPower => do let (lhs, s) ← parsePrefix fuel s @@ -255,7 +294,13 @@ termination_by fuel _ _ => fuel /-- The operator loop of `parseAt`, split out because it needs the decremented fuel and a `where` clause cannot see it. -/ -private def parseInfix : Nat → Nat → Term → St → Except String (Term × St) +private +def parseInfix + : Nat → -- fuel, decremented per operator + Nat → -- minimum binding power + Term → -- left-hand side parsed so far + St → -- parser state + Except String (Term × St) | 0, _, lhs, s => .ok (lhs, s) | fuel + 1, minPower, lhs, s => do match peek s with @@ -284,7 +329,11 @@ private def parseInfix : Nat → Nat → Term → St → Except String (Term × | _ => .ok (lhs, s) termination_by fuel _ _ _ => fuel -private def parsePrefix : Nat → St → Except String (Term × St) +private +def parsePrefix + : Nat → -- fuel, decremented per token + St → -- parser state + Except String (Term × St) | 0, _ => .error "parser made no progress" | fuel + 1, s => do match peek s with @@ -340,7 +389,12 @@ termination_by fuel _ => fuel /-- Application, image and inverse all bind tighter than any infix operator and chain freely: `f(x)(y)`, `r[s][t]`, `f∼(x)`. -/ -private def parsePostfix : Nat → Term → St → Except String (Term × St) +private +def parsePostfix + : Nat → -- fuel, decremented per token + Term → -- term parsed so far + St → -- parser state + Except String (Term × St) | 0, t, s => .ok (t, s) | fuel + 1, t, s => do match peek s with @@ -365,7 +419,11 @@ termination_by fuel _ _ => fuel end -private def parseTokensText (toks : List Tok) : Except String Term := do +private +def parseTokensText + (toks : List Tok) + : Except String Term + := do let arr := toks.toArray -- Consuming one token can descend `parseAt -> parsePrefix -> parsePostfix` and come -- back through `parseInfix`, and each of those decrements, so the budget is a small @@ -376,16 +434,24 @@ private def parseTokensText (toks : List Tok) : Except String Term := do | none => .ok t | some tok => .error s!"trailing input at {tok.render}" -def parseTokens (toks : List Tok) : Except EventB.Error Term := +def parseTokens + (toks : List Tok) + : Except EventB.Error Term + := (parseTokensText toks).mapError EventB.Error.formula -def parse (source : String) : Except EventB.Error Term := do +def parse + (source : String) + : Except EventB.Error Term + := do parseTokens (← lex source) /-- Fully parenthesised, so the printer states the tree rather than relying on the reader's memory of the precedence table. Round-tripping is what the P1 gate checks: `parse (print (parse s)) = parse s`. -/ -def print : Term → String +def print + : Term → + String | .id s => s | .num n => toString n | .bin o a b => "(" ++ print a ++ " " ++ o ++ " " ++ print b ++ ")" @@ -401,7 +467,11 @@ def print : Term → String /-! Self-checks for the parts the corpus does not pin down: ASCII aliases (Rodin normalises them away before writing a file) and the precedence decisions. -/ -private def sameTree (a b : String) : Bool := +private +def sameTree + (a b : String) + : Bool + := match parse a, parse b with | .ok x, .ok y => x == y | _, _ => false @@ -455,13 +525,18 @@ private def sameTree (a b : String) : Bool := /-- The names a binder pattern introduces. Substitution must skip exactly these and descend past everything else. -/ -def patternNames : Term → List String +def patternNames + : Term → + List String | .id n => [n] | .bin "⦂" a _ => patternNames a | .bin _ a b => patternNames a ++ patternNames b | _ => [] -private def allNames : Term → List String +private +def allNames + : Term → + List String | .id n => [n] | .num _ => [] | .bin _ a b => allNames a ++ allNames b @@ -470,13 +545,22 @@ private def allNames : Term → List String | .set ts => ts.flatMap allNames | .bind _ p b => allNames p ++ allNames b -private def freshName (base : String) (used : List String) : Nat → String +private +def freshName + (base : String) + (used : List String) + : Nat → + String | 0 => base ++ "0" | fuel + 1 => if used.contains base then freshName (base ++ "0") used fuel else base -private def makeRenames : List String → List String → List String → - List (String × String) × List String +private +def makeRenames + : List String → -- names to rename + List String → -- names that would conflict + List String → -- names already in use + List (String × String) × List String -- renamed pairs, updated used names | [], _, used => ([], used) | name :: names, conflicts, used => let renamed := if conflicts.contains name then @@ -485,7 +569,11 @@ private def makeRenames : List String → List String → List String → let (rest, finalUsed) := makeRenames names conflicts (renamed :: used) ((name, renamed) :: rest, finalUsed) -private def renameBound (mapping : List (String × String)) : Term → Term +private +def renameBound + (mapping : List (String × String)) + : Term → + Term | .id name => .id (mapping.find? (fun pair => pair.1 == name) |>.map (·.2) |>.getD name) | .num value => .num value | .bin op a b => .bin op (renameBound mapping a) (renameBound mapping b) @@ -501,7 +589,10 @@ private def renameBound (mapping : List (String × String)) : Term → Term mutual -private def termFuel : Term → Nat +private +def termFuel + : Term → + Nat | .id _ | .num _ => 1 | .bin _ a b => 1 + termFuel a + termFuel b | .pre _ a | .post _ a => 1 + termFuel a @@ -509,7 +600,10 @@ private def termFuel : Term → Nat | .set ts => 1 + termFuelList ts | .bind _ p b => 1 + termFuel p + termFuel b -private def termFuelList : List Term → Nat +private +def termFuelList + : List Term → + Nat | [] => 0 | t :: ts => termFuel t + termFuelList ts @@ -519,7 +613,12 @@ mutual /-- Fuelled implementation of simultaneous substitution. Fuel lets the binder case alpha-rename before descending without weakening termination to a partial function. -/ -private def substFuel : Nat → List (String × Term) → Term → Term +private +def substFuel + : Nat → -- fuel, bound for alpha-renaming binders + List (String × Term) → -- substitution mapping + Term → -- term being substituted into + Term | 0, _, term => term | _fuel + 1, σ, .id n => match σ.find? (fun p => p.1 == n) with @@ -546,7 +645,12 @@ private def substFuel : Nat → List (String × Term) → Term → Term .bind k renamedPattern (substFuel fuel (σ.filter (fun q => !renamedBound.contains q.1)) renamedBody) -private def substListFuel : Nat → List (String × Term) → List Term → List Term +private +def substListFuel + : Nat → -- fuel, bound for alpha-renaming binders + List (String × Term) → -- substitution mapping + List Term → -- terms being substituted into + List Term | 0, _, terms => terms | _fuel + 1, _, [] => [] | fuel + 1, σ, term :: terms => @@ -556,7 +660,11 @@ end /-- Simultaneous substitution. Simultaneous matters: an event assigning `a ≔ b` and `b ≔ a` swaps them, and capture-avoiding binders preserve the same semantics. -/ -def subst (σ : List (String × Term)) (term : Term) : Term := +def subst + (σ : List (String × Term)) + (term : Term) + : Term + := substFuel (termFuel term + 1) σ term mutual @@ -564,7 +672,9 @@ mutual /-- Drop the type ascriptions Rodin writes into `.bpo` predicates. They carry no logical content, and a generator has no reason to reproduce them, so comparisons are modulo ascription. -/ -def stripAscriptions : Term → Term +def stripAscriptions + : Term → + Term | .bin "⦂" a _ => stripAscriptions a | .bin o a b => .bin o (stripAscriptions a) (stripAscriptions b) | .pre o a => .pre o (stripAscriptions a) @@ -575,7 +685,9 @@ def stripAscriptions : Term → Term | .bind k p b => .bind k (stripAscriptions p) (stripAscriptions b) | t => t -def stripList : List Term → List Term +def stripList + : List Term → + List Term | [] => [] | t :: ts => stripAscriptions t :: stripList ts @@ -584,7 +696,10 @@ end /-- Compare formulas modulo the names chosen for bound variables. Rodin alpha-renames bound identifiers when an event parameter would collide with one; those names carry no logical content and must not make the P3b statement gate reject the same formula. -/ -def alphaEq (left right : Term) : Bool := +def alphaEq + (left right : Term) + : Bool + := go left right [] [] 0 where lookup (name : String) (env : List (String × Nat)) : Option Nat := diff --git a/EventB/Formula/Translate.lean b/EventB/Formula/Translate.lean index dfac366..ea94f54 100644 --- a/EventB/Formula/Translate.lean +++ b/EventB/Formula/Translate.lean @@ -45,7 +45,10 @@ structure KernelContext where private def semanticValueHash (value : Expr) : String := toString value.hash -def KernelContext.semanticFingerprint (context : KernelContext) : String := +def KernelContext.semanticFingerprint + (context : KernelContext) + : String + := String.intercalate "\n" ["roots=" ++ String.intercalate "," context.roots , "carriers=" ++ String.intercalate ";" (context.signature.carriers.map @@ -66,19 +69,38 @@ structure KernelTerm where private def propType : Expr := mkSort .zero -private def KernelContext.lookup (context : KernelContext) (name : String) : - Option KernelBinding := context.bindings.find? (·.name == name) - -private def KernelContext.lookupFunction (context : KernelContext) (name : String) : - Option KernelFunction := context.functions.find? (·.name == name) - -private def KernelContext.lookupPredicate (context : KernelContext) (name : String) : - Option KernelPredicate := context.predicates.find? (·.name == name) - -private def KernelSignature.carrier? (signature : KernelSignature) (name : String) : - Option Expr := signature.carriers.find? (·.1 == name) |>.map (·.2) - -def leanType (context : KernelContext) : Ty → MetaM Expr +private +def KernelContext.lookup + (context : KernelContext) + (name : String) + : Option KernelBinding + := context.bindings.find? (·.name == name) + +private +def KernelContext.lookupFunction + (context : KernelContext) + (name : String) + : Option KernelFunction + := context.functions.find? (·.name == name) + +private +def KernelContext.lookupPredicate + (context : KernelContext) + (name : String) + : Option KernelPredicate + := context.predicates.find? (·.name == name) + +private +def KernelSignature.carrier? + (signature : KernelSignature) + (name : String) + : Option Expr + := signature.carriers.find? (·.1 == name) |>.map (·.2) + +def leanType + (context : KernelContext) + : Ty → + MetaM Expr | .given name => match context.signature.carrier? name with | some type => pure type @@ -93,7 +115,13 @@ def leanType (context : KernelContext) : Ty → MetaM Expr private abbrev typeExpr := leanType -private def checked (context : KernelContext) (ty : Ty) (value : Expr) : MetaM KernelTerm := do +private +def checked + (context : KernelContext) + (ty : Ty) + (value : Expr) + : MetaM KernelTerm + := do let expected ← leanType context ty let actual ← inferType value unless ← isDefEq actual expected do @@ -106,7 +134,11 @@ 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 := +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] @@ -117,28 +149,49 @@ private def mkEq (left right : Expr) : MetaM Expr := mkAppM ``Eq #[left, right] private def mkPair (left right : Expr) : MetaM Expr := mkAppM ``Prod.mk #[left, right] -private def mkDisjunction : List Expr → MetaM Expr +private +def mkDisjunction + : List Expr → + MetaM Expr | [] => pure (mkConst ``False) | value :: values => values.foldlM mkOr value -private def mkSetExtension (type : Expr) (values : List Expr) : MetaM Expr := do +private +def mkSetExtension + (type : Expr) + (values : List Expr) + : MetaM Expr + := do withLocalDeclD `x type fun x => do let equalities ← values.mapM (mkEq x) mkLambdaFVars #[x] (← mkDisjunction equalities) -private def mkExistsAt (type : Expr) (body : Expr → MetaM Expr) : MetaM Expr := do +private +def mkExistsAt + (type : Expr) + (body : Expr → MetaM Expr) + : MetaM Expr + := do withLocalDeclD `x type fun x => do let predicate ← mkLambdaFVars #[x] (← body x) mkAppM ``Exists #[predicate] -private def mkUnionSet (elementType setOfSets : Expr) : MetaM Expr := do +private +def mkUnionSet + (elementType setOfSets : Expr) + : MetaM Expr + := do let setType ← mkArrow elementType propType withLocalDeclD `x elementType fun x => do let existsExpr ← mkExistsAt setType fun subset => do mkAnd (mkApp setOfSets subset) (mkApp subset x) mkLambdaFVars #[x] existsExpr -private def mkIntersectionSet (elementType setOfSets : Expr) : MetaM Expr := do +private +def mkIntersectionSet + (elementType setOfSets : Expr) + : MetaM Expr + := do let setType ← mkArrow elementType propType withLocalDeclD `x elementType fun x => do withLocalDeclD `subset setType fun subset => do @@ -146,10 +199,18 @@ private def mkIntersectionSet (elementType setOfSets : Expr) : MetaM Expr := do let universal ← mkForallFVars #[subset] implication mkLambdaFVars #[x] universal -private def mkUniversalSet (type : Expr) : MetaM Expr := do +private +def mkUniversalSet + (type : Expr) + : MetaM Expr + := do withLocalDeclD `x type fun x => mkLambdaFVars #[x] trueProp -private def mkIntSet (positive : Bool) : MetaM Expr := do +private +def mkIntSet + (positive : Bool) + : MetaM Expr + := do withLocalDeclD `x (mkConst ``Int) fun x => do let zero := mkApp (mkConst ``Int.ofNat) (mkNatLit 0) let condition := if positive then @@ -158,7 +219,12 @@ private def mkIntSet (positive : Bool) : MetaM Expr := do mkApp2 (mkConst ``Int.le) zero x mkLambdaFVars #[x] condition -private def lookupExpr (context : KernelContext) (name : String) : MetaM KernelTerm := do +private +def lookupExpr + (context : KernelContext) + (name : String) + : MetaM KernelTerm + := do match context.lookup name with | some binding => if let some expected := Theory.typeIn? context.theory context.roots name then @@ -177,8 +243,12 @@ private def lookupExpr (context : KernelContext) (name : String) : MetaM KernelT else throwError s!"unknown Event-B identifier `{name}`" -private def validateFunction (context : KernelContext) (function : KernelFunction) : - MetaM Unit := do +private +def validateFunction + (context : KernelContext) + (function : KernelFunction) + : MetaM Unit + := do if let some expected := Theory.typeIn? context.theory context.roots function.name then let declared := .pow (.prod function.argument function.result) unless expected == declared do @@ -191,8 +261,12 @@ private def validateFunction (context : KernelContext) (function : KernelFunctio throwError s!"semantic function `{function.name}` has Lean type {actual}, " ++ s!"expected {argumentType} → {resultType}" -private def validatePredicate (context : KernelContext) (predicate : KernelPredicate) : - MetaM Unit := do +private +def validatePredicate + (context : KernelContext) + (predicate : KernelPredicate) + : MetaM Unit + := do if let some expected := Theory.typeIn? context.theory context.roots predicate.name then let declared := .pow (.prod predicate.argument .bool) unless expected == declared do @@ -204,16 +278,27 @@ private def validatePredicate (context : KernelContext) (predicate : KernelPredi throwError s!"semantic predicate `{predicate.name}` has Lean type {actual}, " ++ s!"expected {argumentType} → Prop" -private def asSet (term : KernelTerm) : MetaM (Ty × Expr) := +private +def asSet + (term : KernelTerm) + : MetaM (Ty × Expr) + := match term.ty with | .pow type => pure (type, term.value) | type => throwError s!"expected a set, found {type.print}" -private def sameType (left right : Ty) : MetaM Unit := do +private +def sameType + (left right : Ty) + : MetaM Unit + := do unless left == right do throwError s!"incompatible translated types {left.print} and {right.print}" -private def eventBType : Formula.Term → MetaM Ty +private +def eventBType + : Formula.Term → + MetaM Ty | .id "ℤ" | .id "ℕ" | .id "ℕ1" => pure .int | .id "BOOL" => pure .bool | .id name => pure (.given name) @@ -221,9 +306,15 @@ private def eventBType : Formula.Term → MetaM Ty | .bin "×" left right => return .prod (← eventBType left) (← eventBType right) | term => throwError s!"unsupported binder type `{Formula.print term}`" -private def withPattern {α : Type} (context : KernelContext) (pattern : Formula.Term) +private +def withPattern + {α : Type} + (context : KernelContext) + (pattern : Formula.Term) (expected : Option Ty) - (body : KernelContext → List Expr → Expr → Ty → MetaM α) : MetaM α := do + (body : KernelContext → List Expr → Expr → Ty → MetaM α) + : MetaM α + := do match pattern with | .id name => let ty ← match expected with @@ -257,35 +348,63 @@ private def withPattern {α : Type} (context : KernelContext) (pattern : Formula body context (leftLocals ++ rightLocals) value (.prod leftType rightType) | term => throwError s!"unsupported binder pattern `{Formula.print term}`" -private def mkExistsLocals : List Expr → Expr → MetaM Expr +private +def mkExistsLocals + : List Expr → -- local variables to bind + Expr → -- body to wrap in existentials + MetaM Expr | [], body => pure body | localVar :: locals, body => do let body ← mkExistsLocals locals body mkAppM ``Exists #[← mkLambdaFVars #[localVar] body] -private def mkForallLocals : List Expr → Expr → MetaM Expr +private +def mkForallLocals + : List Expr → -- local variables to bind + Expr → -- body to wrap in foralls + MetaM Expr | [], body => pure body | localVar :: locals, body => do let body ← mkForallLocals locals body mkForallFVars #[localVar] body -private def isLambda : Formula.Term → Bool +private +def isLambda + : Formula.Term → + Bool | .bind "λ" _ _ => true | _ => false -private def elementType? : Option Ty → Option Ty +private +def elementType? + : Option Ty → + Option Ty | some (.pow type) => some type | _ => none -private def relationTypes (term : KernelTerm) : MetaM (Ty × Ty) := +private +def relationTypes + (term : KernelTerm) + : MetaM (Ty × Ty) + := match term.ty with | .pow (.prod left right) => pure (left, right) | type => throwError s!"expected a relation, found {type.print}" -private def project (which : Name) (pair : Expr) : MetaM Expr := +private +def project + (which : Name) + (pair : Expr) + : MetaM Expr + := mkAppM which #[pair] -private def mkSetBinary (op : String) (type left right : Expr) : MetaM Expr := do +private +def mkSetBinary + (op : String) + (type left right : Expr) + : MetaM Expr + := do withLocalDeclD `x type fun x => do let a := mkApp left x let b := mkApp right x @@ -296,13 +415,21 @@ private def mkSetBinary (op : String) (type left right : Expr) : MetaM Expr := d | _ => throwError s!"unsupported set operator `{op}`" mkLambdaFVars #[x] body -private def mkSubset (type left right : Expr) : MetaM Expr := do +private +def mkSubset + (type left right : Expr) + : MetaM Expr + := do withLocalDeclD `x type fun x => do let premise := mkApp left x let conclusion := mkApp right x mkForallFVars #[x] (← mkImp premise conclusion) -private def mkProductSet (leftType rightType left right : Expr) : MetaM Expr := do +private +def mkProductSet + (leftType rightType left right : Expr) + : MetaM Expr + := do let pairType ← mkAppM ``Prod #[leftType, rightType] withLocalDeclD `pair pairType fun pair => do let first ← project ``Prod.fst pair @@ -310,7 +437,11 @@ private def mkProductSet (leftType rightType left right : Expr) : MetaM Expr := let body ← mkAnd (mkApp left first) (mkApp right second) mkLambdaFVars #[pair] body -private def mkRelationSpace (leftType rightType left right : Expr) : MetaM Expr := do +private +def mkRelationSpace + (leftType rightType left right : Expr) + : MetaM Expr + := do let pairType ← mkAppM ``Prod #[leftType, rightType] let relationType ← mkArrow pairType propType withLocalDeclD `relation relationType fun relation => do @@ -323,9 +454,12 @@ private def mkRelationSpace (leftType rightType left right : Expr) : MetaM Expr let subset ← mkForallFVars #[pair] implication mkLambdaFVars #[relation] subset -private def mkRelationConstraint (kind : String) - (leftType rightType leftSet rightSet relation : Expr) : - MetaM Expr := do +private +def mkRelationConstraint + (kind : String) + (leftType rightType leftSet rightSet relation : Expr) + : MetaM Expr + := do let relationAt (left right : Expr) : MetaM Expr := do pure (mkApp relation (← mkPair left right)) match kind with @@ -351,7 +485,10 @@ private def mkRelationConstraint (kind : String) mkForallFVars #[y] (← mkImp (mkApp rightSet y) existsExpr) | _ => throwError s!"unknown relation constraint `{kind}`" -private def relationConstraints : String → List String +private +def relationConstraints + : String → + List String | "↔" => [] | "" => ["total"] | "" => ["surjective"] @@ -365,8 +502,12 @@ private def relationConstraints : String → List String | "⤖" => ["functional", "injective", "surjective", "total"] | _ => [] -private def mkRelationArrow (op : String) (leftType rightType left right : Expr) : - MetaM Expr := do +private +def mkRelationArrow + (op : String) + (leftType rightType left right : Expr) + : MetaM Expr + := do let pairType ← mkAppM ``Prod #[leftType, rightType] let relationType ← mkArrow pairType propType let base ← mkRelationSpace leftType rightType left right @@ -378,7 +519,12 @@ private def mkRelationArrow (op : String) (leftType rightType left right : Expr) mkAnd body property mkLambdaFVars #[relation] body -private def mkPowerSet (type set : Expr) (positive : Bool) : MetaM Expr := do +private +def mkPowerSet + (type set : Expr) + (positive : Bool) + : MetaM Expr + := do let setType ← mkArrow type propType withLocalDeclD `subset setType fun subset => do withLocalDeclD `x type fun x => do @@ -392,7 +538,11 @@ private def mkPowerSet (type set : Expr) (positive : Bool) : MetaM Expr := do else pure inclusion mkLambdaFVars #[subset] body -private def mkImage (leftType rightType relation set : Expr) : MetaM Expr := do +private +def mkImage + (leftType rightType relation set : Expr) + : MetaM Expr + := do withLocalDeclD `y rightType fun y => do let existsExpr ← mkExistsAt leftType fun x => do let pair ← mkPair x y @@ -401,7 +551,11 @@ private def mkImage (leftType rightType relation set : Expr) : MetaM Expr := do mkAnd selected related mkLambdaFVars #[y] existsExpr -private def mkInverse (leftType rightType relation : Expr) : MetaM Expr := do +private +def mkInverse + (leftType rightType relation : Expr) + : MetaM Expr + := do let sourcePairType ← mkAppM ``Prod #[rightType, leftType] withLocalDeclD `pair sourcePairType fun pair => do let first ← project ``Prod.fst pair @@ -409,8 +563,12 @@ private def mkInverse (leftType rightType relation : Expr) : MetaM Expr := do let originalPair ← mkPair second first mkLambdaFVars #[pair] (mkApp relation originalPair) -private def mkProjectionSet (leftType rightType relation : Expr) (first : Bool) : - MetaM Expr := do +private +def mkProjectionSet + (leftType rightType relation : Expr) + (first : Bool) + : MetaM Expr + := do withLocalDeclD `value (if first then leftType else rightType) fun value => do let existsExpr ← if first then mkExistsAt rightType fun other => do @@ -422,7 +580,11 @@ private def mkProjectionSet (leftType rightType relation : Expr) (first : Bool) pure (mkApp relation pair) mkLambdaFVars #[value] existsExpr -private def mkIdentity (type set : Expr) : MetaM Expr := do +private +def mkIdentity + (type set : Expr) + : MetaM Expr + := do let pairType ← mkAppM ``Prod #[type, type] withLocalDeclD `pair pairType fun pair => do let first ← project ``Prod.fst pair @@ -430,21 +592,35 @@ private def mkIdentity (type set : Expr) : MetaM Expr := do let body ← mkAnd (mkApp set first) (← mkEq first second) mkLambdaFVars #[pair] body -private def mkRestriction (relationType set relation : Expr) (domain : Bool) : MetaM Expr := do +private +def mkRestriction + (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 restricted := mkApp set endpoint let body ← mkAnd restricted (mkApp relation pair) mkLambdaFVars #[pair] body -private def mkSubtraction (relationType set relation : Expr) (domain : Bool) : MetaM Expr := do +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 +private +def mkComposition + (leftType middleType rightType left right : Expr) + : MetaM Expr + := do let pairType ← mkAppM ``Prod #[leftType, rightType] withLocalDeclD `pair pairType fun pair => do let input ← project ``Prod.fst pair @@ -455,7 +631,11 @@ private def mkComposition (leftType middleType rightType left right : Expr) : Me mkAnd (mkApp left firstPair) (mkApp right secondPair) mkLambdaFVars #[pair] existsExpr -private def mkDirectProduct (leftType middleType rightType p q : Expr) : MetaM Expr := do +private +def mkDirectProduct + (leftType middleType rightType p q : Expr) + : MetaM Expr + := do let outputType ← mkAppM ``Prod #[middleType, rightType] let pairType ← mkAppM ``Prod #[leftType, outputType] withLocalDeclD `pair pairType fun pair => do @@ -468,8 +648,12 @@ private def mkDirectProduct (leftType middleType rightType p q : Expr) : MetaM E let body ← mkAnd (mkApp p firstPair) (mkApp q secondPair) mkLambdaFVars #[pair] body -private def mkParallelProduct (leftType middleType rightType output : Expr) (p q : Expr) : - MetaM Expr := do +private +def mkParallelProduct + (leftType middleType rightType output : Expr) + (p q : Expr) + : MetaM Expr + := do let inputType ← mkAppM ``Prod #[leftType, middleType] let outputType' ← mkAppM ``Prod #[rightType, output] let pairType ← mkAppM ``Prod #[inputType, outputType'] @@ -485,7 +669,11 @@ private def mkParallelProduct (leftType middleType rightType output : Expr) (p q let body ← mkAnd (mkApp p leftPair) (mkApp q rightPair) mkLambdaFVars #[pair] body -private def mkOverride (leftType rightType left right : Expr) : MetaM Expr := do +private +def mkOverride + (leftType rightType left right : Expr) + : MetaM Expr + := do let pairType ← mkAppM ``Prod #[leftType, rightType] withLocalDeclD `pair pairType fun pair => do let input ← project ``Prod.fst pair @@ -496,7 +684,12 @@ private def mkOverride (leftType rightType left right : Expr) : MetaM Expr := do let body ← mkOr rightAt (← mkAnd (mkApp left pair) (← mkNot existsExpr)) mkLambdaFVars #[pair] body -private def builtinSet (context : KernelContext) (name : String) : MetaM KernelTerm := do +private +def builtinSet + (context : KernelContext) + (name : String) + : MetaM KernelTerm + := do match name with | "BOOL" => checked context (.pow .bool) (← mkUniversalSet boolType) | "ℤ" => checked context (.pow .int) (← mkUniversalSet (mkConst ``Int)) @@ -506,11 +699,17 @@ private def builtinSet (context : KernelContext) (name : String) : MetaM KernelT mutual -private def termFuelList : List Formula.Term → Nat +private +def termFuelList + : List Formula.Term → + Nat | [] => 0 | term :: terms => termFuel term + termFuelList terms -private def termFuel : Formula.Term → Nat +private +def termFuel + : Formula.Term → + Nat | .id _ | .num _ => 1 | .bin _ left right => 1 + termFuel left + termFuel right | .pre _ value | .post _ value => 1 + termFuel value @@ -523,8 +722,12 @@ end mutual -private def translateExprList : Nat → KernelContext → List Formula.Term → - MetaM (List KernelTerm) +private +def translateExprList + : Nat → -- fuel, bounded by term size + KernelContext → -- translation environment + List Formula.Term → -- terms to translate + MetaM (List KernelTerm) | 0, _, _ => throwError "formula translation recursion limit reached" | _ + 1, _, [] => pure [] | fuel + 1, context, term :: terms => do @@ -532,8 +735,14 @@ private def translateExprList : Nat → KernelContext → List Formula.Term → let rest ← translateExprList fuel context terms pure (value :: rest) -private def translateComprehension : Nat → KernelContext → Formula.Term → Formula.Term → - Option Ty → MetaM KernelTerm +private +def translateComprehension + : Nat → -- fuel, bounded by term size + KernelContext → -- translation environment + Formula.Term → -- bound-variable pattern + Formula.Term → -- body of the comprehension + Option Ty → -- expected result type + MetaM KernelTerm | fuel, context, pattern, body, expected => do withPattern context pattern none fun bodyContext locals patternValue patternType => do let (predicateTerm, valueTerm) := match body with @@ -553,8 +762,14 @@ private def translateComprehension : Nat → KernelContext → Formula.Term → let set ← mkLambdaFVars #[result] body checked context (.pow resultType) set -private def translateLambda : Nat → KernelContext → Formula.Term → Formula.Term → Option Ty → - MetaM KernelTerm +private +def translateLambda + : Nat → -- fuel, bounded by term size + KernelContext → -- translation environment + Formula.Term → -- bound-variable pattern + Formula.Term → -- body of the lambda + Option Ty → -- expected relation type + MetaM KernelTerm | fuel, context, pattern, body, expected => do let (inputExpected, outputExpected) ← match expected with | some (.pow (.prod input output)) => pure (some input, some output) @@ -591,8 +806,14 @@ private def translateLambda : Nat → KernelContext → Formula.Term → Formula let relation ← mkLambdaFVars #[pair] body checked context (.pow relationType) relation -private def translateEquality : Nat → KernelContext → Formula.Term → Formula.Term → Bool → - MetaM Expr +private +def translateEquality + : Nat → -- fuel, bounded by term size + KernelContext → -- translation environment + Formula.Term → -- left-hand side of equality + Formula.Term → -- right-hand side of equality + Bool → -- true when comparing with ≠ + MetaM Expr | fuel, context, leftTerm, rightTerm, negated => do let (left, right) ← if leftTerm == .set [] || isLambda leftTerm then let right ← translateExpr fuel context rightTerm @@ -606,8 +827,13 @@ private def translateEquality : Nat → KernelContext → Formula.Term → Formu let equality ← mkEq left.value right.value if negated then mkNot equality else pure equality -private def translateExprExpected : Nat → KernelContext → Option Ty → Formula.Term → - MetaM KernelTerm +private +def translateExprExpected + : Nat → -- fuel, bounded by term size + KernelContext → -- translation environment + Option Ty → -- expected type, if known + Formula.Term → -- term to translate + MetaM KernelTerm | 0, _, _, _ => throwError "formula translation recursion limit reached" | _ + 1, context, some (.pow type), .set [] => do let value ← withLocalDeclD `x (← typeExpr context type) fun x => @@ -619,8 +845,13 @@ private def translateExprExpected : Nat → KernelContext → Option Ty → Form translateLambda fuel context pattern body expected | fuel + 1, context, _, term => translateExpr fuel context term -private def translateApplicationArgument : Nat → KernelContext → Ty → Formula.Term → - MetaM KernelTerm +private +def translateApplicationArgument + : Nat → -- fuel, bounded by term size + KernelContext → -- translation environment + Ty → -- expected argument type + Formula.Term → -- argument being translated + MetaM KernelTerm | 0, _, _, _ => throwError "formula translation recursion limit reached" | fuel + 1, context, .prod left right, .bin "," first rest => do let first ← translateApplicationArgument fuel context left first @@ -631,7 +862,12 @@ private def translateApplicationArgument : Nat → KernelContext → Ty → Form | fuel + 1, context, expected, term => translateExprExpected fuel context (some expected) term -private def translateExpr : Nat → KernelContext → Formula.Term → MetaM KernelTerm +private +def translateExpr + : Nat → -- fuel, bounded by term size + KernelContext → -- translation environment + Formula.Term → -- term to translate + MetaM KernelTerm | 0, _, _ => throwError "formula translation recursion limit reached" | _ + 1, context, .num value => checked context .int (mkApp (mkConst ``Int.ofNat) (mkNatLit value)) @@ -864,7 +1100,12 @@ private def translateExpr : Nat → KernelContext → Formula.Term → MetaM Ker checked context (.pow .int) (← mkLambdaFVars #[x] (← mkAnd lower upper)) | _ => throwError s!"unsupported Event-B expression operator `{op}`" -private def translatePred : Nat → KernelContext → Formula.Term → MetaM Expr +private +def translatePred + : Nat → -- fuel, bounded by term size + KernelContext → -- translation environment + Formula.Term → -- predicate to translate + MetaM Expr | 0, _, _ => throwError "formula translation recursion limit reached" | _ + 1, _, .id "⊤" => pure (mkConst ``True) | _ + 1, _, .id "⊥" => pure (mkConst ``False) @@ -957,10 +1198,18 @@ private def translatePred : Nat → KernelContext → Formula.Term → MetaM Exp end -def translateExpression (context : KernelContext) (term : Formula.Term) : MetaM KernelTerm := +def translateExpression + (context : KernelContext) + (term : Formula.Term) + : MetaM KernelTerm + := translateExpr (termFuel term + 1) context term -def translatePredicate (context : KernelContext) (term : Formula.Term) : MetaM Expr := +def translatePredicate + (context : KernelContext) + (term : Formula.Term) + : MetaM Expr + := translatePred (termFuel term + 1) context term end EventB.Embedding diff --git a/EventB/Model.lean b/EventB/Model.lean index c68f58a..a793649 100644 --- a/EventB/Model.lean +++ b/EventB/Model.lean @@ -43,12 +43,16 @@ structure Model where root : Elem deriving BEq, Repr -def inventoryTags : List String := +def inventoryTags + : List String + := ["guard", "action", "event", "refinesEvent", "variable", "invariant", "parameter", "axiom", "constant", "machineFile", "seesContext", "refinesMachine", "extendsContext", "contextFile", "witness", "carrierSet"] -def Elem.tag : Elem → String +def Elem.tag + : Elem → + String | .machineFile _ _ => "org.eventb.core.machineFile" | .contextFile _ _ => "org.eventb.core.contextFile" | .seesContext _ _ => "org.eventb.core.seesContext" @@ -68,7 +72,9 @@ def Elem.tag : Elem → String | .action _ _ => "org.eventb.core.action" | .extension tag _ _ => tag -def Elem.attrs : Elem → XmlAttrs +def Elem.attrs + : Elem → + XmlAttrs | .machineFile attrs _ => attrs | .contextFile attrs _ => attrs | .seesContext attrs _ => attrs @@ -88,7 +94,9 @@ def Elem.attrs : Elem → XmlAttrs | .action attrs _ => attrs | .extension _ attrs _ => attrs -def Elem.children : Elem → List Elem +def Elem.children + : Elem → + List Elem | .machineFile _ children => children | .contextFile _ children => children | .seesContext _ children => children @@ -108,13 +116,20 @@ def Elem.children : Elem → List Elem | .action _ children => children | .extension _ _ children => children -def Elem.attr? (elem : Elem) (key : String) : Option String := +def Elem.attr? + (elem : Elem) + (key : String) + : Option String + := elem.attrs.find? (fun (name, _) => name == key) |>.map (·.2) /-- `Elem.children` is an 18-case match, so the equation compiler cannot see through it to know the sublist is smaller. Proving it once here lets every traversal below be a plain `def` with a `sizeOf` measure, instead of `partial`. -/ -theorem Elem.sizeOf_children (e : Elem) : sizeOf e.children < sizeOf e := by +theorem Elem.sizeOf_children + (e : Elem) + : sizeOf e.children < sizeOf e + := by cases e <;> simp +arith [Elem.children] -- `Elem` nests a `List Elem`, so every traversal needs its list case written out: a @@ -122,55 +137,84 @@ theorem Elem.sizeOf_children (e : Elem) : sizeOf e.children < sizeOf e := by -- equation compiler, and the definition would have to be `partial`. mutual -private def countTag (wanted : String) (elem : Elem) : Nat := +private +def countTag + (wanted : String) + (elem : Elem) + : Nat + := (if elem.tag == wanted then 1 else 0) + countTagList wanted elem.children termination_by sizeOf elem decreasing_by exact Elem.sizeOf_children elem -private def countTagList (wanted : String) : List Elem → Nat +private +def countTagList + (wanted : String) + : List Elem → + Nat | [] => 0 | e :: es => countTag wanted e + countTagList wanted es termination_by es => sizeOf es end -def Model.inventory (model : Model) : List (String × Nat) := +def Model.inventory + (model : Model) + : List (String × Nat) + := inventoryTags.map (fun tag => (tag, countTag ("org.eventb.core." ++ tag) model.root)) /-- Attributes carrying an Event-B formula. `expression` is the variant used by `org.eventb.core.variant`, which the corpus does not exercise but Rodin emits. -/ -def formulaAttrs : List String := +def formulaAttrs + : List String + := ["org.eventb.core.predicate", "org.eventb.core.assignment", "org.eventb.core.expression"] mutual /-- Every formula in the model, in document order, tagged by the owning element's label so a P1 failure names the invariant or guard it came from. -/ -def Elem.formulas (elem : Elem) : List (String × String) := +def Elem.formulas + (elem : Elem) + : List (String × String) + := let label := (elem.attr? "org.eventb.core.label").getD (elem.tag.splitOn "." |>.getLast!) let here := formulaAttrs.filterMap (fun a => (elem.attr? a).map (fun f => (label, f))) here ++ Elem.formulasList elem.children termination_by sizeOf elem decreasing_by exact Elem.sizeOf_children elem -def Elem.formulasList : List Elem → List (String × String) +def Elem.formulasList + : List Elem → + List (String × String) | [] => [] | e :: es => Elem.formulas e ++ Elem.formulasList es termination_by es => sizeOf es end -def Model.formulas (model : Model) : List (String × String) := +def Model.formulas + (model : Model) + : List (String × String) + := model.root.formulas mutual -private def mapElemList : List XmlElem → Except String (List Elem) +private +def mapElemList + : List XmlElem → + Except String (List Elem) | [] => .ok [] | e :: es => do return (← mapElem e) :: (← mapElemList es) termination_by es => sizeOf es -private def mapElem (elem : XmlElem) : Except String Elem := do +private +def mapElem + (elem : XmlElem) + : Except String Elem + := do let children ← mapElemList elem.children match elem.tag with | "org.eventb.core.machineFile" => pure (.machineFile elem.attrs children) @@ -202,31 +246,46 @@ decreasing_by end -def fromXml (xml : XmlElem) : Except EventB.Error Model := do +def fromXml + (xml : XmlElem) + : Except EventB.Error Model + := do let root ← (mapElem xml).mapError EventB.Error.model match root with | .machineFile _ _ | .contextFile _ _ => pure { root := root } | _ => .error (EventB.Error.model ("expected machineFile or contextFile root, got " ++ root.tag)) -def parseModel (source : ByteArray) : Except EventB.Error Model := +def parseModel + (source : ByteArray) + : Except EventB.Error Model + := match parseXml source with | .error err => .error (EventB.Error.model (err.pretty source)) | .ok xml => fromXml xml -def parseMachine (source : ByteArray) : Except EventB.Error Model := do +def parseMachine + (source : ByteArray) + : Except EventB.Error Model + := do let model ← parseModel source match model.root with | .machineFile _ _ => pure model | _ => .error (EventB.Error.model "expected machineFile root") -def parseContext (source : ByteArray) : Except EventB.Error Model := do +def parseContext + (source : ByteArray) + : Except EventB.Error Model + := do let model ← parseModel source match model.root with | .contextFile _ _ => pure model | _ => .error (EventB.Error.model "expected contextFile root") -def readModel (path : System.FilePath) : IO (Except EventB.Error Model) := do +def readModel + (path : System.FilePath) + : IO (Except EventB.Error Model) + := do pure (parseModel (← IO.FS.readBinFile path)) end EventB diff --git a/EventB/POG.lean b/EventB/POG.lean index 6318992..7f30d74 100644 --- a/EventB/POG.lean +++ b/EventB/POG.lean @@ -40,7 +40,10 @@ structure Obligation where /-- 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 := +def Obligation.shapeValid + (obligation : Obligation) + : Bool + := match obligation.kind, obligation.goal with | "WWD", none => !obligation.hyps.isEmpty | "WWD", some _ => false @@ -52,13 +55,24 @@ def Obligation.shapeValid (obligation : Obligation) : Bool := def formulaLanguageVersion : String := "eventb-formula-v2" -private def canonicalField (value : String) : String := +private +def canonicalField + (value : String) + : String + := s!"{value.length}:{value}" -private def canonicalList (values : List String) : String := +private +def canonicalList + (values : List String) + : String + := s!"{values.length}[{String.intercalate "" (values.map canonicalField)}]" -def Obligation.canonical (obligation : Obligation) : String := +def Obligation.canonical + (obligation : Obligation) + : String + := String.intercalate "\n" ["scope=" ++ canonicalField obligation.component , "obligation=" ++ canonicalField obligation.name @@ -69,23 +83,45 @@ def Obligation.canonical (obligation : Obligation) : String := , "hyps=" ++ canonicalList (obligation.hyps.map Formula.print) , "goal=" ++ canonicalField (obligation.goal.map Formula.print |>.getD "")] -private def childrenOf (e : Elem) (tag : String) : List Elem := +private +def childrenOf + (e : Elem) + (tag : String) + : List Elem + := e.children.filter (fun c => c.tag == "org.eventb.core." ++ tag) -private def attrOf (e : Elem) (key : String) : Option String := +private +def attrOf + (e : Elem) + (key : String) + : Option String + := e.attr? ("org.eventb.core." ++ key) private def labelOf (e : Elem) : String := (attrOf e "label").getD "" -private def targetName (e : Elem) : Option String := +private +def targetName + (e : Elem) + : Option String + := (attrOf e "target").map (fun t => (t.splitOn "/").getLast!) -private def eventTargets (ev : Elem) : List String := +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 := +def eventRefinementTargets + (p : Project) + (machine event : String) + : List String + := match lookupComponent p machine with | none => [] | some component => @@ -97,8 +133,11 @@ def eventRefinementTargets (p : Project) (machine event : String) : List String /- 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) := +def eventRefinementTargetLocators + (p : Project) + (machine event : String) + : List (String × String) + := match lookupComponent p machine with | none => [] | some component => @@ -119,20 +158,30 @@ def eventRefinementTargetLocators (p : Project) (machine event : String) : /-- 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 := +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 := +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 +def identifiers + : Term → + List String | .id n => [n] | .num _ => [] | .bin _ a b => identifiers a ++ identifiers b @@ -142,7 +191,11 @@ 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 +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 @@ -154,7 +207,11 @@ private def freeIdentifiers (bound : List String) : Term → List String freeIdentifiers bound pattern ++ freeIdentifiers (patternNames pattern ++ bound) body -private def freeOf (formula : String) : List String := +private +def freeOf + (formula : String) + : List String + := match Formula.parse formula with | .ok t => freeIdentifiers [] t | .error _ => [] @@ -162,7 +219,11 @@ private def freeOf (formula : String) : List String := /-- The substitution an action performs. Only the deterministic form `v ≔ E` yields one: `v :∈ S` and `v :∣ P` choose a value, which Rodin states with a fresh variable rather than a replacement, and which this does not derive yet. -/ -private def substOf (action : Elem) : List (String × Term) := +private +def substOf + (action : Elem) + : List (String × Term) + := match attrOf action "assignment" with | none => [] | some a => @@ -179,7 +240,11 @@ private def substOf (action : Elem) : List (String × Term) := |>.filterMap (fun (v, e) => update v e) | _ => [] -private def witnessBinding (witness : Elem) : Option (String × Term) := +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 @@ -199,17 +264,29 @@ private def witnessBinding (witness : Elem) : Option (String × Term) := | _ => none | _ => none -private def witnessVariable (witness : Elem) : Option String := +private +def witnessVariable + (witness : Elem) + : Option String + := (witnessBinding witness).map (·.1) <|> attrOf witness "label" -private def witnessSubstitution (witness : Elem) : Option (String × Term) := +private +def witnessSubstitution + (witness : Elem) + : Option (String × Term) + := match Formula.parse ((attrOf witness "predicate").getD "") with | .ok (.bin "=" (.id v) e) => some (v, e) | _ => none /-- The variables an action assigns. Rodin's three assignment forms all name their targets on the left: `v ≔ E`, `v :∈ S`, and `v, w :∣ P`. -/ -private def assignedBy (action : Elem) : List String := +private +def assignedBy + (action : Elem) + : List String + := match attrOf action "assignment" with | none => [] | some a => @@ -226,10 +303,18 @@ private def assignedBy (action : Elem) : List String := else [] | .ok _ => [] -private def targetEventName (ev : Elem) : String := +private +def targetEventName + (ev : Elem) + : String + := (eventTargets ev).head?.getD "" -private def beforeElem (target : Elem) : List Elem → List Elem +private +def beforeElem + (target : Elem) + : List Elem → + List Elem | [] => [] | elem :: elems => if elem == target then [] else elem :: beforeElem target elems @@ -240,7 +325,13 @@ it refines, so its effective children are its own plus everything up the chain. has revisited a machine, which means the model has a `refines` cycle and no fixed point exists. Well-formed projects never reach the bound, and reaching it returns what has been gathered so far rather than looping. -/ -def inheritedChildren (p : Project) (tag : String) : Nat → String → Elem → List Elem +def inheritedChildren + (p : Project) + (tag : String) + : Nat → -- depth, bounds walk by component count + String → -- current machine name + Elem → -- event element + List Elem | 0, _, ev => childrenOf ev tag | depth + 1, machine, ev => let own := childrenOf ev tag @@ -259,13 +350,26 @@ def inheritedChildren (p : Project) (tag : String) : Nat → String → Elem → | some ae => inheritedChildren p tag depth am ae inherited ++ own -def effectiveActions (p : Project) (machine : String) (ev : Elem) : List Elem := +def effectiveActions + (p : Project) + (machine : String) + (ev : Elem) + : List Elem + := inheritedChildren p "action" p.length machine ev -def effectiveGuards (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) +private +def parseGuardPredicates? + : List Elem → + Option (List Term) | [] => some [] | guard :: guards => do let source ← guard.attr? "org.eventb.core.predicate" @@ -275,7 +379,11 @@ private def parseGuardPredicates? : List Elem → Option (List Term) /-- 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) := +def eventGuardPredicates + (p : Project) + (machine event : String) + : Option (List Term) + := match lookupComponent p machine with | none => none | some component => @@ -292,7 +400,13 @@ 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. -/ -private def eventActions (p : Project) : Nat → String → Elem → List Elem +private +def eventActions + (p : Project) + : Nat → -- depth, bounds walk by component count + String → -- current machine name + Elem → -- event element + List Elem | 0, machine, ev => match lookupComponent p machine with | some component => initializationActions p component ev @@ -316,25 +430,52 @@ private def eventActions (p : Project) : Nat → String → Elem → List Elem 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 := +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 := +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 := +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) +def eventSubst + (p : Project) + : Nat → + String → -- current machine name + Elem → -- event element + 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 := +private +def actionRelation + (action : Elem) + : Option Term + := match attrOf action "assignment" with | none => none | some source => @@ -351,7 +492,11 @@ private def actionRelation (action : Elem) : Option Term := | .ok (.bin ":∣" _ predicate) => some predicate | _ => none -private def actionRelationAccurate (action : Elem) : Option Term := +private +def actionRelationAccurate + (action : Elem) + : Option Term + := match attrOf action "assignment" with | none => none | some source => @@ -370,7 +515,11 @@ private def actionRelationAccurate (action : Elem) : Option Term := | .ok (.bin ":∣" _ predicate) => some predicate | _ => none -private def nondeterministicSubst (action : Elem) : List (String × Term) := +private +def nondeterministicSubst + (action : Elem) + : List (String × Term) + := match attrOf action "assignment" with | some source => match Formula.parse source with @@ -381,61 +530,125 @@ private def nondeterministicSubst (action : Elem) : List (String × Term) := | _ => [] | none => [] -private def firstAssignments (pairs : List (String × Term)) : List (String × Term) := +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) := +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 := +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) := +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 := +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 := +private +def deterministicAfterRelation + (action : Elem) + : List Term + := (substOf action).map fun (v, rhs) => .bin "=" (.id (v ++ "'")) rhs -private def actionAfterRelation (action : Elem) : List Term := +private +def actionAfterRelation + (action : Elem) + : List Term + := deterministicAfterRelation action ++ (actionRelation action).toList -private def actionAfterRelationAccurate (action : Elem) : List Term := +private +def actionAfterRelationAccurate + (action : Elem) + : List Term + := deterministicAfterRelation action ++ (actionRelationAccurate action).toList -private def frameRelations (variables : List String) (actions : List Elem) : List Term := +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 := +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 := +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 := +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 := +def eventStateRelations + (p : Project) + (machine event : String) + (variables : List String) + : List Term + := match lookupComponent p machine with | none => [] | some component => @@ -449,14 +662,23 @@ def eventStateRelations (p : Project) (machine event : String) actions.flatMap actionAfterRelationAccurate ++ if event == "INITIALISATION" then [] else frameRelations variables actions -private def actionAfterSubst (action : Elem) : List (String × Term) := +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) := +private +def abstractEvents + (p : Project) + (machine : String) + (ev : Elem) + : List (String × Elem) + := match lookupComponent p machine with | none => [] | some m => @@ -469,16 +691,27 @@ private def abstractEvents (p : Project) (machine : String) (ev : Elem) : (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) := +private +def abstractEvent + (p : Project) + (machine : String) + (ev : Elem) + : Option (String × Elem) + := let refs := abstractEvents p machine ev refs.head? -private def disjoin : List Term → Option Term +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 +private +def conjoin + : List Term → + Option Term | [] => some (.id "⊤") | term :: terms => some (terms.foldl (fun acc next => .bin "∧" acc next) term) @@ -488,35 +721,61 @@ structure WdContext where totalKeywords : List String env : List (String × Ty) -private def totalKeywords (theory : Theory.Env) (roots : List String) : List String := +private +def totalKeywords + (theory : Theory.Env) + (roots : List String) + : List String + := Theory.namesWithApplication theory roots .total private def wdTop : Term := .id "⊤" -private def wdIsTop : Term → Bool +private +def wdIsTop + : Term → + Bool | .id "⊤" => true | _ => false -private def wdAtoms : Term → List Term +private +def wdAtoms + : Term → + List Term | .id "⊤" => [] | .bin "∧" a b => wdAtoms a ++ wdAtoms b | t => [t] -private def wdDedupAux (seen : List Term) : List Term → List Term +private +def wdDedupAux + (seen : List Term) + : List Term → + List Term | [] => seen.reverse | t :: ts => if seen.contains t then wdDedupAux seen ts else wdDedupAux (t :: seen) ts private def wdDedup (ts : List Term) : List Term := wdDedupAux [] ts -private def wdBuild : List Term → Term +private +def wdBuild + : List Term → + Term | [] => wdTop | t :: ts => ts.foldl (fun acc next => .bin "∧" acc next) t -private def wdAnd (a b : Term) : Term := +private +def wdAnd + (a b : Term) + : Term + := wdBuild (wdDedup (wdAtoms a ++ wdAtoms b)) -private def wdDrop (known : List Term) : Term → Term +private +def wdDrop + (known : List Term) + : Term → + Term | .id "⊤" => wdTop | .bin "∧" a b => wdAnd (wdDrop known a) (wdDrop known b) | .bin "⇒" p q => @@ -527,13 +786,21 @@ private def wdDrop (known : List Term) : Term → Term if wdIsTop body then wdTop else .bind k pat body | t => if known.contains t then wdTop else t -private def wdImpliesKnown (known : List Term) (p q : Term) : Term := +private +def wdImpliesKnown + (known : List Term) + (p q : Term) + : Term + := let q := wdDrop (known ++ wdAtoms p) q if wdIsTop q || wdIsTop p then q else .bin "⇒" p q private def wdImplies (p q : Term) : Term := wdImpliesKnown [] p q -private def wdType : Ty → Term +private +def wdType + : Ty → + Term | .given n => .id n | .int => .id "ℤ" | .bool => .id "BOOL" @@ -541,7 +808,12 @@ 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 := +private +def actionFeasibility + (types : List (String × Ty)) + (action : Elem) + : Option Term + := match attrOf action "assignment" with | none => none | some source => @@ -557,20 +829,36 @@ private def actionFeasibility (types : List (String × Ty)) (action : Elem) : Op else none | _ => none -private def wdFunctionType (context : WdContext) (f : Term) : Option Term := +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)) | _ => none private def wdNonempty (s : Term) : Term := .bin "≠" s (.set []) -private def wdFreshName (base : String) (used : List String) : Nat → Nat → String +private +def wdFreshName + (base : String) + (used : List String) + : Nat → -- candidate suffix index + Nat → -- fuel, decremented per attempt + 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 := +private +def wdBound + (isMax : Bool) + (s : Term) + : Term + := let used := identifiers s let bName := wdFreshName "b" used 0 (used.length + 1) let xName := wdFreshName "x" (bName :: used) 0 (used.length + 1) @@ -579,20 +867,38 @@ private def wdBound (isMax : Bool) (s : Term) : Term := let order := if isMax then .bin "≥" b x else .bin "≤" b x .bind "∃" b (.bind "∀" x (.bin "⇒" (.bin "∈" x s) order)) -private def wdRule (rule : Definedness) (s : Term) : Term := +private +def wdRule + (rule : Definedness) + (s : Term) + : Term + := match rule with | .finite => .app (.id "finite") s | .nonempty => wdNonempty s | .lowerBound => wdBound false s | .upperBound => wdBound true s -private def wdRules (rules : List Definedness) (s : Term) : Term := +private +def wdRules + (rules : List Definedness) + (s : Term) + : Term + := rules.foldl (fun acc rule => wdAnd acc (wdRule rule s)) wdTop -private def definednessFor (context : WdContext) (name : String) : List Definedness := +private +def definednessFor + (context : WdContext) + (name : String) + : List Definedness + := Theory.definedness? context.theory context.roots name -private def wdPattern : Term → Term +private +def wdPattern + : Term → + Term | .bin "↦" a b => .bin "," (wdPattern a) (wdPattern b) | .bin "," a b => .bin "," (wdPattern a) (wdPattern b) | .bin "⦂" a t => .bin "⦂" (wdPattern a) t @@ -600,7 +906,10 @@ private def wdPattern : Term → Term mutual -def needsWD (totalKeywords : List String) : Term → Bool +def needsWD + (totalKeywords : List String) + : Term → + Bool | .num _ | .id _ => false | .bin op a b => op == "÷" || op == "mod" || op == "^" || needsWD totalKeywords a || @@ -619,7 +928,10 @@ def needsWD (totalKeywords : List String) : Term → Bool /-- `List.any needsWD` would hide the recursive call inside a closure, where the equation compiler cannot see that it is applied to a subterm. Spelling the list traversal out keeps the whole thing structural. -/ -def needsWDAny (totalKeywords : List String) : List Term → Bool +def needsWDAny + (totalKeywords : List String) + : List Term → + Bool | [] => false | t :: ts => needsWD totalKeywords t || needsWDAny totalKeywords ts @@ -627,7 +939,12 @@ end mutual -private def wdTermAux : Nat → WdContext → Term → Option Term +private +def wdTermAux + : Nat → -- fuel, bounded by term size + WdContext → -- well-definedness context + Term → -- term to analyze for WD + Option Term | 0, _, _ => none | _, _, .num _ | _, _, .id _ => some wdTop | fuel + 1, context, .bin op a b => do @@ -691,7 +1008,12 @@ private def wdTermAux : Nat → WdContext → Term → Option Term if k == "λ" || k == "{" then .bind "∀" (wdPattern pat) w else w | _ => wdTermAux fuel context body -private def wdTerms : Nat → WdContext → List Term → Option Term +private +def wdTerms + : Nat → -- fuel, bounded by term size + WdContext → -- well-definedness context + List Term → -- terms to analyze for WD + Option Term | 0, _, _ => none | _, _, [] => some wdTop | fuel + 1, context, t :: ts => do @@ -703,7 +1025,10 @@ end mutual -private def wdFuel : Term → Nat +private +def wdFuel + : Term → + Nat | .id _ | .num _ => 1 | .bin _ a b => wdFuel a + wdFuel b + 1 | .pre _ a | .post _ a => wdFuel a + 1 @@ -711,28 +1036,51 @@ private def wdFuel : Term → Nat | .set ts => wdFuelList ts + 1 | .bind _ p b => wdFuel p + wdFuel b + 1 -private def wdFuelList : List Term → Nat +private +def wdFuelList + : List Term → + Nat | [] => 0 | t :: ts => wdFuel t + wdFuelList ts + 1 end -private def wdTerm (theory : Theory.Env) (roots totalKeywords : List String) - (env : List (String × Ty)) (t : Term) : Option Term := +private +def wdTerm + (theory : Theory.Env) + (roots totalKeywords : List String) + (env : List (String × Ty)) + (t : Term) + : Option Term + := wdTermAux (wdFuel t + 1) { theory, roots, totalKeywords, env } t -private def wdRequired (totalKeywords : List String) (formula : String) : Bool := +private +def wdRequired + (totalKeywords : List String) + (formula : String) + : Bool + := match Formula.parse formula with | .ok t => needsWD totalKeywords t | .error _ => false -private def assignmentRhs (formula : String) : Option String := +private +def assignmentRhs + (formula : String) + : Option String + := match Formula.parse formula with | .ok (.bin op _ rhs) => if op == "≔" || op == ":∈" || op == ":∣" then some (Formula.print rhs) else none | _ => none -private def assignmentRhsMode (strict : Bool) (formula : String) : Option String := +private +def assignmentRhsMode + (strict : Bool) + (formula : String) + : Option String + := if strict then match Formula.parse formula with | .ok (.bin "≔" lhs rhs) => @@ -746,15 +1094,27 @@ private def assignmentRhsMode (strict : Bool) (formula : String) : Option String | _ => none else assignmentRhs formula -private def wdGoal (theory : Theory.Env) (roots totalKeywords : List String) - (env : List (String × Ty)) (formula : String) : Option Term := +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 assignmentWdGoal (strict : Bool) (theory : Theory.Env) +private +def assignmentWdGoal + (strict : Bool) + (theory : Theory.Env) (roots totalKeywords : List String) - (types : List (String × Ty)) (action : Elem) : Option Term := do + (types : List (String × Ty)) + (action : Elem) + : Option Term + := do let source ← attrOf action "assignment" let parsed ← Formula.parse source |>.toOption match parsed with @@ -784,18 +1144,32 @@ private def assignmentWdGoal (strict : Bool) (theory : Theory.Env) 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 +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 +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 +private +def witnessFeasibility + (types visibleParams : List (String × Ty)) + (witness : Elem) + : Option Term + := do let predicate ← Formula.parse ((attrOf witness "predicate").getD "") |>.toOption let witnessVar ← witnessVariable witness let (_, type) ← (visibleParams.find? (fun pair => pair.1 == witnessVar) <|> @@ -828,7 +1202,11 @@ retried. Each was plausible and each made the gates worse: context in the dependency closure, then every invariant up the refinement chain, in declaration order. `closure` already computes that order for the typechecker, so the two cannot drift apart. -/ -def contextHyps (p : Project) (name : String) : List Term := +def contextHyps + (p : Project) + (name : String) + : List Term + := let (_, order) := closure p [] name order.flatMap fun dep => match lookupComponent p dep with @@ -837,7 +1215,12 @@ def contextHyps (p : Project) (name : String) : List Term := (childrenOf c.elem "axiom" ++ childrenOf c.elem "invariant").filterMap fun a => (Formula.parse ((attrOf a "predicate").getD "")).toOption -private def contextAxioms (p : Project) (name : String) : List Term := +private +def contextAxioms + (p : Project) + (name : String) + : List Term + := let (_, order) := closure p [] name order.flatMap fun dep => match lookupComponent p dep with @@ -845,7 +1228,13 @@ private def contextAxioms (p : Project) (name : String) : List Term := | some c => (childrenOf c.elem "axiom").filterMap fun a => (Formula.parse ((attrOf a "predicate").getD "")).toOption -private def hypothesesBefore (p : Project) (name : String) (target : Elem) : List Term := +private +def hypothesesBefore + (p : Project) + (name : String) + (target : Elem) + : List Term + := let (_, order) := closure p [] name order.flatMap fun dep => match lookupComponent p dep with @@ -855,21 +1244,39 @@ private def hypothesesBefore (p : Project) (name : String) (target : Elem) : Lis (if dep == name then beforeElem target declarations else declarations).filterMap fun a => (Formula.parse ((attrOf a "predicate").getD "")).toOption -private def eventHypsBefore (p : Project) (name : String) (ev target : Elem) : List Term := +private +def eventHypsBefore + (p : Project) + (name : String) + (ev target : Elem) + : List Term + := let base := if labelOf ev == "INITIALISATION" then contextAxioms p name else contextHyps p name base ++ (beforeElem target (effectiveGuards p name ev)).filterMap fun g => (Formula.parse ((attrOf g "predicate").getD "")).toOption -private def eventHyps (p : Project) (name : String) (ev : Elem) : List Term := +private +def eventHyps + (p : Project) + (name : String) + (ev : Elem) + : List Term + := let base := if labelOf ev == "INITIALISATION" then contextAxioms p name else contextHyps p name base ++ (effectiveGuards p name ev).filterMap fun g => (Formula.parse ((attrOf g "predicate").getD "")).toOption /-- Obligations for one machine or context under a native theory environment. -/ -private def generateInMode (strict : Bool) (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 => @@ -1162,8 +1569,12 @@ private def generateInMode (strict : Bool) (theory : Theory.Env) (p : Project) /-- 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) := +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}") @@ -1204,18 +1615,29 @@ structure EqlOrigin where actionHyps : List Formula.Term deriving BEq, Repr -private def directVariables (component : Component) : List String := +private +def directVariables + (component : Component) + : List String + := (childrenOf component.elem "variable").filterMap (attrOf · "identifier") -private def exactEqlGoal (varName : String) : Formula.Term := +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 +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 @@ -1271,13 +1693,22 @@ def locateEql? (theory : Theory.Env) (p : Project) element has been selected uniquely and the checked generator has emitted the corresponding obligation. -/ -def exactWitnessBinding? (witness : Elem) : Option (String × Formula.Term) := +def exactWitnessBinding? + (witness : Elem) + : Option (String × Formula.Term) + := witnessBinding witness -def exactWitnessVariable? (witness : Elem) : Option String := +def exactWitnessVariable? + (witness : Elem) + : Option String + := witnessVariable witness -def exactWitnessPredicate? (witness : Elem) : Option Formula.Term := +def exactWitnessPredicate? + (witness : Elem) + : Option Formula.Term + := (attrOf witness "predicate").bind (Formula.parse · |>.toOption) structure WitnessOrigin where @@ -1291,14 +1722,24 @@ structure WitnessOrigin where binding : Option (String × Formula.Term) deriving BEq, Repr -private def uniqueChildByLabel (parent : Elem) (tag label : String) : Option Elem := +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 := +private +def checkedWitnessOrigin + (component event witnessLabel : String) + (concreteEvent witness : Elem) + (predicate : Formula.Term) + (witnessName : String) + : WitnessOrigin + := { component event witnessLabel @@ -1313,9 +1754,12 @@ private def checkedWitnessOrigin (component event witnessLabel : String) 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 +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 @@ -1379,9 +1823,12 @@ structure SimOrigin where 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 +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 @@ -1426,8 +1873,13 @@ def locateSim? (theory : Theory.Env) (p : Project) abstractAction := abstractAction concreteActions := accurateTransitionActions p component concreteEvent }, obligation)) -def simSourceBound (theory : Theory.Env) (p : Project) - (component event abstractActionLabel : String) (target : Obligation) : Bool := +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 @@ -1435,7 +1887,11 @@ def simSourceBound (theory : Theory.Env) (p : Project) /-- 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 := +def generatedSourceBound + (p : Project) + (obligation : Obligation) + : Bool + := let directComponent := lookupComponent p obligation.component let directEvent (event : String) : Option Elem := directComponent.bind fun component => @@ -1513,21 +1969,40 @@ def generatedSourceBound (p : Project) (obligation : Obligation) : Bool := | _, _ => false /-- Compatibility entry point for Rodin corpus projects without user theories. -/ -def generate (p : Project) (name : String) : List Obligation := +def generate + (p : Project) + (name : String) + : List Obligation + := generateInMode false Theory.empty p name -def generateIn (theory : Theory.Env) (p : Project) (name : String) : List Obligation := +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) := +def generateChecked + (p : Project) + (name : String) + : Except EventB.Error (List Obligation) + := generateCheckedIn Theory.empty p name -private def checkedMissingProject : Project := +private +def checkedMissingProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.seesContext [("org.eventb.core.target", "Missing")] []] }] -private def defaultInitializationProject : Project := +private +def defaultInitializationProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -1536,7 +2011,10 @@ private def defaultInitializationProject : Project := , .event [("org.eventb.core.label", "INITIALISATION")] []] }] -private def rightWitnessProject : Project := +private +def rightWitnessProject + : Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -1564,7 +2042,10 @@ private def rightWitnessProject : Project := , .action [("org.eventb.core.label", "set"), ("org.eventb.core.assignment", "x ≔ q + 1")] []]] }] -private def hiddenParameterChild : Component := +private +def hiddenParameterChild + : Component + := { name := "C" elem := .machineFile [("org.eventb.core.name", "C")] [.refinesMachine [("org.eventb.core.target", "B")] [] @@ -1576,7 +2057,10 @@ private def hiddenParameterChild : Component := , .guard [("org.eventb.core.label", "hidden"), ("org.eventb.core.predicate", "p = 0")] []]] } -private def dataRefinementProject : Project := +private +def dataRefinementProject + : Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [.variable [("org.eventb.core.identifier", "a")] [] @@ -1604,7 +2088,10 @@ private def dataRefinementProject : Project := , .action [("org.eventb.core.label", "set"), ("org.eventb.core.assignment", "b ≔ b + 1")] []]] }] -private def mergeProject : Project := +private +def mergeProject + : Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -1634,7 +2121,10 @@ private def mergeProject : Project := , .action [("org.eventb.core.label", "set"), ("org.eventb.core.assignment", "x ≔ x")] []]] }] -private def nonEqualityWitnessProject : Project := +private +def nonEqualityWitnessProject + : Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -1662,7 +2152,10 @@ private def nonEqualityWitnessProject : Project := , .action [("org.eventb.core.label", "set"), ("org.eventb.core.assignment", "x ≔ q")] []]] }] -private def extendedParameterProject : Project := +private +def extendedParameterProject + : Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -1685,7 +2178,10 @@ private def extendedParameterProject : Project := , .action [("org.eventb.core.label", "set_y"), ("org.eventb.core.assignment", "y ≔ p")] []]] }] -private def initializationRefinementProject : Project := +private +def initializationRefinementProject + : Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -1700,7 +2196,10 @@ private def initializationRefinementProject : Project := , .variable [("org.eventb.core.identifier", "x")] [] , .event [("org.eventb.core.label", "INITIALISATION")] []] }] -private def functionUpdateWdProject : Project := +private +def functionUpdateWdProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.variable [("org.eventb.core.identifier", "f")] [] diff --git a/EventB/POG/EQLAdapter.lean b/EventB/POG/EQLAdapter.lean index 9a02f8d..f9d5bf9 100644 --- a/EventB/POG/EQLAdapter.lean +++ b/EventB/POG/EQLAdapter.lean @@ -11,21 +11,34 @@ namespace EventB.POG universe u -def eqlGoal (name : String) : EventB.Formula.Term := +def eqlGoal + (name : String) + : EventB.Formula.Term + := .bin "=" (.id (name ++ "'")) (.id name) -def intRead (name : String) (env : ValueEnv) : Option Int := +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 := +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 +structure EqlIntBinding + (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) + where component : String eventLabel : String eqlVariable : String @@ -47,9 +60,12 @@ structure EqlIntBinding (theory : EventB.Theory.Env) 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) := +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)) => @@ -80,20 +96,31 @@ def EqlIntBinding.fromProject? (theory : EventB.Theory.Env) 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 := +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 +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 +structure EqlIntEventBridge + {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} + (binding : EqlIntBinding theory project) + (σ : Type u) + where fuel : Nat encode : σ → ValueEnv event : Event σ @@ -127,10 +154,15 @@ structure EqlIntEventBridge {theory : EventB.Theory.Env} (encode state).lookup binding.eqlVariable = some (.integer value) nonempty : ∃ before after, event.act before after -def EqlIntEventBridge.read {theory : EventB.Theory.Env} +def EqlIntEventBridge.read + {theory : EventB.Theory.Env} {project : EventB.Typing.Project} - {binding : EqlIntBinding theory project} {σ : Type u} - (bridge : EqlIntEventBridge binding σ) : σ → Option Int := + {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 @@ -161,10 +193,14 @@ theorem intRead_of_eqlEvaluation primeNotNatural1 primeNotBoolean notInteger notNatural notNatural1 notBoolean beforeLookup afterLookup evaluated -def EqlIntEventBridge.sequent {theory : EventB.Theory.Env} +def EqlIntEventBridge.sequent + {theory : EventB.Theory.Env} {project : EventB.Typing.Project} - {binding : EqlIntBinding theory project} {σ : Type u} - (bridge : EqlIntEventBridge binding σ) : Prop := + {binding : EqlIntBinding theory project} + {σ : Type u} + (bridge : EqlIntEventBridge binding σ) + : Prop + := ∀ transition : CheckedBeforeAfter, transition.declarations = binding.declarations → (∀ hypothesis ∈ binding.obligation.hyps, @@ -172,20 +208,26 @@ def EqlIntEventBridge.sequent {theory : EventB.Theory.Env} 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} + {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 + (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} + {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 + (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 @@ -211,23 +253,31 @@ theorem EqlIntEventBridge.framePreserved /- 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 +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 := +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 := +def positiveProject + : EventB.Typing.Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -292,10 +342,15 @@ def positiveProject : EventB.Typing.Project := | _ => 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 +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 index dbad082..1113b42 100644 --- a/EventB/POG/RefinementAdapters.lean +++ b/EventB/POG/RefinementAdapters.lean @@ -11,16 +11,26 @@ namespace EventB.POG universe u v -structure CheckedPO (theory : EventB.Theory.Env) (project : EventB.Typing.Project) where +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 +private +structure MemberResult + (obligations : List Obligation) + where obligation : Obligation member : obligation ∈ obligations -private def findMember (predicate : Obligation → Bool) (obligations : List Obligation) : - Option (MemberResult obligations) := +private +def findMember + (predicate : Obligation → Bool) + (obligations : List Obligation) + : Option (MemberResult obligations) + := match obligations with | [] => none | obligation :: rest => @@ -31,9 +41,13 @@ private def findMember (predicate : Obligation → Bool) (obligations : List Obl | 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) := +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 => @@ -51,12 +65,19 @@ def CheckedPO.fromGenerated? (theory : EventB.Theory.Env) else none else none -private structure ExactMember (target : Obligation) (obligations : List Obligation) where +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) +private +def exactMember + (target : Obligation) + : (obligations : List Obligation) → + Option (ExactMember target obligations) | [] => none | candidate :: rest => if same : candidate = target then @@ -69,9 +90,12 @@ private def exactMember (target : Obligation) : (obligations : List Obligation) | 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) := +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 => @@ -86,29 +110,42 @@ def CheckedPO.fromGeneratedExact? (theory : EventB.Theory.Env) exact member.member } else none -def exactComponentDeclarations? (theory : EventB.Theory.Env) - (project : EventB.Typing.Project) (component : String) : - Option (List (String × EventB.Typing.Ty)) := +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)) := +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)) := +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 +structure CheckedEventSource + (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) + (component event : String) + where valuation : ComponentValuation valuationChecked : ComponentValuation.fromProject theory project component = .ok valuation @@ -118,9 +155,12 @@ structure CheckedEventSource (theory : EventB.Theory.Env) 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) := +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 => @@ -136,13 +176,21 @@ def CheckedEventSource.fromProject (theory : EventB.Theory.Env) 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 := + {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 +structure CheckedGuardSource + (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) + (component event : String) + where valuation : ComponentValuation valuationChecked : ComponentValuation.fromProject theory project component = .ok valuation @@ -152,9 +200,12 @@ structure CheckedGuardSource (theory : EventB.Theory.Env) 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) := +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 => @@ -170,9 +221,14 @@ def CheckedGuardSource.fromProject (theory : EventB.Theory.Env) 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 := + {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 ∧ @@ -181,8 +237,11 @@ def CheckedGuardSource.holds /- 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 +structure CheckedRelationalEventSource + (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) + (component event : String) + where valuation : ComponentValuation valuationChecked : ComponentValuation.fromProject theory project component = .ok valuation @@ -194,9 +253,12 @@ structure CheckedRelationalEventSource (theory : EventB.Theory.Env) 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) := +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 => @@ -213,28 +275,41 @@ def CheckedRelationalEventSource.fromProject (theory : EventB.Theory.Env) relationsNonempty := by simpa using h } def CheckedRelationalEventSource.relationAction - {theory : EventB.Theory.Env} {project : EventB.Typing.Project} + {theory : EventB.Theory.Env} + {project : EventB.Typing.Project} {component event : String} (source : CheckedRelationalEventSource theory project component event) - (fuel : Nat) (transition : CheckedBeforeAfter) : Prop := + (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} +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 := + (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 +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 @@ -243,9 +318,12 @@ structure CheckedMergeSource (theory : EventB.Theory.Env) 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) := +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 => @@ -261,8 +339,11 @@ def CheckedMergeSource.fromProject (theory : EventB.Theory.Env) targetCount := h } else none -def exactWitnessSource? (project : EventB.Typing.Project) - (component event witness : String) : Option (String × EventB.Formula.Term) := +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 => @@ -282,8 +363,11 @@ def exactWitnessSource? (project : EventB.Typing.Project) /- 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 +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 @@ -295,9 +379,12 @@ structure CheckedWitnessSource (theory : EventB.Theory.Env) 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) := +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 => @@ -313,15 +400,21 @@ def CheckedWitnessSource.fromProject (theory : EventB.Theory.Env) 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) := +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 := +def exactVariantExpression? + (project : EventB.Typing.Project) + (component : String) + : Option EventB.Formula.Term + := match EventB.Typing.lookupComponent project component with | none => none | some current => @@ -333,27 +426,43 @@ def exactVariantExpression? (project : EventB.Typing.Project) (component : Strin | some source => (EventB.Formula.parse source).toOption | _ => none -structure CheckedVariantSource (project : EventB.Typing.Project) (component : String) where +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) := +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 := +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 +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 @@ -369,9 +478,13 @@ structure CheckedMergeBranch (theory : EventB.Theory.Env) 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 +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 @@ -384,26 +497,41 @@ structure FormulaAdequacy {theory : EventB.Theory.Env} 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 := +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) := +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 +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 @@ -416,25 +544,40 @@ structure DomainFormulaAdequacy {theory : EventB.Theory.Env} 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 := +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) := +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 +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) @@ -451,73 +594,127 @@ structure TransitionFormulaAdequacy {theory : EventB.Theory.Env} 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 := +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} + {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 := + (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} + {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 : 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 := +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 := +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 := +def actionSemantic + {γ α : Type u} + (gluing : γ → α → Prop) + (concrete : Event γ) + (abstract : Event α) + : Prop + := actionSimulates gluing concrete abstract -def feasibilitySemantic {σ : Type u} (pre : σ → Prop) (action : σ → σ → Prop) : Prop := +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 := +def witnessFeasibilitySemantic + {σ α : Type u} + (pre : σ → Prop) + (predicate : σ → α → Prop) + : Prop + := ∀ state, pre state → ∃ witness, predicate state witness -def witnessDefinednessSemantic {σ : Type u} (pre defined : σ → Prop) : Prop := +def witnessDefinednessSemantic + {σ : Type u} + (pre defined : σ → Prop) + : Prop + := ∀ state, pre state → defined state -def implicationSemantic {σ : Type u} (hypotheses goal : σ → Prop) : Prop := +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 := +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 +structure InvAdapter + (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) + (σ : Type u) + where binding : CheckedPO theory project eventLabel : String invariantLabel : String @@ -537,13 +734,20 @@ structure InvAdapter (theory : EventB.Theory.Env) 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 := +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 +structure GrdAdapter + (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) + (γ α : Type u) + where binding : CheckedPO theory project concreteLabel : String abstractLabel : String @@ -566,13 +770,20 @@ structure GrdAdapter (theory : EventB.Theory.Env) 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 := +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 +structure SimAdapter + (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) + (γ α : Type u) + where binding : CheckedPO theory project concreteLabel : String abstractLabel : String @@ -599,13 +810,20 @@ structure SimAdapter (theory : EventB.Theory.Env) 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 := +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 +structure FisAdapter + (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) + (σ : Type u) + where binding : CheckedPO theory project eventLabel : String actionLabel : String @@ -622,13 +840,20 @@ structure FisAdapter (theory : EventB.Theory.Env) (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 := +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 +structure WfisAdapter + (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) + (σ α : Type u) + where binding : CheckedPO theory project eventLabel : String witnessLabel : String @@ -646,13 +871,20 @@ structure WfisAdapter (theory : EventB.Theory.Env) (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 := +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 +structure WwdAdapter + (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) + (σ α : Type u) + where binding : CheckedPO theory project eventLabel : String witnessLabel : String @@ -669,13 +901,20 @@ structure WwdAdapter (theory : EventB.Theory.Env) 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 := +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 +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" @@ -685,13 +924,20 @@ structure VwdAdapter (theory : EventB.Theory.Env) 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 := +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 +structure WdAdapter + (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) + (σ : Type u) + where binding : CheckedPO theory project sourceLabel : String kind : binding.obligation.kind = "WD" @@ -701,13 +947,20 @@ structure WdAdapter (theory : EventB.Theory.Env) 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 := +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 +structure ThmAdapter + (theory : EventB.Theory.Env) + (project : EventB.Typing.Project) + (σ : Type u) + where binding : CheckedPO theory project sourceLabel : String kind : binding.obligation.kind = "THM" @@ -716,14 +969,23 @@ structure ThmAdapter (theory : EventB.Theory.Env) 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 := +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 +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" @@ -751,17 +1013,31 @@ structure MergeAdapter (theory : EventB.Theory.Env) 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 +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 +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" @@ -785,16 +1061,22 @@ structure IntegerVariantAdapter (theory : EventB.Theory.Env) 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 := +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 +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" @@ -819,20 +1101,26 @@ structure NaturalVariantAdapter (theory : EventB.Theory.Env) 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) := +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 +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 @@ -847,16 +1135,25 @@ structure WellFoundedVariantAdapter (theory : EventB.Theory.Env) 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} +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 : 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 +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" @@ -893,11 +1190,17 @@ structure FiniteSetVariantAdapter (theory : EventB.Theory.Env) 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} +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 : 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 @@ -912,9 +1215,15 @@ theorem FiniteSetVariantAdapter.sound {theory : EventB.Theory.Env} 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 +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" @@ -971,12 +1280,18 @@ structure RestrictedFiniteSetVariantAdapter (theory : EventB.Theory.Env) 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 +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 @@ -997,11 +1312,17 @@ theorem RestrictedFiniteSetVariantAdapter.sound {theory : EventB.Theory.Env} 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} +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 + (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 @@ -1011,11 +1332,19 @@ theorem FiniteSetVariantAdapter.actionTotal {theory : EventB.Theory.Env} /- 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 := +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 := +def finiteSetVariantSourceMatch + (source : String) + (fin var : Obligation) + : Bool + := fin.kind == "FIN" && var.kind == "VAR" && fin.name == "FIN" && var.name == source ++ "/VAR" @@ -1026,7 +1355,10 @@ def finiteSetVariantSourceMatch (source : String) (fin var : Obligation) : Bool { name := "other/NAT", kind := "NAT" } { name := "step/VAR", kind := "VAR" } -private def finiteVariantProject : EventB.Typing.Project := +private +def finiteVariantProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [ ("org.eventb.core.name", "M") ] [ .variable [ ("org.eventb.core.identifier", "x") ] [] @@ -1041,7 +1373,10 @@ private def finiteVariantProject : EventB.Typing.Project := [ .action [ ("org.eventb.core.label", "set") , ("org.eventb.core.assignment", "x ≔ x") ] [] ] ] }] -private def theoremFixtureProject : EventB.Typing.Project := +private +def theoremFixtureProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [ .invariant [("org.eventb.core.label", "taut"), @@ -1061,26 +1396,36 @@ private def theoremFixtureProject : EventB.Typing.Project := #guard (CheckedPO.fromGenerated? EventB.Theory.empty theoremFixtureProject "M" (fun obligation => obligation.kind == "THM" && obligation.name == "taut/THM")).isSome -private def positiveThmObligation : Obligation := +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 := +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 +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 := +private +def positiveThmAdapter + : ThmAdapter EventB.Theory.empty theoremFixtureProject theoremState + := { binding := positiveThmPO sourceLabel := "taut" kind := by native_decide @@ -1109,41 +1454,61 @@ private def positiveThmAdapter : intro _ _ _ trivial } } -example : implicationSemantic positiveThmAdapter.hypotheses positiveThmAdapter.goal := +example + : implicationSemantic positiveThmAdapter.hypotheses positiveThmAdapter.goal + := positiveThmAdapter.sound -private def invariantFixtureProject : EventB.Typing.Project := +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 := +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 := +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 +private +theorem positiveInvPO_obligation + : positiveInvPO.obligation = positiveInvObligation + := by native_decide -private def invariantFixtureSource : CheckedEventSource EventB.Theory.empty - invariantFixtureProject "M" "INITIALISATION" := +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 := +private +def invariantFixtureTransition + : CheckedBeforeAfter + := { before := {}, after := {}, declarations := [] } -private theorem invariantFixtureAssignment : - assignmentRelation 128 [] invariantFixtureTransition [] := by +private +theorem invariantFixtureAssignment + : assignmentRelation 128 [] invariantFixtureTransition [] + := by constructor · rfl constructor @@ -1152,14 +1517,20 @@ private theorem invariantFixtureAssignment : · native_decide · rfl -private def positiveInvSource : CheckedEventSource EventB.Theory.empty - invariantFixtureProject positiveInvPO.obligation.component "INITIALISATION" := by +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 +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 @@ -1169,7 +1540,10 @@ private abbrev invariantSourceState := { transition : CheckedBeforeAfter // positiveInvSource.assignmentAction 128 transition } -private def invariantSourceModel : TypedTransitionModel := +private +def invariantSourceModel + : TypedTransitionModel + := { fuel := 128 wellFormed := positiveInvSource.assignmentAction 128 inhabited := ⟨invariantFixtureTransition, by @@ -1181,8 +1555,10 @@ private def invariantSourceModel : TypedTransitionModel := exact invariantFixtureAssignment⟩ supports := fun _ => true } -private def positiveInvAdapter : InvAdapter EventB.Theory.empty invariantFixtureProject - invariantSourceState := +private +def positiveInvAdapter + : InvAdapter EventB.Theory.empty invariantFixtureProject invariantSourceState + := { binding := positiveInvPO eventLabel := "INITIALISATION" invariantLabel := "taut" @@ -1270,10 +1646,15 @@ private def positiveInvAdapter : InvAdapter EventB.Theory.empty invariantFixture exact invariantFixtureAssignment⟩ exact ⟨state, state, trivial, trivial⟩ } -example : invariantSemantic positiveInvAdapter.event positiveInvAdapter.invariant := +example + : invariantSemantic positiveInvAdapter.event positiveInvAdapter.invariant + := positiveInvAdapter.sound -private def grdFixtureProject : EventB.Typing.Project := +private +def grdFixtureProject + : EventB.Typing.Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [ .event [("org.eventb.core.label", "INITIALISATION")] [] @@ -1292,7 +1673,10 @@ private def grdFixtureProject : EventB.Typing.Project := obligation.kind == "GRD" && obligation.name == "step/g/GRD") | .error _ => false -private def positiveGrdObligation : Obligation := +private +def positiveGrdObligation + : Obligation + := { component := "C", name := "step/g/GRD", kind := "GRD" goal := some (.bin "=" (.num 1) (.num 1)) } @@ -1303,19 +1687,28 @@ private def positiveGrdObligation : Obligation := #guard !(CheckedPO.fromGeneratedExact? EventB.Theory.empty grdFixtureProject { positiveGrdObligation with component := "A" }).isSome -private def positiveGrdPO : CheckedPO EventB.Theory.empty grdFixtureProject := +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 +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 +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 @@ -1325,7 +1718,10 @@ private abbrev grdSourceState := { transition : CheckedBeforeAfter // positiveGrdSource.assignmentAction 128 transition } -private def grdSourceModel : TypedTransitionModel := +private +def grdSourceModel + : TypedTransitionModel + := { fuel := 128 wellFormed := positiveGrdSource.assignmentAction 128 inhabited := ⟨invariantFixtureTransition, by @@ -1337,8 +1733,10 @@ private def grdSourceModel : TypedTransitionModel := exact invariantFixtureAssignment⟩ supports := fun _ => true } -private def positiveGrdAdapter : GrdAdapter EventB.Theory.empty grdFixtureProject - grdSourceState Unit := +private +def positiveGrdAdapter + : GrdAdapter EventB.Theory.empty grdFixtureProject grdSourceState Unit + := { binding := positiveGrdPO concreteLabel := "step" abstractLabel := "g" @@ -1422,11 +1820,16 @@ private def positiveGrdAdapter : GrdAdapter EventB.Theory.empty grdFixtureProjec exact invariantFixtureAssignment⟩ exact ⟨state, (), trivial, trivial⟩ } -example : guardSemantic positiveGrdAdapter.gluing - positiveGrdAdapter.concrete positiveGrdAdapter.abstract := +example + : guardSemantic positiveGrdAdapter.gluing + positiveGrdAdapter.concrete positiveGrdAdapter.abstract + := positiveGrdAdapter.sound -private def simFixtureProject : EventB.Typing.Project := +private +def simFixtureProject + : EventB.Typing.Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [ .variable [("org.eventb.core.identifier", "x")] [] @@ -1448,7 +1851,10 @@ private def simFixtureProject : EventB.Typing.Project := , .action [("org.eventb.core.label", "set"), ("org.eventb.core.assignment", "x ≔ 1")] [] ] ] }] -private def positiveSimObligation : Obligation := +private +def positiveSimObligation + : Obligation + := { component := "C", name := "step/set/SIM", kind := "SIM" hyps := [] goal := some (.bin "=" (.num 1) (.num 1)) } @@ -1460,31 +1866,45 @@ private def positiveSimObligation : Obligation := #guard !(CheckedPO.fromGeneratedExact? EventB.Theory.empty simFixtureProject { positiveSimObligation with component := "A" }).isSome -private def positiveSimPO : CheckedPO EventB.Theory.empty simFixtureProject := +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 +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 +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 := +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 +private +theorem simFixtureAssignment + : assignmentRelation 128 [("x", .int)] simFixtureTransition [("x", .num 1)] + := by exact assignmentRelation_x_one private abbrev simSourceState := @@ -1501,14 +1921,19 @@ private def simFixtureState : simSourceState := ⟨simFixtureTransition, by rw [declarations, updates] exact simFixtureAssignment⟩ -private def simSourceModel : TypedTransitionModel := +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 := +private +def positiveSimAdapter + : SimAdapter EventB.Theory.empty simFixtureProject simSourceState Unit + := { binding := positiveSimPO concreteLabel := "step" abstractLabel := "set" @@ -1594,13 +2019,18 @@ private def positiveSimAdapter : SimAdapter EventB.Theory.empty simFixtureProjec exact ⟨simFixtureState, simFixtureState, (), trivial, trivial, simFixtureState.property⟩ } -example : actionSemantic positiveSimAdapter.gluing - positiveSimAdapter.concrete positiveSimAdapter.abstract := +example + : actionSemantic positiveSimAdapter.gluing + positiveSimAdapter.concrete positiveSimAdapter.abstract + := positiveSimAdapter.sound /- Nondeterministic actions use the relational source binder below. -/ -private def nondeterministicFixtureProject : EventB.Typing.Project := +private +def nondeterministicFixtureProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [ .variable [("org.eventb.core.identifier", "x")] [] @@ -1617,7 +2047,10 @@ private def nondeterministicFixtureProject : EventB.Typing.Project := #guard (CheckedEventSource.fromProject EventB.Theory.empty nondeterministicFixtureProject "M" "INITIALISATION").isNone -private def positiveFisObligation : Obligation := +private +def positiveFisObligation + : Obligation + := { component := "M", name := "INITIALISATION/choose/FIS", kind := "FIS" goal := some (.bin "≠" (.set [.num 0]) (.set [])) } @@ -1628,13 +2061,18 @@ private def positiveFisObligation : Obligation := #guard !(CheckedPO.fromGeneratedExact? EventB.Theory.empty nondeterministicFixtureProject { positiveFisObligation with component := "N" }).isSome -private def positiveFisPO : - CheckedPO EventB.Theory.empty nondeterministicFixtureProject := +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 +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 @@ -1643,13 +2081,18 @@ private def positiveFisSource : CheckedRelationalEventSource EventB.Theory.empty #guard positiveFisSource.relations == [.bin "∈" (.id "x'") (.set [.num 0])] -private def fisFixtureTransition : CheckedBeforeAfter := +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 +private +theorem fisFixtureRelation + : positiveFisSource.relationAction 128 fisFixtureTransition + := by have declarations : positiveFisSource.declarations = [("x", .int)] := by native_decide have relations : positiveFisSource.relations = @@ -1673,14 +2116,19 @@ private abbrev fisSourceState := private def fisFixtureState : fisSourceState := ⟨fisFixtureTransition, fisFixtureRelation⟩ -private def fisSourceModel : TypedTransitionModel := +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 := +private +def positiveFisAdapter + : FisAdapter EventB.Theory.empty nondeterministicFixtureProject fisSourceState + := { binding := positiveFisPO eventLabel := "INITIALISATION" actionLabel := "choose" @@ -1751,14 +2199,19 @@ private def positiveFisAdapter : FisAdapter EventB.Theory.empty trivial nonempty := ⟨fisFixtureState, trivial⟩ } -example : feasibilitySemantic positiveFisAdapter.pre positiveFisAdapter.action := +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 := +private +def witnessFixtureProject + : EventB.Typing.Project + := [ { name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [ .variable [("org.eventb.core.identifier", "x")] [], @@ -1789,13 +2242,19 @@ private def witnessFixtureProject : EventB.Typing.Project := ] } ] -private def positiveWfisObligation : Obligation := +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 := +private +def positiveWwdObligation + : Obligation + := { component := "B", name := "step/p/WWD", kind := "WWD" hyps := [.bin "=" (.num 1) (.num 1), .bin "≠" (.num 1) (.num 0)] } @@ -1811,18 +2270,25 @@ private def positiveWwdObligation : Obligation := #guard !(CheckedPO.fromGeneratedExact? EventB.Theory.empty witnessFixtureProject { positiveWwdObligation with component := "A" }).isSome -private def positiveWfisPO : - CheckedPO EventB.Theory.empty witnessFixtureProject := +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 := +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 +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 @@ -1836,12 +2302,17 @@ private def positiveWitnessEventSource : CheckedEventSource EventB.Theory.empty #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" := +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 := +private +def witnessFormulaModel + : TypedFormulaModel + := { declarations := [("x", .int), ("q", .int), ("p", .int)] fuel := 128 wellFormed := fun env => @@ -1856,8 +2327,10 @@ 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 +private +theorem witnessFormulaModel_wfis_valid + : TypedFormulaModel.validUnchecked witnessFormulaModel positiveWfisObligation + := by constructor · native_decide constructor @@ -1875,8 +2348,10 @@ private theorem witnessFormulaModel_wfis_valid : · intro _ exact evalWitnessIntegerZeroDivOne env -private theorem witnessFormulaModel_wwd_valid : - TypedFormulaModel.validUnchecked witnessFormulaModel positiveWwdObligation := by +private +theorem witnessFormulaModel_wwd_valid + : TypedFormulaModel.validUnchecked witnessFormulaModel positiveWwdObligation + := by constructor · native_decide · intro env _ hypothesis member @@ -1894,23 +2369,33 @@ private theorem witnessFormulaModel_wwd_valid : exact ⟨⟨true, evalPredicateIntegerOneNeZero env⟩, evalPredicateIntegerOneNeZero env⟩ -private def positiveWwdSource : CheckedWitnessSource EventB.Theory.empty - witnessFixtureProject "B" "step" "p" := positiveWitnessSource +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 +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 +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 := +private +def positiveWfisAdapter + : WfisAdapter EventB.Theory.empty witnessFixtureProject witnessState Int + := { binding := positiveWfisPO eventLabel := "step" witnessLabel := "p" @@ -1956,8 +2441,10 @@ private def positiveWfisAdapter : WfisAdapter EventB.Theory.empty by native_decide⟩, trivial⟩ } -private def positiveWwdAdapter : WwdAdapter EventB.Theory.empty - witnessFixtureProject witnessState Int := +private +def positiveWwdAdapter + : WwdAdapter EventB.Theory.empty witnessFixtureProject witnessState Int + := { binding := positiveWwdPO eventLabel := "step" witnessLabel := "p" @@ -1999,13 +2486,20 @@ private def positiveWwdAdapter : WwdAdapter EventB.Theory.empty intro _ _ _ trivial } } -example : witnessFeasibilitySemantic positiveWfisAdapter.pre positiveWfisAdapter.predicate := +example + : witnessFeasibilitySemantic positiveWfisAdapter.pre positiveWfisAdapter.predicate + := positiveWfisAdapter.sound -example : witnessDefinednessSemantic positiveWwdAdapter.pre positiveWwdAdapter.defined := +example + : witnessDefinednessSemantic positiveWwdAdapter.pre positiveWwdAdapter.defined + := positiveWwdAdapter.sound -private def constantVariantProject : EventB.Typing.Project := +private +def constantVariantProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [ .variable [("org.eventb.core.identifier", "x")] [] @@ -2018,11 +2512,17 @@ private def constantVariantProject : EventB.Typing.Project := [ .action [("org.eventb.core.label", "set"), ("org.eventb.core.assignment", "x ≔ x")] [] ] ] }] -private def constantNatObligation : Obligation := +private +def constantNatObligation + : Obligation + := { component := "M", name := "step/NAT", kind := "NAT" goal := some (.bin "∈" (.num 0) (.id "ℕ")) } -private def constantVarObligation : Obligation := +private +def constantVarObligation + : Obligation + := { component := "M", name := "step/VAR", kind := "VAR" goal := some (.bin "≤" (.num 0) (.num 0)) } @@ -2032,41 +2532,62 @@ private def constantVarObligation : Obligation := constantVarObligation).isSome #guard (CheckedVariantSource.fromProject constantVariantProject "M").isSome -private def constantNatPO : CheckedPO EventB.Theory.empty constantVariantProject := +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 := +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" := +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" := +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 +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 +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 := +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 +private +theorem constantVariantAssignment + : constantNatEventSource.assignmentAction 128 constantVariantTransition + := by change assignmentRelation 128 constantNatEventSource.declarations constantVariantTransition constantNatEventSource.updates have declarations : constantNatEventSource.declarations = [("x", .int)] := by @@ -2080,16 +2601,25 @@ private abbrev constantVariantState := { transition : CheckedBeforeAfter // constantNatEventSource.assignmentAction 128 transition } -private def constantVariantStateValue : constantVariantState := +private +def constantVariantStateValue + : constantVariantState + := ⟨constantVariantTransition, constantVariantAssignment⟩ -private def constantVariantModel : TypedTransitionModel := +private +def constantVariantModel + : TypedTransitionModel + := { fuel := 128 wellFormed := constantNatEventSource.assignmentAction 128 inhabited := ⟨constantVariantTransition, constantVariantAssignment⟩ supports := fun _ => true } -private def constantIntegerVariant : IntegerVariant constantVariantState := +private +def constantIntegerVariant + : IntegerVariant constantVariantState + := { source := "step" mode := .anticipated measure := fun _ => 0 @@ -2099,8 +2629,10 @@ private def constantIntegerVariant : IntegerVariant constantVariantState := intro before after _ simp [integerVariantProgress] } -private def constantIntegerVariantAdapter : - IntegerVariantAdapter EventB.Theory.empty constantVariantProject constantVariantState := +private +def constantIntegerVariantAdapter + : IntegerVariantAdapter EventB.Theory.empty constantVariantProject constantVariantState + := { natBinding := constantNatPO varBinding := constantVarPO natKind := by native_decide @@ -2208,18 +2740,26 @@ private def constantIntegerVariantAdapter : natActionExact := by intro state; exact Iff.rfl varActionExact := by intro state; exact Iff.rfl } -example : integerVariantNaturality constantIntegerVariantAdapter.contract ∧ - integerVariantProgressSemantic constantIntegerVariantAdapter.contract := +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 := +private +def theoremMatrixGoal + : EventB.Formula.Term + := .bin "=" (.num 1) (.num 1) -private def theoremMatrixChecked? (goal : EventB.Formula.Term) : - Option (CheckedPO EventB.Theory.empty theoremFixtureProject) := +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" && @@ -2232,7 +2772,10 @@ private def theoremMatrixChecked? (goal : EventB.Formula.Term) : obligation.kind == "THM" && obligation.name == "taut/THM" && obligation.goal == some theoremMatrixGoal)).isSome -private def sourceMatrixProject : EventB.Typing.Project := +private +def sourceMatrixProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [ .variable [("org.eventb.core.identifier", "x")] [] @@ -2259,8 +2802,11 @@ private def sourceMatrixProject : EventB.Typing.Project := [ .action [("org.eventb.core.label", "set"), ("org.eventb.core.assignment", "x ≔ 2")] [] ] ] }] -private def sourceMatrixUpdates? (component event : String) : - Option (List (String × EventB.Formula.Term)) := +private +def sourceMatrixUpdates? + (component event : String) + : Option (List (String × EventB.Formula.Term)) + := (CheckedEventSource.fromProject EventB.Theory.empty sourceMatrixProject component event).map (·.updates) @@ -2270,7 +2816,10 @@ private def sourceMatrixUpdates? (component event : String) : #guard (sourceMatrixUpdates? "M" "missing").isNone #guard !(sourceMatrixUpdates? "M" "step" == sourceMatrixUpdates? "N" "step") -private def variantMatrixProject : EventB.Typing.Project := +private +def variantMatrixProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [ .variable [("org.eventb.core.identifier", "x")] [] @@ -2280,7 +2829,11 @@ private def variantMatrixProject : EventB.Typing.Project := [ .variable [("org.eventb.core.identifier", "y")] [] , .variant [("org.eventb.core.expression", "y")] [] ] }] -private def variantMatrixExpression? (component : String) : Option EventB.Formula.Term := +private +def variantMatrixExpression? + (component : String) + : Option EventB.Formula.Term + := (CheckedVariantSource.fromProject variantMatrixProject component).map (·.expression) #guard variantMatrixExpression? "M" == some (.id "x") @@ -2302,7 +2855,10 @@ private def variantMatrixExpression? (component : String) : Option EventB.Formul | _, _ => false | .error _ => false -private def finiteSetVariantProject : EventB.Typing.Project := +private +def finiteSetVariantProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [ .variable [("org.eventb.core.identifier", "S")] [] diff --git a/EventB/POGBridge.lean b/EventB/POGBridge.lean index a2d6092..c20b6a1 100644 --- a/EventB/POGBridge.lean +++ b/EventB/POGBridge.lean @@ -13,21 +13,33 @@ namespace EventB.POG universe u -def eqlTerm (varName : String) : EventB.Formula.Term := +def eqlTerm + (varName : String) + : EventB.Formula.Term + := .bin "=" (.id (varName ++ "'")) (.id varName) -def transitionDenote (σ : Type u) := +def transitionDenote + (σ : Type u) + := EventB.Formula.Term → (σ × σ) → Prop -def transitionHypothesesHold {σ : Type u} - (denote : transitionDenote σ) (hypotheses : List EventB.Formula.Term) - (before after : σ) : 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 +structure EqlBridge + (σ : Type u) + (α : Type u) + where theory : EventB.Theory.Env project : EventB.Typing.Project obligation : Obligation @@ -46,12 +58,20 @@ structure EqlBridge (σ : Type u) (α : Type u) where denote (eqlTerm varName) (before, after) ↔ read after = read before frame : framePreserved read action -def EqlBridge.valid {σ α : Type u} (bridge : EqlBridge σ α) : Prop := +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 +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 @@ -64,7 +84,10 @@ theorem EqlBridge.valid_of_frame {σ α : Type u} (bridge : EqlBridge σ α) : b /- 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 +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 index c03283f..4145783 100644 --- a/EventB/POGSoundness.lean +++ b/EventB/POGSoundness.lean @@ -13,35 +13,61 @@ namespace EventB.POG universe u -structure FormulaModel (σ : Type u) where +structure FormulaModel + (σ : Type u) + where denote : EventB.Formula.Term → σ → Prop -def validSequent {σ : Type u} (hyps : List (σ → Prop)) (goal : σ → Prop) : 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 := +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 := +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 +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 := +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 := +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 @@ -49,9 +75,14 @@ def Obligation.checkedIn (theory : EventB.Theory.Env) /- 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 := +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 σ) @@ -72,7 +103,9 @@ inductive POClass where | eql | mrg | vwd | nat | fin | var deriving BEq, Repr -def POClass.ofKind : String → Option POClass +def POClass.ofKind + : String → + Option POClass | "INV" => some .inv | "WD" => some .wd | "GRD" => some .grd @@ -89,24 +122,37 @@ def POClass.ofKind : String → Option POClass | "VAR" => some .var | _ => none -def POClass.valuationSupported : POClass → Bool +def POClass.valuationSupported + : POClass → + Bool | .thm | .wd | .vwd | .wfis | .wwd | .fin => true | _ => false -def POClass.transitionValuationSupported : POClass → Bool +def POClass.transitionValuationSupported + : POClass → + Bool | .inv | .grd | .sim | .fis | .mrg | .eql | .nat | .var => true | _ => false -def Obligation.semanticShapeValid (obligation : Obligation) : Bool := +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 := +def Obligation.valuationSupported + (obligation : Obligation) + : Bool + := match POClass.ofKind obligation.kind with | some poClass => poClass.valuationSupported | none => false -def Obligation.transitionValuationSupported (obligation : Obligation) : Bool := +def Obligation.transitionValuationSupported + (obligation : Obligation) + : Bool + := match POClass.ofKind obligation.kind with | some poClass => poClass.transitionValuationSupported | none => false @@ -136,7 +182,11 @@ inductive ValueType where | pair (left right : ValueType) deriving Repr -private def valueTypeBeq : ValueType → ValueType → Bool +private +def valueTypeBeq + : ValueType → -- left-hand type + ValueType → -- right-hand type + Bool | .integer, .integer | .boolean, .boolean => true | .given left, .given right => left == right | .finiteSet none, .finiteSet none => true @@ -147,7 +197,10 @@ private def valueTypeBeq : ValueType → ValueType → Bool instance : BEq ValueType := ⟨valueTypeBeq⟩ -private def valueTypeDecEq : (left right : ValueType) → Decidable (left = right) +private +def valueTypeDecEq + : (left right : ValueType) → + Decidable (left = right) | .integer, .integer => isTrue rfl | .boolean, .boolean => isTrue rfl | .given left, .given right => @@ -206,7 +259,10 @@ inductive Value where mutual -private def valueDecEq : (left right : Value) → Decidable (left = right) +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) @@ -265,7 +321,10 @@ private def valueDecEq : (left right : Value) → Decidable (left = right) .booleanSet, .integerSet | .booleanSet, .naturalSet | .booleanSet, .natural1Set => isFalse (by intro proof; cases proof) -private def valueListDecEq : (left right : List Value) → Decidable (left = right) +private +def valueListDecEq + : (left right : List Value) → + Decidable (left = right) | [], [] => isTrue rfl | left :: lefts, right :: rights => match valueDecEq left right, valueListDecEq lefts rights with @@ -278,7 +337,9 @@ end instance : DecidableEq Value := valueDecEq -def Value.typeOf : Value → ValueType +def Value.typeOf + : Value → + ValueType | .integer _ => .integer | .boolean _ => .boolean | .atom carrier _ => .given carrier @@ -289,11 +350,16 @@ def Value.typeOf : Value → ValueType | .integerSet | .naturalSet | .natural1Set => .finiteSet (some .integer) | .booleanSet => .finiteSet (some .boolean) -def Value.setType : List Value → ValueType +def Value.setType + : List Value → + ValueType | [] => .finiteSet none | first :: _ => .finiteSet (some first.typeOf) -def ValueType.compatible : ValueType → ValueType → Bool +def ValueType.compatible + : ValueType → -- left-hand type + ValueType → -- right-hand type + Bool | .given left, .given right => left == right | .finiteSet left, .finiteSet right => match left, right with @@ -303,10 +369,17 @@ def ValueType.compatible : ValueType → ValueType → Bool compatible left₁ left₂ && compatible right₁ right₂ | left, right => left == right -def Value.sameType (left right : Value) : Bool := +def Value.sameType + (left right : Value) + : Bool + := ValueType.compatible left.typeOf right.typeOf -private def Value.isWellFormed : Nat → Value → Bool +private +def Value.isWellFormed + : Nat → -- fuel, recursion bound + Value → -- value to check + 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 @@ -325,7 +398,11 @@ decreasing_by mutual -def valueEqual : Nat → Value → Value → Except EvalError Bool +def valueEqual + : Nat → -- fuel, evaluator recursion bound + Value → -- left-hand value + Value → -- right-hand 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) @@ -346,14 +423,22 @@ def valueEqual : Nat → Value → Value → Except EvalError Bool | fuel + 1, .powerSet left, .powerSet right => .ok (left == right) | fuel + 1, _, _ => .ok false -def memberOf : Nat → Value → List Value → Except EvalError Bool +def memberOf + : Nat → -- fuel, evaluator recursion bound + Value → -- value being searched for + List Value → -- collection to search + 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 +def subsetOf + : Nat → -- fuel, evaluator recursion bound + List Value → -- left-hand set + List Value → -- right-hand set + Except EvalError Bool | 0, _, _ => .error .fuelExhausted | fuel + 1, left, right => if left == right then .ok true @@ -365,7 +450,10 @@ def subsetOf : Nat → List Value → List Value → Except EvalError Bool end -def Value.makeSet (values : List Value) : Except EvalError Value := +def Value.makeSet + (values : List Value) + : Except EvalError Value + := match values with | [] => .ok (.set []) | first :: rest => @@ -375,7 +463,9 @@ def Value.makeSet (values : List Value) : Except EvalError Value := |>.getD first.typeOf .error (.typeMismatch first.typeOf actual) -def ValueType.ofTy : EventB.Typing.Ty → Option ValueType +def ValueType.ofTy + : EventB.Typing.Ty → + Option ValueType | .int => some .integer | .bool => some .boolean | .given name => some (.given name) @@ -386,15 +476,27 @@ def ValueType.ofTy : EventB.Typing.Ty → Option ValueType pure (.pair left right) | .mvar _ => none -def Value.typeMatches (expected : ValueType) (actual : ValueType) : Bool := +def Value.typeMatches + (expected : ValueType) + (actual : ValueType) + : Bool + := ValueType.compatible expected actual -def Value.matchesTy (value : Value) (expected : EventB.Typing.Ty) : Bool := +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 := +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 => @@ -424,19 +526,36 @@ structure ValueEnv where carriers : List (String × List String) := [] deriving Repr, Inhabited, DecidableEq -def ValueEnv.lookup (env : ValueEnv) (name : String) : Option Value := +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 := +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 := +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 +def ValueEnv.valueIsWellFormed + : Nat → -- fuel, recursion bound + ValueEnv → -- carrier/value environment + Value → -- value to check + Bool | 0, _, _ => false | fuel + 1, env, .atom carrier name => env.carrierContains carrier name | fuel + 1, env, .pair left right => valueIsWellFormed fuel env left && @@ -452,12 +571,19 @@ termination_by fuel => fuel decreasing_by all_goals omega -def ValueEnv.declaredType? (declarations : List (String × EventB.Typing.Ty)) - (name : String) : Option EventB.Typing.Ty := +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 +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 @@ -475,22 +601,37 @@ def ValueEnv.validateFuel (fuel : Nat) (declarations : List (String × EventB.Ty .error .invalidValue else .ok () -def ValueEnv.validate (declarations : List (String × EventB.Typing.Ty)) - (env : ValueEnv) : Except EvalError Unit := +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 := +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 := +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 := +def ValueEnv.lookupMatches + (env : ValueEnv) + (name : String) + (expected : Value) + : Bool + := match env.lookup name with | some actual => valueMatches actual expected | none => false @@ -509,8 +650,13 @@ structure CheckedBeforeAfter where declarations : List (String × EventB.Typing.Ty) deriving Repr, DecidableEq -private def exceptDecEq {α β : Type} [DecidableEq α] [DecidableEq β] : - (left right : Except α β) → Decidable (left = right) +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) @@ -524,9 +670,12 @@ private def exceptDecEq {α β : Type} [DecidableEq α] [DecidableEq β] : instance : DecidableEq (Except EvalError Bool) := exceptDecEq instance : DecidableEq (Except EvalError CheckedBeforeAfter) := exceptDecEq -def CheckedBeforeAfter.make (fuel : Nat) +def CheckedBeforeAfter.make + (fuel : Nat) (declarations : List (String × EventB.Typing.Ty)) - (before after : ValueEnv) : Except EvalError CheckedBeforeAfter := do + (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 @@ -540,7 +689,12 @@ 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 := +private +def EvalView.lookup + (view : EvalView) + (name : String) + : Except EvalError Value + := if name.endsWith "'" then match view.after with | none => .error (.unsupported (.id name)) @@ -553,7 +707,13 @@ private def EvalView.lookup (view : EvalView) (name : String) : Except EvalError | some value => .ok value | none => .error (.unbound name) -private def EvalView.bind (view : EvalView) (name : String) (value : Value) : EvalView := +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) } @@ -563,7 +723,11 @@ private def EvalView.bind (view : EvalView) (name : String) (value : Value) : Ev /- 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 +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) @@ -573,7 +737,12 @@ private def binderCandidate (view : EvalView) : EventB.Formula.Term → Option V | _ => none | _ => none -def filterSetByMembership : Nat → String → List Value → List Value → Except EvalError (List Value) +def filterSetByMembership + : Nat → -- fuel, evaluator recursion bound + String → -- set operator (∩ or ∖) + List Value → -- values being filtered + List Value → -- set to test membership against + Except EvalError (List Value) | 0, _, _, _ => .error .fuelExhausted | fuel + 1, _, [], _ => .ok [] | fuel + 1, op, value :: values, right => do @@ -583,7 +752,11 @@ def filterSetByMembership : Nat → String → List Value → List Value → Exc .ok (value :: rest) else .ok rest -private def relationValidateFunction : Nat → List Value → Except EvalError Unit +private +def relationValidateFunction + : Nat → -- fuel, evaluator recursion bound + List Value → -- relation as list of pairs + Except EvalError Unit | 0, _ => .error .fuelExhausted | fuel + 1, [] => .ok () | fuel + 1, relation :: relations => @@ -598,7 +771,11 @@ private def relationValidateFunction : Nat → List Value → Except EvalError U else relationValidateFunction fuel relations | _ => .error .invalidRelation -private def relationType : Nat → List Value → Except EvalError (Option (ValueType × ValueType)) +private +def relationType + : Nat → -- fuel, evaluator recursion bound + List Value → -- relation as list of pairs + Except EvalError (Option (ValueType × ValueType)) | 0, _ => .error .fuelExhausted | fuel + 1, [] => .ok none | fuel + 1, .pair input output :: relations => do @@ -612,7 +789,12 @@ private def relationType : Nat → List Value → Except EvalError (Option (Valu else .error .invalidRelation | _, _ :: _ => .error .invalidRelation -private def relationApply : Nat → Value → List Value → Except EvalError (Option Value) +private +def relationApply + : Nat → -- fuel, evaluator recursion bound + Value → -- input value to look up + List Value → -- relation as list of pairs + Except EvalError (Option Value) | 0, _, _ => .error .fuelExhausted | fuel + 1, argument, [] => .ok none | fuel + 1, argument, relation :: relations => @@ -627,7 +809,12 @@ private def relationApply : Nat → Value → List Value → Except EvalError (O else relationApply fuel argument relations | _ => .error .invalidRelation -private def relationImage : Nat → Value → List Value → Except EvalError (List Value) +private +def relationImage + : Nat → -- fuel, evaluator recursion bound + Value → -- input value to look up + List Value → -- relation as list of pairs + Except EvalError (List Value) | 0, _, _ => .error .fuelExhausted | fuel + 1, argument, [] => .ok [] | fuel + 1, argument, relation :: relations => @@ -638,7 +825,13 @@ private def relationImage : Nat → Value → List Value → Except EvalError (L if equal then .ok (output :: rest) else .ok rest | _ => .error .invalidRelation -private def relationRestrict : Nat → Bool → List Value → List Value → Except EvalError (List Value) +private +def relationRestrict + : Nat → -- fuel, evaluator recursion bound + Bool → -- true = domain-side, false = range-side + List Value → -- relation as list of pairs + List Value → -- allowed values on that side + Except EvalError (List Value) | 0, _, _, _ => .error .fuelExhausted | fuel + 1, _, [], _ => .ok [] | fuel + 1, domain, relation :: relations, allowed => @@ -649,7 +842,13 @@ private def relationRestrict : Nat → Bool → List Value → List Value → Ex if equal then .ok (relation :: rest) else .ok rest | _ => .error .invalidRelation -private def relationDrop : Nat → Bool → List Value → List Value → Except EvalError (List Value) +private +def relationDrop + : Nat → -- fuel, evaluator recursion bound + Bool → -- true = domain-side, false = range-side + List Value → -- relation as list of pairs + List Value → -- values to drop on that side + Except EvalError (List Value) | 0, _, _, _ => .error .fuelExhausted | fuel + 1, _, [], _ => .ok [] | fuel + 1, domain, relation :: relations, dropped => @@ -660,7 +859,12 @@ private def relationDrop : Nat → Bool → List Value → List Value → Except if equal then .ok rest else .ok (relation :: rest) | _ => .error .invalidRelation -private def relationOverride : Nat → List Value → List Value → Except EvalError (List Value) +private +def relationOverride + : Nat → -- fuel, evaluator recursion bound + List Value → -- relation being overridden + List Value → -- relation that overrides it + Except EvalError (List Value) | 0, _, _ => .error .fuelExhausted | fuel + 1, left, right => do let rightDomains ← right.mapM fun relation => @@ -672,7 +876,12 @@ private def relationOverride : Nat → List Value → List Value → Except Eval mutual -private def evalValueFuel : Nat → EvalView → EventB.Formula.Term → Except EvalError Value +private +def evalValueFuel + : Nat → -- fuel, evaluator recursion bound + EvalView → -- before/after variable state + EventB.Formula.Term → -- term to evaluate + Except EvalError Value | 0, _, _ => .error .fuelExhausted | fuel + 1, view, .id name => if name == "ℤ" then .ok .integerSet @@ -799,8 +1008,12 @@ private def evalValueFuel : Nat → EvalView → EventB.Formula.Term → Except Value.makeSet values | _, _, term => .error (.unsupported term) -private def evalValueListFuel : Nat → EvalView → List EventB.Formula.Term → - Except EvalError (List Value) +private +def evalValueListFuel + : Nat → -- fuel, evaluator recursion bound + EvalView → -- before/after variable state + List EventB.Formula.Term → -- terms to evaluate + Except EvalError (List Value) | 0, _, _ => .error .fuelExhausted | _fuel + 1, _, [] => .ok [] | fuel + 1, view, term :: terms => do @@ -808,7 +1021,12 @@ private def evalValueListFuel : Nat → EvalView → List EventB.Formula.Term let values ← evalValueListFuel fuel view terms pure (value :: values) -private def evalPredicateFuel : Nat → EvalView → EventB.Formula.Term → Except EvalError Bool +private +def evalPredicateFuel + : Nat → -- fuel, evaluator recursion bound + EvalView → -- before/after variable state + EventB.Formula.Term → -- predicate term to evaluate + Except EvalError Bool | 0, _, _ => .error .fuelExhausted | fuel + 1, _, .id "⊤" => .ok true | fuel + 1, _, .id "⊥" => .ok false @@ -887,29 +1105,53 @@ private def evalPredicateFuel : Nat → EvalView → EventB.Formula.Term → Exc end -private def evalValueWithFuel (fuel : Nat) (env : ValueEnv) - (term : EventB.Formula.Term) : Except EvalError Value := +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 := +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 := +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 := +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 := +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 => @@ -919,11 +1161,17 @@ def evalPredicateOverFiniteDomain (fuel : Nat) (env : ValueEnv) (binder : String | .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 +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 => @@ -938,14 +1186,20 @@ theorem evalPredicateOverFiniteDomain_true (fuel : Nat) (env : ValueEnv) 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 +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 +theorem evalWitnessIntegerZeroDivOne + (env : ValueEnv) + : evalPredicateAtFuel 128 env (.bind "∃" (.bin "⦂" (.id "p") (.id "ℤ")) - (.bin "=" (.id "p") (.bin "÷" (.num 0) (.num 1)))) = .ok true := by + (.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 @@ -956,24 +1210,30 @@ theorem evalWitnessIntegerZeroDivOne (env : ValueEnv) : ValueType.compatible, valueEqual, integerCompatible, pNotPrime, Bind.bind, Except.bind] -theorem evalPredicateIntegerOneEqOne (env : ValueEnv) : - evalPredicateAtFuel 128 env (.bin "=" (.num 1) (.num 1)) = .ok true := by +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 +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 +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 @@ -981,8 +1241,10 @@ theorem evalPredicateFiniteZero (env : ValueEnv) : 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 +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 @@ -990,15 +1252,20 @@ theorem evalValueFiniteZero (env : ValueEnv) : 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 +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 := +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 @@ -1020,9 +1287,9 @@ theorem evalBeforeAfterIntegerOneOrOne 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 + (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 @@ -1041,9 +1308,9 @@ theorem evalBeforeAfterZeroSetNeEmpty 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 + (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 @@ -1054,8 +1321,11 @@ theorem evalBeforeAfterZeroSetSubset 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 +private +theorem valueTypeCompatibleSelf + : ∀ valueType : ValueType, + valueType.compatible valueType = true + := by intro valueType cases valueType with | integer => rfl @@ -1134,27 +1404,34 @@ theorem evalBeforeAfterIdentifierFinite 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 + (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 + (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 := +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 := +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 @@ -1226,10 +1503,18 @@ theorem eqlIntegerAfterEqBefore notBoolean] using evaluated exact eq_of_beq equal -def evalValue : ValueEnv → EventB.Formula.Term → Except EvalError Value := +def evalValue + : ValueEnv → + EventB.Formula.Term → + Except EvalError Value + := evalValueWithFuel 128 -def evalPredicate : ValueEnv → EventB.Formula.Term → Except EvalError Bool := +def evalPredicate + : ValueEnv → + EventB.Formula.Term → + Except EvalError Bool + := evalPredicateWithFuel 128 #guard match evalValue @@ -1290,8 +1575,12 @@ def evalPredicate : ValueEnv → EventB.Formula.Term → Except EvalError Bool : (.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 +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) @@ -1303,14 +1592,23 @@ private def ValueEnv.parallelAssign (env : ValueEnv) (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 := +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 +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 @@ -1331,16 +1629,25 @@ def ValueEnv.parallelAssignTypedFuel (fuel : Nat) 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 := + (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 := +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) +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 @@ -1353,9 +1660,12 @@ structure ComponentValuation where variables : List String deriving Repr -def ComponentValuation.fromProject (theory : EventB.Theory.Env) - (project : EventB.Typing.Project) (component : String) : - Except EventB.Error ComponentValuation := do +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 @@ -1373,22 +1683,31 @@ def ComponentValuation.fromProject (theory : EventB.Theory.Env) variables := variables.eraseDups } pure valuation -def ComponentValuation.declarationsForEvent (valuation : ComponentValuation) - (project : EventB.Typing.Project) (event : String) : - List (String × EventB.Typing.Ty) := +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 := +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)) := +def deterministicActionAssignments + (action : EventB.Elem) + : Except EvalError (List (String × EventB.Formula.Term)) + := match action.attr? "org.eventb.core.assignment" with | none => .ok [] | some source => @@ -1405,9 +1724,12 @@ def deterministicActionAssignments (action : EventB.Elem) : | _ => .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)) := +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 => @@ -1419,9 +1741,14 @@ def ComponentValuation.eventAssignments (valuation : ComponentValuation) 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 +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)) @@ -1431,9 +1758,13 @@ def ComponentValuation.parallelAssign (valuation : ComponentValuation) 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 := +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 ∧ @@ -1495,7 +1826,9 @@ theorem assignmentPredicate_x_self_zero : mutual -def supportsValue : EventB.Formula.Term → Bool +def supportsValue + : EventB.Formula.Term → + Bool | .id name => !name.endsWith "'" | .num _ => true | .pre "−" value => supportsValue value @@ -1510,7 +1843,9 @@ def supportsValue : EventB.Formula.Term → Bool | .app function argument | .img function argument => supportsValue function && supportsValue argument -def supportsValueList : List EventB.Formula.Term → Bool +def supportsValueList + : List EventB.Formula.Term → + Bool | [] => true | value :: values => supportsValue value && supportsValueList values @@ -1518,7 +1853,9 @@ end #guard supportsValue (.app (.id "f") (.num 0)) -def supportsPredicate : EventB.Formula.Term → Bool +def supportsPredicate + : EventB.Formula.Term → + Bool | .id _ => true | .pre "¬" predicate => supportsPredicate predicate | .pre _ _ => false @@ -1550,7 +1887,9 @@ def supportsPredicate : EventB.Formula.Term → Bool mutual -def supportsBeforeAfterValue : EventB.Formula.Term → Bool +def supportsBeforeAfterValue + : EventB.Formula.Term → + Bool | .id _ => true | .num _ => true | .pre "−" value => supportsBeforeAfterValue value @@ -1565,7 +1904,9 @@ def supportsBeforeAfterValue : EventB.Formula.Term → Bool | .app function argument | .img function argument => supportsBeforeAfterValue function && supportsBeforeAfterValue argument -def supportsBeforeAfterValueList : List EventB.Formula.Term → Bool +def supportsBeforeAfterValueList + : List EventB.Formula.Term → + Bool | [] => true | value :: values => supportsBeforeAfterValue value && supportsBeforeAfterValueList values @@ -1584,7 +1925,9 @@ end | .error (.typeMismatch _ _) => true | _ => false -def supportsBeforeAfterPredicate : EventB.Formula.Term → Bool +def supportsBeforeAfterPredicate + : EventB.Formula.Term → + Bool | .id _ => true | .pre "¬" predicate => supportsBeforeAfterPredicate predicate | .pre _ _ => false @@ -1603,7 +1946,10 @@ def supportsBeforeAfterPredicate : EventB.Formula.Term → Bool | .app (.id "finite") argument => supportsBeforeAfterValue argument | .num _ | .set _ | .post _ _ | .app _ _ | .img _ _ | .bind _ _ _ => false -private def typedBindingProject : EventB.Typing.Project := +private +def typedBindingProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -1613,7 +1959,10 @@ private def typedBindingProject : EventB.Typing.Project := [.action [("org.eventb.core.label", "set"), ("org.eventb.core.assignment", "x ≔ 1")] []]] }] -private def badTypedBindingProject : EventB.Typing.Project := +private +def badTypedBindingProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -1667,22 +2016,41 @@ structure TypedFormulaModel where 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 := +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 τ := +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 := +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 := +def TypedFormulaModel.formulaModel + (model : TypedFormulaModel) + : FormulaModel ValueEnv + := { denote := model.denote } -def TypedFormulaModel.validUnchecked (model : TypedFormulaModel) (obligation : Obligation) : Prop := +def TypedFormulaModel.validUnchecked + (model : TypedFormulaModel) + (obligation : Obligation) + : Prop + := if obligation.semanticShapeValid = true && obligation.valuationSupported = true then match obligation.kind, obligation.goal with | _, some goal => @@ -1701,11 +2069,14 @@ def TypedFormulaModel.validUnchecked (model : TypedFormulaModel) (obligation : O else False theorem TypedFormulaModel.valid_on - {τ : Type u} (model : TypedFormulaModel) (encode : τ → ValueEnv) + {τ : 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 + (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 @@ -1733,8 +2104,11 @@ theorem TypedFormulaModel.valid_on 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 := + (model : TypedFormulaModel) + (domain : ValueEnv → Prop) + (obligation : Obligation) + : Prop + := if obligation.semanticShapeValid = true && obligation.valuationSupported = true then match obligation.kind, obligation.goal with | _, some goal => @@ -1752,11 +2126,15 @@ def TypedFormulaModel.validOnDomain else False theorem TypedFormulaModel.validOnDomain_on - {τ : Type u} (model : TypedFormulaModel) (domain : ValueEnv → Prop) - (encode : τ → ValueEnv) (obligation : Obligation) + {τ : 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 + (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 @@ -1779,9 +2157,13 @@ theorem TypedFormulaModel.validOnDomain_on · 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 := +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 @@ -1795,20 +2177,35 @@ structure TypedTransitionModel where inhabited : ∃ transition, wellFormed transition supports : EventB.Formula.Term → Bool -def TypedTransitionModel.denote (model : TypedTransitionModel) - (term : EventB.Formula.Term) (transition : CheckedBeforeAfter) : Prop := +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 τ := +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 := +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 := +def TypedTransitionModel.validUnchecked + (model : TypedTransitionModel) + (obligation : Obligation) + : Prop + := if obligation.semanticShapeValid = true && obligation.transitionValuationSupported = true then match obligation.goal with | some goal => @@ -1822,11 +2219,14 @@ def TypedTransitionModel.validUnchecked (model : TypedTransitionModel) else False theorem TypedTransitionModel.valid_on - {τ : Type u} (model : TypedTransitionModel) - (encode : τ → CheckedBeforeAfter) (obligation : Obligation) + {τ : 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 + (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 @@ -1852,7 +2252,9 @@ theorem TypedTransitionModel.valid_on def TypedTransitionModel.validOnDomain (model : TypedTransitionModel) (domain : CheckedBeforeAfter → Prop) - (obligation : Obligation) : Prop := + (obligation : Obligation) + : Prop + := if obligation.semanticShapeValid = true && obligation.transitionValuationSupported = true then match obligation.goal with | some goal => @@ -1866,12 +2268,15 @@ def TypedTransitionModel.validOnDomain else False theorem TypedTransitionModel.validOnDomain_on - {τ : Type u} (model : TypedTransitionModel) + {τ : Type u} + (model : TypedTransitionModel) (domain : CheckedBeforeAfter → Prop) - (encode : τ → CheckedBeforeAfter) (obligation : Obligation) + (encode : τ → CheckedBeforeAfter) + (obligation : Obligation) (valid : model.validOnDomain domain obligation) - (domainValid : ∀ state, domain (encode state)) : - FormulaModel.validUnchecked (model.on encode) obligation := by + (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 @@ -1888,28 +2293,43 @@ theorem TypedTransitionModel.validOnDomain_on · simp [TypedTransitionModel.validOnDomain, shape, valuation] at valid · simp [TypedTransitionModel.validOnDomain, shape] at valid -structure TransitionSourceCoverage (τ : Type u) where +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 := + {τ : 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 := +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 := +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 => @@ -1919,12 +2339,18 @@ private def TypedTransitionModel.ofAssignment (fuel : Nat) inhabited := ⟨transition, rfl⟩ supports := supportsBeforeAfterPredicate } -private def incrementTransition : CheckedBeforeAfter := +private +def incrementTransition + : CheckedBeforeAfter + := { before := { values := [("x", .integer 1)] } after := { values := [("x", .integer 2)] } declarations := [("x", .int)] } -private def incrementModel : TypedTransitionModel := +private +def incrementModel + : TypedTransitionModel + := { fuel := 64 wellFormed := fun transition => transition = incrementTransition inhabited := ⟨incrementTransition, rfl⟩ @@ -1982,9 +2408,11 @@ example : TypedTransitionModel.validUnchecked incrementModel 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 +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 := @@ -2105,7 +2533,11 @@ example : ¬ TypedTransitionModel.validUnchecked incrementModel | .error .fuelExhausted => true | _ => false -private def typedFormulaModel (supports : EventB.Formula.Term → Bool) : TypedFormulaModel := +private +def typedFormulaModel + (supports : EventB.Formula.Term → Bool) + : TypedFormulaModel + := { declarations := [("x", .int)] fuel := 128 wellFormed := fun env => ValueEnv.validationOk 128 [("x", .int)] env = true @@ -2116,8 +2548,11 @@ private def typedFormulaModel (supports : EventB.Formula.Term → Bool) : TypedF private def typedEnv : ValueEnv := { values := [("x", .integer 0)] } -private theorem typedEnvWellFormed (supports : EventB.Formula.Term → Bool) : - (typedFormulaModel supports).wellFormed typedEnv := by +private +theorem typedEnvWellFormed + (supports : EventB.Formula.Term → Bool) + : (typedFormulaModel supports).wellFormed typedEnv + := by change ValueEnv.validationOk 128 [("x", .int)] typedEnv = true native_decide @@ -2148,7 +2583,9 @@ private theorem typedFormulaValid : evalPredicateWithFuel, evalPredicateFuel, evalValue, evalValueWithFuel, evalValueFuel, Bind.bind, Except.bind] -def constantTypedFormulaModel : TypedFormulaModel := +def constantTypedFormulaModel + : TypedFormulaModel + := { declarations := [] fuel := 128 wellFormed := fun env => ValueEnv.validationOk 128 [] env = true @@ -2184,10 +2621,15 @@ theorem constantTypedFormulaModel_taut_valid : Value.typeOf, ValueType.compatible, valueEqual, integerCompatible, Bind.bind, Except.bind] -private def constantTransition : CheckedBeforeAfter := +private +def constantTransition + : CheckedBeforeAfter + := { before := {}, after := {}, declarations := [] } -def constantTypedTransitionModel : TypedTransitionModel := +def constantTypedTransitionModel + : TypedTransitionModel + := { fuel := 128 wellFormed := fun transition => transition = constantTransition inhabited := ⟨constantTransition, rfl⟩ @@ -2295,12 +2737,17 @@ theorem typedTransitionModel_closed_validOnDomain rw [fuel] exact evaluated -private def stutterTransition : CheckedBeforeAfter := +private +def stutterTransition + : CheckedBeforeAfter + := { before := { values := [("x", .integer 0)] } after := { values := [("x", .integer 0)] } declarations := [("x", .int)] } -def stutterTypedTransitionModel : TypedTransitionModel := +def stutterTypedTransitionModel + : TypedTransitionModel + := { fuel := 128 wellFormed := fun transition => transition = stutterTransition inhabited := ⟨stutterTransition, rfl⟩ @@ -2412,18 +2859,22 @@ example : FormulaModel.validUnchecked · intro _ exact typedEnvWellFormed _ -example : ¬ TypedFormulaModel.validUnchecked (typedFormulaModel supportsPredicate) - { component := "M", name := "false/THM", kind := "THM", - goal := some (.bin "<" (.num 1) (.num 0)) } := by +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 +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 @@ -2440,9 +2891,11 @@ example : ¬ TypedFormulaModel.validUnchecked (typedFormulaModel (fun _ => true) 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 +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 @@ -2457,21 +2910,27 @@ example : TypedFormulaModel.validUnchecked (typedFormulaModel (fun _ => true)) 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 +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 +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 +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/Prelude.lean b/EventB/Prelude.lean index 52871d0..8bc8a54 100644 --- a/EventB/Prelude.lean +++ b/EventB/Prelude.lean @@ -38,13 +38,22 @@ structure SymbolId where namespace SymbolId -def unqualified (name : String) : SymbolId := +def unqualified + (name : String) + : SymbolId + := { owner := "", name } -def qualified (owner name : String) : SymbolId := +def qualified + (owner name : String) + : SymbolId + := { owner, name } -def display (id : SymbolId) : String := +def display + (id : SymbolId) + : String + := if id.owner.isEmpty then id.name else id.owner ++ "::" ++ id.name end SymbolId @@ -60,29 +69,54 @@ structure Symbol where source : SourceRange := SourceRange.synthetic deriving Repr, Inhabited -private def carrier (name description : String) : Symbol := +private +def carrier + (name description : String) + : Symbol + := { name, kind := .carrierSet, type := some (.pow .int), description, id := SymbolId.unqualified name, source := SourceRange.synthetic } -private def constant (name description : String) (type : Ty) : Symbol := +private +def constant + (name description : String) + (type : Ty) + : Symbol + := { name, kind := .constant, type := some type, description, id := SymbolId.unqualified name, source := SourceRange.synthetic } -private def predicate (name description : String) (application : ApplicationKind) : Symbol := +private +def predicate + (name description : String) + (application : ApplicationKind) + : Symbol + := { name, kind := .predicate, type := none, description, application := some application, id := SymbolId.unqualified name, source := SourceRange.synthetic } -private def expression (name description : String) (application : ApplicationKind) - (definedness : List Definedness := []) : Symbol := +private +def expression + (name description : String) + (application : ApplicationKind) + (definedness : List Definedness := []) + : Symbol + := { name, kind := .expression, type := none, description, application := some application, definedness, id := SymbolId.unqualified name, source := SourceRange.synthetic } private def coreSource : SourceRange := SourceRange.synthetic "EventB.Prelude" -private def coreSymbol (symbol : Symbol) : Symbol := +private +def coreSymbol + (symbol : Symbol) + : Symbol + := { symbol with id := SymbolId.qualified "EventB.Core" symbol.name, source := coreSource } -def coreSymbols : List Symbol := +def coreSymbols + : List Symbol + := [ carrier "ℤ" "The set of all integers." , carrier "ℕ" "The set of natural numbers." , carrier "ℕ1" "The set of positive natural numbers." @@ -117,16 +151,28 @@ def coreSymbols : List Symbol := , expression "id" "The identity relation on a set." .total ] |>.map coreSymbol -def lookup? (name : String) : Option Symbol := +def lookup? + (name : String) + : Option Symbol + := coreSymbols.find? (·.name == name) -def isIdentifier (name : String) : Bool := +def isIdentifier + (name : String) + : Bool + := (lookup? name).isSome -def type? (name : String) : Option Ty := +def type? + (name : String) + : Option Ty + := (lookup? name).bind (·.type) -def application? (name : String) : Option ApplicationKind := +def application? + (name : String) + : Option ApplicationKind + := (lookup? name).bind (·.application) #guard (lookup? "BOOL").isSome diff --git a/EventB/Project.lean b/EventB/Project.lean index 1ae3daf..9d1767a 100644 --- a/EventB/Project.lean +++ b/EventB/Project.lean @@ -11,7 +11,9 @@ inductive ModelKind where | context deriving BEq, Repr, Inhabited -def ModelKind.label : ModelKind → String +def ModelKind.label + : ModelKind → + String | .machine => "machine" | .context => "context" @@ -23,19 +25,32 @@ structure ModelArtifact where theories : List String := [] deriving BEq, Inhabited -instance : Repr ModelArtifact where +instance + : Repr ModelArtifact + where reprPrec artifact _ := Std.Format.text s!"ModelArtifact({artifact.component}, {artifact.bytes.size} bytes)" -def ModelArtifact.byteString (artifact : ModelArtifact) : String := +def ModelArtifact.byteString + (artifact : ModelArtifact) + : String + := (String.fromUTF8? artifact.bytes).getD "" -private def artifactError (artifact : ModelArtifact) (message : String) : EventB.Error := +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 +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 @@ -55,7 +70,10 @@ def parseModelArtifact (artifact : ModelArtifact) : Except EventB.Error Componen | none => pure () pure { name := artifact.component, elem := model.root, theories := artifact.theories } -def projectFromArtifacts (artifacts : List ModelArtifact) : Except EventB.Error Project := do +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 diff --git a/EventB/Prover/Kernel.lean b/EventB/Prover/Kernel.lean index 01a69db..8691bbc 100644 --- a/EventB/Prover/Kernel.lean +++ b/EventB/Prover/Kernel.lean @@ -19,7 +19,9 @@ inductive Rule where | hypothesisProjection deriving BEq, Repr, Inhabited -def Rule.label : Rule → String +def Rule.label + : Rule → + String | .exactHypothesis => "exact-hypothesis" | .true => "true" | .reflexive => "reflexive" @@ -37,29 +39,51 @@ structure Result where def Result.discharged (result : Result) : Bool := result.rule.isSome -private def withHypLocals {α : Type} (hypotheses : List Expr) - (locals : List Expr) (body : List Expr → MetaM α) : MetaM α := +private +def withHypLocals + {α : Type} + (hypotheses : List Expr) + (locals : List Expr) + (body : List Expr → MetaM α) + : MetaM α + := match hypotheses with | [] => body locals | hypothesis :: rest => withLocalDeclD (Name.mkSimple s!"h{locals.length}") hypothesis fun localVar => withHypLocals rest (locals ++ [localVar]) body -private def lambda (locals : List Expr) (body : Expr) : MetaM Expr := +private +def lambda + (locals : List Expr) + (body : Expr) + : MetaM Expr + := mkLambdaFVars locals.toArray body -private def reflexiveProof (goal : Expr) : MetaM (Option Expr) := do +private +def reflexiveProof + (goal : Expr) + : MetaM (Option Expr) + := do let goal ← whnf goal match goal with | .app (.app (.app (.const ``Eq _) _) left) right => if ← isDefEq left right then some <$> mkAppM ``Eq.refl #[left] else pure none | _ => pure none -private theorem zeroLtIntOfNatSucc (n : Nat) : - Int.ofNat 0 < Int.ofNat (Nat.succ n) := by +private +theorem zeroLtIntOfNatSucc + (n : Nat) + : Int.ofNat 0 < Int.ofNat (Nat.succ n) + := by exact Int.ofNat_lt.mpr (Nat.zero_lt_succ n) -private def zeroLtNumeralProof (goal : Expr) : MetaM (Option Expr) := do +private +def zeroLtNumeralProof + (goal : Expr) + : MetaM (Option Expr) + := do let (function, arguments) := goal.getAppFnArgs if function == ``Int.lt && arguments.size == 2 then let left := arguments[0]! @@ -78,8 +102,12 @@ private def zeroLtNumeralProof (goal : Expr) : MetaM (Option Expr) := do else pure none -private def basicProof (pairs : List (Expr × Expr)) (goal : Expr) : - MetaM (Option (Rule × Expr)) := do +private +def basicProof + (pairs : List (Expr × Expr)) + (goal : Expr) + : MetaM (Option (Rule × Expr)) + := do for pair in pairs do if ← isDefEq pair.1 goal then return some (.exactHypothesis, pair.2) @@ -95,26 +123,42 @@ private def basicProof (pairs : List (Expr × Expr)) (goal : Expr) : return some (.contradiction, proof) pure none -private def andParts (goal : Expr) : MetaM (Option (Expr × Expr)) := do +private +def andParts + (goal : Expr) + : MetaM (Option (Expr × Expr)) + := do let goal ← whnf goal match goal with | .app (.app (.const ``And _) left) right => pure (some (left, right)) | _ => pure none -private def orParts (goal : Expr) : MetaM (Option (Expr × Expr)) := do +private +def orParts + (goal : Expr) + : MetaM (Option (Expr × Expr)) + := do let goal ← whnf goal match goal with | .app (.app (.const ``Or _) left) right => pure (some (left, right)) | _ => pure none -private def implicationParts (goal : Expr) : MetaM (Option (Expr × Expr)) := do +private +def implicationParts + (goal : Expr) + : MetaM (Option (Expr × Expr)) + := do let goal ← whnf goal match goal with | .forallE _ premise body _ => pure (some (premise, body)) | _ => pure none -private def projection (pairs : List (Expr × Expr)) (goal : Expr) : - MetaM (Option Expr) := do +private +def projection + (pairs : List (Expr × Expr)) + (goal : Expr) + : MetaM (Option Expr) + := do for pair in pairs do let hypothesis ← whnf pair.1 match hypothesis with @@ -126,7 +170,12 @@ private def projection (pairs : List (Expr × Expr)) (goal : Expr) : | _ => pure () pure none -private def ruleProof : Nat → List (Expr × Expr) → Expr → MetaM (Option (Rule × Expr)) +private +def ruleProof + : Nat → -- fuel, bounds proof-search depth + List (Expr × Expr) → -- hypothesis type/proof pairs + Expr → -- goal to prove + MetaM (Option (Rule × Expr)) | 0, pairs, goal => do if let some proof ← projection pairs goal then pure (some (.hypothesisProjection, proof)) @@ -164,7 +213,11 @@ private def ruleProof : Nat → List (Expr × Expr) → Expr → MetaM (Option ( else pure none -def prove (context : KernelContext) (obligation : Obligation) : MetaM Result := do +def prove + (context : KernelContext) + (obligation : Obligation) + : MetaM Result + := do let goal ← match obligation.goal with | some value => Embedding.translatePredicate context value | none => throwError s!"obligation `{obligation.name}` has no translated goal" @@ -176,7 +229,11 @@ def prove (context : KernelContext) (obligation : Obligation) : MetaM Result := pure { rule := some rule, proof := some proof } | none => pure {} -def validate (context : KernelContext) (obligation : Obligation) : MetaM Result := do +def validate + (context : KernelContext) + (obligation : Obligation) + : MetaM Result + := do let result ← prove context obligation match result.proof with | none => pure result diff --git a/EventB/Prover/Local.lean b/EventB/Prover/Local.lean index 2e2bae1..5162fa4 100644 --- a/EventB/Prover/Local.lean +++ b/EventB/Prover/Local.lean @@ -19,7 +19,9 @@ inductive Rule where | contradiction deriving BEq, Repr, Inhabited -def Rule.label : Rule → String +def Rule.label + : Rule → + String | .exactHypothesis => "exact-hypothesis" | .true => "true" | .reflexive => "reflexive" @@ -32,15 +34,25 @@ structure Result where def Result.discharged (result : Result) : Bool := result.rule.isSome -private def isReflexive : Term → Bool +private +def isReflexive + : Term → + Bool | .bin "=" left right => Formula.alphaEq left right | _ => false -private def isFalse : Term → Bool +private +def isFalse + : Term → + Bool | .id "⊥" => true | _ => false -private def rule? (obligation : Obligation) : Option Rule := do +private +def rule? + (obligation : Obligation) + : Option Rule + := do let goal ← obligation.goal if goal == .id "⊤" then some .true @@ -53,18 +65,34 @@ private def rule? (obligation : Obligation) : Option Rule := do else none -private def evidenceFingerprint (obligation : Obligation) (rule : Rule) : String := +private +def evidenceFingerprint + (obligation : Obligation) + (rule : Rule) + : String + := Trust.fingerprint (obligation.canonical ++ "\nrule=" ++ rule.label) -def evidence (obligation : Obligation) (rule : Rule) : Evidence := +def evidence + (obligation : Obligation) + (rule : Rule) + : Evidence + := .external "eventb-local" "0" (evidenceFingerprint obligation rule) "EventB.Prover.Local" -def prove (obligation : Obligation) : Result := +def prove + (obligation : Obligation) + : Result + := match rule? obligation with | some rule => { rule := some rule, evidence := evidence obligation rule } | none => {} -def attach (ledger : Ledger) (obligation : Obligation) : Result → Except EventB.Error Ledger +def attach + (ledger : Ledger) + (obligation : Obligation) + : Result → + Except EventB.Error Ledger | { rule := some rule, evidence := .external tool version digest verifier } => if tool != "eventb-local" || version != "0" || verifier != "EventB.Prover.Local" then .error (EventB.Error.prover "local prover evidence metadata mismatch") @@ -78,10 +106,16 @@ def attach (ledger : Ledger) (obligation : Obligation) : Result → Except Event .error (EventB.Error.prover "local prover evidence has wrong trust mode") | _ => pure ledger -private def trueObligation : Obligation := +private +def trueObligation + : Obligation + := { component := "Local", name := "true", kind := "THM", goal := some (.id "⊤") } -private def reflexiveObligation : Obligation := +private +def reflexiveObligation + : Obligation + := { component := "Local", name := "refl", kind := "THM" goal := some (.bin "=" (.id "x") (.id "x")) } diff --git a/EventB/Rossi.lean b/EventB/Rossi.lean index 664970e..951d7d3 100644 --- a/EventB/Rossi.lean +++ b/EventB/Rossi.lean @@ -29,14 +29,26 @@ private inductive CommentMode where private def whitespace (c : Char) : Bool := c.isWhitespace -private def trim (s : String) : String := +private +def trim + (s : String) + : String + := let left := s.toList.dropWhile whitespace String.ofList (left.reverse.dropWhile whitespace |>.reverse) -private def lower (s : String) : String := +private +def lower + (s : String) + : String + := String.ofList (s.toList.map Char.toLower) -private def stripComments (source : String) : Except String String := +private +def stripComments + (source : String) + : Except String String + := go source.toList .normal [] where go : List Char → CommentMode → List Char → Except String String @@ -51,19 +63,31 @@ where | '\n' :: rest, .block, out => go rest .block ('\n' :: out) | _ :: rest, .block, out => go rest .block out -private def structuralWords : List String := +private +def structuralWords + : List String + := ["context", "extends", "sets", "constants", "axioms", "theorems", "end", "machine", "refines", "sees", "variables", "invariants", "variant", "events", "event", "any", "where", "when", "with", "then", "begin", "witness"] -private def wordPrefix? (word : String) (cs : List Char) : Bool := +private +def wordPrefix? + (word : String) + (cs : List Char) + : Bool + := let wanted := (lower word).toList let actual := cs.take wanted.length |>.map Char.toLower actual == wanted && match cs.drop wanted.length with | c :: _ => !c.isAlphanum && c != '_' && c != '-' | [] => true -private def splitStructural (source : String) : String := +private +def splitStructural + (source : String) + : String + := go (source.length + 1) source.toList true [] where go : Nat → List Char → Bool → List Char → String @@ -85,11 +109,19 @@ where else go fuel rest false (c :: out) -private def lines (source : String) : List Line := +private +def lines + (source : String) + : List Line + := (splitStructural source).splitOn "\n" |>.mapIdx fun number text => { number := number + 1, text := trim text } -private def firstWord? (s : String) : Option (String × String) := +private +def firstWord? + (s : String) + : Option (String × String) + := let cs := (trim s).toList let word := cs.takeWhile (fun c => !whitespace c) if word.isEmpty then none @@ -97,12 +129,20 @@ private def firstWord? (s : String) : Option (String × String) := let rest := cs.drop word.length |>.dropWhile whitespace some (String.ofList word, String.ofList rest) -private def head? (s : String) : Option String := +private +def head? + (s : String) + : Option String + := firstWord? s |>.map (fun p => lower p.1) private def tail (s : String) : String := (firstWord? s).map (·.2) |>.getD "" -private def words (s : String) : List String := +private +def words + (s : String) + : List String + := go s.toList [] [] where go : List Char → List Char → List String → List String @@ -115,23 +155,49 @@ where else go rest [] (String.ofList current.reverse :: out) else go rest (c :: current) out -private def lineError (line : Line) (message : String) : String := +private +def lineError + (line : Line) + (message : String) + : String + := s!"line {line.number}: {message}" -private def identAttrs (name : String) : XmlAttrs := +private +def identAttrs + (name : String) + : XmlAttrs + := [("org.eventb.core.identifier", name)] -private def targetAttrs (name : String) : XmlAttrs := +private +def targetAttrs + (name : String) + : XmlAttrs + := [("org.eventb.core.target", name)] -private def labelAttrs (label formula : String) (isTheorem : Bool := false) : XmlAttrs := +private +def labelAttrs + (label formula : String) + (isTheorem : Bool := false) + : XmlAttrs + := [("org.eventb.core.label", label), ("org.eventb.core.predicate", formula)] ++ (if isTheorem then [("org.eventb.core.theorem", "true")] else []) -private def assignmentAttrs (label formula : String) : XmlAttrs := +private +def assignmentAttrs + (label formula : String) + : XmlAttrs + := [("org.eventb.core.label", label), ("org.eventb.core.assignment", formula)] -private def removeTrailingColon (s : String) : String := +private +def removeTrailingColon + (s : String) + : String + := if s.endsWith ":" then String.ofList (s.toList.reverse.drop 1 |>.reverse) else s private structure Labelled where @@ -139,14 +205,22 @@ private structure Labelled where formula : String isTheorem : Bool := false -private def stripTheorem (source : String) : Bool × String := +private +def stripTheorem + (source : String) + : Bool × String + := match firstWord? source with | some (word, rest) => let isTheorem := lower word == "theorem" (isTheorem, if isTheorem then rest else source) | none => (false, source) -private def leadingLabel? (s : String) : Option (String × String) := +private +def leadingLabel? + (s : String) + : Option (String × String) + := let s := trim s if !s.startsWith "@" then none else @@ -157,7 +231,12 @@ private def leadingLabel? (s : String) : Option (String × String) := let rest := cs.drop label.length |>.dropWhile whitespace some (removeTrailingColon (String.ofList label), String.ofList rest) -private def labelled (_generated : String) (source : String) : Except String Labelled := do +private +def labelled + (_generated : String) + (source : String) + : Except String Labelled + := do let source := trim source let (theoremBefore, source) := stripTheorem source let (label, source) := @@ -168,7 +247,11 @@ private def labelled (_generated : String) (source : String) : Except String Lab if source.isEmpty then .error "expected a formula" else .ok { label, formula := source, isTheorem := theoremBefore || theoremAfter } -private def labelOnly? (source : String) : Option String := +private +def labelOnly? + (source : String) + : Option String + := leadingLabel? source |>.filter (·.2.isEmpty) |>.map (·.1) private inductive PredicateKind where @@ -179,7 +262,12 @@ private inductive PredicateKind where | guard | witness -private def predicateElem (kind : PredicateKind) (label formula : String) : Elem := +private +def predicateElem + (kind : PredicateKind) + (label formula : String) + : Elem + := match kind with | .axiom => .axiom (labelAttrs label formula) [] | .theoremAxiom => .axiom (labelAttrs label formula true) [] @@ -188,47 +276,81 @@ private def predicateElem (kind : PredicateKind) (label formula : String) : Elem | .guard => .guard (labelAttrs label formula) [] | .witness => .witness (labelAttrs label formula) [] -private def skipBlank : List Line → List Line +private +def skipBlank + : List Line → + List Line | [] => [] | line :: rest => if line.text.isEmpty then skipBlank rest else line :: rest private def isOneOf (value : String) (values : List String) : Bool := values.contains value -private def contextStops : List String := +private +def contextStops + : List String + := ["extends", "sets", "constants", "axioms", "theorems", "end"] -private def machineStops : List String := +private +def machineStops + : List String + := ["refines", "sees", "variables", "invariants", "theorems", "variant", "events", "end"] -private def eventStops : List String := +private +def eventStops + : List String + := ["any", "where", "when", "with", "witness", "then", "begin", "end"] -private def predicateBoundary (stops : List String) (line : Line) : Bool := +private +def predicateBoundary + (stops : List String) + (line : Line) + : Bool + := match head? line.text with | some head => isOneOf head stops | none => false -private def formulaBody (source : String) : String := +private +def formulaBody + (source : String) + : String + := let (_, source) := stripTheorem source match leadingLabel? source with | some (_, rest) => rest | none => source -private def startsWithFormulaOperator (source : String) : Bool := +private +def startsWithFormulaOperator + (source : String) + : Bool + := match Formula.lex source with | .ok (tok :: _) => match tok with | .op _ => true | _ => false | _ => false -private def formulaComplete (source : String) : Bool := +private +def formulaComplete + (source : String) + : Bool + := match Formula.parse source with | .ok _ => true | .error _ => false -private def collectPredicateText (stops : List String) (line : Line) (rest : List Line) : - String × List Line := +private +def collectPredicateText + (stops : List String) + (line : Line) + (rest : List Line) + : String × List Line + := let initial := line.text let initialBody := formulaBody initial let (initial, rest) := if initialBody.isEmpty then @@ -257,8 +379,15 @@ where else (text, source) -private def predicateLine (kind : PredicateKind) (stops : List String) (index : Nat) (line : Line) - (rest : List Line) : Except String (Elem × List Line) := do +private +def predicateLine + (kind : PredicateKind) + (stops : List String) + (index : Nat) + (line : Line) + (rest : List Line) + : Except String (Elem × List Line) + := do if lower line.text == "theorem" then match skipBlank rest with | next :: remaining => @@ -299,8 +428,14 @@ private def predicateLine (kind : PredicateKind) (stops : List String) (index : return (predicateElem kind (parsed.label.getD label) parsed.formula, remaining) | _, _ => .error (lineError line s!"invalid labelled formula `{line.text}`") -private def parsePredicates (kind : PredicateKind) (stops : List String) : Nat → Nat → - List Line → Except String (List Elem × List Line) +private +def parsePredicates + (kind : PredicateKind) + (stops : List String) + : Nat → -- fuel, bounded by line count + Nat → -- label numbering index + List Line → -- remaining source lines + Except String (List Elem × List Line) | 0, _, _ => .error "Rossi parser ran out of fuel" | fuel + 1, index, source => let source := skipBlank source @@ -314,7 +449,10 @@ private def parsePredicates (kind : PredicateKind) (stops : List String) : Nat let (more, remaining) ← parsePredicates kind stops fuel (index + 1) remaining return (elem :: more, remaining) -private def assignmentLength? : List Char → Option Nat +private +def assignmentLength? + : List Char → + Option Nat | '≔' :: _ => some 1 | ':' :: '=' :: _ => some 2 | ':' :: '∈' :: _ => some 2 @@ -323,7 +461,11 @@ private def assignmentLength? : List Char → Option Nat | ':' :: '∣' :: _ => some 2 | _ => none -private def topLevelAssignments (source : String) : List Nat := +private +def topLevelAssignments + (source : String) + : List Nat + := go source.length source.toList 0 0 where go : Nat → List Char → Nat → Nat → List Nat @@ -350,12 +492,21 @@ where | _ :: rest => go fuel rest 0 (position + 1) | fuel + 1, _ :: rest, depth, position => go fuel rest depth (position + 1) -private def charAt? : List Char → Nat → Option Char +private +def charAt? + : List Char → -- characters to index into + Nat → -- index to look up + Option Char | [], _ => none | c :: _, 0 => some c | _ :: rest, position + 1 => charAt? rest position -private def actionStart (source : String) (marker : Nat) : Nat := +private +def actionStart + (source : String) + (marker : Nat) + : Nat + := let chars := source.toList go chars marker false where @@ -376,7 +527,12 @@ where else position + 1 -private def splitAtPositions (source : String) (starts : List Nat) : List String := +private +def splitAtPositions + (source : String) + (starts : List Nat) + : List String + := go source.toList 0 starts where go : List Char → Nat → List Nat → List String @@ -388,7 +544,11 @@ where let more := go chars next rest if text.isEmpty then more else text :: more -private def splitActionText (source : String) : List String := +private +def splitActionText + (source : String) + : List String + := match topLevelAssignments source with | [] => [source] | first :: rest => @@ -399,7 +559,11 @@ private def splitActionText (source : String) : List String := else starts splitAtPositions source starts -private def actionBody (source : String) : String := +private +def actionBody + (source : String) + : String + := match topLevelAssignments source with | marker :: _ => let chars := source.toList.drop marker @@ -408,7 +572,11 @@ private def actionBody (source : String) : String := | none => "" | [] => "" -private def actionComplete (source : String) : Bool := +private +def actionComplete + (source : String) + : Bool + := let body := match leadingLabel? source with | some (_, rest) => rest | none => source @@ -416,7 +584,12 @@ private def actionComplete (source : String) : Bool := else if topLevelAssignments body |>.isEmpty then false else formulaComplete (actionBody body) -private def collectActionText (line : Line) (rest : List Line) : String × List Line := +private +def collectActionText + (line : Line) + (rest : List Line) + : String × List Line + := go (rest.length + 1) line.text rest where go : Nat → String → List Line → String × List Line @@ -432,7 +605,12 @@ where else (text, source) -private def parseActions : Nat → Nat → List Line → Except String (List Elem × List Line) +private +def parseActions + : Nat → -- fuel, bounded by line count + Nat → -- label numbering index + List Line → -- remaining source lines + Except String (List Elem × List Line) | 0, _, _ => .error "Rossi parser ran out of fuel" | fuel + 1, index, source => let source := skipBlank source @@ -451,14 +629,24 @@ private def parseActions : Nat → Nat → List Line → Except String (List Ele let (more, remaining) ← parseActions fuel (index + chunks.length) remaining return (actions ++ more, remaining) -private def sectionData (line : Line) (rest : List Line) : String × List Line := +private +def sectionData + (line : Line) + (rest : List Line) + : String × List Line + := if !(tail line.text).isEmpty then (tail line.text, rest) else match skipBlank rest with | next :: remaining => (next.text, remaining) | [] => ("", []) -private def collectNames : Nat → List String → List Line → List String × List Line +private +def collectNames + : Nat → -- fuel, bounded by line count + List String → -- section-boundary keywords + List Line → -- remaining source lines + List String × List Line | 0, _, source => ([], source) | fuel + 1, stops, source => let source := skipBlank source @@ -470,7 +658,12 @@ private def collectNames : Nat → List String → List Line → List String × let (more, remaining) := collectNames fuel stops rest (words line.text ++ more, remaining) -private def collectText : Nat → List String → List Line → List String × List Line +private +def collectText + : Nat → -- fuel, bounded by line count + List String → -- section-boundary keywords + List Line → -- remaining source lines + List String × List Line | 0, _, source => ([], source) | fuel + 1, stops, source => let source := skipBlank source @@ -482,15 +675,24 @@ private def collectText : Nat → List String → List Line → List String × L let (more, remaining) := collectText fuel stops rest (line.text :: more, remaining) -private def names (stops : List String) (line : Line) (rest : List Line) : - Except String (List String × List Line) := +private +def names + (stops : List String) + (line : Line) + (rest : List Line) + : Except String (List String × List Line) + := let first := if (tail line.text).isEmpty then [] else [{ number := line.number, text := tail line.text }] let (result, remaining) := collectNames (rest.length + 2) stops (first ++ rest) if result.isEmpty then .error (lineError line "expected one or more names") else .ok (result, remaining) -private def setTokens (s : String) : List String := +private +def setTokens + (s : String) + : List String + := go s.toList [] [] where flush (current : List Char) (out : List String) : List String := @@ -504,7 +706,11 @@ where go rest [] (String.ofList [c] :: out) else go rest (c :: current) out -private def parseSetDecls : Nat → List String → Except String (List (String × Option String)) +private +def parseSetDecls + : Nat → -- fuel, bounded by text length + List String → -- set-declaration tokens + Except String (List (String × Option String)) | 0, _ => .error "too many set declarations" | _, [] => .ok [] | fuel + 1, name :: "=" :: "{" :: rest => do @@ -520,8 +726,12 @@ where | members, "}" :: rest => .ok (members, rest) | members, token :: rest => takeSetMembers (members ++ [token]) rest -private def setElements (line : Line) (rest : List Line) : - Except String (List Elem × List Line) := do +private +def setElements + (line : Line) + (rest : List Line) + : Except String (List Elem × List Line) + := do let (text, remaining) := sectionData line rest let (continuations, remaining) := collectText (remaining.length + 2) contextStops remaining @@ -535,8 +745,12 @@ private def setElements (line : Line) (rest : List Line) : | none => [] .carrierSet (identAttrs name ++ attrs) [], remaining) -private def parseContextBody : Nat → List Elem → List Line → - Except String (Elem × List Line) +private +def parseContextBody + : Nat → -- fuel, bounded by line count + List Elem → -- children parsed so far + List Line → -- remaining source lines + Except String (Elem × List Line) | 0, _, _ => .error "Rossi parser ran out of fuel" | fuel + 1, children, source => let source := skipBlank source @@ -568,8 +782,12 @@ private def parseContextBody : Nat → List Elem → List Line → parseContextBody fuel (children ++ items) remaining | _ => .error (lineError line "unexpected context clause") -private def parseContext (line : Line) (rest : List Line) : - Except String (Component × List Line) := do +private +def parseContext + (line : Line) + (rest : List Line) + : Except String (Component × List Line) + := do let (name, headerTail) ← match firstWord? (tail line.text) with | some pair => pure pair | none => .error (lineError line "CONTEXT needs a component name") @@ -578,13 +796,21 @@ private def parseContext (line : Line) (rest : List Line) : let (root, remaining) ← parseContextBody (source.length + 1) [] source return ({ name, model := { root } }, remaining) -private def convergence (status : String) : Option String := +private +def convergence + (status : String) + : Option String + := if status == "ordinary" then some "0" else if status == "convergent" then some "1" else if status == "anticipated" then some "2" else none -private def parseEventHeader (line : Line) : Except String (String × Option String × String) := do +private +def parseEventHeader + (line : Line) + : Except String (String × Option String × String) + := do let (first, rest) ← match firstWord? line.text with | some pair => pure pair | none => .error (lineError line "EVENT needs a name") @@ -597,7 +823,11 @@ private def parseEventHeader (line : Line) : Except String (String × Option Str | none => .error (lineError line "EVENT needs a name") return (name, status, afterName) -private def eventStatus (line : Line) : Except String (Option String × String) := do +private +def eventStatus + (line : Line) + : Except String (Option String × String) + := do let (word, rest) ← match firstWord? (tail line.text) with | some pair => pure pair | none => .error (lineError line "STATUS expects ordinary, convergent, or anticipated") @@ -605,8 +835,14 @@ private def eventStatus (line : Line) : Except String (Option String × String) | some value => pure (some value, rest) | none => .error (lineError line "STATUS expects ordinary, convergent, or anticipated") -private def parseEventBody : Nat → String → Option String → List Elem → List Line → - Except String (Elem × List Line) +private +def parseEventBody + : Nat → -- fuel, bounded by line count + String → -- event name + Option String → -- convergence status + List Elem → -- children parsed so far + List Line → -- remaining source lines + Except String (Elem × List Line) | 0, _, _, _, _ => .error "Rossi parser ran out of fuel" | fuel + 1, name, status, children, source => let source := skipBlank source @@ -663,13 +899,23 @@ private def parseEventBody : Nat → String → Option String → List Elem → parseEventBody fuel name status (children ++ items) remaining | _ => .error (lineError line "unexpected event clause") -private def parseEvent (line : Line) (rest : List Line) : Except String (Elem × List Line) := do +private +def parseEvent + (line : Line) + (rest : List Line) + : Except String (Elem × List Line) + := do let (name, status, headerTail) ← parseEventHeader line let source := if headerTail.isEmpty then rest else ({ number := line.number, text := headerTail } :: rest) parseEventBody (source.length + 1) name status [] source -private def parseEvents : Nat → List Elem → List Line → Except String (List Elem × List Line) +private +def parseEvents + : Nat → -- fuel, bounded by line count + List Elem → -- events parsed so far + List Line → -- remaining source lines + Except String (List Elem × List Line) | 0, _, _ => .error "Rossi parser ran out of fuel" | fuel + 1, events, source => let source := skipBlank source @@ -693,8 +939,12 @@ private def parseEvents : Nat → List Elem → List Line → Except String (Lis let (event, remaining) ← parseEvent line rest parseEvents fuel (events ++ [event]) remaining -private def parseMachineBody : Nat → List Elem → List Line → - Except String (Elem × List Line) +private +def parseMachineBody + : Nat → -- fuel, bounded by line count + List Elem → -- children parsed so far + List Line → -- remaining source lines + Except String (Elem × List Line) | 0, _, _ => .error "Rossi parser ran out of fuel" | fuel + 1, children, source => let source := skipBlank source @@ -740,8 +990,12 @@ private def parseMachineBody : Nat → List Elem → List Line → parseMachineBody fuel (children ++ events) remaining | _ => .error (lineError line "unexpected machine clause") -private def parseMachine (line : Line) (rest : List Line) : - Except String (Component × List Line) := do +private +def parseMachine + (line : Line) + (rest : List Line) + : Except String (Component × List Line) + := do let (name, headerTail) ← match firstWord? (tail line.text) with | some pair => pure pair | none => .error (lineError line "MACHINE needs a component name") @@ -750,7 +1004,11 @@ private def parseMachine (line : Line) (rest : List Line) : let (root, remaining) ← parseMachineBody (source.length + 1) [] source return ({ name, model := { root } }, remaining) -private def parseComponents : Nat → List Line → Except String (List Component) +private +def parseComponents + : Nat → -- fuel, bounded by line count + List Line → -- remaining source lines + Except String (List Component) | 0, _ => .error "Rossi parser ran out of fuel" | fuel + 1, source => let source := skipBlank source @@ -768,17 +1026,26 @@ private def parseComponents : Nat → List Line → Except String (List Componen return component :: more | _ => .error (lineError line "expected CONTEXT or MACHINE") -def parse (source : String) : Except EventB.Error (List Component) := do +def parse + (source : String) + : Except EventB.Error (List Component) + := do let source ← (stripComments source).mapError EventB.Error.rossi let result ← (parseComponents ((source.length * 2) + 1) (lines source)).mapError EventB.Error.rossi if result.isEmpty then .error (EventB.Error.rossi "Rossi input contains no CONTEXT or MACHINE") else return result -def parseModel (source : String) : Except EventB.Error (List Model) := +def parseModel + (source : String) + : Except EventB.Error (List Model) + := parse source |>.map (·.map (·.model)) -def read (path : System.FilePath) : IO (Except EventB.Error (List Component)) := do +def read + (path : System.FilePath) + : IO (Except EventB.Error (List Component)) + := do try let source ← IO.FS.readFile path return (parse source).mapError (·.withPath path.toString) diff --git a/EventB/Semantics.lean b/EventB/Semantics.lean index a1c2153..fbc2623 100644 --- a/EventB/Semantics.lean +++ b/EventB/Semantics.lean @@ -10,34 +10,61 @@ value; the POs are the fields of `Proved` / `Refines`. Add surface syntax universe u v /-- Guarded event: guard on the pre-state, action as a before-after relation. -/ -structure Event (σ : Type u) where +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 +structure ParameterizedEvent + (σ : Type u) + (π : Type v) + where grd : π → σ → Prop act : π → σ → σ → Prop -def ParameterizedEvent.enabled {σ : Type u} {π : Type v} - (event : ParameterizedEvent σ π) (state : σ) : 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 := +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 := +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 +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 @@ -46,9 +73,13 @@ theorem ParameterizedEvent.step_invariant {σ : Type u} {π : Type v} 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 + {γ α : 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 @@ -61,15 +92,19 @@ structure ParameterizedEventRefinement gluing concreteAfter abstractAfter theorem ParameterizedEventRefinement.stepSim - {γ α : Type u} {πγ πα : Type v} - {concrete : ParameterizedEvent γ πγ} {abstract : ParameterizedEvent α πα} + {γ α : Type u} + {πγ πα : Type v} + {concrete : ParameterizedEvent γ πγ} + {abstract : ParameterizedEvent α πα} {gluing : γ → α → Prop} - (contract : ParameterizedEventRefinement concrete abstract gluing) : - ∀ concreteState concreteAfter abstractState, + (contract : ParameterizedEventRefinement concrete abstract gluing) + : ∀ concreteState concreteAfter abstractState, gluing concreteState abstractState → concrete.step concreteState concreteAfter → - ∃ abstractAfter, abstract.step abstractState abstractAfter ∧ - gluing concreteAfter abstractAfter := by + ∃ 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⟩ := @@ -78,94 +113,170 @@ theorem ParameterizedEventRefinement.stepSim /-- 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 := +def functionalAction + {σ : Type u} + (update : σ → σ) + : σ → + σ → + Prop + := fun before after => after = update before -def deterministicAction {σ : Type u} (action : σ → σ → Prop) : Prop := +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 +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 α := +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 α := +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 +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 +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 +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 +structure Machine + (σ : Type u) + where inv : σ → Prop init : σ → Prop events : List (Event σ) /-- One step = some enabled event fires. -/ -def Machine.step {σ : Type u} (M : Machine σ) (s s' : σ) : Prop := +def Machine.step + {σ : Type u} + (M : Machine σ) + (s s' : σ) + : Prop + := ∃ e ∈ M.events, e.grd s ∧ e.act s s' /-- Reachable states. -/ -inductive Reach {σ : Type u} (M : Machine σ) : σ → Prop where +inductive Reach + {σ : Type u} + (M : Machine σ) + : σ → + Prop + where | init {s} : M.init s → Reach M s | step {s s'} : Reach M s → M.step s s' → Reach M s' /-- The two consistency POs Rodin's POG would emit: INV/INITIALISATION and INV/event. -/ -structure Proved {σ : Type u} (M : Machine σ) : Prop where +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 +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 +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 +theorem Proved.sound + {σ : Type u} + {M : Machine σ} + (h : Proved M) + : ∀ s, + Reach M s → + M.inv s + := by intro s r induction r with | init hi => exact h.invInit _ hi | step _ hs ih => exact h.invStep _ _ ih hs /-- Refinement POs, gluing invariant `J`. Forward simulation. -/ -structure Refines {γ α : Type u} (C : Machine γ) (A : Machine α) (J : γ → α → Prop) : Prop where +structure Refines + {γ α : Type u} + (C : Machine γ) + (A : Machine α) + (J : γ → α → Prop) + : Prop + where 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 +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 → @@ -173,9 +284,19 @@ structure EventRefinement {γ α : Type u} (C : Machine γ) (A : Machine α) 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 +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 @@ -186,18 +307,39 @@ theorem EventRefinement.stepSim {γ α : Type u} {C : Machine γ} {A : Machine /-- 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 +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 +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 +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 intro c r induction r with | init hi => @@ -209,9 +351,19 @@ theorem Refines.sound {γ α : Type u} {C : Machine γ} {A : Machine α} {J : γ exact ⟨a', .step hra ha', hJ'⟩ /-- Abstract invariant transfers to the refinement for free. -/ -theorem Refines.inv_transfer {γ α : Type u} {C : Machine γ} {A : Machine α} {J : γ → α → Prop} - (hr : Refines C A J) (hp : Proved A) : - ∀ c, Reach C c → ∃ a, A.inv a ∧ J c a := by +theorem Refines.inv_transfer + {γ α : Type u} + {C : Machine γ} + {A : Machine α} + {J : γ → α → Prop} + (hr : Refines C A J) + (hp : Proved A) + : ∀ c, + Reach C c → + ∃ a, + A.inv a ∧ + J c a + := by intro c r obtain ⟨a, hra, hJ⟩ := hr.sound c r exact ⟨a, hp.sound a hra, hJ⟩ @@ -221,19 +373,31 @@ theorem Refines.inv_transfer {γ α : Type u} {C : Machine γ} {A : Machine α} 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 := +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 := +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 α) +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 + (notUpdated : ∀ update ∈ updates, update.1 ≠ name) + : parallelUpdate updates state name = state name + := by induction updates with | nil => rfl | cons head tail ih => @@ -247,67 +411,120 @@ theorem State.parallelUpdate_frame_at {α : Type u} · simp [equal] exact ih tailNotUpdated -theorem State.frame_of_parallelUpdate {α : Type u} - (updates : List (String × (State α → α))) (state : State α) +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 + (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 := +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 := +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 := +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 +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 +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) := +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 +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 := +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 := +def strictlyDecreases + {σ : Type u} + (variant : σ → Nat) + (action : σ → σ → Prop) + : Prop + := ∀ before after, action before after → variant after < variant before -structure AnticipatedVariant (σ : Type u) where +structure AnticipatedVariant + (σ : Type u) + where measure : σ → Nat action : σ → σ → Prop nonIncrease : nonIncreasing measure action -structure ConvergentVariant (σ : Type u) where +structure ConvergentVariant + (σ : Type u) + where measure : σ → Nat action : σ → σ → Prop decrease : strictlyDecreases measure action @@ -316,7 +533,11 @@ inductive IntegerVariantMode where | anticipated | convergent -def integerVariantProgress : IntegerVariantMode → Int → Int → Prop +def integerVariantProgress + : IntegerVariantMode → -- anticipated or convergent + Int → -- value after the transition + Int → -- value before the transition + Prop | .anticipated, after, before => after ≤ before | .convergent, after, before => after < before @@ -327,26 +548,46 @@ inductive FiniteVariantMode where | anticipated | convergent -def finiteSubset {α : Type u} (after before : List α) : Prop := +def finiteSubset + {α : Type u} + (after before : List α) + : Prop + := ∀ value, value ∈ after → value ∈ before -def finiteProperSubset {α : Type u} (after before : List α) : Prop := +def finiteProperSubset + {α : Type u} + (after before : List α) + : Prop + := finiteSubset after before ∧ ∃ value, value ∈ before ∧ value ∉ after -def finiteVariantProgress {α : Type u} : FiniteVariantMode → List α → List α → Prop +def finiteVariantProgress + {α : Type u} + : FiniteVariantMode → -- anticipated or convergent + List α → -- set after the transition + List α → -- set before the transition + Prop | .anticipated, after, before => finiteSubset after before | .convergent, after, before => finiteProperSubset after before -example : finiteVariantProgress .anticipated [1] [1, 2] := by +example + : finiteVariantProgress .anticipated [1] [1, 2] + := by intro value member simp_all -example : ¬ finiteVariantProgress .convergent [1] [1] := by +example + : ¬ finiteVariantProgress .convergent [1] [1] + := by intro progress rcases progress.2 with ⟨value, member, absent⟩ simp_all -structure FiniteSetVariant (σ : Type u) (α : Type v) where +structure FiniteSetVariant + (σ : Type u) + (α : Type v) + where mode : FiniteVariantMode measure : σ → List α action : σ → σ → Prop @@ -357,7 +598,9 @@ structure FiniteSetVariant (σ : Type u) (α : Type v) where /- 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 +structure IntegerVariant + (σ : Type u) + where source : String mode : IntegerVariantMode measure : σ → Int @@ -366,20 +609,36 @@ structure IntegerVariant (σ : Type u) where progress : ∀ before after, action before after → integerVariantProgress mode (measure after) (measure before) -def integerVariantNaturality {σ : Type u} (contract : IntegerVariant σ) : Prop := +def integerVariantNaturality + {σ : Type u} + (contract : IntegerVariant σ) + : Prop + := ∀ state, 0 ≤ contract.measure state -def integerVariantProgressSemantic {σ : Type u} (contract : IntegerVariant σ) : Prop := +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 := +def finiteVariantFiniteness + {σ : Type u} + {α : Type v} + (contract : FiniteSetVariant σ α) + : Prop + := ∀ state, contract.finite state -def finiteVariantProgressSemantic {σ : Type u} {α : Type v} - (contract : FiniteSetVariant σ α) : Prop := +def finiteVariantProgressSemantic + {σ : Type u} + {α : Type v} + (contract : FiniteSetVariant σ α) + : Prop + := ∀ before after, contract.action before after → finiteVariantProgress contract.mode (contract.measure after) (contract.measure before) @@ -388,7 +647,10 @@ def finiteVariantProgressSemantic {σ : Type u} {α : Type v} 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 +structure WellFoundedVariant + (σ : Type u) + (α : Type v) + where measure : σ → α relation : α → α → Prop wellFounded : WellFounded relation @@ -396,20 +658,32 @@ structure WellFoundedVariant (σ : Type u) (α : Type v) where progress : ∀ before after, action before after → relation (measure after) (measure before) -def wellFoundedVariantProgressSemantic {σ : Type u} {α : Type v} - (contract : WellFoundedVariant σ α) : Prop := +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 := +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 +structure MergeSimulation + {γ α : Type u} + (C : Machine γ) + (A : Machine α) + (J : γ → α → Prop) + : Type (max u u) + where abstractEvent : Event α abstractMember : abstractEvent ∈ A.events concreteEvents : List (Event γ) @@ -420,9 +694,19 @@ structure MergeSimulation {γ α : Type u} (C : Machine γ) (A : Machine α) 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 +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 @@ -433,8 +717,13 @@ theorem MergeSimulation.stepSim {γ α : Type u} {C : Machine γ} {A : Machine /- 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 +structure SplitSimulation + {γ α : Type u} + (C : Machine γ) + (A : Machine α) + (J : γ → α → Prop) + : Type (max u u) + where concreteEvent : Event γ concreteMember : concreteEvent ∈ C.events abstractEvents : List (Event α) @@ -446,10 +735,20 @@ structure SplitSimulation {γ α : Type u} (C : Machine γ) (A : Machine α) 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 +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'⟩ := @@ -457,7 +756,11 @@ theorem SplitSimulation.stepSim {γ α : Type u} {C : Machine γ} {A : Machine exact ⟨a', ⟨abstract, h.abstractMember abstract abstractMember, abstractGuard, abstractAction⟩, hJ'⟩ -def variantDecreasesAt (variant : Nat → Nat) (before after : Nat) : Bool := +def variantDecreasesAt + (variant : Nat → Nat) + (before after : Nat) + : Bool + := variant after < variant before #guard !variantDecreasesAt (fun _ => 0) 0 0 @@ -465,24 +768,37 @@ def variantDecreasesAt (variant : Nat → Nat) (before after : Nat) : Bool := /- ------------------------------------------------------------------ -/ /- Self-check: bounded counter, refined by (counter, remaining budget). -/ -theorem mem_single {α : Type u} {a b : α} (h : a ∈ [b]) : a = b := by +theorem mem_single + {α : Type u} + {a b : α} + (h : a ∈ [b]) + : a = b + := by simp at h; exact h /-- Abstract: `n` counts up to 10. -/ def incA : Event Nat := { grd := fun n => n < 10, act := fun n n' => n' = n + 1 } -def A : Machine Nat := +def A + : Machine Nat + := { inv := fun n => n ≤ 10, init := fun n => n = 0, events := [incA] } /-- Concrete: carries the variant `10 - n` explicitly; the guard reads the budget. -/ -def incC : Event (Nat × Nat) := +def incC + : Event (Nat × Nat) + := { grd := fun c => 0 < c.2, act := fun c c' => c' = (c.1 + 1, c.2 - 1) } -def C : Machine (Nat × Nat) := +def C + : Machine (Nat × Nat) + := { inv := fun c => c.1 + c.2 = 10, init := fun c => c = (0, 10), events := [incC] } /-- Gluing invariant. -/ def J : Nat × Nat → Nat → Prop := fun c n => c.1 = n ∧ c.1 + c.2 = 10 -theorem A_proved : Proved A := by +theorem A_proved + : Proved A + := by constructor · intro s hs have : s = 0 := hs @@ -496,7 +812,9 @@ theorem A_proved : Proved A := by show s' ≤ 10 omega -theorem C_refines_A : Refines C A J := by +theorem C_refines_A + : Refines C A J + := by constructor · intro c hc have : c = (0, 10) := hc @@ -510,7 +828,9 @@ 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 +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 @@ -537,7 +857,9 @@ def C_event_refinement : EventRefinement C A J := by show c.1 + 1 = n + 1 ∧ (c.1 + 1) + (c.2 - 1) = 10 omega⟩ -def C_merge_refinement : MergeSimulation C A J := by +def C_merge_refinement + : MergeSimulation C A J + := by refine { abstractEvent := incA abstractMember := ?_ @@ -564,15 +886,20 @@ def C_merge_refinement : MergeSimulation C A J := by 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 +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) := +theorem positiveWitness + : WitnessContract Unit Unit (fun _ => True) (fun _ => True) (fun _ _ => True) + := { feasible := fun _ _ => ⟨(), trivial⟩ wellDefined := fun _ _ => trivial } -def positiveConvergentVariant : ConvergentVariant (Nat × Nat) := +def positiveConvergentVariant + : ConvergentVariant (Nat × Nat) + := { measure := fun state => state.2 action := fun before after => incC.grd before ∧ incC.act before after decrease := by @@ -583,14 +910,22 @@ def positiveConvergentVariant : ConvergentVariant (Nat × Nat) := change before.2 - 1 < before.2 omega } -def C_local_refinement : RefinementProof C A J := +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 := +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 +example + : ∀ c, + Reach C c → + c.1 ≤ 10 + := by intro c r obtain ⟨n, hn, hJ⟩ := C_refines_A.inv_transfer A_proved c r have h1 : n ≤ 10 := hn diff --git a/EventB/Source.lean b/EventB/Source.lean index 296ba5a..23e122e 100644 --- a/EventB/Source.lean +++ b/EventB/Source.lean @@ -20,10 +20,16 @@ structure SourceRange where namespace SourceRange -def synthetic (file : String := "") : SourceRange := +def synthetic + (file : String := "") + : SourceRange + := { file, beginPos := { line := 1, column := 0 }, finishPos := { line := 1, column := 0 } } -def display (range : SourceRange) : String := +def display + (range : SourceRange) + : String + := s!"{range.file}:{range.beginPos.line}:{range.beginPos.column + 1}-" ++ s!"{range.finishPos.line}:{range.finishPos.column + 1}" diff --git a/EventB/Theory.lean b/EventB/Theory.lean index de22d33..812fca6 100644 --- a/EventB/Theory.lean +++ b/EventB/Theory.lean @@ -65,38 +65,56 @@ inductive Declaration where | ruleDecl (value : Rule) deriving BEq, Repr, Inhabited -def Declaration.name : Declaration → String +def Declaration.name + : Declaration → + String | .dataType value => value.name | .definitionDecl value => value.name | .ruleDecl value => value.name -def Declaration.kind : Declaration → DeclarationKind +def Declaration.kind + : Declaration → + DeclarationKind | .dataType _ => .datatype | .definitionDecl value => match value.kind with | .definitional => .definition | .axiomatic => .axiom | .ruleDecl value => value.kind -def Declaration.typeParameters : Declaration → List String +def Declaration.typeParameters + : Declaration → + List String | .dataType value => value.parameters | .definitionDecl value => value.typeParameters | .ruleDecl value => value.typeParameters -private def productType : List Typing.Ty → Option Typing.Ty +private +def productType + : List Typing.Ty → + Option Typing.Ty | [] => none | type :: types => some <| types.foldl (fun result next => .prod result next) type -def Constructor.type (datatype : Datatype) (constructor : Constructor) : Typing.Ty := +def Constructor.type + (datatype : Datatype) + (constructor : Constructor) + : Typing.Ty + := match productType constructor.arguments with | none => .given datatype.name | some arguments => .pow (.prod arguments (.given datatype.name)) -def Definition.type (value : Definition) : Typing.Ty := +def Definition.type + (value : Definition) + : Typing.Ty + := match productType (value.parameters.map (·.2)) with | none => value.result | some arguments => .pow (.prod arguments value.result) -def Declaration.expressionType? : Declaration → Option Typing.Ty +def Declaration.expressionType? + : Declaration → + Option Typing.Ty | .definitionDecl value => some value.type | _ => none @@ -111,28 +129,53 @@ structure Env where theories : List Spec := [] deriving Repr, Inhabited -def core : Spec := +def core + : Spec + := { name := "EventB.Core", symbols := coreSymbols } -def empty : Env := +def empty + : Env + := { theories := [core] } -def canonicalize (theory : Spec) : Spec := +def canonicalize + (theory : Spec) + : Spec + := { theory with symbols := theory.symbols.map fun symbol => { symbol with id := SymbolId.qualified theory.name symbol.name } } -def declarationId (theory : String) (declaration : Declaration) : SymbolId := +def declarationId + (theory : String) + (declaration : Declaration) + : SymbolId + := SymbolId.qualified theory declaration.name -def lookupTheory? (env : Env) (name : String) : Option Spec := +def lookupTheory? + (env : Env) + (name : String) + : Option Spec + := env.theories.find? (·.name == name) -private def firstDuplicate (seen : List String) : List String → Option String +private +def firstDuplicate + (seen : List String) + : List String → + Option String | [] => none | name :: names => if seen.contains name then some name else firstDuplicate (name :: seen) names -private def closureAux (env : Env) : Nat → List String → String → List String +private +def closureAux + (env : Env) + : Nat → -- fuel, bounded by theory count + List String → -- theories already visited + String → -- theory name to process + List String | 0, seen, _ => seen | fuel + 1, seen, name => if seen.contains name then seen @@ -144,31 +187,53 @@ private def closureAux (env : Env) : Nat → List String → String → List Str (fun seen imported => closureAux env fuel seen imported) seen name :: seen -private def visibleTheoryNames (env : Env) (roots : List String) : List String := +private +def visibleTheoryNames + (env : Env) + (roots : List String) + : List String + := let fuel := env.theories.length + roots.length + 1 let names := roots.foldl (fun seen root => closureAux env fuel seen root) [] (core.name :: names).eraseDups -def lookupIn? (env : Env) (roots : List String) (name : String) : Option (String × Symbol) := +def lookupIn? + (env : Env) + (roots : List String) + (name : String) + : Option (String × Symbol) + := visibleTheoryNames env roots |>.findSome? fun theoryName => do let theory ← lookupTheory? env theoryName let symbol ← theory.symbols.find? (fun symbol => symbol.name == name) return (theory.name, symbol) -def symbolsIn (env : Env) (roots : List String) : List (String × Symbol) := +def symbolsIn + (env : Env) + (roots : List String) + : List (String × Symbol) + := visibleTheoryNames env roots |>.flatMap fun theoryName => match lookupTheory? env theoryName with | none => [] | some theory => theory.symbols.map (theory.name, ·) -def declarationsIn (env : Env) (roots : List String) : List (String × Declaration) := +def declarationsIn + (env : Env) + (roots : List String) + : List (String × Declaration) + := visibleTheoryNames env roots |>.flatMap fun theoryName => match lookupTheory? env theoryName with | none => [] | some theory => theory.declarations.map (theory.name, ·) -def namesWithApplication (env : Env) (roots : List String) (application : ApplicationKind) : - List String := +def namesWithApplication + (env : Env) + (roots : List String) + (application : ApplicationKind) + : List String + := let symbols := (symbolsIn env roots).filterMap fun (_, symbol) => if symbol.application == some application then some symbol.name else none let definitions := if application == .total then @@ -179,37 +244,66 @@ def namesWithApplication (env : Env) (roots : List String) (application : Applic else [] (symbols ++ definitions).eraseDups -def definedness? (env : Env) (roots : List String) (name : String) : List Definedness := +def definedness? + (env : Env) + (roots : List String) + (name : String) + : List Definedness + := (lookupIn? env roots name).map (·.2.definedness) |>.getD [] -def declaration? (env : Env) (roots : List String) (name : String) : - Option (String × Declaration) := +def declaration? + (env : Env) + (roots : List String) + (name : String) + : Option (String × Declaration) + := declarationsIn env roots |>.find? (·.2.name == name) -def constructor? (env : Env) (roots : List String) (name : String) : - Option (String × Datatype × Constructor) := +def constructor? + (env : Env) + (roots : List String) + (name : String) + : Option (String × Datatype × Constructor) + := declarationsIn env roots |>.findSome? fun (owner, declaration) => match declaration with | .dataType datatype => datatype.constructors.find? (·.name == name) |>.map (owner, datatype, ·) | _ => none -def isDeclarationIn (env : Env) (roots : List String) (name : String) : Bool := +def isDeclarationIn + (env : Env) + (roots : List String) + (name : String) + : Bool + := (declaration? env roots name).isSome -def definitionsIn (env : Env) (roots : List String) : List (String × Definition) := +def definitionsIn + (env : Env) + (roots : List String) + : List (String × Definition) + := declarationsIn env roots |>.filterMap fun (owner, declaration) => match declaration with | .definitionDecl value => some (owner, value) | _ => none -def rewriteRulesIn (env : Env) (roots : List String) : List (String × Rule) := +def rewriteRulesIn + (env : Env) + (roots : List String) + : List (String × Rule) + := declarationsIn env roots |>.filterMap fun (owner, declaration) => match declaration with | .ruleDecl value => if value.kind == .rewrite then some (owner, value) else none | _ => none -private def termSize : Formula.Term → Nat +private +def termSize + : Formula.Term → + Nat | .id _ | .num _ => 1 | .bin _ left right => termSize left + termSize right + 1 | .pre _ term | .post _ term => termSize term + 1 @@ -218,7 +312,11 @@ private def termSize : Formula.Term → Nat | .set terms => terms.foldl (fun size term => size + termSize term) 1 | .bind _ pattern body => termSize pattern + termSize body + 1 -private def patternShape : Formula.Term → Formula.Term → Bool +private +def patternShape + : Formula.Term → -- left-hand pattern + Formula.Term → -- right-hand pattern + Bool | .id _, .id _ => true | .bin leftOp leftA leftB, .bin rightOp rightA rightB => leftOp == rightOp && patternShape leftA rightA && patternShape leftB rightB @@ -226,7 +324,12 @@ private def patternShape : Formula.Term → Formula.Term → Bool mutual -private def referencesBound : Nat → List String → Formula.Term → Bool +private +def referencesBound + : Nat → -- fuel, bounded by term size + List String → -- bound variable names + Formula.Term → -- term to search + Bool | 0, _, _ => false | _ + 1, bound, .id name => bound.contains name | _ + 1, _, .num _ => false @@ -245,7 +348,12 @@ private def referencesBound : Nat → List String → Formula.Term → Bool termination_by fuel _ _ => fuel -private def referencesBoundList : Nat → List String → List Formula.Term → Bool +private +def referencesBoundList + : Nat → -- fuel, bounded by term size + List String → -- bound variable names + List Formula.Term → -- terms to search + Bool | 0, _, _ => false | _ + 1, _, [] => false | fuel + 1, bound, term :: terms => @@ -255,9 +363,16 @@ termination_by fuel _ _ => fuel end -private def matchRewrite : Nat → List String → List (String × String) → List String → - Formula.Term → Formula.Term → List (String × Formula.Term) → - Option (List (String × Formula.Term)) +private +def matchRewrite + : Nat → -- fuel, bounded by term size + List String → -- rule's parameter names + List (String × String) → -- pattern-name to target-name bindings + List String → -- names already bound on target side + Formula.Term → -- rule's left-hand-side pattern + Formula.Term → -- target term being matched + List (String × Formula.Term) → -- substitutions found so far + Option (List (String × Formula.Term)) | 0, _, _, _, _, _, _ => none | _ + 1, parameters, bound, targetBound, .id name, target, substitutions => match bound.find? (·.1 == name) with @@ -325,8 +440,12 @@ private def matchRewrite : Nat → List String → List (String × String) → L | _, _, _, _, _, _, _ => none termination_by fuel _ _ _ _ _ _ => fuel -private def rewriteRoot (rules : List (String × Rule)) (term : Formula.Term) : - Option Formula.Term := +private +def rewriteRoot + (rules : List (String × Rule)) + (term : Formula.Term) + : Option Formula.Term + := rules.findSome? fun (_, rule) => do let lhs ← rule.lhs let rhs ← rule.rhs @@ -335,7 +454,12 @@ private def rewriteRoot (rules : List (String × Rule)) (term : Formula.Term) : let substitutions ← matchRewrite fuel (rule.parameters.map (·.1)) [] [] lhs term [] some (Formula.subst substitutions rhs) -private def normalizeAux (rules : List (String × Rule)) : Nat → Formula.Term → Formula.Term +private +def normalizeAux + (rules : List (String × Rule)) + : Nat → -- fuel, bounds rewrite iterations + Formula.Term → -- term being rewritten + Formula.Term | 0, term => term | fuel + 1, term => match rewriteRoot rules term with @@ -354,33 +478,64 @@ private def normalizeAux (rules : List (String × Rule)) : Nat → Formula.Term (normalizeAux rules fuel body) | _ => term -def normalize (env : Env) (roots : List String) (term : Formula.Term) : Formula.Term := +def normalize + (env : Env) + (roots : List String) + (term : Formula.Term) + : Formula.Term + := let rules := rewriteRulesIn env roots normalizeAux rules (termSize term * (rules.length + 1) + 1) term -private def declarationNames (declarations : List Declaration) : List String := +private +def declarationNames + (declarations : List Declaration) + : List String + := declarations.map Declaration.name -private def constructorNames (datatype : Datatype) : List String := +private +def constructorNames + (datatype : Datatype) + : List String + := datatype.constructors.map (·.name) -private def declarationParts (declaration : Declaration) : List String := +private +def declarationParts + (declaration : Declaration) + : List String + := match declaration with | .dataType datatype => datatype.name :: constructorNames datatype | .definitionDecl definition => [definition.name] | .ruleDecl rule => [rule.name] -private def declarationNamesAll (declarations : List Declaration) : List String := +private +def declarationNamesAll + (declarations : List Declaration) + : List String + := declarations.flatMap declarationParts -private def isDefinitionName (declarations : List Declaration) (name : String) : Bool := +private +def isDefinitionName + (declarations : List Declaration) + (name : String) + : Bool + := declarations.any fun declaration => match declaration with | .definitionDecl definition => definition.name == name | _ => false private def duplicateName (names : List String) : Option String := firstDuplicate [] names -private def typeParameterError (name : String) (parameters : List String) : Option String := +private +def typeParameterError + (name : String) + (parameters : List String) + : Option String + := if parameters.any (· == "") then some s!"declaration `{name}` has an empty type parameter" else match duplicateName parameters with @@ -389,7 +544,11 @@ private def typeParameterError (name : String) (parameters : List String) : Opti | some symbol => some s!"type parameter `{symbol.name}` is reserved by the core prelude" | none => none -private def declarationError (declaration : Declaration) : Option String := +private +def declarationError + (declaration : Declaration) + : Option String + := match declaration with | .dataType datatype => if datatype.constructors.isEmpty then @@ -420,7 +579,12 @@ private def declarationError (declaration : Declaration) : Option String := | some name => some s!"rule parameter `{name}` is repeated" | none => none -private def validate (env : Env) (theory : Spec) : List String := +private +def validate + (env : Env) + (theory : Spec) + : List String + := let names := theory.symbols.map (·.name) let declarationNames := declarationNamesAll theory.declarations let duplicate := firstDuplicate [] names @@ -494,26 +658,51 @@ private def validate (env : Env) (theory : Spec) : List String := | some name => errors ++ [s!"theory `{name}` is not registered"] | none => errors -def add (env : Env) (theory : Spec) : Except EventB.Error Env := +def add + (env : Env) + (theory : Spec) + : Except EventB.Error Env + := let theory := canonicalize theory match validate env theory with | error :: _ => .error (EventB.Error.theory error) | [] => .ok { env with theories := theory :: env.theories } -def register (specs : List Spec) : Except EventB.Error Env := +def register + (specs : List Spec) + : Except EventB.Error Env + := specs.foldlM add empty /-- Compatibility lookup for callers that have no component-specific scope yet. -/ -def lookup? (env : Env) (name : String) : Option (String × Symbol) := +def lookup? + (env : Env) + (name : String) + : Option (String × Symbol) + := lookupIn? env (env.theories.map (·.name)) name -def isIdentifierIn (env : Env) (roots : List String) (name : String) : Bool := +def isIdentifierIn + (env : Env) + (roots : List String) + (name : String) + : Bool + := (lookupIn? env roots name).isSome || isDeclarationIn env roots name -def isIdentifier (env : Env) (name : String) : Bool := +def isIdentifier + (env : Env) + (name : String) + : Bool + := isIdentifierIn env (env.theories.map (·.name)) name -def typeIn? (env : Env) (roots : List String) (name : String) : Option Typing.Ty := +def typeIn? + (env : Env) + (roots : List String) + (name : String) + : Option Typing.Ty + := match (lookupIn? env roots name).bind (·.2.type) with | some type => some type | none => @@ -521,7 +710,11 @@ def typeIn? (env : Env) (roots : List String) (name : String) : Option Typing.Ty | some (_, datatype, constructor) => some (constructor.type datatype) | none => (declaration? env roots name).bind (·.2.expressionType?) -def type? (env : Env) (name : String) : Option Typing.Ty := +def type? + (env : Env) + (name : String) + : Option Typing.Ty + := typeIn? env (env.theories.map (·.name)) name #guard (lookup? empty "BOOL").isSome @@ -530,7 +723,10 @@ def type? (env : Env) (name : String) : Option Typing.Ty := #guard (lookupIn? empty [] "notVisible").isNone #guard namesWithApplication empty [] .total |>.contains "bool" -private def imported : Env := +private +def imported + : Env + := match add empty { name := "Base", symbols := [{ name := "LIMIT", kind := .constant, type := some .int @@ -562,7 +758,10 @@ private def imported : Env := | .error _ => true | .ok _ => false -private def declarationEnv : Env := +private +def declarationEnv + : Env + := match add empty { name := "Data", declarations := [.dataType (Datatype.mk "Colour" [] @@ -578,7 +777,10 @@ private def declarationEnv : Env := #guard typeIn? declarationEnv ["Data"] "zero" == some .int #guard namesWithApplication declarationEnv ["Data"] .total |>.contains "zero" -private def rewriteEnv : Env := +private +def rewriteEnv + : Env + := match add empty { name := "Rewrite", declarations := [.ruleDecl { name := "add_zero", kind := .rewrite, parameters := [("x", .int)] @@ -586,7 +788,10 @@ private def rewriteEnv : Env := | .ok env => env | .error _ => empty -private def binderRewriteEnv : Env := +private +def binderRewriteEnv + : Env + := match add empty { name := "BinderRewrite", declarations := [.ruleDecl @@ -611,7 +816,11 @@ private def binderRewriteEnv : Env := | .ok env => env | .error _ => empty -private def parseFormula! (source : String) : Formula.Term := +private +def parseFormula! + (source : String) + : Formula.Term + := (Formula.parse source).toOption.getD (.id "?") #guard Definition.type diff --git a/EventB/Theory/Embed.lean b/EventB/Theory/Embed.lean index 3358fb8..22ab4cf 100644 --- a/EventB/Theory/Embed.lean +++ b/EventB/Theory/Embed.lean @@ -41,17 +41,30 @@ structure KernelRule where obligations : List Validate.Obligation := [] deriving Repr -private def reportText (report : Validate.Report) : String := +private +def reportText + (report : Validate.Report) + : String + := String.intercalate "; " (report.errors.map (·.message)) -private def requireValid (env : Theory.Env) (roots : List String) - (declaration : Declaration) : MetaM Unit := do +private +def requireValid + (env : Theory.Env) + (roots : List String) + (declaration : Declaration) + : MetaM Unit + := do let report := Validate.validateDeclaration env roots declaration unless report.isValid do throwError s!"invalid theory declaration: {reportText report}" -private def checkTypeParameters (context : KernelContext) (parameters : List String) : - MetaM Unit := do +private +def checkTypeParameters + (context : KernelContext) + (parameters : List String) + : MetaM Unit + := do for parameter in parameters do match context.signature.carriers.find? (·.1 == parameter) with | none => @@ -60,9 +73,14 @@ private def checkTypeParameters (context : KernelContext) (parameters : List Str unless (← inferType value).isSort do throwError s!"Lean instantiation for type parameter `{parameter}` is not a type" -private def withParameters {α : Type} (context : KernelContext) +private +def withParameters + {α : Type} + (context : KernelContext) (parameters : List (String × Ty)) - (continuation : KernelContext → List Expr → MetaM α) : MetaM α := + (continuation : KernelContext → List Expr → MetaM α) + : MetaM α + := match parameters with | [] => continuation context [] | (name, ty) :: rest => do @@ -72,22 +90,36 @@ private def withParameters {α : Type} (context : KernelContext) withParameters context rest fun context values => continuation context (value :: values) -private def functionType (context : KernelContext) (parameters : List (String × Ty)) - (result : Ty) : MetaM Expr := do +private +def functionType + (context : KernelContext) + (parameters : List (String × Ty)) + (result : Ty) + : MetaM Expr + := do let result ← leanType context result parameters.foldrM (fun (_, ty) result => do let type ← leanType context ty mkArrow type result) result -private def checkedFunction (context : KernelContext) (parameters : List (String × Ty)) - (result : Ty) (value : Expr) : MetaM Unit := do +private +def checkedFunction + (context : KernelContext) + (parameters : List (String × Ty)) + (result : Ty) + (value : Expr) + : MetaM Unit + := do let expected ← functionType context parameters result let actual ← inferType value unless ← isDefEq actual expected do throwError s!"translated declaration has type {actual}, expected {expected}" -def translateDefinition (context : KernelContext) (definition : Definition) : - MetaM KernelDefinition := do +def translateDefinition + (context : KernelContext) + (definition : Definition) + : MetaM KernelDefinition + := do requireValid context.theory context.roots (.definitionDecl definition) checkTypeParameters context definition.typeParameters withParameters context definition.parameters fun bodyContext parameters => do @@ -99,11 +131,18 @@ def translateDefinition (context : KernelContext) (definition : Definition) : checkedFunction context definition.parameters definition.result value pure { name := definition.name, kind := definition.kind, result := definition.result, value } -private def productType : List Ty → Option Ty +private +def productType + : List Ty → + Option Ty | [] => none | type :: types => some (types.foldl (fun result next => .prod result next) type) -private def productValues (value : Expr) : Nat → MetaM (List Expr) +private +def productValues + (value : Expr) + : Nat → + MetaM (List Expr) | 0 => pure [] | 1 => pure [value] | count + 1 => do @@ -111,16 +150,26 @@ private def productValues (value : Expr) : Nat → MetaM (List Expr) let right ← mkAppM ``Prod.snd #[value] return (← productValues left count) ++ [right] -private def uncurried (context : KernelContext) (parameters : List (String × Ty)) - (value : Expr) : MetaM Expr := do +private +def uncurried + (context : KernelContext) + (parameters : List (String × Ty)) + (value : Expr) + : MetaM Expr + := do let some argumentType := productType (parameters.map (·.2)) | unreachable! withLocalDeclD `arguments (← leanType context argumentType) fun arguments => do let values ← productValues arguments parameters.length let applied := values.foldl (fun function argument => mkApp function argument) value mkLambdaFVars #[arguments] applied -private def addDefinitionBinding (context : KernelContext) (definition : Definition) - (translated : KernelDefinition) : MetaM KernelContext := +private +def addDefinitionBinding + (context : KernelContext) + (definition : Definition) + (translated : KernelDefinition) + : MetaM KernelContext + := match definition.parameters with | [] => pure { context with bindings := @@ -142,26 +191,44 @@ private def addDefinitionBinding (context : KernelContext) (definition : Definit /-- Translate all visible definitional declarations and add their Lean denotations to the formula context. Declarations are resolved in theory order, so a definition may depend on an earlier definition while still requiring explicit model and datatype denotations. -/ -def translateDefinitions (context : KernelContext) : MetaM KernelContext := do +def translateDefinitions + (context : KernelContext) + : MetaM KernelContext + := do let mut resolved := context for (_, definition) in Theory.definitionsIn context.theory context.roots do let translated ← translateDefinition resolved definition resolved ← addDefinitionBinding resolved definition translated pure resolved -private def constructorType (context : KernelContext) (arguments : List Ty) (result : Expr) : - MetaM Expr := do +private +def constructorType + (context : KernelContext) + (arguments : List Ty) + (result : Expr) + : MetaM Expr + := do arguments.foldrM (fun type result => do let type ← leanType context type mkArrow type result) result -private def namedParameters : Nat → List Ty → List (String × Ty) +private +def namedParameters + : Nat → -- index for auto-generated arg names + List Ty → -- argument types to name + List (String × Ty) | _, [] => [] | index, type :: types => ("arg" ++ toString index, type) :: namedParameters (index + 1) types -private def checkedUncurriedFunction (context : KernelContext) (name : String) - (argument result : Ty) (value : Expr) : MetaM Unit := do +private +def checkedUncurriedFunction + (context : KernelContext) + (name : String) + (argument result : Ty) + (value : Expr) + : MetaM Unit + := do let argumentType ← leanType context argument let resultType ← leanType context result let actual ← inferType value @@ -169,8 +236,13 @@ private def checkedUncurriedFunction (context : KernelContext) (name : String) throwError s!"constructor `{name}` has Lean type {actual}, " ++ s!"expected {argumentType} → {resultType}" -def checkDatatype (context : KernelContext) (datatype : Datatype) (value : Expr) - (constructors : List (String × Expr)) : MetaM KernelDatatype := do +def checkDatatype + (context : KernelContext) + (datatype : Datatype) + (value : Expr) + (constructors : List (String × Expr)) + : MetaM KernelDatatype + := do requireValid context.theory context.roots (.dataType datatype) checkTypeParameters context datatype.parameters unless (← inferType value).isSort do @@ -189,8 +261,13 @@ def checkDatatype (context : KernelContext) (datatype : Datatype) (value : Expr) pure { name := datatype.name, value, constructors := checked } /-- Check datatype denotations and add their constructors to a formula context. -/ -def addDatatypeBindings (context : KernelContext) (datatype : Datatype) (value : Expr) - (constructors : List (String × Expr)) : MetaM KernelContext := do +def addDatatypeBindings + (context : KernelContext) + (datatype : Datatype) + (value : Expr) + (constructors : List (String × Expr)) + : MetaM KernelContext + := do let checked ← checkDatatype context datatype value constructors let mut resolved := context for (declaration, constructor) in datatype.constructors.zip checked.constructors do @@ -216,12 +293,20 @@ def addDatatypeBindings (context : KernelContext) (datatype : Datatype) (value : value := function } :: resolved.functions } pure resolved -private def implications : List Expr → Expr → MetaM Expr +private +def implications + : List Expr → -- premises to chain as arrows + Expr → -- final conclusion type + MetaM Expr | [], conclusion => pure conclusion | premise :: premises, conclusion => do mkArrow premise (← implications premises conclusion) -def translateRule (context : KernelContext) (rule : Rule) : MetaM KernelRule := do +def translateRule + (context : KernelContext) + (rule : Rule) + : MetaM KernelRule + := do requireValid context.theory context.roots (.ruleDecl rule) checkTypeParameters context rule.typeParameters withParameters context rule.parameters fun bodyContext parameters => do diff --git a/EventB/Theory/Rodin.lean b/EventB/Theory/Rodin.lean index 7184c15..ce86984 100644 --- a/EventB/Theory/Rodin.lean +++ b/EventB/Theory/Rodin.lean @@ -17,38 +17,73 @@ open EventB EventB.Formula EventB.Prelude EventB.Typing private def ns := "org.eventb.theory.core." private def tag (name : String) : String := ns ++ name -private def attr (elem : XmlElem) (names : List String) : Option String := +private +def attr + (elem : XmlElem) + (names : List String) + : Option String + := names.findSome? elem.attr? -private def required (path : List String) (elem : XmlElem) (names : List String) : - Except String String := +private +def required + (path : List String) + (elem : XmlElem) + (names : List String) + : Except String String + := match attr elem names with | some value => pure value | none => .error s!"{String.intercalate "/" path}: missing `{names.head!}`" -private def checkChildren (path : List String) (elem : XmlElem) (allowed : List String) : - Except String Unit := +private +def checkChildren + (path : List String) + (elem : XmlElem) + (allowed : List String) + : Except String Unit + := match elem.children.find? (fun child => !allowed.contains child.tag) with | none => pure () | some child => .error s!"{String.intercalate "/" path}: unsupported child `{child.tag}`" -private def parseType (path : List String) (elem : XmlElem) : Except String Ty := do +private +def parseType + (path : List String) + (elem : XmlElem) + : Except String Ty + := do let source ← required path elem ["type", "org.eventb.core.type"] match Ty.parse source with | some type => pure type | none => .error s!"{String.intercalate "/" path}: invalid type `{source}`" -private def parseFormula (path : List String) (source : String) : Except String Term := +private +def parseFormula + (path : List String) + (source : String) + : Except String Term + := match Formula.parse source with | .ok term => pure term | .error error => .error s!"{String.intercalate "/" path}: invalid formula: {error}" -private def parseFormulaAttr (path : List String) (elem : XmlElem) (name : String) : - Except String Term := do +private +def parseFormulaAttr + (path : List String) + (elem : XmlElem) + (name : String) + : Except String Term + := do let source ← required path elem [name] parseFormula path source -private def parseSymbol (path : List String) (elem : XmlElem) : Except String Symbol := do +private +def parseSymbol + (path : List String) + (elem : XmlElem) + : Except String Symbol + := do let _ ← checkChildren path elem [] let name ← required path elem ["identifier", "name"] let kind ← required path elem ["kind"] @@ -70,8 +105,12 @@ private def parseSymbol (path : List String) (elem : XmlElem) : Except String Sy pure (Symbol.mk name kind type description application [] (SymbolId.unqualified name) (SourceRange.synthetic "Rodin theory")) -private def parseConstructor (path : List String) (elem : XmlElem) : - Except String Constructor := do +private +def parseConstructor + (path : List String) + (elem : XmlElem) + : Except String Constructor + := do let _ ← checkChildren path elem [tag "constructorArgument"] let name ← required path elem ["identifier", "name"] let arguments ← elem.children.mapM fun child => do @@ -81,8 +120,12 @@ private def parseConstructor (path : List String) (elem : XmlElem) : parseType childPath child pure { name, arguments } -private def parseDatatype (path : List String) (elem : XmlElem) : - Except String Declaration := do +private +def parseDatatype + (path : List String) + (elem : XmlElem) + : Except String Declaration + := do let _ ← checkChildren path elem [tag "typeParameter", tag "datatypeConstructor"] let name ← required path elem ["identifier", "name"] let parameters ← elem.children.filter (·.tag == tag "typeParameter") |>.mapM fun child => @@ -91,20 +134,32 @@ private def parseDatatype (path : List String) (elem : XmlElem) : (parseConstructor (path ++ ["datatypeConstructor"])) pure (.dataType { name, parameters, constructors }) -private def parseParameters (path : List String) (elem : XmlElem) : - Except String (List (String × Ty)) := +private +def parseParameters + (path : List String) + (elem : XmlElem) + : Except String (List (String × Ty)) + := elem.children.filter (·.tag == tag "parameter") |>.mapM fun child => do let name ← required (path ++ [child.tag]) child ["identifier", "name"] let type ← parseType (path ++ [child.tag]) child pure (name, type) -private def parseTypeParameters (path : List String) (elem : XmlElem) : - Except String (List String) := +private +def parseTypeParameters + (path : List String) + (elem : XmlElem) + : Except String (List String) + := elem.children.filter (·.tag == tag "typeParameter") |>.mapM fun child => required (path ++ [child.tag]) child ["identifier", "name"] -private def parseDefinition (path : List String) (elem : XmlElem) : - Except String Declaration := do +private +def parseDefinition + (path : List String) + (elem : XmlElem) + : Except String Declaration + := do let _ ← checkChildren path elem [tag "typeParameter", tag "parameter"] let name ← required path elem ["identifier", "name"] let typeParameters ← parseTypeParameters path elem @@ -114,8 +169,13 @@ private def parseDefinition (path : List String) (elem : XmlElem) : let kind := if attr elem ["kind"] == some "axiomatic" then .axiomatic else .definitional pure (.definitionDecl { name, typeParameters, parameters, result, body, kind }) -private def parseRule (path : List String) (elem : XmlElem) (kind : DeclarationKind) : - Except String Declaration := do +private +def parseRule + (path : List String) + (elem : XmlElem) + (kind : DeclarationKind) + : Except String Declaration + := do let _ ← checkChildren path elem [tag "typeParameter", tag "parameter", tag "premise"] let name ← required path elem ["identifier", "name"] let typeParameters ← parseTypeParameters path elem @@ -133,8 +193,12 @@ private def parseRule (path : List String) (elem : XmlElem) (kind : DeclarationK | _ => some <$> parseFormulaAttr path elem "conclusion" pure (.ruleDecl { name, kind, typeParameters, parameters, premises, lhs, rhs, conclusion }) -private def parseChild (path : List String) (elem : XmlElem) : Except String (Option String × - Option Symbol × Option Declaration) := do +private +def parseChild + (path : List String) + (elem : XmlElem) + : Except String (Option String × Option Symbol × Option Declaration) + := do if elem.tag == tag "import" then let name ← required path elem ["identifier", "name"] pure (some name, none, none) @@ -152,7 +216,11 @@ private def parseChild (path : List String) (elem : XmlElem) : Except String (Op pure (none, none, some (← parseRule path elem .theorem)) else .error s!"{String.intercalate "/" path}: unsupported theory child `{elem.tag}`" -private def parseRoot (root : XmlElem) : Except String Spec := do +private +def parseRoot + (root : XmlElem) + : Except String Spec + := do unless root.tag == tag "theoryFile" || root.tag == tag "theoryRoot" do throw s!"root is not a Rodin theory file: `{root.tag}`" let name ← required [root.tag] root ["identifier", "name"] @@ -163,7 +231,11 @@ private def parseRoot (root : XmlElem) : Except String Spec := do let declarations := values.filterMap (fun value => value.2.2) pure (Theory.canonicalize { name, imports, symbols, declarations }) -def importSpec (env : Env) (source : String) : Except EventB.Error Spec := +def importSpec + (env : Env) + (source : String) + : Except EventB.Error Spec + := match parseXmlString source with | .error error => .error (EventB.Error.theory s!"invalid Rodin theory XML: {error.pretty source.toUTF8}") @@ -176,7 +248,11 @@ def importSpec (env : Env) (source : String) : Except EventB.Error Spec := else .error (EventB.Error.theory (report.errors.map (·.message) |>.intersperse "; " |>.foldl (· ++ ·) "")) -private def escape (source : String) : String := +private +def escape + (source : String) + : String + := source.toList.foldl (fun output char => output ++ match char with | '&' => "&" | '<' => "<" @@ -185,13 +261,21 @@ private def escape (source : String) : String := | '\'' => "'" | char => char.toString) "" -private def attrs (values : List (String × String)) : String := +private +def attrs + (values : List (String × String)) + : String + := values.foldl (fun output (name, value) => output ++ " " ++ name ++ "=\"" ++ escape value ++ "\"") "" mutual -private def render : Nat → XmlElem → Except String String +private +def render + : Nat → -- fuel, bounds XML nesting depth + XmlElem → -- element to render + Except String String | 0, _ => .error "Rodin theory XML is too deeply nested" | fuel + 1, elem => do let head := "<" ++ elem.tag ++ attrs elem.attrs @@ -200,7 +284,11 @@ private def render : Nat → XmlElem → Except String String let children ← renderChildren fuel elem.children pure (head ++ ">" ++ children ++ "") -private def renderChildren : Nat → List XmlElem → Except String String +private +def renderChildren + : Nat → -- fuel, bounds XML nesting depth + List XmlElem → -- child elements to render + Except String String | 0, _ => .error "Rodin theory XML is too deeply nested" | _, [] => pure "" | fuel + 1, child :: children => do @@ -210,7 +298,11 @@ private def renderChildren : Nat → List XmlElem → Except String String end -private def symbolElem (symbol : Symbol) : XmlElem := +private +def symbolElem + (symbol : Symbol) + : XmlElem + := { tag := tag "symbol" attrs := [("identifier", symbol.name), ("kind", match symbol.kind with | .carrierSet => "carrierSet" @@ -223,26 +315,45 @@ private def symbolElem (symbol : Symbol) : XmlElem := | .wellDefined => "wellDefined")) |>.toList) children := [] } -private def constructorElem (constructor : Constructor) : XmlElem := +private +def constructorElem + (constructor : Constructor) + : XmlElem + := { tag := tag "datatypeConstructor", attrs := [("identifier", constructor.name)] children := constructor.arguments.map fun type => { tag := tag "constructorArgument", attrs := [("type", type.print)], children := [] } } -private def datatypeElem (datatype : Datatype) : XmlElem := +private +def datatypeElem + (datatype : Datatype) + : XmlElem + := let parameters : List XmlElem := datatype.parameters.map fun parameter => { tag := tag "typeParameter", attrs := [("identifier", parameter)], children := [] } { tag := tag "datatypeDefinition", attrs := [("identifier", datatype.name)], children := parameters ++ datatype.constructors.map constructorElem } -private def typeParameterElems (parameters : List String) : List XmlElem := +private +def typeParameterElems + (parameters : List String) + : List XmlElem + := parameters.map fun parameter => { tag := tag "typeParameter", attrs := [("identifier", parameter)], children := [] } -private def parameterElem (parameter : String × Ty) : XmlElem := +private +def parameterElem + (parameter : String × Ty) + : XmlElem + := { tag := tag "parameter", attrs := [("identifier", parameter.1), ("type", parameter.2.print)], children := [] } -private def declarationElems : Declaration → List XmlElem +private +def declarationElems + : Declaration → + List XmlElem | .dataType datatype => [datatypeElem datatype] | .definitionDecl definition => @@ -268,7 +379,11 @@ private def declarationElems : Declaration → List XmlElem rule.premises.map fun premise => XmlElem.mk (tag "premise") [("formula", Formula.print premise)] [])] -def exportSpec (env : Env) (spec : Spec) : Except EventB.Error String := do +def exportSpec + (env : Env) + (spec : Spec) + : Except EventB.Error String + := do let report := Validate.validateSpec env spec if report.isValid then let root : XmlElem := diff --git a/EventB/Theory/Validate.lean b/EventB/Theory/Validate.lean index b47c9db..ca02714 100644 --- a/EventB/Theory/Validate.lean +++ b/EventB/Theory/Validate.lean @@ -58,27 +58,47 @@ structure Report where obligations : List Obligation := [] deriving BEq, Repr, Inhabited -def Report.isValid (report : Report) : Bool := +def Report.isValid + (report : Report) + : Bool + := report.issues.all (·.severity != .error) -def Report.errors (report : Report) : List Issue := +def Report.errors + (report : Report) + : List Issue + := report.issues.filter (·.severity == .error) -def Report.append (left right : Report) : Report := +def Report.append + (left right : Report) + : Report + := { issues := left.issues ++ right.issues obligations := left.obligations ++ right.obligations } -private def error (declaration field message : String) : Issue := +private +def error + (declaration field message : String) + : Issue + := { declaration, field, message } -private def firstDuplicate (seen : List String) : List String → Option String +private +def firstDuplicate + (seen : List String) + : List String → + Option String | [] => none | name :: names => if seen.contains name then some name else firstDuplicate (name :: seen) names mutual -private def termSize : Term → Nat +private +def termSize + : Term → + Nat | .id _ | .num _ => 1 | .bin _ left right => termSize left + termSize right + 1 | .pre _ term | .post _ term => termSize term + 1 @@ -87,30 +107,49 @@ private def termSize : Term → Nat | .set terms => termSizeList terms + 1 | .bind _ pattern body => termSize pattern + termSize body + 1 -private def termSizeList : List Term → Nat +private +def termSizeList + : List Term → + Nat | [] => 0 | term :: terms => termSize term + termSizeList terms end -private def parameterIssues (name : String) (parameters : List (String × Ty)) : List Issue := +private +def parameterIssues + (name : String) + (parameters : List (String × Ty)) + : List Issue + := match firstDuplicate [] (parameters.map (·.1)) with | some parameter => [error name "parameters" s!"parameter `{parameter}` is repeated"] | none => [] -private def hasMVar : Ty → Bool +private +def hasMVar + : Ty → + Bool | .mvar _ => true | .pow type => hasMVar type | .prod left right => hasMVar left || hasMVar right | _ => false -private def typeNames : Ty → List String +private +def typeNames + : Ty → + List String | .given name => [name] | .pow type => typeNames type | .prod left right => typeNames left ++ typeNames right | _ => [] -private def visibleTypeNames (theory : Theory.Env) (roots : List String) : List String := +private +def visibleTypeNames + (theory : Theory.Env) + (roots : List String) + : List String + := let carriers := (Theory.symbolsIn theory roots).filterMap fun (_, symbol) => if symbol.kind == .carrierSet then some symbol.name else none let datatypes := (Theory.declarationsIn theory roots).filterMap fun (_, declaration) => @@ -119,7 +158,12 @@ private def visibleTypeNames (theory : Theory.Env) (roots : List String) : List | _ => none (carriers ++ datatypes).eraseDups -private def typeParameterIssues (name : String) (parameters : List String) : List Issue := +private +def typeParameterIssues + (name : String) + (parameters : List String) + : List Issue + := let empty := parameters.find? (· == "") let duplicate := firstDuplicate [] parameters let reserved := parameters.find? (fun parameter => @@ -135,8 +179,15 @@ private def typeParameterIssues (name : String) (parameters : List String) : Lis s!"type parameter `{parameter}` is reserved by the core prelude"] | none => [] -private def typeIssues (theory : Theory.Env) (roots : List String) - (name field : String) (parameters : List String) (types : List (String × Ty)) : List Issue := +private +def typeIssues + (theory : Theory.Env) + (roots : List String) + (name field : String) + (parameters : List String) + (types : List (String × Ty)) + : List Issue + := let allowed := parameters ++ visibleTypeNames theory roots types.flatMap fun (_, type) => (typeNames type).eraseDups |>.filterMap fun typeName => @@ -144,34 +195,61 @@ private def typeIssues (theory : Theory.Env) (roots : List String) else some (error name field s!"type `{typeName}` is neither a type parameter nor a visible type") -private def unresolvedTypeIssues (name field : String) (types : List (String × Ty)) : - List Issue := +private +def unresolvedTypeIssues + (name field : String) + (types : List (String × Ty)) + : List Issue + := types.flatMap fun (parameter, type) => if hasMVar type then [error name field s!"type of `{parameter}` contains an unresolved metavariable"] else [] -private def unresolvedResultIssue (name field : String) (type : Ty) : List Issue := +private +def unresolvedResultIssue + (name field : String) + (type : Ty) + : List Issue + := if hasMVar type then [error name field "type contains an unresolved metavariable"] else [] -private def expressionIssue (theory : Theory.Env) (roots : List String) - (parameters : List (String × Ty)) (name field : String) (term : Term) : - List Issue := +private +def expressionIssue + (theory : Theory.Env) + (roots : List String) + (parameters : List (String × Ty)) + (name field : String) + (term : Term) + : List Issue + := match inferTermAt theory roots parameters term with | .ok _ => [] | .error message => [error name field s!"not a well-typed expression: {message}"] -private def predicateIssue (theory : Theory.Env) (roots : List String) - (parameters : List (String × Ty)) (name field : String) (term : Term) : List Issue := +private +def predicateIssue + (theory : Theory.Env) + (roots : List String) + (parameters : List (String × Ty)) + (name field : String) + (term : Term) + : List Issue + := match (checkPred term).run { env := parameters, theory, theoryRoots := roots } with | .ok _ => [] | .error message => [error name field s!"not a well-formed predicate: {message}"] -private def definitionIssues (theory : Theory.Env) (roots : List String) - (definition : Definition) : List Issue := +private +def definitionIssues + (theory : Theory.Env) + (roots : List String) + (definition : Definition) + : List Issue + := let typeParameterErrors := typeParameterIssues definition.name definition.typeParameters let parameterErrors := parameterIssues definition.name definition.parameters let parameterTypeErrors := unresolvedTypeIssues definition.name "parameters" @@ -190,8 +268,13 @@ private def definitionIssues (theory : Theory.Env) (roots : List String) typeParameterErrors ++ parameterErrors ++ parameterTypeErrors ++ resultTypeErrors ++ typeErrors ++ bodyErrors ++ resultErrors -private def rewriteIssues (theory : Theory.Env) (roots : List String) - (rule : Rule) : List Issue := +private +def rewriteIssues + (theory : Theory.Env) + (roots : List String) + (rule : Rule) + : List Issue + := let typeParameterErrors := typeParameterIssues rule.name rule.typeParameters let parameterErrors := parameterIssues rule.name rule.parameters let parameterTypeErrors := unresolvedTypeIssues rule.name "parameters" rule.parameters @@ -220,8 +303,13 @@ private def rewriteIssues (theory : Theory.Env) (roots : List String) orientationErrors | _, _ => typeParameterErrors ++ parameterErrors ++ parameterTypeErrors ++ typeErrors ++ missing -private def inferenceIssues (theory : Theory.Env) (roots : List String) - (rule : Rule) : List Issue := +private +def inferenceIssues + (theory : Theory.Env) + (roots : List String) + (rule : Rule) + : List Issue + := let typeParameterErrors := typeParameterIssues rule.name rule.typeParameters let parameterErrors := parameterIssues rule.name rule.parameters let parameterTypeErrors := unresolvedTypeIssues rule.name "parameters" rule.parameters @@ -235,8 +323,13 @@ private def inferenceIssues (theory : Theory.Env) (roots : List String) typeParameterErrors ++ parameterErrors ++ parameterTypeErrors ++ typeErrors ++ premiseErrors ++ conclusionErrors -private def theoremIssues (theory : Theory.Env) (roots : List String) - (rule : Rule) : List Issue := +private +def theoremIssues + (theory : Theory.Env) + (roots : List String) + (rule : Rule) + : List Issue + := let typeParameterErrors := typeParameterIssues rule.name rule.typeParameters let parameterErrors := parameterIssues rule.name rule.parameters let parameterTypeErrors := unresolvedTypeIssues rule.name "parameters" rule.parameters @@ -250,8 +343,13 @@ private def theoremIssues (theory : Theory.Env) (roots : List String) typeParameterErrors ++ parameterErrors ++ parameterTypeErrors ++ typeErrors ++ premiseErrors ++ conclusionErrors -private def datatypeIssues (theory : Theory.Env) (roots : List String) - (datatype : Datatype) : List Issue := +private +def datatypeIssues + (theory : Theory.Env) + (roots : List String) + (datatype : Datatype) + : List Issue + := let names := datatype.constructors.map (·.name) let duplicate := firstDuplicate [] names let duplicateErrors := match duplicate with @@ -272,7 +370,10 @@ private def datatypeIssues (theory : Theory.Env) (roots : List String) duplicateErrors ++ emptyError ++ typeParameterErrors ++ typeErrors ++ constructorTypeErrors -private def declarationObligations : Declaration → List Obligation +private +def declarationObligations + : Declaration → + List Obligation | .dataType datatype => [{ declaration := datatype.name, field := "declaration", kind := .declarationType status := .checked }] @@ -308,7 +409,11 @@ private def declarationObligations : Declaration → List Obligation status := .open, premises := rule.premises, conclusion := rule.conclusion }] | _ => [] -def declaration (theory : Theory.Env) (roots : List String) : Declaration → Report +def declaration + (theory : Theory.Env) + (roots : List String) + : Declaration → + Report | .dataType datatype => { issues := datatypeIssues theory roots datatype obligations := declarationObligations (.dataType datatype) } @@ -323,29 +428,53 @@ def declaration (theory : Theory.Env) (roots : List String) : Declaration → Re | _ => [error rule.name "kind" "declaration kind is not a supported rule"] obligations := declarationObligations (.ruleDecl rule) } -private def declarationParts : Declaration → List String +private +def declarationParts + : Declaration → + List String | .dataType datatype => datatype.name :: datatype.constructors.map (·.name) | .definitionDecl definition => [definition.name] | .ruleDecl rule => [rule.name] -private def specNames (spec : Spec) : List String := +private +def specNames + (spec : Spec) + : List String + := spec.symbols.map (·.name) ++ spec.declarations.flatMap declarationParts -private def specNameIssues (spec : Spec) : List Issue := +private +def specNameIssues + (spec : Spec) + : List Issue + := match firstDuplicate [] (specNames spec) with | some name => [error spec.name "names" s!"name `{name}` is declared more than once"] | none => [] -private def registrationIssues (env : Theory.Env) (spec : Spec) : List Issue := +private +def registrationIssues + (env : Theory.Env) + (spec : Spec) + : List Issue + := match Theory.add env spec with | .ok _ => [] | .error message => [error spec.name "registration" (EventB.Error.render message)] -def validateDeclaration (theory : Theory.Env) (roots : List String) - (value : Declaration) : Report := +def validateDeclaration + (theory : Theory.Env) + (roots : List String) + (value : Declaration) + : Report + := declaration theory roots value -def validateSpec (env : Theory.Env) (spec : Spec) : Report := +def validateSpec + (env : Theory.Env) + (spec : Spec) + : Report + := let registrationErrors := registrationIssues env spec let checkingEnv := match Theory.add env spec with | .ok extended => extended @@ -392,7 +521,10 @@ def validateSpec (env : Theory.Env) (spec : Spec) : Report := rhs := some (.bin "+" (.id "x") (.num 0)) })).issues.any (fun issue => issue.field == "orientation") -private def scopedSpec : Spec := +private +def scopedSpec + : Spec + := { name := "Bounds" symbols := [Symbol.mk "LIMIT" .constant (some .int) "A visible theory constant." none [] (SymbolId.unqualified "LIMIT") SourceRange.synthetic] diff --git a/EventB/Trust.lean b/EventB/Trust.lean index fa9d831..a696814 100644 --- a/EventB/Trust.lean +++ b/EventB/Trust.lean @@ -19,7 +19,9 @@ inductive Mode where | unproved deriving BEq, Repr, Inhabited -def Mode.label : Mode → String +def Mode.label + : Mode → + String | .kernel => "kernel-checked" | .kernelAxiomatized => "kernel-checked-with-axioms" | .smt => "smt-declared" @@ -27,7 +29,9 @@ def Mode.label : Mode → String | .external => "external-declared" | .unproved => "unproved" -def Mode.rank : Mode → Nat +def Mode.rank + : Mode → + Nat | .unproved => 0 | .external | .rodinImported => 1 | .smt => 2 @@ -35,17 +39,29 @@ def Mode.rank : Mode → Nat private def provenanceField (value : String) : String := s!"{value.length}:{value}" -private def provenanceList (values : List String) : String := +private +def provenanceList + (values : List String) + : String + := s!"{values.length}[{String.intercalate "" (values.map provenanceField)}]" -private def modelProvenanceText (model : ModelArtifact) : String := +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 := +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)}" diff --git a/EventB/Trust/Replay.lean b/EventB/Trust/Replay.lean index 99304a6..163189f 100644 --- a/EventB/Trust/Replay.lean +++ b/EventB/Trust/Replay.lean @@ -24,14 +24,22 @@ structure Report where axioms : List String := [] deriving BEq, Repr, Inhabited -private def mkImplications : List Expr → Expr → MetaM Expr +private +def mkImplications + : List Expr → -- premises to chain as arrows + Expr → -- final conclusion type + MetaM Expr | [], conclusion => pure conclusion | premise :: premises, conclusion => do let rest ← mkImplications premises conclusion mkArrow premise rest -private def statement (context : Embedding.KernelContext) - (obligation : POG.Obligation) : MetaM Expr := do +private +def statement + (context : Embedding.KernelContext) + (obligation : POG.Obligation) + : MetaM Expr + := do let goal ← match obligation.goal with | some goal => Embedding.translatePredicate context goal | none => throwError s!"obligation `{obligation.name}` has no translated goal" @@ -39,17 +47,28 @@ private def statement (context : Embedding.KernelContext) mkImplications hypotheses goal /-- Translate a complete obligation sequent without assigning trust evidence. -/ -def translateStatement (context : Embedding.KernelContext) - (obligation : POG.Obligation) : MetaM Expr := +def translateStatement + (context : Embedding.KernelContext) + (obligation : POG.Obligation) + : MetaM Expr + := statement context obligation private def declarationName (declaration : String) : Name := declaration.toName -def proofFingerprint (context : Embedding.KernelContext) (obligation : POG.Obligation) : String := +def proofFingerprint + (context : Embedding.KernelContext) + (obligation : POG.Obligation) + : String + := Trust.fingerprint (obligation.canonical ++ "\nsemantic-context=" ++ context.semanticFingerprint) -private def proofTerm (declaration : String) : MetaM Expr := do +private +def proofTerm + (declaration : String) + : MetaM Expr + := do let name := declarationName declaration let info ← getConstInfo name if info.isUnsafe then @@ -60,7 +79,11 @@ private def proofTerm (declaration : String) : MetaM Expr := do throwError s!"proof declaration `{declaration}` has an inconsistent type" pure proof -private def specializeProof (proof : Expr) : List KernelBinding → MetaM Expr +private +def specializeProof + (proof : Expr) + : List KernelBinding → + MetaM Expr | [] => pure proof | binding :: bindings => do let proofType ← whnf (← inferType proof) @@ -73,14 +96,22 @@ private def specializeProof (proof : Expr) : List KernelBinding → MetaM Expr | _ => throwError s!"proof declaration has no parameter for `{binding.name}`" -private def declarationDependencies (info : ConstantInfo) : Array Name := +private +def declarationDependencies + (info : ConstantInfo) + : Array Name + := match info with | .defnInfo value => value.value.getUsedConstants | .thmInfo value => value.value.getUsedConstants | .opaqueInfo value => value.value.getUsedConstants | _ => #[] -private def axiomNames (initial : List Name) : MetaM NameSet := do +private +def axiomNames + (initial : List Name) + : MetaM NameSet + := do let mut pending := initial let mut seen : NameSet := {} let mut axioms : NameSet := {} @@ -97,24 +128,40 @@ private def axiomNames (initial : List Name) : MetaM NameSet := do pending := pending ++ (declarationDependencies info).toList pure axioms -private def sortedNames (names : NameSet) : List String := +private +def sortedNames + (names : NameSet) + : List String + := names.toList.map (·.toString false) |>.mergeSort (· < ·) -private def actualAxioms (proof : Expr) : MetaM (List String) := do +private +def actualAxioms + (proof : Expr) + : MetaM (List String) + := do let names ← axiomNames proof.getUsedConstants.toList pure (sortedNames names) -private def expectedAxioms (evidence : Evidence) : MetaM (String × List String) := do +private +def expectedAxioms + (evidence : Evidence) + : MetaM (String × List String) + := do match evidence with | .kernel declaration axioms => pure (declaration, axioms.map fun name => (name.toName).toString false) | _ => throwError "kernel replay requires kernel evidence" /-- Validate an in-memory proof term against the translated sequent. -/ -def validateTerm (context : Embedding.KernelContext) - (obligation : POG.Obligation) (proof : Expr) +def validateTerm + (context : Embedding.KernelContext) + (obligation : POG.Obligation) + (proof : Expr) (declaration : String := "") - (declaredAxioms : List String := []) : MetaM Report := do + (declaredAxioms : List String := []) + : MetaM Report + := do unless obligation.diagnostics.isEmpty do throwError s!"obligation `{obligation.name}` has diagnostics" unless obligation.goal.isSome do @@ -136,15 +183,23 @@ def validateTerm (context : Embedding.KernelContext) 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 +private +def replayKernel + (context : Embedding.KernelContext) + (obligation : POG.Obligation) + (evidence : Evidence) + : MetaM Report + := do let (declaration, declaredAxioms) ← expectedAxioms evidence let proof ← proofTerm declaration let proof ← specializeProof proof context.bindings validateTerm context obligation proof declaration declaredAxioms -def validate (context : Embedding.KernelContext) (obligation : POG.Obligation) : - Evidence → MetaM Report +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" @@ -177,8 +232,12 @@ def validate (context : Embedding.KernelContext) (obligation : POG.Obligation) : throwError "evidence metadata is incomplete" pure { mode := evidence.mode, fingerprint := proofFingerprint context obligation } -def validateEntry (context : Embedding.KernelContext) (obligation : POG.Obligation) - (entry : Entry) : MetaM Report := do +def validateEntry + (context : Embedding.KernelContext) + (obligation : POG.Obligation) + (entry : Entry) + : MetaM Report + := do unless entry.component == obligation.component && entry.obligation == obligation.name do throwError s!"evidence entry does not identify `{obligation.component}:{obligation.name}`" unless entry.fingerprint == Trust.fingerprint obligation.canonical do @@ -199,7 +258,9 @@ def validateEntry (context : Embedding.KernelContext) (obligation : POG.Obligati namespace TestFixtures -theorem propextTrue : True := by +theorem propextTrue + : True + := by have h : True = True := propext Iff.rfl exact Eq.mp h True.intro @@ -211,7 +272,10 @@ theorem reflexive (value : Int) : value = value := rfl end TestFixtures -private def replayObligation : POG.Obligation := +private +def replayObligation + : POG.Obligation + := { component := "Replay" name := "true/THM" kind := "THM" diff --git a/EventB/Trust/Rodin.lean b/EventB/Trust/Rodin.lean index d8ec244..604a689 100644 --- a/EventB/Trust/Rodin.lean +++ b/EventB/Trust/Rodin.lean @@ -34,12 +34,21 @@ structure Comparison where scopeAmbiguous : Bool := false deriving BEq, Repr, Inhabited -private def attr (elem : XmlElem) (name : String) : Except String String := +private +def attr + (elem : XmlElem) + (name : String) + : Except String String + := match elem.attr? name with | some value => pure value | none => .error s!"missing `{name}` on `{elem.tag}`" -private def natValue (source : String) : Option Nat := +private +def natValue + (source : String) + : Option Nat + := if source.isEmpty then none else source.toList.foldl (fun result char => do @@ -47,7 +56,11 @@ private def natValue (source : String) : Option Nat := let digit := char.toNat if 48 ≤ digit && digit ≤ 57 then some (value * 10 + digit - 48) else none) (some 0) -private def parseStatus (elem : XmlElem) : Except String Status := do +private +def parseStatus + (elem : XmlElem) + : Except String Status + := do unless elem.tag == "org.eventb.core.psStatus" do throw s!"unsupported proof-status child `{elem.tag}`" unless elem.children.isEmpty do @@ -68,7 +81,10 @@ private def parseStatus (elem : XmlElem) : Except String Status := do | none => .error "missing `org.eventb.core.psManual` on proof-status" pure { name, confidence, manual } -def validateStatuses (statuses : List Status) : Except EventB.Error Unit := +def validateStatuses + (statuses : List Status) + : Except EventB.Error Unit + := let rec go : List Status → Except EventB.Error Unit | [] => pure () | status :: rest => @@ -84,7 +100,10 @@ def validateStatuses (statuses : List Status) : Except EventB.Error Unit := go rest go statuses -def importStatuses (source : String) : Except EventB.Error (List Status) := do +def importStatuses + (source : String) + : Except EventB.Error (List Status) + := do let root ← match parseXmlString source with | .ok root => pure root | .error error => .error (EventB.Error.trust @@ -95,19 +114,35 @@ def importStatuses (source : String) : Except EventB.Error (List Status) := do validateStatuses statuses pure statuses -private def status? (statuses : List Status) (name : String) : Option Status := +private +def status? + (statuses : List Status) + (name : String) + : Option Status + := statuses.find? (·.name == name) -private def duplicateKeys (seen : List String) : List String → List String +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 := +def provenanceDigest + (provenance : Provenance) + : String + := Trust.provenanceFingerprintOf provenance.models provenance.bpo provenance.statuses -def compare (obligations : List POG.Obligation) (statuses : List Status) : Comparison := +def compare + (obligations : List POG.Obligation) + (statuses : List Status) + : Comparison + := let eligible := obligations.filter fun obligation => obligation.diagnostics.isEmpty && obligation.goal.isSome let expected := eligible.map (·.name) @@ -129,8 +164,14 @@ def compare (obligations : List POG.Obligation) (statuses : List Status) : Compa scopeAmbiguous := scopeAmbiguous stale := statuses.countP (fun status => !expected.contains status.name) } -private def attachVerified (ledger : Ledger) (obligation : POG.Obligation) - (provenance : Provenance) (manual : Bool) : Except EventB.Error Ledger := do +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 @@ -161,7 +202,11 @@ private def attachVerified (ledger : Ledger) (obligation : POG.Obligation) { current with mode := .rodinImported, evidence := evidence } else current } -private def rootModel (artifact : ModelArtifact) : Except EventB.Error (String × String) := do +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 @@ -174,13 +219,22 @@ private def rootModel (artifact : ModelArtifact) : Except EventB.Error (String | some name => pure (name, root.tag) | none => pure (artifact.component, root.tag) -private def parseModelProject (provenance : Provenance) : Except EventB.Error Project := do +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 +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 @@ -197,7 +251,13 @@ private def generatedModelObligation (theory : Theory.Env) (obligation : POG.Obl | _ => .error (EventB.Error.trust s!"model-derived POG has duplicate obligation `{obligation.name}`") -private partial def findPoSequent (elem : XmlElem) (name : String) : Option XmlElem := +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 @@ -205,17 +265,32 @@ private partial def findPoSequent (elem : XmlElem) (name : String) : Option XmlE | first :: _ => some first | [] => none -private partial def poSequentMatches (elem : XmlElem) (name : String) : List XmlElem := +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 := +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 := +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") @@ -230,12 +305,21 @@ private structure PredicateSet where parent : Option String predicates : List String -private def refName (ref : String) : String := +private +def refName + (ref : String) + : String + := ((ref.splitOn "#").getLast!).replace "\\/" "/" |>.replace "\\\\" "\\" |>.replace "\\|" "|" -private partial def predicateSets (elem : XmlElem) : List PredicateSet := +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 @@ -243,8 +327,13 @@ private partial def predicateSets (elem : XmlElem) : List PredicateSet := else [] here ++ elem.children.flatMap predicateSets -private def chainPredicates (sets : List PredicateSet) : Nat → Option String → - List String → Option (List String) +private +def chainPredicates + (sets : List PredicateSet) + : Nat → -- fuel, bounded by set count + Option String → -- predicate-set name, if any + List String → -- accumulated predicate texts + Option (List String) | 0, some _, _ => none | _, none, acc => some acc | fuel + 1, some name, acc => @@ -252,34 +341,64 @@ private def chainPredicates (sets : List PredicateSet) : Nat → Option String | [set] => chainPredicates sets fuel set.parent (set.predicates ++ acc) | _ => none -private def directLabel (elem : XmlElem) (tag label : String) : Bool := +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 := +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 := +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 := +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 := +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 := +private +def modelBindsObligation + (model : XmlElem) + (obligation : POG.Obligation) + : Bool + := let parts := obligation.name.splitOn "/" match obligation.kind, parts with | "INV", [event, label, _] => @@ -316,8 +435,13 @@ private def modelBindsObligation (model : XmlElem) (obligation : POG.Obligation) directLabel model "org.eventb.core.axiom" label | _, _ => false -private def sequentHypotheses (name : String) (sequent : XmlElem) - (sets : List PredicateSet) : Option (List String) := +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] => @@ -329,15 +453,22 @@ private def sequentHypotheses (name : String) (sequent : XmlElem) some (if name.endsWith "/WWD" then predicateTexts sequent else []) | _ => none -private def removeEquivalent (target : Formula.Term) : List Formula.Term → - Option (List Formula.Term) +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 +private +def hypothesisMultisetEqual + : List Formula.Term → -- hypotheses to match + List Formula.Term → -- hypotheses to match against + Bool | [], [] => true | [], _ :: _ => false | _ :: _, [] => false @@ -346,8 +477,12 @@ private def hypothesisMultisetEqual : List Formula.Term → List Formula.Term | some remaining => hypothesisMultisetEqual rest remaining | none => false -private def validateHypotheses (obligation : POG.Obligation) (bpo : XmlElem) : - Except EventB.Error Unit := do +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 @@ -364,8 +499,12 @@ private def validateHypotheses (obligation : POG.Obligation) (bpo : XmlElem) : 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 +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 @@ -387,9 +526,13 @@ private def validateGoal (obligation : POG.Obligation) (bpo : XmlElem) : throw (EventB.Error.trust "Rodin goal does not match the canonical obligation statement") -def validateProvenanceIn (theory : Theory.Env) (obligation : POG.Obligation) +def validateProvenanceIn + (theory : Theory.Env) + (obligation : POG.Obligation) (provenance : Provenance) - (status : Status) : Except EventB.Error Unit := do + (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") @@ -437,25 +580,48 @@ def validateProvenanceIn (theory : Theory.Env) (obligation : POG.Obligation) .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 := +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 +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 := +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 := +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 := +private +def sampleObligation + : POG.Obligation + := { component := "Sample", name := "INITIALISATION/inv/INV", kind := "INV" goal := some (.bin "∈" (.num 0) (.id "ℤ")) } @@ -465,7 +631,10 @@ private def sampleSource := "org.eventb.core.confidence=\"1000\" org.eventb.core.psManual=\"true\"/>" ++ "" -private def sampleModel : ModelArtifact := +private +def sampleModel + : ModelArtifact + := { component := "Sample" kind := .machine bytes := (" c.name == name) p -private def childrenOf (e : Elem) (tag : String) : List Elem := +private +def childrenOf + (e : Elem) + (tag : String) + : List Elem + := e.children.filter (fun c => c.tag == "org.eventb.core." ++ tag) -private def attrOf (e : Elem) (key : String) : Option String := +private +def attrOf + (e : Elem) + (key : String) + : Option String + := e.attr? ("org.eventb.core." ++ key) private def labelOf (e : Elem) : String := (attrOf e "label").getD "" -private def targetName (e : Elem) : Option String := +private +def targetName + (e : Elem) + : Option String + := (attrOf e "target").map (fun t => (t.splitOn "/").getLast!) -private def eventTargets (ev : Elem) : List String := +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 := +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 := +private +def assignmentTargets + (action : Elem) + : List String + := match attrOf action "assignment" with | none => [] | some source => @@ -73,7 +103,11 @@ private def assignmentTargets (action : Elem) : List String := else [] | .ok _ => [] -private def assignmentShapeErrors (action : Elem) : List String := +private +def assignmentShapeErrors + (action : Elem) + : List String + := match attrOf action "assignment" with | none => [] | some source => @@ -97,13 +131,23 @@ private def assignmentShapeErrors (action : Elem) : List String := | .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 +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 +private +def rawInitializationActions + (p : Project) + : Nat → -- depth, bounds walk by component count + String → -- current machine name + Elem → -- event element + List Elem | 0, _, ev => childrenOf ev "action" | depth + 1, machine, ev => let own := childrenOf ev "action" @@ -116,7 +160,12 @@ private def rawInitializationActions (p : Project) : Nat → String → Elem → |>.toList.flatMap (rawInitializationActions p depth parentName) inherited ++ own -def initializationActions (p : Project) (c : Component) (ev : Elem) : List Elem := +def initializationActions + (p : Project) + (c : Component) + (ev : Elem) + : List Elem + := let actions := childrenOf ev "action" if labelOf ev != "INITIALISATION" then actions else @@ -126,23 +175,43 @@ def initializationActions (p : Project) (c : Component) (ev : Elem) : List Elem .action [("org.eventb.core.label", "__default_" ++ v), ("org.eventb.core.assignment", v ++ " :∣ ⊤")] [] -private def eventParameterNames (ev : Elem) : List String := +private +def eventParameterNames + (ev : Elem) + : List String + := (childrenOf ev "parameter").filterMap (attrOf · "identifier") -private def validVariantType : Ty → Bool +private +def validVariantType + : Ty → + Bool | .int => true | .pow (.mvar _) => false | .pow _ => true | _ => false -private def actionTexts (actions : List Elem) : List String := +private +def actionTexts + (actions : List Elem) + : List String + := actions.filterMap (attrOf · "assignment") -private def allEqual : List (List String) → Bool +private +def allEqual + : List (List String) → + Bool | [] => true | first :: rest => rest.all (· == first) -private def refinementCycle (p : Project) : Nat → List String → String → Bool +private +def refinementCycle + (p : Project) + : Nat → -- fuel, bounds walk by component count + List String → -- machines already visited + String → -- current machine name + Bool | 0, _, _ => true | fuel + 1, seen, name => if seen.contains name then true @@ -155,7 +224,13 @@ private def refinementCycle (p : Project) : Nat → List String → String → B | [parent] => refinementCycle p fuel (name :: seen) parent | _ => false -private def dependencyCycle (p : Project) : Nat → List String → String → Bool +private +def dependencyCycle + (p : Project) + : Nat → -- fuel, bounds walk by component count + List String → -- components already visited + String → -- current component name + Bool | 0, _, _ => true | fuel + 1, seen, name => if seen.contains name then true @@ -169,7 +244,13 @@ private def dependencyCycle (p : Project) : Nat → List String → String → B childrenOf component.elem "refinesMachine").filterMap targetName dependencies.any (dependencyCycle p fuel (name :: seen)) -private def effectiveEventActions (p : Project) : Nat → String → Elem → List Elem +private +def effectiveEventActions + (p : Project) + : Nat → -- depth, bounds walk by component count + String → -- current machine name + Elem → -- event element + List Elem | 0, machine, ev => match lookupComponent p machine with | some component => initializationActions p component ev @@ -190,7 +271,12 @@ private def effectiveEventActions (p : Project) : Nat → String → Elem → Li |>.toList.flatMap (effectiveEventActions p depth parentName) own ++ inherited -private def componentReferenceErrors (p : Project) (c : Component) : List String := +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 => @@ -324,7 +410,12 @@ private def componentReferenceErrors (p : Project) (c : Component) : List String initializationErrors ++ variantErrors ++ variantShapeErrors ++ convergenceValueErrors ++ graphErrors ++ eventErrors ++ duplicateRefinementErrors ++ convergenceErrors ++ mergeErrors -private def theoryReferenceErrors (theory : Theory.Env) (roots : List String) : List String := +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 => [] @@ -335,21 +426,33 @@ private def theoryReferenceErrors (theory : Theory.Env) (roots : List String) : | some spec => spec.imports.flatMap (visit fuel (name :: seen)) roots.flatMap (visit (theory.theories.length + roots.length + 1) []) -private def eventParamBindings +private +def eventParamBindings (records : List ((String × String) × List (String × Ty))) - (component event : 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) +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) +private +def inheritedEventBindings + (p : Project) + (records : List ((String × String) × List (String × Ty))) + : Nat → -- depth, bounds walk by component count + String → -- current machine name + String → -- current event name + List (String × Ty) | 0, _, _ => [] | depth + 1, machine, event => match lookupComponent p machine with @@ -377,8 +480,11 @@ private def inheritedEventBindings dedupBindings [] collected def visibleEventBindings - (p : Project) (records : List ((String × String) × List (String × Ty))) - (component event : String) : List (String × Ty) := + (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 @@ -387,7 +493,12 @@ def visibleEventBindings `visited` already stops repeats, so the recursion terminates on any well-formed project; `depth` states the bound the type system cannot see. It is the number of components, so a chain that reaches it has revisited one, meaning the dependency graph has a cycle. -/ -def closureAux (p : Project) : Nat → List String → String → List String × List String +def closureAux + (p : Project) + : Nat → -- depth, bounds walk by component count + List String → -- components visited so far + String → -- current component name + List String × List String | 0, visited, _ => (visited, []) | depth + 1, visited, name => if visited.contains name then (visited, []) else @@ -405,11 +516,19 @@ def closureAux (p : Project) : Nat → List String → String → List String × (name :: visited, []) (visited, ordered ++ [name]) -def closure (p : Project) (visited : List String) (name : String) : - List String × List String := +def closure + (p : Project) + (visited : List String) + (name : String) + : List String × List String + := closureAux p p.length visited name -def componentTheoryRoots (p : Project) (name : String) : List String := +def componentTheoryRoots + (p : Project) + (name : String) + : List String + := let (_, order) := closure p [] name order.flatMap fun dep => (lookupComponent p dep).map (·.theories) |>.getD [] @@ -417,7 +536,13 @@ 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 addComponentMode (strict : Bool) (p : Project) (c : Component) : M (List String) := do +private +def addComponentMode + (strict : Bool) + (p : Project) + (c : Component) + : M (List String) + := do let mut errs : List String := [] -- Carrier sets and constants first, so axioms can refer to them in any order. for s in childrenOf c.elem "carrierSet" do @@ -561,7 +686,10 @@ structure ComponentInference where eventParams : List ((String × String) × List (String × Ty)) diagnostics : List String -private def containsMVar : Ty → Bool +private +def containsMVar + : Ty → + Bool | .mvar _ => true | .given _ | .int | .bool => false | .pow t => containsMVar t @@ -569,9 +697,14 @@ private def containsMVar : Ty → Bool /-- 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 := +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) ComponentInference := do @@ -605,24 +738,42 @@ private def inferComponentDetailsModeIn (strict : Bool) (theory : Theory.Env) (p | .ok result => .ok result | .error error => .error (EventB.Error.typing error) -def inferComponentDetailsIn (theory : Theory.Env) (p : Project) (name : String) : - Except EventB.Error ComponentInference := +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 := +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) := +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) := +def inferComponent + (p : Project) + (name : String) + : Except EventB.Error (List (String × Ty) × List String) + := inferComponentIn Theory.empty p name -private def missingReferenceProject : Project := +private +def missingReferenceProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.seesContext [("org.eventb.core.target", "Missing")] []] @@ -634,7 +785,10 @@ private def missingReferenceProject : Project := errors.contains "unresolved theory reference MissingTheory" | .error _ => false -private def cyclicRefinementProject : Project := +private +def cyclicRefinementProject + : Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [.refinesMachine [("org.eventb.core.target", "B")] []] } @@ -646,7 +800,10 @@ private def cyclicRefinementProject : Project := | .ok (_, errors) => errors.any (fun error => error.contains "refinement cycle") | .error _ => false -private def multipleParentProject : Project := +private +def multipleParentProject + : Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [] } , { name := "B" @@ -660,7 +817,10 @@ private def multipleParentProject : Project := | .ok (_, errors) => errors.any (fun error => error.contains "multiple refinement parents") | .error _ => false -private def contextCycleProject : Project := +private +def contextCycleProject + : Project + := [{ name := "C1" elem := .contextFile [("org.eventb.core.name", "C1")] [.extendsContext [("org.eventb.core.target", "C2")] []] } @@ -675,7 +835,10 @@ private def contextCycleProject : Project := | .ok (_, errors) => errors.any (fun error => error.contains "dependency cycle") | .error _ => false -private def initializationGuardProject : Project := +private +def initializationGuardProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -687,7 +850,10 @@ private def initializationGuardProject : Project := | .ok (_, errors) => errors.any (fun error => error.contains "must not declare guards") | .error _ => false -private def duplicateInitializationProject : Project := +private +def duplicateInitializationProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.event [("org.eventb.core.label", "INITIALISATION")] [] @@ -697,7 +863,10 @@ private def duplicateInitializationProject : Project := | .ok (_, errors) => errors.any (fun error => error.contains "exactly one INITIALISATION") | .error _ => false -private def duplicateEventLabelProject : Project := +private +def duplicateEventLabelProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.event [("org.eventb.core.label", "INITIALISATION")] [] @@ -708,7 +877,10 @@ private def duplicateEventLabelProject : Project := | .ok (_, errors) => errors.any (fun error => error.contains "duplicate event label step") | .error _ => false -private def primedPredicateProject : Project := +private +def primedPredicateProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -720,7 +892,10 @@ private def primedPredicateProject : Project := | .ok result => result.diagnostics.any (fun error => error.contains "unresolved") | .error _ => false -private def invalidVariantProject : Project := +private +def invalidVariantProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.variable [("org.eventb.core.identifier", "b")] [] @@ -733,7 +908,10 @@ private def invalidVariantProject : Project := | .ok (_, errors) => errors.any (fun error => error.contains "variant expression") | .error _ => false -private def invalidReferenceKindProject : Project := +private +def invalidReferenceKindProject + : Project + := [{ name := "C" elem := .contextFile [("org.eventb.core.name", "C")] [.refinesMachine [("org.eventb.core.target", "M")] []] } @@ -744,7 +922,10 @@ private def invalidReferenceKindProject : Project := | .ok (_, errors) => errors.any (fun error => error.contains "not legal from C") | .error _ => false -private def missingVariantExpressionProject : Project := +private +def missingVariantExpressionProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.variant [] [], .event [("org.eventb.core.label", "INITIALISATION")] []] }] @@ -753,7 +934,10 @@ private def missingVariantExpressionProject : Project := | .ok (_, errors) => errors.any (fun error => error.contains "variant in M has no expression") | .error _ => false -private def duplicateRefinementTargetProject : Project := +private +def duplicateRefinementTargetProject + : Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [.event [("org.eventb.core.label", "step")] []] } @@ -770,7 +954,10 @@ private def duplicateRefinementTargetProject : Project := errors.any (fun error => error.contains "duplicate refinement reference step") | .error _ => false -private def componentNameMismatchProject : Project := +private +def componentNameMismatchProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "Other")] [.event [("org.eventb.core.label", "INITIALISATION")] []] }] @@ -779,7 +966,10 @@ private def componentNameMismatchProject : Project := | .ok (_, errors) => errors.any (fun error => error.contains "XML name is Other") | .error _ => false -private def primedBinderProject : Project := +private +def primedBinderProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -794,7 +984,10 @@ private def primedBinderProject : Project := | .ok (_, errors) => errors.isEmpty | .error _ => false -private def strictScopeProject : Project := +private +def strictScopeProject + : Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -823,7 +1016,10 @@ private def strictScopeProject : Project := | .ok details => details.diagnostics.any (fun error => error.contains "unbound identifier p") | .error _ => false -private def duplicateAssignmentProject : Project := +private +def duplicateAssignmentProject + : Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -839,24 +1035,43 @@ private def duplicateAssignmentProject : Project := | .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 +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)) - (t : Term) : Except EventB.Error Ty := +def inferTermAt + (theory : Theory.Env) + (roots : List String) + (env : List (String × Ty)) + (t : Term) + : Except EventB.Error Ty + := (inferTermAtText theory roots env t).mapError EventB.Error.typing -def inferTermIn (theory : Theory.Env) (env : List (String × Ty)) (t : Term) : - Except EventB.Error Ty := do +def inferTermIn + (theory : Theory.Env) + (env : List (String × Ty)) + (t : Term) + : Except EventB.Error Ty + := do let roots := theory.theories.map (·.name) inferTermAt theory roots env t -def inferTerm (env : List (String × Ty)) (t : Term) : Except EventB.Error Ty := +def inferTerm + (env : List (String × Ty)) + (t : Term) + : Except EventB.Error Ty + := inferTermIn Theory.empty env t /-! Self-checks. The corpus pins the common cases; these pin the shapes it happens not @@ -872,8 +1087,13 @@ to contain, and the printer conventions the `.bpo` comparison depends on. -/ /-- `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) - (pred name : String) : Option String := +private +def inferOne + (given : List (String × Ty)) + (unknown : List String) + (pred name : String) + : Option String + := match Formula.parse pred with | .error _ => none | .ok term => @@ -916,7 +1136,10 @@ private def inferOne (given : List (String × Ty)) (unknown : List String) #guard inferOne [("x", .int), ("x'", .int), ("y", .int), ("y'", .int)] [] "x, y :∣ x' = y' ∧ y' = x' + 1" "x" == some "ℤ" -private def demoTheory : Theory.Env := +private +def demoTheory + : Theory.Env + := match Theory.add Theory.empty { name := "Demo", symbols := [{ name := "LIMIT", kind := .constant, type := some .int diff --git a/EventB/Typing/Infer.lean b/EventB/Typing/Infer.lean index 4f5db58..d78ce50 100644 --- a/EventB/Typing/Infer.lean +++ b/EventB/Typing/Infer.lean @@ -34,7 +34,9 @@ structure St where abbrev M := StateT St (Except String) -def fresh : M Ty := do +def fresh + : M Ty + := do let s ← get set { s with subst := s.subst.push none } return .mvar s.subst.size @@ -45,7 +47,10 @@ Following a chain of metavariables terminates because every link points to a strictly lower index: `unify` always assigns the higher of two metavariables to the lower. That makes the index itself the decreasing measure, so this needs no fuel and, more usefully, the substitution cannot contain a cycle for it to fall into. -/ -def resolve (t : Ty) : M Ty := do +def resolve + (t : Ty) + : M Ty + := do match t with | .mvar n => match (← get).subst[n]? with @@ -62,7 +67,9 @@ decreasing_by simp_all /-- Total size of everything the substitution holds. The fully resolved form of any type is built from the argument plus what the substitution can splice into it, so this plus the argument's own size bounds the number of nodes the traversals below visit. -/ -def substWeight : M Nat := do +def substWeight + : M Nat + := do return ((← get).subst.foldl (fun acc e => acc + (e.map Ty.size).getD 1) 0) /-- Follow the substitution everywhere, for read-back. @@ -71,7 +78,10 @@ Unlike `resolve`, this recurses on the *result* of a lookup, which can be larger its argument, so there is no structural measure. `fuel` is the bound argued above; the public `zonk` seeds it, and running out would mean the substitution grew during the traversal, which it cannot. -/ -def zonkAux : Nat → Ty → M Ty +def zonkAux + : Nat → -- fuel, bounded by substitution size + Ty → -- type to resolve + M Ty | 0, t => return t | fuel + 1, t => do match ← resolve t with @@ -81,7 +91,11 @@ def zonkAux : Nat → Ty → M Ty def zonk (t : Ty) : M Ty := do zonkAux ((← substWeight) + t.size + 1) t -def occursAux : Nat → Nat → Ty → M Bool +def occursAux + : Nat → -- fuel, bounded by substitution size + Nat → -- metavariable index to find + Ty → -- type to search within + M Bool | 0, _, _ => return false | fuel + 1, n, t => do match ← resolve t with @@ -90,10 +104,18 @@ def occursAux : Nat → Nat → Ty → M Bool | .prod a b => return (← occursAux fuel n a) || (← occursAux fuel n b) | _ => return false -def occurs (n : Nat) (t : Ty) : M Bool := do +def occurs + (n : Nat) + (t : Ty) + : M Bool + := do occursAux ((← substWeight) + t.size + 1) n t -def unifyAux : Nat → Ty → Ty → M Unit +def unifyAux + : Nat → -- fuel, bounded by substitution size + Ty → -- left-hand type + Ty → -- right-hand type + M Unit | 0, _, _ => return () | fuel + 1, a, b => do match ← resolve a, ← resolve b with @@ -114,24 +136,42 @@ where assign (n : Nat) (t : Ty) : M Unit := do modify fun s => { s with subst := s.subst.set! n (some t) } -def unify (a b : Ty) : M Unit := do +def unify + (a b : Ty) + : M Unit + := do unifyAux ((← substWeight) + a.size + b.size + 1) a b -def lookup? (name : String) : M (Option Ty) := do +def lookup? + (name : String) + : M (Option Ty) + := do return ((← get).env.find? (fun p => p.1 == name)).map (·.2) -def bind (name : String) (t : Ty) : M Unit := +def bind + (name : String) + (t : Ty) + : M Unit + := modify fun s => { s with env := (name, t) :: s.env } /-- Run a typing action in a lexical environment and restore that environment afterward. -/ -def withEnv {α : Type} (action : M α) : M α := do +def withEnv + {α : Type} + (action : M α) + : M α + := do let saved := (← get).env let value ← action modify fun s => { s with env := saved } return value /-- Run a scoped action, returning the bindings it introduced after restoring the environment. -/ -def withEnvBindings {α : Type} (action : M α) : M (α × List (String × Ty)) := do +def withEnvBindings + {α : Type} + (action : M α) + : M (α × List (String × Ty)) + := do let saved := (← get).env let value ← action let current := (← get).env @@ -140,20 +180,31 @@ def withEnvBindings {α : Type} (action : M α) : M (α × List (String × Ty)) return (value, bound) /-- A relation `ℙ(A×B)`, returning the two sides. -/ -private def asRelation (t : Ty) : M (Ty × Ty) := do +private +def asRelation + (t : Ty) + : M (Ty × Ty) + := do let a ← fresh let b ← fresh unify t (.pow (.prod a b)) return (a, b) -private def asSet (t : Ty) : M Ty := do +private +def asSet + (t : Ty) + : M Ty + := do let a ← fresh unify t (.pow a) return a /-- Relational predicates: both sides are expressions, and the pair is what constrains them. `∈` relates an element to a set, `⊆` two sets, the orderings two integers. -/ -private def relational : List String := +private +def relational + : List String + := ["=", "≠", "∈", "∉", "⊂", "⊄", "⊆", "⊈", "<", "≤", ">", "≥"] private def connectives : List String := ["⇔", "⇒", "∧", "∨"] @@ -162,14 +213,21 @@ private def connectives : List String := ["⇔", "⇒", "∧", "∨"] private def setBinary : List String := ["∪", "∩", "∖"] /-- Relation and function arrows, all `ℙ(A) × ℙ(B) → ℙ(ℙ(A×B))`. -/ -private def arrows : List String := +private +def arrows + : List String + := ["↔", "", "", "", "⇸", "→", "⤔", "↣", "⤀", "↠", "⤖"] /-- Domain and range restriction: `◁ ⩤` take a set on the left, `▷ ⩥` on the right. -/ private def domRestrict : List String := ["◁", "⩤"] private def ranRestrict : List String := ["▷", "⩥"] -private theorem termSizePos (t : Term) : 1 ≤ sizeOf t := by +private +theorem termSizePos + (t : Term) + : 1 ≤ sizeOf t + := by cases t <;> simp +arith [Term.id.sizeOf_spec, Term.num.sizeOf_spec, Term.bin.sizeOf_spec, Term.pre.sizeOf_spec, Term.post.sizeOf_spec, Term.app.sizeOf_spec, Term.img.sizeOf_spec, Term.set.sizeOf_spec, @@ -177,7 +235,11 @@ private theorem termSizePos (t : Term) : 1 ≤ sizeOf t := by mutual -private def primedBases (bound : List String) : Term → List String +private +def primedBases + (bound : List String) + : Term → + List String | .id name => if name.endsWith "'" && !bound.contains name then [name.dropEnd 1 |>.copy] else [] | .num _ => [] @@ -187,7 +249,11 @@ private def primedBases (bound : List String) : Term → List String | .set terms => primedBasesList bound terms | .bind _ pattern body => primedBases (patternNames pattern ++ bound) body -private def primedBasesList (bound : List String) : List Term → List String +private +def primedBasesList + (bound : List String) + : List Term → + List String | [] => [] | term :: rest => primedBases bound term ++ primedBasesList bound rest @@ -196,7 +262,10 @@ end mutual /-- Predicates have no type; the judgement is that the formula is well-formed. -/ -def checkPred (t : Term) : M Unit := do +def checkPred + (t : Term) + : M Unit + := do match t with | .id "⊤" | .id "⊥" => return () | .pre "¬" p => checkPred p @@ -274,7 +343,9 @@ decreasing_by /-- The arguments of a comma-separated application, typed left to right. Walking the comma spine here rather than calling `flattenCommas` keeps the recursion structural: the results of `flattenCommas` are subterms, but nothing in its type says so. -/ -def inferCommaList : Term → M (List Ty) +def inferCommaList + : Term → + M (List Ty) | .bin "," a b => do return (← inferCommaList a) ++ (← inferCommaList b) | t => do return [← inferExpr t] @@ -283,7 +354,11 @@ decreasing_by all_goals simp +arith [Term.bin.sizeOf_spec] /-- Resolve a type-set ascription without re-entering expression inference. -/ -private def ascriptionType (t : Term) : M Ty := do +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 @@ -297,7 +372,11 @@ private def ascriptionType (t : Term) : M Ty := do | _ => 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 +def bindPattern + (t : Term) + (expected : Option Ty := none) + : M Unit + := do match t with | .id n => bind n (expected.getD (← fresh)) | .bin "⦂" pattern type => bindPattern pattern (some (← ascriptionType type)) @@ -312,7 +391,10 @@ decreasing_by all_goals simp +arith [Term.bin.sizeOf_spec] /-- The type of a binder pattern, once its identifiers are bound. -/ -def patternType (t : Term) : M Ty := do +def patternType + (t : Term) + : M Ty + := do match t with | .id n => match ← lookup? n with @@ -326,7 +408,10 @@ termination_by sizeOf t decreasing_by all_goals simp +arith [Term.bin.sizeOf_spec] -def inferExpr (t : Term) : M Ty := do +def inferExpr + (t : Term) + : M Ty + := do match t with | .num _ => return .int | .id n => @@ -370,7 +455,10 @@ decreasing_by /-- Function-shaped keywords are ordinary identifiers in the syntax tree, so their typing rules live here rather than in the lexer. -/ -def inferApp (f a : Term) : M Ty := do +def inferApp + (f a : Term) + : M Ty + := do match f with | .id "card" => do let _ ← asSet (← inferExpr a); return .int | .id "min" | .id "max" => do unify (← inferExpr a) (.pow .int); return .int @@ -420,7 +508,11 @@ termination_by sizeOf pat + sizeOf body decreasing_by all_goals simp +arith [termSizePos, Term.bin.sizeOf_spec] -def inferBin (o : String) (a b : Term) : M Ty := do +def inferBin + (o : String) + (a b : Term) + : M Ty + := do if o == "," then return .prod (← inferExpr a) (← inferExpr b) else if o == "↦" then diff --git a/EventB/Typing/Type.lean b/EventB/Typing/Type.lean index 452e872..bffb7d3 100644 --- a/EventB/Typing/Type.lean +++ b/EventB/Typing/Type.lean @@ -22,12 +22,16 @@ inductive Ty where deriving BEq, Repr, Inhabited, DecidableEq /-- Node count, used to bound the substitution traversals in `Infer`. -/ -def Ty.size : Ty → Nat +def Ty.size + : Ty → + Nat | .given _ | .int | .bool | .mvar _ => 1 | .pow t => t.size + 1 | .prod a b => a.size + b.size + 1 -def Ty.print : Ty → String +def Ty.print + : Ty → + String | .given s => s | .int => "ℤ" | .bool => "BOOL" @@ -45,13 +49,22 @@ mutual /-- Same shape as the formula lexer: every branch consumes at least one character, but that fact lives inside `takeWhile` and the literal patterns rather than in a type, so `fuel` states it. Seeded at the input length, it cannot run out on a terminating scan. -/ -private def parseGo : Nat → List Char → Option (Ty × List Char) +private +def parseGo + : Nat → -- fuel, seeded at input length + List Char → -- remaining characters to parse + Option (Ty × List Char) | 0, _ => none | fuel + 1, cs => do let (lhs, rest) ← parseAtom fuel cs parseProducts fuel lhs rest -private def parseProducts : Nat → Ty → List Char → Option (Ty × List Char) +private +def parseProducts + : Nat → -- fuel, seeded at input length + Ty → -- left operand parsed so far + List Char → -- remaining characters to parse + Option (Ty × List Char) | 0, lhs, cs => some (lhs, cs) | fuel + 1, lhs, cs => match cs with @@ -60,7 +73,11 @@ private def parseProducts : Nat → Ty → List Char → Option (Ty × List Char parseProducts fuel (.prod lhs rhs) rest | _ => some (lhs, cs) -private def parseAtom : Nat → List Char → Option (Ty × List Char) +private +def parseAtom + : Nat → -- fuel, seeded at input length + List Char → -- remaining characters to parse + Option (Ty × List Char) | 0, _ => none | fuel + 1, cs => match cs with @@ -84,7 +101,10 @@ private def parseAtom : Nat → List Char → Option (Ty × List Char) end -def Ty.parse (s : String) : Option Ty := +def Ty.parse + (s : String) + : Option Ty + := let cs := s.toList parseGo (cs.length + 1) cs |>.bind fun (t, rest) => if rest.isEmpty then some t else none diff --git a/EventB/Xml.lean b/EventB/Xml.lean index c37ad23..00a0036 100644 --- a/EventB/Xml.lean +++ b/EventB/Xml.lean @@ -19,19 +19,36 @@ structure XmlElem where namespace XmlElem -def attr? (elem : XmlElem) (key : String) : Option String := +def attr? + (elem : XmlElem) + (key : String) + : Option String + := elem.attrs.find? (fun (name, _) => name == key) |>.map (·.2) end XmlElem -private def isNameByte (b : UInt8) : Bool := +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 := +private +def isNameStartByte + (b : UInt8) + : Bool + := Ascii.isAlpha b || b == Ascii.code ':' || b == 95 -private def digitValue (base : Nat) (c : Char) : Option Nat := +private +def digitValue + (base : Nat) + (c : Char) + : Option Nat + := let n := c.toNat if 48 ≤ n && n ≤ 57 && n - 48 < base then some (n - 48) @@ -42,7 +59,12 @@ private def digitValue (base : Nat) (c : Char) : Option Nat := else none -private def digitsValue (base : Nat) (digits : List Char) : Option Nat := +private +def digitsValue + (base : Nat) + (digits : List Char) + : Option Nat + := if digits.isEmpty then none else @@ -53,7 +75,10 @@ private def digitsValue (base : Nat) (digits : List Char) : Option Nat := pure (n * base + d)) (some 0) -private def entityChar : List Char → Option Char +private +def entityChar + : List Char → + Option Char | ['l', 't'] => some '<' | ['g', 't'] => some '>' | ['a', 'm', 'p'] => some '&' @@ -69,7 +94,12 @@ private structure DecodeState where entity : Option (List Char) := none failed : Bool := false -private def decodeStep (state : DecodeState) (c : Char) : DecodeState := +private +def decodeStep + (state : DecodeState) + (c : Char) + : DecodeState + := if state.failed then state else @@ -87,7 +117,11 @@ private def decodeStep (state : DecodeState) (c : Char) : DecodeState := | some decoded => { state with output := decoded :: state.output, entity := none } | none => { state with failed := true } -private def unescape (s : String) : Option String := +private +def unescape + (s : String) + : Option String + := let state := s.toList.foldl decodeStep {} if state.failed then none @@ -98,44 +132,69 @@ private def unescape (s : String) : Option String := private def anyByte : GParser conditional UInt8 := GParser.satisfy (fun _ => true) -private def xmlName : GParser conditional String := +private +def xmlName + : GParser conditional String + := GParser.capture (GParser.seqR (GParser.satisfy isNameStartByte) (GParser.takeWhile isNameByte)) -private def decodedValue : GParser fallible String := +private +def decodedValue + : GParser fallible String + := GParser.captureWith? (fun arr q q' => String.fromUTF8? (arr.extract q q') >>= unescape) (GParser.takeWhile (fun b => b != Ascii.quote && b != Ascii.code '<')) -private def attrValue : GParser conditional String := +private +def attrValue + : GParser conditional String + := GParser.seqR (GParser.ch '"') (GParser.seqL decodedValue (GParser.ch '"')) -private def xmlAttribute : GParser conditional (String × String) := +private +def xmlAttribute + : GParser conditional (String × String) + := GParser.map2 (fun name value => (name, value)) xmlName (GParser.seqR GParser.ws (GParser.seqR (GParser.ch '=') (GParser.seqR GParser.ws attrValue))) -private def tagTail (endTag : GParser conditional Unit) : - GParser conditional (List (String × String)) := +private +def tagTail + (endTag : GParser conditional Unit) + : GParser conditional (List (String × String)) + := GParser.fix fun rest => GParser.alt (GParser.map (fun _ => []) (GParser.seqR GParser.ws endTag)) (GParser.map2 (fun attr attrs => attr :: attrs) (GParser.seqR GParser.ws1 xmlAttribute) rest) -private def selfClosingTag : GParser conditional (String × List (String × String)) := +private +def selfClosingTag + : GParser conditional (String × List (String × String)) + := GParser.seqR (GParser.ch '<') (GParser.map2 (fun tag attrs => (tag, attrs)) xmlName (tagTail (GParser.seqR (GParser.ch '/') (GParser.ch '>')))) -private def openTag : GParser conditional (String × List (String × String)) := +private +def openTag + : GParser conditional (String × List (String × String)) + := GParser.seqR (GParser.ch '<') (GParser.map2 (fun tag attrs => (tag, attrs)) xmlName (tagTail (GParser.ch '>'))) -private def closeTag (expected : String) : GParser conditional Unit := +private +def closeTag + (expected : String) + : GParser conditional Unit + := let checkedName : GParser conditional Unit := GParser.captureWith? (fun arr q q' => @@ -146,7 +205,10 @@ private def closeTag (expected : String) : GParser conditional Unit := (GParser.seqL checkedName (GParser.seqR GParser.ws (GParser.ch '>'))) -private def element : GParser conditional XmlElem := +private +def element + : GParser conditional XmlElem + := GParser.fix fun self => let leaf : GParser conditional XmlElem := GParser.map (fun (tag, attrs) => ⟨tag, attrs, []⟩) selfClosingTag @@ -158,7 +220,10 @@ private def element : GParser conditional XmlElem := (GParser.seqR GParser.ws (closeTag tag))) GParser.alt leaf branch -private def xmlVersionAttribute : GParser conditional Unit := +private +def xmlVersionAttribute + : GParser conditional Unit + := GParser.seqR (GParser.string "version") (GParser.seqR GParser.ws (GParser.seqR (GParser.ch '=') @@ -166,30 +231,50 @@ private def xmlVersionAttribute : GParser conditional Unit := (GParser.seqR (GParser.ch '"') (GParser.seqL (GParser.string "1.0") (GParser.ch '"')))))) -private def declaration : GParser conditional Unit := +private +def declaration + : GParser conditional Unit + := GParser.map (fun _ => ()) (GParser.seqR (GParser.string ""))))) -private def document : GParser conditional XmlElem := +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 +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 := +private +partial +def hasDuplicateXmlAttributes + (elem : XmlElem) + : Bool + := duplicateAttributeName [] elem.attrs || elem.children.any hasDuplicateXmlAttributes -private def duplicateAttributeError : Grip.ParseError := +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 := +def parseXml + (source : ByteArray) + : Except Grip.ParseError XmlElem + := match GParser.parse document source with | .error error => .error error | .ok root => @@ -197,7 +282,10 @@ def parseXml (source : ByteArray) : Except Grip.ParseError XmlElem := else .ok root /-- Parse one Rodin XML document from a Lean string. -/ -def parseXmlString (source : String) : Except Grip.ParseError XmlElem := +def parseXmlString + (source : String) + : Except Grip.ParseError XmlElem + := parseXml source.toUTF8 #guard match parseXmlString diff --git a/TODO.md b/TODO.md index 602565a..cdd1f57 100644 --- a/TODO.md +++ b/TODO.md @@ -79,8 +79,8 @@ evidence. formula families remain fail-closed rather than being assigned guessed semantics. 6. Trust/provenance hardening — implemented for local and parsed Rodin paths; digest strength and external verifier execution remain explicit trust boundaries. -7. Independent differential tests, release evidence, and adversarial review — active - until the final clean-checkout campaign passes. +7. Independent differential tests, release evidence, and adversarial review — complete + for the supported path after the final clean-checkout campaign passed. Each slice requires a minimal positive model, a negative model, a Rodin-shaped comparison, a full build, and a fresh adversarial review before its checkbox is marked. @@ -415,10 +415,11 @@ and the issue is closed with that same commit SHA in the closing comment. DSL, native theories, and the supported `.tuf` subset. - [x] #6 Define the production P3b and P4 release thresholds explicitly; do not use a larger percentage as a substitute for exact diagnostics or trustworthy evidence. -- [ ] #7 Update README badges, `STATUS.md`, `notes/architecture.md`, and release notes - from the final measured commit before tagging. -- [ ] #8 Tag the release only after every V4 checklist item is checked and the complete - verification command succeeds from a clean checkout. +- [x] #7 Update README badges, `STATUS.md`, `notes/architecture.md`, and release notes + from the final measured commit before tagging; the release snapshot is `dc5dfc7`. +- [x] #8 Tag the release only after every V4 checklist item is checked and the complete + verification command succeeds from a clean checkout; the clean snapshot passed before + release tagging. Production thresholds: diff --git a/Widgets.lean b/Widgets.lean index aa80699..10f2228 100644 --- a/Widgets.lean +++ b/Widgets.lean @@ -14,33 +14,58 @@ namespace EventB.Widgets open Lean Server Elab Command open EventB Formula POG ProofWidgets -private def elementWith (tag : String) (attributes : List (String × Json)) - (children : List Html) : Html := +private +def elementWith + (tag : String) + (attributes : List (String × Json)) + (children : List Html) + : Html + := .element tag attributes.toArray children.toArray -private def element (tag : String) (children : List Html) : Html := +private +def element + (tag : String) + (children : List Html) + : Html + := elementWith tag [] children private def text (value : String) : Html := .text value private def classes (value : String) : String × Json := ("className", .str value) -private def badge (label colorClass : String) : Html := +private +def badge + (label colorClass : String) + : Html + := elementWith "span" [classes s!"f7 b dib ml2 ph1 ba br-pill {colorClass}"] [text label] -private def formula (value : Formula.Term) : Html := +private +def formula + (value : Formula.Term) + : Html + := elementWith "pre" [classes "overflow-auto mv2 pa2 ba br1"] [ element "code" [text (Formula.print value)] ] -private def hypothesisList (hyps : List Formula.Term) : Html := +private +def hypothesisList + (hyps : List Formula.Term) + : Html + := if hyps.isEmpty then elementWith "p" [classes "mv1 o-70"] [text "none"] else elementWith "ul" [classes "mv2 pl3"] (hyps.map fun hypothesis => element "li" [formula hypothesis]) -private def evidenceLabel : Trust.Evidence → String +private +def evidenceLabel + : Trust.Evidence → + String | .none => "none" | .kernel declaration axioms => if axioms.isEmpty then s!"Lean declaration {declaration}" @@ -52,10 +77,19 @@ private def evidenceLabel : Trust.Evidence → String | .rodinImportedProvenance _ _ _ _ manual => s!"Rodin provenance ({if manual then "manual" else "automatic"})" -private def hypothesisOnly (obligation : Obligation) : Bool := +private +def hypothesisOnly + (obligation : Obligation) + : Bool + := obligation.kind == "WWD" && obligation.goal.isNone -private def obligationBody (obligation : Obligation) (entry : Trust.Entry) : Html := +private +def obligationBody + (obligation : Obligation) + (entry : Trust.Entry) + : Html + := elementWith "div" [classes "pa2"] [ elementWith "p" [classes "mv1 o-70"] [ text s!"{obligation.hyps.length} hypotheses · {entry.mode.label}" @@ -82,7 +116,10 @@ private def obligationBody (obligation : Obligation) (entry : Trust.Entry) : Htm ] ] -private def kindClass : String → String +private +def kindClass + : String → + String | "INV" => "blue" | "GRD" => "gold" | "SIM" => "purple" @@ -99,7 +136,10 @@ private def kindClass : String → String | "VAR" => "teal" | _ => "grey" -private def kindTitle : String → String +private +def kindTitle + : String → + String | "INV" => "Invariant preservation" | "GRD" => "Guard strengthening" | "SIM" => "Action simulation" @@ -116,13 +156,27 @@ private def kindTitle : String → String | "VAR" => "Variant decrease" | kind => kind -private def fallbackEntry (obligation : Obligation) : Trust.Entry := +private +def fallbackEntry + (obligation : Obligation) + : Trust.Entry + := (Trust.Ledger.ofObligations [obligation]).entries.head! -private def entryFor (ledger : Trust.Ledger) (obligation : Obligation) : Trust.Entry := +private +def entryFor + (ledger : Trust.Ledger) + (obligation : Obligation) + : Trust.Entry + := (ledger.displayEntry? obligation.component obligation.name).getD (fallbackEntry obligation) -private def obligationCard (ledger : Trust.Ledger) (obligation : Obligation) : Html := +private +def obligationCard + (ledger : Trust.Ledger) + (obligation : Obligation) + : Html + := let entry := entryFor ledger obligation elementWith "details" [classes "mv1 ba br1"] [ elementWith "summary" [classes "pointer pa2"] [ @@ -136,23 +190,44 @@ private def obligationCard (ledger : Trust.Ledger) (obligation : Obligation) : H obligationBody obligation entry ] -private def kinds : List String := +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 := +private +def countKind + (kind : String) + (obligations : List Obligation) + : Nat + := obligations.countP (·.kind == kind) -private def countDerived (obligations : List Obligation) : Nat := +private +def countDerived + (obligations : List Obligation) + : Nat + := obligations.countP (·.goal.isSome) -private def stat (label value accent : String) : Html := +private +def stat + (label value accent : String) + : Html + := elementWith "div" [classes "ba br2 pa2 mr2 mb2"] [ elementWith "div" [classes s!"f3 b {accent}"] [text value], elementWith "div" [classes "f7 o-70"] [text label] ] -private def summary (obligations : List Obligation) (ledger : Trust.Ledger) : Html := +private +def summary + (obligations : List Obligation) + (ledger : Trust.Ledger) + : Html + := elementWith "div" [classes "flex flex-wrap mv2"] [ stat "total obligations" (toString obligations.length) "blue", stat "goals derived" (toString (countDerived obligations)) "green", @@ -161,12 +236,21 @@ private def summary (obligations : List Obligation) (ledger : Trust.Ledger) : Ht stat "open / unproved" (toString (ledger.count .unproved)) "red" ] -private def openAttribute (isOpen : Bool) : List (String × Json) := +private +def openAttribute + (isOpen : Bool) + : List (String × Json) + := if isOpen then [("open", .bool true)] else [] -private def kindSection (kind : String) (obligations : List Obligation) - (ledger : Trust.Ledger) (isOpen : Bool) : - Option Html := +private +def kindSection + (kind : String) + (obligations : List Obligation) + (ledger : Trust.Ledger) + (isOpen : Bool) + : Option Html + := if obligations.isEmpty then none else @@ -180,34 +264,75 @@ private def kindSection (kind : String) (obligations : List Obligation) (obligations.map (obligationCard ledger)) ] -private def firstKind (obligations : List Obligation) : Option String := +private +def firstKind + (obligations : List Obligation) + : Option String + := kinds.find? (fun kind => countKind kind obligations > 0) -private def componentChildren (elem : Elem) (kind : String) : List Elem := +private +def componentChildren + (elem : Elem) + (kind : String) + : List Elem + := elem.children.filter (fun child => child.tag == "org.eventb.core." ++ kind) -private def componentAttr (elem : Elem) (key : String) : Option String := +private +def componentAttr + (elem : Elem) + (key : String) + : Option String + := elem.attr? ("org.eventb.core." ++ key) -private def shortTarget (target : String) : String := +private +def shortTarget + (target : String) + : String + := (target.splitOn "/").getLast! -private def componentTargets (elem : Elem) (kind : String) : List String := +private +def componentTargets + (elem : Elem) + (kind : String) + : List String + := (componentChildren elem kind).filterMap (componentAttr · "target") |>.map shortTarget -private def componentNames (elem : Elem) (kind : String) : List String := +private +def componentNames + (elem : Elem) + (kind : String) + : List String + := (componentChildren elem kind).filterMap (componentAttr · "identifier") -private def namesText (names : List String) : String := +private +def namesText + (names : List String) + : String + := names.foldl (fun acc name => if acc.isEmpty then name else acc ++ ", " ++ name) "" -private def infoLine (label value : String) : Html := +private +def infoLine + (label value : String) + : Html + := elementWith "p" [classes "mv1"] [ elementWith "span" [classes "b"] [text s!"{label}: "], text (if value.isEmpty then "none" else value) ] -private def nameList (label : String) (names : List String) : Html := +private +def nameList + (label : String) + (names : List String) + : Html + := elementWith "div" [classes "mb2"] [ elementWith "h4" [classes "mt2 mb1 f6"] [text label], if names.isEmpty then @@ -217,7 +342,12 @@ private def nameList (label : String) (names : List String) : Html := (names.map fun name => element "li" [text name]) ] -private def labelledFormula (elem : Elem) (formulaAttr : String) : Html := +private +def labelledFormula + (elem : Elem) + (formulaAttr : String) + : Html + := let label := (componentAttr elem "label").getD "unnamed" match componentAttr elem formulaAttr with | some source => @@ -229,7 +359,12 @@ private def labelledFormula (elem : Elem) (formulaAttr : String) : Html := | .error _ => infoLine label source | none => infoLine label "missing formula" -private def labelledFormulas (elem : Elem) (kind formulaAttr : String) : Html := +private +def labelledFormulas + (elem : Elem) + (kind formulaAttr : String) + : Html + := let formulas := componentChildren elem kind elementWith "div" [classes "mb2"] [ elementWith "h4" [classes "mt2 mb1 f6"] [text kind], @@ -239,7 +374,11 @@ private def labelledFormulas (elem : Elem) (kind formulaAttr : String) : Html := element "div" (formulas.map (labelledFormula · formulaAttr)) ] -private def eventCard (ev : Elem) : Html := +private +def eventCard + (ev : Elem) + : Html + := let name := (componentAttr ev "label").getD "unnamed event" let refinedTargets := componentTargets ev "refinesEvent" let parameters := componentNames ev "parameter" @@ -256,7 +395,11 @@ private def eventCard (ev : Elem) : Html := ] ] -private def eventList (elem : Elem) : Html := +private +def eventList + (elem : Elem) + : Html + := let events := componentChildren elem "event" elementWith "div" [classes "mb2"] [ elementWith "h4" [classes "mt2 mb1 f6"] [text "Events"], @@ -265,7 +408,12 @@ private def eventList (elem : Elem) : Html := else element "div" (events.map eventCard) ] -private def obligationStats (project : Typing.Project) (name : String) : Html := +private +def obligationStats + (project : Typing.Project) + (name : String) + : Html + := let obligations := POG.generate project name let ledger := Trust.Ledger.ofObligations obligations elementWith "div" [classes "flex flex-wrap mv2"] [ @@ -275,7 +423,12 @@ private def obligationStats (project : Typing.Project) (name : String) : Html := stat "trust ledger" ledger.summary "orange" ] -private def modelPanel (kind name : String) (body : List Html) : Html := +private +def modelPanel + (kind name : String) + (body : List Html) + : Html + := elementWith "details" [classes "mv2", ("open", .bool true)] [ elementWith "summary" [classes "pointer b"] [ text s!"Event-B {kind} · {name}" @@ -284,7 +437,11 @@ private def modelPanel (kind name : String) (body : List Html) : Html := ] /-- Render the declarations and proof-relevant surface of one project component. -/ -def renderComponent (project : Typing.Project) (name : String) : Html := +def renderComponent + (project : Typing.Project) + (name : String) + : Html + := match Typing.lookupComponent project name with | none => modelPanel "component" name [infoLine "error" "component not found"] | some component => @@ -309,7 +466,12 @@ def renderComponent (project : Typing.Project) (name : String) : Html := | _ => modelPanel "component" name [infoLine "error" "unsupported component kind"] /-- Render obligations for a project component under an explicit theory environment. -/ -private def scopedLedger (ledger : Trust.Ledger) (obligations : List Obligation) : Trust.Ledger := +private +def scopedLedger + (ledger : Trust.Ledger) + (obligations : List Obligation) + : Trust.Ledger + := { entries := obligations.map fun obligation => entryFor ledger obligation } /-- Render obligations with evidence supplied by the caller. @@ -318,8 +480,13 @@ The default widget has no proof backend and therefore supplies an empty ledger. the ledger explicit here prevents cards from silently discarding imported or replayed evidence when a front end does have it. -/ -def renderProjectInWithLedger (theory : Theory.Env) (project : Typing.Project) - (machine : String) (ledger : Trust.Ledger) : Html := +def renderProjectInWithLedger + (theory : Theory.Env) + (project : Typing.Project) + (machine : String) + (ledger : Trust.Ledger) + : Html + := let obligations := POG.generateIn theory project machine let ledger := scopedLedger ledger obligations let first := firstKind obligations @@ -342,16 +509,29 @@ def renderProjectInWithLedger (theory : Theory.Env) (project : Typing.Project) ] ] -def renderProjectIn (theory : Theory.Env) (project : Typing.Project) (machine : String) : Html := +def renderProjectIn + (theory : Theory.Env) + (project : Typing.Project) + (machine : String) + : Html + := renderProjectInWithLedger theory project machine (Trust.Ledger.ofObligations (POG.generateIn theory project machine)) -def renderProjectWithLedger (project : Typing.Project) (machine : String) - (ledger : Trust.Ledger) : Html := +def renderProjectWithLedger + (project : Typing.Project) + (machine : String) + (ledger : Trust.Ledger) + : Html + := renderProjectInWithLedger Theory.empty project machine ledger /-- Compatibility widget for projects using only the core prelude. -/ -def renderProject (project : Typing.Project) (machine : String) : Html := +def renderProject + (project : Typing.Project) + (machine : String) + : Html + := renderProjectIn Theory.empty project machine /-- Display generated obligations without changing the ordinary text POG command. -/ diff --git a/bench/Bench.lean b/bench/Bench.lean index ef6d3ec..bcb94ca 100644 --- a/bench/Bench.lean +++ b/bench/Bench.lean @@ -6,7 +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 (args : List String) : IO Unit := do +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)" diff --git a/cli/Cli.lean b/cli/Cli.lean index 8378828..e76156f 100644 --- a/cli/Cli.lean +++ b/cli/Cli.lean @@ -15,8 +15,12 @@ open EventB.Typing open Argus open TermColor -private def diagnosticText (paths : List System.FilePath) (error : EventB.Error) : - IO TermColor.Text := do +private +def diagnosticText + (paths : List System.FilePath) + (error : EventB.Error) + : IO TermColor.Text + := do let candidates := error.path.toList.map System.FilePath.mk ++ paths match candidates.head? with | none => pure (TermColor.Text.plain error.render) @@ -33,28 +37,57 @@ private def diagnosticText (paths : List System.FilePath) (error : EventB.Error) (fun diagnostic context => diagnostic.withNote context) diagnostic pure (TermColor.Diagnostics.render #[source] diagnostic) -private def printError (paths : List System.FilePath) (error : EventB.Error) : IO Unit := do +private +def printError + (paths : List System.FilePath) + (error : EventB.Error) + : IO Unit + := do let stderr ← IO.getStderr let target ← TermColor.targetWithTty .auto (← stderr.isTty) let text ← diagnosticText paths error stderr.putStr (TermColor.Text.render target (text ++ TermColor.Text.plain "\n")) -private def isSource (path : System.FilePath) : Bool := +private +def isSource + (path : System.FilePath) + : Bool + := path.toString.endsWith ".bum" || path.toString.endsWith ".buc" -private def isRossi (path : System.FilePath) : Bool := +private +def isRossi + (path : System.FilePath) + : Bool + := path.toString.endsWith ".eventb" -private def isBpo (path : System.FilePath) : Bool := +private +def isBpo + (path : System.FilePath) + : Bool + := path.toString.endsWith ".bpo" -private def isTheory (path : System.FilePath) : Bool := +private +def isTheory + (path : System.FilePath) + : Bool + := path.toString.endsWith ".tuf" -private def stem (path : System.FilePath) : String := +private +def stem + (path : System.FilePath) + : String + := ((path.toString.splitOn "/").getLast!).splitOn "." |>.head! -private def sourceFiles (dir : System.FilePath) : IO (List System.FilePath) := do +private +def sourceFiles + (dir : System.FilePath) + : IO (List System.FilePath) + := do let mut paths : List System.FilePath := [] for entry in ← dir.readDir do if !(← entry.path.isDir) && isSource entry.path then @@ -63,7 +96,12 @@ private def sourceFiles (dir : System.FilePath) : IO (List System.FilePath) := d -- partiality: recursive directory discovery follows the filesystem, whose depth is not a kernel -- data bound; IO traversal is the correct operational boundary here. -private partial def rossiFiles (dir : System.FilePath) : IO (List System.FilePath) := do +private +partial +def rossiFiles + (dir : System.FilePath) + : IO (List System.FilePath) + := do let mut paths : List System.FilePath := [] for entry in ← dir.readDir do if ← entry.path.isDir then @@ -74,7 +112,12 @@ private partial def rossiFiles (dir : System.FilePath) : IO (List System.FilePat -- partiality: recursive directory discovery follows the filesystem, whose depth is not a kernel -- data bound; IO traversal is the correct operational boundary here. -private partial def theoryFiles (dir : System.FilePath) : IO (List System.FilePath) := do +private +partial +def theoryFiles + (dir : System.FilePath) + : IO (List System.FilePath) + := do let mut paths : List System.FilePath := [] for entry in ← dir.readDir do if ← entry.path.isDir then @@ -83,7 +126,11 @@ private partial def theoryFiles (dir : System.FilePath) : IO (List System.FilePa paths := entry.path :: paths return paths.mergeSort (fun left right => left.toString < right.toString) -private def bpoFiles (dir : System.FilePath) : IO (List System.FilePath) := do +private +def bpoFiles + (dir : System.FilePath) + : IO (List System.FilePath) + := do let mut paths : List System.FilePath := [] for entry in ← dir.readDir do if !(← entry.path.isDir) && isBpo entry.path then @@ -95,7 +142,12 @@ private structure Source where name : String model : Model -private def projectComponent (roots : List String) (source : Source) : Component := +private +def projectComponent + (roots : List String) + (source : Source) + : Component + := { name := source.name, elem := source.model.root, theories := roots } private structure ProjectData where @@ -105,8 +157,11 @@ private structure ProjectData where errors : List EventB.Error paths : List System.FilePath -private def loadTheories (paths : List System.FilePath) : - IO (Theory.Env × List EventB.Error) := do +private +def loadTheories + (paths : List System.FilePath) + : IO (Theory.Env × List EventB.Error) + := do let mut pending := paths let mut env := Theory.empty let mut errors : List EventB.Error := [] @@ -138,7 +193,11 @@ private def loadTheories (paths : List System.FilePath) : pending := next.reverse.map (·.1) return (env, errors.reverse) -private def readSource (path : System.FilePath) : IO (Except EventB.Error Source) := do +private +def readSource + (path : System.FilePath) + : IO (Except EventB.Error Source) + := do try match ← readModel path with | .ok model => @@ -160,14 +219,22 @@ private def readSource (path : System.FilePath) : IO (Except EventB.Error Source catch err => return .error ((EventB.Error.io s!"could not be read: {err}").withPath path.toString) -private def readRossi (path : System.FilePath) : IO (Except EventB.Error (List Source)) := do +private +def readRossi + (path : System.FilePath) + : IO (Except EventB.Error (List Source)) + := do match ← Rossi.read path with | .error reason => return .error (reason.withPath path.toString) | .ok components => return .ok (components.map fun component => { path := path, name := component.name, model := component.model }) -private def loadProject (path : System.FilePath) : IO ProjectData := do +private +def loadProject + (path : System.FilePath) + : IO ProjectData + := do let mut sources : List Source := [] let mut errors : List EventB.Error := [] let isDir ← path.isDir @@ -210,7 +277,12 @@ private def loadProject (path : System.FilePath) : IO ProjectData := do return ProjectData.mk project uniqueSources theory (errors.reverse ++ duplicateErrors.reverse) (path :: theoryPaths ++ sourcePaths ++ rossiPaths) -private def formulaErrorLabel (model : Model) (error : String) : Option String := +private +def formulaErrorLabel + (model : Model) + (error : String) + : Option String + := model.formulas.find? (fun pair => match pair with | (_label, formula) => @@ -223,14 +295,24 @@ private def formulaErrorLabel (model : Model) (error : String) : Option String : (error.drop marker.length).toString) |>.map (·.1) -private def formatTypeError (source : Source) (error : String) : EventB.Error := +private +def formatTypeError + (source : Source) + (error : String) + : EventB.Error + := let reason := if error.startsWith "parse: " then error.drop 7 else error let message := match formulaErrorLabel source.model error with | some label => s!"element {label}: {reason}" | none => s!"typechecking failed: {reason}" (EventB.Error.typing message).withPath source.path.toString -private def typeErrors (data : ProjectData) (source : Source) : List EventB.Error := +private +def typeErrors + (data : ProjectData) + (source : Source) + : List EventB.Error + := match inferComponentIn data.theory data.project source.name with | .error error => [formatTypeError source error.message] | .ok (_, errors) => errors.map (formatTypeError source) @@ -240,20 +322,36 @@ private structure Report where obligations : List Obligation errors : List EventB.Error -private def reports (data : ProjectData) : List Report := +private +def reports + (data : ProjectData) + : List Report + := data.sources.map fun source => { source := source obligations := generateIn data.theory data.project source.name errors := typeErrors data source } -private def fatalErrors (data : ProjectData) (rs : List Report) : List EventB.Error := +private +def fatalErrors + (data : ProjectData) + (rs : List Report) + : List EventB.Error + := data.errors ++ rs.flatMap (·.errors) -private def kinds : List String := +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) := +private +def parseKinds + (value : String) + : Except String (List String) + := let values := value.splitOn "," if values.isEmpty || values.any (fun kind => !kinds.contains kind) then .error s!"unknown obligation class in --kind {value}; use {String.intercalate "," kinds}" @@ -266,12 +364,23 @@ private structure CheckArgs where kinds : Option String := none machine : Option String := none -private def printCheckDiagnostics (data : ProjectData) (rs : List Report) : IO Unit := do +private +def printCheckDiagnostics + (data : ProjectData) + (rs : List Report) + : IO Unit + := do for error in fatalErrors data rs do printError data.paths error -private def makeCheck (dir : System.FilePath) (json : Bool) (kinds : Option String) - (machine : Option String) : CheckArgs := +private +def makeCheck + (dir : System.FilePath) + (json : Bool) + (kinds : Option String) + (machine : Option String) + : CheckArgs + := { dir, json, kinds, machine } private inductive Action where @@ -283,10 +392,16 @@ private inductive Action where | prove (dir : System.FilePath) | diff (dir : System.FilePath) -private def pathParam : Param System.FilePath := +private +def pathParam + : Param System.FilePath + := Param.map System.FilePath.mk Param.path -private def projectArg (help : String) := +private +def projectArg + (help : String) + := Spec.arg "PROJECT" help pathParam private def checkSpec := @@ -302,7 +417,10 @@ private def summarySpec := Spec.map2 Action.summary (projectArg "Project directory or .eventb file") (Spec.switch "json" none "Emit one JSON summary") -private def command : Command Action := +private +def command + : Command Action + := group "eventb" [ cmd "check" (Spec.map Action.check checkSpec) (description := "Typecheck a project and list generated obligations."), @@ -325,7 +443,11 @@ private def command : Command Action := (description := "Compare generated obligation names with Rodin .bpo files.") ] (description := "Inspect Event-B projects from Rodin XML or Rossi text.") -private def jsonEscape (value : String) : String := +private +def jsonEscape + (value : String) + : String + := String.ofList (value.toList.flatMap fun c => match c with | '"' => ['\\', '"'] @@ -335,16 +457,30 @@ private def jsonEscape (value : String) : String := | '\t' => ['\\', 't'] | _ => [c]) -private def jsonString (value : String) : String := +private +def jsonString + (value : String) + : String + := "\"" ++ jsonEscape value ++ "\"" private def jsonBool (value : Bool) : String := if value then "true" else "false" -private def hypothesisOnly (obligation : Obligation) : Bool := +private +def hypothesisOnly + (obligation : Obligation) + : Bool + := obligation.kind == "WWD" && obligation.goal.isNone -private def selected (machine : Option String) (kinds : Option (List String)) (report : Report) - (obligation : Obligation) : Bool := +private +def selected + (machine : Option String) + (kinds : Option (List String)) + (report : Report) + (obligation : Obligation) + : Bool + := (match machine with | none => true | some name => name == report.source.name) && @@ -352,14 +488,23 @@ private def selected (machine : Option String) (kinds : Option (List String)) (r | none => true | some selectedKinds => selectedKinds.contains obligation.kind) -private def filteredObligations (args : CheckArgs) (kinds : Option (List String)) - (rs : List Report) : - List (String × Obligation) := +private +def filteredObligations + (args : CheckArgs) + (kinds : Option (List String)) + (rs : List Report) + : List (String × Obligation) + := rs.flatMap fun report => (report.obligations.filter (selected args.machine kinds report)).map (fun o => (report.source.name, o)) -private def runCheckWithKinds (args : CheckArgs) (kinds : Option (List String)) : IO UInt32 := do +private +def runCheckWithKinds + (args : CheckArgs) + (kinds : Option (List String)) + : IO UInt32 + := do let data ← loadProject args.dir if data.sources.isEmpty then for error in data.errors do @@ -390,7 +535,11 @@ private def runCheckWithKinds (args : CheckArgs) (kinds : Option (List String)) if hypothesisOnly then "hypothesis-only" else "no statement")) return if (fatalErrors data rs).isEmpty then 0 else 1 -private def runCheck (args : CheckArgs) : IO UInt32 := +private +def runCheck + (args : CheckArgs) + : IO UInt32 + := match args.kinds with | none => runCheckWithKinds args none | some value => @@ -400,32 +549,65 @@ private def runCheck (args : CheckArgs) : IO UInt32 := printError [] (EventB.Error.cli s!"eventb check: {error}") return 1 -private def bump (key : String) : List (String × Nat) → List (String × Nat) +private +def bump + (key : String) + : List (String × Nat) → + List (String × Nat) | [] => [(key, 1)] | (name, count) :: rest => if name == key then (name, count + 1) :: rest else (name, count) :: bump key rest -private def countKinds (obligations : List Obligation) : List (String × Nat) := +private +def countKinds + (obligations : List Obligation) + : List (String × Nat) + := obligations.foldl (fun counts obligation => bump obligation.kind counts) [] -private def derivedCount (obligations : List Obligation) : Nat := +private +def derivedCount + (obligations : List Obligation) + : Nat + := obligations.countP (·.goal.isSome) -private def notDerivedCount (obligations : List Obligation) : Nat := +private +def notDerivedCount + (obligations : List Obligation) + : Nat + := obligations.countP (·.goal.isNone) -private def notDerivedKinds (obligations : List Obligation) : List (String × Nat) := +private +def notDerivedKinds + (obligations : List Obligation) + : List (String × Nat) + := countKinds (obligations.filter (·.goal.isNone)) -private def hypothesisOnlyCount (obligations : List Obligation) : Nat := +private +def hypothesisOnlyCount + (obligations : List Obligation) + : Nat + := obligations.countP hypothesisOnly -private def jsonCounts (counts : List (String × Nat)) : String := +private +def jsonCounts + (counts : List (String × Nat)) + : String + := "{" ++ String.intercalate "," (counts.map fun (name, count) => jsonString name ++ ":" ++ toString count) ++ "}" -private def runSummary (dir : System.FilePath) (json : Bool) : IO UInt32 := do +private +def runSummary + (dir : System.FilePath) + (json : Bool) + : IO UInt32 + := do let data ← loadProject dir if data.sources.isEmpty then for error in data.errors do @@ -468,7 +650,11 @@ private def runSummary (dir : System.FilePath) (json : Bool) : IO UInt32 := do s!"({derivedCount report.obligations} derived)") return if (fatalErrors data rs).isEmpty then 0 else 1 -private def runTheory (path : System.FilePath) : IO UInt32 := do +private +def runTheory + (path : System.FilePath) + : IO UInt32 + := do let paths ← if ← path.isDir then theoryFiles path else if isTheory path then pure [path] else pure [] @@ -486,7 +672,11 @@ private def runTheory (path : System.FilePath) : IO UInt32 := do String.intercalate "," spec.imports) return if errors.isEmpty then 0 else 1 -private def runProve (dir : System.FilePath) : IO UInt32 := do +private +def runProve + (dir : System.FilePath) + : IO UInt32 + := do let data ← loadProject dir if data.sources.isEmpty then for error in data.errors do @@ -507,14 +697,23 @@ private def runProve (dir : System.FilePath) : IO UInt32 := do IO.println s!" {obligation.name}: {rule.label} [external evidence]" return if (fatalErrors data rs).isEmpty then 0 else 1 -private def findObligation : List Report → String → Option (String × Obligation) +private +def findObligation + : List Report → -- reports to search + String → -- obligation name to find + Option (String × Obligation) | [], _ => none | report :: rest, name => match report.obligations.find? (fun obligation => obligation.name == name) with | some obligation => some (report.source.name, obligation) | none => findObligation rest name -private def runPo (dir : System.FilePath) (name : String) : IO UInt32 := do +private +def runPo + (dir : System.FilePath) + (name : String) + : IO UInt32 + := do let data ← loadProject dir if data.sources.isEmpty then for error in data.errors do @@ -541,7 +740,11 @@ private def runPo (dir : System.FilePath) (name : String) : IO UInt32 := do mutual -private def poNames (elem : XmlElem) : List String := +private +def poNames + (elem : XmlElem) + : List String + := let here := if elem.tag == "org.eventb.core.poSequent" then elem.attr? "name" |>.toList else [] @@ -550,7 +753,10 @@ private def poNames (elem : XmlElem) : List String := termination_by sizeOf elem decreasing_by cases elem; simp +arith -private def poNamesList : List XmlElem → List String +private +def poNamesList + : List XmlElem → + List String | [] => [] | elem :: rest => poNames elem ++ poNamesList rest @@ -558,7 +764,11 @@ termination_by rest => sizeOf rest end -private def readGoldPOs (path : System.FilePath) : IO (Except String (List String)) := do +private +def readGoldPOs + (path : System.FilePath) + : IO (Except String (List String)) + := do try let bytes ← IO.FS.readBinFile path match parseXml bytes with @@ -567,22 +777,37 @@ private def readGoldPOs (path : System.FilePath) : IO (Except String (List Strin catch error => return .error s!"could not be read: {error}" -private def localLedger (obligations : List Obligation) : Trust.Ledger := +private +def localLedger + (obligations : List Obligation) + : Trust.Ledger + := obligations.foldl (fun ledger obligation => match Prover.Local.attach ledger obligation (Prover.Local.prove obligation) with | .ok updated => updated | .error _ => ledger) (Trust.Ledger.ofObligations obligations) -private def reportCoverage (gold : List (String × List String)) - (machine name : String) : String := +private +def reportCoverage + (gold : List (String × List String)) + (machine name : String) + : String + := match gold.find? (·.1 == machine) with | none => "not-compared" | some (_, names) => if names.contains name then "name-matched" else "name-missing" -private def jsonArray (values : List String) : String := +private +def jsonArray + (values : List String) + : String + := "[" ++ String.intercalate "," (values.map jsonString) ++ "]" -private def evidenceJson : Trust.Evidence → String +private +def evidenceJson + : Trust.Evidence → + String | .none => "{\"mode\":\"unproved\",\"declaration\":\"\",\"verifier\":\"\",\"dependencies\":[]}" | .kernel declaration axioms => @@ -622,8 +847,14 @@ private def evidenceJson : Trust.Evidence → String #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 := +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.displayEntry? machine obligation.name).getD fallback let mode := entry.mode.label @@ -644,7 +875,11 @@ private def reportEntry (gold : List (String × List String)) (ledger : Trust.Le ",\"fingerprint\":" ++ jsonString (Trust.fingerprint obligation.canonical) ++ ",\"goal\":" ++ jsonString goal ++ "}" -private def runReport (dir : System.FilePath) : IO UInt32 := do +private +def runReport + (dir : System.FilePath) + : IO UInt32 + := do let data ← loadProject dir if data.sources.isEmpty then for error in data.errors do @@ -678,10 +913,19 @@ private def runReport (dir : System.FilePath) : IO UInt32 := do "],\"trust_ledger\":{" ++ String.intercalate "," counts ++ "}}") return if (fatalErrors data rs).isEmpty then 0 else 1 -private def findSource (sources : List Source) (name : String) : Option Source := +private +def findSource + (sources : List Source) + (name : String) + : Option Source + := sources.find? (fun source => source.name == name) -private def runDiff (dir : System.FilePath) : IO UInt32 := do +private +def runDiff + (dir : System.FilePath) + : IO UInt32 + := do let data ← loadProject dir if data.sources.isEmpty then printError [dir] @@ -729,7 +973,10 @@ private def runDiff (dir : System.FilePath) : IO UInt32 := do ((EventB.Error.cli "eventb diff: no matching .bpo file").withPath source.path.toString) return if failed then 1 else 0 -private def runAction : Action → IO UInt32 +private +def runAction + : Action → + IO UInt32 | .check args => runCheck args | .po dir name => runPo dir name | .summary dir json => runSummary dir json @@ -738,7 +985,10 @@ private def runAction : Action → IO UInt32 | .prove dir => runProve dir | .diff dir => runDiff dir -def main (args : List String) : IO UInt32 := do +def main + (args : List String) + : IO UInt32 + := do try Argus.Term.main command args runAction catch error => diff --git a/examples/BookBridge.lean b/examples/BookBridge.lean index e5795d0..ceeb178 100644 --- a/examples/BookBridge.lean +++ b/examples/BookBridge.lean @@ -225,7 +225,9 @@ partial/total functions, domain restriction, images, lambdas, quantifiers, inter boolean values, simultaneous assignments, witnesses, theorem predicates and refinement targets. These are deliberately real `Elem` trees, not comments or parser-only tests. -/ -def bookProject : Typing.Project := +def bookProject + : Typing.Project + := [ { name := "BridgeCtx", elem := BridgeCtx } , { name := "Bridge0", elem := Bridge0 } , { name := "Bridge1", elem := Bridge1 } @@ -237,14 +239,26 @@ def bookProject : Typing.Project := , { name := "File2", elem := File2 } , { name := "File3", elem := File3 } ] -private def hasPO (machine name : String) : Bool := +private +def hasPO + (machine name : String) + : Bool + := (POG.generate bookProject machine).any (·.name == name) -private def goalText (machine name : String) : Option String := +private +def goalText + (machine name : String) + : Option String + := (POG.generate bookProject machine).find? (·.name == name) |>.bind (fun obligation => obligation.goal.map Formula.print) -private def hypothesesText (machine name : String) : Option (List String) := +private +def hypothesesText + (machine name : String) + : Option (List String) + := (POG.generate bookProject machine).find? (·.name == name) |>.map (fun obligation => obligation.hyps.map Formula.print) diff --git a/examples/BookPrograms.lean b/examples/BookPrograms.lean index c64022b..e45b194 100644 --- a/examples/BookPrograms.lean +++ b/examples/BookPrograms.lean @@ -281,7 +281,9 @@ eventb_machine Inverse1 where guard grd2 : "f((r + 1 + q) ÷ 2) ≤ n" action act1 : "r ≔ (r + 1 + q) ÷ 2" -def programsProject : Typing.Project := +def programsProject + : Typing.Project + := [ { name := "NotationCtx", elem := NotationCtx } , { name := "NotationMachine", elem := NotationMachine } , { name := "MathCtx", elem := MathCtx } @@ -300,7 +302,11 @@ def programsProject : Typing.Project := , { name := "Inverse0", elem := Inverse0 } , { name := "Inverse1", elem := Inverse1 } ] -private def hasPO (machine name : String) : Bool := +private +def hasPO + (machine name : String) + : Bool + := (POG.generate programsProject machine).any (·.name == name) #guard hasPO "NotationMachine" "INITIALISATION/inv0_1/INV" @@ -317,7 +323,11 @@ private def hasPO (machine name : String) : Bool := #guard hasPO "SimpleProgram" "progress/NAT" #guard hasPO "SimpleProgram" "progress/VAR" -private def goalText (machine name : String) : Option String := +private +def goalText + (machine name : String) + : Option String + := (POG.generate programsProject machine).find? (·.name == name) |>.bind (·.goal.map Formula.print) diff --git a/examples/BookSystems.lean b/examples/BookSystems.lean index 69637e0..df4298b 100644 --- a/examples/BookSystems.lean +++ b/examples/BookSystems.lean @@ -496,7 +496,9 @@ eventb_machine Train1 where guard grd1 : "r ∈ rdy" action act1 : "occ, lbt, rdy ≔ occ ∪ {fst(r)}, lbt ∪ {fst(r)}, rdy ∖ {r}" -def systemsProject : Typing.Project := +def systemsProject + : Typing.Project + := [ { name := "PressCtx", elem := PressCtx } , { name := "Press0", elem := Press0 } , { name := "Press1", elem := Press1 } @@ -526,7 +528,11 @@ def systemsProject : Typing.Project := , { name := "Train0", elem := Train0 } , { name := "Train1", elem := Train1 } ] -private def hasPO (machine name : String) : Bool := +private +def hasPO + (machine name : String) + : Bool + := (POG.generate systemsProject machine).any (·.name == name) #guard hasPO "Press0" "a_on/inv0_1/INV" @@ -538,11 +544,19 @@ private def hasPO (machine name : String) : Bool := #guard hasPO "Access0" "enter/inv0_1/INV" #guard hasPO "Train1" "route_formation/act1/SIM" -private def pressGoal (name : String) : Option String := +private +def pressGoal + (name : String) + : Option String + := (POG.generate systemsProject "Press0").find? (·.name == name) |>.bind (fun obligation => obligation.goal.map Formula.print) -private def pressHypotheses (name : String) : Option (List String) := +private +def pressHypotheses + (name : String) + : Option (List String) + := (POG.generate systemsProject "Press0").find? (·.name == name) |>.map (fun obligation => obligation.hyps.map Formula.print) diff --git a/examples/LspDemo.lean b/examples/LspDemo.lean index e44c882..072eb63 100644 --- a/examples/LspDemo.lean +++ b/examples/LspDemo.lean @@ -19,14 +19,26 @@ eventb_machine LspMachine where event step where action act : state := state + 1 -private def symbolName (owner symbol : String) : Name := +private +def symbolName + (owner symbol : String) + : Name + := Name.mkSimple ("EventB.DSL.symbol." ++ owner ++ "." ++ symbol) -private def requireRange (owner symbol : String) : CommandElabM Unit := do +private +def requireRange + (owner symbol : String) + : CommandElabM Unit + := do unless (← Lean.findDeclarationRanges? (symbolName owner symbol)).isSome do throwError s!"missing native Event-B source range for `{owner}.{symbol}`" -private def requireDeclaration (name : Name) : CommandElabM Unit := do +private +def requireDeclaration + (name : Name) + : CommandElabM Unit + := do unless (← Lean.findDeclarationRanges? name).isSome do throwError s!"missing native declaration range for `{name}`" diff --git a/examples/ProverDemo.lean b/examples/ProverDemo.lean index fb16577..9969b85 100644 --- a/examples/ProverDemo.lean +++ b/examples/ProverDemo.lean @@ -5,7 +5,10 @@ import EventB.Trust.Replay open EventB EventB.POG EventB.Prover.Local -private def obligations : List Obligation := +private +def obligations + : List Obligation + := [{ component := "Demo", name := "true", kind := "THM", goal := some (.id "⊤") }, { component := "Demo", name := "refl", kind := "THM", goal := some (.bin "=" (.id "x") (.id "x")) }, @@ -21,47 +24,80 @@ namespace KernelChecks open Lean Elab Command Meta open EventB EventB.Embedding EventB.Formula EventB.POG -private def trueObligation : Obligation := +private +def trueObligation + : Obligation + := { component := "Demo", name := "true", kind := "THM", goal := some (.id "⊤") } -private def exactObligation : Obligation := +private +def exactObligation + : Obligation + := { component := "Demo", name := "exact", kind := "THM", goal := some (.id "⊤"), hyps := [.id "⊤"] } -private def reflexiveObligation : Obligation := +private +def reflexiveObligation + : Obligation + := { component := "Demo", name := "refl", kind := "THM" goal := some (.bin "=" (.num 1) (.num 1)) } -private def numeralObligation : Obligation := +private +def numeralObligation + : Obligation + := { component := "Demo", name := "zero-lt-numeral", kind := "THM" goal := some (.bin "<" (.num 0) (.num 1)) } -private def contradictionObligation : Obligation := +private +def contradictionObligation + : Obligation + := { component := "Demo", name := "contra", kind := "THM", goal := some (.bin "=" (.num 1) (.num 2)), hyps := [.id "⊥"] } -private def conjunctionObligation : Obligation := +private +def conjunctionObligation + : Obligation + := { component := "Demo", name := "and", kind := "THM", goal := some (.bin "∧" (.id "⊤") (.bin "=" (.num 1) (.num 1))) } -private def membershipObligation : Obligation := +private +def membershipObligation + : Obligation + := { component := "Demo", name := "membership", kind := "THM", goal := some (.bin "∈" (.num 1) (.set [.num 1, .num 2])) } -private def subsetObligation : Obligation := +private +def subsetObligation + : Obligation + := { component := "Demo", name := "subset", kind := "THM", goal := some (.bin "⊆" (.set [.num 1]) (.set [.num 1])) } -private def implicationObligation : Obligation := +private +def implicationObligation + : Obligation + := { component := "Demo", name := "imp", kind := "THM", goal := some (.bin "⇒" (.id "⊤") (.id "⊤")) } -private def projectionObligation : Obligation := +private +def projectionObligation + : Obligation + := { component := "Demo", name := "projection", kind := "THM", goal := some (.bin "=" (.num 1) (.num 2)), hyps := [.bin "∧" (.id "⊤") (.bin "=" (.num 1) (.num 2))] } -private def examples : List (EventB.Prover.Kernel.Rule × Obligation) := +private +def examples + : List (EventB.Prover.Kernel.Rule × Obligation) + := [(.true, trueObligation), (.exactHypothesis, exactObligation), (.reflexive, reflexiveObligation), (.contradiction, contradictionObligation), (.zeroLtNumeral, numeralObligation), diff --git a/examples/RodinTheoryDemo.lean b/examples/RodinTheoryDemo.lean index f4c6c96..475e517 100644 --- a/examples/RodinTheoryDemo.lean +++ b/examples/RodinTheoryDemo.lean @@ -58,12 +58,18 @@ private def unsupported := | .error _ => true | .ok _ => false -private def baseSymbol : EventB.Prelude.Symbol := +private +def baseSymbol + : EventB.Prelude.Symbol + := { name := "LIMIT", kind := .constant, type := some .int, description := "A base constant.", id := EventB.Prelude.SymbolId.unqualified "LIMIT", source := EventB.SourceRange.synthetic } -private def base : Spec := +private +def base + : Spec + := { name := "Base", symbols := [baseSymbol] } #guard match Theory.add Theory.empty base with diff --git a/examples/RossiBoundaryDemo.lean b/examples/RossiBoundaryDemo.lean index a1dae31..4324f7b 100644 --- a/examples/RossiBoundaryDemo.lean +++ b/examples/RossiBoundaryDemo.lean @@ -8,16 +8,32 @@ namespace EventB.RossiBoundaryDemo open EventB -private def childrenWith (tag : String) (elem : Elem) : List Elem := +private +def childrenWith + (tag : String) + (elem : Elem) + : List Elem + := elem.children.filter (fun child => child.tag == "org.eventb.core." ++ tag) -private def formulaOf (elem : Elem) : Option String := +private +def formulaOf + (elem : Elem) + : Option String + := elem.attr? "org.eventb.core.predicate" -private def assignmentOf (elem : Elem) : Option String := +private +def assignmentOf + (elem : Elem) + : Option String + := elem.attr? "org.eventb.core.assignment" -private def wrapped : String := +private +def wrapped + : String + := "CONTEXT C\nSETS S\nCONSTANTS x y\nAXIOMS\n@a\nx ∈ S\n∧ y ∈ S\n@b\ny = y\nEND\n" ++ "MACHINE M\nSEES C\nVARIABLES v w\nEVENTS\nEVENT INITIALISATION\nTHEN\n" ++ "v := 0 v := 1\nEND\nEVENT update\nTHEN\n@set_v\n" ++ diff --git a/examples/RossiDemo.lean b/examples/RossiDemo.lean index f85061d..eacf2e3 100644 --- a/examples/RossiDemo.lean +++ b/examples/RossiDemo.lean @@ -10,7 +10,10 @@ namespace EventB.RossiDemo open EventB -private def source : String := +private +def source + : String + := "CONTEXT counter_ctx SETS STATUS CONSTANTS max_value " ++ "AXIOMS @max_value_eq max_value = 100 @max_value_pos max_value > 0 END " ++ "MACHINE counter SEES counter_ctx VARIABLES count INVARIANTS " ++ @@ -19,10 +22,18 @@ private def source : String := "EVENT increment STATUS convergent WHERE @below_max count < max_value " ++ "THEN count := count + 1 END END" -private def childrenWith (tag : String) (elem : Elem) : List Elem := +private +def childrenWith + (tag : String) + (elem : Elem) + : List Elem + := elem.children.filter (fun child => child.tag == "org.eventb.core." ++ tag) -private def compactMachine : String := +private +def compactMachine + : String + := "MACHINE M VARIABLES x INVARIANTS @i x ∈ ℕ EVENTS " ++ "EVENT INITIALISATION THEN x := 0 END END" @@ -44,7 +55,10 @@ private def compactMachine : String := | .error message => (EventB.Error.render message).contains "formula" | _ => false -private def sourceWithRefinement : String := +private +def sourceWithRefinement + : String + := "context C\nsets\n S = {a, b}\nconstants\n k\n" ++ "axioms\n @a1\n k ∈ S\ntheorems\n theorem @t1 k = k\nend\n" ++ "machine M\nvariables x\nevents\nconvergent event M\nrefines Old\n" ++ diff --git a/examples/TheoryDemo.lean b/examples/TheoryDemo.lean index 78bb4a2..32f021c 100644 --- a/examples/TheoryDemo.lean +++ b/examples/TheoryDemo.lean @@ -43,18 +43,25 @@ eventb_machine TheoryMachine where event INITIALISATION where action act1 : cars := 0 -def theoryProject : Typing.Project := +def theoryProject + : Typing.Project + := [ { name := "TheoryCtx", elem := TheoryCtx, theories := ["Controls"] } , { name := "TheoryMachine", elem := TheoryMachine, theories := ["Controls"] } ] -def theoryEnv : Theory.Env := +def theoryEnv + : Theory.Env + := match Theory.register [Bounds, Controls, Algebra, Generic] with | .ok env => env | .error _ => Theory.empty #guard (Theory.declaration? theoryEnv ["Algebra"] "Colour").isSome #guard (Theory.declaration? theoryEnv ["Algebra"] "add_zero").isSome -private def genericDatatype : Bool := +private +def genericDatatype + : Bool + := match Theory.declaration? theoryEnv ["Generic"] "Box" with | some (_, declaration) => match declaration with diff --git a/examples/TheoryEmbedDemo.lean b/examples/TheoryEmbedDemo.lean index 64dbb35..002a1eb 100644 --- a/examples/TheoryEmbedDemo.lean +++ b/examples/TheoryEmbedDemo.lean @@ -9,7 +9,10 @@ open EventB EventB.Embedding EventB.Formula EventB.Theory theorem zeroReflexive (zero : Int) : zero = zero := rfl -theorem addZero (value : Int) : value + 0 = value := by +theorem addZero + (value : Int) + : value + 0 = value + := by simp inductive Colour where diff --git a/examples/TheoryValidateDemo.lean b/examples/TheoryValidateDemo.lean index 60d9173..9686c64 100644 --- a/examples/TheoryValidateDemo.lean +++ b/examples/TheoryValidateDemo.lean @@ -8,43 +8,67 @@ open EventB.Typing open EventB.Theory open EventB.Theory.Validate -private def validDefinition : Declaration := +private +def validDefinition + : Declaration + := .definitionDecl { name := "zero", parameters := [], result := .int, body := .num 0 } -private def invalidDefinition : Declaration := +private +def invalidDefinition + : Declaration + := .definitionDecl { name := "bad", parameters := [], result := .bool, body := .num 0 } -private def validInference : Declaration := +private +def validInference + : Declaration + := .ruleDecl { name := "lt_identity", kind := .inference, parameters := [("x", .int), ("y", .int)] premises := [.bin "<" (.id "x") (.id "y")] conclusion := some (.bin "<" (.id "x") (.id "y")) } -private def validTheorem : Declaration := +private +def validTheorem + : Declaration + := .ruleDecl { name := "zero_eq", kind := .theorem conclusion := some (.bin "=" (.num 0) (.num 0)) } -private def polymorphicTheorem : Declaration := +private +def polymorphicTheorem + : Declaration + := .ruleDecl { name := "identity_eq", kind := .theorem, typeParameters := ["α"] parameters := [("x", .given "α")] conclusion := some (.bin "=" (.id "x") (.id "x")) } -private def unscopedType : Declaration := +private +def unscopedType + : Declaration + := .definitionDecl { name := "unscoped", parameters := [("x", .given "β")], result := .given "β" body := .id "x" } -private def nonDecreasingRewrite : Declaration := +private +def nonDecreasingRewrite + : Declaration + := .ruleDecl { name := "cycle", kind := .rewrite, parameters := [("x", .int)] lhs := some (.id "x") rhs := some (.bin "+" (.id "x") (.num 0)) } -private def validRewrite : Declaration := +private +def validRewrite + : Declaration + := .ruleDecl { name := "add_zero", kind := .rewrite, parameters := [("x", .int)] lhs := some (.bin "+" (.id "x") (.num 0)) @@ -67,7 +91,10 @@ private def validRewrite : Declaration := #guard (validateDeclaration Theory.empty [] nonDecreasingRewrite).obligations.any (fun obligation => obligation.kind == .rewriteTermination && obligation.status == .open) -private def duplicateSpec : Spec := +private +def duplicateSpec + : Spec + := { name := "Duplicate" declarations := [validDefinition, validDefinition] } diff --git a/examples/TrustRodinDemo.lean b/examples/TrustRodinDemo.lean index f905426..aa0ef0d 100644 --- a/examples/TrustRodinDemo.lean +++ b/examples/TrustRodinDemo.lean @@ -5,7 +5,10 @@ namespace EventB.TrustRodinDemo open EventB -private def obligation : POG.Obligation := +private +def obligation + : POG.Obligation + := { component := "Demo", name := "INITIALISATION/inv/INV", kind := "INV" goal := some (.bin "∈" (.num 0) (.id "ℤ")) } @@ -15,7 +18,10 @@ private def source := "org.eventb.core.confidence=\"1000\" org.eventb.core.psManual=\"false\"/>" ++ "" -private def provenance : Trust.Rodin.Provenance := +private +def provenance + : Trust.Rodin.Provenance + := { models := [{ component := "Demo", kind := .machine, bytes := (" ledger | some obligation => @@ -166,13 +258,19 @@ private def attachWidgetProof (ledger : Trust.Ledger) | .ok updated => updated | .error _ => ledger -def widgetLedger : Trust.Ledger := +def widgetLedger + : Trust.Ledger + := let obligations := POG.generate widgetProject "BridgeController" let initial := Trust.Ledger.ofObligations obligations widgetProofs.foldl (fun ledger (name, declaration) => attachWidgetProof ledger obligations name declaration) initial -private def validateWidgetProofs (limit cars gate : Expr) : MetaM Unit := do +private +def validateWidgetProofs + (limit cars gate : Expr) + : MetaM Unit + := do let context : Embedding.KernelContext := { bindings := [{ name := "LIMIT", ty := .int, value := limit } diff --git a/notes/production-acceptance.md b/notes/production-acceptance.md index 6c94da7..70a6684 100644 --- a/notes/production-acceptance.md +++ b/notes/production-acceptance.md @@ -10,8 +10,8 @@ The current acceptance run uses Lean `v4.33.0`, ProofWidgets `v0.0.108`, and `corpus/MANIFEST.tsv` SHA256 `c76a5dca92f0ea32f8c1e20e9da4cb88006bd048cee78d9fd66d03a20e664c45`. The corpus itself remains pinned to the upstream commits recorded in the manifest. -The release candidate is accepted only after the clean-checkout command matrix below -passes; the current worktree is intentionally still under adversarial review. +The v4.0.10 release candidate was accepted after the clean-checkout command matrix below +passed against the final committed snapshot; the supported-path ceilings remain explicit. | Gate | Result | Interpretation | | --- | ---: | --- | diff --git a/spike/Spike/Prelude.lean b/spike/Spike/Prelude.lean index 80f676c..766c282 100644 --- a/spike/Spike/Prelude.lean +++ b/spike/Spike/Prelude.lean @@ -39,68 +39,181 @@ def ranSub (r : Rel α β) (s : Set β) : Rel α β := {p ∈ r | p.2 ∉ s} /-- Override `r q`: `q` wins wherever it is defined. -/ def override (r q : Rel α β) : Rel α β := q ∪ domSub (dom q) r -def comp (r : Rel α β) (q : Rel β γ) : Rel α γ := +def comp + (r : Rel α β) + (q : Rel β γ) + : Rel α γ + := {p | ∃ b, (p.1, b) ∈ r ∧ (b, p.2) ∈ q} -@[simp] theorem mem_dom (r : Rel α β) (a : α) : - a ∈ dom r ↔ ∃ b, (a, b) ∈ r := Iff.rfl - -@[simp] theorem mem_ran (r : Rel α β) (b : β) : - b ∈ ran r ↔ ∃ a, (a, b) ∈ r := Iff.rfl - -@[simp] theorem mem_image (r : Rel α β) (s : Set α) (b : β) : - b ∈ image r s ↔ ∃ a ∈ s, (a, b) ∈ r := Iff.rfl - -@[simp] theorem mem_domRes (s : Set α) (r : Rel α β) (a : α) (b : β) : - (a, b) ∈ domRes s r ↔ (a, b) ∈ r ∧ a ∈ s := Iff.rfl - -@[simp] theorem mem_domSub (s : Set α) (r : Rel α β) (a : α) (b : β) : - (a, b) ∈ domSub s r ↔ (a, b) ∈ r ∧ a ∉ s := Iff.rfl - -@[simp] theorem mem_ranRes (r : Rel α β) (s : Set β) (a : α) (b : β) : - (a, b) ∈ ranRes r s ↔ (a, b) ∈ r ∧ b ∈ s := Iff.rfl - -@[simp] theorem mem_ranSub (r : Rel α β) (s : Set β) (a : α) (b : β) : - (a, b) ∈ ranSub r s ↔ (a, b) ∈ r ∧ b ∉ s := Iff.rfl - -@[simp] theorem mem_override (r q : Rel α β) (a : α) (b : β) : - (a, b) ∈ override r q ↔ (a, b) ∈ q ∨ ((a, b) ∈ r ∧ a ∉ dom q) := by +@[simp] +theorem mem_dom + (r : Rel α β) + (a : α) + : a ∈ dom r ↔ + ∃ b, + (a, b) ∈ r + := Iff.rfl + +@[simp] +theorem mem_ran + (r : Rel α β) + (b : β) + : b ∈ ran r ↔ + ∃ a, + (a, b) ∈ r + := Iff.rfl + +@[simp] +theorem mem_image + (r : Rel α β) + (s : Set α) + (b : β) + : b ∈ image r s ↔ + ∃ a ∈ s, + (a, b) ∈ r + := Iff.rfl + +@[simp] +theorem mem_domRes + (s : Set α) + (r : Rel α β) + (a : α) + (b : β) + : (a, b) ∈ domRes s r ↔ + (a, b) ∈ r ∧ + a ∈ s + := Iff.rfl + +@[simp] +theorem mem_domSub + (s : Set α) + (r : Rel α β) + (a : α) + (b : β) + : (a, b) ∈ domSub s r ↔ + (a, b) ∈ r ∧ + a ∉ s + := Iff.rfl + +@[simp] +theorem mem_ranRes + (r : Rel α β) + (s : Set β) + (a : α) + (b : β) + : (a, b) ∈ ranRes r s ↔ + (a, b) ∈ r ∧ + b ∈ s + := Iff.rfl + +@[simp] +theorem mem_ranSub + (r : Rel α β) + (s : Set β) + (a : α) + (b : β) + : (a, b) ∈ ranSub r s ↔ + (a, b) ∈ r ∧ + b ∉ s + := Iff.rfl + +@[simp] +theorem mem_override + (r q : Rel α β) + (a : α) + (b : β) + : (a, b) ∈ override r q ↔ + (a, b) ∈ q ∨ + ((a, b) ∈ r ∧ a ∉ dom q) + := by simp [override] -def partition (s : Set α) (parts : List (Set α)) : Prop := +def partition + (s : Set α) + (parts : List (Set α)) + : Prop + := s = parts.foldr (· ∪ ·) ∅ ∧ parts.Pairwise (fun a b => Disjoint a b) /-- `r` is functional: no argument is related to two results. -/ -def IsFun (r : Rel α β) : Prop := +def IsFun + (r : Rel α β) + : Prop + := ∀ a b₁ b₂, (a, b₁) ∈ r → (a, b₂) ∈ r → b₁ = b₂ /-- The arrow families, each a *set of relations*, which is how Event-B states them and why membership in an arrow is a predicate rather than a typing judgement. -/ -def rel (s : Set α) (t : Set β) : Set (Rel α β) := +def rel + (s : Set α) + (t : Set β) + : Set (Rel α β) + := {r | dom r ⊆ s ∧ ran r ⊆ t} /-- The three arrow families Rodin spells with private-use codepoints U+E100..U+E102: surjective, total, and total surjective *relations*. They have no standard Unicode spelling, which is why they are easy to lose when copying an operator table. -/ -def srel (s : Set α) (t : Set β) : Set (Rel α β) := +def srel + (s : Set α) + (t : Set β) + : Set (Rel α β) + := {r | r ∈ rel s t ∧ ran r = t} -def trel (s : Set α) (t : Set β) : Set (Rel α β) := +def trel + (s : Set α) + (t : Set β) + : Set (Rel α β) + := {r | r ∈ rel s t ∧ dom r = s} -def strel (s : Set α) (t : Set β) : Set (Rel α β) := +def strel + (s : Set α) + (t : Set β) + : Set (Rel α β) + := {r | r ∈ rel s t ∧ dom r = s ∧ ran r = t} -def pfun (s : Set α) (t : Set β) : Set (Rel α β) := +def pfun + (s : Set α) + (t : Set β) + : Set (Rel α β) + := {r | r ∈ rel s t ∧ IsFun r} -def tfun (s : Set α) (t : Set β) : Set (Rel α β) := +def tfun + (s : Set α) + (t : Set β) + : Set (Rel α β) + := {r | r ∈ pfun s t ∧ dom r = s} -def pinj (s : Set α) (t : Set β) : Set (Rel α β) := +def pinj + (s : Set α) + (t : Set β) + : Set (Rel α β) + := {r | r ∈ pfun s t ∧ IsFun (inv r)} -def tinj (s : Set α) (t : Set β) : Set (Rel α β) := +def tinj + (s : Set α) + (t : Set β) + : Set (Rel α β) + := {r | r ∈ tfun s t ∧ IsFun (inv r)} -def psurj (s : Set α) (t : Set β) : Set (Rel α β) := +def psurj + (s : Set α) + (t : Set β) + : Set (Rel α β) + := {r | r ∈ pfun s t ∧ ran r = t} -def tsurj (s : Set α) (t : Set β) : Set (Rel α β) := +def tsurj + (s : Set α) + (t : Set β) + : Set (Rel α β) + := {r | r ∈ tfun s t ∧ ran r = t} -def tbij (s : Set α) (t : Set β) : Set (Rel α β) := +def tbij + (s : Set α) + (t : Set β) + : Set (Rel α β) + := {r | r ∈ tinj s t ∧ ran r = t} /-- Cartesian product as an Event-B *value*, a set of pairs. -/ @@ -109,74 +222,147 @@ def prod (s : Set α) (t : Set β) : Rel α β := {p | p.1 ∈ s ∧ p.2 ∈ t} /-- Integer range `a ‥ b`. -/ def upto (a b : Int) : Set Int := {n | a ≤ n ∧ n ≤ b} -@[simp] theorem mem_inv (r : Rel α β) (a : α) (b : β) : - (b, a) ∈ inv r ↔ (a, b) ∈ r := Iff.rfl - -@[simp] theorem mem_prod (s : Set α) (t : Set β) (a : α) (b : β) : - (a, b) ∈ prod s t ↔ a ∈ s ∧ b ∈ t := Iff.rfl - -@[simp] theorem mem_upto (a b n : Int) : - n ∈ upto a b ↔ a ≤ n ∧ n ≤ b := Iff.rfl +@[simp] +theorem mem_inv + (r : Rel α β) + (a : α) + (b : β) + : (b, a) ∈ inv r ↔ + (a, b) ∈ r + := Iff.rfl + +@[simp] +theorem mem_prod + (s : Set α) + (t : Set β) + (a : α) + (b : β) + : (a, b) ∈ prod s t ↔ + a ∈ s ∧ + b ∈ t + := Iff.rfl + +@[simp] +theorem mem_upto + (a b n : Int) + : n ∈ upto a b ↔ + a ≤ n ∧ + n ≤ b + := Iff.rfl /-- `ℕ` as a subset of `ℤ`, which is how Event-B uses it. -/ def NAT : Set Int := {n | 0 ≤ n} def NAT1 : Set Int := {n | 1 ≤ n} /-- Event-B's maximum is defined only for a nonempty set bounded above. -/ -noncomputable def max (s : Set Int) : Int := +noncomputable +def max + (s : Set Int) + : Int + := open Classical in if h : ∃ m, m ∈ s ∧ ∀ x ∈ s, x ≤ m then h.choose else Classical.arbitrary Int -@[grind] theorem max_mem {s : Set Int} - (h : ∃ m, m ∈ s ∧ ∀ x ∈ s, x ≤ m) : max s ∈ s := by +@[grind] +theorem max_mem + {s : Set Int} + (h : ∃ m, m ∈ s ∧ ∀ x ∈ s, x ≤ m) + : max s ∈ s + := by simp only [max, dif_pos h] exact h.choose_spec.1 -@[grind] theorem max_le {s : Set Int} - (h : ∃ m, m ∈ s ∧ ∀ x ∈ s, x ≤ m) : ∀ x ∈ s, x ≤ max s := by +@[grind] +theorem max_le + {s : Set Int} + (h : ∃ m, m ∈ s ∧ ∀ x ∈ s, x ≤ m) + : ∀ x ∈ s, + x ≤ max s + := by simp only [max, dif_pos h] exact h.choose_spec.2 -theorem max_eq {s : Set Int} {m : Int} - (hs : ∃ x, x ∈ s ∧ ∀ y ∈ s, y ≤ x) (hm : m ∈ s) - (hmax : ∀ x ∈ s, x ≤ m) : max s = m := by +theorem max_eq + {s : Set Int} + {m : Int} + (hs : ∃ x, x ∈ s ∧ ∀ y ∈ s, y ≤ x) + (hm : m ∈ s) + (hmax : ∀ x ∈ s, x ≤ m) + : max s = m + := by exact le_antisymm (hmax _ (max_mem hs)) (max_le hs _ hm) /-- Event-B's minimum is defined only for a nonempty set bounded below. -/ -noncomputable def min (s : Set Int) : Int := +noncomputable +def min + (s : Set Int) + : Int + := open Classical in if h : ∃ m, m ∈ s ∧ ∀ x ∈ s, m ≤ x then h.choose else Classical.arbitrary Int -@[grind] theorem min_mem {s : Set Int} - (h : ∃ m, m ∈ s ∧ ∀ x ∈ s, m ≤ x) : min s ∈ s := by +@[grind] +theorem min_mem + {s : Set Int} + (h : ∃ m, m ∈ s ∧ ∀ x ∈ s, m ≤ x) + : min s ∈ s + := by simp only [min, dif_pos h] exact h.choose_spec.1 -@[grind] theorem min_le {s : Set Int} - (h : ∃ m, m ∈ s ∧ ∀ x ∈ s, m ≤ x) : ∀ x ∈ s, min s ≤ x := by +@[grind] +theorem min_le + {s : Set Int} + (h : ∃ m, m ∈ s ∧ ∀ x ∈ s, m ≤ x) + : ∀ x ∈ s, + min s ≤ x + := by simp only [min, dif_pos h] exact h.choose_spec.2 -theorem min_eq {s : Set Int} {m : Int} - (hs : ∃ x, x ∈ s ∧ ∀ y ∈ s, x ≤ y) (hm : m ∈ s) - (hmin : ∀ x ∈ s, m ≤ x) : min s = m := by +theorem min_eq + {s : Set Int} + {m : Int} + (hs : ∃ x, x ∈ s ∧ ∀ y ∈ s, x ≤ y) + (hm : m ∈ s) + (hmin : ∀ x ∈ s, m ≤ x) + : min s = m + := by exact le_antisymm (min_le hs _ hm) (hmin _ (min_mem hs)) /-- Function application. Event-B's `f(x)` is defined only when `x ∈ dom f` and `f` is functional there; outside that it is an arbitrary value, and the well-definedness obligation is what rules the bad case out. Choice is the honest encoding: it makes `f(x)` total in Lean while leaving every fact about it dependent on the WD hypothesis. -/ -noncomputable def app [Nonempty β] (f : Rel α β) (a : α) : β := +noncomputable +def app + [Nonempty β] + (f : Rel α β) + (a : α) + : β + := open Classical in if h : ∃ b, (a, b) ∈ f then h.choose else Classical.arbitrary β -theorem app_mem [Nonempty β] {f : Rel α β} {a : α} (h : ∃ b, (a, b) ∈ f) : - (a, app f a) ∈ f := by +theorem app_mem + [Nonempty β] + {f : Rel α β} + {a : α} + (h : ∃ b, (a, b) ∈ f) + : (a, app f a) ∈ f + := by simp only [app, dif_pos h] exact h.choose_spec -theorem app_eq [Nonempty β] {f : Rel α β} {a : α} {b : β} - (hf : IsFun f) (hab : (a, b) ∈ f) : app f a = b := +theorem app_eq + [Nonempty β] + {f : Rel α β} + {a : α} + {b : β} + (hf : IsFun f) + (hab : (a, b) ∈ f) + : app f a = b + := hf a _ _ (app_mem ⟨b, hab⟩) hab end B diff --git a/spike/tools/AstDump.lean b/spike/tools/AstDump.lean index ff61117..2afb6af 100644 --- a/spike/tools/AstDump.lean +++ b/spike/tools/AstDump.lean @@ -4,7 +4,9 @@ open EventB.Formula /-- Dump the parsed form of each input line as JSON, so the spike's translator works from the real parser's output rather than a second implementation of it. -/ -def toJson : Term → String +def toJson + : Term → + String | .id s => "[\"id\"," ++ esc s ++ "]" | .num n => "[\"num\"," ++ toString n ++ "]" | .bin o a b => "[\"bin\"," ++ esc o ++ "," ++ toJson a ++ "," ++ toJson b ++ "]" @@ -22,7 +24,10 @@ where esc (s : String) : String := "\"" ++ (s.replace "\\" "\\\\" |>.replace "\"" "\\\"") ++ "\"" -def main (args : List String) : IO Unit := do +def main + (args : List String) + : IO Unit + := do let path := args.head! let text ← IO.FS.readFile path for l in text.splitOn "\n" do diff --git a/spike/tools/ShowPO.lean b/spike/tools/ShowPO.lean index e01e21e..de67504 100644 --- a/spike/tools/ShowPO.lean +++ b/spike/tools/ShowPO.lean @@ -4,7 +4,10 @@ open EventB EventB.POG EventB.Typing /-- Print the goal this generator derives for one obligation, for comparing against the `.bpo` by eye when the gate says "differs". -/ -def main (args : List String) : IO Unit := do +def main + (args : List String) + : IO Unit + := do let dir : System.FilePath := "corpus" let mut project : Project := [] for proj in ← dir.readDir do diff --git a/test/EnabledGuardFixtures.lean b/test/EnabledGuardFixtures.lean index 3926978..791ff56 100644 --- a/test/EnabledGuardFixtures.lean +++ b/test/EnabledGuardFixtures.lean @@ -4,7 +4,10 @@ import EventB.POG.RefinementAdapters namespace EventB.POG -private def enabledEventProject : EventB.Typing.Project := +private +def enabledEventProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -21,13 +24,17 @@ private def enabledEventProject : EventB.Typing.Project := | .ok _ => true | .error _ => false -private def enabledEventSource : - CheckedEventSource EventB.Theory.empty enabledEventProject "M" "step" := +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" := +private +def enabledGuardSource + : CheckedGuardSource EventB.Theory.empty enabledEventProject "M" "step" + := (CheckedGuardSource.fromProject EventB.Theory.empty enabledEventProject "M" "step").get (by native_decide) @@ -36,18 +43,26 @@ private def enabledGuardSource : #guard enabledGuardSource.predicates == [.bin "=" (.id "x") (.num 0)] -private def enabledTransition : CheckedBeforeAfter := +private +def enabledTransition + : CheckedBeforeAfter + := { before := { values := [("x", .integer 0)] } after := { values := [("x", .integer 0)] } declarations := [("x", .int)] } -private def disabledTransition : CheckedBeforeAfter := +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 +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 @@ -57,8 +72,10 @@ private theorem enabledAction : rw [declarations, updates] exact assignmentRelation_x_self_zero -private theorem disabledAction : - enabledEventSource.assignmentAction 128 disabledTransition := by +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 @@ -69,8 +86,10 @@ private theorem disabledAction : unfold assignmentRelation native_decide -private theorem enabledGuard : - enabledGuardSource.holds 128 enabledTransition := by +private +theorem enabledGuard + : enabledGuardSource.holds 128 enabledTransition + := by have declarations : enabledGuardSource.declarations = [("x", .int)] := by native_decide have predicates : enabledGuardSource.predicates = @@ -90,8 +109,10 @@ private theorem enabledGuard : unfold assignmentPredicateWithFuel native_decide -private theorem disabledGuardNotHolds : - ¬ enabledGuardSource.holds 128 disabledTransition := by +private +theorem disabledGuardNotHolds + : ¬ enabledGuardSource.holds 128 disabledTransition + := by intro holds have predicates : enabledGuardSource.predicates = [.bin "=" (.id "x") (.num 0)] := by @@ -107,39 +128,59 @@ private theorem disabledGuardNotHolds : native_decide exact notTrue falsePredicate -private def enabledEvent : Event CheckedBeforeAfter := +private +def enabledEvent + : Event CheckedBeforeAfter + := { grd := fun transition => enabledGuardSource.holds 128 transition act := fun before _ => enabledEventSource.assignmentAction 128 before } -private def badGuardEvent : Event CheckedBeforeAfter := +private +def badGuardEvent + : Event CheckedBeforeAfter + := { grd := fun _ => True act := fun before _ => enabledEventSource.assignmentAction 128 before } -private theorem actionProvenance : - eventActionExact enabledEventSource 128 +private +theorem actionProvenance + : eventActionExact enabledEventSource 128 (fun state : CheckedBeforeAfter × CheckedBeforeAfter => state.1) - (fun state => enabledEvent.act state.1 state.2) := by + (fun state => enabledEvent.act state.1 state.2) + := by intro state rfl -private theorem guardProvenance : - ∀ transition, enabledEvent.grd transition ↔ - enabledGuardSource.holds 128 transition := by +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 +private +theorem enabledEvent_is_enabled + : enabledEvent.grd enabledTransition ∧ + enabledEvent.act enabledTransition enabledTransition + := by exact ⟨enabledGuard, enabledAction⟩ -private theorem enabledEvent_is_disabled : ¬ enabledEvent.grd disabledTransition := +private +theorem enabledEvent_is_disabled + : ¬ enabledEvent.grd disabledTransition + := disabledGuardNotHolds -example : enabledEvent.act disabledTransition disabledTransition := by +example + : enabledEvent.act disabledTransition disabledTransition + := by exact disabledAction -example : ¬ (∀ transition, - badGuardEvent.grd transition ↔ enabledGuardSource.holds 128 transition) := by +example + : ¬ (∀ transition, badGuardEvent.grd transition ↔ enabledGuardSource.holds 128 transition) + := by intro exactness have mismatch := exactness disabledTransition apply disabledGuardNotHolds @@ -149,7 +190,10 @@ example : ¬ (∀ transition, 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 := +private +def parameterizedEventProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [ ("org.eventb.core.name", "M") ] [ .variable [("org.eventb.core.identifier", "x")] [] @@ -169,13 +213,17 @@ private def parameterizedEventProject : EventB.Typing.Project := | .ok _ => true | .error _ => false -private def parameterizedEventSource : - CheckedEventSource EventB.Theory.empty parameterizedEventProject "M" "step" := +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" := +private +def parameterizedGuardSource + : CheckedGuardSource EventB.Theory.empty parameterizedEventProject "M" "step" + := (CheckedGuardSource.fromProject EventB.Theory.empty parameterizedEventProject "M" "step").get (by native_decide) @@ -184,25 +232,36 @@ private def parameterizedGuardSource : #guard parameterizedGuardSource.declarations == [("x", .int), ("p", .int)] #guard parameterizedGuardSource.predicates == [.bin ">" (.id "p") (.num 0)] -private def parameterizedTransition (parameter state after : Int) : CheckedBeforeAfter := +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 := +private +def parameterizedEvent + : ParameterizedEvent Int Int + := { grd := fun parameter _ => parameter > 0 act := fun parameter _ after => after = parameter } -example : parameterizedEvent.enabled 0 := by +example + : parameterizedEvent.enabled 0 + := by exact ⟨1, by change (1 : Int) > 0; omega⟩ -example : parameterizedEventSource.assignmentAction 128 - (parameterizedTransition 7 0 7) := by +example + : parameterizedEventSource.assignmentAction 128 (parameterizedTransition 7 0 7) + := by unfold CheckedEventSource.assignmentAction assignmentRelation native_decide -example : parameterizedGuardSource.holds 128 - (parameterizedTransition 7 0 7) := by +example + : parameterizedGuardSource.holds 128 (parameterizedTransition 7 0 7) + := by have declarations : parameterizedGuardSource.declarations = [("x", .int), ("p", .int)] := by native_decide have predicates : parameterizedGuardSource.predicates = @@ -221,8 +280,9 @@ example : parameterizedGuardSource.holds 128 unfold assignmentPredicateWithFuel native_decide -example : ¬ parameterizedGuardSource.holds 128 - (parameterizedTransition (-1) 0 (-1)) := by +example + : ¬ parameterizedGuardSource.holds 128 (parameterizedTransition (-1) 0 (-1)) + := by have predicates : parameterizedGuardSource.predicates = [.bin ">" (.id "p") (.num 0)] := by native_decide unfold CheckedGuardSource.holds @@ -237,17 +297,25 @@ example : ¬ parameterizedGuardSource.holds 128 native_decide exact notTrue falsePredicate -private def abstractParameterizedEvent : ParameterizedEvent Nat Nat := +private +def abstractParameterizedEvent + : ParameterizedEvent Nat Nat + := { grd := fun parameter _ => parameter > 0 act := fun _ before after => after = before + 1 } -private def concreteParameterizedEvent : ParameterizedEvent Nat Nat := +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) := +private +theorem parameterizedRefinement + : ParameterizedEventRefinement concreteParameterizedEvent + abstractParameterizedEvent (fun concrete abstract => concrete = abstract) + := { guard := by intro parameter concrete abstract glued guard subst abstract @@ -257,9 +325,11 @@ private theorem parameterizedRefinement : subst abstract exact ⟨parameter, concreteAfter, guard, action, rfl⟩ } -example : ∃ abstractAfter, - abstractParameterizedEvent.step 1 abstractAfter ∧ - (2 = abstractAfter) := by +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 @@ -267,14 +337,19 @@ example : ∃ abstractAfter, by change (2 : Nat) = 1 + 1; decide⟩) exact ⟨abstractAfter, step, by simpa using glued⟩ -private def naturalWellFoundedVariant : WellFoundedVariant Nat Nat := +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 := +example + : wellFoundedVariantProgressSemantic naturalWellFoundedVariant + := naturalWellFoundedVariant.progressSemantic end EventB.POG diff --git a/test/EqlFixtures.lean b/test/EqlFixtures.lean index 4264af7..955f5bc 100644 --- a/test/EqlFixtures.lean +++ b/test/EqlFixtures.lean @@ -4,26 +4,41 @@ import EventB.POG.EQLAdapter namespace EventB.POG -private def eqlBinding : EqlIntBinding Theory.empty positiveProject := +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 := +private +def eqlEncode + (_ : Unit) + : ValueEnv + := { values := [("x", .integer 0)] } -private def eqlTransition : CheckedBeforeAfter := +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 +private +theorem eqlAssignment + : ValueEnv.parallelAssignTypedFuel 128 [("x", .int)] (eqlEncode ()) + [("x", .id "x")] = .ok eqlTransition + := by native_decide -private def eqlBridge : EqlIntEventBridge eqlBinding Unit := +private +def eqlBridge + : EqlIntEventBridge eqlBinding Unit + := { fuel := 128 encode := eqlEncode event := @@ -90,12 +105,17 @@ private def eqlBridge : EqlIntEventBridge eqlBinding Unit := rw [declarations, updates] exact ⟨eqlTransition, eqlAssignment, rfl⟩ } -private def eqlAdapter : EqlIntAdapter Theory.empty positiveProject Unit := +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 := +example + : framePreserved eqlAdapter.bridge.read eqlAdapter.bridge.event.act + := eqlAdapter.sound end EventB.POG diff --git a/test/FiniteSetEvaluatorFixtures.lean b/test/FiniteSetEvaluatorFixtures.lean index fc94124..ad5dd7c 100644 --- a/test/FiniteSetEvaluatorFixtures.lean +++ b/test/FiniteSetEvaluatorFixtures.lean @@ -4,16 +4,28 @@ import EventB.POGSoundness namespace EventB.POG -private def setEnv : ValueEnv := +private +def setEnv + : ValueEnv + := { values := [("S", .set [.integer 0, .integer 1])] } -private def badSetEnv : ValueEnv := +private +def badSetEnv + : ValueEnv + := { values := [("S", .set [.integer 0, .boolean true])] } -private def integerUniverseEnv : ValueEnv := +private +def integerUniverseEnv + : ValueEnv + := { values := [("S", .integerSet)] } -private def setTransition : CheckedBeforeAfter := +private +def setTransition + : CheckedBeforeAfter + := { before := setEnv after := { values := [("S", .set [.integer 1])] } declarations := [("S", .pow .int)] } @@ -37,7 +49,10 @@ private def setTransition : CheckedBeforeAfter := | .error _ => true | .ok _ => false -private def witnessBody : EventB.Formula.Term := +private +def witnessBody + : EventB.Formula.Term + := .bin "=" (.id "p") (.num 0) #guard evalPredicateOverFiniteDomain 128 {} "p" @@ -45,8 +60,11 @@ private def witnessBody : EventB.Formula.Term := #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 +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 diff --git a/test/FiniteVariantFixtures.lean b/test/FiniteVariantFixtures.lean index 360f38b..9f2de98 100644 --- a/test/FiniteVariantFixtures.lean +++ b/test/FiniteVariantFixtures.lean @@ -4,7 +4,10 @@ import EventB.POG.RefinementAdapters namespace EventB.POG -private def finiteVariantProject : EventB.Typing.Project := +private +def finiteVariantProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [ .variable [("org.eventb.core.identifier", "S")] [] @@ -21,7 +24,11 @@ private def finiteVariantProject : EventB.Typing.Project := , .action [("org.eventb.core.label", "remove"), ("org.eventb.core.assignment", "S ≔ S ∖ {0}")] [] ] ] }] -private def parsed? (source : String) : Option EventB.Formula.Term := +private +def parsed? + (source : String) + : Option EventB.Formula.Term + := (EventB.Formula.parse source).toOption #guard match generateCheckedIn EventB.Theory.empty finiteVariantProject "M" with @@ -40,7 +47,10 @@ private def parsed? (source : String) : Option EventB.Formula.Term := #guard EventB.POG.eventConvergenceMode? finiteVariantProject "M" "step" == some "1" #guard EventB.POG.eventConvergenceMode? finiteVariantProject "M" "missing" == none -private def anticipatedFiniteVariantProject : EventB.Typing.Project := +private +def anticipatedFiniteVariantProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [ .variable [("org.eventb.core.identifier", "S")] [] @@ -57,13 +67,19 @@ private def anticipatedFiniteVariantProject : EventB.Typing.Project := [ .action [("org.eventb.core.label", "hold"), ("org.eventb.core.assignment", "S ≔ S")] [] ] ] }] -private def anticipatedFinObligation : Obligation := +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 := +private +def anticipatedVarObligation + : Obligation + := { component := "M", name := "hold/VAR", kind := "VAR" goal := parsed? "S ⊆ S" hyps := [(parsed? "S ∈ ℙ(ℤ)").get (by native_decide), @@ -75,27 +91,41 @@ private def anticipatedVarObligation : Obligation := anticipatedVarObligation).isSome #guard EventB.POG.eventConvergenceMode? anticipatedFiniteVariantProject "M" "hold" == some "2" -private def anticipatedFinPO : CheckedPO EventB.Theory.empty anticipatedFiniteVariantProject := +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 := +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" := +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" := +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 := +private +def constantFiniteVariantProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [ .variant [("org.eventb.core.expression", "{0}")] [] @@ -103,11 +133,17 @@ private def constantFiniteVariantProject : EventB.Typing.Project := , .event [("org.eventb.core.label", "hold"), ("org.eventb.core.convergence", "2")] [] ] }] -private def constantFinObligation : Obligation := +private +def constantFinObligation + : Obligation + := { component := "M", name := "FIN", kind := "FIN" goal := some (.app (.id "finite") (.set [.num 0])) } -private def constantVarObligation : Obligation := +private +def constantVarObligation + : Obligation + := { component := "M", name := "hold/VAR", kind := "VAR" goal := some (.bin "⊆" (.set [.num 0]) (.set [.num 0])) } @@ -120,53 +156,80 @@ private def constantVarObligation : Obligation := obligation.kind == "VAR" && obligation.goal == parsed? "{0} ⊆ {0}") | .error _ => false -private def constantFinPO : CheckedPO EventB.Theory.empty constantFiniteVariantProject := +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 := +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 := +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 := +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" := +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" := +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 := +private +def constantFiniteTransition + : CheckedBeforeAfter + := { before := {}, after := {}, declarations := [] } -private def constantFiniteEventSourceBound : CheckedEventSource EventB.Theory.empty - constantFiniteVariantProject constantFinPOExact.obligation.component "hold" := by +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 +private +def constantFiniteVariantSourceBound + : CheckedVariantSource constantFiniteVariantProject constantFinPOExact.obligation.component + := by change CheckedVariantSource constantFiniteVariantProject "M" exact constantFiniteVariantSource -private theorem constantFiniteAssignment : - constantFiniteEventSource.assignmentAction 128 constantFiniteTransition := by +private +theorem constantFiniteAssignment + : constantFiniteEventSource.assignmentAction 128 constantFiniteTransition + := by change assignmentRelation 128 constantFiniteEventSource.declarations constantFiniteTransition constantFiniteEventSource.updates have declarations : constantFiniteEventSource.declarations = [] := by native_decide @@ -179,19 +242,28 @@ private abbrev constantFiniteSourceState := { transition : CheckedBeforeAfter // constantFiniteEventSourceBound.assignmentAction 128 transition } -private def constantFiniteSourceStateValue : constantFiniteSourceState := +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 +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 := +private +def constantFiniteFormulaModel + : TypedFormulaModel + := { declarations := [] fuel := 128 wellFormed := fun env => ValueEnv.validateFuel 128 [] env = .ok PUnit.unit @@ -206,8 +278,10 @@ private def constantFiniteFormulaModel : TypedFormulaModel := private abbrev constantFiniteFormulaState := { env : ValueEnv // ValueEnv.validateFuel 128 [] env = .ok PUnit.unit } -private theorem constantFiniteFormulaValid : - TypedFormulaModel.validUnchecked constantFiniteFormulaModel constantFinObligation := by +private +theorem constantFiniteFormulaValid + : TypedFormulaModel.validUnchecked constantFiniteFormulaModel constantFinObligation + := by constructor · native_decide constructor @@ -221,7 +295,10 @@ private theorem constantFiniteFormulaValid : · intro _ exact evalPredicateFiniteZero env -private def constantFiniteTransitionModel : TypedTransitionModel := +private +def constantFiniteTransitionModel + : TypedTransitionModel + := { fuel := 128 wellFormed := fun _ => True inhabited := ⟨constantFiniteTransition, trivial⟩ @@ -230,8 +307,11 @@ private def constantFiniteTransitionModel : TypedTransitionModel := private abbrev constantFiniteSemanticState := { env : ValueEnv // ValueEnv.validateFuel 128 [] env = .ok PUnit.unit } -private def constantFiniteStateOf (state : constantFiniteSourceState) : - constantFiniteSemanticState := by +private +def constantFiniteStateOf + (state : constantFiniteSourceState) + : constantFiniteSemanticState + := by refine ⟨state.1.before, ?_⟩ rcases state.property with ⟨declared, beforeValid, _, _⟩ have sourceDeclarations : constantFiniteEventSourceBound.declarations = [] := by native_decide @@ -239,7 +319,10 @@ private def constantFiniteStateOf (state : constantFiniteSourceState) : simpa [sourceDeclarations, declared] using beforeValid exact validationFuelOfOk _ beforeValid' -private def constantFiniteVariant : FiniteSetVariant constantFiniteSemanticState Int := +private +def constantFiniteVariant + : FiniteSetVariant constantFiniteSemanticState Int + := { mode := .anticipated measure := fun _ => [0] action := fun _ _ => True @@ -248,8 +331,11 @@ private def constantFiniteVariant : FiniteSetVariant constantFiniteSemanticState intro _ _ _ value member simpa using member } -private def constantFiniteAdapter : FiniteSetVariantAdapter (γ := constantFiniteSourceState) - EventB.Theory.empty constantFiniteVariantProject constantFiniteVariant := +private +def constantFiniteAdapter + : FiniteSetVariantAdapter (γ := constantFiniteSourceState) + EventB.Theory.empty constantFiniteVariantProject constantFiniteVariant + := { finBinding := constantFinPOExact varBinding := constantVarPOExact finKind := by native_decide @@ -374,8 +460,10 @@ private def constantFiniteAdapter : FiniteSetVariantAdapter (γ := constantFinit · intro _ trivial } -example : finiteVariantFiniteness constantFiniteVariant ∧ - finiteVariantProgressSemantic constantFiniteVariant := +example + : finiteVariantFiniteness constantFiniteVariant ∧ + finiteVariantProgressSemantic constantFiniteVariant + := constantFiniteAdapter.sound end EventB.POG diff --git a/test/FiniteVariantModelFixtures.lean b/test/FiniteVariantModelFixtures.lean index c40f269..dcd0afc 100644 --- a/test/FiniteVariantModelFixtures.lean +++ b/test/FiniteVariantModelFixtures.lean @@ -4,7 +4,10 @@ import EventB.POG.RefinementAdapters namespace EventB.POG -private def modelFiniteProject : EventB.Typing.Project := +private +def modelFiniteProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [ .variable [("org.eventb.core.identifier", "S")] [] @@ -17,16 +20,26 @@ private def modelFiniteProject : EventB.Typing.Project := , .event [("org.eventb.core.label", "hold"), ("org.eventb.core.convergence", "2")] [] ] }] -private def parsed? (source : String) : Option EventB.Formula.Term := +private +def parsed? + (source : String) + : Option EventB.Formula.Term + := (EventB.Formula.parse source).toOption -private def modelFinObligation : Obligation := +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 := +private +def modelVarObligation + : Obligation + := { component := "M", name := "hold/VAR", kind := "VAR" goal := parsed? "S ⊆ S" hyps := [(parsed? "S ∈ ℙ(ℤ)").get (by native_decide), @@ -38,52 +51,88 @@ private def modelVarObligation : Obligation := modelVarObligation).isSome #guard EventB.POG.eventRefinementTargets modelFiniteProject "M" "hold" == [] -private def modelFinPO : CheckedPO EventB.Theory.empty modelFiniteProject := +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 := +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" := +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" := +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 +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 +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) := +private +def modelDeclarations + : List (String × EventB.Typing.Ty) + := [("S", .pow .int)] -private def modelTypeGoal : EventB.Formula.Term := +private +def modelTypeGoal + : EventB.Formula.Term + := .bin "∈" (.id "S") (.pre "ℙ" (.id "ℤ")) -private def modelFiniteGoal : EventB.Formula.Term := +private +def modelFiniteGoal + : EventB.Formula.Term + := .app (.id "finite") (.id "S") -private def modelShape (env : ValueEnv) : Prop := +private +def modelShape + (env : ValueEnv) + : Prop + := ∃ values, evalValueAtFuel 127 env (.id "S") = .ok (.set values) -private def modelFinObligationExact : Obligation := +private +def modelFinObligationExact + : Obligation + := { component := "M", name := "FIN", kind := "FIN" goal := some modelFiniteGoal hyps := [modelTypeGoal, modelFiniteGoal] } -private def modelDomain (env : ValueEnv) : Prop := +private +def modelDomain + (env : ValueEnv) + : Prop + := ValueEnv.validationOk 128 modelDeclarations env = true ∧ evalPredicateAtFuel 128 env modelTypeGoal = .ok true ∧ evalPredicateAtFuel 128 env modelFiniteGoal = .ok true ∧ @@ -91,15 +140,21 @@ private def modelDomain (env : ValueEnv) : Prop := 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 +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 := +private +def modelFormulaModel + : TypedFormulaModel + := { declarations := modelDeclarations fuel := 128 wellFormed := fun env => ValueEnv.validationOk 128 modelDeclarations env = true @@ -116,11 +171,18 @@ private def modelFormulaModel : TypedFormulaModel := private def modelEncode (state : modelState) : ValueEnv := state.1 -private def modelSourceTransition (state : modelState) : CheckedBeforeAfter := +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 +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 @@ -135,9 +197,12 @@ private theorem modelSourceAssignment (state : modelState) : CheckedBeforeAfter.make, validationFuel, Bind.bind, Except.bind] rfl -private theorem modelSourceAfterEq (transition : CheckedBeforeAfter) - (source : modelEventSourceBound.assignmentAction 128 transition) : - transition.after = transition.before := by +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 @@ -165,22 +230,37 @@ private theorem modelSourceAfterEq (transition : CheckedBeforeAfter) private abbrev modelVarState := { pair : modelState × modelState // pair.1.1 = pair.2.1 } -private def modelVarEncode (state : modelVarState) : CheckedBeforeAfter := +private +def modelVarEncode + (state : modelVarState) + : CheckedBeforeAfter + := { before := state.1.1.1, after := state.1.2.1, declarations := modelDeclarations } -private def modelVarSource (transition : CheckedBeforeAfter) : Prop := +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 +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 +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⟩), @@ -194,16 +274,21 @@ private theorem modelVarSourceComplete (transition : CheckedBeforeAfter) simp [modelVarEncode] exact declaredExact.symm -private theorem modelSubsetSelfEval (transition : CheckedBeforeAfter) +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 + (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 := +private +def modelInitialState + : modelState + := ⟨{ values := [("S", .set [.integer 0]) ] }, by refine ⟨?_, ?_, ?_, ?_⟩ · native_decide @@ -212,17 +297,25 @@ private def modelInitialState : modelState := · refine ⟨[.integer 0], ?_⟩ exact evalValueIdentifierSingletonZero⟩ -private def modelInitialVarState : modelVarState := +private +def modelInitialVarState + : modelVarState + := ⟨(modelInitialState, modelInitialState), rfl⟩ -private def modelVarEvaluator : TypedTransitionModel := +private +def modelVarEvaluator + : TypedTransitionModel + := { fuel := 128 wellFormed := modelVarSource inhabited := ⟨modelVarEncode modelInitialVarState, modelVarSourceValid modelInitialVarState⟩ supports := fun _ => true } -private theorem modelVarEvaluatorValid : - modelVarEvaluator.validOnDomain modelVarSource modelVarObligation := by +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")) @@ -262,8 +355,10 @@ private theorem modelVarEvaluatorValid : exact modelSubsetSelfEval transition beforeValid' afterValid' beforeDomain.2.2.2 afterEq -private theorem modelFinEvaluatorValid : - modelFormulaModel.validOnDomain modelDomain modelFinObligation := by +private +theorem modelFinEvaluatorValid + : modelFormulaModel.validOnDomain modelDomain modelFinObligation + := by have obligationExact : modelFinObligation = modelFinObligationExact := by native_decide rw [obligationExact] @@ -295,7 +390,10 @@ private theorem modelFinEvaluatorValid : · intro _ exact finiteValid -private def modelFiniteVariant : FiniteSetVariant modelState Int := +private +def modelFiniteVariant + : FiniteSetVariant modelState Int + := { mode := .anticipated measure := fun state => match evalValueAtFuel 128 state.1 (.id "S") with @@ -308,9 +406,12 @@ private def modelFiniteVariant : FiniteSetVariant modelState Int := intro before after action value member simpa [action] using member } -private theorem modelFinitenessExact : ∀ state : modelState, - modelFiniteVariant.finite state ↔ - modelFormulaModel.denote modelFiniteGoal (modelEncode state) := by +private +theorem modelFinitenessExact + : ∀ state : modelState, + modelFiniteVariant.finite state ↔ + modelFormulaModel.denote modelFiniteGoal (modelEncode state) + := by intro state constructor · intro _ @@ -318,8 +419,11 @@ private theorem modelFinitenessExact : ∀ state : modelState, · intro _ trivial -private def modelFinFormula : DomainFormulaAdequacy modelFinPO modelState - (finiteVariantFiniteness modelFiniteVariant) modelDomain := +private +def modelFinFormula + : DomainFormulaAdequacy modelFinPO modelState + (finiteVariantFiniteness modelFiniteVariant) modelDomain + := { evaluator := modelFormulaModel encode := modelEncode declarationScope := none @@ -387,9 +491,11 @@ private def modelVarFormula : TransitionFormulaAdequacy modelVarPO modelVarState intro value member simpa [modelVarBefore, modelVarAfter, action] using member } -private def modelRestrictedAdapter : - RestrictedFiniteSetVariantAdapter (η := modelVarState) (γ := modelState) - EventB.Theory.empty modelFiniteProject modelFiniteVariant := +private +def modelRestrictedAdapter + : RestrictedFiniteSetVariantAdapter (η := modelVarState) (γ := modelState) + EventB.Theory.empty modelFiniteProject modelFiniteVariant + := { finBinding := modelFinPO varBinding := modelVarPO finKind := by native_decide @@ -438,12 +544,16 @@ private def modelRestrictedAdapter : simpa [modelVarBefore, modelVarAfter, modelVarEncode] using afterEq.symm fuelExact := by constructor <;> rfl } -private theorem modelRestrictedSound : - finiteVariantFiniteness modelFiniteVariant ∧ - finiteVariantProgressSemantic modelFiniteVariant := +private +theorem modelRestrictedSound + : finiteVariantFiniteness modelFiniteVariant ∧ + finiteVariantProgressSemantic modelFiniteVariant + := RestrictedFiniteSetVariantAdapter.sound modelRestrictedAdapter -example : ¬ finiteVariantProgress .convergent ([0] : List Int) [0] := by +example + : ¬ finiteVariantProgress .convergent ([0] : List Int) [0] + := by intro progress rcases progress.2 with ⟨value, member, absent⟩ simp_all diff --git a/test/Gates.lean b/test/Gates.lean index 08e213b..d293997 100644 --- a/test/Gates.lean +++ b/test/Gates.lean @@ -17,17 +17,26 @@ structure FileResult where status : String model : Option Model := none -def expectedInventory : List (String × Nat) := +def expectedInventory + : List (String × Nat) + := [("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)] -private def isSource (path : System.FilePath) : Bool := +private +def isSource + (path : System.FilePath) + : Bool + := path.toString.endsWith ".bum" || path.toString.endsWith ".buc" -private def sourceFiles : IO (List System.FilePath) := do +private +def sourceFiles + : IO (List System.FilePath) + := do let mut paths : List System.FilePath := [] let corpus : System.FilePath := "corpus" for project in ← corpus.readDir do @@ -38,10 +47,18 @@ private def sourceFiles : IO (List System.FilePath) := do paths := entry.path :: paths pure (paths.mergeSort (fun left right => left.toString < right.toString)) -private def shortReason (reason : String) : String := +private +def shortReason + (reason : String) + : String + := reason.splitOn "\n" |>.head?.getD "parse failed" -private def checkFile (path : System.FilePath) : IO FileResult := do +private +def checkFile + (path : System.FilePath) + : IO FileResult + := do try let source ← IO.FS.readBinFile path let parsed := @@ -57,14 +74,21 @@ private def checkFile (path : System.FilePath) : IO FileResult := do catch err => pure { path := path.toString, status := "FAIL:IO " ++ err.toString } -private def sumInventory : List (String × Nat) → List (String × Nat) → - List (String × Nat) +private +def sumInventory + : List (String × Nat) → -- running inventory totals + List (String × Nat) → -- inventory to add in + List (String × Nat) | [], _ => [] | _, [] => [] | (name, left) :: xs, (_, right) :: ys => (name, left + right) :: sumInventory xs ys -private def totalInventory (results : List FileResult) : List (String × Nat) := +private +def totalInventory + (results : List FileResult) + : List (String × Nat) + := results.foldl (fun total result => match result.model with @@ -72,7 +96,11 @@ private def totalInventory (results : List FileResult) : List (String × Nat) := | none => total) (expectedInventory.map (fun (name, _) => (name, 0))) -private def histogramAdd (reason : String) : List (String × Nat) → List (String × Nat) +private +def histogramAdd + (reason : String) + : List (String × Nat) → + List (String × Nat) | [] => [(reason, 1)] | (name, count) :: rest => if name == reason then @@ -80,7 +108,11 @@ private def histogramAdd (reason : String) : List (String × Nat) → List (Stri else (name, count) :: histogramAdd reason rest -private def histogram (results : List FileResult) : List (String × Nat) := +private +def histogram + (results : List FileResult) + : List (String × Nat) + := (results.foldl (fun counts result => if result.status.startsWith "FAIL:" then @@ -100,7 +132,11 @@ private structure FormulaResult where key : String status : String -private def checkFormula (file label formula : String) : FormulaResult := +private +def checkFormula + (file label formula : String) + : FormulaResult + := let key := file ++ "\t" ++ label match Formula.parse formula with | .error reason => { key := key, status := "FAIL:" ++ EventB.Error.render reason } @@ -112,13 +148,21 @@ private def checkFormula (file label formula : String) : FormulaResult := if again == term then { key := key, status := "PASS" } else { key := key, status := "FAIL:round-trip differs" } -private def formulaResults (results : List FileResult) : List FormulaResult := +private +def formulaResults + (results : List FileResult) + : List FormulaResult + := results.flatMap fun result => match result.model with | none => [] | some model => model.formulas.map (fun (label, f) => checkFormula result.path label f) -private def formulaHistogram (results : List FormulaResult) : List (String × Nat) := +private +def formulaHistogram + (results : List FormulaResult) + : List (String × Nat) + := (results.foldl (fun counts result => if result.status.startsWith "FAIL:" then histogramAdd result.status counts @@ -139,7 +183,11 @@ mutual `poFile`, outside the machine/context element set, so this walks the raw XML tree rather than the Event-B model. The first spelling of each name wins; the corpus never types one name two ways within a file. -/ -private def rawIdentifiers (e : XmlElem) : List (String × String) := +private +def rawIdentifiers + (e : XmlElem) + : List (String × String) + := let here := if e.tag == "org.eventb.core.poIdentifier" then -- Rodin writes the identifier name as a plain `name` attribute, unnamespaced. @@ -151,28 +199,41 @@ private def rawIdentifiers (e : XmlElem) : List (String × String) := termination_by sizeOf e decreasing_by cases e; simp +arith -private def rawIdentifiersList : List XmlElem → List (String × String) +private +def rawIdentifiersList + : List XmlElem → + List (String × String) | [] => [] | e :: es => rawIdentifiers e ++ rawIdentifiersList es termination_by es => sizeOf es end -private def dedupFirst : List (String × String) → List (String × String) → - List (String × String) +private +def dedupFirst + : List (String × String) → -- name/type pairs to dedup + List (String × String) → -- deduped pairs so far (reversed) + List (String × String) | [], acc => acc.reverse | (n, t) :: rest, acc => 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 +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 +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 @@ -180,7 +241,11 @@ private def conflictingIdentifiers (seen : List (String × String)) : | none => [] conflicts ++ conflictingIdentifiers ((name, type) :: seen) rest -private def readGoldTypes (path : System.FilePath) : IO (List (String × String)) := do +private +def readGoldTypes + (path : System.FilePath) + : IO (List (String × String)) + := do match parseXml (← IO.FS.readBinFile path) with | .error _ => throw (IO.userError s!"cannot parse Rodin type oracle {path}") | .ok xml => @@ -196,14 +261,23 @@ private structure TypeResult where /-- Compare inferred against recorded by parsing both, so a mismatch is reported as two types rather than a diff of Unicode. -/ -private def compareType (key inferred gold : String) : TypeResult := +private +def compareType + (key inferred gold : String) + : TypeResult + := if inferred == gold then { key := key, status := "PASS" } else match Ty.parse gold with | none => { key := key, status := s!"FAIL:ungrammatical gold type {gold}" } | some _ => { key := key, status := s!"FAIL:inferred {inferred}, recorded {gold}" } -private def checkTypes (project : Project) (file : String) - (gold : List (String × String)) : List TypeResult := +private +def checkTypes + (project : Project) + (file : String) + (gold : List (String × String)) + : List TypeResult + := match inferComponent project file with | .error e => gold.map (fun (n, _) => @@ -218,7 +292,11 @@ private def checkTypes (project : Project) (file : String) | none => { key := key, status := "FAIL:not inferred" } | some (_, t) => compareType key t.print g -private def typeHistogram (results : List TypeResult) : List (String × Nat) := +private +def typeHistogram + (results : List TypeResult) + : List (String × Nat) + := (results.foldl (fun counts r => if r.status.startsWith "FAIL:" then histogramAdd r.status counts else counts) @@ -239,21 +317,32 @@ private def p4Minimum : Nat := 73 mutual -private def poNames (e : XmlElem) : List String := +private +def poNames + (e : XmlElem) + : List String + := let here := if e.tag == "org.eventb.core.poSequent" then (e.attr? "name").toList else [] here ++ poNamesList e.children termination_by sizeOf e decreasing_by cases e; simp +arith -private def poNamesList : List XmlElem → List String +private +def poNamesList + : List XmlElem → + List String | [] => [] | e :: es => poNames e ++ poNamesList es termination_by es => sizeOf es end -private def readGoldPOs (path : System.FilePath) : IO (List String) := do +private +def readGoldPOs + (path : System.FilePath) + : IO (List String) + := do match parseXml (← IO.FS.readBinFile path) with | .error _ => throw (IO.userError s!"cannot parse Rodin PO oracle {path}") | .ok xml => @@ -269,8 +358,13 @@ private structure PoResult where /-- Both directions, one line per obligation, so `--histogram` separates "we missed it" from "we invented it". -/ -private def checkPOs (project : Project) (file : String) (gold : List String) : - List PoResult := +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" } @@ -282,7 +376,11 @@ private def checkPOs (project : Project) (file : String) (gold : List String) : |>.map fun n => { key := file ++ "\t" ++ n, status := "PASS" } duplicateOurs ++ matched ++ missing ++ spurious -private def poHistogram (results : List PoResult) : List (String × Nat) := +private +def poHistogram + (results : List PoResult) + : List (String × Nat) + := (results.foldl (fun counts r => if r.status.startsWith "FAIL:" then @@ -302,14 +400,23 @@ recorded answer: the goal is derived from the `.bum` alone. Rodin keeps a sequent's hypotheses in a parent chain of predicate sets, so the whole chain has to be resolved before they can be compared. -/ -private def refName (ref : String) : String := +private +def refName + (ref : String) + : String + := ((ref.splitOn "#").getLast!).replace "\\/" "/" |>.replace "\\\\" "\\" |>.replace "\\|" "|" -- partiality: these helpers walk externally supplied Rodin XML trees; the XML representation has -- no indexed depth measure, and this test-only traversal is kept direct and local. -private partial def predicateSets (e : XmlElem) : List (String × Option String × List String) := +private +partial +def predicateSets + (e : XmlElem) + : List (String × Option String × List String) + := let here := if e.tag == "org.eventb.core.poPredicateSet" then [(((e.attr? "name").getD ""), @@ -319,8 +426,12 @@ private partial def predicateSets (e : XmlElem) : List (String × Option String else [] e.children.foldl (fun acc c => acc ++ predicateSets c) here -private def chainHyps (sets : List (String × Option String × List String)) - (start : Option String) : List String := +private +def chainHyps + (sets : List (String × Option String × List String)) + (start : Option String) + : List String + := go sets.length start [] where go : Nat → Option String → List String → List String @@ -331,8 +442,11 @@ where | none => acc | some (_, parent, preds) => go fuel parent (preds ++ acc) -private def predicateSetErrors - (sets : List (String × Option String × List String)) : List String := +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. @@ -359,8 +473,13 @@ private def predicateSetErrors 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) := +private +partial +def goldHyps + (e : XmlElem) + (sets : List (String × Option String × List String)) + : List (String × List String) + := let here := if e.tag == "org.eventb.core.poSequent" then match e.attr? "name" with @@ -378,7 +497,12 @@ private partial def goldHyps (e : XmlElem) e.children.foldl (fun acc c => acc ++ goldHyps c sets) here -- partiality: this is the corresponding test-only XML walk for recorded proof obligations. -private partial def goldGoals (e : XmlElem) : List (String × String) := +private +partial +def goldGoals + (e : XmlElem) + : List (String × String) + := let here := if e.tag == "org.eventb.core.poSequent" then match e.attr? "name" with @@ -400,7 +524,12 @@ 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 := +private +partial +def goalShapeErrors + (e : XmlElem) + : List String + := let here := if e.tag == "org.eventb.core.poSequent" then match e.attr? "name" with @@ -416,7 +545,11 @@ private partial def goalShapeErrors (e : XmlElem) : List String := else [] here ++ e.children.flatMap goalShapeErrors -private def readGoldGoals (path : System.FilePath) : IO (List (String × String)) := do +private +def readGoldGoals + (path : System.FilePath) + : IO (List (String × String)) + := do match parseXml (← IO.FS.readBinFile path) with | .error _ => throw (IO.userError s!"cannot parse Rodin goal oracle {path}") | .ok xml => @@ -434,16 +567,28 @@ them. Nothing else is normalised: the gate's job is to notice a difference, and comparison that rewrites both sides can only hide one. -/ private def comparable (t : Term) : Term := Formula.stripAscriptions t -private def equivalent (left right : Term) : Bool := +private +def equivalent + (left right : Term) + : Bool + := Formula.alphaEq (comparable left) (comparable right) -private def removeEquivalent (target : Term) : List Term → Option (List Term) +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 +private +def multisetEqual + : List Term → -- terms to match + List Term → -- terms to match against + Bool | [], [] => true | [], _ :: _ => false | _ :: _, [] => false @@ -452,7 +597,11 @@ private def multisetEqual : List Term → List Term → Bool | none => false | some remaining => multisetEqual rest remaining -private def hypothesesMatch (ours wanted : List Term) : Bool := +private +def hypothesesMatch + (ours wanted : List Term) + : Bool + := multisetEqual (ours.map comparable) (wanted.map comparable) private structure GoalResult where @@ -467,7 +616,11 @@ private structure CoverageResult where reason : String diagnostic : String -private def coverageReasonFor (hasName hasGoal derived goalOK hypsOK : Bool) : String := +private +def coverageReasonFor + (hasName hasGoal derived goalOK hypsOK : Bool) + : String + := if !hasName then "no-sequent" else if !derived then "not-derived" else if !hasGoal then "no-sequent" @@ -475,15 +628,25 @@ private def coverageReasonFor (hasName hasGoal derived goalOK hypsOK : Bool) : S else if !hypsOK then "hypotheses-differ" else "matched" -private theorem deletedGoldSequentIsCoverageLoss : - coverageReasonFor false false false false false == "no-sequent" := by decide +private +theorem deletedGoldSequentIsCoverageLoss + : coverageReasonFor false false false false false == "no-sequent" + := by decide -private def isPlainTypeInvariant : Formula.Term → Bool +private +def isPlainTypeInvariant + : Formula.Term → + Bool | .bin op (.id _) (.id _) => op == "∈" || op == "⊆" | .bin op (.id _) (.pre "ℙ" (.id _)) => op == "∈" | _ => false -private def omittedInvariant (project : Project) (file name : String) : Bool := +private +def omittedInvariant + (project : Project) + (file name : String) + : Bool + := match lookupComponent project file, name.splitOn "/" with | some component, _ :: label :: _ => match component.elem.children.find? (fun elem => @@ -499,8 +662,14 @@ private def omittedInvariant (project : Project) (file name : String) : Bool := | none => false | _, _ => false -private def coverageDiagnostic (project : Project) (file : String) - (obligation : Obligation) (reason : String) : String := +private +def coverageDiagnostic + (project : Project) + (file : String) + (obligation : Obligation) + (reason : String) + : String + := 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" @@ -516,7 +685,12 @@ private def coverageDiagnostic (project : Project) (file : String) #guard isPlainTypeInvariant (.bin "∈" (.id "x") (.pre "ℙ" (.id "S"))) #guard !isPlainTypeInvariant (.bin "=" (.id "x") (.id "y")) -private def goalAgrees (obligation : Obligation) (gold : List (String × String)) : Bool := +private +def goalAgrees + (obligation : Obligation) + (gold : List (String × String)) + : Bool + := match obligation.goal, gold.find? (fun p => p.1 == obligation.name) with | some ours, some (_, wanted) => match Formula.parse wanted with @@ -524,8 +698,12 @@ private def goalAgrees (obligation : Obligation) (gold : List (String × String) | .error _ => false | _, _ => false -private def hypothesesAgree (obligation : Obligation) - (gold : List (String × List String)) : Bool := +private +def hypothesesAgree + (obligation : Obligation) + (gold : List (String × List String)) + : Bool + := match gold.find? (fun p => p.1 == obligation.name) with | none => false | some (_, wanted) => @@ -533,9 +711,15 @@ private def hypothesesAgree (obligation : Obligation) | .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)) : - List CoverageResult := +private +def coverage + (project : Project) + (file : String) + (names : List String) + (goals : List (String × String)) + (hyps : List (String × List String)) + : List CoverageResult + := (generate project file).map fun obligation => let hasName := names.contains obligation.name let hasGoal := goals.any (fun p => p.1 == obligation.name) @@ -552,12 +736,20 @@ private def coverage (project : Project) (file : String) (names : List String) reason := reason diagnostic := coverageDiagnostic project file obligation reason } -private def coverageLine (record : CoverageResult) : String := +private +def coverageLine + (record : CoverageResult) + : String + := String.intercalate "\t" [record.component, record.kind, record.name, record.derivation, record.reason, record.diagnostic] -private def coverageHistogram (records : List CoverageResult) : List (String × Nat) := +private +def coverageHistogram + (records : List CoverageResult) + : List (String × Nat) + := (records.foldl (fun counts record => if record.reason == "matched" then counts @@ -567,18 +759,29 @@ private def coverageHistogram (records : List CoverageResult) : List (String × []).mergeSort (fun left right => if left.2 == right.2 then left.1 < right.1 else right.2 < left.2) -private def compatibilityDiagnosticNames : List String := +private +def compatibilityDiagnosticNames + : List String + := ["pinned-bpo-omits-plain-type-invariant", "pinned-bpo-omits-definedness-sequent", "pinned-bpo-omits-refinement-guard-sequent", "pinned-bpo-omits-refinement-action-sequent", "pinned-bpo-omits-witness-feasibility-sequent"] -private def isKnownCompatibilityRecord (record : CoverageResult) : Bool := +private +def isKnownCompatibilityRecord + (record : CoverageResult) + : Bool + := (record.reason == "no-sequent" || record.reason == "not-derived") && compatibilityDiagnosticNames.contains record.diagnostic -private def compatibilityRecords (records : List CoverageResult) : List CoverageResult := +private +def compatibilityRecords + (records : List CoverageResult) + : List CoverageResult + := records.filter isKnownCompatibilityRecord #guard coverageReasonFor true true true false true == "goal-differs" @@ -589,8 +792,13 @@ private def compatibilityRecords (records : List CoverageResult) : List Coverage /-- Only obligations we generate a goal for are scored; the rest are not yet attempted and would otherwise drown the signal. -/ -private def checkGoals (project : Project) (file : String) - (gold : List (String × String)) : List GoalResult := +private +def checkGoals + (project : Project) + (file : String) + (gold : List (String × String)) + : List GoalResult + := (generate project file).filterMap fun o => match o.goal with | none => none @@ -611,7 +819,11 @@ private def checkGoals (project : Project) (file : String) else some { key := key, status := "FAIL:differs" } -private def readGoldHyps (path : System.FilePath) : IO (List (String × List String)) := do +private +def readGoldHyps + (path : System.FilePath) + : IO (List (String × List String)) + := do match parseXml (← IO.FS.readBinFile path) with | .error _ => throw (IO.userError s!"cannot parse Rodin hypothesis oracle {path}") | .ok xml => @@ -628,8 +840,13 @@ private def readGoldHyps (path : System.FilePath) : IO (List (String × List Str /-- 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 order is not wrong. -/ -private def checkHyps (project : Project) (file : String) - (gold : List (String × List String)) : List GoalResult := +private +def checkHyps + (project : Project) + (file : String) + (gold : List (String × List String)) + : List GoalResult + := (generate project file).filterMap fun o => -- Scored for every obligation with a derived goal. An empty hypothesis list is a -- claim (INITIALISATION assumes nothing), not an absence of one. @@ -647,8 +864,13 @@ private def checkHyps (project : Project) (file : String) else some { key := key, status := "FAIL:hypothesis multiset differs" } -private def checkWWD (project : Project) (file : String) - (gold : List (String × List String)) : List GoalResult := +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 @@ -667,7 +889,12 @@ private structure P4Result where result : Result accepted : Bool -private def localResults (project : Project) (poResults : List PoResult) : List P4Result := +private +def localResults + (project : Project) + (poResults : List PoResult) + : List P4Result + := let matched := poResults.filter (·.status == "PASS") |>.map (·.key) let obligations := (project.flatMap fun component => generate project component.name).filter fun obligation => matched.contains (obligation.component ++ "\t" ++ obligation.name) @@ -679,14 +906,21 @@ private def localResults (project : Project) (poResults : List PoResult) : List | .error _ => false { obligation, result, accepted } -private def goalHistogram (results : List GoalResult) : List (String × Nat) := +private +def goalHistogram + (results : List GoalResult) + : List (String × Nat) + := (results.foldl (fun counts r => if r.status.startsWith "FAIL:" then histogramAdd r.status counts else counts) []).mergeSort (fun left right => if left.2 == right.2 then left.1 < right.1 else right.2 < left.2) -private def termShape : Term → String +private +def termShape + : Term → + String | .id _ => "id" | .num _ => "numeral" | .bin op _ _ => "bin:" ++ op @@ -697,7 +931,11 @@ private def termShape : Term → String | .set _ => "set" | .bind op _ _ => "binder:" ++ op -private def p4Histogram (results : List P4Result) : List (String × Nat) := +private +def p4Histogram + (results : List P4Result) + : List (String × Nat) + := (results.foldl (fun counts result => if result.accepted then counts else histogramAdd (match result.obligation.goal with @@ -705,22 +943,38 @@ 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 := +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 := +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) +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 +private +def multisetSubset + : List String → -- expected lines (subset) + List String → -- actual lines to check against + Bool | [], _ => true | line :: rest, actual => match removeExact line actual with @@ -730,7 +984,11 @@ private def multisetSubset : List String → List String → Bool #guard multisetSubset ["a", "a"] ["a"] == false #guard multisetSubset ["a", "b"] ["b", "a", "c"] -private def baselineDiff (baseline actual : List String) : IO Bool := do +private +def baselineDiff + (baseline actual : List String) + : IO Bool + := do if baseline == actual then pure true else @@ -743,14 +1001,26 @@ private def baselineDiff (baseline actual : List String) : IO Bool := do IO.eprintln s!"- {line}" pure false -private def writeBaseline (path : String) (lines : List String) : IO Unit := do +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) +private +def writeStatus + (results : List FileResult) + (formulas : List FormulaResult) + (types : List TypeResult) + (pos : List PoResult) (goals hyps wwd : List GoalResult) - (compatibilityCount : Nat) (p4 : List P4Result) (inventory : List (String × Nat)) : - IO Unit := do + (compatibilityCount : Nat) + (p4 : List P4Result) + (inventory : List (String × Nat)) + : IO Unit + := do let passed := results.countP (fun result => result.status == "PASS") let fpass := formulas.countP (fun result => result.status == "PASS") let tpass := types.countP (fun result => result.status == "PASS") @@ -792,7 +1062,11 @@ private def writeStatus (results : List FileResult) (formulas : List FormulaResu "PASS/FAIL cannot detect.\n\n| element | count |\n| --- | --- |\n" ++ String.intercalate "\n" counts ++ "\n") -private def run (args : List String) : IO UInt32 := do +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 diff --git a/test/GuardFixtures.lean b/test/GuardFixtures.lean index 0bc4d9a..037bf74 100644 --- a/test/GuardFixtures.lean +++ b/test/GuardFixtures.lean @@ -4,7 +4,10 @@ import EventB.POG.RefinementAdapters namespace EventB.POG -private def guardedProject : EventB.Typing.Project := +private +def guardedProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.variable [("org.eventb.core.identifier", "x")] [] @@ -15,7 +18,10 @@ private def guardedProject : EventB.Typing.Project := [.guard [("org.eventb.core.label", "g"), ("org.eventb.core.predicate", "x ∈ ℤ")] []]] }] -private def malformedGuardProject : EventB.Typing.Project := +private +def malformedGuardProject + : EventB.Typing.Project + := [{ name := "M" elem := .machineFile [("org.eventb.core.name", "M")] [.event [("org.eventb.core.label", "step")] diff --git a/test/MrgAdapterFixtures.lean b/test/MrgAdapterFixtures.lean index 1a9c809..73068bc 100644 --- a/test/MrgAdapterFixtures.lean +++ b/test/MrgAdapterFixtures.lean @@ -4,7 +4,10 @@ import EventB.POG.RefinementAdapters namespace EventB.POG -private def mrgAdapterProject : EventB.Typing.Project := +private +def mrgAdapterProject + : EventB.Typing.Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [ .event [("org.eventb.core.label", "INITIALISATION")] [] @@ -22,7 +25,10 @@ private def mrgAdapterProject : EventB.Typing.Project := [ .refinesEvent [("org.eventb.core.target", "left")] [] , .refinesEvent [("org.eventb.core.target", "right")] [] ] ] }] -private def mrgObligation : Obligation := +private +def mrgObligation + : Obligation + := { component := "B" name := "merge/MRG" kind := "MRG" @@ -33,79 +39,113 @@ private def mrgObligation : Obligation := #guard (CheckedPO.fromGeneratedExact? EventB.Theory.empty mrgAdapterProject mrgObligation).isSome -private def mrgPO : CheckedPO EventB.Theory.empty mrgAdapterProject := +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 +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 +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 +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 := +private +def mrgLeft + : Event Unit + := { grd := fun _ => True act := fun _ _ => True } -private def mrgRight : Event Unit := +private +def mrgRight + : Event Unit + := { grd := fun _ => True act := fun _ _ => True } -private def mrgEventSource : CheckedEventSource EventB.Theory.empty - mrgAdapterProject "B" "merge" := +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" := +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" := +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 := +private +def mrgTransition + : CheckedBeforeAfter + := { before := {}, after := {}, declarations := [] } -private def mrgLeftEventSource : CheckedEventSource EventB.Theory.empty - mrgAdapterProject "A" "left" := +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" := +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" := +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" := +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 +private +theorem mrgLeftAssignment + : mrgLeftEventSource.assignmentAction 128 mrgTransition + := by change assignmentRelation 128 mrgLeftEventSource.declarations mrgTransition mrgLeftEventSource.updates have declarations : mrgLeftEventSource.declarations = [] := by native_decide @@ -119,8 +159,10 @@ private theorem mrgLeftAssignment : · native_decide · rfl -private theorem mrgRightAssignment : - mrgRightEventSource.assignmentAction 128 mrgTransition := by +private +theorem mrgRightAssignment + : mrgRightEventSource.assignmentAction 128 mrgTransition + := by change assignmentRelation 128 mrgRightEventSource.declarations mrgTransition mrgRightEventSource.updates have declarations : mrgRightEventSource.declarations = [] := by native_decide @@ -134,8 +176,10 @@ private theorem mrgRightAssignment : · native_decide · rfl -private theorem mrgLeftGuardHolds : - mrgLeftGuardSource.holds 128 mrgTransition := by +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 @@ -153,8 +197,10 @@ private theorem mrgLeftGuardHolds : unfold assignmentPredicateWithFuel native_decide -private theorem mrgRightGuardHolds : - mrgRightGuardSource.holds 128 mrgTransition := by +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 @@ -172,8 +218,10 @@ private theorem mrgRightGuardHolds : unfold assignmentPredicateWithFuel native_decide -private def mrgLeftBinding : CheckedMergeBranch EventB.Theory.empty - mrgAdapterProject Unit := +private +def mrgLeftBinding + : CheckedMergeBranch EventB.Theory.empty mrgAdapterProject Unit + := { locator := ("A", "left") eventSource := mrgLeftEventSource guardSource := mrgLeftGuardSource @@ -195,8 +243,10 @@ private def mrgLeftBinding : CheckedMergeBranch EventB.Theory.empty · intro _ trivial } -private def mrgRightBinding : CheckedMergeBranch EventB.Theory.empty - mrgAdapterProject Unit := +private +def mrgRightBinding + : CheckedMergeBranch EventB.Theory.empty mrgAdapterProject Unit + := { locator := ("A", "right") eventSource := mrgRightEventSource guardSource := mrgRightGuardSource @@ -218,12 +268,16 @@ private def mrgRightBinding : CheckedMergeBranch EventB.Theory.empty · intro _ trivial } -private def mrgBranchBindings : List (CheckedMergeBranch EventB.Theory.empty - mrgAdapterProject Unit) := +private +def mrgBranchBindings + : List (CheckedMergeBranch EventB.Theory.empty mrgAdapterProject Unit) + := [mrgLeftBinding, mrgRightBinding] -private theorem mrgAssignment : - mrgEventSourceBound.assignmentAction 128 mrgTransition := by +private +theorem mrgAssignment + : mrgEventSourceBound.assignmentAction 128 mrgTransition + := by change assignmentRelation 128 mrgEventSourceBound.declarations mrgTransition mrgEventSourceBound.updates have declarations : mrgEventSourceBound.declarations = [] := by native_decide @@ -243,28 +297,42 @@ private abbrev mrgSourceState := private def mrgState : mrgSourceState := ⟨mrgTransition, mrgAssignment⟩ -private def mrgModel : TypedTransitionModel := +private +def mrgModel + : TypedTransitionModel + := { fuel := 128 wellFormed := mrgEventSourceBound.assignmentAction 128 inhabited := ⟨mrgTransition, mrgAssignment⟩ supports := fun _ => true } -private def mrgConcrete : Event mrgSourceState := +private +def mrgConcrete + : Event mrgSourceState + := { grd := fun _ => True act := fun _ _ => True } -private def mrgAbstractMachine : Machine Unit := +private +def mrgAbstractMachine + : Machine Unit + := { inv := fun _ => True init := fun _ => True events := [mrgLeft, mrgRight] } -private def mrgConcreteMachine : Machine mrgSourceState := +private +def mrgConcreteMachine + : Machine mrgSourceState + := { inv := fun _ => True init := fun _ => True events := [mrgConcrete] } -private def mrgContract : SplitSimulation mrgConcreteMachine mrgAbstractMachine - (fun _ _ => True) := +private +def mrgContract + : SplitSimulation mrgConcreteMachine mrgAbstractMachine (fun _ _ => True) + := { concreteEvent := mrgConcrete concreteMember := by simp [mrgConcreteMachine] abstractEvents := [mrgLeft, mrgRight] @@ -283,11 +351,16 @@ private def mrgContract : SplitSimulation mrgConcreteMachine mrgAbstractMachine simpa using member rcases branches with rfl | rfl <;> exact ⟨(), trivial, trivial⟩ } -private def mrgBranches : List (String × Event Unit) := +private +def mrgBranches + : List (String × Event Unit) + := [("left", mrgLeft), ("right", mrgRight)] -private theorem mrgSemantic : - splitSimulationSemantic mrgContract mrgBranches := by +private +theorem mrgSemantic + : splitSimulationSemantic mrgContract mrgBranches + := by intro _ _ _ _ _ _ exact ⟨"left", mrgLeft, (), by simp [mrgBranches], trivial, trivial, trivial⟩ @@ -390,10 +463,17 @@ private def mrgAdapter : MergeAdapter EventB.Theory.empty mrgAdapterProject · 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 := +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 index a093e62..ab8db21 100644 --- a/test/MrgFixtures.lean +++ b/test/MrgFixtures.lean @@ -4,7 +4,10 @@ import EventB.POG.RefinementAdapters namespace EventB.POG -private def mergeFixtureProject : EventB.Typing.Project := +private +def mergeFixtureProject + : EventB.Typing.Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [ .variable [("org.eventb.core.identifier", "x")] [] @@ -42,7 +45,10 @@ private def mergeFixtureProject : EventB.Typing.Project := #guard (CheckedMergeSource.fromProject EventB.Theory.empty mergeFixtureProject "B" "left").isNone #guard (CheckedMergeSource.fromProject EventB.Theory.empty mergeFixtureProject "B" "missing").isNone -private def rawMergeObligation : Obligation := +private +def rawMergeObligation + : Obligation + := { component := "B" name := "merge/MRG" kind := "MRG" diff --git a/test/MrgSemanticFixtures.lean b/test/MrgSemanticFixtures.lean index 02e01d1..d8c993c 100644 --- a/test/MrgSemanticFixtures.lean +++ b/test/MrgSemanticFixtures.lean @@ -4,7 +4,10 @@ import EventB.POG.RefinementAdapters namespace EventB.POG -private def mergeSemanticProject : EventB.Typing.Project := +private +def mergeSemanticProject + : EventB.Typing.Project + := [{ name := "A" elem := .machineFile [("org.eventb.core.name", "A")] [ .event [("org.eventb.core.label", "INITIALISATION")] [] @@ -21,35 +24,54 @@ private def mergeSemanticProject : EventB.Typing.Project := , .action [("org.eventb.core.label", "set"), ("org.eventb.core.assignment", "x ≔ 0")] [] ] ] }] -private def mergeSource : CheckedMergeSource Theory.empty - mergeSemanticProject "B" "merge" := +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 := +private +def concreteEvent + : Event Unit + := { grd := fun _ => True act := fun _ _ => True } -private def leftBranch : Event Bool := +private +def leftBranch + : Event Bool + := { grd := fun state => state = false act := fun _ _ => True } -private def rightBranch : Event Bool := +private +def rightBranch + : Event Bool + := { grd := fun state => state = true act := fun _ _ => True } -private def abstractMachine : Machine Bool := +private +def abstractMachine + : Machine Bool + := { inv := fun _ => True init := fun _ => True events := [leftBranch, rightBranch] } -private def concreteMachine : Machine Unit := +private +def concreteMachine + : Machine Unit + := { inv := fun _ => True init := fun _ => True events := [concreteEvent] } -private def splitContract : SplitSimulation concreteMachine abstractMachine - (fun _ _ => True) := +private +def splitContract + : SplitSimulation concreteMachine abstractMachine (fun _ _ => True) + := { concreteEvent := concreteEvent concreteMember := by simp [concreteMachine] abstractEvents := [leftBranch, rightBranch] @@ -71,7 +93,10 @@ private def splitContract : SplitSimulation concreteMachine abstractMachine rcases branches with rfl | rfl <;> exact ⟨false, by simp [leftBranch, rightBranch], trivial⟩ } -private def sourceBranches : List (String × Event Bool) := +private +def sourceBranches + : List (String × Event Bool) + := [("left", leftBranch), ("right", rightBranch)] #guard mergeSource.targets == ["left", "right"] @@ -80,7 +105,9 @@ private def sourceBranches : List (String × Event Bool) := example : [leftBranch, rightBranch] = sourceBranches.map (·.2) := by rfl -example : splitSimulationSemantic splitContract sourceBranches := by +example + : splitSimulationSemantic splitContract sourceBranches + := by intro _ _ abstract _ _ _ cases abstract with | false => @@ -90,12 +117,16 @@ example : splitSimulationSemantic splitContract sourceBranches := by exact ⟨"right", rightBranch, true, by simp [sourceBranches], by simp [rightBranch], by simp [rightBranch], trivial⟩ -private def foreignBranch : Event Bool := +private +def foreignBranch + : Event Bool + := { grd := fun _ => True act := fun _ _ => False } -example : ¬ splitSimulationSemantic splitContract - [("foreign", foreignBranch)] := by +example + : ¬ splitSimulationSemantic splitContract [("foreign", foreignBranch)] + := by intro semantic obtain ⟨label, branch, after, member, _, action, _⟩ := semantic () () false trivial trivial trivial @@ -107,8 +138,9 @@ example : ¬ splitSimulationSemantic splitContract /- 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 +example + : ¬ splitSimulationSemantic splitContract [("left", foreignBranch), ("right", rightBranch)] + := by intro semantic obtain ⟨label, branch, after, member, guard, action, _⟩ := semantic () () false trivial trivial trivial diff --git a/test/RossiDump.lean b/test/RossiDump.lean index 56ef1fb..f27a5d8 100644 --- a/test/RossiDump.lean +++ b/test/RossiDump.lean @@ -4,7 +4,11 @@ namespace EventB.RossiDump open EventB -private def jsonEscape (value : String) : String := +private +def jsonEscape + (value : String) + : String + := String.ofList (value.toList.flatMap fun c => match c with | '"' => ['\\', '"'] @@ -16,16 +20,28 @@ private def jsonEscape (value : String) : String := private def jsonString (value : String) : String := "\"" ++ jsonEscape value ++ "\"" -private def componentJson (component : Rossi.Component) : String := +private +def componentJson + (component : Rossi.Component) + : String + := let kind := if component.model.root.tag.endsWith "contextFile" then "Context" else "Machine" "{\"component_type\":" ++ jsonString kind ++ ",\"component_name\":" ++ jsonString component.name ++ "}" -private def fileJson (path : String) (components : List Rossi.Component) : String := +private +def fileJson + (path : String) + (components : List Rossi.Component) + : String + := "{\"file\":" ++ jsonString path ++ ",\"success\":true,\"components\":[" ++ String.intercalate "," (components.map componentJson) ++ "]}" -def main (args : List String) : IO UInt32 := do +def main + (args : List String) + : IO UInt32 + := do let mut failed := false for path in args do match ← Rossi.read path with diff --git a/test/VariantFixtures.lean b/test/VariantFixtures.lean index e6f605e..ed13303 100644 --- a/test/VariantFixtures.lean +++ b/test/VariantFixtures.lean @@ -13,18 +13,36 @@ namespace EventB.VariantFixtures open EventB EventB.Formula EventB.POG EventB.Typing -private def childrenOf (element : Elem) (tag : String) : List Elem := +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 := +private +def attrOf + (element : Elem) + (key : String) + : Option String + := element.attr? ("org.eventb.core." ++ key) -private def componentElements (project : Project) (component : String) : - Option Elem := +private +def componentElements + (project : Project) + (component : String) + : Option Elem + := (lookupComponent project component).map (·.elem) -private def variantExpressions (project : Project) (component : String) : - List (Option Term) := +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) @@ -32,22 +50,36 @@ private def variantExpressions (project : Project) (component : String) : /- 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 := +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 := +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 := +private +def parsed? + (source : String) + : Option Term + := (Formula.parse source).toOption -def boundedNatVariantProject : Project := +def boundedNatVariantProject + : Project + := [{ name := "M" elem := .machineFile [ ("org.eventb.core.name", "M") ] [ .variable [ ("org.eventb.core.identifier", "x") ] [] @@ -68,8 +100,13 @@ def boundedNatVariantProject : Project := [ .action [ ("org.eventb.core.label", "unchanged") , ("org.eventb.core.assignment", "x ≔ x") ] [] ] ] }] -private def variantGoal? (project : Project) (event kind : String) - (goal : Option Term) : Bool := +private +def variantGoal? + (project : Project) + (event kind : String) + (goal : Option Term) + : Bool + := match generateCheckedIn Theory.empty project "M" with | .error _ => false | .ok obligations => @@ -78,17 +115,29 @@ private def variantGoal? (project : Project) (event kind : String) obligation.kind == kind && obligation.goal == goal && generatedSourceBound project obligation -private def exactVariantGoal? (project : Project) (event kind mode : String) - (goal : Option Term) : Bool := +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 := +private +def exactVariantSource? + : Option Term + := uniqueVariantExpression? boundedNatVariantProject "M" -private def assignmentUpdates? (project : Project) (component event : String) : - Option (List (String × Term)) := +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 => @@ -99,7 +148,10 @@ private def assignmentUpdates? (project : Project) (component event : String) : | .bin "≔" (.id name) rhs => some (name, rhs) | _ => none -private def exactStepSource? : Option (List (String × Term)) := +private +def exactStepSource? + : Option (List (String × Term)) + := assignmentUpdates? boundedNatVariantProject "M" "step" /- Exact provenance and exact generated goals. The parser comparison is AST equality, @@ -127,7 +179,10 @@ private def exactStepSource? : Option (List (String × Term)) := (parsed? "x ≤ x") #guard !variantGoal? boundedNatVariantProject "missing" "VAR" (parsed? "x < x") -private def alteredVariantProject : Project := +private +def alteredVariantProject + : Project + := [{ name := "M" elem := .machineFile [ ("org.eventb.core.name", "M") ] [ .variable [ ("org.eventb.core.identifier", "x") ] [] @@ -140,7 +195,10 @@ private def alteredVariantProject : Project := [ .action [ ("org.eventb.core.label", "decrement") , ("org.eventb.core.assignment", "x ≔ x − 1") ] [] ] ] }] -private def duplicateVariantProject : Project := +private +def duplicateVariantProject + : Project + := [{ name := "M" elem := .machineFile [ ("org.eventb.core.name", "M") ] [ .variable [ ("org.eventb.core.identifier", "x") ] [] @@ -160,44 +218,65 @@ inductive BoundedState where | two deriving DecidableEq, Repr -def measure : BoundedState → Nat +def measure + : BoundedState → + Nat | .zero => 0 | .one => 1 | .two => 2 -def sourceValue : BoundedState → Int +def sourceValue + : BoundedState → + Int | .zero => 0 | .one => 1 | .two => 2 -def decrement : BoundedState → BoundedState → Prop +def decrement + : BoundedState → -- state before the transition + BoundedState → -- state after the transition + Prop | .one, .zero => True | .two, .one => True | _, _ => False def boundedStates : List BoundedState := [.zero, .one, .two] -def boundedTransitions : List (BoundedState × BoundedState) := +def boundedTransitions + : List (BoundedState × BoundedState) + := [(.one, .zero), (.two, .one)] -theorem bounded_nat : ∀ state, 0 ≤ measure state := by +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 +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 +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, +theorem no_unit_source_cover + : ¬ ∃ encode : Unit → + BoundedState × BoundedState, ∀ transition ∈ boundedTransitions, - ∃ state, encode state = transition := by + ∃ 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]) diff --git a/test/VwdFixtures.lean b/test/VwdFixtures.lean index 9141eb8..687ac3d 100644 --- a/test/VwdFixtures.lean +++ b/test/VwdFixtures.lean @@ -8,30 +8,48 @@ import EventB.POG.RefinementAdapters namespace EventB.POG -private def vwdFixtureProject : EventB.Typing.Project := +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 := +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 := +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 := +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" := +private +def positiveVwdSource + : CheckedVariantSource vwdFixtureProject "M" + := (CheckedVariantSource.fromProject vwdFixtureProject "M").get (by native_decide) -private def vwdFormulaModel : TypedFormulaModel := +private +def vwdFormulaModel + : TypedFormulaModel + := { declarations := [] fuel := 128 wellFormed := fun env => ValueEnv.validationOk 128 [] env = true @@ -43,8 +61,10 @@ private def vwdFormulaModel : TypedFormulaModel := private abbrev vwdState := { env : ValueEnv // ValueEnv.validationOk 128 [] env = true } -private theorem vwdFormulaModel_valid : - TypedFormulaModel.validUnchecked vwdFormulaModel positiveVwdObligation := by +private +theorem vwdFormulaModel_valid + : TypedFormulaModel.validUnchecked vwdFormulaModel positiveVwdObligation + := by constructor · native_decide constructor @@ -58,8 +78,10 @@ private theorem vwdFormulaModel_valid : · intro _ exact evalPredicateIntegerOneNeZero env -private def positiveVwdAdapter : VwdAdapter EventB.Theory.empty - vwdFixtureProject vwdState := +private +def positiveVwdAdapter + : VwdAdapter EventB.Theory.empty vwdFixtureProject vwdState + := { binding := positiveVwdPOExact kind := by native_decide sourceName := by native_decide @@ -84,7 +106,9 @@ private def positiveVwdAdapter : VwdAdapter EventB.Theory.empty adequate := by intro _ _ _; trivial } nonempty := ⟨⟨{}, by native_decide⟩, trivial⟩ } -example : witnessDefinednessSemantic positiveVwdAdapter.pre positiveVwdAdapter.defined := +example + : witnessDefinednessSemantic positiveVwdAdapter.pre positiveVwdAdapter.defined + := positiveVwdAdapter.sound end EventB.POG