import phase2.flexible_completion
import phase2.reduction
import phase2.refine

open quiver set sum with_bot
open_locale classical

universe u

namespace con_nf

namespace struct_approx
variables [params.{u}] {α : Λ} [position_data.{}] [phase_2_assumptions α] {β : Iic α}
  {γ : Iic α} {δ ε : Iio α} (hδ : (δ : Λ) < γ) (hε : (ε : Λ) < γ) (hδε : δ ≠ ε)
  {A : path (β : type_index) γ} {t : tangle δ}
  (H : hypothesis ⟨inr (f_map (coe_ne_coe.mpr $ coe_ne' hδε) t).to_near_litter,
    (A.cons (coe_lt hε)).cons (bot_lt_coe _)⟩)

/-- The inductive hypothesis used for proving freedom of action:
Every free approximation exactly approximates some allowable permutation. -/
def foa_ih (β : Iic α) : Prop :=
∀ (π₀ : struct_approx β), π₀.free → ∃ (π : allowable β), π₀.exactly_approximates π.to_struct_perm

/-- A proof-relevant statement that `L` is `A`-inflexible (excluding `ε = ⊥`). -/
structure inflexible_coe (L : litter) (A : extended_index β) :=
(γ : Iic α) (δ ε : Iio α) (hδ : (δ : Λ) < γ) (hε : (ε : Λ) < γ) (hδε : δ ≠ ε)
(B : quiver.path (β : type_index) γ) (t : tangle δ)
(hL : L = f_map (coe_ne_coe.mpr $ coe_ne' hδε) t)
(hA : A = (B.cons (coe_lt hε)).cons (bot_lt_coe _))

instance (L : litter) (A : extended_index β) : subsingleton (inflexible_coe L A) :=
begin
  constructor,
  rintros ⟨γ₁, δ₁, ε₁, hδ₁, hε₁, hδε₁, B₁, t₁, rfl, rfl⟩
    ⟨γ₂, δ₂, ε₂, hδ₂, hε₂, hδε₂, B₂, t₂, hL₂, hA₂⟩,
  cases subtype.coe_injective (coe_eq_coe.mp (path.obj_eq_of_cons_eq_cons hA₂)),
  cases subtype.coe_injective (coe_eq_coe.mp (path.obj_eq_of_cons_eq_cons
    (path.heq_of_cons_eq_cons hA₂).eq)),
  cases (path.heq_of_cons_eq_cons (path.heq_of_cons_eq_cons hA₂).eq).eq,
  have h₁ := f_map_β (coe_ne_coe.mpr $ coe_ne' hδε₁) t₁,
  have h₂ := f_map_β (coe_ne_coe.mpr $ coe_ne' hδε₂) t₂,
  rw [hL₂, h₂] at h₁,
  cases subtype.coe_injective (coe_eq_coe.mp h₁),
  cases f_map_injective _ hL₂,
  refl,
end

/-- A proof-relevant statement that `L` is `A`-inflexible, where `δ = ⊥`. -/
structure inflexible_bot (L : litter) (A : extended_index β) :=
(γ : Iic α) (ε : Iio α) (hε : (ε : Λ) < γ)
(B : quiver.path (β : type_index) γ) (a : atom)
(hL : L = f_map (show (⊥ : type_index) ≠ (ε : Λ), from bot_ne_coe) a)
(hA : A = (B.cons (coe_lt hε)).cons (bot_lt_coe _))

instance (L : litter) (A : extended_index β) : subsingleton (inflexible_bot L A) :=
begin
  constructor,
  rintros ⟨γ₁, ε₁, hε₁, B₁, a₁, rfl, rfl⟩ ⟨γ₂, ε₂, hε₂, B₂, a₂, hL₂, hA₂⟩,
  cases subtype.coe_injective (coe_eq_coe.mp (path.obj_eq_of_cons_eq_cons hA₂)),
  cases subtype.coe_injective (coe_eq_coe.mp (path.obj_eq_of_cons_eq_cons
    (path.heq_of_cons_eq_cons hA₂).eq)),
  cases (path.heq_of_cons_eq_cons (path.heq_of_cons_eq_cons hA₂).eq).eq,
  cases f_map_injective _ hL₂,
  refl,
end

lemma inflexible_bot_inflexible_coe {L : litter} {A : extended_index β} :
  inflexible_bot L A → inflexible_coe L A → false :=
begin
  rintros ⟨γ₁, ε₁, hε₁, B₁, a₁, rfl, rfl⟩ ⟨γ₂, δ₂, ε₂, hδ₂, hε₂, hδε₂, B₂, t₂, hL₂, hA₂⟩,
  have h₁ := f_map_β (show (⊥ : type_index) ≠ (ε₁ : Λ), from bot_ne_coe) a₁,
  have h₂ := f_map_β (coe_ne_coe.mpr $ coe_ne' hδε₂) t₂,
  rw [hL₂, h₂] at h₁,
  cases h₁,
end

lemma inflexible_coe.δ_lt_β {L : litter} {A : extended_index β} (h : inflexible_coe L A) :
  (h.δ : Λ) < β :=
h.hδ.trans_le (show _, from coe_le_coe.mp (le_of_path h.B))

lemma inflexible_bot.constrains {L : litter} {A : extended_index β} (h : inflexible_bot L A) :
  relation.trans_gen (constrains α β)
    (inl h.a, (h.B.cons (bot_lt_coe _))) (inr L.to_near_litter, A) :=
begin
  have := constrains.f_map_bot h.hε h.B h.a,
  rw [← h.hL, ← h.hA] at this,
  exact relation.trans_gen.single this,
end

class freedom_of_action_hypothesis (β : Iic α) :=
(freedom_of_action_of_lt : ∀ γ < β, foa_ih γ)

export freedom_of_action_hypothesis (freedom_of_action_of_lt)

variable [freedom_of_action_hypothesis β]

/-- For the support map of `t`, we use everything that constrains `t`. -/
def inflexible_support {L : litter} {A : extended_index β} (h : inflexible_coe L A) :
  set (support_condition h.δ) :=
(λ c, (c.1, (h.B.cons (coe_lt h.hδ)).comp c.2)) ⁻¹'
{c | relation.trans_gen (constrains α β) c
  (inr (f_map (coe_ne_coe.mpr $ coe_ne' h.hδε) h.t).to_near_litter,
    (h.B.cons (coe_lt h.hε)).cons (bot_lt_coe _))}

lemma inflexible_support_small {L : litter} {A : extended_index β} (h : inflexible_coe L A) :
  small (inflexible_support h) :=
begin
  refine lt_of_le_of_lt (cardinal.mk_preimage_of_injective _ _ _) _,
  { intros c d h,
    simp only [prod.mk.inj_iff, path.comp_inj_right] at h,
    exact prod.ext h.1 h.2, },
  { refine small.mono _ (reduction_small' α (small_singleton
    (inr (f_map (coe_ne_coe.mpr $ coe_ne' h.hδε) h.t).to_near_litter,
      (h.B.cons (coe_lt h.hε)).cons (bot_lt_coe _)))),
    intros c hc,
    exact ⟨_, rfl, hc.to_refl⟩, },
end

lemma inflexible_support_supports_f_map {π : allowable β} {γ : Iic α} {δ ε : Iio α}
  (hδ : (δ : Λ) < γ) (hε : (ε : Λ) < γ) (hδε : δ ≠ ε)
  {B : path (β : type_index) γ} {t : tangle δ}
  (hπ : ∀ ⦃a : support_condition ↑β⦄,
    a ≺[α] (inr (f_map (coe_ne_coe.mpr $ coe_ne' hδε) t).to_near_litter,
      (B.cons (coe_lt hε)).cons (bot_lt_coe _)) → π • a = a)
  (hc : (f_map (coe_ne_coe.mpr $ coe_ne' hδε) t).to_near_litter.is_litter →
    inflexible α (f_map (coe_ne_coe.mpr $ coe_ne' hδε) t)
      ((B.cons (coe_lt hε)).cons (bot_lt_coe _))) :
  (allowable.derivative (show path ((β : Iic_index α) : type_index) (ε : Iic_index α),
      from B.cons (coe_lt hε)) π : allowable (ε : Iic_index α)) •
    f_map (coe_ne_coe.mpr $ coe_ne' hδε) t =
    f_map (coe_ne_coe.mpr $ coe_ne' hδε) t :=
begin
  have h₁ := allowable.derivative_cons (show path ((β : Iic_index α) : type_index)
    (γ : Iic_index α), from B) (coe_lt hε),
  have h₂ := @smul_f_map _ _ _ _ (γ : Iic_index α) (δ : Iio_index α) ε
    (coe_lt hδ) (coe_lt hε) (Iio.coe_injective.ne hδε)
    (allowable.derivative (show path ((β : Iic_index α) : type_index)
      (γ : Iic_index α), from B) π) t,
  rw h₁,
  refine h₂.trans (congr_arg _ _),
  refine (designated_support t).supports _ (λ c hc, _),
  have := congr_arg prod.fst (hπ (constrains.f_map hδ hε hδε B t c hc)),
  obtain ⟨c, C⟩ := c,
  refine prod.ext (eq.trans _ this) rfl,
  rw ← allowable.to_struct_perm_smul at this ⊢,
  rw [← phase_2_assumptions.allowable_derivative_eq, ← allowable.derivative_to_struct_perm],
  change _ • _ = _ • _,
  simp only [struct_perm.derivative_derivative, path.comp_cons, path.comp_nil],
end

-- TODO: Does `litter_map_injective` follow from `atom_mem`?
structure hypothesis_injective_inflexible {L : litter} {A : extended_index β}
  (H : hypothesis ⟨inr L.to_near_litter, A⟩) (h : inflexible_coe L A) : Prop :=
(atom_map_injective : ∀ a b B
  (ha : (inl a, B) ∈ inflexible_support h) (hb : (inl b, B) ∈ inflexible_support h),
  H.atom_image a ((h.B.cons (coe_lt h.hδ)).comp B)
    (by rwa [inflexible_support, ← h.hL, ← h.hA] at ha) =
  H.atom_image b ((h.B.cons (coe_lt h.hδ)).comp B)
    (by rwa [inflexible_support, ← h.hL, ← h.hA] at hb) → a = b)
(litter_map_injective : ∀ (L₁ L₂ : litter) B
  (hL₁ : (inr L₁.to_near_litter, B) ∈ inflexible_support h)
  (hL₂ : (inr L₂.to_near_litter, B) ∈ inflexible_support h),
  (H.near_litter_image L₁.to_near_litter ((h.B.cons (coe_lt h.hδ)).comp B)
    (by rwa [inflexible_support, ← h.hL, ← h.hA] at hL₁) ∩
  H.near_litter_image L₂.to_near_litter ((h.B.cons (coe_lt h.hδ)).comp B)
    (by rwa [inflexible_support, ← h.hL, ← h.hA] at hL₂) : set atom).nonempty → L₁ = L₂)
(atom_mem : ∀ a (L : litter) B
  (ha : (inl a, B) ∈ inflexible_support h) (hL : (inr L.to_near_litter, B) ∈ inflexible_support h),
  a ∈ litter_set L ↔
    H.atom_image a ((h.B.cons (coe_lt h.hδ)).comp B)
      (by rwa [inflexible_support, ← h.hL, ← h.hA] at ha) ∈
    H.near_litter_image L.to_near_litter ((h.B.cons (coe_lt h.hδ)).comp B)
      (by rwa [inflexible_support, ← h.hL, ← h.hA] at hL))
(map_flexible : ∀ (L : litter) B (hL₁ : (inr L.to_near_litter, B) ∈ inflexible_support h)
  (hL₂ : flexible α L B),
  flexible α (H.near_litter_image L.to_near_litter ((h.B.cons (coe_lt h.hδ)).comp B)
    (by rwa [inflexible_support, ← h.hL, ← h.hA] at hL₁)).1 B)

def hypothesised_weak_struct_approx {L : litter} {A : extended_index β}
  (H : hypothesis ⟨inr L.to_near_litter, A⟩) (h : inflexible_coe L A)
  (hH : hypothesis_injective_inflexible H h) : weak_struct_approx h.δ :=
λ B, {
  atom_map := λ a, ⟨(inl a, B) ∈ inflexible_support h,
    λ ha, H.atom_image a ((h.B.cons (coe_lt h.hδ)).comp B)
      (by rwa [inflexible_support, ← h.hL, ← h.hA] at ha)⟩,
  litter_map := λ L, ⟨(inr L.to_near_litter, B) ∈ inflexible_support h,
    λ hL, H.near_litter_image L.to_near_litter ((h.B.cons (coe_lt h.hδ)).comp B)
      (by rwa [inflexible_support, ← h.hL, ← h.hA] at hL)⟩,
  atom_map_dom_small := begin
    simp only [pfun.dom_mk],
    refine lt_of_le_of_lt _ (inflexible_support_small h),
    refine ⟨⟨λ a, ⟨_, a.prop⟩, λ a b h, _⟩⟩,
    simp only [subtype.mk_eq_mk, prod.mk.inj_iff, subtype.coe_inj, eq_self_iff_true, and_true] at h,
    exact h,
  end,
  litter_map_dom_small := begin
    simp only [pfun.dom_mk],
    refine lt_of_le_of_lt _ (inflexible_support_small h),
    refine ⟨⟨λ L, ⟨_, L.prop⟩, λ L₁ L₂ h, _⟩⟩,
    simp only [subtype.mk_eq_mk, prod.mk.inj_iff, eq_self_iff_true, and_true,
      litter.to_near_litter_injective.eq_iff, subtype.coe_inj] at h,
    exact h,
  end,
  atom_map_injective := λ a b ha hb, hH.atom_map_injective a b B ha hb,
  litter_map_injective := λ L₁ L₂ hL₁ hL₂, hH.litter_map_injective L₁ L₂ B hL₁ hL₂,
  atom_mem := λ a ha L hL, hH.atom_mem a L B ha hL,
}

@[simp] lemma hypothesised_weak_struct_approx_atom_map {L : litter} {A : extended_index β}
  (H : hypothesis ⟨inr L.to_near_litter, A⟩) (h : inflexible_coe L A)
  (hH : hypothesis_injective_inflexible H h) (B : extended_index h.δ) (a : atom) :
  (hypothesised_weak_struct_approx H h hH B).atom_map a = {
    dom := (inl a, B) ∈ inflexible_support h,
    get := λ ha, H.atom_image a ((h.B.cons (coe_lt h.hδ)).comp B)
      (by rwa [inflexible_support, ← h.hL, ← h.hA] at ha)
  } := rfl

@[simp] lemma hypothesised_weak_struct_approx_litter_map {L : litter} {A : extended_index β}
  (H : hypothesis ⟨inr L.to_near_litter, A⟩) (h : inflexible_coe L A)
  (hH : hypothesis_injective_inflexible H h) (B : extended_index h.δ) (L : litter) :
  (hypothesised_weak_struct_approx H h hH B).litter_map L = {
    dom := (inr L.to_near_litter, B) ∈ inflexible_support h,
    get := λ hL, H.near_litter_image L.to_near_litter ((h.B.cons (coe_lt h.hδ)).comp B)
      (by rwa [inflexible_support, ← h.hL, ← h.hA] at hL)
  } := rfl

lemma hypothesised_weak_struct_approx_free (π : struct_approx β) (hπ : π.free) {L : litter}
  {A : extended_index β} (H : hypothesis ⟨inr L.to_near_litter, A⟩) (h : inflexible_coe L A)
  (hH : hypothesis_injective_inflexible H h) :
  @struct_approx.free _ _ _ _ (h.δ : Iic α)
  (hypothesised_weak_struct_approx H h hH).refine.complete :=
begin
  rintros B L' ((hL' | ⟨L', hL', rfl⟩) | hL'),
  { exact hL'.2, },
  { rw weak_near_litter_approx.rough_litter_map_or_else_of_dom _ hL'.1,
    exact hH.map_flexible L' B hL'.1 hL'.2, },
  { exact (local_perm.sandbox_subset_subset _ _ hL').2, },
end

noncomputable def allowable_of_weak_struct_approx (π : struct_approx β) (hπ : π.free)
  {γ : Iic α} {δ : Iio α} (hδ : (δ : Λ) < γ) (B : path (β : type_index) γ)
  (w : weak_struct_approx δ)
  (hw : (show struct_approx (δ : Iic α), from w.complete).free) :
  allowable δ :=
(freedom_of_action_of_lt (δ : Iic α)
  (hδ.trans_le (show _, from coe_le_coe.mp (le_of_path B))) _ hw).some

lemma allowable_of_weak_struct_approx_exactly_approximates (π : struct_approx β) (hπ : π.free)
  {γ : Iic α} {δ : Iio α} (hδ : (δ : Λ) < γ) (B : path (β : type_index) γ)
  (w : weak_struct_approx δ)
  (hw : (show struct_approx (δ : Iic α), from w.complete).free) :
  w.complete.exactly_approximates (allowable_of_weak_struct_approx π hπ hδ B w hw).to_struct_perm :=
(freedom_of_action_of_lt (δ : Iic α)
  (hδ.trans_le (show _, from coe_le_coe.mp (le_of_path B))) _ hw).some_spec

noncomputable def hypothesised_allowable (π : struct_approx β) (hπ : π.free)
  {L : litter} {A : extended_index β} (h : inflexible_coe L A)
  (H : hypothesis ⟨inr L.to_near_litter, A⟩) (hH : hypothesis_injective_inflexible H h) :
  allowable h.δ :=
allowable_of_weak_struct_approx π hπ h.hδ h.B _ (hypothesised_weak_struct_approx_free π hπ H h hH)

lemma hypothesised_allowable_exactly_approximates (π : struct_approx β) (hπ : π.free)
  {L : litter} {A : extended_index β} (h : inflexible_coe L A)
  (H : hypothesis ⟨inr L.to_near_litter, A⟩) (hH : hypothesis_injective_inflexible H h) :
  (hypothesised_weak_struct_approx H h hH).refine.complete.exactly_approximates
    (hypothesised_allowable π hπ h H hH).to_struct_perm :=
allowable_of_weak_struct_approx_exactly_approximates π hπ h.hδ h.B _
  (hypothesised_weak_struct_approx_free π hπ H h hH)

-- TODO: Rename next few lemmas.
-- TODO: Trim assumptions from lots of these little lemmas, then package into `variables`.
lemma mem_inflexible_support (π : struct_approx β) (hπ : π.free)
  {L : litter} {A : extended_index β} (h : inflexible_coe L A)
  (B : extended_index h.δ) (a : atom)
  (d : support_condition h.δ) (hd₁ : d ∈ designated_support h.t)
  (hd₂ : relation.refl_trans_gen (constrains α h.δ) (inl a, B) d) :
    (inl a, B) ∈ inflexible_support h :=
relation.trans_gen.tail'
  (refl_trans_gen_constrains_comp hd₂ _)
  (constrains.f_map h.hδ h.hε h.hδε h.B h.t d hd₁)

noncomputable def litter_completion (π : struct_approx β) (hπ : π.free)
  (L : litter) (A : extended_index β) (H : hypothesis ⟨inr L.to_near_litter, A⟩) : litter :=
if h : nonempty (inflexible_coe L A) then
  if hH : hypothesis_injective_inflexible H h.some then
    f_map (coe_ne_coe.mpr $ coe_ne' h.some.hδε)
      (hypothesised_allowable π hπ h.some H hH • h.some.t)
  else
    near_litter_approx.flexible_completion α (π A) A • L
else if h : nonempty (inflexible_bot L A) then
  f_map (show (⊥ : type_index) ≠ (h.some.ε : Λ), from bot_ne_coe)
    (H.atom_image h.some.a (h.some.B.cons (bot_lt_coe _)) h.some.constrains)
else
  near_litter_approx.flexible_completion α (π A) A • L

lemma litter_completion_of_flexible (π : struct_approx β) (hπ : π.free)
  (L : litter) (A : extended_index β) (H : hypothesis ⟨inr L.to_near_litter, A⟩)
  (hflex : flexible α L A) :
  litter_completion π hπ L A H = near_litter_approx.flexible_completion α (π A) A • L :=
begin
  rw [litter_completion, dif_neg, dif_neg],
  { rintro ⟨⟨γ, ε, hε, C, a, rfl, rfl⟩⟩,
    exact hflex (inflexible.mk_bot _ _ _), },
  { rintro ⟨⟨γ, δ, ε, hδ, hε, hδε, C, t, rfl, rfl⟩⟩,
    exact hflex (inflexible.mk_coe hδ _ _ _ _), },
end

lemma litter_completion_of_inflexible_coe (π : struct_approx β) (hπ : π.free)
  (L : litter) (A : extended_index β) (H : hypothesis ⟨inr L.to_near_litter, A⟩)
  (h : inflexible_coe L A) (hH : hypothesis_injective_inflexible H h) :
  litter_completion π hπ L A H =
  f_map (coe_ne_coe.mpr $ coe_ne' h.hδε) (hypothesised_allowable π hπ h H hH • h.t) :=
begin
  rw [litter_completion, dif_pos, dif_pos],
  { repeat {
      congr' 1;
      try { rw subsingleton.elim h, },
    }, },
  { rw subsingleton.elim h at hH,
    exact hH, },
  { exact ⟨h⟩, },
end

lemma litter_completion_of_inflexible_bot (π : struct_approx β) (hπ : π.free)
  (L : litter) (A : extended_index β) (H : hypothesis ⟨inr L.to_near_litter, A⟩)
  (h : inflexible_bot L A) :
  litter_completion π hπ L A H =
  f_map (show (⊥ : type_index) ≠ (h.ε : Λ), from bot_ne_coe)
    (H.atom_image h.a (h.B.cons (bot_lt_coe _)) h.constrains) :=
begin
  rw [litter_completion, dif_neg, dif_pos, subsingleton.elim h],
  { exact ⟨h⟩, },
  { rintro ⟨h'⟩,
    exact inflexible_bot_inflexible_coe h h', },
end

end struct_approx

end con_nf


/-
Copyright (c) 2020 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Lean.Parser.Command
import Lean.Meta.Closure
import Lean.Meta.SizeOf
import Lean.Meta.Injective
import Lean.Meta.Structure
import Lean.Meta.AppBuilder
import Lean.Elab.Command
import Lean.Elab.DeclModifiers
import Lean.Elab.DeclUtil
import Lean.Elab.Inductive
import Lean.Elab.DeclarationRange
import Lean.Elab.Binders

namespace Lean.Elab.Command

open Meta

/- Recall that the `structure command syntax is
```
leading_parser (structureTk <|> classTk) >> declId >> many Term.bracketedBinder >> optional «extends» >> Term.optType >> optional (" := " >> optional structCtor >> structFields)
```
-/

structure StructCtorView where
  ref       : Syntax
  modifiers : Modifiers
  inferMod  : Bool  -- true if `{}` is used in the constructor declaration
  name      : Name
  declName  : Name

structure StructFieldView where
  ref        : Syntax
  modifiers  : Modifiers
  binderInfo : BinderInfo
  inferMod   : Bool
  declName   : Name
  name       : Name -- The field name as it is going to be registered in the kernel. It does not include macroscopes.
  rawName    : Name -- Same as `name` but including macroscopes.
  binders    : Syntax
  type?      : Option Syntax
  value?     : Option Syntax

structure StructView where
  ref               : Syntax
  modifiers         : Modifiers
  scopeLevelNames   : List Name  -- All `universe` declarations in the current scope
  allUserLevelNames : List Name  -- `scopeLevelNames` ++ explicit universe parameters provided in the `structure` command
  isClass           : Bool
  declName          : Name
  scopeVars         : Array Expr -- All `variable` declaration in the current scope
  params            : Array Expr -- Explicit parameters provided in the `structure` command
  parents           : Array Syntax
  type              : Syntax
  ctor              : StructCtorView
  fields            : Array StructFieldView

inductive StructFieldKind where
  | newField | copiedField | fromParent | subobject
  deriving Inhabited, DecidableEq, Repr

structure StructFieldInfo where
  name     : Name
  declName : Name -- Remark: for `fromParent` fields, `declName` is only relevant in the generation of auxiliary "default value" functions.
  fvar     : Expr
  kind     : StructFieldKind
  inferMod : Bool := false
  value?   : Option Expr := none
  deriving Inhabited, Repr

def StructFieldInfo.isFromParent (info : StructFieldInfo) : Bool :=
  match info.kind with
  | StructFieldKind.fromParent => true
  | _                          => false

def StructFieldInfo.isSubobject (info : StructFieldInfo) : Bool :=
  match info.kind with
  | StructFieldKind.subobject => true
  | _                         => false

/- Auxiliary declaration for `mkProjections` -/
structure ProjectionInfo where
  declName : Name
  inferMod : Bool

structure ElabStructResult where
  decl            : Declaration
  projInfos       : List ProjectionInfo
  projInstances   : List Name -- projections (to parent classes) that must be marked as instances.
  mctx            : MetavarContext
  lctx            : LocalContext
  localInsts      : LocalInstances
  defaultAuxDecls : Array (Name × Expr × Expr)

private def defaultCtorName := `mk

/-
The structure constructor syntax is
```
leading_parser try (declModifiers >> ident >> optional inferMod >> " :: ")
```
-/
private def expandCtor (structStx : Syntax) (structModifiers : Modifiers) (structDeclName : Name) : TermElabM StructCtorView := do
  let useDefault := do
    let declName := structDeclName ++ defaultCtorName
    addAuxDeclarationRanges declName structStx[2] structStx[2]
    pure { ref := structStx, modifiers := {}, inferMod := false, name := defaultCtorName, declName }
  if structStx[5].isNone then
    useDefault
  else
    let optCtor := structStx[5][1]
    if optCtor.isNone then
      useDefault
    else
      let ctor := optCtor[0]
      withRef ctor do
      let ctorModifiers ← elabModifiers ctor[0]
      checkValidCtorModifier ctorModifiers
      if ctorModifiers.isPrivate && structModifiers.isPrivate then
        throwError "invalid 'private' constructor in a 'private' structure"
      if ctorModifiers.isProtected && structModifiers.isPrivate then
        throwError "invalid 'protected' constructor in a 'private' structure"
      let inferMod := !ctor[2].isNone
      let name := ctor[1].getId
      let declName := structDeclName ++ name
      let declName ← applyVisibility ctorModifiers.visibility declName
      addDocString' declName ctorModifiers.docString?
      addAuxDeclarationRanges declName ctor[1] ctor[1]
      pure { ref := ctor, name, modifiers := ctorModifiers, inferMod, declName }

def checkValidFieldModifier (modifiers : Modifiers) : TermElabM Unit := do
  if modifiers.isNoncomputable then
    throwError "invalid use of 'noncomputable' in field declaration"
  if modifiers.isPartial then
    throwError "invalid use of 'partial' in field declaration"
  if modifiers.isUnsafe then
    throwError "invalid use of 'unsafe' in field declaration"
  if modifiers.attrs.size != 0 then
    throwError "invalid use of attributes in field declaration"

/-
```
def structExplicitBinder := leading_parser atomic (declModifiers true >> "(") >> many1 ident >> optional inferMod >> optDeclSig >> optional (Term.binderTactic <|> Term.binderDefault) >> ")"
def structImplicitBinder := leading_parser atomic (declModifiers true >> "{") >> many1 ident >> optional inferMod >> declSig >> "}"
def structInstBinder     := leading_parser atomic (declModifiers true >> "[") >> many1 ident >> optional inferMod >> declSig >> "]"
def structSimpleBinder   := leading_parser atomic (declModifiers true >> ident) >> optional inferMod >> optDeclSig >> optional (Term.binderTactic <|> Term.binderDefault)
def structFields         := leading_parser many (structExplicitBinder <|> structImplicitBinder <|> structInstBinder)
```
-/
private def expandFields (structStx : Syntax) (structModifiers : Modifiers) (structDeclName : Name) : TermElabM (Array StructFieldView) :=
  let fieldBinders := if structStx[5].isNone then #[] else structStx[5][2][0].getArgs
  fieldBinders.foldlM (init := #[]) fun (views : Array StructFieldView) fieldBinder => withRef fieldBinder do
    let mut fieldBinder := fieldBinder
    if fieldBinder.getKind == ``Parser.Command.structSimpleBinder then
      fieldBinder := mkNode ``Parser.Command.structExplicitBinder
        #[ fieldBinder[0], mkAtomFrom fieldBinder "(", mkNullNode #[ fieldBinder[1] ], fieldBinder[2], fieldBinder[3], fieldBinder[4], mkAtomFrom fieldBinder ")" ]
    let k := fieldBinder.getKind
    let binfo ←
      if k == ``Parser.Command.structExplicitBinder then pure BinderInfo.default
      else if k == ``Parser.Command.structImplicitBinder then pure BinderInfo.implicit
      else if k == ``Parser.Command.structInstBinder then pure BinderInfo.instImplicit
      else throwError "unexpected kind of structure field"
    let fieldModifiers ← elabModifiers fieldBinder[0]
    checkValidFieldModifier fieldModifiers
    if fieldModifiers.isPrivate && structModifiers.isPrivate then
      throwError "invalid 'private' field in a 'private' structure"
    if fieldModifiers.isProtected && structModifiers.isPrivate then
      throwError "invalid 'protected' field in a 'private' structure"
    let inferMod         := !fieldBinder[3].isNone
    let (binders, type?) ←
      if binfo == BinderInfo.default then
        let (binders, type?) := expandOptDeclSig fieldBinder[4]
        let optBinderTacticDefault := fieldBinder[5]
        if optBinderTacticDefault.isNone then
          pure (binders, type?)
        else if optBinderTacticDefault[0].getKind != ``Parser.Term.binderTactic then
          pure (binders, type?)
        else
          let binderTactic := optBinderTacticDefault[0]
          match type? with
          | none => throwErrorAt binderTactic "invalid field declaration, type must be provided when auto-param (tactic) is used"
          | some type =>
            let tac := binderTactic[2]
            let name ← Term.declareTacticSyntax tac
            -- The tactic should be for binders+type.
            -- It is safe to reset the binders to a "null" node since there is no value to be elaborated
            let type ← `(forall $(binders.getArgs):bracketedBinder*, $type)
            let type ← `(autoParam $type $(mkIdentFrom tac name))
            pure (mkNullNode, some type)
      else
        let (binders, type) := expandDeclSig fieldBinder[4]
        pure (binders, some type)
    let value? ←
      if binfo != BinderInfo.default then
        pure none
      else
        let optBinderTacticDefault := fieldBinder[5]
        -- trace[Elab.struct] ">>> {optBinderTacticDefault}"
        if optBinderTacticDefault.isNone then
          pure none
        else if optBinderTacticDefault[0].getKind == ``Parser.Term.binderTactic then
          pure none
        else
          -- binderDefault := leading_parser " := " >> termParser
          pure (some optBinderTacticDefault[0][1])
    let idents := fieldBinder[2].getArgs
    idents.foldlM (init := views) fun (views : Array StructFieldView) ident => withRef ident do
      let rawName := ident.getId
      let name    := rawName.eraseMacroScopes
      unless name.isAtomic do
        throwErrorAt ident "invalid field name '{name.eraseMacroScopes}', field names must be atomic"
      let declName := structDeclName ++ name
      let declName ← applyVisibility fieldModifiers.visibility declName
      addDocString' declName fieldModifiers.docString?
      return views.push {
        ref        := ident
        modifiers  := fieldModifiers
        binderInfo := binfo
        inferMod
        declName
        name
        rawName
        binders
        type?
        value?
      }

private def validStructType (type : Expr) : Bool :=
  match type with
  | Expr.sort .. => true
  | _            => false

private def findFieldInfo? (infos : Array StructFieldInfo) (fieldName : Name) : Option StructFieldInfo :=
  infos.find? fun info => info.name == fieldName

private def containsFieldName (infos : Array StructFieldInfo) (fieldName : Name) : Bool :=
  (findFieldInfo? infos fieldName).isSome

private def updateFieldInfoVal (infos : Array StructFieldInfo) (fieldName : Name) (value : Expr) : Array StructFieldInfo :=
  infos.map fun info =>
    if info.name == fieldName then
      { info with value? := value  }
    else
      info

register_builtin_option structureDiamondWarning : Bool := {
  defValue := false
  descr    := "enable/disable warning messages for structure diamonds"
}

/-- Return `some fieldName` if field `fieldName` of the parent structure `parentStructName` is already in `infos` -/
private def findExistingField? (infos : Array StructFieldInfo) (parentStructName : Name) : CoreM (Option Name) := do
  let fieldNames := getStructureFieldsFlattened (← getEnv) parentStructName
  for fieldName in fieldNames do
    if containsFieldName infos fieldName then
      return some fieldName
  return none

private partial def processSubfields (structDeclName : Name) (parentFVar : Expr) (parentStructName : Name) (subfieldNames : Array Name)
    (infos : Array StructFieldInfo) (k : Array StructFieldInfo → TermElabM α) : TermElabM α :=
  go 0 infos
where
  go (i : Nat) (infos : Array StructFieldInfo) := do
    if h : i < subfieldNames.size then
      let subfieldName := subfieldNames.get ⟨i, h⟩
      if containsFieldName infos subfieldName then
        throwError "field '{subfieldName}' from '{parentStructName}' has already been declared"
      let val  ← mkProjection parentFVar subfieldName
      let type ← inferType val
      withLetDecl subfieldName type val fun subfieldFVar =>
        /- The following `declName` is only used for creating the `_default` auxiliary declaration name when
           its default value is overwritten in the structure. If the default value is not overwritten, then its value is irrelevant. -/
        let declName := structDeclName ++ subfieldName
        let infos := infos.push { name := subfieldName, declName, fvar := subfieldFVar, kind := StructFieldKind.fromParent }
        go (i+1) infos
    else
      k infos

/-- Given `obj.foo.bar.baz`, return `obj`. -/
private partial def getNestedProjectionArg (e : Expr) : MetaM Expr := do
  if let Expr.const subProjName .. := e.getAppFn then
    if let some { numParams, .. } ← getProjectionFnInfo? subProjName then
      if e.getAppNumArgs == numParams + 1 then
        return ← getNestedProjectionArg e.appArg!
  return e

/-- Get field type of `fieldName` in `parentStructName`, but replace references
  to other fields of that structure by existing field fvars.
  Auxiliary method for `copyNewFieldsFrom`. -/
private def getFieldType (infos : Array StructFieldInfo) (parentStructName : Name) (parentType : Expr) (fieldName : Name) : MetaM Expr := do
  withLocalDeclD (← mkFreshId) parentType fun parent => do
    let proj ← mkProjection parent fieldName
    let projType ← inferType proj
    /- Eliminate occurrences of `parent.field`. This happens when the structure contains dependent fields.
    If the copied parent extended another structure via a subobject,
    then the occurrence can also look like `parent.toGrandparent.field`
    (where `toGrandparent` is not a field of the current structure). -/
    let visit (e : Expr) : MetaM TransformStep := do
      if let Expr.const subProjName .. := e.getAppFn then
        if let some { ctorName, numParams, .. } ← getProjectionFnInfo? subProjName then
          let Name.str subStructName subFieldName .. := subProjName
            | throwError "invalid projection name {subProjName}"
          let args := e.getAppArgs
          if let some major := args.get? numParams then
            if (← getNestedProjectionArg major) == parent then
              if let some existingFieldInfo := findFieldInfo? infos subFieldName then
                return TransformStep.done <| mkAppN existingFieldInfo.fvar args[numParams+1:args.size]
      return TransformStep.done e
    let projType ← Meta.transform projType (post := visit)
    if projType.containsFVar parent.fvarId! then
      throwError "unsupported dependent field in {fieldName} : {projType}"
    return projType

private def toVisibility (fieldInfo : StructureFieldInfo) : CoreM Visibility := do
  if isProtected (← getEnv) fieldInfo.projFn then
    return Visibility.protected
  else if isPrivateName fieldInfo.projFn then
    return Visibility.private
  else
    return Visibility.regular

abbrev FieldMap := NameMap Expr -- Map from field name to expression representing the field

/-- Reduce projetions of the structures in `structNames` -/
private def reduceProjs (e : Expr) (structNames : NameSet) : MetaM Expr :=
  let reduce (e : Expr) : MetaM TransformStep := do
    match (← reduceProjOf? e structNames.contains) with
    | some v => return TransformStep.done v
    | _ => return TransformStep.done e
  transform e (post := reduce)

/--
  Copy the default value for field `fieldName` set at structure `structName`.
  The arguments for the `_default` auxiliary function are provided by `fieldMap`.
  Recall some of the entries in `fieldMap` are constructor applications, and they needed
  to be reduced using `reduceProjs`. Otherwise, the produced default value may be "cyclic".
  That is, we reduce projections of the structures in `expandedStructNames`. Here is
  an example that shows why the reduction is needed.
  ```
  structure A where
    a : Nat

  structure B where
    a : Nat
    b : Nat
    c : Nat

  structure C extends B where
    d : Nat
    c := b + d

  structure D extends A, C

  #print D.c._default
  ```
  Without the reduction, it produces
  ```
  def D.c._default : A → Nat → Nat → Nat → Nat :=
  fun toA b c d => id ({ a := toA.a, b := b, c := c : B }.b + d)
  ```
-/
private partial def copyDefaultValue? (fieldMap : FieldMap) (expandedStructNames : NameSet) (structName : Name) (fieldName : Name) : TermElabM (Option Expr) := do
  match getDefaultFnForField? (← getEnv) structName fieldName with
  | none => return none
  | some defaultFn =>
    let cinfo ← getConstInfo defaultFn
    let us ← mkFreshLevelMVarsFor cinfo
    go? (cinfo.instantiateValueLevelParams us)
where
  failed : TermElabM (Option Expr) := do
    logWarning s!"ignoring default value for field '{fieldName}' defined at '{structName}'"
    return none

  go? (e : Expr) : TermElabM (Option Expr) := do
    match e with
    | Expr.lam n d b c =>
      if c.binderInfo.isExplicit then
        let fieldName := n
        match fieldMap.find? n with
        | none => failed
        | some val =>
          let valType ← inferType val
          if (← isDefEq valType d) then
            go? (b.instantiate1 val)
          else
            failed
      else
        let arg ← mkFreshExprMVar d
        go? (b.instantiate1 arg)
    | e =>
      let r := if e.isAppOfArity ``id 2 then e.appArg! else e
      return some (← reduceProjs (← instantiateMVars e.appArg!) expandedStructNames)

private partial def copyNewFieldsFrom (structDeclName : Name) (infos : Array StructFieldInfo) (parentType : Expr) (k : Array StructFieldInfo → TermElabM α) : TermElabM α := do
  copyFields infos {} parentType fun infos _ _ => k infos
where
  copyFields (infos : Array StructFieldInfo) (expandedStructNames : NameSet) (parentType : Expr) (k : Array StructFieldInfo → FieldMap → NameSet → TermElabM α) : TermElabM α := do
    let parentStructName ← getStructureName parentType
    let fieldNames := getStructureFields (← getEnv) parentStructName
    let rec copy (i : Nat) (infos : Array StructFieldInfo) (fieldMap : FieldMap) (expandedStructNames : NameSet) : TermElabM α := do
      if h : i < fieldNames.size then
        let fieldName := fieldNames.get ⟨i, h⟩
        let fieldType ← getFieldType infos parentStructName parentType fieldName
        match findFieldInfo? infos fieldName with
        | some existingFieldInfo =>
          let existingFieldType ← inferType existingFieldInfo.fvar
          unless (← isDefEq fieldType existingFieldType) do
            throwError "parent field type mismatch, field '{fieldName}' from parent '{parentStructName}' {← mkHasTypeButIsExpectedMsg fieldType existingFieldType}"
          /- Remark: if structure has a default value for this field, it will be set at the `processOveriddenDefaultValues` below. -/
          copy (i+1) infos (fieldMap.insert fieldName existingFieldInfo.fvar) expandedStructNames
        | none =>
          let some fieldInfo := getFieldInfo? (← getEnv) parentStructName fieldName | unreachable!
          let addNewField : TermElabM α := do
            let value? ← copyDefaultValue? fieldMap expandedStructNames parentStructName fieldName
            withLocalDecl fieldName fieldInfo.binderInfo fieldType fun fieldFVar => do
              let fieldDeclName := structDeclName ++ fieldName
              let fieldDeclName ← applyVisibility (← toVisibility fieldInfo) fieldDeclName
              let infos := infos.push { name := fieldName, declName := fieldDeclName, fvar := fieldFVar, value?,
                                        kind := StructFieldKind.copiedField, inferMod := fieldInfo.inferMod }
              copy (i+1) infos (fieldMap.insert fieldName fieldFVar) expandedStructNames
          if fieldInfo.subobject?.isSome then
            let fieldParentStructName ← getStructureName fieldType
            if (← findExistingField? infos fieldParentStructName).isSome then
              -- See comment at `copyDefaultValue?`
              let expandedStructNames := expandedStructNames.insert fieldParentStructName
              copyFields infos expandedStructNames fieldType fun infos nestedFieldMap expandedStructNames => do
                let fieldVal ← mkCompositeField fieldType nestedFieldMap
                trace[Meta.debug] "composite, {fieldName} := {fieldVal}"
                copy (i+1) infos (fieldMap.insert fieldName fieldVal) expandedStructNames
            else
              let subfieldNames := getStructureFieldsFlattened (← getEnv) fieldParentStructName
              let fieldName := fieldInfo.fieldName
              withLocalDecl fieldName fieldInfo.binderInfo fieldType fun parentFVar =>
                let infos := infos.push { name := fieldName, declName := structDeclName ++ fieldName, fvar := parentFVar, kind := StructFieldKind.subobject }
                processSubfields structDeclName parentFVar fieldParentStructName subfieldNames infos fun infos =>
                  copy (i+1) infos (fieldMap.insert fieldName parentFVar) expandedStructNames
          else
            addNewField
      else
        let infos ← processOveriddenDefaultValues infos fieldMap expandedStructNames parentStructName
        k infos fieldMap expandedStructNames
    copy 0 infos {} expandedStructNames

  processOveriddenDefaultValues (infos : Array StructFieldInfo) (fieldMap : FieldMap) (expandedStructNames : NameSet) (parentStructName : Name) : TermElabM (Array StructFieldInfo) :=
    infos.mapM fun info => do
      match (← copyDefaultValue? fieldMap expandedStructNames parentStructName info.name) with
      | some value => return { info with value? := value }
      | none       => return info

  mkCompositeField (parentType : Expr) (fieldMap : FieldMap) : TermElabM Expr := do
    let env ← getEnv
    let Expr.const parentStructName us _ ← pure parentType.getAppFn | unreachable!
    let parentCtor := getStructureCtor env parentStructName
    let mut result := mkAppN (mkConst parentCtor.name us) parentType.getAppArgs
    for fieldName in getStructureFields env parentStructName do
      match fieldMap.find? fieldName with
      | some val => result := mkApp result val
      | none => throwError "failed to copy fields from parent structure{indentExpr parentType}" -- TODO improve error message
    return result

private partial def mkToParentName (parentStructName : Name) (p : Name → Bool) : Name := Id.run <| do
  let base := Name.mkSimple $ "to" ++ parentStructName.eraseMacroScopes.getString!
  if p base then
    base
  else
    let rec go (i : Nat) : Name :=
      let curr := base.appendIndexAfter i
      if p curr then curr else go (i+1)
    go 1

private partial def withParents (view : StructView) (k : Array StructFieldInfo → Array Expr → TermElabM α) : TermElabM α := do
  go 0 #[] #[]
where
  go (i : Nat) (infos : Array StructFieldInfo) (copiedParents : Array Expr) : TermElabM α := do
    if h : i < view.parents.size then
      let parentStx := view.parents.get ⟨i, h⟩
      withRef parentStx do
      let parentType ← Term.elabType parentStx
      let parentStructName ← getStructureName parentType
      if let some existingFieldName ← findExistingField? infos parentStructName then
        if structureDiamondWarning.get (← getOptions) then
          logWarning s!"field '{existingFieldName}' from '{parentStructName}' has already been declared"
        copyNewFieldsFrom view.declName infos parentType fun infos => go (i+1) infos (copiedParents.push parentType)
        -- TODO: if `class`, then we need to create a let-decl that stores the local instance for the `parentStructure`
      else
        let env ← getEnv
        let subfieldNames := getStructureFieldsFlattened env parentStructName
        let toParentName := mkToParentName parentStructName fun n => !containsFieldName infos n && !subfieldNames.contains n
        let binfo := if view.isClass && isClass env parentStructName then BinderInfo.instImplicit else BinderInfo.default
        withLocalDecl toParentName binfo parentType fun parentFVar =>
          let infos := infos.push { name := toParentName, declName := view.declName ++ toParentName, fvar := parentFVar, kind := StructFieldKind.subobject }
          processSubfields view.declName parentFVar parentStructName subfieldNames infos fun infos => go (i+1) infos copiedParents
    else
      k infos copiedParents

private def elabFieldTypeValue (view : StructFieldView) : TermElabM (Option Expr × Option Expr) := do
  Term.withAutoBoundImplicit <| Term.elabBinders view.binders.getArgs fun params => do
    match view.type? with
    | none         =>
      match view.value? with
      | none        => return (none, none)
      | some valStx =>
        Term.synthesizeSyntheticMVarsNoPostponing
        let params ← Term.addAutoBoundImplicits params
        let value ← Term.elabTerm valStx none
        let value ← mkLambdaFVars params value
        return (none, value)
    | some typeStx =>
      let type ← Term.elabType typeStx
      Term.synthesizeSyntheticMVarsNoPostponing
      let params ← Term.addAutoBoundImplicits params
      match view.value? with
      | none        =>
        let type  ← mkForallFVars params type
        return (type, none)
      | some valStx =>
        let value ← Term.elabTermEnsuringType valStx type
        Term.synthesizeSyntheticMVarsNoPostponing
        let type  ← mkForallFVars params type
        let value ← mkLambdaFVars params value
        return (type, value)

private partial def withFields (views : Array StructFieldView) (infos : Array StructFieldInfo) (k : Array StructFieldInfo → TermElabM α) : TermElabM α := do
  go 0 {} infos
where
  go (i : Nat) (defaultValsOverridden : NameSet) (infos : Array StructFieldInfo) : TermElabM α := do
    if h : i < views.size then
      let view := views.get ⟨i, h⟩
      withRef view.ref do
      match findFieldInfo? infos view.name with
      | none      =>
        let (type?, value?) ← elabFieldTypeValue view
        match type?, value? with
        | none,      none => throwError "invalid field, type expected"
        | some type, _    =>
          withLocalDecl view.rawName view.binderInfo type fun fieldFVar =>
            let infos := infos.push { name := view.name, declName := view.declName, fvar := fieldFVar, value? := value?,
                                      kind := StructFieldKind.newField, inferMod := view.inferMod }
            go (i+1) defaultValsOverridden infos
        | none, some value =>
          let type ← inferType value
          withLocalDecl view.rawName view.binderInfo type fun fieldFVar =>
            let infos := infos.push { name := view.name, declName := view.declName, fvar := fieldFVar, value? := value,
                                      kind := StructFieldKind.newField, inferMod := view.inferMod }
            go (i+1) defaultValsOverridden infos
      | some info =>
        let updateDefaultValue (fromParent : Bool) : TermElabM α := do
          match view.value? with
          | none       => throwError "field '{view.name}' has been declared in parent structure"
          | some valStx =>
            if let some type := view.type? then
              throwErrorAt type "omit field '{view.name}' type to set default value"
            else
              if defaultValsOverridden.contains info.name then
                throwError "field '{view.name}' new default value has already been set"
              let defaultValsOverridden := defaultValsOverridden.insert info.name
              let mut valStx := valStx
              if view.binders.getArgs.size > 0 then
                valStx ← `(fun $(view.binders.getArgs)* => $valStx:term)
              let fvarType ← inferType info.fvar
              let value ← Term.elabTermEnsuringType valStx fvarType
              let infos := updateFieldInfoVal infos info.name value
              go (i+1) defaultValsOverridden infos
        match info.kind with
        | StructFieldKind.newField    => throwError "field '{view.name}' has already been declared"
        | StructFieldKind.subobject   => throwError "unexpected subobject field reference" -- improve error message
        | StructFieldKind.copiedField => updateDefaultValue false
        | StructFieldKind.fromParent  => updateDefaultValue true
    else
      k infos

private def getResultUniverse (type : Expr) : TermElabM Level := do
  let type ← whnf type
  match type with
  | Expr.sort u _ => pure u
  | _             => throwError "unexpected structure resulting type"

private def collectUsed (params : Array Expr) (fieldInfos : Array StructFieldInfo) : StateRefT CollectFVars.State MetaM Unit := do
  params.forM fun p => do
    let type ← inferType p
    Meta.collectUsedFVars type
  fieldInfos.forM fun info => do
    let fvarType ← inferType info.fvar
    Meta.collectUsedFVars fvarType
    match info.value? with
    | none       => pure ()
    | some value => Meta.collectUsedFVars value

private def removeUnused (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo)
    : TermElabM (LocalContext × LocalInstances × Array Expr) := do
  let (_, used) ← (collectUsed params fieldInfos).run {}
  Meta.removeUnused scopeVars used

private def withUsed {α} (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo) (k : Array Expr → TermElabM α)
    : TermElabM α := do
  let (lctx, localInsts, vars) ← removeUnused scopeVars params fieldInfos
  withLCtx lctx localInsts <| k vars

private def levelMVarToParamFVar (fvar : Expr) : StateRefT Nat TermElabM Unit := do
  let type ← inferType fvar
  discard <| Term.levelMVarToParam' type

private def levelMVarToParamFVars (fvars : Array Expr) : StateRefT Nat TermElabM Unit :=
  fvars.forM levelMVarToParamFVar

private def levelMVarToParamAux (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo)
    : StateRefT Nat TermElabM (Array StructFieldInfo) := do
  levelMVarToParamFVars scopeVars
  levelMVarToParamFVars params
  fieldInfos.mapM fun info => do
    levelMVarToParamFVar info.fvar
    match info.value? with
    | none       => pure info
    | some value =>
      let value ← Term.levelMVarToParam' value
      pure { info with value? := value }

private def levelMVarToParam (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo) : TermElabM (Array StructFieldInfo) :=
  (levelMVarToParamAux scopeVars params fieldInfos).run' 1

private partial def collectUniversesFromFields (r : Level) (rOffset : Nat) (fieldInfos : Array StructFieldInfo) : TermElabM (Array Level) := do
  fieldInfos.foldlM (init := #[]) fun (us : Array Level) (info : StructFieldInfo) => do
    let type ← inferType info.fvar
    let u ← getLevel type
    let u ← instantiateLevelMVars u
    accLevelAtCtor u r rOffset us

private def updateResultingUniverse (fieldInfos : Array StructFieldInfo) (type : Expr) : TermElabM Expr := do
  let r ← getResultUniverse type
  let rOffset : Nat   := r.getOffset
  let r       : Level := r.getLevelOffset
  match r with
  | Level.mvar mvarId _ =>
    let us ← collectUniversesFromFields r rOffset fieldInfos
    let rNew := mkResultUniverse us rOffset
    assignLevelMVar mvarId rNew
    instantiateMVars type
  | _ => throwError "failed to compute resulting universe level of structure, provide universe explicitly"

private def collectLevelParamsInFVar (s : CollectLevelParams.State) (fvar : Expr) : TermElabM CollectLevelParams.State := do
  let type ← inferType fvar
  let type ← instantiateMVars type
  return collectLevelParams s type

private def collectLevelParamsInFVars (fvars : Array Expr) (s : CollectLevelParams.State) : TermElabM CollectLevelParams.State :=
  fvars.foldlM collectLevelParamsInFVar s

private def collectLevelParamsInStructure (structType : Expr) (scopeVars : Array Expr) (params : Array Expr) (fieldInfos : Array StructFieldInfo)
    : TermElabM (Array Name) := do
  let s := collectLevelParams {} structType
  let s ← collectLevelParamsInFVars scopeVars s
  let s ← collectLevelParamsInFVars params s
  let s ← fieldInfos.foldlM (init := s) fun s info => collectLevelParamsInFVar s info.fvar
  return s.params

private def addCtorFields (fieldInfos : Array StructFieldInfo) : Nat → Expr → TermElabM Expr
  | 0,   type => pure type
  | i+1, type => do
    let info := fieldInfos[i]
    let decl ← Term.getFVarLocalDecl! info.fvar
    let type ← instantiateMVars type
    let type := type.abstract #[info.fvar]
    match info.kind with
    | StructFieldKind.fromParent =>
      let val := decl.value
      addCtorFields fieldInfos i (type.instantiate1 val)
    | _  =>
      addCtorFields fieldInfos i (mkForall decl.userName decl.binderInfo decl.type type)

private def mkCtor (view : StructView) (levelParams : List Name) (params : Array Expr) (fieldInfos : Array StructFieldInfo) : TermElabM Constructor :=
  withRef view.ref do
  let type := mkAppN (mkConst view.declName (levelParams.map mkLevelParam)) params
  let type ← addCtorFields fieldInfos fieldInfos.size type
  let type ← mkForallFVars params type
  let type ← instantiateMVars type
  let type := type.inferImplicit params.size !view.ctor.inferMod
  -- trace[Meta.debug] "ctor type {type}"
  pure { name := view.ctor.declName, type }

@[extern "lean_mk_projections"]
private constant mkProjections (env : Environment) (structName : Name) (projs : List ProjectionInfo) (isClass : Bool) : Except KernelException Environment

private def addProjections (structName : Name) (projs : List ProjectionInfo) (isClass : Bool) : TermElabM Unit := do
  let env ← getEnv
  match mkProjections env structName projs isClass with
  | Except.ok env   => setEnv env
  | Except.error ex => throwKernelException ex

private def registerStructure (structName : Name) (infos : Array StructFieldInfo) : TermElabM Unit := do
  let fields ← infos.filterMapM fun info => do
      if info.kind == StructFieldKind.fromParent then
        return none
      else
        return some {
          fieldName  := info.name
          projFn     := info.declName
          inferMod   := info.inferMod
          binderInfo := (← getFVarLocalDecl info.fvar).binderInfo
          subobject? :=
            if info.kind == StructFieldKind.subobject then
              match (← getEnv).find? info.declName with
              | some (ConstantInfo.defnInfo val) =>
                match val.type.getForallBody.getAppFn with
                | Expr.const parentName .. => some parentName
                | _ => panic! "ill-formed structure"
              | _ => panic! "ill-formed environment"
            else
              none
        }
  modifyEnv fun env => Lean.registerStructure env { structName, fields }

private def mkAuxConstructions (declName : Name) : TermElabM Unit := do
  let env ← getEnv
  let hasUnit := env.contains `PUnit
  let hasEq   := env.contains `Eq
  let hasHEq  := env.contains `HEq
  mkRecOn declName
  if hasUnit then mkCasesOn declName
  if hasUnit && hasEq && hasHEq then mkNoConfusion declName

private def addDefaults (lctx : LocalContext) (defaultAuxDecls : Array (Name × Expr × Expr)) : TermElabM Unit := do
  let localInsts ← getLocalInstances
  withLCtx lctx localInsts do
    defaultAuxDecls.forM fun (declName, type, value) => do
      let value ← instantiateMVars value
      if value.hasExprMVar then
        throwError "invalid default value for field, it contains metavariables{indentExpr value}"
      /- The identity function is used as "marker". -/
      let value ← mkId value
      discard <| mkAuxDefinition declName type value (zeta := true)
      setReducibleAttribute declName

private partial def mkCoercionToCopiedParent (levelParams : List Name) (params : Array Expr) (view : StructView) (parentType : Expr) : MetaM Unit := do
  let env ← getEnv
  let structName := view.declName
  let sourceFieldNames := getStructureFieldsFlattened env structName
  let structType := mkAppN (Lean.mkConst structName (levelParams.map mkLevelParam)) params
  let Expr.const parentStructName us _ ← pure parentType.getAppFn | unreachable!
  let binfo := if view.isClass && isClass env parentStructName then BinderInfo.instImplicit else BinderInfo.default
  withLocalDecl `self binfo structType fun source => do
    let declType ← instantiateMVars (← mkForallFVars params (← mkForallFVars #[source] parentType))
    let declType := declType.inferImplicit params.size true
    let rec copyFields (parentType : Expr) : MetaM Expr := do
      let Expr.const parentStructName us _ ← pure parentType.getAppFn | unreachable!
      let parentCtor := getStructureCtor env parentStructName
      let mut result := mkAppN (mkConst parentCtor.name us) parentType.getAppArgs
      for fieldName in getStructureFields env parentStructName do
        if sourceFieldNames.contains fieldName then
          let fieldVal ← mkProjection source fieldName
          result := mkApp result fieldVal
        else
          -- fieldInfo must be a field of `parentStructName`
          let some fieldInfo := getFieldInfo? env parentStructName fieldName | unreachable!
          if fieldInfo.subobject?.isNone then throwError "failed to build coercion to parent structure"
          let resultType ← whnfD (← inferType result)
          unless resultType.isForall do throwError "failed to build coercion to parent structure, unexpect type{indentExpr resultType}"
          let fieldVal ← copyFields resultType.bindingDomain!
          result := mkApp result fieldVal
      return result
    let declVal ← instantiateMVars (← mkLambdaFVars params (← mkLambdaFVars #[source] (← copyFields parentType)))
    let declName := structName ++ mkToParentName (← getStructureName parentType) fun n => !env.contains (structName ++ n)
    addAndCompile <| Declaration.defnDecl {
      name        := declName
      levelParams := levelParams
      type        := declType
      value       := declVal
      hints       := ReducibilityHints.abbrev
      safety      := if view.modifiers.isUnsafe then DefinitionSafety.unsafe else DefinitionSafety.safe
    }
    if binfo.isInstImplicit then
      addInstance declName AttributeKind.global (eval_prio default)
    else
      setReducibleAttribute declName

private def elabStructureView (view : StructView) : TermElabM Unit := do
  view.fields.forM fun field => do
    if field.declName == view.ctor.declName then
      throwErrorAt field.ref "invalid field name '{field.name}', it is equal to structure constructor name"
    addAuxDeclarationRanges field.declName field.ref field.ref
  let numExplicitParams := view.params.size
  let type ← Term.elabType view.type
  unless validStructType type do throwErrorAt view.type "expected Type"
  withRef view.ref do
  withParents view fun fieldInfos copiedParents => do
  withFields view.fields fieldInfos fun fieldInfos => do
    Term.synthesizeSyntheticMVarsNoPostponing
    let u ← getResultUniverse type
    let inferLevel ← shouldInferResultUniverse u
    withUsed view.scopeVars view.params fieldInfos fun scopeVars => do
      let numParams := scopeVars.size + numExplicitParams
      let fieldInfos ← levelMVarToParam scopeVars view.params fieldInfos
      let type ← withRef view.ref do
        if inferLevel then
          updateResultingUniverse fieldInfos type
        else
          checkResultingUniverse (← getResultUniverse type)
          pure type
      trace[Elab.structure] "type: {type}"
      let usedLevelNames ← collectLevelParamsInStructure type scopeVars view.params fieldInfos
      match sortDeclLevelParams view.scopeLevelNames view.allUserLevelNames usedLevelNames with
      | Except.error msg      => withRef view.ref <| throwError msg
      | Except.ok levelParams =>
        let params := scopeVars ++ view.params
        let ctor ← mkCtor view levelParams params fieldInfos
        let type ← mkForallFVars params type
        let type ← instantiateMVars type
        let indType := { name := view.declName, type := type, ctors := [ctor] : InductiveType }
        let decl    := Declaration.inductDecl levelParams params.size [indType] view.modifiers.isUnsafe
        Term.ensureNoUnassignedMVars decl
        addDecl decl
        let projInfos := (fieldInfos.filter fun (info : StructFieldInfo) => !info.isFromParent).toList.map fun (info : StructFieldInfo) =>
          { declName := info.declName, inferMod := info.inferMod : ProjectionInfo }
        addProjections view.declName projInfos view.isClass
        registerStructure view.declName fieldInfos
        mkAuxConstructions view.declName
        let instParents ← fieldInfos.filterM fun info => do
          let decl ← Term.getFVarLocalDecl! info.fvar
          pure (info.isSubobject && decl.binderInfo.isInstImplicit)
        withSaveInfoContext do  -- save new env
          Term.addTermInfo view.ref[1] (← mkConstWithLevelParams view.declName) (isBinder := true)
          if let some _ := view.ctor.ref[1].getPos? (originalOnly := true) then
            Term.addTermInfo view.ctor.ref[1] (← mkConstWithLevelParams view.ctor.declName) (isBinder := true)
          for field in view.fields do
            -- may not exist if overriding inherited field
            if (← getEnv).contains field.declName then
              Term.addTermInfo field.ref (← mkConstWithLevelParams field.declName) (isBinder := true)
        Term.applyAttributesAt view.declName view.modifiers.attrs AttributeApplicationTime.afterTypeChecking
        let projInstances := instParents.toList.map fun info => info.declName
        projInstances.forM fun declName => addInstance declName AttributeKind.global (eval_prio default)
        copiedParents.forM fun parent => mkCoercionToCopiedParent levelParams params view parent
        let lctx ← getLCtx
        let fieldsWithDefault := fieldInfos.filter fun info => info.value?.isSome
        let defaultAuxDecls ← fieldsWithDefault.mapM fun info => do
          let type ← inferType info.fvar
          pure (mkDefaultFnOfProjFn info.declName, type, info.value?.get!)
        /- The `lctx` and `defaultAuxDecls` are used to create the auxiliary "default value" declarations
           The parameters `params` for these definitions must be marked as implicit, and all others as explicit. -/
        let lctx :=
          params.foldl (init := lctx) fun (lctx : LocalContext) (p : Expr) =>
            lctx.setBinderInfo p.fvarId! BinderInfo.implicit
        let lctx :=
          fieldInfos.foldl (init := lctx) fun (lctx : LocalContext) (info : StructFieldInfo) =>
            if info.isFromParent then lctx -- `fromParent` fields are elaborated as let-decls, and are zeta-expanded when creating "default value" auxiliary functions
            else lctx.setBinderInfo info.fvar.fvarId! BinderInfo.default
        addDefaults lctx defaultAuxDecls

/-
leading_parser (structureTk <|> classTk) >> declId >> many Term.bracketedBinder >> optional «extends» >> Term.optType >> " := " >> optional structCtor >> structFields >> optDeriving

where
def «extends» := leading_parser " extends " >> sepBy1 termParser ", "
def typeSpec := leading_parser " : " >> termParser
def optType : Parser := optional typeSpec

def structFields         := leading_parser many (structExplicitBinder <|> structImplicitBinder <|> structInstBinder)
def structCtor           := leading_parser try (declModifiers >> ident >> optional inferMod >> " :: ")

-/
def elabStructure (modifiers : Modifiers) (stx : Syntax) : CommandElabM Unit := do
  checkValidInductiveModifier modifiers
  let isClass   := stx[0].getKind == ``Parser.Command.classTk
  let modifiers := if isClass then modifiers.addAttribute { name := `class } else modifiers
  let declId    := stx[1]
  let params    := stx[2].getArgs
  let exts      := stx[3]
  let parents   := if exts.isNone then #[] else exts[0][1].getSepArgs
  let optType   := stx[4]
  let derivingClassViews ← getOptDerivingClasses stx[6]
  let type ← if optType.isNone then `(Sort _) else pure optType[0][1]
  let declName ←
    runTermElabM none fun scopeVars => do
      let scopeLevelNames ← Term.getLevelNames
      let ⟨name, declName, allUserLevelNames⟩ ← Elab.expandDeclId (← getCurrNamespace) scopeLevelNames declId modifiers
      addDeclarationRanges declName stx
      Term.withDeclName declName do
        let ctor ← expandCtor stx modifiers declName
        let fields ← expandFields stx modifiers declName
        Term.withLevelNames allUserLevelNames <| Term.withAutoBoundImplicit <|
          Term.elabBinders params fun params => do
            Term.synthesizeSyntheticMVarsNoPostponing
            let params ← Term.addAutoBoundImplicits params
            let allUserLevelNames ← Term.getLevelNames
            elabStructureView {
              ref := stx
              modifiers
              scopeLevelNames
              allUserLevelNames
              declName
              isClass
              scopeVars
              params
              parents
              type
              ctor
              fields
            }
            unless isClass do
              mkSizeOfInstances declName
              mkInjectiveTheorems declName
            return declName
  derivingClassViews.forM fun view => view.applyHandlers #[declName]

builtin_initialize registerTraceClass `Elab.structure

end Lean.Elab.Command


import for_mathlib.algebraic_topology.homotopical_algebra.bifibrant_replacement
import for_mathlib.algebraic_topology.homotopical_algebra.cofibrant_replacement

noncomputable theory

open category_theory category_theory.limits category_theory.category category_theory

namespace algebraic_topology

namespace model_category

variables {C : Type*} [category C] [model_category C]

variables {Hcof : Type*} [category Hcof] (Lcof : cofibrant_object C ⥤ Hcof)
  [Lcof.is_localization cofibrant_object.weq]

lemma Lcof_map_surjective_both_fibrant (X Y : cofibrant_object C)
  [is_fibrant X.obj] [is_fibrant Y.obj] :
  function.surjective (@category_theory.functor.map _ _ _ _ Lcof X Y) := λ f,
begin
  unfreezingI { rcases X with ⟨X, Xcof⟩, rcases Y with ⟨Y, Ycof⟩, },
  let X' := bifibrant_object.mk X,
  let Y' := bifibrant_object.mk Y,
  let f' : (bifibrant_object.forget_fib C ⋙ Lcof).obj X' ⟶
    (bifibrant_object.forget_fib C ⋙ Lcof).obj Y' := f,
  refine ⟨(bifibrant_object.forget_fib C).map
    ((bifibrant_object.forget_fib C ⋙ Lcof).preimage f'), _⟩,
  rw [← functor.comp_map, functor.image_preimage],
end

lemma Lcof_map_eq_iff_bifibrant_Q_map_eq {X Y : bifibrant_object C} (f₁ f₂ : X ⟶ Y) :
  Lcof.map ((bifibrant_object.forget_fib C).map f₁) =
    Lcof.map ((bifibrant_object.forget_fib C).map f₂) ↔
  bifibrant_object.homotopy_category.Q.map f₁ = bifibrant_object.homotopy_category.Q.map f₂ :=
begin
  erw ← functor.map_eq_iff_of_nat_iso (Lbif_comp_Hobif_to_Hocof_iso Lcof
    bifibrant_object.homotopy_category.Q),
  dsimp only [functor.comp_map],
  apply (Hobif_to_Hocof Lcof bifibrant_object.homotopy_category.Q).map_eq_iff,
end

lemma Lcof_map_surjective (X Y : cofibrant_object C) [is_fibrant Y.obj] :
  function.surjective (@category_theory.functor.map _ _ _ _ Lcof X Y) := λ g,
begin
  let X' := cofibrant_object.mk (CM5a.obj (terminal.from X.obj)),
  let f : X ⟶ X' := CM5a.i (terminal.from X.obj),
  have hf : cofibrant_object.weq f,
  { change model_category.weq (CM5a.i (terminal.from X.obj)),
    exact weak_eq.property, },
  haveI : is_iso (Lcof.map f) := is_iso_Lcof_map' Lcof f hf,
  rcases Lcof_map_surjective_both_fibrant Lcof _ _ (inv (Lcof.map f) ≫ g) with ⟨φ, hφ⟩,
  exact ⟨f ≫ φ, by rw [Lcof.map_comp, hφ, is_iso.hom_inv_id_assoc]⟩,
end

lemma Lcof_map_eq_iff'_both_fibrant {X Y : cofibrant_object C} [is_fibrant X.obj] [is_fibrant Y.obj]
  (P : path_object Y.obj) (f₁ f₂ : X ⟶ Y) :
  Lcof.map f₁ = Lcof.map f₂ ↔ nonempty (model_category.right_homotopy P.pre f₁ f₂) :=
begin
  unfreezingI { rcases X with ⟨X, Xcof⟩, rcases Y with ⟨Y, Ycof⟩, },
  let g₁ : bifibrant_object.mk X ⟶ bifibrant_object.mk Y := f₁,
  let g₂ : bifibrant_object.mk X ⟶ bifibrant_object.mk Y := f₂,
  let P' : path_object (bifibrant_object.mk Y).obj := P,
  erw ← bifibrant_object.homotopy_category.Q_map_eq_iff' P' g₁ g₂,
  erw ← functor.map_eq_iff_of_nat_iso (Lbif_comp_Hobif_to_Hocof_iso Lcof
    bifibrant_object.homotopy_category.Q) g₁ g₂,
  dsimp only [functor.comp_map],
  apply (Hobif_to_Hocof Lcof bifibrant_object.homotopy_category.Q).map_eq_iff,
end

lemma Lcof_map_eq_iff' {X Y : cofibrant_object C} [is_fibrant Y.obj] (P : path_object Y.obj)
  (f₁ f₂ : X ⟶ Y) :
  Lcof.map f₁ = Lcof.map f₂ ↔ nonempty (model_category.right_homotopy P.pre f₁ f₂) :=
begin
  split,
  { intro h,
    let X' := CM5a.obj (terminal.from X.obj),
    let i : X.obj ⟶ X' := CM5a.i (terminal.from X.obj),
    have sq₁ : comm_sq ((cofibrant_object.forget C).map f₁) i (terminal.from Y.obj) (terminal.from X') := by tidy,
    have sq₂ : comm_sq ((cofibrant_object.forget C).map f₂) i (terminal.from Y.obj) (terminal.from X') := by tidy,
    let g₁ : cofibrant_object.mk X' ⟶ Y := sq₁.lift,
    let g₂ : cofibrant_object.mk X' ⟶ Y := sq₂.lift,
    have eq : Lcof.map g₁ = Lcof.map g₂,
    { let j : X ⟶ cofibrant_object.mk X' := i,
      haveI : weak_eq ((cofibrant_object.forget C).map j) := by { dsimp [j], apply_instance, },
      haveI := is_iso_Lcof_map Lcof j,
      simp only [← cancel_epi (Lcof.map j), ← functor.map_comp],
      convert h,
      exacts [sq₁.fac_left, sq₂.fac_left], },
    rw Lcof_map_eq_iff'_both_fibrant Lcof P g₁ g₂ at eq,
    convert nonempty.intro (eq.some.comp_left i),
    exacts [sq₁.fac_left.symm, sq₂.fac_left.symm], },
  { intro h,
    change (cofibrant_replacement.π Lcof).map (cofibrant_object.homotopy_category.Q.map f₁) =
      (cofibrant_replacement.π Lcof).map (cofibrant_object.homotopy_category.Q.map f₂),
    congr' 1,
    apply category_theory.quotient.sound,
    exact cofibrant_object.right_homotopy.trans_closure.mk
      (cofibrant_object.right_homotopy.mk P h.some), },
end

lemma Lcof_map_eq_iff {X Y : cofibrant_object C} [is_fibrant Y.obj] (Cyl : cylinder X.obj)
  (f₁ f₂ : X ⟶ Y) :
  Lcof.map f₁ = Lcof.map f₂ ↔ nonempty (left_homotopy Cyl.pre f₁ f₂) :=
begin
  let P := path_object.some Y.obj,
  rw Lcof_map_eq_iff' Lcof P,
  split,
  { exact λ h, nonempty.intro (h.some.to_left_homotopy Cyl), },
  { exact λ h, nonempty.intro (h.some.to_right_homotopy P), },
end

namespace fundamental_lemma

variables {Ho : Type*} [category Ho] (L : C ⥤ Ho) [L.is_localization weq] (C)

variables {C}

lemma map_surjective (X Y : C) [is_cofibrant X] [is_fibrant Y] :
  function.surjective (@category_theory.functor.map _ _ _ _ L X Y) :=
begin
  let Y' := CM5b.obj (initial.to Y),
  suffices : function.surjective (@category_theory.functor.map _ _ _ _ L X Y'),
  { intro g,
    let p : Y' ⟶ Y := CM5b.p (initial.to Y),
    haveI := localization.inverts L weq p weak_eq.property,
    rcases this (g ≫ inv (L.map p)) with ⟨φ, hφ⟩,
    exact ⟨φ ≫ p, by rw [L.map_comp, hφ, assoc, is_iso.inv_hom_id, comp_id]⟩, },
  suffices : ∀ (A B : cofibrant_object C) [is_fibrant B.obj], function.surjective
    (@category_theory.functor.map _ _ _ _ (cofibrant_object.forget C ⋙ L) A B),
  { exact this (cofibrant_object.mk X) (cofibrant_object.mk Y'), },
  simp only [← functor.function_surjective_map_iff_of_iso (Lcof_comp_Hocof_to_Ho_iso Lcof' L)],
  introsI A B hB,
  exact function.surjective.comp (Hocof_to_Ho Lcof' L).map_surjective
    (Lcof_map_surjective Lcof' A B),
end

instance {X Y : C} (f : X ⟶ Y) [weak_eq f] : is_iso (L.map f) :=
localization.inverts L weq f weak_eq.property

lemma map_eq_of_left_homotopy {X Y : C} {f₁ f₂ : X ⟶ Y} {P : precylinder X}
  (h : left_homotopy P f₁ f₂) : L.map f₁ = L.map f₂ :=
begin
  simp only [← h.h₀, ← h.h₁, L.map_comp],
  congr' 1,
  simp only [← cancel_mono (L.map P.σ), ← L.map_comp, P.σd₀, P.σd₁],
end

lemma map_eq_iff {X Y : C} [is_cofibrant X] [is_fibrant Y] (Cyl : cylinder X) (f₁ f₂ : X ⟶ Y) :
  L.map f₁ = L.map f₂ ↔ nonempty (left_homotopy Cyl.pre f₁ f₂) :=
begin
  split,
  { intro h,
    let Y' := CM5b.obj (initial.to Y),
    let i : Y' ⟶ Y := CM5b.p (initial.to Y),
    have sq₁ : comm_sq (initial.to Y') (initial.to X) i f₁ := by tidy,
    have sq₂ : comm_sq (initial.to Y') (initial.to X) i f₂ := by tidy,
    let g₁ : cofibrant_object.mk X ⟶ cofibrant_object.mk Y' := sq₁.lift,
    let g₂ : cofibrant_object.mk X ⟶ cofibrant_object.mk Y' := sq₂.lift,
    haveI := localization.inverts L weq i weak_eq.property,
    rw [← sq₁.fac_right, ← sq₂.fac_right, L.map_comp, L.map_comp,
      cancel_mono] at h,
    change (cofibrant_object.forget C ⋙ L).map g₁ =
      (cofibrant_object.forget C ⋙ L).map g₂ at h,
    rw ← functor.map_eq_iff_of_nat_iso (Lcof_comp_Hocof_to_Ho_iso Lcof' L) at h,
    have h' := (Hocof_to_Ho Lcof' L).map_injective h,
    let Cyl' : cylinder (cofibrant_object.mk X).obj := Cyl,
    rw Lcof_map_eq_iff Lcof' Cyl' g₁ g₂ at h',
    rw [← sq₁.fac_right, ← sq₂.fac_right],
    exact nonempty.intro (h'.some.comp_right i), },
  { intro h,
    exact map_eq_of_left_homotopy L h.some, },
end

lemma map_eq_iff' {X Y : C} [is_cofibrant X] [is_fibrant Y] (P : path_object Y) (f₁ f₂ : X ⟶ Y) :
  L.map f₁ = L.map f₂ ↔ nonempty (right_homotopy P.pre f₁ f₂) :=
begin
  let Cyl := cylinder.some X,
  rw map_eq_iff L Cyl f₁ f₂,
  split,
  { exact λ h, nonempty.intro (h.some.to_right_homotopy P), },
  { exact λ h, nonempty.intro (h.some.to_left_homotopy Cyl), },
end

end fundamental_lemma

end model_category

end algebraic_topology


import basic .hp .hp_component .view

namespace hp

open interaction_monad.result widget rc
-- #check create_hp_state
-- meta def rc.run_to_tc {π α} [has_should_update π]: rc π α → tc π α
-- | rr :=
--   component.with_should_update (λ ⟨ts₁,p₁⟩ ⟨ts₂, p₂⟩, (should_update p₁ p₂))
--   $ component.with_state
  -- $ component.with_state

  -- $ component.stateful β (result hp_state σ)
  -- (λ ⟨ts,p⟩ last,
  --   match last with
  --   | none := match create_hp_state ts with
  --             | (success rs _) := let r := run $ i p none in r rs
  --             | (exception _ _ ts) := undefined_core "rc.run_to_tc create_hp_state failed" -- [hack]
  --             end
  --   | some (success s rs) := let r := run $  i p (some s) in r rs
  --   | some (exception _ _ rs) := let r := run $ i p none  in r rs
  --   end
  -- ) (λ ⟨_,p⟩ s b,
  --   match s with
  --   | (success s rs) := let r := run $ u p s b in let r := r rs in (prod.fst <$> r,result.get r >>= prod.snd)
  --   | x := (x,none)
  --   end
  -- ) (λ ⟨_,p⟩ s,
  --   match s with
  --   | (success s rs) := let r := run $ v p s in let r := r rs in ["error occurred"] <| r.get
  --   | (exception msg _ rs) := ["error: ", show_html msg]
  --   end
  -- )

-- meta def rc.run : rc unit string → component tactic_state string
-- | r := tc.to_component $ rc.run_to_tc r

open tactic
meta def rt_run {α : Type}: hp α → tactic α
| r := do
  rs ← create_hp_state,
  let r := (run r),
  match r rs with
  | (result.success a rs) := do
    tactic.write rs.ts,
    (result, gs) ← tactic.unsafe.type_context.run $ box.all_targets rs.b,
    -- tactic.trace result,
    tactic.unsafe.assign rs.result result,
    tactic.set_goals gs,
    pure a
  | (result.exception m p rs) := (λ _, result.exception m p rs.ts)
  end

meta def rt_run_inst: monad_run tactic hp :=
{run := @rt_run}

meta def step {α : Type} (m : hp α) : hp unit :=
m >> pure ()

-- /- istep is used to make an interactive thingy.  -/
-- meta def istep_core {σ τ α : Type} (line0 col0 line col : nat) (t : state_t σ (interaction_monad τ) α) : state_t σ (interaction_monad τ) unit :=
-- ⟨λ v s,
--   match (@scope_trace _ line col (λ _, t.run v s)) with
--   | (success ⟨a,v⟩ s') := success ((),v) s'
--   | (exception (some msg) p s') := exception (some msg) (some ⟨line, col ⟩) s'
--   | (exception none p s') := silent_fail s'
--   end
-- ⟩
meta def istep_core {α : Type} (line0 col0 line col : nat) (t : hp α) : hp unit :=
-- @monad_lift (interaction_monad hp_state) hp _ unit $
λ v : hp_state,
  match ((@scope_trace _ line col (λ _, let r := (run t) in r v)) : interaction_monad.result hp_state α) with
  | (success a s') := success () s'
  | (exception (some msg) p s') := exception (some msg) (some ⟨line, col ⟩) s'
  | (exception none p s') := silent_fail s'
  end

meta def istep {α : Type} (line0 col0 line col ast : nat) (r : hp α) : hp unit :=
istep_core line0 col0 line col r

meta instance : interactive.executor hp :=
{ config_type := nat,
  execute_with := λ n tac, rt_run tac
}

meta def main (rs : hp_state) : component tactic_state empty :=
component.with_should_update (λ _ _, tt)
$ component.stateful string unit
(λ _ _, ⟨⟩)
(λ _ _ _, (⟨⟩, none))
(λ _ _, html.of_component rs app)

meta def save_info (p : pos) : hp unit := do
  v ← get,
  monad_lift $ tactic.save_widget p $ main v,
  pure ()

open tactic.unsafe

meta def first {α} : ZR α → hp α
| zr := do
  rs ← get,
  b ← pure $ rs.b,
  adrs ← pure $ box.target_addresses b,
  adrs.mfirst (λ adr, ZR.run $ do
      ZR.goto adr,
      zr
  )

namespace interactive

meta def trace_box : hp unit := do
  rs ← get,
  ⍐ $ tactic.trace rs.b,
  pure ()

meta def trace_writeup : hp unit := do
  rs ← get,
  r ← monad_lift $ writeup.write rs.dont_instantiate rs.writeup.reverse,
  -- [todo] tostring the html?
  pure ()

meta def try_targets_with_name {α} : name → ZR α → ZR α | n z := do
  ⟨_,b⟩ ← get,
  adrs ← pure $ box.find_targets_with_name n b,
  adrs.mfirst (λ a, do
    ⍐ $ box.Z.down_adr a,
    z
  )

meta def try_with_name {α} : name → ZR α → ZR α | n z := do
  -- ⍐ $ trace_m "try_with_name: " $ n,
  ⟨_, b⟩ ← get,
  adrs ← pure $ box.find_with_name n b,
  adrs.mfirst (λ a, do
    ⍐ $ box.Z.down_adr a,
    z
  )

meta def try_all_targets {α} : ZR α → ZR α | z := do
  adrs ← ⍐ $ box.Z.prop_goal_addresses,
  adrs.mfirst (λ a, do
    ⍐ $ box.Z.down_adr a,
    z
  )

meta def intros : hp unit :=
  ZR.run $ try_all_targets $ ZR.intros *> pure ()

meta def cosplit : hp unit :=
  ZR.run $ try_all_targets $ ZR.cosplit

meta def split : hp unit := ZR.run $ try_all_targets $ (split_conj_cmd <|> split_exists) *> pure ()

meta def trace_commands_at (n : name) : hp unit := do
  ZR.run (do
    ⍐ $ box.Z.goto_name n,
    cs ← get_commands,
    ⍐ $ tactic.trace $ waterfall_command.display_name <$> cs,
    pure ()
  )

@[derive has_reflect, derive has_to_tactic_format]
meta inductive source_loc
| of_name (n : name)
| of_type_pexpr (t : pexpr)
| just_pexpr (e : pexpr)

@[reducible]
meta def target_loc := option name

open lean.parser

meta def surround {α} (l r : string) : lean.parser α → lean.parser α
| p := tk l *> p <* tk r

meta def parse_source_loc : lean.parser (source_loc) :=
  (pure source_loc.of_name <*> ident)
  -- <|> surround "‹" "›" (pure source_loc.of_type_pexpr <*> lean.parser.pexpr std.prec.max tt)
  <|> ((pure source_loc.just_pexpr) <*> interactive.types.texpr)

meta def goto_source_from_loc : source_loc → box.Z unit
| (source_loc.of_name n) := do
  b ← box.Z.cursor,
  a ← returnopt $ box.find_source (λ Γ s, s.label = n) b,
  box.Z.goto a
| _ := notimpl

meta def get_source_from_loc : source_loc → list source → tactic (list source)
| (source_loc.of_name n) ss := singleton <$> (alternative.returnopt $ ss.find (λ x, x.label = n))
| (source_loc.of_type_pexpr p) ss := do
  T ← tactic.to_expr p tt ff,
  ss.mfilter (λ s, tactic.can_unify s.type T)
| (source_loc.just_pexpr p) _ := do
  x ← tactic.to_expr p tt ff,

  s ← source.of_lemma x,
  pure [s]

meta def parse_targ_loc : lean.parser target_loc :=
  (optional (tk "at") *> pure some <*> ident) <|> pure none

meta def try_loc {α} : option name → ZR α → ZR α
| none z := try_all_targets z
| (some n) z := try_with_name n z

meta def apply (s : interactive.parse parse_source_loc) (t : interactive.parse parse_targ_loc) : hp unit :=
  ZR.run $ try_loc t (do
    ZR.set_context,
    g ← ⍐ $ box.Z.down_stub,
    ss ← ⍐ $ box.Z.source_list,
    ss ← ⍐ $ get_source_from_loc s ss,
    ss.mfirst (λ s, do
      hp.apply s g,
      ZR.commit
    ))

meta def cases (s : interactive.parse parse_source_loc) : hp unit :=
ZR.run (do
  ⍐ $ goto_source_from_loc s,
  cases_or <|> cases_and
)

meta def expand (s : interactive.parse parse_targ_loc) : hp unit :=
ZR.run $ try_loc s ( (expand_target <|> expand_source) *> pure ())

meta def unroll (s : interactive.parse parse_targ_loc) : hp unit :=
ZR.run $ try_loc s $ hp.unroll

end interactive
end hp
-- set_option pp.all true
open hp
set_option trace.app_builder true
-- example {P: nat → nat → Prop} : Π (p : ∀ y, ∃ x, P y x), ∃ z, P 0 z :=
-- begin [hp]
--   -- (ZR.run (do (⍐ box.Z.first_goal) *> get_target_commands >>= (list.mmap $ pure ∘ waterfall_command.display_name))) >>= ⍐ ∘ tactic.trace,
--   intros,
--   -- (ZR.run (⍐ (box.Z.intros) *> get_target_commands *> ZR.trace_state)),
--   split,
--   apply_first `p,
--   -- (ZR.run (do ((⍐ box.Z.first_goal) *> (⍐ box.Z.next)) *> get_target_commands >>= (list.mmap $ pure ∘ waterfall_command.display_name))) >>= ⍐ ∘ tactic.trace,
-- end