/-
File: signature_recover_public_key_assert_nn_le_soundness.lean

Autogenerated file.
-/
import starkware.cairo.lean.semantics.soundness.hoare
import .signature_recover_public_key_code
import ..signature_recover_public_key_spec
import .signature_recover_public_key_assert_le_soundness
open tactic

open starkware.cairo.common.math

variables {F : Type} [field F] [decidable_eq F] [prelude_hyps F]
variable  mem : F → F
variable  σ : register_state F

/- starkware.cairo.common.math.assert_nn_le autogenerated soundness theorem -/

theorem auto_sound_assert_nn_le
    -- arguments
    (range_check_ptr a b : F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_assert_nn_le σ.pc)
    -- all dependencies are in memory
    (h_mem_0 : mem_at mem code_assert_nn (σ.pc  - 9))
    (h_mem_1 : mem_at mem code_assert_le (σ.pc  - 5))
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 5))
    (hin_a : a = mem (σ.fp - 4))
    (hin_b : b = mem (σ.fp - 3))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      τ.ap = σ.ap + 14 ∧
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 5)) (mem $ τ.ap - 1)
        (spec_assert_nn_le mem κ range_check_ptr a b (mem (τ.ap - 1)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_assert_nn_le at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8⟩,
  -- function call
  step_assert_eq hpc0 with arg0,
  step_assert_eq hpc1 with arg1,
  step_sub hpc2 (auto_sound_assert_nn mem _ range_check_ptr a _ _ _),
  { rw hpc3, norm_num2, exact h_mem_0 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call4 ap4 h_call4,
  rcases h_call4 with ⟨h_call4_ap_offset, h_call4⟩,
  rcases h_call4 with ⟨rc_m4, rc_mle4, hl_range_check_ptr₁, h_call4⟩,
  generalize' hr_rev_range_check_ptr₁: mem (ap4 - 1) = range_check_ptr₁,
  have htv_range_check_ptr₁ := hr_rev_range_check_ptr₁.symm, clear hr_rev_range_check_ptr₁,
  try { simp only [arg0 ,arg1] at hl_range_check_ptr₁ },
  rw [←htv_range_check_ptr₁, ←hin_range_check_ptr] at hl_range_check_ptr₁,
  try { simp only [arg0 ,arg1] at h_call4 },
  rw [hin_range_check_ptr] at h_call4,
  clear arg0 arg1,
  -- function call
  step_assert_eq hpc4 with arg0,
  step_assert_eq hpc5 with arg1,
  step_sub hpc6 (auto_sound_assert_le mem _ range_check_ptr₁ a b _ _ _ _ _),
  { rw hpc7, norm_num2, exact h_mem_1 },
  { rw hpc7, norm_num2, exact h_mem_0 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call4_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call4_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call4_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call8 ap8 h_call8,
  rcases h_call8 with ⟨h_call8_ap_offset, h_call8⟩,
  rcases h_call8 with ⟨rc_m8, rc_mle8, hl_range_check_ptr₂, h_call8⟩,
  generalize' hr_rev_range_check_ptr₂: mem (ap8 - 1) = range_check_ptr₂,
  have htv_range_check_ptr₂ := hr_rev_range_check_ptr₂.symm, clear hr_rev_range_check_ptr₂,
  try { simp only [arg0 ,arg1] at hl_range_check_ptr₂ },
  rw [←htv_range_check_ptr₂, ←htv_range_check_ptr₁] at hl_range_check_ptr₂,
  try { simp only [arg0 ,arg1] at h_call8 },
  rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr] at h_call8,
  clear arg0 arg1,
  -- return
  step_ret hpc8,
  -- finish
  step_done, use_only [rfl, rfl],
  split,
  { try { simp only [h_call4_ap_offset ,h_call8_ap_offset] },
    try { arith_simps }, try { refl } },
  -- range check condition
  use_only (rc_m4+rc_m8+0+0), split,
  linarith [rc_mle4, rc_mle8],
  split,
  { arith_simps,
    rw [←htv_range_check_ptr₂, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr],
    try { arith_simps, refl <|> norm_cast }, try { refl } },
  intro rc_h_range_check_ptr, repeat { rw [add_assoc] at rc_h_range_check_ptr },
  have rc_h_range_check_ptr' := range_checked_add_right rc_h_range_check_ptr,
  -- Final Proof
  -- user-provided reduction
  suffices auto_spec: auto_spec_assert_nn_le mem _ range_check_ptr a b _,
  { apply sound_assert_nn_le, apply auto_spec },
  -- prove the auto generated assertion
  dsimp [auto_spec_assert_nn_le],
  try { norm_num1 }, try { arith_simps },
  use_only [κ_call4],
  use_only [range_check_ptr₁],
  have rc_h_range_check_ptr₁ := range_checked_offset' rc_h_range_check_ptr,
  have rc_h_range_check_ptr₁' := range_checked_add_right rc_h_range_check_ptr₁, try { norm_cast at rc_h_range_check_ptr₁' },
  have spec4 := h_call4 rc_h_range_check_ptr',
  rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec4,
  try { dsimp at spec4, arith_simps at spec4 },
  use_only [spec4],
  use_only [κ_call8],
  use_only [range_check_ptr₂],
  have rc_h_range_check_ptr₂ := range_checked_offset' rc_h_range_check_ptr₁,
  have rc_h_range_check_ptr₂' := range_checked_add_right rc_h_range_check_ptr₂, try { norm_cast at rc_h_range_check_ptr₂' },
  have spec8 := h_call8 rc_h_range_check_ptr₁',
  rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec8,
  try { dsimp at spec8, arith_simps at spec8 },
  use_only [spec8],
  try { split, linarith },
  try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_range_check_ptr₂] }, },
  try { simp only [h_call4_ap_offset, h_call8_ap_offset] },
  try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
end


import .yul_ast
import .aux

import tactic.linarith

import data.finset.basic
import data.vector
import init.data.fin.ops
import init.data.list.basic

set_option class.instance_max_depth 100

def FTContext := Identifier → option (ℕ × ℕ)
def empΓ : FTContext := λ_, none

def VarStore (vars : finset Identifier) := ∀ i : Identifier, (i ∈ vars) → Literal
def empStore : VarStore ∅
  | i i_in_emp := absurd i_in_emp (finset.not_mem_empty i)

namespace YulCommands

variable Γ : FTContext

inductive IsInFor : Type
| NestedInFor : IsInFor
| NotNestedInFor : IsInFor

inductive IsInFunc : Type
| InFunc : IsInFunc
| NotInFunc : IsInFunc

inductive TermType : Type
| BlockList :  finset Identifier → finset Identifier → IsInFor → IsInFunc → TermType
| CBlock : finset Identifier → IsInFor → IsInFunc → TermType
| SwitchBody : finset Identifier → IsInFor → IsInFunc → TermType
| CExpr : finset Identifier → ℕ → TermType
| CStatement : finset Identifier → finset Identifier → IsInFor → IsInFunc → TermType

open IsInFor
open IsInFunc
open TermType

inductive YulTerm : TermType → Type
| EmpCBlock :
    ∀{vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm (BlockList vars vars b b')
| SeqCBlock  :
    ∀ {vars : finset Identifier} (vars' : finset Identifier)
      {vars'' : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm (CStatement vars vars' b b') ->
    YulTerm (BlockList vars' vars'' b b') →
    YulTerm (BlockList vars vars'' b b')

| NestedScope :
    ∀ {vars : finset Identifier} (inner_vars inner_vars' : finset Identifier)
      {b : IsInFor} {b' : IsInFunc},
    VarStore inner_vars →
    YulTerm (BlockList (inner_vars ∪ vars) (inner_vars' ∪ vars) b b') →
    YulTerm (CBlock vars b b')

| CCase :
    ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
      Literal → YulTerm (CBlock vars b b') → YulTerm (SwitchBody vars b b') →
      YulTerm (SwitchBody vars b b')
| CDefault :
    ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
      YulTerm (CBlock vars b b') → YulTerm (SwitchBody vars b b')
| CNone :
    ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
      YulTerm (SwitchBody vars b b')

| CFunctionCall :
    ∀ {vars : finset Identifier}
      (f_id : Identifier) (n : ℕ) {m : ℕ},
        (Γ f_id = some (n,m)) →
        (fin n → YulTerm (CExpr vars 1)) →
        YulTerm (CExpr vars m)
| CId :
    ∀ {vars : finset Identifier} (id : Identifier),
    id ∈ vars → YulTerm (CExpr vars 1)
| CLit :
    ∀ {vars : finset Identifier},
      Literal → YulTerm (CExpr vars 1)
| Scope : ∀ {vars_outer : finset Identifier} (vars_inner vars_fin : finset Identifier)
               {n : ℕ} (ret_vars : vector Identifier n),
    VarStore (vars_inner ∪ (tofinset' ret_vars)) →
    YulTerm (BlockList (vars_inner ∪ (tofinset' ret_vars)) (vars_fin ∪ (tofinset' ret_vars)) NotNestedInFor InFunc) →
    YulTerm (CExpr vars_outer n)
| Result :
    ∀ {vars : finset Identifier} {n : ℕ},
      vector Literal n → YulTerm (CExpr vars n)

| CBlock :
  ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm (CBlock vars b b') → YulTerm (CStatement vars vars b b')
  -- Function definitions already parsed into FTContext.
| CVariableDeclarationAss :
    ∀ {vars : finset Identifier} (n : ℕ)
        (new_vars : fin n -> Identifier) {b : IsInFor} {b' : IsInFunc},
      YulTerm (CExpr vars n) →
      YulTerm (CStatement vars (vars ∪ (tofinset new_vars)) b b')
| CVariableDeclaration :
    ∀ {vars : finset Identifier} (n : ℕ)
        (new_vars : fin n -> Identifier) {b : IsInFor} {b' : IsInFunc},
      YulTerm (CStatement vars (vars ∪ (tofinset new_vars)) b b')
| CAssignment :
    ∀ {vars : finset Identifier} (n : ℕ)
        (ids : fin n -> Identifier) {b : IsInFor} {b' : IsInFunc},
      tofinset ids ⊆ vars → YulTerm (CExpr vars n) →
      YulTerm (CStatement vars vars b b')
| CIf :
    ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
      YulTerm (CExpr vars 1) → YulTerm (CBlock vars b b') →
      YulTerm (CStatement vars vars b b')
| CExpressionStatement :
    ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm (CExpr vars 0) -> YulTerm (CStatement vars vars b b')
| CSwitch : ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm (CExpr vars 1) →
    YulTerm (SwitchBody vars b b') →
    YulTerm (CStatement vars vars b b')
| CFor :
  ∀ {vars : finset Identifier} (inner_vars inner_vars' inner_vars'' : finset Identifier)
      {b : IsInFor} {b' : IsInFunc},
    YulTerm (BlockList vars (vars ∪ inner_vars) NotNestedInFor b') →
    YulTerm (CExpr (vars ∪ inner_vars) 1) →
    YulTerm (BlockList (vars ∪ inner_vars) (vars ∪ inner_vars') NestedInFor b') →
    YulTerm (BlockList (vars ∪ inner_vars') (vars ∪ inner_vars'') NotNestedInFor b') →
    YulTerm (CStatement vars vars b b')
| CBreak :
    ∀ {vars : finset Identifier} {b' : IsInFunc},
      YulTerm (CStatement vars vars NestedInFor b')
| CContinue :
    ∀ {vars : finset Identifier} {b' : IsInFunc},
      YulTerm (CStatement vars vars NestedInFor b')
| CLeave :
    ∀ {vars : finset Identifier} {b : IsInFor},
      YulTerm (CStatement vars vars b InFunc)
| ForExecInit :
  ∀ {vars : finset Identifier} (curr_inner_vars inner_vars inner_vars' inner_vars'' : finset Identifier)
      {b : IsInFor} {b' : IsInFunc},
    VarStore curr_inner_vars →
    YulTerm (CExpr (vars ∪ inner_vars) 1) →
    YulTerm (BlockList (vars ∪ inner_vars) (vars ∪ inner_vars') NestedInFor b') →
    YulTerm (BlockList (vars ∪ inner_vars') (vars ∪ inner_vars'') NotNestedInFor b') →
    YulTerm (BlockList (vars ∪ curr_inner_vars) (vars ∪ inner_vars) NotNestedInFor b') →
     YulTerm (CStatement vars vars b b')
| ForCheckCond :
  ∀ {vars : finset Identifier} (inner_vars inner_vars' inner_vars'' : finset Identifier)
      {b : IsInFor} {b' : IsInFunc},
    VarStore inner_vars →
    YulTerm (CExpr (vars ∪ inner_vars) 1) →
    YulTerm (BlockList (vars ∪ inner_vars) (vars ∪ inner_vars') NestedInFor b') →
    YulTerm (BlockList (vars ∪ inner_vars') (vars ∪ inner_vars'') NotNestedInFor b') →
    YulTerm (CExpr (vars ∪ inner_vars) 1) →
    YulTerm (CStatement vars vars b b')
| ForExecBody :
  ∀ {vars : finset Identifier} (curr_inner_vars inner_vars inner_vars' inner_vars'' : finset Identifier)
      {b : IsInFor} {b' : IsInFunc},
    VarStore curr_inner_vars →
    vars ∪ inner_vars ⊆ vars ∪ curr_inner_vars →
    YulTerm (CExpr (vars ∪ inner_vars) 1) →
    YulTerm (BlockList (vars ∪ inner_vars) (vars ∪ inner_vars') NestedInFor b') →
    YulTerm (BlockList (vars ∪ inner_vars') (vars ∪ inner_vars'') NotNestedInFor b') →
    YulTerm (BlockList (vars ∪ curr_inner_vars) (vars ∪ inner_vars') NestedInFor b') →
    YulTerm (CStatement vars vars b b')
| ForExecPost :
  ∀ {vars : finset Identifier} (curr_inner_vars inner_vars inner_vars' inner_vars'' : finset Identifier)
      {b : IsInFor} {b' : IsInFunc},
    VarStore curr_inner_vars →
    YulTerm (CExpr (vars ∪ inner_vars) 1) →
    YulTerm (BlockList (vars ∪ inner_vars) (vars ∪ inner_vars') NestedInFor b') →
    YulTerm (BlockList (vars ∪ inner_vars') (vars ∪ inner_vars'') NotNestedInFor b') →
    YulTerm (BlockList (vars ∪ curr_inner_vars) (vars ∪ inner_vars'') NotNestedInFor b') →
    YulTerm (CStatement vars vars b b')
| Skip :
    ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
      YulTerm (CStatement vars vars b b')
  -- ForCheckCond, ForExecbody and Skip not in Yul specification, added for small step semantics.

open YulTerm

def getVariableUpdate : ∀ {t : TermType} , YulTerm Γ t → option (finset Identifier × finset Identifier)
| (BlockList vars vars' _ _) _ := some (vars, vars')
| (CBlock _ _ _) _ := none
| (SwitchBody _ _ _) _ := none
| (CExpr _ _) _ := none
| (CStatement vars vars' _ _) _ := some (vars, vars')

lemma term_scope_monotonic :
        ∀ {t : TermType} (term : YulTerm Γ t) (vars vars' : finset Identifier),
        getVariableUpdate Γ term = some (vars, vars') → vars ⊆ vars' :=
  begin
    intros ttype t,
    induction t,

    -- EmpCBlock
    intros vars vars' is_var_update i,
    intro i_in_vars,
    rw getVariableUpdate at is_var_update,
    injection is_var_update with is_var_update,
    injection is_var_update with vars_eq_tvars tvars_eq_tvars,
    rw [←tvars_eq_tvars, vars_eq_tvars],
    exact i_in_vars,

    -- SeqCBlock
    intros vars vars' is_var_update i,
    intro i_in_vars,
    rw getVariableUpdate at is_var_update,
    injection is_var_update with is_var_update,
    injection is_var_update with vars_eq_tvars tvars''_eq_vars',
    rw vars_eq_tvars at t_ᾰ,
    have int₁ := t_ih_ᾰ vars t_vars' _ i_in_vars,
    rw tvars''_eq_vars' at t_ᾰ_1,
    have int₂ := t_ih_ᾰ_1 t_vars' vars' _ int₁,
    exact int₂,
    rw getVariableUpdate,
    injection is_var_update with _ tvars''_eq_vars',
    rw tvars''_eq_vars',
    rw getVariableUpdate,
    rw vars_eq_tvars,

    -- Block, SwitchBody & Expr
    repeat {
      intros vars vars',
      intro f,
      rw getVariableUpdate at f,
      exfalso,
      exact option.some_ne_none (vars, vars') (eq.symm f),
    },

    -- CStatements that do not bring new variables into scope.
    repeat {
      intros vars vars',
      intro is_var_update,
      rw getVariableUpdate at is_var_update,
      injection is_var_update with is_var_update,
      injection is_var_update with vars_eq_tvars tvars_eq_vars',
      rw [←tvars_eq_vars', vars_eq_tvars],
      exact finset.subset.refl vars,
    },

    -- CVariableDeclaration, CVariableDeclarationAss
    repeat {
      intros vars vars',
      intro is_var_update,
      rw getVariableUpdate at is_var_update,
      injection is_var_update with is_var_update,
      injection is_var_update with vars_eq eq_vars',
      rw [←vars_eq,←eq_vars'],
      exact finset.subset_union_left _ _,
    },

  end

def frame_TermType : TermType → finset Identifier → TermType
| (BlockList vars vars' b b') fvars :=
    BlockList (vars ∪ fvars) (vars' ∪ fvars) b b'
| (CBlock vars b b') fvars := CBlock (vars ∪ fvars) b b'
| (SwitchBody vars b b') fvars := SwitchBody (vars ∪ fvars) b b'
| (CExpr vars n) fvars := CExpr (vars ∪ fvars) n
| (CStatement vars vars' b b') fvars :=
    CStatement (vars ∪ fvars) (vars' ∪ fvars) b b'

lemma frame_lemma :
  ∀ s₁ s₂ s₃ : finset Identifier,
    s₁ ∪ s₂ ∪ s₃ = s₁ ∪ s₃ ∪ s₂ :=
  begin
    intros s₁ s₂ s₃,
    rw (finset.union_assoc s₁ s₂ s₃),
    rw (finset.union_assoc s₁ s₃ s₂),
    rw (finset.union_comm s₂ s₃),
  end

def frame :
  ∀ {t : TermType} (fvars : finset Identifier),
    YulTerm Γ t → YulTerm Γ (frame_TermType t fvars)
| (BlockList _ _ _ _) fvars EmpCBlock := EmpCBlock
| (BlockList _ _ _ _) fvars (SeqCBlock vars' cstmnt cblklst') :=
    SeqCBlock (vars' ∪ fvars) (frame fvars cstmnt) (frame fvars cblklst')
| (CBlock vars b b') fvars (NestedScope inner_vars inner_vars' σ blklst) :=
    let inner_vars_eq:= finset.union_assoc inner_vars vars fvars,
       inner_vars'_eq := finset.union_assoc inner_vars' vars fvars,
       cast (cblklst : YulTerm Γ (BlockList((inner_vars ∪ vars) ∪ fvars) ((inner_vars' ∪ vars) ∪ fvars) b b')) :
                 YulTerm Γ (BlockList (inner_vars ∪ (vars ∪ fvars)) (inner_vars' ∪ (vars ∪ fvars)) b b') :=
              eq.rec (eq.rec cblklst inner_vars_eq) inner_vars'_eq
      in NestedScope inner_vars inner_vars' σ (cast $ frame fvars blklst)
| (SwitchBody _ _ _) fvars (CCase lit blk swtchbody) :=
    CCase lit (frame fvars blk) (frame fvars swtchbody)
| (SwitchBody _ _ _) fvars (CDefault blk) :=
    CDefault (frame fvars blk)
| (SwitchBody _ _ _) fvars CNone :=
    CNone
| (CExpr vars m) fvars (CFunctionCall f_id n p args) :=
    CFunctionCall f_id n p (λi, frame fvars (args i))
| (CExpr vars 1) fvars (CId i i_in_vars) :=
    CId i (finset.mem_of_subset (finset.subset_union_left vars fvars) i_in_vars)
| (CExpr _ 1) fvars (CLit lit) := CLit lit
| (CExpr _ _) fvars (Scope vars_inner vars_inner' ret_vars σ stmnt) :=
    Scope vars_inner vars_inner' ret_vars σ stmnt
| (CExpr _ _) fvars (Result res_vec) :=
    Result res_vec
| (CStatement _ _ _ _) fvars (CBlock blk) :=
    CBlock (frame fvars blk)
| (CStatement vars _ b b') fvars (CVariableDeclarationAss n new_vars cexpr) :=
    let cast (cstmnt : YulTerm Γ (CStatement (vars ∪ fvars) (vars ∪ fvars ∪ tofinset new_vars) b b'))
            : YulTerm Γ (CStatement (vars ∪ fvars) (vars ∪ tofinset new_vars ∪ fvars) b b') :=
              eq.rec cstmnt (finset.union_right_comm vars fvars (tofinset new_vars))
    in cast $ CVariableDeclarationAss n new_vars (frame fvars cexpr)
| (CStatement vars _ b b') fvars (CVariableDeclaration n new_vars) :=
    let cast (cstmnt : YulTerm Γ (CStatement (vars ∪ fvars) (vars ∪ fvars ∪ tofinset new_vars) b b'))
            : YulTerm Γ (CStatement (vars ∪ fvars) (vars ∪ tofinset new_vars ∪ fvars) b b') :=
              eq.rec cstmnt (finset.union_right_comm vars fvars (tofinset new_vars))
    in cast $ CVariableDeclaration n new_vars
| (CStatement vars _ b b') fvars (CAssignment n ids in_scope cexpr) :=
    CAssignment n ids
      (has_subset.subset.trans in_scope (finset.subset_union_left vars fvars))
      (frame fvars cexpr)
| (CStatement vars _ b b') fvars (CIf cexpr blk) :=
    CIf (frame fvars cexpr) (frame fvars blk)
| (CStatement vars _ b b') fvars (CExpressionStatement cexpr) :=
    CExpressionStatement (frame fvars cexpr)
| (CStatement vars _ b b') fvars (CSwitch cexpr swtchbody) :=
    CSwitch (frame fvars cexpr) (frame fvars swtchbody)
| (CStatement vars _ b b') fvars (CFor inner_vars inner_vars' inner_vars'' init cond body post) :=
    let init_framed : YulTerm Γ (BlockList (vars ∪ fvars) (vars ∪ fvars ∪ inner_vars) NotNestedInFor b') :=
          begin
            have init_framed := frame fvars init,
            rw frame_TermType at init_framed,
            apply eq.rec init_framed,
            rw frame_lemma,
          end,
        cond_framed : YulTerm Γ (CExpr (vars ∪ fvars ∪ inner_vars) 1) :=
          begin
            have cond_framed := frame fvars cond,
            rw frame_TermType at cond_framed,
            apply eq.rec cond_framed,
            rw frame_lemma,
          end,
        body_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars) (vars ∪ fvars ∪ inner_vars') NestedInFor b') :=
          begin
            have body_framed := frame fvars body,
            rw frame_TermType at body_framed,
            apply eq.rec body_framed,
            rw (frame_lemma vars inner_vars fvars),
            rw (frame_lemma vars inner_vars' fvars),
          end,
        post_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars') (vars ∪ fvars ∪ inner_vars'') NotNestedInFor b') :=
          begin
            have post_framed := frame fvars post,
            rw frame_TermType at post_framed,
            apply eq.rec post_framed,
            rw (frame_lemma vars inner_vars' fvars),
            rw (frame_lemma vars inner_vars'' fvars),
          end
    in CFor inner_vars inner_vars' inner_vars''
        init_framed cond_framed body_framed post_framed
| (CStatement vars _ b b') fvars CBreak := CBreak
| (CStatement vars _ b b') fvars CContinue := CContinue
| (CStatement vars _ b b') fvars CLeave := CLeave
| (CStatement vars _ b b') fvars
      (ForExecInit curr_inner_vars inner_vars inner_vars' inner_vars'' σ cond loop post eval_init) :=
    let cond_framed : YulTerm Γ (CExpr (vars ∪ fvars ∪ inner_vars) 1) :=
          begin
            have cond_framed := frame fvars cond,
            rw frame_TermType at cond_framed,
            apply eq.rec cond_framed,
            rw frame_lemma,
          end,
        loop_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars) (vars ∪ fvars ∪ inner_vars') NestedInFor b') :=
          begin
            have loop_framed := frame fvars loop,
            rw frame_TermType at loop_framed,
            apply eq.rec loop_framed,
            rw (frame_lemma vars inner_vars fvars),
            rw (frame_lemma vars inner_vars' fvars),
          end,
        post_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars') (vars ∪ fvars ∪ inner_vars'') NotNestedInFor b') :=
          begin
            have post_framed := frame fvars post,
            rw frame_TermType at post_framed,
            apply eq.rec post_framed,
            rw (frame_lemma vars inner_vars' fvars),
            rw (frame_lemma vars inner_vars'' fvars),
          end,
        eval_init_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ curr_inner_vars) (vars ∪ fvars ∪ inner_vars) NotNestedInFor b') :=
          begin
            have eval_init_framed := frame fvars eval_init,
            rw frame_TermType at eval_init_framed,
            apply eq.rec eval_init_framed,
            rw (frame_lemma vars curr_inner_vars fvars),
            rw (frame_lemma vars inner_vars fvars),
          end
    in ForExecInit curr_inner_vars inner_vars inner_vars' inner_vars'' σ
        cond_framed loop_framed post_framed eval_init_framed
| (CStatement vars _ b b') fvars
      (ForCheckCond inner_vars inner_vars' inner_vars'' σ cond loop post eval_cond) :=
    let cond_framed : YulTerm Γ (CExpr (vars ∪ fvars ∪ inner_vars) 1) :=
          begin
            have cond_framed := frame fvars cond,
            rw frame_TermType at cond_framed,
            apply eq.rec cond_framed,
            rw frame_lemma,
          end,
        loop_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars) (vars ∪ fvars ∪ inner_vars') NestedInFor b') :=
          begin
            have loop_framed := frame fvars loop,
            rw frame_TermType at loop_framed,
            apply eq.rec loop_framed,
            rw (frame_lemma vars inner_vars fvars),
            rw (frame_lemma vars inner_vars' fvars),
          end,
        post_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars') (vars ∪ fvars ∪ inner_vars'') NotNestedInFor b') :=
          begin
            have post_framed := frame fvars post,
            rw frame_TermType at post_framed,
            apply eq.rec post_framed,
            rw (frame_lemma vars inner_vars' fvars),
            rw (frame_lemma vars inner_vars'' fvars),
          end,
        eval_cond_framed : YulTerm Γ (CExpr (vars ∪ fvars ∪ inner_vars) 1) :=
          begin
            have eval_cond_framed := frame fvars eval_cond,
            rw frame_TermType at eval_cond_framed,
            apply eq.rec eval_cond_framed,
            rw (frame_lemma vars inner_vars fvars),
          end
    in ForCheckCond inner_vars inner_vars' inner_vars'' σ
        cond_framed loop_framed post_framed eval_cond_framed
| (CStatement vars _ b b') fvars
      (ForExecBody curr_inner_vars inner_vars inner_vars' inner_vars'' σ p cond loop post eval_loop) :=
    let cond_framed : YulTerm Γ (CExpr (vars ∪ fvars ∪ inner_vars) 1) :=
          begin
            have cond_framed := frame fvars cond,
            rw frame_TermType at cond_framed,
            apply eq.rec cond_framed,
            rw frame_lemma,
          end,
        loop_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars) (vars ∪ fvars ∪ inner_vars') NestedInFor b') :=
          begin
            have loop_framed := frame fvars loop,
            rw frame_TermType at loop_framed,
            apply eq.rec loop_framed,
            rw (frame_lemma vars inner_vars fvars),
            rw (frame_lemma vars inner_vars' fvars),
          end,
        post_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars') (vars ∪ fvars ∪ inner_vars'') NotNestedInFor b') :=
          begin
            have post_framed := frame fvars post,
            rw frame_TermType at post_framed,
            apply eq.rec post_framed,
            rw (frame_lemma vars inner_vars' fvars),
            rw (frame_lemma vars inner_vars'' fvars),
          end,
        eval_loop_framed :YulTerm Γ (BlockList (vars ∪ fvars ∪ curr_inner_vars) (vars ∪ fvars ∪ inner_vars') NestedInFor b') :=
          begin
            have eval_loop_framed := frame fvars eval_loop,
            rw frame_TermType at eval_loop_framed,
            apply eq.rec eval_loop_framed,
            rw (frame_lemma vars inner_vars' fvars),
            rw (frame_lemma vars curr_inner_vars fvars),
          end,
        p' : vars ∪ fvars ∪ inner_vars ⊆ vars ∪ fvars ∪ curr_inner_vars :=
          begin
            intros i i_in,
            repeat {
              rw finset.mem_union at i_in,
            },
            repeat {
              rw finset.mem_union,
            },
            cases i_in with x y,
            exact or.inl x,
            cases finset.mem_union.1 (p (finset.mem_union_right vars y)) with h,
            exact or.inl (or.inl h),
            exact or.inr h,
          end
    in ForExecBody curr_inner_vars inner_vars inner_vars' inner_vars'' σ p'
        cond_framed loop_framed post_framed eval_loop_framed
| (CStatement vars _ b b') fvars
      (ForExecPost curr_inner_vars inner_vars inner_vars' inner_vars'' σ cond loop post eval_post) :=
    let cond_framed : YulTerm Γ (CExpr (vars ∪ fvars ∪ inner_vars) 1) :=
          begin
            have cond_framed := frame fvars cond,
            rw frame_TermType at cond_framed,
            apply eq.rec cond_framed,
            rw frame_lemma,
          end,
        loop_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars) (vars ∪ fvars ∪ inner_vars') NestedInFor b') :=
          begin
            have loop_framed := frame fvars loop,
            rw frame_TermType at loop_framed,
            apply eq.rec loop_framed,
            rw (frame_lemma vars inner_vars fvars),
            rw (frame_lemma vars inner_vars' fvars),
          end,
        post_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ inner_vars') (vars ∪ fvars ∪ inner_vars'') NotNestedInFor b') :=
          begin
            have post_framed := frame fvars post,
            rw frame_TermType at post_framed,
            apply eq.rec post_framed,
            rw (frame_lemma vars inner_vars' fvars),
            rw (frame_lemma vars inner_vars'' fvars),
          end,
        eval_post_framed : YulTerm Γ (BlockList (vars ∪ fvars ∪ curr_inner_vars) (vars ∪ fvars ∪ inner_vars'') NotNestedInFor b') :=
          begin
            have eval_post_framed := frame fvars eval_post,
            rw frame_TermType at eval_post_framed,
            apply eq.rec eval_post_framed,
            rw (frame_lemma vars inner_vars'' fvars),
            rw (frame_lemma vars curr_inner_vars fvars),
          end
    in ForExecPost curr_inner_vars inner_vars inner_vars' inner_vars'' σ
        cond_framed loop_framed post_framed eval_post_framed
| (CStatement vars _ b b') fvars Skip := Skip

def are_args_reduced :
  ∀ {vars : finset Identifier} {n : ℕ},
    vector (YulTerm Γ (CExpr vars 1)) n → Prop
| _ 0 _ := true
| vars (nat.succ n) ⟨ (Result _) :: cexprs, p ⟩ :=
  are_args_reduced
    (⟨
      cexprs,
      by {
            rw list.length at p,
            exact (nat.add_right_cancel p),
          }
     ⟩ : vector (YulTerm Γ (CExpr vars 1)) n)
| _ (nat.succ n) ⟨ _ :: _, _ ⟩ := false

instance (vars : finset Identifier) (n : ℕ)
  (cexprs : vector (YulTerm Γ (CExpr vars 1)) n) :
    decidable (are_args_reduced Γ cexprs) :=
  begin
    induction n,
    rw are_args_reduced,
    apply decidable.is_true,
    trivial,
    cases cexprs,
    cases cexprs_val,
    exfalso,
    exact list.ne_nil_of_length_eq_succ cexprs_property (eq.refl list.nil),
    cases cexprs_val_hd,
    repeat {
      rw are_args_reduced,
      apply decidable.is_false,
      trivial,
    },
    rw are_args_reduced,
    exact n_ih ⟨ cexprs_val_tl, _ ⟩,
  end

lemma nil_reduced :
  ∀ {Γ : FTContext} {vars : finset Identifier},
    @are_args_reduced Γ vars 0 vector.nil :=
  begin
    intros Γ vars,
    rw are_args_reduced,
    trivial,
  end

def is_result :
  ∀ {vars : finset Identifier} {n : ℕ},
    YulTerm Γ (CExpr vars n) -> Prop
| _ _ (Result _) := true
| _ _ (CLit _) := false
| _ _ (CId _ _) := false
| _ _ (CFunctionCall _ _ _ _) := false
| _ _ (Scope _ _ _ _ _) := false

instance
  (vars : finset Identifier) (n : ℕ)
    (cexpr : YulTerm Γ (CExpr vars n)) : decidable (is_result Γ cexpr) :=
  begin
    cases cexpr,
    repeat {
      rw is_result,
      apply decidable.is_false,
      trivial,
    },
    rw is_result,
    apply decidable.is_true,
    trivial,
  end

def is_skip :
  ∀ {vars vars': finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm Γ (CStatement vars vars' b b') -> Prop
| _ _ _ _ Skip := true
| _ _ _ _ (CBlock _) := false
| _ _ _ _ (CVariableDeclarationAss _ _ _) := false
| _ _ _ _ (CVariableDeclaration _ _) := false
| _ _ _ _ (CAssignment _ _ _ _) := false
| _ _ _ _ (CIf _ _) := false
| _ _ _ _ (CExpressionStatement _) := false
| _ _ _ _ (CSwitch _ _) := false
| _ _ _ _ (CFor _ _ _ _ _ _ _) := false
| _ _ _ _ CBreak := false
| _ _ _ _ CContinue := false
| _ _ _ _ CLeave := false
| _ _ _ _ (ForExecInit _ _ _ _ _ _ _ _ _) := false
| _ _ _ _ (ForCheckCond _ _ _ _ _ _ _ _) := false
| _ _ _ _ (ForExecBody _ _ _ _ _ _ _ _ _ _) := false
| _ _ _ _ (ForExecPost _ _ _ _ _ _ _ _ _) := false

lemma is_skip_imp_vars_eq_vars' :
  ∀ {vars vars' : finset Identifier} {b : IsInFor} {b' : IsInFunc}
      {cstmnt : YulTerm Γ (CStatement vars vars' b b')},
    is_skip Γ cstmnt → vars' = vars :=
  begin
    intros vars vars' b b' cstmnt cstmnt_is_skip,
    cases cstmnt,
    repeat {
      rw is_skip at cstmnt_is_skip,
    },
    repeat {
      exfalso,
      exact cstmnt_is_skip,
    },
  end

instance is_skip_decidable {vars vars' : finset Identifier} {b : IsInFor} {b' : IsInFunc}
  {stmnt : YulTerm Γ (CStatement vars vars' b b')} : decidable (is_skip Γ stmnt) :=
  begin
    cases stmnt,
    repeat{
      rw is_skip,
      apply decidable.is_false,
      trivial,
    },
    rw is_skip,
    apply decidable.is_true,
    trivial,
  end

def is_empcblock :
  ∀ {vars vars' : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm Γ (BlockList vars vars' b b') → Prop
| _ _ _ _ EmpCBlock := true
| _ _ _ _ _ := false

instance empcblock_decidable
  {vars vars' : finset Identifier} {b : IsInFor} {b' : IsInFunc}
    {blklst : YulTerm Γ (BlockList vars vars' b b')} :
  decidable (is_empcblock Γ blklst) :=
  begin
    cases blklst,
    rw is_empcblock,
    apply decidable.is_true,
    trivial,
    rw is_empcblock,
    apply decidable.is_false,
    trivial,
  end

lemma is_empcblock_imp_vars_eq_vars' :
  ∀ {vars vars' : finset Identifier} {b : IsInFor}
      {b' : IsInFunc} {cblk : YulTerm Γ (BlockList vars vars' b b')},
    is_empcblock Γ cblk → vars = vars' :=
  begin
    intros vars vars' b b' cblk cblk_is_empcblock,
    cases cblk,
    refl,
    exfalso,
    rw is_empcblock at cblk_is_empcblock,
    exact cblk_is_empcblock,
  end

def is_empblock :
  ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    YulTerm Γ (CBlock vars b b') → Prop
| _ _ _ (NestedScope _ _ _ blklst) := is_empcblock Γ blklst

instance (vars : finset Identifier) (b : IsInFor) (b' : IsInFunc)
  (blk : YulTerm Γ (CBlock vars b b')) : decidable (is_empblock Γ blk) :=
  begin
    cases blk,
    rw is_empblock,
    exact YulCommands.empcblock_decidable Γ,
  end

def to_literal : ∀ {vars : finset Identifier} {n : ℕ}
      (cexpr : YulTerm Γ (CExpr vars n)), is_result Γ cexpr → vector Literal n
  | _ _ cexpr@(CFunctionCall _ _ _ _) cexpr_is_res :=
    let cexpr_n_is_res : ¬ is_result Γ cexpr :=
      begin
        rw is_result,
        intro f,
        exact f,
      end
    in absurd cexpr_is_res cexpr_n_is_res
  | _ _ cexpr@(CId _ _) cexpr_is_res :=
    let cexpr_n_is_res : ¬ is_result Γ cexpr :=
      begin
        rw is_result,
        intro f,
        exact f,
      end
    in absurd cexpr_is_res cexpr_n_is_res
  | _ _ cexpr@(CLit l) cexpr_is_res :=
    let cexpr_n_is_res : ¬ is_result Γ cexpr :=
      begin
        rw is_result,
        intro f,
        exact f,
      end
    in absurd cexpr_is_res cexpr_n_is_res
  | _ _ cexpr@(Scope _ _ _ _ _) cexpr_is_res :=
    let cexpr_n_is_res : ¬ is_result Γ cexpr :=
      begin
        rw is_result,
        intro f,
        exact f,
      end
    in absurd cexpr_is_res cexpr_n_is_res
  | _ _ cexpr@(Result res_vec) _ := res_vec

def getCase :
  ∀ {vars : finset Identifier} {b : IsInFor} {b' : IsInFunc},
    Literal -> YulTerm Γ (SwitchBody vars b b') → YulTerm Γ (CBlock vars b b')
| _ _ _ _ CNone := NestedScope ∅ ∅ empStore EmpCBlock
| _ _ _ _ (CDefault blk) := blk
| _ _ _ l (CCase lit blk swtchbody') :=
  if l = lit
  then blk
  else getCase l swtchbody'

lemma reduced_and_n_tail_reduced_imp_n_lit
  {vars : finset Identifier}
  (cexpr : YulTerm Γ (CExpr vars 1))
  {n : ℕ}
  (cexprs : vector (YulTerm Γ (CExpr vars 1)) n) :
    ¬ (are_args_reduced Γ (vector.cons cexpr cexprs)) → are_args_reduced Γ cexprs →
      ¬ is_result Γ cexpr :=
  begin
    intros full_not_red tail_red,
    cases cexpr,
    repeat {
      rw is_result,
      intro f,
      exact f,
    },
    cases cexprs,
    exfalso,
    rw vector.cons at full_not_red,
    rw are_args_reduced at full_not_red,
    exact full_not_red(tail_red),
  end

def get_lits :
  ∀ {vars : finset Identifier} {n : ℕ}
    (arg_cexprs : vector (YulTerm Γ (CExpr vars 1)) n),
  are_args_reduced Γ arg_cexprs → vector Literal n
| _ 0 _ _ := vector.nil
| vars (nat.succ n) ⟨(Result lit) :: lit_cexprs, len_p⟩ p :=
  let lit_cexprs_vec' : vector (YulTerm Γ (CExpr vars 1)) n :=
        ⟨ lit_cexprs,
          by {
            rw list.length at len_p,
            exact (nat.add_right_cancel len_p),
          }
        ⟩
  in vector.cons lit.head $
      get_lits lit_cexprs_vec' $
        by {
          rw are_args_reduced at p,
          exact p,
        }

end YulCommands


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon, Patrick Massot
-/
import algebra.group.pi
import group_theory.group_action.defs

/-!
# Pi instances for multiplicative actions

This file defines instances for mul_action and related structures on Pi types.

## See also

* `group_theory.group_action.prod`
* `group_theory.group_action.sigma`
* `group_theory.group_action.sum`
-/

universes u v w
variable {I : Type u}     -- The indexing type
variable {f : I → Type v} -- The family of types already equipped with instances
variables (x y : Π i, f i) (i : I)

namespace pi

@[to_additive pi.has_vadd]
instance has_scalar {α : Type*} [Π i, has_scalar α $ f i] :
  has_scalar α (Π i : I, f i) :=
⟨λ s x, λ i, s • (x i)⟩

@[to_additive]
lemma smul_def {α : Type*} [Π i, has_scalar α $ f i] (s : α) : s • x = λ i, s • x i := rfl
@[simp, to_additive]
lemma smul_apply {α : Type*} [Π i, has_scalar α $ f i] (s : α) : (s • x) i = s • x i := rfl

@[to_additive pi.has_vadd']
instance has_scalar' {g : I → Type*} [Π i, has_scalar (f i) (g i)] :
  has_scalar (Π i, f i) (Π i : I, g i) :=
⟨λ s x, λ i, (s i) • (x i)⟩

@[simp, to_additive]
lemma smul_apply' {g : I → Type*} [∀ i, has_scalar (f i) (g i)] (s : Π i, f i) (x : Π i, g i) :
  (s • x) i = s i • x i :=
rfl
instance is_scalar_tower {α β : Type*}
  [has_scalar α β] [Π i, has_scalar β $ f i] [Π i, has_scalar α $ f i]
  [Π i, is_scalar_tower α β (f i)] : is_scalar_tower α β (Π i : I, f i) :=
⟨λ x y z, funext $ λ i, smul_assoc x y (z i)⟩

instance is_scalar_tower' {g : I → Type*} {α : Type*}
  [Π i, has_scalar α $ f i] [Π i, has_scalar (f i) (g i)] [Π i, has_scalar α $ g i]
  [Π i, is_scalar_tower α (f i) (g i)] : is_scalar_tower α (Π i : I, f i) (Π i : I, g i) :=
⟨λ x y z, funext $ λ i, smul_assoc x (y i) (z i)⟩

instance is_scalar_tower'' {g : I → Type*} {h : I → Type*}
  [Π i, has_scalar (f i) (g i)] [Π i, has_scalar (g i) (h i)] [Π i, has_scalar (f i) (h i)]
  [Π i, is_scalar_tower (f i) (g i) (h i)] : is_scalar_tower (Π i, f i) (Π i, g i) (Π i, h i) :=
⟨λ x y z, funext $ λ i, smul_assoc (x i) (y i) (z i)⟩

@[to_additive]
instance smul_comm_class {α β : Type*}
  [Π i, has_scalar α $ f i] [Π i, has_scalar β $ f i] [∀ i, smul_comm_class α β (f i)] :
  smul_comm_class α β (Π i : I, f i) :=
⟨λ x y z, funext $ λ i, smul_comm x y (z i)⟩

@[to_additive]
instance smul_comm_class' {g : I → Type*} {α : Type*}
  [Π i, has_scalar α $ g i] [Π i, has_scalar (f i) (g i)] [∀ i, smul_comm_class α (f i) (g i)] :
  smul_comm_class α (Π i : I, f i) (Π i : I, g i) :=
⟨λ x y z, funext $ λ i, smul_comm x (y i) (z i)⟩

@[to_additive]
instance smul_comm_class'' {g : I → Type*} {h : I → Type*}
  [Π i, has_scalar (g i) (h i)] [Π i, has_scalar (f i) (h i)]
  [∀ i, smul_comm_class (f i) (g i) (h i)] : smul_comm_class (Π i, f i) (Π i, g i) (Π i, h i) :=
⟨λ x y z, funext $ λ i, smul_comm (x i) (y i) (z i)⟩

instance {α : Type*} [Π i, has_scalar α $ f i] [Π i, has_scalar αᵐᵒᵖ $ f i]
  [∀ i, is_central_scalar α (f i)] : is_central_scalar α (Π i, f i) :=
⟨λ r m, funext $ λ i, op_smul_eq_smul _ _⟩

/-- If `f i` has a faithful scalar action for a given `i`, then so does `Π i, f i`. This is
not an instance as `i` cannot be inferred. -/
@[to_additive pi.has_faithful_vadd_at]
lemma has_faithful_smul_at {α : Type*}
  [Π i, has_scalar α $ f i] [Π i, nonempty (f i)] (i : I) [has_faithful_smul α (f i)] :
  has_faithful_smul α (Π i, f i) :=
⟨λ x y h, eq_of_smul_eq_smul $ λ a : f i, begin
  classical,
  have := congr_fun (h $ function.update (λ j, classical.choice (‹Π i, nonempty (f i)› j)) i a) i,
  simpa using this,
end⟩

@[to_additive pi.has_faithful_vadd]
instance has_faithful_smul {α : Type*}
  [nonempty I] [Π i, has_scalar α $ f i] [Π i, nonempty (f i)] [Π i, has_faithful_smul α (f i)] :
  has_faithful_smul α (Π i, f i) :=
let ⟨i⟩ := ‹nonempty I› in has_faithful_smul_at i

@[to_additive]
instance mul_action (α) {m : monoid α} [Π i, mul_action α $ f i] :
  @mul_action α (Π i : I, f i) m :=
{ smul := (•),
  mul_smul := λ r s f, funext $ λ i, mul_smul _ _ _,
  one_smul := λ f, funext $ λ i, one_smul α _ }

@[to_additive]
instance mul_action' {g : I → Type*} {m : Π i, monoid (f i)} [Π i, mul_action (f i) (g i)] :
  @mul_action (Π i, f i) (Π i : I, g i) (@pi.monoid I f m) :=
{ smul := (•),
  mul_smul := λ r s f, funext $ λ i, mul_smul _ _ _,
  one_smul := λ f, funext $ λ i, one_smul _ _ }

instance distrib_mul_action (α) {m : monoid α} {n : ∀ i, add_monoid $ f i}
  [∀ i, distrib_mul_action α $ f i] :
  @distrib_mul_action α (Π i : I, f i) m (@pi.add_monoid I f n) :=
{ smul_zero := λ c, funext $ λ i, smul_zero _,
  smul_add := λ c f g, funext $ λ i, smul_add _ _ _,
  ..pi.mul_action _ }

instance distrib_mul_action' {g : I → Type*} {m : Π i, monoid (f i)} {n : Π i, add_monoid $ g i}
  [Π i, distrib_mul_action (f i) (g i)] :
  @distrib_mul_action (Π i, f i) (Π i : I, g i) (@pi.monoid I f m) (@pi.add_monoid I g n) :=
{ smul_add := by { intros, ext x, apply smul_add },
  smul_zero := by { intros, ext x, apply smul_zero } }

lemma single_smul {α} [monoid α] [Π i, add_monoid $ f i]
  [Π i, distrib_mul_action α $ f i] [decidable_eq I] (i : I) (r : α) (x : f i) :
  single i (r • x) = r • single i x :=
single_op (λ i : I, ((•) r : f i → f i)) (λ j, smul_zero _) _ _

/-- A version of `pi.single_smul` for non-dependent functions. It is useful in cases Lean fails
to apply `pi.single_smul`. -/
lemma single_smul' {α β} [monoid α] [add_monoid β]
  [distrib_mul_action α β] [decidable_eq I] (i : I) (r : α) (x : β) :
  single i (r • x) = r • single i x :=
single_smul i r x

lemma single_smul₀ {g : I → Type*} [Π i, monoid_with_zero (f i)] [Π i, add_monoid (g i)]
  [Π i, distrib_mul_action (f i) (g i)] [decidable_eq I] (i : I) (r : f i) (x : g i) :
  single i (r • x) = single i r • single i x :=
single_op₂ (λ i : I, ((•) : f i → g i → g i)) (λ j, smul_zero _) _ _ _

instance mul_distrib_mul_action (α) {m : monoid α} {n : Π i, monoid $ f i}
  [Π i, mul_distrib_mul_action α $ f i] :
  @mul_distrib_mul_action α (Π i : I, f i) m (@pi.monoid I f n) :=
{ smul_one := λ c, funext $ λ i, smul_one _,
  smul_mul := λ c f g, funext $ λ i, smul_mul' _ _ _,
  ..pi.mul_action _ }

instance mul_distrib_mul_action' {g : I → Type*} {m : Π i, monoid (f i)} {n : Π i, monoid $ g i}
  [Π i, mul_distrib_mul_action (f i) (g i)] :
  @mul_distrib_mul_action (Π i, f i) (Π i : I, g i) (@pi.monoid I f m) (@pi.monoid I g n) :=
{ smul_mul := by { intros, ext x, apply smul_mul' },
  smul_one := by { intros, ext x, apply smul_one } }

end pi

namespace function

/-- Non-dependent version of `pi.has_scalar`. Lean gets confused by the dependent instance if this
is not present. -/
@[to_additive has_vadd]
instance has_scalar {ι R M : Type*} [has_scalar R M] :
  has_scalar R (ι → M) :=
pi.has_scalar

/-- Non-dependent version of `pi.smul_comm_class`. Lean gets confused by the dependent instance if
this is not present. -/
@[to_additive]
instance smul_comm_class {ι α β M : Type*}
  [has_scalar α M] [has_scalar β M] [smul_comm_class α β M] :
  smul_comm_class α β (ι → M) :=
pi.smul_comm_class

@[to_additive]
lemma update_smul {α : Type*} [Π i, has_scalar α (f i)] [decidable_eq I]
  (c : α) (f₁ : Π i, f i) (i : I) (x₁ : f i) :
  update (c • f₁) i (c • x₁) = c • update f₁ i x₁ :=
funext $ λ j, (apply_update (λ i, (•) c) f₁ i x₁ j).symm

end function

namespace set

@[to_additive]
lemma piecewise_smul {α : Type*} [Π i, has_scalar α (f i)] (s : set I) [Π i, decidable (i ∈ s)]
  (c : α) (f₁ g₁ : Π i, f i) :
  s.piecewise (c • f₁) (c • g₁) = c • s.piecewise f₁ g₁ :=
s.piecewise_op _ _ (λ _, (•) c)

end set

section extend

@[to_additive] lemma function.extend_smul {R α β γ : Type*} [has_scalar R γ]
  (r : R) (f : α → β) (g : α → γ) (e : β → γ) :
  function.extend f (r • g) (r • e) = r • function.extend f g e :=
funext $ λ _, by convert (apply_dite ((•) r) _ _ _).symm

end extend


import tactic
import .direction
import .boolset2d
import .listdec
import .sokostate
import .sokowidget

structure sokolevel :=
(avail : bset2d)
(ini : sokostate)
(goal : boxes_only)

instance : inhabited sokolevel
:= ⟨{ avail := [[tt]], ini := {boxes := [], storekeeper := (0,0)}, goal := ⟨[]⟩ }⟩

namespace sokolevel

def valid (level : sokolevel) := level.ini.valid level.avail
instance {level : sokolevel} : decidable level.valid
  := sokostate.valid.decidable

lemma default.valid : (default sokolevel).valid := dec_trivial

def move (level : sokolevel) (d : direction) : sokolevel
:= {ini := (level.ini.move level.avail d) ..level}

def solvable (level : sokolevel) :=
  exists goal_state : sokostate, goal_state ∈ level.goal ∧
    goal_state.reachable level.avail level.ini

lemma solvable.triv (level : sokolevel)
: level.ini ∈ level.goal → level.solvable
:= λ Hin, ⟨level.ini, ⟨Hin, sokostate.reachable.triv⟩⟩

lemma solvable.move (d : direction) (level : sokolevel)
: (level.move d).solvable → level.solvable
:= λ Hsol, exists.elim Hsol (λ goal Hsol,
  ⟨goal, ⟨Hsol.1, sokostate.reachable.move d Hsol.2⟩⟩ )

--   _                            _
--  (_)_ __ ___  _ __   ___  _ __| |_
--  | | '_ ` _ \| '_ \ / _ \| '__| __|
--  | | | | | | | |_) | (_) | |  | |_
--  |_|_| |_| |_| .__/ \___/|_|   \__|
--              |_|

def add_newline (s : sokolevel) : sokolevel := {
  avail := []::s.avail,
  ini := {
    boxes := []::s.ini.boxes,
    storekeeper := match s.ini.storekeeper with (x,y) := (x,y+1) end
  },
  goal := { boxes := []::s.goal.boxes },
}
def add_newsquare (av box stor sk : bool) (s : sokolevel) : sokolevel := {
  avail := list2d.add_to_line1 av s.avail,
  ini := {
    boxes := list2d.add_to_line1 box s.ini.boxes,
    storekeeper := if sk then (0, 0) else match s.ini.storekeeper with
      | (x,0) := (x+1,0)
      | xy := xy
    end
  },
  goal := { boxes := list2d.add_to_line1 stor s.goal.boxes, }
}

def from_string_aux : list char → option (sokolevel × bool)
| [] := some ( ⟨ [], ⟨[], (0,0)⟩, ⟨[]⟩⟩ , ff)
| (c::str) := match (from_string_aux str), c with
  | none, _ := none
  | (some (s, sk_set)), '\n' := some (s.add_newline, sk_set)
  | (some (s, sk_set)), ' ' := some (s.add_newsquare tt ff ff ff, sk_set)
  | (some (s, sk_set)), '#' := some (s.add_newsquare ff ff ff ff, sk_set)
  | (some (s, sk_set)), '.' := some (s.add_newsquare tt ff tt ff, sk_set)
  | (some (s, sk_set)), '$' := some (s.add_newsquare tt tt ff ff, sk_set)
  | (some (s, sk_set)), '*' := some (s.add_newsquare tt tt tt ff, sk_set)
  | (some (s, ff)), '@' := some (s.add_newsquare tt ff ff tt, tt)
  | (some (s, ff)), '+' := some (s.add_newsquare tt ff tt tt, tt)
  | (some _), _ := none
  end

def from_string (str : string) : sokolevel :=
  match (from_string_aux str.to_list) with
  | none := default sokolevel
  | some (_, ff) := default sokolevel
  | some (level, tt) := level
  end

--                              _
--    _____  ___ __   ___  _ __| |_
--   / _ \ \/ / '_ \ / _ \| '__| __|
--  |  __/>  <| |_) | (_) | |  | |_
--   \___/_/\_\ .__/ \___/|_|   \__|
--            |_|

def square_to_char : bool → bool → bool → bool → char
| tt ff ff ff := ' '
| ff ff ff ff := '#'
| tt ff tt ff := '.'
| tt tt ff ff := '$'
| tt tt tt ff := '*'
| tt ff ff tt := '@'
| tt ff tt tt := '+'
| _ _ _ _ := '?'

def to_string_aux1 (str : list char) : list (bool × bool × bool × bool) → list char
| [] := str
| ((av,box,stor,sk)::t) := (square_to_char av box stor sk)::(to_string_aux1 t)

def to_string_aux2 : list2d (bool × bool × bool × bool) → list char
| [] := []
| (h::t) := to_string_aux1 ('\n'::(to_string_aux2 t)) h

instance : has_to_string sokolevel := ⟨λ s,
  list.as_string (to_string_aux2
  (s.avail.dfzip2d (s.ini.boxes.dfzip2d (s.goal.boxes.dfzip2d (list2d.set2d true [] s.ini.storekeeper)))))
⟩

instance : has_repr sokolevel
:= ⟨λ lev, (string.append (string.append "from_string \"" (to_string lev)) "\"")⟩

meta def to_html (lev : sokolevel) : widget.html empty
  := sokowidget.build_table lev.avail lev.avail lev.ini.boxes lev.goal.boxes (bset2d.from_index lev.ini.storekeeper)

--       _                 _ _  __ _           _   _
--   ___(_)_ __ ___  _ __ | (_)/ _(_) ___ __ _| |_(_) ___  _ __
--  / __| | '_ ` _ \| '_ \| | | |_| |/ __/ _` | __| |/ _ \| '_ \
--  \__ \ | | | | | | |_) | | |  _| | (_| (_| | |_| | (_) | | | |
--  |___/_|_| |_| |_| .__/|_|_|_| |_|\___\__,_|\__|_|\___/|_| |_|
--                  |_|

meta def soko_show : tactic unit :=
do
  `(sokolevel.solvable %%lev_e) ← tactic.target,
  lev ← tactic.eval_expr sokolevel lev_e,
  tactic.trace (to_string lev)

meta def soko_simp_root (e : expr) : tactic unit :=
do
  soko ← tactic.eval_expr sokolevel e,
  tactic.trace (to_string soko),
  let p : pexpr := ``(%%e = sokolevel.mk
    %%soko.avail (sokostate.mk %%soko.ini.boxes %%soko.ini.storekeeper) (boxes_only.mk %%soko.goal.boxes)),
  eq ← tactic.to_expr p,
  name ← tactic.get_unused_name,
  H ← tactic.assert name eq,
  tactic.reflexivity,
  tactic.rewrite_target H,
  tactic.clear H

meta def soko_simp : tactic unit :=
do
  `(sokolevel.solvable %%lev) ← tactic.target,
  soko_simp_root lev

meta def soko_check_depth : expr → ℕ → tactic unit
| _ 0 := return ()
| e (n+1) := do
  `(sokolevel.move %%lev _) ← return e,
  soko_check_depth lev n

meta def soko_simp_if_deep : tactic unit :=
do
  `(sokolevel.solvable %%lev) ← tactic.target,
  tactic.try ((soko_check_depth lev 20) >> (soko_simp_root lev))

meta def solve_up : tactic unit
:= tactic.apply `(solvable.move direction.up) >> soko_simp_if_deep
meta def solve_down : tactic unit
:= tactic.apply `(solvable.move direction.down) >> soko_simp_if_deep
meta def solve_left : tactic unit
:= tactic.apply `(solvable.move direction.left) >> soko_simp_if_deep
meta def solve_right : tactic unit
:= tactic.apply `(solvable.move direction.right) >> soko_simp_if_deep
meta def solve_finish : tactic unit
:= tactic.apply `(solvable.triv) >> tactic.apply `(@of_as_true) >> tactic.triv

end sokolevel


-- Copyright (c) Microsoft Corporation. All rights reserved.
-- Licensed under the MIT license.

import ..smtexpr
import ..smtcompile
import ..bitvector
import ..verifyopt
import .spec
import .lemmas
import .irstate
import .freevar
import .equiv
import .openprog
import ..irsem_exec
import smt2.syntax
import system.io
import init.meta.tactic
import init.meta.interactive

namespace spec

open opt
open irsem

set_option pp.proofs true
lemma check_val_exec_spec_prf : check_val_exec_spec
:= begin
  unfold check_val_exec_spec,
  intros,
  cases vsrc with szsrc vsrc psrc,
  cases vtgt with sztgt vtgt ptgt,
  unfold check_val at H,
  have HSZ:decidable (sztgt = szsrc), apply_instance,
  cases HSZ,
  { rw dif_neg at H, cases H, apply neq_symm, assumption },
  {
    rw dif_pos at H,
    rw valty_rwsize_exec sztgt szsrc,
    injection H with H,
    generalize H0: (vsrc =_{irsem_exec.boolty}
      cast (check_val._match_1._proof_1
        irsem_exec szsrc sztgt (eq.symm HSZ)) vtgt) = t,
    rw H0 at H,
    unfold has_not.not at H,
    unfold has_or.or at H,
    unfold has_and.and at H,

    cases psrc,
    {
      apply val_refines.poison_intty, refl
    },
    {
      apply val_refines.concrete_intty,
      { refl },
      { cases ptgt,
        {
          cases t, cases H, cases H
        },
        refl },
      {
        cases t,
        { cases ptgt, cases H, cases H },
        {
          unfold has_eq.eq at H0,
          unfold has_comp.eq at H0,
          unfold bitvector.eq at H0,
          simp at H0, rw H0
        }
      }
    },
    any_goals { assumption }
  }
end

set_option pp.proofs true
lemma check_val_replace: ∀ vssrc vstgt (η:freevar.env),
  η⟦opt.check_val irsem_smt vssrc vstgt⟧' = opt.check_val irsem_smt (η⟦vssrc⟧) (η⟦vstgt⟧)
:= begin
  intros,
  cases vssrc, cases vstgt,
  unfold opt.check_val,
  unfold freevar.env.replace_valty,
  have HSZ: decidable (vssrc_sz = vstgt_sz), apply_instance,
  cases HSZ,
  {
    unfold check_val._match_1,
    rw dif_neg HSZ,
    rw dif_neg HSZ
  },
  {
    unfold check_val._match_1,
    rw dif_pos HSZ,
    rw dif_pos HSZ,
    unfold apply,
    unfold_coes,
    unfold id,
    rw env.replace_sb_or,
    rw env.replace_sb_not,
    rw env.replace_sb_and,
    unfold has_eq.eq, unfold has_comp.eq,
    rw env.replace_sb_eqbv,
    rw env.replace_sbv_cast, rw HSZ
  }
end

lemma check_val_some: ∀ {vssrc vstgt vesrc vetgt sres eres}
    (HEQS:equals_size vssrc vesrc = tt)
    (HEQT:equals_size vstgt vetgt = tt)
    (HS:sres = opt.check_val irsem_smt vssrc vstgt)
    (HE:eres = opt.check_val irsem_exec vesrc vetgt),
  none_or_some sres eres (λ s e, true)
:= begin
  intros,
  cases vssrc, cases vesrc, cases vstgt, cases vetgt,
  unfold equals_size at HEQS, simp at HEQS,
  unfold equals_size at HEQT, simp at HEQT,
  unfold check_val at HS,
  unfold check_val at HE,

  have HSZ': decidable (vssrc_sz = vstgt_sz), apply_instance,
  cases HSZ',
  {
    have HSZ'': vesrc_sz ≠ vetgt_sz,
    { rw ← HEQS, rw ← HEQT, assumption },
    rw dif_neg HSZ' at HS,
    rw dif_neg HSZ'' at HE,
    unfold none_or_some, left, split; assumption
  },
  {
    have HSZ'': vesrc_sz = vetgt_sz,
    { rw ← HEQS, rw ← HEQT, assumption },
    rw dif_pos HSZ' at HS,
    rw dif_pos HSZ'' at HE,
    cases sres, cases HS, injection HS,
    cases eres, cases HE, injection HE,
    unfold none_or_some, right, apply exists.intro,
    apply exists.intro, split, refl, split, refl, constructor
  }
end

lemma check_val_equiv: ∀ {vssrc vstgt vesrc vetgt sres eres}
    (HEQS:val_equiv vssrc vesrc)
    (HEQT:val_equiv vstgt vetgt)
    (HS:sres = opt.check_val irsem_smt vssrc vstgt)
    (HE:eres = opt.check_val irsem_exec vesrc vetgt),
  none_or_some sres eres (λ s e, b_equiv s e)
:= begin
  intros,
  cases vssrc, cases vstgt,
  cases vesrc, cases vetgt, -- make ivals
  have HSSZEQ := val_equiv_eqsize HEQS,
  have HTSZEQ := val_equiv_eqsize HEQT,
  unfold opt.check_val at *,

  have HSZ': decidable (vssrc_sz = vstgt_sz), apply_instance,
  cases HSZ',
  {
    have HSZ'': vesrc_sz ≠ vetgt_sz,
    {
      rw ← HSSZEQ, rw ← HTSZEQ, assumption
    },
    rw dif_neg HSZ' at HS,
    rw dif_neg HSZ'' at HE,
    rw HS, rw HE, unfold none_or_some, left, split;refl
  },
  {
    have HSZ'': vesrc_sz = vetgt_sz,
    { rw [← HSSZEQ, ← HTSZEQ], rw HSZ' },
    rw dif_pos HSZ' at HS,
    rw dif_pos HSZ'' at HE,
    cases sres, cases HS,
    cases eres, cases HE,
    injection HS with HS, injection HE with HE,
    unfold none_or_some,
    right,
    existsi sres, existsi eres,
    split, refl, split, refl,
    rw [HS, HE],

    cases HEQS,
    { -- source is poison.
      cases HEQS_a with HEQS_a,
      apply b_equiv.or1,
      { apply b_equiv.not, unfold_coes, unfold id, assumption },
      { intros H, rw HEQS_a_2 at H, cases H }
    },
    { -- source is concrete value,
      cases HEQS_a,
      cases HEQT,
      { -- target is poison
        apply b_equiv.or1, apply b_equiv.not, assumption,
        intros, apply b_equiv.and1, cases HEQT_a, assumption,
        intros, rw HEQT_a_2 at a_1, cases a_1
      },
      {
        cases HEQT_a,
        apply b_equiv.or1,
        { apply b_equiv.not, assumption },
        { intros, apply b_equiv.and1, assumption, intros,
          apply b_equiv.eq, assumption, --apply HEQT_a_1, apply bv_equiv.cast,
          apply bv_equiv_cast, assumption, rw HSZ''
        }
      }
    }
  }
end

universe u
lemma check_single_reg0_replace: ∀ psrc ptgt root ss0 (η:freevar.env),
    η⟦opt.check_single_reg0 irsem_smt psrc ptgt root ss0⟧' =
        opt.check_single_reg0 irsem_smt psrc ptgt root (η⟦ss0⟧)
:= begin
  intros,
  unfold opt.check_single_reg0,
  generalize HSS: irsem.bigstep irsem_smt ss0 psrc = oss,
  generalize HSS': irsem.bigstep irsem_smt ss0 ptgt = oss',
  rw ← bigstep_replace,
  rw ← bigstep_replace,
  rw HSS, rw HSS',
  unfold has_bind.bind,
  cases oss; cases oss';unfold option.bind,
  generalize HSV: irstate.getreg irsem_smt oss root = ovs,
  generalize HSV': irstate.getreg irsem_smt oss' root = ovs',
  rw getreg_replace HSV,
  rw getreg_replace HSV',
  cases ovs; cases ovs'; unfold option.bind,
  rw ← check_val_replace,
  generalize HCV: check_val irsem_smt ovs ovs' = ocv,
  cases ocv;unfold option.bind,
  unfold return, unfold pure,
  unfold apply,
  rw env.replace_sb_or,
  rw env.replace_sb_not,
  rw replace_getub,
  rw env.replace_sb_and,
  rw replace_getub
end

lemma check_single_reg0_equiv: ∀ psrc ptgt root ss0 se0 sres eres
    (HEQ:irstate_equiv ss0 se0)
    (HS:sres = opt.check_single_reg0 irsem_smt psrc ptgt root ss0)
    (HE:eres = opt.check_single_reg0 irsem_exec psrc ptgt root se0)
    (HEQS:irstate_equiv ss0 se0),
  none_or_some sres eres (λ s e, b_equiv s e)
:= begin
  intros,
  unfold opt.check_single_reg0 at *,
  unfold has_bind.bind at HS,
  unfold has_bind.bind at HE,
  generalize HSS: irsem.bigstep irsem_smt ss0 psrc = oss,
  generalize HSS': irsem.bigstep irsem_smt ss0 ptgt = oss',
  generalize HSE: irsem.bigstep irsem_exec se0 psrc = ose,
  generalize HSE': irsem.bigstep irsem_exec se0 ptgt = ose',
  rw [HSS, HSS'] at HS,
  rw [HSE, HSE'] at HE,
  have HPTGT_ENTANGLED: none_or_some oss' ose' (λ ss' se', irstate_equiv ss' se'),
  {
    apply bigstep_both_equiv,
    assumption, rw HSS', rw HSE'
  },
  have HPSRC_ENTANGLED: none_or_some oss ose (λ ss' se', irstate_equiv ss' se'),
  {
    apply bigstep_both_equiv,
    assumption, rw HSS, rw HSE
  },
  cases oss; cases oss';
  cases ose; cases ose',
  any_goals { unfold option.bind at HS, unfold option.bind at HE,
              rw HS, rw HE, unfold none_or_some, left, split; refl },
  any_goals {
    exfalso, apply none_or_some_false2, apply HPSRC_ENTANGLED
  },
  any_goals {
    exfalso, apply none_or_some_false1, apply HPSRC_ENTANGLED
  },
  any_goals {
    exfalso, apply none_or_some_false2, apply HPTGT_ENTANGLED
  },
  any_goals {
    exfalso, apply none_or_some_false1, apply HPTGT_ENTANGLED
  },
  rw none_or_some_apply at HPSRC_ENTANGLED,
  rw none_or_some_apply at HPTGT_ENTANGLED,
  unfold option.bind at HS,
  unfold option.bind at HE,
  generalize HSV: irstate.getreg irsem_smt oss root = ovs,
  generalize HSV': irstate.getreg irsem_smt oss' root = ovs',
  generalize HEV: irstate.getreg irsem_exec ose root = ove,
  generalize HEV': irstate.getreg irsem_exec ose' root = ove',
  have HSRCVEQ := irstate.getreg_equiv HPSRC_ENTANGLED (eq.symm HSV) (eq.symm HEV),
  have HTGTVEQ := irstate.getreg_equiv HPTGT_ENTANGLED (eq.symm HSV') (eq.symm HEV'),
  rw [HSV, HSV'] at HS,
  rw [HEV, HEV'] at HE,
  cases ovs; cases ovs'; cases ove; cases ove',
  any_goals { unfold option.bind at HS, unfold option.bind at HE,
              rw HS, rw HE, unfold none_or_some, left, split; refl },
  any_goals {
    exfalso, apply none_or_some_false2, apply HSRCVEQ
  },
  any_goals {
    exfalso, apply none_or_some_false1, apply HSRCVEQ
  },
  any_goals {
    exfalso, apply none_or_some_false2, apply HTGTVEQ
  },
  any_goals {
    exfalso, apply none_or_some_false1, apply HTGTVEQ
  },
  rw none_or_some_apply at HSRCVEQ,
  rw none_or_some_apply at HTGTVEQ,
  unfold option.bind at HS,
  unfold option.bind at HE,
  cases HSRCVEQ with HSRCSZEQ HSRCVEQ,
  cases HTGTVEQ with HTGTSZEQ HTGTVEQ,
  generalize HSCV: check_val irsem_smt ovs ovs' = scv,
  generalize HECV: check_val irsem_exec ove ove' = ecv,
  rw HSCV at HS, rw HECV at HE,
  have HCVRET := check_val_some HSRCSZEQ HTGTSZEQ (eq.symm HSCV) (eq.symm HECV),
  cases scv ; cases ecv,
  { unfold option.bind at HS, unfold option.bind at HE,
    rw HS, rw HE, unfold none_or_some, left, split; refl },
  {
    unfold option.bind at HS,
    unfold option.bind at HE,
    exfalso, apply none_or_some_false2,
    assumption
  },
  {
    unfold option.bind at HS,
    unfold option.bind at HE,
    exfalso, apply none_or_some_false1,
    assumption
  },
  unfold option.bind at HS,
  unfold option.bind at HE,
  unfold return at *, unfold pure at *,
  unfold none_or_some, right,
  apply exists.intro,
  apply exists.intro,
  split, assumption,
  split, assumption,
  generalize HUB: (~irstate.getub irsem_exec ose) = ub,
  cases ub,
  {
    apply b_equiv.or1,
    {
      rw ← HUB, apply b_equiv.not,
      apply irstate.getub_equiv,
      apply HPSRC_ENTANGLED,
      refl, refl
    },
    {
      generalize HUB': irstate.getub irsem_exec ose' = ub',
      cases ub',
      {
        intros, apply b_equiv.and1,
        rw ← HUB',
        apply irstate.getub_equiv,
        apply HPTGT_ENTANGLED, refl, rw HUB', intros Q, cases Q
      },
      {
        intros, apply b_equiv.and1,
        apply irstate.getub_equiv,
        apply HPTGT_ENTANGLED, refl, rw HUB',
        have HNOUB: has_no_ub ose = tt,
        {
          cases ose, unfold irstate.getub at HUB,
          simp at HUB, unfold has_not.not at HUB,
          cases ose_fst, cases HUB, refl
        },
        have HNOUB': has_no_ub ose' = tt,
        {
          cases ose', unfold irstate.getub at HUB',
          simp at HUB',
          cases ose'_fst, cases HUB', refl
        },
        have HV := HSRCVEQ HNOUB,
        have HV' := HTGTVEQ HNOUB',
        have HCVRET := check_val_equiv HV HV' (eq.symm HSCV) (eq.symm HECV),
        rw none_or_some_apply at HCVRET,
        intros, assumption
      }
    }
  },
  {
    apply b_equiv.or1,
    {
      rw ← HUB, apply b_equiv.not, apply irstate.getub_equiv, apply HPSRC_ENTANGLED,
      refl, refl
    },
    {
      intros Q, cases Q
    }
  }
end

theorem refines_single_reg_correct_prf: refines_single_reg_correct
:= begin
  unfold refines_single_reg_correct,
  intros,
  unfold root_refines_smt,
  intros,
  unfold root_refines_finalstate,
  intros,
  generalize HEREF: check_single_reg0 irsem_exec psrc ptgt root se0 = oeb,
  have HSREF': some (η⟦sb⟧) = check_single_reg0 irsem_smt psrc ptgt root (η⟦ss0⟧),
  {
    rw ← check_single_reg0_replace,
    rw ← HSREF
  },
  have HCHKEQ: none_or_some (some (η⟦sb⟧)) oeb (λ s e, b_equiv s e),
  {
    apply check_single_reg0_equiv,
    unfold encode at a, apply a,
    rw HSREF', rw HEREF, unfold encode at a, apply a
  },
  cases oeb with eb,
  { exfalso, apply none_or_some_false1, assumption },
  rw none_or_some_apply at HCHKEQ,
  have HCHKTT := HEQ η eb HCHKEQ,

  unfold root_refines,
  unfold check_single_reg0 at HEREF,
  rw [← a_1, ← a_2] at HEREF,
  unfold has_bind.bind at HEREF,
  unfold option.bind at HEREF,
  generalize HV: (irstate.getreg irsem_exec se root) = ov,
  generalize HV': (irstate.getreg irsem_exec se' root) = ov',
  rw [HV, HV'] at HEREF,
  cases ov with v; cases ov' with v',
  any_goals { unfold option.bind at HEREF, cases HEREF, done },
  unfold option.bind at HEREF,

  generalize HCV: check_val irsem_exec v v' = ocv,
  rw HCV at HEREF,
  cases ocv with cv,
  any_goals { unfold option.bind at HEREF, cases HEREF, done },
  unfold option.bind at HEREF,
  injection HEREF with HEREF,
  subst HCHKTT,
  split,
  {
    generalize HUBSRC : irstate.getub irsem_exec se = ubsrc,
    generalize HUBTGT : irstate.getub irsem_exec se' = ubtgt,
    rw HUBSRC at HEREF,
    rw HUBTGT at HEREF,
    cases ubsrc,
    {
      apply ub_refines.ub,
      rw HUBSRC, refl
    },
    {
      apply ub_refines.noub, rw HUBSRC, refl,
      cases ubtgt,
      { cases cv; cases HEREF },
      { rw HUBTGT, refl }
    }
  },
  {
    intros HUBTRUE,
    existsi v, existsi v',
    split, refl, split, refl,
    apply check_val_exec_spec_prf,
    rw HUBTRUE at HEREF,
    cases (irstate.getub irsem_exec se'); cases cv,
    any_goals { cases HEREF, done },
    assumption
  }
end

end spec


import LeanCodePrompts.Premises
open Lean Meta Elab Term Syntax PrettyPrinter Parser

namespace LeanAide.Meta

class Reprint(a : Type) where
    reprSyn : a → String

instance reprintString : Reprint String where
    reprSyn := id

instance reprintName : Reprint Name where
    reprSyn := toString

instance reprintNat : Reprint Nat where
    reprSyn := toString

instance reprintBool : Reprint Bool where
    reprSyn := toString

instance reprintArray {a : Type} [Reprint a] : Reprint (Array a) where
    reprSyn := fun xs => xs.toList.map Reprint.reprSyn |>.toString

instance reprintList {a : Type} [Reprint a] : Reprint (List a) where
    reprSyn := fun xs => xs.map Reprint.reprSyn |>.toString

instance reprintOption {a : Type} [Reprint a] : Reprint (Option a) where
    reprSyn := fun xs => xs.map Reprint.reprSyn |>.getD ""

instance reprintSyntax : Reprint Syntax where
    reprSyn := fun xs => xs.reprint.get!

def reprint {a : Type}[Reprint a] (x : a) : String := Reprint.reprSyn x

instance reprintTermData : Reprint TermData where
    reprSyn := fun x => s!"context: {Reprint.reprSyn x.context}; term: {Reprint.reprSyn x.value}"

instance reprintProofData : Reprint PropProofData where
    reprSyn := fun x => s!"context: {Reprint.reprSyn x.context}; prop: {Reprint.reprSyn x.prop}; proof : {Reprint.reprSyn x.proof}"

def viewSyntax (s: String) : MetaM <| Syntax × String := do
    let c := runParserCategory (← getEnv) `term s
    match c with
    | Except.error e => throwError e
    | Except.ok s => pure (s, s.reprint.get!)

def nameDefTypeSyntax (name: Name) : MetaM <| Syntax × Syntax := do
    let info? := ((← getEnv).find? name)
    let info := info?.get!
    let exp := info.value?.get!
    let type := info.type
    let (stx, _) ←  delabCore exp {} (delabVerbose)
    let (tstx, _) ←  delabCore type {} (delabVerbose)
    return (stx, tstx)

def nameDefSyntax (name: Name) : MetaM <| Option Syntax := do
    let exp? ← nameExpr? name
    match exp? with
    | none => pure none
    | some exp => do
        let stx ←  delab exp
        pure (some stx)

def premisesFromName (name : Name) : MetaM (List PremiseData) := do
    let (pf, prop) ← nameDefTypeSyntax name
    Lean.Syntax.premiseDataM #[] pf prop true name name

def _root_.PremiseData.view : PremiseData → MetaM String := fun data => do
    return s!"context: {reprint data.context}; name?: {data.name?}; defnName: {data.defnName}; type: {reprint data.type}; type-group: {reprint data.typeGroup}; sub-terms: {reprint data.terms}; sub-proofs : {reprint data.propProofs}  identifiers: {data.ids}"

def premisesViewFromName (name: Name) : MetaM <| List String := do
    let premises ← premisesFromName name
    premises.mapM (fun p => p.view)

def premisesJsonFromName (name: Name) : MetaM <| Json := do
    let premises ← premisesFromName name
    return toJson premises

#eval premisesViewFromName ``Nat.pred_le_pred

-- #eval premisesJsonFromName ``Nat.pred_le_pred

-- #eval premisesViewFromName ``Nat.le_of_succ_le_succ

def boundedDef (bound: Nat)(name: Name) : MetaM Bool := do
    let exp? ← nameExpr? name
    match exp? with
    | none => pure false
    | some exp => do
        pure (exp.approxDepth.toNat < bound)

def nameDefView (name: Name) : MetaM String := do
    let stx? ← nameDefSyntax name
    return (stx?.get!.reprint.get!)

def nameDefCleanView (name: Name) : MetaM String := do
    let stx? ← nameDefSyntax name
    return ((stx?.get!.purge).reprint.get!)

def nameDefSyntaxVerbose (name: Name) : MetaM <| Option Syntax := do
    let exp? ← nameExpr? name
    match exp? with
    | none => pure none
    | some exp => do
        let (stx, _) ←  delabCore exp {} (delabVerbose)
        pure (some stx)

def nameDefViewVerbose (name: Name) : MetaM String := do
    let stx? ← nameDefSyntaxVerbose name
    return (stx?.get!.reprint.get!)

-- #eval nameDefSyntax ``List.join

-- #eval nameDefSyntax ``Nat.le_of_succ_le_succ

-- #eval nameDefView ``Nat.gcd_eq_zero_iff

-- #eval nameDefCleanView ``Nat.gcd_eq_zero_iff

-- def egSplit : MetaM <| Option (Syntax × Array Syntax) := do
--     let stx? ← nameDefSyntax ``Nat.gcd_eq_zero_iff
--     lambdaStx? stx?.get!

-- #eval egSplit

-- def egSplitView : MetaM <| Option (String × Array String) := do
--     let stx? ← nameDefSyntax ``Nat.gcd_eq_zero_iff
--     let pair? ← lambdaStx? stx?.get!
--     let (stx, args) := pair?.get!
--     pure (stx.reprint.get!, args.map (fun s => s.reprint.get!))

-- #eval egSplitView

-- set_option pp.proofs false in
-- #eval nameDefView ``Nat.gcd_eq_zero_iff

-- set_option pp.proofs.withType true in
-- #eval nameDefView ``Nat.gcd_eq_zero_iff

-- #eval nameDefViewVerbose ``Nat.gcd_eq_zero_iff

-- #eval nameDefSyntaxVerbose ``Nat.gcd_eq_zero_iff

-- #eval nameDefViewVerbose ``Nat.gcd_eq_gcd_ab

-- set_option pp.proofs false in
-- #eval nameDefView ``Nat.gcd_eq_gcd_ab

-- #eval setDelabBound 200

-- #eval nameDefViewVerbose ``Nat.xgcd_aux_P

-- set_option pp.proofs false in
-- #eval nameDefView ``Nat.xgcd_aux_P

-- theorem oddExample : ∀ (n : Nat), ∃ m, m > n ∧ m % 2 = 1 := by
--   intro n -- introduce a variable n
--   use 2 * n + 1 -- use `m = 2 * n + 1`
--   apply And.intro -- apply the constructor of `∧` to split goals
--   · linarith -- solve the first goal using `linarith`
--   · simp [Nat.add_mod] -- solve the second goal using `simp` with the lemma `Nat.add_mod`

-- -- #eval premisesViewFromName ``oddExample

end LeanAide.Meta

open LeanAide.Meta

structure ConstsData where
    definitions : HashMap Name  Syntax
    theorems : HashMap Name  Syntax

def constsData : MetaM ConstsData := do
    let consts ← constantNameTypes
    let mut definitions := HashMap.empty
    let mut theorems := HashMap.empty
    for (c, type) in consts do
        let tstx ← delab type
        let tstx := tstx.raw.purge
        if ← Meta.isProp type then
            theorems := theorems.insert c tstx
        else
            definitions := definitions.insert c tstx
    return { definitions := definitions, theorems := theorems }

partial def Lean.Syntax.identsM (stx: Syntax)(context: Array Syntax)(maxDepth? : Option Nat := none) : MetaM <| List <| Name × Nat  := do
    if maxDepth? = some 0 then
        pure []
    else
    match ← namedArgument? stx with
    | some (arg, _) =>
        -- IO.println s!"Named: {arg}"
        let prev ←  identsM  arg context (maxDepth?.map (· -1))
        return prev.map (fun (s, m) => (s, m + 1))
    | none =>
    match ← proofWithProp? stx with
    | some (proof, _) =>
        -- IO.println s!"Proof: {proof}"
        let prev ←  identsM  proof context (maxDepth?.map (· -1))
        return prev.map (fun (s, m) => (s, m + 1))
    | none =>
    match ← lambdaStx? stx with
    | some (body, args) =>
        -- IO.println s!"Lambda: {args}"
        let prev ←  identsM  body (context ++ args) (maxDepth?.map (· -1))
        return prev.map (fun (s, m) => (s, m + args.size))
    | none =>
        match stx with
        | Syntax.node _ _ args =>
            let prev ← args.mapM (identsM · context (maxDepth?.map (· -1)))
            return prev.toList.join.map (fun (s, m) => (s, m + 1))
        | Syntax.ident _ _ name .. =>
            let contextVars := context.filterMap getVar
            -- IO.println s!"Context: {contextVars} from {context}"
            if  !(contextVars.contains name) &&
                !(excludePrefixes.any (fun pfx => pfx.isPrefixOf name)) && !(excludeSuffixes.any (fun pfx => pfx.isSuffixOf name)) then
                pure [(name, 0)]
            else pure []
        | _ => pure []

-- -- #eval termKindList

partial def Lean.Syntax.termsM (context : Array Syntax)(stx: Syntax)(maxDepth? : Option Nat := none) : MetaM <| List <| TermData   := do
    let tks ← termKindList
    let tks := tks.map (·.1)
    if maxDepth? = some 0 then
        pure []
    else
    match ← namedArgument? stx with
    | some (arg, _) =>
        -- IO.println s!"Named: {arg}"
        let prev ←  termsM  context arg (maxDepth?.map (· -1))
        return prev.map (fun s => s.increaseDepth 1 )
    | none =>
    match ← proofWithProp? stx with
    | some (proof, _) =>
        -- IO.println s!"Proof: {proof}"
        let prev ←  termsM context  proof (maxDepth?.map (· -1))
        return prev.map (fun s => s.increaseDepth 1)
    | none =>
    match ← lambdaStx? stx with
    | some (body, args) =>
        -- IO.println s!"Lambda: {args}"
        let prev ←  termsM (context ++ args) body (maxDepth?.map (· -1))
        return prev.map (fun s => s.increaseDepth args.size)
    | none =>
        match stx with
        | Syntax.node _ k args =>
            -- IO.println s!"Node: {k}"
            let prev ← args.mapM (termsM context · (maxDepth?.map (· -1)))
            let head : TermData := ⟨context, stx.purge, stx.purge.size, 0⟩
            if tks.contains k then
                return (head) :: prev.toList.join.map (fun s => s.increaseDepth 1)
            else
            return prev.toList.join.map (fun s => s.increaseDepth 1)
        | Syntax.ident .. =>
             pure []
        | _ => pure []

partial def Lean.Syntax.proofsM (context : Array Syntax)(stx: Syntax)(maxDepth? : Option Nat := none) : MetaM <| List <| PropProofData   := do
    if maxDepth? = some 0 then
        pure []
    else
    match ← namedArgument? stx with
    | some (arg, _) =>
        -- IO.println s!"Named: {arg}"
        let prev ←  proofsM  context arg (maxDepth?.map (· -1))
        return prev.map (fun s => s.increaseDepth 1)
    | none =>
    match ← proofWithProp? stx with
    | some (proof, prop) =>
        -- IO.println s!"Proof: {proof}"
        let prev ←  proofsM context  proof (maxDepth?.map (· -1))
        let head : PropProofData :=
            ⟨context, prop, proof, prop.size, proof.size, 0⟩
        return  (head) :: prev.map (fun s => s.increaseDepth 1)
    | none =>
    match ← lambdaStx? stx with
    | some (body, args) =>
        -- IO.println s!"Lambda: {args}"
        let prev ←  proofsM (context ++ args) body (maxDepth?.map (· -1))
        return prev.map (fun s => s.increaseDepth args.size)
    | none =>
        match stx with
        | Syntax.node _ _ args =>
            -- IO.println s!"Node: {k}"
            let prev ← args.mapM (proofsM context · (maxDepth?.map (· -1)))
            return prev.toList.join.map (fun s => s.increaseDepth 1)
        | Syntax.ident .. =>
             pure []
        | _ => pure []

def PremiseData.get(ctx : Array Syntax)(name: Name)(prop pf : Syntax) : MetaM PremiseData := do
    let subProofs: List (PropProofData) ←  pf.proofsM ctx
    let subTerms : List (TermData)  ← Syntax.termsM ctx pf
    let ids : List (Name  × Nat) ← pf.identsM ctx
    return ⟨ctx, some name, name, prop.purge, prop.purge, pf.purge, prop.purge.size, pf.purge.size, subTerms.toArray, subProofs.toArray, ids.toArray⟩

def viewData (name: Name) : MetaM <| String := do
    let (stx, tstx) ← nameDefTypeSyntax name
    -- IO.println s!"{stx.reprint.get!}"
    -- IO.println s!"{← proofWithProp? stx}"
    let data ←  PremiseData.get  #[] name tstx stx
    data.view

-- #eval viewData ``Nat.succ_le_succ

partial def Lean.Syntax.kinds (stx: Syntax)(maxDepth?: Option Nat := none) : List String :=
    if maxDepth? = some 0 then
        []
    else
    match stx with
    | Syntax.node _ k args =>
        let head? : Option String :=
            k.components.head?.map (· |>.toString)
        match head? with
        | some head => head :: (args.map (kinds · (maxDepth?.map (· -1))) |>.toList.join)
        | none => args.map (kinds · (maxDepth?.map (· -1))) |>.toList.join
    | _ => []

partial def Lean.Syntax.idents (stx: Syntax)(maxDepth? : Option Nat := none) : List <| Name × Nat  :=
    if maxDepth? = some 0 then
        []
    else
    match stx with
    | Syntax.node _ _ args =>
         args.map (idents · (maxDepth?.map (· -1)))
            |>.toList.join.map (fun (s, m) => (s, m + 1))
    | Syntax.ident _ _ name .. =>
        if !(excludePrefixes.any (fun pfx => pfx.isPrefixOf name)) && !(excludeSuffixes.any (fun pfx => pfx.isSuffixOf name)) then
            [(name, 0)]
        else []
    | _ => []

partial def Lean.Syntax.terms (stx: Syntax)(maxDepth?: Option Nat := none) :
     MetaM <|  List <| String × Nat × List Name := do
    let tks ← termKindList
    let tks := tks.map (·.1)
    if maxDepth? = some 0 then
        pure []
    else
    match stx with
    | Syntax.node _ k args =>
        match stx with
        | `(proved_prop| ($pf:term =: $_:term )) =>
           pf.raw.terms
        | _ =>
        let head? : Option String := do
            if
                k ∈ tks
            then
                ← stx.reprint
            else
                none
        let argTerms ← args.mapM (terms · (maxDepth?.map (· -1)))
        let argTerms := argTerms.toList.join
        match head? with
        | some head =>
            return (head.trim, 0, stx.idents.map (·.1)) ::
                 (argTerms.map (fun (s, m, l) => (s, m + 1, l)))
        | none =>
            return (argTerms.map (fun (s, m, l) => (s, m + 1, l)))

    | _ => pure []

structure Premises where
    type : String
    defTerms : List <| String × Nat × List Name
    defIdents : List <| Name × Nat
    typeTerms : List <| String × Nat × List Name
    typeIdents : List <| Name × Nat
deriving Repr, Inhabited

def Premises.defMainTerms (p: Premises) : List <| String × Nat × List Name  :=
    p.defTerms.filter (
            fun (s, _) => s.1.length < 20)

def Premises.typeMainTerms (p: Premises) : List <| String × Nat × List Name :=
    p.typeTerms.filter (fun (s, _) => (s.splitOn "=>").length == 1
                && (s.splitOn "↦").length == 1)

def getPremises (name: Name)(maxDepth? : Option Nat := none ) : MetaM <| Premises := do
    let termStx? ← nameDefSyntaxVerbose name
    let term ←  mkConstWithLevelParams name
    let type ← inferType term
    let typeView ← Meta.ppExpr type
    let typeStx ← delab type
    let defTerms ←  match termStx? with
        | none => pure []
        | some stx => stx.terms maxDepth?
    let defTerms := defTerms.filter (fun (s, _) => s.1.length < 10000
        && !s.contains '\n')
    let defIdents := match termStx? with
        | none => []
        | some stx => stx.idents maxDepth?
    pure {type := typeView.pretty 10000, defTerms := defTerms, defIdents := defIdents, typeTerms := ←  typeStx.raw |>.terms maxDepth?, typeIdents := typeStx.raw |>.idents maxDepth?}

-- Testing

def showTerms (s: String) : MetaM <| List <| String × Nat × List Name  := do
    let c := runParserCategory (← getEnv) `term s
    match c with
    | Except.error e => throwError e
    | Except.ok s => (s.terms)

def showIdents (s: String) : MetaM <| List <| Name × Nat := do
    let c := runParserCategory (← getEnv) `term s
    match c with
    | Except.error e => throwError e
    | Except.ok s => pure (s.idents)

def showKinds (s: String) : MetaM <| List String := do
    let c := runParserCategory (← getEnv) `term s
    match c with
    | Except.error e => throwError e
    | Except.ok s => pure (s.kinds)

def nameDefTerms (name: Name)(maxDepth? : Option Nat := none ) : MetaM <|
    List <| String × Nat × List Name  := do
    let stx? ← nameDefSyntax name
    match stx? with
    | none => pure []
    | some stx => (stx.terms maxDepth?)

def nameDefIdents (name: Name)(maxDepth? : Option Nat := none ) : MetaM <| List <| Name × Nat := do
    let stx? ← nameDefSyntax name
    match stx? with
    | none => pure []
    | some stx => pure (stx.idents maxDepth?)

#check List.join

-- #eval showTerms "fun n ↦ Nat.succ n"

-- #eval showIdents "fun n ↦ Nat.succ n"

-- #eval showTerms "fun n ↦ Nat.succ n = n + 1"

#eval viewSyntax "match n + 2 with | 0 => 0 | _ => 1"

-- #eval viewSyntax "f (n := m)"

def zeroOrOne : Nat → Nat
| 0 => 0
| _ => 1

#eval nameDefSyntax ``zeroOrOne

-- #eval nameDefSyntax ``Nat.succ_le_succ

#check Lean.Parser.Term.namedArgument
#check Lean.Parser.Term.matchAlt

-- #eval showKinds "n = n + 1"

-- def egTerms : MetaM <| List <| String × Nat × List Name := do
--     let p ←  getPremises ``oddExample (some 30)
--     return p.defMainTerms

-- #eval egTerms

-- def egIdents : MetaM <| List <| Name × Nat:= do
--     let p ←  getPremises ``oddExample (some 50)
--     return p.defIdents

-- #eval egIdents

-- def egGpIdents : MetaM NameGroups := do
--     let nd ← egIdents
--     return groupedNames nd.toArray

-- #eval egGpIdents

-- #check Linarith.lt_irrefl

-- -- #eval nameDefSyntax ``oddExample

def dataSize : MetaM Nat := do
    let names ← constantNames
    return names.size

-- #eval dataSize

def boundedDataSize (n: Nat) : MetaM Nat := do
    let names ← constantNames
    let names ← names.filterM (boundedDef n)
    return names.size

-- #eval boundedDataSize 50

def sampleExtract (n: Nat := 100) : MetaM <|
        List (Name × (List <| String × Nat × List Name) ×
        (List <| Name × Nat)) := do
    let names ← constantNames
    let names := names.toList.take n
    names.mapM (fun n => do
        let p ← nameDefTerms n
        let q ← nameDefIdents n
        pure (n, p, q)
        )

def batchPremiseExtractM (start stop: Nat) : MetaM Nat  := do
    let names ← constantNames
    let premisesFile := System.mkFilePath ["rawdata",
    s!"outer-premises.jsonl"]
    let h ← IO.FS.Handle.mk premisesFile IO.FS.Mode.append Bool.false
    let names := names.toList.drop start |>.take (stop - start)
    let mut cursor := start
    IO.println s!"start: {start}, stop: {stop}"
    for name in names do
        IO.println <| s!"starting: {cursor} {name}"
        let premises ← getPremises name (some 30)
        let p := premises.defMainTerms
        let pJson := p.map
            (fun (s, n, l) =>
                Json.mkObj [
                    ("term", s),
                    ("depth", n),
                    ("local-idents", Json.arr  (
                        l.toArray
                        |>.filter (fun name => !names.contains name)
                        |>.map (fun name : Name =>
                            name.toString)))
                ]
            )
        let q:= premises.defIdents
        let q := q.filter (fun (name, _) => names.contains name)
        let qJson := q.map
            (fun (name, n) =>
                Json.mkObj [
                    ("name", name.toString),
                    ("depth", n)
                ]
            )
        let js := Json.mkObj [
            ("name", name.toString),
            ("type", premises.type),
            ("terms", Json.arr
                pJson.toArray),
            ("idents", Json.arr
                qJson.toArray)
        ]
        let out := js.pretty 10000
        if out.length < 9000 then
            h.putStrLn <| out
        IO.println <| s!"{cursor}. {name} : {premises.type} ({p.length}, {q.length}, {out.length})"
        cursor := cursor + 1
    return cursor

def batchPremiseExtractCore (start stop: Nat) : CoreM Nat :=
    (batchPremiseExtractM start stop).run'

-- -- #eval sampleExtract

-- theorem imo_1964_q1b : ∀ (n : Nat), (2 ^ n + 1) % 7 ≠ 0
--     | 0 | 1 | 2 => by decide
--     | n + 3 => by
--       rw [pow_add, Nat.add_mod, Nat.mul_mod, show 2 ^ 3 % 7 = 1 from by rfl]
--       simp [imo_1964_q1b n]

-- set_option pp.proofs.withType true in
-- -- #eval nameDefView ``imo_1964_q1b

-- #eval nameDefView ``imo_1964_q1b

-- -- #eval nameDefViewVerbose ``imo_1964_q1b


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison, Bhavik Mehta
-/
import category_theory.monad.adjunction
import category_theory.adjunction.limits
import category_theory.limits.preserves.shapes.terminal

namespace category_theory
open category
open category_theory.limits

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

namespace monad

variables {C : Type u₁} [category.{v₁} C]
variables {T : monad C}

variables {J : Type v₁} [small_category J]

namespace forget_creates_limits

variables (D : J ⥤ algebra T) (c : cone (D ⋙ forget T)) (t : is_limit c)

/-- (Impl) The natural transformation used to define the new cone -/
@[simps] def γ : (D ⋙ forget T ⋙ ↑T) ⟶ (D ⋙ forget T) := { app := λ j, (D.obj j).a }

/-- (Impl) This new cone is used to construct the algebra structure -/
@[simps] def new_cone : cone (D ⋙ forget T) :=
{ X := T.obj c.X,
  π := (functor.const_comp _ _ ↑T).inv ≫ whisker_right c.π T ≫ (γ D) }

/-- The algebra structure which will be the apex of the new limit cone for `D`. -/
@[simps] def cone_point : algebra T :=
{ A := c.X,
  a := t.lift (new_cone D c),
  unit' :=
  begin
    apply t.hom_ext,
    intro j,
    erw [category.assoc, t.fac (new_cone D c), id_comp],
    dsimp,
    erw [id_comp, ← category.assoc, ← T.η.naturality, functor.id_map, category.assoc,
         (D.obj j).unit, comp_id],
  end,
  assoc' :=
  begin
    apply t.hom_ext,
    intro j,
    rw [category.assoc, category.assoc, t.fac (new_cone D c)],
    dsimp,
    erw id_comp,
    slice_lhs 1 2 {rw ← T.μ.naturality},
    slice_lhs 2 3 {rw (D.obj j).assoc},
    slice_rhs 1 2 {rw ← (T : C ⥤ C).map_comp},
    rw t.fac (new_cone D c),
    dsimp,
    erw [id_comp, functor.map_comp, category.assoc]
  end }

/-- (Impl) Construct the lifted cone in `algebra T` which will be limiting. -/
@[simps] def lifted_cone : cone D :=
{ X := cone_point D c t,
  π := { app := λ j, { f := c.π.app j },
         naturality' := λ X Y f, by { ext1, dsimp, erw c.w f, simp } } }

/-- (Impl) Prove that the lifted cone is limiting. -/
@[simps]
def lifted_cone_is_limit : is_limit (lifted_cone D c t) :=
{ lift := λ s,
  { f := t.lift ((forget T).map_cone s),
    h' :=
    begin
      apply t.hom_ext, intro j,
      slice_rhs 2 3 {rw t.fac ((forget T).map_cone s) j},
      dsimp,
      slice_lhs 2 3 {rw t.fac (new_cone D c) j},
      dsimp,
      rw category.id_comp,
      slice_lhs 1 2 {rw ← (T : C ⥤ C).map_comp},
      rw t.fac ((forget T).map_cone s) j,
      exact (s.π.app j).h
    end },
  uniq' := λ s m J,
  begin
    ext1,
    apply t.hom_ext,
    intro j,
    simpa [t.fac (functor.map_cone (forget T) s) j] using congr_arg algebra.hom.f (J j),
  end }

end forget_creates_limits

-- Theorem 5.6.5 from [Riehl][riehl2017]
/-- The forgetful functor from the Eilenberg-Moore category creates limits. -/
noncomputable
instance forget_creates_limits : creates_limits (forget T) :=
{ creates_limits_of_shape := λ J 𝒥, by exactI
  { creates_limit := λ D,
    creates_limit_of_reflects_iso (λ c t,
    { lifted_cone := forget_creates_limits.lifted_cone D c t,
      valid_lift := cones.ext (iso.refl _) (λ j, (id_comp _).symm),
      makes_limit := forget_creates_limits.lifted_cone_is_limit _ _ _ } ) } }

/-- `D ⋙ forget T` has a limit, then `D` has a limit. -/
lemma has_limit_of_comp_forget_has_limit (D : J ⥤ algebra T) [has_limit (D ⋙ forget T)] :
  has_limit D :=
has_limit_of_created D (forget T)

namespace forget_creates_colimits

-- Let's hide the implementation details in a namespace
variables {D : J ⥤ algebra T} (c : cocone (D ⋙ forget T)) (t : is_colimit c)

-- We have a diagram D of shape J in the category of algebras, and we assume that we are given a
-- colimit for its image D ⋙ forget T under the forgetful functor, say its apex is L.

-- We'll construct a colimiting coalgebra for D, whose carrier will also be L.
-- To do this, we must find a map TL ⟶ L. Since T preserves colimits, TL is also a colimit.
-- In particular, it is a colimit for the diagram `(D ⋙ forget T) ⋙ T`
-- so to construct a map TL ⟶ L it suffices to show that L is the apex of a cocone for this diagram.
-- In other words, we need a natural transformation from const L to `(D ⋙ forget T) ⋙ T`.
-- But we already know that L is the apex of a cocone for the diagram `D ⋙ forget T`, so it
-- suffices to give a natural transformation `((D ⋙ forget T) ⋙ T) ⟶ (D ⋙ forget T)`:

/--
(Impl)
The natural transformation given by the algebra structure maps, used to construct a cocone `c` with
apex `colimit (D ⋙ forget T)`.
 -/
@[simps] def γ : ((D ⋙ forget T) ⋙ ↑T) ⟶ (D ⋙ forget T) := { app := λ j, (D.obj j).a }

/--
(Impl)
A cocone for the diagram `(D ⋙ forget T) ⋙ T` found by composing the natural transformation `γ`
with the colimiting cocone for `D ⋙ forget T`.
-/
@[simps]
def new_cocone : cocone ((D ⋙ forget T) ⋙ ↑T) :=
{ X := c.X,
  ι := γ ≫ c.ι }

variables [preserves_colimit (D ⋙ forget T) (T : C ⥤ C)]

/--
(Impl)
Define the map `λ : TL ⟶ L`, which will serve as the structure of the coalgebra on `L`, and
we will show is the colimiting object. We use the cocone constructed by `c` and the fact that
`T` preserves colimits to produce this morphism.
-/
@[reducible]
def lambda : ((T : C ⥤ C).map_cocone c).X ⟶ c.X :=
(preserves_colimit.preserves t).desc (new_cocone c)

/-- (Impl) The key property defining the map `λ : TL ⟶ L`. -/
lemma commuting (j : J) :
T.map (c.ι.app j) ≫ lambda c t = (D.obj j).a ≫ c.ι.app j :=
is_colimit.fac (preserves_colimit.preserves t) (new_cocone c) j

variables [preserves_colimit ((D ⋙ forget T) ⋙ ↑T) (T : C ⥤ C)]

/--
(Impl)
Construct the colimiting algebra from the map `λ : TL ⟶ L` given by `lambda`. We are required to
show it satisfies the two algebra laws, which follow from the algebra laws for the image of `D` and
our `commuting` lemma.
-/
@[simps] def cocone_point :
algebra T :=
{ A := c.X,
  a := lambda c t,
  unit' :=
  begin
    apply t.hom_ext,
    intro j,
    erw [comp_id, ← category.assoc, T.η.naturality, category.assoc, commuting, ← category.assoc],
    erw algebra.unit, apply id_comp
  end,
  assoc' :=
  begin
    apply is_colimit.hom_ext (preserves_colimit.preserves (preserves_colimit.preserves t)),
    intro j,
    erw [← category.assoc, T.μ.naturality, ← functor.map_cocone_ι_app, category.assoc,
         is_colimit.fac _ (new_cocone c) j],
    rw ← category.assoc,
    erw [← functor.map_comp, commuting],
    dsimp,
    erw [← category.assoc, algebra.assoc, category.assoc, functor.map_comp, category.assoc,
      commuting],
    apply_instance, apply_instance
  end }

/-- (Impl) Construct the lifted cocone in `algebra T` which will be colimiting. -/
@[simps] def lifted_cocone : cocone D :=
{ X := cocone_point c t,
  ι := { app := λ j, { f := c.ι.app j, h' := commuting _ _ _ },
         naturality' := λ A B f, by { ext1, dsimp, erw [comp_id, c.w] } } }

/-- (Impl) Prove that the lifted cocone is colimiting. -/
@[simps]
def lifted_cocone_is_colimit : is_colimit (lifted_cocone c t) :=
{ desc := λ s,
  { f := t.desc ((forget T).map_cocone s),
    h' :=
    begin
      dsimp,
      apply is_colimit.hom_ext (preserves_colimit.preserves t),
      intro j,
      rw ← category.assoc, erw ← functor.map_comp,
      erw t.fac',
      rw ← category.assoc, erw forget_creates_colimits.commuting,
      rw category.assoc, rw t.fac',
      apply algebra.hom.h,
      apply_instance
    end },
  uniq' := λ s m J,
  by { ext1, apply t.hom_ext, intro j, simpa using congr_arg algebra.hom.f (J j) } }

end forget_creates_colimits

open forget_creates_colimits

-- TODO: the converse of this is true as well
/--
The forgetful functor from the Eilenberg-Moore category for a monad creates any colimit
which the monad itself preserves.
-/
noncomputable
instance forget_creates_colimit (D : J ⥤ algebra T)
  [preserves_colimit (D ⋙ forget T) (T : C ⥤ C)]
  [preserves_colimit ((D ⋙ forget T) ⋙ ↑T) (T : C ⥤ C)] :
  creates_colimit D (forget T) :=
creates_colimit_of_reflects_iso $ λ c t,
{ lifted_cocone :=
  { X := cocone_point c t,
    ι :=
    { app := λ j, { f := c.ι.app j, h' := commuting _ _ _ },
      naturality' := λ A B f, by { ext1, dsimp, erw [comp_id, c.w] } } },
  valid_lift := cocones.ext (iso.refl _) (by tidy),
  makes_colimit := lifted_cocone_is_colimit _ _ }

noncomputable
instance forget_creates_colimits_of_shape
  [preserves_colimits_of_shape J (T : C ⥤ C)] :
  creates_colimits_of_shape J (forget T) :=
{ creates_colimit := λ K, by apply_instance }

noncomputable
instance forget_creates_colimits
  [preserves_colimits (T : C ⥤ C)] :
  creates_colimits (forget T) :=
{ creates_colimits_of_shape := λ J 𝒥₁, by apply_instance }

/--
For `D : J ⥤ algebra T`, `D ⋙ forget T` has a colimit, then `D` has a colimit provided colimits
of shape `J` are preserved by `T`.
-/
lemma forget_creates_colimits_of_monad_preserves
  [preserves_colimits_of_shape J (T : C ⥤ C)] (D : J ⥤ algebra T) [has_colimit (D ⋙ forget T)] :
has_colimit D :=
has_colimit_of_created D (forget T)

end monad

variables {C : Type u₁} [category.{v₁} C] {D : Type u₂} [category.{v₁} D]
variables {J : Type v₁} [small_category J]

instance comp_comparison_forget_has_limit
  (F : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] [has_limit (F ⋙ R)] :
  has_limit ((F ⋙ monad.comparison (adjunction.of_right_adjoint R)) ⋙ monad.forget _) :=
@has_limit_of_iso _ _ _ _ (F ⋙ R) _ _
  (iso_whisker_left F (monad.comparison_forget (adjunction.of_right_adjoint R)).symm)

instance comp_comparison_has_limit
  (F : J ⥤ D) (R : D ⥤ C) [monadic_right_adjoint R] [has_limit (F ⋙ R)] :
  has_limit (F ⋙ monad.comparison (adjunction.of_right_adjoint R)) :=
monad.has_limit_of_comp_forget_has_limit (F ⋙ monad.comparison (adjunction.of_right_adjoint R))

/-- Any monadic functor creates limits. -/
noncomputable
def monadic_creates_limits (R : D ⥤ C) [monadic_right_adjoint R] :
  creates_limits R :=
creates_limits_of_nat_iso (monad.comparison_forget (adjunction.of_right_adjoint R))

/--
The forgetful functor from the Eilenberg-Moore category for a monad creates any colimit
which the monad itself preserves.
-/
noncomputable
def monadic_creates_colimit_of_preserves_colimit (R : D ⥤ C) (K : J ⥤ D)
  [monadic_right_adjoint R]
  [preserves_colimit (K ⋙ R) (left_adjoint R ⋙ R)]
  [preserves_colimit ((K ⋙ R) ⋙ left_adjoint R ⋙ R) (left_adjoint R ⋙ R)] :
  creates_colimit K R :=
begin
  apply creates_colimit_of_nat_iso (monad.comparison_forget (adjunction.of_right_adjoint R)),
  apply category_theory.comp_creates_colimit _ _,
  apply_instance,
  let i : ((K ⋙ monad.comparison (adjunction.of_right_adjoint R)) ⋙ monad.forget _) ≅ K ⋙ R :=
    functor.associator _ _ _ ≪≫
      iso_whisker_left K (monad.comparison_forget (adjunction.of_right_adjoint R)),
  apply category_theory.monad.forget_creates_colimit _,
  { dsimp,
    refine preserves_colimit_of_iso_diagram _ i.symm },
  { dsimp,
    refine preserves_colimit_of_iso_diagram _ (iso_whisker_right i (left_adjoint R ⋙ R)).symm },
end

/-- A monadic functor creates any colimits of shapes it preserves. -/
noncomputable
def monadic_creates_colimits_of_shape_of_preserves_colimits_of_shape (R : D ⥤ C)
  [monadic_right_adjoint R] [preserves_colimits_of_shape J R] : creates_colimits_of_shape J R :=
begin
  have : preserves_colimits_of_shape J (left_adjoint R ⋙ R),
  { apply category_theory.limits.comp_preserves_colimits_of_shape _ _,
    { haveI := adjunction.left_adjoint_preserves_colimits (adjunction.of_right_adjoint R),
      apply_instance },
    apply_instance },
  exactI ⟨λ K, monadic_creates_colimit_of_preserves_colimit _ _⟩,
end

/-- A monadic functor creates colimits if it preserves colimits. -/
noncomputable
def monadic_creates_colimits_of_preserves_colimits (R : D ⥤ C) [monadic_right_adjoint R]
  [preserves_colimits R] : creates_colimits R :=
{ creates_colimits_of_shape := λ J 𝒥₁,
    by exactI monadic_creates_colimits_of_shape_of_preserves_colimits_of_shape _ }

section

lemma has_limit_of_reflective (F : J ⥤ D) (R : D ⥤ C) [has_limit (F ⋙ R)] [reflective R] :
  has_limit F :=
by { haveI := monadic_creates_limits R, exact has_limit_of_created F R }

/-- If `C` has limits of shape `J` then any reflective subcategory has limits of shape `J`. -/
lemma has_limits_of_shape_of_reflective [has_limits_of_shape J C] (R : D ⥤ C) [reflective R] :
  has_limits_of_shape J D :=
{ has_limit := λ F, has_limit_of_reflective F R }

/-- If `C` has limits then any reflective subcategory has limits. -/
lemma has_limits_of_reflective (R : D ⥤ C) [has_limits C] [reflective R] : has_limits D :=
{ has_limits_of_shape := λ J 𝒥₁, by exactI has_limits_of_shape_of_reflective R }

/-- If `C` has colimits of shape `J` then any reflective subcategory has colimits of shape `J`. -/
lemma has_colimits_of_shape_of_reflective (R : D ⥤ C)
  [reflective R] [has_colimits_of_shape J C] : has_colimits_of_shape J D :=
{ has_colimit := λ F,
begin
  let c := (left_adjoint R).map_cocone (colimit.cocone (F ⋙ R)),
  letI := (adjunction.of_right_adjoint R).left_adjoint_preserves_colimits,
  let t : is_colimit c := is_colimit_of_preserves (left_adjoint R) (colimit.is_colimit _),
  apply has_colimit.mk ⟨_, (is_colimit.precompose_inv_equiv _ _).symm t⟩,
  apply (iso_whisker_left F (as_iso (adjunction.of_right_adjoint R).counit) : _) ≪≫ F.right_unitor,
end }

/-- If `C` has colimits then any reflective subcategory has colimits. -/
lemma has_colimits_of_reflective (R : D ⥤ C) [reflective R] [has_colimits C] :
  has_colimits D :=
{ has_colimits_of_shape := λ J 𝒥, by exactI has_colimits_of_shape_of_reflective R }

/--
The reflector always preserves terminal objects. Note this in general doesn't apply to any other
limit.
-/
noncomputable def left_adjoint_preserves_terminal_of_reflective
  (R : D ⥤ C) [reflective R] [has_terminal C] :
  preserves_limits_of_shape (discrete pempty) (left_adjoint R) :=
{ preserves_limit := λ K,
  begin
    letI : has_terminal D := has_limits_of_shape_of_reflective R,
    letI := monadic_creates_limits R,
    letI := category_theory.preserves_limit_of_creates_limit_and_has_limit (functor.empty _) R,
    letI : preserves_limit (functor.empty _) (left_adjoint R),
    { apply preserves_terminal_of_iso,
      apply _ ≪≫ as_iso ((adjunction.of_right_adjoint R).counit.app (⊤_ D)),
      apply (left_adjoint R).map_iso (preserves_terminal.iso R).symm },
    apply preserves_limit_of_iso_diagram (left_adjoint R) (functor.unique_from_empty _).symm,
  end }

end
end category_theory