notation:40 env:40 " ⊢ " e:40 " ↦ " v:40 => Eval env e v

notation:40 env:40 " ⊢ " e:40 " ↓" => Eval.Defined env e

notation:40 env:40 " ⊢ " e:40 " ↦(" n ") " v:40 => Eval.Indexed n env e v

notation:40 e:40 " ≲(" n:40 ")⟨" env:40 ", " env':40 "⟩ " e':40 => Expr.Approx.Param.Indexed n env env' e e'

syntax "case " expr " of " cases " end" : expr

notation:40 args₁:40 " ≲ₐ(" n:40 ") " args₂:40 => List.Forall₂ (Value.Approx.Indexed n) args₁ args₂

syntax:100 expr:100 ppSpace expr:101 : expr

syntax:50 expr:50 " + " expr:51 : expr

syntax:50 expr:50 " - " expr:50 : expr

syntax:60 expr:60 " * " expr:61 : expr

syntax:60 expr:60 " / " expr:60 : expr

macro "invert" h:term : tactic => `(tactic| (cases ($h).invert <;> try clear $h))

syntax "let " ident " := " expr " in " expr : expr

macro_rules
  | `(⟪$s:ident ♯ $i:num⟫) => `(Expr.var $(Lean.Syntax.mkStrLit s.getId.toString) $i)
  | `(⟪$num:num⟫) => `(Expr.const (Constant.int $num))
  | `(⟪$s:str⟫) => `(Expr.const (Constant.string $s))
  | `(⟪υ⟫) => `(Expr.unit)
  | `(⟪$e₁:expr $e₂:expr⟫) => `(Expr.app ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪λ $s:ident $e:expr⟫) => `(Expr.lambda $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e⟫)
  | `(⟪λ $ss:ident* . $e:expr⟫) => mkLambdas ss e
  | `(⟪ $s:ident ⟫) => `(Expr.constr $(Lean.Syntax.mkStrLit s.getId.toString))
  | `(⟪ $s:ident $es:expr* ⟫) => mkConstrApp s es
  | `(⟪$e₁ + $e₂⟫) => `(Expr.binop BinaryOp.add_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ - $e₂⟫) => `(Expr.binop BinaryOp.sub_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ * $e₂⟫) => `(Expr.binop BinaryOp.mul_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ / $e₂⟫) => `(Expr.binop BinaryOp.div_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪let $s:ident := $e₁:expr in $e₂:expr⟫) => `(Expr.save $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪letrec $s:ident := $e₁:expr in $e₂:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.save $name (Expr.recur $name ⟪$e₁⟫) ⟪$e₂⟫)
  | `(⟪rec $s:ident $e:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.recur $name ⟪$e⟫)
  | `(⟪⊥⟫) => `(Expr.fail)
  | `(⟪cases| | $s:ident => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ Expr.fail)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ Expr.fail)
  | `(⟪cases| | _ => $e:expr ⟫) =>
    `(⟪$e⟫)
  | `(⟪case $e:expr of $cs:cases end⟫) => do
    `(Expr.save "_case_" ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪($e)⟫) => `(⟪$e⟫)

  inductive Value : Type where
    | unit : Value
    | const : Constant → Value
    | constr_app : (constr : Name) → (args_rev : List Value) → Value
    | closure : (env : List Object) → (value : Expr) → Value
    deriving Inhabited

abbrev cons_value (v : Value) (env : Env) : Env := Object.value v :: env

  inductive Object : Type where
    | value : Value → Object
    | delayed : (env : List Object) → Expr → Object
    deriving Inhabited

Expr

inductive Expr : Type where
  | var : (name : String) → (index : Nat) → Expr
  | unit : Expr
  | const : Constant → Expr
  | constr : Name → Expr
  | app : Expr → Expr → Expr
  | constr_app : Expr → Expr → Expr
  | binop : (oper : BinaryOp) → (arg₁ arg₂ : Expr) → Expr
  | lambda : (var_name : String) → (body : Expr) → Expr
  | save : (var_name : String) → (value : Expr) → (body : Expr) → Expr
  | branch : (constr : Name) → (var_names : List Name) → (body : Expr) → (next : Expr) → Expr
  | recur : (var_name : Name) → (body : Expr) → Expr
  | fail : Expr
  deriving Inhabited, BEq, DecidableEq

BinaryOp

inductive BinaryOp : Type where
  | add_int : BinaryOp
  | sub_int : BinaryOp
  | mul_int : BinaryOp
  | div_int : BinaryOp
  deriving Inhabited, BEq, DecidableEq

Constant

inductive Constant : Type where
  | int : Int → Constant
  | string : String → Constant
  deriving Inhabited, BEq, DecidableEq

Name

abbrev Name : Type := String

Env

abbrev Env : Type := List Object

Value.Approx

def Value.Approx (v v' : Value) : Prop :=
  ∀ n, v ≲ᵥ(n) v'

Object.Approx

inductive Object.Approx : Object → Object → Prop where
  | value {v₁ v₂} : v₁ ≲ᵥ v₂ → Object.Approx (Object.value v₁) (Object.value v₂)
  | delayed {env₁ env₂ e₁ e₂} :
    e₁ ≲⟨env₁, env₂⟩ e₂ →
    Object.Approx (Object.delayed env₁ e₁) (Object.delayed env₂ e₂)

Env.Approx

def Env.Approx : (env₁ env₂ : Env) → Prop :=
  List.Forall₂ Object.Approx

Expr.Approx

def Expr.Approx (e₁ e₂ : Expr) : Prop :=
  ∀ env₁ env₂, env₁ ≲ₑ env₂ → e₁ ≲⟨env₁, env₂⟩ e₂

Expr.Approx.Param

def Expr.Approx.Param (env₁ env₂ : Env) (e₁ e₂ : Expr) : Prop :=
  (∀ v₁, env₁ ⊢ e₁ ↦ v₁ → ∃ v₂, env₂ ⊢ e₂ ↦ v₂ ∧ v₁ ≲ᵥ v₂)

Eval.Indexed

inductive Eval.Indexed : Nat → Env → Expr → Value → Prop where
  | var {n env name idx val} :
    env[idx]? = some (Object.value val) →
    Eval.Indexed n env (Expr.var name idx) val
  | var_rec {n env name idx env' expr val} :
    env[idx]? = some (Object.delayed env' expr) →
    Eval.Indexed n env' expr val →
    Eval.Indexed n env (Expr.var name idx) val
  | unit {n env} :
    Eval.Indexed n env Expr.unit Value.unit
  | const {n env c} :
    Eval.Indexed n env (Expr.const c) (Value.const c)
  | constr {n env name} :
    Eval.Indexed n env (Expr.constr name) (Value.constr_app name [])
  | app {n n₁ n₂ env env' f body arg val val'} :
    n₁ + n₂ + 1 ≤ n →
    Eval.Indexed n₁ env f (Value.closure env' body) →
    Eval.Indexed (n₁ + 1) env arg val →
    Eval.Indexed n₂ (val ∷ env') body val' →
    Eval.Indexed n env (Expr.app f arg) val'
  | constr_app {n n' env ctr ctr_name ctr_args_rev arg val} :
    n' < n →
    Eval.Indexed n env ctr (Value.constr_app ctr_name ctr_args_rev) →
    Eval.Indexed n' env arg val →
    Eval.Indexed n env (Expr.constr_app ctr arg) (Value.constr_app ctr_name (val :: ctr_args_rev))
  | binop {n env op arg₁ arg₂ val₁ val₂} :
    Eval.Indexed n env arg₁ (Value.const (Constant.int val₁)) →
    Eval.Indexed n env arg₂ (Value.const (Constant.int val₂)) →
    Eval.Indexed n env (Expr.binop op arg₁ arg₂) (Value.const (Constant.int (eval_binop_int op val₁ val₂)))
  | lambda {n env name body} :
    Eval.Indexed n env (Expr.lambda name body) (Value.closure env body)
  | save {n n₁ n₂ env name value body val val'} :
    n₁ + n₂ ≤ n →
    Eval.Indexed n₁ env value val →
    Eval.Indexed n₂ (val ∷ env) body val' →
    Eval.Indexed n env (Expr.save name value body) val'
  | branch_matches {n n' env name args_rev body val} :
    n' < n →
    Eval.Indexed n' (args_rev.map Object.value ++ env) body val →
    Eval.Indexed n (Value.constr_app name args_rev ∷ env) (Expr.branch name _ body _) val
  | branch_fails {n env name name' args_rev next val} :
    name ≠ name' →
    Eval.Indexed n (Value.constr_app name args_rev ∷ env) next val →
    Eval.Indexed n (Value.constr_app name args_rev ∷ env) (Expr.branch name' _ _ next) val
  | recur {n n' env name body val} :
    n' < n →
    Eval.Indexed n' (Object.delayed env (Expr.recur name body) :: env) body val →
    Eval.Indexed n env (Expr.recur name body) val

Eval

@[aesop unsafe constructors]
inductive Eval : Env → Expr → Value → Prop where
  | var {env name idx val} :
    env[idx]? = some (Object.value val) →
    Eval env (Expr.var name idx) val
  | var_rec {env name idx env' expr val} :
    env[idx]? = some (Object.delayed env' expr) →
    Eval env' expr val →
    Eval env (Expr.var name idx) val
  | unit {env} :
    Eval env Expr.unit Value.unit
  | const {env c} :
    Eval env (Expr.const c) (Value.const c)
  | constr {env name} :
    Eval env (Expr.constr name) (Value.constr_app name [])
  | app {env env' f body arg val val'} :
    Eval env f (Value.closure env' body) →
    Eval env arg val →
    Eval (val ∷ env') body val' →
    Eval env (Expr.app f arg) val'
  | constr_app {env ctr ctr_name ctr_args_rev arg val} :
    Eval env ctr (Value.constr_app ctr_name ctr_args_rev) →
    Eval env arg val →
    Eval env (Expr.constr_app ctr arg) (Value.constr_app ctr_name (val :: ctr_args_rev))
  | binop {env op arg₁ arg₂ val₁ val₂} :
    Eval env arg₁ (Value.const (Constant.int val₁)) →
    Eval env arg₂ (Value.const (Constant.int val₂)) →
    Eval env (Expr.binop op arg₁ arg₂) (Value.const (Constant.int (eval_binop_int op val₁ val₂)))
  | lambda {env name body} :
    Eval env (Expr.lambda name body) (Value.closure env body)
  | save {env name value body val val'} :
    Eval env value val →
    Eval (val ∷ env) body val' →
    Eval env (Expr.save name value body) val'
  | branch_matches {env name args_rev body val} :
    Eval (args_rev.map Object.value ++ env) body val →
    Eval (Value.constr_app name args_rev ∷ env) (Expr.branch name _ body _) val
  | branch_fails {env name name' args_rev next val} :
    name ≠ name' →
    Eval (Value.constr_app name args_rev ∷ env) next val →
    Eval (Value.constr_app name args_rev ∷ env) (Expr.branch name' _ _ next) val
  | recur {env name body val} :
    Eval (Object.delayed env (Expr.recur name body) :: env) body val →
    Eval env (Expr.recur name body) val

Context

inductive Context : Type where
  | hole : Context
  | app_left : Context → Expr → Context
  | app_right : Expr → Context → Context
  | constr_app_left : Context → Expr → Context
  | constr_app_right : Expr → Context → Context
  | binop_left : (oper : BinaryOp) → (arg₁ : Context) → (arg₂ : Expr) → Context
  | binop_right : (oper : BinaryOp) → (arg₁ : Expr) → (arg₂ : Context) → Context
  | lambda : (var_name : String) → (body : Context) → Context
  | save_left : (var_name : String) → (value : Context) → (body : Expr) → Context
  | save_right : (var_name : String) → (value : Expr) → (body : Context) → Context
  | branch_left : (constr : Name) → (var_names : List Name) → (body : Context) → (next : Expr) → Context
  | branch_right : (constr : Name) → (var_names : List Name) → (body : Expr) → (next : Context) → Context
  | recur : (var_name : Name) → (ctx : Context) → Context
  deriving Inhabited, BEq

def eval_binop_int (op : BinaryOp) (i₁ i₂ : Int) : Int :=
  match op with
  | BinaryOp.add_int => i₁ + i₂
  | BinaryOp.sub_int => i₁ - i₂
  | BinaryOp.mul_int => i₁ * i₂
  | BinaryOp.div_int => i₁ / i₂

infixr:50 " ∷ " => cons_value

notation:40 v:40 " ≲ᵥ " v':40 => Value.Approx v v'

notation:40 e:40 " ≲⟨" env:40 ", " env':40 "⟩ " e':40 => Expr.Approx.Param env env' e e'

notation:40 v:40 " ≲ₒ " v':40 => Object.Approx v v'

notation:40 env₁:40 " ≲ₑ " env₂:40 => Env.Approx env₁ env₂

notation:40 e₁:40 " ≲ " e₂:40 => Expr.Approx e₁ e₂

infixl:100 " @@ " => Expr.app

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

Juvix.Core.Main.Env.Approx.Indexed'.get

lemma Env.Approx.Indexed'.get {n i : Nat} {env env' o₁}
  (h₁ : env ≲ₑ'(n) env')
  (h₂ : env[i]? = some o₁) :
  ∃ o₂, env'[i]? = some o₂ ∧ o₁ ≲ₒ'(n) o₂

lemma Env.Approx.Indexed'.value {n i : Nat} {env env' v}
  (h₁ : env ≲ₑ'(n) env')
  (h₂ : env[i]? = some (Object.value v)) :
  ∃ v', env'[i]? = some (Object.value v') ∧ v ≲ᵥ(n) v'

lemma Env.Approx.Indexed'.delayed {n i : Nat} {env₁ env₂ env e}
  (h₁ : env₁ ≲ₑ'(n) env₂)
  (h₂ : env₁[i]? = some (Object.delayed env e)) :
  (∃ env' e', e ≲(n)⟨env, env'⟩ e' ∧ env₂[i]? = some (Object.delayed env' e')) ∨
  ∃ env', env ≲ₑ'(n) env' ∧ env₂[i]? = some (Object.delayed env' e)

lemma Env.Approx.Indexed'.from_value {n l₁ l₂} (h : l₁ ≲ₐ(n) l₂) :
  List.map Object.value l₁ ≲ₑ'(n) List.map Object.value l₂

lemma Env.Approx.Indexed'.concat {n env₁ env₂ env₁' env₂'}
  (h₁ : env₁ ≲ₑ'(n) env₁')
  (h₂ : env₂ ≲ₑ'(n) env₂') :
  env₁ ++ env₂ ≲ₑ'(n) env₁' ++ env₂'

lemma Env.Approx.Indexed'.cons {n o₁ o₂ env₁ env₂}
  (h₁ : o₁ ≲ₒ'(n) o₂)
  (h₂ : env₁ ≲ₑ'(n) env₂) :
  o₁ :: env₁ ≲ₑ'(n) o₂ :: env₂

@[aesop unsafe apply]
lemma Value.Approx.Indexed.unit {n} : Value.unit ≲ᵥ(n) Value.unit

@[aesop unsafe apply]
lemma Value.Approx.Indexed.const {n c} : Value.const c ≲ᵥ(n) Value.const c

@[aesop unsafe apply]
lemma Value.Approx.Indexed.constr_app {n ctr_name args_rev args_rev'} :
    (∀ k < n, args_rev ≲ₐ(k) args_rev') →
    Value.constr_app ctr_name args_rev ≲ᵥ(n) Value.constr_app ctr_name args_rev'

@[aesop unsafe apply]
lemma Value.Approx.Indexed.closure {n env₁ body₁ env₂ body₂} :
    (∀ n₁ n₂, n₁ + n₂ < n →
      ∀ a₁ a₂ v₁,
        a₁ ≲ᵥ(n₁ + n₂) a₂ →
        a₁ ∷ env₁ ⊢ body₁ ↦(n₁) v₁ →
        ∃ v₂, a₂ ∷ env₂ ⊢ body₂ ↦ v₂ ∧ v₁ ≲ᵥ(n₂) v₂) →
    Value.closure env₁ body₁ ≲ᵥ(n) Value.closure env₂ body₂

lemma Value.Approx.Indexed.anti_monotone {n n' v₁ v₂} (h : v₁ ≲ᵥ(n) v₂) (h' : n' ≤ n) : v₁ ≲ᵥ(n') v₂

lemma Expr.Approx.Param.Indexed.anti_monotone {n n' env₁ env₂ e₁ e₂}
  (h : e₁ ≲(n)⟨env₁, env₂⟩ e₂)
  (h' : n' ≤ n)
  : e₁ ≲(n')⟨env₁, env₂⟩ e₂

lemma Expr.Approx.Indexed'.anti_monotone {n n' e₁ e₂}
  (h : e₁ ≲'(n) e₂)
  (h' : n' ≤ n)
  : e₁ ≲'(n') e₂

  lemma Env.Approx.Indexed'.anti_monotone {n n' env₁ env₂}
    (h : env₁ ≲ₑ'(n) env₂)
    (h' : n' ≤ n)
    : env₁ ≲ₑ'(n') env₂

lemma Object.Approx.Indexed'.anti_monotone {n n' o₁ o₂} (h : o₁ ≲ₒ'(n) o₂) (h' : n' ≤ n) : o₁ ≲ₒ'(n') o₂

lemma Value.Approx.Indexed.Preservation.anti_monotone {k k'} (h : Value.Approx.Indexed.Preservation k) (h' : k' ≤ k) : Value.Approx.Indexed.Preservation k'

lemma Value.Approx.Indexed.preserved_step {k} :
  (∀ k' < k, Preservation k') → Preservation k

import Juvix.Core.Main.Semantics.Eval

import Juvix.Core.Main.Semantics.Eval.Indexed

import Juvix.Utils

import Mathlib.Tactic.Linarith

import Mathlib.Data.List.Forall2

import Aesop

namespace Juvix.Core.Main

def Value.Approx.Indexed (n : Nat) (v₁ v₂ : Value) : Prop :=
  (v₁ = Value.unit ∧ v₂ = Value.unit) ∨
  (∃ c, v₁ = Value.const c ∧ v₂ = Value.const c) ∨
  (∃ ctr_name args_rev args_rev',
    v₁ = Value.constr_app ctr_name args_rev ∧
    v₂ = Value.constr_app ctr_name args_rev' ∧
    (∀ k < n, List.Forall₂ (Value.Approx.Indexed k) args_rev args_rev')) ∨
  (∃ env₁ body₁ env₂ body₂,
    v₁ = Value.closure env₁ body₁ ∧
    v₂ = Value.closure env₂ body₂ ∧
    (∀ n₁ n₂, n₁ + n₂ < n →
      ∀ a₁ a₂ r₁,
        Value.Approx.Indexed (n₁ + n₂) a₁ a₂ →
        a₁ ∷ env₁ ⊢ body₁ ↦(n₁) r₁ →
        ∃ r₂,
          a₂ ∷ env₂ ⊢ body₂ ↦ r₂ ∧
          Value.Approx.Indexed n₂ r₁ r₂))

notation:40 v:40 " ≲ᵥ(" n:40 ") " v':40 => Value.Approx.Indexed n v v'

notation:40 args₁:40 " ≲ₐ(" n:40 ") " args₂:40 => List.Forall₂ (Value.Approx.Indexed n) args₁ args₂

def Expr.Approx.Param.Indexed (n : Nat) (env₁ env₂ : Env) (e₁ e₂ : Expr) : Prop :=
  (∀ n₁ n₂ v₁, n₁ + n₂ ≤ n → env₁ ⊢ e₁ ↦(n₁) v₁ → ∃ v₂, env₂ ⊢ e₂ ↦ v₂ ∧ v₁ ≲ᵥ(n₂) v₂)

notation:40 e:40 " ≲(" n:40 ")⟨" env:40 ", " env':40 "⟩ " e':40 => Expr.Approx.Param.Indexed n env env' e e'

inductive Object.Approx.Indexed' (n : Nat) : Object → Object → Prop where
  | value {v₁ v₂} :
    v₁ ≲ᵥ(n) v₂ →
    Object.Approx.Indexed' n (Object.value v₁) (Object.value v₂)
  | delayed {env₁ env₂ e₁ e₂} :
    e₁ ≲(n)⟨env₁, env₂⟩ e₂ →
    Object.Approx.Indexed' n (Object.delayed env₁ e₁) (Object.delayed env₂ e₂)
  | delayed_eq {env₁ env₂ e} :
    List.Forall₂ (Object.Approx.Indexed' n) env₁ env₂ →
    Object.Approx.Indexed' n (Object.delayed env₁ e) (Object.delayed env₂ e)

def Env.Approx.Indexed' (n : Nat) : (env₁ env₂ : Env) → Prop :=
  List.Forall₂ (Object.Approx.Indexed' n)

notation:40 v:40 " ≲ₒ'(" n:40 ") " v':40 => Object.Approx.Indexed' n v v'

notation:40 env₁:40 " ≲ₑ'(" n:40 ") " env₂:40 => Env.Approx.Indexed' n env₁ env₂

def Expr.Approx.Indexed' (n : Nat) (e₁ e₂ : Expr) : Prop :=
  (∀ n₁ n₂ v₁, n₁ + n₂ ≤ n →
    ∀ env₁ env₂, env₁ ≲ₑ'(n₁ + n₂) env₂ → env₁ ⊢ e₁ ↦(n₁) v₁ → ∃ v₂, env₂ ⊢ e₂ ↦ v₂ ∧ v₁ ≲ᵥ(n₂) v₂)

notation:40 e:40 " ≲'(" n:40 ") " e':40 => Expr.Approx.Indexed' n e e'

@[aesop safe cases]
inductive Value.Approx.Indexed.Inversion (n : Nat) : Value → Value → Prop where
  | unit : Value.Approx.Indexed.Inversion n Value.unit Value.unit
  | const {c} : Value.Approx.Indexed.Inversion n (Value.const c) (Value.const c)
  | constr_app {ctr_name args_rev args_rev'} :
    (∀ k < n, args_rev ≲ₐ(k) args_rev') →
    Value.Approx.Indexed.Inversion n (Value.constr_app ctr_name args_rev) (Value.constr_app ctr_name args_rev')
  | closure {env₁ body₁ env₂ body₂} :
    (∀ n₁ n₂, n₁ + n₂ < n →
      ∀ a₁ a₂ v₁,
        a₁ ≲ᵥ(n₁ + n₂) a₂ →
        a₁ ∷ env₁ ⊢ body₁ ↦(n₁) v₁ →
        ∃ v₂, a₂ ∷ env₂ ⊢ body₂ ↦ v₂ ∧ v₁ ≲ᵥ(n₂) v₂) →
    Value.Approx.Indexed.Inversion n (Value.closure env₁ body₁) (Value.closure env₂ body₂)

end

def Value.Approx.Indexed.Preservation (k : Nat) : Prop :=
  ∀ m n env env' e v,
    m + n < k →
    env ≲ₑ'(m + n) env' →
    env ⊢ e ↦(n) v →
    ∃ v', env' ⊢ e ↦ v' ∧ v ≲ᵥ(m) v'

lemma Value.Approx.Indexed.preserved' {k} : Preservation k :=

:= by
  suffices ∀ k' ≤ k, Preservation k' by
    aesop
  induction k with
  | zero =>
    intro k' hk'
    refine preserved_step ?_
    intro k hk
    linarith
  | succ k ih =>
    intro k' hk'
    cases hk'
    case succ.refl =>
      refine preserved_step ?_
      intro k' hk'
      apply ih
      linarith
    case succ.step =>
      apply ih
      simp_all only [Nat.le_eq]


notation:40 v:40 " ≲ᵥ(" n:40 ") " v':40 => Value.Approx.Indexed n v v'

syntax "case " expr " of " cases " end" : expr

macro_rules
  | `(⟪$s:ident ♯ $i:num⟫) => `(Expr.var $(Lean.Syntax.mkStrLit s.getId.toString) $i)
  | `(⟪$num:num⟫) => `(Expr.const (Constant.int $num))
  | `(⟪$s:str⟫) => `(Expr.const (Constant.string $s))
  | `(⟪υ⟫) => `(Expr.unit)
  | `(⟪$e₁:expr $e₂:expr⟫) => `(Expr.app ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪λ $s:ident $e:expr⟫) => `(Expr.lambda $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e⟫)
  | `(⟪λ $ss:ident* . $e:expr⟫) => mkLambdas ss e
  | `(⟪ $s:ident ⟫) => `(Expr.constr $(Lean.Syntax.mkStrLit s.getId.toString))
  | `(⟪ $s:ident $es:expr* ⟫) => mkConstrApp s es
  | `(⟪$e₁ + $e₂⟫) => `(Expr.binop BinaryOp.add_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ - $e₂⟫) => `(Expr.binop BinaryOp.sub_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ * $e₂⟫) => `(Expr.binop BinaryOp.mul_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ / $e₂⟫) => `(Expr.binop BinaryOp.div_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪let $s:ident := $e₁:expr in $e₂:expr⟫) => `(Expr.save $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪letrec $s:ident := $e₁:expr in $e₂:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.save $name (Expr.recur $name ⟪$e₁⟫) ⟪$e₂⟫)
  | `(⟪rec $s:ident $e:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.recur $name ⟪$e⟫)
  | `(⟪⊥⟫) => `(Expr.fail)
  | `(⟪cases| | $s:ident => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ Expr.fail)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ Expr.fail)
  | `(⟪cases| | _ => $e:expr ⟫) =>
    `(⟪$e⟫)
  | `(⟪case $e:expr of $cs:cases end⟫) => do
    `(Expr.save "_case_" ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪($e)⟫) => `(⟪$e⟫)

  inductive Object : Type where
    | value : Value → Object
    | delayed : (env : List Object) → Expr → Object
    deriving Inhabited

Object.Approx

inductive Object.Approx : Object → Object → Prop where
  | value {v₁ v₂} : v₁ ≲ᵥ v₂ → Object.Approx (Object.value v₁) (Object.value v₂)
  | delayed {env₁ env₂ e₁ e₂} :
    e₁ ≲⟨env₁, env₂⟩ e₂ →
    Object.Approx (Object.delayed env₁ e₁) (Object.delayed env₂ e₂)

Env.Approx

def Env.Approx : (env₁ env₂ : Env) → Prop :=
  List.Forall₂ Object.Approx

BinaryOp

inductive BinaryOp : Type where
  | add_int : BinaryOp
  | sub_int : BinaryOp
  | mul_int : BinaryOp
  | div_int : BinaryOp
  deriving Inhabited, BEq, DecidableEq

Expr

inductive Expr : Type where
  | var : (name : String) → (index : Nat) → Expr
  | unit : Expr
  | const : Constant → Expr
  | constr : Name → Expr
  | app : Expr → Expr → Expr
  | constr_app : Expr → Expr → Expr
  | binop : (oper : BinaryOp) → (arg₁ arg₂ : Expr) → Expr
  | lambda : (var_name : String) → (body : Expr) → Expr
  | save : (var_name : String) → (value : Expr) → (body : Expr) → Expr
  | branch : (constr : Name) → (var_names : List Name) → (body : Expr) → (next : Expr) → Expr
  | recur : (var_name : Name) → (body : Expr) → Expr
  | fail : Expr
  deriving Inhabited, BEq, DecidableEq

Constant

inductive Constant : Type where
  | int : Int → Constant
  | string : String → Constant
  deriving Inhabited, BEq, DecidableEq

notation:40 v:40 " ≲ₒ " v':40 => Object.Approx v v'

notation:40 env₁:40 " ≲ₑ " env₂:40 => Env.Approx env₁ env₂

infixl:100 " @@ " => Expr.app

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

Juvix.Core.Main.Env.Approx.Indexed'

lemma Env.Approx.Indexed'.refl' {n env} (h : ∀ v, v ≲ᵥ(n) v) : env ≲ₑ'(n) env

import Juvix.Core.Main.Semantics.Eval

import Juvix.Core.Main.Semantics.Eval.Indexed

import Juvix.Utils

import Mathlib.Tactic.Linarith

import Mathlib.Data.List.Forall2

import Aesop

namespace Juvix.Core.Main

notation:40 v:40 " ≲ᵥ(" n:40 ") " v':40 => Value.Approx.Indexed n v v'

notation:40 args₁:40 " ≲ₐ(" n:40 ") " args₂:40 => List.Forall₂ (Value.Approx.Indexed n) args₁ args₂

notation:40 e:40 " ≲(" n:40 ")⟨" env:40 ", " env':40 "⟩ " e':40 => Expr.Approx.Param.Indexed n env env' e e'

inductive Object.Approx.Indexed' (n : Nat) : Object → Object → Prop where
  | value {v₁ v₂} :
    v₁ ≲ᵥ(n) v₂ →
    Object.Approx.Indexed' n (Object.value v₁) (Object.value v₂)
  | delayed {env₁ env₂ e₁ e₂} :
    e₁ ≲(n)⟨env₁, env₂⟩ e₂ →
    Object.Approx.Indexed' n (Object.delayed env₁ e₁) (Object.delayed env₂ e₂)
  | delayed_eq {env₁ env₂ e} :
    List.Forall₂ (Object.Approx.Indexed' n) env₁ env₂ →
    Object.Approx.Indexed' n (Object.delayed env₁ e) (Object.delayed env₂ e)

def Env.Approx.Indexed' (n : Nat) : (env₁ env₂ : Env) → Prop :=
  List.Forall₂ (Object.Approx.Indexed' n)

notation:40 v:40 " ≲ₒ'(" n:40 ") " v':40 => Object.Approx.Indexed' n v v'

notation:40 env₁:40 " ≲ₑ'(" n:40 ") " env₂:40 => Env.Approx.Indexed' n env₁ env₂

notation:40 e:40 " ≲'(" n:40 ") " e':40 => Expr.Approx.Indexed' n e e'

end

lemma Object.Approx.Indexed'.refl' {n o} (h : ∀ v, v ≲ᵥ(n) v) : o ≲ₒ'(n) o :=

:= by
    cases o
    case value v =>
      apply Object.Approx.Indexed'.value
      apply h
    case delayed env e =>
      apply Object.Approx.Indexed'.delayed_eq
      exact Env.Approx.Indexed'.refl' h


notation:40 e₁:40 " ≲ " e₂:40 => Expr.Approx e₁ e₂

notation:40 e:40 " ≲⟨" env:40 ", " env':40 "⟩ " e':40 => Expr.Approx.Param env env' e e'

notation:40 env:40 " ⊢ " e:40 " ↦ " v:40 => Eval env e v

notation:40 env:40 " ⊢ " e:40 " ↓" => Eval.Defined env e

notation:40 env:40 " ⊢ " e:40 " ↦(" n ") " v:40 => Eval.Indexed n env e v

notation:40 v:40 " ≲ᵥ " v':40 => Value.Approx v v'

notation:40 v:40 " ≲ᵥ(" n:40 ") " v':40 => Value.Approx.Indexed n v v'

notation:40 e:40 " ≲(" n:40 ")⟨" env:40 ", " env':40 "⟩ " e':40 => Expr.Approx.Param.Indexed n env env' e e'

syntax:100 expr:100 ppSpace expr:101 : expr

syntax:50 expr:50 " + " expr:51 : expr

syntax:50 expr:50 " - " expr:50 : expr

syntax:60 expr:60 " * " expr:61 : expr

syntax:60 expr:60 " / " expr:60 : expr

syntax "case " expr " of " cases " end" : expr

notation:40 v:40 " ≲ₒ'(" n:40 ") " v':40 => Object.Approx.Indexed' n v v'

notation:40 env₁:40 " ≲ₑ'(" n:40 ") " env₂:40 => Env.Approx.Indexed' n env₁ env₂

macro "invert" h:term : tactic => `(tactic| (cases ($h).invert <;> try clear $h))

macro_rules
  | `(⟪$s:ident ♯ $i:num⟫) => `(Expr.var $(Lean.Syntax.mkStrLit s.getId.toString) $i)
  | `(⟪$num:num⟫) => `(Expr.const (Constant.int $num))
  | `(⟪$s:str⟫) => `(Expr.const (Constant.string $s))
  | `(⟪υ⟫) => `(Expr.unit)
  | `(⟪$e₁:expr $e₂:expr⟫) => `(Expr.app ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪λ $s:ident $e:expr⟫) => `(Expr.lambda $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e⟫)
  | `(⟪λ $ss:ident* . $e:expr⟫) => mkLambdas ss e
  | `(⟪ $s:ident ⟫) => `(Expr.constr $(Lean.Syntax.mkStrLit s.getId.toString))
  | `(⟪ $s:ident $es:expr* ⟫) => mkConstrApp s es
  | `(⟪$e₁ + $e₂⟫) => `(Expr.binop BinaryOp.add_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ - $e₂⟫) => `(Expr.binop BinaryOp.sub_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ * $e₂⟫) => `(Expr.binop BinaryOp.mul_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ / $e₂⟫) => `(Expr.binop BinaryOp.div_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪let $s:ident := $e₁:expr in $e₂:expr⟫) => `(Expr.save $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪letrec $s:ident := $e₁:expr in $e₂:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.save $name (Expr.recur $name ⟪$e₁⟫) ⟪$e₂⟫)
  | `(⟪rec $s:ident $e:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.recur $name ⟪$e⟫)
  | `(⟪⊥⟫) => `(Expr.fail)
  | `(⟪cases| | $s:ident => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ Expr.fail)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ Expr.fail)
  | `(⟪cases| | _ => $e:expr ⟫) =>
    `(⟪$e⟫)
  | `(⟪case $e:expr of $cs:cases end⟫) => do
    `(Expr.save "_case_" ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪($e)⟫) => `(⟪$e⟫)

Expr

inductive Expr : Type where
  | var : (name : String) → (index : Nat) → Expr
  | unit : Expr
  | const : Constant → Expr
  | constr : Name → Expr
  | app : Expr → Expr → Expr
  | constr_app : Expr → Expr → Expr
  | binop : (oper : BinaryOp) → (arg₁ arg₂ : Expr) → Expr
  | lambda : (var_name : String) → (body : Expr) → Expr
  | save : (var_name : String) → (value : Expr) → (body : Expr) → Expr
  | branch : (constr : Name) → (var_names : List Name) → (body : Expr) → (next : Expr) → Expr
  | recur : (var_name : Name) → (body : Expr) → Expr
  | fail : Expr
  deriving Inhabited, BEq, DecidableEq

Expr.Approx

def Expr.Approx (e₁ e₂ : Expr) : Prop :=
  ∀ env₁ env₂, env₁ ≲ₑ env₂ → e₁ ≲⟨env₁, env₂⟩ e₂

Constant

inductive Constant : Type where
  | int : Int → Constant
  | string : String → Constant
  deriving Inhabited, BEq, DecidableEq

def eval_binop_int (op : BinaryOp) (i₁ i₂ : Int) : Int :=
  match op with
  | BinaryOp.add_int => i₁ + i₂
  | BinaryOp.sub_int => i₁ - i₂
  | BinaryOp.mul_int => i₁ * i₂
  | BinaryOp.div_int => i₁ / i₂

BinaryOp

inductive BinaryOp : Type where
  | add_int : BinaryOp
  | sub_int : BinaryOp
  | mul_int : BinaryOp
  | div_int : BinaryOp
  deriving Inhabited, BEq, DecidableEq

  inductive Value : Type where
    | unit : Value
    | const : Constant → Value
    | constr_app : (constr : Name) → (args_rev : List Value) → Value
    | closure : (env : List Object) → (value : Expr) → Value
    deriving Inhabited

Value.Approx

def Value.Approx (v v' : Value) : Prop :=
  ∀ n, v ≲ᵥ(n) v'

Env.Approx

def Env.Approx : (env₁ env₂ : Env) → Prop :=
  List.Forall₂ Object.Approx

Object.Approx

inductive Object.Approx : Object → Object → Prop where
  | value {v₁ v₂} : v₁ ≲ᵥ v₂ → Object.Approx (Object.value v₁) (Object.value v₂)
  | delayed {env₁ env₂ e₁ e₂} :
    e₁ ≲⟨env₁, env₂⟩ e₂ →
    Object.Approx (Object.delayed env₁ e₁) (Object.delayed env₂ e₂)

  inductive Object : Type where
    | value : Value → Object
    | delayed : (env : List Object) → Expr → Object
    deriving Inhabited

Value.Approx.Indexed

def Value.Approx.Indexed (n : Nat) (v₁ v₂ : Value) : Prop :=
  (v₁ = Value.unit ∧ v₂ = Value.unit) ∨
  (∃ c, v₁ = Value.const c ∧ v₂ = Value.const c) ∨
  (∃ ctr_name args_rev args_rev',
    v₁ = Value.constr_app ctr_name args_rev ∧
    v₂ = Value.constr_app ctr_name args_rev' ∧
    (∀ k < n, List.Forall₂ (Value.Approx.Indexed k) args_rev args_rev')) ∨
  (∃ env₁ body₁ env₂ body₂,
    v₁ = Value.closure env₁ body₁ ∧
    v₂ = Value.closure env₂ body₂ ∧
    (∀ n₁ n₂, n₁ + n₂ < n →
      ∀ a₁ a₂ r₁,
        Value.Approx.Indexed (n₁ + n₂) a₁ a₂ →
        a₁ ∷ env₁ ⊢ body₁ ↦(n₁) r₁ →
        ∃ r₂,
          a₂ ∷ env₂ ⊢ body₂ ↦ r₂ ∧
          Value.Approx.Indexed n₂ r₁ r₂))

abbrev cons_value (v : Value) (env : Env) : Env := Object.value v :: env

Name

abbrev Name : Type := String

Env

abbrev Env : Type := List Object

Env.Approx.Indexed'

def Env.Approx.Indexed' (n : Nat) : (env₁ env₂ : Env) → Prop :=
  List.Forall₂ (Object.Approx.Indexed' n)

Object.Approx.Indexed'

inductive Object.Approx.Indexed' (n : Nat) : Object → Object → Prop where
  | value {v₁ v₂} :
    v₁ ≲ᵥ(n) v₂ →
    Object.Approx.Indexed' n (Object.value v₁) (Object.value v₂)
  | delayed {env₁ env₂ e₁ e₂} :
    e₁ ≲(n)⟨env₁, env₂⟩ e₂ →
    Object.Approx.Indexed' n (Object.delayed env₁ e₁) (Object.delayed env₂ e₂)
  | delayed_eq {env₁ env₂ e} :
    List.Forall₂ (Object.Approx.Indexed' n) env₁ env₂ →
    Object.Approx.Indexed' n (Object.delayed env₁ e) (Object.delayed env₂ e)

Eval.Indexed

inductive Eval.Indexed : Nat → Env → Expr → Value → Prop where
  | var {n env name idx val} :
    env[idx]? = some (Object.value val) →
    Eval.Indexed n env (Expr.var name idx) val
  | var_rec {n env name idx env' expr val} :
    env[idx]? = some (Object.delayed env' expr) →
    Eval.Indexed n env' expr val →
    Eval.Indexed n env (Expr.var name idx) val
  | unit {n env} :
    Eval.Indexed n env Expr.unit Value.unit
  | const {n env c} :
    Eval.Indexed n env (Expr.const c) (Value.const c)
  | constr {n env name} :
    Eval.Indexed n env (Expr.constr name) (Value.constr_app name [])
  | app {n n₁ n₂ env env' f body arg val val'} :
    n₁ + n₂ + 1 ≤ n →
    Eval.Indexed n₁ env f (Value.closure env' body) →
    Eval.Indexed (n₁ + 1) env arg val →
    Eval.Indexed n₂ (val ∷ env') body val' →
    Eval.Indexed n env (Expr.app f arg) val'
  | constr_app {n n' env ctr ctr_name ctr_args_rev arg val} :
    n' < n →
    Eval.Indexed n env ctr (Value.constr_app ctr_name ctr_args_rev) →
    Eval.Indexed n' env arg val →
    Eval.Indexed n env (Expr.constr_app ctr arg) (Value.constr_app ctr_name (val :: ctr_args_rev))
  | binop {n env op arg₁ arg₂ val₁ val₂} :
    Eval.Indexed n env arg₁ (Value.const (Constant.int val₁)) →
    Eval.Indexed n env arg₂ (Value.const (Constant.int val₂)) →
    Eval.Indexed n env (Expr.binop op arg₁ arg₂) (Value.const (Constant.int (eval_binop_int op val₁ val₂)))
  | lambda {n env name body} :
    Eval.Indexed n env (Expr.lambda name body) (Value.closure env body)
  | save {n n₁ n₂ env name value body val val'} :
    n₁ + n₂ ≤ n →
    Eval.Indexed n₁ env value val →
    Eval.Indexed n₂ (val ∷ env) body val' →
    Eval.Indexed n env (Expr.save name value body) val'
  | branch_matches {n n' env name args_rev body val} :
    n' < n →
    Eval.Indexed n' (args_rev.map Object.value ++ env) body val →
    Eval.Indexed n (Value.constr_app name args_rev ∷ env) (Expr.branch name _ body _) val
  | branch_fails {n env name name' args_rev next val} :
    name ≠ name' →
    Eval.Indexed n (Value.constr_app name args_rev ∷ env) next val →
    Eval.Indexed n (Value.constr_app name args_rev ∷ env) (Expr.branch name' _ _ next) val
  | recur {n n' env name body val} :
    n' < n →
    Eval.Indexed n' (Object.delayed env (Expr.recur name body) :: env) body val →
    Eval.Indexed n env (Expr.recur name body) val

Eval

@[aesop unsafe constructors]
inductive Eval : Env → Expr → Value → Prop where
  | var {env name idx val} :
    env[idx]? = some (Object.value val) →
    Eval env (Expr.var name idx) val
  | var_rec {env name idx env' expr val} :
    env[idx]? = some (Object.delayed env' expr) →
    Eval env' expr val →
    Eval env (Expr.var name idx) val
  | unit {env} :
    Eval env Expr.unit Value.unit
  | const {env c} :
    Eval env (Expr.const c) (Value.const c)
  | constr {env name} :
    Eval env (Expr.constr name) (Value.constr_app name [])
  | app {env env' f body arg val val'} :
    Eval env f (Value.closure env' body) →
    Eval env arg val →
    Eval (val ∷ env') body val' →
    Eval env (Expr.app f arg) val'
  | constr_app {env ctr ctr_name ctr_args_rev arg val} :
    Eval env ctr (Value.constr_app ctr_name ctr_args_rev) →
    Eval env arg val →
    Eval env (Expr.constr_app ctr arg) (Value.constr_app ctr_name (val :: ctr_args_rev))
  | binop {env op arg₁ arg₂ val₁ val₂} :
    Eval env arg₁ (Value.const (Constant.int val₁)) →
    Eval env arg₂ (Value.const (Constant.int val₂)) →
    Eval env (Expr.binop op arg₁ arg₂) (Value.const (Constant.int (eval_binop_int op val₁ val₂)))
  | lambda {env name body} :
    Eval env (Expr.lambda name body) (Value.closure env body)
  | save {env name value body val val'} :
    Eval env value val →
    Eval (val ∷ env) body val' →
    Eval env (Expr.save name value body) val'
  | branch_matches {env name args_rev body val} :
    Eval (args_rev.map Object.value ++ env) body val →
    Eval (Value.constr_app name args_rev ∷ env) (Expr.branch name _ body _) val
  | branch_fails {env name name' args_rev next val} :
    name ≠ name' →
    Eval (Value.constr_app name args_rev ∷ env) next val →
    Eval (Value.constr_app name args_rev ∷ env) (Expr.branch name' _ _ next) val
  | recur {env name body val} :
    Eval (Object.delayed env (Expr.recur name body) :: env) body val →
    Eval env (Expr.recur name body) val

infixr:50 " ∷ " => cons_value

notation:40 v:40 " ≲ₒ " v':40 => Object.Approx v v'

notation:40 env₁:40 " ≲ₑ " env₂:40 => Env.Approx env₁ env₂

infixl:100 " @@ " => Expr.app

lemma Expr.Approx.eval_const₁ {op a₁ a₂ i₁ i₂ i₃} :
  a₁ ≲ Expr.const (Constant.int i₁) →
  a₂ ≲ Expr.const (Constant.int i₂) →
  i₃ = eval_binop_int op i₁ i₂ →
  Expr.binop op a₁ a₂ ≲
    Expr.const (Constant.int i₃)

lemma Expr.Approx.const_right {c e env v} :
  e ≲ Expr.const c →
  env ⊢ e ↦ v →
  v = Value.const c

Expr.Approx.preservation

lemma Expr.Approx.preservation {e₁ e₂} :
  e₁ ≲ e₂ ↔
  ∀ env v₁, env ⊢ e₁ ↦ v₁ → ∃ v₂, env ⊢ e₂ ↦ v₂ ∧ v₁ ≲ᵥ v₂

lemma Expr.Approx.to_preservation {e₁ e₂} :
  e₁ ≲ e₂ →
  ∀ env v₁, env ⊢ e₁ ↦ v₁ → ∃ v₂, env ⊢ e₂ ↦ v₂ ∧ v₁ ≲ᵥ v₂

lemma Expr.Approx.from_preservation {e₁ e₂}
  (h : ∀ env v₁, env ⊢ e₁ ↦ v₁ → ∃ v₂, env ⊢ e₂ ↦ v₂ ∧ v₁ ≲ᵥ v₂)
  : e₁ ≲ e₂

Value.Approx.preserved

theorem Value.Approx.preserved :
  ∀ env env' e v,
    env ≲ₑ env' →
    env ⊢ e ↦ v →
    ∃ v', env' ⊢ e ↦ v' ∧ v ≲ᵥ v'

Env.Approx.toIndexed

lemma Env.Approx.toIndexed {env₁ env₂} : env₁ ≲ₑ env₂ → ∀ n, env₁ ≲ₑ'(n) env₂

Object.Approx.toIndexed

lemma Object.Approx.toIndexed {o₁ o₂} : o₁ ≲ₒ o₂ → ∀ n, o₁ ≲ₒ'(n) o₂

Env.Approx.cons

lemma Env.Approx.cons {env₁ env₂ o₁ o₂} :
  o₁ ≲ₒ o₂ → env₁ ≲ₑ env₂ → (o₁ :: env₁) ≲ₑ (o₂ :: env₂)

lemma Expr.Approx.eval_const₂ {op a₁ a₂ i₁ i₂ i₃} :
  Expr.const (Constant.int i₁) ≲ a₁ →
  Expr.const (Constant.int i₂) ≲ a₂ →
  i₃ = eval_binop_int op i₁ i₂ →
  Expr.const (Constant.int i₃) ≲
  Expr.binop op a₁ a₂

lemma Expr.Approx.const_left {c e env} :
  Expr.const c ≲ e →
  env ⊢ e ↦ Value.const c

Expr.Approx.const

lemma Expr.Approx.const {c₁ c₂} :
  Expr.const c₁ ≲ Expr.const c₂ →
  c₁ = c₂

Juvix.Core.Main.Expr.Equiv

import Juvix.Core.Main.Semantics.Approx

namespace Juvix.Core.Main

notation:40 v:40 " ≈ᵥ " v':40 => Value.Equiv v v'

notation:40 args₁:40 " ≈ₐ " args₂:40 => List.Forall₂ Value.Equiv args₁ args₂

notation:40 v:40 " ≈ₒ " v':40 => Object.Equiv v v'

notation:40 env₁:40 " ≈ₑ " env₂:40 => Env.Equiv env₁ env₂

notation:40 e₁:40 " ≈⟨" env₁:40 ", " env₂:40 "⟩ " e₂:40 => Expr.Equiv.Param env₁ env₂ e₁ e₂

def Expr.Equiv (e₁ e₂ : Expr) : Prop :=
  e₁ ≲ e₂ ∧ e₂ ≲ e₁

notation:40 e₁:40 " ≈ " e₂:40 => Expr.Equiv e₁ e₂

lemma Expr.Equiv.eval_const {op a₁ a₂ i₁ i₂ i₃} :
  a₁ ≈ Expr.const (Constant.int i₁) →
  a₂ ≈ Expr.const (Constant.int i₂) →
  i₃ = eval_binop_int op i₁ i₂ →
  Expr.binop op a₁ a₂ ≈
    Expr.const (Constant.int i₃) :=

:= by
  simp only [Expr.Equiv]
  intro h₁ h₂ h₃
  constructor
  · apply Expr.Approx.eval_const₁ (op := op) (i₁ := i₁) (i₂ := i₂) <;>
      simp_all only
  · apply Expr.Approx.eval_const₂ (op := op) (i₁ := i₁) (i₂ := i₂) <;>
      simp_all only


notation:40 env₁:40 " ≲ₑ'(" n:40 ") " env₂:40 => Env.Approx.Indexed' n env₁ env₂

syntax "case " expr " of " cases " end" : expr

macro_rules
  | `(⟪$s:ident ♯ $i:num⟫) => `(Expr.var $(Lean.Syntax.mkStrLit s.getId.toString) $i)
  | `(⟪$num:num⟫) => `(Expr.const (Constant.int $num))
  | `(⟪$s:str⟫) => `(Expr.const (Constant.string $s))
  | `(⟪υ⟫) => `(Expr.unit)
  | `(⟪$e₁:expr $e₂:expr⟫) => `(Expr.app ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪λ $s:ident $e:expr⟫) => `(Expr.lambda $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e⟫)
  | `(⟪λ $ss:ident* . $e:expr⟫) => mkLambdas ss e
  | `(⟪ $s:ident ⟫) => `(Expr.constr $(Lean.Syntax.mkStrLit s.getId.toString))
  | `(⟪ $s:ident $es:expr* ⟫) => mkConstrApp s es
  | `(⟪$e₁ + $e₂⟫) => `(Expr.binop BinaryOp.add_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ - $e₂⟫) => `(Expr.binop BinaryOp.sub_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ * $e₂⟫) => `(Expr.binop BinaryOp.mul_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ / $e₂⟫) => `(Expr.binop BinaryOp.div_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪let $s:ident := $e₁:expr in $e₂:expr⟫) => `(Expr.save $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪letrec $s:ident := $e₁:expr in $e₂:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.save $name (Expr.recur $name ⟪$e₁⟫) ⟪$e₂⟫)
  | `(⟪rec $s:ident $e:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.recur $name ⟪$e⟫)
  | `(⟪⊥⟫) => `(Expr.fail)
  | `(⟪cases| | $s:ident => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ Expr.fail)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ Expr.fail)
  | `(⟪cases| | _ => $e:expr ⟫) =>
    `(⟪$e⟫)
  | `(⟪case $e:expr of $cs:cases end⟫) => do
    `(Expr.save "_case_" ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪($e)⟫) => `(⟪$e⟫)

  inductive Object : Type where
    | value : Value → Object
    | delayed : (env : List Object) → Expr → Object
    deriving Inhabited

Object.Approx

inductive Object.Approx : Object → Object → Prop where
  | value {v₁ v₂} : v₁ ≲ᵥ v₂ → Object.Approx (Object.value v₁) (Object.value v₂)
  | delayed {env₁ env₂ e₁ e₂} :
    e₁ ≲⟨env₁, env₂⟩ e₂ →
    Object.Approx (Object.delayed env₁ e₁) (Object.delayed env₂ e₂)

Env.Approx

def Env.Approx : (env₁ env₂ : Env) → Prop :=
  List.Forall₂ Object.Approx

BinaryOp

inductive BinaryOp : Type where
  | add_int : BinaryOp
  | sub_int : BinaryOp
  | mul_int : BinaryOp
  | div_int : BinaryOp
  deriving Inhabited, BEq, DecidableEq

Expr

inductive Expr : Type where
  | var : (name : String) → (index : Nat) → Expr
  | unit : Expr
  | const : Constant → Expr
  | constr : Name → Expr
  | app : Expr → Expr → Expr
  | constr_app : Expr → Expr → Expr
  | binop : (oper : BinaryOp) → (arg₁ arg₂ : Expr) → Expr
  | lambda : (var_name : String) → (body : Expr) → Expr
  | save : (var_name : String) → (value : Expr) → (body : Expr) → Expr
  | branch : (constr : Name) → (var_names : List Name) → (body : Expr) → (next : Expr) → Expr
  | recur : (var_name : Name) → (body : Expr) → Expr
  | fail : Expr
  deriving Inhabited, BEq, DecidableEq

Constant

inductive Constant : Type where
  | int : Int → Constant
  | string : String → Constant
  deriving Inhabited, BEq, DecidableEq

notation:40 v:40 " ≲ₒ " v':40 => Object.Approx v v'

notation:40 env₁:40 " ≲ₑ " env₂:40 => Env.Approx env₁ env₂

infixl:100 " @@ " => Expr.app

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

Juvix.Core.Main.Env.Approx.Indexed'

import Juvix.Core.Main.Semantics.Eval

import Juvix.Core.Main.Semantics.Eval.Indexed

import Juvix.Utils

import Mathlib.Tactic.Linarith

import Mathlib.Data.List.Forall2

import Aesop

namespace Juvix.Core.Main

notation:40 v:40 " ≲ᵥ(" n:40 ") " v':40 => Value.Approx.Indexed n v v'

notation:40 args₁:40 " ≲ₐ(" n:40 ") " args₂:40 => List.Forall₂ (Value.Approx.Indexed n) args₁ args₂

notation:40 e:40 " ≲(" n:40 ")⟨" env:40 ", " env':40 "⟩ " e':40 => Expr.Approx.Param.Indexed n env env' e e'

inductive Object.Approx.Indexed' (n : Nat) : Object → Object → Prop where
  | value {v₁ v₂} :
    v₁ ≲ᵥ(n) v₂ →
    Object.Approx.Indexed' n (Object.value v₁) (Object.value v₂)
  | delayed {env₁ env₂ e₁ e₂} :
    e₁ ≲(n)⟨env₁, env₂⟩ e₂ →
    Object.Approx.Indexed' n (Object.delayed env₁ e₁) (Object.delayed env₂ e₂)
  | delayed_eq {env₁ env₂ e} :
    List.Forall₂ (Object.Approx.Indexed' n) env₁ env₂ →
    Object.Approx.Indexed' n (Object.delayed env₁ e) (Object.delayed env₂ e)

def Env.Approx.Indexed' (n : Nat) : (env₁ env₂ : Env) → Prop :=
  List.Forall₂ (Object.Approx.Indexed' n)

notation:40 v:40 " ≲ₒ'(" n:40 ") " v':40 => Object.Approx.Indexed' n v v'

notation:40 env₁:40 " ≲ₑ'(" n:40 ") " env₂:40 => Env.Approx.Indexed' n env₁ env₂

notation:40 e:40 " ≲'(" n:40 ") " e':40 => Expr.Approx.Indexed' n e e'

lemma Env.Approx.Indexed'.from_delayed {n env₁ env₂ l} (h : env₁ ≲ₑ'(n) env₂) :
  List.map (Object.delayed env₁) l ≲ₑ'(n) List.map (Object.delayed env₂) l :=

:= by
  induction l
  case nil =>
    exact List.Forall₂.nil
  case cons e l' h' =>
    simp
    apply List.Forall₂.cons
    · apply Object.Approx.Indexed'.delayed_eq
      assumption
    · assumption


syntax:100 expr:100 ppSpace expr:101 : expr

syntax:50 expr:50 " + " expr:51 : expr

syntax:50 expr:50 " - " expr:50 : expr

syntax:60 expr:60 " * " expr:61 : expr

syntax:60 expr:60 " / " expr:60 : expr

notation:40 env:40 " ⊢ " e:40 " ↦ " v:40 => Eval env e v

notation:40 env:40 " ⊢ " e:40 " ↓" => Eval.Defined env e

notation:40 env:40 " ⊢ " e:40 " ↦(" n ") " v:40 => Eval.Indexed n env e v

macro_rules
  | `(⟪$s:ident ♯ $i:num⟫) => `(Expr.var $(Lean.Syntax.mkStrLit s.getId.toString) $i)
  | `(⟪$num:num⟫) => `(Expr.const (Constant.int $num))
  | `(⟪$s:str⟫) => `(Expr.const (Constant.string $s))
  | `(⟪υ⟫) => `(Expr.unit)
  | `(⟪$e₁:expr $e₂:expr⟫) => `(Expr.app ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪λ $s:ident $e:expr⟫) => `(Expr.lambda $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e⟫)
  | `(⟪λ $ss:ident* . $e:expr⟫) => mkLambdas ss e
  | `(⟪ $s:ident ⟫) => `(Expr.constr $(Lean.Syntax.mkStrLit s.getId.toString))
  | `(⟪ $s:ident $es:expr* ⟫) => mkConstrApp s es
  | `(⟪$e₁ + $e₂⟫) => `(Expr.binop BinaryOp.add_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ - $e₂⟫) => `(Expr.binop BinaryOp.sub_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ * $e₂⟫) => `(Expr.binop BinaryOp.mul_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ / $e₂⟫) => `(Expr.binop BinaryOp.div_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪let $s:ident := $e₁:expr in $e₂:expr⟫) => `(Expr.save $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪letrec $s:ident := $e₁:expr in $e₂:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.save $name (Expr.recur $name ⟪$e₁⟫) ⟪$e₂⟫)
  | `(⟪rec $s:ident $e:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.recur $name ⟪$e⟫)
  | `(⟪⊥⟫) => `(Expr.fail)
  | `(⟪cases| | $s:ident => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ Expr.fail)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ Expr.fail)
  | `(⟪cases| | _ => $e:expr ⟫) =>
    `(⟪$e⟫)
  | `(⟪case $e:expr of $cs:cases end⟫) => do
    `(Expr.save "_case_" ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪($e)⟫) => `(⟪$e⟫)

Constant

inductive Constant : Type where
  | int : Int → Constant
  | string : String → Constant
  deriving Inhabited, BEq, DecidableEq

  inductive Value : Type where
    | unit : Value
    | const : Constant → Value
    | constr_app : (constr : Name) → (args_rev : List Value) → Value
    | closure : (env : List Object) → (value : Expr) → Value
    deriving Inhabited

Eval

@[aesop unsafe constructors]
inductive Eval : Env → Expr → Value → Prop where
  | var {env name idx val} :
    env[idx]? = some (Object.value val) →
    Eval env (Expr.var name idx) val
  | var_rec {env name idx env' expr val} :
    env[idx]? = some (Object.delayed env' expr) →
    Eval env' expr val →
    Eval env (Expr.var name idx) val
  | unit {env} :
    Eval env Expr.unit Value.unit
  | const {env c} :
    Eval env (Expr.const c) (Value.const c)
  | constr {env name} :
    Eval env (Expr.constr name) (Value.constr_app name [])
  | app {env env' f body arg val val'} :
    Eval env f (Value.closure env' body) →
    Eval env arg val →
    Eval (val ∷ env') body val' →
    Eval env (Expr.app f arg) val'
  | constr_app {env ctr ctr_name ctr_args_rev arg val} :
    Eval env ctr (Value.constr_app ctr_name ctr_args_rev) →
    Eval env arg val →
    Eval env (Expr.constr_app ctr arg) (Value.constr_app ctr_name (val :: ctr_args_rev))
  | binop {env op arg₁ arg₂ val₁ val₂} :
    Eval env arg₁ (Value.const (Constant.int val₁)) →
    Eval env arg₂ (Value.const (Constant.int val₂)) →
    Eval env (Expr.binop op arg₁ arg₂) (Value.const (Constant.int (eval_binop_int op val₁ val₂)))
  | lambda {env name body} :
    Eval env (Expr.lambda name body) (Value.closure env body)
  | save {env name value body val val'} :
    Eval env value val →
    Eval (val ∷ env) body val' →
    Eval env (Expr.save name value body) val'
  | branch_matches {env name args_rev body val} :
    Eval (args_rev.map Object.value ++ env) body val →
    Eval (Value.constr_app name args_rev ∷ env) (Expr.branch name _ body _) val
  | branch_fails {env name name' args_rev next val} :
    name ≠ name' →
    Eval (Value.constr_app name args_rev ∷ env) next val →
    Eval (Value.constr_app name args_rev ∷ env) (Expr.branch name' _ _ next) val
  | recur {env name body val} :
    Eval (Object.delayed env (Expr.recur name body) :: env) body val →
    Eval env (Expr.recur name body) val

def eval_binop_int (op : BinaryOp) (i₁ i₂ : Int) : Int :=
  match op with
  | BinaryOp.add_int => i₁ + i₂
  | BinaryOp.sub_int => i₁ - i₂
  | BinaryOp.mul_int => i₁ * i₂
  | BinaryOp.div_int => i₁ / i₂

abbrev cons_value (v : Value) (env : Env) : Env := Object.value v :: env

  inductive Object : Type where
    | value : Value → Object
    | delayed : (env : List Object) → Expr → Object
    deriving Inhabited

Name

abbrev Name : Type := String

Env

abbrev Env : Type := List Object

infixr:50 " ∷ " => cons_value

infixl:100 " @@ " => Expr.app

import Juvix.Core.Main.Tactics.Base

namespace Juvix.Core.Main

lemma Termination.binop {env op e₁ e₂ c₁ c₂} :
  env ⊢ e₁ ↦ Value.const (Constant.int c₁) →
  env ⊢ e₂ ↦ Value.const (Constant.int c₂) →
  env ⊢ Expr.binop op e₁ e₂ ↓ :=

:= by
  intro h₁ h₂
  constructor
  apply Juvix.Core.Main.Eval.binop
  · assumption
  · assumption


notation:40 v:40 " ≲ᵥ(" n:40 ") " v':40 => Value.Approx.Indexed n v v'

macro "invert" h:term : tactic => `(tactic| (cases ($h).invert <;> try clear $h))

notation:40 args₁:40 " ≲ₐ(" n:40 ") " args₂:40 => List.Forall₂ (Value.Approx.Indexed n) args₁ args₂

syntax "case " expr " of " cases " end" : expr

macro_rules
  | `(⟪$s:ident ♯ $i:num⟫) => `(Expr.var $(Lean.Syntax.mkStrLit s.getId.toString) $i)
  | `(⟪$num:num⟫) => `(Expr.const (Constant.int $num))
  | `(⟪$s:str⟫) => `(Expr.const (Constant.string $s))
  | `(⟪υ⟫) => `(Expr.unit)
  | `(⟪$e₁:expr $e₂:expr⟫) => `(Expr.app ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪λ $s:ident $e:expr⟫) => `(Expr.lambda $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e⟫)
  | `(⟪λ $ss:ident* . $e:expr⟫) => mkLambdas ss e
  | `(⟪ $s:ident ⟫) => `(Expr.constr $(Lean.Syntax.mkStrLit s.getId.toString))
  | `(⟪ $s:ident $es:expr* ⟫) => mkConstrApp s es
  | `(⟪$e₁ + $e₂⟫) => `(Expr.binop BinaryOp.add_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ - $e₂⟫) => `(Expr.binop BinaryOp.sub_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ * $e₂⟫) => `(Expr.binop BinaryOp.mul_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ / $e₂⟫) => `(Expr.binop BinaryOp.div_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪let $s:ident := $e₁:expr in $e₂:expr⟫) => `(Expr.save $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪letrec $s:ident := $e₁:expr in $e₂:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.save $name (Expr.recur $name ⟪$e₁⟫) ⟪$e₂⟫)
  | `(⟪rec $s:ident $e:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.recur $name ⟪$e⟫)
  | `(⟪⊥⟫) => `(Expr.fail)
  | `(⟪cases| | $s:ident => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ Expr.fail)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ Expr.fail)
  | `(⟪cases| | _ => $e:expr ⟫) =>
    `(⟪$e⟫)
  | `(⟪case $e:expr of $cs:cases end⟫) => do
    `(Expr.save "_case_" ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪($e)⟫) => `(⟪$e⟫)

  inductive Object : Type where
    | value : Value → Object
    | delayed : (env : List Object) → Expr → Object
    deriving Inhabited

abbrev Env : Type := List Object

  inductive Value : Type where
    | unit : Value
    | const : Constant → Value
    | constr_app : (constr : Name) → (args_rev : List Value) → Value
    | closure : (env : List Object) → (value : Expr) → Value
    deriving Inhabited

Constant

inductive Constant : Type where
  | int : Int → Constant
  | string : String → Constant
  deriving Inhabited, BEq, DecidableEq

Expr

inductive Expr : Type where
  | var : (name : String) → (index : Nat) → Expr
  | unit : Expr
  | const : Constant → Expr
  | constr : Name → Expr
  | app : Expr → Expr → Expr
  | constr_app : Expr → Expr → Expr
  | binop : (oper : BinaryOp) → (arg₁ arg₂ : Expr) → Expr
  | lambda : (var_name : String) → (body : Expr) → Expr
  | save : (var_name : String) → (value : Expr) → (body : Expr) → Expr
  | branch : (constr : Name) → (var_names : List Name) → (body : Expr) → (next : Expr) → Expr
  | recur : (var_name : Name) → (body : Expr) → Expr
  | fail : Expr
  deriving Inhabited, BEq, DecidableEq

BinaryOp

inductive BinaryOp : Type where
  | add_int : BinaryOp
  | sub_int : BinaryOp
  | mul_int : BinaryOp
  | div_int : BinaryOp
  deriving Inhabited, BEq, DecidableEq

Name

abbrev Name : Type := String

Value.Approx.Indexed

def Value.Approx.Indexed (n : Nat) (v₁ v₂ : Value) : Prop :=
  (v₁ = Value.unit ∧ v₂ = Value.unit) ∨
  (∃ c, v₁ = Value.const c ∧ v₂ = Value.const c) ∨
  (∃ ctr_name args_rev args_rev',
    v₁ = Value.constr_app ctr_name args_rev ∧
    v₂ = Value.constr_app ctr_name args_rev' ∧
    (∀ k < n, List.Forall₂ (Value.Approx.Indexed k) args_rev args_rev')) ∨
  (∃ env₁ body₁ env₂ body₂,
    v₁ = Value.closure env₁ body₁ ∧
    v₂ = Value.closure env₂ body₂ ∧
    (∀ n₁ n₂, n₁ + n₂ < n →
      ∀ a₁ a₂ r₁,
        Value.Approx.Indexed (n₁ + n₂) a₁ a₂ →
        a₁ ∷ env₁ ⊢ body₁ ↦(n₁) r₁ →
        ∃ r₂,
          a₂ ∷ env₂ ⊢ body₂ ↦ r₂ ∧
          Value.Approx.Indexed n₂ r₁ r₂))

abbrev cons_value (v : Value) (env : Env) : Env := Object.value v :: env

Value.Approx.Indexed.Inversion

@[aesop safe cases]
inductive Value.Approx.Indexed.Inversion (n : Nat) : Value → Value → Prop where
  | unit : Value.Approx.Indexed.Inversion n Value.unit Value.unit
  | const {c} : Value.Approx.Indexed.Inversion n (Value.const c) (Value.const c)
  | constr_app {ctr_name args_rev args_rev'} :
    (∀ k < n, args_rev ≲ₐ(k) args_rev') →
    Value.Approx.Indexed.Inversion n (Value.constr_app ctr_name args_rev) (Value.constr_app ctr_name args_rev')
  | closure {env₁ body₁ env₂ body₂} :
    (∀ n₁ n₂, n₁ + n₂ < n →
      ∀ a₁ a₂ v₁,
        a₁ ≲ᵥ(n₁ + n₂) a₂ →
        a₁ ∷ env₁ ⊢ body₁ ↦(n₁) v₁ →
        ∃ v₂, a₂ ∷ env₂ ⊢ body₂ ↦ v₂ ∧ v₁ ≲ᵥ(n₂) v₂) →
    Value.Approx.Indexed.Inversion n (Value.closure env₁ body₁) (Value.closure env₂ body₂)

infixr:50 " ∷ " => cons_value

infixl:100 " @@ " => Expr.app

Value.Approx.Indexed.invert

@[aesop unsafe destruct]
lemma Value.Approx.Indexed.invert {n v v'} :
  v ≲ᵥ(n) v' →
  Value.Approx.Indexed.Inversion n v v'

@[aesop unsafe apply]
lemma Value.Approx.Indexed.constr_app {n ctr_name args_rev args_rev'} :
    (∀ k < n, args_rev ≲ₐ(k) args_rev') →
    Value.constr_app ctr_name args_rev ≲ᵥ(n) Value.constr_app ctr_name args_rev'

Value.Approx.Indexed.unit

@[aesop unsafe apply]
lemma Value.Approx.Indexed.unit {n} : Value.unit ≲ᵥ(n) Value.unit

Value.Approx.Indexed.const

@[aesop unsafe apply]
lemma Value.Approx.Indexed.const {n c} : Value.const c ≲ᵥ(n) Value.const c

Value.Approx.Indexed.closure

@[aesop unsafe apply]
lemma Value.Approx.Indexed.closure {n env₁ body₁ env₂ body₂} :
    (∀ n₁ n₂, n₁ + n₂ < n →
      ∀ a₁ a₂ v₁,
        a₁ ≲ᵥ(n₁ + n₂) a₂ →
        a₁ ∷ env₁ ⊢ body₁ ↦(n₁) v₁ →
        ∃ v₂, a₂ ∷ env₂ ⊢ body₂ ↦ v₂ ∧ v₁ ≲ᵥ(n₂) v₂) →
    Value.closure env₁ body₁ ≲ᵥ(n) Value.closure env₂ body₂

theorem forall₂_trans' {α} {P Q R : α → α → Prop} {l₁ l₂ l₃}
  (h : ∀ x y z, P x y → Q y z → R x z)
  (h₁ : List.Forall₂ P l₁ l₂)
  (h₂ : List.Forall₂ Q l₂ l₃)
  : List.Forall₂ R l₁ l₃

Juvix.Core.Main.Value.Approx.invert

@[aesop unsafe destruct]
lemma Value.Approx.invert {v v'} :
  v ≲ᵥ v' →
  Value.Approx.Inversion v v'

@[trans]
lemma Value.Approx.Indexed.trans {n v₁ v₂ v₃} : v₁ ≲ᵥ(n) v₂ → v₂ ≲ᵥ v₃ → v₁ ≲ᵥ(n) v₃

Juvix.Core.Main.Value.Approx.trans

@[trans]
lemma Value.Approx.trans {v₁ v₂ v₃} : v₁ ≲ᵥ v₂ → v₂ ≲ᵥ v₃ → v₁ ≲ᵥ v₃

Juvix.Core.Main.Expr.Approx.Param.trans

lemma Expr.Approx.Param.trans {env₁ env₂ env₃ e₁ e₂ e₃} :
  e₁ ≲⟨env₁, env₂⟩ e₂ → e₂ ≲⟨env₂, env₃⟩ e₃ → e₁ ≲⟨env₁, env₃⟩ e₃

import Juvix.Core.Main.Semantics.Approx.Indexed

namespace Juvix.Core.Main

def Value.Approx (v v' : Value) : Prop :=
  ∀ n, v ≲ᵥ(n) v'

notation:40 v:40 " ≲ᵥ " v':40 => Value.Approx v v'

notation:40 args₁:40 " ≲ₐ " args₂:40 => List.Forall₂ Value.Approx args₁ args₂

def Expr.Approx.Param (env₁ env₂ : Env) (e₁ e₂ : Expr) : Prop :=
  (∀ v₁, env₁ ⊢ e₁ ↦ v₁ → ∃ v₂, env₂ ⊢ e₂ ↦ v₂ ∧ v₁ ≲ᵥ v₂)

notation:40 e:40 " ≲⟨" env:40 ", " env':40 "⟩ " e':40 => Expr.Approx.Param env env' e e'

inductive Object.Approx : Object → Object → Prop where
  | value {v₁ v₂} : v₁ ≲ᵥ v₂ → Object.Approx (Object.value v₁) (Object.value v₂)
  | delayed {env₁ env₂ e₁ e₂} :
    e₁ ≲⟨env₁, env₂⟩ e₂ →
    Object.Approx (Object.delayed env₁ e₁) (Object.delayed env₂ e₂)

notation:40 v:40 " ≲ₒ " v':40 => Object.Approx v v'

notation:40 env₁:40 " ≲ₑ " env₂:40 => Env.Approx env₁ env₂

def Expr.Approx (e₁ e₂ : Expr) : Prop :=
  ∀ env₁ env₂, env₁ ≲ₑ env₂ → e₁ ≲⟨env₁, env₂⟩ e₂

notation:40 e₁:40 " ≲ " e₂:40 => Expr.Approx e₁ e₂

@[aesop safe cases]
inductive Value.Approx.Inversion : Value -> Value -> Prop where
  | unit : Value.Approx.Inversion Value.unit Value.unit
  | const {c} : Value.Approx.Inversion (Value.const c) (Value.const c)
  | constr_app {ctr_name args_rev args_rev'} :
    args_rev ≲ₐ args_rev' →
    Value.Approx.Inversion (Value.constr_app ctr_name args_rev) (Value.constr_app ctr_name args_rev')
  | closure {env₁ body₁ env₂ body₂} :
    (∀ a₁ a₂, a₁ ≲ᵥ a₂ → body₁ ≲⟨a₁ ∷ env₁, a₂ ∷ env₂⟩ body₂) →
    Value.Approx.Inversion (Value.closure env₁ body₁) (Value.closure env₂ body₂)

@[trans]
lemma Object.Approx.trans {o₁ o₂ o₃} : o₁ ≲ₒ o₂ → o₂ ≲ₒ o₃ → o₁ ≲ₒ o₃ :=

:= by
  intros h₁ h₂
  cases h₁
  case value v₁ v₂ happrox =>
    cases h₂
    case value v₃ happrox' =>
      apply Object.Approx.value
      trans v₂ <;> assumption
  case delayed env₁ env₂ e₁ e₂ happrox =>
    cases h₂
    case delayed env₂' e₂' happrox' =>
      apply Object.Approx.delayed
      exact Expr.Approx.Param.trans happrox happrox'


notation:40 v:40 " ≲ᵥ(" n:40 ") " v':40 => Value.Approx.Indexed n v v'

syntax "case " expr " of " cases " end" : expr

macro_rules
  | `(⟪$s:ident ♯ $i:num⟫) => `(Expr.var $(Lean.Syntax.mkStrLit s.getId.toString) $i)
  | `(⟪$num:num⟫) => `(Expr.const (Constant.int $num))
  | `(⟪$s:str⟫) => `(Expr.const (Constant.string $s))
  | `(⟪υ⟫) => `(Expr.unit)
  | `(⟪$e₁:expr $e₂:expr⟫) => `(Expr.app ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪λ $s:ident $e:expr⟫) => `(Expr.lambda $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e⟫)
  | `(⟪λ $ss:ident* . $e:expr⟫) => mkLambdas ss e
  | `(⟪ $s:ident ⟫) => `(Expr.constr $(Lean.Syntax.mkStrLit s.getId.toString))
  | `(⟪ $s:ident $es:expr* ⟫) => mkConstrApp s es
  | `(⟪$e₁ + $e₂⟫) => `(Expr.binop BinaryOp.add_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ - $e₂⟫) => `(Expr.binop BinaryOp.sub_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ * $e₂⟫) => `(Expr.binop BinaryOp.mul_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ / $e₂⟫) => `(Expr.binop BinaryOp.div_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪let $s:ident := $e₁:expr in $e₂:expr⟫) => `(Expr.save $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪letrec $s:ident := $e₁:expr in $e₂:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.save $name (Expr.recur $name ⟪$e₁⟫) ⟪$e₂⟫)
  | `(⟪rec $s:ident $e:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.recur $name ⟪$e⟫)
  | `(⟪⊥⟫) => `(Expr.fail)
  | `(⟪cases| | $s:ident => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ Expr.fail)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ Expr.fail)
  | `(⟪cases| | _ => $e:expr ⟫) =>
    `(⟪$e⟫)
  | `(⟪case $e:expr of $cs:cases end⟫) => do
    `(Expr.save "_case_" ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪($e)⟫) => `(⟪$e⟫)

  inductive Object : Type where
    | value : Value → Object
    | delayed : (env : List Object) → Expr → Object
    deriving Inhabited

abbrev cons_value (v : Value) (env : Env) : Env := Object.value v :: env

  inductive Value : Type where
    | unit : Value
    | const : Constant → Value
    | constr_app : (constr : Name) → (args_rev : List Value) → Value
    | closure : (env : List Object) → (value : Expr) → Value
    deriving Inhabited

Expr

inductive Expr : Type where
  | var : (name : String) → (index : Nat) → Expr
  | unit : Expr
  | const : Constant → Expr
  | constr : Name → Expr
  | app : Expr → Expr → Expr
  | constr_app : Expr → Expr → Expr
  | binop : (oper : BinaryOp) → (arg₁ arg₂ : Expr) → Expr
  | lambda : (var_name : String) → (body : Expr) → Expr
  | save : (var_name : String) → (value : Expr) → (body : Expr) → Expr
  | branch : (constr : Name) → (var_names : List Name) → (body : Expr) → (next : Expr) → Expr
  | recur : (var_name : Name) → (body : Expr) → Expr
  | fail : Expr
  deriving Inhabited, BEq, DecidableEq

BinaryOp

inductive BinaryOp : Type where
  | add_int : BinaryOp
  | sub_int : BinaryOp
  | mul_int : BinaryOp
  | div_int : BinaryOp
  deriving Inhabited, BEq, DecidableEq

Constant

inductive Constant : Type where
  | int : Int → Constant
  | string : String → Constant
  deriving Inhabited, BEq, DecidableEq

Name

abbrev Name : Type := String

Env

abbrev Env : Type := List Object

infixr:50 " ∷ " => cons_value

infixl:100 " @@ " => Expr.app

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

Juvix.Core.Main.Value.Approx.refl

@[refl]
lemma Value.Approx.refl v : v ≲ᵥ v

Juvix.Core.Main.Object.Approx.refl

@[refl]
lemma Object.Approx.refl {o} : o ≲ₒ o

Juvix.Core.Main.Env.Approx.refl

@[refl]
lemma Env.Approx.refl {env} : env ≲ₑ env

Juvix.Core.Main.Env.Approx.cons

lemma Env.Approx.cons {env₁ env₂ o₁ o₂} :
  o₁ ≲ₒ o₂ → env₁ ≲ₑ env₂ → (o₁ :: env₁) ≲ₑ (o₂ :: env₂)

import Juvix.Core.Main.Semantics.Approx.Indexed

namespace Juvix.Core.Main

def Value.Approx (v v' : Value) : Prop :=
  ∀ n, v ≲ᵥ(n) v'

notation:40 v:40 " ≲ᵥ " v':40 => Value.Approx v v'

notation:40 args₁:40 " ≲ₐ " args₂:40 => List.Forall₂ Value.Approx args₁ args₂

notation:40 e:40 " ≲⟨" env:40 ", " env':40 "⟩ " e':40 => Expr.Approx.Param env env' e e'

inductive Object.Approx : Object → Object → Prop where
  | value {v₁ v₂} : v₁ ≲ᵥ v₂ → Object.Approx (Object.value v₁) (Object.value v₂)
  | delayed {env₁ env₂ e₁ e₂} :
    e₁ ≲⟨env₁, env₂⟩ e₂ →
    Object.Approx (Object.delayed env₁ e₁) (Object.delayed env₂ e₂)

def Env.Approx : (env₁ env₂ : Env) → Prop :=
  List.Forall₂ Object.Approx

notation:40 v:40 " ≲ₒ " v':40 => Object.Approx v v'

notation:40 env₁:40 " ≲ₑ " env₂:40 => Env.Approx env₁ env₂

notation:40 e₁:40 " ≲ " e₂:40 => Expr.Approx e₁ e₂

lemma Env.Approx.cons_value {v₁ v₂ env} :
  v₁ ≲ᵥ v₂ → v₁ ∷ env ≲ₑ v₂ ∷ env :=

:= by
  intro h
  apply Env.Approx.cons
  · apply Object.Approx.value
    assumption
  · apply Env.Approx.refl


syntax:100 expr:100 ppSpace expr:101 : expr

syntax:50 expr:50 " + " expr:51 : expr

syntax:50 expr:50 " - " expr:50 : expr

syntax:60 expr:60 " * " expr:61 : expr

syntax:60 expr:60 " / " expr:60 : expr

notation:40 env:40 " ⊢ " e:40 " ↦ " v:40 => Eval env e v

notation:40 env:40 " ⊢ " e:40 " ↓" => Eval.Defined env e

notation:40 env:40 " ⊢ " e:40 " ↦(" n ") " v:40 => Eval.Indexed n env e v

macro_rules
  | `(⟪$s:ident ♯ $i:num⟫) => `(Expr.var $(Lean.Syntax.mkStrLit s.getId.toString) $i)
  | `(⟪$num:num⟫) => `(Expr.const (Constant.int $num))
  | `(⟪$s:str⟫) => `(Expr.const (Constant.string $s))
  | `(⟪υ⟫) => `(Expr.unit)
  | `(⟪$e₁:expr $e₂:expr⟫) => `(Expr.app ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪λ $s:ident $e:expr⟫) => `(Expr.lambda $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e⟫)
  | `(⟪λ $ss:ident* . $e:expr⟫) => mkLambdas ss e
  | `(⟪ $s:ident ⟫) => `(Expr.constr $(Lean.Syntax.mkStrLit s.getId.toString))
  | `(⟪ $s:ident $es:expr* ⟫) => mkConstrApp s es
  | `(⟪$e₁ + $e₂⟫) => `(Expr.binop BinaryOp.add_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ - $e₂⟫) => `(Expr.binop BinaryOp.sub_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ * $e₂⟫) => `(Expr.binop BinaryOp.mul_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪$e₁ / $e₂⟫) => `(Expr.binop BinaryOp.div_int ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪let $s:ident := $e₁:expr in $e₂:expr⟫) => `(Expr.save $(Lean.Syntax.mkStrLit s.getId.toString) ⟪$e₁⟫ ⟪$e₂⟫)
  | `(⟪letrec $s:ident := $e₁:expr in $e₂:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.save $name (Expr.recur $name ⟪$e₁⟫) ⟪$e₂⟫)
  | `(⟪rec $s:ident $e:expr⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.recur $name ⟪$e⟫)
  | `(⟪⊥⟫) => `(Expr.fail)
  | `(⟪cases| | $s:ident => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr $cs:cases ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪cases| | $s:ident => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    `(Expr.branch $name [] ⟪$e⟫ Expr.fail)
  | `(⟪cases| | $s:ident $ss:ident* => $e:expr ⟫) =>
    let name := Lean.Syntax.mkStrLit s.getId.toString
    let vnames := ss.toList.map fun s => s.getId.toString
    `(Expr.branch $name $(quote vnames) ⟪$e⟫ Expr.fail)
  | `(⟪cases| | _ => $e:expr ⟫) =>
    `(⟪$e⟫)
  | `(⟪case $e:expr of $cs:cases end⟫) => do
    `(Expr.save "_case_" ⟪$e⟫ ⟪cases|$cs⟫)
  | `(⟪($e)⟫) => `(⟪$e⟫)

Eval

@[aesop unsafe constructors]
inductive Eval : Env → Expr → Value → Prop where
  | var {env name idx val} :
    env[idx]? = some (Object.value val) →
    Eval env (Expr.var name idx) val
  | var_rec {env name idx env' expr val} :
    env[idx]? = some (Object.delayed env' expr) →
    Eval env' expr val →
    Eval env (Expr.var name idx) val
  | unit {env} :
    Eval env Expr.unit Value.unit
  | const {env c} :
    Eval env (Expr.const c) (Value.const c)
  | constr {env name} :
    Eval env (Expr.constr name) (Value.constr_app name [])
  | app {env env' f body arg val val'} :
    Eval env f (Value.closure env' body) →
    Eval env arg val →
    Eval (val ∷ env') body val' →
    Eval env (Expr.app f arg) val'
  | constr_app {env ctr ctr_name ctr_args_rev arg val} :
    Eval env ctr (Value.constr_app ctr_name ctr_args_rev) →
    Eval env arg val →
    Eval env (Expr.constr_app ctr arg) (Value.constr_app ctr_name (val :: ctr_args_rev))
  | binop {env op arg₁ arg₂ val₁ val₂} :
    Eval env arg₁ (Value.const (Constant.int val₁)) →
    Eval env arg₂ (Value.const (Constant.int val₂)) →
    Eval env (Expr.binop op arg₁ arg₂) (Value.const (Constant.int (eval_binop_int op val₁ val₂)))
  | lambda {env name body} :
    Eval env (Expr.lambda name body) (Value.closure env body)
  | save {env name value body val val'} :
    Eval env value val →
    Eval (val ∷ env) body val' →
    Eval env (Expr.save name value body) val'
  | branch_matches {env name args_rev body val} :
    Eval (args_rev.map Object.value ++ env) body val →
    Eval (Value.constr_app name args_rev ∷ env) (Expr.branch name _ body _) val
  | branch_fails {env name name' args_rev next val} :
    name ≠ name' →
    Eval (Value.constr_app name args_rev ∷ env) next val →
    Eval (Value.constr_app name args_rev ∷ env) (Expr.branch name' _ _ next) val
  | recur {env name body val} :
    Eval (Object.delayed env (Expr.recur name body) :: env) body val →
    Eval env (Expr.recur name body) val

def eval_binop_int (op : BinaryOp) (i₁ i₂ : Int) : Int :=
  match op with
  | BinaryOp.add_int => i₁ + i₂
  | BinaryOp.sub_int => i₁ - i₂
  | BinaryOp.mul_int => i₁ * i₂
  | BinaryOp.div_int => i₁ / i₂

BinaryOp

inductive BinaryOp : Type where
  | add_int : BinaryOp
  | sub_int : BinaryOp
  | mul_int : BinaryOp
  | div_int : BinaryOp
  deriving Inhabited, BEq, DecidableEq

Expr

inductive Expr : Type where
  | var : (name : String) → (index : Nat) → Expr
  | unit : Expr
  | const : Constant → Expr
  | constr : Name → Expr
  | app : Expr → Expr → Expr
  | constr_app : Expr → Expr → Expr
  | binop : (oper : BinaryOp) → (arg₁ arg₂ : Expr) → Expr
  | lambda : (var_name : String) → (body : Expr) → Expr
  | save : (var_name : String) → (value : Expr) → (body : Expr) → Expr
  | branch : (constr : Name) → (var_names : List Name) → (body : Expr) → (next : Expr) → Expr
  | recur : (var_name : Name) → (body : Expr) → Expr
  | fail : Expr
  deriving Inhabited, BEq, DecidableEq

abbrev cons_value (v : Value) (env : Env) : Env := Object.value v :: env

  inductive Object : Type where
    | value : Value → Object
    | delayed : (env : List Object) → Expr → Object
    deriving Inhabited

  inductive Value : Type where
    | unit : Value
    | const : Constant → Value
    | constr_app : (constr : Name) → (args_rev : List Value) → Value
    | closure : (env : List Object) → (value : Expr) → Value
    deriving Inhabited

Constant

inductive Constant : Type where
  | int : Int → Constant
  | string : String → Constant
  deriving Inhabited, BEq, DecidableEq

Name

abbrev Name : Type := String

Env

abbrev Env : Type := List Object

infixr:50 " ∷ " => cons_value

infixl:100 " @@ " => Expr.app

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

lemma Termination.branch_matches {env name vnames args_rev e e'} :
  args_rev.map Object.value ++ env ⊢ e ↓ →
  Value.constr_app name args_rev ∷ env ⊢ Expr.branch name vnames e e' ↓ :=

:= by
  intro h
  obtain ⟨w, h⟩ := h
  constructor
  apply Juvix.Core.Main.Eval.branch_matches
  assumption


import ExprEval.Steps
import ExprEval.Lemmas
import ExprEval.Expr

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')

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

    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

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₃

BoolStepStar.refl

def BoolStepStar.refl {V: Type} (val: V -> Int) := StepStar.refl (Step := BoolStep V) val

    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

ArStepStar.trans

def ArStepStar.trans {V: Type} {val: V -> Int} e₁ e₂ e₃ := StepStar.trans e₁ e₂ e₃ (Step := ArStep V) (val := val)

ArStepStar

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

ArStepStar.refl

def ArStepStar.refl {V: Type} (val: V -> Int) := StepStar.refl (Step := ArStep V) val

BoolStepStar.trans

def BoolStepStar.trans {V: Type} {val: V -> Int} e₁ e₂ e₃ := StepStar.trans e₁ e₂ e₃ (Step := BoolStep V) (val := val)

StepKind

def StepKind (V: Type) (ExprType: Type):= (V -> Int) -> ExprType -> ExprType -> Prop

BoolStepStar.andStepLeft

theorem BoolStepStar.andStepLeft (e₁ e₁' e₂: BoolExpr V):
        BoolStepStar V val e₁ e₁' -> BoolStepStar V val
            (BoolExpr.And e₁ e₂)
            (BoolExpr.And e₁' e₂)

theorem chasles_step_star {ExprKind: Type} {Step: StepKind V ExprKind} {e₁ e₂ e₃: ExprKind}:
    StepStar (Step := Step) V val e₁ e₂  ->
        StepStar (Step := Step) V val e₂ e₃ ->
            StepStar (Step := Step) V val e₁ e₃

BoolStepStar.lessArStepStarLeft

theorem BoolStepStar.lessArStepStarLeft (e₁ e₁' e₂: ArExpr V):
        ArStepStar V val e₁ e₁' ->
            BoolStepStar V val
                (BoolExpr.Less e₁ e₂)
                (BoolExpr.Less e₁' e₂)

BoolStepStar.notStep

theorem BoolStepStar.notStep {V: Type} {val: V -> Int}
        (e e': BoolExpr V):
            BoolStepStar V val e e' -> BoolStepStar V val (BoolExpr.Not e) (BoolExpr.Not e')

BoolStepStar.lessArStepStarRight

theorem BoolStepStar.lessArStepStarRight (e₁ e₂ e₂': ArExpr V):
        ArStepStar V val e₂ e₂' ->
            BoolStepStar V val
                (BoolExpr.Less e₁ e₂)
                (BoolExpr.Less e₁ e₂')

theorem step_to_stepstar {ExprKind: Type} {Step: StepKind V ExprKind} {e e': ExprKind}:
    Step val e e' -> StepStar (Step := Step) V val e e'

BoolStepStar.eqArStepStarRight

theorem BoolStepStar.eqArStepStarRight (e₁ e₂ e₂': ArExpr V):
        ArStepStar V val e₂ e₂' ->
            BoolStepStar V val
                (BoolExpr.Eq e₁ e₂)
                (BoolExpr.Eq e₁ e₂')

BoolStepStar.eqArStepStarLeft

theorem BoolStepStar.eqArStepStarLeft (e₁ e₁' e₂: ArExpr V):
        ArStepStar V val e₁ e₁' ->
            BoolStepStar V val
                (BoolExpr.Eq e₁ e₂)
                (BoolExpr.Eq e₁' e₂)

BoolStepStar.orStepLeft

theorem BoolStepStar.orStepLeft (e₁ e₁' e₂: BoolExpr V):
        BoolStepStar V val e₁ e₁' -> BoolStepStar V val
            (BoolExpr.Or e₁ e₂)
            (BoolExpr.Or e₁' e₂)

theorem arstepstar_add_right (n: Int) (e₂ e₂': ArExpr V) :
            ArStepStar V val e₂ e₂' ->
                    ArStepStar V val
                            (ArExpr.Add (ArExpr.Const n) e₂)
                            (ArExpr.Add (ArExpr.Const n) e₂')

theorem arstepstar_sub_left (e₁ e₁' e₂: ArExpr V) :
            ArStepStar V val e₁ e₁' ->
                    ArStepStar V val
                            (ArExpr.Sub e₁ e₂)
                            (ArExpr.Sub e₁' e₂)

theorem arstepstar_add_left (e₁ e₁' e₂: ArExpr V) :
            ArStepStar V val e₁ e₁' -> ArStepStar V val (ArExpr.Add e₁ e₂) (ArExpr.Add e₁' e₂)

theorem arstepstar_sub_right (n: Int) (e₂ e₂': ArExpr V) :
            ArStepStar V val e₂ e₂' ->
                    ArStepStar V val
                            (ArExpr.Sub (ArExpr.Const n) e₂)
                            (ArExpr.Sub (ArExpr.Const n) e₂')

ArStepStar.ifStep

theorem ArStepStar.ifStep (e e': BoolExpr V) (a b: ArExpr V): BoolStepStar V val e e' ->
        ArStepStar V val (ArExpr.If e a b) (ArExpr.If e' a b)

theorem arstepstar_mul_right (n: Int) (e₂ e₂': ArExpr V) :
            ArStepStar V val e₂ e₂' ->
                    ArStepStar V val
                            (ArExpr.Mul (ArExpr.Const n) e₂)
                            (ArExpr.Mul (ArExpr.Const n) e₂')

theorem arstepstar_mul_left (e₁ e₁' e₂: ArExpr V) :
            ArStepStar V val e₁ e₁' ->
                    ArStepStar V val
                            (ArExpr.Mul e₁ e₂)
                            (ArExpr.Mul e₁' e₂)

theorem eval_completeness (e: ArExpr V) : ArStepStar V val e (ArExpr.Const (eval V val e))

import ExprEval.Steps

import ExprEval.Lemmas

variable (V: Type)

theorem eval_bool_completeness (e: BoolExpr V): BoolStepStar V val e (BoolExpr.Const (eval_bool V val e)) :=

:= by
        cases e with
        | Const b =>
            simp [eval_bool]
            apply BoolStepStar.refl
        | Not e =>
            simp [eval_bool]
            have ihn := eval_bool_completeness e (val := val)
            have h := BoolStepStar.notStep e _ ihn
            have h1 := BoolStep.notIsBoolNot (eval_bool V val e) (val := val)
            have h2 := (step_to_stepstar V h1)
            apply chasles_step_star V h h2
        | And l r =>
            have l_step := eval_bool_completeness l (val := val)
            have r_step := eval_bool_completeness r (val := val)
            simp [eval_bool]
            by_cases h: (eval_bool V val l)
            .   simp [and]
                rw [h]
                simp
                rw [h] at l_step
                have h1 := BoolStep.andLeftTrue r (val := val)
                have h2 := StepStar.trans _ _ _ h1 r_step
                have h3 := BoolStepStar.andStepLeft _ _ r l_step
                exact chasles_step_star V h3 h2

            .   replace h := eq_false_of_ne_true h
                rw [h]
                rw [h] at l_step
                simp [and]
                have h1 := BoolStepStar.andStepLeft _ _ r l_step
                have h2 := BoolStep.andLeftShortCircuit r (val := val)
                have h3 := step_to_stepstar V h2
                exact chasles_step_star V h1 h3
        | Or l r =>
            have l_step := eval_bool_completeness l (val := val)
            have r_step := eval_bool_completeness r (val := val)
            simp [eval_bool]
            by_cases h: (eval_bool V val l)
            .   rw [h]
                rw [h] at l_step
                simp [or]
                have h1 := BoolStepStar.orStepLeft _ _ r l_step
                have h2 := BoolStep.orLeftShortCircuit r (val := val)
                have h3 := step_to_stepstar V h2
                exact chasles_step_star V h1 h3

            .   replace h := eq_false_of_ne_true h
                rw [h]
                rw [h] at l_step
                simp
                have h1 := BoolStep.orLeftFalse r (val := val)
                have h2 := StepStar.trans _ _ _ h1 r_step
                have h3 := BoolStepStar.orStepLeft _ _ r l_step
                exact chasles_step_star V h3 h2
        | Eq l r =>
            simp [eval_bool]

            by_cases h: (eval V val l == eval V val r)

            .   replace h := eq_of_beq h
                rw [h]
                simp
                have h1 := BoolStep.eqConstConstTrue _ _ h (val := val)
                have hl := eval_completeness l (val := val)
                have hr := eval_completeness r (val := val)
                have h2 := BoolStepStar.eqArStepStarLeft l (ArExpr.Const (eval V val l)) r hl
                have h3 := BoolStepStar.eqArStepStarRight (ArExpr.Const (eval V val l)) r (ArExpr.Const (eval V val r)) hr
                have h4 := chasles_step_star V h2 h3
                exact chasles_step_star V h4 (step_to_stepstar V h1)

            .   replace h := eq_false_of_ne_true h
                rw [h]
                have h' := ne_of_beq_false h
                rw [<- bne_iff_ne] at h'
                have h1 := BoolStep.eqConstConstFalse _ _ h' (val := val)
                have hl := eval_completeness l (val := val)
                have hr := eval_completeness r (val := val)
                have h2 := BoolStepStar.eqArStepStarLeft l (ArExpr.Const (eval V val l)) r hl
                have h3 := BoolStepStar.eqArStepStarRight (ArExpr.Const (eval V val l)) r (ArExpr.Const (eval V val r)) hr
                have h4 := chasles_step_star V h2 h3
                exact chasles_step_star V h4 (step_to_stepstar V h1)
        | Less l r =>
            simp [eval_bool]

            by_cases h: (eval V val l < eval V val r)

            .   rw [decide_eq_true]
                have h1 := BoolStep.lessConstConstTrue _ _ h (val := val)
                have hr := eval_completeness r (val := val)
                have hl := eval_completeness l (val := val)
                have hr := eval_completeness r (val := val)
                have h2 := BoolStepStar.lessArStepStarLeft l (ArExpr.Const (eval V val l)) r hl
                have h3 := BoolStepStar.lessArStepStarRight (ArExpr.Const (eval V val l)) r (ArExpr.Const (eval V val r)) hr
                have h4 := chasles_step_star V h2 h3
                apply chasles_step_star V h4 (step_to_stepstar V h1)
                exact h

            .   rw [decide_eq_false]
                have h' := h
                rw [Int.not_lt] at h'
                rw [<- ge_iff_le] at h'
                have h1 := BoolStep.lessConstConstFalse _ _ h' (val := val)
                have hl := eval_completeness l (val := val)
                have hr := eval_completeness r (val := val)
                have h2 := BoolStepStar.lessArStepStarLeft l (ArExpr.Const (eval V val l)) r hl
                have h3 := BoolStepStar.lessArStepStarRight (ArExpr.Const (eval V val l)) r (ArExpr.Const (eval V val r)) hr
                have h4 := chasles_step_star V h2 h3
                exact chasles_step_star V h4 (step_to_stepstar V h1)
                exact h


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

ArStepStar.trans

def ArStepStar.trans {V: Type} {val: V -> Int} e₁ e₂ e₃ := StepStar.trans e₁ e₂ e₃ (Step := ArStep V) (val := val)

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

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₃

ArStepStar

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

    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

ArStepStar.refl

def ArStepStar.refl {V: Type} (val: V -> Int) := StepStar.refl (Step := ArStep V) val

BoolStepStar

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

BoolStepStar.refl

def BoolStepStar.refl {V: Type} (val: V -> Int) := StepStar.refl (Step := BoolStep V) val

StepKind

def StepKind (V: Type) (ExprType: Type):= (V -> Int) -> ExprType -> ExprType -> Prop

BoolStepStar.trans

def BoolStepStar.trans {V: Type} {val: V -> Int} e₁ e₂ e₃ := StepStar.trans e₁ e₂ e₃ (Step := BoolStep V) (val := val)

theorem arstepstar_add_right (n: Int) (e₂ e₂': ArExpr V) :
            ArStepStar V val e₂ e₂' ->
                    ArStepStar V val
                            (ArExpr.Add (ArExpr.Const n) e₂)
                            (ArExpr.Add (ArExpr.Const n) e₂')

theorem arstepstar_sub_left (e₁ e₁' e₂: ArExpr V) :
            ArStepStar V val e₁ e₁' ->
                    ArStepStar V val
                            (ArExpr.Sub e₁ e₂)
                            (ArExpr.Sub e₁' e₂)

theorem chasles_step_star {ExprKind: Type} {Step: StepKind V ExprKind} {e₁ e₂ e₃: ExprKind}:
    StepStar (Step := Step) V val e₁ e₂  ->
        StepStar (Step := Step) V val e₂ e₃ ->
            StepStar (Step := Step) V val e₁ e₃

theorem arstepstar_add_left (e₁ e₁' e₂: ArExpr V) :
            ArStepStar V val e₁ e₁' -> ArStepStar V val (ArExpr.Add e₁ e₂) (ArExpr.Add e₁' e₂)

theorem arstepstar_sub_right (n: Int) (e₂ e₂': ArExpr V) :
            ArStepStar V val e₂ e₂' ->
                    ArStepStar V val
                            (ArExpr.Sub (ArExpr.Const n) e₂)
                            (ArExpr.Sub (ArExpr.Const n) e₂')

ArStepStar.ifStep

theorem ArStepStar.ifStep (e e': BoolExpr V) (a b: ArExpr V): BoolStepStar V val e e' ->
        ArStepStar V val (ArExpr.If e a b) (ArExpr.If e' a b)

theorem arstepstar_mul_right (n: Int) (e₂ e₂': ArExpr V) :
            ArStepStar V val e₂ e₂' ->
                    ArStepStar V val
                            (ArExpr.Mul (ArExpr.Const n) e₂)
                            (ArExpr.Mul (ArExpr.Const n) e₂')

theorem arstepstar_mul_left (e₁ e₁' e₂: ArExpr V) :
            ArStepStar V val e₁ e₁' ->
                    ArStepStar V val
                            (ArExpr.Mul e₁ e₂)
                            (ArExpr.Mul e₁' e₂)

BoolStepStar.andStepLeft

theorem BoolStepStar.andStepLeft (e₁ e₁' e₂: BoolExpr V):
        BoolStepStar V val e₁ e₁' -> BoolStepStar V val
            (BoolExpr.And e₁ e₂)
            (BoolExpr.And e₁' e₂)

BoolStepStar.lessArStepStarLeft

theorem BoolStepStar.lessArStepStarLeft (e₁ e₁' e₂: ArExpr V):
        ArStepStar V val e₁ e₁' ->
            BoolStepStar V val
                (BoolExpr.Less e₁ e₂)
                (BoolExpr.Less e₁' e₂)

BoolStepStar.notStep

theorem BoolStepStar.notStep {V: Type} {val: V -> Int}
        (e e': BoolExpr V):
            BoolStepStar V val e e' -> BoolStepStar V val (BoolExpr.Not e) (BoolExpr.Not e')

BoolStepStar.lessArStepStarRight

theorem BoolStepStar.lessArStepStarRight (e₁ e₂ e₂': ArExpr V):
        ArStepStar V val e₂ e₂' ->
            BoolStepStar V val
                (BoolExpr.Less e₁ e₂)
                (BoolExpr.Less e₁ e₂')

theorem step_to_stepstar {ExprKind: Type} {Step: StepKind V ExprKind} {e e': ExprKind}:
    Step val e e' -> StepStar (Step := Step) V val e e'

BoolStepStar.eqArStepStarRight

theorem BoolStepStar.eqArStepStarRight (e₁ e₂ e₂': ArExpr V):
        ArStepStar V val e₂ e₂' ->
            BoolStepStar V val
                (BoolExpr.Eq e₁ e₂)
                (BoolExpr.Eq e₁ e₂')

BoolStepStar.eqArStepStarLeft

theorem BoolStepStar.eqArStepStarLeft (e₁ e₁' e₂: ArExpr V):
        ArStepStar V val e₁ e₁' ->
            BoolStepStar V val
                (BoolExpr.Eq e₁ e₂)
                (BoolExpr.Eq e₁' e₂)

BoolStepStar.orStepLeft

theorem BoolStepStar.orStepLeft (e₁ e₁' e₂: BoolExpr V):
        BoolStepStar V val e₁ e₁' -> BoolStepStar V val
            (BoolExpr.Or e₁ e₂)
            (BoolExpr.Or e₁' e₂)

theorem eval_completeness (e: ArExpr V) : ArStepStar V val e (ArExpr.Const (eval V val e)) :=

:= by
        cases e with
        | Const x =>
            simp [eval]
            exact ArStepStar.refl _ _
        | Add e₁ e₂ =>
            have ih1 := eval_completeness e₁ (val := val)
            have ih2 := eval_completeness e₂ (val := val)
            simp [eval]
            have a := arstepstar_add_left _ _ e₂ ih1
            have b := arstepstar_add_right (eval V val e₁) e₂ _ ih2
            have c := ArStep.addConstConst (val := val) (eval V val e₁) (eval V val e₂)
            have d := ArStepStar.trans _ _ _ c (ArStepStar.refl _ (ArExpr.Const (eval V val e₁ + eval V val e₂)))
            have e := chasles_step_star _ a (chasles_step_star _ b d)
            exact e
        | Sub e₁ e₂ =>
            have ih1 := eval_completeness e₁ (val := val)
            have ih2 := eval_completeness e₂ (val := val)
            simp [eval]
            have a := arstepstar_sub_left _ _ e₂ ih1
            have b := arstepstar_sub_right (eval V val e₁) e₂ _ ih2
            have c := ArStep.subConstConst (val := val) (eval V val e₁) (eval V val e₂)
            have d := ArStepStar.trans _ _ _ c (ArStepStar.refl _ (ArExpr.Const  (eval V val e₁ - eval V val e₂)))
            have e := chasles_step_star _ a (chasles_step_star _ b d)
            exact e
        | Mul e₁ e₂ =>
            have ih1 := eval_completeness e₁ (val := val)
            have ih2 := eval_completeness e₂ (val := val)
            simp [eval]
            have a := arstepstar_mul_left _ _ e₂ ih1
            have b := arstepstar_mul_right (eval V val e₁) e₂ _ ih2
            have c := ArStep.mulConstConst (val := val) (eval V val e₁) (eval V val e₂)
            have d := ArStepStar.trans _ _ _ c (ArStepStar.refl _ (ArExpr.Const (eval  V val e₁ * eval V val e₂)))
            have e := chasles_step_star _ a (chasles_step_star _ b d)
            exact e
        | Var var =>
            simp [eval]
            have a := ArStep.getVarValue var (val := val)
            have b := ArStepStar.refl val (ArExpr.Const (val var))
            exact ArStepStar.trans (val := val) _ _ _ a b
        | If cond a b =>
            simp [eval]
            cases h: (eval_bool V val cond)
            .   simp
                have h1 := ArStep.ifCondFalse a b (val := val)
                have h2 := eval_completeness b (val := val)
                have h3 := StepStar.trans _ _ _ h1 h2
                have h4 := eval_bool_completeness cond (val := val)
                rw [h] at h4
                have h5 := ArStepStar.ifStep _ _ a b h4
                exact chasles_step_star V h5 h3
            .   simp
                have h1 := ArStep.ifCondTrue a b (val := val)
                have h2 := eval_completeness a (val := val)
                have h3 := StepStar.trans _ _ _ h1 h2
                have h4 := eval_bool_completeness cond (val := val)
                rw [h] at h4
                have h5 := ArStepStar.ifStep _ _ a b h4
                exact chasles_step_star V h5 h3