/-
Inspired by https://leanprover.zulipchat.com/#narrow/stream/236449-Program-verification/topic/.E2.9C.94.20Small-step.20operational.20semantics
-/
import Batteries.Tactic.Basic
-- import Batteries.Tactic.RCases
import Batteries.CodeAction
inductive Tm where
| C : Nat โ Tm
| P : Tm โ Tm โ Tm
namespace Tm
def evalF: Tm โ Nat
| C n => n
| P l r => l.evalF + r.evalF
set_option hygiene false in
infixl :25 " ==> " => eval
inductive eval : Tm โ Nat โ Prop where
| EConst : โ n, C n ==> n
| EPlus : โ tโ tโ nโ nโ,
tโ ==> nโ โ
tโ ==> nโ โ
P tโ tโ ==> nโ + nโ
-- Repeating this helps delaboration
infixl :25 " ==> " => eval
set_option hygiene false in
infixl :25 " ~~> " => step
inductive step : Tm โ Tm โ Prop where
| StPlusConstConst :
P (C nโ) (C nโ) ~~> C (nโ + nโ)
| StPlusLeft (tโ tโ' tโ : Tm):
tโ ~~> tโ' โ
P tโ tโ ~~> P tโ' tโ
| StPlusRight (tโ tโ' : Tm):
tโ ~~> tโ' โ
P (C n) tโ ~~> P (C n) tโ'
-- Repeating this helps delaboration
infixl :25 " ~~> " => step
end Tm
def Relation (ฮฑ: Type ) := ฮฑ โ ฮฑ โ Prop
def Relation.deterministic (R: Relation ฮฑ) : Prop :=
โ {x yโ yโ: ฮฑ}, R x yโ โ R x yโ โ yโ = yโ
theorem EvalSmallStep.deterministic : Relation.deterministic Tm.step := by
unfold Relation.deterministic : {ฮฑ : Type} โ Relation ฮฑ โ Prop
Relation.deterministicโ {x yโ yโ : Tm}, x ~~> yโ โ x ~~> yโ โ yโ = yโ
intro x yโ yโ hyโ hyโ x, yโ, yโ : Tm hyโ : x ~~> yโ hyโ : x ~~> yโ
yโ = yโ
induction hyโ generalizing yโ x, yโ : Tm nโโ, nโโ : Nat yโ : Tm hyโ : (Tm.C nโโ ). P (Tm.C nโโ ) ~~> yโ
StPlusConstConst Tm.C (nโโ + nโโ ) = yโ
<;> x, yโ : Tm nโโ, nโโ : Nat yโ : Tm hyโ : (Tm.C nโโ ). P (Tm.C nโโ ) ~~> yโ
StPlusConstConst Tm.C (nโโ + nโโ ) = yโ
first
| x, yโ : Tm nโ : Nat tโโ, tโ'โ : Tm aโ : tโโ ~~> tโ'โ a_ihโ : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โ = yโyโ : Tm hyโ : (Tm.C nโ ). P tโโ ~~> yโ
StPlusRight (Tm.C nโ ). P tโ'โ = yโ
cases hyโ : (Tm.C nโโ).P (Tm.C nโโ) ~~> yโ
hyโ x, yโ : Tm nโ : Nat tโ'โ : Tm nโโ : Nat aโ : Tm.C nโโ ~~> tโ'โ a_ihโ : โ {yโ : Tm}, Tm.C nโโ ~~> yโ โ tโ'โ = yโ
StPlusRight.StPlusConstConst (Tm.C nโ ). P tโ'โ = Tm.C (nโ + nโโ )
<;> x, yโ : Tm nโ : Nat tโ'โ : Tm nโโ : Nat aโ : Tm.C nโโ ~~> tโ'โ a_ihโ : โ {yโ : Tm}, Tm.C nโโ ~~> yโ โ tโ'โ = yโ
StPlusRight.StPlusConstConst (Tm.C nโ ). P tโ'โ = Tm.C (nโ + nโโ )
rename_i h : Tm.C nโ ~~> tโ'โ
h x, yโ : Tm nโ : Nat tโโ, tโ'โยน : Tm aโ : tโโ ~~> tโ'โยน a_ihโ : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โยน = yโtโ'โ : Tm h : tโโ ~~> tโ'โ
StPlusRight.StPlusRight (Tm.C nโ ). P tโ'โยน = (Tm.C nโ ). P tโ'โ
<;> x, yโ : Tm nโโ, h : Nat
StPlusConstConst.StPlusConstConst Tm.C (nโโ + h) = Tm.C (nโโ + h)
first | x, yโ, tโ'โ : Tm nโโ, nโโ : Nat aโ : Tm.C nโโ ~~> tโ'โ h : โ {yโ : Tm}, Tm.C nโโ ~~> yโ โ tโ'โ = yโ
StPlusLeft.StPlusConstConst tโ'โ. P (Tm.C nโโ ) = Tm.C (nโโ + nโโ )
rfl x, yโ : Tm nโโ, nโโ : Nat tโ'โ : Tm h : Tm.C nโโ ~~> tโ'โ
StPlusConstConst.StPlusRight Tm.C (nโโ + nโโ ) = (Tm.C nโโ ). P tโ'โ
| x, yโ, tโ'โ : Tm nโโ, nโโ : Nat aโ : Tm.C nโโ ~~> tโ'โ h : โ {yโ : Tm}, Tm.C nโโ ~~> yโ โ tโ'โ = yโ
StPlusLeft.StPlusConstConst tโ'โ. P (Tm.C nโโ ) = Tm.C (nโโ + nโโ )
cases h : โ {yโ : Tm}, Tm.C nโโ ~~> yโ โ tโ'โ = yโ
h x, yโ, tโ'โ : Tm nโโ, nโโ : Nat aโ : Tm.C nโโ ~~> tโ'โ h : โ {yโ : Tm}, Tm.C nโโ ~~> yโ โ tโ'โ = yโxโ : Tm.C nโโ ~~> ? m. 6631 โ tโ'โ = ? m. 6631
StPlusLeft.StPlusConstConst tโ'โ. P (Tm.C nโโ ) = Tm.C (nโโ + nโโ )
| x, yโ : Tm nโ : Nat tโโ, tโ'โ : Tm aโ : tโโ ~~> tโ'โ a_ihโ : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โ = yโyโ : Tm hyโ : (Tm.C nโ ). P tโโ ~~> yโ
StPlusRight (Tm.C nโ ). P tโ'โ = yโ
rename_i h hP : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โ = yโ
hP x, yโ : Tm nโ : Nat tโโ, tโ'โ : Tm h : tโโ ~~> tโ'โ hP : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โ = yโyโ : Tm hyโ : (Tm.C nโ ). P tโโ ~~> yโ
StPlusRight (Tm.C nโ ). P tโ'โ = yโ
; cases hyโ : tโโ.P tโโ ~~> yโ
hyโ x, yโ : Tm nโ : Nat tโ'โ : Tm nโโ : Nat h : Tm.C nโโ ~~> tโ'โ hP : โ {yโ : Tm}, Tm.C nโโ ~~> yโ โ tโ'โ = yโ
StPlusRight.StPlusConstConst (Tm.C nโ ). P tโ'โ = Tm.C (nโ + nโโ )
<;> x, yโ : Tm nโ : Nat tโ'โ : Tm nโโ : Nat h : Tm.C nโโ ~~> tโ'โ hP : โ {yโ : Tm}, Tm.C nโโ ~~> yโ โ tโ'โ = yโ
StPlusRight.StPlusConstConst (Tm.C nโ ). P tโ'โ = Tm.C (nโ + nโโ )
first | x, yโ : Tm nโ : Nat tโโ, tโ'โยน : Tm h : tโโ ~~> tโ'โยน hP : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โยน = yโtโ'โ : Tm aโ : tโโ ~~> tโ'โ
StPlusRight.StPlusRight (Tm.C nโ ). P tโ'โยน = (Tm.C nโ ). P tโ'โ
contradiction | x, yโ : Tm nโ : Nat tโโ, tโ'โยน : Tm h : tโโ ~~> tโ'โยน hP : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โยน = yโtโ'โ : Tm aโ : tโโ ~~> tโ'โ
StPlusRight.StPlusRight (Tm.C nโ ). P tโ'โยน = (Tm.C nโ ). P tโ'โ
cases _ x, yโ : Tm nโ : Nat tโโ, tโ'โยน : Tm h : tโโ ~~> tโ'โยน hP : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โยน = yโtโ'โ : Tm aโ : tโโ ~~> tโ'โ xโ : ? m. 9168
StPlusRight.StPlusRight (Tm.C nโ ). P tโ'โยน = (Tm.C nโ ). P tโ'โ
| x, yโ : Tm nโ : Nat tโโ, tโ'โยน : Tm h : tโโ ~~> tโ'โยน hP : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โยน = yโtโ'โ : Tm aโ : tโโ ~~> tโ'โ
StPlusRight.StPlusRight (Tm.C nโ ). P tโ'โยน = (Tm.C nโ ). P tโ'โ
( x, yโ : Tm nโ : Nat tโโ, tโ'โยน : Tm h : tโโ ~~> tโ'โยน hP : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โยน = yโtโ'โ : Tm aโ : tโโ ~~> tโ'โ
StPlusRight.StPlusRight (Tm.C nโ ). P tโ'โยน = (Tm.C nโ ). P tโ'โ
rename_i h' x, yโ, tโโ, tโ'โยน, tโโ : Tm h : tโโ ~~> tโ'โยน hP : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โยน = yโtโ'โ : Tm h' : tโโ ~~> tโ'โ
StPlusLeft.StPlusLeft tโ'โยน. P tโโ = tโ'โ. P tโโ
; rw [ x, yโ : Tm nโ : Nat tโโ, tโ'โยน : Tm h : tโโ ~~> tโ'โยน hP : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โยน = yโtโ'โ : Tm h' : tโโ ~~> tโ'โ
StPlusRight.StPlusRight (Tm.C nโ ). P tโ'โยน = (Tm.C nโ ). P tโ'โ
hP : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โยน = yโ
hP h' x, yโ, tโโ, tโ'โยน, tโโ : Tm h : tโโ ~~> tโ'โยน hP : โ {yโ : Tm}, tโโ ~~> yโ โ tโ'โยน = yโtโ'โ : Tm h' : tโโ ~~> tโ'โ
StPlusLeft.StPlusLeft tโ'โ. P tโโ = tโ'โ. P tโโ
] )
-- induction hyโ generalizing yโ with
-- | StPlusConstConst =>
-- cases hyโ <;> rename_i hโ <;> first | rfl | cases hโ
-- -- cases hyโ with
-- -- | StPlusConstConst => rfl
-- -- | StPlusLeft =>
-- -- rename_i hl
-- -- cases hl
-- -- | StPlusRight =>
-- -- rename_i hr
-- -- cases hr
-- | StPlusLeft =>
-- rename_i h hP
-- cases hyโ <;> first | contradiction | cases _ | (rename_i h'; rw [hP h'])
-- -- rename_i hl hPl
-- -- cases hyโ with
-- -- | StPlusConstConst => contradiction
-- -- | StPlusLeft =>
-- -- rename_i hl'
-- -- rw [hPl hl']
-- -- | StPlusRight => cases hl
-- | StPlusRight =>
-- rename_i h hP
-- cases hyโ <;> first | contradiction | cases _ | (rename_i h'; rw [hP h'])
-- -- rename_i hr hPr
-- -- cases hyโ with
-- -- | StPlusConstConst => contradiction
-- -- | StPlusLeft =>
-- -- rename_i hl'
-- -- cases hl'
-- -- | StPlusRight =>
-- -- rename_i hr'
-- -- rw [hPr hr']
done