structure PFunctor : Type 1 :=
( α : Type )
( β : α → Type )

variable (P : PFunctor)

namespace PFunctor

def obj (X : Type) : Type :=
Σ (a : P.α), P.β a → X

def map {X Y : Type} (f : X → Y) (x : P.obj X) : P.obj Y :=
⟨x.1, λ a => f (x.2 a)⟩

inductive Z (P : PFunctor) : Type
| bud : Z P
| some (a : P.α) (f : P.β a → Z P) : Z P

variable {P}

def of_α (a : P.α) : Z P :=
Z.some a (λ _ => Z.bud)

inductive bud : Z P → Type
| bud : bud (@Z.bud P)
| some {a : P.α} {f : P.β a → Z P} {p : P.β a} (b : bud (f p)) :
    bud (Z.some a f)

inductive is_extension : Z P → Z P → Prop
| bud (z : Z P) : is_extension Z.bud z
| some {a : P.α} {f₁ f₂ : P.β a → Z P} (h : ∀ p : P.β a, is_extension (f₁ p) (f₂ p)) :
  is_extension (Z.some a f₁) (Z.some a f₂)

theorem is_extension.refl : (z : Z P) → is_extension z z
| Z.bud => is_extension.bud _
| Z.some _ _ => is_extension.some (λ _ => is_extension.refl _)

inductive extends_at {P : PFunctor}: (z₁ : Z P) → (b : bud z) → Z P → Type
| bud {a : P.α} {f : P.β a → Z P} : extends_at (@Z.bud P) (@bud.bud P) (Z.some a f)
| some {a : P.α} {f₁ f₂ : P.β a → Z P} {p : P.β a} (b : bud (f₁ p))
  (h : extends_at (f₁ p) b (f₂ p)) :
    extends_at (Z.some a f₁) (bud.some b) (Z.some a f₂)

structure M' (P : PFunctor) : Type :=
( s : Z P → Prop )
( bud_mem : s Z.bud )
( extension_pair {z₁ z₂ : Z P} : s z₁ → s z₂ →
  ∃ z₃ : Z P, s z₃ ∧ is_extension z₁ z₃ ∧ is_extension z₂ z₃ )
( extend {z : Z P} : s z → bud z → Z P )
( extend_extends {z : Z P} (h : s z) (b : bud z) :
    extends_at z b (extend h b) )

def M'.constructor (m : M' P) : P.α :=
let z := m.extend m.bud_mem bud.bud
have hz : extends_at Z.bud bud.bud z := m.extend_extends m.bud_mem bud.bud
match z, hz with
| Z.some a _, _ => a

def M.branch (m : M' P) (a : P.β m.constructor) : M' P :=

def M'_coalg (m : M' P) : P.obj (M' P) :=
let z := m.extend m.bud_mem bud.bud
have hz : extends_at Z.bud bud.bud z := m.extend_extends m.bud_mem bud.bud
match z, hz with
| Z.some a f, _ => ⟨a, λ p =>
  { s := λ z => z = Z.bud ∨ ∃ f : P.β a → Z P, m.s (Z.some a f) ∧ z = f p,
    bud_mem := Or.inl rfl,
    extension_pair := @λ z₁ z₂ hz₁ hz₂ =>
      match z₁, z₂, hz₁, hz₂ with
      | _, z₂, Or.inl rfl, hz₂ =>
        ⟨z₂, hz₂, is_extension.bud _, is_extension.refl _⟩
      | z₁, _, hz₁, Or.inl rfl =>
        ⟨z₁, hz₁, is_extension.refl _, is_extension.bud _⟩
      | _, _, Or.inr ⟨f₁, hf₁, rfl⟩, Or.inr ⟨f₂, hf₂, rfl⟩ =>
        match m.extension_pair hf₁ hf₂ with
        | ⟨Z.some _ f, h₁, is_extension.some h₂, is_extension.some h₃⟩ =>
          ⟨f p, Or.inr ⟨f, h₁, rfl⟩, h₂ p, h₃ p⟩,
    extend := @λ z hz b =>
      match z, hz, b with
      | Z.bud, _, bud.bud => f p
      | Z.some a' f', h, @bud.some _ _ _ p' h' =>
        _
    extend_extends := sorry
       }⟩

-- def M'.rel (m₁ m₂ : M' P) : Prop :=
-- ∃ m₃ : M' P, (∀ z, m₁.s z → m₃.s z) ∧ (∀ z, m₂.s z → m₃.s z)

-- def M'.rel.refl (m : M' P) : M'.rel m m :=
-- ⟨m, λ _ => id, λ _ => id⟩

-- def M'.rel.symm {m₁ m₂ : M' P} : M'.rel m₁ m₂ → M'.rel m₂ m₁
-- | ⟨m₃, h₁, h₂⟩ => ⟨m₃, h₂, h₁⟩

-- def M'.rel.trans {m₁ m₂ m₃ : M' P} : M'.rel m₁ m₂ → M'.rel m₂ m₃ → M'.rel m₁ m₃
-- | ⟨n, hn₁, hn₂⟩, ⟨o, ho₁, ho₂⟩ =>
--   ⟨{ s := λ z => n.s z ∨ o.s z,
--      bud_mem := Or.inl n.s.bud_mem,
--      extension_pair := _  }


import Aesop

axiom Scheme : Type
axiom P : Scheme → Prop
axiom Q : Scheme → Prop
axiom R : Scheme → Prop
axiom S : Scheme → Prop

@[aesop 99%] axiom Q_of_P (X : Scheme) (h : P X) : Q X
@[aesop 99%] axiom R_of_Q (X : Scheme) (h : Q X) : R X

@[aesop 99%] axiom S_of__R_of_P (X : Scheme) (h : P X → R X) : S X

theorem thm : S X := by {
  aesop;
}

#print thm


import tactic.basic
import tactic.ext
import data.set.basic

meta def my_tactic : tactic unit := `[exact 7, refl]
example : ∃ (n : ℕ), n = 7 :=
begin
    split,
    swap,
    my_tactic,
end

meta def my_tactic_5 : tactic unit :=
do `[induction a],
    tactic.reflexivity,
    `[simpa]


import data.complex.exponential
import analysis.special_functions.trigonometric.basic

theorem AMC_2021_A_19 (s:finset ℝ)
(h:∀(x:ℝ), x∈s ↔ real.sin ((real.pi/2)*real.cos x)=real.cos ((real.pi/2)*real.sin x)):
finset.card s = 2
:=
begin
  sorry
end


import data.list.alist
import .presheaf2

namespace o_minimal

variables {R : Type*} {S : struc R}

structure sect (Γ : Def S) (X : Type*) [definable_psh S X] :=
(to_fun : Γ → X)
(definable : definable_psh.definable to_fun)

infixr ` ⊢ `:10 := sect

def sect.precomp {Γ' Γ : Def S} {X : Type*} [definable_psh S X]
  (σ : Γ ⊢ X) (φ : Hom Γ' Γ) : Γ' ⊢ X :=
{ to_fun := σ.to_fun ∘ φ.to_fun,
  definable := definable_psh.definable_precomp φ σ.definable }

lemma begin_lem {X : Type*} [definable_psh S X] {x : X} :
  definable S x ↔ ∀ (Γ : Def S), definable_psh.definable (λ (γ : Γ), x) :=
begin
  unfold definable,
  split; intro H,
  { intro Γ,
    let u : Hom Γ pt := ⟨λ _, default _, by exact pt.definable⟩,
    exact definable_psh.definable_precomp u H },
  { apply H }
end

lemma intro_lem₁ {X Y : Type*} [definable_psh S X] [definable_psh S Y]
  (f : X → Y) :
  (∀ (Γ : Def S), definable S (λ (γ : Γ), f)) ↔
  (∀ (Γ : Def S) (x : Γ → X), definable S x → definable S (λ (γ : Γ), f (x γ))) :=
sorry

lemma definable_fun' {Γ : Def S} {X Y : Type*} [definable_psh S X] [definable_psh S Y]
  {f : Γ → X → Y} : definable_psh.definable f ↔
  (∀ (Γ' : Def S) (π : Hom Γ' Γ) (g : Γ' ⊢ X),
   definable_psh.definable (λ γ_1, f (π.to_fun γ_1) (g.to_fun γ_1))) :=
begin
  split; intro H,
  { intros Γ' π g,
    have : definable_psh.definable (λ γ', (π.to_fun γ', g.to_fun γ')) :=
      ⟨π.is_definable, g.definable⟩,
    exact H Γ' this },
  { intros M g hg,
    exact H M ⟨_, hg.1⟩ ⟨_, hg.2⟩ }
end

lemma definable.app_ctx' {Γ : Def S} {X Y : Type*} [definable_psh S X] [definable_psh S Y]
  (f : Γ → X → Y) {hf : definable_psh.definable f} (x : Γ → X) {hx : definable_psh.definable x} :
  definable_psh.definable (λ γ, f γ (x γ)) :=
begin
  have : definable_psh.definable (λ γ, (γ, x γ)) :=
    ⟨(Def.id _).is_definable, hx⟩,
  exact hf Γ this
end

lemma definable_const {Γ : Def S} {X : Type*} [definable_psh S X] {x : X} :
  definable S x → definable_psh.definable (λ (_ : Γ), x) :=
λ H, begin_lem.mp H Γ

end o_minimal

namespace tactic.interactive

open tactic
open interactive interactive.types

meta def defin_start : tactic unit :=
`[rw o_minimal.begin_lem, intro Γ]

/-- Return the variable representing the definable context. -/
meta def guess_ctx_var : tactic expr :=
do `(o_minimal.definable_psh.definable (λ (_ : ↥%%var), _)) ← target,
   -- trace var,
   return var

/-- Return a list of "definable" variables along with their processed types. -/
meta def guess_defin_vars (ctx_var : expr) : tactic (list (expr × expr)) :=
do l ← local_context,
   -- some kind of moption_map?
   l ← l.mmap (λ var,
     (do `(o_minimal.sect %%ctx_var %%ty) ← infer_type var,
         return $ some (var, ty)) <|> return none),
   let l' := l.filter_map id,
   -- trace l',
   return l'

meta def guess_defin_vars' : tactic (list (expr × expr)) :=
guess_ctx_var >>= guess_defin_vars

/-- Goal should look like
  ⊢ definable_psh.definable (λ γ, λ x, e)
We want to "intro" `x` as a definable variable, and leave
  ⊢ definable_psh.definable (λ γ, e)
as the new goal.

Strategy:
By `definable_fun'` it's enough to check the new goal
for an arbitrary context extension π : Γ' → Γ and section x : Γ' ⊢ α.
However, we also have to move any existing definable variables from Γ to Γ'.
So, we proceed as follows:
* Identify the variables `γ` (`i_var`) and `Γ` (`ctx_var`) in the goal
  `definable_psh.definable (λ (γ : Γ), body)`.
  Here `body` is expected to be a function whose argument `x`
  we want to intro.
* Use `definable_fun'` but then intro only `Γ'` and `π`.
* For each existing definable variable `p`, we add a let binding
  `p' := p.precomp π`.
* Now intro the new variable `x` (`new_var`) as well, and build a new function
  (λ (γ' : Γ'), body' (x.to_fun γ')), by making the following replacements:
  - each old `p` becomes `p'`;
  - `i` becomes `i'`;
  - `Γ` becomes `Γ'`.
  The claim is that the new expression is well-typed and definitionally equal
  (in the context of the let-bound variables `p'`, ...) to the current goal.
  Moreover, it only mentions the new `Γ'` and `p'`.
* Now we cover our tracks:
  - clear the bodies of the let bindings `p'`, so that we can:
  - clear the old definable variables, `π`, and the old `Γ`.

The tactic reuses the same user-visible names for the new `Γ` and `γ`.
This is nice for interactive use, but not so nice for debugging the tactic.
In the latter case, add `name.append_after _ 1` when generating names.
-/
meta def defin_intro (var : parse ident_) : tactic unit :=
let trace : Π {α : Type} [has_to_tactic_format α] (a : α), tactic unit :=
  λ _ _ _, tactic.skip in       -- comment this for debugging
do `(o_minimal.definable_psh.definable %%f) ← target,
   ([i_var], body) ← open_n_lambdas f 1,
   ctx_var ← guess_ctx_var,
   trace i_var,
   trace body,
   `[rw definable_fun'],
   new_ctx_var ← tactic.intro ctx_var.local_pp_name,
   proj_var ← tactic.intro `π,
   defin_vars ← guess_defin_vars ctx_var,
   -- do something to them:
   -- * for each old variable `p`, create a new variable `p'`
   --   which is let-bound to `p.precomp π`
   defin_var_list ← defin_vars.mmap (λ ⟨dvar, dvar_ty⟩, do
     -- "let p' := p.precomp π,"
     new_body ← to_expr ``((%%dvar).precomp %%proj_var),
     new_dvar ← tactic.pose dvar.local_pp_name none new_body,
     return (sigma.mk dvar new_dvar)),
   new_i_type ← to_expr ``(↥%%new_ctx_var),
   new_i_var ← mk_local' i_var.local_pp_name f.binding_info new_i_type,
   -- * replace variables `p` → `p'` in `body`, and also the γ and Γ vars
   let var_map :=
     (defin_var_list.to_alist.insert i_var new_i_var).insert ctx_var new_ctx_var,
   let body' := body.replace (λ e _, do
     -- for "efficiency", first check whether we have a variable at all
     guard (e.is_local_constant),
     -- then, look up the whole expression in our map
     var_map.lookup e),
   -- do the actual intro
   new_var ← tactic.intro var,
   new_var' ← to_expr ``((%%new_var).to_fun %%new_i_var),
   new_f ← tactic.lambdas [new_i_var] (body'.subst new_var'),
   trace new_f,
   new_target ← to_expr
     ``(o_minimal.definable_psh.definable %%new_f),
   tactic.change new_target,
   -- for each defin var:
   -- * forget its let binding (so that we can do the `clear`s below)
   --   (using `clear_value` from mathlib's `tactic.core`)
   -- * clear the original variable
   tactic.clear_value (defin_var_list.map sigma.snd),
   defin_var_list.mmap (λ ⟨dvar, new_dvar⟩, do tactic.clear dvar),
   tactic.clear proj_var,
   tactic.clear ctx_var,
   return ()

/-- Goal should look like
 ⊢ definable_psh.definable (λ γ, f x)
and we want to produce
 ⊢ definable_psh.definable (λ γ, f)
 ⊢ definable_psh.definable (λ γ, x)
This is just `apply definable.app_ctx'`,
but Lean needs help with the unification problem.
-/
meta def defin_app : tactic unit :=
do `(o_minimal.definable_psh.definable %%e) ← target,
   ([i_var], body) ← open_n_lambdas e 1,
   (expr.app f x) ← pure body,
   f' ← tactic.lambdas [i_var] f,
   x' ← tactic.lambdas [i_var] x,
   `[apply o_minimal.definable.app_ctx' %%f' %%x'],
   return ()

/-- Goal should look like
 ⊢ definable_psh.definable (λ γ, p.to_fun γ)
where p : Γ ⊢ α. Just apply `sect.definable`.
-/
meta def defin_var : tactic unit :=
`[refine o_minimal.sect.definable _]

end tactic.interactive

-- Now dress it up

meta def defin := tactic

meta instance : monad defin :=
show monad tactic, by apply_instance

meta instance : interactive.executor defin :=
{ config_type := unit,
  inhabited := by apply_instance,
  execute_with := λ _ tac, tactic.interactive.defin_start >> tac }

namespace defin

meta def execute (tac : defin unit) : tactic unit :=
tactic.interactive.defin_start >> tac

meta def step := @tactic.step   -- what does this even do
meta def istep := @tactic.istep -- ditto
meta def solve1 : defin unit → defin unit := tactic.solve1

open tactic

-- Tactic state display borrows liberally from
-- https://github.com/unitb/temporal-logic
-- file temporal_logic.tactic

/-- Replace any occurrences of `p.to_fun γ` with simply `p`.
This is rather crude, but these aren't expected to appear
outside the execution of a defin tactic. (More sophisticated
would be to process only those variables which are sections
over the context variable that appears in the goal.)
The resulting expression is intended to be used for display purposes. -/
meta def shorten (E : expr) : expr :=
E.replace $ λ e _, match e with
  | `(o_minimal.sect.to_fun %%p _) := some p
  | _ := none
end

meta structure hyp_data : Type :=
(crisp : bool)
(var : expr)
(ty : expr)
(val : option expr)

/-- Return information about a local hypothesis `l`. -/
meta def get_hyp_data (l : expr) : defin hyp_data :=
do ty ← infer_type l,
   val ← try_core (shorten <$> local_def_value l),
   match ty with
   | `(o_minimal.sect %%Γ %%ty') := return ⟨ff, l, shorten ty', val⟩
   | _ := return ⟨tt, l, shorten ty, val⟩
   end

meta def decl_to_fmt (s : tactic_state) (crisp : bool) (vs : list expr)
  (ty : expr) (val : option expr) : format :=
let vs' := format.join $ (vs.map s.format_expr).intersperse " ",
    t := s.format_expr ty,
    sep := if crisp then "::" else ":" in
match val with
| (some val) := format! "{vs'} {sep} {t} := {s.format_expr val}"
| none := format! "{vs'} {sep} {t}"
end

meta def goal_to_fmt (g : expr) : defin (thunk format) :=
do set_goals [g],
   s ← read,
   `(o_minimal.definable_psh.definable (λ (_ : ↥%%Γ), %%body)) ← target
     | pure (λ _, to_fmt s),
   lc ← local_context,
   ctx_var ← tactic.interactive.guess_ctx_var,
   dat ← (lc.filter (λ l, l ≠ ctx_var)).mmap get_hyp_data,
   return $ λ _, format.intercalate format.line
     [format.intercalate ("," ++ format.line) $ dat.map $ λ d,
        decl_to_fmt s d.crisp [d.var] d.ty d.val,
      format! "⊢ {s.format_expr (shorten body)} def"]

meta def save_info (p : pos) : defin unit :=
do gs ← get_goals,
   fmt ← gs.mmap goal_to_fmt,
   set_goals gs,
   tactic.save_info_thunk p (λ _,
     let header := if fmt.length > 1 then format! "{fmt.length} goals\n" else "",
         eval : thunk format → format := λ f, f () in
     if fmt.empty
       then "no goals"
       else format.join ((fmt.map eval).intersperse (format.line ++ format.line)))

namespace interactive

meta def swap := tactic.interactive.swap
meta def exact := tactic.interactive.exact
meta def solve1 : defin unit → defin unit := tactic.interactive.solve1

meta def intro := tactic.interactive.defin_intro
meta def app := tactic.interactive.defin_app
meta def var := tactic.interactive.defin_var

meta def trace_state : defin unit :=
do s ← read,
   trace s.to_format

end interactive

end defin

namespace o_minimal

variables {R : Type*} {S : struc R}

local infixr ` ⊢ `:10 := sect

example : definable S (λ p q, (q ∧ p) ∧ q) :=
begin
  defin_start,
  defin_intro p,
  defin_intro q,
  defin_app,
  swap,
  { defin_var },
  defin_app,
  { exact definable_const definable_and },
  defin_app,
  { defin_app,
    { exact definable_const definable_and },
    defin_var },
  { defin_var },
end

example : definable S (λ p q, (q ∧ p) ∧ q) :=
begin [defin]
  intro p,
  intro q,
  app,
  swap,
  { var },
  app,
  { exact definable_const definable_and },
  app,
  { app,
    { exact definable_const definable_and },
    var },
  { var },
end

example : definable S and :=
begin [defin]
  intro p,
  intro q,
  exact struc.def_coords.inter p.definable q.definable
end

example {X Y Z : Type*} [definable_psh S X] [definable_psh S Y] [definable_psh S Z] : definable S (@function.curry X Y Z) :=
begin
  unfold function.curry,
  begin [defin]
    intro f,
    intro x,
    intro y,
    app, { var },
    exact ⟨x.definable, y.definable⟩
    /-
    app,
    app,
    exact definable_const definable_prod_mk,
    var,
    var, -/
  end
end

#exit

-- stuff after this uses pi type instances, which we don't need yet

variables {Y : Type*} [definable_psh S Y] (y : Y)

--set_option trace.class_instances true
example : definable S (λ (X : set Y) (h : nonempty X), true) :=
begin
  defin_start, rw ←definable_yoneda, -- TODO: combine these

  -- "intro X",
  rw definable_fun', intros Γ' π p,
  -- now we need to pull back any variables mentioning Γ
  -- to use Γ' -- there aren't any yet ✓
  -- since that's done, we can dispose of the old context
  clear π Γ,
  rename Γ' → Γ,

  -- "intro x",
  rw definable_fun', intros Γ' π, -- don't intro q just yet
  -- this time we need to deal with p
  have : ∀ d, p.to_fun (π.to_fun d) = (p.precomp π).to_fun d := λ d, rfl,
  simp only [this],
  generalize H : (p.precomp π) = p', clear this H p, rename p' → p,
  -- okay, now it's safe to intro q
  intro q,
  -- dispose of old context again
  clear π Γ,
  rename Γ' → Γ,

  -- we're done with intros!
end

end o_minimal


import tactic
import category_theory.functor
import data.W.basic
import category_theory.closed.types
import algebra.category.CommRing.basic
import algebra.category.Module.basic

universes w x u v

open category_theory

variables (𝒞 : Type u) [category.{v} 𝒞]

@[protect_proj] structure struc : Type (max u v (w+1) (x+1)) :=
( F : 𝒞 → Type w )
( hom : Π (A B : sigma F) (f : A.1 ⟶ B.1), Type x )
( id : Π (A : sigma F), Σ f : A.1 ⟶ A.1, hom A A f )
( id_fst' : Π (A : sigma F), (id A).fst = 𝟙 A.1 )
( comp : Π {A B C : sigma F}
    (f : Σ f : A.1 ⟶ B.1, hom A B f)
    (g : Σ g : B.1 ⟶ C.1, hom B C g),
    Σ h : A.1 ⟶ C.1, hom A C h )
( comp_fst' : Π {A B C : sigma F}
    (f : Σ f : A.1 ⟶ B.1, hom A B f)
    (g : Σ g : B.1 ⟶ C.1, hom B C g),
    (comp f g).fst = f.1 ≫ g.1)
( id_comp' : Π {A B : sigma F} (f : Σ f : A.1 ⟶ B.1, hom A B f),
    comp (id A) f = f )
( comp_id' : Π {A B : sigma F} (f : Σ f : A.1 ⟶ B.1, hom A B f),
    comp f (id B) = f )
( assoc' : Π {A B C D : sigma F}
    (f : Σ f : A.1 ⟶ B.1, hom A B f)
    (g : Σ g : B.1 ⟶ C.1, hom B C g)
    (h : Σ h : C.1 ⟶ D.1, hom C D h),
    comp (comp f g) h = comp f (comp g h) )

namespace struc

instance : has_coe_to_fun (struc 𝒞) (λ _, 𝒞 → Type w) :=
{ coe := struc.F }

variables {𝒞} {F : struc 𝒞}

@[simp] lemma id_comp {A B : sigma F} (f : Σ (f : A.fst ⟶ B.fst), F.hom A B f) :
  F.comp (F.id A) f = f := F.id_comp' _

@[simp] lemma comp_id {A B : sigma F} (f : Σ (f : A.fst ⟶ B.fst), F.hom A B f) :
  F.comp f (F.id B) = f := F.comp_id' _

@[simp] lemma assoc {A B C D : sigma F}
  (f : Σ f : A.1 ⟶ B.1, F.hom A B f)
  (g : Σ g : B.1 ⟶ C.1, F.hom B C g)
  (h : Σ h : C.1 ⟶ D.1, F.hom C D h):
  F.comp (F.comp f g) h = F.comp f (F.comp g h) :=
F.assoc' _ _ _

@[simp] lemma id_fst₁ (A : sigma F) : (F.id A).fst = 𝟙 A.1 := F.id_fst' _

@[simp] lemma comp_fst₁ {A B C : sigma F}
  (f : Σ f : A.1 ⟶ B.1, F.hom A B f)
  (g : Σ g : B.1 ⟶ C.1, F.hom B C g) :
  (F.comp f g).fst = f.1 ≫ g.1 := F.comp_fst' _ _

instance : category_struct (sigma F) :=
{ hom := λ A B, Σ (f : A.1 ⟶ B.1), F.hom A B f,
  id := F.id,
  comp := F.comp }

variable {F}

def sigma_category : category (sigma F) :=
{ id_comp' := F.id_comp',
  comp_id' := F.comp_id',
  assoc' := F.assoc' }

@[simp] lemma comp_fst {A B C : sigma F} (f : A ⟶ B) (g : B ⟶ C) :
  (f ≫ g).fst = f.1 ≫ g.1 := struc.comp_fst₁ f g

@[simp] lemma id_fst {A : sigma F} : sigma.fst (𝟙 A) = 𝟙 A.1 := struc.id_fst₁ _

instance (X : 𝒞) : category_struct (F X) :=
{ hom := λ A B, F.hom ⟨X, A⟩ ⟨X, B⟩ (𝟙 X),
  id := λ A, (F.id ⟨X, A⟩).snd,
  comp := λ A B C f g, begin
    have := (F.comp ⟨(F.id ⟨X, B⟩).fst, f⟩ _).snd,
  end }

lemma id_def {X : 𝒞} (x : F X) : 𝟙 x = F.id x := rfl

lemma comp_def (X : 𝒞) (A B C : F X) (f : A ⟶ B) (g : B ⟶ C) :
  f ≫ g = F.hom_iso (𝟙 X ≫ 𝟙 X) A C (𝟙 X) A C (iso.refl X) (iso.refl X)
    (by simp) (by simp) (by simp) (F.comp f g) := rfl

instance (X : 𝒞) : category (F X) :=
{ id_comp' := λ A B f, begin
      simp [id_def, comp_def],
      rw [← equiv.trans_apply, F.hom_iso_trans],
      simp
    end,
  comp_id' := λ A B f, begin
      simp [id_def, comp_def],
      rw [← equiv.trans_apply, F.hom_iso_trans],
      simp
    end,
  assoc' := λ A B C D f g h,
      begin
        simp only [comp_def, ← F.hom_iso_comp],
        erw F.hom_iso_comp,
      end }

def forget : sigma₂ F ⥤ 𝒞 :=
{ obj := sigma.fst,
  map := λ _ _, sigma.fst }

def thing (X : 𝒞) : F X ⥤ sigma₂ F :=
{ obj := λ A, ⟨X, A⟩,
  map := λ A B f, ⟨𝟙 X, f⟩,
  map_id' := λ A, rfl,
  map_comp' := λ A B C f g, sigma.ext
    (by simp) begin
      simp only [comp_snd],
      rw [struc.comp_eq_cast F f g (𝟙 X ≫ 𝟙 X) rfl (𝟙 X)
        (category.comp_id _)],
      symmetry,
      rw [← cast_eq_iff_heq],
      simp, refl,
      simp,
    end }

open opposite

protected def op (F : struc 𝒞) : struc 𝒞ᵒᵖ :=
{ F := λ A, F.F (unop A),
  hom := λ A B f a b, F.hom f.unop b a,
  id := λ A a, F.id a,
  comp := λ A B C a b c f g f' g' h hH,
    F.comp g' f' (by simp [← hH]),
  id_comp := λ A B f a b f', F.comp_id _,
  comp_id := λ A B f a b f', F.id_comp _,
  assoc := λ A B C D f g h a b c d f' g' h',
    by rw F.assoc_left; refl }

def unop (F : struc 𝒞ᵒᵖ) : struc 𝒞 :=
{ F := λ A, F.F (op A),
  hom := λ A B f a b, F.hom f.op b a,
  id := λ A a, F.id a,
  comp := λ A B C a b c f g f' g' h hH,
     F.comp g' f' (by simp [← hH]),
  id_comp := λ A B f a b f', F.comp_id _,
  comp_id := λ A B f a b f', F.id_comp _,
  assoc := λ A B C D f g h a b c d f' g' h',
    by rw F.assoc_left; refl }

def of_functor (F : 𝒞 ⥤ Type w) : struc 𝒞 :=
{ F := F.obj,
  hom := λ A B f a b, plift (F.map f a = b),
  id := λ A a, ⟨by simp⟩,
  comp := λ A B C a b c f g h₁ h₂ _ h, ⟨by simp [← h, F.map_comp, h₁.down, h₂.down]⟩,
  assoc := λ _ _ _ _ _ _ _ _ _ _ _ h₁ h₂ h₃,
    begin simp [h₁.down, h₂.down, h₃.down] end,
  id_comp := λ _ _ _ _ _ h,
    begin simp [h.down] end,
  comp_id := λ _ _ _ _ _ h,
    begin simp [h.down] end }

def Module₂ : struc Ring :=
{ F := λ R, Module R,
  hom := λ R S f M₁ M₂, M₁ →ₛₗ[f] M₂,
  id := λ R M, linear_map.id,
  comp := λ R S T M₁ M₂ M₃ f g f' g' _ h,
    @linear_map.comp _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ _ ⟨h⟩ g' f',
  id_comp := λ R S f M₁ M₂ f', begin
      cases f', cases f, refl
    end,
  comp_id := λ R S f M₁ M₂ f', begin
      cases f', cases f, refl,
    end,
  assoc := λ R S T U f g h M₁ M₂ M₃ M₄ f' g' h',
    begin
      cases f, cases g, cases h, cases f', cases g', cases h',
      refl
    end }

def pi.struc (F : 𝒞 ⥤ Type) (G : struc (sigma₂ (of_functor F))) : struc 𝒞 :=
{ F := λ X, Π a : F.obj X, G.F ⟨X, a⟩,
  hom := λ X Y f x y, Π (a : F.obj X),
    @struc.hom _ _ G ⟨X, a⟩ ⟨Y, F.map f a⟩ ⟨f, ⟨rfl⟩⟩ (x a) (y (F.map f a)),
  id := λ X x a, by convert (G.id (x a)); simp,
  comp := λ X Y Z x y z f g f' g' h H a,
    by convert struc.comp G (f' a) (g' (F.map f a)) rfl; subst H; simp,
  id_comp := λ X a, begin
    intros,
    ext,
    simp,

  end }

-- Maybe think about W.

end struc


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Mario Carneiro
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.PostPort

universes u u_1 u_2

namespace Mathlib

/-!
# A type for VM-erased data

This file defines a type `erased α` which is classically isomorphic to `α`,
but erased in the VM. That is, at runtime every value of `erased α` is
represented as `0`, just like types and proofs.
-/

/-- `erased α` is the same as `α`, except that the elements
  of `erased α` are erased in the VM in the same way as types
  and proofs. This can be used to track data without storing it
  literally. -/
def erased (α : Sort u) := psigma fun (s : α → Prop) => ∃ (a : α), (fun (b : α) => a = b) = s

namespace erased

/-- Erase a value. -/
def mk {α : Sort u_1} (a : α) : erased α := psigma.mk (fun (b : α) => a = b) sorry

/-- Extracts the erased value, noncomputably. -/
def out {α : Sort u_1} : erased α → α := sorry

/--
Extracts the erased value, if it is a type.

Note: `(mk a).out_type` is not definitionally equal to `a`.
-/
def out_type (a : erased (Sort u)) := out a

/-- Extracts the erased value, if it is a proof. -/
theorem out_proof {p : Prop} (a : erased p) : p := out a

@[simp] theorem out_mk {α : Sort u_1} (a : α) : out (mk a) = a :=
  let h : ∃ (x : α), (fun (b : α) => x = b) = fun (b : α) => a = b := mk._proof_1 a;
  id (cast (Eq.symm (congr_fun (classical.some_spec h) a)) rfl)

@[simp] theorem mk_out {α : Sort u_1} (a : erased α) : mk (out a) = a := sorry

theorem out_inj {α : Sort u_1} (a : erased α) (b : erased α) (h : out a = out b) : a = b := sorry

/-- Equivalence between `erased α` and `α`. -/
def equiv (α : Sort u_1) : erased α ≃ α := equiv.mk out mk mk_out out_mk

protected instance has_repr (α : Type u) : has_repr (erased α) :=
  has_repr.mk
    fun (_x : erased α) =>
      string.str
        (string.str
          (string.str
            (string.str
              (string.str
                (string.str string.empty (char.of_nat (bit1 (bit0 (bit1 (bit0 (bit0 (bit1 1))))))))
                (char.of_nat (bit0 (bit1 (bit0 (bit0 (bit1 (bit1 1))))))))
              (char.of_nat (bit1 (bit0 (bit0 (bit0 (bit0 (bit1 1))))))))
            (char.of_nat (bit1 (bit1 (bit0 (bit0 (bit1 (bit1 1))))))))
          (char.of_nat (bit1 (bit0 (bit1 (bit0 (bit0 (bit1 1))))))))
        (char.of_nat (bit0 (bit0 (bit1 (bit0 (bit0 (bit1 1)))))))

protected instance has_to_string (α : Type u) : has_to_string (erased α) :=
  has_to_string.mk
    fun (_x : erased α) =>
      string.str
        (string.str
          (string.str
            (string.str
              (string.str
                (string.str string.empty (char.of_nat (bit1 (bit0 (bit1 (bit0 (bit0 (bit1 1))))))))
                (char.of_nat (bit0 (bit1 (bit0 (bit0 (bit1 (bit1 1))))))))
              (char.of_nat (bit1 (bit0 (bit0 (bit0 (bit0 (bit1 1))))))))
            (char.of_nat (bit1 (bit1 (bit0 (bit0 (bit1 (bit1 1))))))))
          (char.of_nat (bit1 (bit0 (bit1 (bit0 (bit0 (bit1 1))))))))
        (char.of_nat (bit0 (bit0 (bit1 (bit0 (bit0 (bit1 1)))))))

/-- Computably produce an erased value from a proof of nonemptiness. -/
def choice {α : Sort u_1} (h : Nonempty α) : erased α := mk (Classical.choice h)

@[simp] theorem nonempty_iff {α : Sort u_1} : Nonempty (erased α) ↔ Nonempty α := sorry

protected instance inhabited {α : Sort u_1} [h : Nonempty α] : Inhabited (erased α) :=
  { default := choice h }

/--
`(>>=)` operation on `erased`.

This is a separate definition because `α` and `β` can live in different
universes (the universe is fixed in `monad`).
-/
def bind {α : Sort u_1} {β : Sort u_2} (a : erased α) (f : α → erased β) : erased β :=
  psigma.mk (fun (b : β) => psigma.fst (f (out a)) b) sorry

@[simp] theorem bind_eq_out {α : Sort u_1} {β : Sort u_2} (a : erased α) (f : α → erased β) :
    bind a f = f (out a) :=
  sorry

/--
Collapses two levels of erasure.
-/
def join {α : Sort u_1} (a : erased (erased α)) : erased α := bind a id

@[simp] theorem join_eq_out {α : Sort u_1} (a : erased (erased α)) : join a = out a :=
  bind_eq_out a id

/--
`(<$>)` operation on `erased`.

This is a separate definition because `α` and `β` can live in different
universes (the universe is fixed in `functor`).
-/
def map {α : Sort u_1} {β : Sort u_2} (f : α → β) (a : erased α) : erased β := bind a (mk ∘ f)

@[simp] theorem map_out {α : Sort u_1} {β : Sort u_2} {f : α → β} (a : erased α) :
    out (map f a) = f (out a) :=
  sorry

protected instance monad : Monad erased :=
  { toApplicative :=
      { toFunctor := { map := map, mapConst := fun (α β : Type u_1) => map ∘ function.const β },
        toPure := { pure := mk },
        toSeq :=
          { seq :=
              fun (α β : Type u_1) (f : erased (α → β)) (x : erased α) =>
                bind f fun (_x : α → β) => map _x x },
        toSeqLeft :=
          { seqLeft :=
              fun (α β : Type u_1) (a : erased α) (b : erased β) =>
                (fun (α β : Type u_1) (f : erased (α → β)) (x : erased α) =>
                    bind f fun (_x : α → β) => map _x x)
                  β α (map (function.const β) a) b },
        toSeqRight :=
          { seqRight :=
              fun (α β : Type u_1) (a : erased α) (b : erased β) =>
                (fun (α β : Type u_1) (f : erased (α → β)) (x : erased α) =>
                    bind f fun (_x : α → β) => map _x x)
                  β β (map (function.const α id) a) b } },
    toBind := { bind := bind } }

@[simp] theorem pure_def {α : Type u_1} : pure = mk := rfl

@[simp] theorem bind_def {α : Type u_1} {β : Type u_1} : bind = bind := rfl

@[simp] theorem map_def {α : Type u_1} {β : Type u_1} : Functor.map = map := rfl

protected instance is_lawful_monad : is_lawful_monad erased := sorry

end Mathlib


import Smt

theorem length : "a".length = 1 := by
  smt
  rfl


import Architectural.ArchWithContracts

variables {Φ Var : Type} [fintype Var] [decidable_eq Var] [AssertionLang Φ Var]

def isCorrectDecompositionImpl
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is : Implementations A.to_Architecture)
  : Prop :=
(∀ (S' : Component Var) (h : S' ∈ A.subs), (Is S' h).satisfiesContract (A.contracts.find_val S').iget)
   → (@CompositeImplementation Var _ _ _ _ S {..A} Is).satisfiesContract A.parent

def isCorrectDecompositionEnv
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is : Implementations A.to_Architecture)
(E : Env Var) : Prop :=
∀ (S'' : Component Var) (h'': S'' ∈ A.subs) ,
(E.satisfiesContract A.parent ∧
(∀ (S' : Component Var) {S' ∈ A.subs.erase S''}, (Is S' (list.mem_of_mem_erase H)).satisfiesContract (A.contracts.find_val S').iget) →
(CompositeEnvironment A.to_Architecture S'' Is E).satisfiesContract (A.contracts.find_val S'').iget)

def isCorrectDecomposition
{S : Component Var}
(A : ArchitectureWithContracts Φ S)
(Is : Implementations A.to_Architecture)
(E : Env Var) :=
isCorrectDecompositionImpl A Is ∧
isCorrectDecompositionEnv A Is E

namespace Claim

def correctDecompositionImpl
{S : Component Var}
(A : ArchitectureWithContracts Φ S)
(Is :Implementations A.to_Architecture)
(σ : Trace Var) : Prop :=
(∀ (S' : Component Var) {S' ∈ A.subs}, ∀ σ',(σ' ∈ (Is S' H) ∧
(σ' ∈ (@AssertionLang.sem Φ Var _ _ _ (A.contracts.find_val S').iget.A))) →
(σ' ∈ (@AssertionLang.sem Φ Var _ _ _ (A.contracts.find_val S').iget.G))) → ( (σ ∈ (@CompositeImplementation Var _ _ _ _ S ↑A Is) ∧ (σ ∈ (@AssertionLang.sem Φ Var _ _ _ A.parent.A))) → (σ ∈ (@AssertionLang.sem Φ Var _ _ _ A.parent.G)))

-- example {C : Contract Φ Var} {σ : Trace Var}  :
-- (σ ∈ (@AssertionLang.sem Φ Var _ _ _ C.A)) → (σ ∈ (@AssertionLang.sem Φ Var _ _ _ C.G))
-- ↔ (σ ∈ (@AssertionLang.sem Φ Var _ _ _ C.nf)) :=
-- begin
--   split,
--   intro H,
--   rw AssertionLang.disj_def,
--   rw AssertionLang.compl_def,
--   simp,
--   rw ← imp_iff_not_or, exact H,
--    intro H,
--   rw AssertionLang.disj_def at H,
--   rw AssertionLang.compl_def at H,
--   simp at H,
--   rw ← imp_iff_not_or at H, exact H,
-- end

def correctDecompositionImpl'
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is :Implementations A.to_Architecture)
(σ : Trace Var) : Prop :=
(∀ (S' : Component Var) {S' ∈ A.subs}, ∀ σ',(σ' ∈ (Is S' H) ∧
(σ' ∈ (@AssertionLang.sem Φ Var _ _ _ (A.contracts.find_val S').iget.A))) →
(σ' ∈ (@AssertionLang.sem Φ Var _ _ _ (A.contracts.find_val S').iget.G))) →
( (σ ∈ (@CompositeImplementation Var _ _ _ _ S ↑A Is) ∧ (σ ∈ (@AssertionLang.sem Φ Var _ _ _ A.parent.A))) → (σ ∈ (@AssertionLang.sem Φ Var _ _ _ A.parent.G)))

def correctDecompositionEnv
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is :Implementations A.to_Architecture)
(E : Env Var) (σ : Trace Var) : Prop :=
∀ (S'' : Component Var) {S'' ∈ A.subs},
E.satisfiesContract A.parent →
(∀ (S' : Component Var) {S' ∈ A.subs.erase S''}, (Is S' (list.mem_of_mem_erase H)).satisfiesContract (A.contracts.find_val S').iget) →
(σ ∈ (CompositeEnvironment A.to_Architecture S'' Is E)) → σ ∈ (@AssertionLang.sem Φ Var _ _ _ ((A.contracts.find_val S'').iget).A)

def correctDecomposition
{S : Component Var}
(A : ArchitectureWithContracts Φ S)
(Is : Implementations A.to_Architecture)
(E : Env Var) : Claim (Trace Var) :=
{
  X := set.univ,
  P :=
  λ σ, correctDecompositionImpl A Is σ ∧ correctDecompositionEnv A Is E σ
}

end Claim
-- def correctDecompositionImplProperty
-- (A : ArchWithContracts S)
-- (Is : Implementations A)  : Property (Trace Var) := λ σ,
-- (∀ (S' : Component Var) {S' ∈ A.subs},
--     (∀ σ', σ' ∈ (Is S' H) ∧ σ' ∈ $\llparenthesis$(A.contracts.get S').A$\rrparenthesis$
--   → (σ' ∈ $\llparenthesis$(A.contracts.get S').G$\rrparenthesis$))
-- → ((σ ∈ CompositeImplementation A Is ∧ σ ∈ $\llparenthesis$S.C.A$\rrparenthesis$)
-- → σ ∈ $\llparenthesis$S.C.G$\rrparenthesis$)

-- def correctDecompositionEnvProperty
-- {S : ComponentWithContract Φ Var}
-- (A : ArchWithContracts S)
-- (Is :Implementations A)
-- (E : Env Var)  : Property (Trace Var) :=λ σ,
-- ∀ (S'' : Component Var),
--   E.satisfiesContract S.C →
--   (∀ (S' : Component Var) {S' ∈ A.subs},
--   (Is S' H).satisfies (A.contracts.get S')) →
--  (σ ∈ CompositeEnvironment A S'' Is E) →
--  σ ∈ {{((A.contracts.get S'')).A}}
theorem
claim_imp_correctDecomp
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is : Implementations A.to_Architecture)
(E : Env Var) :
⟦Claim.correctDecomposition A Is E⟧ → isCorrectDecomposition A Is E :=
begin
  intro clm,
  rw meaning at clm, split, {
    intro h,
    intro s,
    replace clm := clm s,
    rw [Claim.correctDecomposition] at clm,
    simp at clm, replace clm := clm.1,
    intro h',
    cases h' with h₂ h₃,
    rw Claim.correctDecompositionImpl at clm,
    apply clm,
    intros S' S'' hMem,
    replace h := h S'',
    rw Impl.satisfiesContract at h,
    rw CompositeImplementation at h₂, simp at h₂,
    intro h'', apply h,split, exact h₂,
    exact h₃,
  },
  {
    rintros S'' h₄ ⟨h₅, h₆⟩ s,
    replace clm := clm s, rw [Claim.correctDecomposition] at clm,
    simp at clm, replace clm := clm.2 S'' h₅ h₆, exact clm,
    rw Claim.correctDecompositionEnv at clm, assumption,
}
end

theorem decompCorrectImpClaim
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is : Implementations A.to_Architecture)
(E : Env Var) :
isCorrectDecomposition A Is E →
⟦Claim.correctDecomposition A Is  E⟧ :=
begin
  intro h,
  rw Claim.correctDecomposition, rw meaning, simp,
  rw forall_and_distrib,
  split,
  {
    intro s,
    rw Claim.correctDecompositionImpl,
    revert s,simp,
    replace h := h.1,
    rw isCorrectDecompositionImpl at h,
    intros σ' h₂ h₃,
    rw CompositeImplementation at h₃,
    intros h₄,
    rw Impl.satisfiesContract at h,
    simp at h,
    apply h,
    intros S' h',
    replace h₂ := h₂ S' h',
    intros σ h₅, cases h₅ with L R,
    replace h₂ := h₂ σ L R, simp,
    apply h₂,split, rw CompositeImplementation, apply h₃, assumption,
  },
  {
    intros σ, intros _, intros S'' mem,
    replace h := h.2,
    rw isCorrectDecompositionEnv at h,
    simp at h,
    replace h := h S'' mem,
    intros s smem, rw Env.satisfiesContract at h,
    simp at h,
    apply h,
    intros h₂, apply s, exact smem,
  }

end

theorem decompositionCorrectAsClaim
{S : Component Var}
(A : ArchitectureWithContracts Φ  S)
(Is : Implementations A.to_Architecture)
(E : Env Var) :
isCorrectDecomposition A Is E ↔ ⟦Claim.correctDecomposition A Is E⟧ :=
iff.intro (decompCorrectImpClaim A Is  E) (claim_imp_correctDecomp A Is  E)


import LMT

variable {I} [Nonempty I] {E} [Nonempty E] [Nonempty (A I E)]

example {a1 a2 a3 : A I E} :
        ((a2).write i3 (v1)) ≠ (a2) → ((a1).write i3 (v1)) = (a2) → False := by
  arr


/-
Copyright (c) 2021 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Transform
import Lean.Meta.Tactic.Injection
import Lean.Meta.Tactic.Apply
import Lean.Meta.Tactic.Cases
import Lean.Meta.Tactic.Subst
import Lean.Meta.Tactic.Simp.Types
import Lean.Meta.Tactic.Assumption

namespace Lean.Meta

private def mkAnd? (args : Array Expr) : Option Expr := Id.run <| do
  if args.isEmpty then
    return none
  else
    let mut result := args.back
    for arg in args.reverse[1:] do
      result := mkApp2 (mkConst ``And) arg result
    return result

def elimOptParam (type : Expr) : CoreM Expr := do
  Core.transform type fun e =>
    if e.isAppOfArity  ``optParam 2 then
      return TransformStep.visit (e.getArg! 0)
    else
      return TransformStep.visit e

private partial def mkInjectiveTheoremTypeCore? (ctorVal : ConstructorVal) (useEq : Bool) : MetaM (Option Expr) := do
  let us := ctorVal.levelParams.map mkLevelParam
  let type ← elimOptParam ctorVal.type
  forallBoundedTelescope type ctorVal.numParams fun params type =>
  forallTelescope type fun args1 resultType => do
    let jp (args2 args2New : Array Expr) : MetaM (Option Expr) := do
      let lhs := mkAppN (mkAppN (mkConst ctorVal.name us) params) args1
      let rhs := mkAppN (mkAppN (mkConst ctorVal.name us) params) args2
      let eq ← mkEq lhs rhs
      let mut eqs := #[]
      for arg1 in args1, arg2 in args2 do
        let arg1Type ← inferType arg1
        if !(← isProp arg1Type) && arg1 != arg2 then
          if (← isDefEq arg1Type (← inferType arg2)) then
            eqs := eqs.push (← mkEq arg1 arg2)
          else
            eqs := eqs.push (← mkHEq arg1 arg2)
      if let some andEqs := mkAnd? eqs then
        let result ←
          if useEq then
            mkEq eq andEqs
          else
            mkArrow eq andEqs
        mkForallFVars params (← mkForallFVars args1 (← mkForallFVars args2New result))
      else
        return none
    let rec mkArgs2 (i : Nat) (type : Expr) (args2 args2New : Array Expr) : MetaM (Option Expr) := do
      if h : i < args1.size then
        match (← whnf type) with
        | Expr.forallE n d b _ =>
          let arg1 := args1.get ⟨i, h⟩
          if arg1.occurs resultType then
            mkArgs2 (i + 1) (b.instantiate1 arg1) (args2.push arg1) args2New
          else
            withLocalDecl n (if useEq then BinderInfo.default else BinderInfo.implicit) d fun arg2 =>
              mkArgs2 (i + 1) (b.instantiate1 arg2) (args2.push arg2) (args2New.push arg2)
        | _ => throwError "unexpected constructor type for '{ctorVal.name}'"
      else
        jp args2 args2New
    if useEq then
      mkArgs2 0 type #[] #[]
    else
      withNewBinderInfos (params.map fun param => (param.fvarId!, BinderInfo.implicit)) <|
      withNewBinderInfos (args1.map fun arg1 => (arg1.fvarId!, BinderInfo.implicit)) <|
        mkArgs2 0 type #[] #[]

private def mkInjectiveTheoremType? (ctorVal : ConstructorVal) : MetaM (Option Expr) :=
  mkInjectiveTheoremTypeCore? ctorVal false

private def injTheoremFailureHeader (ctorName : Name) : MessageData :=
  m!"failed to prove injectivity theorem for constructor '{ctorName}', use 'set_option genInjectivity false' to disable the generation"

private def throwInjectiveTheoremFailure {α} (ctorName : Name) (mvarId : MVarId) : MetaM α :=
  throwError "{injTheoremFailureHeader ctorName}{indentD <| MessageData.ofGoal mvarId}"

private def solveEqOfCtorEq (ctorName : Name) (mvarId : MVarId) (h : FVarId) : MetaM Unit := do
  match (← injection mvarId h) with
  | InjectionResult.solved => unreachable!
  | InjectionResult.subgoal mvarId .. =>
    (← splitAnd mvarId).forM fun mvarId =>
      unless (← assumptionCore mvarId) do
        throwInjectiveTheoremFailure ctorName mvarId

private def mkInjectiveTheoremValue (ctorName : Name) (targetType : Expr) : MetaM Expr :=
  forallTelescopeReducing targetType fun xs type => do
    let mvar ← mkFreshExprSyntheticOpaqueMVar type
    solveEqOfCtorEq ctorName mvar.mvarId! xs.back.fvarId!
    mkLambdaFVars xs mvar

def mkInjectiveTheoremNameFor (ctorName : Name) : Name :=
  ctorName ++ `inj

private def mkInjectiveTheorem (ctorVal : ConstructorVal) : MetaM Unit := do
  let some type ← mkInjectiveTheoremType? ctorVal
    | return ()
  let value ← mkInjectiveTheoremValue ctorVal.name type
  addDecl <| Declaration.thmDecl {
    name        := mkInjectiveTheoremNameFor ctorVal.name
    levelParams := ctorVal.levelParams
    type        := (← instantiateMVars type)
    value       := (← instantiateMVars value)
  }

def mkInjectiveEqTheoremNameFor (ctorName : Name) : Name :=
  ctorName ++ `injEq

private def mkInjectiveEqTheoremType? (ctorVal : ConstructorVal) : MetaM (Option Expr) :=
  mkInjectiveTheoremTypeCore? ctorVal true

private def mkInjectiveEqTheoremValue (ctorName : Name) (targetType : Expr) : MetaM Expr := do
  forallTelescopeReducing targetType fun xs type => do
    let mvar ← mkFreshExprSyntheticOpaqueMVar type
    let [mvarId₁, mvarId₂] ← apply mvar.mvarId! (mkConst ``Eq.propIntro)
      | throwError "unexpected number of subgoals when proving injective theorem for constructor '{ctorName}'"
    let (h, mvarId₁) ← intro1 mvarId₁
    let (_, mvarId₂) ← intro1 mvarId₂
    solveEqOfCtorEq ctorName mvarId₁ h
    let mvarId₂ ← casesAnd mvarId₂
    let mvarId₂ ← substEqs mvarId₂
    applyRefl mvarId₂ (injTheoremFailureHeader ctorName)
    mkLambdaFVars xs mvar

private def mkInjectiveEqTheorem (ctorVal : ConstructorVal) : MetaM Unit := do
  let some type ← mkInjectiveEqTheoremType? ctorVal
    | return ()
  let value ← mkInjectiveEqTheoremValue ctorVal.name type
  let name := mkInjectiveEqTheoremNameFor ctorVal.name
  addDecl <| Declaration.thmDecl {
    name
    levelParams := ctorVal.levelParams
    type        := (← instantiateMVars type)
    value       := (← instantiateMVars value)
  }
  addSimpTheorem (ext := simpExtension) name (post := true) (inv := false) AttributeKind.global (prio := eval_prio default)

register_builtin_option genInjectivity : Bool := {
  defValue := true
  descr    := "generate injectivity theorems for inductive datatype constructors"
}

def mkInjectiveTheorems (declName : Name) : MetaM Unit := do
  if (← getEnv).contains ``Eq.propIntro && genInjectivity.get (← getOptions) &&  !(← isInductivePredicate declName) then
    let info ← getConstInfoInduct declName
    unless info.isUnsafe do
      for ctor in info.ctors do
        let ctorVal ← getConstInfoCtor ctor
        if ctorVal.numFields > 0 then
          mkInjectiveTheorem ctorVal
          mkInjectiveEqTheorem ctorVal

end Lean.Meta


import system.io
import tactic
import data.nat.basic
import algebra.char_p
import ring_theory.power_series.basic
import combinatorics.partition
import data.nat.parity
import data.finset.nat_antidiagonal
import tactic.interval_cases
import tactic.apply_fun

open finset
open_locale big_operators
open_locale classical

open lean
def test1 := "theorem group_with_all_squares_equal_to_one_is_abelian (G : Type*)
   [group G] (hG : ∀ x : G, x^2 = 1) :
   ∀ x y : G, x * y = y * x := sorry"

def test2 := "theorem binomial_theorem_char_p (F : Type*) [field F] (p : ℕ) (hp : char_p F p)
  (a b : F) : (a + b)^p = ∑ i in finset.range p, (p choose i) * a^i * b^(p - i) := sorry"

-- theorem binomial_theorem_char_p (F : Type*) [field F] (p : ℕ) (hp : char_p F p)
--   (a b : F) : (a + b)^p = ∑ i in finset.range p, (p choose i) * a^i * b^(p - i) := sorry

meta structure decl_parse_result : Type :=
  (name : name)
  (binders : list expr)
  (type : expr)

open lean.parser

meta def binder.to_pi : binder → expr → expr
| b body := expr.pi b.name b.info b.type body

meta def mk_type_mvar : tactic expr :=
do u ← tactic.mk_meta_univ,
   t ← tactic.mk_meta_var (expr.sort u),
   return t

meta def expr.local_binder_info : pexpr → binder_info
  | (expr.local_const _ _ bi _) := bi
  | _ := inhabited.default

meta def pexpr.local_uniq_name : pexpr → name
  | (expr.local_const un _ _ _) := un
  | _ := inhabited.default

meta def pi_intro (b : binder) : tactic expr := do
  (main :: rest) ← tactic.get_goals,
  u ← tactic.mk_meta_univ,
  (new_goal, fvar) ← tactic.unsafe.type_context.run (do
    fvar ← tactic.unsafe.type_context.push_local b.name b.type b.info,
    new_goal ← tactic.unsafe.type_context.mk_mvar `T (expr.sort u),
    let assignment := binder.to_pi b $ expr.mk_delayed_abstraction new_goal [fvar.local_uniq_name],
    tactic.unsafe.type_context.assign main assignment,
    return (new_goal, fvar)
  ),
  tactic.set_goals (new_goal :: rest),
  return fvar

meta def add_binders : list pexpr → parser unit
  | [] := pure ()
  | ((expr.local_const un pn bi t) :: tail) := do
    parser.add_local (expr.local_const un pn bi (inhabited.default)),
    add_binders tail
  | _ := pure ()

meta def parse_decl : parser decl_parse_result := do
  (tk "theorem" <|> tk "def"),
  name ← ident,
  binders ← interactive.parse_binders,
  add_binders binders,
  tk ":",
  smt ← parser.pexpr 0,
  tk ":=",
  (T,fvars) ← parser.of_tactic (do
   T ← mk_type_mvar,
   tactic.set_goals [T],
   fvars : list expr ← binders.mmap (λ b, do
         t ← pure $ b.local_type,
         type ← tactic.i_to_expr ``(%%t : Sort*),
         let b : binder := ⟨b.local_pp_name, b.local_binder_info, type⟩,
         fvar ← pi_intro b,
         pure fvar
   ),
   smt ← tactic.i_to_expr ``(%%smt : Sort*),
   tactic.exact smt,
   T ← tactic.instantiate_mvars T,
   return (T, fvars)
  ),
  _ ← fvars.mmap parser.add_local,
  return {
     name := name,
     binders := fvars,
     type := T,
  }

-- set_option pp.all true

-- run_cmd do {
--    d1 ← parser.run_with_input parse_decl test1,
--    tactic.trace d1.name,
--    tactic.trace d1.type,
--    -- this step errors
--    d2 ← parser.run_with_input parse_decl test2,
--    tactic.trace d2.name,
--    tactic.trace d2.type
-- }


import for_mathlib.category_theory.localization.predicate

noncomputable theory

open category_theory category_theory.category

namespace category_theory

namespace morphism_property

namespace is_inverted_by

/-
lemma op {C D : Type*} [category C] [category D]
  {W : morphism_property C} {L : C ⥤ D} (h : W.is_inverted_by L) :
  W.op.is_inverted_by L.op := λ X Y f hf,
by { haveI := h f.unop hf, dsimp, apply_instance, }

lemma right_op {C D : Type*} [category C] [category D]
  {W : morphism_property C} {L : Cᵒᵖ ⥤ D} (h : W.op.is_inverted_by L):
  W.is_inverted_by L.right_op := λ X Y f hf,
by { haveI := h f.op hf, dsimp, apply_instance, }-/

end is_inverted_by

end morphism_property

variables {C D : Type*} [category C] [category D] {L : C ⥤ D}
  {W : morphism_property C}

namespace localization

def strict_universal_property_fixed_target.op {E : Type*} [category E]
  (h : strict_universal_property_fixed_target L W Eᵒᵖ):
  strict_universal_property_fixed_target L.op W.op E :=
{ inverts := h.inverts.op,
  lift := λ F hF, (h.lift F.right_op hF.right_op).left_op,
  fac := λ F hF, begin
    convert congr_arg functor.left_op (h.fac F.right_op hF.right_op),
    exact F.right_op_left_op_eq.symm,
  end,
  uniq := λ F₁ F₂ eq, begin
    suffices : F₁.right_op = F₂.right_op,
    { rw [← F₁.right_op_left_op_eq, ← F₂.right_op_left_op_eq, this], },
    have eq' := congr_arg functor.right_op eq,
    exact h.uniq _ _ eq',
  end, }

instance is_localization_op : W.Q.op.is_localization W.op :=
functor.is_localization.mk' W.Q.op W.op
  (strict_universal_property_fixed_target_Q W _).op
  (strict_universal_property_fixed_target_Q W _).op

end localization

namespace functor

variables (L W)

instance is_localization.op [h : L.is_localization W] : L.op.is_localization W.op :=
is_localization.of_equivalence_target W.Q.op W.op L.op (localization.equivalence_from_model L W).op
  (nat_iso.op (localization.Q_comp_equivalence_from_model_functor_iso L W).symm)

end functor

end category_theory


/-
File: signature_recover_public_key_validate_reduced_field_element_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_nn_le_soundness
open tactic

open starkware.cairo.common.cairo_secp.field
open starkware.cairo.common.cairo_secp.bigint
open starkware.cairo.common.math
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.field.validate_reduced_field_element autogenerated soundness theorem -/

theorem auto_sound_validate_reduced_field_element
    -- arguments
    (range_check_ptr : F) (val : BigInt3 F)
    -- code is in memory at σ.pc
    (h_mem : mem_at mem code_validate_reduced_field_element σ.pc)
    -- all dependencies are in memory
    (h_mem_0 : mem_at mem code_assert_nn (σ.pc  - 152))
    (h_mem_1 : mem_at mem code_assert_le (σ.pc  - 148))
    (h_mem_2 : mem_at mem code_assert_nn_le (σ.pc  - 143))
    -- input arguments on the stack
    (hin_range_check_ptr : range_check_ptr = mem (σ.fp - 6))
    (hin_val : val = cast_BigInt3 mem (σ.fp - 5))
    -- conclusion
  : ensures_ret mem σ (λ κ τ,
      ∃ μ ≤ κ, rc_ensures mem (rc_bound F) μ (mem (σ.fp - 6)) (mem $ τ.ap - 1)
        (spec_validate_reduced_field_element mem κ range_check_ptr val (mem (τ.ap - 1)))) :=
begin
  apply ensures_of_ensuresb, intro νbound,
  have h_mem_rec := h_mem,
  unpack_memory code_validate_reduced_field_element 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⟩,
  -- function call
  step_assert_eq hpc0 with arg0,
  step_assert_eq hpc1 with arg1,
  step_assert_eq hpc2 hpc3 with arg2,
  step_sub hpc4 (auto_sound_assert_nn_le mem _ range_check_ptr val.d2 P2 _ _ _ _ _ _),
  { rw hpc5, norm_num2, exact h_mem_2 },
  { rw hpc5, norm_num2, exact h_mem_0 },
  { rw hpc5, norm_num2, exact h_mem_1 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1, arg2] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1, arg2] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1, arg2] },
    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 - 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 ,arg2] at hl_range_check_ptr₁ },
  rw [←htv_range_check_ptr₁, ←hin_range_check_ptr] at hl_range_check_ptr₁,
  try { simp only [arg0 ,arg1 ,arg2] at h_call6 },
  rw [hin_range_check_ptr] at h_call6,
  clear arg0 arg1 arg2,
  -- function call
  step_assert_eq hpc6 with arg0,
  step_assert_eq hpc7 hpc8 with arg1,
  step_sub hpc9 (auto_sound_assert_nn_le mem _ range_check_ptr₁ val.d1 (BASE - 1) _ _ _ _ _ _),
  { rw hpc10, norm_num2, exact h_mem_2 },
  { rw hpc10, norm_num2, exact h_mem_0 },
  { rw hpc10, norm_num2, exact h_mem_1 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call6_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_val, htv_range_check_ptr₁] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call6_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_val, htv_range_check_ptr₁] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call6_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call11 ap11 h_call11,
  rcases h_call11 with ⟨h_call11_ap_offset, h_call11⟩,
  rcases h_call11 with ⟨rc_m11, rc_mle11, hl_range_check_ptr₂, h_call11⟩,
  generalize' hr_rev_range_check_ptr₂: mem (ap11 - 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_call11 },
  rw [←htv_range_check_ptr₁, hl_range_check_ptr₁, hin_range_check_ptr] at h_call11,
  clear arg0 arg1,
  -- function call
  step_assert_eq hpc11 with arg0,
  step_assert_eq hpc12 hpc13 with arg1,
  step_sub hpc14 (auto_sound_assert_nn_le mem _ range_check_ptr₂ val.d0 (BASE - 1) _ _ _ _ _ _),
  { rw hpc15, norm_num2, exact h_mem_2 },
  { rw hpc15, norm_num2, exact h_mem_0 },
  { rw hpc15, norm_num2, exact h_mem_1 },
  { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call6_ap_offset, h_call11_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_val, htv_range_check_ptr₁, htv_range_check_ptr₂] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call6_ap_offset, h_call11_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_val, htv_range_check_ptr₁, htv_range_check_ptr₂] },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [arg0, arg1] },
    try { simp only [h_call6_ap_offset, h_call11_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  intros κ_call16 ap16 h_call16,
  rcases h_call16 with ⟨h_call16_ap_offset, h_call16⟩,
  rcases h_call16 with ⟨rc_m16, rc_mle16, hl_range_check_ptr₃, h_call16⟩,
  generalize' hr_rev_range_check_ptr₃: mem (ap16 - 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_call16 },
  rw [←htv_range_check_ptr₂, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr] at h_call16,
  clear arg0 arg1,
  -- if statement
  step_assert_eq hpc16 hpc17 with temp0,
  have htest: _ = val.d2 - P2, {
    apply eq.trans temp0,
    try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
    try { dsimp [cast_BigInt3] },
    try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
  clear temp0,
  step_jnz hpc18 hpc19 with hcond hcond,
  {
    -- if: positive branch
    have a16 := cond_aux1 htest hcond,
    try { arith_simps at a16 },
    clear htest hcond,
    -- if statement
    step_assert_eq hpc20 hpc21 with temp0,
    have htest: _ = val.d1 - P1, {
      apply eq.trans temp0,
      try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
      try { dsimp [cast_BigInt3] },
      try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
    clear temp0,
    step_jnz hpc22 hpc23 with hcond hcond,
    {
      -- if: positive branch
      have a20 := cond_aux1 htest hcond,
      try { arith_simps at a20 },
      clear htest hcond,
      -- function call
      step_assert_eq hpc24 with arg0,
      step_assert_eq hpc25 with arg1,
      step_assert_eq hpc26 hpc27 with arg2,
      step_sub hpc28 (auto_sound_assert_nn_le mem _ range_check_ptr₃ val.d0 (P0 - 1) _ _ _ _ _ _),
      { rw hpc29, norm_num2, exact h_mem_2 },
      { rw hpc29, norm_num2, exact h_mem_0 },
      { rw hpc29, norm_num2, exact h_mem_1 },
      { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2] },
        try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_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_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2] },
        try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_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_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2] },
        try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
      intros κ_call30 ap30 h_call30,
      rcases h_call30 with ⟨h_call30_ap_offset, h_call30⟩,
      rcases h_call30 with ⟨rc_m30, rc_mle30, hl_range_check_ptr₄, h_call30⟩,
      generalize' hr_rev_range_check_ptr₄: mem (ap30 - 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 ,arg2] at hl_range_check_ptr₄ },
      rw [←htv_range_check_ptr₄, ←htv_range_check_ptr₃] at hl_range_check_ptr₄,
      try { simp only [arg0 ,arg1 ,arg2] at h_call30 },
      rw [←htv_range_check_ptr₃, hl_range_check_ptr₃, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr] at h_call30,
      clear arg0 arg1 arg2,
      -- return
      step_ret hpc30,
      -- finish
      step_done, use_only [rfl, rfl],
      -- range check condition
      use_only (rc_m6+rc_m11+rc_m16+rc_m30+0+0), split,
      linarith [rc_mle6, rc_mle11, rc_mle16, rc_mle30],
      split,
      { arith_simps,
        rw [←htv_range_check_ptr₄, hl_range_check_ptr₄, hl_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_validate_reduced_field_element mem _ range_check_ptr val _,
      { apply sound_validate_reduced_field_element, apply auto_spec },
      -- prove the auto generated assertion
      dsimp [auto_spec_validate_reduced_field_element],
      try { norm_num1 }, try { arith_simps },
      use_only [κ_call6],
      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 spec6 := h_call6 rc_h_range_check_ptr',
      rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec6,
      try { dsimp at spec6, arith_simps at spec6 },
      use_only [spec6],
      use_only [κ_call11],
      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 spec11 := h_call11 rc_h_range_check_ptr₁',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec11,
      try { dsimp at spec11, arith_simps at spec11 },
      use_only [spec11],
      use_only [κ_call16],
      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 spec16 := h_call16 rc_h_range_check_ptr₂',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←hl_range_check_ptr₂, ←htv_range_check_ptr₃] at spec16,
      try { dsimp at spec16, arith_simps at spec16 },
      use_only [spec16],
      left,
      use_only [a16],
      left,
      use_only [a20],
      use_only [κ_call30],
      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 spec30 := h_call30 rc_h_range_check_ptr₃',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←hl_range_check_ptr₂, ←hl_range_check_ptr₃, ←htv_range_check_ptr₄] at spec30,
      try { dsimp at spec30, arith_simps at spec30 },
      use_only [spec30],
      try { split, linarith },
      try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃, htv_range_check_ptr₄] }, },
      try { dsimp [cast_BigInt3] },
      try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset, h_call30_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
    },
    {
      -- if: negative branch
      have a20 := cond_aux2 htest hcond,
      try { arith_simps at a20 },
      clear htest hcond,
      -- function call
      step_assert_eq hpc31 with arg0,
      step_assert_eq hpc32 with arg1,
      step_assert_eq hpc33 hpc34 with arg2,
      step_sub hpc35 (auto_sound_assert_nn_le mem _ range_check_ptr₃ val.d1 (P1 - 1) _ _ _ _ _ _),
      { rw hpc36, norm_num2, exact h_mem_2 },
      { rw hpc36, norm_num2, exact h_mem_0 },
      { rw hpc36, norm_num2, exact h_mem_1 },
      { try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2] },
        try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_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_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2] },
        try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_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_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] },
        try { dsimp [cast_BigInt3] },
        try { arith_simps }, try { simp only [arg0, arg1, arg2] },
        try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
        try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } }, },
      intros κ_call37 ap37 h_call37,
      rcases h_call37 with ⟨h_call37_ap_offset, h_call37⟩,
      rcases h_call37 with ⟨rc_m37, rc_mle37, hl_range_check_ptr₄, h_call37⟩,
      generalize' hr_rev_range_check_ptr₄: mem (ap37 - 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 ,arg2] at hl_range_check_ptr₄ },
      rw [←htv_range_check_ptr₄, ←htv_range_check_ptr₃] at hl_range_check_ptr₄,
      try { simp only [arg0 ,arg1 ,arg2] at h_call37 },
      rw [←htv_range_check_ptr₃, hl_range_check_ptr₃, hl_range_check_ptr₂, hl_range_check_ptr₁, hin_range_check_ptr] at h_call37,
      clear arg0 arg1 arg2,
      -- return
      step_ret hpc37,
      -- finish
      step_done, use_only [rfl, rfl],
      -- range check condition
      use_only (rc_m6+rc_m11+rc_m16+rc_m37+0+0), split,
      linarith [rc_mle6, rc_mle11, rc_mle16, rc_mle37],
      split,
      { arith_simps,
        rw [←htv_range_check_ptr₄, hl_range_check_ptr₄, hl_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_validate_reduced_field_element mem _ range_check_ptr val _,
      { apply sound_validate_reduced_field_element, apply auto_spec },
      -- prove the auto generated assertion
      dsimp [auto_spec_validate_reduced_field_element],
      try { norm_num1 }, try { arith_simps },
      use_only [κ_call6],
      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 spec6 := h_call6 rc_h_range_check_ptr',
      rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec6,
      try { dsimp at spec6, arith_simps at spec6 },
      use_only [spec6],
      use_only [κ_call11],
      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 spec11 := h_call11 rc_h_range_check_ptr₁',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec11,
      try { dsimp at spec11, arith_simps at spec11 },
      use_only [spec11],
      use_only [κ_call16],
      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 spec16 := h_call16 rc_h_range_check_ptr₂',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←hl_range_check_ptr₂, ←htv_range_check_ptr₃] at spec16,
      try { dsimp at spec16, arith_simps at spec16 },
      use_only [spec16],
      left,
      use_only [a16],
      right,
      use_only [a20],
      use_only [κ_call37],
      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 spec37 := h_call37 rc_h_range_check_ptr₃',
      rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←hl_range_check_ptr₂, ←hl_range_check_ptr₃, ←htv_range_check_ptr₄] at spec37,
      try { dsimp at spec37, arith_simps at spec37 },
      use_only [spec37],
      try { split, linarith },
      try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃, htv_range_check_ptr₄] }, },
      try { dsimp [cast_BigInt3] },
      try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset, h_call37_ap_offset] },
      try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
    }
  },
  {
    -- if: negative branch
    have a16 := cond_aux2 htest hcond,
    try { arith_simps at a16 },
    clear htest hcond,
    -- return
    step_assert_eq hpc38 with hret0,
    step_ret hpc39,
    -- finish
    step_done, use_only [rfl, rfl],
    -- range check condition
    use_only (rc_m6+rc_m11+rc_m16+0+0), split,
    linarith [rc_mle6, rc_mle11, rc_mle16],
    split,
    { arith_simps, try { simp only [hret0] },
      rw [←htv_range_check_ptr₃, hl_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_validate_reduced_field_element mem _ range_check_ptr val _,
    { apply sound_validate_reduced_field_element, apply auto_spec },
    -- prove the auto generated assertion
    dsimp [auto_spec_validate_reduced_field_element],
    try { norm_num1 }, try { arith_simps },
    use_only [κ_call6],
    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 spec6 := h_call6 rc_h_range_check_ptr',
    rw [←hin_range_check_ptr, ←htv_range_check_ptr₁] at spec6,
    try { dsimp at spec6, arith_simps at spec6 },
    use_only [spec6],
    use_only [κ_call11],
    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 spec11 := h_call11 rc_h_range_check_ptr₁',
    rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←htv_range_check_ptr₂] at spec11,
    try { dsimp at spec11, arith_simps at spec11 },
    use_only [spec11],
    use_only [κ_call16],
    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 spec16 := h_call16 rc_h_range_check_ptr₂',
    rw [←hin_range_check_ptr, ←hl_range_check_ptr₁, ←hl_range_check_ptr₂, ←htv_range_check_ptr₃] at spec16,
    try { dsimp at spec16, arith_simps at spec16 },
    use_only [spec16],
    right,
    use_only [a16],
    try { split, linarith },
    try { ensures_simps; try { simp only [add_neg_eq_sub, hin_range_check_ptr, hin_val, htv_range_check_ptr₁, htv_range_check_ptr₂, htv_range_check_ptr₃] }, },
    try { dsimp [cast_BigInt3] },
    try { arith_simps }, try { simp only [hret0] },
    try { simp only [h_call6_ap_offset, h_call11_ap_offset, h_call16_ap_offset] },
    try { arith_simps; try { split }; triv <|> refl <|> simp <|> abel; try { norm_num } },
  }
end


/-
Copyright (c) 2019 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Meta.Basic
import Lean.Meta.FunInfo
import Lean.Meta.InferType

namespace Lean.Meta.DiscrTree
/-
  (Imperfect) discrimination trees.
  We use a hybrid representation.
  - A `PersistentHashMap` for the root node which usually contains many children.
  - A sorted array of key/node pairs for inner nodes.

  The edges are labeled by keys:
  - Constant names (and arity). Universe levels are ignored.
  - Free variables (and arity). Thus, an entry in the discrimination tree
    may reference hypotheses from the local context.
  - Literals
  - Star/Wildcard. We use them to represent metavariables and terms
    we want to ignore. We ignore implicit arguments and proofs.
  - Other. We use to represent other kinds of terms (e.g., nested lambda, forall, sort, etc).

  We reduce terms using `TransparencyMode.reducible`. Thus, all reducible
  definitions in an expression `e` are unfolded before we insert it into the
  discrimination tree.

  Recall that projections from classes are **NOT** reducible.
  For example, the expressions `Add.add α (ringAdd ?α ?s) ?x ?x`
  and `Add.add Nat Nat.hasAdd a b` generates paths with the following keys
  respctively
  ```
  ⟨Add.add, 4⟩, *, *, *, *
  ⟨Add.add, 4⟩, *, *, ⟨a,0⟩, ⟨b,0⟩
  ```

  That is, we don't reduce `Add.add Nat inst a b` into `Nat.add a b`.
  We say the `Add.add` applications are the de-facto canonical forms in
  the metaprogramming framework.
  Moreover, it is the metaprogrammer's responsibility to re-pack applications such as
  `Nat.add a b` into `Add.add Nat inst a b`.

  Remark: we store the arity in the keys
  1- To be able to implement the "skip" operation when retrieving "candidate"
     unifiers.
  2- Distinguish partial applications `f a`, `f a b`, and `f a b c`.
-/

def Key.ctorIdx : Key → Nat
  | Key.star      => 0
  | Key.other     => 1
  | Key.lit _     => 2
  | Key.fvar _ _  => 3
  | Key.const _ _ => 4
  | Key.arrow     => 5

def Key.lt : Key → Key → Bool
  | Key.lit v₁,      Key.lit v₂      => v₁ < v₂
  | Key.fvar n₁ a₁,  Key.fvar n₂ a₂  => Name.quickLt n₁ n₂ || (n₁ == n₂ && a₁ < a₂)
  | Key.const n₁ a₁, Key.const n₂ a₂ => Name.quickLt n₁ n₂ || (n₁ == n₂ && a₁ < a₂)
  | k₁,              k₂              => k₁.ctorIdx < k₂.ctorIdx

instance : LT Key := ⟨fun a b => Key.lt a b⟩
instance (a b : Key) : Decidable (a < b) := inferInstanceAs (Decidable (Key.lt a b))

def Key.format : Key → Format
  | Key.star                   => "*"
  | Key.other                  => "◾"
  | Key.lit (Literal.natVal v) => fmt v
  | Key.lit (Literal.strVal v) => repr v
  | Key.const k _              => fmt k
  | Key.fvar k _               => fmt k
  | Key.arrow                  => "→"

instance : ToFormat Key := ⟨Key.format⟩

def Key.arity : Key → Nat
  | Key.const _ a => a
  | Key.fvar _ a  => a
  | Key.arrow     => 2
  | _             => 0

instance : Inhabited (Trie α) := ⟨Trie.node #[] #[]⟩

def empty : DiscrTree α := { root := {} }

partial def Trie.format [ToFormat α] : Trie α → Format
  | Trie.node vs cs => Format.group $ Format.paren $
    "node" ++ (if vs.isEmpty then Format.nil else " " ++ fmt vs)
    ++ Format.join (cs.toList.map $ fun ⟨k, c⟩ => Format.line ++ Format.paren (fmt k ++ " => " ++ format c))

instance [ToFormat α] : ToFormat (Trie α) := ⟨Trie.format⟩

partial def format [ToFormat α] (d : DiscrTree α) : Format :=
  let (_, r) := d.root.foldl
    (fun (p : Bool × Format) k c =>
      (false, p.2 ++ (if p.1 then Format.nil else Format.line) ++ Format.paren (fmt k ++ " => " ++ fmt c)))
    (true, Format.nil)
  Format.group r

instance [ToFormat α] : ToFormat (DiscrTree α) := ⟨format⟩

/- The discrimination tree ignores implicit arguments and proofs.
   We use the following auxiliary id as a "mark". -/
private def tmpMVarId : MVarId := `_discr_tree_tmp
private def tmpStar := mkMVar tmpMVarId

instance : Inhabited (DiscrTree α) where
  default := {}

/--
  Return true iff the argument should be treated as a "wildcard" by the discrimination tree.

  - We ignore proofs because of proof irrelevance. It doesn't make sense to try to
    index their structure.

  - We ignore instance implicit arguments (e.g., `[Add α]`) because they are "morally" canonical.
    Moreover, we may have many definitionally equal terms floating around.
    Example: `Ring.hasAdd Int Int.isRing` and `Int.hasAdd`.

  - We considered ignoring implicit arguments (e.g., `{α : Type}`) since users don't "see" them,
    and may not even understand why some simplification rule is not firing.
    However, in type class resolution, we have instance such as `Decidable (@Eq Nat x y)`,
    where `Nat` is an implicit argument. Thus, we would add the path
    ```
    Decidable -> Eq -> * -> * -> * -> [Nat.decEq]
    ```
    to the discrimination tree IF we ignored the implict `Nat` argument.
    This would be BAD since **ALL** decidable equality instances would be in the same path.
    So, we index implicit arguments if they are types.
    This setting seems sensible for simplification lemmas such as:
    ```
    forall (x y : Unit), (@Eq Unit x y) = true
    ```
    If we ignore the implicit argument `Unit`, the `DiscrTree` will say it is a candidate
    simplification lemma for any equality in our goal.

  Remark: if users have problems with the solution above, we may provide a `noIndexing` annotation,
  and `ignoreArg` would return true for any term of the form `noIndexing t`.
-/
private def ignoreArg (a : Expr) (i : Nat) (infos : Array ParamInfo) : MetaM Bool := do
  if h : i < infos.size then
    let info := infos.get ⟨i, h⟩
    if info.instImplicit then
      return true
    else if info.implicit then
      return not (← isType a)
    else
      isProof a
  else
    isProof a

private partial def pushArgsAux (infos : Array ParamInfo) : Nat → Expr → Array Expr → MetaM (Array Expr)
  | i, Expr.app f a _, todo => do
    if (← ignoreArg a i infos) then
      pushArgsAux infos (i-1) f (todo.push tmpStar)
    else
      pushArgsAux infos (i-1) f (todo.push a)
  | _, _, todo => return todo

private partial def whnfEta (e : Expr) : MetaM Expr := do
  let e ← whnf e
  match e.etaExpandedStrict? with
  | some e => whnfEta e
  | none   => return e

/--
  Return true if `e` is one of the following
  - A nat literal (numeral)
  - `Nat.zero`
  - `Nat.succ x` where `isNumeral x`
  - `OfNat.ofNat _ x _` where `isNumeral x` -/
private partial def isNumeral (e : Expr) : Bool :=
  if e.isNatLit then true
  else
    let f := e.getAppFn
    if !f.isConst then false
    else
      let fName := f.constName!
      if fName == ``Nat.succ && e.getAppNumArgs == 1 then isNumeral e.appArg!
      else if fName == ``OfNat.ofNat && e.getAppNumArgs == 3 then isNumeral (e.getArg! 1)
      else if fName == ``Nat.zero && e.getAppNumArgs == 0 then true
      else false

private def isNatType (e : Expr) : MetaM Bool :=
  return (← whnf e).isConstOf ``Nat

/--
  Return true if `e` is one of the following
  - `Nat.add _ k` where `isNumeral k`
  - `Add.add Nat _ _ k` where `isNumeral k`
  - `HAdd.hAdd _ Nat _ _ k` where `isNumeral k`
  - `Nat.succ _`
  This function assumes `e.isAppOf fName`
-/
private def isOffset (fName : Name) (e : Expr) : MetaM Bool := do
  if fName == ``Nat.add && e.getAppNumArgs == 2 then
    return isNumeral e.appArg!
  else if fName == ``Add.add && e.getAppNumArgs == 4 then
    if (← isNatType (e.getArg! 0)) then return isNumeral e.appArg! else return false
  else if fName == ``HAdd.hAdd && e.getAppNumArgs == 6 then
    if (← isNatType (e.getArg! 1)) then return isNumeral e.appArg! else return false
  else
    return fName == ``Nat.succ && e.getAppNumArgs == 1

/-
  TODO: add hook for users adding their own functions for controlling `shouldAddAsStar`
  Different `DiscrTree` users may populate this set using, for example, attributes.

  Remark: we currently tag `Nat.zero` and "offset" terms to avoid having to add special
  support for `Expr.lit` and offset terms.
  Example, suppose the discrimination tree contains the entry
  `Nat.succ ?m |-> v`, and we are trying to retrieve the matches for `Expr.lit (Literal.natVal 1) _`.
  In this scenario, we want to retrieve `Nat.succ ?m |-> v` -/
private def shouldAddAsStar (fName : Name) (e : Expr) : MetaM Bool := do
  if fName == `Nat.zero then
    return true
  else
    isOffset fName e

def mkNoindexAnnotation (e : Expr) : Expr :=
  mkAnnotation `noindex e

def hasNoindexAnnotation (e : Expr) : Bool :=
  annotation? `noindex e |>.isSome

/- Remark: we use `shouldAddAsStar` only for nested terms, and `root == false` for nested terms -/

private def pushArgs (root : Bool) (todo : Array Expr) (e : Expr) : MetaM (Key × Array Expr) := do
  if hasNoindexAnnotation e then
    return (Key.star, todo)
  else
    let e ← whnfEta e
    let fn := e.getAppFn
    let push (k : Key) (nargs : Nat) : MetaM (Key × Array Expr) := do
      let info ← getFunInfoNArgs fn nargs
      let todo ← pushArgsAux info.paramInfo (nargs-1) e todo
      return (k, todo)
    match fn with
    | Expr.lit v _       => return (Key.lit v, todo)
    | Expr.const c _ _   =>
      unless root do
        if (← shouldAddAsStar c e) then
          return (Key.star, todo)
      let nargs := e.getAppNumArgs
      push (Key.const c nargs) nargs
    | Expr.fvar fvarId _ =>
      let nargs := e.getAppNumArgs
      push (Key.fvar fvarId nargs) nargs
    | Expr.mvar mvarId _ =>
      if mvarId == tmpMVarId then
        -- We use `tmp to mark implicit arguments and proofs
        return (Key.star, todo)
      else if (← isReadOnlyOrSyntheticOpaqueExprMVar mvarId) then
        return (Key.other, todo)
      else
        return (Key.star, todo)
    | Expr.forallE _ d b _ =>
      if b.hasLooseBVars then
        return (Key.other, todo)
      else
        return (Key.arrow, todo.push d |>.push b)
    | _ =>
      return (Key.other, todo)

partial def mkPathAux (root : Bool) (todo : Array Expr) (keys : Array Key) : MetaM (Array Key) := do
  if todo.isEmpty then
    return keys
  else
    let e    := todo.back
    let todo := todo.pop
    let (k, todo) ← pushArgs root todo e
    mkPathAux false todo (keys.push k)

private def initCapacity := 8

def mkPath (e : Expr) : MetaM (Array Key) := do
  withReducible do
    let todo : Array Expr := Array.mkEmpty initCapacity
    let keys : Array Key  := Array.mkEmpty initCapacity
    mkPathAux (root := true) (todo.push e) keys

private partial def createNodes (keys : Array Key) (v : α) (i : Nat) : Trie α :=
  if h : i < keys.size then
    let k := keys.get ⟨i, h⟩
    let c := createNodes keys v (i+1)
    Trie.node #[] #[(k, c)]
  else
    Trie.node #[v] #[]

private def insertVal [BEq α] (vs : Array α) (v : α) : Array α :=
  if vs.contains v then vs else vs.push v

private partial def insertAux [BEq α] (keys : Array Key) (v : α) : Nat → Trie α → Trie α
  | i, Trie.node vs cs =>
    if h : i < keys.size then
      let k := keys.get ⟨i, h⟩
      let c := Id.run $ cs.binInsertM
          (fun a b => a.1 < b.1)
          (fun ⟨_, s⟩ => let c := insertAux keys v (i+1) s; (k, c)) -- merge with existing
          (fun _ => let c := createNodes keys v (i+1); (k, c))
          (k, arbitrary)
      Trie.node vs c
    else
      Trie.node (insertVal vs v) cs

def insertCore [BEq α] (d : DiscrTree α) (keys : Array Key) (v : α) : DiscrTree α :=
  if keys.isEmpty then panic! "invalid key sequence"
  else
    let k := keys[0]
    match d.root.find? k with
    | none =>
      let c := createNodes keys v 1
      { root := d.root.insert k c }
    | some c =>
      let c := insertAux keys v 1 c
      { root := d.root.insert k c }

def insert [BEq α] (d : DiscrTree α) (e : Expr) (v : α) : MetaM (DiscrTree α) := do
  let keys ← mkPath e
  return d.insertCore keys v

private def getKeyArgs (e : Expr) (isMatch : Bool) : MetaM (Key × Array Expr) := do
  let e ← whnfEta e
  match e.getAppFn with
  | Expr.lit v _       => return (Key.lit v, #[])
  | Expr.const c _ _   =>
    let nargs := e.getAppNumArgs
    return (Key.const c nargs, e.getAppRevArgs)
  | Expr.fvar fvarId _ =>
    let nargs := e.getAppNumArgs
    return (Key.fvar fvarId nargs, e.getAppRevArgs)
  | Expr.mvar mvarId _ =>
    if isMatch then
      return (Key.other, #[])
    else do
      let ctx ← read
      if ctx.config.isDefEqStuckEx then
        /-
          When the configuration flag `isDefEqStuckEx` is set to true,
          we want `isDefEq` to throw an exception whenever it tries to assign
          a read-only metavariable.
          This feature is useful for type class resolution where
          we may want to notify the caller that the TC problem may be solveable
          later after it assigns `?m`.
          The method `DiscrTree.getUnify e` returns candidates `c` that may "unify" with `e`.
          That is, `isDefEq c e` may return true. Now, consider `DiscrTree.getUnify d (Add ?m)`
          where `?m` is a read-only metavariable, and the discrimination tree contains the keys
          `HadAdd Nat` and `Add Int`. If `isDefEqStuckEx` is set to true, we must treat `?m` as
          a regular metavariable here, otherwise we return the empty set of candidates.
          This is incorrect because it is equivalent to saying that there is no solution even if
          the caller assigns `?m` and try again. -/
        return (Key.star, #[])
      else if (← isReadOnlyOrSyntheticOpaqueExprMVar mvarId) then
        return (Key.other, #[])
      else
        return (Key.star, #[])
  | Expr.forallE _ d b _ =>
    if b.hasLooseBVars then
      return (Key.other, #[])
    else
      return (Key.arrow, #[d, b])
  | _ =>
    return (Key.other, #[])

private abbrev getMatchKeyArgs (e : Expr) : MetaM (Key × Array Expr) :=
  getKeyArgs e (isMatch := true)

private abbrev getUnifyKeyArgs (e : Expr) : MetaM (Key × Array Expr) :=
  getKeyArgs e (isMatch := false)

private def getStarResult (d : DiscrTree α) : Array α :=
  let result : Array α := Array.mkEmpty initCapacity
  match d.root.find? Key.star with
  | none                  => result
  | some (Trie.node vs _) => result ++ vs

private abbrev findKey (cs : Array (Key × Trie α)) (k : Key) : Option (Key × Trie α) :=
  cs.binSearch (k, arbitrary) (fun a b => a.1 < b.1)

partial def getMatch (d : DiscrTree α) (e : Expr) : MetaM (Array α) :=
  withReducible do
    let result := getStarResult d
    let (k, args) ← getMatchKeyArgs e
    match k with
    | Key.star => return result
    | _        =>
      match d.root.find? k with
      | none   => return result
      | some c => process args c result
where
  process (todo : Array Expr) (c : Trie α) (result : Array α) : MetaM (Array α) := do
    match c with
    | Trie.node vs cs =>
      if todo.isEmpty then
        return result ++ vs
      else if cs.isEmpty then
        return result
      else
        let e     := todo.back
        let todo  := todo.pop
        let first := cs[0] /- Recall that `Key.star` is the minimal key -/
        let (k, args) ← getMatchKeyArgs e
        /- We must always visit `Key.star` edges since they are wildcards.
           Thus, `todo` is not used linearly when there is `Key.star` edge
           and there is an edge for `k` and `k != Key.star`. -/
        let visitStar (result : Array α) : MetaM (Array α) :=
          if first.1 == Key.star then
            process todo first.2 result
          else
            return result
        let visitNonStar (k : Key) (args : Array Expr) (result : Array α) : MetaM (Array α) :=
          match findKey cs k with
          | none   => result
          | some c => process (todo ++ args) c.2 result
        let result ← visitStar result
        match k with
        | Key.star  => result
        /-
          Recall that dependent arrows are `(Key.other, #[])`, and non-dependent arrows are `(Key.arrow, #[a, b])`.
          A non-dependent arrow may be an instance of a dependent arrow (stored at `DiscrTree`). Thus, we also visit the `Key.other` child.
        -/
        | Key.arrow => visitNonStar Key.other #[] (← visitNonStar k args result)
        | _         => visitNonStar k args result

partial def getUnify (d : DiscrTree α) (e : Expr) : MetaM (Array α) :=
  withReducible do
    let (k, args) ← getUnifyKeyArgs e
    match k with
    | Key.star => d.root.foldlM (init := #[]) fun result k c => process k.arity #[] c result
    | _ =>
      let result := getStarResult d
      match d.root.find? k with
      | none   => return result
      | some c => process 0 args c result
where
  process (skip : Nat) (todo : Array Expr) (c : Trie α) (result : Array α) : MetaM (Array α) := do
    match skip, c with
    | skip+1, Trie.node vs cs =>
      if cs.isEmpty then
        return result
      else
        cs.foldlM (init := result) fun result ⟨k, c⟩ => process (skip + k.arity) todo c result
    | 0, Trie.node vs cs => do
      if todo.isEmpty then
        return result ++ vs
      else if cs.isEmpty then
        return result
      else
        let e     := todo.back
        let todo  := todo.pop
        let (k, args) ← getUnifyKeyArgs e
        let visitStar (result : Array α) : MetaM (Array α) :=
          let first := cs[0]
          if first.1 == Key.star then
            process 0 todo first.2 result
          else
            return result
        let visitNonStar (k : Key) (args : Array Expr) (result : Array α) : MetaM (Array α) :=
          match findKey cs k with
          | none   => result
          | some c => process 0 (todo ++ args) c.2 result
        match k with
        | Key.star  => cs.foldlM (init := result) fun result ⟨k, c⟩ => process k.arity todo c result
        -- See comment a `getMatch` regarding non-dependent arrows vs dependent arrows
        | Key.arrow => visitNonStar Key.other #[] (← visitNonStar k args (← visitStar result))
        | _         => visitNonStar k args (← visitStar result)

end Lean.Meta.DiscrTree


import ReactorModel.Objects.Reaction

open Reactor (Component)

class ReactorType (α : Type) where
  ports : α → Kind → ID ⇀ Value
  acts  : α → ID ⇀ Action
  state : α → ID ⇀ Value
  rcns  : α → ID ⇀ Reaction
  nest  : α → ID ⇀ α

namespace ReactorType

abbrev cptType [ReactorType α] : Component → Type
  | .rtr     => α
  | .rcn     => Reaction
  | .val cpt => cpt.type

abbrev cpt? [inst : ReactorType α] : (cpt : Component) → α → ID ⇀ inst.cptType cpt
  | .rtr   => nest
  | .rcn   => rcns
  | .prt k => (ports · k)
  | .act   => acts
  | .stv   => state

inductive Member [ReactorType α] (cpt : Component) (i : ID) : α → Type _
  | final : (i ∈ cpt? cpt rtr) → Member cpt i rtr
  | nest : (nest rtr₁ j = some rtr₂) → (m : Member cpt i rtr₂) → Member cpt i rtr₁

class Extensional (α) extends ReactorType α where
  ext_iff :
    rtr₁ = rtr₂ ↔
    (ports rtr₁ = ports rtr₂) ∧ (acts rtr₁ = acts rtr₂) ∧ (state rtr₁ = state rtr₂) ∧
    (rcns rtr₁ = rcns rtr₂) ∧ (nest rtr₁ = nest rtr₂)

@[ext]
theorem Extensional.ext [inst : Extensional α] {rtr₁ rtr₂ : α} :
    (ports rtr₁ = ports rtr₂) ∧ (acts rtr₁ = acts rtr₂) ∧ (state rtr₁ = state rtr₂) ∧
    (rcns rtr₁ = rcns rtr₂) ∧ (nest rtr₁ = nest rtr₂) → rtr₁ = rtr₂
  := inst.ext_iff.mpr

end ReactorType