import data.pfun
import phase2.approximation
import phase2.complete_orbit
import phase2.reduction

open cardinal quiver set sum with_bot
open_locale cardinal classical pointwise

universe u

namespace con_nf
variable [params.{u}]

/-!
# Weak approximations
-/

/-- Noncomputably eliminates a disjunction into a (possibly predicative) universe. -/
noncomputable def _root_.or.elim' {α : Sort*} {p q : Prop}
  (h : p ∨ q) (f : p → α) (g : q → α) : α :=
if hp : p then f hp else g (h.resolve_left hp)

lemma _root_.or.elim'_left {α : Sort*} {p q : Prop}
  (h : p ∨ q) (f : p → α) (g : q → α) (hp : p) : h.elim' f g = f hp :=
by rw [or.elim', dif_pos hp]

lemma _root_.or.elim'_right {α : Sort*} {p q : Prop}
  (h : p ∨ q) (f : p → α) (g : q → α) (hp : ¬p) : h.elim' f g = g (h.resolve_left hp) :=
by rw [or.elim', dif_neg hp]

/-- A *weak near-litter approximation* is a partial function from atoms to atoms and a partial
function from litters to near-litters, both of which have small domain.
The image of a litter under the `litter_map` should be interpreted as the intended *precise* image
of this litter under an allowable permutation.
The atom and litter maps should be injective (in suitable senses) and cohere in the sense that
images of atoms in litters are mapped to atoms inside the corresponding near-litters. -/
@[ext] structure weak_near_litter_approx :=
(atom_map : atom →. atom)
(litter_map : litter →. near_litter)
(atom_map_dom_small : small atom_map.dom)
(litter_map_dom_small : small litter_map.dom)
(atom_map_injective : ∀ ⦃a b⦄ ha hb, (atom_map a).get ha = (atom_map b).get hb → a = b)
(litter_map_injective : ∀ ⦃L₁ L₂ : litter⦄ hL₁ hL₂,
  (((litter_map L₁).get hL₁ : set atom) ∩ (litter_map L₂).get hL₂).nonempty → L₁ = L₂)
(atom_mem : ∀ (a : atom) ha L hL, a.1 = L ↔ (atom_map a).get ha ∈ (litter_map L).get hL)

/-- A `β`-weak structural approximation is a product that assigns a weak near-litter approximation
to each `β`-extended index. -/
def weak_struct_approx (β : type_index) := extended_index β → weak_near_litter_approx

namespace weak_near_litter_approx

variable (w : weak_near_litter_approx)

/-- A litter that is not allowed to be used as a sandbox because it appears somewhere that
we need to preserve. -/
@[mk_iff] inductive banned_litter : litter → Prop
| atom_dom (a : atom) : (w.atom_map a).dom → banned_litter a.1
| litter_dom (L : litter) : (w.litter_map L).dom → banned_litter L
| atom_map (a : atom) (h) : banned_litter ((w.atom_map a).get h).1
| litter_map (L : litter) (h) : banned_litter ((w.litter_map L).get h).1
| diff (L : litter) (h) (a : atom) :
    a ∈ ((w.litter_map L).get h : set atom) \ litter_set ((w.litter_map L).get h).1 →
    banned_litter a.1

lemma banned_litter.mem_map (a : atom) (L : litter) (hL)
  (ha : a ∈ ((w.litter_map L).get hL : set atom)) : w.banned_litter a.1 :=
begin
  by_cases a.1 = ((w.litter_map L).get hL).1,
  { rw h,
    exact banned_litter.litter_map L hL, },
  { exact banned_litter.diff L hL a ⟨ha, h⟩, },
end

/-- There are only a small amount of banned litters. -/
lemma banned_litter_small : small {L | w.banned_litter L} :=
begin
  simp only [banned_litter_iff, mem_diff, set_like.mem_coe, mem_litter_set],
  refine small.union _ (small.union _ (small.union _ (small.union _ _))),
  { refine lt_of_le_of_lt _ w.atom_map_dom_small,
    refine ⟨⟨λ a, ⟨_, a.prop.some_spec.1⟩, λ a₁ a₂ h, _⟩⟩,
    simp only [subtype.mk_eq_mk, prod.mk.inj_iff] at h,
    have := a₁.prop.some_spec.2,
    rw h at this,
    exact subtype.coe_injective (this.trans a₂.prop.some_spec.2.symm), },
  { refine lt_of_le_of_lt _ w.litter_map_dom_small,
    refine ⟨⟨λ L, ⟨_, L.prop⟩, λ L₁ L₂ h, _⟩⟩,
    simp only [subtype.mk_eq_mk, prod.mk.inj_iff] at h,
    exact subtype.coe_injective h, },
  { refine lt_of_le_of_lt _ w.atom_map_dom_small,
    refine ⟨⟨λ L, ⟨_, L.prop.some_spec.some⟩, λ L₁ L₂ h, _⟩⟩,
    simp only [subtype.mk_eq_mk, prod.mk.inj_iff] at h,
    have := L₁.prop.some_spec.some_spec,
    simp_rw h at this,
    exact subtype.coe_injective (this.trans L₂.prop.some_spec.some_spec.symm), },
  { refine lt_of_le_of_lt _ w.litter_map_dom_small,
    refine ⟨⟨λ L, ⟨_, L.prop.some_spec.some⟩, λ L₁ L₂ h, _⟩⟩,
    simp only [subtype.mk_eq_mk, prod.mk.inj_iff] at h,
    have := L₁.prop.some_spec.some_spec,
    simp_rw h at this,
    exact subtype.coe_injective (this.trans L₂.prop.some_spec.some_spec.symm), },
  { have : small ⋃ (L : litter) (h : (w.litter_map L).dom),
      ((w.litter_map L).get h : set atom) \ litter_set ((w.litter_map L).get h).1,
    { refine small.bUnion _ _,
      { refine lt_of_le_of_lt _ w.litter_map_dom_small,
        refine ⟨⟨λ N, ⟨_, N.prop⟩, λ N₁ N₂ h, _⟩⟩,
        simp only [subtype.mk_eq_mk, prod.mk.inj_iff] at h,
        exact subtype.coe_inj.mp h, },
      { intros L hL,
        refine small.mono _ ((w.litter_map L).get hL).2.prop,
        exact λ x hx, or.inr hx, }, },
    refine lt_of_le_of_lt _ this,
    refine ⟨⟨λ L, ⟨L.prop.some_spec.some_spec.some, _⟩, λ L₁ L₂ h, _⟩⟩,
    { simp only [mem_Union],
      exact ⟨_, _, L.prop.some_spec.some_spec.some_spec.1⟩, },
    simp only [subtype.mk_eq_mk, prod.mk.inj_iff] at h,
    have := L₁.prop.some_spec.some_spec.some_spec.2,
    rw h at this,
    exact subtype.coe_injective
      (this.trans L₂.prop.some_spec.some_spec.some_spec.2.symm), },
end

lemma mk_not_banned_litter : #{L | ¬w.banned_litter L} = #μ :=
begin
  have := mk_sum_compl {L | w.banned_litter L},
  rw [compl_set_of, mk_litter] at this,
  rw [← this, add_eq_right],
  { by_contra' h,
    have h' := add_le_add (le_of_lt w.banned_litter_small) h.le,
    rw this at h',
    refine not_lt_of_le h' _,
    refine cardinal.add_lt_of_lt μ_strong_limit.is_limit.aleph_0_le κ_lt_μ _,
    exact lt_of_le_of_lt κ_regular.aleph_0_le κ_lt_μ, },
  { by_contra' h,
    have h' := add_le_add (le_of_lt w.banned_litter_small) h.le,
    rw this at h',
    refine not_lt_of_le h' _,
    refine cardinal.add_lt_of_lt μ_strong_limit.is_limit.aleph_0_le κ_lt_μ _,
    exact lt_trans w.banned_litter_small κ_lt_μ, },
end

lemma not_banned_litter_nonempty : nonempty {L | ¬w.banned_litter L} :=
by simp only [← mk_ne_zero_iff, mk_not_banned_litter, ne.def, mk_ne_zero, not_false_iff]

/-- The *sandbox litter* for a weak near-litter approximation is an arbitrarily chosen litter that
isn't banned. -/
noncomputable def sandbox_litter : litter := w.not_banned_litter_nonempty.some

lemma sandbox_litter_not_banned : ¬w.banned_litter w.sandbox_litter :=
w.not_banned_litter_nonempty.some.prop

/-- If `a` is in the domain, this is the atom map. Otherwise, this gives an arbitrary atom. -/
noncomputable def atom_map_or_else (a : atom) : atom := (w.atom_map a).get_or_else (arbitrary atom)

lemma atom_map_or_else_of_dom {a : atom} (ha : (w.atom_map a).dom) :
  w.atom_map_or_else a = (w.atom_map a).get ha :=
by rw [atom_map_or_else, part.get_or_else_of_dom]

lemma mk_atom_map_image_le_mk_sandbox :
  #(w.atom_map.dom ∆ (w.atom_map_or_else '' w.atom_map.dom) : set atom) ≤
    #(litter_set w.sandbox_litter) :=
begin
  rw mk_litter_set,
  refine le_trans (mk_subtype_mono symm_diff_subset_union) (le_trans (mk_union_le _ _) _),
  refine add_le_of_le κ_regular.aleph_0_le _ _,
  exact le_of_lt w.atom_map_dom_small,
  exact le_trans mk_image_le (le_of_lt w.atom_map_dom_small),
end

lemma disjoint_sandbox :
  disjoint (w.atom_map.dom ∪ w.atom_map_or_else '' w.atom_map.dom) (litter_set w.sandbox_litter) :=
begin
  rw [disjoint_iff_inter_eq_empty, eq_empty_iff_forall_not_mem],
  rintros a ⟨ha₁, ha₂⟩,
  rw mem_litter_set at ha₂,
  have hnb := w.sandbox_litter_not_banned,
  rw ← ha₂ at hnb,
  cases ha₁,
  { exact hnb (banned_litter.atom_dom a ha₁), },
  { refine hnb _,
    simp only [mem_image, pfun.mem_dom] at ha₁,
    obtain ⟨b, ⟨_, hb, rfl⟩, rfl⟩ := ha₁,
    rw w.atom_map_or_else_of_dom hb,
    exact banned_litter.atom_map b hb, },
end

lemma atom_map_or_else_injective : inj_on w.atom_map_or_else w.atom_map.dom :=
begin
  intros a ha b hb h,
  rw [w.atom_map_or_else_of_dom ha, w.atom_map_or_else_of_dom hb] at h,
  exact w.atom_map_injective ha hb h,
end

/-- If `L` is in the domain, this is the litter map.
Otherwise, this gives an arbitrary near-litter. -/
noncomputable def litter_map_or_else (L : litter) : near_litter :=
(w.litter_map L).get_or_else (arbitrary near_litter)

lemma litter_map_or_else_of_dom {L : litter} (hL : (w.litter_map L).dom) :
  w.litter_map_or_else L = (w.litter_map L).get hL :=
by rw [litter_map_or_else, part.get_or_else_of_dom]

noncomputable def rough_litter_map_or_else (L : litter) : litter :=
(w.litter_map_or_else L).1

lemma rough_litter_map_or_else_of_dom {L : litter} (hL : (w.litter_map L).dom) :
  w.rough_litter_map_or_else L = ((w.litter_map L).get hL).1 :=
by rw [rough_litter_map_or_else, litter_map_or_else_of_dom]

/-- The induced action of this weak approximation on near-litters. -/
noncomputable def near_litter_map_or_else (N : near_litter) : near_litter :=
⟨(w.litter_map_or_else N.fst).fst,
  w.litter_map_or_else N.fst ∆ (w.atom_map_or_else '' litter_set N.fst ∆ N),
  begin
    rw [is_near_litter, is_near, ← symm_diff_assoc],
    exact (w.litter_map_or_else N.fst).snd.prop.symm_diff (small.image N.2.prop),
  end⟩

/-- A weak approximation is precise at a litter in its domain if all atoms in the symmetric
difference of its image are accounted for. -/
@[mk_iff] structure precise_at {L : litter} (hL : (w.litter_map L).dom) : Prop :=
(diff : ((w.litter_map L).get hL : set atom) ∆ litter_set ((w.litter_map L).get hL).1 ⊆
  w.atom_map.ran)
(fwd : ∀ a ha, (w.atom_map a).get ha ∈ litter_set L → (w.atom_map ((w.atom_map a).get ha)).dom)
(back : w.atom_map.dom ∩ (w.litter_map L).get hL ⊆ w.atom_map.ran)

/-- A weak approximation is precise if it is precise at every litter in its domain. -/
def precise : Prop := ∀ ⦃L⦄ (hL : (w.litter_map L).dom), w.precise_at hL

/-!
## Induced litter permutation
-/

lemma mk_dom_symm_diff_le :
  #↥(w.litter_map.dom ∆ (w.rough_litter_map_or_else '' w.litter_map.dom)) ≤
  #{L : litter | ¬w.banned_litter L} :=
begin
  rw mk_not_banned_litter,
  refine le_trans (le_of_lt _) κ_le_μ,
  exact small.symm_diff w.litter_map_dom_small w.litter_map_dom_small.image,
end

lemma aleph_0_le_not_banned_litter : ℵ₀ ≤ #{L | ¬w.banned_litter L} :=
begin
  rw mk_not_banned_litter,
  exact μ_strong_limit.is_limit.aleph_0_le,
end

lemma disjoint_dom_not_banned_litter :
  disjoint (w.litter_map.dom ∪ w.rough_litter_map_or_else '' w.litter_map.dom)
    {L : litter | ¬w.banned_litter L} :=
begin
  simp only [set.disjoint_left, mem_union, pfun.mem_dom, mem_image, mem_set_of_eq, not_not],
  rintros _ (⟨_, hL, rfl⟩ | ⟨L, ⟨_, hL, rfl⟩, rfl⟩),
  { exact banned_litter.litter_dom _ hL, },
  { rw w.rough_litter_map_or_else_of_dom hL,
    exact banned_litter.litter_map _ hL, },
end

lemma rough_litter_map_or_else_inj_on : inj_on w.rough_litter_map_or_else w.litter_map.dom :=
begin
  intros L₁ hL₁ L₂ hL₂ h,
  rw [w.rough_litter_map_or_else_of_dom hL₁, w.rough_litter_map_or_else_of_dom hL₂] at h,
  exact w.litter_map_injective hL₁ hL₂ (near_litter.inter_nonempty_of_fst_eq_fst h),
end

/-- A local permutation on the set of litters that occur in the domain or range of `w`.
This permutes both flexible and inflexible litters. -/
noncomputable def litter_perm' : local_perm litter :=
local_perm.complete
  w.rough_litter_map_or_else
  w.litter_map.dom
  {L | ¬w.banned_litter L}
  w.mk_dom_symm_diff_le
  w.aleph_0_le_not_banned_litter
  w.disjoint_dom_not_banned_litter
  w.rough_litter_map_or_else_inj_on

def id_on_banned (s : set litter) : local_perm litter := {
  to_fun := id,
  inv_fun := id,
  domain := {L | w.banned_litter L} \ s,
  to_fun_domain' := λ L h, h,
  inv_fun_domain' := λ L h, h,
  left_inv' := λ L h, rfl,
  right_inv' := λ L h, rfl,
}

noncomputable def litter_perm : local_perm litter :=
local_perm.piecewise w.litter_perm' (w.id_on_banned w.litter_perm'.domain)
  (by rw ← set.subset_compl_iff_disjoint_left; exact λ L h, h.2)

lemma litter_perm'_apply_eq (L : litter) (hL : L ∈ w.litter_map.dom) :
  w.litter_perm' L = w.rough_litter_map_or_else L :=
local_perm.complete_apply_eq _ _ _ hL

lemma litter_perm_apply_eq (L : litter) (hL : L ∈ w.litter_map.dom) :
  w.litter_perm L = w.rough_litter_map_or_else L :=
begin
  rw ← w.litter_perm'_apply_eq L hL,
  exact local_perm.piecewise_apply_eq_left (or.inl (or.inl hL)),
end

lemma litter_perm'_domain_small : small w.litter_perm'.domain :=
begin
  refine small.union (small.union w.litter_map_dom_small w.litter_map_dom_small.image) _,
  rw small,
  rw cardinal.mk_congr (local_perm.sandbox_subset_equiv _ _),
  simp only [mk_sum, mk_prod, mk_denumerable, lift_aleph_0, lift_uzero, lift_id],
  refine add_lt_of_lt κ_regular.aleph_0_le _ _;
    refine (mul_lt_of_lt κ_regular.aleph_0_le (lt_of_le_of_lt Λ_limit.aleph_0_le Λ_lt_κ) _);
    refine lt_of_le_of_lt (mk_subtype_mono (diff_subset _ _)) _,
  exact w.litter_map_dom_small,
  exact w.litter_map_dom_small.image,
end

lemma litter_perm_domain_small : small w.litter_perm.domain :=
small.union w.litter_perm'_domain_small (small.mono (diff_subset _ _) w.banned_litter_small)

variables {α : Λ} [position_data.{}] [phase_2_assumptions α] {β : Iio α} {A : extended_index β}

lemma mk_not_banned_litter_and_flexible : #{L | ¬w.banned_litter L ∧ flexible α L A} = #μ :=
begin
  refine le_antisymm ((mk_subtype_le _).trans mk_litter.le) _,
  by_contra,
  rw not_le at h,
  have h₁ := cardinal.le_mk_diff_add_mk {L | flexible α L A} {L | w.banned_litter L},
  rw [mk_flexible, diff_eq, inter_comm] at h₁,
  have h₂ := add_lt_of_lt μ_strong_limit.is_limit.aleph_0_le h
    (lt_trans w.banned_litter_small κ_lt_μ),
  exact h₁.not_lt h₂,
end

lemma mk_dom_inter_flexible_symm_diff_le :
  #↥((w.litter_map.dom ∩ {L | flexible α L A}) ∆
    (w.rough_litter_map_or_else '' (w.litter_map.dom ∩ {L | flexible α L A}))) ≤
  #{L : litter | ¬w.banned_litter L ∧ flexible α L A} :=
begin
  rw mk_not_banned_litter_and_flexible,
  refine le_trans (le_of_lt _) κ_le_μ,
  exact small.symm_diff
    (small.mono (inter_subset_left _ _) w.litter_map_dom_small)
    (small.mono (inter_subset_left _ _) w.litter_map_dom_small).image,
end

lemma aleph_0_le_not_banned_litter_and_flexible : ℵ₀ ≤ #{L | ¬w.banned_litter L ∧ flexible α L A} :=
begin
  rw mk_not_banned_litter_and_flexible,
  exact μ_strong_limit.is_limit.aleph_0_le,
end

lemma disjoint_dom_inter_flexible_not_banned_litter :
  disjoint ((w.litter_map.dom ∩ {L | flexible α L A})
    ∪ w.rough_litter_map_or_else '' (w.litter_map.dom ∩ {L | flexible α L A}))
    {L : litter | ¬w.banned_litter L ∧ flexible α L A} :=
begin
  refine disjoint_of_subset _ (inter_subset_left _ _) w.disjoint_dom_not_banned_litter,
  rintros a (ha | ⟨b, hb, rfl⟩),
  exact or.inl ha.1,
  exact or.inr ⟨b, hb.1, rfl⟩,
end

lemma rough_litter_map_or_else_inj_on_dom_inter_flexible :
  inj_on w.rough_litter_map_or_else (w.litter_map.dom ∩ {L | flexible α L A}) :=
w.rough_litter_map_or_else_inj_on.mono (inter_subset_left _ _)

noncomputable def flexible_litter_perm (A : extended_index β) :
  local_perm litter :=
local_perm.complete
  w.rough_litter_map_or_else
  (w.litter_map.dom ∩ {L | flexible α L A})
  {L | ¬w.banned_litter L ∧ flexible α L A}
  w.mk_dom_inter_flexible_symm_diff_le
  w.aleph_0_le_not_banned_litter_and_flexible
  w.disjoint_dom_inter_flexible_not_banned_litter
  w.rough_litter_map_or_else_inj_on_dom_inter_flexible

lemma flexible_litter_perm_apply_eq (L : litter)
  (hL₁ : L ∈ w.litter_map.dom) (hL₂ : flexible α L A) :
  w.flexible_litter_perm A L = w.rough_litter_map_or_else L :=
local_perm.complete_apply_eq _ _ _ ⟨hL₁, hL₂⟩

lemma flexible_litter_perm_domain_small : small (w.flexible_litter_perm A).domain :=
begin
  refine small.union (small.union _ _) _,
  { exact w.litter_map_dom_small.mono (inter_subset_left _ _) },
  { exact (w.litter_map_dom_small.mono (inter_subset_left _ _)).image, },
  { rw small,
    rw cardinal.mk_congr (local_perm.sandbox_subset_equiv _ _),
    simp only [mk_sum, mk_prod, mk_denumerable, lift_aleph_0, lift_uzero, lift_id],
    refine add_lt_of_lt κ_regular.aleph_0_le _ _;
      refine (mul_lt_of_lt κ_regular.aleph_0_le (lt_of_le_of_lt Λ_limit.aleph_0_le Λ_lt_κ) _);
      refine lt_of_le_of_lt (mk_subtype_mono (diff_subset _ _)) _,
    exact w.litter_map_dom_small.mono (inter_subset_left _ _),
    exact (w.litter_map_dom_small.mono (inter_subset_left _ _)).image, },
end

/-!
# Completed permutations
-/

/-- A local permutation induced by completing the orbits of atoms in a weak near-litter
approximation. This function creates forward and backward images of atoms in the *sandbox litter*,
a litter which is away from the domain and range of the approximation in question, so it should
not interfere with other constructions. -/
noncomputable def complete_atom_perm : local_perm atom :=
local_perm.complete
  w.atom_map_or_else
  w.atom_map.dom
  (litter_set w.sandbox_litter)
  w.mk_atom_map_image_le_mk_sandbox
  (by simpa only [mk_litter_set] using κ_regular.aleph_0_le)
  w.disjoint_sandbox
  w.atom_map_or_else_injective

lemma sandbox_subset_small : small (local_perm.sandbox_subset
  w.mk_atom_map_image_le_mk_sandbox
  (by simpa only [mk_litter_set] using κ_regular.aleph_0_le)) :=
begin
  rw small,
  rw cardinal.mk_congr (local_perm.sandbox_subset_equiv _ _),
  simp only [mk_sum, mk_prod, mk_denumerable, lift_aleph_0, lift_uzero, lift_id],
  refine add_lt_of_lt κ_regular.aleph_0_le _ _;
    refine (mul_lt_of_lt κ_regular.aleph_0_le (lt_of_le_of_lt Λ_limit.aleph_0_le Λ_lt_κ) _);
    refine lt_of_le_of_lt (mk_subtype_mono (diff_subset _ _)) _,
  { exact w.atom_map_dom_small, },
  { exact lt_of_le_of_lt mk_image_le w.atom_map_dom_small, },
end

lemma complete_atom_perm_domain_small : small w.complete_atom_perm.domain :=
small.union (small.union w.atom_map_dom_small
  (lt_of_le_of_lt mk_image_le w.atom_map_dom_small)) w.sandbox_subset_small

/-- A near-litter approximation built from this weak near-litter approximation.
Its action on atoms matches that of the weak approximation, and its rough action on litters
matches the given litter permutation. -/
noncomputable def complete (A : extended_index β) : near_litter_approx := {
  atom_perm := w.complete_atom_perm,
  litter_perm := w.flexible_litter_perm A,
  domain_small := λ L, small.mono (inter_subset_right _ _) w.complete_atom_perm_domain_small,
}

variable {litter_perm : local_perm litter}

lemma complete_atom_perm_apply_eq {a : atom} (ha : (w.atom_map a).dom) :
  w.complete_atom_perm a = (w.atom_map a).get ha :=
by rwa [complete_atom_perm, local_perm.complete_apply_eq, atom_map_or_else_of_dom]

lemma complete_smul_atom_eq {a : atom} (ha : (w.atom_map a).dom) :
  w.complete A • a = (w.atom_map a).get ha := w.complete_atom_perm_apply_eq ha

@[simp] lemma complete_smul_litter_eq (L : litter) :
  w.complete A • L = w.flexible_litter_perm A L := rfl

lemma smul_atom_eq
  {π : near_litter_perm} (hπ : (w.complete A).exactly_approximates π)
  {a : atom} (ha : (w.atom_map a).dom) :
  π • a = (w.atom_map a).get ha :=
by rw [← hπ.map_atom a (or.inl (or.inl ha)), w.complete_smul_atom_eq ha]

lemma smul_to_near_litter_eq_of_precise_at
  {π : near_litter_perm} (hπ : (w.complete A).exactly_approximates π)
  {L : litter} (hL : (w.litter_map L).dom) (hw : w.precise_at hL)
  (hπL : π • L = ((w.litter_map L).get hL).1) :
  π • L.to_near_litter = (w.litter_map L).get hL :=
begin
  refine set_like.coe_injective _,
  ext a : 1,
  simp only [mem_smul_set_iff_inv_smul_mem, near_litter_perm.coe_smul, litter.coe_to_near_litter,
    mem_litter_set, set_like.mem_coe],
  split,
  { intro ha,
    by_cases π.is_exception a,
    { suffices h' : π⁻¹ • a ∈ w.atom_map.dom,
      { rw w.atom_mem _ h' L hL at ha,
        have := hπ.map_atom _ (or.inl (or.inl h')),
        rw w.complete_smul_atom_eq h' at this,
        rw [this, smul_inv_smul] at ha,
        exact ha, },
      rw ← hπ.symm_map_atom a (hπ.exception_mem _ h) at ha ⊢,
      obtain ((hdom | hdom) | hdom) := (w.complete A).atom_perm.symm.map_domain
        (hπ.exception_mem _ h),
      { exact hdom, },
      { obtain ⟨c, hc₁, hc₂⟩ := hdom,
        rw w.atom_map_or_else_of_dom hc₁ at hc₂,
        have := hw.fwd c hc₁ (by rwa hc₂),
        rw hc₂ at this,
        exact this, },
      { cases w.sandbox_litter_not_banned _,
        rw ← eq_of_mem_litter_set_of_mem_litter_set ha
          (local_perm.sandbox_subset_subset _ _ hdom),
        exact banned_litter.litter_dom L hL, }, },
    { by_contradiction h',
      simp only [near_litter_perm.is_exception, mem_litter_set, not_or_distrib, not_not, ha] at h,
      obtain ⟨b, hb, rfl⟩ := hw.diff
        (or.inr ⟨by rw [← hπL, h.2, smul_inv_smul, mem_litter_set], h'⟩),
      refine h' ((w.atom_mem b hb L hL).mp _),
      have := hπ.map_atom b (or.inl (or.inl hb)),
      rw [w.complete_smul_atom_eq hb] at this,
      rw [this, inv_smul_smul] at ha,
      exact ha, }, },
  { intro ha,
    -- TODO: probably possible to clean up `by_cases` into a `suffices`
    by_cases π⁻¹ • a ∈ w.atom_map.dom,
    { rw w.atom_mem _ h L hL,
      have := hπ.map_atom _ (or.inl (or.inl h)),
      rw w.complete_smul_atom_eq h at this,
      rw [this, smul_inv_smul],
      exact ha, },
    have haL : a ∈ litter_set ((w.litter_map L).get hL).fst,
    { by_contradiction h',
      obtain ⟨b, hb, rfl⟩ := hw.diff (or.inl ⟨ha, h'⟩),
      have := hπ.map_atom b (or.inl (or.inl hb)),
      rw [w.complete_smul_atom_eq hb] at this,
      rw [this, inv_smul_smul] at h,
      exact h hb, },
    by_contradiction h',
    have hex : π.is_exception a,
    { refine or.inr (λ h'', h' (h''.trans _)),
      rw [inv_smul_eq_iff, hπL],
      exact haL, },
    obtain ((hdom | ⟨b, hb₁, hb₂⟩) | hdom) := hπ.exception_mem a hex,
    { obtain ⟨b, hb₁, hb₂⟩ := hw.back ⟨hdom, ha⟩,
      have := hπ.map_atom b (or.inl (or.inl hb₁)),
      rw [w.complete_smul_atom_eq hb₁] at this,
      rw [this, smul_eq_iff_eq_inv_smul] at hb₂,
      rw hb₂ at hb₁,
      exact h hb₁, },
    { rw w.atom_map_or_else_of_dom hb₁ at hb₂,
      have := hπ.map_atom b (or.inl (or.inl hb₁)),
      rw [w.complete_smul_atom_eq hb₁, hb₂, ← inv_smul_eq_iff] at this,
      rw this at h,
      exact h hb₁, },
    { refine w.sandbox_litter_not_banned _,
      rw eq_of_mem_litter_set_of_mem_litter_set (local_perm.sandbox_subset_subset _ _ hdom) haL,
      exact banned_litter.litter_map L hL, }, },
end

lemma smul_near_litter_eq_of_precise_at
  {π : near_litter_perm} (hπ : (w.complete A).exactly_approximates π)
  {N : near_litter} (hN : (w.litter_map N.1).dom) (hw : w.precise_at hN)
  (hπL : π • N.1 = ((w.litter_map N.1).get hN).1) :
  ((π • N : near_litter) : set atom) = (w.litter_map N.1).get hN ∆ (π • (litter_set N.1 ∆ N)) :=
begin
  refine (near_litter_perm.smul_near_litter_eq_smul_symm_diff_smul _ _).trans _,
  rw ← w.smul_to_near_litter_eq_of_precise_at hπ hN hw hπL,
  refl,
end

end weak_near_litter_approx

namespace weak_struct_approx

section

def precise {β : type_index} (w : weak_struct_approx β) : Prop := ∀ B, (w B).precise

variables {α : Λ} [position_data.{}] [phase_2_assumptions α] {β : Iio α} (w : weak_struct_approx β)

noncomputable def complete : struct_approx β :=
λ B, (w B).complete B

lemma smul_atom_eq
  {π : struct_perm β} (hπ : w.complete.exactly_approximates π)
  {a : atom} {B : extended_index β} (ha : ((w B).atom_map a).dom) :
  struct_perm.derivative B π • a = ((w B).atom_map a).get ha :=
begin
  have := (w B).smul_atom_eq (hπ B) ha,
  rw struct_perm.of_bot_smul at this,
  exact this,
end

lemma smul_to_near_litter_eq_of_precise (hw : w.precise)
  {π : struct_perm β} (hπ : w.complete.exactly_approximates π)
  {L : litter} {B : extended_index β} (hL : ((w B).litter_map L).dom)
  (hπL : struct_perm.derivative B π • L = (((w B).litter_map L).get hL).1) :
  struct_perm.derivative B π • L.to_near_litter = ((w B).litter_map L).get hL :=
begin
  have := (w B).smul_to_near_litter_eq_of_precise_at (hπ B) hL (hw B hL) _,
  { rw struct_perm.of_bot_smul at this,
    exact this, },
  { rw struct_perm.of_bot_smul,
    exact hπL, },
end

lemma smul_near_litter_eq_of_precise (hw : w.precise)
  {π : struct_perm β} (hπ : w.complete.exactly_approximates π)
  {N : near_litter} {B : extended_index β} (hN : ((w B).litter_map N.1).dom)
  (hπL : struct_perm.derivative B π • N.1 = (((w B).litter_map N.1).get hN).1) :
  ((struct_perm.derivative B π • N : near_litter) : set atom) =
  ((w B).litter_map N.1).get hN ∆ (struct_perm.derivative B π • (litter_set N.1 ∆ N)) :=
begin
  have := (w B).smul_near_litter_eq_of_precise_at (hπ B) hN (hw B hN) _,
  { rw struct_perm.of_bot_smul at this,
    exact this, },
  { rw struct_perm.of_bot_smul,
    exact hπL, },
end

end

variables {α : Λ} [position_data.{}] [phase_2_assumptions α] {β : Iio α}

/-- A weak structural approximation *supports* a tangle if it defines an image for everything
in the reduction of its designated support. -/
structure supports (w : weak_struct_approx β) (t : tangle β) : Prop :=
(atom_mem : ∀ a B, (inl a, B) ∈ reduction α (designated_support t : set (support_condition β)) →
  ((w B).atom_map a).dom)
(litter_mem : ∀ (L : litter) B,
  (inr L.to_near_litter, B) ∈ reduction α (designated_support t : set (support_condition β)) →
  ((w B).litter_map L).dom)

/-- Two weak structural approximations are *compatible* for a tangle if they both support the
tangle and agree on the reduction of its designated support. -/
structure compatible (w v : weak_struct_approx β) (t : tangle β) : Prop :=
(w_supports : w.supports t)
(v_supports : v.supports t)
(atom_map : ∀ a B ha, ((w B).atom_map a).get (w_supports.atom_mem a B ha) =
  ((v B).atom_map a).get (v_supports.atom_mem a B ha))
(litter_map : ∀ L B hL, ((w B).litter_map L).get (w_supports.litter_mem L B hL) =
  ((v B).litter_map L).get (v_supports.litter_mem L B hL))

/-- The action of a weak structural approximation on support conditions. -/
noncomputable def support_condition_map_or_else (w : weak_struct_approx β) :
  support_condition β → support_condition β
| (inl a, B) := (inl ((w B).atom_map_or_else a), B)
| (inr N, B) := (inr ((w B).near_litter_map_or_else N), B)

def coherent_coe (w : weak_struct_approx β) (t : tangle β) : Prop :=
∀ {π : allowable β} (hπ : w.complete.exactly_approximates π.to_struct_perm)
  (γ : Iic α) (δ ε : Iio α) (hδ : (δ : Λ) < γ) (hε : (ε : Λ) < γ) (hδε : δ ≠ ε)
  (C : path (β : type_index) γ) (t' : tangle δ) (hL)
  (hc₁ : ∃ (d : support_condition β), d ∈ (designated_support t).carrier ∧
    relation.refl_trans_gen (constrains α β)
    (inr (f_map (coe_ne_coe.mpr (coe_ne' hδε)) t').to_near_litter,
      (C.cons (coe_lt hε)).cons (bot_lt_coe _)) d)
  (hc₂ : ∀ (c : support_condition δ), c ∈ (designated_support t').carrier →
    π • (show support_condition β, from (c.fst, (C.cons (coe_lt hδ)).comp c.snd)) =
      w.support_condition_map_or_else (c.fst, (C.cons (coe_lt hδ)).comp c.snd)),
  f_map (subtype.coe_injective.ne (Iio.coe_injective.ne hδε))
      (show tangle δ, from
        (show allowable δ, from allowable_derivative (γ : Iic_index α) δ (coe_lt_coe.mpr hδ)
          (allowable.derivative
            (show path ((β : Iic_index α) : type_index) (γ : Iic_index α), from C) π)) • t') =
    (((w ((C.cons (coe_lt hε)).cons (bot_lt_coe _))).litter_map
      (f_map (subtype.coe_injective.ne (Iio.coe_injective.ne hδε)) t')).get hL).fst

def coherent_bot (w : weak_struct_approx β) : Prop :=
∀ {π : allowable β} (hπ : w.complete.exactly_approximates π.to_struct_perm)
  (γ : Iic α) (ε : Iio α) (hε : (ε : Λ) < γ)
  (C : path (β : type_index) γ) (a : tangle ⊥) (hL)
  (hc : struct_perm.derivative (C.cons (bot_lt_coe _)) π.to_struct_perm • a =
    (w (C.cons (bot_lt_coe _))).atom_map_or_else a),
  f_map (show ((⊥ : Iio_index α) : type_index) ≠ (ε : Iio_index α),
    from subtype.coe_injective.ne Iio_index.bot_ne_coe)
      ((struct_perm.derivative (C.cons (bot_lt_coe _))) π.to_struct_perm • a) =
    (((w ((C.cons (coe_lt hε)).cons (bot_lt_coe _))).litter_map
      (f_map (show (⊥ : type_index) ≠ (ε : Λ), from bot_ne_coe) a)).get hL).fst

@[mk_iff] structure coherent (w : weak_struct_approx β) (t : tangle β) : Prop :=
(coe : w.coherent_coe t)
(bot : w.coherent_bot)

lemma smul_litter_eq_of_supports (w : weak_struct_approx β)
  {π : allowable β} (hπ : w.complete.exactly_approximates π.to_struct_perm)
  (t : tangle β) (hwc : w.coherent t) (hws : w.supports t)
  (d : support_condition β) (hd : d ∈ designated_support t)
  (B : extended_index β) (L : litter)
  (ih : ∀ (e : support_condition β),
    relation.trans_gen (constrains α β) e (inr L.to_near_litter, B) →
    π • e = w.support_condition_map_or_else e)
  (hc : relation.refl_trans_gen (constrains α β) (inr L.to_near_litter, B) d) :
  struct_perm.derivative B π.to_struct_perm • L =
  (((w B).litter_map L).get
    (hws.litter_mem L B ⟨⟨d, hd, refl_trans_gen_near_litter hc⟩, reduced.mk_litter _ _⟩)).fst :=
begin
  by_cases hflex : inflexible α L B,
  rw inflexible_iff at hflex,
  obtain (⟨γ, δ, ε, hδ, hε, hδε, C, t', rfl, rfl⟩ | ⟨γ, ε, hε, C, a, rfl, rfl⟩) := hflex,
  { have hc₂ := λ c hc, ih _ (relation.trans_gen.single $ constrains.f_map hδ hε hδε C t' c hc),
    have := smul_f_map (δ : Iio_index α) ε _ _ (Iio.coe_injective.ne hδε)
      (allowable.derivative
        (show path ((β : Iic_index α) : type_index) (γ : Iic_index α), from C) π) t',
    rw [← allowable.derivative_cons_apply, allowable.derivative_smul,
      ← struct_perm.derivative_bot_smul, ← struct_perm.derivative_cons] at this,
    exact this.trans (hwc.coe hπ γ δ ε hδ hε hδε C t' _ ⟨d, hd, hc⟩ hc₂), },
  { have hc : (_, _) = (_, _) := ih _ (relation.trans_gen.single $ constrains.f_map_bot hε C a),
    simp only [smul_inl, prod.mk.inj_iff, eq_self_iff_true, and_true] at hc,
    have := smul_f_map (⊥ : Iio_index α) ε _ _ _
      (allowable.derivative
        (show path ((β : Iic_index α) : type_index) (γ : Iic_index α), from C) π) a,
    rw [← allowable.derivative_cons_apply, allowable.derivative_smul,
      ← struct_perm.derivative_bot_smul, ← struct_perm.derivative_cons] at this,
    rw ← hwc.bot hπ γ ε hε C a _ hc,
    refine this.trans _,
    swap 3,
    refine congr_arg _ _,
    swap 3,
    { rw ← allowable.derivative_cons_apply,
      rw ← allowable.derivative_smul
        (show path ((β : Iic_index α) : type_index) ((⊥ : Iic_index α) : type_index),
          from C.cons (bot_lt_coe _)) π a,
      congr,
      sorry, },
    all_goals { sorry, }, },
  { have := hws.litter_mem L B ⟨⟨d, hd, refl_trans_gen_near_litter hc⟩, reduced.mk_litter _ _⟩,
    rw [← struct_perm.of_bot_smul, ← (hπ B).map_litter _ (or.inl (or.inl ⟨this, hflex⟩))],
    refine ((w B).complete_smul_litter_eq L).trans _,
    rw [(w B).flexible_litter_perm_apply_eq, (w B).rough_litter_map_or_else_of_dom],
    exact this,
    exact hflex, },
end

lemma smul_support_condition_eq (w : weak_struct_approx β) (hw : w.precise)
  {π : allowable β} (hπ : w.complete.exactly_approximates π.to_struct_perm)
  (t : tangle β) (hwc : w.coherent t) (hws : w.supports t)
  (c d : support_condition β)
  (hc : relation.refl_trans_gen (constrains α β) c d)
  (hd : d ∈ designated_support t) :
  π • c = w.support_condition_map_or_else c :=
begin
  revert d,
  refine (constrains_wf α β).trans_gen.induction c _,
  rintros c ih d hc hd,
  obtain ⟨a | N, B⟩ := c,
  { refine prod.ext _ rfl,
    change inl _ = inl _,
    refine congr_arg inl _,
    rw [w.smul_atom_eq hπ (hws.atom_mem a B ⟨⟨d, hd, hc⟩, reduced.mk_atom a B⟩),
      weak_near_litter_approx.atom_map_or_else_of_dom], },
  refine prod.ext _ rfl,
  change inr _ = inr _,
  refine congr_arg inr (set_like.coe_injective _),
  have ih' := λ e he, ih e (relation.trans_gen.single he) d
    (relation.refl_trans_gen.head he hc) hd,
  rw w.smul_near_litter_eq_of_precise hw hπ (hws.litter_mem N.1 B _) _,
  { simp only [weak_near_litter_approx.near_litter_map_or_else,
      near_litter.coe_mk, subtype.coe_mk],
    rw (w B).litter_map_or_else_of_dom (hws.litter_mem N.1 B _),
    congr' 1,
    ext a : 1,
    rw [mem_smul_set, mem_image],
    split,
    { rintro ⟨b, hb₁, hb₂⟩,
      have : (_, _) = (_, _) := ih' _ (constrains.symm_diff N _ hb₁ B),
      simp only [smul_inl, smul_inv_smul, prod.mk.inj_iff] at this,
      rw this.1 at hb₂,
      exact ⟨b, hb₁, hb₂⟩, },
    { rintro ⟨b, hb₁, hb₂⟩,
      have : (_, _) = (_, _) := ih' _ (constrains.symm_diff N _ hb₁ B),
      simp only [smul_inl, smul_inv_smul, prod.mk.inj_iff] at this,
      rw ← this.1 at hb₂,
      exact ⟨b, hb₁, hb₂⟩, },
    { exact ⟨⟨d, hd, refl_trans_gen_near_litter hc⟩, reduced.mk_litter _ _⟩, }, },
  refine w.smul_litter_eq_of_supports hπ t hwc hws d hd B N.1 _ (refl_trans_gen_near_litter hc),
  exact λ e he, ih e (trans_gen_near_litter he) d
    (relation.refl_trans_gen.trans he.to_refl (refl_trans_gen_near_litter hc)) hd,
end

lemma smul_eq_smul_tangle (w v : weak_struct_approx β)
  (hw : w.precise) (hv : v.precise)
  (t : tangle β) (h : compatible w v t)
  (hwc : w.coherent t) (hvc : v.coherent t)
  {πw πv : allowable β} (hπw : w.complete.exactly_approximates πw.to_struct_perm)
  (hπv : v.complete.exactly_approximates πv.to_struct_perm) :
  πw • t = πv • t :=
begin
  rw [smul_eq_iff_eq_inv_smul, smul_smul],
  symmetry,
  refine (designated_support t).supports _ _,
  intros c hc,
  rw [mul_smul, inv_smul_eq_iff],
  symmetry,
  rw smul_support_condition_eq w hw hπw t hwc h.w_supports c c relation.refl_trans_gen.refl hc,
  rw smul_support_condition_eq v hv hπv t hvc h.v_supports c c relation.refl_trans_gen.refl hc,
  obtain ⟨a | N, B⟩ := c,
  { simp only [support_condition_map_or_else, prod.mk.inj_iff, eq_self_iff_true, and_true],
    rw [(w B).atom_map_or_else_of_dom, (v B).atom_map_or_else_of_dom],
    refine h.atom_map a B _,
    exact ⟨⟨_, hc, relation.refl_trans_gen.refl⟩, reduced.mk_atom _ _⟩, },
  { simp only [support_condition_map_or_else, prod.mk.inj_iff, eq_self_iff_true, and_true,
      weak_near_litter_approx.near_litter_map_or_else],
    refine set_like.coe_injective _,
    simp only [near_litter.coe_mk, subtype.coe_mk],
    congr' 1,
    { rw [(w B).litter_map_or_else_of_dom, (v B).litter_map_or_else_of_dom, h.litter_map N.1 B _],
      exact ⟨⟨_, hc, refl_trans_gen_near_litter relation.refl_trans_gen.refl⟩,
        reduced.mk_litter _ _⟩, },
    { ext a : 1,
      rw [mem_image, mem_image],
      split;
      rintro ⟨b, hb₁, hb₂⟩;
      refine ⟨b, hb₁, _⟩;
      rw [← hb₂, (w B).atom_map_or_else_of_dom, (v B).atom_map_or_else_of_dom],
      { refine (h.atom_map b B _).symm,
        exact ⟨⟨_, hc, relation.refl_trans_gen.single (constrains.symm_diff N b hb₁ B)⟩,
          reduced.mk_atom _ _⟩, },
      { refine h.atom_map b B _,
        exact ⟨⟨_, hc, relation.refl_trans_gen.single (constrains.symm_diff N b hb₁ B)⟩,
          reduced.mk_atom _ _⟩, }, }, },
end

end weak_struct_approx

end con_nf


/-
Copyright (c) 2021 Gabriel Ebner. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Gabriel Ebner, Scott Morrison
-/
import Std.Tactic.TryThis
import Mathlib.Lean.Expr.Basic
import Mathlib.Tactic.Cache
import Mathlib.Tactic.Core
import Mathlib.Tactic.SolveByElim

/-!
# Library search

This file defines a tactic `library_search`
and a term elaborator `library_search%`
that tries to find a lemma
solving the current goal
(subgoals are solved using `solveByElim`).

```
example : x < x + 1 := library_search%
example : Nat := by library_search
```
-/

namespace Lean.Meta.DiscrTree

/--
Inserts a new key into a discrimination tree,
but only if it is not of the form `#[*]` or `#[=, *, *, *]`.
-/
def insertIfSpecific {α : Type} {s : Bool} [BEq α] (d : DiscrTree α s)
    (keys : Array (DiscrTree.Key s)) (v : α) : DiscrTree α s :=
  if keys == #[Key.star] || keys == #[Key.const `Eq 3, Key.star, Key.star, Key.star] then
    d
  else
    d.insertCore keys v

end Lean.Meta.DiscrTree

namespace Mathlib.Tactic.LibrarySearch

open Lean Meta Std.Tactic.TryThis

initialize registerTraceClass `Tactic.librarySearch

-- from Lean.Server.Completion
private def isBlackListed (declName : Name) : MetaM Bool := do
  if declName == ``sorryAx then return true
  if declName matches .str _ "inj" then return true
  if declName matches .str _ "noConfusionType" then return true
  let env ← getEnv
  pure $ declName.isInternal'
   || isAuxRecursor env declName
   || isNoConfusion env declName
  <||> isRec declName <||> isMatcher declName

/--
A "modifier" for a declaration.
* `none` indicates the original declaration,
* `symm` indicates that (possibly after binders) the declaration is an `=`,
  and we want to consider the symmetric version,
* `mp` indicates that (possibly after binders) the declaration is an `iff`,
  and we want to consider the forward direction,
* `mpr` similarly, but for the backward direction.
-/
inductive DeclMod
| none | symm | mp | mpr
deriving DecidableEq

initialize librarySearchLemmas : DeclCache (DiscrTree (Name × DeclMod) true) ←
  DeclCache.mk "librarySearch: init cache" {} fun name constInfo lemmas => do
    if constInfo.isUnsafe then return lemmas
    if ← isBlackListed name then return lemmas
    withNewMCtxDepth do withReducible do
      let (_, _, type) ← forallMetaTelescopeReducing constInfo.type
      let keys ← DiscrTree.mkPath type
      let lemmas := lemmas.insertIfSpecific keys (name, .none)
      match type.getAppFnArgs with
      | (``Eq, #[_, lhs, rhs]) => do
        let keys_symm ← DiscrTree.mkPath (← mkEq rhs lhs)
        pure (lemmas.insertIfSpecific keys_symm (name, .symm))
      | (``Iff, #[lhs, rhs]) => do
        let keys_mp ← DiscrTree.mkPath rhs
        let keys_mpr ← DiscrTree.mkPath lhs
        pure <| (lemmas.insertIfSpecific keys_mp (name, .mp)).insertIfSpecific keys_mpr (name, .mpr)
      | _ => pure lemmas

/-- Shortcut for calling `solveByElim`. -/
def solveByElim (goals : List MVarId) (required : List Expr) (depth) := do
  -- There is only a marginal decrease in performance for using the `symm` and `exfalso`
  -- options for `solveByElim`.
  -- (measured via `lake build && time lake env lean test/librarySearch.lean`).
  let cfg : SolveByElim.Config := { maxDepth := depth, exfalso := true, symm := true }
  let cfg := if !required.isEmpty then cfg.requireUsingAll required else cfg
  _ ← SolveByElim.solveByElim.processSyntax cfg false false [] [] #[] goals

/--
Try to solve the goal either by:
* calling `solveByElim`
* or applying a library lemma then calling `solveByElim` on the resulting goals.

If it successfully closes the goal, returns `none`.
Otherwise, it returns `some a`, where `a : Array (MetavarContext × List MVarId)`,
with an entry for each library lemma which was successfully applied,
containing the metavariable context after the application, and a list of the subsidiary goals.

(Always succeeds, and the metavariable context stored in the monad is reverted,
unless the goal was completely solved.)

(Note that if `solveByElim` solves some but not all subsidiary goals,
this is not currently tracked.)
-/
def librarySearch (goal : MVarId) (lemmas : DiscrTree (Name × DeclMod) s) (required : List Expr)
    (solveByElimDepth := 6) : MetaM <| Option (Array <| MetavarContext × List MVarId) := do
  profileitM Exception "librarySearch" (← getOptions) do
  let ty ← goal.getType
  withTraceNode `Tactic.librarySearch (return m!"{exceptOptionEmoji ·} {ty}") do

  let mut suggestions := #[]

  let state0 ← get

  try
    solveByElim [goal] required solveByElimDepth
    return none
  catch _ =>
    set state0

  for (lem, mod) in ← lemmas.getMatch ty do
    trace[Tactic.librarySearch] "{lem}"
    let result ← withTraceNode `Tactic.librarySearch (return m!"{exceptOptionEmoji ·} trying {lem}")
      try
        let lem ← mkConstWithFreshMVarLevels lem
        let lem ← match mod with
        | .none => pure lem
        | .symm => mapForallTelescope (fun e => mkAppM ``Eq.symm #[e]) lem
        | .mp => mapForallTelescope (fun e => mkAppM ``Iff.mp #[e]) lem
        | .mpr => mapForallTelescope (fun e => mkAppM ``Iff.mpr #[e]) lem
        let newGoals ← goal.apply lem
        (try
          for newGoal in newGoals do
            trace[Tactic.librarySearch] "proving {← addMessageContextFull (mkMVar newGoal)}"
          solveByElim newGoals required solveByElimDepth
          pure $ some $ Sum.inr ()
        catch _ =>
          let res := some $ Sum.inl (← getMCtx, newGoals)
          set state0
          return res)
    catch _ =>
      set state0
      pure none
    match result with
    | none => pure ()
    | some (Sum.inr ()) => return none
    | some (Sum.inl suggestion) => suggestions := suggestions.push suggestion

  pure $ some suggestions

def lines (ls : List MessageData) :=
  MessageData.joinSep ls (MessageData.ofFormat Format.line)

open Lean.Parser.Tactic

-- TODO: implement the additional options for `library_search` from Lean 3,
-- in particular including additional lemmas
-- with `library_search [X, Y, Z]` or `library_search with attr`.
syntax (name := librarySearch') "library_search" (config)? (simpArgs)?
  (" using " (colGt term),+)? : tactic
syntax (name := librarySearch!) "library_search!" (config)? (simpArgs)?
  (" using " (colGt term),+)? : tactic

-- For now we only implement the basic functionality.
-- The full syntax is recognized, but will produce a "Tactic has not been implemented" error.

open Elab.Tactic Elab Tactic in
elab_rules : tactic | `(tactic| library_search%$tk $[using $[$required:term],*]?) => do
  let mvar ← getMainGoal
  let (_, goal) ← (← getMainGoal).intros
  goal.withContext do
    let required := (← (required.getD #[]).mapM getFVarId).toList.map .fvar
    if let some suggestions ← librarySearch goal (← librarySearchLemmas.get) required then
      for suggestion in suggestions do
        withMCtx suggestion.1 do
          addExactSuggestion tk (← instantiateMVars (mkMVar mvar)).headBeta
      admitGoal goal
    else
      addExactSuggestion tk (← instantiateMVars (mkMVar mvar)).headBeta

open Elab Term in
elab tk:"library_search%" : term <= expectedType => do
  let goal ← mkFreshExprMVar expectedType
  let (_, introdGoal) ← goal.mvarId!.intros
  introdGoal.withContext do
    if let some suggestions ← librarySearch introdGoal (← librarySearchLemmas.get) [] then
      for suggestion in suggestions do
        withMCtx suggestion.1 do
          addTermSuggestion tk (← instantiateMVars goal).headBeta
      mkSorry expectedType (synthetic := true)
    else
      addTermSuggestion tk (← instantiateMVars goal).headBeta
      instantiateMVars goal


import tactic
import tactic.monotonicity
import tactic.norm_num
import category.basic
import category.nursery
import data.equiv.nursery
import data.serial.medium

universes u v w

abbreviation put_m' := medium.put_m'.{u} unsigned
abbreviation put_m  := medium.put_m'.{u} unsigned punit
abbreviation get_m  := medium.get_m.{u} unsigned

def serial_inverse {α : Type u} (encode : α → put_m) (decode : get_m α) : Prop :=
∀ w, decode -<< encode w = pure w

class serial (α : Type u) :=
  (encode : α → put_m)
  (decode : get_m α)
  (correctness : ∀ w, decode -<< encode w = pure w)

class serial1 (f : Type u → Type v) :=
  (encode : Π {α}, (α → put_m) → f α → put_m)
  (decode : Π {α}, get_m α → get_m (f α))
  (correctness : ∀ {α} put get, serial_inverse.{u} put get →
                 ∀ (w : f α), decode get -<< encode put w = pure w)

instance serial.serial1 {f α} [serial1 f] [serial α] : serial (f α) :=
{ encode := λ x, serial1.encode serial.encode x,
  decode := serial1.decode f (serial.decode α),
  correctness := serial1.correctness _ _ serial.correctness }

class serial2 (f : Type u → Type v → Type w) :=
  (encode : Π {α β}, (α → put_m.{u}) → (β → put_m.{v}) → f α β → put_m.{w})
  (decode : Π {α β}, get_m α → get_m β → get_m (f α β))
  (correctness : ∀ {α β} putα getα putβ getβ,
                   serial_inverse putα getα →
                   serial_inverse putβ getβ →
                 ∀ (w : f α β), decode getα getβ -<< encode putα putβ w = pure w)

instance serial.serial2 {f α β} [serial2 f] [serial α] [serial β] : serial (f α β) :=
{ encode := λ x, serial2.encode serial.encode serial.encode x,
  decode := serial2.decode f (serial.decode _) (serial.decode _),
  correctness := serial2.correctness _ _ _ _ serial.correctness serial.correctness }

instance serial1.serial2 {f α} [serial2 f] [serial α] : serial1 (f α) :=
{ encode := λ β put x, serial2.encode serial.encode put x,
  decode := λ β get, serial2.decode f (serial.decode _) get,
  correctness := λ β get put, serial2.correctness _ _ _ _ serial.correctness  }

export serial (encode decode)

namespace serial

open function
export medium (hiding put_m get_m put_m')

variables {α β σ γ : Type u} {ω : Type}

def serialize [serial α] (x : α) : list unsigned := (encode x).eval
def deserialize (α : Type u) [serial α] (bytes : list unsigned) : option α := (decode α).eval bytes

lemma deserialize_serialize  [serial α] (x : α) :
  deserialize _ (serialize x) = some x :=
by simp [deserialize,serialize,eval_eval,serial.correctness]; refl

lemma encode_decode_bind [serial α]
  (f : α → get_m β) (f' : punit → put_m) (w : α) :
  (decode α >>= f) -<< (encode w >>= f') = f w -<< f' punit.star :=
by { rw [read_write_mono]; rw serial.correctness; refl }

lemma encode_decode_bind' [serial α]
  (f : α → get_m β) (w : α) :
  (decode α >>= f) -<< (encode w) = f w -<< pure punit.star :=
by { rw [read_write_mono_left]; rw serial.correctness; refl }

lemma encode_decode_pure
  (w w' : α) (u : punit) :
  (pure w : get_m α) -<< (pure u) = pure w' ↔ w = w' :=
by split; intro h; cases h; refl

open ulift

protected def ulift.encode [serial α] (w : ulift.{v} α) : put_m :=
(liftable1.up _ equiv.punit_equiv_punit (encode (down w) : medium.put_m' unsigned _) : medium.put_m' unsigned _)

protected def ulift.decode [serial α] : get_m (ulift α) :=
get_m.up ulift.up (decode α)

instance [serial α] : serial (ulift.{v u} α) :=
{ encode := ulift.encode
, decode := ulift.decode
, correctness :=
  by { introv, simp [ulift.encode,ulift.decode],
       rw up_read_write' _ equiv.ulift.symm,
       rw [serial.correctness], cases w, refl,
       intro, refl } }

instance unsigned.serial : serial unsigned :=
{ encode := λ w, put_m'.write w put_m'.pure
, decode := get_m.read get_m.pure
, correctness := by introv; refl }

-- protected def write_word (w : unsigned) : put_m :=
-- encode (up.{u} w)

@[simp] lemma loop_read_write_word {α β γ : Type u}
  (w : unsigned) (x : α) (f : α → unsigned → get_m (β ⊕ α)) (g : β → get_m γ)
  (rest : punit → put_m) :
  get_m.loop f g x -<< (write_word w >>= rest) =
  (f x w >>= get_m.loop.rest f g) -<< rest punit.star := rfl

@[simp] lemma loop_read_write_word' {α β γ : Type u}
  (w : unsigned) (x : α) (f : α → unsigned → get_m (β ⊕ α)) (g : β → get_m γ)  :
  get_m.loop f g x -<< (write_word w) =
  (f x w >>= get_m.loop.rest f g) -<< pure punit.star := rfl

-- protected def read_word : get_m.{u} (ulift unsigned) :=
-- decode _

def select_tag' (tag : unsigned) : list (unsigned × get_m α) → get_m α
| [] := get_m.fail
| ((w,x) :: xs) := if w = tag then x else select_tag' xs

def select_tag (xs : list (unsigned × get_m α)) : get_m α :=
do w ← read_word,
   select_tag' (down w) xs

@[simp]
lemma read_write_tag_hit {w w' : unsigned} {x : get_m α}
  {xs : list (unsigned × get_m α)} {y : put_m}
  (h : w = w') :
  select_tag ( (w,x) :: xs ) -<< (write_word w' >> y) = x -<< y :=
by subst w'; simp [select_tag,(>>),encode_decode_bind,select_tag']

lemma read_write_tag_hit' {w w' : unsigned} {x : get_m α}
  {xs : list (unsigned × get_m α)}
  (h : w = w') :
  select_tag ( (w,x) :: xs ) -<< (write_word w') = x -<< pure punit.star :=
by subst w'; simp [select_tag,(>>),encode_decode_bind',select_tag']

@[simp]
lemma read_write_tag_miss {w w' : unsigned} {x : get_m α}
  {xs : list (unsigned × get_m α)} {y : put_m}
  (h : w ≠ w') :
  select_tag ( (w,x) :: xs ) -<< (write_word w' >> y) = select_tag xs -<< (write_word w' >> y) :=
by simp [select_tag,(>>),encode_decode_bind,select_tag',*]

def recursive_parser {α} : ℕ → (get_m α → get_m α) → get_m α
| 0 _ := get_m.fail
| (nat.succ n) rec_fn := rec_fn $ recursive_parser n rec_fn

lemma recursive_parser_unfold {α} (n : ℕ) (f : get_m α → get_m α) (h : 1 ≤ n) :
  recursive_parser n f = f (recursive_parser (n-1) f) :=
by cases n; [ cases h, refl ]

attribute [simp] serial.correctness

end serial

structure serializer (α : Type u) (β : Type u) :=
(encoder : α → put_m.{u})
(decoder : get_m β)

def serial.mk_serializer' (α) [serial α] : serializer α α :=
{ encoder := encode,
  decoder := decode α }

namespace serializer

def valid_serializer {α} (x : serializer α α) :=
serial_inverse
      (serializer.encoder x)
      (serializer.decoder x)

lemma serializer.eq {α β} (x y : serializer α β)
  (h : x.encoder = y.encoder)
  (h' : x.decoder = y.decoder) :
  x = y :=
by cases x; cases y; congr; assumption

namespace serializer.seq

variables {α : Type u} {i j : Type u}
variables (x : serializer α (i → j))
variables (y : serializer α i)

def encoder := λ (k : α), (x.encoder k >> y.encoder k : put_m' _)
def decoder := x.decoder <*> y.decoder

end serializer.seq

instance {α : Type u} : applicative (serializer.{u} α) :=
{ pure := λ i x, { encoder := λ _, (return punit.star : put_m' _), decoder := pure x }
, seq := λ i j x y,
  { encoder := serializer.seq.encoder x y
  , decoder := serializer.seq.decoder x y } }

section lawful_applicative

variables {α β : Type u} {σ : Type u}

@[simp]
lemma decoder_pure (x : β) :
  (pure x : serializer σ β).decoder = pure x := rfl

@[simp]
lemma decoder_map (f : α → β) (x : serializer σ α) :
  (f <$> x).decoder = f <$> x.decoder := rfl

@[simp]
lemma decoder_seq (f : serializer σ (α → β)) (x : serializer σ α) :
  (f <*> x).decoder = f.decoder <*> x.decoder := rfl

@[simp]
lemma encoder_pure (x : β) (w : σ) :
  (pure x : serializer σ β).encoder w = (pure punit.star : put_m' _) := rfl

@[simp]
lemma encoder_map (f : α → β) (w : σ) (x : serializer σ α) :
  (f <$> x : serializer σ β).encoder w = x.encoder w := rfl

@[simp]
lemma encoder_seq (f : serializer σ (α → β)) (x : serializer σ α) (w : σ) :
  (f <*> x : serializer σ β).encoder w = (f.encoder w >> x.encoder w : put_m' _) := rfl

end lawful_applicative

instance {α} : is_lawful_functor (serializer.{u} α) :=
by refine { .. }; intros; apply serializer.eq; try { ext }; simp [map_map]

instance {α} : is_lawful_applicative (serializer.{u} α) :=
by{  constructor; intros; apply serializer.eq; try { ext };
     simp [(>>),pure_seq_eq_map,seq_assoc,bind_assoc],  }

protected def up {β} (ser : serializer β β) : serializer (ulift.{u v} β) (ulift.{u v} β) :=
{ encoder := pliftable.up' _ ∘ ser.encoder ∘ ulift.down,
  decoder := medium.get_m.up ulift.up ser.decoder }

def ser_field_with {α β} (ser : serializer β β) (f : α → β) : serializer α β :=
{ encoder := ser.encoder ∘ f,
  decoder := ser.decoder }

@[simp]
def ser_field_with' {α β} (ser : serializer β β) (f : α → β) : serializer.{max u v} α (ulift.{v} β) :=
ser_field_with ser.up (ulift.up ∘ f)

@[simp]
def ser_field {α β} [serial β] (f : α → β) : serializer α β :=
ser_field_with (serial.mk_serializer' β) f

@[simp]
lemma valid_mk_serializer (α) [serial α] :
  valid_serializer (serial.mk_serializer' α) :=
serial.correctness

variables {α β σ γ : Type u} {ω : Type}

def there_and_back_again
  (y : serializer γ α) (w : γ) : option α :=
y.decoder -<< y.encoder w

open medium (hiding put_m put_m' get_m)

lemma there_and_back_again_seq {ser : serializer α α}
  {x : serializer γ (α → β)} {f : α → β} {y : γ → α} {w : γ} {w' : β}
  (h' : there_and_back_again x w = pure f)
  (h : w' = f (y w))
  (h₀ : valid_serializer ser) :
  there_and_back_again (x <*> ser_field_with ser y) w = pure w' :=
by { simp [there_and_back_again,(>>),seq_eq_bind_map] at *,
     rw [read_write_mono h',map_read_write],
     rw [ser_field_with,h₀], subst w', refl }

lemma there_and_back_again_map {ser : serializer α α}
  {f : α → β} {y : γ → α} {w : γ}
  (h₀ : valid_serializer ser) :
  there_and_back_again (f <$> ser_field_with ser y) w = pure (f $ y w) :=
by rw [← pure_seq_eq_map,there_and_back_again_seq]; refl <|> assumption

lemma there_and_back_again_pure (x : β) (w : γ) :
  there_and_back_again (pure x) w =
  pure x := rfl

lemma valid_serializer_of_there_and_back_again
      {α : Type*} (y : serializer α α) :
  valid_serializer y ↔
  ∀ (w : α), there_and_back_again y w = pure w :=
by { simp [valid_serializer,serial_inverse],
     repeat { rw forall_congr, intro }, refl }

@[simp]
lemma valid_serializer_up (x: serializer α α) :
  valid_serializer (serializer.up.{v} x) ↔ valid_serializer x :=
by { cases x, simp [valid_serializer,serializer.up,serial_inverse,equiv.forall_iff_forall equiv.ulift],
     apply forall_congr, intro, dsimp [equiv.ulift,pliftable.up'],
     rw up_read_write' _ equiv.ulift.symm, split; intro h,
     { replace h := congr_arg (liftable1.down.{u} option (equiv.symm equiv.ulift)) h,
       simp [liftable1.down_up] at h, simp [h], refl },
     { simp [h], refl },
     { intro, refl, } }

open ulift

def ser_field' {α β} [serial β] (f : α → β) : serializer.{max u v} α (ulift.{v} β) :=
ser_field (up ∘ f)

def put₀ {α} (x : α) : put_m.{u} := (pure punit.star : put_m' _)
def get₀ {α} : get_m α := get_m.fail

def of_encoder {α} (x : α → put_m) : serializer α α :=
⟨ x, get₀ ⟩

def of_decoder {α} (x : get_m α) : serializer α α :=
⟨ put₀, x ⟩

section applicative

@[simp]
lemma encoder_ser_field (f : β → α) (x : serializer α α) (w : β) :
  (ser_field_with x f).encoder w = x.encoder (f w) := rfl

@[simp]
lemma encoder_up (x : serializer α α) (w : ulift α) :
  (serializer.up x).encoder w = pliftable.up' _ (x.encoder $ w.down) := rfl

@[simp]
lemma encoder_of_encoder (x : α → put_m) (w : α) :
  (of_encoder x).encoder w = x w := rfl

@[simp]
lemma decoder_ser_field (f : β → α) (x : serializer α α) :
  (ser_field_with x f).decoder = x.decoder := rfl

@[simp]
lemma decoder_up (x : serializer α α) :
  (serializer.up x).decoder = (x.decoder).up ulift.up := rfl

@[simp]
lemma decoder_of_decoder (x : get_m α) :
  (of_decoder x).decoder = x := rfl

end applicative
end serializer

namespace serial

open serializer

def of_serializer {α} (s : serializer α α)
  (h : ∀ w, there_and_back_again s w = pure w) : serial α :=
{ encode := s.encoder
, decode := s.decoder
, correctness := @h }

def of_serializer₁ {f : Type u → Type v}
  (s : Π α, serializer α α → serializer (f α) (f α))
  (h : ∀ α ser, valid_serializer ser →
       ∀ w, there_and_back_again (s α ser) w = pure w)
  (h₀ : ∀ {α} ser w, (s α (of_encoder (encoder ser))).encoder w = (s α ser).encoder w)
  (h₁ : ∀ {α} ser, (s α (of_decoder (decoder ser))).decoder = (s α ser).decoder) : serial1 f :=
{ encode := λ α put, (s α (of_encoder put)).encoder
, decode := λ α get, (s α (of_decoder get)).decoder
, correctness := by { introv hh, simp [h₀ ⟨put, get⟩,h₁ ⟨put,get⟩], apply h; assumption } }

def of_serializer₂ {f : Type u → Type v → Type w}
  (s : Π α β, serializer α α →
              serializer β β →
              serializer (f α β) (f α β))
  (h : ∀ α β serα serβ, valid_serializer serα → valid_serializer serβ →
       ∀ w, there_and_back_again (s α β serα serβ) w = pure w)
  (h₀ : ∀ {α β} serα serβ w, (s α β (of_encoder (encoder serα)) (of_encoder (encoder serβ))).encoder w = (s α β serα serβ).encoder w)
  (h₁ : ∀ {α β} serα serβ, (s α β (of_decoder (decoder serα)) (of_decoder (decoder serβ))).decoder = (s α β serα serβ).decoder) : serial2 f :=
{ encode := λ α β putα putβ, (s α β (of_encoder putα) (of_encoder putβ)).encoder
, decode := λ α β getα getβ, (s α β (of_decoder getα) (of_decoder getβ)).decoder
, correctness := by { introv hα hβ, simp [h₀ ⟨putα,getα⟩ ⟨putβ,getβ⟩,h₁ ⟨putα,getα⟩ ⟨putβ,getβ⟩],
                      apply h; assumption } }

end serial

namespace tactic
open interactive
open interactive.types
open lean.parser

meta def interactive.mk_serializer (p : parse texpr) : tactic unit :=
do g ← mk_mvar,
   refine ``(serial.of_serializer %%p %%g) <|>
     refine ``(serial.of_serializer₁ (λ α ser, %%p) %%g _ _) <|>
     refine ``(serial.of_serializer₂ (λ α β ser_α ser_β, %%p) %%g _ _),
   gs ← get_goals,
   set_goals [g],
   vs ← intros,
   cases vs.ilast,
   iterate $
     applyc ``serializer.there_and_back_again_map <|>
     applyc ``serializer.there_and_back_again_pure <|>
     applyc ``serializer.there_and_back_again_seq,
  gs' ← get_goals,
  set_goals (gs ++ gs'),
  repeat $
    intros >>
    `[simp *] <|>
    reflexivity

end tactic


/-
Copyright (c) 2022 Jannis Limperg. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jannis Limperg
-/

import Aesop

example : True := by
  aesop (options := { noSuchOption := true })

example : True := by
  aesop (simp_options := { noSuchOption := true })


syntax "tac" : tactic
theorem a : True := by tac
#check a -- should be declared

theorem a' : True ∧ True := ⟨by tac, by tac⟩
#check a' -- should be declared

syntax "term" : term
def b (n : Nat) : Nat := term
#print b -- should be declared


syntax:1021 term:1021 "·" term:1022 : term
macro_rules
  | `($a·$f $args*) => `($f $a $args*)
  | `($a·$f)        => `($f $a)

example [Add a] (x y : a) (f : a → b) (g : b → c) (h : c → a) : a := y + x·f·g·h + x·id


import Graph.Graph
import Graph.UndirectedGraph
import Std

/-!
## Traverse
-/

namespace Graph

variable {α : Type} [Inhabited α] {β : Type}

private def depthFirstTraverseAux (g : Graph α β) (visit : Nat -> γ -> γ × Bool) (leave : (Nat -> γ -> γ )) (state : γ) (sources : Array Nat) (visited : Array Bool) : Nat -> γ × Bool × Array Bool
  | 0 => (state, true, #[])
  | n + 1 => Id.run do
    let mut visited := visited
    let mut state := state
    for id in sources do
      if visited[id]! then continue else
      visited := visited.set! id true
      let (newState, terminate?) := visit id state;
      state := newState
      if terminate? then return (leave id state, true, #[]) else
      let adjacencyList := (g.vertices[id]!.adjacencyList.map (λ edge => edge.target)).filter (!visited[.]!)
      let (newState, terminate?, newVisited) := g.depthFirstTraverseAux visit leave state adjacencyList visited n
      visited := newVisited
      state := leave id newState
      if terminate? then return (state, true, #[])

    return (state, false, visited)

/-- A depth-first traversal of the graph starting at `sources`. Nodes on the same "level" of the traversal are visited in order of the edges added.
    `visit` is a function executed at each vertex, its parameters are the vertex ID and the current state, it should return a new state and
    a boolean which terminates the traversal if true (but it will still leave the node). The optional parameter `leave` is executed when the node is left,
    when all its successors have been visited, uses the same state.
    Please provide a starting state. See example uses in `Graph.TraverseExample`. -/
def depthFirstTraverse (g : Graph α β) (sources : Array Nat) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (leave : Nat -> γ -> γ  := (λ _ x => x)) : γ :=
  (g.depthFirstTraverseAux visit leave startingState sources (mkArray g.vertexCount false) (g.vertexCount)).1

/-- A depth-first traversal started from all vertices in order. Each vertex is visited exactly once. See `depthFirstTraverse` for more info. -/
def depthFirstCompleteTraverse (g : Graph α β) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (leave : Nat -> γ -> γ  := (λ _ x => x)) : γ :=
  g.depthFirstTraverse g.getAllVertexIDs startingState visit leave

private def breadthFirstTraverseAux (g : Graph α β) (visit : Nat -> γ -> γ × Bool) (state : γ) (startingSources : Array Nat) (sources : Array Nat) (visited : Array Bool) : Nat -> γ
  | 0 => state
  | n + 1 => Id.run do
    let mut visited := visited
    let mut state := state
    let mut nextSources : Lean.HashSet Nat := Lean.HashSet.empty
    for id in sources do
      visited := visited.set! id true
      let (newState, terminate?) := visit id state;
      state := newState
      if terminate? then return state else
      let adjacencyList := (g.vertices[id]!.adjacencyList.map (λ edge => edge.target))
      for targetId in adjacencyList do nextSources := nextSources.insert targetId

    let sourcesArray : Array Nat := nextSources.fold (λ arr id => if visited[id]! then arr else arr.push id) #[]
    let startingSources := startingSources.filter (!visited[.]!)
    match (sourcesArray.isEmpty, startingSources.isEmpty) with
      | (false, _) => g.breadthFirstTraverseAux visit state startingSources sourcesArray visited n
      | (_, false) => g.breadthFirstTraverseAux visit state startingSources.pop #[startingSources.back] visited n
      | (true, true) => state

/-- A breadth-first traversals of the graph starting at the `sources` in order, sources should not contain duplicates. Each vertex is only visited at most once.
    Nodes on the same "level" of the traversal will be visited in random order. If you need the order to be fixed then have a look at `breadthFirstTraverseDeprecated`.
    `visit` is a function executed at each vertex, its parameters are the vertex ID and the current state, it should return a new state and a boolean which terminates
    the traversal if true. Please provide a starting state. `maxDepth` is an optional parameter you can use to limit the depth of the traversal.
    See example uses in `Graph.TraverseExample`. -/
def breadthFirstTraverse (g : Graph α β) (sources : Array Nat) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (maxDepth : Nat := g.vertexCount + sources.size) : γ := Id.run do
  g.breadthFirstTraverseAux visit startingState sources.reverse #[] (mkArray g.vertexCount false) maxDepth

/-- A breadth-first traversal started from all vertices in order. Each vertex is visited exactly once. See `breadthFirstTraverse` for more info. -/
def breadthFirstCompleteTraverse (g : Graph α β) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (maxDepth : Nat := g.vertexCount) : γ :=
  g.breadthFirstTraverse g.getAllVertexIDs startingState visit maxDepth

namespace UndirectedGraph

/-- See directed graph. -/
def depthFirstTraverse (ug : UndirectedGraph α β) (sources : Array Nat) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (leave : Nat -> γ -> γ  := (λ _ x => x)) : γ :=
  ug.graph.depthFirstTraverse sources startingState visit leave

/-- See directed graph. -/
def depthFirstCompleteTraverse (ug : UndirectedGraph α β) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (leave : Nat -> γ -> γ  := (λ _ x => x)) : γ :=
  ug.graph.depthFirstCompleteTraverse startingState visit leave

/-- See directed graph. -/
def breadthFirstTraverse (ug : UndirectedGraph α β) (sources : Array Nat) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (maxDepth : Nat := ug.vertexCount) : γ :=
  ug.graph.breadthFirstTraverse sources startingState visit maxDepth

/-- See directed graph. -/
def breadthFirstCompleteTraverse (ug : UndirectedGraph α β) (startingState : γ ) (visit : Nat -> γ -> γ × Bool) (maxDepth : Nat := ug.vertexCount) : γ :=
  ug.graph.breadthFirstCompleteTraverse startingState visit maxDepth

end UndirectedGraph
end Graph


import GeneralizedRewriting.Algorithm
import GeneralizedRewriting.Eauto

section Examples

variable (α β γ: Type)
variable (Rα: relation α) (Rβ: relation β) (Rγ: relation γ)
variable (Pα: α → Prop) (Pβ: β → Prop) (Pγ: γ → Prop)
variable (Pαβγ: α → β → Prop)
variable (fαβ: α → β) (fβγ: β → γ)
variable [Proper_fαβ: Proper (Rα ==> Rβ) fαβ]
variable [Proper_Pα: Proper (Rα ==> Iff) Pα]
variable [PER Rα] [PER Rβ]

set_option trace.Meta.Tactic.grewrite true
set_option trace.Meta.Tactic.eauto true
set_option trace.Meta.Tactic.eauto.hints true

-- Smallest example
example (h: Rα a a') (finish: Pα a') : Pα a := by
  grewrite h
  exact finish

-- Rewrite a PER within itself
example (h: Rα a a') (finish: Rα a' x) : Rα a x := by
  grewrite h
  exact finish
example (h: Rα a a') (finish: Rα x a') : Rα x a := by
  grewrite h
  exact finish

-- Nested function call
example (h: Rα a a') (finish: Rβ (fαβ a') x): Rβ (fαβ a) x := by
  grewrite h
  exact finish

-- Multiple occurrences
example (h: Rα a a') (finish: Rα a' a'): Rα a a := by
  grewrite h
  exact finish
example (h: Rα a a') (finish: Rα a' a): Rα a a := by
  grewrite h at 1
  exact finish
example (h: Rα a a') (finish: Rα a a'): Rα a a := by
  grewrite h at 2
  exact finish
example (h: Rα a a') (finish: Rα a' a'): Rα a a := by
  grewrite h at -1
  grewrite h at 1
  exact finish

-- More complex selection
example (h: Rα a a') (finish: Pα a'): Pα a ∧ Pα a ∧ Pα a ∧ Pα a ∧ Pα a ∧ Pα a := by
  grewrite h at 5
  grewrite h at - 2 4
  grewrite h
  repeat (constructor; assumption)
  assumption

end Examples


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

/-!
# Pi instances for multiplicative actions

> THIS FILE IS SYNCHRONIZED WITH MATHLIB4.
> Any changes to this file require a corresponding PR to mathlib4.

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

## See also

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

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

namespace pi

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

@[simp, to_additive]
lemma smul_apply' {g : I → Type*} [∀ i, has_smul (f i) (g i)] (s : Π i, f i) (x : Π i, g i) :
  (s • x) i = s i • x i :=
rfl

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

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

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

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

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

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

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

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

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

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

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

instance smul_zero_class (α) {n : ∀ i, has_zero $ f i}
  [∀ i, smul_zero_class α $ f i] :
  @smul_zero_class α (Π i : I, f i) (@pi.has_zero I f n) :=
{ smul_zero := λ c, funext $ λ i, smul_zero _ }

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

instance distrib_smul (α) {n : ∀ i, add_zero_class $ f i} [∀ i, distrib_smul α $ f i] :
  @distrib_smul α (Π i : I, f i) (@pi.add_zero_class I f n) :=
{ smul_add := λ c f g, funext $ λ i, smul_add _ _ _ }

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

instance distrib_mul_action (α) {m : monoid α} {n : ∀ i, add_monoid $ f i}
  [∀ i, distrib_mul_action α $ f i] :
  @distrib_mul_action α (Π i : I, f i) m (@pi.add_monoid I f n) :=
{ ..pi.mul_action _,
  ..pi.distrib_smul _ }

instance distrib_mul_action' {g : I → Type*} {m : Π i, monoid (f i)} {n : Π i, add_monoid $ g i}
  [Π i, distrib_mul_action (f i) (g i)] :
  @distrib_mul_action (Π i, f i) (Π i : I, g i) (@pi.monoid I f m) (@pi.add_monoid I g n) :=
{ .. pi.mul_action',
  .. pi.distrib_smul' }

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

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

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

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

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

end pi

namespace function

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

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

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

end function

namespace set

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

end set

section extend

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

end extend


import basic hp.core

namespace hp

/-- A relation and a directionality.
So eg `<` is encoded as `⟨has_lt, ff⟩` and `>` is encoded as `⟨has_lt, tt⟩`.
`=` is encoded as `⟨eq,ff⟩`.
-/
@[derive decidable_eq]
meta structure rel_inst :=
(r : name)
(dir : bool)

meta def rel_inst.op : name → tactic name
| `eq := pure `eq
| _ := failure

meta def rel_inst.mk_app : rel_inst → expr → expr → tactic expr
| ⟨n,ff⟩ l r := tactic.mk_app n [l,r]
| ⟨n,tt⟩ l r := do n ← rel_inst.op n, tactic.mk_app n [l,r]

meta def rel_inst.flip : rel_inst → rel_inst | ⟨n,d⟩ := ⟨n,bnot d⟩

meta instance : has_coe name rel_inst := ⟨λ n, ⟨n,ff⟩⟩

/-- A `rule` is a lemma of the form `pf : Π ..params, rel lhs rhs`. The parameters `params` should all be concrete.
That is, have types that are not dependent on other parameters.
The effects of setting `rel_inst.dir`:
For example, with `dir := false`, we have
`lhs ≤ rhs`
and with dir true we have `lhs ≥ rhs` or equivalently `rhs ≤ lhs`.
The dir says that we should flip the ordering of lhs and rhs when using the proof term, but that we
 should still consider lhs to be on the left for the purposes of rule composition and rewriting.
 rewrites always occur lhs -> rhs.
-/
@[derive decidable_eq]
meta structure rule :=
(type : expr) -- the type of LHS and RHS.
(rel : rel_inst)
(params : list expr) -- a list of local constants which lhs and rhs and type are in terms of.
(lhs : expr)
(rhs : expr)
(pf : expr) -- if rel_inst.dir then reverse lhs and rhs before feeding to proof. each param is a pi binding

open expr expr.zipper

namespace rule

meta instance : has_lt rule := ⟨λ x y, x.pf < y.pf⟩

meta instance : decidable_rel ((<) : rule → rule → Prop) := by apply_instance

meta def of_proof : expr → tactic rule
| pf := do
    T ← infer_type pf,
    (ctxt, body) ← pure $ telescope.of_pis T,
    locals ← telescope.to_locals ctxt,
    body ← pure $ expr.instantiate_vars body locals,
    (rel_name, lhs, rhs) ← tactic.relation_lhs_rhs body,
    type ← tactic.infer_type lhs,
    pure { type := type
         , rel := rel_inst.mk rel_name ff
         , lhs := lhs
         , rhs := rhs
         , params := locals
         , pf := expr.mk_app pf $ list.reverse locals
         }

meta def flip : rule → rule
| r := {rel := r.rel.flip, lhs := r.rhs, rhs := r.lhs, ..r}

meta def get_lhs_rhs : rule → tactic (expr × expr)
| r := pure $ (r.lhs, r.rhs)

meta def body : rule → tactic expr
| r := tactic.mk_app r.rel.r $ if r.rel.dir then [r.rhs, r.lhs] else [r.lhs, r.rhs]

meta instance rule_has_to_tactic_format : has_to_tactic_format rule :=
⟨λ r, rel_inst.mk_app r.rel r.lhs r.rhs >>= tactic.pp⟩

meta def of_name (n : name) : tactic rule :=
tactic.resolve_name n >>= pure ∘ pexpr.mk_explicit >>= tactic.to_expr >>= of_proof

meta def is_commute_raw : expr → expr → option expr
| (expr.app (expr.app f1 x1) y1) (expr.app (expr.app f2 x2) y2) := do
    guard $ f1 = f2 ∧ x1 = y2 ∧ y1 = x2, pure f1
| _ _ := none

meta def is_commutativity (r : rule) : option expr := is_commute_raw r.lhs r.rhs

meta def is_ground (r : rule)  : bool  := r.params.empty

/-- Returns true when the left hand side is a variable or metavariable. -/
meta def lhs_wildcard : rule → bool := λ r, expr.is_var r.lhs || expr.is_mvar r.lhs

/-- Returns true when the right hand side is a variable or metavariable. -/
meta def rhs_wildcard : rule → bool := λ r, expr.is_var r.rhs || expr.is_mvar r.rhs

meta def with_metas : rule → tactic (list expr × rule) | r := do
    ms ← r.params.mmap (λ lc, do
        m ← (tactic.mk_meta_var $ expr.local_type lc),
        pure (expr.local_uniq_name lc, m)
    ),
    c ← pure $ { rule
                . params := []
                , rel := r.rel
                , type := r.type
                , lhs := instantiate_locals ms r.lhs
                , rhs := instantiate_locals ms r.rhs
                , pf :=  instantiate_locals ms r.pf
                },
    pure (prod.snd <$> ms, c)

meta def instantiate_mvars : rule → tactic rule | r := do
    lhs ← tactic.instantiate_mvars r.lhs,
    rhs ← tactic.instantiate_mvars r.rhs ,
    pf ← tactic.instantiate_mvars r.pf,
    pure $ { lhs := lhs, rhs := rhs, pf := pf , ..r}

meta def mk_trans_proof : expr → expr → tactic expr |p₁ p₂ := tactic.mk_sorry

open tactic

meta def instantiate_params : rule → list expr → tactic rule | r assignments := do
    let zipples := list.zip (expr.local_uniq_name <$> r.params) assignments,
    pure {rule
         . lhs := instantiate_locals zipples r.lhs
         , rhs := instantiate_locals zipples r.rhs
         , pf := instantiate_locals zipples r.pf
         , params := [], ..r }

/-- Take a path entry and compute the right equality congruence rule to use. -/
private meta def mk_congr : expr → zipper.path.entry → tactic expr
| pf (zipper.path.entry.app_fn () a) := tactic.mk_congr_fun pf a
| pf (zipper.path.entry.app_arg f ()) := tactic.mk_congr_arg f pf
| pf _ := fail "rewriting under binders not implemented"

meta def make_congr_proof : expr → expr.zipper.path → tactic expr
| pf z := z.mfoldl mk_congr pf

meta def mk_monotone_proof : expr → zipper → tactic expr
| pf z := tactic.mk_sorry

-- meta def head_rewrite : rule → zipper → tactic rule
-- |r z := do
--     guard (r.rel.r = `eq),
--     pf ← make_congr_proof r.pf z,

open tactic

/-- Take an unparameterised rule - that is, a rule with params = [] - and
    take a list of metavariable, local_const pairs and assign each unassigned mvar in the list to a new local_constant.
    then return a rule with these new local constants as its parameters. -/
private meta def reparameterise : list (expr × expr) → rule → tactic rule | ps r := do
        let mmapper := (λ (p : expr×expr), do
            ⟨m,expr.local_const u_n pp_n bi y⟩ ← pure p,
            ia ← tactic.is_assigned m <|> pure ff,
            if ia then pure m else do
            loc' ← tactic.mk_local' pp_n bi y,
            tactic.unsafe.assign m loc',
            pure loc'
        ),
        ms ← list.mmap mmapper $ ps,
        locals ← pure $ list.bfilter expr.is_local_constant ms,
        ms ← ms.mmap tactic.instantiate_mvars,
        r ← rule.instantiate_mvars r,
        pure {
            params := locals,
            ..r
        }

meta def same_statement : rule → rule → tactic bool |r1 r2 :=
    if r1.params.length ≠ r2.params.length then pure ff else do
    -- [todo] if dirs are different and the rel is non-symmetric then fail.
    if r1.rel.r ≠ r2.rel.r then pure ff else do
    tactic.hypothetically (do
        r3 ← instantiate_params r1 r2.params,
        pure $ (r3.lhs = r2.lhs) && (r3.rhs = r2.rhs)
    ) <|> pure ff

meta def compose : rule → rule → tactic (list rule) | r1 r2 := do
    tactic.hypothetically (do
        (ms1,mr1) ← with_metas r1,
        (ms2,mr2) ← with_metas r2,
        unify mr1.rhs mr2.lhs,
        ps ← pure $ list.zip (ms1 ++ ms2) (r1.params ++ r2.params),
        pf ← mk_trans_proof  mr1.pf mr2.pf,
        r ← pure {rule . type := r1.type, rel := r1.rel, lhs := mr1.lhs, rhs := mr2.rhs, params := [], pf := pf},
        r ← reparameterise ps r,
        pure [r]
    ) <|> pure []

meta structure subcomposition :=
(l : rule)
(r : rule)
(rz : zipper)
(l_assignments : list expr)
(r_assignments : list expr)
(intersection_symbols : list expr)
(new_rule : rule)

/-- Take a pair of rules `lc`, `rc` and find a subterm of lc.rhs that unifies with rc.lhs and then compose them.
 -/
meta def subcompose (lc : rule) (rc : rule) : tactic (list subcomposition) := do
    tactic.hypothetically (do
        (lm,l) ← with_metas lc,
        (rm,r) ← with_metas rc,
        results ← hp.traverse_proper (λ acc z, do -- [todo] replace 'traverse_proper' with traverse monotone.
            if zipper.is_mvar z then pure acc else do
            tactic.hypothetically (do
                unify r.lhs z.cursor transparency.none,
                -- trace_m "subcompose: " $ (lc, rc),
                pf ← tactic.mk_sorry, -- [hack] [todo] get below line to work.
                -- pf  ← make_congr_proof r.pf z >>= mk_trans_proof l.pf,
                new_rule ← pure { rule
                          . type := l.type
                          , params := []
                          , rel := l.rel -- [todo] get from transitivity lemma
                          , lhs := l.lhs
                          , rhs := z.unzip_with r.rhs
                          , pf := pf
                          },
                ps ← pure $ list.zip (lm ++ rm) (lc.params ++ rc.params),
                new_rule ← reparameterise ps new_rule,
                lm ← lm.mmap tactic.instantiate_mvars,
                rm ← rm.mmap tactic.instantiate_mvars,
                intersection_symbols ← hp.get_shared_nodes r.lhs z,
                sc ← pure $ { subcomposition
                             . l := lc
                             , r := rc
                             , rz := z
                             , l_assignments := lm
                             , r_assignments := rm
                             , intersection_symbols := intersection_symbols
                             , new_rule := new_rule
                             },
                pure $ list.cons sc acc
            ) <|> pure acc
        ) [] $ zipper.zip l.rhs,
        pure results
    )

meta def subsume : rule → rule → tactic (list rule)
| r1 r2 := do
    ss ← same_statement r1 r2,
    if ss then pure [] else do
    tactic.hypothetically (do
            (ms1,mr1) ← with_metas r1,
            (ms2,mr2) ← with_metas r2,
            unify mr1.lhs mr2.lhs,
            unify mr1.rhs mr2.rhs,
            ps ← pure $ list.zip (ms1 ++ ms2) (r1.params ++ r2.params),
            r ← reparameterise ps mr1,
            pure [r]
    ) <|> pure []

-- /-- Get the smallest terms on the lhs of rule which are not present on the rhs. [todo] rename to not be confused with `get_destroys`. -/
-- meta def get_destructions (r : rule) : tactic (list zipper) := do
--     (lhs,rhs) ← rule.get_lhs_rhs r,
--     destroys ← minimal_monotone (λ z_lhs, do
--         occs ← find_occurences rhs z_lhs.cursor,
--         guard (occs.empty),
--         pure z_lhs
--     ) lhs,
--     pure destroys

-- /-- Get the smallest terms on the lhs of rule which are not present on the rhs. -/
-- meta def get_creations (r : rule) : tactic (list zipper) := do
--     (lhs,rhs) ← rule.get_lhs_rhs r,
--     creates ← minimal_monotone (λ z_rhs, do
--         occs ← find_occurences lhs z_rhs.cursor,
--         guard (occs.empty),
--         pure z_rhs
--     ) rhs,
--     pure creates

meta def get_creates_aux (rev : bool) : expr → rule → tactic (list rule)
| e r := do
    (ms,mr) ← rule.with_metas r,
    /- idea: `r` creates `e` when there exists a substitution σ such that e ∉ lhs and e ∈ rhs.
       additionally, `e` can't appear in σ. A part of `e` must be non-trivially involved in the rewrite.
    -/
     (lhs,rhs) ← (if rev then prod.swap else id) <$> get_lhs_rhs r,
     rs ← maximal_monotone (λ rhs,
        if rhs.is_mvar || rhs.is_constant then failure else do
        tactic.hypothetically (do
            unify e rhs.cursor transparency.none,
            occs ← find_occurences lhs e, -- [todo] likely optimisable
            guard $ occs.empty,
            r ← reparameterise (list.zip ms mr.params) mr,
            pure r
        )
     ) rhs,
    pure rs

meta def head_rewrite : expr → rule → tactic rule
| e rc := do
    (rm,r) ← with_metas rc,
    tactic.hypothetically (do
        unify e r.lhs,
        ps ← pure $ list.zip rm rc.params,
        new_rule ← reparameterise ps r,
        -- trace_m "head_rewrite: " $ new_rule,
        pure new_rule
    )

meta def congr : zipper.path → rule → tactic rule
| p r := do
   lhs ← pure $ zipper.path.apply p r.lhs,
   rhs ← pure $ zipper.path.apply p r.rhs,
   type ← tactic.infer_type lhs,
   pf ← make_congr_proof r.pf p,
--    trace_m "congr: " $ lhs,

   pure $ { rule
     . type := type
     , rel := r.rel -- [todo] in general this needs to be deduced from monotone lemmas
     , params := r.params
     , lhs := lhs
     , rhs := rhs
     , pf := pf
     }

/-- moves up a zipper path until the rule can be applied. -/
meta def rewrite_on_zipper (r : rule) : zipper → tactic rule
| z := (head_rewrite z.cursor r >>= congr z.get_path) <|> (up z >>= rewrite_on_zipper)

meta def get_creates := get_creates_aux tt
meta def get_destroys := get_creates_aux ff

-- [todo] another case is an 'independent subcompose'. This is where you rw on a param in the upper rule. This also should require a 'target expression' to prevent too many cases from being made.
/- That is,
    a pair r₁, r₂ such that r₁(_,_,r₂,_,_).rhs =?= target and the lhs doesn't and r₁ independently doesn't.
    It might also have to be that a subterm of the RHS unifies in a way that crosses the region between r₁ r₂.
    It will be best to figure this out when I have some specific examples when the above methods are not good enough.
 -/

meta def mmap_children {t : Type → Type} [monad t] (f : telescope → expr → t expr) : telescope → rule → t rule
| Γ r := pure rule.mk
            <*> (Γ ⍄ f $ r.type)
            <*> pure r.rel
            <*> (Γ ⍄ f $ r.params) -- [bug] is this right?
            <*> (Γ ⍄ f $ r.lhs)
            <*> (Γ ⍄ f $ r.rhs)
            <*> (Γ ⍄ f $ r.pf)

meta instance : assignable rule := ⟨@mmap_children⟩

meta def is_def_eq (r₁ r₂ : rule) : tactic bool :=
  tactic.is_success $ (do
    tactic.is_def_eq r₁.lhs r₂.lhs,
    tactic.is_def_eq r₁.rhs r₂.rhs
  )

meta def lhs_param_at : address → rule → bool
| a r := ff <| (do s ← expr.address.follow a r.lhs,
    pure $ (expr.is_local_constant s) ∧ (r.params.any (λ x, s = x)))

-- /-- Alternative implementation of congr using rewrite instead of mk_congr. -/
-- meta def mk_eq_congr : rule → zipper.path → tactic rule
-- | r p := do
--     guard (r.rel.r = `eq),
--     new_type ← tactic.to_expr ```(%%(zipper.unzip ⟨p,r.lhs⟩) = %%(zipper.unzip ⟨p,r.rhs⟩)),
--     new_type ← pure $ expr.pis r.params new_type,
--     pf ← tactic.fabricate new_type (do
--         xs ← intron r.params.length,
--         tactic.rewrite_target r.pf
--     ),
--     rule.of_proof pf

/-- Use the given rule application on the lhs of the target. Will look for congruences. -/
meta def rewrite_conv : rule → conv unit := λ r, do
        lhs ← conv.lhs >>= tactic.instantiate_mvars,
        sub ← tactic.instantiate_mvars r.lhs,
        l ← find_occurences (zipper.zip lhs) r.lhs,
        (z::rest) ← pure l,
        r ← tactic.trace_fail $ rewrite_on_zipper r z,
        -- tactic.trace_m "rewrite_conv: " $ r,
        transitivity,
        apply r.pf,
        -- trace_state, trace r,
        try $ all_goals $ apply_instance <|> prop_assumption,
        pure ()

/-- Checks whether the given rule is a local hyp or derived from one. -/
meta def is_local_hypothesis : rule → tactic bool
| r := (do
    p ← pure $ r.pf,
    ls ← pure $ list_locals p,
    ls ← ls.m_some (λ l, (do
        y ← tactic.infer_type l,
        (`=,_,_) ← tactic.relation_lhs_rhs y,
        pure tt) <|> pure ff
    ),
    pure tt
) <|> pure ff

meta def count_metas : rule → tactic nat
| r := do
    lhs ← tactic.instantiate_mvars r.lhs,
    uns ← traverse_proper (λ t e, pure $
        match expr.as_mvar e.cursor with
        | none := t
        | (some ⟨u,_,_⟩) := table.insert u t
        end) ∅ lhs,
    pure $ table.size $ uns

end rule
end hp


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/

import data.buffer.parser

open lean.parser tactic interactive parser

/--
`restate_axiom` takes a structure field, and makes a new, definitionally simplified copy of it, appending `_lemma` to the name.
The main application is to provide clean versions of structure fields that have been tagged with an auto_param.
-/
meta def restate_axiom (d : declaration) (new_name : name) : tactic unit :=
do (levels, type, value, reducibility, trusted) ← pure (match d.to_definition with
  | declaration.defn name levels type value reducibility trusted :=
    (levels, type, value, reducibility, trusted)
  | _ := undefined
  end),
  (s, u) ← mk_simp_set ff [] [],
  new_type ← (s.dsimplify [] type) <|> pure (type),
  updateex_env $ λ env, env.add (declaration.defn new_name levels new_type value reducibility trusted)

private meta def name_lemma (old : name) (new : option name := none) : tactic name :=
match new with
| none :=
  match old.components.reverse with
  | last :: most := (do let last := last.to_string,
                       let last := if last.to_list.ilast = ''' then
                                     (last.to_list.reverse.drop 1).reverse.as_string
                                   else last ++ "_lemma",
                       return (mk_str_name old.get_prefix last)) <|> failed
  | nil          := undefined
  end
| (some new) := return (mk_str_name old.get_prefix new.to_string)
end

@[user_command] meta def restate_axiom_cmd (meta_info : decl_meta_info)
  (_ : parse $ tk "restate_axiom") : lean.parser unit :=
do from_lemma ← ident,
   new_name ← optional ident,
   from_lemma_fully_qualified ← resolve_constant from_lemma,
  d ← get_decl from_lemma_fully_qualified <|>
    fail ("declaration " ++ to_string from_lemma ++ " not found"),
  do {
    new_name ← name_lemma from_lemma_fully_qualified new_name,
    restate_axiom d new_name
  }


import tactic
import tactic.induction

import .base

lemma A_pw_1_not_hws : ¬A_hws 1 :=
begin
  sorry
end


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sebastian Ullrich
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.bool.lemmas
import Mathlib.Lean3Lib.init.data.string.basic
import Mathlib.Lean3Lib.init.meta.well_founded_tactics

namespace Mathlib

namespace string

namespace iterator

@[simp] theorem next_to_string_mk_iterator (s : string) : next_to_string (mk_iterator s) = s :=
  string_imp.rec (fun (s : List char) => Eq.refl (next_to_string (mk_iterator (string_imp.mk s)))) s

@[simp] theorem length_next_to_string_next (it : iterator) :
    length (next_to_string (next it)) = length (next_to_string it) - 1 :=
  sorry

theorem zero_lt_length_next_to_string_of_has_next {it : iterator} :
    ↥(has_next it) → 0 < length (next_to_string it) :=
  sorry

end iterator

-- TODO(Sebastian): generalize to something like https://doc.rust-lang.org/std/primitive.str.html#method.split

def split (p : char → Bool) (s : string) : List string :=
  split_core p (mk_iterator s) (mk_iterator s)

end Mathlib