/-
Copyright (c) 2019 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.category_theory.concrete_category.default
import Mathlib.category_theory.discrete_category
import Mathlib.category_theory.eq_to_hom
import Mathlib.PostPort

universes v u u_1 u_2 u_3 u_4

namespace Mathlib

/-!
# Category of categories

This file contains the definition of the category `Cat` of all categories.
In this category objects are categories and
morphisms are functors between these categories.

## Implementation notes

Though `Cat` is not a concrete category, we use `bundled` to define
its carrier type.
-/

namespace category_theory

/-- Category of categories. -/
def Cat :=
  bundled category

namespace Cat

protected instance inhabited : Inhabited Cat :=
  { default := bundled.mk (Type u) }

protected instance has_coe_to_sort : has_coe_to_sort Cat :=
  has_coe_to_sort.mk (Type u) bundled.α

protected instance str (C : Cat) : category ↥C :=
  bundled.str C

/-- Construct a bundled `Cat` from the underlying type and the typeclass. -/
def of (C : Type u) [category C] : Cat :=
  bundled.of C

/-- Category structure on `Cat` -/
protected instance category : large_category Cat :=
  category.mk

/-- Functor that gets the set of objects of a category. It is not
called `forget`, because it is not a faithful functor. -/
def objects : Cat ⥤ Type u :=
  functor.mk (fun (C : Cat) => ↥C) fun (C D : Cat) (F : C ⟶ D) => functor.obj F

/-- Any isomorphism in `Cat` induces an equivalence of the underlying categories. -/
def equiv_of_iso {C : Cat} {D : Cat} (γ : C ≅ D) : ↥C ≌ ↥D :=
  equivalence.mk' (iso.hom γ) (iso.inv γ) (eq_to_iso sorry) (eq_to_iso (iso.inv_hom_id γ))

end Cat

/--
Embedding `Type` into `Cat` as discrete categories.

This ought to be modelled as a 2-functor!
-/
@[simp] theorem Type_to_Cat_obj (X : Type u) : functor.obj Type_to_Cat X = Cat.of (discrete X) :=
  Eq.refl (functor.obj Type_to_Cat X)

protected instance Type_to_Cat.faithful : faithful Type_to_Cat :=
  faithful.mk

protected instance Type_to_Cat.full : full Type_to_Cat :=
  full.mk
    fun (X Y : Type (max (max (max u_1 u_2 u_3 u_4) u_1 u_2 u_3) (max u_1 u_2 u_3 u_4) u_1 u_2))
      (F : functor.obj Type_to_Cat X ⟶ functor.obj Type_to_Cat Y) => functor.obj F


import phase2.weak_approx

open cardinal quiver set sum with_bot
open_locale cardinal classical pointwise

universe u

namespace con_nf
variables [params.{u}]

/-!
# Filling in orbits of atoms
-/

namespace weak_near_litter_approx

variables (w : weak_near_litter_approx)

def need_forward_images : set atom := w.atom_map.ran \ w.atom_map.dom
def need_backward_images : set atom := w.atom_map.dom \ w.atom_map.ran

lemma atom_map_ran_small : small w.atom_map.ran :=
begin
  have : small (w.atom_map_or_else '' w.atom_map.dom) := small.image w.atom_map_dom_small,
  refine small.mono _ this,
  rintros _ ⟨a, ha, rfl⟩,
  refine ⟨a, ha, _⟩,
  rw atom_map_or_else_of_dom,
end

lemma need_forward_images_small : small w.need_forward_images :=
small.mono (diff_subset _ _) w.atom_map_ran_small

lemma need_backward_images_small : small w.need_backward_images :=
small.mono (diff_subset _ _) w.atom_map_dom_small

lemma mk_diff_dom_ran (L : litter) :
  #(litter_set L \ (w.atom_map.dom ∪ w.atom_map.ran) : set atom) = #κ :=
begin
  refine le_antisymm _ _,
  { refine ⟨⟨λ a, a.1.2, _⟩⟩,
    intros a b h,
    refine subtype.coe_injective (prod.ext (a.prop.1.trans b.prop.1.symm) _),
    simp only [subtype.val_eq_coe] at h,
    exact h, },
  { by_contra' h,
    have := add_lt_of_lt κ_regular.aleph_0_le h
      (small.union w.atom_map_dom_small w.atom_map_ran_small),
    have := (le_mk_diff_add_mk (litter_set L) _).trans_lt this,
    simp only [mk_litter_set, lt_self_iff_false] at this,
    exact this, },
end

lemma need_images_small (L : litter) :
  #(ℕ × w.need_backward_images ⊕ ℕ × w.need_forward_images) < #κ :=
begin
  simp only [mk_prod, mk_denumerable, lift_aleph_0, lift_uzero, mk_diff_dom_ran, mk_sum, lift_id],
  rw ← mul_add,
  refine lt_of_le_of_lt (mul_le_max _ _) (max_lt (max_lt _ _) _),
  exact Λ_limit.aleph_0_le.trans_lt Λ_lt_κ,
  exact add_lt_of_lt κ_regular.aleph_0_le w.need_backward_images_small w.need_forward_images_small,
  exact Λ_limit.aleph_0_le.trans_lt Λ_lt_κ,
end

lemma le_mk_diff_dom_ran (L : litter) :
  #(ℕ × w.need_backward_images ⊕ ℕ × w.need_forward_images) ≤
    #(litter_set L \ (w.atom_map.dom ∪ w.atom_map.ran) : set atom) :=
begin
  rw [mk_diff_dom_ran],
  exact (w.need_images_small L).le,
end

def orbit_set (L : litter) : set atom :=
(le_mk_iff_exists_subset.mp (w.le_mk_diff_dom_ran L)).some

lemma orbit_set_subset (L : litter) :
  w.orbit_set L ⊆ litter_set L \ (w.atom_map.dom ∪ w.atom_map.ran) :=
(le_mk_iff_exists_subset.mp (w.le_mk_diff_dom_ran L)).some_spec.1

lemma not_mem_need_forward_images_of_mem_orbit_set {a : atom} {L : litter}
  (h : a ∈ w.orbit_set L) : a ∉ w.need_forward_images :=
λ ha, (w.orbit_set_subset L h).2 (or.inr ha.1)

lemma not_mem_need_backward_images_of_mem_orbit_set {a : atom} {L : litter}
  (h : a ∈ w.orbit_set L) : a ∉ w.need_backward_images :=
λ ha, (w.orbit_set_subset L h).2 (or.inl ha.1)

lemma mk_orbit_set (L : litter) :
  #(w.orbit_set L) = #(ℕ × w.need_backward_images ⊕ ℕ × w.need_forward_images) :=
(le_mk_iff_exists_subset.mp (w.le_mk_diff_dom_ran L)).some_spec.2

@[irreducible] noncomputable def orbit_set_equiv (L : litter) :
  w.orbit_set L ≃ ℕ × w.need_backward_images ⊕ ℕ × w.need_forward_images :=
(cardinal.eq.mp (w.mk_orbit_set L)).some

lemma orbit_set_equiv_injective {a₁ a₂ : ℕ × w.need_backward_images ⊕ ℕ × w.need_forward_images}
  {L₁ L₂ : litter} (h : ((w.orbit_set_equiv L₁).symm a₁ : atom) = (w.orbit_set_equiv L₂).symm a₂) :
  L₁ = L₂ ∧ a₁ = a₂ :=
begin
  have h₁ := w.orbit_set_subset L₁ ((w.orbit_set_equiv L₁).symm a₁).prop,
  have h₂ := w.orbit_set_subset L₂ ((w.orbit_set_equiv L₂).symm a₂).prop,
  rw h at h₁,
  cases eq_of_mem_litter_set_of_mem_litter_set h₁.1 h₂.1,
  simp only [subtype.coe_inj, embedding_like.apply_eq_iff_eq] at h,
  exact ⟨rfl, h⟩,
end

lemma orbit_set_equiv_congr {L L' : litter} {a : atom} (ha : a ∈ w.orbit_set L) (h : L = L') :
  w.orbit_set_equiv L ⟨a, ha⟩ = w.orbit_set_equiv L' ⟨a, h ▸ ha⟩ :=
by cases h; refl

lemma orbit_set_equiv_symm_congr {L L' : litter}
  {a : ℕ × ↥(w.need_backward_images) ⊕ ℕ × ↥(w.need_forward_images)} (h : L = L') :
  ((w.orbit_set_equiv L).symm a : atom) = (w.orbit_set_equiv L').symm a :=
by cases h; refl

lemma orbit_set_small (L : litter) : small (w.orbit_set L) :=
begin
  rw [small, mk_orbit_set],
  exact w.need_images_small L,
end

noncomputable def next_forward_image (L : litter) (a : ℕ × w.need_forward_images) : atom :=
(w.orbit_set_equiv (w.litter_perm L)).symm (inr (a.1 + 1, a.2))

noncomputable def next_backward_image (L : litter) : ℕ × w.need_backward_images → atom
| (0, a) := a
| (n + 1, a) := (w.orbit_set_equiv (w.litter_perm L)).symm (inl (n, a))

def next_forward_image_domain (L : litter) : set (ℕ × w.need_forward_images) :=
{a | (a.2 : atom).1 ∈ w.litter_perm.domain ∧ (w.litter_perm^[a.1 + 1] (a.2 : atom).1 = L)}

def next_backward_image_domain (L : litter) : set (ℕ × w.need_backward_images) :=
{a | (a.2 : atom).1 ∈ w.litter_perm.domain ∧ (w.litter_perm.symm^[a.1 + 1] (a.2 : atom).1 = L)}

lemma mk_mem_next_forward_image_domain (L : litter) (n : ℕ) (a : w.need_forward_images) :
  (n, a) ∈ w.next_forward_image_domain L ↔
    (a : atom).1 ∈ w.litter_perm.domain ∧ (w.litter_perm^[n + 1] (a : atom).1 = L) := iff.rfl

lemma mk_mem_next_backward_image_domain (L : litter) (n : ℕ) (a : w.need_backward_images) :
  (n, a) ∈ w.next_backward_image_domain L ↔
    (a : atom).1 ∈ w.litter_perm.domain ∧ (w.litter_perm.symm^[n + 1] (a : atom).1 = L) := iff.rfl

lemma next_forward_image_eq {L₁ L₂ : litter} {a b : ℕ × w.need_forward_images}
  (hL₁ : L₁ ∈ w.litter_perm.domain) (hL₂ : L₂ ∈ w.litter_perm.domain)
  (h : w.next_forward_image L₁ a = w.next_forward_image L₂ b) : L₁ = L₂ :=
begin
  rw [next_forward_image, next_forward_image] at h,
  have ha := w.orbit_set_subset _
    ((w.orbit_set_equiv (w.litter_perm L₁)).symm (inr (a.1 + 1, a.2))).prop,
  have hb := w.orbit_set_subset _
    ((w.orbit_set_equiv (w.litter_perm L₂)).symm (inr (b.1 + 1, b.2))).prop,
  rw h at ha,
  refine w.litter_perm.inj_on hL₁ hL₂ _,
  exact eq_of_mem_litter_set_of_mem_litter_set ha.1 hb.1,
end

lemma next_backward_image_eq {L₁ L₂ : litter} {a b : ℕ × w.need_backward_images}
  (ha : a ∈ w.next_backward_image_domain L₁) (hb : b ∈ w.next_backward_image_domain L₂)
  (hL₁ : L₁ ∈ w.litter_perm.domain) (hL₂ : L₂ ∈ w.litter_perm.domain)
  (h : w.next_backward_image L₁ a = w.next_backward_image L₂ b) : L₁ = L₂ :=
begin
  obtain ⟨m, a⟩ := a,
  obtain ⟨n, b⟩ := b,
  cases m;
  cases n;
  rw [next_backward_image, next_backward_image] at h,
  { simp only [next_backward_image_domain, function.iterate_succ, function.comp_app, mem_set_of_eq,
      function.iterate_zero, id.def] at ha hb,
    rw [← h, ha.2] at hb,
    exact hb.2, },
  { rw subtype.coe_eq_iff at h,
    obtain ⟨h₁, h₂⟩ := h,
    cases w.not_mem_need_backward_images_of_mem_orbit_set ((w.orbit_set_equiv _).symm _).prop h₁, },
  { symmetry' at h,
    rw subtype.coe_eq_iff at h,
    obtain ⟨h₁, h₂⟩ := h,
    cases w.not_mem_need_backward_images_of_mem_orbit_set ((w.orbit_set_equiv _).symm _).prop h₁, },
  { have ha := w.orbit_set_subset _
      ((w.orbit_set_equiv (w.litter_perm L₁)).symm (inl (m, a))).prop,
    have hb := w.orbit_set_subset _
      ((w.orbit_set_equiv (w.litter_perm L₂)).symm (inl (n, b))).prop,
    rw h at ha,
    refine w.litter_perm.inj_on hL₁ hL₂ _,
    exact eq_of_mem_litter_set_of_mem_litter_set ha.1 hb.1, },
end

lemma next_forward_image_injective {L : litter} {a b : ℕ × w.need_forward_images}
  (h : w.next_forward_image L a = w.next_forward_image L b) : a = b :=
begin
  simp only [next_forward_image, subtype.coe_inj, embedding_like.apply_eq_iff_eq, prod.mk.inj_iff,
    add_left_inj] at h,
  exact prod.ext h.1 h.2,
end

lemma next_backward_image_injective {L : litter} {a b : ℕ × w.need_backward_images}
  (ha : a ∈ w.next_backward_image_domain L) (hb : b ∈ w.next_backward_image_domain L)
  (h : w.next_backward_image L a = w.next_backward_image L b) : a = b :=
begin
  obtain ⟨m, a⟩ := a,
  obtain ⟨n, b⟩ := b,
  cases m;
  cases n;
  simp only [prod.mk.inj_iff, subtype.coe_inj, embedding_like.apply_eq_iff_eq, prod.mk.inj_iff,
    false_and, nat.nat_zero_eq_zero, prod.mk.inj_iff, next_backward_image, prod.mk.inj_iff,
    eq_self_iff_true, true_and, subtype.coe_inj] at h ⊢,
  { exact h, },
  { rw subtype.coe_eq_iff at h,
    obtain ⟨h₁, h₂⟩ := h,
    cases w.not_mem_need_backward_images_of_mem_orbit_set ((w.orbit_set_equiv _).symm _).prop h₁, },
  { symmetry' at h,
    rw subtype.coe_eq_iff at h,
    obtain ⟨h₁, h₂⟩ := h,
    cases w.not_mem_need_backward_images_of_mem_orbit_set ((w.orbit_set_equiv _).symm _).prop h₁, },
  { exact h, },
end

lemma next_forward_image_injective' {L₁ L₂ : litter} {a b : ℕ × w.need_forward_images}
  (hL₁ : L₁ ∈ w.litter_perm.domain) (hL₂ : L₂ ∈ w.litter_perm.domain)
  (h : w.next_forward_image L₁ a = w.next_forward_image L₂ b) : a = b :=
begin
  cases w.next_forward_image_eq hL₁ hL₂ h,
  exact w.next_forward_image_injective h,
end

lemma next_backward_image_injective' {L₁ L₂ : litter} {a b : ℕ × w.need_backward_images}
  (ha : a ∈ w.next_backward_image_domain L₁) (hb : b ∈ w.next_backward_image_domain L₂)
  (hL₁ : L₁ ∈ w.litter_perm.domain) (hL₂ : L₂ ∈ w.litter_perm.domain)
  (h : w.next_backward_image L₁ a = w.next_backward_image L₂ b) : a = b :=
begin
  cases w.next_backward_image_eq ha hb hL₁ hL₂ h,
  exact w.next_backward_image_injective ha hb h,
end

lemma next_forward_image_ne_next_backward_image {L₁ L₂ : litter}
  {a : ℕ × w.need_forward_images} {b : ℕ × w.need_backward_images} :
  w.next_forward_image L₁ a ≠ w.next_backward_image L₂ b :=
begin
  obtain ⟨n, b⟩ := b,
  cases n,
  { rw [next_forward_image, next_backward_image],
    refine (ne_of_mem_of_not_mem _
      (w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop).2).symm,
    exact or.inl b.prop.1, },
  { rw [next_forward_image, next_backward_image],
    intro h,
    cases (w.orbit_set_equiv_injective h).2, },
end

noncomputable def next_image_core (a : atom) (L : litter) (ha : a ∈ w.orbit_set L) : atom :=
(w.orbit_set_equiv L ⟨a, ha⟩).elim (w.next_backward_image L) (w.next_forward_image L)

def next_image_core_domain : set atom :=
⋃ L ∈ w.litter_perm.domain, coe '' {a : w.orbit_set L | (w.orbit_set_equiv L a).elim
  (λ b, b ∈ w.next_backward_image_domain L) (λ b, b ∈ w.next_forward_image_domain L)}

lemma next_image_core_domain_small : small w.next_image_core_domain :=
small.bUnion w.litter_perm_domain_small
  (λ L hL, small.image (lt_of_le_of_lt (cardinal.mk_subtype_le _) (w.orbit_set_small L)))

lemma litter_map_dom_of_mem_next_image_core_domain {a : atom} (h : a ∈ w.next_image_core_domain) :
  a.1 ∈ w.litter_perm.domain :=
begin
  rw next_image_core_domain at h,
  simp only [pfun.mem_dom, Union_exists, mem_Union, mem_image, mem_set_of_eq, set_coe.exists,
    subtype.coe_mk, exists_and_distrib_right, exists_eq_right, exists_prop] at h,
  obtain ⟨L, hL, ha, h⟩ := h,
  have := (w.orbit_set_subset L ha).1,
  rw mem_litter_set at this,
  rw this,
  exact hL,
end

lemma mem_orbit_set_of_mem_next_image_core_domain {a : atom} (h : a ∈ w.next_image_core_domain) :
  a ∈ w.orbit_set a.1 :=
begin
  rw next_image_core_domain at h,
  simp only [pfun.mem_dom, Union_exists, mem_Union, mem_image, mem_set_of_eq, set_coe.exists,
    subtype.coe_mk, exists_and_distrib_right, exists_eq_right, exists_prop] at h,
  obtain ⟨L, hL, ha, h⟩ := h,
  have := (w.orbit_set_subset L ha).1,
  rw mem_litter_set at this,
  rw this,
  exact ha,
end

lemma orbit_set_equiv_elim_of_mem_next_image_core_domain {a : atom}
  (h : a ∈ w.next_image_core_domain) :
  (w.orbit_set_equiv a.1 ⟨a, w.mem_orbit_set_of_mem_next_image_core_domain h⟩).elim
    (λ c, c ∈ w.next_backward_image_domain a.1) (λ c, c ∈ w.next_forward_image_domain a.1) :=
begin
  rw next_image_core_domain at h,
  simp only [pfun.mem_dom, Union_exists, mem_Union, mem_image, mem_set_of_eq, set_coe.exists,
    subtype.coe_mk, exists_and_distrib_right, exists_eq_right, exists_prop] at h,
  obtain ⟨L, hL, ha, h⟩ := h,
  have := (w.orbit_set_subset L ha).1,
  rw mem_litter_set at this,
  cases this,
  exact h,
end

lemma next_image_core_injective (a b : atom)
  (ha : a ∈ w.next_image_core_domain) (hb : b ∈ w.next_image_core_domain)
  (h : w.next_image_core a a.1 (w.mem_orbit_set_of_mem_next_image_core_domain ha) =
    w.next_image_core b b.1 (w.mem_orbit_set_of_mem_next_image_core_domain hb)) : a = b :=
begin
  rw [next_image_core, next_image_core] at h,
  obtain ⟨a', ha'⟩ := (w.orbit_set_equiv a.fst).symm.surjective
    ⟨a, w.mem_orbit_set_of_mem_next_image_core_domain ha⟩,
  obtain ⟨b', hb'⟩ := (w.orbit_set_equiv b.fst).symm.surjective
    ⟨b, w.mem_orbit_set_of_mem_next_image_core_domain hb⟩,
  have hae := w.orbit_set_equiv_elim_of_mem_next_image_core_domain ha,
  have hbe := w.orbit_set_equiv_elim_of_mem_next_image_core_domain hb,
  simp only [← ha', ← hb', equiv.apply_symm_apply] at h hae hbe,
  obtain (⟨m, a'⟩ | ⟨m, a'⟩) := a';
  obtain (⟨n, b'⟩ | ⟨n, b'⟩) := b';
  simp only [elim_inl, elim_inr,
    mk_mem_next_backward_image_domain, mk_mem_next_forward_image_domain] at h hae hbe,
  { cases w.next_backward_image_injective' _ _ _ _ h,
    { rw hae.2 at hbe,
      rw [subtype.ext_iff, subtype.coe_mk] at ha' hb',
      rw [← ha', ← hb', hbe.2], },
    { exact hae, },
    { exact hbe, },
    { exact w.litter_map_dom_of_mem_next_image_core_domain ha, },
    { exact w.litter_map_dom_of_mem_next_image_core_domain hb, }, },
  { cases w.next_forward_image_ne_next_backward_image h.symm, },
  { cases w.next_forward_image_ne_next_backward_image h, },
  { cases w.next_forward_image_injective' _ _ h,
    { rw hae.2 at hbe,
      rw [subtype.ext_iff, subtype.coe_mk] at ha' hb',
      rw [← ha', ← hb'],
      exact w.orbit_set_equiv_symm_congr hbe.2, },
    { exact w.litter_map_dom_of_mem_next_image_core_domain ha, },
    { exact w.litter_map_dom_of_mem_next_image_core_domain hb, }, },
end

def next_image_domain : set atom :=
(w.need_forward_images ∩ {a | a.1 ∈ w.litter_perm.domain}) ∪ w.next_image_core_domain

noncomputable def next_image (a : atom) (ha : a ∈ w.next_image_domain) : atom :=
ha.elim'
  (λ ha', (w.orbit_set_equiv (w.litter_perm a.1)).symm (inr (0, ⟨a, ha'.1⟩)))
  (w.next_image_core a a.1 ∘ w.mem_orbit_set_of_mem_next_image_core_domain)

lemma next_image_domain_small : small w.next_image_domain :=
small.union
  (small.mono (inter_subset_left _ _) w.need_forward_images_small)
  w.next_image_core_domain_small

lemma disjoint_need_forward_images_next_image_core_domain :
  disjoint w.need_forward_images w.next_image_core_domain :=
begin
  rw set.disjoint_iff,
  rintro a ⟨ha₁, ha₂⟩,
  exact (w.orbit_set_subset _ (w.mem_orbit_set_of_mem_next_image_core_domain ha₂)).2 (or.inr ha₁.1),
end

lemma next_image_eq_of_need_forward_images (a : atom)
  (ha : a ∈ w.need_forward_images ∧ a.1 ∈ w.litter_perm.domain) :
  w.next_image a (or.inl ha) =
  (w.orbit_set_equiv (w.litter_perm a.1)).symm (inr (0, ⟨a, ha.1⟩)) :=
or.elim'_left _ _ _ ha

lemma next_image_eq_of_mem_next_image_core_domain (a : atom) (ha : a ∈ w.next_image_core_domain) :
  w.next_image a (or.inr ha) =
  w.next_image_core a a.1 (w.mem_orbit_set_of_mem_next_image_core_domain ha) :=
begin
  refine or.elim'_right _ _ _ _,
  exact λ h, set.disjoint_right.mp w.disjoint_need_forward_images_next_image_core_domain ha h.1,
end

lemma orbit_set_equiv_ne_next_image_core (a b : atom)
  (ha : a ∈ w.need_forward_images ∧ a.fst ∈ w.litter_perm.domain)
  (hb : b ∈ w.next_image_core_domain) :
  (((w.orbit_set_equiv (w.litter_perm a.fst)).symm) (inr (0, ⟨a, ha.1⟩)) : atom) ≠
    w.next_image_core b b.fst (w.mem_orbit_set_of_mem_next_image_core_domain hb) :=
begin
  obtain ⟨b', hb'⟩ := (w.orbit_set_equiv b.fst).symm.surjective
    ⟨b, w.mem_orbit_set_of_mem_next_image_core_domain hb⟩,
  rw equiv.symm_apply_eq at hb',
  intro h,
  rw next_image_core at h,
  rw ← hb' at h,
  obtain (⟨_ | n, b'⟩ | b') := b';
  simp only [elim_inl, elim_inr, next_backward_image, next_forward_image] at h,
  { have := w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop,
    rw h at this,
    exact this.2 (or.inl b'.prop.1), },
  { cases (w.orbit_set_equiv_injective h).2, },
  { cases (w.orbit_set_equiv_injective h).2, },
end

lemma next_image_injective (a b : atom)
  (ha : a ∈ w.next_image_domain) (hb : b ∈ w.next_image_domain)
  (h : w.next_image a ha = w.next_image b hb) : a = b :=
begin
  cases ha;
  cases hb;
  simp only [next_image_eq_of_need_forward_images,
    next_image_eq_of_mem_next_image_core_domain] at h,
  { have := w.orbit_set_equiv_injective h,
    simp only [prod.mk.inj_iff, eq_self_iff_true, subtype.mk_eq_mk, true_and] at this,
    exact this.2, },
  { cases w.orbit_set_equiv_ne_next_image_core _ _ _ _ h, },
  { cases w.orbit_set_equiv_ne_next_image_core _ _ _ _ h.symm, },
  { refine w.next_image_core_injective a b ha hb h, },
end

noncomputable def orbit_atom_map : atom →. atom :=
λ a, {
  dom := (w.atom_map a).dom ∨ a ∈ w.next_image_domain,
  get := λ h, or.elim' h (w.atom_map a).get (w.next_image a)
}

@[simp] lemma orbit_atom_map_dom_iff (a : atom) :
  (w.orbit_atom_map a).dom ↔ (w.atom_map a).dom ∨ a ∈ w.next_image_domain := iff.rfl

@[simp] lemma orbit_atom_map_dom :
  w.orbit_atom_map.dom = w.atom_map.dom ∪ w.next_image_domain := rfl

lemma disjoint_atom_map_dom_next_image_domain : disjoint w.atom_map.dom w.next_image_domain :=
begin
  rw set.disjoint_iff,
  rintros a ⟨h₁, h₂ | h₂⟩,
  { exact h₂.1.2 h₁, },
  { exact (w.orbit_set_subset _
      (w.mem_orbit_set_of_mem_next_image_core_domain h₂)).2 (or.inl h₁), },
end

lemma orbit_atom_map_eq_of_mem_dom (a : atom) (ha : (w.atom_map a).dom) :
  (w.orbit_atom_map a).get (or.inl ha) = (w.atom_map a).get ha :=
or.elim'_left _ _ _ _

lemma orbit_atom_map_eq_of_mem_next_image_domain (a : atom) (ha : a ∈ w.next_image_domain) :
  (w.orbit_atom_map a).get (or.inr ha) = w.next_image a ha :=
or.elim'_right _ _ _ (id set.disjoint_right.mp w.disjoint_atom_map_dom_next_image_domain ha)

lemma orbit_atom_map_eq_of_need_forward_images (a : atom)
  (ha : a ∈ w.need_forward_images ∧ a.fst ∈ w.litter_perm.domain) :
  (w.orbit_atom_map a).get (or.inr (or.inl ha)) =
  (w.orbit_set_equiv (w.litter_perm a.1)).symm (inr (0, ⟨a, ha.1⟩)) :=
begin
  unfold orbit_atom_map,
  simp only,
  rw or.elim'_right,
  exact w.next_image_eq_of_need_forward_images a ha,
  exact id set.disjoint_right.mp w.disjoint_atom_map_dom_next_image_domain (or.inl ha),
end

lemma orbit_atom_map_eq_of_mem_next_image_core_domain (a : atom)
  (ha : a ∈ w.next_image_core_domain) :
  (w.orbit_atom_map a).get (or.inr (or.inr ha)) =
    w.next_image_core a a.1 (w.mem_orbit_set_of_mem_next_image_core_domain ha) :=
begin
  unfold orbit_atom_map,
  simp only,
  rw or.elim'_right,
  exact w.next_image_eq_of_mem_next_image_core_domain a ha,
  exact id set.disjoint_right.mp w.disjoint_atom_map_dom_next_image_domain (or.inr ha),
end

lemma orbit_atom_map_dom_small : small w.orbit_atom_map.dom :=
small.union w.atom_map_dom_small w.next_image_domain_small

lemma orbit_atom_map_apply_ne_of_need_forward_images ⦃a b : atom⦄
  (ha : (w.atom_map a).dom) (hb : b ∈ w.need_forward_images ∧ b.fst ∈ w.litter_perm.domain) :
  (w.orbit_atom_map a).get (or.inl ha) ≠ (w.orbit_atom_map b).get (or.inr (or.inl hb)) :=
begin
  rw [orbit_atom_map_eq_of_mem_dom, orbit_atom_map_eq_of_need_forward_images],
  intro h,
  have := w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop,
  rw ← h at this,
  exact this.2 (or.inr ⟨a, ha, rfl⟩),
end

lemma orbit_atom_map_apply_ne_of_mem_next_image_core_domain ⦃a b : atom⦄
  (ha : (w.atom_map a).dom) (hb : b ∈ w.next_image_core_domain) :
  (w.orbit_atom_map a).get (or.inl ha) ≠ (w.orbit_atom_map b).get (or.inr (or.inr hb)) :=
begin
  obtain ⟨b', hb'⟩ := (w.orbit_set_equiv b.fst).symm.surjective
    ⟨b, w.mem_orbit_set_of_mem_next_image_core_domain hb⟩,
  rw [orbit_atom_map_eq_of_mem_dom, orbit_atom_map_eq_of_mem_next_image_core_domain,
    next_image_core, ← hb', equiv.apply_symm_apply],
  obtain (⟨_ | n, b'⟩ | ⟨n, b'⟩) := b';
  simp only [elim_inr, elim_inl, nat.nat_zero_eq_zero, next_backward_image, next_forward_image],
  { intro h,
    have := b'.prop.2,
    rw ← h at this,
    exact this ⟨a, ha, rfl⟩, },
  { intro h,
    have := (w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop).2,
    rw ← h at this,
    exact this (or.inr ⟨a, ha, rfl⟩), },
  { intro h,
    have := (w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop).2,
    rw ← h at this,
    exact this (or.inr ⟨a, ha, rfl⟩), },
end

lemma orbit_atom_map_apply_ne ⦃a b : atom⦄
  (ha : (w.atom_map a).dom) (hb : b ∈ w.next_image_domain) :
  (w.orbit_atom_map a).get (or.inl ha) ≠ (w.orbit_atom_map b).get (or.inr hb) :=
begin
  cases hb,
  exact w.orbit_atom_map_apply_ne_of_need_forward_images ha hb,
  exact w.orbit_atom_map_apply_ne_of_mem_next_image_core_domain ha hb,
end

lemma orbit_atom_map_injective ⦃a b : atom⦄
  (ha : (w.orbit_atom_map a).dom) (hb : (w.orbit_atom_map b).dom)
  (h : (w.orbit_atom_map a).get ha = (w.orbit_atom_map b).get hb) : a = b :=
begin
  cases ha;
  cases hb,
  { rw [orbit_atom_map_eq_of_mem_dom, orbit_atom_map_eq_of_mem_dom] at h,
    exact w.atom_map_injective ha hb h, },
  { cases w.orbit_atom_map_apply_ne ha hb h, },
  { cases w.orbit_atom_map_apply_ne hb ha h.symm, },
  { rw [orbit_atom_map_eq_of_mem_next_image_domain,
      orbit_atom_map_eq_of_mem_next_image_domain] at h,
    exact w.next_image_injective a b ha hb h, },
end

lemma next_image_core_atom_mem_litter_map
  (a : atom) (ha : a ∈ w.next_image_core_domain) :
  w.next_image_core a a.fst (w.mem_orbit_set_of_mem_next_image_core_domain ha) ∈
    litter_set (w.litter_perm a.fst) :=
begin
  have hL := w.litter_map_dom_of_mem_next_image_core_domain ha,
  have := w.mem_orbit_set_of_mem_next_image_core_domain ha,
  obtain ⟨a', ha'⟩ := (w.orbit_set_equiv a.fst).symm.surjective
    ⟨a, w.mem_orbit_set_of_mem_next_image_core_domain ha⟩,
  have := w.orbit_set_equiv_elim_of_mem_next_image_core_domain ha,
  rw [next_image_core],
  rw [← ha', equiv.apply_symm_apply] at this ⊢,
  obtain (⟨_ | n, a'⟩ | ⟨n, a'⟩) := a';
  simp only [elim_inr, elim_inl, nat.nat_zero_eq_zero, next_backward_image, next_forward_image,
    mk_mem_next_backward_image_domain, mk_mem_next_forward_image_domain,
    function.iterate_one] at this ⊢,
  { have ha'' := this.2.symm,
    rw local_perm.eq_symm_apply at ha'',
    { exact ha''.symm, },
    { exact hL, },
    { exact this.1, }, },
  exact (w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop).1,
  exact (w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop).1,
end

lemma next_image_core_not_mem_ran
  (a : atom) (ha : a ∈ w.next_image_core_domain) :
  w.next_image_core a a.fst (w.mem_orbit_set_of_mem_next_image_core_domain ha) ∉ w.atom_map.ran :=
begin
  rintro ⟨b, hb₁, hb₂⟩,
  rw next_image_core at hb₂,
  obtain ⟨a', ha'⟩ := (w.orbit_set_equiv a.fst).symm.surjective
    ⟨a, w.mem_orbit_set_of_mem_next_image_core_domain ha⟩,
  rw [← ha', equiv.apply_symm_apply] at hb₂,
  obtain (⟨_ | n, a'⟩ | ⟨n, a'⟩) := a';
  simp only [elim_inr, elim_inl, nat.nat_zero_eq_zero, next_backward_image, next_forward_image,
    mk_mem_next_backward_image_domain, mk_mem_next_forward_image_domain,
    function.iterate_one] at hb₂,
  { exact a'.prop.2 ⟨b, hb₁, hb₂⟩, },
  all_goals { have := w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop,
    rw ← hb₂ at this,
    exact this.2 (or.inr ⟨b, hb₁, rfl⟩), },
end

lemma next_image_core_atom_mem
  (hdiff : ∀ L hL, ((w.litter_map L).get hL : set atom) ∆ litter_set ((w.litter_map L).get hL).1 ⊆
    w.atom_map.ran)
  (a : atom) (ha : a ∈ w.next_image_core_domain)
  (L : litter) (hL : (w.litter_map L).dom) :
  a.fst = L ↔
    w.next_image_core a a.fst (w.mem_orbit_set_of_mem_next_image_core_domain ha) ∈
      (w.litter_map L).get hL :=
begin
  have hamem := w.mem_orbit_set_of_mem_next_image_core_domain ha,
  have ha' := w.next_image_core_atom_mem_litter_map a ha,
  rw mem_litter_set at ha',
  split,
  { rintro rfl,
    have := not_mem_subset (hdiff _ hL) (w.next_image_core_not_mem_ran a ha),
    simp only [mem_symm_diff, set_like.mem_coe, mem_litter_set,
      not_or_distrib, not_and_distrib, not_not] at this,
    refine this.2.resolve_left (not_not.mpr _),
    rw ha',
    rw w.litter_perm_apply_eq _ hL,
    rw w.rough_litter_map_or_else_of_dom,  },
  { intro h,
    have hL' := w.litter_perm_apply_eq L hL,
    rw w.rough_litter_map_or_else_of_dom hL at hL',
    have := not_mem_subset (hdiff _ hL) (w.next_image_core_not_mem_ran a ha),
    simp only [mem_symm_diff, set_like.mem_coe, mem_litter_set, not_not, h, true_and,
      not_true, and_false, or_false] at this,
    rw [ha', ← hL', ← local_perm.eq_symm_apply, local_perm.left_inv] at this,
    exact this,
    exact or.inl (or.inl (or.inl hL)),
    exact w.litter_map_dom_of_mem_next_image_core_domain ha,
    exact local_perm.map_domain _ (or.inl (or.inl (or.inl hL))), },
end

lemma orbit_set_equiv_atom_mem
  (hdiff : ∀ L hL, ((w.litter_map L).get hL : set atom) ∆ litter_set ((w.litter_map L).get hL).1 ⊆
    w.atom_map.ran)
  (a : atom) (ha : a ∈ w.need_forward_images ∧ a.fst ∈ w.litter_perm.domain)
  (L : litter) (hL : (w.litter_map L).dom) :
  a.fst = L ↔ ((w.orbit_set_equiv (w.litter_perm a.fst)).symm (inr (0, ⟨a, ha.1⟩)) : atom) ∈
    (w.litter_map L).get hL :=
begin
  have ha' : _ ∧ _ := w.orbit_set_subset _
    ((w.orbit_set_equiv (w.litter_perm a.fst)).symm (inr (0, ⟨a, ha.1⟩))).prop,
  rw mem_litter_set at ha',
  split,
  { rintro rfl,
    have := not_mem_subset (hdiff _ hL) _,
    simp only [mem_symm_diff, set_like.mem_coe, mem_litter_set,
      not_or_distrib, not_and_distrib, not_not] at this,
    refine this.2.resolve_left (not_not.mpr _),
    { rw ha'.1,
      rw w.litter_perm_apply_eq _ hL,
      rw w.rough_litter_map_or_else_of_dom, },
    { exact ha'.2 ∘ or.inr, }, },
  { intro h,
    have := @not_mem_subset _
      ((w.orbit_set_equiv (w.litter_perm a.fst)).symm (inr (0, ⟨a, ha.1⟩)) : atom) _ _
      (hdiff L hL) (ha'.2 ∘ or.inr),
    simp only [mem_symm_diff, h, set_like.mem_coe, mem_litter_set, true_and, not_true, and_false,
      or_false, not_not] at this,
    rw [ha'.1, ← rough_litter_map_or_else_of_dom, ← litter_perm_apply_eq,
      ← local_perm.eq_symm_apply, local_perm.left_inv] at this,
    exact this,
    { exact or.inl (or.inl (or.inl hL)), },
    { exact ha.2, },
    { exact w.litter_perm.map_domain (or.inl (or.inl (or.inl hL))), },
    { exact hL, }, },
end

lemma orbit_atom_mem
  (hdiff : ∀ L hL, ((w.litter_map L).get hL : set atom) ∆ litter_set ((w.litter_map L).get hL).1 ⊆
    w.atom_map.ran)
  (a : atom) (ha : (w.orbit_atom_map a).dom)
  (L : litter) (hL : (w.litter_map L).dom) :
  a.fst = L ↔ (w.orbit_atom_map a).get ha ∈ (w.litter_map L).get hL :=
begin
  obtain ha | ha | ha := ha,
  { rw orbit_atom_map_eq_of_mem_dom,
    exact w.atom_mem a ha L hL, },
  { rw orbit_atom_map_eq_of_need_forward_images,
    exact w.orbit_set_equiv_atom_mem hdiff a ha L hL, },
  { rw orbit_atom_map_eq_of_mem_next_image_core_domain,
    rw w.next_image_core_atom_mem hdiff a ha L hL, },
end

noncomputable def fill_atom_orbits
  (hdiff : ∀ L hL, ((w.litter_map L).get hL : set atom) ∆ litter_set ((w.litter_map L).get hL).1 ⊆
    w.atom_map.ran) : weak_near_litter_approx := {
  atom_map := w.orbit_atom_map,
  litter_map := w.litter_map,
  atom_map_dom_small := w.orbit_atom_map_dom_small,
  litter_map_dom_small := w.litter_map_dom_small,
  atom_map_injective := w.orbit_atom_map_injective,
  litter_map_injective := w.litter_map_injective,
  atom_mem := w.orbit_atom_mem hdiff,
}

variables {w} {hdiff : ∀ L hL,
  ((w.litter_map L).get hL : set atom) ∆ litter_set ((w.litter_map L).get hL).1 ⊆ w.atom_map.ran}

@[simp] lemma fill_atom_orbits_atom_map :
  (w.fill_atom_orbits hdiff).atom_map = w.orbit_atom_map := rfl

@[simp] lemma fill_atom_orbits_litter_map :
  (w.fill_atom_orbits hdiff).litter_map = w.litter_map := rfl

lemma subset_orbit_atom_map_dom : w.atom_map.dom ⊆ w.orbit_atom_map.dom :=
subset_union_left _ _

lemma subset_orbit_atom_map_ran : w.atom_map.ran ⊆ w.orbit_atom_map.ran :=
begin
  rintro _ ⟨a, ha, rfl⟩,
  exact ⟨a, subset_orbit_atom_map_dom ha, w.orbit_atom_map_eq_of_mem_dom _ _⟩,
end

lemma fst_mem_litter_perm_domain_of_mem_map ⦃L : litter⦄ (hL : (w.litter_map L).dom)
  ⦃a : atom⦄ (ha : a ∈ (w.litter_map L).get hL) :
  a.1 ∈ w.litter_perm.domain :=
begin
  by_cases a.1 = ((w.litter_map L).get hL).1,
  { rw h,
    refine or.inl (or.inl (or.inr ⟨L, hL, _⟩)),
    rw rough_litter_map_or_else_of_dom, },
  { by_cases h' : a.fst ∈ w.litter_perm'.domain,
    exact or.inl h',
    exact or.inr ⟨banned_litter.diff L hL a ⟨ha, h⟩, h'⟩, },
end

lemma fst_mem_litter_perm_domain_of_dom ⦃a : atom⦄ (ha : a ∈ w.atom_map.dom) :
  a.fst ∈ w.litter_perm.domain :=
begin
  by_cases h' : a.fst ∈ w.litter_perm'.domain,
  exact or.inl h',
  exact or.inr ⟨banned_litter.atom_dom a ha, h'⟩,
end

lemma fst_mem_litter_perm_domain_of_ran ⦃a : atom⦄ (ha : a ∈ w.atom_map.ran) :
  a.fst ∈ w.litter_perm.domain :=
begin
  by_cases h' : a.fst ∈ w.litter_perm'.domain,
  exact or.inl h',
  obtain ⟨b, hb, rfl⟩ := ha,
  exact or.inr ⟨banned_litter.atom_map b hb, h'⟩,
end

lemma fill_atom_orbits_precise
  (hdiff : ∀ L hL, ((w.litter_map L).get hL : set atom) ∆ litter_set ((w.litter_map L).get hL).1 ⊆
    w.atom_map.ran) : precise (w.fill_atom_orbits hdiff) :=
begin
  intros L hL,
  constructor,
  { exact subset_trans (hdiff L hL) subset_orbit_atom_map_ran, },
  { intros a ha ha',
    simp only [fill_atom_orbits_atom_map, fill_atom_orbits_litter_map, mem_litter_set,
      orbit_atom_map_dom_iff] at *,
    obtain ha | ha | ha := ha,
    { have := w.orbit_atom_map_eq_of_mem_dom a ha,
      generalize_proofs at this ha' ⊢,
      rw [this, or_iff_not_imp_left],
      intro hmap,
      have hfwd : (w.atom_map a).get ha ∈ w.need_forward_images := ⟨⟨a, _, rfl⟩, hmap⟩,
      refine or.inl ⟨hfwd, or.inl (or.inl _)⟩,
      refine mem_of_eq_of_mem _ (or.inl hL),
      rw [← ha', this], },
    { refine or.inr (or.inr ⟨_, ⟨L, rfl⟩, _⟩),
      simp only [pfun.mem_dom, Union_exists, mem_Union, mem_image, mem_set_of_eq, set_coe.exists,
        subtype.coe_mk, exists_and_distrib_right, exists_eq_right, exists_prop],
      have haL : L = w.litter_perm a.fst,
      { have := (congr_arg prod.fst
          (w.orbit_atom_map_eq_of_need_forward_images a ha)).symm.trans ha',
        rw ← this,
        exact (w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop).1, },
      refine ⟨or.inl (or.inl (or.inl hL)), _, _⟩,
      { refine mem_of_eq_of_mem (w.orbit_atom_map_eq_of_need_forward_images a ha) _,
        rw haL,
        exact ((w.orbit_set_equiv _).symm _).prop, },
      { have := w.orbit_atom_map_eq_of_need_forward_images a ha,
        obtain ⟨hm₁, hm₂⟩ := subtype.coe_eq_iff.mp this.symm,
        rw [equiv.symm_apply_eq, w.orbit_set_equiv_congr hm₁ haL.symm] at hm₂,
        refine mem_of_eq_of_mem hm₂.symm _,
        change sum.elim (λ b, b ∈ w.next_backward_image_domain L)
          (λ b, b ∈ w.next_forward_image_domain L) (inr (0, ⟨a, ha.1⟩)),
        refine ⟨ha.2, _⟩,
        simp only [subtype.coe_mk, function.iterate_one],
        exact haL.symm, }, },
    { have := w.orbit_atom_map_eq_of_mem_next_image_core_domain a ha,
      generalize_proofs at this ha' ⊢,
      rw [this, next_image_core],
      obtain ⟨_, ⟨L', rfl⟩, _, ⟨hL', rfl⟩, a, hbL, rfl⟩ := ha,
      set b := w.orbit_set_equiv L' a with hb,
      clear_value b,
      simp only [mem_set_of_eq] at hbL,
      rw ← hb at hbL,
      have haL' := (w.orbit_set_subset _ a.prop).1,
      rw mem_litter_set at haL',
      have := w.orbit_set_equiv_congr (w.mem_orbit_set_of_mem_next_image_core_domain _)
        (w.orbit_set_subset _ a.prop).1,
      rw subtype.coe_eta at this,
      rw [this, ← hb],
      obtain (⟨_ | n, b⟩ | ⟨n, b⟩) := b;
      simp only [need_backward_images, need_forward_images, elim_inl, elim_inr,
        next_backward_image, next_forward_image] at hbL ⊢,
      { exact or.inl b.prop.1, },
      { refine or.inr (or.inr _),
        have hbL' := hbL.2,
        symmetry' at hbL',
        rw [function.iterate_succ_apply',
          local_perm.eq_symm_apply _ hL' (w.litter_perm.symm.iterate_domain hbL.1)] at hbL',
        refine ⟨_, ⟨w.litter_perm.symm^[n + 1] (b : atom).1, rfl⟩, _, ⟨_, rfl⟩,
          ⟨(w.orbit_set_equiv (w.litter_perm (a : atom).1)).symm (inl (n, b)), _⟩, _⟩,
        { exact w.litter_perm.symm.iterate_domain hbL.1, },
        { rw ← hbL',
          have := (((w.orbit_set_equiv (w.litter_perm (a : atom).1)).symm (inl (n, b)))).prop,
          rw haL' at this ⊢,
          exact this, },
        { simp only [function.comp_app, mem_set_of_eq, subtype.coe_mk,
            eq_self_iff_true, and_true],
          rw [w.orbit_set_equiv_congr _ hbL'.symm,
            w.orbit_set_equiv_congr _ (congr_arg w.litter_perm haL'.symm)],
          simp only [subtype.coe_eta, equiv.apply_symm_apply, elim_inl],
          exact ⟨hbL.1, rfl⟩, }, },
      { refine or.inr (or.inr _),
        refine ⟨_, ⟨w.litter_perm^[n + 2] (b : atom).1, rfl⟩, _, ⟨_, rfl⟩,
          ⟨(w.orbit_set_equiv (w.litter_perm (a : atom).1)).symm (inr (n + 1, b)), _⟩, _⟩,
        { exact w.litter_perm.iterate_domain hbL.1, },
        { rw [function.iterate_succ_apply', hbL.2, haL'],
          exact ((w.orbit_set_equiv _).symm _).prop, },
        { simp only [function.comp_app, mem_set_of_eq,
            subtype.coe_mk, eq_self_iff_true, and_true],
          have := congr_arg w.litter_perm hbL.2,
          rw ← function.iterate_succ_apply' w.litter_perm (n + 1) at this,
          rw [w.orbit_set_equiv_congr _ this,
            w.orbit_set_equiv_congr _ (congr_arg w.litter_perm haL'.symm)],
          simp only [function.iterate_succ, function.comp_app, subtype.coe_eta,
            equiv.apply_symm_apply, elim_inr],
          exact ⟨hbL.1, rfl⟩, }, },
      { refine ⟨_, ⟨L', rfl⟩, _, ⟨hL', rfl⟩, a, _, rfl⟩,
        rw [mem_set_of_eq, ← hb],
        exact hbL, }, }, },
  { rw fill_atom_orbits_litter_map at hL,
    rintros a ⟨ha₁ | ⟨ha₁, ha₁'⟩ | ha₁, ha₂⟩;
    simp only [fill_atom_orbits_atom_map, fill_atom_orbits_litter_map, orbit_atom_map_dom,
      mem_inter_iff, mem_union, set_like.mem_coe] at *,
    { by_cases ha₃ : a ∈ w.atom_map.ran,
      { obtain ⟨b, hb₁, hb₂⟩ := ha₃,
        refine ⟨b, or.inl hb₁, _⟩,
        rw orbit_atom_map_eq_of_mem_dom,
        exact hb₂, },
      { refine ⟨(w.orbit_set_equiv (w.litter_perm.symm a.1)).symm (inl (0, ⟨a, ha₁, ha₃⟩)), _, _⟩,
        { refine or.inr (or.inr ⟨_, ⟨w.litter_perm.symm a.1, rfl⟩, _, ⟨_, rfl⟩, _⟩),
          { exact w.litter_perm.symm.map_domain (fst_mem_litter_perm_domain_of_mem_map hL ha₂), },
          refine ⟨_, _, rfl⟩,
          simp only [mem_set_of_eq, equiv.apply_symm_apply, elim_inl],
          exact ⟨fst_mem_litter_perm_domain_of_mem_map hL ha₂, rfl⟩, },
        { rw [orbit_atom_map_eq_of_mem_next_image_core_domain, next_image_core],
          have : (((w.orbit_set_equiv (w.litter_perm.symm a.fst)).symm)
            (inl (0, ⟨a, _⟩)) : atom).fst = w.litter_perm.symm a.fst,
          { exact (w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop).1,
            exact ⟨ha₁, ha₃⟩, },
          rw w.orbit_set_equiv_congr _ this,
          simp only [equiv.apply_symm_apply, elim_inl, subtype.coe_eta, next_backward_image,
            subtype.coe_mk], }, }, },
    { obtain ⟨⟨b, hb₁, hb₂⟩, ha₁⟩ := ha₁,
      rw ← hb₂,
      refine ⟨b, or.inl hb₁, _⟩,
      rw orbit_atom_map_eq_of_mem_dom, },
    { obtain ⟨a', ha'⟩ := (w.orbit_set_equiv a.fst).symm.surjective
        ⟨a, w.mem_orbit_set_of_mem_next_image_core_domain ha₁⟩,
      obtain (⟨n, a'⟩ | ⟨_ | n, a'⟩) := a',
      { have : ((w.orbit_set_equiv (w.litter_perm.symm^[n + 2] (a' : atom).fst)).symm
          (inl (n + 1, a')) : atom) ∈ w.next_image_core_domain,
        { refine ⟨_, ⟨w.litter_perm.symm^[n + 2] (a' : atom).fst, rfl⟩, _, ⟨_, rfl⟩, _⟩,
          exact w.litter_perm.symm.iterate_domain (fst_mem_litter_perm_domain_of_dom a'.prop.1),
          refine ⟨_, _, rfl⟩,
          simp only [mem_set_of_eq, equiv.apply_symm_apply, elim_inl],
          exact ⟨fst_mem_litter_perm_domain_of_dom a'.prop.1, rfl⟩, },
        refine ⟨_, or.inr (or.inr this), _⟩,
        rw orbit_atom_map_eq_of_mem_next_image_core_domain,
        rw next_image_core,
        have : (((w.orbit_set_equiv (w.litter_perm.symm^[n + 2] (a' : atom).fst)).symm)
            (inl (n + 1, a')) : atom).fst = (w.litter_perm.symm^[n + 2] (a' : atom).fst) :=
          (w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop).1,
        rw w.orbit_set_equiv_congr _ this,
        simp only [subtype.coe_eta, equiv.apply_symm_apply, elim_inl, next_backward_image],
        have := congr_arg subtype.val ha',
        simp only [subtype.val_eq_coe] at this,
        rw ← this,
        refine w.orbit_set_equiv_symm_congr _,
        have := (w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop).1,
        rw mem_litter_set at this,
        rw this,
        have := w.orbit_set_equiv_elim_of_mem_next_image_core_domain ha₁,
        rw ← ha' at this,
        simp only [equiv.apply_symm_apply, elim_inl, next_backward_image_domain,
          function.comp_app, mem_set_of_eq] at this,
        rw [← this.2, function.iterate_succ_apply', local_perm.right_inv],
        exact w.litter_perm.symm.iterate_domain this.1, },
      { have := w.orbit_set_equiv_elim_of_mem_next_image_core_domain ha₁,
        rw ← ha' at this,
        simp only [equiv.apply_symm_apply, elim_inr, next_forward_image_domain,
          function.comp_app, mem_set_of_eq, function.iterate_one] at this,
        refine ⟨a', or.inr (or.inl ⟨a'.prop, this.1⟩), _⟩,
        rw [orbit_atom_map_eq_of_need_forward_images, w.orbit_set_equiv_symm_congr this.2,
          subtype.coe_eta, ha'],
        refl, },
      { have : ((w.orbit_set_equiv (w.litter_perm^[n + 1] (a' : atom).fst)).symm
          (inr (n, a')) : atom) ∈ w.next_image_core_domain,
        { refine ⟨_, ⟨w.litter_perm^[n + 1] (a' : atom).fst, rfl⟩, _, ⟨_, rfl⟩, _⟩,
          exact w.litter_perm.iterate_domain (fst_mem_litter_perm_domain_of_ran a'.prop.1),
          refine ⟨_, _, rfl⟩,
          simp only [mem_set_of_eq, equiv.apply_symm_apply, elim_inl],
          exact ⟨fst_mem_litter_perm_domain_of_ran a'.prop.1, rfl⟩, },
        refine ⟨_, or.inr (or.inr this), _⟩,
        rw orbit_atom_map_eq_of_mem_next_image_core_domain,
        rw next_image_core,
        have : (((w.orbit_set_equiv (w.litter_perm^[n + 1] (a' : atom).fst)).symm)
            (inr (n, a')) : atom).fst = (w.litter_perm^[n + 1] (a' : atom).fst) :=
          (w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop).1,
        rw w.orbit_set_equiv_congr _ this,
        simp only [subtype.coe_eta, equiv.apply_symm_apply, elim_inl, next_backward_image],
        have := congr_arg subtype.val ha',
        simp only [subtype.val_eq_coe] at this,
        rw ← this,
        refine w.orbit_set_equiv_symm_congr _,
        have := (w.orbit_set_subset _ ((w.orbit_set_equiv _).symm _).prop).1,
        rw mem_litter_set at this,
        rw this,
        have := w.orbit_set_equiv_elim_of_mem_next_image_core_domain ha₁,
        rw ← ha' at this,
        simp only [equiv.apply_symm_apply, elim_inr, next_forward_image_domain,
          function.comp_app, mem_set_of_eq] at this,
        rw [← this.2, function.iterate_succ_apply', function.iterate_succ_apply',
          function.iterate_succ_apply'], }, }, },
end

end weak_near_litter_approx

end con_nf


/-
Copyright (c) 2018 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Simon Hudon
-/
import control.functor

/-!
# Traversable type class

Type classes for traversing collections. The concepts and laws are taken from
<http://hackage.haskell.org/package/base-4.11.1.0/docs/Data-Traversable.html>

Traversable collections are a generalization of functors. Whereas
functors (such as `list`) allow us to apply a function to every
element, it does not allow functions which external effects encoded in
a monad. Consider for instance a functor `invite : email → io response`
that takes an email address, sends an email and waits for a
response. If we have a list `guests : list email`, using calling
`invite` using `map` gives us the following: `map invite guests : list
(io response)`.  It is not what we need. We need something of type `io
(list response)`. Instead of using `map`, we can use `traverse` to
send all the invites: `traverse invite guests : io (list response)`.
`traverse` applies `invite` to every element of `guests` and combines
all the resulting effects. In the example, the effect is encoded in the
monad `io` but any applicative functor is accepted by `traverse`.

For more on how to use traversable, consider the Haskell tutorial:
<https://en.wikibooks.org/wiki/Haskell/Traversable>

## Main definitions
  * `traversable` type class - exposes the `traverse` function
  * `sequence` - based on `traverse`,
    turns a collection of effects into an effect returning a collection
  * `is_lawful_traversable` - laws for a traversable functor
  * `applicative_transformation` - the notion of a natural transformation for applicative functors

## Tags

traversable iterator functor applicative

## References

 * "Applicative Programming with Effects", by Conor McBride and Ross Paterson,
   Journal of Functional Programming 18:1 (2008) 1-13, online at
   <http://www.soi.city.ac.uk/~ross/papers/Applicative.html>
 * "The Essence of the Iterator Pattern", by Jeremy Gibbons and Bruno Oliveira,
   in Mathematically-Structured Functional Programming, 2006, online at
   <http://web.comlab.ox.ac.uk/oucl/work/jeremy.gibbons/publications/#iterator>
 * "An Investigation of the Laws of Traversals", by Mauro Jaskelioff and Ondrej Rypacek,
   in Mathematically-Structured Functional Programming, 2012,
   online at <http://arxiv.org/pdf/1202.2919>
-/

open function (hiding comp)

universes u v w

section applicative_transformation

variables (F : Type u → Type v) [applicative F] [is_lawful_applicative F]
variables (G : Type u → Type w) [applicative G] [is_lawful_applicative G]

/-- A transformation between applicative functors.  It a natural
transformation such that `app` preserves the `has_pure.pure` and
`functor.map` (`<*>`) operations. See
`applicative_transformation.preserves_map` for naturality. -/
structure applicative_transformation : Type (max (u+1) v w) :=
(app : Π α : Type u, F α → G α)
(preserves_pure' : ∀ {α : Type u} (x : α), app _ (pure x) = pure x)
(preserves_seq' : ∀ {α β : Type u} (x : F (α → β)) (y : F α), app _ (x <*> y) = app _ x <*> app _ y)

end applicative_transformation

namespace applicative_transformation

variables (F : Type u → Type v) [applicative F] [is_lawful_applicative F]
variables (G : Type u → Type w) [applicative G] [is_lawful_applicative G]

instance : has_coe_to_fun (applicative_transformation F G) :=
{ F := λ _, Π {α}, F α → G α,
  coe := λ a, a.app }

variables {F G}

@[simp]
lemma app_eq_coe (η : applicative_transformation F G) : η.app = η := rfl

@[simp]
lemma coe_mk (f : Π (α : Type u), F α → G α) (pp ps) :
  ⇑(applicative_transformation.mk f pp ps) = f := rfl

protected
lemma congr_fun (η η' : applicative_transformation F G) (h : η = η') {α : Type u} (x : F α) :
  η x = η' x :=
congr_arg (λ η'' : applicative_transformation F G, η'' x) h

protected
lemma congr_arg (η : applicative_transformation F G) {α : Type u} {x y : F α} (h : x = y) :
  η x = η y :=
congr_arg (λ z : F α, η z) h

lemma coe_inj ⦃η η' : applicative_transformation F G⦄ (h : (η : Π α, F α → G α) = η') : η = η' :=
by { cases η, cases η', congr, exact h }

@[ext]
lemma ext ⦃η η' : applicative_transformation F G⦄ (h : ∀ (α : Type u) (x : F α), η x = η' x) :
  η = η' :=
by { apply coe_inj, ext1 α, exact funext (h α) }

lemma ext_iff {η η' : applicative_transformation F G} :
  η = η' ↔ ∀ (α : Type u) (x : F α), η x = η' x :=
⟨λ h α x, h ▸ rfl, λ h, ext h⟩

section preserves
variables (η : applicative_transformation F G)

@[functor_norm]
lemma preserves_pure : ∀ {α} (x : α), η (pure x) = pure x := η.preserves_pure'

@[functor_norm]
lemma preserves_seq :
  ∀ {α β : Type u} (x : F (α → β)) (y : F α), η (x <*> y) = η x <*> η y :=
η.preserves_seq'

@[functor_norm]
lemma preserves_map {α β} (x : α → β) (y : F α) : η (x <$> y) = x <$> η y :=
by rw [← pure_seq_eq_map, η.preserves_seq]; simp with functor_norm

lemma preserves_map' {α β} (x : α → β) : @η _ ∘ functor.map x = functor.map x ∘ @η _ :=
by { ext y, exact preserves_map η x y }

end preserves

/-- The identity applicative transformation from an applicative functor to itself. -/
def id_transformation : applicative_transformation F F :=
{ app := λ α, id,
  preserves_pure' := by simp,
  preserves_seq' := λ α β x y, by simp }

instance : inhabited (applicative_transformation F F) := ⟨id_transformation⟩

universes s t
variables {H : Type u → Type s} [applicative H] [is_lawful_applicative H]

/-- The composition of applicative transformations. -/
def comp (η' : applicative_transformation G H) (η : applicative_transformation F G) :
  applicative_transformation F H :=
{ app := λ α x, η' (η x),
  preserves_pure' := λ α x, by simp with functor_norm,
  preserves_seq' := λ α β x y, by simp with functor_norm }

@[simp]
lemma comp_apply (η' : applicative_transformation G H) (η : applicative_transformation F G)
  {α : Type u} (x : F α) :
  η'.comp η x = η' (η x) := rfl

lemma comp_assoc {I : Type u → Type t} [applicative I] [is_lawful_applicative I]
  (η'' : applicative_transformation H I)
  (η' : applicative_transformation G H)
  (η : applicative_transformation F G) :
  (η''.comp η').comp η = η''.comp (η'.comp η) := rfl

@[simp]
lemma comp_id (η : applicative_transformation F G) : η.comp id_transformation = η :=
ext $ λ α x, rfl

@[simp]

end applicative_transformation

open applicative_transformation

/-- A traversable functor is a functor along with a way to commute
with all applicative functors (see `sequence`).  For example, if `t`
is the traversable functor `list` and `m` is the applicative functor
`io`, then given a function `f : α → io β`, the function `functor.map f` is
`list α → list (io β)`, but `traverse f` is `list α → io (list β)`. -/
class traversable (t : Type u → Type u) extends functor t :=
(traverse : Π {m : Type u → Type u} [applicative m] {α β},
   (α → m β) → t α → m (t β))

open functor

export traversable (traverse)

section functions

variables {t : Type u → Type u}
variables {m : Type u → Type v} [applicative m]
variables {α β : Type u}

variables {f : Type u → Type u} [applicative f]

/-- A traversable functor commutes with all applicative functors. -/
def sequence [traversable t] : t (f α) → f (t α) := traverse id

end functions

/-- A traversable functor is lawful if its `traverse` satisfies a
number of additional properties.  It must send `id.mk` to `id.mk`,
send the composition of applicative functors to the composition of the
`traverse` of each, send each function `f` to `λ x, f <$> x`, and
satisfy a naturality condition with respect to applicative
transformations. -/
class is_lawful_traversable (t : Type u → Type u) [traversable t]
  extends is_lawful_functor t : Type (u+1) :=
(id_traverse : ∀ {α} (x : t α), traverse id.mk x = x )
(comp_traverse : ∀ {F G} [applicative F] [applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G]
    {α β γ} (f : β → F γ) (g : α → G β) (x : t α),
  traverse (comp.mk ∘ map f ∘ g) x =
  comp.mk (map (traverse f) (traverse g x)))
(traverse_eq_map_id : ∀ {α β} (f : α → β) (x : t α),
  traverse (id.mk ∘ f) x = id.mk (f <$> x))
(naturality : ∀ {F G} [applicative F] [applicative G]
    [is_lawful_applicative F] [is_lawful_applicative G]
    (η : applicative_transformation F G) {α β} (f : α → F β) (x : t α),
  η (traverse f x) = traverse (@η _ ∘ f) x)

instance : traversable id := ⟨λ _ _ _ _, id⟩
instance : is_lawful_traversable id := by refine {..}; intros; refl

section

variables {F : Type u → Type v} [applicative F]

instance : traversable option := ⟨@option.traverse⟩

instance : traversable list := ⟨@list.traverse⟩

end

namespace sum

variables {σ : Type u}
variables {F : Type u → Type u}
variables [applicative F]

/-- Defines a `traverse` function on the second component of a sum type.
This is used to give a `traversable` instance for the functor `σ ⊕ -`. -/
protected def traverse {α β} (f : α → F β) : σ ⊕ α → F (σ ⊕ β)
| (sum.inl x) := pure (sum.inl x)
| (sum.inr x) := sum.inr <$> f x

end sum

instance {σ : Type u} : traversable.{u} (sum σ) := ⟨@sum.traverse _⟩


/-
Copyright (c) 2020 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Reid Barton
-/
import tactic.auto_cases
import tactic.tidy
import tactic.with_local_reducibility
import tactic.show_term
import topology.basic
/-!
# Tactics for topology

Currently we have one domain-specific tactic for topology: `continuity`.

-/

/-!
### `continuity` tactic

Automatically solve goals of the form `continuous f`.

Mark lemmas with `@[continuity]` to add them to the set of lemmas
used by `continuity`. Note: `to_additive` doesn't know yet how to
copy the attribute to the additive version.
-/

/-- User attribute used to mark tactics used by `continuity`. -/
@[user_attribute]
meta def continuity : user_attribute :=
{ name := `continuity,
  descr := "lemmas usable to prove continuity" }

-- Mark some continuity lemmas already defined in `topology.basic`
attribute [continuity]
  continuous_id
  continuous_const

-- As we will be using `apply_rules` with `md := semireducible`,
-- we need another version of `continuous_id`.
@[continuity] lemma continuous_id' {α : Type*} [topological_space α] : continuous (λ a : α, a) :=
continuous_id

namespace tactic

/--
Tactic to apply `continuous.comp` when appropriate.

Applying `continuous.comp` is not always a good idea, so we have some
extra logic here to try to avoid bad cases.

* If the function we're trying to prove continuous is actually
  constant, and that constant is a function application `f z`, then
  continuous.comp would produce new goals `continuous f`, `continuous
  (λ _, z)`, which is silly. We avoid this by failing if we could
  apply continuous_const.

* continuous.comp will always succeed on `continuous (λ x, f x)` and
  produce new goals `continuous (λ x, x)`, `continuous f`. We detect
  this by failing if a new goal can be closed by applying
  continuous_id.
-/
meta def apply_continuous.comp : tactic unit :=
`[fail_if_success { exact continuous_const };
  refine continuous.comp _ _;
  fail_if_success { exact continuous_id }]

/-- List of tactics used by `continuity` internally. -/
meta def continuity_tactics (md : transparency := reducible) : list (tactic string) :=
[
  intros1               >>= λ ns, pure ("intros " ++ (" ".intercalate (ns.map (λ e, e.to_string)))),
  apply_rules [``(continuity)] 50 { md := md }
                        >> pure "apply_rules continuity",
  apply_continuous.comp >> pure "refine continuous.comp _ _"
]

namespace interactive
setup_tactic_parser

/--
Solve goals of the form `continuous f`. `continuity?` reports back the proof term it found.
-/
meta def continuity
  (bang : parse $ optional (tk "!")) (trace : parse $ optional (tk "?")) (cfg : tidy.cfg := {}) :
  tactic unit :=
let md              := if bang.is_some then semireducible else reducible,
    continuity_core := tactic.tidy { tactics := continuity_tactics md, ..cfg },
    trace_fn        := if trace.is_some then show_term else id in
trace_fn continuity_core

/-- Version of `continuity` for use with auto_param. -/
meta def continuity' : tactic unit := continuity none none {}

/--
`continuity` solves goals of the form `continuous f` by applying lemmas tagged with the
`continuity` user attribute.

```
example {X Y : Type*} [topological_space X] [topological_space Y]
  (f₁ f₂ : X → Y) (hf₁ : continuous f₁) (hf₂ : continuous f₂)
  (g : Y → ℝ) (hg : continuous g) : continuous (λ x, (max (g (f₁ x)) (g (f₂ x))) + 1) :=
by continuity
```
will discharge the goal, generating a proof term like
`((continuous.comp hg hf₁).max (continuous.comp hg hf₂)).add continuous_const`

You can also use `continuity!`, which applies lemmas with `{ md := semireducible }`.
The default behaviour is more conservative, and only unfolds `reducible` definitions
when attempting to match lemmas with the goal.

`continuity?` reports back the proof term it found.
-/
add_tactic_doc
{ name := "continuity / continuity'",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.continuity, `tactic.interactive.continuity'],
  tags := ["lemma application"]
}

end interactive

end tactic


/-
Copyright (c) 2018 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad, Mario Carneiro, Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.fin2
import Mathlib.data.typevec
import Mathlib.logic.function.basic
import Mathlib.tactic.basic
import Mathlib.PostPort

universes u_1 u_2 l u v

namespace Mathlib

/-!

Functors between the category of tuples of types, and the category Type

Features:

`mvfunctor n` : the type class of multivariate functors
`f <$$> x`    : notation for map

-/

/-- multivariate functors, i.e. functor between the category of type vectors
and the category of Type -/
class mvfunctor {n : ℕ} (F : typevec n → Type u_2)
where
  map : {α β : typevec n} → typevec.arrow α β → F α → F β

namespace mvfunctor

/-- predicate lifting over multivariate functors -/
def liftp {n : ℕ} {F : typevec n → Type v} [mvfunctor F] {α : typevec n} (p : (i : fin2 n) → α i → Prop) (x : F α) :=
  ∃ (u : F fun (i : fin2 n) => Subtype (p i)), map (fun (i : fin2 n) => subtype.val) u = x

/-- relational lifting over multivariate functors -/
def liftr {n : ℕ} {F : typevec n → Type v} [mvfunctor F] {α : typevec n} (r : {i : fin2 n} → α i → α i → Prop) (x : F α) (y : F α) :=
  ∃ (u : F fun (i : fin2 n) => Subtype fun (p : α i × α i) => r (prod.fst p) (prod.snd p)),
    map (fun (i : fin2 n) (t : Subtype fun (p : α i × α i) => r (prod.fst p) (prod.snd p)) => prod.fst (subtype.val t))
          u =
        x ∧
      map (fun (i : fin2 n) (t : Subtype fun (p : α i × α i) => r (prod.fst p) (prod.snd p)) => prod.snd (subtype.val t))
          u =
        y

/-- given `x : F α` and a projection `i` of type vector `α`, `supp x i` is the set
of `α.i` contained in `x` -/
def supp {n : ℕ} {F : typevec n → Type v} [mvfunctor F] {α : typevec n} (x : F α) (i : fin2 n) : set (α i) :=
  set_of fun (y : α i) => ∀ {p : (i : fin2 n) → α i → Prop}, liftp p x → p i y

theorem of_mem_supp {n : ℕ} {F : typevec n → Type v} [mvfunctor F] {α : typevec n} {x : F α} {p : {i : fin2 n} → α i → Prop} (h : liftp p x) (i : fin2 n) (y : α i) (H : y ∈ supp x i) : p y :=
  hy h

end mvfunctor

/-- laws for `mvfunctor` -/
class is_lawful_mvfunctor {n : ℕ} (F : typevec n → Type u_2) [mvfunctor F]
where
  id_map : ∀ {α : typevec n} (x : F α), mvfunctor.map typevec.id x = x
  comp_map : ∀ {α β γ : typevec n} (g : typevec.arrow α β) (h : typevec.arrow β γ) (x : F α),
  mvfunctor.map (typevec.comp h g) x = mvfunctor.map h (mvfunctor.map g x)

namespace mvfunctor

/-- adapt `mvfunctor.liftp` to accept predicates as arrows -/
def liftp' {n : ℕ} {α : typevec n} {F : typevec n → Type v} [mvfunctor F] (p : typevec.arrow α (typevec.repeat n Prop)) : F α → Prop :=
  liftp fun (i : fin2 n) (x : α i) => typevec.of_repeat (p i x)

/-- adapt `mvfunctor.liftp` to accept relations as arrows -/
def liftr' {n : ℕ} {α : typevec n} {F : typevec n → Type v} [mvfunctor F] (r : typevec.arrow (typevec.prod α α) (typevec.repeat n Prop)) : F α → F α → Prop :=
  liftr fun (i : fin2 n) (x y : α i) => typevec.of_repeat (r i (typevec.prod.mk i x y))

@[simp] theorem id_map {n : ℕ} {α : typevec n} {F : typevec n → Type v} [mvfunctor F] [is_lawful_mvfunctor F] (x : F α) : map typevec.id x = x :=
  is_lawful_mvfunctor.id_map x

@[simp] theorem id_map' {n : ℕ} {α : typevec n} {F : typevec n → Type v} [mvfunctor F] [is_lawful_mvfunctor F] (x : F α) : map (fun (i : fin2 n) (a : α i) => a) x = x :=
  id_map x

theorem map_map {n : ℕ} {α : typevec n} {β : typevec n} {γ : typevec n} {F : typevec n → Type v} [mvfunctor F] [is_lawful_mvfunctor F] (g : typevec.arrow α β) (h : typevec.arrow β γ) (x : F α) : map h (map g x) = map (typevec.comp h g) x :=
  Eq.symm (comp_map g h x)

theorem exists_iff_exists_of_mono {n : ℕ} {α : typevec n} {β : typevec n} (F : typevec n → Type v) [mvfunctor F] [is_lawful_mvfunctor F] {p : F α → Prop} {q : F β → Prop} (f : typevec.arrow α β) (g : typevec.arrow β α) (h₀ : typevec.comp f g = typevec.id) (h₁ : ∀ (u : F α), p u ↔ q (map f u)) : (∃ (u : F α), p u) ↔ ∃ (u : F β), q u := sorry

theorem liftp_def {n : ℕ} {α : typevec n} {F : typevec n → Type v} [mvfunctor F] (p : typevec.arrow α (typevec.repeat n Prop)) [is_lawful_mvfunctor F] (x : F α) : liftp' p x ↔ ∃ (u : F (typevec.subtype_ p)), map (typevec.subtype_val p) u = x := sorry

theorem liftr_def {n : ℕ} {α : typevec n} {F : typevec n → Type v} [mvfunctor F] (r : typevec.arrow (typevec.prod α α) (typevec.repeat n Prop)) [is_lawful_mvfunctor F] (x : F α) (y : F α) : liftr' r x y ↔
  ∃ (u : F (typevec.subtype_ r)),
    map (typevec.comp typevec.prod.fst (typevec.subtype_val r)) u = x ∧
      map (typevec.comp typevec.prod.snd (typevec.subtype_val r)) u = y := sorry

end mvfunctor

namespace mvfunctor

theorem liftp_last_pred_iff {n : ℕ} {F : typevec (n + 1) → Type u_1} [mvfunctor F] [is_lawful_mvfunctor F] {α : typevec n} {β : Type u} (p : β → Prop) (x : F (α ::: β)) : liftp' (typevec.pred_last' α p) x ↔ liftp (typevec.pred_last α p) x := sorry

theorem liftr_last_rel_iff {n : ℕ} {F : typevec (n + 1) → Type u_1} [mvfunctor F] [is_lawful_mvfunctor F] {α : typevec n} {β : Type u} (rr : β → β → Prop) (x : F (α ::: β)) (y : F (α ::: β)) : liftr' (typevec.rel_last' α rr) x y ↔ liftr (typevec.rel_last α rr) x y := sorry


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.abel
import Mathlib.category_theory.limits.shapes.biproducts
import Mathlib.category_theory.preadditive.default
import Mathlib.PostPort

universes u v

namespace Mathlib

/-!
# Basic facts about morphisms between biproducts in preadditive categories.

* In any category (with zero morphisms), if `biprod.map f g` is an isomorphism,
  then both `f` and `g` are isomorphisms.

The remaining lemmas hold in any preadditive category.

* If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
  then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
  so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
  via Gaussian elimination.

* As a corollary of the previous two facts,
  if we have an isomorphism `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
  we can construct an isomorphism `X₂ ≅ Y₂`.

* If `f : W ⊞ X ⟶ Y ⊞ Z` is an isomorphism, either `𝟙 W = 0`,
  or at least one of the component maps `W ⟶ Y` and `W ⟶ Z` is nonzero.

* If `f : ⨁ S ⟶ ⨁ T` is an isomorphism,
  then every column (corresponding to a nonzero summand in the domain)
  has some nonzero matrix entry.
-/

namespace category_theory

/--
If
```
(f 0)
(0 g)
```
is invertible, then `f` is invertible.
-/
def is_iso_left_of_is_iso_biprod_map {C : Type u} [category C] [limits.has_zero_morphisms C] [limits.has_binary_biproducts C] {W : C} {X : C} {Y : C} {Z : C} (f : W ⟶ Y) (g : X ⟶ Z) [is_iso (limits.biprod.map f g)] : is_iso f :=
  is_iso.mk (limits.biprod.inl ≫ inv (limits.biprod.map f g) ≫ limits.biprod.fst)

/--
If
```
(f 0)
(0 g)
```
is invertible, then `g` is invertible.
-/
def is_iso_right_of_is_iso_biprod_map {C : Type u} [category C] [limits.has_zero_morphisms C] [limits.has_binary_biproducts C] {W : C} {X : C} {Y : C} {Z : C} (f : W ⟶ Y) (g : X ⟶ Z) [is_iso (limits.biprod.map f g)] : is_iso g :=
  let _inst : is_iso (limits.biprod.map g f) := eq.mpr sorry is_iso.comp_is_iso;
  is_iso_left_of_is_iso_biprod_map g f

/--
The "matrix" morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` with specified components.
-/
def biprod.of_components {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂ :=
  limits.biprod.fst ≫ f₁₁ ≫ limits.biprod.inl + limits.biprod.fst ≫ f₁₂ ≫ limits.biprod.inr +
      limits.biprod.snd ≫ f₂₁ ≫ limits.biprod.inl +
    limits.biprod.snd ≫ f₂₂ ≫ limits.biprod.inr

@[simp] theorem biprod.inl_of_components {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) : limits.biprod.inl ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ = f₁₁ ≫ limits.biprod.inl + f₁₂ ≫ limits.biprod.inr := sorry

@[simp] theorem biprod.inr_of_components {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) : limits.biprod.inr ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ = f₂₁ ≫ limits.biprod.inl + f₂₂ ≫ limits.biprod.inr := sorry

@[simp] theorem biprod.of_components_fst {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) : biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ limits.biprod.fst = limits.biprod.fst ≫ f₁₁ + limits.biprod.snd ≫ f₂₁ := sorry

@[simp] theorem biprod.of_components_snd {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) : biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ limits.biprod.snd = limits.biprod.fst ≫ f₁₂ + limits.biprod.snd ≫ f₂₂ := sorry

@[simp] theorem biprod.of_components_eq {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂) : biprod.of_components (limits.biprod.inl ≫ f ≫ limits.biprod.fst) (limits.biprod.inl ≫ f ≫ limits.biprod.snd)
    (limits.biprod.inr ≫ f ≫ limits.biprod.fst) (limits.biprod.inr ≫ f ≫ limits.biprod.snd) =
  f := sorry

@[simp] theorem biprod.of_components_comp {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} {Z₁ : C} {Z₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) (g₁₁ : Y₁ ⟶ Z₁) (g₁₂ : Y₁ ⟶ Z₂) (g₂₁ : Y₂ ⟶ Z₁) (g₂₂ : Y₂ ⟶ Z₂) : biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ biprod.of_components g₁₁ g₁₂ g₂₁ g₂₂ =
  biprod.of_components (f₁₁ ≫ g₁₁ + f₁₂ ≫ g₂₁) (f₁₁ ≫ g₁₂ + f₁₂ ≫ g₂₂) (f₂₁ ≫ g₁₁ + f₂₂ ≫ g₂₁) (f₂₁ ≫ g₁₂ + f₂₂ ≫ g₂₂) := sorry

/--
The unipotent upper triangular matrix
```
(1 r)
(0 1)
```
as an isomorphism.
-/
@[simp] theorem biprod.unipotent_upper_hom {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} (r : X₁ ⟶ X₂) : iso.hom (biprod.unipotent_upper r) = biprod.of_components 𝟙 r 0 𝟙 :=
  Eq.refl (iso.hom (biprod.unipotent_upper r))

/--
The unipotent lower triangular matrix
```
(1 0)
(r 1)
```
as an isomorphism.
-/
@[simp] theorem biprod.unipotent_lower_hom {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} (r : X₂ ⟶ X₁) : iso.hom (biprod.unipotent_lower r) = biprod.of_components 𝟙 0 r 𝟙 :=
  Eq.refl (iso.hom (biprod.unipotent_lower r))

/--
If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
via Gaussian elimination.

(This is the version of `biprod.gaussian` written in terms of components.)
-/
def biprod.gaussian' {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) [is_iso f₁₁] : psigma
  fun (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) =>
    psigma
      fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) =>
        psigma
          fun (g₂₂ : X₂ ⟶ Y₂) =>
            iso.hom L ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ iso.hom R = limits.biprod.map f₁₁ g₂₂ :=
  psigma.mk (biprod.unipotent_lower (-f₂₁ ≫ inv f₁₁))
    (psigma.mk (biprod.unipotent_upper (-inv f₁₁ ≫ f₁₂)) (psigma.mk (f₂₂ - f₂₁ ≫ inv f₁₁ ≫ f₁₂) sorry))

/--
If `f` is a morphism `X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct isomorphisms `L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂` and `R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂`
so that `L.hom ≫ g ≫ R.hom` is diagonal (with `X₁ ⟶ Y₁` component still `f`),
via Gaussian elimination.
-/
def biprod.gaussian {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f : X₁ ⊞ X₂ ⟶ Y₁ ⊞ Y₂) [is_iso (limits.biprod.inl ≫ f ≫ limits.biprod.fst)] : psigma
  fun (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) =>
    psigma
      fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) =>
        psigma
          fun (g₂₂ : X₂ ⟶ Y₂) =>
            iso.hom L ≫ f ≫ iso.hom R = limits.biprod.map (limits.biprod.inl ≫ f ≫ limits.biprod.fst) g₂₂ :=
  let this :
    psigma
      fun (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂) =>
        psigma
          fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) =>
            psigma
              fun (g₂₂ : X₂ ⟶ Y₂) =>
                iso.hom L ≫
                    biprod.of_components (limits.biprod.inl ≫ f ≫ limits.biprod.fst)
                        (limits.biprod.inl ≫ f ≫ limits.biprod.snd) (limits.biprod.inr ≫ f ≫ limits.biprod.fst)
                        (limits.biprod.inr ≫ f ≫ limits.biprod.snd) ≫
                      iso.hom R =
                  limits.biprod.map (limits.biprod.inl ≫ f ≫ limits.biprod.fst) g₂₂ :=
    biprod.gaussian' (limits.biprod.inl ≫ f ≫ limits.biprod.fst) (limits.biprod.inl ≫ f ≫ limits.biprod.snd)
      (limits.biprod.inr ≫ f ≫ limits.biprod.fst) (limits.biprod.inr ≫ f ≫ limits.biprod.snd);
  eq.mpr sorry (eq.mp sorry this)

/--
If `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` via a two-by-two matrix whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct an isomorphism `X₂ ≅ Y₂`, via Gaussian elimination.
-/
def biprod.iso_elim' {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f₁₁ : X₁ ⟶ Y₁) (f₁₂ : X₁ ⟶ Y₂) (f₂₁ : X₂ ⟶ Y₁) (f₂₂ : X₂ ⟶ Y₂) [is_iso f₁₁] [is_iso (biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂)] : X₂ ≅ Y₂ :=
  psigma.cases_on (biprod.gaussian' f₁₁ f₁₂ f₂₁ f₂₂)
    fun (L : X₁ ⊞ X₂ ≅ X₁ ⊞ X₂)
      (snd :
      psigma
        fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂) =>
          psigma
            fun (g₂₂ : X₂ ⟶ Y₂) =>
              iso.hom L ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ iso.hom R = limits.biprod.map f₁₁ g₂₂) =>
      psigma.cases_on snd
        fun (R : Y₁ ⊞ Y₂ ≅ Y₁ ⊞ Y₂)
          (snd_snd :
          psigma
            fun (g₂₂ : X₂ ⟶ Y₂) =>
              iso.hom L ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ iso.hom R = limits.biprod.map f₁₁ g₂₂) =>
          psigma.cases_on snd_snd
            fun (g : X₂ ⟶ Y₂)
              (w : iso.hom L ≫ biprod.of_components f₁₁ f₁₂ f₂₁ f₂₂ ≫ iso.hom R = limits.biprod.map f₁₁ g) =>
              let _inst : is_iso (limits.biprod.map f₁₁ g) := eq.mpr sorry is_iso.comp_is_iso;
              let _inst_6 : is_iso g := is_iso_right_of_is_iso_biprod_map f₁₁ g;
              as_iso g

/--
If `f` is an isomorphism `X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂` whose `X₁ ⟶ Y₁` entry is an isomorphism,
then we can construct an isomorphism `X₂ ≅ Y₂`, via Gaussian elimination.
-/
def biprod.iso_elim {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {X₁ : C} {X₂ : C} {Y₁ : C} {Y₂ : C} (f : X₁ ⊞ X₂ ≅ Y₁ ⊞ Y₂) [is_iso (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.fst)] : X₂ ≅ Y₂ :=
  let _inst :
    is_iso
      (biprod.of_components (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.fst)
        (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.snd) (limits.biprod.inr ≫ iso.hom f ≫ limits.biprod.fst)
        (limits.biprod.inr ≫ iso.hom f ≫ limits.biprod.snd)) :=
    eq.mpr sorry (is_iso.of_iso f);
  biprod.iso_elim' (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.fst) (limits.biprod.inl ≫ iso.hom f ≫ limits.biprod.snd)
    (limits.biprod.inr ≫ iso.hom f ≫ limits.biprod.fst) (limits.biprod.inr ≫ iso.hom f ≫ limits.biprod.snd)

theorem biprod.column_nonzero_of_iso {C : Type u} [category C] [preadditive C] [limits.has_binary_biproducts C] {W : C} {X : C} {Y : C} {Z : C} (f : W ⊞ X ⟶ Y ⊞ Z) [is_iso f] : 𝟙 = 0 ∨ limits.biprod.inl ≫ f ≫ limits.biprod.fst ≠ 0 ∨ limits.biprod.inl ≫ f ≫ limits.biprod.snd ≠ 0 := sorry

theorem biproduct.column_nonzero_of_iso' {C : Type u} [category C] [preadditive C] {σ : Type v} {τ : Type v} [DecidableEq σ] [DecidableEq τ] [fintype τ] {S : σ → C} [limits.has_biproduct S] {T : τ → C} [limits.has_biproduct T] (s : σ) (f : ⨁ S ⟶ ⨁ T) [is_iso f] : (∀ (t : τ), limits.biproduct.ι S s ≫ f ≫ limits.biproduct.π T t = 0) → 𝟙 = 0 := sorry

/--
If `f : ⨁ S ⟶ ⨁ T` is an isomorphism, and `s` is a non-trivial summand of the source,
then there is some `t` in the target so that the `s, t` matrix entry of `f` is nonzero.
-/
def biproduct.column_nonzero_of_iso {C : Type u} [category C] [preadditive C] {σ : Type v} {τ : Type v} [DecidableEq σ] [DecidableEq τ] [fintype τ] {S : σ → C} [limits.has_biproduct S] {T : τ → C} [limits.has_biproduct T] (s : σ) (nz : 𝟙 ≠ 0) [(t : τ) → DecidableEq (S s ⟶ T t)] (f : ⨁ S ⟶ ⨁ T) [is_iso f] : trunc (psigma fun (t : τ) => limits.biproduct.ι S s ≫ f ≫ limits.biproduct.π T t ≠ 0) :=
  trunc_sigma_of_exists sorry


/-
Copyright (c) 2018 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/

/-!
# Extra definitions on `option`

This file defines more operations involving `option α`. Lemmas about them are located in other
files under `data.option.`.
Other basic operations on `option` are defined in the core library.
-/

namespace option
variables {α : Type*} {β : Type*}

attribute [inline] option.is_some option.is_none

/-- An elimination principle for `option`. It is a nondependent version of `option.rec`. -/
@[simp] protected def elim (b : β) (f : α → β) : option α → β
| (some a) := f a
| none     := b

instance has_mem : has_mem α (option α) := ⟨λ a b, b = some a⟩

@[simp] theorem mem_def {a : α} {b : option α} : a ∈ b ↔ b = some a :=
iff.rfl

lemma mem_iff {a : α} {b : option α} : a ∈ b ↔ b = a := iff.rfl

theorem is_none_iff_eq_none {o : option α} : o.is_none = tt ↔ o = none :=
⟨option.eq_none_of_is_none, λ e, e.symm ▸ rfl⟩

theorem some_inj {a b : α} : some a = some b ↔ a = b := by simp

lemma mem_some_iff {α : Type*} {a b : α} : a ∈ some b ↔ b = a :=
by simp

/--
`o = none` is decidable even if the wrapped type does not have decidable equality.

This is not an instance because it is not definitionally equal to `option.decidable_eq`.
Try to use `o.is_none` or `o.is_some` instead.
-/
@[inline]
def decidable_eq_none {o : option α} : decidable (o = none) :=
decidable_of_decidable_of_iff (bool.decidable_eq _ _) is_none_iff_eq_none

instance decidable_forall_mem {p : α → Prop} [decidable_pred p] :
  ∀ o : option α, decidable (∀ a ∈ o, p a)
| none     := is_true (by simp [false_implies_iff])
| (some a) := if h : p a
  then is_true $ λ o e, some_inj.1 e ▸ h
  else is_false $ mt (λ H, H _ rfl) h

instance decidable_exists_mem {p : α → Prop} [decidable_pred p] :
  ∀ o : option α, decidable (∃ a ∈ o, p a)
| none     := is_false (λ ⟨a, ⟨h, _⟩⟩, by cases h)
| (some a) := if h : p a
  then is_true $ ⟨_, rfl, h⟩
  else is_false $ λ ⟨_, ⟨rfl, hn⟩⟩, h hn

/-- Inhabited `get` function. Returns `a` if the input is `some a`, otherwise returns `default`. -/
@[reducible] def iget [inhabited α] : option α → α
| (some x) := x
| none     := default

@[simp] theorem iget_some [inhabited α] {a : α} : (some a).iget = a := rfl

/-- `guard p a` returns `some a` if `p a` holds, otherwise `none`. -/
def guard (p : α → Prop) [decidable_pred p] (a : α) : option α :=
if p a then some a else none

/-- `filter p o` returns `some a` if `o` is `some a` and `p a` holds, otherwise `none`. -/
def filter (p : α → Prop) [decidable_pred p] (o : option α) : option α :=
o.bind (guard p)

/-- Cast of `option` to `list `. Returns `[a]` if the input is `some a`, and `[]` if it is
`none`. -/
def to_list : option α → list α
| none     := []
| (some a) := [a]

@[simp] theorem mem_to_list {a : α} {o : option α} : a ∈ to_list o ↔ a ∈ o :=
by cases o; simp [to_list, eq_comm]

/-- Two arguments failsafe function. Returns `f a b` if the inputs are `some a` and `some b`, and
"does nothing" otherwise. -/
def lift_or_get (f : α → α → α) : option α → option α → option α
| none     none     := none
| (some a) none     := some a       -- get a
| none     (some b) := some b       -- get b
| (some a) (some b) := some (f a b) -- lift f

instance lift_or_get_comm (f : α → α → α) [h : is_commutative α f] :
  is_commutative (option α) (lift_or_get f) :=
⟨λ a b, by cases a; cases b; simp [lift_or_get, h.comm]⟩

instance lift_or_get_assoc (f : α → α → α) [h : is_associative α f] :
  is_associative (option α) (lift_or_get f) :=
⟨λ a b c, by cases a; cases b; cases c; simp [lift_or_get, h.assoc]⟩

instance lift_or_get_idem (f : α → α → α) [h : is_idempotent α f] :
  is_idempotent (option α) (lift_or_get f) :=
⟨λ a, by cases a; simp [lift_or_get, h.idempotent]⟩

instance lift_or_get_is_left_id (f : α → α → α) :
  is_left_id (option α) (lift_or_get f) none :=
⟨λ a, by cases a; simp [lift_or_get]⟩

instance lift_or_get_is_right_id (f : α → α → α) :
  is_right_id (option α) (lift_or_get f) none :=
⟨λ a, by cases a; simp [lift_or_get]⟩

/-- Lifts a relation `α → β → Prop` to a relation `option α → option β → Prop` by just adding
`none ~ none`. -/
inductive rel (r : α → β → Prop) : option α → option β → Prop
/-- If `a ~ b`, then `some a ~ some b` -/
| some {a b} : r a b → rel (some a) (some b)
/-- `none ~ none` -/
| none       : rel none none

/-- Partial bind. If for some `x : option α`, `f : Π (a : α), a ∈ x → option β` is a
  partial function defined on `a : α` giving an `option β`, where `some a = x`,
  then `pbind x f h` is essentially the same as `bind x f`
  but is defined only when all `x = some a`, using the proof to apply `f`. -/
@[simp] def pbind : Π (x : option α), (Π (a : α), a ∈ x → option β) → option β
| none     _ := none
| (some a) f := f a rfl

/-- Partial map. If `f : Π a, p a → β` is a partial function defined on `a : α` satisfying `p`,
then `pmap f x h` is essentially the same as `map f x` but is defined only when all members of `x`
satisfy `p`, using the proof to apply `f`. -/
@[simp] def pmap {p : α → Prop} (f : Π (a : α), p a → β) :
  Π x : option α, (∀ a ∈ x, p a) → option β
| none     _ := none
| (some a) H := some (f a (H a (mem_def.mpr rfl)))

/-- Flatten an `option` of `option`, a specialization of `mjoin`. -/
@[simp] def join : option (option α) → option α :=
λ x, bind x id

protected def {u v} traverse {F : Type u → Type v} [applicative F] {α β : Type*} (f : α → F β) :
  option α → F (option β)
| none     := pure none
| (some x) := some <$> f x

/- By analogy with `monad.sequence` in `init/category/combinators.lean`. -/

/-- If you maybe have a monadic computation in a `[monad m]` which produces a term of type `α`, then
there is a naturally associated way to always perform a computation in `m` which maybe produces a
result. -/
def {u v} maybe {m : Type u → Type v} [monad m] {α : Type u} : option (m α) → m (option α)
| none      := return none
| (some fn) := some <$> fn

/-- Map a monadic function `f : α → m β` over an `o : option α`, maybe producing a result. -/
def {u v w} mmap {m : Type u → Type v} [monad m] {α : Type w} {β : Type u} (f : α → m β)
  (o : option α) : m (option β) := (o.map f).maybe

/-- A monadic analogue of `option.elim`. -/
def melim {α β : Type*} {m : Type* → Type*} [monad m] (y : m β) (z : α → m β) (x : m (option α)) :
  m β :=
x >>= option.elim y z

/-- A monadic analogue of `option.get_or_else`. -/
def mget_or_else {α : Type*} {m : Type* → Type*} [monad m] (x : m (option α)) (y : m α) : m α :=
melim y pure x

end option


/- This file contains the construction of the presheaf of rings on Spec(R) and the proof
   that it satisfies the sheaf axiom for finite covers by basic open sets.

   We seem to need to explicitly tell Lean that something canonically isomorphic
   to an exact sequence is an exact sequence.

   We start with Kenny's non-canonical proof that something iso to a three term exact seq is exact.

   We then use my ghastly application coming from localization.

   This file corresponds to the line in tag01HR:
   "Thus we may apply Algebra, Lemma 10.22.2 to the module Mf over Rf and the elements g1,…,gn.
   We conclude that the sequence is exact."
   The issue is that there are a lot of diagrams which commute, but this needs checking.

-/
import algebra.group data.set data.equiv.basic -- for comm diag stuff
import tag00DY -- definition of standard basis on Spec(R) plus proof it's a basis
import tag00E0
import tag00EJ -- finite cover by basic opens sheaf axiom
import tag009I -- definition of presheaf of types on basis
import tag009L -- definition of basis_is_compact
--import group_theory.submonoid
import ring_theory.localization
import Kenny_comm_alg.Zariski
--import tag00E0
import tag01HS -- for "lemma_standard_open" giving map R[1/f] -> R[1/g] from D(g) ⊆ D(f)
--import tag009I -- presheaf of types on a basis
--import tag00DY -- claim that D(f) form a basis
--import tag006N -- presheaves / sheaves of rings on a basis
--import tag009P -- presheaf of rings on a basis
--import tag009L -- sheaf for finite covers on basis -> sheaf for basis
import tag00EJ
import linear_algebra -- for span

local attribute [instance] classical.prop_decidable

universes u0 u v w

definition Pi_lift_map₁ {γ : Type u} {F : γ → Type u} {G : γ → Type u}
  (H : ∀ i : γ, F i → G i) : (Π i, F i) → Π i, G i := λ Fi i, H i (Fi i)

definition Pi_lift_map₂ {γ : Type u} {X : Type u} {G : γ → Type u}
  (H : ∀ i : γ, X → G i) : X → Π i, G i := λ x i, H i x

namespace is_add_group_hom

variables {α : Type*} {β : Type*} [add_group α] [add_group β] (f : α → β) [hf : is_add_group_hom f]

instance ring_hom_is_add_group_hom {α β : Type u} [ring α] [ring β] (f : α → β) [is_ring_hom f] : is_add_group_hom f :=
⟨λ _ _, is_ring_hom.map_add f⟩

def ker : set α :=
{ x | f x = 0 }

instance Pi_lift {γ : Type u} {F : γ → Type u} {G : γ → Type u} [∀ i, add_group (F i)]
[∀ i, add_group (G i)] (H : ∀ i : γ, F i → G i) [∀ i, is_add_group_hom (H i)] :
 is_add_group_hom (Pi_lift_map₁ H) := ⟨λ a b, funext $ λ i,
show H i ((a i) + (b i)) = H i (a i) + H i (b i),
by rw (add (H i))⟩

instance equiv.Pi_congr_right {γ : Type u} {F : γ → Type u} {G : γ → Type u} [∀ i, add_group (F i)]
[∀ i, add_group (G i)] (H : ∀ i : γ, F i ≃ G i) [∀ i, is_add_group_hom (H i)] :
 is_add_group_hom (equiv.Pi_congr_right H) :=
-- is_add_group_hom.Pi_lift H
 is_add_group_hom.Pi_lift (λ i, H i)

end is_add_group_hom

namespace equiv

theorem to_fun.injective {α β : Type u} (e : α ≃ β) : function.injective e :=
function.injective_of_has_left_inverse ⟨e.symm,e.inverse_apply_apply⟩

end equiv

--class is_alg_hom (R : Type u) [ring R] {A B : Type u} [ring A] [ring B] (sA : R → A) (sB : R → B)
--[is_ring_hom sA] [is_ring_hom sB] (f : A → B) extends is_ring_hom f : Prop :=
--(commutes : ∀ r, f (sA r) = sB r)

namespace is_ring_hom

instance Pi_lift_map₁ {γ : Type u} {F : γ → Type u} {G : γ → Type u} [∀ i, ring (F i)]
[∀ i, ring (G i)] (H : ∀ i : γ, F i → G i) [H' : ∀ i, is_ring_hom (H i)] :
 is_ring_hom (Pi_lift_map₁ H) :=
{ map_add := λ a b, funext $ λ x,begin
    show H x (a x + b x) = H x (a x) + H x (b x),
    rw (H' x).map_add,
    end,
  map_mul := λ a b, funext $ λ x,begin
    show H x (a x * b x) = H x (a x) * H x (b x),
    rw (H' x).map_mul,
    end,
  map_one := funext $ λ x,begin
    show H x 1 = 1,
    exact (H' x).map_one
  end
}

instance equiv.Pi_congr_right {γ : Type u} {F : γ → Type u} {G : γ → Type u} [∀ i, ring (F i)]
[∀ i, ring (G i)] (H : ∀ i : γ, F i ≃ G i) [H' : ∀ i, is_ring_hom (H i)] :
 is_ring_hom (equiv.Pi_congr_right H) := is_ring_hom.Pi_lift_map₁ (λ i, H i)

end is_ring_hom

-- If A -> B -> C is isomorphic to A' -> B' -> C' and first sequence is exact then second is.
-- But I don't ever use this now.
/-
theorem three (A B C A' B' C' : Type*)
  [add_comm_group A] [add_comm_group A']
  [add_comm_group B] [add_comm_group B']
  [add_comm_group C] [add_comm_group C']
  (ab : A → B) [is_add_group_hom ab]
  (bc : B → C) [is_add_group_hom bc]
  (Habc : set.range ab = is_add_group_hom.ker bc)
  (fa : A ≃ A') [is_add_group_hom fa]
  (fb : B ≃ B') [is_add_group_hom fb]
  (fc : C ≃ C') [is_add_group_hom fc]

  (ab' : A' → B') [is_add_group_hom ab']
  (bc' : B' → C') [is_add_group_hom bc']
  (H1 : fb ∘ ab = ab' ∘ fa)
  (H2 : fc ∘ bc = bc' ∘ fb) :

  set.range ab' = is_add_group_hom.ker bc' :=
begin
  apply set.ext,
  intro b',
  split,
  { intro hb',
    cases hb' with a' ha',
    simp [is_add_group_hom.ker],
    let a := fa.symm a',
    have ha : fa a = a',
    { simp [a] },
    rw [← ha', ← ha],
    change bc' ((ab' ∘ fa) a) = 0,
    rw ← H1,
    change (bc' ∘ fb) (ab a) = 0,
    rw ← H2,
    have H3 : ab a ∈ is_add_group_hom.ker bc,
    { rw ← Habc, existsi a, simp },
    simp [is_add_group_hom.ker] at H3 ⊢,
    rw H3,
    apply is_add_group_hom.zero },
  { intro hb',
    let b := fb.symm b',
    have hb : fb b = b',
    { simp [b] },
    simp [is_add_group_hom.ker] at hb',
    rw ← hb at hb',
    change (bc' ∘ fb) b = 0 at hb',
    rw ← H2 at hb',
    rw ← is_add_group_hom.zero fc at hb',
    replace hb' := congr_arg fc.symm hb',
    simp at hb',
    have H3 : b ∈ set.range ab,
    { rwa Habc },
    cases H3 with a ha,
    existsi fa a,
    change (ab' ∘ fa) a = b',
    rw ← H1,
    simp [ha] }
end

-- Thanks Kenny.
-/

-- Now start moving stuff from tag01HR.lean which has got really
-- unwieldy. Here I am going to prove the sheaf on a finite basis
-- statement from the ring theory lemma tag00EJ

-- First here's the choice-free definition of the structure presheaf

def is_zariski.standard_open {R : Type u} [comm_ring R] (U : set (X R)) := ∃ f : R, U = Spec.D'(f)

def non_zero_on_U {R : Type u} [comm_ring R] (U : set (X R)) : set R := {g : R | U ⊆ Spec.D'(g)}

instance nonzero_on_U_is_mult_set {R : Type u} [comm_ring R] (U : set (X R)) : is_submonoid (non_zero_on_U U) :=
{ one_mem := λ P HP, @is_proper_ideal.one_not_mem _ _ P.1 P.2.1,
  mul_mem := begin
    intros f g Hf Hg,
    show U ⊆ Spec.D'(f*g),
    rw [tag00E0.lemma15 R f g],
    exact set.subset_inter Hf Hg
    end
}

lemma nonzero_on_U_mono {R : Type u} [comm_ring R] {U V : set (X R)} : V ⊆ U → non_zero_on_U U ⊆ non_zero_on_U V :=
λ H _,set.subset.trans H

def zariski.structure_presheaf_on_standard {R : Type u} [comm_ring R] (U : set (X R)) (H : is_zariski.standard_open U) : Type u :=
  @localization.loc R _ (non_zero_on_U U) (nonzero_on_U_is_mult_set U)

instance zariski.structure_presheaf_on_standard.comm_ring {R : Type u} [comm_ring R] (U : set (X R)) (H : is_zariski.standard_open U) :
comm_ring (zariski.structure_presheaf_on_standard U H) :=
@localization.comm_ring _ _ _ (nonzero_on_U_is_mult_set U)

-- A key notion for us is that of a canonical R-algebra isomorphism.
-- Because I still don't quite understand what makes an isomorphism
-- canonical let's just start with the notion of an R-algebra isomorphism.

structure R_alg_equiv {R : Type u} {α : Type v} {β : Type w} [comm_ring R] [comm_ring α] [comm_ring β]
  (sα : R → α) (sβ : R → β) extends ring_equiv α β :=
(R_alg_hom : sβ = to_fun ∘ sα)

instance R_alg_equiv_coe_to_fun {R : Type u} {α : Type v} {β : Type w} [comm_ring R] [comm_ring α] [comm_ring β]
  (sα : R → α) (sβ : R → β) : has_coe_to_fun (R_alg_equiv sα sβ) := ⟨_,λ h,h.to_fun⟩

instance R_alg_equiv_is_ring_hom {R : Type u} {α : Type v} {β : Type w} [comm_ring R] [comm_ring α] [comm_ring β]
  (sα : R → α) (sβ : R → β) (H : R_alg_equiv sα sβ) : is_ring_hom H := H.is_ring_hom

namespace R_alg_equiv

lemma symm {R : Type u} {α : Type v} {β : Type w}
  [comm_ring R] [comm_ring α] [comm_ring β]
  {sα : R → α} {sβ : R → β} :
  R_alg_equiv sα sβ → R_alg_equiv sβ sα :=
  λ H, { R_alg_hom := begin
         let f := H.to_fun,
         have H2 : sβ = f ∘ sα := H.R_alg_hom,
         let g := H.inv_fun,
         show sα = g ∘ sβ,
         rw H2,
         funext,
         show _ = g (f (sα x)),
         conv begin
           to_lhs,
           rw ←H.left_inv (sα x),
         end,
       end,
    ..(H.to_ring_equiv).symm
  }

/- we have his for ring_equiv and I've never implemented this version here
  lemma inv_fun_is_ring_hom {R : Type u} {α : Type v} {β : Type w}
  [comm_ring R] [comm_ring α] [comm_ring β]
  {sα : R → α} {sβ : R → β} (H : R_alg_equiv sα sβ) : is_ring_hom H.inv_fun := sorry
-/
lemma trans {R : Type u0} {α : Type u} {β : Type v} {γ : Type w}
  [comm_ring R] [comm_ring α] [comm_ring β] [comm_ring γ]
  {sα : R → α} {sβ : R → β} {sγ : R → γ} :
  R_alg_equiv sα sβ → R_alg_equiv sβ sγ → R_alg_equiv sα sγ :=
λ H1 H2,
{ R_alg_hom := begin
     show sγ = H2.to_fun ∘ (H1.to_fun ∘ sα),
     funext,
     have H3 : sγ = H2.to_fun ∘ sβ := H2.R_alg_hom,
     have H4 : sβ = H1.to_fun ∘ sα := H1.R_alg_hom,
     conv begin
       to_lhs,
       rw H3,
       change H2.to_fun (sβ x),
     end,
     conv in (sβ x) begin
       rw H4,
     end,
  end,
  ..(ring_equiv.trans H1.to_ring_equiv H2.to_ring_equiv)
}

-- TODO
-- I need to now give easy access to "inv_fun is ring hom".

open localization

definition of_unique_homs {R : Type u} {α : Type v} {β : Type w} [comm_ring R] [comm_ring α] [comm_ring β]
  {sα : R → α} {sβ : R → β} {f : α → β} {g : β → α} {hα : α → α} {hβ : β → β}
  [is_ring_hom sα] [is_ring_hom sβ] [H : is_ring_hom f] [is_ring_hom g] [is_ring_hom hα] [is_ring_hom hβ] :
is_unique_R_alg_hom sα sβ f → is_unique_R_alg_hom sβ sα g → is_unique_R_alg_hom sα sα hα → is_unique_R_alg_hom sβ sβ hβ
  → R_alg_equiv sα sβ := λ Hαβ Hβα Hαα Hββ,
{ to_fun := f,
  inv_fun := g,
  left_inv := λ x, begin
    have Hα : id = hα,
      exact Hαα.is_unique id rfl,
    show (g ∘ f) x = x,
    rw [comp_unique sα sβ sα f g hα Hαβ Hβα Hαα,←Hα],
    refl
  end,
  right_inv := λ x, begin
    have Hβ : id = hβ,
      exact Hββ.is_unique id rfl,
    show (f ∘ g) x = x,
    rw [comp_unique sβ sα sβ g f hβ Hβα Hαβ Hββ,←Hβ],
    refl
  end,
  is_ring_hom := H,
  R_alg_hom := show sβ = f ∘ sα, from Hαβ.R_alg_hom
}

end R_alg_equiv -- namespace

-- The proof below (is_loc) could be simpler: a lot of the definitions would follow from
-- universal properties, but Kenny just proved them directly anyway.
-- It's the proof that if U=D(f) and S=S(U) is the functions which are non-vanishing
-- on U then R[1/S]=R[1/f] as R-algebras.

open localization

noncomputable definition zariski.structure_presheaf_on_standard_is_loc {R : Type u} [comm_ring R] (f : R) :
  R_alg_equiv (of_comm_ring R _ : R → zariski.structure_presheaf_on_standard (Spec.D'(f)) (⟨f,rfl⟩))
    (of_comm_ring R (powers f) : R → away f) :=
{ to_fun      := extend_map_of_im_unit
    (of_comm_ring R (powers f))
    (λ s hs, lemma_standard_open_1a R _ _ hs),
  is_ring_hom := extend_map_of_im_unit.is_ring_hom _ _,
  inv_fun     := away.extend_map_of_im_unit
    (of_comm_ring R _)
    ⟨mk _ _ ⟨1, f, set.subset.refl _⟩,
     quotient.sound ⟨1, is_submonoid.one_mem _, by simp⟩⟩,
  left_inv    := @unique _ _ _ _ _ _ _ _
    (@@is_ring_hom.comp _ _ _
       (extend_map_of_im_unit.is_ring_hom _ _) _ _
       (extend_map_of_im_unit.is_ring_hom _ _))
    (ring_equiv.refl _).is_ring_hom
    (by intro x; dsimp [ring_equiv.refl, equiv.refl]; rw [extend_map_extends, extend_map_extends]),
  right_inv   := @localization.unique _ _ _ _ _ _ _ _
    (@@is_ring_hom.comp _ _ _
       (extend_map_of_im_unit.is_ring_hom _ _) _ _
       (extend_map_of_im_unit.is_ring_hom _ _))
    (ring_equiv.refl _).is_ring_hom
    (by intro x; dsimp [ring_equiv.refl, equiv.refl]; rw [localization.extend_map_extends, localization.extend_map_extends]),
  R_alg_hom := (funext (λ r, (localization.extend_map_extends
     (_ : R → localization.loc R (powers f))
     _ r
       ).symm)
  : localization.of_comm_ring R (powers f) =
    localization.extend_map_of_im_unit (localization.of_comm_ring R (powers f)) _ ∘
      localization.of_comm_ring R (non_zero_on_U (Spec.D' f)))
}

-- we now need some universal properties coming from localization.

set_option class.instance_max_depth 52 -- !!

/-- universal property of inverting one element and then another -/
theorem away_away_universal_property {R : Type u} [comm_ring R] (f : R)
(g : loc R (powers f)) {γ : Type v} [comm_ring γ] (sγ : R → γ) [is_ring_hom sγ] (Hf : is_unit (sγ f))
(Hg : is_unit (away.extend_map_of_im_unit sγ Hf g)) :
is_unique_R_alg_hom
  ((of_comm_ring (away f) (powers g)) ∘ (of_comm_ring R (powers f)))
  sγ
  (away.extend_map_of_im_unit (away.extend_map_of_im_unit sγ Hf) Hg) :=
begin
  let α := loc R (powers f),
  let β := loc α (powers g),
  let sα := of_comm_ring R (powers f),
  let fαβ := of_comm_ring α (powers g),
  let sβ := fαβ ∘ sα,
  let fαγ := away.extend_map_of_im_unit sγ Hf,
  let fβγ := away.extend_map_of_im_unit fαγ Hg,
  have HUαγ : is_unique_R_alg_hom sα sγ fαγ := away_universal_property f sγ Hf,
  have HUβγ : is_unique_R_alg_hom fαβ fαγ fβγ := away_universal_property g fαγ Hg,
  have Hαγ : sγ = fαγ ∘ sα := HUαγ.R_alg_hom,
  have Hβγ : fαγ = fβγ ∘ fαβ := HUβγ.R_alg_hom,
  -- it's the next line which needs class.instance_max_depth 52
  have Htemp : is_unique_R_alg_hom sα sγ fαγ ↔ is_unique_R_alg_hom sα (fβγ ∘ fαβ ∘ sα) (fβγ ∘ fαβ),
    simp [Hαγ,Hβγ],
  have Htemp2 : is_unique_R_alg_hom fαβ fαγ fβγ ↔ is_unique_R_alg_hom fαβ (fβγ ∘ fαβ) fβγ,
    simp [Hβγ],
  have H : is_unique_R_alg_hom (fαβ ∘ sα) (fβγ ∘ fαβ ∘ sα) fβγ := unique_R_of_unique_R_of_unique_Rloc sα fαβ fβγ (Htemp.1 HUαγ) (Htemp2.1 HUβγ),
  have Htemp3 : is_unique_R_alg_hom (fαβ ∘ sα) (fβγ ∘ fαβ ∘ sα) fβγ ↔ is_unique_R_alg_hom (fαβ ∘ sα) sγ fβγ,
    simp [Hαγ,Hβγ],
  exact Htemp3.1 H
end

/-- universal property of inverting two elements of R one by one -/
theorem away_away_universal_property' {R : Type u} [comm_ring R] (f g : R)
{γ : Type v} [comm_ring γ] (sγ : R → γ) [is_ring_hom sγ] (Hf : is_unit (sγ f))
(Hg : is_unit (sγ g)) :
is_unique_R_alg_hom
  ((of_comm_ring (away f) (powers (of_comm_ring R (powers f) g))) ∘ (of_comm_ring R (powers f)))
  sγ
  (away.extend_map_of_im_unit (away.extend_map_of_im_unit sγ Hf) (begin rwa away.extend_map_extends end)) :=
away_away_universal_property f (of_comm_ring R (powers f) g) sγ Hf (begin rwa away.extend_map_extends end)

-- To get Chris' lemma to apply to covers of D(f) (rather than a cover of R)
-- we need R[1/f][1/g] = R[1/g] if D(g) ⊆ D(f), so let's prove this from the
-- universal property.

noncomputable definition localization.loc_loc_is_loc {R : Type u} [comm_ring R] {f g : R} (H : Spec.D' g ⊆ Spec.D' f) :
  let sα := (of_comm_ring (away f) (powers (of_comm_ring R (powers f) g))) ∘ (of_comm_ring R (powers f)) in
  let sβ := of_comm_ring R (powers g) in
R_alg_equiv sα sβ :=
begin
  have Htemp : is_ring_hom (of_comm_ring (away f) (powers (of_comm_ring R (powers f) g))) := by apply_instance,
  letI := Htemp,
  let sα : R → loc (away f) (powers (of_comm_ring R (powers f) g)) :=
    (of_comm_ring (away f) (powers (of_comm_ring R (powers f) g))) ∘ (of_comm_ring R (powers f)),
  let sβ := of_comm_ring R (powers g),
  have HUfα : is_unit (sα f),
    show is_unit ((of_comm_ring (away f) (powers (of_comm_ring R (powers f) g))) ((of_comm_ring R (powers f)) f)),
    exact im_unit_of_unit (of_comm_ring (away f) (powers (of_comm_ring R (powers f) g))) (unit_of_in_S (away.in_powers f)),
  have HUfβ : is_unit (sβ f) := lemma_standard_open_1a R f g H,
  have HUgα : is_unit (sα g) := unit_of_in_S (away.in_powers (of_comm_ring R (powers f) g)),
  have HUgβ : is_unit (sβ g) := unit_of_in_S (away.in_powers g),
  exact R_alg_equiv.of_unique_homs
    (away_away_universal_property' f g sβ HUfβ HUgβ)
    (away_universal_property g sα HUgα : is_unique_R_alg_hom sβ sα _)
    (away_away_universal_property' f g sα HUfα HUgα)
    (away_universal_property g sβ HUgβ)
end

-- Now I need the following technical result:
-- If V = D(g) ⊆ U = D(f) in Spec(R)
-- then structure sheaf evaluated on V (R[1/S(V)]) is R-isomorphic to R[1/f][1/gbar]
-- with gbar = image of g. The map is from R[1/S(V)] to R[1/f][1/gbar]
-- The proof goes via R[1/g]
-- It is also true that the R-isomorphism is the unique R-homomorphism
-- between these rings -- see the lemma after this.
noncomputable definition canonical_iso {R : Type u} [comm_ring R] {f g : R} (H : Spec.D' g ⊆ Spec.D' f) :
let gbar := of_comm_ring R (powers f) g in
let sα : R → loc (away f) (powers gbar) :=
  of_comm_ring (away f) (powers gbar) ∘ of_comm_ring R (powers f) in
let sγ := (of_comm_ring R (non_zero_on_U (Spec.D' g))) in
R_alg_equiv sγ sα :=
R_alg_equiv.trans
  (zariski.structure_presheaf_on_standard_is_loc g )
  (R_alg_equiv.symm (localization.loc_loc_is_loc H))

-- and we also need that the canonical iso is the unique R-alg hom.
-- From R[1/S(V)] to R[1/f][1/gbar] the result is here:

-- NB Chris suggests I remove the first three let's.
theorem canonical_iso_is_canonical_hom₁ {R : Type u} [comm_ring R] {f g : R} (H : Spec.D' g ⊆ Spec.D' f) :
let gbar := of_comm_ring R (powers f) g in
let sα : R → loc (away f) (powers gbar) :=
  of_comm_ring (away f) (powers gbar) ∘ of_comm_ring R (powers f) in
let sγ := (of_comm_ring R (non_zero_on_U (Spec.D' g))) in
let H3 : is_ring_hom sα := by apply_instance in
let H2 := (canonical_iso H).is_ring_hom in
let H4 : is_ring_hom sγ := by apply_instance in
@is_unique_R_alg_hom _ _ _ _ _ _ sγ sα (canonical_iso H).to_fun H4 H3 H2 :=
begin
letI := (canonical_iso H).is_ring_hom,
have H5 := unique_R_alg_from_loc (canonical_iso H).to_fun,
have H6 := (canonical_iso H).R_alg_hom.symm,
simp [H6] at H5,
exact H5,
end

-- now let's go the other way -- but do I need this?
/-
theorem canonical_iso_is_canonical_hom₂ {R : Type u} [comm_ring R] {f g : R} (H : Spec.D' g ⊆ Spec.D' f) :
let gbar := of_comm_ring R (powers f) g in
let sα : R → loc (away f) (powers gbar) :=
  of_comm_ring (away f) (powers gbar) ∘ of_comm_ring R (powers f) in
let sγ := (of_comm_ring R (non_zero_on_U (Spec.D' g))) in
let H3 : is_ring_hom sα := by apply_instance in
let H2 : is_ring_hom (canonical_iso H).inv_fun := ring_equiv.inv_fun_is_ring_hom (canonical_iso H).to_ring_equiv in
let H4 : is_ring_hom sγ := by apply_instance in
@is_unique_R_alg_hom _ _ _ _ _ _ sα sγ (canonical_iso H).inv_fun H3 H4 H2 := sorry
-/

-- Chris has proved that 0-> A -> sum A_{g_i} -> sum A_{g_i g_j} is exact
-- if Spec(A) is covered by D(g_i) (a finite cover).

-- I want to prove that if U = D(f) is open and covered by U_i = D(g_i)
-- and if A = R[1/S(U)] then
-- 0 -> A -> sum R[1/S(U_i)] -> sum R[1/S(U_i intersect U_j)] is exact

-- Let's formulate exactly what we need.

theorem fourexact_from_iso_to_fourexact {A B C A' B' C' : Type u}
  [add_comm_group A] [add_comm_group A']
  [add_comm_group B] [add_comm_group B']
  [add_comm_group C] [add_comm_group C']
  (ab : A → B) [is_add_group_hom ab]
  (bc : B → C) [is_add_group_hom bc]
--  (Habc : set.range ab = is_add_group_hom.ker bc)
  (H4exact : ∀ b : B, bc b = 0 → ∃! a : A, ab a = b)
  (fa : A ≃ A') [is_add_group_hom fa]
  (fb : B ≃ B') [is_add_group_hom fb]
  (fc : C ≃ C') [is_add_group_hom fc]

  (ab' : A' → B') [is_add_group_hom ab']
  (bc' : B' → C') [is_add_group_hom bc']
  (H1 : ∀ a, fb (ab a) = ab' (fa a))
  (H2 : ∀ b, fc (bc b) = bc' (fb b))
  : ∀ b' : B', (bc' b' = 0 → ∃! a' : A', ab' a' = b') :=
begin
  intros b' Hb',
  let b := fb.symm b',
    have H3 : fc (bc b) = 0,
    rw H2 b,
    simp [Hb'],
  have Hb : bc b = 0,
    have H4 : fc.symm (fc (bc b)) = 0,
      rw H3,
      have H5 : fc (0 : C) = 0 := is_add_group_hom.zero fc,
      rw ←H5,
      simp,
    simp only [equiv.inverse_apply_apply fc] at H4,
    exact H4,
  cases H4exact b Hb with a Ha,
  existsi (fa a),
  split,
  { show ab' (fa a) = b',
    rw ←H1,
    rw Ha.1,
    exact equiv.apply_inverse_apply fb b'
  },
  intros a₁' Ha₁',
  have H4 := Ha.2 (fa.symm a₁'),
  suffices H5 : ab (fa.symm a₁') = b,
    rw ←(H4 H5),simp,
  apply equiv.to_fun.injective fb,
  rw H1,
  simp [Ha₁'],
end


import tactic --hide

/-Lemma
A nested chain ofimplications.
-/
lemma lemma_7 (P Q: Prop) : (P → Q) → ((P → Q) → P) → Q :=
begin
  intros hPQ hPQP,
  apply hPQ,
  apply hPQP,
  exact hPQ,

end