import tactic
import measure_theory.interval_integral
import measure_theory.lebesgue_measure
import measure_theory.set_integral
import analysis.calculus.deriv
import analysis.special_functions.exp_log
import analysis.special_functions.trigonometric
import data.finset

noncomputable theory
open_locale classical
open_locale big_operators
open measure_theory
open interval_integral
open set
open real

namespace tactic.interactive

meta def show_continuous := `[
  all_goals {try {simp}},
  apply_rules [
    continuous_on.neg,
    continuous.continuous_on,
    differentiable.continuous,
    differentiable_on.continuous_on,
    continuous.Icc_extend,
    continuous_on.mono,
    continuous.neg,
    continuous_id,
    continuous_sin,
    continuous_cos,
    continuous_const,
    continuous.pow,
    continuous.mul,
    continuous.smul,
    continuous.sub,
    continuous.add
    ] 10,
  all_goals {try {norm_num}}
]

meta def show_differentiable := `[
  apply_rules [
    differentiable.differentiable_on,
    differentiable.neg,
    differentiable.smul,
    differentiable.cos,
    differentiable.sin,
    differentiable_const,
    differentiable_id,
    differentiable.mul,
    differentiable_fpow
    ] 10,
  all_goals {try {norm_num}}
]

meta def show_nonzero := `[
  apply_rules [
    mul_ne_zero,
    sub_ne_zero_of_ne,
    pow_ne_zero,
    ne_of_gt,
    ne_of_lt
    ] 10,
  all_goals {try {norm_cast}, try {norm_num}}
]

meta def show_pos := `[
  apply_rules [
    nat.succ_pos,
    mul_pos,
    div_pos,
    inv_pos.mpr,
    pow_pos
    ] 10,
  all_goals {try {norm_cast}, try {norm_num}, try {nlinarith}}
]

meta def clear_denoms := `[
  try {rw div_eq_div_iff},
  try {rw eq_div_iff},
  try {symmetry, rw eq_div_iff},
  try { ring_exp },
  all_goals {show_nonzero}
]

meta def discrete_field := `[
  try {ext},
  try {field_simp *},
  try {clear_denoms},
  try {ring_exp},
  try {norm_num},
  try {linarith}
]

end tactic.interactive

lemma integrable_of_cont {f : ℝ → ℝ} (a b : ℝ) (h : continuous f):
    interval_integrable f measure_theory.measure_space.volume a b :=
begin
    have hmeas : measurable f := continuous.measurable h,
    have hconton : continuous_on f (interval a b) := continuous.continuous_on h,
    exact continuous_on.interval_integrable hconton,
end

/- lemma self_mem_ae_restrict
  {s : set ℝ} (hs : is_measurable s):
  s ∈ (measure.restrict measure_space.volume s).ae :=
begin
  rw ae_restrict_eq hs,
  simp only [exists_prop, filter.mem_principal_sets, filter.mem_inf_sets],
  exact ⟨univ, filter.univ_mem_sets, s, by simp⟩,
end
 -/
lemma nonempty_inter_of_nonempty_inter_closure {α : Type*} [topological_space α] {s t : set α}
  (hs : is_open s) (h : (s ∩ closure t).nonempty) : (s ∩ t).nonempty :=
let ⟨x, xs, xt⟩ := h in _root_.mem_closure_iff.1 xt s hs xs

lemma real.volume_pos_of_is_open_of_nonempty {s : set ℝ} (h : is_open s) (h' : s.nonempty) :
  0 < volume s :=
begin
  rcases h' with ⟨x, hx⟩,
  have : ∀ᶠ (y : ℝ) in nhds x, y ∈ s := filter.eventually_of_mem (mem_nhds_sets h hx) (λ y H, H),
  exact filter.eventually.volume_pos_of_nhds_real this,
end

theorem integral_strictly_pos_of_cont (f : ℝ → ℝ) (a b : ℝ)
    (hf : continuous f)
    (hab : a < b)
    (h : ∀ (x : ℝ), a ≤ x → x ≤ b → 0 ≤ f x)
    (hneq: ∃ x, a ≤ x ∧ x ≤ b ∧ 0 < f x) :
    0 < ∫ x in a..b, f x :=
begin
  rw integral_pos_iff_support_of_nonneg_ae',
  { refine ⟨hab, _⟩,
    let s := {b : ℝ | 0 < f b},
    have s_open : is_open s := is_open_lt continuous_const hf,
    have : (s ∩ closure (Ioo a b)).nonempty,
    { rw closure_Ioo hab,
      rcases hneq with ⟨x, ax, xb, fxpos⟩,
      have : x ∈ s ∩ Icc a b := ⟨fxpos, ax, xb⟩,
      exact nonempty_of_mem this },
    have : (s ∩ Ioo a b).nonempty := nonempty_inter_of_nonempty_inter_closure s_open this,
    have : 0 < volume (s ∩ Ioo a b) :=
      real.volume_pos_of_is_open_of_nonempty (is_open_inter s_open is_open_Ioo) this,
    refine this.trans_le (measure_mono (λ x hx, _)),
    split,
    { exact ne_of_gt (show 0 < f x, from hx.1) },
    { exact ⟨hx.2.1, hx.2.2.le⟩ } },
  { have : Ioc b a = ∅ := Ioc_eq_empty hab.le,
    simp only [this, union_empty],
    apply filter.eventually_of_mem _ _,
    exact Icc a b,
    {
        simp,
        use univ,
        simp,
        use Icc a b,
        exact ⟨Ioc_subset_Icc_self, rfl.subset⟩,
    },
    simpa using h },
  { exact integrable_of_cont a b hf }
end

theorem integral_strictly_monotone_of_cont (f g : ℝ → ℝ) (a b : ℝ)
    (hf : continuous f) (hg : continuous g) (hab : a < b)
    (h : ∀ (x : ℝ), a ≤ x → x ≤ b → f x ≤ g x)
    (hneq: ∃ x, a ≤ x ∧ x ≤ b ∧ f x < g x) :
    ∫ x in a..b, f x < ∫ x in a..b, g x :=
begin
    have H : 0 < ∫ x in a..b, (g x - f x),
    {
        apply integral_strictly_pos_of_cont
        (g-f) a b (continuous.sub hg hf) hab,
        all_goals {
            simp [sub_pos],
            assumption,
        },
    },
    rw [←sub_pos, ←interval_integral.integral_sub (integrable_of_cont a b hg) (integrable_of_cont a b hf)],
    exact H,
end

lemma int_pos_of_pos {f : ℝ → ℝ} {a b : ℝ} (hab : a < b) (hf : continuous f)
(hnonneg : ∀ x, a ≤ x → x ≤ b → 0 ≤ f x)
(hx : ∃ x, a ≤ x ∧ x ≤ b ∧ 0 < f x) : 0 < ∫ x in a..b, f x :=
begin
    rw ← (integral_zero : ∫ x in a..b, (0:ℝ) = 0 ),
    exact integral_strictly_monotone_of_cont (λ x, (0:ℝ)) f a b continuous_const hf hab hnonneg hx,
end

lemma int_pos_of_square {f : ℝ → ℝ} {a b} (x : ℝ)
    (hab : a < b) (hf : continuous f) (hx : a ≤ x ∧ x ≤ b ∧ f x ≠ 0) :
     0 < ∫ x in a..b, (f x)^2 :=
begin
    refine int_pos_of_pos hab _
        (λ x hx1 hx2, pow_two_nonneg (f x)) ⟨x, ⟨hx.1, hx.2.1, pow_two_pos_of_ne_zero (f x) hx.2.2⟩⟩,
    show_continuous,
end

theorem my_integral_smul (f : ℝ → ℝ) (a b c : ℝ) :
    ∫ x in a..b, c * (f x) = c * ∫ x in a..b, f x :=
begin
    suffices :  ∫ x in a..b, c • (f x) = c • ∫ x in a..b, f x, by exact this,
    rw_mod_cast interval_integral.integral_smul,
end

theorem product_rule {f g : ℝ → ℝ} (hdf : differentiable ℝ f) (hdg : differentiable ℝ g) :
    deriv (f * g) = (deriv f) * g + f * deriv g :=
begin
    ext,
    have hdf0 : differentiable_at ℝ f x := hdf x,
    have hdg0 : differentiable_at ℝ g x := hdg x,
    apply deriv_mul hdf0 hdg0,
end

theorem differentiable_fpow {f : ℝ → ℝ} {n : ℕ} :
    differentiable ℝ f → differentiable ℝ (f^n) :=
begin
    induction n with d hd,
    { intro h,
      simp only [pow_zero],
        exact differentiable_const 1 },
    {
        intro h,
        rw pow_succ,
        exact h.mul (hd h),
    }
end

theorem power_rule {f : ℝ → ℝ} {n : ℕ} (hfd : differentiable ℝ f):
    deriv (f^(n+1)) = ((n : ℝ) + 1) • f^n * (deriv f) :=
begin
    induction n with d hd, by norm_num,
    have H : f^(d+1) = f^d * f := pow_succ' f d,
    calc
        deriv (f^(d.succ+1)) = deriv (f^(d.succ) * f) : by {rw pow_succ' f (d.succ),}
        ... = (deriv (f^(d.succ))) * f + f^(d+1) * (deriv f) :
        begin
            rw product_rule,
            exact differentiable_fpow hfd,
            exact hfd,
        end
        ... = ((d:ℝ) + 1) • f^d * deriv f * f + f^d.succ * deriv f : by {rw hd}
        ... = ((d:ℝ) + 1) • (f^(d.succ)) * deriv f + f^(d.succ) * deriv f :
        begin
            simp only [add_left_inj, H],
            norm_num,
            rw mul_assoc,
            nth_rewrite_lhs 1 mul_comm,
            rw ←mul_assoc,
        end
        ... = ((d.succ:ℝ) + 1) • (f^(d.succ)) * deriv f :
        begin
            simp only [nat.cast_succ, algebra.smul_mul_assoc],
            nth_rewrite 1 add_smul,
            rw one_smul,
        end
end

lemma pow_fun_def {f : ℝ → ℝ} {n : ℕ} : f^n = λ x, (f x)^n :=
begin
    induction n with d hd,
    all_goals {
        try {rw [pow_succ, hd]},
        refl,
    }
end

lemma pow_deriv_fun_def {f : ℝ → ℝ} {n : ℕ} : ((n : ℝ) + 1) • f^n * (deriv f) =
    λ (x : ℝ), ((n : ℝ) + 1) • ((f x)^n * deriv f x) :=
begin
    rw pow_fun_def,
    simpa,
end

@[simp] lemma power_rule'  {f : ℝ → ℝ} (n : ℕ) (hfd : differentiable ℝ f):
    deriv (λ (x : ℝ), (f x)^(n + 1)) = λ (x : ℝ), ((n : ℝ) + 1) • ((f x)^n * deriv f x) :=
begin
    rw [←pow_fun_def, ←pow_deriv_fun_def],
    exact power_rule hfd,
end

@[simp] lemma power_rule'' (n : ℕ) :
    deriv (λ (x : ℝ), x^(n + 1)) = λ (x : ℝ), ((n : ℝ) + 1) • (x^n) :=
begin
    have hfd : differentiable ℝ (λ (x:ℝ), (x:ℝ)) := differentiable_id',
    have deriv_id_my : deriv (λ x, x) = λ (x : ℝ), (1:ℝ) := deriv_id',
    have H := power_rule' n hfd,
    rw deriv_id_my at H,
    rw H,
    simp only [mul_one, algebra.id.smul_eq_mul],
end

theorem int_by_parts (u v : ℝ → ℝ) {a b : ℝ} (hu : differentiable ℝ u)
    (hv : differentiable ℝ v) (hcu : continuous(deriv u)) (hcv : continuous(deriv v)) :
∫ x in a..b, u x * deriv v x =
    u b * v b - u a * v a - ∫ x in a..b,  v x * deriv u x :=
begin
    have hu' : ∀ (x : ℝ), differentiable_at ℝ u x := hu,
    have hv' : ∀ (x : ℝ), differentiable_at ℝ v x := hv,
    have huv : deriv (u * v) = (deriv u) * v + u * deriv v := product_rule hu hv,
    have H : ∫ x in  a..b, ((deriv u) x) * (v x)  + (u x) * ((deriv v) x) = ∫ x in a..b, (deriv (u*v)) x,
    {
        congr,
        solve_by_elim,
    },
    have duv_cont : continuous (deriv (u * v)),
    {
        rw product_rule hu hv,
        apply continuous.add,
        rw mul_comm,
        all_goals {
            apply continuous.mul,
            work_on_goal 0
            {
                apply @differentiable.continuous ℝ _ _ _ _ _ _ _,
            },
            repeat {assumption},
        },
    },
    have duv_cont' : continuous_on (deriv (u * v)) (interval a b),
    {
        intros x hx,
        exact continuous.continuous_within_at duv_cont,
    },
    have H2 : ∫ x in a..b, deriv (u*v) x = u b * v b - u a * v a,
    {
        apply integral_deriv_eq_sub,
        intros x hx,
        exact differentiable_at.mul (hu' x) (hv' x),
        exact duv_cont',
    },
    rw [←H2, ←interval_integral.integral_sub],
    {
        congr,
        ext,
        rw huv,
        simp only [pi.add_apply, pi.mul_apply],
        rw mul_comm (v x) (deriv u x),
        ring,
    },
    {
        apply integrable_of_cont,
        assumption,
    },
    apply integrable_of_cont,
    apply continuous.mul,
    apply @differentiable.continuous ℝ _ _ _ _ _ _ _,
    repeat {assumption},
end

lemma int_by_parts_zero_ends (u v : ℝ → ℝ) {a b : ℝ} (hu : differentiable ℝ u)
    (hv : differentiable ℝ v) (hcu : continuous(deriv u)) (hcv : continuous(deriv v))
    (ha : u a * v a = 0) (hb : u b * v b = 0)
    :
∫ x in a..b, u x * deriv v x = - ∫ x in a..b,  v x * deriv u x :=
begin
    rw int_by_parts,
    repeat {assumption},
    rw [ha, hb],
    norm_num,
end

@[simp] lemma pow_ext (f : ℝ → ℝ) (n : ℕ) : f^n = λ x, (f x)^n :=
begin
    induction n with d hd,
    {
        norm_num,
        refl,
    },
    {
        change f^(d+1) = λ x, (f x)^(d+1),
        rw [pow_add, hd, pow_one],
        ext,
        norm_num,
        ring_nf,
    }
end

lemma differentiable_cospow_at (n: ℕ) {x : ℝ} : differentiable_at ℝ (cos^(n+1)) x:=
by show_differentiable

lemma deriv_cospow (n: ℕ) : deriv (λ (x : ℝ), cos x ^ (n+1)) = λ x, -((n : ℝ)+1) * (cos x)^n * sin x :=
begin
    suffices : (λ (x : ℝ), -(((n:ℝ) + 1) * (cos x ^ n * sin x))) =
        λ (x : ℝ), (-1 + -n) * cos x^n * sin x, by simpa,
    ext,
    ring,
end

lemma continuous_cospow {n: ℕ} : continuous (λ (x : ℝ), (cos x)^n) :=
begin
    exact continuous.pow continuous_cos n,
end

lemma continuous_cospow' {c : ℝ} {m : ℕ}  :
  continuous
    (λ (x : ℝ), c * cos x ^m) := by show_continuous

lemma differentiable_cospow {n: ℕ} : differentiable ℝ (λ (x : ℝ), (cos x)^n) :=
begin
    simp only [differentiable_id', differentiable.pow, differentiable.cos],
end

lemma continuous_deriv_cospow (n: ℕ) : continuous (deriv (λ (x : ℝ), cos x ^ (n+1))) :=
begin
    rw deriv_cospow,
    apply continuous.mul continuous_cospow' continuous_sin,
end

@[simp] lemma deriv_sin_times_cos {x : ℝ} : deriv(sin * cos) x =
    2 * cos x ^ 2 - 1 :=
begin
    have H : deriv (λ (y : ℝ), sin y * cos y) x =
        deriv sin x * cos x + sin x * deriv cos x
        := deriv_mul differentiable_at_sin differentiable_at_cos,
    have h0 : sin * cos = λ y, sin y * cos y, by refl,
    have hsin : sin x^2 = 1 - cos x^2,
    {
        rw eq_sub_iff_add_eq,
        exact sin_sq_add_cos_sq x,
    },
    rw [h0, H, real.deriv_sin, real.deriv_cos],
    ring_nf,
    rw hsin,
    ring,
end

@[simp] lemma deriv_sin_cos {m : ℕ} : deriv (λ x, sin x * cos x^(m+1)) =
    λ x, (m+2) * cos x^(m+2) - (m+1) * cos x^m :=
begin
    ext,
    suffices : deriv(sin * cos^(m+1)) x =
    (m+2) * (cos x)^(m+2) - (m+1) * (cos x)^m,
    {
        rw pow_ext at this,
        exact this,
    },
    induction m with d hd,
    {
        simp only [mul_one, nat.cast_zero, pow_one, zero_add, pow_zero],
        exact deriv_sin_times_cos,
    },
    {
        simp,
        have H := deriv_mul (@differentiable_at_sin x)
            (differentiable_cospow_at d.succ),
        repeat {rw pow_succ,},
        have h2 : (λ (y : ℝ), sin y * (cos ^ (d.succ + 1)) y) x =
            sin x * (cos ^ (d.succ + 1)) x, by tauto,
        have hsin : sin * (λ (x : ℝ), cos x ^ (d.succ + 1)) =
            (λ x, sin x * cos x ^ (d.succ + 1)), by tauto,
        rw hsin,
        have hhd : (sin * cos ^ (d + 1) = λ (y : ℝ), sin y * cos y ^ (d + 1)),
        {
            ext,
            simp only [pi.mul_apply, pow_ext],
        },
        simp [pow_ext],
        ring_exp,
        have sin_to_cos : sin x^2 = 1 - cos x^2,
        {
            rw eq_sub_iff_add_eq,
            exact sin_sq_add_cos_sq x,
        },
        rw sin_to_cos,
        discrete_field,
    },
end


-- A target specifies all `pid_t`s that may receive a message.
--
-- Messages may be sent to all processes (corresponding to `target.all`) or to
-- just one process (corresponding to `target.just p` where `p` is the `pid_t`
-- of the receiving process)
inductive target (pid_t : Type) : Type
| just : pid_t → target
| exclude : pid_t → target

namespace target

variable {pid_t : Type}

-- If `t` is a `target pid_t` and `p` is a `pid_t`, then `t.matches p` is the
-- proposition that "t specifies p as a receiver".
def matches : target pid_t → pid_t → Prop
| (just p₀)    p := p₀ = p
| (exclude p₀) p := p₀ ≠ p

end target

lemma just_self_matches {pid_t : Type} (p : pid_t) : (target.just p).matches p :=
begin
exact eq.refl p
end


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import category_theory.limits.shapes.pullbacks
import category_theory.limits.shapes.kernel_pair
import category_theory.limits.shapes.comm_sq

/-!
# The diagonal object of a morphism.

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

We provide various API and isomorphisms considering the diagonal object `Δ_{Y/X} := pullback f f`
of a morphism `f : X ⟶ Y`.

-/

open category_theory

noncomputable theory

namespace category_theory.limits

variables {C : Type*} [category C] {X Y Z : C}

namespace pullback

section diagonal

variables (f : X ⟶ Y) [has_pullback f f]

/-- The diagonal object of a morphism `f : X ⟶ Y` is `Δ_{X/Y} := pullback f f`. -/
abbreviation diagonal_obj : C := pullback f f

/-- The diagonal morphism `X ⟶ Δ_{X/Y}` for a morphism `f : X ⟶ Y`. -/
def diagonal : X ⟶ diagonal_obj f :=
pullback.lift (𝟙 _) (𝟙 _) rfl

@[simp, reassoc] lemma diagonal_fst : diagonal f ≫ pullback.fst = 𝟙 _ :=
pullback.lift_fst _ _ _

@[simp, reassoc] lemma diagonal_snd : diagonal f ≫ pullback.snd = 𝟙 _ :=
pullback.lift_snd _ _ _

instance : is_split_mono (diagonal f) :=
⟨⟨⟨pullback.fst, diagonal_fst f⟩⟩⟩

instance : is_split_epi (pullback.fst : pullback f f ⟶ X) :=
⟨⟨⟨diagonal f, diagonal_fst f⟩⟩⟩

instance : is_split_epi (pullback.snd : pullback f f ⟶ X) :=
⟨⟨⟨diagonal f, diagonal_snd f⟩⟩⟩

instance [mono f] : is_iso (diagonal f) :=
begin
  rw (is_iso.inv_eq_of_inv_hom_id (diagonal_fst f)).symm,
  apply_instance
end

/-- The two projections `Δ_{X/Y} ⟶ X` form a kernel pair for `f : X ⟶ Y`. -/
lemma diagonal_is_kernel_pair :
  is_kernel_pair f (pullback.fst : diagonal_obj f ⟶ _) pullback.snd :=
is_pullback.of_has_pullback f f

end diagonal

end pullback

variable [has_pullbacks C]

open pullback

section

variables {U V₁ V₂ : C} (f : X ⟶ Y) (i : U ⟶ Y)
variables (i₁ : V₁ ⟶ pullback f i) (i₂ : V₂ ⟶ pullback f i)

@[simp, reassoc]
lemma pullback_diagonal_map_snd_fst_fst :
  (pullback.snd : pullback (diagonal f) (map (i₁ ≫ snd) (i₂ ≫ snd) f f (i₁ ≫ fst) (i₂ ≫ fst) i
    (by simp [condition]) (by simp [condition])) ⟶ _) ≫ fst ≫ i₁ ≫ fst = pullback.fst :=
begin
  conv_rhs { rw ← category.comp_id pullback.fst },
  rw [← diagonal_fst f, pullback.condition_assoc, pullback.lift_fst]
end

@[simp, reassoc]
lemma pullback_diagonal_map_snd_snd_fst :
  (pullback.snd : pullback (diagonal f) (map (i₁ ≫ snd) (i₂ ≫ snd) f f (i₁ ≫ fst) (i₂ ≫ fst) i
    (by simp [condition]) (by simp [condition])) ⟶ _) ≫ snd ≫ i₂ ≫ fst = pullback.fst :=
begin
  conv_rhs { rw ← category.comp_id pullback.fst },
  rw [← diagonal_snd f, pullback.condition_assoc, pullback.lift_snd]
end

variable [has_pullback i₁ i₂]

/--
This iso witnesses the fact that
given `f : X ⟶ Y`, `i : U ⟶ Y`, and `i₁ : V₁ ⟶ X ×[Y] U`, `i₂ : V₂ ⟶ X ×[Y] U`, the diagram

V₁ ×[X ×[Y] U] V₂ ⟶ V₁ ×[U] V₂
        |                 |
        |                 |
        ↓                 ↓
        X         ⟶  X ×[Y] X

is a pullback square.
Also see `pullback_fst_map_snd_is_pullback`.
-/
def pullback_diagonal_map_iso :
  pullback (diagonal f) (map (i₁ ≫ snd) (i₂ ≫ snd) f f (i₁ ≫ fst) (i₂ ≫ fst) i
    (by simp [condition]) (by simp [condition])) ≅ pullback i₁ i₂ :=
{ hom := pullback.lift (pullback.snd ≫ pullback.fst) (pullback.snd ≫ pullback.snd)
    begin
      ext; simp only [category.assoc, pullback.condition, pullback_diagonal_map_snd_fst_fst,
        pullback_diagonal_map_snd_snd_fst],
    end,
  inv := pullback.lift (pullback.fst ≫ i₁ ≫ pullback.fst) (pullback.map _ _ _ _ (𝟙 _) (𝟙 _)
      pullback.snd (category.id_comp _).symm (category.id_comp _).symm)
    begin
      ext; simp only [diagonal_fst, diagonal_snd, category.comp_id, pullback.condition_assoc,
        category.assoc, lift_fst, lift_fst_assoc, lift_snd, lift_snd_assoc],
    end,
  hom_inv_id' := by ext; simp only [category.id_comp, category.assoc, lift_fst_assoc,
    pullback_diagonal_map_snd_fst_fst, lift_fst, lift_snd, category.comp_id],
  inv_hom_id' := by ext; simp }

@[simp, reassoc]
lemma pullback_diagonal_map_iso_hom_fst :
  (pullback_diagonal_map_iso f i i₁ i₂).hom ≫ pullback.fst = pullback.snd ≫ pullback.fst :=
by { delta pullback_diagonal_map_iso, simp }

@[simp, reassoc]
lemma pullback_diagonal_map_iso_hom_snd :
  (pullback_diagonal_map_iso f i i₁ i₂).hom ≫ pullback.snd = pullback.snd ≫ pullback.snd :=
by { delta pullback_diagonal_map_iso, simp }

@[simp, reassoc]
lemma pullback_diagonal_map_iso_inv_fst :
  (pullback_diagonal_map_iso f i i₁ i₂).inv ≫ pullback.fst = pullback.fst ≫ i₁ ≫ pullback.fst :=
by { delta pullback_diagonal_map_iso, simp }

@[simp, reassoc]
lemma pullback_diagonal_map_iso_inv_snd_fst :
  (pullback_diagonal_map_iso f i i₁ i₂).inv ≫ pullback.snd ≫ pullback.fst = pullback.fst :=
by { delta pullback_diagonal_map_iso, simp }

@[simp, reassoc]
lemma pullback_diagonal_map_iso_inv_snd_snd :
  (pullback_diagonal_map_iso f i i₁ i₂).inv ≫ pullback.snd ≫ pullback.snd = pullback.snd :=
by { delta pullback_diagonal_map_iso, simp }

lemma pullback_fst_map_snd_is_pullback :
  is_pullback
    (fst ≫ i₁ ≫ fst)
    (map i₁ i₂ (i₁ ≫ snd) (i₂ ≫ snd) _ _ _ (category.id_comp _).symm (category.id_comp _).symm)
    (diagonal f)
    (map (i₁ ≫ snd) (i₂ ≫ snd) f f (i₁ ≫ fst) (i₂ ≫ fst) i
      (by simp [condition]) (by simp [condition])) :=
is_pullback.of_iso_pullback ⟨by ext; simp [condition_assoc]⟩
  (pullback_diagonal_map_iso f i i₁ i₂).symm (pullback_diagonal_map_iso_inv_fst f i i₁ i₂)
  (by ext1; simp)

end

section

variables {S T : C} (f : X ⟶ T) (g : Y ⟶ T) (i : T ⟶ S)
variables [has_pullback i i] [has_pullback f g] [has_pullback (f ≫ i) (g ≫ i)]
variable [has_pullback (diagonal i) (pullback.map (f ≫ i) (g ≫ i) i i f g (𝟙 _)
    (category.comp_id _) (category.comp_id _))]

/--
This iso witnesses the fact that
given `f : X ⟶ T`, `g : Y ⟶ T`, and `i : T ⟶ S`, the diagram

X ×ₜ Y ⟶ X ×ₛ Y
   |         |
   |         |
   ↓         ↓
   T   ⟶ T ×ₛ T

is a pullback square.
Also see `pullback_map_diagonal_is_pullback`.
-/
def pullback_diagonal_map_id_iso :
  pullback (diagonal i) (pullback.map (f ≫ i) (g ≫ i) i i f g (𝟙 _)
    (category.comp_id _) (category.comp_id _)) ≅ pullback f g :=
begin
  refine (as_iso $ pullback.map _ _ _ _ (𝟙 _) (pullback.congr_hom _ _).hom (𝟙 _) _ _) ≪≫
    pullback_diagonal_map_iso i (𝟙 _) (f ≫ inv pullback.fst) (g ≫ inv pullback.fst) ≪≫
      (as_iso $ pullback.map _ _ _ _ (𝟙 _) (𝟙 _) pullback.fst _ _),
  { rw [← category.comp_id pullback.snd, ← condition, category.assoc, is_iso.inv_hom_id_assoc] },
  { rw [← category.comp_id pullback.snd, ← condition, category.assoc, is_iso.inv_hom_id_assoc] },
  { rw [category.comp_id, category.id_comp] },
  { ext; simp },
  { apply_instance },
  { rw [category.assoc, category.id_comp, is_iso.inv_hom_id, category.comp_id] },
  { rw [category.assoc, category.id_comp, is_iso.inv_hom_id, category.comp_id] },
  { apply_instance },
end

@[simp, reassoc]
lemma pullback_diagonal_map_id_iso_hom_fst :
  (pullback_diagonal_map_id_iso f g i).hom ≫ pullback.fst = pullback.snd ≫ pullback.fst :=
by { delta pullback_diagonal_map_id_iso, simp }

@[simp, reassoc]
lemma pullback_diagonal_map_id_iso_hom_snd :
  (pullback_diagonal_map_id_iso f g i).hom ≫ pullback.snd = pullback.snd ≫ pullback.snd :=
by { delta pullback_diagonal_map_id_iso, simp }

@[simp, reassoc]
lemma pullback_diagonal_map_id_iso_inv_fst :
  (pullback_diagonal_map_id_iso f g i).inv ≫ pullback.fst = pullback.fst ≫ f :=
begin
  rw [iso.inv_comp_eq, ← category.comp_id pullback.fst, ← diagonal_fst i, pullback.condition_assoc],
  simp,
end

@[simp, reassoc]
lemma pullback_diagonal_map_id_iso_inv_snd_fst :
  (pullback_diagonal_map_id_iso f g i).inv ≫ pullback.snd ≫ pullback.fst = pullback.fst :=
by { rw iso.inv_comp_eq, simp }

@[simp, reassoc]
lemma pullback_diagonal_map_id_iso_inv_snd_snd :
  (pullback_diagonal_map_id_iso f g i).inv ≫ pullback.snd ≫ pullback.snd = pullback.snd :=
by { rw iso.inv_comp_eq, simp }

lemma pullback.diagonal_comp (f : X ⟶ Y) (g : Y ⟶ Z) [has_pullback f f] [has_pullback g g]
  [has_pullback (f ≫ g) (f ≫ g)] :
  diagonal (f ≫ g) = diagonal f ≫ (pullback_diagonal_map_id_iso f f g).inv ≫ pullback.snd :=
by ext; simp

lemma pullback_map_diagonal_is_pullback : is_pullback (pullback.fst ≫ f)
  (pullback.map f g (f ≫ i) (g ≫ i) _ _ i (category.id_comp _).symm (category.id_comp _).symm)
  (diagonal i)
  (pullback.map (f ≫ i) (g ≫ i) i i f g (𝟙 _) (category.comp_id _) (category.comp_id _)) :=
begin
  apply is_pullback.of_iso_pullback _ (pullback_diagonal_map_id_iso f g i).symm,
  { simp },
  { ext; simp },
  { constructor, ext; simp [condition] },
end

/-- The diagonal object of `X ×[Z] Y ⟶ X` is isomorphic to `Δ_{Y/Z} ×[Z] X`. -/
def diagonal_obj_pullback_fst_iso {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  diagonal_obj (pullback.fst : pullback f g ⟶ X) ≅
    pullback (pullback.snd ≫ g : diagonal_obj g ⟶ Z) f :=
pullback_right_pullback_fst_iso _ _ _ ≪≫ pullback.congr_hom pullback.condition rfl ≪≫
  pullback_assoc _ _ _ _ ≪≫ pullback_symmetry _ _ ≪≫ pullback.congr_hom pullback.condition rfl

@[simp, reassoc] lemma diagonal_obj_pullback_fst_iso_hom_fst_fst {X Y Z : C} (f : X ⟶ Z)
  (g : Y ⟶ Z) :
  (diagonal_obj_pullback_fst_iso f g).hom ≫ pullback.fst ≫ pullback.fst =
    pullback.fst ≫ pullback.snd :=
by { delta diagonal_obj_pullback_fst_iso, simp }

@[simp, reassoc] lemma diagonal_obj_pullback_fst_iso_hom_fst_snd {X Y Z : C} (f : X ⟶ Z)
  (g : Y ⟶ Z) :
  (diagonal_obj_pullback_fst_iso f g).hom ≫ pullback.fst ≫ pullback.snd =
    pullback.snd ≫ pullback.snd :=
by { delta diagonal_obj_pullback_fst_iso, simp }

@[simp, reassoc] lemma diagonal_obj_pullback_fst_iso_hom_snd {X Y Z : C} (f : X ⟶ Z)
  (g : Y ⟶ Z) :
  (diagonal_obj_pullback_fst_iso f g).hom ≫ pullback.snd = pullback.fst ≫ pullback.fst :=
by { delta diagonal_obj_pullback_fst_iso, simp }

@[simp, reassoc] lemma diagonal_obj_pullback_fst_iso_inv_fst_fst {X Y Z : C} (f : X ⟶ Z)
  (g : Y ⟶ Z) :
  (diagonal_obj_pullback_fst_iso f g).inv ≫ pullback.fst ≫ pullback.fst =
    pullback.snd :=
by { delta diagonal_obj_pullback_fst_iso, simp }

@[simp, reassoc] lemma diagonal_obj_pullback_fst_iso_inv_fst_snd {X Y Z : C} (f : X ⟶ Z)
  (g : Y ⟶ Z) :
  (diagonal_obj_pullback_fst_iso f g).inv ≫ pullback.fst ≫ pullback.snd =
    pullback.fst ≫ pullback.fst :=
by { delta diagonal_obj_pullback_fst_iso, simp }

@[simp, reassoc] lemma diagonal_obj_pullback_fst_iso_inv_snd_fst {X Y Z : C} (f : X ⟶ Z)
  (g : Y ⟶ Z) :
  (diagonal_obj_pullback_fst_iso f g).inv ≫ pullback.snd ≫ pullback.fst = pullback.snd :=
by { delta diagonal_obj_pullback_fst_iso, simp }

@[simp, reassoc]

lemma diagonal_pullback_fst {X Y Z : C} (f : X ⟶ Z) (g : Y ⟶ Z) :
  diagonal (pullback.fst : pullback f g ⟶ _) =
    (pullback_symmetry _ _).hom ≫ ((base_change f).map
      (over.hom_mk (diagonal g) (by simp) : over.mk g ⟶ over.mk (pullback.snd ≫ g))).left ≫
    (diagonal_obj_pullback_fst_iso f g).inv :=
by ext; simp

end

/--
Given the following diagram with `S ⟶ S'` a monomorphism,

    X  ⟶ X'
      ↘      ↘
        S  ⟶ S'
      ↗      ↗
    Y  ⟶ Y'

This iso witnesses the fact that

      X ×[S] Y ⟶ (X' ×[S'] Y') ×[Y'] Y
          |                  |
          |                  |
          ↓                  ↓
(X' ×[S'] Y') ×[X'] X ⟶ X' ×[S'] Y'

is a pullback square. The diagonal map of this square is `pullback.map`.
Also see `pullback_lift_map_is_pullback`.
-/
@[simps]
def pullback_fst_fst_iso {X Y S X' Y' S' : C} (f : X ⟶ S) (g : Y ⟶ S) (f' : X' ⟶ S')
  (g' : Y' ⟶ S') (i₁ : X ⟶ X') (i₂ : Y ⟶ Y') (i₃ : S ⟶ S') (e₁ : f ≫ i₃ = i₁ ≫ f')
  (e₂ : g ≫ i₃ = i₂ ≫ g') [mono i₃] :
    pullback (pullback.fst : pullback (pullback.fst : pullback f' g' ⟶ _) i₁ ⟶ _)
      (pullback.fst : pullback (pullback.snd : pullback f' g' ⟶ _) i₂ ⟶ _) ≅ pullback f g :=
{ hom := pullback.lift (pullback.fst ≫ pullback.snd) (pullback.snd ≫ pullback.snd)
    begin
      rw [← cancel_mono i₃, category.assoc, category.assoc, category.assoc, category.assoc, e₁, e₂,
        ← pullback.condition_assoc, pullback.condition_assoc, pullback.condition,
        pullback.condition_assoc]
    end,
  inv := pullback.lift
    (pullback.lift (pullback.map _ _ _ _ _ _ _ e₁ e₂) pullback.fst (pullback.lift_fst _ _ _))
    (pullback.lift (pullback.map _ _ _ _ _ _ _ e₁ e₂) pullback.snd (pullback.lift_snd _ _ _))
    begin
      rw [pullback.lift_fst, pullback.lift_fst]
    end,
  hom_inv_id' := by ext; simp only [category.assoc, category.id_comp, lift_fst, lift_snd,
    lift_fst_assoc, lift_snd_assoc, condition, ← condition_assoc],
  inv_hom_id' := by ext; simp only [category.assoc, category.id_comp, lift_fst, lift_snd,
    lift_fst_assoc, lift_snd_assoc], }

lemma pullback_map_eq_pullback_fst_fst_iso_inv {X Y S X' Y' S' : C} (f : X ⟶ S) (g : Y ⟶ S)
  (f' : X' ⟶ S')
  (g' : Y' ⟶ S') (i₁ : X ⟶ X') (i₂ : Y ⟶ Y') (i₃ : S ⟶ S') (e₁ : f ≫ i₃ = i₁ ≫ f')
  (e₂ : g ≫ i₃ = i₂ ≫ g') [mono i₃] :
  pullback.map f g f' g' i₁ i₂ i₃ e₁ e₂ =
    (pullback_fst_fst_iso f g f' g' i₁ i₂ i₃ e₁ e₂).inv ≫ pullback.snd ≫ pullback.fst :=
begin
  ext; simp only [category.assoc, category.id_comp, lift_fst, lift_snd, lift_fst_assoc,
    lift_snd_assoc, pullback_fst_fst_iso_inv, ← pullback.condition, ← pullback.condition_assoc],
end

lemma pullback_lift_map_is_pullback {X Y S X' Y' S' : C} (f : X ⟶ S) (g : Y ⟶ S) (f' : X' ⟶ S')
  (g' : Y' ⟶ S') (i₁ : X ⟶ X') (i₂ : Y ⟶ Y') (i₃ : S ⟶ S') (e₁ : f ≫ i₃ = i₁ ≫ f')
  (e₂ : g ≫ i₃ = i₂ ≫ g') [mono i₃] :
  is_pullback
    (pullback.lift (pullback.map f g f' g' i₁ i₂ i₃ e₁ e₂) fst (lift_fst _ _ _))
    (pullback.lift (pullback.map f g f' g' i₁ i₂ i₃ e₁ e₂) snd (lift_snd _ _ _))
    pullback.fst pullback.fst :=
is_pullback.of_iso_pullback ⟨by rw [lift_fst, lift_fst]⟩
  (pullback_fst_fst_iso f g f' g' i₁ i₂ i₃ e₁ e₂).symm (by simp) (by simp)

end category_theory.limits


/-
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) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Keeley Hoek, Scott Morrison
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.tactic.core
import Mathlib.PostPort

namespace Mathlib

/-!
## #simp
A user command to run the simplifier.
-/

namespace tactic

/-- Strip all annotations of non local constants in the passed `expr`. (This is required in an
incantation later on in order to make the C++ simplifier happy.) -/
/-- `simp_arg_type.to_pexpr` retrieves the `pexpr` underlying the given `simp_arg_type`, if there is
one. -/
/-- Incantation which prepares a `pexpr` in a `simp_arg_type` for use by the simplifier after
`expr.replace_subexprs` as been called to replace some of its local variables. -/
/-- `simp_arg_type.replace_subexprs` calls `expr.replace_subexprs` on the underlying `pexpr`, if
there is one, and then prepares the result for use by the simplifier. -/
/- Turn off the messages if the result is exactly `true` with this option. -/

/--
The basic usage is `#simp e`, where `e` is an expression,
which will print the simplified form of `e`.

You can specify additional simp lemmas as usual for example using
`#simp [f, g] : e`, or `#simp with attr : e`.
(The colon is optional, but helpful for the parser.)

`#simp` understands local variables, so you can use them to
introduce parameters.
-/


/-
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