import tactic.core

attribute [inline] or.decidable decidable.to_bool bool.decidable_eq and.decidable
  nat.decidable_eq ne.decidable decidable.false implies.decidable option.get_or_else
  option.map

meta def format.form (as : list format) : format :=
(format.join (as.intersperse format.line)).paren.group

open native

meta def expr.meta_vars (e : expr) : rb_set expr :=
e.fold mk_rb_set $ λ e i ms,
match e with
| expr.mvar _ _ _ := ms.insert e
| _ := ms
end

meta def list.dup_by_native {α β} [has_lt β] [decidable_rel ((<) : β → β → Prop)]
  (f : α → β) (xs : list α) : list α :=
rb_map.values $ xs.foldl (λ m x, m.insert (f x) x) mk_rb_map

meta def level.mvar_name : level → name
| (level.mvar n) := n
| _ := name.anonymous

private meta def level.meta_vars_core : level → name_set → name_set
| level.zero := id
| (level.param _) := id
| (level.succ l) := l.meta_vars_core
| (level.mvar n) := λ ms, ms.insert n
| (level.max a b) := a.meta_vars_core ∘ b.meta_vars_core
| (level.imax a b) := a.meta_vars_core ∘ b.meta_vars_core

meta def level.meta_vars (l : level) : name_set :=
level.meta_vars_core l mk_name_set

meta def expr.univ_meta_vars (e : expr) : name_set :=
e.fold mk_name_set $ λ e i ms,
match e with
| expr.sort l := level.meta_vars_core l ms
| expr.const _ ls := ls.foldr level.meta_vars_core ms
| _ := ms
end

def list.index_of_core' {α} [decidable_eq α] (a : α) : ℕ → list α → option ℕ
| i [] := none
| i (x::xs) := if x = a then some i else xs.index_of_core' (i+1)

def list.index_of' {α} [decidable_eq α] (a : α) (xs : list α) : option ℕ :=
xs.index_of_core' a 0

meta def expr.abstract_mvars (e : expr) (mvars : list name) : expr :=
e.replace $ λ e i,
match e with
| e@(expr.mvar n _ _) :=
  (mvars.index_of' n).map (λ j, expr.var (i + j))
| e := none
end

meta def expr.meta_uniq_name : expr → name
| (expr.mvar n _ _) := n
| _ := name.anonymous

meta def expr.meta_type : expr → expr
| (expr.mvar _ _ t) := t
| _ := default _

meta def expr.abstract_mvars' (e : expr) (mvars : list expr) : expr :=
e.abstract_mvars (mvars.map expr.meta_uniq_name)

open tactic

private meta def sorted_mvars_core : list expr → list expr → tactic (list expr)
| (e@(expr.mvar n pp_n _)::es) ctx :=
  if ∃ m ∈ ctx, (m : expr).meta_uniq_name = e.meta_uniq_name then
    sorted_mvars_core es ctx
  else do
    t ← infer_type e >>= instantiate_mvars,
    ctx ← sorted_mvars_core t.meta_vars.to_list ctx,
    sorted_mvars_core es (e :: ctx)
| [] ctx := pure ctx
| (e::es) ctx := sorted_mvars_core (e.meta_vars.to_list ++ es) ctx

meta def expr.sorted_mvars' (es : list expr) : tactic (list expr) :=
sorted_mvars_core es []

meta def expr.sorted_mvars (e : expr) : tactic (list expr) :=
expr.sorted_mvars' [e]

meta def abstract_mvar_telescope : list expr → tactic (list expr)
| [] := pure []
| (m :: ms) := do
  t ← infer_type m >>= instantiate_mvars,
  ms' ← abstract_mvar_telescope ms,
  pure $ t.abstract_mvars' ms :: ms'

meta def level.instantiate_univ_mvars (subst : rb_map name level) : level → level
| level.zero := level.zero
| (level.succ a) := a.instantiate_univ_mvars.succ
| (level.max a b) := level.max (a.instantiate_univ_mvars) (b.instantiate_univ_mvars)
| (level.imax a b) := level.imax (a.instantiate_univ_mvars) (b.instantiate_univ_mvars)
| l@(level.param _) := l
| l@(level.mvar n) := (subst.find n).get_or_else l

meta def expr.instantiate_univ_mvars (subst : rb_map name level) (e : expr) : expr :=
e.replace $ λ e i,
match e with
| (expr.const n ls) :=
  some $ expr.const n (ls.map (level.instantiate_univ_mvars subst))
| (expr.sort l) :=
  some $ expr.sort (l.instantiate_univ_mvars subst)
| _ := none
end

meta def expr.mk_lambda (x e : expr) : expr :=
expr.lam x.local_pp_name x.local_binding_info x.local_type (e.abstract x)

meta def expr.mk_lambdas (xs : list expr) (e : expr) : expr :=
xs.foldr expr.mk_lambda e

meta def expr.mk_pi (x e : expr) : expr :=
expr.pi x.local_pp_name x.local_binding_info x.local_type (e.abstract x)

meta def expr.mk_pis (xs : list expr) (e : expr) : expr :=
xs.foldr expr.mk_pi e

meta def expr.app' : expr → expr → expr
| (expr.lam _ _ _ a) b := a.instantiate_var b
| a b := a b

lemma or_imp_congr {p p' q q'} (hp : p → p') (hq : q → q') : p ∨ q → p' ∨ q'
| (or.inl h) := or.inl (hp h)
| (or.inr h) := or.inr (hq h)

lemma or_imp_congr_left {p q r} (h : q → r) : q ∨ p → r ∨ p :=
or_imp_congr h id

lemma or_imp_congr_right {p q r} (h : q → r) : p ∨ q → p ∨ r :=
or_imp_congr id h

lemma or_imp_congr_right_strong {p q r} (h : ¬ p → q → r) : p ∨ q → p ∨ r :=
match classical.prop_decidable p with
| decidable.is_true hp := λ _, or.inl hp
| decidable.is_false hp := or_imp_congr_right (h hp)
end

lemma imp_iff_or_not {p q : Prop} : (p → q) ↔ (¬ p ∨ q) :=
by cases classical.prop_decidable p; simp *

lemma not_imp_iff_or {p q : Prop} : (¬ p → q) ↔ (p ∨ q) :=
by cases classical.prop_decidable p; simp *

theorem iff_imp {a b c} : ((a ↔ b) → c) ↔ ((a → b) → (b → a) → c) :=
iff.intro (λ h ha hb, h ⟨ha, hb⟩) (λ h ⟨ha, hb⟩, h ha hb)

lemma classical.forall_imp_iff_exists_not_or {α} {p : α → Prop} {q : Prop} :
  ((∀ x, p x) → q) ↔ ((∃ x, ¬ p x) ∨ q) :=
by simp [imp_iff_or_not]

def list.has_dups_core {α} [decidable_eq α] : list α → list α → bool
| (x::xs) ys := x ∈ ys ∨ xs.has_dups_core (x::ys)
| [] _ := ff

def list.has_dups {α} [decidable_eq α] (xs : list α) : bool :=
xs.has_dups_core []

def list.zip_with_index_core {α} : ℕ → list α → list (α × ℕ)
| _ [] := []
| i (x::xs) := (x,i) :: list.zip_with_index_core (i+1) xs

def list.zip_with_index {α} : list α → list (α × ℕ) :=
list.zip_with_index_core 0

def list.filter_maximal {α} (gt : α → α → bool) (l : list α) : list α :=
l.filter $ λ x, ∀ y ∈ l, ¬ gt y x

def list.m_any {α m} [monad m] (f : α → m bool) : list α → m bool
| [] := pure ff
| (x::xs) := do f_x ← f x, if f_x then pure tt else xs.m_any

meta def mk_metas_core : list expr → tactic (list expr)
| [] := pure []
| (t::ts) := do
  ms ← mk_metas_core ts,
  m ← mk_meta_var (t.instantiate_vars ms),
  pure (m::ms)

meta def expr.name_hint : expr → option name
| (expr.const n _) := n
| (expr.app a b) := a.name_hint <|> b.name_hint
| (expr.pi pp_n _ a b) := b.name_hint <|> a.name_hint <|> pp_n
| (expr.lam pp_n _ a b) := b.name_hint <|> pp_n
| (expr.sort _) := `type
| (expr.local_const _ pp_n _ _) := pp_n
| _ := name.anonymous

meta def expr.hyp_name_hint (e : expr) : name :=
match e.name_hint with
| some (name.mk_string s _) := ("h_" ++ s : string)
| _ := `h
end

meta def mk_locals_core : list expr → tactic (list expr)
| [] := pure []
| (t::ts) := do
  lcs ← mk_locals_core ts,
  lc ← mk_local' t.hyp_name_hint binder_info.default (t.instantiate_vars lcs),
  pure (lc :: lcs)

meta def expr.const_levels : expr → list level
| (expr.const n ls) := ls
| _ := []

@[inline] instance has_monad_lift.refl {m} [monad m] : has_monad_lift m m := ⟨λ _, id⟩

meta def tactic.unify_level (l1 l2 : level) : tactic unit :=
tactic.unify (expr.sort l1) (expr.sort l2)

namespace tactic

meta def unify_with_type (a b : expr) (trnsp := transparency.semireducible) (approx := ff) :
  tactic unit := do
ta ← infer_type a,
tb ← infer_type b,
unify ta tb trnsp approx,
unify a b trnsp approx

meta def minimal_tc_failure : expr → tactic expr | e := do
ff ← succeeds (type_check e),
match e with
| (expr.app a b) := minimal_tc_failure a <|> minimal_tc_failure b
| (expr.lam n bi a b) :=
  minimal_tc_failure a <|> (do
    l ← mk_local' n bi a,
    minimal_tc_failure (b.instantiate_var a))
| (expr.pi n bi a b) :=
  minimal_tc_failure a <|> (do
    l ← mk_local' n bi a,
    minimal_tc_failure (b.instantiate_var a))
| (expr.elet n t v b) :=
  minimal_tc_failure t <|> minimal_tc_failure v <|>
    minimal_tc_failure (b.instantiate_var v)
| e := pure e
end <|> pure e

end tactic

-- decidable instance for bounded existence is not short-circuiting?!?
def list.existsb {α} (p : α → bool) : list α → bool
| [] := ff
| (x :: xs) := if p x then tt else xs.existsb

meta def infer_univ (type : expr) : tactic level := do
sort_of_type ← infer_type type >>= whnf,
match sort_of_type with
| expr.sort lvl := pure lvl
| not_sort := do
  fmt ← pp not_sort,
  fail $ (to_fmt "cannot get universe level of sort:" ++ format.line ++ fmt).group.nest 1
end


import tactic.derive_fintype
import logic.function.basic
import data.set.function
import data.fin.tuple
import data.finset.lattice

section vars
@[derive decidable_eq, derive fintype, derive inhabited]
inductive Vars
| i | j | k | w | x | y | z | ind₀ | ind₁ | ind₂ | break | output | len | vals

open Vars
instance : has_to_string Vars :=
⟨λ v, match v with
-- S.split(" | ").map(s => s + ' := "' + s + '"')
| i := "i" | j := "j" | k := "k" | w := "w" | x := "x" | y := "y" | z := "z" | ind₀ := "ind₀" | ind₁ := "ind₁" | ind₂ := "ind₂" | break := "break" | output := "output" | len := "len" | vals := "vals"
end⟩
end vars

section NameSpace
@[derive decidable_eq, derive inhabited, derive has_to_string, reducible]
def NameSpace := ℕ

def NameSpace.reserved : NameSpace := 0

def fresh (S : finset NameSpace) : NameSpace :=
S.max.iget + 1

theorem not_fresh_mem (S : finset NameSpace) : fresh S ∉ S :=
begin
  simp only [fresh],
  cases hn : S.max,
  { rw finset.max_eq_bot.1 hn, exact finset.not_mem_empty _, },
  { refine finset.not_mem_of_max_lt _ hn, simp },
end

theorem not_fresh_reserved (S : finset NameSpace) : fresh S ≠ NameSpace.reserved :=
by simp [fresh, NameSpace.reserved]

attribute [irreducible] NameSpace
end NameSpace

@[derive decidable_eq, derive fintype, derive inhabited]
inductive Types
| nn | rr | bb

section Ident

@[derive decidable_eq]
structure Ident (b : Types) :=
(ns : NameSpace)
(name : Vars)

instance {b : Types} : has_to_string (Ident b) :=
⟨λ i, "n" ++ (to_string i.ns) ++ "_" ++ (to_string i.name)⟩

lemma Ident_ns_surjective {b : Types} : function.surjective (@Ident.ns b) :=
by { intro x, use ⟨x, default⟩, }

@[simp] lemma Ident_ns_range {b : Types} : set.range (@Ident.ns b) = set.univ :=
by simpa [set.surjective_iff_surj_on_univ, set.surj_on, set.univ_subset_iff] using Ident_ns_surjective

infix `∷`:9000 := Ident.mk
infix `∷ₙ`:9000 := @Ident.mk Types.nn
infix `∷ᵣ`:9000 := @Ident.mk Types.rr

end Ident

section frames
-- TODO Fix
variables {α γ : Type*} {β : α → Type*} (f : (Π x, β x) → γ) (g : (Π x, β x) → (Π x, β x))

def function.has_dframe (S : set α) : Prop :=
∀ ⦃c₁ c₂ : Π x, β x⦄, (∀ x ∈ S, c₁ x = c₂ x) → f c₁ = f c₂

structure function.has_dheap (S : set α) : Prop :=
(local_frame : ∀ (c₁ c₂ : Π x, β x), (∀ x ∈ S, c₁ x = c₂ x) → ∀ {y}, y ∈ S → g c₁ y = g c₂ y)
(global_id : ∀ (c y), y ∉ S → g c y = c y)

variables {f g}
theorem function.has_dframe.res {S} (h : function.has_dframe f S) (S') (hS' : S ⊆ S') :
  function.has_dframe f S' :=
λ c₁ c₂ h', h (λ x hx, h' _ (hS' hx))

theorem function.has_dheap.res {S} (h : function.has_dheap g S) (S') (hS' : S ⊆ S') :
  function.has_dheap g S' :=
{ local_frame := λ c₁ c₂ c_eq y hy,
begin
  by_cases H : y ∈ S,
  { exact h.local_frame c₁ c₂ (λ x hx, c_eq _ (hS' hx)) H, },
  { rw [h.global_id c₁ _ H, h.global_id c₂ _ H],  exact c_eq _ hy, },
end,
  global_id := λ c y hy, h.global_id c y (λ H, hy (hS' H)), }

theorem function.has_dframe.const (x : γ) (S : set α) : function.has_dframe (λ _ : Π x, β x, x) S :=
λ _ _ _, rfl

theorem function.has_dheap.id (S : set α) : function.has_dheap (@id (Π x, β x)) S :=
{ local_frame := λ c₁ c₂ h y hy, h y hy,
  global_id := λ _ _ _, rfl }

example {S : set α} {x₀ : α} {y₀ : β x₀} [∀ x, decidable_eq (β x)] (f : (Π x, β x) → (Π x, β x)) (g : (Π x, β x) → γ)
  (hf : function.has_dframe g S) (hg : function.has_dheap f (insert x₀ S)) :
  function.has_dframe (λ ctx, if ctx x₀ = y₀ then g (f ctx) else g ctx) (insert x₀ S) :=
begin
  intros c₁ c₂ c_eq, dsimp only,
  have := (hf.res _ _) c_eq,
  all_goals { sorry, },
end

end frames

def Context (val_type : Types → Type) : Type :=
∀ ⦃b : Types⦄, Ident b → val_type b

structure HeapContext (val_type : Types → Type) : Type :=
(store : Context val_type)
(heap : Context (list ∘ val_type))

namespace Context

variable {val_type : Types → Type}

instance [∀ b, inhabited (val_type b)] : inhabited (Context val_type) :=
⟨λ _ _, default⟩

def get (ctx : Context val_type) {b : Types} (x : Ident b) : val_type b := ctx x

def update (ctx : Context val_type) {b : Types} (x : Ident b) (v : val_type b) :
  Context val_type :=
function.update ctx b (function.update (@ctx b) x v)

/- Spec for context -/
@[simp] lemma update_sound (ctx : Context val_type) {b : Types} (x : Ident b) (v : val_type b) :
  (ctx.update x v).get x = v := by simp [update, get]

@[simp] lemma update_frame (ctx : Context val_type) {b : Types} (x y : Ident b) (vx : val_type b)
  (neq : y ≠ x) : (ctx.update x vx).get y = ctx.get y := by simp [get, update, function.update, neq]

/- TODO: Add simp lemmas -/

/- For some reason doesn't play well with equation compiler -/
-- attribute [irreducible] Context

-- @[simp]
-- def try_modify (ctx : Context val_type) {b : Types} (x : Ident b) (f : val_type b → option (val_type b)) :
--   option (Context val_type) :=
-- (f (ctx.get x)).map (ctx.update x)

end Context

namespace HeapContext
variable {val_type : Types → Type}

@[simps] def update (ctx : HeapContext val_type) {b : Types} (x : Ident b) (v : val_type b) :
  HeapContext val_type :=
{ store := ctx.store.update x v,
  heap := ctx.heap }

@[simps] def update_arr (ctx : HeapContext val_type) {b : Types} (x : Ident b)
  (n : ℕ) (v : val_type b) : HeapContext val_type :=
{ store := ctx.store,
  heap := ctx.heap.update x ((ctx.heap.get x).update_nth n v) }

end HeapContext

section iterate

@[simp]
def iterate_while {α : Type*} (f : α → option α) (cond : α → option bool) : ℕ → α → option α
| 0 x := none
| (n+1) x := (cond x).bind (λ b, if b then (f x).bind (iterate_while n) else some x)

-- theorem iterate_while_tr {α β : Type*} {f₁ : α → option α} {cond₁ : α → option bool} {n : ℕ} {x : α}
--   (tr : α → β) (f₂ : β → option β) (cond₂ : β → option bool) (y : β)
--   (hf : ∀ x, )

-- theorem iterate_while_eq_of_invariant {α : Type*} (inv : α → ℕ → Prop)
--   (f : α → option α) (cond : α → option bool) (n : ℕ) (x : α)
--   (hcond : ∀ {x i}, inv x i → (cond x).is_some)
--   (h₀ : inv x 0) (hind : ∀ x i, cond x = some tt → inv x i → ∃ x' ∈ f x, inv x' (i + 1))
--   (hₜ : ∀ {x}, inv x n → cond x = some ff) :
--   ∃ r ∈ iterate_while f cond (n + 1) x, inv r n :=
-- begin
--   induction n with n ih generalizing x,
--   { simpa [hₜ h₀], },
--   obtain ⟨_|_, hc⟩ := option.is_some_iff_exists.mp (hcond h₀),
--   { simp, }
-- end

end iterate

theorem imp_iff_distrib {a b c : Prop} : ((a → b) ↔ (a → c)) ↔ (a → (b ↔ c)) :=
⟨λ h ha, ⟨λ hb, h.mp (λ _, hb) ha, λ hc, h.mpr (λ _, hc) ha⟩, λ h, ⟨λ hb ha, (h ha).mp (hb ha), λ hc ha, (h ha).mpr (hc ha)⟩⟩


partial def inf (u : Unit) : List Unit := u :: inf u

theorem aa : False :=
  nomatch (⟨inf._unsafe_rec (), rfl⟩ : ∃ l, l = () :: l)


/-
File: signature_recover_public_key_div_mod_n_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_bigint_mul_soundness
import .signature_recover_public_key_nondet_bigint3_soundness
open tactic

open starkware.cairo.common.cairo_secp.signature
open starkware.cairo.common.cairo_secp.bigint
open starkware.cairo.common.cairo_secp.constants

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

/- starkware.cairo.common.cairo_secp.signature.div_mod_n autogenerated soundness theorem -/

theorem auto_sound_div_mod_n
    -- arguments
    (range_check_ptr : F) (a b : BigInt3 F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_div_mod_n σ.pc)
    -- all dependencies are in memory
    (h_mem_3 : mem_at mem code_bigint_mul (σ.pc  - 668))
    (h_mem_4 : mem_at mem code_nondet_bigint3 (σ.pc  - 654))
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 9))
    (hin_a : a = cast_BigInt3 mem (σ.fp - 8))
    (hin_b : b = cast_BigInt3 mem (σ.fp - 5))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      τ.ap = σ.ap + 88 ∧
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 9)) (mem $ τ.ap - 4)
        (spec_div_mod_n mem κ range_check_ptr a b (mem (τ.ap - 4)) (cast_BigInt3 mem (τ.ap - 3)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_div_mod_n at h_mem with ⟨hpc0, hpc1, hpc2, hpc3, hpc4, hpc5, hpc6, hpc7, hpc8, hpc9, hpc10, hpc11, hpc12, hpc13, hpc14, hpc15, hpc16, hpc17, hpc18, hpc19, hpc20, hpc21, hpc22, hpc23, hpc24, hpc25, hpc26, hpc27, hpc28, hpc29, hpc30, hpc31, hpc32, hpc33, hpc34, hpc35, hpc36, hpc37, hpc38, hpc39, hpc40, hpc41, hpc42, hpc43, hpc44, hpc45, hpc46, hpc47, hpc48, hpc49, hpc50, hpc51, hpc52, hpc53, hpc54, hpc55, hpc56, hpc57, hpc58, hpc59, hpc60, hpc61, hpc62, hpc63, hpc64⟩,
  -- function call
  step_assert_eq hpc0 with arg0,
  step_sub hpc1 (auto_sound_nondet_bigint3 mem _ range_check_ptr _ _),
  { rw hpc2, norm_num2, exact h_mem_4 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call3 ap3 h_call3,
  rcases h_call3 with ⟨h_call3_ap_offset, h_call3⟩,
  rcases h_call3 with ⟨rc_m3, rc_mle3, hl_range_check_ptr₁, h_call3⟩,
  generalize' hr_rev_range_check_ptr₁: mem (ap3 - 4) = range_check_ptr₁,
  have htv_range_check_ptr₁ := hr_rev_range_check_ptr₁.symm, clear hr_rev_range_check_ptr₁,
  generalize' hr_rev_res: cast_BigInt3 mem (ap3 - 3) = res,
  simp only [hr_rev_res] at h_call3,
  have htv_res := hr_rev_res.symm, clear hr_rev_res,
  try { simp only [arg0] at hl_range_check_ptr₁ },
  rw [←htv_range_check_ptr₁, ←hin_range_check_ptr] at hl_range_check_ptr₁,
  try { simp only [arg0] at h_call3 },
  rw [hin_range_check_ptr] at h_call3,
  clear arg0,
  -- function call
  step_assert_eq hpc3 with arg0,
  step_sub hpc4 (auto_sound_nondet_bigint3 mem _ range_check_ptr₁ _ _),
  { rw hpc5, norm_num2, exact h_mem_4 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0] },
    try { simp only [h_call3_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call6 ap6 h_call6,
  rcases h_call6 with ⟨h_call6_ap_offset, h_call6⟩,
  rcases h_call6 with ⟨rc_m6, rc_mle6, hl_range_check_ptr₂, h_call6⟩,
  generalize' hr_rev_range_check_ptr₂: mem (ap6 - 4) = range_check_ptr₂,
  have htv_range_check_ptr₂ := hr_rev_range_check_ptr₂.symm, clear hr_rev_range_check_ptr₂,
  generalize' hr_rev_k: cast_BigInt3 mem (ap6 - 3) = k,
  simp only [hr_rev_k] at h_call6,
  have htv_k := hr_rev_k.symm, clear hr_rev_k,
  try { simp only [arg0] at hl_range_check_ptr₂ },
  rw [←htv_range_check_ptr₂, ←htv_range_check_ptr₁] at hl_range_check_ptr₂,
  try { simp only [arg0] at h_call6 },
  rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr] at h_call6,
  clear arg0,
  -- function call
  step_assert_eq hpc6 with arg0,
  step_assert_eq hpc7 with arg1,
  step_assert_eq hpc8 with arg2,
  step_assert_eq hpc9 with arg3,
  step_assert_eq hpc10 with arg4,
  step_assert_eq hpc11 with arg5,
  step_sub hpc12 (auto_sound_bigint_mul mem _ res b _ _ _),
  { rw hpc13, norm_num2, exact h_mem_3 },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k] },
      try { dsimp [cast_BigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5] },
      try { simp only [h_call3_ap_offset, h_call6_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k] },
      try { dsimp [cast_BigInt3] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5] },
      try { simp only [h_call3_ap_offset, h_call6_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  intros κ_call14 ap14 h_call14,
  rcases h_call14 with ⟨h_call14_ap_offset, h_call14⟩,
  generalize' hr_rev_res_b: cast_UnreducedBigInt5 mem (ap14 - 5) = res_b,
  simp only [hr_rev_res_b] at h_call14,
  have htv_res_b := hr_rev_res_b.symm, clear hr_rev_res_b,
  clear arg0 arg1 arg2 arg3 arg4 arg5,
  -- let
  generalize' hl_rev_n: ({
    d0 := N0,
    d1 := N1,
    d2 := N2
  } : BigInt3 F) = n,
  have hl_n := hl_rev_n.symm, clear hl_rev_n,
  try { dsimp at hl_n }, try { arith_simps at hl_n },
  -- function call
  step_assert_eq hpc14 with arg0,
  step_assert_eq hpc15 with arg1,
  step_assert_eq hpc16 with arg2,
  step_assert_eq hpc17 hpc18 with arg3,
  step_assert_eq hpc19 hpc20 with arg4,
  step_assert_eq hpc21 hpc22 with arg5,
  step_sub hpc23 (auto_sound_bigint_mul mem _ k n _ _ _),
  { rw hpc24, norm_num2, exact h_mem_3 },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k, htv_res_b, hl_n] },
      try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5] },
      try { simp only [h_call3_ap_offset, h_call6_ap_offset, h_call14_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  { try { ext } ; {
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k, htv_res_b, hl_n] },
      try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
      try { arith_simps }, try { simp only [arg0, arg1, arg2, arg3, arg4, arg5] },
      try { simp only [h_call3_ap_offset, h_call6_ap_offset, h_call14_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },}, },
  intros κ_call25 ap25 h_call25,
  rcases h_call25 with ⟨h_call25_ap_offset, h_call25⟩,
  generalize' hr_rev_k_n: cast_UnreducedBigInt5 mem (ap25 - 5) = k_n,
  simp only [hr_rev_k_n] at h_call25,
  have htv_k_n := hr_rev_k_n.symm, clear hr_rev_k_n,
  clear arg0 arg1 arg2 arg3 arg4 arg5,
  -- tempvar
  step_assert_eq hpc25 with tv_carry10,
  step_assert_eq hpc26 with tv_carry11,
  step_assert_eq hpc27 hpc28 with tv_carry12,
  generalize' hl_rev_carry1: ((res_b.d0 - k_n.d0 - a.d0) / (BASE : ℤ) : F) = carry1,
  have hl_carry1 := hl_rev_carry1.symm, clear hl_rev_carry1,
  have htv_carry1: carry1 = _, {
    have h_δ25_c0 : ∀ x : F, x / (BASE : ℤ) = x * (-46768052394588894761721767695234645457402928824320 : ℤ),
    { intro x,  apply div_eq_mul_inv', apply PRIME.int_cast_mul_eq_one, rw [PRIME], try { simp_int_casts }, norm_num1 },
    apply eq.symm, apply eq.trans tv_carry12,
      try { simp only [h_δ25_c0] at hl_carry1 },
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k, htv_res_b, hl_n, htv_k_n, hl_carry1] },
      try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
      try { arith_simps }, try { simp only [(eq_sub_of_eq_add tv_carry10), (eq_sub_of_eq_add tv_carry11)] },
      try { simp only [h_call3_ap_offset, h_call6_ap_offset, h_call14_ap_offset, h_call25_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  clear tv_carry10 tv_carry11 tv_carry12,
  try { dsimp at hl_carry1 }, try { arith_simps at hl_carry1 },
  -- compound assert eq
  step_assert_eq hpc29 hpc30 with temp0,
  step_assert_eq hpc31 with temp1,
  have a29: mem (range_check_ptr₂ + 0) = carry1 + 2 ^ 127, {
    apply assert_eq_reduction temp1.symm,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k, htv_res_b, hl_n, htv_k_n, hl_carry1, htv_carry1] },
    try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
    try { arith_simps }, try { simp only [temp0] },
    try { simp only [h_call3_ap_offset, h_call6_ap_offset, h_call14_ap_offset, h_call25_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a29 }, try { arith_simps at a29 },
  clear temp0 temp1,
  -- tempvar
  step_assert_eq hpc32 with tv_carry20,
  step_assert_eq hpc33 with tv_carry21,
  step_assert_eq hpc34 with tv_carry22,
  step_assert_eq hpc35 hpc36 with tv_carry23,
  generalize' hl_rev_carry2: ((res_b.d1 - k_n.d1 - a.d1 + carry1) / (BASE : ℤ) : F) = carry2,
  have hl_carry2 := hl_rev_carry2.symm, clear hl_rev_carry2,
  have htv_carry2: carry2 = _, {
    have h_δ32_c0 : ∀ x : F, x / (BASE : ℤ) = x * (-46768052394588894761721767695234645457402928824320 : ℤ),
    { intro x,  apply div_eq_mul_inv', apply PRIME.int_cast_mul_eq_one, rw [PRIME], try { simp_int_casts }, norm_num1 },
    apply eq.symm, apply eq.trans tv_carry23,
      try { simp only [h_δ32_c0] at hl_carry2 },
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k, htv_res_b, hl_n, htv_k_n, hl_carry1, htv_carry1, hl_carry2] },
      try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
      try { arith_simps }, try { simp only [(eq_sub_of_eq_add tv_carry20), (eq_sub_of_eq_add tv_carry21), tv_carry22] },
      try { simp only [h_call3_ap_offset, h_call6_ap_offset, h_call14_ap_offset, h_call25_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  clear tv_carry20 tv_carry21 tv_carry22 tv_carry23,
  try { dsimp at hl_carry2 }, try { arith_simps at hl_carry2 },
  -- compound assert eq
  step_assert_eq hpc37 hpc38 with temp0,
  step_assert_eq hpc39 with temp1,
  have a37: mem (range_check_ptr₂ + 1) = carry2 + 2 ^ 127, {
    apply assert_eq_reduction temp1.symm,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k, htv_res_b, hl_n, htv_k_n, hl_carry1, htv_carry1, hl_carry2, htv_carry2] },
    try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
    try { arith_simps }, try { simp only [temp0] },
    try { simp only [h_call3_ap_offset, h_call6_ap_offset, h_call14_ap_offset, h_call25_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a37 }, try { arith_simps at a37 },
  clear temp0 temp1,
  -- tempvar
  step_assert_eq hpc40 with tv_carry30,
  step_assert_eq hpc41 with tv_carry31,
  step_assert_eq hpc42 with tv_carry32,
  step_assert_eq hpc43 hpc44 with tv_carry33,
  generalize' hl_rev_carry3: ((res_b.d2 - k_n.d2 - a.d2 + carry2) / (BASE : ℤ) : F) = carry3,
  have hl_carry3 := hl_rev_carry3.symm, clear hl_rev_carry3,
  have htv_carry3: carry3 = _, {
    have h_δ40_c0 : ∀ x : F, x / (BASE : ℤ) = x * (-46768052394588894761721767695234645457402928824320 : ℤ),
    { intro x,  apply div_eq_mul_inv', apply PRIME.int_cast_mul_eq_one, rw [PRIME], try { simp_int_casts }, norm_num1 },
    apply eq.symm, apply eq.trans tv_carry33,
      try { simp only [h_δ40_c0] at hl_carry3 },
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k, htv_res_b, hl_n, htv_k_n, hl_carry1, htv_carry1, hl_carry2, htv_carry2, hl_carry3] },
      try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
      try { arith_simps }, try { simp only [(eq_sub_of_eq_add tv_carry30), (eq_sub_of_eq_add tv_carry31), tv_carry32] },
      try { simp only [h_call3_ap_offset, h_call6_ap_offset, h_call14_ap_offset, h_call25_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  clear tv_carry30 tv_carry31 tv_carry32 tv_carry33,
  try { dsimp at hl_carry3 }, try { arith_simps at hl_carry3 },
  -- compound assert eq
  step_assert_eq hpc45 hpc46 with temp0,
  step_assert_eq hpc47 with temp1,
  have a45: mem (range_check_ptr₂ + 2) = carry3 + 2 ^ 127, {
    apply assert_eq_reduction temp1.symm,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k, htv_res_b, hl_n, htv_k_n, hl_carry1, htv_carry1, hl_carry2, htv_carry2, hl_carry3, htv_carry3] },
    try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
    try { arith_simps }, try { simp only [temp0] },
    try { simp only [h_call3_ap_offset, h_call6_ap_offset, h_call14_ap_offset, h_call25_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a45 }, try { arith_simps at a45 },
  clear temp0 temp1,
  -- tempvar
  step_assert_eq hpc48 with tv_carry40,
  step_assert_eq hpc49 with tv_carry41,
  step_assert_eq hpc50 hpc51 with tv_carry42,
  generalize' hl_rev_carry4: ((res_b.d3 - k_n.d3 + carry3) / (BASE : ℤ) : F) = carry4,
  have hl_carry4 := hl_rev_carry4.symm, clear hl_rev_carry4,
  have htv_carry4: carry4 = _, {
    have h_δ48_c0 : ∀ x : F, x / (BASE : ℤ) = x * (-46768052394588894761721767695234645457402928824320 : ℤ),
    { intro x,  apply div_eq_mul_inv', apply PRIME.int_cast_mul_eq_one, rw [PRIME], try { simp_int_casts }, norm_num1 },
    apply eq.symm, apply eq.trans tv_carry42,
      try { simp only [h_δ48_c0] at hl_carry4 },
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k, htv_res_b, hl_n, htv_k_n, hl_carry1, htv_carry1, hl_carry2, htv_carry2, hl_carry3, htv_carry3, hl_carry4] },
      try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
      try { arith_simps }, try { simp only [(eq_sub_of_eq_add tv_carry40), tv_carry41] },
      try { simp only [h_call3_ap_offset, h_call6_ap_offset, h_call14_ap_offset, h_call25_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  clear tv_carry40 tv_carry41 tv_carry42,
  try { dsimp at hl_carry4 }, try { arith_simps at hl_carry4 },
  -- compound assert eq
  step_assert_eq hpc52 hpc53 with temp0,
  step_assert_eq hpc54 with temp1,
  have a52: mem (range_check_ptr₂ + 3) = carry4 + 2 ^ 127, {
    apply assert_eq_reduction temp1.symm,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k, htv_res_b, hl_n, htv_k_n, hl_carry1, htv_carry1, hl_carry2, htv_carry2, hl_carry3, htv_carry3, hl_carry4, htv_carry4] },
    try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
    try { arith_simps }, try { simp only [temp0] },
    try { simp only [h_call3_ap_offset, h_call6_ap_offset, h_call14_ap_offset, h_call25_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a52 }, try { arith_simps at a52 },
  clear temp0 temp1,
  -- compound assert eq
  step_assert_eq hpc55 with temp0,
  step_assert_eq hpc56 hpc57 with temp1,
  step_assert_eq hpc58 with temp2,
  have a55: res_b.d4 - k_n.d4 + carry4 = 0, {
    apply assert_eq_reduction temp2.symm,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_a, hin_b, htv_range_check_ptr₁, htv_res, htv_range_check_ptr₂, htv_k, htv_res_b, hl_n, htv_k_n, hl_carry1, htv_carry1, hl_carry2, htv_carry2, hl_carry3, htv_carry3, hl_carry4, htv_carry4] },
    try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
    try { arith_simps }, try { simp only [(eq_sub_of_eq_add temp0), temp1] },
    try { simp only [h_call3_ap_offset, h_call6_ap_offset, h_call14_ap_offset, h_call25_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  },
  try { dsimp at a55 }, try { arith_simps at a55 },
  clear temp0 temp1 temp2,
  -- let
  generalize' hl_rev_range_check_ptr₃: (range_check_ptr₂ + 4 : F) = range_check_ptr₃,
  have hl_range_check_ptr₃ := hl_rev_range_check_ptr₃.symm, clear hl_rev_range_check_ptr₃,
  try { dsimp at hl_range_check_ptr₃ }, try { arith_simps at hl_range_check_ptr₃ },
  -- return
  step_assert_eq hpc59 hpc60 with hret0,
  step_assert_eq hpc61 with hret1,
  step_assert_eq hpc62 with hret2,
  step_assert_eq hpc63 with hret3,
  step_ret hpc64,
  -- finish
  step_done, use_only [rfl, rfl],
  split,
  { try { simp only [h_call3_ap_offset ,h_call6_ap_offset ,h_call14_ap_offset ,h_call25_ap_offset] },
    try { arith_simps }, try { refl } },
  -- range check condition
  use_only (rc_m3+rc_m6+4+0+0), split,
  linarith [rc_mle3, rc_mle6],
  split,
  { arith_simps, try { simp only [hret0 ,hret1 ,hret2 ,hret3] },
    try { simp only [h_call25_ap_offset ,h_call14_ap_offset] }, try { 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_div_mod_n mem _ range_check_ptr a b _ _,
  { apply sound_div_mod_n, apply auto_spec },
  -- prove the auto generated assertion
  dsimp [auto_spec_div_mod_n],
  try { norm_num1 }, try { arith_simps },
  use_only [κ_call3],
  use_only [range_check_ptr₁],
  use_only [res],
  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 spec3 := h_call3 rc_h_range_check_ptr',
  rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec3,
  try { dsimp at spec3, arith_simps at spec3 },
  use_only [spec3],
  use_only [κ_call6],
  use_only [range_check_ptr₂],
  use_only [k],
  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 spec6 := h_call6 rc_h_range_check_ptr₁',
  rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec6,
  try { dsimp at spec6, arith_simps at spec6 },
  use_only [spec6],
  use_only [κ_call14],
  use_only [res_b],
  try { dsimp at h_call14, arith_simps at h_call14 },
  try { use_only [h_call14] },
  use_only [n, hl_n],
  use_only [κ_call25],
  use_only [k_n],
  try { dsimp at h_call25, arith_simps at h_call25 },
  try { use_only [h_call25] },
  use_only [carry1, hl_carry1],
  use_only [a29],
  cases rc_h_range_check_ptr₂' (0) (by norm_num1) with n hn, arith_simps at hn,
  use_only [n], { simp only [a29.symm, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr], arith_simps, exact hn },
  use_only [carry2, hl_carry2],
  use_only [a37],
  cases rc_h_range_check_ptr₂' (1) (by norm_num1) with n hn, arith_simps at hn,
  use_only [n], { simp only [a37.symm, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr], arith_simps, exact hn },
  use_only [carry3, hl_carry3],
  use_only [a45],
  cases rc_h_range_check_ptr₂' (2) (by norm_num1) with n hn, arith_simps at hn,
  use_only [n], { simp only [a45.symm, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr], arith_simps, exact hn },
  use_only [carry4, hl_carry4],
  use_only [a52],
  cases rc_h_range_check_ptr₂' (3) (by norm_num1) with n hn, arith_simps at hn,
  use_only [n], { simp only [a52.symm, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr], arith_simps, exact hn },
  use_only [a55],
  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₃' },
  use_only [range_check_ptr₃, hl_range_check_ptr₃],
  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_res, htv_range_check_ptr₂, htv_k, htv_res_b, hl_n, htv_k_n, hl_carry1, htv_carry1, hl_carry2, htv_carry2, hl_carry3, htv_carry3, hl_carry4, htv_carry4, hl_range_check_ptr₃] }, },
  try { dsimp [cast_BigInt3, cast_UnreducedBigInt5] },
  try { arith_simps }, try { simp only [hret0, hret1, hret2, hret3] },
  try { simp only [h_call3_ap_offset, h_call6_ap_offset, h_call14_ap_offset, h_call25_ap_offset] },
  try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
end


import category_theory.isomorphism category_theory.concrete_category
import category_theory.limits.shapes.equalizers
import category_theory.endomorphism
import category_theory.category.preorder data.fin.basic
import category_theory.arrow
import category_theory.category.Cat
import category_theory.limits.presheaf
import category_theory.limits.comma

-- Should not be here...
lemma nat.iterate_succ {α : Type*} (f : α → α)
  : ∀ (n : ℕ) (x0 : α), f^[n + 1] x0 = f (f^[n] x0)
| 0       x0 := rfl
| (n + 1) x0 := nat.iterate_succ n (f x0)

namespace category_theory

open category_theory category_theory.limits

local attribute [instance]
  category_theory.concrete_category.has_coe_to_sort
  category_theory.concrete_category.has_coe_to_fun

lemma iso.eq_app_inv_of_app_hom_eq
  {C : Type*} [category C] [concrete_category C] {X Y : C} (f : X ≅ Y)
  {x : X} {y : Y} (H : f.hom x = y) : x = f.inv y :=
begin
  transitivity f.inv (f.hom x),
  { rw [← comp_apply, iso.hom_inv_id, id_apply] },
  { rw H }
end

lemma is_iso.eq_app_inv_of_app_hom_eq
  {C : Type*} [category C] [concrete_category C] {X Y : C} (f : X ⟶ Y) [is_iso f]
  {x : X} {y : Y} : f x = y → x = inv f y :=
  iso.eq_app_inv_of_app_hom_eq (as_iso f)

theorem is_iso.cancel_iso_inv_left {C : Type*} [category C] {X Y Z : C}
  (f : Y ⟶ X) [is_iso f] : ∀ (g g' : Y ⟶ Z), inv f ≫ g = inv f ≫ g' ↔ g = g' :=
  iso.cancel_iso_inv_left (as_iso f)

lemma parallel_pair_comp
  {C : Type*} {D : Type*} [category C] [category D] (F : C ⥤ D) {X Y : C} (f g : X ⟶ Y)
  : parallel_pair f g ⋙ F = parallel_pair (F.map f) (F.map g) :=
begin
  apply category_theory.functor.hext,
  { intro u, cases u; refl },
  { intros u v i, cases u; cases v; cases i,
    all_goals { simp },
    all_goals { refl } },
end

def parallel_pair_comp.cocone_comp_to_cocone_pair
  {C : Type*} {D : Type*} [category C] [category D] (F : C ⥤ D) {X Y : C} (f g : X ⟶ Y)
  (c : cocone (parallel_pair f g ⋙ F)) : cocone (parallel_pair (F.map f) (F.map g)) := {
    X := c.X,
    ι := eq_to_hom (parallel_pair_comp F f g).symm ≫ c.ι
  }

def parallel_pair_comp.cocone_pair_to_cocone_comp
  {C : Type*} {D : Type*} [category C] [category D] (F : C ⥤ D) {X Y : C} (f g : X ⟶ Y)
  (c : cocone (parallel_pair (F.map f) (F.map g))) : cocone (parallel_pair f g ⋙ F) := {
    X := c.X,
    ι := eq_to_hom (parallel_pair_comp F f g) ≫ c.ι
  }

def parallel_pair_comp.is_colimit_comp_to_is_colimit_pair
  {C : Type*} {D : Type*} [category C] [category D] (F : C ⥤ D) {X Y : C} (f g : X ⟶ Y)
  (c : cocone (parallel_pair f g ⋙ F)) (hc : is_colimit c)
  : is_colimit (parallel_pair_comp.cocone_comp_to_cocone_pair F f g c) := {
    desc := λ s, hc.desc (parallel_pair_comp.cocone_pair_to_cocone_comp F f g s),
    fac' := by { intros, refine eq.trans (category.assoc _ _ _) _, rw hc.fac',
                 refine eq.trans (category.assoc _ _ _).symm _, simp },
    uniq' := λ s m h, hc.uniq' (parallel_pair_comp.cocone_pair_to_cocone_comp F f g s) m
                               (λ u, by { refine eq.trans _ (congr_arg (λ w, nat_trans.app (eq_to_hom (parallel_pair_comp F f g)) u ≫ w) (h u)),
                                          refine eq.trans _ (category.assoc _ _ _),
                                          refine congr_arg (λ w, w ≫ m) _,
                                          refine eq.trans _ (category.assoc _ _ _),
                                          simp }) }

def parallel_pair_comp.is_colimit_pair_to_is_colimit_comp
  {C : Type*} {D : Type*} [category C] [category D] (F : C ⥤ D) {X Y : C} (f g : X ⟶ Y)
  (c : cocone (parallel_pair (F.map f) (F.map g))) (hc : is_colimit c)
  : is_colimit (parallel_pair_comp.cocone_pair_to_cocone_comp F f g c) := {
    desc := λ s, hc.desc (parallel_pair_comp.cocone_comp_to_cocone_pair F f g s),
    fac' := by { intros, refine eq.trans (category.assoc _ _ _) _, rw hc.fac',
                 refine eq.trans (category.assoc _ _ _).symm _, simp },
    uniq' := λ s m h, hc.uniq' (parallel_pair_comp.cocone_comp_to_cocone_pair F f g s) m
                               (λ u, by { refine eq.trans _ (congr_arg (λ w, nat_trans.app (eq_to_hom (parallel_pair_comp F f g).symm) u ≫ w) (h u)),
                                          refine eq.trans _ (category.assoc _ _ _),
                                          refine congr_arg (λ w, w ≫ m) _,
                                          refine eq.trans _ (category.assoc _ _ _),
                                          simp }) }

lemma concrete_category.pow_eq_iter {C : Type*} [category C] [concrete_category C] {X : C} (f : X ⟶ X)
  (k : ℕ) : @coe_fn _ _ concrete_category.has_coe_to_fun (f ^ k : End X) = (f^[k]) :=
begin
  ext x,
  induction k with k ih,
  { simp },
  { rw nat.iterate_succ, rw ← npow_eq_pow, dsimp [monoid.npow, npow_rec], simp, congr, exact ih }
end

universe u
def restricted_yoneda_functor {C : Type u} [small_category C] {ℰ : Type*} [category ℰ]
  : (C ⥤ ℰ)ᵒᵖ ⥤ ℰ ⥤ Cᵒᵖ ⥤ Type u :=
  category_theory.functor.op_hom _ _
  ⋙ whiskering_left Cᵒᵖ ℰᵒᵖ (Type u)
  ⋙ (whiskering_left _ _ _).obj yoneda

lemma restricted_yoneda_functor_obj {C : Type u} [small_category C] {ℰ : Type*} [category ℰ]
  (A : C ⥤ ℰ) : restricted_yoneda_functor.obj (opposite.op A) = colimit_adj.restricted_yoneda A := rfl

def functor.map_cone_comp {J C D E : Type*} [category J] [category C] [category D] [category E]
  (K : J ⥤ C) (F : C ⥤ D) (G : D ⥤ E)
  : cones.functoriality K (F ⋙ G)
  ≅ cones.functoriality K F
    ⋙ cones.functoriality (K ⋙ F) G
    ⋙ cones.postcompose (functor.associator K F G).hom :=
begin
  refine nat_iso.of_components _ _,
  { intro c, refine category_theory.limits.cones.ext (iso.refl _) _,
    intro j, symmetry, exact eq.trans (category.id_comp _) (category.comp_id _) },
  { intros c c' f, ext,
    exact eq.trans (category.comp_id _) (category.id_comp _).symm }
end

def functor.map_cone_map_cone {J C D E : Type*} [category J] [category C] [category D] [category E]
  (K : J ⥤ C) (F : C ⥤ D) (G : D ⥤ E)
  : cones.functoriality K (F ⋙ G) ⋙ cones.postcompose (functor.associator K F G).inv
  ≅ cones.functoriality K F ⋙ cones.functoriality (K ⋙ F) G :=
  ((whiskering_right _ _ _).obj (cones.postcompose (functor.associator K F G).inv)).map_iso
    (functor.map_cone_comp K F G)
  ≪≫ ((whiskering_right _ _ _).obj (cones.postcompose (functor.associator K F G).inv)).map_iso
        (functor.associator (cones.functoriality K F) (cones.functoriality (K ⋙ F) G)
                            (cones.postcompose (K.associator F G).hom)).symm

  ≪≫ (functor.associator _ _ _)
  ≪≫ ((whiskering_left _ _ _).obj _).map_iso
        ((limits.cones.postcompose_comp _ _).symm ≪≫
          by { rw (K.associator F G).hom_inv_id, exact limits.cones.postcompose_id })
  ≪≫ (functor.right_unitor _)

def functor.map_cone_comp' {J C D E : Type*} [category J] [category C] [category D] [category E]
  (K : J ⥤ C) (F : C ⥤ D) (G : D ⥤ E) (c : cone K)
  : (F ⋙ G).map_cone c
  ≅ (cones.postcompose (functor.associator K F G).hom).obj (G.map_cone (F.map_cone c)) :=
  ((evaluation _ _).obj c).map_iso (functor.map_cone_comp K F G)

def functor.map_cone_map_cone' {J C D E : Type*} [category J] [category C] [category D] [category E]
  (K : J ⥤ C) (F : C ⥤ D) (G : D ⥤ E) (c : cone K)
  : (cones.postcompose (functor.associator K F G).inv).obj ((F ⋙ G).map_cone c)
  ≅ G.map_cone (F.map_cone c) :=
  ((evaluation _ _).obj c).map_iso (functor.map_cone_map_cone K F G)

def functor.map_cocone_comp {J C D E : Type*} [category J] [category C] [category D] [category E]
  (K : J ⥤ C) (F : C ⥤ D) (G : D ⥤ E)
  : cocones.functoriality K (F ⋙ G)
  ≅ cocones.functoriality K F
    ⋙ cocones.functoriality (K ⋙ F) G
    ⋙ cocones.precompose (functor.associator K F G).hom :=
begin
  refine nat_iso.of_components _ _,
  { intro c, refine category_theory.limits.cocones.ext (iso.refl _) _,
    intro j,
    exact eq.trans (category.comp_id _) (category.id_comp _).symm },
  { intros c c' f, ext,
    exact eq.trans (category.comp_id _) (category.id_comp _).symm }
end

def functor.map_cocone_map_cocone {J C D E : Type*} [category J] [category C] [category D] [category E]
  (K : J ⥤ C) (F : C ⥤ D) (G : D ⥤ E)
  : cocones.functoriality K (F ⋙ G) ⋙ cocones.precompose (functor.associator K F G).inv
  ≅ cocones.functoriality K F ⋙ cocones.functoriality (K ⋙ F) G :=
  ((whiskering_right _ _ _).obj (cocones.precompose (functor.associator K F G).inv)).map_iso
    (functor.map_cocone_comp K F G)
  ≪≫ ((whiskering_right _ _ _).obj (cocones.precompose (functor.associator K F G).inv)).map_iso
        (functor.associator (cocones.functoriality K F) (cocones.functoriality (K ⋙ F) G)
                            (cocones.precompose (K.associator F G).hom)).symm

  ≪≫ (functor.associator _ _ _)
  ≪≫ ((whiskering_left _ _ _).obj _).map_iso
        ((limits.cocones.precompose_comp _ _).symm ≪≫
          by { rw (K.associator F G).inv_hom_id, exact limits.cocones.precompose_id })
  ≪≫ (functor.right_unitor _)

def functor.map_cocone_comp' {J C D E : Type*} [category J] [category C] [category D] [category E]
  (K : J ⥤ C) (F : C ⥤ D) (G : D ⥤ E) (c : cocone K)
  : (F ⋙ G).map_cocone c
  ≅ (cocones.precompose (functor.associator K F G).hom).obj (G.map_cocone (F.map_cocone c)) :=
  ((evaluation _ _).obj c).map_iso (functor.map_cocone_comp K F G)

def functor.map_cocone_map_cocone' {J C D E : Type*} [category J] [category C] [category D]
  [category E] (K : J ⥤ C) (F : C ⥤ D) (G : D ⥤ E) (c : cocone K)
  : (cocones.precompose (functor.associator K F G).inv).obj ((F ⋙ G).map_cocone c)
  ≅ G.map_cocone (F.map_cocone c) :=
  ((evaluation _ _).obj c).map_iso (functor.map_cocone_map_cocone K F G)

def category_theory.limits.preserves_limits_of_equiv_domain {C : Type*} [category C]
  {D : Type*} [category D] {J : Type*} [category J] {K : J ⥤ C}
  {C' : Type*} [category C'] (F : C ⥤ D) (e : C ≌ C')
  (h : preserves_limit (K ⋙ e.functor) (e.inverse ⋙ F))
  : preserves_limit K F :=
begin
  constructor, intros c hc,
  let α : K ⋙ F ≅ (K ⋙ e.functor) ⋙ (e.inverse ⋙ F) :=
  calc K ⋙ F ≅ K ⋙ (𝟭 C ⋙ F) : ((whiskering_left _ _ _).obj K).map_iso F.left_unitor.symm
          ... ≅ K ⋙ ((e.functor ⋙ e.inverse) ⋙ F) : ((whiskering_left _ _ _).obj K).map_iso
                                                          (((whiskering_right _ _ _).obj F).map_iso
                                                            e.unit_iso)
          ... ≅ K ⋙ (e.functor ⋙ (e.inverse ⋙ F)) : ((whiskering_left _ _ _).obj K).map_iso
                                                          (functor.associator _ _ _)
          ... ≅ (K ⋙ e.functor) ⋙ (e.inverse ⋙ F) : functor.associator _ _ _,
  refine is_limit.equiv_of_nat_iso_of_iso α.symm
                                          ((e.inverse ⋙ F).map_cone (e.functor.map_cone c))
                                          (F.map_cone c) _ _,
  { ext, swap, { exact F.map_iso (e.unit_iso.app c.X).symm },
    { dsimp,
      refine eq.trans (congr_arg _ (category.id_comp _))
               (eq.trans (congr_arg _ (category.id_comp _))
                 (eq.trans (congr_arg _ (category.comp_id _)) _)),
      rw [← F.map_comp, ← F.map_comp],
      refine congr_arg _ _,
      rw [← functor.comp_map],
      apply e.unit_iso.inv.naturality } },
  { destruct h, intros h' _, refine h' _,
    destruct adjunction.is_equivalence_preserves_limits e.functor, intros h'' _,
    destruct h'', intros h''' _, destruct @h''' K, intros H _,
    exact H hc, }
end.

def category_theory.limits.preserves_colimits_of_equiv_domain {C : Type*} [category C]
  {D : Type*} [category D] {J : Type*} [category J] {K : J ⥤ C}
  {C' : Type*} [category C'] (F : C ⥤ D) (e : C ≌ C')
  (h : preserves_colimit (K ⋙ e.functor) (e.inverse ⋙ F))
  : preserves_colimit K F :=
begin
  constructor, intros c hc,
  let α : K ⋙ F ≅ (K ⋙ e.functor) ⋙ (e.inverse ⋙ F) :=
  calc K ⋙ F ≅ K ⋙ (𝟭 C ⋙ F) : ((whiskering_left _ _ _).obj K).map_iso F.left_unitor.symm
          ... ≅ K ⋙ ((e.functor ⋙ e.inverse) ⋙ F) : ((whiskering_left _ _ _).obj K).map_iso
                                                          (((whiskering_right _ _ _).obj F).map_iso
                                                            e.unit_iso)
          ... ≅ K ⋙ (e.functor ⋙ (e.inverse ⋙ F)) : ((whiskering_left _ _ _).obj K).map_iso
                                                          (functor.associator _ _ _)
          ... ≅ (K ⋙ e.functor) ⋙ (e.inverse ⋙ F) : functor.associator _ _ _,
  refine is_colimit.equiv_of_nat_iso_of_iso α.symm
                                            ((e.inverse ⋙ F).map_cocone (e.functor.map_cocone c))
                                            (F.map_cocone c) _ _,
  { ext, swap, { exact F.map_iso (e.unit_iso.app c.X).symm },
    { dsimp,
      refine eq.trans (congr_arg2 _ (congr_arg2 _ (category.comp_id _) rfl) rfl)  _,
      refine eq.trans (congr_arg2 _ (congr_arg2 _ (category.comp_id _) rfl) rfl)  _,
      refine eq.trans (congr_arg2 _ (congr_arg2 _ (category.id_comp _) rfl) rfl)  _,
      rw [← F.map_comp, ← F.map_comp],
      refine congr_arg _ _,
      rw [← functor.comp_map],
      rw ← e.unit_iso.hom.naturality, simp } },
  { destruct h, intros h' _, refine h' _,
    destruct adjunction.is_equivalence_preserves_colimits e.functor, intros h'' _,
    destruct h'', intros h''' _, destruct @h''' K, intros H _,
    exact H hc, }
end.

def category_theory.limits.preserves_colimits_of_equiv_codomain {C : Type*} [category C]
  {D : Type*} [category D] {J : Type*} [category J] {K : J ⥤ C}
  {D' : Type*} [category D'] (F : C ⥤ D) (e : D ≌ D')
  (h : preserves_colimit K (F ⋙ e.functor))
  : preserves_colimit K F :=
  @limits.preserves_colimit_of_nat_iso _ _ _ _ _ _ _ _ _
    (functor.associator _ _ _ ≪≫ ((whiskering_left _ _ _).obj F).map_iso e.unit_iso.symm
                              ≪≫ functor.right_unitor _)
    (@limits.comp_preserves_colimit C _ D' _ J _ K D _ (F ⋙ e.functor) e.inverse h _)

def category_theory.iso_to_equiv {C : Type*} [category C] {D : Type*} [category D]
  (F : Cat.of C ≅ Cat.of D) : C ≌ D :=
  ⟨F.hom, F.inv, eq_to_iso (F.hom_inv_id.symm), eq_to_iso (F.inv_hom_id),
   by { intro, simp, rw category_theory.eq_to_hom_map, simp, refl }⟩.

lemma colimit_iso_colimit_cocone_desc {J C : Type*} [category J] [category C]
  (F : J ⥤ C) [has_colimit F] (c : colimit_cocone F) (c' : cocone F)
  : (colimit.iso_colimit_cocone c).inv ≫ colimit.desc F c' = c.is_colimit.desc c' :=
 by { apply c.is_colimit.hom_ext, intro j, simp }

-- universes v₁ v₂ v₃ v₄ u₁ u₂ u₃ u₄
-- I think the universe levels are borked :(
-- def comma.cocone_of_preserves_is_colimit'
--   {J : Type u₁} [small_category.{u₁} J] {A : Type u₂}
--   [category.{(max u₁ u₂) u₂} A] {B : Type u₃}
--   [category.{(max u₁ u₃) u₃} B] {T : Type u₄}
--   [category.{(max u₁ u₄) u₄} T] {L : A ⥤ T} {R : B ⥤ T}
--   (F : J ⥤ comma L R)
--   [preserves_colimit (F ⋙ comma.fst L R) L]
--   {c₁ : cocone (F ⋙ comma.fst L R)} (t₁ : is_colimit c₁)
--   {c₂ : cocone (F ⋙ comma.snd L R)} (t₂ : is_colimit c₂) :
--   is_colimit (comma.cocone_of_preserves.{u₁} F t₁ c₂) :=
-- { desc := λ s,
--   { left := t₁.desc ((fst L R).map_cocone s),
--     right := t₂.desc ((snd L R).map_cocone s),
--     w' := (is_colimit_of_preserves L t₁).hom_ext $ λ j,
--     begin
--       rw [cocone_of_preserves_X_hom, (is_colimit_of_preserves L t₁).fac_assoc,
--         colimit_auxiliary_cocone_ι_app, assoc, ←R.map_comp, t₂.fac, L.map_cocone_ι_app,
--         ←L.map_comp_assoc, t₁.fac],
--       exact (s.ι.app j).w,
--     end },
--   uniq' := λ s m w, comma_morphism.ext _ _
--       (t₁.uniq ((fst L R).map_cocone s) _ (by simp [←w]))
--       (t₂.uniq ((snd L R).map_cocone s) _ (by simp [←w])) }

end category_theory


import tactic.basic core data.sum tactic.rcases
universes u₁ u₂

open interactive interactive.types
open lean.parser nat tactic

meta def get_ext_subject : expr → tactic name
| (expr.pi n bi d b) :=
  do v  ← mk_local' n bi d,
     b' ← whnf $ b.instantiate_var v,
     get_ext_subject b'
| (expr.app _ e) :=
  do t ← infer_type e >>= instantiate_mvars >>= head_beta,
     if t.get_app_fn.is_constant then
       pure $ t.get_app_fn.const_name
     else if t.is_pi then
       pure $ name.mk_numeral 0 name.anonymous
     else if t.is_sort then
       pure $ name.mk_numeral 1 name.anonymous
     else do
       t ← pp t,
       fail format!"only constants and Pi types are supported: {t}"
| e := fail format!"Only expressions of the form `_ → _ → ... → R ... e are supported: {e}"

open native

@[reducible] def ext_param_type := option name ⊕ option name

meta def opt_minus : lean.parser (option name → ext_param_type) :=
sum.inl <$ tk "-" <|> pure sum.inr

meta def ext_param :=
opt_minus <*> ( name.mk_numeral 0 name.anonymous <$ brackets "(" ")" (tk "→" <|> tk "->") <|>
                none <$  tk "*" <|>
                some <$> ident )

meta def saturate_fun : name → tactic expr
| (name.mk_numeral 0 name.anonymous) :=
do v₀ ← mk_mvar,
   v₁ ← mk_mvar,
   return $ v₀.imp v₁
| (name.mk_numeral 1 name.anonymous) :=
do u ← mk_meta_univ,
   pure $ expr.sort u
| n :=
do e ← resolve_constant n >>= mk_const,
   a ← get_arity e,
   e.mk_app <$> (list.iota a).mmap (λ _, mk_mvar)

meta def equiv_type_constr (n n' : name) : tactic unit :=
do e  ← saturate_fun n,
   e' ← saturate_fun n',
   unify e e' <|> fail format!"{n} and {n'} are not definitionally equal types"

/--
 Tag lemmas of the form:

 ```
 @[extensionality]
 lemma my_collection.ext (a b : my_collection)
   (h : ∀ x, a.lookup x = b.lookup y) :
   a = b := ...
 ```

 The attribute indexes extensionality lemma using the type of the
 objects (i.e. `my_collection`) which it gets from the statement of
 the lemma.  In some cases, the same lemma can be used to state the
 extensionality of multiple types that are definitionally equivalent.

 ```
 attribute [extensionality [(→),thunk,stream]] funext
 ```

 Those parameters are cumulative. The following are equivalent:

 ```
 attribute [extensionality [(→),thunk]] funext
 attribute [extensionality [stream]] funext
 ```
 and
 ```
 attribute [extensionality [(→),thunk,stream]] funext
 ```

 One removes type names from the list for one lemma with:
 ```
 attribute [extensionality [-stream,-thunk]] funext
  ```

 Finally, the following:

 ```
 @[extensionality]
 lemma my_collection.ext (a b : my_collection)
   (h : ∀ x, a.lookup x = b.lookup y) :
   a = b := ...
 ```

 is equivalent to

 ```
 @[extensionality *]
 lemma my_collection.ext (a b : my_collection)
   (h : ∀ x, a.lookup x = b.lookup y) :
   a = b := ...
 ```

 This allows us specify type synonyms along with the type
 that referred to in the lemma statement.

 ```
 @[extensionality [*,my_type_synonym]]
 lemma my_collection.ext (a b : my_collection)
   (h : ∀ x, a.lookup x = b.lookup y) :
   a = b := ...
 ```
 -/
@[user_attribute]
meta def extensional_attribute : user_attribute (name_map name) (bool × list ext_param_type × list name × list (name × name)) :=
{ name := `extensionality,
  descr := "lemmas usable by `ext` tactic",
  cache_cfg := { mk_cache := λ ls,
                          do { attrs ← ls.mmap $ λ l,
                                     do { ⟨_,_,ls,_⟩ ← extensional_attribute.get_param l,
                                          pure $ prod.mk <$> ls <*> pure l },
                               pure $ rb_map.of_list $ attrs.join },
                 dependencies := [] },
  parser :=
    do { ls ← pure <$> ext_param <|> list_of ext_param <|> pure [],
         m ← extensional_attribute.get_cache,
         pure $ (ff,ls,[],m.to_list)  },
  after_set := some $ λ n _ b,
    do (ff,ls,_,ls') ← extensional_attribute.get_param n | pure (),
       s ← mk_const n >>= infer_type >>= get_ext_subject,
       let (rs,ls'') := if ls.empty
                           then ([],[s])
                           else ls.partition_map (sum.map (flip option.get_or_else s) (flip option.get_or_else s)),
       ls''.mmap' (equiv_type_constr s),
       let l := ls'' ∪ (ls'.filter $ λ l, prod.snd l = n).map prod.fst \ rs,
       extensional_attribute.set n (tt,[],l,[]) b }

attribute [extensionality] array.ext propext
attribute [extensionality [(→),thunk]] _root_.funext

namespace ulift
@[extensionality] lemma ext {α : Type u₁} (X Y : ulift.{u₂} α) (w : X.down = Y.down) : X = Y :=
begin
  cases X, cases Y, dsimp at w, rw w,
end
end ulift

namespace tactic

meta def try_intros : ext_patt → tactic ext_patt
| [] := try intros $> []
| (x::xs) :=
do tgt ← target >>= whnf,
   if tgt.is_pi
     then rintro [x] >> try_intros xs
     else pure (x :: xs)

meta def ext1 (xs : ext_patt) : tactic ext_patt :=
do subject ← target >>= get_ext_subject,
   m ← extensional_attribute.get_cache,
   do { rule ← m.find subject,
        applyc rule } <|>
     do { ls ← attribute.get_instances `extensionality,
          ls.any_of applyc } <|>
     fail format!"no applicable extensionality rule found for {subject}",
   try_intros xs

meta def ext : ext_patt → option ℕ → tactic unit
| _  (some 0) := skip
| xs n        := focus1 $ do
  ys ← ext1 xs, try (ext ys (nat.pred <$> n))

local postfix `?`:9001 := optional
local postfix *:9001 := many

/--
  `ext1 id` selects and apply one extensionality lemma (with attribute
  `extensionality`), using `id`, if provided, to name a local constant
  introduced by the lemma. If `id` is omitted, the local constant is
  named automatically, as per `intro`.
 -/
meta def interactive.ext1 (xs : parse ext_parse) : tactic unit :=
ext1 xs $> ()

/--
  - `ext` applies as many extensionality lemmas as possible;
  - `ext ids`, with `ids` a list of identifiers, finds extentionality and applies them
    until it runs out of identifiers in `ids` to name the local constants.

  When trying to prove:

  ```
  α β : Type,
  f g : α → set β
  ⊢ f = g
  ```

  applying `ext x y` yields:

  ```
  α β : Type,
  f g : α → set β,
  x : α,
  y : β
  ⊢ y ∈ f x ↔ y ∈ f x
  ```

  by applying functional extensionality and set extensionality.

  A maximum depth can be provided with `ext x y z : 3`.
  -/
meta def interactive.ext : parse ext_parse → parse (tk ":" *> small_nat)? → tactic unit
 | [] (some n) := iterate_range 1 n (ext1 [] $> ())
 | [] none     := repeat1 (ext1 [] $> ())
 | xs n        := tactic.ext xs n

end tactic


import Lean
import Lean.Parser.Term

open Lean Elab Command Term Meta

namespace SumMacro

-- The Prismatic class lets you move between a sum type and its subtypes
-- For instance if you had a sum type X := A | B then
--  > inject goes from A → X or B → X
--  > project goes from X → Option A or X → Option B
class Prismatic (e : Type → Type) (u : Type → Type v) where
    inject : e α → u α
    project : u α → Option (e α)

-- Given a sum type we need a way to label each branch of the sum type.
-- For example given X := A | B we need to generate contructors for A and B.
-- For normal sum types these are usually Left and Right, but one reason to use
-- macros is so that the names are a little more readable.
-- Typically the subtype name is just the name of the subtype, assuming
-- the subtype is just an identifier indicating some type. However, you can
-- actually pass in an expression as a subtype. We need a way to generate
-- an ID for that expression that is (mostly) unique and also repeatable
-- for that expression (thus we can't just generate random names).
partial
def compileSubId : Syntax → Name := fun subterm =>
    match subterm with
    | .missing => "missing_"
    | .node _ kind args =>
        if kind == strLitKind
        then compileSubId args[0]!
        -- ignore parenthesis
        else if kind == ``Lean.Parser.Term.paren
        then compileSubId args[1]!
        -- for parameterized types we merge the function and its argument
        else if kind == ``Lean.Parser.Term.app
        then
            let fName := compileSubId args[0]!
            let argNames := compileSubId args[1]!
            fName ++ argNames
        -- if we didn't handle the term already we just punt and try
        -- to fold together all the sub nodes, ignoring null or empty values
        else if args.size > 0
        then Array.foldl (fun x y =>
                              let y' := compileSubId y
                              if x == ""
                              then compileSubId y
                              else if y' == "null"
                              then x
                              else x ++ y') "" args
        else if kind == `null
        then "null"
        else toString kind
    | .atom _ val => val
    | .ident _ _ val _ => val

def sumCtorName2 : Ident → Term → Name := fun sumid subterm => sumid.getId ++ Name.appendAfter (compileSubId subterm) "select"

-- to generate the sum type we basically need to generate constructors for each subtype
-- and then tie it all together with an inductive view.
def elabSumI (sumid : Ident) (subids : Syntax.TSepArray `term ",") : CommandElabM Unit := do
    let subvals : Array (TSyntax `term) := subids
    let toCtor : Term → CommandElabM CtorView :=
      fun subterm => do
        let ty ← `({x : Type} → $subterm x → $sumid x)
        pure { ref := default,
                modifiers := default,
                declName := sumCtorName2 sumid subterm,
                binders := Syntax.missing,
                type? := ty
                }
    let subCtors : Array CtorView ← Array.sequenceMap subvals toCtor
    let indView : InductiveView := {
        ref := default,
        modifiers := {docString? := "argh"},
        declId := sumid,
        shortDeclName := sumid.getId,
        declName      := sumid.getId,
        levelNames := [],
        binders := Syntax.missing,
        type? := (← `(Type → Type 1)),
        ctors := subCtors,
        derivingClasses := #[],
        computedFields := #[]
        }
    elabInductiveViews #[indView]

-- you can make the sum type directly using mkSumI but typically you use
-- mkSumType which also generates prismatic instances
elab "mkSumI" sumid:ident " o: " subids:term,+ ":o" : command => elabSumI sumid subids

def elabPrismatic (sumid : Ident) (subterm: Term) : CommandElabM Unit := do
    let ctorName : Ident := Lean.mkIdent <| sumCtorName2 sumid subterm
    let instanceCmd ←
      `(instance  : Prismatic $subterm ($sumid) where
          inject := fun sx => $ctorName sx
          project := fun bx => match bx with
                                | $ctorName sx => Option.some sx
                                | _ => Option.none)
    elabCommand instanceCmd

elab "mkPrismatic" sumid:ident subid:term : command => elabPrismatic sumid subid

elab "mkSumType" sumid:ident " >| " subids:term,+ " |< " : command => do
    elabSumI sumid subids
    let mkP := fun subterm => elabPrismatic sumid subterm
    Array.forM mkP (subids : Array Term)

def elabCollapse (collapsertarget : TSyntax `term) (sumid : Ident) (subids: Syntax.TSepArray `term sep) (collapsers : Syntax.TSepArray `term sep) : TermElabM Expr := do
    let evalBranch : (TSyntax `term × TSyntax `term) → TermElabM (TSyntax `Lean.Parser.Term.matchAlt) := fun ⟨subval, collapser⟩ => do
        let ctorName := Lean.mkIdent <| sumCtorName2 sumid subval
        `(Parser.Term.matchAltExpr| | $ctorName x => $collapser x)
    let subidsArray : Array (TSyntax `term) := subids
    let collapsersArray : Array (TSyntax `term) := collapsers
    let branches ← Array.sequenceMap (Array.zip subidsArray collapsersArray) evalBranch
    let collapserFunc ← `(fun {α : Type} (sumVal : $sumid α) => (match sumVal with $branches:matchAlt* : $collapsertarget α))
    elabTerm collapserFunc Option.none

elab "buildInterpreter" commandtype:ident targetmonad:ident subids:term,+ " [: " collapsers:term,+ " :] " : term =>
    elabCollapse targetmonad commandtype subids collapsers

/-
namespace x

inductive OtherI (y : Type) where
  | A : y → OtherI y
  | C : y → y → OtherI y
    deriving Repr

inductive EcksI (x : Type) (y : Type) where
| X : x → y → EcksI x y
-/
/-
mkSumI Argh o: (EcksI Nat),OtherI :o
mkPrismatic Argh (EcksI Nat)
mkPrismatic Argh OtherI

mkSumType Argh >| EcksI Nat, OtherI |<

def collapserArgh := buildInterpreter Argh IO (EcksI Nat),OtherI
    [:
      (fun s => match s with
                | EcksI.X x y => pure y),
      (fun o => match o with
                | OtherI.A y => pure y
                | OtherI.C a b => pure b)
    :]

open Prismatic

def aVal : Argh Nat := inject <| EcksI.X 3 4
end x

-/

/-#print Argh
#check Argh.EcksI.Natselect (EcksI.X 3 4)
#check @Prismatic.inject (EcksI Nat) Argh _ Nat (EcksI.X 3 5)
#check (Prismatic.inject (EcksI.X 3 7) : Argh Nat)
#check blargh aVal
-/

end SumMacro


import classes.unrestricted.basics.definition

variables {T : Type} {g : grammar T}

/-- The relation `grammar_derives` is reflexive. -/
lemma grammar_deri_self {w : list (symbol T g.nt)} :
  grammar_derives g w w :=
relation.refl_trans_gen.refl

lemma grammar_deri_of_tran {v w : list (symbol T g.nt)} :
  grammar_transforms g v w → grammar_derives g v w :=
relation.refl_trans_gen.single

/-- The relation `grammar_derives` is transitive. -/
lemma grammar_deri_of_deri_deri {u v w : list (symbol T g.nt)}
    (huv : grammar_derives g u v) (hvw : grammar_derives g v w) :
  grammar_derives g u w :=
relation.refl_trans_gen.trans huv hvw

lemma grammar_deri_of_deri_tran {u v w : list (symbol T g.nt)}
    (huv : grammar_derives g u v) (hvw : grammar_transforms g v w) :
  grammar_derives g u w :=
grammar_deri_of_deri_deri huv (grammar_deri_of_tran hvw)

lemma grammar_deri_of_tran_deri {u v w : list (symbol T g.nt)}
    (huv : grammar_transforms g u v) (hvw : grammar_derives g v w) :
  grammar_derives g u w :=
grammar_deri_of_deri_deri (grammar_deri_of_tran huv) hvw

lemma grammar_tran_or_id_of_deri {u w : list (symbol T g.nt)} (ass : grammar_derives g u w) :
  (u = w) ∨
  (∃ v : list (symbol T g.nt), (grammar_transforms g u v) ∧ (grammar_derives g v w)) :=
relation.refl_trans_gen.cases_head ass

lemma grammar_deri_with_prefix {w₁ w₂ : list (symbol T g.nt)}
    (pᵣ : list (symbol T g.nt))
    (ass : grammar_derives g w₁ w₂) :
  grammar_derives g (pᵣ ++ w₁) (pᵣ ++ w₂) :=
begin
  induction ass with x y trash hyp ih,
  {
    apply grammar_deri_self,
  },
  apply grammar_deri_of_deri_tran,
  {
    exact ih,
  },
  rcases hyp with ⟨r, rin, u, v, h_bef, h_aft⟩,
  use r,
  split,
  {
    exact rin,
  },
  use pᵣ ++ u,
  use v,
  rw h_bef,
  rw h_aft,
  split;
  simp only [list.append_assoc],
end

lemma grammar_deri_with_postfix {w₁ w₂ : list (symbol T g.nt)}
    (pₒ : list (symbol T g.nt))
    (ass : grammar_derives g w₁ w₂) :
  grammar_derives g (w₁ ++ pₒ) (w₂ ++ pₒ) :=
begin
  induction ass with x y trash hyp ih,
  {
    apply grammar_deri_self,
  },
  apply grammar_deri_of_deri_tran,
  {
    exact ih,
  },
  rcases hyp with ⟨r, rin, u, v, h_bef, h_aft⟩,
  use r,
  split,
  {
    exact rin,
  },
  use u,
  use v ++ pₒ,
  rw h_bef,
  rw h_aft,
  split;
  simp only [list.append_assoc],
end

def as_terminal {N : Type} : symbol T N → option T
| (symbol.terminal t)    := some t
| (symbol.nonterminal _) := none

def all_used_terminals (g : grammar T) : list T :=
list.filter_map as_terminal (list.join (list.map grule.output_string g.rules))


/-
Copyright (c) 2017 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Johannes Hölzl
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.lint.default
import Mathlib.tactic.ext
import Mathlib.tactic.simps
import Mathlib.PostPort

universes u_1 u_2 u_3

namespace Mathlib

namespace subtype

/-- See Note [custom simps projection] -/
def simps.val {α : Sort u_1} {p : α → Prop} (x : Subtype p) : α :=
  ↑x

/-- A version of `x.property` or `x.2` where `p` is syntactically applied to the coercion of `x`
  instead of `x.1`. A similar result is `subtype.mem` in `data.set.basic`. -/
theorem prop {α : Sort u_1} {p : α → Prop} (x : Subtype p) : p ↑x :=
  property x

@[simp] theorem val_eq_coe {α : Sort u_1} {p : α → Prop} {x : Subtype p} : val x = ↑x :=
  rfl

@[simp] protected theorem forall {α : Sort u_1} {p : α → Prop} {q : (Subtype fun (a : α) => p a) → Prop} : (∀ (x : Subtype fun (a : α) => p a), q x) ↔ ∀ (a : α) (b : p a), q { val := a, property := b } := sorry

/-- An alternative version of `subtype.forall`. This one is useful if Lean cannot figure out `q`
  when using `subtype.forall` from right to left. -/
protected theorem forall' {α : Sort u_1} {p : α → Prop} {q : (x : α) → p x → Prop} : (∀ (x : α) (h : p x), q x h) ↔ ∀ (x : Subtype fun (a : α) => p a), q (↑x) (property x) :=
  iff.symm subtype.forall

@[simp] protected theorem exists {α : Sort u_1} {p : α → Prop} {q : (Subtype fun (a : α) => p a) → Prop} : (∃ (x : Subtype fun (a : α) => p a), q x) ↔ ∃ (a : α), ∃ (b : p a), q { val := a, property := b } := sorry

protected theorem ext {α : Sort u_1} {p : α → Prop} {a1 : Subtype fun (x : α) => p x} {a2 : Subtype fun (x : α) => p x} : ↑a1 = ↑a2 → a1 = a2 := sorry

theorem ext_iff {α : Sort u_1} {p : α → Prop} {a1 : Subtype fun (x : α) => p x} {a2 : Subtype fun (x : α) => p x} : a1 = a2 ↔ ↑a1 = ↑a2 :=
  { mp := congr_arg fun {a1 : Subtype fun (x : α) => p x} => ↑a1, mpr := subtype.ext }

theorem heq_iff_coe_eq {α : Sort u_1} {p : α → Prop} {q : α → Prop} (h : ∀ (x : α), p x ↔ q x) {a1 : Subtype fun (x : α) => p x} {a2 : Subtype fun (x : α) => q x} : a1 == a2 ↔ ↑a1 = ↑a2 :=
  Eq._oldrec (fun (a2' : Subtype fun (x : α) => p x) => iff.trans heq_iff_eq ext_iff)
    (funext fun (x : α) => propext (h x)) a2

theorem ext_val {α : Sort u_1} {p : α → Prop} {a1 : Subtype fun (x : α) => p x} {a2 : Subtype fun (x : α) => p x} : val a1 = val a2 → a1 = a2 :=
  subtype.ext

theorem ext_iff_val {α : Sort u_1} {p : α → Prop} {a1 : Subtype fun (x : α) => p x} {a2 : Subtype fun (x : α) => p x} : a1 = a2 ↔ val a1 = val a2 :=
  ext_iff

@[simp] theorem coe_eta {α : Sort u_1} {p : α → Prop} (a : Subtype fun (a : α) => p a) (h : p ↑a) : { val := ↑a, property := h } = a :=
  subtype.ext rfl

@[simp] theorem coe_mk {α : Sort u_1} {p : α → Prop} (a : α) (h : p a) : ↑{ val := a, property := h } = a :=
  rfl

@[simp] theorem mk_eq_mk {α : Sort u_1} {p : α → Prop} {a : α} {h : p a} {a' : α} {h' : p a'} : { val := a, property := h } = { val := a', property := h' } ↔ a = a' :=
  ext_iff

theorem coe_eq_iff {α : Sort u_1} {p : α → Prop} {a : Subtype fun (a : α) => p a} {b : α} : ↑a = b ↔ ∃ (h : p b), a = { val := b, property := h } := sorry

theorem coe_injective {α : Sort u_1} {p : α → Prop} : function.injective coe :=
  fun (a b : Subtype p) => subtype.ext

theorem val_injective {α : Sort u_1} {p : α → Prop} : function.injective val :=
  coe_injective

/-- Restrict a (dependent) function to a subtype -/
def restrict {α : Sort u_1} {β : α → Type u_2} (f : (x : α) → β x) (p : α → Prop) (x : Subtype p) : β (val x) :=
  f ↑x

theorem restrict_apply {α : Sort u_1} {β : α → Type u_2} (f : (x : α) → β x) (p : α → Prop) (x : Subtype p) : restrict f p x = f (val x) :=
  Eq.refl (restrict f p x)

theorem restrict_def {α : Sort u_1} {β : Type u_2} (f : α → β) (p : α → Prop) : restrict f p = f ∘ coe :=
  Eq.refl (restrict f p)

theorem restrict_injective {α : Sort u_1} {β : Type u_2} {f : α → β} (p : α → Prop) (h : function.injective f) : function.injective (restrict f p) :=
  function.injective.comp h coe_injective

/-- Defining a map into a subtype, this can be seen as an "coinduction principle" of `subtype`-/
def coind {α : Sort u_1} {β : Sort u_2} (f : α → β) {p : β → Prop} (h : ∀ (a : α), p (f a)) : α → Subtype p :=
  fun (a : α) => { val := f a, property := h a }

theorem coind_injective {α : Sort u_1} {β : Sort u_2} {f : α → β} {p : β → Prop} (h : ∀ (a : α), p (f a)) (hf : function.injective f) : function.injective (coind f h) :=
  fun (x y : α) (hxy : coind f h x = coind f h y) => hf (congr_arg val hxy)

theorem coind_surjective {α : Sort u_1} {β : Sort u_2} {f : α → β} {p : β → Prop} (h : ∀ (a : α), p (f a)) (hf : function.surjective f) : function.surjective (coind f h) := sorry

theorem coind_bijective {α : Sort u_1} {β : Sort u_2} {f : α → β} {p : β → Prop} (h : ∀ (a : α), p (f a)) (hf : function.bijective f) : function.bijective (coind f h) :=
  { left := coind_injective h (and.left hf), right := coind_surjective h (and.right hf) }

/-- Restriction of a function to a function on subtypes. -/
@[simp] theorem map_coe {α : Sort u_1} {β : Sort u_2} {p : α → Prop} {q : β → Prop} (f : α → β) (h : ∀ (a : α), p a → q (f a)) : ∀ (ᾰ : Subtype p), ↑(map f h ᾰ) = f ↑ᾰ :=
  fun (ᾰ : Subtype p) => Eq.refl ↑(map f h ᾰ)

theorem map_comp {α : Sort u_1} {β : Sort u_2} {γ : Sort u_3} {p : α → Prop} {q : β → Prop} {r : γ → Prop} {x : Subtype p} (f : α → β) (h : ∀ (a : α), p a → q (f a)) (g : β → γ) (l : ∀ (a : β), q a → r (g a)) : map g l (map f h x) = map (g ∘ f) (fun (a : α) (ha : p a) => l (f a) (h a ha)) x :=
  rfl

theorem map_id {α : Sort u_1} {p : α → Prop} {h : ∀ (a : α), p a → p (id a)} : map id h = id := sorry

theorem map_injective {α : Sort u_1} {β : Sort u_2} {p : α → Prop} {q : β → Prop} {f : α → β} (h : ∀ (a : α), p a → q (f a)) (hf : function.injective f) : function.injective (map f h) :=
  coind_injective (fun (x : Subtype fun (a : α) => p a) => map._proof_1 f h x) (function.injective.comp hf coe_injective)

theorem map_involutive {α : Sort u_1} {p : α → Prop} {f : α → α} (h : ∀ (a : α), p a → p (f a)) (hf : function.involutive f) : function.involutive (map f h) :=
  fun (x : Subtype fun (a : α) => p a) => subtype.ext (hf ↑x)

protected instance has_equiv {α : Sort u_1} [has_equiv α] (p : α → Prop) : has_equiv (Subtype p) :=
  has_equiv.mk fun (s t : Subtype p) => ↑s ≈ ↑t

theorem equiv_iff {α : Sort u_1} [has_equiv α] {p : α → Prop} {s : Subtype p} {t : Subtype p} : s ≈ t ↔ ↑s ≈ ↑t :=
  iff.rfl

protected theorem refl {α : Sort u_1} {p : α → Prop} [setoid α] (s : Subtype p) : s ≈ s :=
  setoid.refl ↑s

protected theorem symm {α : Sort u_1} {p : α → Prop} [setoid α] {s : Subtype p} {t : Subtype p} (h : s ≈ t) : t ≈ s :=
  setoid.symm h

protected theorem trans {α : Sort u_1} {p : α → Prop} [setoid α] {s : Subtype p} {t : Subtype p} {u : Subtype p} (h₁ : s ≈ t) (h₂ : t ≈ u) : s ≈ u :=
  setoid.trans h₁ h₂

theorem equivalence {α : Sort u_1} [setoid α] (p : α → Prop) : equivalence has_equiv.equiv :=
  mk_equivalence has_equiv.equiv subtype.refl subtype.symm subtype.trans

protected instance setoid {α : Sort u_1} [setoid α] (p : α → Prop) : setoid (Subtype p) :=
  setoid.mk has_equiv.equiv (equivalence p)

end subtype

namespace subtype

/-! Some facts about sets, which require that `α` is a type. -/

@[simp] theorem coe_prop {α : Type u_1} {S : set α} (a : Subtype fun (a : α) => a ∈ S) : ↑a ∈ S :=
  prop a

theorem val_prop {α : Type u_1} {S : set α} (a : Subtype fun (a : α) => a ∈ S) : val a ∈ S :=
  property a