import ExprEval.Steps
import ExprEval.Expr

BoolExpr

inductive BoolExpr : Type
        | Const: Bool -> BoolExpr
        | Less: ArExpr -> ArExpr -> BoolExpr
        | Eq: ArExpr -> ArExpr -> BoolExpr
        | Not : BoolExpr -> BoolExpr
        | And : BoolExpr -> BoolExpr -> BoolExpr
        | Or : BoolExpr -> BoolExpr -> BoolExpr

    inductive ArExpr: Type
        | Const: Int -> ArExpr
        | Add: ArExpr -> ArExpr -> ArExpr
        | Sub: ArExpr -> ArExpr -> ArExpr
        | Mul: ArExpr -> ArExpr -> ArExpr
        | Var: V -> ArExpr
        | If : BoolExpr -> ArExpr -> ArExpr -> ArExpr

BoolStep

inductive BoolStep: (val: V -> Int) -> (BoolExpr V) -> (BoolExpr V) -> Prop where
    | notIsBoolNot (b: Bool): BoolStep val
        (BoolExpr.Not (BoolExpr.Const b))
        (BoolExpr.Const !b)
    | andLeftTrue (e: BoolExpr V): BoolStep val
        (BoolExpr.And (BoolExpr.Const true) e)
        e
    | orLeftFalse (e: BoolExpr V): BoolStep val
        (BoolExpr.Or (BoolExpr.Const false) e)
        e
    | andLeftShortCircuit e : BoolStep val
        (BoolExpr.And (BoolExpr.Const false) e)
        (BoolExpr.Const false)
    | orLeftShortCircuit e : BoolStep val
        (BoolExpr.Or (BoolExpr.Const true) e)
        (BoolExpr.Const true)
    | lessConstConstTrue n₁ n₂ : n₁ < n₂ -> BoolStep val
        (BoolExpr.Less (ArExpr.Const n₁) (ArExpr.Const n₂))
        (BoolExpr.Const true)
    | lessConstConstFalse n₁ n₂ : n₁ >= n₂ -> BoolStep val
        (BoolExpr.Less (ArExpr.Const n₁) (ArExpr.Const n₂))
        (BoolExpr.Const false)
    | eqConstConstTrue n₁ n₂ : n₁ = n₂ -> BoolStep val
        (BoolExpr.Eq (ArExpr.Const n₁) (ArExpr.Const n₂))
        (BoolExpr.Const true)
    | eqConstConstFalse n₁ n₂ : n₁ != n₂ -> BoolStep val
        (BoolExpr.Eq (ArExpr.Const n₁) (ArExpr.Const n₂))
        (BoolExpr.Const false)
    | lessArStepLeft (e₁ e₁' e₂: ArExpr V):
        ArStep val e₁ e₁' ->
            BoolStep val
                (BoolExpr.Less e₁ e₂)
                (BoolExpr.Less e₁' e₂)
    | eqArStepLeft (e₁ e₁' e₂: ArExpr V):
        ArStep val e₁ e₁' ->
            BoolStep val
                (BoolExpr.Eq e₁ e₂)
                (BoolExpr.Eq e₁' e₂)
     | lessArStepRight (e₁ e₂ e₂': ArExpr V):
        ArStep val e₂ e₂' ->
            BoolStep val
                (BoolExpr.Less e₁ e₂)
                (BoolExpr.Less e₁ e₂')
    | eqArStepRight (e₁ e₂ e₂': ArExpr V):
        ArStep val e₂ e₂' ->
            BoolStep val
                (BoolExpr.Eq e₁ e₂)
                (BoolExpr.Eq e₁ e₂')
    | orStepLeft (e₁ e₁' e₂: BoolExpr V):
        BoolStep val e₁ e₁' ->
            BoolStep val
                (BoolExpr.Or e₁ e₂)
                (BoolExpr.Or e₁' e₂)
    | andStepLeft (e₁ e₁' e₂: BoolExpr V):
        BoolStep val e₁ e₁' ->
            BoolStep val
                (BoolExpr.And e₁ e₂)
                (BoolExpr.And e₁' e₂)
    | notStep (e e' : BoolExpr V):
        BoolStep val e e' -> BoolStep val
            (BoolExpr.Not e)
            (BoolExpr.Not e')

    def eval (val: V -> Int) (e: ArExpr V) : Int :=
        match e with
            | ArExpr.Const x => x
            | ArExpr.Add lhs rhs => (eval val lhs) + (eval val rhs)
            | ArExpr.Sub lhs rhs => (eval val lhs) - (eval val rhs)
            | ArExpr.Mul lhs rhs => (eval val lhs) * (eval val rhs)
            | ArExpr.Var v => val v
            | ArExpr.If cond then_e else_e => if eval_bool val cond then eval val then_e else eval val else_e

    def eval_bool (val: V -> Int) (e: BoolExpr V): Bool :=
        match e with
        | BoolExpr.Const b => b
        | BoolExpr.Less l r =>  (eval val l) < (eval val r)
        | BoolExpr.Eq l r => (eval val l) == (eval val r)
        | BoolExpr.Not e => not (eval_bool val e)
        | BoolExpr.And l r => if eval_bool val l then eval_bool val r else false
        | BoolExpr.Or l r => if eval_bool val l then true else eval_bool val r

ArStep

inductive ArStep: (val: V -> Int) -> (ArExpr V) -> (ArExpr V) -> Prop where
    | getVarValue (var: V) :
        ArStep
            val
            (ArExpr.Var var)
            (ArExpr.Const (val var))
    | addConstConst(n₁ n₂: Int) :
        ArStep
            val
            (ArExpr.Add (ArExpr.Const n₁) (ArExpr.Const n₂))
            (ArExpr.Const (n₁ + n₂))
    | subConstConst(n₁ n₂: Int) :
        ArStep
            val
            (ArExpr.Sub (ArExpr.Const n₁) (ArExpr.Const n₂))
            (ArExpr.Const (n₁ - n₂))
    | mulConstConst(n₁ n₂: Int) :
        ArStep
            val
            (ArExpr.Mul (ArExpr.Const n₁) (ArExpr.Const n₂))
            (ArExpr.Const (n₁ * n₂))
    | addLeft (e₁ e₁' e₂) : ArStep val e₁ e₁' -> ArStep val (ArExpr.Add e₁ e₂) (ArExpr.Add e₁' e₂)

    | subLeft (e₁ e₁' e₂) : ArStep val e₁ e₁' -> ArStep val (ArExpr.Sub e₁ e₂) (ArExpr.Sub e₁' e₂)

    | mulLeft (e₁ e₁' e₂) : ArStep val e₁ e₁' -> ArStep val (ArExpr.Mul e₁ e₂) (ArExpr.Mul e₁' e₂)

    | addRight (n: Int) (e₂ e₂': ArExpr V) : ArStep val e₂ e₂' -> ArStep val (ArExpr.Add (ArExpr.Const n) e₂)  (ArExpr.Add (ArExpr.Const n) e₂')

    | subRight (n: Int) (e₂ e₂': ArExpr V) : ArStep val e₂ e₂' -> ArStep val (ArExpr.Sub (ArExpr.Const n) e₂)  (ArExpr.Sub (ArExpr.Const n) e₂')
    | mulRight (n: Int) (e₂ e₂': ArExpr V) : ArStep val e₂ e₂' -> ArStep val (ArExpr.Mul (ArExpr.Const n) e₂)  (ArExpr.Mul (ArExpr.Const n) e₂')

    | ifStep (e e': BoolExpr V) (a b : ArExpr V): BoolStep val e e' ->
        ArStep val (ArExpr.If e a b) (ArExpr.If e' a b)
    | ifCondTrue (a b: ArExpr V) : ArStep val (ArExpr.If (BoolExpr.Const true) a b) a
    | ifCondFalse (a b: ArExpr V) : ArStep val (ArExpr.If (BoolExpr.Const false) a b) b

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

theorem arstep_preserve_eval (e e': ArExpr V): (ArStep V val) e e' -> eval V val e = eval V val e'

import ExprEval.Expr

import ExprEval.Steps

theorem boolstep_preserves_eval_bool (e e': BoolExpr V):
        BoolStep V val e e' -> eval_bool V val e = eval_bool V val e' :=

:= by
        intro h
        cases h with
        | notIsBoolNot b => simp [eval_bool]
        | andLeftTrue e => simp [eval_bool]
        | orLeftFalse e => simp [eval_bool]
        | andLeftShortCircuit e => simp [eval_bool]
        | orLeftShortCircuit e => simp [eval_bool]
        | lessConstConstTrue n1 n2 h =>
            simp [eval_bool]
            simp [eval]
            exact h
        | lessConstConstFalse n1 n2 h =>
            simp [eval_bool]
            simp [eval]
            exact h
        | eqConstConstTrue n1 n2 h =>
            simp [eval_bool]
            simp [eval]
            exact h
        | eqConstConstFalse n1 n2 h =>
            simp [eval_bool]
            simp [eval]
            simp [bne_iff_ne] at h
            exact h
        | lessArStepLeft e₁ e₁' e₂ arstep
        | eqArStepLeft e₁ e₁' e₂ arstep =>
            simp [eval_bool]
            have h' := arstep_preserve_eval e₁ e₁' arstep
            rw [h']
        | lessArStepRight e₁ e₂ e₂' arstep
        | eqArStepRight e₁ e₂ e₂' arstep =>
            simp [eval_bool]
            have h' := arstep_preserve_eval e₂ e₂' arstep
            rw [h']
        | orStepLeft e₁ e₁' e₂ step
        | andStepLeft e₁ e₁' e₂ step =>
            have ihn := boolstep_preserves_eval_bool e₁ e₁' step
            simp [eval_bool]
            rw [ihn]
        | notStep e e' step =>
            simp[eval_bool]
            have ihn := boolstep_preserves_eval_bool e e' step
            rw [ihn]


BoolStep

inductive BoolStep: (val: V -> Int) -> (BoolExpr V) -> (BoolExpr V) -> Prop where
    | notIsBoolNot (b: Bool): BoolStep val
        (BoolExpr.Not (BoolExpr.Const b))
        (BoolExpr.Const !b)
    | andLeftTrue (e: BoolExpr V): BoolStep val
        (BoolExpr.And (BoolExpr.Const true) e)
        e
    | orLeftFalse (e: BoolExpr V): BoolStep val
        (BoolExpr.Or (BoolExpr.Const false) e)
        e
    | andLeftShortCircuit e : BoolStep val
        (BoolExpr.And (BoolExpr.Const false) e)
        (BoolExpr.Const false)
    | orLeftShortCircuit e : BoolStep val
        (BoolExpr.Or (BoolExpr.Const true) e)
        (BoolExpr.Const true)
    | lessConstConstTrue n₁ n₂ : n₁ < n₂ -> BoolStep val
        (BoolExpr.Less (ArExpr.Const n₁) (ArExpr.Const n₂))
        (BoolExpr.Const true)
    | lessConstConstFalse n₁ n₂ : n₁ >= n₂ -> BoolStep val
        (BoolExpr.Less (ArExpr.Const n₁) (ArExpr.Const n₂))
        (BoolExpr.Const false)
    | eqConstConstTrue n₁ n₂ : n₁ = n₂ -> BoolStep val
        (BoolExpr.Eq (ArExpr.Const n₁) (ArExpr.Const n₂))
        (BoolExpr.Const true)
    | eqConstConstFalse n₁ n₂ : n₁ != n₂ -> BoolStep val
        (BoolExpr.Eq (ArExpr.Const n₁) (ArExpr.Const n₂))
        (BoolExpr.Const false)
    | lessArStepLeft (e₁ e₁' e₂: ArExpr V):
        ArStep val e₁ e₁' ->
            BoolStep val
                (BoolExpr.Less e₁ e₂)
                (BoolExpr.Less e₁' e₂)
    | eqArStepLeft (e₁ e₁' e₂: ArExpr V):
        ArStep val e₁ e₁' ->
            BoolStep val
                (BoolExpr.Eq e₁ e₂)
                (BoolExpr.Eq e₁' e₂)
     | lessArStepRight (e₁ e₂ e₂': ArExpr V):
        ArStep val e₂ e₂' ->
            BoolStep val
                (BoolExpr.Less e₁ e₂)
                (BoolExpr.Less e₁ e₂')
    | eqArStepRight (e₁ e₂ e₂': ArExpr V):
        ArStep val e₂ e₂' ->
            BoolStep val
                (BoolExpr.Eq e₁ e₂)
                (BoolExpr.Eq e₁ e₂')
    | orStepLeft (e₁ e₁' e₂: BoolExpr V):
        BoolStep val e₁ e₁' ->
            BoolStep val
                (BoolExpr.Or e₁ e₂)
                (BoolExpr.Or e₁' e₂)
    | andStepLeft (e₁ e₁' e₂: BoolExpr V):
        BoolStep val e₁ e₁' ->
            BoolStep val
                (BoolExpr.And e₁ e₂)
                (BoolExpr.And e₁' e₂)
    | notStep (e e' : BoolExpr V):
        BoolStep val e e' -> BoolStep val
            (BoolExpr.Not e)
            (BoolExpr.Not e')

    inductive BoolExpr : Type
        | Const: Bool -> BoolExpr
        | Less: ArExpr -> ArExpr -> BoolExpr
        | Eq: ArExpr -> ArExpr -> BoolExpr
        | Not : BoolExpr -> BoolExpr
        | And : BoolExpr -> BoolExpr -> BoolExpr
        | Or : BoolExpr -> BoolExpr -> BoolExpr

    inductive ArExpr: Type
        | Const: Int -> ArExpr
        | Add: ArExpr -> ArExpr -> ArExpr
        | Sub: ArExpr -> ArExpr -> ArExpr
        | Mul: ArExpr -> ArExpr -> ArExpr
        | Var: V -> ArExpr
        | If : BoolExpr -> ArExpr -> ArExpr -> ArExpr

    def eval (val: V -> Int) (e: ArExpr V) : Int :=
        match e with
            | ArExpr.Const x => x
            | ArExpr.Add lhs rhs => (eval val lhs) + (eval val rhs)
            | ArExpr.Sub lhs rhs => (eval val lhs) - (eval val rhs)
            | ArExpr.Mul lhs rhs => (eval val lhs) * (eval val rhs)
            | ArExpr.Var v => val v
            | ArExpr.If cond then_e else_e => if eval_bool val cond then eval val then_e else eval val else_e

    def eval_bool (val: V -> Int) (e: BoolExpr V): Bool :=
        match e with
        | BoolExpr.Const b => b
        | BoolExpr.Less l r =>  (eval val l) < (eval val r)
        | BoolExpr.Eq l r => (eval val l) == (eval val r)
        | BoolExpr.Not e => not (eval_bool val e)
        | BoolExpr.And l r => if eval_bool val l then eval_bool val r else false
        | BoolExpr.Or l r => if eval_bool val l then true else eval_bool val r

theorem arstep_preserve_eval (e e': ArExpr V): (ArStep V val) e e' -> eval V val e = eval V val e' :=

:= by
            intro h
            cases h with

            | addConstConst n₁ n₂
            | subConstConst n₁ n₂
            | mulConstConst n₁ n₂ => simp [eval]
            | subLeft e₁ e₁' e₂ step
            | addLeft e₁ e₁' e₂ step =>
                simp [eval]
                exact arstep_preserve_eval e₁ e₁' step
            | mulLeft e₁ e₁' e₂ step =>
                simp [eval]
                cases h : (eval V val e₂ == 0)
                .   rw [beq_eq_false_iff_ne] at h
                    rw [Int.mul_eq_mul_right_iff]
                    exact arstep_preserve_eval e₁ e₁' step
                    exact h
                .   rw [beq_iff_eq] at h
                    rw [h]
                    simp
            | addRight n e₂ e₁' step
            | subRight n e₂ e₁' step
            | mulRight n e₂ e₁' step =>
                -- have ih := arstep_preserve_eval e₁ e₁' step
                have ihn := arstep_preserve_eval e₂ e₁' step
                simp [eval, ihn]

            | getVarValue var => simp [eval]
            | ifCondTrue a b =>
                simp [eval]
                simp [eval_bool]
            | ifCondFalse a b =>
                simp [eval]
                simp [eval_bool]
            | ifStep e e' a b bstep =>
                have ihn := boolstep_preserves_eval_bool e e' bstep
                cases h: (eval_bool V val e)
                .   simp [eval]
                    rw [h]
                    rw [<- ihn]
                    simp
                    intro noth
                    rw [h] at noth
                    nomatch noth
                .   simp [eval]
                    rw [h]
                    rw [<- ihn]
                    simp
                    intro noth
                    rw [h] at noth
                    nomatch noth


BoolStepStar

def BoolStepStar (V: Type) := StepStar (Step := BoolStep V) V

BoolStep

inductive BoolStep: (val: V -> Int) -> (BoolExpr V) -> (BoolExpr V) -> Prop where
    | notIsBoolNot (b: Bool): BoolStep val
        (BoolExpr.Not (BoolExpr.Const b))
        (BoolExpr.Const !b)
    | andLeftTrue (e: BoolExpr V): BoolStep val
        (BoolExpr.And (BoolExpr.Const true) e)
        e
    | orLeftFalse (e: BoolExpr V): BoolStep val
        (BoolExpr.Or (BoolExpr.Const false) e)
        e
    | andLeftShortCircuit e : BoolStep val
        (BoolExpr.And (BoolExpr.Const false) e)
        (BoolExpr.Const false)
    | orLeftShortCircuit e : BoolStep val
        (BoolExpr.Or (BoolExpr.Const true) e)
        (BoolExpr.Const true)
    | lessConstConstTrue n₁ n₂ : n₁ < n₂ -> BoolStep val
        (BoolExpr.Less (ArExpr.Const n₁) (ArExpr.Const n₂))
        (BoolExpr.Const true)
    | lessConstConstFalse n₁ n₂ : n₁ >= n₂ -> BoolStep val
        (BoolExpr.Less (ArExpr.Const n₁) (ArExpr.Const n₂))
        (BoolExpr.Const false)
    | eqConstConstTrue n₁ n₂ : n₁ = n₂ -> BoolStep val
        (BoolExpr.Eq (ArExpr.Const n₁) (ArExpr.Const n₂))
        (BoolExpr.Const true)
    | eqConstConstFalse n₁ n₂ : n₁ != n₂ -> BoolStep val
        (BoolExpr.Eq (ArExpr.Const n₁) (ArExpr.Const n₂))
        (BoolExpr.Const false)
    | lessArStepLeft (e₁ e₁' e₂: ArExpr V):
        ArStep val e₁ e₁' ->
            BoolStep val
                (BoolExpr.Less e₁ e₂)
                (BoolExpr.Less e₁' e₂)
    | eqArStepLeft (e₁ e₁' e₂: ArExpr V):
        ArStep val e₁ e₁' ->
            BoolStep val
                (BoolExpr.Eq e₁ e₂)
                (BoolExpr.Eq e₁' e₂)
     | lessArStepRight (e₁ e₂ e₂': ArExpr V):
        ArStep val e₂ e₂' ->
            BoolStep val
                (BoolExpr.Less e₁ e₂)
                (BoolExpr.Less e₁ e₂')
    | eqArStepRight (e₁ e₂ e₂': ArExpr V):
        ArStep val e₂ e₂' ->
            BoolStep val
                (BoolExpr.Eq e₁ e₂)
                (BoolExpr.Eq e₁ e₂')
    | orStepLeft (e₁ e₁' e₂: BoolExpr V):
        BoolStep val e₁ e₁' ->
            BoolStep val
                (BoolExpr.Or e₁ e₂)
                (BoolExpr.Or e₁' e₂)
    | andStepLeft (e₁ e₁' e₂: BoolExpr V):
        BoolStep val e₁ e₁' ->
            BoolStep val
                (BoolExpr.And e₁ e₂)
                (BoolExpr.And e₁' e₂)
    | notStep (e e' : BoolExpr V):
        BoolStep val e e' -> BoolStep val
            (BoolExpr.Not e)
            (BoolExpr.Not e')

StepStar

inductive StepStar {ExprType: Type} {Step: StepKind V ExprType} : (val: V -> Int) -> ExprType -> ExprType -> Prop where
        | refl val e : StepStar val e e
        | trans e₁ e₂ e₃ : Step val e₁ e₂ -> StepStar val e₂ e₃ -> StepStar val e₁ e₃

    def eval_bool (val: V -> Int) (e: BoolExpr V): Bool :=
        match e with
        | BoolExpr.Const b => b
        | BoolExpr.Less l r =>  (eval val l) < (eval val r)
        | BoolExpr.Eq l r => (eval val l) == (eval val r)
        | BoolExpr.Not e => not (eval_bool val e)
        | BoolExpr.And l r => if eval_bool val l then eval_bool val r else false
        | BoolExpr.Or l r => if eval_bool val l then true else eval_bool val r

    def eval (val: V -> Int) (e: ArExpr V) : Int :=
        match e with
            | ArExpr.Const x => x
            | ArExpr.Add lhs rhs => (eval val lhs) + (eval val rhs)
            | ArExpr.Sub lhs rhs => (eval val lhs) - (eval val rhs)
            | ArExpr.Mul lhs rhs => (eval val lhs) * (eval val rhs)
            | ArExpr.Var v => val v
            | ArExpr.If cond then_e else_e => if eval_bool val cond then eval val then_e else eval val else_e

    theorem boolstep_preserves_eval_bool (e e': BoolExpr V):
        BoolStep V val e e' -> eval_bool V val e = eval_bool V val e'

theorem boolstepstar_preserves_eval_bool (e e': BoolExpr V):
        BoolStepStar V val e e' -> eval_bool V val e = eval_bool V val e' :=

:= by
        intro h
        induction h with
        | refl => rfl
        | trans _ _ _ h_step _ ihn =>
            rw [<- ihn]
            exact boolstep_preserves_eval_bool _ _ h_step


ArExpr

inductive ArExpr: Type
        | Const: Int -> ArExpr
        | Add: ArExpr -> ArExpr -> ArExpr
        | Sub: ArExpr -> ArExpr -> ArExpr
        | Mul: ArExpr -> ArExpr -> ArExpr
        | Var: V -> ArExpr
        | If : BoolExpr -> ArExpr -> ArExpr -> ArExpr

    inductive BoolExpr : Type
        | Const: Bool -> BoolExpr
        | Less: ArExpr -> ArExpr -> BoolExpr
        | Eq: ArExpr -> ArExpr -> BoolExpr
        | Not : BoolExpr -> BoolExpr
        | And : BoolExpr -> BoolExpr -> BoolExpr
        | Or : BoolExpr -> BoolExpr -> BoolExpr

ArStepStar

def ArStepStar (V: Type) := StepStar (Step := ArStep V) V

StepStar

inductive StepStar {ExprType: Type} {Step: StepKind V ExprType} : (val: V -> Int) -> ExprType -> ExprType -> Prop where
        | refl val e : StepStar val e e
        | trans e₁ e₂ e₃ : Step val e₁ e₂ -> StepStar val e₂ e₃ -> StepStar val e₁ e₃

    def eval (val: V -> Int) (e: ArExpr V) : Int :=
        match e with
            | ArExpr.Const x => x
            | ArExpr.Add lhs rhs => (eval val lhs) + (eval val rhs)
            | ArExpr.Sub lhs rhs => (eval val lhs) - (eval val rhs)
            | ArExpr.Mul lhs rhs => (eval val lhs) * (eval val rhs)
            | ArExpr.Var v => val v
            | ArExpr.If cond then_e else_e => if eval_bool val cond then eval val then_e else eval val else_e

    def eval_bool (val: V -> Int) (e: BoolExpr V): Bool :=
        match e with
        | BoolExpr.Const b => b
        | BoolExpr.Less l r =>  (eval val l) < (eval val r)
        | BoolExpr.Eq l r => (eval val l) == (eval val r)
        | BoolExpr.Not e => not (eval_bool val e)
        | BoolExpr.And l r => if eval_bool val l then eval_bool val r else false
        | BoolExpr.Or l r => if eval_bool val l then true else eval_bool val r

theorem arstepstar_preserves_eval (e e': ArExpr V) :
            ArStepStar V val e e' -> eval V val e = eval V val e' :=

:= by
            intro h
            induction h with
            | refl _ => rfl
            | trans _ _ _ h1 _ ih =>
                rw [arstep_preserve_eval _ _ h1, ih]


/-- Construct a `BitVec w` from a number less than `2^w`.

O(1), because we use `Fin` as the internal representation of a bitvector. -/

/-- Interpret a bitvector as a number less than `2^w`.

syntax term "==>" term : term

syntax term "==>" term : term

syntax term "~~>" term : term

syntax term "~~>*" term : term

syntax:30 term " =[ " imp " ]=> " term : term

syntax term "!->" term "; " term : term

syntax:36 term "<<->>" term : term

macro_rules
  | `(term|$t:term ==> $n:term) => `(Eval $t $n)

macro_rules
  | `(term|$t₁:term ~~> $t₂:term) => `(Step $t₁ $t₂)

example :
    p
      (p (c 1) (c 3))
      (p (c 2) (c 4))
    ~~>
    p
      (c 4)
      (p (c 2) (c 4)) := by admit /- proof elided -/

macro_rules
  | `(term|$t₁:term ~~>* $t₂:term) => `(Multi Step $t₁ $t₂)

macro_rules
  | `(term|$p <<->> $q) => `($p ->> $q ∧ $q ->> $p)

macro_rules
  | `(term|{*$p*} $c {*$q*}) => `(valid_hoare_triple $p $c $q)

macro_rules
  | `(term|$st =[ $c ]=> $st') => `(CEval <{$c}> $st $st')

macro_rules
  | `(term|$x:term !-> $a:term ; $st) => `(update $st $x $a)

example : empty =[
      x := 2;
      if (x <= 1) then y := 3 else z := 4 end
    ]=> (z !-> 4; x !-> 2; empty) := by admit /- proof elided -/

Tm

inductive Tm : Type :=
  | c : Nat → Tm
  | p : Tm → Tm → Tm

BValue

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

TM.value

theorem bool_canonical t : HasType t bool → value t → BValue t

theorem nat_canonical t : HasType t nat → value t → NValue t

import Frap.SmallStep

namespace TM

inductive Tm : Type :=
  | tru : Tm
  | fls : Tm
  | ite : Tm → Tm → Tm → Tm
  | zro : Tm
  | scc : Tm → Tm
  | prd : Tm → Tm
  | iszero : Tm → Tm

open Tm

inductive BValue : Tm → Prop :=
  | bv_true : BValue tru
  | bv_false : BValue fls

inductive NValue : Tm → Prop :=
  | nv_0 : NValue zro
  | nv_succ t : NValue t → NValue (scc t)

open BValue

open NValue

abbrev value (t : Tm) := BValue t ∨ NValue t

inductive Step : Tm → Tm → Prop :=
  | st_ifTrue t₁ t₂ : Step (ite tru t₁ t₂) t₁
  | st_ifFalse t₁ t₂ : Step (ite fls t₁ t₂) t₂
  | st_if c c' t₁ t₂ :
      Step c c' → Step (ite c t₁ t₂) (ite c' t₁ t₂)
  | st_succ t₁ t₁' : Step t₁ t₁' → Step (scc t₁) (scc t₁')
  | st_pred0 : Step (prd zro) zro
  | st_predSucc v : NValue v → Step (prd (scc v)) v
  | st_pred t₁ t₁' : Step t₁ t₁' → Step (prd t₁) (prd t₁')
  | st_iszero0 : Step (iszero zro) tru
  | st_iszeroSucc v : NValue v → Step (iszero (scc v)) fls
  | st_iszero t₁ t₁' :
      Step t₁ t₁' → Step (iszero t₁) (iszero t₁')

open Step

inductive Ty : Type :=
  | bool : Ty
  | nat : Ty

open Ty

inductive HasType : Tm → Ty → Prop :=
  | t_true : HasType tru bool
  | t_false : HasType fls bool
  | t_if t₁ t₂ t₃ T :
      HasType t₁ bool → HasType t₂ T → HasType t₃ T
      → HasType (ite t₁ t₂ t₃) T
  | t_0 : HasType zro nat
  | t_succ t₁ : HasType t₁ nat → HasType (scc t₁) nat
  | t_pred t₁ : HasType t₁ nat → HasType (prd t₁) nat
  | t_iszero t₁ : HasType t₁ nat → HasType (iszero t₁) bool

open HasType

example  -- `⊢ if false then 0 else (succ 0) ∈ nat`
    : HasType (ite fls zro (scc zro)) nat := by
  apply t_if
  . apply t_false
  . apply t_0
  . apply t_succ
    apply t_0

/-
It's important to realize that the typing relation is a _conservative_ (or _static_) approximation: it does not consider what happens when the term is reduced.
In particular, it does not calculate the type of its normal form.
-/

example  -- `⊢ if false then zero else true ∉ bool`
    : ¬ HasType (ite fls zro tru) bool := by
  intro contra
  cases contra
  rename_i contra _
  cases contra

/-
exercise (1-star)
-/
example t : HasType (scc t) nat → HasType t nat := by
  intro ht
  cases ht
  assumption

theorem progress t T
    : HasType t T → value t ∨ ∃ t', Step t t' :=

:= by
  intro ht
  induction ht with
  | t_if t₁ t₂ t₃ T =>
    rename_i ih₁ ih₂ ih₃
    right; cases ih₁
    . -- t₁ is a value
      have h : BValue t₁ := by
        apply bool_canonical <;> assumption
      cases h
      . exists t₂; apply st_ifTrue
      . exists t₃; apply st_ifFalse
    . -- t₁ can take a step
      rename_i h
      obtain ⟨t₁', h₁⟩ := h
      exists ite t₁' t₂ t₃
      apply st_if; exact h₁
  | t_true =>
    left;unfold value; left; apply bv_true
  | t_false =>
    left; unfold value; left; apply bv_false
  | t_0 =>
    left; unfold value; right; apply nv_0
  | t_succ t =>
    rename_i ih
    cases ih
    . -- t is a value
      left
      have h : NValue t := by
        apply nat_canonical <;> assumption
      cases h
      . unfold value; right; apply nv_succ; apply nv_0
      . unfold value; right; apply nv_succ; apply nv_succ; assumption
    . -- t can take a step
      right
      rename_i ih
      obtain ⟨t', h⟩ := ih
      exists (scc t')
      apply st_succ; exact h
  | t_pred t =>
    rename_i ih
    right; cases ih
    . -- t is a value
      have h : NValue t := by
        apply nat_canonical <;> assumption
      cases h
      . exists zro; apply st_pred0
      . constructor; apply st_predSucc; assumption
    . -- t can take a step
      rename_i h
      obtain ⟨t', h⟩ := h
      exists (prd t')
      apply st_pred; exact h
  | t_iszero t =>
    rename_i ih
    right; cases ih
    . -- t is a value
      have h : NValue t := by
        apply nat_canonical <;> assumption
      cases h
      . exists tru; apply st_iszero0
      . exists fls; apply st_iszeroSucc; assumption
    . -- t can take a step
      rename_i h
      obtain ⟨t', h⟩ := h
      exists (iszero t')
      apply st_iszero; exact h

/-
### Type preservation

The second critical property of typing is that, when a well-typed term takes a step, the result is a well-typed term (of the same type).
-/

/-
exercise (3-star)
Complete the following informal proof:

_Theorem_: If `⊢ t ∈ T` and `t ~~> t'`, then `⊢ t' ∈ T`.
_Proof_: By induction on a derivation of `⊢ t ∈ T`.

* If the last rule in the derivation is `t_if`, then `t = if t₁ then t₂ else t₃`, with `⊢ t₁ ∈ bool`, `⊢ t₂ ∈ T`, and `⊢ t₃ ∈ T`.
  Inspecting the rules for the small-step reduction relation and remembering that `t` is the form `if ...`, we see that the only ones that could have been used to prove `t ~~> t'` are `st_ifTrue`, `st_ifFalse`, or `st_if`.
 * If the last rule was `st_ifTrue`, then `t' = t₂`.
   But we know that `⊢ t₂ ∈ T`, so we are done.
 * If the last rule was `st_ifFalse`, then `t' = t₃`.
   But we know that `⊢ t₃ ∈ T`, so we are done.
 * If the last rule was `st_if`, then `t' = if t₁' then t₂ else t₃`, where `t₁ ~~> t₁'`.
   We know `⊢ t₁ ∈ bool`, so by the IH, `⊢ t₁' ∈ bool`.
   The `t_if` rule then gives us `⊢ if if t₁' then t₂ else t₃ ∈ T`, as required.
/- **FILL IN HERE** -/
-/


import Frap.Exercises.Equiv
import Frap.Equiv

syntax "<[" term "]>" : imp

syntax "<[" term "]>" : imp

syntax "<{" imp "}>" : term

syntax "false" : imp

syntax "false" : term

syntax:21 "if" imp:20 "then" imp:20 "else" imp:20 "end" : imp

syntax "true" : imp

syntax "true" : term

syntax "skip" : imp

syntax:21 "while" imp:20 "do" imp:20 "end" : imp

macro_rules
  | `(term|true) => `(Bool.true)
  | `(term|false) => `(Bool.false)
  | `(term|<{$x}>) => `(imp|$x)
  | `(imp|$n:num) => `(a_num $n)
  | `(imp|$s:str) => `(a_id $s)
  | `(imp|$x + $y) => `(a_plus <{$x}> <{$y}>)
  | `(imp|$x - $y) => `(a_minus <{$x}> <{$y}>)
  | `(imp|$x * $y) => `(a_mult <{$x}> <{$y}>)
  | `(imp|true) => `(b_true)
  | `(imp|false) => `(b_false)
  | `(imp|$x = $y) => `(b_eq <{$x}> <{$y}>)
  | `(imp|$x != $y) => `(b_neq <{$x}> <{$y}>)
  | `(imp|$x <= $y) => `(b_le <{$x}> <{$y}>)
  | `(imp|!$x) => `(b_not <{$x}>)
  | `(imp|$x && $y) => `(b_and <{$x}> <{$y}>)
  | `(imp|$x || $y) => `(b_or <{$x}> <{$y}>)
  | `(imp|($x)) => `(<{$x}>)
  | `(imp|$x:ident) => `(a_id $(Lean.quote (toString x.getId)))
  | `(imp|<[$t:term]>) => pure t

macro_rules
  | `(imp|skip) => `(c_skip)
  | `(imp|$x:str := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$x:ident := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$c1 ; $c2) => `(c_seq <{$c1}> <{$c2}>)
  | `(imp|if $b then $c1 else $c2 end) => `(c_if <{$b}> <{$c1}> <{$c2}>)
  | `(imp|while $b do $c end) => `(c_while <{$b}> <{$c}>)

cequiv

def cequiv (c₁ c₂ : Com) : Prop :=
  ∀ st st' : State, (st =[<[c₁]>]=> st') ↔ (st =[<[c₂]>]=> st')

State

abbrev State := String → Nat

Com

inductive Com :=
  | c_skip : Com
  | c_asgn : String → AExp → Com
  | c_seq : Com → Com → Com
  | c_if : BExp → Com → Com → Com
  | c_while : BExp → Com → Com

AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_id : String → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

Com

inductive Com : Type :=
  | c_skip : Com
  | c_asgn : String → AExp → Com
  | c_seq : Com → Com → Com
  | c_if : BExp → Com → Com → Com
  | c_while : BExp → Com → Com
  | c_par : Com → Com → Com

BExp

inductive BExp where
  | b_true : BExp
  | b_false : BExp
  | b_eq : AExp → AExp → BExp
  | b_neq : AExp → AExp → BExp
  | b_le : AExp → AExp → BExp
  | b_not : BExp → BExp
  | b_and : BExp → BExp → BExp
  | b_or : BExp → BExp → BExp

x

abbrev x := "x"

y

abbrev y := "y"

loop

def loop : Com :=
  <{ while true do
       skip
     end }>

bequiv

def bequiv (b₁ b₂ : BExp) : Prop :=
  ∀ (st : State), beval st b₁ = beval st b₂

beval

def beval (st : State) (b : BExp) : Bool :=
  match b with
  | b_true => true
  | b_false => false
  | b_eq a₁ a₂ => (aeval st a₁) == (aeval st a₂)
  | b_neq a₁ a₂ => (aeval st a₁) != (aeval st a₂)
  | b_le a₁ a₂ => (aeval st a₁) <= (aeval st a₂)
  | b_not b₁ => not (beval st b₁)
  | b_and b₁ b₂ => and (beval st b₁) (beval st b₂)
  | b_or b₁ b₂ => or (beval st b₁) (beval st b₂)

example : aeval (update empty x 5)
    <{3 + x * 2}>

    = 13 := by admit /- proof elided -/

empty

def empty : State := fun _ => 0

z

abbrev z := "z"

aeval

def aeval (st : State) (a : AExp) : Nat :=
  match a with
  | a_num n => n
  | a_id x => st x
  | a_plus a₁ a₂ => (aeval st a₁) + (aeval st a₂)
  | a_minus a₁ a₂ => (aeval st a₁) - (aeval st a₂)
  | a_mult a₁ a₂ => (aeval st a₁) * (aeval st a₂)

update

def update (st : State) (k : String) (v : Nat) : State :=
  fun x => if x == k then v else st x

aequiv

def aequiv (a₁ a₂ : AExp) : Prop :=
  ∀ (st : State), aeval st a₁ = aeval st a₂

CEval

inductive CEval : Com → State → State → Prop :=
  | e_skip : ∀ st,
      CEval c_skip st st
  | e_asgn : ∀ a n x st,
      aeval st a = n
      → CEval (c_asgn x a) st (update st x n)
  | e_seq : ∀ c₁ c₂ st st' st'',
      CEval c₁ st st' → CEval c₂ st' st''
      → CEval (c_seq c₁ c₂) st st''
  | e_ifTrue : ∀ b c₁ c₂ st st',
      beval st b = true → CEval c₁ st st'
      → CEval (c_if b c₁ c₂) st st'
  | e_ifFalse : ∀ b c₁ c₂ st st',
      beval st b = false → CEval c₂ st st'
      → CEval (c_if b c₁ c₂) st st'
  | e_whileFalse : ∀ b c st,
      beval st b = false
      → CEval (c_while b c) st st
  | e_whileTrue : ∀ b c st st' st'',
      beval st b = true
      → CEval c st st'
      → CEval (c_while b c) st' st''
      → CEval (c_while b c) st st''

theorem if_true b c₁ c₂
    : bequiv b <{true}> → cequiv <{if <[b]> then <[c₁]> else <[c₂]> end}> c₁

theorem if_false b c₁ c₂
    : bequiv b <{false}> → cequiv <{if <[b]> then <[c₁]> else <[c₂]> end}> c₂

theorem while_false b c : bequiv b <{false}> →
    cequiv <{while <[b]> do <[c]> end}> <{skip}>

theorem while_true b c :
    bequiv b <{true}> → cequiv <{while <[b]> do <[c]> end}> loop

theorem sym_bequiv b₁ b₂ : bequiv b₁ b₂ → bequiv b₂ b₁

theorem sym_cequiv c₁ c₂ : cequiv c₁ c₂ → cequiv c₂ c₁

theorem trans_cequiv c₁ c₂ c₃ : cequiv c₁ c₂ → cequiv c₂ c₃ → cequiv c₁ c₃

theorem c_asgn_congruence x a a'
    : aequiv a a' → cequiv <{x := <[a]>}> <{x := <[a']>}>

theorem c_while_congruence b b' c c'
    : bequiv b b' → cequiv c c'
      → cequiv <{while <[b]> do <[c]> end}> <{while <[b']> do <[c']> end}>

theorem c_seq_congruence c₁ c₁' c₂ c₂'
    : cequiv c₁ c₁' → cequiv c₂ c₂' → cequiv (c_seq c₁ c₂) (c_seq c₁' c₂')

theorem c_if_congruence b b' c₁ c₁' c₂ c₂'
    : bequiv b b' → cequiv c₁ c₁' → cequiv c₂ c₂'
      → cequiv (c_if b c₁ c₂) (c_if b' c₁' c₂')

theorem fold_constants_aexp_sound : atrans_sound fold_constants_aexp

theorem fold_constants_bexp_sound : btrans_sound fold_constants_bexp

import Frap.Equiv

import Frap.Exercises.Equiv

namespace Imp

open AExp

open BExp

open Com

open CEval

def atrans_sound (atrans : AExp → AExp) :=
  ∀ (a : AExp), aequiv a (atrans a)

def btrans_sound (btrans : BExp → BExp) :=
  ∀ (b : BExp), bequiv b (btrans b)

def ctrans_sound (ctrans : Com → Com) :=
  ∀ (c : Com), cequiv c (ctrans c)

def fold_constants_aexp (a : AExp) : AExp :=
  match a with
  | a_num _
  | a_id _
    => a
  | a_plus a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (a_num n1, a_num n2) => a_num (n1 + n2)
    | (a1', a2') => a_plus a1' a2'
  | a_minus a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (a_num n1, a_num n2) => a_num (n1 - n2)
    | (a1', a2') => a_minus a1' a2'
  | a_mult a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (a_num n1, a_num n2) => a_num (n1 * n2)
    | (a1', a2') => a_mult a1' a2'

example : fold_constants_aexp <{(1 + 2) * x}> = <{3 * x}> := by admit /- proof elided -/

def fold_constants_bexp (b : BExp) : BExp :=
  match b with
  | b_true
  | b_false
    => b
  | b_eq a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (a_num n1, a_num n2) => if n1 == n2 then b_true else b_false
    | (a1', a2') => b_eq a1' a2'
  | b_neq a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (a_num n1, a_num n2) => if n1 != n2 then b_true else b_false
    | (a1', a2') => b_neq a1' a2'
  | b_le a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (a_num n1, a_num n2) => if n1 <= n2 then b_true else b_false
    | (a1', a2') => b_le a1' a2'
  | b_not b1 =>
    match fold_constants_bexp b1 with
    | b_true => b_false
    | b_false => b_true
    | b1' => b_not b1'
  | b_and b1 b2 =>
    match (fold_constants_bexp b1, fold_constants_bexp b2) with
    | (b_true, b_true) => b_true
    | (b_true, b_false) => b_false
    | (b_false, b_true) => b_false
    | (b_false, b_false) => b_false
    | (b1', b2') => b_and b1' b2'
  | b_or b1 b2 =>
    match (fold_constants_bexp b1, fold_constants_bexp b2) with
    | (b_true, b_true) => b_true
    | (b_true, b_false) => b_true
    | (b_false, b_true) => b_true
    | (b_false, b_false) => b_false
    | (b1', b2') => b_or b1' b2'

example : fold_constants_bexp <{true && !(false && true)}> = <{true}> := by admit /- proof elided -/

def fold_constants_com (c : Com) : Com :=
  match c with
  | c_skip => c
  | c_asgn x a => c_asgn x (fold_constants_aexp a)
  | c_seq c1 c2 => c_seq (fold_constants_com c1) (fold_constants_com c2)
  | c_if b c1 c2 =>
    match fold_constants_bexp b with
    | b_true => fold_constants_com c1
    | b_false => fold_constants_com c2
    | b' => c_if b' (fold_constants_com c1) (fold_constants_com c2)
  | c_while b c1 =>
    match fold_constants_bexp b with
    | b_true => loop
    | b_false => c_skip
    | b' => c_while b' (fold_constants_com c1)

example : fold_constants_com

    <{ x := 4 + 5;
       y := x - 3;
       if (x - y) = (2 + 4) then skip
       else y := 0 end;
       if 0 <= (4 - (2 + 1)) then y := 0
       else skip end;
       while y = 0 do
         x := x + 1
       end }>
    =
    <{ x := 9;
       y := x - 3;
       if (x - y) = 6 then skip
       else y := 0 end;
       y := 0;
       while y = 0 do
         x := x + 1
       end }> := by admit /- proof elided -/

theorem fold_constants_com_sound : ctrans_sound fold_constants_com :=

:= by
  intro c; induction c with simp [fold_constants_com]
  | c_asgn =>
    apply c_asgn_congruence
    apply fold_constants_aexp_sound
  | c_seq =>
    apply c_seq_congruence <;> assumption
  | c_if b c₁ c₂ ih1 ih2 =>
    split
    . apply trans_cequiv _ c₁
      . apply if_true
        rename_i heq; rw [← heq]
        apply fold_constants_bexp_sound
      . assumption
    . apply trans_cequiv _ c₂
      . apply if_false
        rename_i heq; rw [← heq]
        apply fold_constants_bexp_sound
      . assumption
    . apply c_if_congruence
      . apply fold_constants_bexp_sound
      . assumption
      . assumption
  | c_while b c' ih =>
    split
    . apply while_true
      rename_i heq; rw [← heq]
      apply fold_constants_bexp_sound
    . apply while_false
      rename_i heq; rw [← heq]
      apply fold_constants_bexp_sound
    . apply c_while_congruence
      . apply fold_constants_bexp_sound
      . assumption


syntax:21 "if" imp:20 "then" imp:20 "else" imp:20 "end" : imp

macro_rules
  | `(term|true) => `(Bool.true)
  | `(term|false) => `(Bool.false)
  | `(term|<{$x}>) => `(imp|$x)
  | `(imp|$n:num) => `(a_num $n)
  | `(imp|$s:str) => `(a_id $s)
  | `(imp|$x + $y) => `(a_plus <{$x}> <{$y}>)
  | `(imp|$x - $y) => `(a_minus <{$x}> <{$y}>)
  | `(imp|$x * $y) => `(a_mult <{$x}> <{$y}>)
  | `(imp|true) => `(b_true)
  | `(imp|false) => `(b_false)
  | `(imp|$x = $y) => `(b_eq <{$x}> <{$y}>)
  | `(imp|$x != $y) => `(b_neq <{$x}> <{$y}>)
  | `(imp|$x <= $y) => `(b_le <{$x}> <{$y}>)
  | `(imp|!$x) => `(b_not <{$x}>)
  | `(imp|$x && $y) => `(b_and <{$x}> <{$y}>)
  | `(imp|$x || $y) => `(b_or <{$x}> <{$y}>)
  | `(imp|($x)) => `(<{$x}>)
  | `(imp|$x:ident) => `(a_id $(Lean.quote (toString x.getId)))
  | `(imp|<[$t:term]>) => pure t

macro_rules
  | `(imp|skip) => `(c_skip)
  | `(imp|$x:str := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$x:ident := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$c1 ; $c2) => `(c_seq <{$c1}> <{$c2}>)
  | `(imp|if $b then $c1 else $c2 end) => `(c_if <{$b}> <{$c1}> <{$c2}>)
  | `(imp|while $b do $c end) => `(c_while <{$b}> <{$c}>)

AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_id : String → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

State

abbrev State := String → Nat

BExp

inductive BExp where
  | b_true : BExp
  | b_false : BExp
  | b_eq : AExp → AExp → BExp
  | b_neq : AExp → AExp → BExp
  | b_le : AExp → AExp → BExp
  | b_not : BExp → BExp
  | b_and : BExp → BExp → BExp
  | b_or : BExp → BExp → BExp

x

abbrev x := "x"

Com

inductive Com :=
  | c_skip : Com
  | c_asgn : String → AExp → Com
  | c_seq : Com → Com → Com
  | c_if : BExp → Com → Com → Com
  | c_while : BExp → Com → Com

empty

def empty : State := fun _ => 0

Multi

inductive Multi {X : Type} (R : relation X) : relation X :=
  | multi_refl x : Multi R x x
  | multi_step x y z : R x y → Multi R y z → Multi R x z

relation

def relation (X : Type) := X → X → Prop

update

def update (st : State) (k : String) (v : Nat) : State :=
  fun x => if x == k then v else st x

y

abbrev y := "y"

And

inductive And : Prop → Prop → Prop where
  | intro : a → b → And a b

theorem multi_R (X : Type) (R : relation X) x y : R x y → Multi R x y

theorem multi_trans (X : Type) (R : relation X) x y z
    : Multi R x y → Multi R y z → Multi R x z

CImp.CStep

theorem par_body_n__Sn n st
    : st x = n ∧ st y = 0
      → Multi CStep (par_loop, st) (par_loop, x !-> n + 1; st)

theorem par_body_n n st
    : st x = 0 ∧ st y = 0
      → ∃ st', Multi CStep (par_loop, st) (par_loop, st')
          ∧ st' x = n ∧ st' y = 0

import Frap.Equiv

import Frap.SmallStep

open Imp

open AExp

open BExp

open Com

open Multi

inductive AVal : AExp → Prop :=
  | av_num : ∀ n, AVal (a_num n)

inductive AStep (st : State) : AExp → AExp → Prop :=
  | as_id : ∀ v, AStep st (a_id v) (a_num (st v))
  | as_plus1 : ∀ a₁ a₁' a₂,
      AStep st a₁ a₁'
      → AStep st (a_plus a₁ a₂) (a_plus a₁' a₂)
  | as_plus2 : ∀ v₁ a₂ a₂',
      AVal v₁ → AStep st a₂ a₂'
      → AStep st (a_plus v₁ a₂) (a_plus v₁ a₂')
  | as_plus : ∀ (v₁ v₂ : Nat),
      AStep st (a_plus (a_num v₁) (a_num v₂)) (a_num (v₁ + v₂))
  | as_minus1 : ∀ a₁ a₁' a₂,
      AStep st a₁ a₁'
      → AStep st (a_minus a₁ a₂) (a_minus a₁' a₂)
  | as_minus2 : ∀ v₁ a₂ a₂',
      AVal v₁ → AStep st a₂ a₂'
      → AStep st (a_minus v₁ a₂) (a_minus v₁ a₂')
  | as_minus : ∀ (v₁ v₂ : Nat),
      AStep st (a_minus (a_num v₁) (a_num v₂)) (a_num (v₁ - v₂))
  | as_mult1 : ∀ a₁ a₁' a₂,
      AStep st a₁ a₁'
      → AStep st (a_mult a₁ a₂) (a_mult a₁' a₂)
  | as_mult2 : ∀ v₁ a₂ a₂',
      AVal v₁ → AStep st a₂ a₂'
      → AStep st (a_mult v₁ a₂) (a_mult v₁ a₂')
  | as_mult : ∀ (v₁ v₂ : Nat),
      AStep st (a_mult (a_num v₁) (a_num v₂)) (a_num (v₁ * v₂))

open AStep

inductive BStep (st : State) : BExp → BExp → Prop :=
  | bs_eq1 : ∀ a₁ a₁' a₂,
      AStep st a₁ a₁'
      → BStep st (b_eq a₁ a₂) (b_eq a₁' a₂)
  | bs_eq2 : ∀ v₁ a₂ a₂',
      AVal v₁ → AStep st a₂ a₂'
      → BStep st (b_eq v₁ a₂) (b_eq v₁ a₂')
  | bs_eq : ∀ (v₁ v₂ : Nat),
      BStep st (b_eq (a_num v₁) (a_num v₂))
          (if v₁ == v₂ then b_true else b_false)
  | bs_neq1 : ∀ a₁ a₁' a₂,
      AStep st a₁ a₁'
      → BStep st (b_neq a₁ a₂) (b_neq a₁' a₂)
  | bs_neq2 : ∀ v₁ a₂ a₂',
      AVal v₁ → AStep st a₂ a₂'
      → BStep st (b_neq v₁ a₂) (b_neq v₁ a₂')
  | bs_neq : ∀ (v₁ v₂ : Nat),
      BStep st (b_neq (a_num v₁) (a_num v₂))
          (if v₁ != v₂ then b_true else b_false)
  | bs_le1 : ∀ a₁ a₁' a₂,
      AStep st a₁ a₁'
      → BStep st (b_le a₁ a₂) (b_le a₁' a₂)
  | bs_le2 : ∀ v₁ a₂ a₂',
      AVal v₁ → AStep st a₂ a₂'
      → BStep st (b_le v₁ a₂) (b_le v₁ a₂')
  | bs_le : ∀ (v₁ v₂ : Nat),
      BStep st (b_le (a_num v₁) (a_num v₂))
          (if v₁ <= v₂ then b_true else b_false)
  | bs_notStep : ∀ b₁ b₁',
      BStep st b₁ b₁'
      → BStep st (b_not b₁) (b_not b₁')
  | bs_notTrue : BStep st (b_not b_true) b_false
  | bs_notFalse : BStep st (b_not b_false) b_true
  | bs_andStep : ∀ b₁ b₁' b₂,
      BStep st b₁ b₁'
      → BStep st (b_and b₁ b₂) (b_and b₁' b₂)
  | bs_andFalse : ∀ b₂,
      BStep st (b_and b_false b₂) b_false
  | bs_andTrueStep : ∀ b₂ b₂',
      BStep st b₂ b₂'
      → BStep st (b_and b_true b₂) (b_and b_true b₂')
  | bs_andTrueTrue :
      BStep st (b_and b_true b_true) b_true
  | bs_andTrueFalse :
      BStep st (b_and b_true b_false) b_false
  | bs_orStep : ∀ b₁ b₁' b₂,
      BStep st b₁ b₁'
      → BStep st (b_or b₁ b₂) (b_or b₁' b₂)
  | bs_orTrue : ∀ b₂,
      BStep st (b_or b_true b₂) b_true
  | bs_orFalseStep : ∀ b₂ b₂',
      BStep st b₂ b₂'
      → BStep st (b_or b_false b₂) (b_or b_false b₂')
  | bs_orFalseTrue :
      BStep st (b_or b_false b_true) b_true
  | bs_orFalseFalse :
      BStep st (b_or b_false b_false) b_false

open BStep

inductive CStep : (Com × State) → (Com × State) → Prop :=
  | cs_asgnStep : ∀ st v a₁ a₁',
      AStep st a₁ a₁'
      → CStep (c_asgn v a₁, st) (c_asgn v a₁', st)
  | cs_asgn : ∀ st v (n : Nat),
      CStep (c_asgn v (a_num n), st) (c_skip, x !-> n; st)
  | cs_seqStep : ∀ st c₁ c₁' st' c₂,
      CStep (c₁, st) (c₁', st')
      → CStep (c_seq c₁ c₂, st) (c_seq c₁' c₂, st')
  | cs_seqFinish : ∀ st c₂,
      CStep (c_seq c_skip c₂, st) (c₂, st)
  | cs_ifStep : ∀ st b₁ b₁' c₁ c₂,
      BStep st b₁ b₁'
      → CStep (c_if b₁ c₁ c₂, st) (c_if b₁' c₁ c₂, st)
  | cs_ifTrue : ∀ st c₁ c₂,
      CStep (c_if b_true c₁ c₂, st) (c₁, st)
  | cs_ifFalse : ∀ st c₁ c₂,
      CStep (c_if b_false c₁ c₂, st) (c₂, st)
  | cs_while : ∀ st b₁ c₁,
      CStep (c_while b₁ c₁, st)
        (c_if b₁ (c_seq c₁ (c_while b₁ c₁)) c_skip, st)

namespace CImp

inductive Com : Type :=
  | c_skip : Com
  | c_asgn : String → AExp → Com
  | c_seq : Com → Com → Com
  | c_if : BExp → Com → Com → Com
  | c_while : BExp → Com → Com
  | c_par : Com → Com → Com

open Com

inductive CStep : (Com × State) → (Com × State) → Prop :=

  | cs_asgnStep : ∀ st v a₁ a₁',
      AStep st a₁ a₁'
      → CStep (c_asgn v a₁, st) (c_asgn v a₁', st)
  | cs_asgn : ∀ st v (n : Nat),
      CStep (c_asgn v (a_num n), st) (c_skip, v !-> n; st)
  | cs_seqStep : ∀ st c₁ c₁' st' c₂,
      CStep (c₁, st) (c₁', st')
      → CStep (c_seq c₁ c₂, st) (c_seq c₁' c₂, st')
  | cs_seqFinish : ∀ st c₂,
      CStep (c_seq c_skip c₂, st) (c₂, st)
  | cs_ifStep : ∀ st b₁ b₁' c₁ c₂,
      BStep st b₁ b₁'
      → CStep (c_if b₁ c₁ c₂, st) (c_if b₁' c₁ c₂, st)
  | cs_ifTrue : ∀ st c₁ c₂,
      CStep (c_if b_true c₁ c₂, st) (c₁, st)
  | cs_ifFalse : ∀ st c₁ c₂,
      CStep (c_if b_false c₁ c₂, st) (c₂, st)
  | cs_while : ∀ st b₁ c₁,
      CStep (c_while b₁ c₁, st)
        (c_if b₁ (c_seq c₁ (c_while b₁ c₁)) c_skip, st)

  | cs_par1 : ∀ st c₁ c₁' c₂ st',
      CStep (c₁, st) (c₁', st')
      → CStep (c_par c₁ c₂, st) (c_par c₁' c₂, st')
  | cs_par2 : ∀ st c₁ c₂ c₂' st',
      CStep (c₂, st) (c₂', st')
      → CStep (c_par c₁ c₂, st) (c_par c₁ c₂', st')
  | cs_parDone : ∀ st,
      CStep (c_par c_skip c_skip, st) (c_skip, st)

open CStep

def par_loop : Com :=
  c_par
    (c_asgn y (a_num 1))
    (c_while (b_eq (a_id y) (a_num 0))
      (c_asgn x (a_plus (a_id x) (a_num 1))))

/-
In particular, it can terminate with `x` set to `0`.
-/

example : ∃ st',
    Multi CStep (par_loop, empty) (c_skip, st')
    ∧ st' x = 0 :=

theorem par_loop_any_x n
    : ∃ st', Multi CStep (par_loop, empty) (c_skip, st')
        ∧ st' x = n :=

:= by
  let h := par_body_n n empty
  simp [empty] at h
  obtain ⟨st', ⟨h', ⟨hx, _⟩⟩⟩ := h
  exists y !-> 1; st'
  constructor
  . apply multi_trans
    . apply h'
    . apply multi_step
      . apply cs_par1; apply cs_asgn
      . apply multi_step
        . apply cs_par2; apply cs_while
        . apply multi_step
          . apply cs_par2; apply cs_ifStep
            apply bs_eq1; apply as_id
          . apply multi_step
            . apply cs_par2; apply cs_ifStep
              apply bs_eq
            . simp [update]; apply multi_step
              . apply cs_par2; apply cs_ifFalse
              . apply multi_R
                apply cs_parDone
  . simp [update]; assumption


syntax "<{" imp "}>" : term

syntax "<{" imp "}>" : term

syntax "false" : imp

syntax "false" : term

syntax:21 "if" imp:20 "then" imp:20 "else" imp:20 "end" : imp

syntax "true" : imp

syntax "true" : term

macro_rules
  | `(term|true) => `(Bool.true)
  | `(term|false) => `(Bool.false)
  | `(term|<{$x}>) => `(imp|$x)
  | `(imp|$n:num) => `(a_num $n)
  | `(imp|$s:str) => `(a_id $s)
  | `(imp|$x + $y) => `(a_plus <{$x}> <{$y}>)
  | `(imp|$x - $y) => `(a_minus <{$x}> <{$y}>)
  | `(imp|$x * $y) => `(a_mult <{$x}> <{$y}>)
  | `(imp|true) => `(b_true)
  | `(imp|false) => `(b_false)
  | `(imp|$x = $y) => `(b_eq <{$x}> <{$y}>)
  | `(imp|$x != $y) => `(b_neq <{$x}> <{$y}>)
  | `(imp|$x <= $y) => `(b_le <{$x}> <{$y}>)
  | `(imp|!$x) => `(b_not <{$x}>)
  | `(imp|$x && $y) => `(b_and <{$x}> <{$y}>)
  | `(imp|$x || $y) => `(b_or <{$x}> <{$y}>)
  | `(imp|($x)) => `(<{$x}>)
  | `(imp|$x:ident) => `(a_id $(Lean.quote (toString x.getId)))
  | `(imp|<[$t:term]>) => pure t

macro_rules
  | `(imp|skip) => `(c_skip)
  | `(imp|$x:str := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$x:ident := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$c1 ; $c2) => `(c_seq <{$c1}> <{$c2}>)
  | `(imp|if $b then $c1 else $c2 end) => `(c_if <{$b}> <{$c1}> <{$c2}>)
  | `(imp|while $b do $c end) => `(c_while <{$b}> <{$c}>)

AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_id : String → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

x

abbrev x := "x"

y

abbrev y := "y"

BExp

inductive BExp where
  | b_true : BExp
  | b_false : BExp
  | b_eq : AExp → AExp → BExp
  | b_neq : AExp → AExp → BExp
  | b_le : AExp → AExp → BExp
  | b_not : BExp → BExp
  | b_and : BExp → BExp → BExp
  | b_or : BExp → BExp → BExp

bequiv

def bequiv (b₁ b₂ : BExp) : Prop :=
  ∀ (st : State), beval st b₁ = beval st b₂

beval

def beval (st : State) (b : BExp) : Bool :=
  match b with
  | b_true => true
  | b_false => false
  | b_eq a₁ a₂ => (aeval st a₁) == (aeval st a₂)
  | b_neq a₁ a₂ => (aeval st a₁) != (aeval st a₂)
  | b_le a₁ a₂ => (aeval st a₁) <= (aeval st a₂)
  | b_not b₁ => not (beval st b₁)
  | b_and b₁ b₂ => and (beval st b₁) (beval st b₂)
  | b_or b₁ b₂ => or (beval st b₁) (beval st b₂)

example : aeval (update empty x 5)
    <{3 + x * 2}>

    = 13 := by admit /- proof elided -/

empty

def empty : State := fun _ => 0

State

abbrev State := String → Nat

z

abbrev z := "z"

aeval

def aeval (st : State) (a : AExp) : Nat :=
  match a with
  | a_num n => n
  | a_id x => st x
  | a_plus a₁ a₂ => (aeval st a₁) + (aeval st a₂)
  | a_minus a₁ a₂ => (aeval st a₁) - (aeval st a₂)
  | a_mult a₁ a₂ => (aeval st a₁) * (aeval st a₂)

update

def update (st : State) (k : String) (v : Nat) : State :=
  fun x => if x == k then v else st x

aequiv

def aequiv (a₁ a₂ : AExp) : Prop :=
  ∀ (st : State), aeval st a₁ = aeval st a₂

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

theorem fold_constants_aexp_sound : atrans_sound fold_constants_aexp

import Frap.Equiv

import Frap.Exercises.Equiv

namespace Imp

open AExp

open BExp

open Com

open CEval

def atrans_sound (atrans : AExp → AExp) :=
  ∀ (a : AExp), aequiv a (atrans a)

def btrans_sound (btrans : BExp → BExp) :=
  ∀ (b : BExp), bequiv b (btrans b)

def fold_constants_aexp (a : AExp) : AExp :=
  match a with
  | a_num _
  | a_id _
    => a
  | a_plus a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (a_num n1, a_num n2) => a_num (n1 + n2)
    | (a1', a2') => a_plus a1' a2'
  | a_minus a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (a_num n1, a_num n2) => a_num (n1 - n2)
    | (a1', a2') => a_minus a1' a2'
  | a_mult a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (a_num n1, a_num n2) => a_num (n1 * n2)
    | (a1', a2') => a_mult a1' a2'

example : fold_constants_aexp <{(1 + 2) * x}> = <{3 * x}> := by admit /- proof elided -/

def fold_constants_bexp (b : BExp) : BExp :=
  match b with
  | b_true
  | b_false
    => b
  | b_eq a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (a_num n1, a_num n2) => if n1 == n2 then b_true else b_false
    | (a1', a2') => b_eq a1' a2'
  | b_neq a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (a_num n1, a_num n2) => if n1 != n2 then b_true else b_false
    | (a1', a2') => b_neq a1' a2'
  | b_le a1 a2 =>
    match (fold_constants_aexp a1, fold_constants_aexp a2) with
    | (a_num n1, a_num n2) => if n1 <= n2 then b_true else b_false
    | (a1', a2') => b_le a1' a2'
  | b_not b1 =>
    match fold_constants_bexp b1 with
    | b_true => b_false
    | b_false => b_true
    | b1' => b_not b1'
  | b_and b1 b2 =>
    match (fold_constants_bexp b1, fold_constants_bexp b2) with
    | (b_true, b_true) => b_true
    | (b_true, b_false) => b_false
    | (b_false, b_true) => b_false
    | (b_false, b_false) => b_false
    | (b1', b2') => b_and b1' b2'
  | b_or b1 b2 =>
    match (fold_constants_bexp b1, fold_constants_bexp b2) with
    | (b_true, b_true) => b_true
    | (b_true, b_false) => b_true
    | (b_false, b_true) => b_true
    | (b_false, b_false) => b_false
    | (b1', b2') => b_or b1' b2'

example : fold_constants_bexp <{true && !(false && true)}> = <{true}> := by admit /- proof elided -/

theorem fold_constants_bexp_sound : btrans_sound fold_constants_bexp :=

:= by
  intro b st; induction b with simp [fold_constants_bexp]
  | b_eq a1 a2 =>
    rw [fold_constants_aexp_sound a1, fold_constants_aexp_sound a2]
    split
    . rename_i hm
      simp at hm
      obtain ⟨⟩ := hm
      split <;> simp [*]
    . rename_i hm
      simp at hm
      obtain ⟨⟩ := hm
      simp [*]
  | b_neq a1 a2 =>
    rw [fold_constants_aexp_sound a1, fold_constants_aexp_sound a2]
    split
    . rename_i hm
      simp at hm
      obtain ⟨⟩ := hm
      split <;> simp [*]
    . rename_i hm
      simp at hm
      obtain ⟨⟩ := hm
      simp [*]
  | b_le a1 a2 =>
    rw [fold_constants_aexp_sound a1, fold_constants_aexp_sound a2]
    split
    . rename_i hm
      simp at hm
      obtain ⟨⟩ := hm
      split <;> simp [*]
    . rename_i hm
      simp at hm
      obtain ⟨⟩ := hm
      simp [*]
  | b_not =>
    split <;> simp [*]
  | b_and =>
    simp [*]
    split <;> (
      rename_i hm
      simp at hm
      obtain ⟨⟩ := hm
      simp [*]
    )
  | b_or =>
    simp [*]
    split <;> (
      rename_i hm
      simp at hm
      obtain ⟨⟩ := hm
      simp [*]
    )


relation

def relation (X : Type) := X → X → Prop

normalizing

theorem strong_progress t : Value t ∨ ∃t', Step t t'

theorem value_is_nf v : Value v → normal_form Step v

theorem nf_is_value t : normal_form Step t → Value t

theorem nf_same_as_value t : normal_form Step t ↔ Value t

theorem multi_R (X : Type) (R : relation X) x y : R x y → Multi R x y

theorem multi_trans (X : Type) (R : relation X) x y z
    : Multi R x y → Multi R y z → Multi R x z

theorem multistep_congr_1 t₁ t₁' t₂
    : (t₁ ~~>* t₁') → (p t₁ t₂ ~~>* p t₁' t₂)

theorem multistep_congr_2 v₁ t₂ t₂'
    : (t₂ ~~>* t₂') → (p v₁ t₂ ~~>* p v₁ t₂')

inductive Tm : Type :=
  | c : Nat → Tm
  | p : Tm → Tm → Tm

open Tm

open Eval

namespace SimpleArith1

inductive Step : Tm → Tm → Prop :=
  | st_plusConstConst n₁ n₂ : Step (p (c n₁) (c n₂)) (c (n₁ + n₂))
  | st_plus1 t₁ t₁' t₂ : Step t₁ t₁' → Step (p t₁ t₂) (p t₁' t₂)
  | st_plus2 n₁ t₂ t₂' : Step t₂ t₂' → Step (p (c n₁) t₂) (p (c n₁) t₂')

open Step

end SimpleArith1

def relation (X : Type) := X → X → Prop

namespace SimpleArith2

open SimpleArith1

end SimpleArith2

inductive Value : Tm → Prop :=
  | v_const n : Value (c n)

open Value

inductive Step : Tm → Tm → Prop :=
  | st_plusConstConst n₁ n₂ : Step (p (c n₁) (c n₂)) (c (n₁ + n₂))
  | st_plus1 t₁ t₁' t₂ : Step t₁ t₁' → Step (p t₁ t₂) (p t₁' t₂)
  | st_plus2 v₁ t₂ t₂' : Value v₁ → Step t₂ t₂' → Step (p v₁ t₂) (p v₁ t₂')

open Step

def normal_form {X : Type} (R : relation X) (t : X) : Prop := ¬∃t', R t t'

inductive Multi {X : Type} (R : relation X) : relation X :=
  | multi_refl x : Multi R x x
  | multi_step x y z : R x y → Multi R y z → Multi R x z

open Multi

def normalizing {X : Type} (R : relation X) :=
  ∀t, ∃t', (Multi R) t t' ∧ normal_form R t'

theorem step_normalizing : normalizing Step :=

:= by
  unfold normalizing
  intro t
  induction t with
  | c n =>
    exists c n
    constructor
    . apply multi_refl
    . rw [nf_same_as_value]; apply v_const
  | p t₁ t₂ ih₁ ih₂ =>
    obtain ⟨t₁', ⟨hs₁, hn₁⟩⟩ := ih₁
    obtain ⟨t₂', ⟨hs₂, hn₂⟩⟩ := ih₂
    rw [nf_same_as_value] at hn₁
    rw [nf_same_as_value] at hn₂
    cases hn₁; cases hn₂
    rename_i n₁ n₂
    exists c (n₁ + n₂)
    constructor
    . apply multi_trans
      . apply multistep_congr_1
        apply hs₁
      . apply multi_trans
        . apply multistep_congr_2
          apply hs₂
        . apply multi_R
          apply st_plusConstConst
    . rw [nf_same_as_value]; apply v_const


syntax "<{" imp "}>" : term

syntax "<{" imp "}>" : term

syntax:21 "while" imp:20 "do" imp:20 "end" : imp

syntax "<[" term "]>" : imp

syntax:21 "if" imp:20 "then" imp:20 "else" imp:20 "end" : imp

syntax "false" : imp

syntax "false" : term

syntax "true" : imp

syntax "true" : term

macro_rules
  | `(term|true) => `(Bool.true)
  | `(term|false) => `(Bool.false)
  | `(term|<{$x}>) => `(imp|$x)
  | `(imp|$n:num) => `(a_num $n)
  | `(imp|$s:str) => `(a_id $s)
  | `(imp|$x + $y) => `(a_plus <{$x}> <{$y}>)
  | `(imp|$x - $y) => `(a_minus <{$x}> <{$y}>)
  | `(imp|$x * $y) => `(a_mult <{$x}> <{$y}>)
  | `(imp|true) => `(b_true)
  | `(imp|false) => `(b_false)
  | `(imp|$x = $y) => `(b_eq <{$x}> <{$y}>)
  | `(imp|$x != $y) => `(b_neq <{$x}> <{$y}>)
  | `(imp|$x <= $y) => `(b_le <{$x}> <{$y}>)
  | `(imp|!$x) => `(b_not <{$x}>)
  | `(imp|$x && $y) => `(b_and <{$x}> <{$y}>)
  | `(imp|$x || $y) => `(b_or <{$x}> <{$y}>)
  | `(imp|($x)) => `(<{$x}>)
  | `(imp|$x:ident) => `(a_id $(Lean.quote (toString x.getId)))
  | `(imp|<[$t:term]>) => pure t

macro_rules
  | `(imp|skip) => `(c_skip)
  | `(imp|$x:str := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$x:ident := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$c1 ; $c2) => `(c_seq <{$c1}> <{$c2}>)
  | `(imp|if $b then $c1 else $c2 end) => `(c_if <{$b}> <{$c1}> <{$c2}>)
  | `(imp|while $b do $c end) => `(c_while <{$b}> <{$c}>)

AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_id : String → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

BExp

inductive BExp where
  | b_true : BExp
  | b_false : BExp
  | b_eq : AExp → AExp → BExp
  | b_neq : AExp → AExp → BExp
  | b_le : AExp → AExp → BExp
  | b_not : BExp → BExp
  | b_and : BExp → BExp → BExp
  | b_or : BExp → BExp → BExp

Com

inductive Com :=
  | c_skip : Com
  | c_asgn : String → AExp → Com
  | c_seq : Com → Com → Com
  | c_if : BExp → Com → Com → Com
  | c_while : BExp → Com → Com

inductive Com : Type :=
  | c_skip : Com
  | c_asgn : String → AExp → Com
  | c_seq : Com → Com → Com
  | c_if : BExp → Com → Com → Com
  | c_while : BExp → Com → Com
  | c_par : Com → Com → Com

def ctrans_sound (ctrans : Com → Com) :=
  ∀ (c : Com), cequiv c (ctrans c)

cequiv

def cequiv (c₁ c₂ : Com) : Prop :=
  ∀ st st' : State, (st =[<[c₁]>]=> st') ↔ (st =[<[c₂]>]=> st')

State

abbrev State := String → Nat

def btrans_sound (btrans : BExp → BExp) :=
  ∀ (b : BExp), bequiv b (btrans b)

bequiv

def bequiv (b₁ b₂ : BExp) : Prop :=
  ∀ (st : State), beval st b₁ = beval st b₂

beval

def beval (st : State) (b : BExp) : Bool :=
  match b with
  | b_true => true
  | b_false => false
  | b_eq a₁ a₂ => (aeval st a₁) == (aeval st a₂)
  | b_neq a₁ a₂ => (aeval st a₁) != (aeval st a₂)
  | b_le a₁ a₂ => (aeval st a₁) <= (aeval st a₂)
  | b_not b₁ => not (beval st b₁)
  | b_and b₁ b₂ => and (beval st b₁) (beval st b₂)
  | b_or b₁ b₂ => or (beval st b₁) (beval st b₂)

example : aeval (update empty x 5)
    <{3 + x * 2}>

    = 13 := by admit /- proof elided -/

empty

def empty : State := fun _ => 0

y

abbrev y := "y"

x

abbrev x := "x"

z

abbrev z := "z"

aeval

def aeval (st : State) (a : AExp) : Nat :=
  match a with
  | a_num n => n
  | a_id x => st x
  | a_plus a₁ a₂ => (aeval st a₁) + (aeval st a₂)
  | a_minus a₁ a₂ => (aeval st a₁) - (aeval st a₂)
  | a_mult a₁ a₂ => (aeval st a₁) * (aeval st a₂)

update

def update (st : State) (k : String) (v : Nat) : State :=
  fun x => if x == k then v else st x

def atrans_sound (atrans : AExp → AExp) :=
  ∀ (a : AExp), aequiv a (atrans a)

aequiv

def aequiv (a₁ a₂ : AExp) : Prop :=
  ∀ (st : State), aeval st a₁ = aeval st a₂

CEval

inductive CEval : Com → State → State → Prop :=
  | e_skip : ∀ st,
      CEval c_skip st st
  | e_asgn : ∀ a n x st,
      aeval st a = n
      → CEval (c_asgn x a) st (update st x n)
  | e_seq : ∀ c₁ c₂ st st' st'',
      CEval c₁ st st' → CEval c₂ st' st''
      → CEval (c_seq c₁ c₂) st st''
  | e_ifTrue : ∀ b c₁ c₂ st st',
      beval st b = true → CEval c₁ st st'
      → CEval (c_if b c₁ c₂) st st'
  | e_ifFalse : ∀ b c₁ c₂ st st',
      beval st b = false → CEval c₂ st st'
      → CEval (c_if b c₁ c₂) st st'
  | e_whileFalse : ∀ b c st,
      beval st b = false
      → CEval (c_while b c) st st
  | e_whileTrue : ∀ b c st st' st'',
      beval st b = true
      → CEval c st st'
      → CEval (c_while b c) st' st''
      → CEval (c_while b c) st st''

theorem c_while_congruence b b' c c'
    : bequiv b b' → cequiv c c'
      → cequiv <{while <[b]> do <[c]> end}> <{while <[b']> do <[c']> end}>

theorem sym_bequiv b₁ b₂ : bequiv b₁ b₂ → bequiv b₂ b₁

theorem sym_cequiv c₁ c₂ : cequiv c₁ c₂ → cequiv c₂ c₁

theorem c_if_congruence b b' c₁ c₁' c₂ c₂'
    : bequiv b b' → cequiv c₁ c₁' → cequiv c₂ c₂'
      → cequiv (c_if b c₁ c₂) (c_if b' c₁' c₂')

theorem c_asgn_congruence x a a'
    : aequiv a a' → cequiv <{x := <[a]>}> <{x := <[a']>}>

theorem c_seq_congruence c₁ c₁' c₂ c₂'
    : cequiv c₁ c₁' → cequiv c₂ c₂' → cequiv (c_seq c₁ c₂) (c_seq c₁' c₂')

theorem refl_cequiv c : cequiv c c

theorem optimize_0plus_aexp_sound : atrans_sound optimize_0plus_aexp

theorem optimize_0plus_bexp_sound : btrans_sound optimize_0plus_bexp

import Frap.Trans

namespace Hidden.AExp

open AExp

end Hidden.AExp

namespace Imp

open AExp

open BExp

open Com

open CEval

def optimize_0plus_aexp (a : AExp) : AExp :=
  match a with
  | a_num _ => a
  | a_id _ => a
  | a_plus (a_num 0) a₂ => optimize_0plus_aexp a₂
  | a_plus a₁ a₂ => a_plus (optimize_0plus_aexp a₁) (optimize_0plus_aexp a₂)
  | a_minus a₁ a₂ => a_minus (optimize_0plus_aexp a₁) (optimize_0plus_aexp a₂)
  | a_mult a₁ a₂ => a_mult (optimize_0plus_aexp a₁) (optimize_0plus_aexp a₂)

def optimize_0plus_bexp (b : BExp) : BExp :=
  match b with
  | b_true => b_true
  | b_false => b_false
  | b_eq a₁ a₂ => b_eq (optimize_0plus_aexp a₁) (optimize_0plus_aexp a₂)
  | b_neq a₁ a₂ => b_neq (optimize_0plus_aexp a₁) (optimize_0plus_aexp a₂)
  | b_le a₁ a₂ => b_le (optimize_0plus_aexp a₁) (optimize_0plus_aexp a₂)
  | b_not b₁ => b_not (optimize_0plus_bexp b₁)
  | b_and b₁ b₂ => b_and (optimize_0plus_bexp b₁) (optimize_0plus_bexp b₂)
  | b_or b₁ b₂ => b_or (optimize_0plus_bexp b₁) (optimize_0plus_bexp b₂)

def optimize_0plus_com (c : Com) : Com :=
  match c with
  | c_skip => c_skip
  | c_asgn x a => c_asgn x (optimize_0plus_aexp a)
  | c_seq c₁ c₂ => c_seq (optimize_0plus_com c₁) (optimize_0plus_com c₂)
  | c_if b c₁ c₂ => c_if (optimize_0plus_bexp b) (optimize_0plus_com c₁) (optimize_0plus_com c₂)
  | c_while b c => c_while (optimize_0plus_bexp b) (optimize_0plus_com c)

example :
    optimize_0plus_com <{ while x != 0 do x := 0 + x - 1 end }>
    = <{ while x != 0 do x := x - 1 end }> := by admit /- proof elided -/

theorem optimize_0plus_com_sound : ctrans_sound optimize_0plus_com :=

:= by
  intros c
  induction c with simp [*] at *
  | c_skip => apply refl_cequiv
  | c_asgn => apply c_asgn_congruence; apply optimize_0plus_aexp_sound
  | c_seq =>
    apply c_seq_congruence
    . assumption
    . assumption
  | c_if =>
    apply c_if_congruence
    . apply optimize_0plus_bexp_sound
    . assumption
    . assumption
  | c_while =>
    apply c_while_congruence
    . apply optimize_0plus_bexp_sound
    . assumption


theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

Color

inductive Color where
  | red
  | black

Tree.BST

theorem forallTree_imp {α : Type u} (P Q : Nat → α → Prop) t
    : ForallTree P t → (∀ k v, P k v → Q k v) → ForallTree Q t

theorem forallTree_lt {α : Type u} (t : Tree α) k k'
    : ForallTree (fun x _ => x < k) t → k < k'
      → ForallTree (fun x _ => x < k') t

theorem forallTree_gt {α : Type u} (t : Tree α) k k'
    : ForallTree (fun x _ => x > k) t → k > k'
      → ForallTree (fun x _ => x > k') t

inductive Color where
  | red
  | black

inductive Tree (α : Type u) where
  | empty  : Tree α
  | tree (c: Color) (l : Tree α) (k : Nat) (v : α) (r : Tree α) : Tree α

namespace Tree

open Color

def ex_tree : Tree String :=
  tree black (tree red empty 2 "two" empty) 4 "four" (tree red empty 5 "five" empty)

def balance {α : Type u} (c : Color) (l : Tree α) (k : Nat) (vk : α) (r : Tree α) : Tree α :=
  match c with
  | red => tree red l k vk r
  | black =>
    match (l, k, vk, r) with
    | (tree red (tree red a x vx b) y vy c, z, vz, d)
    | (tree red a x vx (tree red b y vy c), z, vz, d)
    | (a, x, vx, tree red (tree red b y vy c) z vz d)
    | (a, x, vx, tree red b y vy (tree red c z vz d))
        => tree red (tree black a x vx b) y vy (tree black c z vz d)
    | _ => tree black l k vk r

inductive ForallTree {α : Type u} (p : Nat → α → Prop) : Tree α → Prop where
  | empty : ForallTree p empty
  | tree : ∀ c l k v r,
      p k v → ForallTree p l → ForallTree p r
      → ForallTree p (tree c l k v r)

inductive BST {α : Type u} : Tree α → Prop where
  | empty : BST empty
  | tree : ∀ c l k v r,
      ForallTree (fun x _ => x < k) l
      → ForallTree (fun x _ => x > k) r
      → BST l
      → BST r
      → BST (tree c l k v r)

example : BST ex_tree := by admit /- proof elided -/

theorem balance_BST {α : Type u} c (l : Tree α) k vk (r : Tree α)
    : ForallTree (fun x _ => x < k) l
      -> ForallTree (fun x _ => x > k) r
      -> BST l
      -> BST r
      -> BST (balance c l k vk r) :=

:= by
  intro hlk hkr hbl hbr; simp
  split
  . constructor <;> assumption
  . split
    . -- we are in the case where `x` is left child of `y`
      cases l <;> repeat simp [*] at *
      rcases hbl with ⟨⟩ | ⟨_, _, _, _, _, hxy, hyc, hbx, hbc⟩
      rcases hlk with ⟨⟩ | ⟨_, _, _, _, _, hyz, hxz, hzc⟩
      rcases hbx with ⟨⟩ | ⟨_, _, _, _, _, hax, hxb, hba, hbb⟩
      rcases hxy with ⟨⟩ | ⟨_, _, _, _, _, hxy, hay, hby⟩
      rcases hxz with ⟨⟩ | ⟨_, _, _, _, _, haz, hxz, hbz⟩
      /-
      Here, we have destructed all the assumptions to the atomic level.
      The goal remains to show that the resulting tree is a BST.
      We apply the constructor tactic repeatedly.
      Most of the resulting subgoals are trivial by assumption.
      -/
      (repeat' constructor) <;> try assumption
      /-
      The only interesting subgoal is to show that each node in the right subtree of the original root is greater than the left child of the original root.
      This should follow from assumptions, although not trivially.
      To facilitate reasoning at this point, we prove lemmas `forallTree_imp`, `forallTree_lt`, and `forallTree_gt` above.
      -/
      apply forallTree_gt <;> assumption
    . -- we are in the case where `y` is right child of `x`
      cases l <;> repeat simp [*] at *
      rcases hbl with ⟨⟩ | ⟨_, _, _, _, _, hax, hxy, hba, hby⟩
      rcases hlk with ⟨⟩ | ⟨_, _, _, _, _, hxz, haz, hyz⟩
      rcases hby with ⟨⟩ | ⟨_, _, _, _, _, hby, hyc, hbb, hbc⟩
      rcases hxy with ⟨⟩ | ⟨_, _, _, _, _, hxy, hxb, hxc⟩
      rcases hyz with ⟨⟩ | ⟨_, _, _, _, _, hyz, hbz, hcz⟩
      (repeat' constructor) <;> try assumption
      . apply forallTree_lt
        . exact hax
        . assumption
      . apply forallTree_gt <;> assumption
    . -- we are in the case where `y` is left child of `z`
      cases r <;> repeat simp [*] at *
      rcases hbr with ⟨⟩ | ⟨_, _, _, _, _, hyz, hzd, hby, hbd⟩
      rcases hkr with ⟨⟩ | ⟨_, _, _, _, _, hxz, hxy, hxd⟩
      rcases hby with ⟨⟩ | ⟨_, _, _, _, _, hby, hyc, hbb, hbc⟩
      rcases hxy with ⟨⟩ | ⟨_, _, _, _, _, hxy, hxb, hxc⟩
      rcases hyz with ⟨⟩ | ⟨_, _, _, _, _, hyz, hbz, hcz⟩
      (repeat' constructor) <;> try assumption
      . apply forallTree_lt <;> assumption
      . apply forallTree_gt
        . exact hzd
        . assumption
    . -- we are in the case where `z` is right child of `y`
      cases r <;> repeat simp [*] at *
      rcases hbr with ⟨⟩ | ⟨_, _, _, _, _, hby, hyz, hbb, hbz⟩
      rcases hkr with ⟨⟩ | ⟨_, _, _, _, _, hxy, hxb, hxz⟩
      rcases hbz with ⟨⟩ | ⟨_, _, _, _, _, hcz, hzd, hbc, hbd⟩
      rcases hxz with ⟨⟩ | ⟨_, _, _, _, _, hxz, hxc, hxd⟩
      rcases hyz with ⟨⟩ | ⟨_, _, _, _, _, hyz, hyc, hyd⟩
      (repeat' constructor) <;> try assumption
      apply forallTree_lt <;> assumption
    . constructor <;> assumption


theorem append_assoc (as bs cs : List α)
        : (as ++ bs) ++ cs = as ++ (bs ++ cs)

Permutation

theorem permutation_refl (l : List α) : Permutation l l

theorem permutation_symm (l l' : List α)
    : Permutation l l' → Permutation l' l

theorem permutation_app_tail (l l' tl : List α)
    : Permutation l l' → Permutation (l++tl) (l'++tl)

theorem permutation_app_head (l tl tl' : List α)
    : Permutation tl tl' → Permutation (l++tl) (l++tl')

theorem permutation_cons_append (l : List α) x
    : Permutation (x :: l) (l ++ [x])

inductive Permutation {α : Type} : List α → List α → Prop :=
  | perm_nil : Permutation [] []
  | perm_skip x l l'
      : Permutation l l' → Permutation (x::l) (x::l')
  | perm_swap x y l : Permutation (y::x::l) (x::y::l)
  | perm_trans l l' l''
      : Permutation l l' → Permutation l' l''
        → Permutation l l''

open Permutation

theorem permutation_app_comm (l l' : List α)
    : Permutation (l ++ l') (l' ++ l) :=

:= by
  induction l with simp
  | nil => apply permutation_refl
  | cons a al ih =>
    -- a :: (al ++ l')
    -- al ++ l' ++ [a]
    -- l' ++ al ++ [a]
    -- l' ++ (al ++ [a])
    -- l' ++ a :: al
    apply perm_trans
    . apply permutation_cons_append
    . apply perm_trans
      . apply permutation_app_tail; exact ih
      . rw [List.append_assoc]
        apply permutation_app_head
        apply permutation_symm
        apply permutation_cons_append


Hidden.Nat

theorem add_zero (m : Nat) : m + zero = m

theorem add_succ (m n : Nat) : m + succ n = succ (m + n)

theorem zero_add (n : Nat) : zero + n = n

theorem succ_add (m n : Nat) : succ (m + n) = succ m + n

section rewriting

variable (α : Type) (a b c d : α)  -- a, b, c, d are elements of some type

/-
## Rewriting

Recall our equality proof from last time.
-/

example : a = b → c = b → c = d → a = d := by
  intro hab hcb hcd
  apply Eq.trans
  . exact hab
  . apply Eq.trans
    . apply Eq.symm
      exact hcb
    . exact hcd

/-
Notice that in each subgoal, we are attempting to use a hypothesis by way of an equality property.
For example, we invoke the transitive property on `a = d` so that we can use the assumption `a = b` and be left with `b = d` to prove.
In effect, we are substituting `b` for `a` in the goal.

This substitution operation can be seen as rewriting some term in the goal with another, via an equality in the hypothesis.
This rewriting operation is so common that Lean provides a `rw` tactic to do so.
It replaces equals for equals, which could be an equality (`=`) or equivalence (`↔`).

Be default, it rewrites the left-hand side with the right-hand side.
For right-to-left rewriting, a left arrow needs to be indicated before the hypothesis (`←`, typed with `\<-` shortcut) .
-/

example : a = b → c = b → c = d → a = d := by
  intro hab hcb hcd
  rw [hab]
  rw [← hcd]
  rw [hcb]

end rewriting

/-
## reflexivity tactic

One of the most powerful tactics is the _reflexivity_ tactic, written `rfl` in Lean.
It will attempt to conclude that both sides of an equality goal is indeed equal, up to some trivial computation, such as expansion of definitions and function applications.
-/

example : 2 + 5 = 7 := by
  rfl

example : ¬ Even = 3 := by
  intro h
  sorry

namespace Hidden

inductive Nat where
  | zero : Nat
  | succ : Nat → Nat

namespace Nat

end Nat

end Hidden

section opendemo

open Nat

end opendemo

namespace Hidden

namespace Nat

end Nat

end Hidden

namespace Hidden

namespace Nat

theorem add_comm (m n : Nat) : m + n = n + m :=

:= by
  induction n with
  | zero =>
      rw [add_zero]
      rw [zero_add]
  | succ n' ih =>
      rw [add_succ]
      rw [ih]
      rw [succ_add]

/-
Alternatively, if the supporting fact is only useful within a single theorem, we can embed the proof within, using the
-/

example (m n : Nat) : m + n = n + m := by
  induction n with
  | zero =>
      rw [add_zero]
      rw [zero_add]
  | succ n' ih =>
      rw [add_succ]
      rw [ih]
      have h (m n : Nat) : succ (m + n) = succ m + n := by
        induction n with
        | zero =>
            rw [add_zero]
            rw [add_zero]
        | succ n' ih =>
            rw [add_succ]
            rw [add_succ]
            rw [ih]
      rw [h]


theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

Hidden.List.Palindrome

theorem nil_append (as : List α) : nil ++ as = as

theorem cons_append (a : α) (as bs : List α)
        : (cons a as) ++ bs = cons a (as ++ bs)

theorem append_nil (as : List α) : as ++ nil = as

theorem append_assoc (as bs cs : List α)
        : (as ++ bs) ++ cs = as ++ (bs ++ cs)

theorem reverse_append {α : Type u} (as bs : List α)
    : reverse (as ++ bs) = reverse bs ++ reverse as

namespace Hidden

inductive List (α : Type u) where
  | nil  : List α
  | cons : α → List α → List α

namespace List

def reverse {α : Type u} (as : List α) : List α :=
  match as with
  | nil        => nil
  | cons a as' => reverse as' ++ cons a nil

inductive Palindrome {α : Type} : List α → Prop where
  | nil : Palindrome nil
  | single (x : α) : Palindrome (cons x nil)
  | sandwich (x : α) (xs : List α)
      : Palindrome xs → Palindrome (cons x xs ++ cons x nil)

namespace Palindrome

theorem Palindrome_rev {α : Type} (l : List α)
    : Palindrome l → l = reverse l :=

:= by
  intro lPal
  induction lPal with
  | nil => rfl
  | single x => rfl
  | sandwich x xs xsPal xsRev =>
    rw [reverse_append, reverse, reverse, nil_append, reverse, ←xsRev]
    rw [cons_append, ←append_assoc, cons_append, nil_append, cons_append]


syntax:21 "if" imp:20 "then" imp:20 "else" imp:20 "end" : imp

syntax "false" : imp

syntax "false" : term

syntax "true" : imp

syntax "true" : term

syntax "<{" imp "}>" : term

syntax:21 "while" imp:20 "do" imp:20 "end" : imp

syntax:30 "{*" term "*}" term "{*" term "*}" : term

macro_rules
  | `(term|true) => `(Bool.true)
  | `(term|false) => `(Bool.false)
  | `(term|<{$x}>) => `(imp|$x)
  | `(imp|$n:num) => `(a_num $n)
  | `(imp|$s:str) => `(a_id $s)
  | `(imp|$x + $y) => `(a_plus <{$x}> <{$y}>)
  | `(imp|$x - $y) => `(a_minus <{$x}> <{$y}>)
  | `(imp|$x * $y) => `(a_mult <{$x}> <{$y}>)
  | `(imp|true) => `(b_true)
  | `(imp|false) => `(b_false)
  | `(imp|$x = $y) => `(b_eq <{$x}> <{$y}>)
  | `(imp|$x != $y) => `(b_neq <{$x}> <{$y}>)
  | `(imp|$x <= $y) => `(b_le <{$x}> <{$y}>)
  | `(imp|!$x) => `(b_not <{$x}>)
  | `(imp|$x && $y) => `(b_and <{$x}> <{$y}>)
  | `(imp|$x || $y) => `(b_or <{$x}> <{$y}>)
  | `(imp|($x)) => `(<{$x}>)
  | `(imp|$x:ident) => `(a_id $(Lean.quote (toString x.getId)))
  | `(imp|<[$t:term]>) => pure t

macro_rules
  | `(imp|skip) => `(c_skip)
  | `(imp|$x:str := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$x:ident := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$c1 ; $c2) => `(c_seq <{$c1}> <{$c2}>)
  | `(imp|if $b then $c1 else $c2 end) => `(c_if <{$b}> <{$c1}> <{$c2}>)
  | `(imp|while $b do $c end) => `(c_while <{$b}> <{$c}>)

macro_rules
  | `(term|$p <<->> $q) => `($p ->> $q ∧ $q ->> $p)

macro_rules
  | `(term|{*$p*} $c {*$q*}) => `(valid_hoare_triple $p $c $q)

x

abbrev x := "x"

beval

def beval (st : State) (b : BExp) : Bool :=
  match b with
  | b_true => true
  | b_false => false
  | b_eq a₁ a₂ => (aeval st a₁) == (aeval st a₂)
  | b_neq a₁ a₂ => (aeval st a₁) != (aeval st a₂)
  | b_le a₁ a₂ => (aeval st a₁) <= (aeval st a₂)
  | b_not b₁ => not (beval st b₁)
  | b_and b₁ b₂ => and (beval st b₁) (beval st b₂)
  | b_or b₁ b₂ => or (beval st b₁) (beval st b₂)

example : aeval (update empty x 5)
    <{3 + x * 2}>

    = 13 := by admit /- proof elided -/

empty

def empty : State := fun _ => 0

State

abbrev State := String → Nat

y

abbrev y := "y"

z

abbrev z := "z"

aeval

def aeval (st : State) (a : AExp) : Nat :=
  match a with
  | a_num n => n
  | a_id x => st x
  | a_plus a₁ a₂ => (aeval st a₁) + (aeval st a₂)
  | a_minus a₁ a₂ => (aeval st a₁) - (aeval st a₂)
  | a_mult a₁ a₂ => (aeval st a₁) * (aeval st a₂)

AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_id : String → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

update

def update (st : State) (k : String) (v : Nat) : State :=
  fun x => if x == k then v else st x

BExp

inductive BExp where
  | b_true : BExp
  | b_false : BExp
  | b_eq : AExp → AExp → BExp
  | b_neq : AExp → AExp → BExp
  | b_le : AExp → AExp → BExp
  | b_not : BExp → BExp
  | b_and : BExp → BExp → BExp
  | b_or : BExp → BExp → BExp

Com

inductive Com : Type :=
  | c_skip : Com
  | c_asgn : String → AExp → Com
  | c_seq : Com → Com → Com
  | c_if : BExp → Com → Com → Com
  | c_while : BExp → Com → Com
  | c_par : Com → Com → Com

CEval

inductive CEval : Com → State → State → Prop :=
  | e_skip : ∀ st,
      CEval c_skip st st
  | e_asgn : ∀ a n x st,
      aeval st a = n
      → CEval (c_asgn x a) st (update st x n)
  | e_seq : ∀ c₁ c₂ st st' st'',
      CEval c₁ st st' → CEval c₂ st' st''
      → CEval (c_seq c₁ c₂) st st''
  | e_ifTrue : ∀ b c₁ c₂ st st',
      beval st b = true → CEval c₁ st st'
      → CEval (c_if b c₁ c₂) st st'
  | e_ifFalse : ∀ b c₁ c₂ st st',
      beval st b = false → CEval c₂ st st'
      → CEval (c_if b c₁ c₂) st st'
  | e_whileFalse : ∀ b c st,
      beval st b = false
      → CEval (c_while b c) st st
  | e_whileTrue : ∀ b c st st' st'',
      beval st b = true
      → CEval c st st'
      → CEval (c_while b c) st' st''
      → CEval (c_while b c) st st''

syntax:30 term " =[ " imp " ]=> " term : term
macro_rules
  | `(term|$st =[ $c ]=> $st') => `(CEval <{$c}> $st $st')

Assertion

abbrev Assertion := State → Prop

def assert_implies (P Q : Assertion) : Prop :=
  ∀ st, P st → Q st

def valid_hoare_triple (P : Assertion) (c : Com) (Q : Assertion) : Prop :=
  ∀ st st', P st → (st =[<[c]>]=> st') → Q st'

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

import Frap.Trans

namespace Imp

open AExp

open BExp

open Com

open CEval

namespace Hoare

infix:36 " ->> " => assert_implies

theorem hoare_while P b c :
    {* fun st => P st ∧ beval st b *} c {* P *}
    → {* P *} c_while b c {* fun st => P st ∧ ¬(beval st b) *} :=

:= by
  intro hHoare st st' hPre hEval
  -- we proceed by induction on `hEval`
  generalize hloop : c_while b c = cmd at *
  induction hEval with simp at *
  | e_whileFalse =>
    constructor
    . exact hPre
    . simp [*]
  | e_whileTrue =>
    simp [*] at *
    rename_i ih
    apply ih
    apply hHoare
    . constructor
      . apply hPre
      . assumption
    . assumption

/-
We call `P` a _loop invariant_ of `while b do c` if
  `{P ∧ b} c {P}`
is a valid Hoare triple.

This means that `P` will be true at the end of the loop body whenever the loop body executes.
If `P` contradicts `b`, this holds trivially since the precondition is false.

For instance, `X = 0` is a loop invariant of
  `while X = 2 do X := 1 end`
since the program will never enter the loop.

The program
  `while Y > 10 do Y := Y - 1; Z := Z + 1 end`
admits an interesting loop invariant:
  `X = Y + Z`
Note that this doesn't contradict the loop guard but neither is it a command invariant of
  `Y := Y - 1; Z := Z + 1`
since, if `X = 5`, `Y = 0` and `Z = 5`, running the command will set `Y + Z` to 6, because `Y` remains 0.
The loop guard `Y > 10` guarantees that this will not be the case.
We will see many such loop invariants in the following lecture.
-/

example :
    -- { x ≤ 3 }
    {* fun st => st x ≤ 3 *}
    <{
      while x <= 2 do
        x := x + 1


Tree.BST

theorem forall_insert_of_forall {α : Type u} (P : Nat → α → Prop) (t : Tree α)
    : ForallTree P t → ∀ k v, P k v → ForallTree P (insert k v t)

inductive Tree (α : Type u) where
  | empty  : Tree α
  | tree (l : Tree α) (k : Nat) (v : α) (r : Tree α) : Tree α

namespace Tree

def ex_tree : Tree String :=
  tree (tree empty 2 "two" empty) 4 "four" (tree empty 5 "five" empty)

def insert {α : Type u} (x : Nat) (v : α) (t : Tree α) : Tree α :=
  match t with
  | empty => tree empty x v empty
  | tree l k v' r =>
      if x < k then tree (insert x v l) k v' r
      else if x > k then tree l k v' (insert x v r)
      else tree l x v r

inductive ForallTree {α : Type u} (p : Nat → α → Prop) : Tree α → Prop where
  | empty : ForallTree p empty
  | tree : ∀ l k v r,
      p k v → ForallTree p l → ForallTree p r
      → ForallTree p (tree l k v r)

inductive BST {α : Type u} : Tree α → Prop where
  | empty : BST empty
  | tree : ∀ l k v r,
      ForallTree (fun x _ => x < k) l
      → ForallTree (fun x _ => x > k) r
      → BST l
      → BST r
      → BST (tree l k v r)

example : BST ex_tree := by admit /- proof elided -/

theorem bst_insert_of_bst {α : Type u} (k : Nat) (v : α) (t : Tree α)
    : BST t → BST (insert k v t) :=

:= by
  intro hbst
  induction hbst with
  | empty => constructor <;> constructor
  | tree l k' v' r hlt hgt hbstl hbstr =>
    unfold insert
    split
    . constructor
      . apply forall_insert_of_forall
        . assumption
        . assumption
      . assumption
      . assumption
      . assumption
    . split
      . constructor
        . assumption
        . apply forall_insert_of_forall
          . assumption
          . assumption
        . assumption
        . assumption
      . have heq : k = k' := by
          simp [*] at *
          apply Nat.le_antisymm <;> assumption
        constructor
        . rw [heq]; assumption
        . rw [heq]; assumption
        . assumption
        . assumption


Hidden.List

inductive List (α : Type u) where
  | nil  : List α
  | cons : α → List α → List α

Hidden.List.reverse

def reverse {α : Type u} (as : List α) : List α :=
  match as with
  | nil        => nil
  | cons a as' => reverse as' ++ cons a nil

Hidden.List.Palindrome

inductive Palindrome {α : Type} : List α → Prop where
  | nil : Palindrome nil
  | single (x : α) : Palindrome (cons x nil)
  | sandwich (x : α) (xs : List α)
      : Palindrome xs → Palindrome (cons x xs ++ cons x nil)

theorem nil_append (as : List α) : nil ++ as = as

theorem cons_append (a : α) (as bs : List α)
        : (cons a as) ++ bs = cons a (as ++ bs)

theorem append_assoc (as bs cs : List α)
        : (as ++ bs) ++ cs = as ++ (bs ++ cs)

theorem Palindrome_app_rev {α : Type} (l : List α) : Palindrome (l ++ reverse l) :=

:= by
  induction l with
  | nil => rw [nil_append, reverse]; exact nil
  | cons x xs ih =>
    rw [cons_append, reverse, ←append_assoc, ←cons_append]
    apply sandwich x
    exact ih


Hidden.Nat.add

theorem add_succ (m n : Nat) : m + succ n = succ (m + n)

theorem add_assoc (m n k : Nat) : m + n + k = m + (n + k)

theorem mul_succ (m n : Nat) : m * succ n = add (m * n) m

theorem add_infix (m n : Nat) : m.add n = m + n

section rewriting

variable (α : Type) (a b c d : α)  -- a, b, c, d are elements of some type

/-
## Rewriting

Recall our equality proof from last time.
-/

example : a = b → c = b → c = d → a = d := by
  intro hab hcb hcd
  apply Eq.trans
  . exact hab
  . apply Eq.trans
    . apply Eq.symm
      exact hcb
    . exact hcd

/-
Notice that in each subgoal, we are attempting to use a hypothesis by way of an equality property.
For example, we invoke the transitive property on `a = d` so that we can use the assumption `a = b` and be left with `b = d` to prove.
In effect, we are substituting `b` for `a` in the goal.

This substitution operation can be seen as rewriting some term in the goal with another, via an equality in the hypothesis.
This rewriting operation is so common that Lean provides a `rw` tactic to do so.
It replaces equals for equals, which could be an equality (`=`) or equivalence (`↔`).

Be default, it rewrites the left-hand side with the right-hand side.
For right-to-left rewriting, a left arrow needs to be indicated before the hypothesis (`←`, typed with `\<-` shortcut) .
-/

example : a = b → c = b → c = d → a = d := by
  intro hab hcb hcd
  rw [hab]
  rw [← hcd]
  rw [hcb]

end rewriting

/-
## reflexivity tactic

One of the most powerful tactics is the _reflexivity_ tactic, written `rfl` in Lean.
It will attempt to conclude that both sides of an equality goal is indeed equal, up to some trivial computation, such as expansion of definitions and function applications.
-/

example : 2 + 5 = 7 := by
  rfl

example : ¬ Even = 3 := by
  intro h
  sorry

namespace Hidden

inductive Nat where
  | zero : Nat
  | succ : Nat → Nat

namespace Nat

def add (m n : Nat) : Nat :=
  match n with
  | zero    => m
  | succ n' => succ (add m n')

def mul (m n : Nat) : Nat :=
  match n with
  | zero    => zero
  | succ n' => add (mul m n') m

instance : Add Nat where
  add := add

instance : Mul Nat where
  mul := mul

end Nat

end Hidden

section opendemo

open Nat

end opendemo

namespace Hidden

namespace Nat

end Nat

end Hidden

namespace Hidden

namespace Nat

theorem mul_assoc (m n k : Nat) : m * n * k = m * (n * k) :=

:= by
  induction k with
  | zero => rfl
  | succ k' ih =>
      rw [mul_succ, mul_succ, ih, add_infix, add_infix]
      have nat_distrib (m n k : Nat)
            : m * n + m * k = m * (n + k) := by
        -- distributive property from left
        induction k with
        | zero => rfl
        | succ k' ih =>
            rw [mul_succ, add_succ, mul_succ, add_infix, add_infix, ← add_assoc, ih]
      rw [nat_distrib]


Permutation

inductive Permutation {α : Type} : List α → List α → Prop :=
  | perm_nil : Permutation [] []
  | perm_skip x l l'
      : Permutation l l' → Permutation (x::l) (x::l')
  | perm_swap x y l : Permutation (y::x::l) (x::y::l)
  | perm_trans l l' l''
      : Permutation l l' → Permutation l' l''
        → Permutation l l''

theorem permutation_refl (l : List α) : Permutation l l

theorem permutation_symm (l l' : List α)
    : Permutation l l' → Permutation l' l

theorem permutation_app_head (l tl tl' : List α)
    : Permutation tl tl' → Permutation (l++tl) (l++tl')

theorem permutation_cons_append (l : List α) x
    : Permutation (x :: l) (l ++ [x])

theorem permutation_cons_app (l l₁ l₂ : List α)
    : Permutation l (l₁ ++ l₂)
      → Permutation (a :: l) (l₁ ++ a :: l₂) :=

:= by
  intro h
  -- a :: l
  -- a :: (l₁ ++ l₂)
  -- l₁ ++ l₂ ++ [a]
  -- l₁ ++ (l₂ ++ [a])
  -- l₁ ++ a :: l₂
  apply perm_trans
  . apply perm_skip; exact h
  . apply perm_trans
    . apply permutation_cons_append
    . rw [List.append_assoc]
      apply permutation_app_head
      apply permutation_symm
      apply permutation_cons_append


syntax term "==>" term : term

syntax term "==>" term : term

syntax term "~~>" term : term

syntax term "~~>*" term : term

syntax:30 term " =[ " imp " ]=> " term : term

syntax term "!->" term "; " term : term

syntax:36 term "<<->>" term : term

macro_rules
  | `(term|$t:term ==> $n:term) => `(Eval $t $n)

macro_rules
  | `(term|$t₁:term ~~> $t₂:term) => `(Step $t₁ $t₂)

example :
    p
      (p (c 1) (c 3))
      (p (c 2) (c 4))
    ~~>
    p
      (c 4)
      (p (c 2) (c 4)) := by admit /- proof elided -/

macro_rules
  | `(term|$t₁:term ~~>* $t₂:term) => `(Multi Step $t₁ $t₂)

macro_rules
  | `(term|$p <<->> $q) => `($p ->> $q ∧ $q ->> $p)

macro_rules
  | `(term|{*$p*} $c {*$q*}) => `(valid_hoare_triple $p $c $q)

macro_rules
  | `(term|$st =[ $c ]=> $st') => `(CEval <{$c}> $st $st')

macro_rules
  | `(term|$x:term !-> $a:term ; $st) => `(update $st $x $a)

example : empty =[
      x := 2;
      if (x <= 1) then y := 3 else z := 4 end
    ]=> (z !-> 4; x !-> 2; empty) := by admit /- proof elided -/

Tm

inductive Tm : Type :=
  | c : Nat → Tm
  | p : Tm → Tm → Tm

def normal_form {X : Type} (R : relation X) (t : X) : Prop := ¬∃t', R t t'

relation

def relation (X : Type) := X → X → Prop

And

inductive And : Prop → Prop → Prop where
  | intro : a → b → And a b

Multi

inductive Multi {X : Type} (R : relation X) : relation X :=
  | multi_refl x : Multi R x x
  | multi_step x y z : R x y → Multi R y z → Multi R x z

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

TM.multistep

abbrev multistep := Multi Step

theorem bool_canonical t : HasType t bool → value t → BValue t

theorem nat_canonical t : HasType t nat → value t → NValue t

TM.progress

theorem progress t T
    : HasType t T → value t ∨ ∃ t', Step t t'

TM.preservation

theorem preservation t t' T
    : HasType t T → Step t t' → HasType t' T

import Frap.SmallStep

namespace TM

inductive Tm : Type :=
  | tru : Tm
  | fls : Tm
  | ite : Tm → Tm → Tm → Tm
  | zro : Tm
  | scc : Tm → Tm
  | prd : Tm → Tm
  | iszero : Tm → Tm

open Tm

inductive BValue : Tm → Prop :=
  | bv_true : BValue tru
  | bv_false : BValue fls

inductive NValue : Tm → Prop :=
  | nv_0 : NValue zro
  | nv_succ t : NValue t → NValue (scc t)

open BValue

open NValue

abbrev value (t : Tm) := BValue t ∨ NValue t

inductive Step : Tm → Tm → Prop :=
  | st_ifTrue t₁ t₂ : Step (ite tru t₁ t₂) t₁
  | st_ifFalse t₁ t₂ : Step (ite fls t₁ t₂) t₂
  | st_if c c' t₁ t₂ :
      Step c c' → Step (ite c t₁ t₂) (ite c' t₁ t₂)
  | st_succ t₁ t₁' : Step t₁ t₁' → Step (scc t₁) (scc t₁')
  | st_pred0 : Step (prd zro) zro
  | st_predSucc v : NValue v → Step (prd (scc v)) v
  | st_pred t₁ t₁' : Step t₁ t₁' → Step (prd t₁) (prd t₁')
  | st_iszero0 : Step (iszero zro) tru
  | st_iszeroSucc v : NValue v → Step (iszero (scc v)) fls
  | st_iszero t₁ t₁' :
      Step t₁ t₁' → Step (iszero t₁) (iszero t₁')

open Step

abbrev step_normal_form := normal_form Step

def stuck (t: Tm) : Prop :=
  step_normal_form t ∧ ¬ value t

/-
exercise (2-star)
-/
example : ∃ t, stuck t :=

inductive Ty : Type :=
  | bool : Ty
  | nat : Ty

open Ty

inductive HasType : Tm → Ty → Prop :=
  | t_true : HasType tru bool
  | t_false : HasType fls bool
  | t_if t₁ t₂ t₃ T :
      HasType t₁ bool → HasType t₂ T → HasType t₃ T
      → HasType (ite t₁ t₂ t₃) T
  | t_0 : HasType zro nat
  | t_succ t₁ : HasType t₁ nat → HasType (scc t₁) nat
  | t_pred t₁ : HasType t₁ nat → HasType (prd t₁) nat
  | t_iszero t₁ : HasType t₁ nat → HasType (iszero t₁) bool

open HasType

example  -- `⊢ if false then 0 else (succ 0) ∈ nat`
    : HasType (ite fls zro (scc zro)) nat := by
  apply t_if
  . apply t_false
  . apply t_0
  . apply t_succ
    apply t_0

/-
It's important to realize that the typing relation is a _conservative_ (or _static_) approximation: it does not consider what happens when the term is reduced.
In particular, it does not calculate the type of its normal form.
-/

example  -- `⊢ if false then zero else true ∉ bool`
    : ¬ HasType (ite fls zro tru) bool := by
  intro contra
  cases contra
  rename_i contra _
  cases contra

/-
exercise (1-star)
-/
example t : HasType (scc t) nat → HasType t nat := by
  intro ht
  cases ht
  assumption

abbrev multistep := Multi Step

theorem soundness t t' T
    : HasType t T → multistep t t' → ¬ stuck t' :=

:= by
  intro hT P
  induction P with (intro contra; obtain ⟨R, S⟩ := contra)
  | multi_refl =>
    cases (progress _ _ hT)
    . -- value
      simp [*] at *
    . -- step
      simp [step_normal_form, normal_form, *] at *
  | multi_step =>
    rename_i ih; apply ih
    . apply preservation
      . apply hT
      . assumption
    . unfold stuck; constructor <;> assumption


syntax:21 "if" imp:20 "then" imp:20 "else" imp:20 "end" : imp

macro_rules
  | `(term|true) => `(Bool.true)
  | `(term|false) => `(Bool.false)
  | `(term|<{$x}>) => `(imp|$x)
  | `(imp|$n:num) => `(a_num $n)
  | `(imp|$s:str) => `(a_id $s)
  | `(imp|$x + $y) => `(a_plus <{$x}> <{$y}>)
  | `(imp|$x - $y) => `(a_minus <{$x}> <{$y}>)
  | `(imp|$x * $y) => `(a_mult <{$x}> <{$y}>)
  | `(imp|true) => `(b_true)
  | `(imp|false) => `(b_false)
  | `(imp|$x = $y) => `(b_eq <{$x}> <{$y}>)
  | `(imp|$x != $y) => `(b_neq <{$x}> <{$y}>)
  | `(imp|$x <= $y) => `(b_le <{$x}> <{$y}>)
  | `(imp|!$x) => `(b_not <{$x}>)
  | `(imp|$x && $y) => `(b_and <{$x}> <{$y}>)
  | `(imp|$x || $y) => `(b_or <{$x}> <{$y}>)
  | `(imp|($x)) => `(<{$x}>)
  | `(imp|$x:ident) => `(a_id $(Lean.quote (toString x.getId)))
  | `(imp|<[$t:term]>) => pure t

macro_rules
  | `(imp|skip) => `(c_skip)
  | `(imp|$x:str := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$x:ident := $y) => `(c_asgn $x <{$y}>)
  | `(imp|$c1 ; $c2) => `(c_seq <{$c1}> <{$c2}>)
  | `(imp|if $b then $c1 else $c2 end) => `(c_if <{$b}> <{$c1}> <{$c2}>)
  | `(imp|while $b do $c end) => `(c_while <{$b}> <{$c}>)

AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_id : String → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

inductive AExp where
  | a_num : Nat → AExp
  | a_plus : AExp → AExp → AExp
  | a_minus : AExp → AExp → AExp
  | a_mult : AExp → AExp → AExp

State

abbrev State := String → Nat

BExp

inductive BExp where
  | b_true : BExp
  | b_false : BExp
  | b_eq : AExp → AExp → BExp
  | b_neq : AExp → AExp → BExp
  | b_le : AExp → AExp → BExp
  | b_not : BExp → BExp
  | b_and : BExp → BExp → BExp
  | b_or : BExp → BExp → BExp

x

abbrev x := "x"

Com

inductive Com :=
  | c_skip : Com
  | c_asgn : String → AExp → Com
  | c_seq : Com → Com → Com
  | c_if : BExp → Com → Com → Com
  | c_while : BExp → Com → Com

empty

def empty : State := fun _ => 0

relation

def relation (X : Type) := X → X → Prop

update

def update (st : State) (k : String) (v : Nat) : State :=
  fun x => if x == k then v else st x

y

abbrev y := "y"

And

inductive And : Prop → Prop → Prop where
  | intro : a → b → And a b

theorem List.getElem_append_left{α : Type u_1} {l₁ l₂ : List α} {i : Nat} (hn : i < l₁.length) :\n(l₁ ++ l₂)[i] = l₁[i]

AVal

inductive AVal : AExp → Prop :=
  | av_num : ∀ n, AVal (a_num n)

AStep

inductive AStep (st : State) : AExp → AExp → Prop :=
  | as_id : ∀ v, AStep st (a_id v) (a_num (st v))
  | as_plus1 : ∀ a₁ a₁' a₂,
      AStep st a₁ a₁'
      → AStep st (a_plus a₁ a₂) (a_plus a₁' a₂)
  | as_plus2 : ∀ v₁ a₂ a₂',
      AVal v₁ → AStep st a₂ a₂'
      → AStep st (a_plus v₁ a₂) (a_plus v₁ a₂')
  | as_plus : ∀ (v₁ v₂ : Nat),
      AStep st (a_plus (a_num v₁) (a_num v₂)) (a_num (v₁ + v₂))
  | as_minus1 : ∀ a₁ a₁' a₂,
      AStep st a₁ a₁'
      → AStep st (a_minus a₁ a₂) (a_minus a₁' a₂)
  | as_minus2 : ∀ v₁ a₂ a₂',
      AVal v₁ → AStep st a₂ a₂'
      → AStep st (a_minus v₁ a₂) (a_minus v₁ a₂')
  | as_minus : ∀ (v₁ v₂ : Nat),
      AStep st (a_minus (a_num v₁) (a_num v₂)) (a_num (v₁ - v₂))
  | as_mult1 : ∀ a₁ a₁' a₂,
      AStep st a₁ a₁'
      → AStep st (a_mult a₁ a₂) (a_mult a₁' a₂)
  | as_mult2 : ∀ v₁ a₂ a₂',
      AVal v₁ → AStep st a₂ a₂'
      → AStep st (a_mult v₁ a₂) (a_mult v₁ a₂')
  | as_mult : ∀ (v₁ v₂ : Nat),
      AStep st (a_mult (a_num v₁) (a_num v₂)) (a_num (v₁ * v₂))

BStep

inductive BStep (st : State) : BExp → BExp → Prop :=
  | bs_eq1 : ∀ a₁ a₁' a₂,
      AStep st a₁ a₁'
      → BStep st (b_eq a₁ a₂) (b_eq a₁' a₂)
  | bs_eq2 : ∀ v₁ a₂ a₂',
      AVal v₁ → AStep st a₂ a₂'
      → BStep st (b_eq v₁ a₂) (b_eq v₁ a₂')
  | bs_eq : ∀ (v₁ v₂ : Nat),
      BStep st (b_eq (a_num v₁) (a_num v₂))
          (if v₁ == v₂ then b_true else b_false)
  | bs_neq1 : ∀ a₁ a₁' a₂,
      AStep st a₁ a₁'
      → BStep st (b_neq a₁ a₂) (b_neq a₁' a₂)
  | bs_neq2 : ∀ v₁ a₂ a₂',
      AVal v₁ → AStep st a₂ a₂'
      → BStep st (b_neq v₁ a₂) (b_neq v₁ a₂')
  | bs_neq : ∀ (v₁ v₂ : Nat),
      BStep st (b_neq (a_num v₁) (a_num v₂))
          (if v₁ != v₂ then b_true else b_false)
  | bs_le1 : ∀ a₁ a₁' a₂,
      AStep st a₁ a₁'
      → BStep st (b_le a₁ a₂) (b_le a₁' a₂)
  | bs_le2 : ∀ v₁ a₂ a₂',
      AVal v₁ → AStep st a₂ a₂'
      → BStep st (b_le v₁ a₂) (b_le v₁ a₂')
  | bs_le : ∀ (v₁ v₂ : Nat),
      BStep st (b_le (a_num v₁) (a_num v₂))
          (if v₁ <= v₂ then b_true else b_false)
  | bs_notStep : ∀ b₁ b₁',
      BStep st b₁ b₁'
      → BStep st (b_not b₁) (b_not b₁')
  | bs_notTrue : BStep st (b_not b_true) b_false
  | bs_notFalse : BStep st (b_not b_false) b_true
  | bs_andStep : ∀ b₁ b₁' b₂,
      BStep st b₁ b₁'
      → BStep st (b_and b₁ b₂) (b_and b₁' b₂)
  | bs_andFalse : ∀ b₂,
      BStep st (b_and b_false b₂) b_false
  | bs_andTrueStep : ∀ b₂ b₂',
      BStep st b₂ b₂'
      → BStep st (b_and b_true b₂) (b_and b_true b₂')
  | bs_andTrueTrue :
      BStep st (b_and b_true b_true) b_true
  | bs_andTrueFalse :
      BStep st (b_and b_true b_false) b_false
  | bs_orStep : ∀ b₁ b₁' b₂,
      BStep st b₁ b₁'
      → BStep st (b_or b₁ b₂) (b_or b₁' b₂)
  | bs_orTrue : ∀ b₂,
      BStep st (b_or b_true b₂) b_true
  | bs_orFalseStep : ∀ b₂ b₂',
      BStep st b₂ b₂'
      → BStep st (b_or b_false b₂) (b_or b_false b₂')
  | bs_orFalseTrue :
      BStep st (b_or b_false b_true) b_true
  | bs_orFalseFalse :
      BStep st (b_or b_false b_false) b_false

CStep

inductive CStep : (Com × State) → (Com × State) → Prop :=
  | cs_asgnStep : ∀ st v a₁ a₁',
      AStep st a₁ a₁'
      → CStep (c_asgn v a₁, st) (c_asgn v a₁', st)
  | cs_asgn : ∀ st v (n : Nat),
      CStep (c_asgn v (a_num n), st) (c_skip, x !-> n; st)
  | cs_seqStep : ∀ st c₁ c₁' st' c₂,
      CStep (c₁, st) (c₁', st')
      → CStep (c_seq c₁ c₂, st) (c_seq c₁' c₂, st')
  | cs_seqFinish : ∀ st c₂,
      CStep (c_seq c_skip c₂, st) (c₂, st)
  | cs_ifStep : ∀ st b₁ b₁' c₁ c₂,
      BStep st b₁ b₁'
      → CStep (c_if b₁ c₁ c₂, st) (c_if b₁' c₁ c₂, st)
  | cs_ifTrue : ∀ st c₁ c₂,
      CStep (c_if b_true c₁ c₂, st) (c₁, st)
  | cs_ifFalse : ∀ st c₁ c₂,
      CStep (c_if b_false c₁ c₂, st) (c₂, st)
  | cs_while : ∀ st b₁ c₁,
      CStep (c_while b₁ c₁, st)
        (c_if b₁ (c_seq c₁ (c_while b₁ c₁)) c_skip, st)

CImp.Com

inductive Com : Type :=
  | c_skip : Com
  | c_asgn : String → AExp → Com
  | c_seq : Com → Com → Com
  | c_if : BExp → Com → Com → Com
  | c_while : BExp → Com → Com
  | c_par : Com → Com → Com

CImp.CStep

inductive CStep : (Com × State) → (Com × State) → Prop :=

  | cs_asgnStep : ∀ st v a₁ a₁',
      AStep st a₁ a₁'
      → CStep (c_asgn v a₁, st) (c_asgn v a₁', st)
  | cs_asgn : ∀ st v (n : Nat),
      CStep (c_asgn v (a_num n), st) (c_skip, v !-> n; st)
  | cs_seqStep : ∀ st c₁ c₁' st' c₂,
      CStep (c₁, st) (c₁', st')
      → CStep (c_seq c₁ c₂, st) (c_seq c₁' c₂, st')
  | cs_seqFinish : ∀ st c₂,
      CStep (c_seq c_skip c₂, st) (c₂, st)
  | cs_ifStep : ∀ st b₁ b₁' c₁ c₂,
      BStep st b₁ b₁'
      → CStep (c_if b₁ c₁ c₂, st) (c_if b₁' c₁ c₂, st)
  | cs_ifTrue : ∀ st c₁ c₂,
      CStep (c_if b_true c₁ c₂, st) (c₁, st)
  | cs_ifFalse : ∀ st c₁ c₂,
      CStep (c_if b_false c₁ c₂, st) (c₂, st)
  | cs_while : ∀ st b₁ c₁,
      CStep (c_while b₁ c₁, st)
        (c_if b₁ (c_seq c₁ (c_while b₁ c₁)) c_skip, st)

  | cs_par1 : ∀ st c₁ c₁' c₂ st',
      CStep (c₁, st) (c₁', st')
      → CStep (c_par c₁ c₂, st) (c_par c₁' c₂, st')
  | cs_par2 : ∀ st c₁ c₂ c₂' st',
      CStep (c₂, st) (c₂', st')
      → CStep (c_par c₁ c₂, st) (c_par c₁ c₂', st')
  | cs_parDone : ∀ st,
      CStep (c_par c_skip c_skip, st) (c_skip, st)

def par_loop : Com :=
  c_par
    (c_asgn y (a_num 1))
    (c_while (b_eq (a_id y) (a_num 0))
      (c_asgn x (a_plus (a_id x) (a_num 1))))

/-
In particular, it can terminate with `x` set to `0`.
-/

example : ∃ st',
    Multi CStep (par_loop, empty) (c_skip, st')
    ∧ st' x = 0 :=

theorem par_body_n__Sn n st
    : st x = n ∧ st y = 0
      → Multi CStep (par_loop, st) (par_loop, x !-> n + 1; st)

theorem par_body_n n st
    : st x = 0 ∧ st y = 0
      → ∃ st', Multi CStep (par_loop, st) (par_loop, st')
          ∧ st' x = n ∧ st' y = 0 :=

:= by
  intro h
  obtain ⟨hx, hy⟩ := h
  induction n with
  | zero =>
      exists st
      apply And.intro
      . apply multi_refl
      . apply And.intro
        . apply hx
        . apply hy
  | succ n' hn' =>
      obtain ⟨st', ⟨h', ⟨hx', hy'⟩⟩⟩ := hn'
      constructor
      apply And.intro
      . apply multi_trans
        . apply h'
        . apply par_body_n__Sn
          . apply And.intro
            . exact hx'
            . exact hy'
      . apply And.intro
        . rfl
        . exact hy'