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 " ↓" => Eval.Defined env e

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

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

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 v:40 " ≲ₒ'(" n:40 ") " v':40 => Object.Approx.Indexed' n v v'

syntax "case " expr " of " cases " end" : 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'

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

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

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 env:40 " ⊢ " e:40 " ↦ " v:40 => Eval env e v

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

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 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₂

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'

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_step {k} :
  (∀ k' < k, Preservation k') → Preservation k :=

:= by
  intro ihk
  intro m n env env' e v h₀ h₁ h₂
  induction h₂ generalizing m env'
  case var env i v h =>
    obtain ⟨v', hget, happrox⟩ := Env.Approx.Indexed'.value h₁ h
    exists v'
    constructor
    · apply Eval.var
      aesop
    · apply Value.Approx.Indexed.anti_monotone
      · assumption
      · linarith
  case var_rec n' env₁ name i env₁' e₁' v' hget heval ih =>
    have hget_or :
        (∃ env₂' e₂', e₁' ≲(m + n')⟨env₁', env₂'⟩ e₂' ∧
          env'[i]? = some (Object.delayed env₂' e₂')) ∨
        (∃ env₂', env₁' ≲ₑ'(m + n') env₂' ∧
          env'[i]? = some (Object.delayed env₂' e₁')) := by
      apply Env.Approx.Indexed'.delayed h₁; assumption
    cases hget_or
    case inl hget' =>
      obtain ⟨env₂', e₂', h₂, hget'⟩ := hget'
      simp [Expr.Approx.Param.Indexed] at h₂
      obtain ⟨v'', heval', happrox'⟩ := h₂ n' m v' (by linarith) heval
      exists v''
      constructor
      · apply Eval.var_rec
        · exact hget'
        · assumption
      · assumption
    case inr hget' =>
      obtain ⟨env₂, happrox, hget'⟩ := hget'
      obtain ⟨v'', heval', happrox'⟩ := ih m env₂ (by linarith) happrox
      exists v''
      constructor
      · apply Eval.var_rec
        · exact hget'
        · assumption
      · assumption
  case unit =>
    exists Value.unit
    constructor
    · apply Eval.unit
    · apply Value.Approx.Indexed.unit
  case const c =>
    exists Value.const c
    constructor
    · apply Eval.const
    · apply Value.Approx.Indexed.const
  case constr ctr_name =>
    exists Value.constr_app ctr_name []
    constructor
    · apply Eval.constr
    · apply Value.Approx.Indexed.constr_app
      intro k hk
      simp
  case app n n₁ n₂ env env₀ f body arg val val' hn hcl h₂ h₃ ih_f ih_arg ih_body =>
    have : env ≲ₑ'(m + n₂ + 1 + n₁) env' := by
      apply Env.Approx.Indexed'.anti_monotone
      · assumption
      · linarith
    obtain ⟨v_f, heval_f, happrox_f⟩ := ih_f (m + n₂ + 1) env' (by linarith) this
    clear this
    have : env ≲ₑ'(m + n₂ + n₁ + 1) env' := by
      apply Env.Approx.Indexed'.anti_monotone
      · assumption
      · linarith
    obtain ⟨v_arg, heval_arg, happrox_arg⟩ := ih_arg (m + n₂) env' (by nlinarith) this
    clear this
    invert happrox_f
    case closure cenv cbody ch =>
      have happrox_arg' : val ≲ᵥ(n₂ + m) v_arg := by
        have : m + n₂ = n₂ + m := by linarith
        rw [this] at happrox_arg
        exact happrox_arg
      obtain ⟨v_body, heval_body, happrox_body⟩ := ch n₂ m (by linarith) val v_arg val' happrox_arg' h₃
      exists v_body
      constructor
      · apply Eval.app
        · exact heval_f
        · exact heval_arg
        · exact heval_body
      · assumption
  case constr_app n₁ n₂ env₁ e₁ cname args arg v' hlt _ h₂ h₃ h₄ =>
    obtain ⟨v₁, heval_e₁, happrox_e₁⟩ := h₃ m env' (by linarith) h₁
    have : env₁ ≲ₑ'(m + n₂) env' := by
      apply Env.Approx.Indexed'.anti_monotone
      · assumption
      · linarith
    obtain ⟨v₂, heval_arg, happrox_arg⟩ := h₄ m env' (by linarith) this
    invert happrox_e₁
    case constr_app args_rev hargs =>
      exists (Value.constr_app cname (v₂ :: args_rev))
      constructor
      · apply Eval.constr_app
        · exact heval_e₁
        · exact heval_arg
      · apply Value.Approx.Indexed.constr_app
        intro k hk
        constructor
        · apply Value.Approx.Indexed.anti_monotone
          · exact happrox_arg
          · linarith
        · apply hargs
          linarith
  case binop n' env₁ op arg₁ arg₂ i₁ i₂ v₁ v₂ hv₁ hv₂ =>
    obtain ⟨v₁', heval₁, happrox₁⟩ := hv₁ m env' (by linarith) h₁
    obtain ⟨v₂', heval₂, happrox₂⟩ := hv₂ m env' (by linarith) h₁
    invert happrox₁
    invert happrox₂
    exists (Value.const (Constant.int (eval_binop_int op i₁ i₂)))
    constructor
    · apply Eval.binop
      · exact heval₁
      · exact heval₂
    · apply Value.Approx.Indexed.const
  case lambda n' env₁ name body =>
    exists (Value.closure env' body)
    constructor
    · apply Eval.lambda
    · apply Value.Approx.Indexed.closure
      intro n₁ n₂ hlt a₁ a₂ v₁ happrox heval
      have happrox_env : a₁ ∷ env₁ ≲ₑ'(n₁ + n₂) a₂ ∷ env' := by
        constructor
        · constructor
          exact happrox
        · apply Env.Approx.Indexed'.anti_monotone (n := m + n')
          · assumption
          · linarith
      apply ihk (n₁ + n₂ + 1) (by linarith) (m := n₂) (n := n₁)
      · linarith
      · have : n₁ + n₂ = n₂ + n₁ := by linarith
        rw [<- this]
        exact happrox_env
      · exact heval
  case save n' n₁ n₂ env₁ name e₁ e₂ val val' hle ha₁ ha₂ ih₁ ih₂ =>
    have : env₁ ≲ₑ'(m + n₂ + n₁) env' := by
      apply Env.Approx.Indexed'.anti_monotone
      · assumption
      · linarith
    obtain ⟨v₁, heval₁, happrox₁⟩ := ih₁ (m + n₂) env' (by linarith) this
    clear this
    have : val ∷ env₁ ≲ₑ'(m + n₂) v₁ ∷ env' := by
      constructor
      · apply Object.Approx.Indexed'.value
        · apply Value.Approx.Indexed.anti_monotone
          · exact happrox₁
          · linarith
      apply Env.Approx.Indexed'.anti_monotone
      · assumption
      · linarith
    obtain ⟨v₂, heval₂, happrox₂⟩ := ih₂ m (v₁ ∷ env') (by linarith) this
    exists v₂
    constructor
    · apply Eval.save
      · exact heval₁
      · exact heval₂
    · assumption
  case branch_matches e' n₁ n₁' env₁ name args_rev body val hlt heval_body ih =>
    rcases env' with
      ⟨⟩ | ⟨⟨hd⟩, env'⟩
    case nil =>
      cases h₁
    case cons.value =>
      cases h₁
      case cons h₁ h₂ =>
        cases h₁
        case value h₁ =>
          invert h₁
          case constr_app args_rev' happrox =>
            let args := List.map Object.value args_rev
            let args' := List.map Object.value args_rev'
            have : args ++ env₁ ≲ₑ'(m + n₁') args' ++ env' := by
              apply Env.Approx.Indexed'.concat
              · apply Env.Approx.Indexed'.from_value
                apply happrox
                linarith
              · apply Env.Approx.Indexed'.anti_monotone
                · assumption
                · linarith
            obtain ⟨v', heval', happrox'⟩ := ih m (args' ++ env') (by linarith) this
            exists v'
            constructor
            · apply Eval.branch_matches
              · exact heval'
            · assumption
    case cons.delayed =>
      cases h₁
      case cons h _ =>
        cases h
  case branch_fails e' n' env₁ name name' args e₂ v₂ hname heval ih =>
    rcases env' with
      ⟨⟩ | ⟨⟨hd⟩, env'⟩
    case nil =>
      cases h₁
    case cons.value =>
      cases h₁
      case cons h₁ h₂ =>
        cases h₁
        case value h₁ =>
          invert h₁
          case constr_app args_rev h =>
            have h₃ : Value.constr_app name args ∷ env₁ ≲ₑ'(m + n') Value.constr_app name args_rev ∷ env' := by
              constructor
              · apply Object.Approx.Indexed'.value
                apply Value.Approx.Indexed.constr_app
                intro k hk
                apply h
                exact hk
              · apply Env.Approx.Indexed'.anti_monotone
                · assumption
                · linarith
            obtain ⟨v', heval', happrox'⟩ := ih m (Value.constr_app name args_rev ∷ env') (by linarith) h₃
            exists v'
            constructor
            · apply Eval.branch_fails
              · exact hname
              · exact heval'
            · assumption
    case cons.delayed =>
      cases h₁
      case cons h _ =>
        cases h
  case recur n₁ n₂ env₁ name body val hn ha₁ ih =>
    let d := Object.delayed env₁ (Expr.recur name body)
    let d' := Object.delayed env' (Expr.recur name body)
    have : d ≲ₒ'(m + n₂) d' := by
      simp [d, d']
      apply Object.Approx.Indexed'.delayed_eq
      apply Env.Approx.Indexed'.anti_monotone
      · assumption
      · linarith
    have : d :: env₁ ≲ₑ'(m + n₂) d' :: env' := by
      apply Env.Approx.Indexed'.cons
      · assumption
      · apply Env.Approx.Indexed'.anti_monotone
        · assumption
        · linarith
    obtain ⟨v, heval, happrox⟩ := ih m (d' :: env') (by linarith) this
    exists v
    constructor
    · apply Eval.recur
      exact heval
    · assumption


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 env₁:40 " ≲ₑ'(" n:40 ") " env₂:40 => Env.Approx.Indexed' n env₁ env₂

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

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

theorem Value.Approx.Indexed.preserved :
  ∀ m n env env' e v,
    env ≲ₑ'(m + n) env' →
    env ⊢ e ↦(n) v →
    ∃ v', env' ⊢ e ↦ v' ∧ v ≲ᵥ(m) v'

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

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

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'

end

@[refl]
lemma Value.Approx.Indexed.refl {n} v : v ≲ᵥ(n) v :=

:= by
  revert n
  suffices ∀ n, ∀ k ≤ n, v ≲ᵥ(k) v by
    intro k
    exact this k k k.le_refl
  intro n
  induction n generalizing v with
  | zero =>
    intros k hk
    cases v
    case unit =>
      exact Value.Approx.Indexed.unit
    case const c =>
      exact Value.Approx.Indexed.const
    case constr_app ctr_name args_rev =>
      apply Value.Approx.Indexed.constr_app
      · intros
        have : k = 0 := by linarith
        subst k
        contradiction
    case closure env body =>
      apply Value.Approx.Indexed.closure
      · intros
        have : k = 0 := by linarith
        subst k
        contradiction
  | succ n ih =>
    intros k hk
    cases v
    case unit =>
      exact Value.Approx.Indexed.unit
    case const c =>
      exact Value.Approx.Indexed.const
    case constr_app ctr_name args_rev =>
      apply Value.Approx.Indexed.constr_app
      · intros k' hk'
        have : k' ≤ n := by linarith
        rw [List.forall₂_same]
        intros
        apply ih
        · assumption
    case closure env body =>
      apply Value.Approx.Indexed.closure
      · intros n₁ n₂ hn a₁ a₂ r₁ happrox heval
        have henv : a₁ ∷ env ≲ₑ'(n₁ + n₂) a₂ ∷ env := by
          simp [Env.Approx.Indexed']
          constructor
          · constructor; exact happrox
          · intro x _
            cases x
            case value v₁ v₂ =>
              apply Object.Approx.Indexed'.value
              · apply ih
                · linarith
            case delayed =>
              apply Object.Approx.Indexed'.refl'
              intro v
              apply ih
              linarith
        apply Value.Approx.Indexed.preserved (n := n₁) (m := n₂)
        · have : n₁ + n₂ = n₂ + n₁ := by linarith
          rw [<- this]
          exact henv
        · assumption


import Mathlib.Tactic.Linarith
import Juvix.Core.Main.Semantics.Eval

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 env:40 " ⊢ " e:40 " ↦ " v:40 => Eval env e v

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

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

BinaryOp

inductive BinaryOp : Type where
  | add_int : BinaryOp
  | sub_int : BinaryOp
  | mul_int : BinaryOp
  | div_int : BinaryOp
  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₂

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

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

infixr:50 " ∷ " => cons_value

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

Termination.var

lemma Termination.var {env name i v} :
  env[i]? = some (Object.value v) →
  env ⊢ Expr.var name i ↓

lemma Termination.var_rec {env name i env' e} :
    env[i]? = some (Object.delayed env' e) →
    env' ⊢ e ↓ →
    env ⊢ (Expr.var name i) ↓

Termination.unit

lemma Termination.unit {env} :
  env ⊢ Expr.unit ↓

Termination.const

lemma Termination.const {env c} :
  env ⊢ Expr.const c ↓

Termination.constr

lemma Termination.constr {env nm} :
  env ⊢ Expr.constr nm ↓

Termination.app

lemma Termination.app {env e₁ e₂ v env' body} :
  env ⊢ e₁ ↦ Value.closure env' body →
  env ⊢ e₂ ↦ v →
  v ∷ env' ⊢ body ↓ →
  env ⊢ Expr.app e₁ e₂ ↓

lemma Termination.constr_app {env e₁ e₂ e₁₁ e₁₂} :
  env ⊢ e₁ ↦ Value.constr_app e₁₁ e₁₂ →
  env ⊢ e₂ ↓ →
  env ⊢ Expr.constr_app e₁ e₂ ↓

Termination.binop

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₂ ↓

Termination.lambda

lemma Termination.lambda {env name e} : env ⊢ Expr.lambda name e ↓

Termination.save

lemma Termination.save {env name e₁ e₂ v} :
  env ⊢ e₁ ↦ v →
  v ∷ env ⊢ e₂ ↓ →
  env ⊢ Expr.save name e₁ e₂ ↓

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

lemma Termination.branch_fails {env name name' vnames args_rev e e'} :
  name ≠ name' →
  Value.constr_app name args_rev ∷ env ⊢ e' ↓ →
  Value.constr_app name args_rev ∷ env ⊢ Expr.branch name' vnames e e' ↓

Termination.recur

lemma Termination.recur {env name e} :
  Object.delayed env (Expr.recur name e) :: env ⊢ e ↓ →
  env ⊢ Expr.recur name e ↓

Juvix.Core.Main.Eval.Indexed.monotone

lemma Eval.Indexed.monotone {n n' env e v} (h : env ⊢ e ↦(n) v) (h' : n ≤ n') : env ⊢ e ↦(n') v

import Juvix.Core.Main.Semantics.Eval

import Mathlib.Tactic.Linarith

namespace Juvix.Core.Main

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

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

lemma Eval.toIndexed {env e v} (h : env ⊢ e ↦ v) : ∃ n, env ⊢ e ↦(n) v :=

:= by
  induction h
  case var =>
    exists 0; apply Eval.Indexed.var; assumption
  case var_rec ih =>
    obtain ⟨n, ih⟩ := ih
    exists n
    apply Eval.Indexed.var_rec <;> assumption
  case unit =>
    exists 0; apply Eval.Indexed.unit
  case const =>
    exists 0; apply Eval.Indexed.const
  case constr =>
    exists 0; apply Eval.Indexed.constr
  case app env env' f body arg val val' _ _ _ ih1 ih2 ih3 =>
    obtain ⟨n₁, ih₁⟩ := ih1
    obtain ⟨n₂, ih₂⟩ := ih2
    obtain ⟨n₃, ih₃⟩ := ih3
    have ih₁' : env ⊢ f ↦(n₁ + n₂) Value.closure env' body := by
      apply Eval.Indexed.monotone ih₁; linarith
    have ih₂' : env ⊢ arg ↦(n₁ + n₂ + 1) val := by
      apply Eval.Indexed.monotone ih₂; linarith
    exists (n₁ + n₂ + n₃ + 1)
    apply Eval.Indexed.app
    · rfl
    · exact ih₁'
    · exact ih₂'
    · exact ih₃
  case constr_app ih₁ ih₂ =>
    obtain ⟨n₁, ih₁⟩ := ih₁
    obtain ⟨n₂, ih₂⟩ := ih₂
    exists (n₁ + n₂ + 1)
    apply Eval.Indexed.constr_app (n' := n₁ + n₂)
    · linarith
    · apply Eval.Indexed.monotone ih₁; linarith
    · apply Eval.Indexed.monotone ih₂; linarith
  case binop ih₁ ih₂ =>
    obtain ⟨n₁, ih₁⟩ := ih₁
    obtain ⟨n₂, ih₂⟩ := ih₂
    exists (n₁ + n₂)
    apply Eval.Indexed.binop (n := n₁ + n₂)
    · apply Eval.Indexed.monotone ih₁; linarith
    · apply Eval.Indexed.monotone ih₂; linarith
  case lambda =>
    exists 0; apply Eval.Indexed.lambda
  case save ih₁ ih₂ =>
    obtain ⟨n₁, ih₁⟩ := ih₁
    obtain ⟨n₂, ih₂⟩ := ih₂
    exists (n₁ + n₂)
    apply Eval.Indexed.save (n := n₁ + n₂)
    · rfl
    · apply Eval.Indexed.monotone ih₁; linarith
    · apply Eval.Indexed.monotone ih₂; linarith
  case branch_matches ih =>
    obtain ⟨n, ih⟩ := ih
    exists (n + 1)
    apply Eval.Indexed.branch_matches (n' := n)
    · linarith
    · assumption
  case branch_fails ih =>
    obtain ⟨n, ih⟩ := ih
    exists n
    apply Eval.Indexed.branch_fails <;> assumption
  case recur ih =>
    obtain ⟨n, ih⟩ := ih
    exists n.succ
    apply Eval.Indexed.recur (n' := n)
    · linarith
    · 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⟫)

  inductive Object : Type where
    | value : Value → Object
    | delayed : (env : List Object) → Expr → Object
    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₂

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

Eval.Defined

def Eval.Defined (env : Env) (e : Expr) : Prop :=
  ∃ v, env ⊢ e ↦ v

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]

import Juvix.Core.Main.Tactics.Base

namespace Juvix.Core.Main

lemma Termination.recur {env name e} :
  Object.delayed env (Expr.recur name e) :: env ⊢ e ↓ →
  env ⊢ Expr.recur name e ↓ :=

:= by
  unfold Eval.Defined
  intro h
  obtain ⟨w, h⟩ := h
  exists w
  · apply Juvix.Core.Main.Eval.recur
    exact h


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

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

  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

Name

abbrev Name : Type := String

Env

abbrev Env : Type := List Object

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'

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'

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₂

@[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 Value.Approx.Indexed.trans {n v₁ v₂ v₃} : v₁ ≲ᵥ(n) v₂ → v₂ ≲ᵥ v₃ → v₁ ≲ᵥ(n) v₃ :=

:= by
  revert n
  suffices ∀ n, ∀ k ≤ n, v₁ ≲ᵥ(k) v₂ → v₂ ≲ᵥ v₃ → v₁ ≲ᵥ(k) v₃ by
    intro k
    exact this k k k.le_refl
  intros n
  induction n generalizing v₁ v₂ v₃ with
  | zero =>
    intros k hk h₁ h₂
    invert h₁
    case unit =>
      invert h₂
      case unit =>
        exact Value.Approx.Indexed.unit
    case const =>
      invert h₂
      case const =>
        exact Value.Approx.Indexed.const
    case constr_app ctr_name args_rev₁ args_rev₁' ch₁ =>
      cases h₂.invert
      case constr_app args_rev₂ ch₂ =>
        apply Value.Approx.Indexed.constr_app;
        intros
        simp_all only [nonpos_iff_eq_zero, not_lt_zero', IsEmpty.forall_iff, implies_true]
    case closure env₁ body₁ env₁' body₁' ch₁ =>
      cases h₂.invert
      case closure env₂ body₂ ch₂ =>
        apply Value.Approx.Indexed.closure
        · intro k' hk' v v₁ h
          have : k = 0 := by linarith
          subst k
          contradiction
  | succ n ih =>
    intros k hk h₁ h₂
    invert h₁
    case unit =>
      invert h₂
      case unit =>
        exact Value.Approx.Indexed.unit
    case const =>
      invert h₂
      case const =>
        exact Value.Approx.Indexed.const
    case constr_app ctr_name args_rev args_rev' ch₁ =>
      invert h₂
      case constr_app args_rev'' ch₂ =>
        apply Value.Approx.Indexed.constr_app
        · intro k' hk'
          have hk' : k' ≤ n := by linarith
          apply Utils.forall₂_trans' (P := fun v₁ v₂ => v₁ ≲ᵥ(k') v₂) (Q := fun v₁ v₂ => v₁ ≲ᵥ v₂)
          · intros v₁ v₂ v₃ h₁ h₂
            apply ih <;> assumption
          · apply ch₁
            simp_all only
          · apply ch₂
    case closure env₁ body₁ env₂ body₂ ch₁ =>
      invert h₂
      case closure env₃ body₃ ch₂ =>
        apply Value.Approx.Indexed.closure
        · intro n₁ n₂ hn a₁ a₃ v₁ happrox heval₁
          have ah₁ : ∃ v₂, (a₃ ∷ env₂) ⊢ body₂ ↦ v₂ ∧ v₁ ≲ᵥ(n₂) v₂ := by
            apply ch₁
            · assumption
            · assumption
            · assumption
          obtain ⟨v₂, heval₂, h₂⟩ := ah₁
          have ah₂ : ∃ v₃, (a₃ ∷ env₃) ⊢ body₃ ↦ v₃ ∧ v₂ ≲ᵥ v₃ := by
            apply ch₂
            · rfl
            · assumption
          obtain ⟨v₃, _, h₃⟩ := ah₂
          have : n₂ ≤ n := by linarith
          exists v₃
          aesop


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 "invert" h:term : tactic => `(tactic| (cases ($h).invert <;> try clear $h))

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

infixr:50 " ∷ " => cons_value

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

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.Indexed

@[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₂

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₂

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

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 Value.Approx.Indexed.anti_monotone {n n' v₁ v₂} (h : v₁ ≲ᵥ(n) v₂) (h' : n' ≤ n) : v₁ ≲ᵥ(n') v₂ :=

:= by
  revert n n'
  suffices ∀ n, v₁ ≲ᵥ(n) v₂ → ∀ k ≤ n, v₁ ≲ᵥ(k) v₂ by
    intro n n' h hn
    exact this n h n' hn
  intro n
  induction n generalizing v₁ v₂ with
  | zero =>
    intros h k hk
    invert h
    case unit =>
      exact Value.Approx.Indexed.unit
    case const =>
      exact Value.Approx.Indexed.const
    case constr_app ctr_name args_rev args_rev' hargs =>
      apply Value.Approx.Indexed.constr_app
      · intros
        have : k = 0 := by linarith
        subst k
        contradiction
    case closure env₁ body₁ env₂ body₂ h =>
      apply Value.Approx.Indexed.closure
      · intros
        have : k = 0 := by linarith
        subst k
        contradiction
  | succ n ih =>
    intros h k hk
    invert h
    case unit =>
      exact Value.Approx.Indexed.unit
    case const =>
      exact Value.Approx.Indexed.const
    case constr_app ctr_name args_rev args_rev' hargs =>
      apply Value.Approx.Indexed.constr_app
      · intros k' hk'
        have : k' < n + 1 := by linarith
        simp_all only
    case closure env₁ body₁ env₂ body₂ ch =>
      apply Value.Approx.Indexed.closure
      · intro n₁ n₂ hn a₁ a₂ v₁ happrox heval
        apply ch n₁ n₂
        · linarith
        · assumption
        · assumption