Research source · Plain text
TableEval.lean
site/public/formal/persistent-stacks/lean/FPRDTransfer/PEG/TableEval.lean
554 lines. Source is displayed for inspection; it is not executed by this page.
File fingerprint
SHA-256: aace39c31f35b083a4bd579422b3019fd513e24d3dbacc48eac5c3fd4461c6f8
import FPRDTransfer.PEG.Semantics
namespace FPRD
universe uSym
namespace Expr
/-- A syntax-directed sufficient test: every successful evaluation consumes at
least one symbol. Nonterminals are deliberately treated conservatively. -/
def guaranteedConsumes : Expr NT Sym → Bool
| .eps | .fail | .nonterm _ | .notP _ => false
| .any | .term _ => true
| .seq left right => guaranteedConsumes left || guaranteedConsumes right
| .alt left right => guaranteedConsumes left && guaranteedConsumes right
/-- Nonterminal calls which can be reached before this expression has
necessarily consumed input. -/
def samePositionCalls : Expr NT Sym → List NT
| .eps | .fail | .any | .term _ => []
| .nonterm name => [name]
| .seq left right =>
samePositionCalls left ++
if guaranteedConsumes left then [] else samePositionCalls right
| .alt left right => samePositionCalls left ++ samePositionCalls right
| .notP body => samePositionCalls body
end Expr
/-- Successful PEG evaluation leaves a suffix of its input. -/
theorem eval_remainder_suffix_of_eq {G : Grammar NT Sym}
{expr : Expr NT Sym} {input : List Sym} {result : Result Sym}
(h : Eval G expr input result) :
∀ {rest}, result = .ok rest → rest <:+ input := by
induction h with
| eps => intro rest hr; cases hr; simp
| fail => intro rest hr; cases hr
| anyOk => intro rest hr; cases hr; simp
| anyNil => intro rest hr; cases hr
| termOk => intro rest hr; cases hr; simp
| termNe => intro rest hr; cases hr
| termNil => intro rest hr; cases hr
| nonterm _ ih => exact ih
| seqOk _ _ ihLeft ihRight =>
intro rest hr
exact (ihRight hr).trans (ihLeft rfl)
| seqErr => intro rest hr; cases hr
| altOk _ ih => exact ih
| altErr _ _ _ ihRight => exact ihRight
| notOk => intro rest hr; cases hr
| notErr => intro rest hr; cases hr; simp
theorem eval_remainder_suffix {G : Grammar NT Sym} {expr : Expr NT Sym}
{input rest : List Sym} (h : Eval G expr input (.ok rest)) :
rest <:+ input := eval_remainder_suffix_of_eq h rfl
/-- The syntactic consumption test is sound for every successful relational
evaluation. -/
theorem guaranteedConsumes_sound_of_eq {G : Grammar NT Sym}
{expr : Expr NT Sym} {input : List Sym} {result : Result Sym}
(h : Eval G expr input result) : ∀ {rest}, result = .ok rest →
Expr.guaranteedConsumes expr = true → rest.length < input.length := by
induction h with
| eps => simp [Expr.guaranteedConsumes]
| fail => intro rest hr; cases hr
| anyOk => intro rest hr; cases hr; simp
| anyNil => intro rest hr; cases hr
| termOk => intro rest hr; cases hr; simp
| termNe => intro rest hr; cases hr
| termNil => intro rest hr; cases hr
| nonterm => simp [Expr.guaranteedConsumes]
| seqOk hLeft hRight ihLeft ihRight =>
intro rest hr hconsumes
simp only [Expr.guaranteedConsumes, Bool.or_eq_true] at hconsumes
rcases hconsumes with hleft | hright
· exact Nat.lt_of_le_of_lt
(eval_remainder_suffix_of_eq hRight hr).length_le
(ihLeft rfl hleft)
· exact Nat.lt_of_lt_of_le (ihRight hr hright)
(eval_remainder_suffix hLeft).length_le
| seqErr => intro rest hr; cases hr
| altOk hLeft ih =>
intro rest hr hconsumes
simp only [Expr.guaranteedConsumes, Bool.and_eq_true] at hconsumes
exact ih hr hconsumes.1
| altErr _ hRight _ ihRight =>
intro rest hr hconsumes
simp only [Expr.guaranteedConsumes, Bool.and_eq_true] at hconsumes
exact ihRight hr hconsumes.2
| notOk => intro rest hr; cases hr
| notErr => simp [Expr.guaranteedConsumes]
theorem guaranteedConsumes_sound {G : Grammar NT Sym}
{expr : Expr NT Sym} {input rest : List Sym}
(h : Eval G expr input (.ok rest))
(hconsumes : Expr.guaranteedConsumes expr = true) :
rest.length < input.length :=
guaranteedConsumes_sound_of_eq h rfl hconsumes
/-- An explicit nonterminal order whose prefix contains every call that may be
reached at the same input position. -/
structure RankSchedule {n : Nat} (G : Grammar (Fin n) Sym) where
order : List (Fin n)
nodup : order.Nodup
complete : ∀ name, name ∈ order
earlier : ∀ {before after caller callee},
order = before ++ caller :: after →
callee ∈ Expr.samePositionCalls (G.rule caller) →
callee ∈ before
namespace TableEval
abbrev Key (n : Nat) (Sym : Type uSym) := List Sym × Fin n
abbrev Table (n : Nat) (Sym : Type uSym) := List (Key n Sym × Result Sym)
def lookup [DecidableEq Sym] (table : Table n Sym)
(input : List Sym) (name : Fin n) : Option (Result Sym) :=
match table with
| [] => none
| (key, result) :: rest =>
if key = (input, name) then some result else lookup rest input name
def insert (table : Table n Sym) (input : List Sym) (name : Fin n)
(result : Result Sym) : Table n Sym :=
((input, name), result) :: table
def Sound [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(table : Table n Sym) : Prop :=
∀ input name result, lookup table input name = some result →
Eval G (.nonterm name) input result
def Filled [DecidableEq Sym] (table : Table n Sym)
(input : List Sym) (name : Fin n) : Prop :=
∃ result, lookup table input name = some result
/-- Structural expression evaluation reads nonterminals only from the table.
`none` is an internal missing-cell signal, never PEG rejection. -/
def evalExpr [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(table : Table n Sym) : Expr (Fin n) Sym → List Sym → Option (Result Sym)
| .eps, input => some (.ok input)
| .fail, _ => some .err
| .any, [] => some .err
| .any, _ :: rest => some (.ok rest)
| .term _, [] => some .err
| .term expected, actual :: rest =>
some (if expected = actual then .ok rest else .err)
| .nonterm name, input => lookup table input name
| .seq left right, input => do
match ← evalExpr G table left input with
| .err => pure .err
| .ok middle => evalExpr G table right middle
| .alt left right, input => do
match ← evalExpr G table left input with
| .ok rest => pure (.ok rest)
| .err => evalExpr G table right input
| .notP body, input => do
match ← evalExpr G table body input with
| .ok _ => pure .err
| .err => pure (.ok input)
theorem evalExpr_sound [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(table : Table n Sym) (htable : Sound G table)
{expr : Expr (Fin n) Sym} {input : List Sym} {result : Result Sym}
(hresult : evalExpr G table expr input = some result) :
Eval G expr input result := by
induction expr generalizing input result with
| eps =>
have hr : result = .ok input := by simpa [evalExpr] using hresult.symm
cases hr
exact .eps
| fail =>
have hr : result = .err := by simpa [evalExpr] using hresult.symm
cases hr
exact .fail
| any =>
cases input with
| nil =>
have hr : result = .err := by simpa [evalExpr] using hresult.symm
cases hr
exact .anyNil
| cons symbol rest =>
have hr : result = .ok rest := by simpa [evalExpr] using hresult.symm
cases hr
exact .anyOk
| term expected =>
cases input with
| nil =>
have hr : result = .err := by simpa [evalExpr] using hresult.symm
cases hr
exact .termNil
| cons actual rest =>
by_cases hsame : expected = actual
· subst actual
have hr : result = .ok rest := by
simpa [evalExpr] using hresult.symm
cases hr
exact .termOk
· have hr : result = .err := by
simpa [evalExpr, hsame] using hresult.symm
cases hr
exact .termNe hsame
| nonterm name => exact htable input name result hresult
| seq left right ihLeft ihRight =>
cases hleft : evalExpr G table left input with
| none => simp [evalExpr, hleft] at hresult
| some leftResult =>
cases leftResult with
| err =>
have hr : result = .err := by simpa [evalExpr, hleft] using hresult.symm
cases hr
exact .seqErr (ihLeft hleft)
| ok middle =>
have hright : evalExpr G table right middle = some result := by
simpa [evalExpr, hleft] using hresult
exact .seqOk (ihLeft hleft) (ihRight hright)
| alt left right ihLeft ihRight =>
cases hleft : evalExpr G table left input with
| none => simp [evalExpr, hleft] at hresult
| some leftResult =>
cases leftResult with
| ok rest =>
have hr : result = .ok rest := by
simpa [evalExpr, hleft] using hresult.symm
cases hr
exact .altOk (ihLeft hleft)
| err =>
have hright : evalExpr G table right input = some result := by
simpa [evalExpr, hleft] using hresult
exact .altErr (ihLeft hleft) (ihRight hright)
| notP body ih =>
cases hbody : evalExpr G table body input with
| none => simp [evalExpr, hbody] at hresult
| some bodyResult =>
cases bodyResult with
| ok rest =>
have hr : result = .err := by
simpa [evalExpr, hbody] using hresult.symm
cases hr
exact .notOk (ih hbody)
| err =>
have hr : result = .ok input := by
simpa [evalExpr, hbody] using hresult.symm
cases hr
exact .notErr (ih hbody)
/-- If every proper-suffix cell and every syntactically same-position call is
present, structural evaluation cannot encounter an absent table entry. -/
theorem evalExpr_present [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(table : Table n Sym) (htable : Sound G table)
{expr : Expr (Fin n) Sym} {input : List Sym}
(shorter : ∀ suffix, suffix <:+ input → suffix.length < input.length →
∀ name, Filled table suffix name)
(same : ∀ name, name ∈ Expr.samePositionCalls expr →
Filled table input name) :
∃ result, evalExpr G table expr input = some result := by
induction expr generalizing input with
| eps => exact ⟨.ok input, rfl⟩
| fail => exact ⟨.err, rfl⟩
| any =>
cases input with
| nil => exact ⟨.err, rfl⟩
| cons symbol rest => exact ⟨.ok rest, rfl⟩
| term expected =>
cases input with
| nil => exact ⟨.err, rfl⟩
| cons actual rest =>
by_cases hsame : expected = actual
· subst actual
exact ⟨.ok rest, by simp [evalExpr]⟩
· exact ⟨.err, by simp [evalExpr, hsame]⟩
| nonterm name => exact same name (by simp [Expr.samePositionCalls])
| seq left right ihLeft ihRight =>
obtain ⟨leftResult, hleft⟩ := ihLeft shorter (fun name hname =>
same name (by simp [Expr.samePositionCalls, hname]))
cases leftResult with
| err => exact ⟨.err, by simp [evalExpr, hleft]⟩
| ok middle =>
have hleftEval : Eval G left input (.ok middle) :=
evalExpr_sound G table htable hleft
have hmiddleSuffix : middle <:+ input := eval_remainder_suffix hleftEval
have hrightShorter : ∀ suffix, suffix <:+ middle →
suffix.length < middle.length → ∀ name, Filled table suffix name := by
intro suffix hsuffix hlength name
exact shorter suffix (hsuffix.trans hmiddleSuffix)
(Nat.lt_of_lt_of_le hlength hmiddleSuffix.length_le) name
have hrightSame : ∀ name,
name ∈ Expr.samePositionCalls right → Filled table middle name := by
intro name hname
rcases Nat.lt_or_eq_of_le hmiddleSuffix.length_le with hlt | heq
· exact shorter middle hmiddleSuffix hlt name
· have hm : middle = input := hmiddleSuffix.eq_of_length heq
subst middle
by_cases hconsumes : Expr.guaranteedConsumes left = true
· exact (Nat.ne_of_lt
(guaranteedConsumes_sound hleftEval hconsumes) rfl).elim
· exact same name (by
simp [Expr.samePositionCalls, hconsumes, hname])
obtain ⟨rightResult, hright⟩ :=
ihRight hrightShorter hrightSame
exact ⟨rightResult, by simp [evalExpr, hleft, hright]⟩
| alt left right ihLeft ihRight =>
obtain ⟨leftResult, hleft⟩ := ihLeft shorter (fun name hname =>
same name (by simp [Expr.samePositionCalls, hname]))
cases leftResult with
| ok rest => exact ⟨.ok rest, by simp [evalExpr, hleft]⟩
| err =>
obtain ⟨rightResult, hright⟩ := ihRight shorter (fun name hname =>
same name (by simp [Expr.samePositionCalls, hname]))
exact ⟨rightResult, by simp [evalExpr, hleft, hright]⟩
| notP body ih =>
obtain ⟨bodyResult, hbody⟩ := ih shorter (fun name hname =>
same name (by simpa [Expr.samePositionCalls] using hname))
cases bodyResult with
| ok rest => exact ⟨.err, by simp [evalExpr, hbody]⟩
| err => exact ⟨.ok input, by simp [evalExpr, hbody]⟩
theorem sound_empty [DecidableEq Sym] (G : Grammar (Fin n) Sym) :
Sound G [] := by
intro input name result h
simp [lookup] at h
theorem sound_insert [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(table : Table n Sym) (htable : Sound G table)
(input : List Sym) (name : Fin n) (result : Result Sym)
(hresult : Eval G (.nonterm name) input result) :
Sound G (insert table input name result) := by
intro input' name' result' hlookup
simp only [insert, lookup] at hlookup
split at hlookup
next hkey =>
have hresult_eq : result = result' := Option.some.inj hlookup
have hinput : input = input' := congrArg (fun key => key.1) hkey
have hname : name = name' := congrArg (fun key => key.2) hkey
subst input'
subst name'
subst result'
exact hresult
next => exact htable input' name' result' hlookup
theorem filled_insert_same [DecidableEq Sym] (table : Table n Sym)
(input : List Sym) (name : Fin n) (result : Result Sym) :
Filled (insert table input name result) input name := by
exact ⟨result, by simp [insert, lookup]⟩
theorem filled_insert_of_filled [DecidableEq Sym] (table : Table n Sym)
(input : List Sym) (name : Fin n) (result : Result Sym)
{input' : List Sym} {name' : Fin n}
(hfilled : Filled table input' name') :
Filled (insert table input name result) input' name' := by
by_cases hkey : (input, name) = (input', name')
· cases hkey
exact filled_insert_same table input name result
· obtain ⟨oldResult, hold⟩ := hfilled
exact ⟨oldResult, by simp [insert, lookup, hkey, hold]⟩
def fillNames [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(table : Table n Sym) (input : List Sym) : List (Fin n) → Table n Sym
| [] => table
| name :: names =>
match evalExpr G table (G.rule name) input with
| none => fillNames G table input names
| some result => fillNames G (insert table input name result) input names
theorem sound_fillNames [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(table : Table n Sym) (htable : Sound G table) (input : List Sym)
(names : List (Fin n)) : Sound G (fillNames G table input names) := by
induction names generalizing table with
| nil => exact htable
| cons name names ih =>
simp only [fillNames]
cases hresult : evalExpr G table (G.rule name) input with
| none => exact ih table htable
| some result =>
exact ih _ (sound_insert G table htable input name result
(.nonterm (evalExpr_sound G table htable hresult)))
theorem filled_fillNames_of_filled [DecidableEq Sym]
(G : Grammar (Fin n) Sym) (table : Table n Sym) (input input' : List Sym)
(name' : Fin n) (names : List (Fin n))
(hfilled : Filled table input' name') :
Filled (fillNames G table input names) input' name' := by
induction names generalizing table with
| nil => exact hfilled
| cons name names ih =>
simp only [fillNames]
cases hresult : evalExpr G table (G.rule name) input with
| none => exact ih table hfilled
| some result =>
simpa [fillNames, hresult] using
ih (insert table input name result)
(filled_insert_of_filled table input name result hfilled)
theorem fillNames_complete [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(schedule : RankSchedule G) (table : Table n Sym) (htable : Sound G table)
(input : List Sym)
(shorter : ∀ suffix, suffix <:+ input → suffix.length < input.length →
∀ name, Filled table suffix name)
(before after : List (Fin n))
(horder : schedule.order = before ++ after)
(hbefore : ∀ name, name ∈ before → Filled table input name) :
∀ name, name ∈ before ++ after →
Filled (fillNames G table input after) input name := by
induction after generalizing table before with
| nil =>
intro name hname
exact hbefore name (by simpa using hname)
| cons caller after ih =>
have hpresent : ∃ result,
evalExpr G table (G.rule caller) input = some result :=
evalExpr_present G table htable shorter (fun callee hcall =>
hbefore callee (schedule.earlier horder hcall))
obtain ⟨result, hresult⟩ := hpresent
have hnewSound : Sound G (insert table input caller result) :=
sound_insert G table htable input caller result
(.nonterm (evalExpr_sound G table htable hresult))
have hnewShorter : ∀ suffix, suffix <:+ input →
suffix.length < input.length →
∀ name, Filled (insert table input caller result) suffix name := by
intro suffix hsuffix hlength name
exact filled_insert_of_filled table input caller result
(shorter suffix hsuffix hlength name)
have hnewBefore : ∀ name, name ∈ before ++ [caller] →
Filled (insert table input caller result) input name := by
intro name hname
rcases List.mem_append.mp hname with hold | hcaller
· exact filled_insert_of_filled table input caller result
(hbefore name hold)
· have : name = caller := by simpa using hcaller
subst name
exact filled_insert_same table input caller result
have hnewOrder : schedule.order = (before ++ [caller]) ++ after := by
simpa [List.append_assoc] using horder
have hrec := ih (table := insert table input caller result)
(before := before ++ [caller]) hnewSound hnewShorter hnewOrder hnewBefore
intro name hname
have hmembership : name ∈ (before ++ [caller]) ++ after := by
simpa [List.append_assoc] using hname
simpa [fillNames, hresult] using hrec name hmembership
/-- Process the empty suffix first, then extend outward one input symbol at a
time. At each suffix, process the certified nonterminal order. -/
def fillSuffixes [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(schedule : RankSchedule G) : List Sym → Table n Sym
| [] => fillNames G [] [] schedule.order
| symbol :: rest =>
fillNames G (fillSuffixes G schedule rest) (symbol :: rest) schedule.order
theorem sound_fillSuffixes [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(schedule : RankSchedule G) (input : List Sym) :
Sound G (fillSuffixes G schedule input) := by
induction input with
| nil => exact sound_fillNames G [] (sound_empty G) [] schedule.order
| cons symbol rest ih => exact sound_fillNames G _ ih _ schedule.order
theorem suffix_of_proper_suffix_cons {suffix rest : List Sym} {symbol : Sym}
(hsuffix : suffix <:+ symbol :: rest)
(hlength : suffix.length < (symbol :: rest).length) :
suffix <:+ rest := by
obtain ⟨before, hbefore⟩ := hsuffix
cases before with
| nil =>
simp only [List.nil_append] at hbefore
subst suffix
simp at hlength
| cons head tail =>
simp only [List.cons_append] at hbefore
injection hbefore with _ htail
exact ⟨tail, htail⟩
theorem fillSuffixes_complete [DecidableEq Sym]
(G : Grammar (Fin n) Sym) (schedule : RankSchedule G) (input : List Sym) :
∀ suffix, suffix <:+ input → ∀ name,
Filled (fillSuffixes G schedule input) suffix name := by
induction input with
| nil =>
have hcurrent := fillNames_complete G schedule [] (sound_empty G) []
(fun suffix _ hlength => by simp at hlength) [] schedule.order
(by simp) (by simp)
intro suffix hsuffix name
have hsuffixNil : suffix = [] := hsuffix.eq_of_length (by
exact Nat.eq_zero_of_le_zero hsuffix.length_le)
subst suffix
exact hcurrent name (by simp [schedule.complete name])
| cons symbol rest ih =>
let previous := fillSuffixes G schedule rest
have hpreviousSound : Sound G previous := sound_fillSuffixes G schedule rest
have hshorter : ∀ suffix, suffix <:+ symbol :: rest →
suffix.length < (symbol :: rest).length →
∀ name, Filled previous suffix name := by
intro suffix hsuffix hlength name
exact ih suffix (suffix_of_proper_suffix_cons hsuffix hlength) name
have hcurrent := fillNames_complete G schedule previous hpreviousSound
(symbol :: rest) hshorter [] schedule.order (by simp) (by simp)
intro suffix hsuffix name
by_cases heq : suffix = symbol :: rest
· subst suffix
exact hcurrent name (by simp [schedule.complete name])
· have hlength : suffix.length < (symbol :: rest).length := by
have hle := hsuffix.length_le
exact Nat.lt_of_le_of_ne hle (fun hlen =>
heq (hsuffix.eq_of_length hlen))
have hold : Filled previous suffix name :=
ih suffix (suffix_of_proper_suffix_cons hsuffix hlength) name
exact filled_fillNames_of_filled G previous (symbol :: rest)
suffix name schedule.order hold
end TableEval
/-- The public evaluator has no fuel or missing-entry outcome. Its internal
table lookup is unwrapped only with the rank/suffix completeness proof. -/
def evalTable [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(schedule : RankSchedule G) (input : List Sym) : Result Sym :=
let table := TableEval.fillSuffixes G schedule input
let present := TableEval.fillSuffixes_complete G schedule input input
(by simp) G.start
(TableEval.lookup table input G.start).get
(Option.isSome_iff_exists.mpr present)
theorem evalTable_sound [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(schedule : RankSchedule G) (input : List Sym) :
Eval G (.nonterm G.start) input (evalTable G schedule input) := by
let table := TableEval.fillSuffixes G schedule input
let present := TableEval.fillSuffixes_complete G schedule input input
(by simp) G.start
let isSome : (TableEval.lookup table input G.start).isSome = true :=
Option.isSome_iff_exists.mpr present
have hlookup : TableEval.lookup table input G.start =
some ((TableEval.lookup table input G.start).get isSome) :=
(Option.some_get isSome).symm
exact TableEval.sound_fillSuffixes G schedule input input G.start
(evalTable G schedule input) (by
simpa only [evalTable, table, present, isSome] using hlookup)
theorem evalTable_eq_of_eval [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(schedule : RankSchedule G) (input : List Sym) (result : Result Sym)
(hresult : Eval G (.nonterm G.start) input result) :
evalTable G schedule input = result :=
eval_deterministic (evalTable_sound G schedule input) hresult
theorem no_self_schedule [DecidableEq Sym] (G : Grammar (Fin n) Sym)
(name : Fin n) (hrule : G.rule name = .nonterm name) :
RankSchedule G → False := by
intro schedule
obtain ⟨before, after, horder⟩ := List.mem_iff_append.mp (schedule.complete name)
have hcall : name ∈ Expr.samePositionCalls (G.rule name) := by
rw [hrule]
simp [Expr.samePositionCalls]
have hbefore : name ∈ before := schedule.earlier horder hcall
have hnodup : (before ++ name :: after).Nodup := by
simpa [horder] using schedule.nodup
have hcross := (List.nodup_append.mp hnodup).2.2
exact hcross name hbefore name (by simp) rfl
end FPRD