import NBG.SetTheory.Axioms.Basic

open Classical

-- subset function
theorem SubsetInductiveClassOppositeExists:
  ∃T: Class, ∀u:Class,
    (u ∈ T ↔ ∃x y z: Class, ∃_: Set x, ∃_: Set y, ∃_: Set z,
      ∃_: z ∈ x, ∃_: z ∉ y,
        u ＝ ＜x, y, z＞) := by {
  let t := (↺ (E ✕ U)) ∩ (↻ ((U₂ ＼ (RelInv E)) ✕ U));
  have t_def := IntersectionClass_def (↺ (E ✕ U)) (↻ ((U₂ ＼ (RelInv E)) ✕ U));
  have tl_def1 := LeftCycleClass_def (E ✕ U);
  have tl_def2 := ProductClass_def E U;
  have tr_def1 := RightCycleClass_def ((U₂ ＼ (RelInv E)) ✕ U);
  have tr_def2 := ProductClass_def (U₂ ＼ (RelInv E)) U;
  have tr_def3 := Diff_def U₂ (RelInv E);
  have tr_def4 := RelInv_def E;
  have u2_def := ProductClass_def U U;
  have E_def := E_def;
  exists t;
  intro u;
  rw [t_def];
  apply Iff.intro;
  {
    intro h;
    have ⟨z,x,y,set_z,set_x,set_y,hin,heq⟩ := (tl_def1 u).1 h.1;
    exists x,y,z,set_x,set_y,set_z;
    have z_in_x: z ∈ x := by {
      have ⟨e,y',e_in_E,hy',heq'⟩ := (tl_def2 ＜z,x,y＞).1 hin;
      have _ := Set.mk₁ e_in_E;
      have _ := Set.mk₁ hy';
      have ⟨z'',x'',set_z'', set_x'',z_in_x'',heq''⟩ := ((E_def e).1 e_in_E);
      have _ := OrdPair_is_Set z x;
      have zz_xx := OrdPairEq.1 (ClassEq.trans (OrdPairEq.1 heq').1 heq'');
      have := (((AxiomExtensionality x x'').1 zz_xx.2) z'').2 z_in_x'';
      exact ClassEqMenberImpMenber zz_xx.1 this;
    }
    have ⟨y',z',x',set_y',set_z',set_x',hin',heq'⟩ := (tr_def1 u).1 h.2;
    have z_not_in_y: z ∉ y := by {
      intro z_in_y;
      have ⟨e,x1,he,x1_in_U,yzx_eq_ex1⟩ := (tr_def2 ＜y',z',x'＞).1 hin';
      have he2 := (tr_def3 e).1 he;
      have ⟨y1,z1,hy1,hz1,e_eq_y1z1⟩ := (u2_def e).1 he2.1;
      have set_z1 := Set.mk₁ hz1;
      have set_y1 := Set.mk₁ hy1;
      have hn_z1y1 :=  ImpIffNotImpNot.1 (
        NotExistsImpForall (
          NotExistsImpForall (
            NotExistsImpForall (
              NotExistsImpForall (
                NotExistsImpForall (
        (IffIffNotIffNot.1 (tr_def4 e)).2 he2.2) z1) y1) set_z1) set_y1)) (IffNotNot.1 e_eq_y1z1);
      have zy_eq_z1y1 : ＜z,y＞ ＝ ＜z1,y1＞ := by {
        have heq_xyz:= OrdTripleEq.1 (ClassEq.trans (ClassEq.symm heq) heq');
        have _ := Set.mk₁ he;
        have _ := OrdPair_is_Set y' z';
        have _ := Set.mk₂ x1_in_U;
        have heq_yy_zz := OrdPairEq.1 (ClassEq.trans (OrdPairEq.1 yzx_eq_ex1).1 e_eq_y1z1);
        have z_eq_z1:= ClassEq.trans heq_xyz.2.2 heq_yy_zz.2;
        have y_eq_y1:= ClassEq.trans heq_xyz.2.1 heq_yy_zz.1;
        exact OrdPairEq.2 ⟨z_eq_z1,y_eq_y1⟩;
      };
      have h_z1y1 := (E_def ＜z1,y1＞).2 ⟨z,y,set_z,set_y,z_in_y,ClassEq.symm zy_eq_z1y1⟩;
      contradiction;
    }
    exists z_in_x,z_not_in_y;
  }
  {
    intro ⟨x,y,z,set_x,set_y,set_z,z_in_x,z_not_in_y,u_eq_xyz⟩;
    apply And.intro;
    {
      apply (tl_def1 u).2;
      have zx_in_E := (E_def ＜z,x＞).2 ⟨z,x,set_z,set_x,z_in_x,ClassEq.refl _⟩
      have hzxy := (tl_def2 ＜z,x,y＞).2 ⟨＜z,x＞,y,zx_in_E,set_y.2,ClassEq.refl _⟩;
      exists z,x,y,set_z,set_x,set_y,hzxy;
    }
    {
      apply (tr_def1 u).2;
      exists y,z,x,set_y,set_z,set_x;
      have yz_in_u2 := (u2_def ＜y,z＞).2 ⟨y,z,set_y.2,set_z.2,ClassEq.refl _⟩;
      have yz_not_in_relinv_u2: ¬ (＜y,z＞ ∈ RelInv E) := by {
        intro h;
        have ⟨z1,y1,set_z1,set_y1,z1y1_in_E,yz_eqy1z1⟩:= (tr_def4 ＜y,z＞).1 h;
        have ⟨z2,y2,set_z2,set_y2,z2_in_y2,heq_zz_yy⟩:= (E_def ＜z1,y1＞).1 z1y1_in_E;
        have yy_zz1 := OrdPairEq.1 yz_eqy1z1;
        have zz_yy2 := OrdPairEq.1 heq_zz_yy;
        have := ((AxiomExtensionality y y2).1 (ClassEq.trans yy_zz1.1 zz_yy2.2) z).2 (
          ClassEqMenberImpMenber (ClassEq.trans yy_zz1.2 zz_yy2.1) z2_in_y2);
        contradiction;
      }
      have h_yz_in := (tr_def3 ＜y,z＞).2 ⟨yz_in_u2,yz_not_in_relinv_u2⟩;
      exists (tr_def2 ＜y,z,x＞).2 ⟨＜y,z＞,x,h_yz_in,set_x.2,ClassEq.refl _⟩;
    }
  }
}

private noncomputable def T : Class :=
  choose SubsetInductiveClassOppositeExists
private noncomputable def T_def :=
  choose_spec SubsetInductiveClassOppositeExists

theorem SubsetInductiveClassExists:
  ∃S: Class, ∀z:Class,
    (z ∈ S ↔ ∃x y: Class, ∃hx: Set x, ∃hy: Set y,
      ∃_: x ⊂ y,
        z ＝ ＜x, y＞) := by {
  let s := U₂ ＼ (Dom T);
  have s_def := Diff_def U₂ (Dom T);
  have dom_def := Dom_def T;
  have t_def := T_def;
  have u2_def := ProductClass_def U U;

  exists s;
  intro u;
  rw [s_def];
  apply Iff.intro;
  {
    intro h;
    have ⟨x,y,hx,hy,hu⟩ := (u2_def u).1 h.1;
    have set_x := (Set.mk₂ hx);
    have set_y := (Set.mk₂ hy);
    have _:= (OrdPair_is_Set x y);
    have set_u: Set u := Set.mk₁ h.1;
    have : x ⊂ y := by {
      have ht := ExistsIffNotForall.1 ((IffIffNotIffNot.1 (dom_def u)).2 h.2);
      clear s_def u2_def dom_def;
      intro v hv;
      by_cases hz': (∃z: Class, z ∈ x ∧ z ∉ y);
      {
        let z := choose hz';
        have hz: z ∈ x ∧ z ∉ y := choose_spec hz';
        have set_z := Set.mk₁ hz.1
        have ht1 := ht z;
        have uz_eq_xyz: ＜u,z＞ ＝ ＜x,y,z＞ := OrdPairEq.2 ⟨hu , ClassEq.refl z⟩;
        have ez_in_T: ∃_:Set z, ＜u,z＞ ∈ T :=
          ⟨set_z, (t_def ＜u,z＞).2 ⟨x,y,z,set_x,set_y,set_z,hz.1,hz.2,uz_eq_xyz⟩⟩;
        clear t_def;
        -- contradiction;
        sorry;
      }
      {
        cases NotAndIffNotOrNot.1 ((ExistsIffNotForall.1 hz') v);
        case inr.inl hvy => {contradiction;}
        case inr.inr hvy => {exact (IffNotNot.2 hvy);}
      }
    }
    exists x,y,set_x,set_y,this;
  }
  {
    intro ⟨x,y,set_x,set_y,x_subset_y,hu⟩;
    apply And.intro;
    {exact (u2_def u).2 ⟨x,y,set_x.2,set_y.2,hu⟩;}
    {
      intro hn;
      have set_u: Set u := Set.mk₁ hn;
      have ⟨u',z,set_u',set_z,uz_in_T,huu'⟩:= (dom_def u).1 hn;
      have ⟨x',y',z',set_x',set_y',set_z',z_in_x',z_not_in_y',heq'⟩ :=
        (t_def ＜u',z＞).1 uz_in_T;
      have set_xy' := (OrdPair_is_Set x' y')
      have heq'' :=
        (@OrdPairEq u' z ＜x',y'＞ z' set_u' set_z set_xy' set_z').1 heq';
      have heq''' :=
        OrdPairEq.1 (ClassEq.trans (ClassEq.trans (ClassEq.symm hu) huu') heq''.1);
      have :=
        (((AxiomExtensionality y y').1 heq'''.2) z').1 ((x_subset_y z') ((((AxiomExtensionality x x').1 heq'''.1) z').2 z_in_x'));
      contradiction;
    }
  }
}

noncomputable def S : Class :=
  choose SubsetInductiveClassExists
noncomputable def S_def:
  ∀z:Class,
    (z ∈ S ↔ ∃x y: Class, ∃_: Set x, ∃_: Set y,
      ∃_: x ⊂ y,
        z ＝ ＜x, y＞) :=
  choose_spec SubsetInductiveClassExists

theorem SubsetPairAreInS {x y: Class} [hx: Set x] [hy: Set y]:
  x ⊂ y → ＜x, y＞ ∈ S :=
  fun h => (S_def ＜x,y＞).2 ⟨x, y, hx, hy, h, ClassEq.refl _⟩

-- identity function
theorem IdentityClassExists:
  ∃Id: Class, ∀z:Class,
    (z ∈ Id ↔ ∃x: Class, ∃_: Set x, z ＝ ＜x, x＞) := by {
  let id := S ∩ (RelInv S);
  have id_def := IntersectionClass_def S (RelInv S);
  have relinv_def := RelInv_def S;
  have s_def := S_def;

  exists id;
  intro z;
  rw [id_def, relinv_def, s_def];
  apply Iff.intro;
  {
    intro ⟨⟨x,y,set_x,set_y,hxy,hz1⟩,⟨x',y',set_x',set_y',hxy',hz2⟩⟩;
    have ⟨x'',y'',set_x'',set_y'',hxy'',hz3⟩ := (s_def ＜x',y'＞).1 hxy';
    have heq := OrdPairEq.1 (ClassEq.trans (ClassEq.symm hz1) hz2);
    have heq' := OrdPairEq.1 hz3;
    have hyx : y ⊂ x := by {
      intro z;
      have hx1 := ((AxiomExtensionality x y').1 heq.1 z).2;
      have hx2:= ((AxiomExtensionality y' y'').1 heq'.2 z).2;
      have hy1 := ((AxiomExtensionality y x').1 heq.2 z).1;
      have hy2:= ((AxiomExtensionality x' x'').1 heq'.1 z).1;
      have := (hxy'' z);
      exact fun h => hx1 (hx2 ((hxy'' z) (hy2 (hy1 h))));
    };
    clear id_def relinv_def s_def id hxy' hxy'' hz2 hz3 heq heq';
    exists x, set_x;
    have := ClassSubsetSymmImplyEq hyx hxy;
    have := (@OrdPairEq x y x x set_x set_y set_x set_x).2 ⟨ClassEq.refl _, this⟩;
    exact ClassEq.trans hz1 this;
  }
  {
    intro ⟨x,hx,hz⟩;
    have hxxS := (s_def ＜x,x＞).2 ⟨x,x,hx,hx,ClassSubset.refl _,ClassEq.refl _⟩;
    exact ⟨⟨x,x,hx,hx,ClassSubset.refl _, hz⟩,⟨x,x,hx,hx,hxxS,hz⟩⟩;
  }
}

noncomputable def IdClass : Class :=
  choose IdentityClassExists
noncomputable def IdClass_def:
  ∀z:Class,
    (z ∈ IdClass ↔ ∃x: Class, ∃_: Set x, z ＝ ＜x, x＞) :=
  choose_spec IdentityClassExists

theorem AllIdSetIsInId (x: Class) [hx: Set x]:
  ＜x, x＞ ∈ IdClass :=
(IdClass_def ＜x, x＞).2 ⟨x, ⟨hx, ClassEq.refl _⟩⟩

theorem IdClassIsRelation:
  isRelation IdClass := sorry


-- Copyright (C) 2020 by @ljt12138

import tactic pal.basics

namespace pal_logic

/-----------------------------------------------------------------------
 -                    Reduction of Dynamic Modality                    -
 -----------------------------------------------------------------------

   Now we have define the syntax and semantics for PAL⬝S5, in which the
public announcement [!φ] is called dynamic modaltiy. Here we will show
that a PAL⬝S5 sentence can be translate to an equivalent static S5
sentence. The idea is to use the following axioms recursively.

                 [!φ]p          ≡         φ → p
                 [!φ]⊥          ≡         φ → ⊥
                 [!φ](ψ→γ)      ≡         [!φ]ψ → [!φ]γ
                 [!φ]□ᵢψ        ≡         φ → □ᵢ[!φ]ψ

  Our plan is to show the soundness of the axioms, prove some lemma about
semantically equivalent, and then prove our main theorem.
-/

/-     ---- 1. Semantically Equivalent and Recursion Axioms ----      -/

inductive static {α agent : Type} : sentence α agent → Prop
| atom (p : _)                : static ⟦p⟧
| perp                        : static ⊥
| imply (φ ψ : _)             : static φ → static ψ → static (φ ↣ ψ)
| box (a : _) (φ : _)         : static φ → static □(a : φ)

@[simp]
def sem_equiv {α agent : Type} (φ φ' : sentence α agent) :=
  ∀ W : Type, ∀ M (s : W), (M, s) ⊨ φ ↔ (M, s) ⊨ φ'

infix ≡ := sem_equiv

@[simp, refl]
lemma sem_equiv_refl {α agent : Type} (φ : sentence α agent) :
  φ ≡ φ :=
begin
  unfold sem_equiv, intros, trivial
end

@[symm]
lemma sem_equiv_symm {α agent : Type} (φ ψ : sentence α agent) :
  φ ≡ ψ → ψ ≡ φ :=
begin
  unfold sem_equiv, intros, symmetry, apply a
end

@[trans]
lemma sem_equiv_trans {α agent : Type} (φ ψ γ : sentence α agent) :
  φ ≡ ψ → ψ ≡ γ → φ ≡ γ :=
begin
  unfold sem_equiv, intros a a' W M s,
  have a₁ := a W M s,
  have a₂ := a' W M s,
  tauto
end

lemma recursion_atom {α agent : Type} : ∀ (p : α) (φ : sentence α agent),
  ([!φ]⟦p⟧) ≡ φ ↣ ⟦p⟧ :=
begin
  intros, unfold sem_equiv, intros, split,
  { intros a, simp at *, exact a },
  { intros a, simp at *, exact a }
end

lemma recursion_perp {α agent : Type} : ∀ (φ : sentence α agent),
  ([!φ]⊥) ≡ φ ↣ ⊥ :=
begin
  intros, unfold sem_equiv, intros, split,
  { intros a, simp at *, exact a},
  { intros a, simp at *, exact a}
end

lemma recursion_imply {α agent : Type} : ∀ (φ ψ γ : sentence α agent),
  ([!φ](ψ↣γ)) ≡ ([!φ]ψ) ↣ ([!φ]γ) :=
begin
  intros, unfold sem_equiv evaluate, intros, split,
  {
    intros a a₁ a₂,
    exact a a₂ (a₁ a₂)
  },
  {
    intros a a₁ a₂,
    exact a (λ x, a₂) a₁
  }
end

lemma recursion_box {α agent : Type} : ∀ (i : agent) (φ ψ : sentence α agent),
  ([!φ]□(i : ψ)) ≡ φ ↣ □(i : [!φ]ψ) :=
begin
  intros, unfold sem_equiv, intros, split,
  {
    intros a, unfold evaluate at *, intros a₁ t a₂ a₃,
    apply a, exact a₁, simp,
    right, tauto
  },
  {
    intros a, unfold evaluate at *, intros a₁ t a₂,
    apply a, { exact a₁ },
    {
      simp at a₂, cases a₂,
      { rewrite a₂, cases M.equiv i, apply left },
      { exact a₂.right.right }
    },
    {
      simp at a₂, cases a₂,
      { rewrite ← a₂, exact a₁ },
      { exact a₂.right.left }
    }
  }
end

lemma equiv_imply {α agent : Type} {φ ψ φ' ψ' : sentence α agent} :
  φ ≡ φ' → ψ ≡ ψ' → φ ↣ ψ ≡ φ' ↣ ψ' :=
begin
  intros a₁ a₂, unfold sem_equiv, intros, split,
  { simp, intros a₃ a₄, apply (a₂ _ _ _).mp, apply a₃, apply (a₁ _ _ _).mpr, exact a₄ },
  { simp, intros a₃ a₄, apply (a₂ _ _ _).mpr, apply a₃, apply (a₁ _ _ _).mp, exact a₄ }
end

lemma equiv_box {α agent : Type} {i : agent} {φ ψ : sentence α agent} :
  φ ≡ ψ → □(i : φ) ≡ □(i : ψ) :=
begin
  intros, unfold sem_equiv, intros, split,
  { intros, unfold evaluate at *, intros, apply (a W M t).mp, exact a_1 t a_2 },
  { intros, unfold evaluate at *, intros, apply (a W M t).mpr, exact a_1 t a_2}
end

lemma equiv_restriction {α agent W : Type} (M : worlds α agent W) (P P' : W → Prop) :
  (∀ t, P t ↔ P' t) → (restriction M P = restriction M P') :=
begin
  intros a, simp,
  have a' : ∀ t, P t = P' t, intros, apply propext, apply a,
  repeat {apply funext, intros},
  simp, rewrite a', rewrite a'
end

lemma equiv_announce {α agent : Type} {φ ψ φ' ψ' : sentence α agent} :
  φ ≡ φ' → ψ ≡ ψ' → ([!φ]ψ) ≡ [!φ']ψ' :=
begin
  intros a₁ a₂, unfold sem_equiv, intros, split,
  {
    intros, unfold evaluate at *, intros a', apply (a₂ _ _ _).mp,
    rewrite equiv_restriction,
    { apply a, apply (a₁ _ _ _).mpr, exact a' },
    { intros, symmetry, exact a₁ _ _ _ }
  },
  {
    intros, unfold evaluate at *, intros a', apply (a₂ _ _ _).mpr,
    rewrite equiv_restriction,
    { apply a, apply (a₁ _ _ _).mp, exact a' },
    { intros, exact a₁ _ _ _ }
  }
end

/-                   ---- 2. Main Theorem ----                   -/

lemma reduction_lemma {α agent : Type} (φ ψ : sentence α agent) :
  static φ → static ψ → ∃ γ, ([!φ]ψ) ≡ γ ∧ static γ :=
begin
  intros a₁ a₂, induction a₂ with p ψ₁ ψ₂ a₂' a₂'' ih₁ ih₂ i ψ a_ψ ih₁,
  {
    existsi φ↣⟦p⟧, split, apply recursion_atom,
    apply static.imply, assumption, apply static.atom
  },
  {
    existsi φ↣⊥, split, apply recursion_perp,
    apply static.imply, assumption, apply static.perp
  },
  {
    cases ih₁ with γ₁ ih₁, cases ih₂ with γ₂ ih₂,
    existsi γ₁ ↣ γ₂, split,
    {
      have h₁ := recursion_imply φ ψ₁ ψ₂,
      have h₂ : ([!φ]ψ₁) ↣ ([!φ]ψ₂) ≡ γ₁ ↣ γ₂,
        { apply equiv_imply, exact ih₁.left, exact ih₂.left },
      transitivity, assumption, assumption
    },
    { apply static.imply, exact ih₁.right, exact ih₂.right }
  },
  {
    cases ih₁ with γ ih₁, cases ih₁ with ih₁ ih₂,
    existsi φ ↣ □(i : γ), split,
    {
      have h₁ := recursion_box i φ ψ,
      have h₂ : φ↣□(i:[!φ]ψ) ≡ φ↣□(i:γ),
        { apply equiv_imply, simp, apply equiv_box, exact ih₁ },
      transitivity, assumption, assumption
    },
    { apply static.imply, exact a₁, apply static.box, exact ih₂ }
  }
end

theorem reduction_dynamics {α agent : Type} (φ : sentence α agent) :
  ∃ ψ, φ ≡ ψ ∧ static ψ :=
begin
  induction φ with p φ₁ φ₂ ih₁ ih₂ i φ ih φ₁ φ₂ ih₁ ih₂,
  { existsi ⟦p⟧, split, simp, apply static.atom },
  { existsi (⊥ : sentence α agent), split, simp, apply static.perp },
  {
    cases ih₁ with ψ₁ ih₁, cases ih₂ with ψ₂ ih₂, existsi ψ₁ ↣ ψ₂, split,
    { exact equiv_imply ih₁.left ih₂.left },
    { apply static.imply, tauto, tauto }
  },
  {
    cases ih with φ' ih, existsi □(i : φ'), split,
    { exact equiv_box ih.left },
    { apply static.box, exact ih.right }
  },
  {
    cases ih₁ with ψ₁ ih₁, cases ih₂ with ψ₂ ih₂,
    cases reduction_lemma ψ₁ ψ₂ ih₁.right ih₂.right with γ h,
    existsi γ, split,
    {
      have a := equiv_announce ih₁.left ih₂.left,
      transitivity, exact a, exact h.left
    },
    { exact h.right }
  }
end

end pal_logic


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.equiv.basic
import Mathlib.algebra.group.defs
import Mathlib.algebra.group.hom
import Mathlib.logic.embedding
import Mathlib.PostPort

universes u v l u_1 u_2 u_3 w

namespace Mathlib

/-!
# Definitions of group actions

This file defines a hierarchy of group action type-classes:

* `has_scalar α β`
* `mul_action α β`
* `distrib_mul_action α β`

The hierarchy is extended further by `semimodule`, defined elsewhere.

Also provided are type-classes regarding the interaction of different group actions,

* `smul_comm_class M N α`
* `is_scalar_tower M N α`

## Notation

`a • b` is used as notation for `smul a b`.

## Implementation details

This file should avoid depending on other parts of `group_theory`, to avoid import cycles.
More sophisticated lemmas belong in `group_theory.group_action`.
-/

/-- Typeclass for types with a scalar multiplication operation, denoted `•` (`\bu`) -/
class has_scalar (α : Type u) (γ : Type v)
where
  smul : α → γ → γ

infixr:73 " • " => Mathlib.has_scalar.smul

/-- Typeclass for multiplicative actions by monoids. This generalizes group actions. -/
class mul_action (α : Type u) (β : Type v) [monoid α]
extends has_scalar α β
where
  one_smul : ∀ (b : β), 1 • b = b
  mul_smul : ∀ (x y : α) (b : β), (x * y) • b = x • y • b

/-- A typeclass mixin saying that two actions on the same space commute. -/
class smul_comm_class (M : Type u_1) (N : Type u_2) (α : Type u_3) [has_scalar M α] [has_scalar N α]
where
  smul_comm : ∀ (m : M) (n : N) (a : α), m • n • a = n • m • a

/-- Commutativity of actions is a symmetric relation. This lemma can't be an instance because this
would cause a loop in the instance search graph. -/
theorem smul_comm_class.symm (M : Type u_1) (N : Type u_2) (α : Type u_3) [has_scalar M α] [has_scalar N α] [smul_comm_class M N α] : smul_comm_class N M α :=
  smul_comm_class.mk fun (a' : N) (a : M) (b : α) => Eq.symm (smul_comm a a' b)

protected instance smul_comm_class_self (M : Type u_1) (α : Type u_2) [comm_monoid M] [mul_action M α] : smul_comm_class M M α :=
  smul_comm_class.mk
    fun (a a' : M) (b : α) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (a • a' • b = a' • a • b)) (Eq.symm (mul_smul a a' b))))
        (eq.mpr (id (Eq._oldrec (Eq.refl ((a * a') • b = a' • a • b)) (mul_comm a a')))
          (eq.mpr (id (Eq._oldrec (Eq.refl ((a' * a) • b = a' • a • b)) (mul_smul a' a b))) (Eq.refl (a' • a • b))))

/-- An instance of `is_scalar_tower M N α` states that the multiplicative
action of `M` on `α` is determined by the multiplicative actions of `M` on `N`
and `N` on `α`. -/
class is_scalar_tower (M : Type u_1) (N : Type u_2) (α : Type u_3) [has_scalar M N] [has_scalar N α] [has_scalar M α]
where
  smul_assoc : ∀ (x : M) (y : N) (z : α), (x • y) • z = x • y • z

@[simp] theorem smul_assoc {α : Type u} {M : Type u_1} {N : Type u_2} [has_scalar M N] [has_scalar N α] [has_scalar M α] [is_scalar_tower M N α] (x : M) (y : N) (z : α) : (x • y) • z = x • y • z :=
  is_scalar_tower.smul_assoc x y z

theorem smul_smul {α : Type u} {β : Type v} [monoid α] [mul_action α β] (a₁ : α) (a₂ : α) (b : β) : a₁ • a₂ • b = (a₁ * a₂) • b :=
  Eq.symm (mul_smul a₁ a₂ b)

@[simp] theorem one_smul (α : Type u) {β : Type v} [monoid α] [mul_action α β] (b : β) : 1 • b = b :=
  mul_action.one_smul b

/-- Pullback a multiplicative action along an injective map respecting `•`. -/
protected def function.injective.mul_action {α : Type u} {β : Type v} {γ : Type w} [monoid α] [mul_action α β] [has_scalar α γ] (f : γ → β) (hf : function.injective f) (smul : ∀ (c : α) (x : γ), f (c • x) = c • f x) : mul_action α γ :=
  mul_action.mk sorry sorry

/-- Pushforward a multiplicative action along a surjective map respecting `•`. -/
protected def function.surjective.mul_action {α : Type u} {β : Type v} {γ : Type w} [monoid α] [mul_action α β] [has_scalar α γ] (f : β → γ) (hf : function.surjective f) (smul : ∀ (c : α) (x : β), f (c • x) = c • f x) : mul_action α γ :=
  mul_action.mk sorry sorry

theorem ite_smul {α : Type u} {β : Type v} [monoid α] [mul_action α β] (p : Prop) [Decidable p] (a₁ : α) (a₂ : α) (b : β) : ite p a₁ a₂ • b = ite p (a₁ • b) (a₂ • b) := sorry

theorem smul_ite {α : Type u} {β : Type v} [monoid α] [mul_action α β] (p : Prop) [Decidable p] (a : α) (b₁ : β) (b₂ : β) : a • ite p b₁ b₂ = ite p (a • b₁) (a • b₂) := sorry

namespace mul_action

/-- The regular action of a monoid on itself by left multiplication. -/
def regular (α : Type u) [monoid α] : mul_action α α :=
  mk sorry sorry

protected instance is_scalar_tower.left (α : Type u) {β : Type v} [monoid α] [mul_action α β] : is_scalar_tower α α β :=
  is_scalar_tower.mk fun (x y : α) (z : β) => mul_smul x y z

/-- Embedding induced by action. -/
def to_fun (α : Type u) (β : Type v) [monoid α] [mul_action α β] : β ↪ α → β :=
  function.embedding.mk (fun (y : β) (x : α) => x • y) sorry

@[simp] theorem to_fun_apply {α : Type u} {β : Type v} [monoid α] [mul_action α β] (x : α) (y : β) : coe_fn (to_fun α β) y x = x • y :=
  rfl

/-- An action of `α` on `β` and a monoid homomorphism `γ → α` induce an action of `γ` on `β`. -/
def comp_hom {α : Type u} (β : Type v) {γ : Type w} [monoid α] [mul_action α β] [monoid γ] (g : γ →* α) : mul_action γ β :=
  mk sorry sorry

end mul_action

@[simp] theorem smul_one_smul {α : Type u} {M : Type u_1} (N : Type u_2) [monoid N] [has_scalar M N] [mul_action N α] [has_scalar M α] [is_scalar_tower M N α] (x : M) (y : α) : (x • 1) • y = x • y :=
  eq.mpr (id (Eq._oldrec (Eq.refl ((x • 1) • y = x • y)) (smul_assoc x 1 y)))
    (eq.mpr (id (Eq._oldrec (Eq.refl (x • 1 • y = x • y)) (one_smul N y))) (Eq.refl (x • y)))

/-- Typeclass for multiplicative actions on additive structures. This generalizes group modules. -/
class distrib_mul_action (α : Type u) (β : Type v) [monoid α] [add_monoid β]
extends mul_action α β
where
  smul_add : ∀ (r : α) (x y : β), r • (x + y) = r • x + r • y
  smul_zero : ∀ (r : α), r • 0 = 0

theorem smul_add {α : Type u} {β : Type v} [monoid α] [add_monoid β] [distrib_mul_action α β] (a : α) (b₁ : β) (b₂ : β) : a • (b₁ + b₂) = a • b₁ + a • b₂ :=
  distrib_mul_action.smul_add a b₁ b₂

@[simp] theorem smul_zero {α : Type u} {β : Type v} [monoid α] [add_monoid β] [distrib_mul_action α β] (a : α) : a • 0 = 0 :=
  distrib_mul_action.smul_zero a

/-- Pullback a distributive multiplicative action along an injective additive monoid
homomorphism. -/
protected def function.injective.distrib_mul_action {α : Type u} {β : Type v} {γ : Type w} [monoid α] [add_monoid β] [distrib_mul_action α β] [add_monoid γ] [has_scalar α γ] (f : γ →+ β) (hf : function.injective ⇑f) (smul : ∀ (c : α) (x : γ), coe_fn f (c • x) = c • coe_fn f x) : distrib_mul_action α γ :=
  distrib_mul_action.mk sorry sorry

/-- Pushforward a distributive multiplicative action along a surjective additive monoid
homomorphism.-/
protected def function.surjective.distrib_mul_action {α : Type u} {β : Type v} {γ : Type w} [monoid α] [add_monoid β] [distrib_mul_action α β] [add_monoid γ] [has_scalar α γ] (f : β →+ γ) (hf : function.surjective ⇑f) (smul : ∀ (c : α) (x : β), coe_fn f (c • x) = c • coe_fn f x) : distrib_mul_action α γ :=
  distrib_mul_action.mk sorry sorry

/-- Scalar multiplication by `r` as an `add_monoid_hom`. -/
def const_smul_hom {α : Type u} (β : Type v) [monoid α] [add_monoid β] [distrib_mul_action α β] (r : α) : β →+ β :=
  add_monoid_hom.mk (has_scalar.smul r) (smul_zero r) (smul_add r)

@[simp] theorem const_smul_hom_apply {α : Type u} {β : Type v} [monoid α] [add_monoid β] [distrib_mul_action α β] (r : α) (x : β) : coe_fn (const_smul_hom β r) x = r • x :=
  rfl

@[simp] theorem smul_neg {α : Type u} {β : Type v} [monoid α] [add_group β] [distrib_mul_action α β] (r : α) (x : β) : r • -x = -(r • x) := sorry

theorem smul_sub {α : Type u} {β : Type v} [monoid α] [add_group β] [distrib_mul_action α β] (r : α) (x : β) (y : β) : r • (x - y) = r • x - r • y := sorry


/-
Copyright (c) 2020 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser

! This file was ported from Lean 3 source module linear_algebra.multilinear.tensor_product
! leanprover-community/mathlib commit ce11c3c2a285bbe6937e26d9792fda4e51f3fe1a
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.Multilinear.Basic
import Mathbin.LinearAlgebra.TensorProduct

/-!
# Constructions relating multilinear maps and tensor products.
-/

namespace MultilinearMap

section DomCoprod

open TensorProduct

variable {R ι₁ ι₂ ι₃ ι₄ : Type _}

variable [CommSemiring R]

variable {N₁ : Type _} [AddCommMonoid N₁] [Module R N₁]

variable {N₂ : Type _} [AddCommMonoid N₂] [Module R N₂]

variable {N : Type _} [AddCommMonoid N] [Module R N]

/-- Given two multilinear maps `(ι₁ → N) → N₁` and `(ι₂ → N) → N₂`, this produces the map
`(ι₁ ⊕ ι₂ → N) → N₁ ⊗ N₂` by taking the coproduct of the domain and the tensor product
of the codomain.

This can be thought of as combining `equiv.sum_arrow_equiv_prod_arrow.symm` with
`tensor_product.map`, noting that the two operations can't be separated as the intermediate result
is not a `multilinear_map`.

While this can be generalized to work for dependent `Π i : ι₁, N'₁ i` instead of `ι₁ → N`, doing so
introduces `sum.elim N'₁ N'₂` types in the result which are difficult to work with and not defeq
to the simple case defined here. See [this zulip thread](
https://leanprover.zulipchat.com/#narrow/stream/217875-Is-there.20code.20for.20X.3F/topic/Instances.20on.20.60sum.2Eelim.20A.20B.20i.60/near/218484619).
-/
@[simps apply]
def domCoprod (a : MultilinearMap R (fun _ : ι₁ => N) N₁)
    (b : MultilinearMap R (fun _ : ι₂ => N) N₂) :
    MultilinearMap R (fun _ : Sum ι₁ ι₂ => N) (N₁ ⊗[R] N₂)
    where
  toFun v := (a fun i => v (Sum.inl i)) ⊗ₜ b fun i => v (Sum.inr i)
  map_add' _ v i p q := by
    skip
    letI := (@Sum.inl_injective ι₁ ι₂).DecidableEq
    letI := (@Sum.inr_injective ι₁ ι₂).DecidableEq
    cases i <;> simp [TensorProduct.add_tmul, TensorProduct.tmul_add]
  map_smul' _ v i c p := by
    skip
    letI := (@Sum.inl_injective ι₁ ι₂).DecidableEq
    letI := (@Sum.inr_injective ι₁ ι₂).DecidableEq
    cases i <;> simp [TensorProduct.smul_tmul', TensorProduct.tmul_smul]
#align multilinear_map.dom_coprod MultilinearMap.domCoprod

/-- A more bundled version of `multilinear_map.dom_coprod` that maps
`((ι₁ → N) → N₁) ⊗ ((ι₂ → N) → N₂)` to `(ι₁ ⊕ ι₂ → N) → N₁ ⊗ N₂`. -/
def domCoprod' :
    MultilinearMap R (fun _ : ι₁ => N) N₁ ⊗[R] MultilinearMap R (fun _ : ι₂ => N) N₂ →ₗ[R]
      MultilinearMap R (fun _ : Sum ι₁ ι₂ => N) (N₁ ⊗[R] N₂) :=
  TensorProduct.lift <|
    LinearMap.mk₂ R domCoprod
      (fun m₁ m₂ n => by
        ext
        simp only [dom_coprod_apply, TensorProduct.add_tmul, add_apply])
      (fun c m n => by
        ext
        simp only [dom_coprod_apply, TensorProduct.smul_tmul', smul_apply])
      (fun m n₁ n₂ => by
        ext
        simp only [dom_coprod_apply, TensorProduct.tmul_add, add_apply])
      fun c m n => by
      ext
      simp only [dom_coprod_apply, TensorProduct.tmul_smul, smul_apply]
#align multilinear_map.dom_coprod' MultilinearMap.domCoprod'

@[simp]
theorem domCoprod'_apply (a : MultilinearMap R (fun _ : ι₁ => N) N₁)
    (b : MultilinearMap R (fun _ : ι₂ => N) N₂) : domCoprod' (a ⊗ₜ[R] b) = domCoprod a b :=
  rfl
#align multilinear_map.dom_coprod'_apply MultilinearMap.domCoprod'_apply

/-- When passed an `equiv.sum_congr`, `multilinear_map.dom_dom_congr` distributes over
`multilinear_map.dom_coprod`. -/
theorem domCoprod_domDomCongr_sumCongr (a : MultilinearMap R (fun _ : ι₁ => N) N₁)
    (b : MultilinearMap R (fun _ : ι₂ => N) N₂) (σa : ι₁ ≃ ι₃) (σb : ι₂ ≃ ι₄) :
    (a.domCoprod b).domDomCongr (σa.sumCongr σb) =
      (a.domDomCongr σa).domCoprod (b.domDomCongr σb) :=
  rfl
#align multilinear_map.dom_coprod_dom_dom_congr_sum_congr MultilinearMap.domCoprod_domDomCongr_sumCongr

end DomCoprod

end MultilinearMap


import data.list

universes U₁ U₂

def nonempty_list (γ : Type U₁) := {l : list γ // l ≠ []}

namespace nonempty_list
  variable {γ : Type U₁}

  @[simp]
  def last (l : nonempty_list γ) := list.last l.val l.property

  @[simp]
  def head : nonempty_list γ → γ
  | ⟨[]      , h ⟩ := absurd rfl h
  | ⟨ x :: t , _ ⟩ := x

end nonempty_list

namespace list
  variables {α : Type U₁} {β : Type U₂}

  -- Much like head, but doesn't require α to be inhabited
  @[simp] def head'': Π  (L : list α), L ≠ [] → α
  | []        h := absurd rfl h
  | (x :: xs) h := x

  variables {R : α → α → Prop} {x y : α} {L L₁ L₂ : list α}

  @[simp]
  lemma chain'_desc_left : chain' R (x :: L) → chain' R L := by cases L; simp[chain']

  def chain'_apply_between (f : Π(a b : α), (R a b) → β) : Π (L : list α), list.chain' R L → list β
  | [] h := []
  | [x] h := []
  | (x :: y :: xs) h := (f x y (rel_of_chain_cons h)) ::
                       (chain'_apply_between (y :: xs) (chain'_desc_left h) )

  @[simp]
  lemma chain'_of_two : chain' R [x, y] ↔ R x y := by dunfold chain'; exact chain_singleton

  lemma chain'_of_first_two : chain' R (x :: y :: L) → R x y := by dunfold chain'; simp; exact λ a b, a

  lemma chain'_append : Π (L₁ : list α) (h : L₁ ≠ []) (x : α), (R (L₁.last h) x) → (chain' R L₁) → chain' R (L₁ ++ [x])
  | [] h           _ _  _  := absurd rfl h
  | [a] h         x h₁ h₂ := (by simp; assumption)
  | (a :: b :: l) h  x h₁ h₂ := iff.elim_right (@chain'_split α R b [a] (l ++ [x]))
      ⟨ iff.elim_right chain'_of_two (chain'_of_first_two h₂),
        chain'_append  (b :: l) _ x h₁ (chain'_desc_left h₂) ⟩

  lemma chain'_concat' : Π (L₁ L₂ : nonempty_list α), (R L₁.last L₂.head) → (chain' R L₁.val) → (chain' R L₂.val) → chain' R (L₁.val ++ L₂.val)
  | ⟨ [] , h₁ ⟩ _ _ _ _ := absurd rfl h₁
  | _ ⟨ [] , h₁ ⟩ _ _ _ := absurd rfl h₁
  | ⟨ x₁ :: l₁ , h₁ ⟩ ⟨ x₂ :: l₂ , h₂ ⟩ h₃ s₁ s₂ :=
    begin
      intros;
      apply iff.elim_right chain'_split;
      simp;
      apply and.intro,
      have k : nonempty_list.head ⟨x₂ :: l₂, h₂⟩ = x₂ := rfl,
      cases l₁,
      simp,
      have j : nonempty_list.last ⟨[x₁], h₁⟩ = x₁ := rfl,
      have l : chain' R [x₁ , x₂] := iff.elim_right (@chain'_of_two α R x₁ x₂) h₃,
      exact (iff.elim_left chain'_of_two) l,
      simp,
      apply @chain'_append α R (x₁ :: l₁_hd :: l₁_tl),
      apply h₃,
      assumption,
      assumption
    end

  def apply_between (f : α → α → β) : list α → list β
  | [] := []
  | [x] := []
  | (x :: y :: xs) := (f x y) :: apply_between (y :: xs)

  @[simp]
  lemma tail_of_append  (x y : α) (l : list α) : tail (l ++ [y,x]) = tail (l ++ [y]) ++ [x] :=
  by cases l; repeat {simp}

  lemma rev_init_rev_tail : Π (l : list α), l.init.reverse = l.reverse.tail
  | []            := rfl
  | [x]           := rfl
  | (x :: y :: l) := (by simp[init, rev_init_rev_tail]; finish)

  lemma rev_init_rev_tail_2 : Π (l : list α), l.reverse.init = l.tail.reverse :=
  begin
    intros,
    set l2 := l.reverse with l2h,
    calc l.reverse.init = l2.reverse.reverse.init : by rw [l2h,reverse_reverse]
                   ...  = l2.reverse.reverse.init.reverse.reverse : by simp
                   ...  = l2.reverse.reverse.reverse.tail.reverse : by rw rev_init_rev_tail
                   ...  = l.reverse.reverse.tail.reverse : by rw [l2h,reverse_reverse]
                   ...  = l.tail.reverse : by rw reverse_reverse
  end

  lemma rev_init_rev_tail' : Π (l : list α), l.init = l.reverse.tail.reverse := λ l,
  calc l.init = l.init.reverse.reverse : by rw reverse_reverse
          ... = l.reverse.tail.reverse : by rw rev_init_rev_tail

  @[simp] def rev_rel : (α → α → Prop) → (α → α → Prop) := λ S x y, S y x

  lemma chain_rev : Π (L : list α) , chain' R L → chain' (rev_rel R) L.reverse
  | [] h := by simp
  | [x] h := by simp; exact chain.nil
  | (x :: y :: l) h := begin
    rw reverse_cons,
    rw reverse_cons,
    simp,
    apply chain'_split.2,
    rw (reverse_cons y l).symm,
    have h2 : chain' R (y :: l) := (chain_cons.1 h).elim_right,
    split,
    exact chain_rev _ h2,
    apply chain'_of_two.2,
    exact (chain_cons.1 h).elim_left
  end

  lemma chain'_init' : Π (L₁ : list α), chain' R L₁.reverse  → chain' R L₁.reverse.init :=
  begin
    intros,
    rw rev_init_rev_tail',
    apply chain_rev,
    simp,
    cases L₁,
      simp,
    simp,
    have h : chain' (rev_rel R) (L₁_hd :: L₁_tl) := begin
      intros,
      rw (reverse_reverse (L₁_hd :: L₁_tl)).symm,
      exact chain_rev (L₁_hd :: L₁_tl).reverse a,
    end,
    exact chain'_desc_left h
  end

  lemma chain'_init : Π (L₁ : list α), chain' R L₁  → chain' R L₁.init :=
  begin
    intros,
    set L₂ := L₁.reverse with Lh,
    rw (reverse_reverse (L₁)).symm,
    rw Lh.symm,
    apply chain'_init',
    rw Lh,
    rw reverse_reverse,
    assumption
  end

  lemma chain'_trans_last : Π (L : list α) [reflexive R] [transitive R] [chain' R L] (h : L ≠ []), ∀ (x ∈ L), R x (L.last h)
  | [] _ _ _ h := absurd rfl h
  | [x] h _ _ _ := begin
    intros,
    simp,
    rw list.eq_of_mem_singleton H,
    apply h x
  end
  | (x :: y :: l) h₁ h₂ h₃ _ := begin
    intros,
    cases H,
    have I : R x y := chain'_of_first_two h₃,
    have J : R y (last (y :: l) (by simp)) := @chain'_trans_last (y :: l) h₁ h₂ (chain'_desc_left h₃) (by simp) y (by simp),
    have K : R x (last (y :: l) (by simp)) := h₂ I J,
    rw last_cons,
    rw H,
    exact K,
    rw last_cons,
    exact @chain'_trans_last (y :: l) h₁ h₂ (chain'_desc_left h₃) (by simp) x_1 H
  end

  def map₃ : Π (L : list α) (f : Π (a : α), a ∈ L → β), list β
  | [] _ := []
  | (x :: y) f := f x (mem_cons_self x y) :: map₃ y (λ z h, f z (mem_cons_of_mem _ h))

  variables (p : α → Prop) [preorder α]

  def map₄ : Π (L : list α) (f : Π (a : α), a ∈ L → p a), list {x : α // p x}
  | [] _ := []
  | (x :: y) f := ⟨x, f x (mem_cons_self x y)⟩ :: map₄ y (λ z h, f z (mem_cons_of_mem _ h))

  theorem chain'_map₄ : Π (L : list α) (f : Π (a : α), a ∈ L → p a),
    chain' (≤) L → chain' (≤) (map₄ p L (λ a h, (f a h)))
  | [] _ c := (by dunfold map₄; exact (chain'_map (λ (a : {x // p x}), a.val)).mp c)
  | [x] _ c := begin
    intros,
    exact (chain'_map (λ (a : {x // p x}), a.val)).mp c
  end
  | (x :: y :: l) f c := begin
    intros,
    apply chain.cons,
      apply chain'_of_first_two c,
    exact chain'_map₄ (y :: l) (λ z h, f z (mem_cons_of_mem _ h)) (chain'_desc_left c)
  end

end list


import tactic
import .topology
import .gluing
import .fiber_product

section fiber_bundle

/-

Bundles.

Goal: Show that trivializations pull back.

We distinguish between:
  1. *trivial bundles* : these are bundles of the form
      prod.fst : B × fiber → B
  2. *trivializations of bundles* : given π : E → B, this is the data of
      φ  : equiv (B × fiber) E,
      hφ : π ∘ φ = prod.fst

These aren't the same thing of course. (In real life, this occurs when a bundle
can be trivialized in many ways. Think of picking a basis of a vector space.
For trivial bundles (1), the choice is already made. Otherwise it's data.)

Warning: The pullback of a trivial bundle B × fiber along f : B' → B is trivializable,
in fact *canonically* trivializable (we will write down a natural trivialization).
But it is not *definitionally* trivial. This is because it has the form

      {(b, f b, v)} ⊆ B' × (B × fiber)

rather than being B' × fiber, with the definition we give in terms of fiber products.
It is (almost) defeq to (id ×f f) × fiber, except for being parenthesized wrong.

Our approach:

a) Define bundles, bundle maps and functorial pullbacks of bundle maps
   (in particular of equivalences).
b) Define trivial bundle
c) Define trivialization of bundle (:= equivalence to the bundle from a trivial bundle)
d) Construct a *canonical* trivialization of the pullback of a trivial bundle.
   (Method: equivalence from trivial bundles to bundles pulled back from the constant map to a point).
e) Combine (a) and (d) to "pull back trivializations". 🎉
-/

-- Bundles and bundle maps.

structure bundle (B : Type) :=
  (space : Type)
  (π : space → B)

instance bundle_to_proj (B : Type) : has_coe_to_fun (bundle B) :=
{ F   := λ E, E.space → B,
  coe := λ E, E.π }

@[ext]
structure bundle_map {B : Type} (E F : bundle B) :=
  (map : E.space → F.space)
  (h : F.π ∘ map = E.π)
infix `→→`:110 := bundle_map

instance bundle_map_to_fn {B : Type} (E F : bundle B) : has_coe_to_fun (E →→ F) :=
{ F   := λ φ, E.space → F.space,
  coe := λ φ, φ.map }

def bundle_map.id {B : Type} (E : bundle B) : E →→ E :=
{ map := id,
  h   := function.comp.right_id E.π, }

def bundle_map.comp {B : Type} {E F G : bundle B}
  (φ' : F →→ G) (φ : E →→ F) : E →→ G :=
{ map := φ'.map ∘ φ.map,
  h   := by rw [← function.comp.assoc, φ'.h, φ.h], }
infix `∘∘`:110 := bundle_map.comp

@[simp]
lemma bundle_map.comp.assoc {B : Type} {E F G H : bundle B}
  (φ'' : G →→ H) (φ' : F →→ G) (φ : E →→ F) :
  (φ'' ∘∘ φ') ∘∘ φ = φ'' ∘∘ (φ' ∘∘ φ) := rfl

@[simp]
lemma bundle_map.left_id {B : Type} {E F : bundle B} (φ : bundle_map E F) :
  (bundle_map.id F) ∘∘ φ = φ :=
begin
  ext x, refl,
end

@[simp]
lemma bundle_map.right_id {B : Type} {E F : bundle B} (φ : bundle_map E F) :
  φ ∘∘ (bundle_map.id E) = φ :=
begin
  ext x, refl,
end

structure bundle_equiv {B : Type} (E F : bundle B) :=
  (to_bundle_map  : E →→ F)
  (inv_bundle_map : F →→ E)
  (left_inv       : inv_bundle_map ∘∘ to_bundle_map = bundle_map.id E)
  (right_inv      : to_bundle_map ∘∘ inv_bundle_map = bundle_map.id F)
infix `≃≃`:100 := bundle_equiv

def bundle_equiv.mk' {B : Type} {E F : bundle B}
  (φ : equiv E.space F.space)
  (hφ : F.π ∘ φ.to_fun = E.π)
  (hφ_inv : E.π ∘ φ.inv_fun = F.π) : E ≃≃ F :=
  { to_bundle_map  := ⟨φ.to_fun, hφ⟩,
    inv_bundle_map := ⟨φ.inv_fun, hφ_inv⟩,
    left_inv       := begin ext e, exact φ.left_inv e, end,
    right_inv      := begin ext e, exact φ.right_inv e, end }

def bundle_equiv.symm {B : Type} {E F : bundle B}
  (φ : E ≃≃ F) : F ≃≃ E :=
  { to_bundle_map  := φ.inv_bundle_map,
    inv_bundle_map := φ.to_bundle_map,
    left_inv       := φ.right_inv,
    right_inv      := φ.left_inv }

def bundle_equiv.trans {B : Type} {E F G : bundle B}
  (φ : E ≃≃ F) (φ' : F ≃≃ G) : E ≃≃ G :=
  { to_bundle_map  := φ'.to_bundle_map ∘∘ φ.to_bundle_map,
    inv_bundle_map := φ.inv_bundle_map ∘∘ φ'.inv_bundle_map,
    left_inv       := by rw [bundle_map.comp.assoc,
                             ← bundle_map.comp.assoc φ'.inv_bundle_map,
                             φ'.left_inv,
                             bundle_map.left_id,
                             φ.left_inv],
    right_inv      := by rw [bundle_map.comp.assoc,
                             ← bundle_map.comp.assoc φ.to_bundle_map,
                             φ.right_inv,
                             bundle_map.left_id,
                             φ'.right_inv], }
infix `≃∘≃`:110 := bundle_equiv.trans

section pullback
-- Pullbacks. Closely related to fiber products.

open fiber_product

@[reducible]
def pullback_bundle {B' B : Type} (f : B' → B) (E : bundle B) : bundle B' :=
{ space := E.π ×f f,
  π := fiber_product.fst E.π f }
infix `**`:110 := pullback_bundle

def pullback_map {B' B : Type} (f : B' → B) {E F : bundle B} (φ : E →→ F) :
  (f ** E) →→ (f ** F) :=
{ map := fiber_product.exact.map F.π f (f ** E).π (φ.map ∘ (fiber_product.snd E.π f))
         begin rw [← function.comp.assoc F.π, φ.h, ← fiber_product.sound], end,
  h := begin ext ⟨⟨e', b'⟩, h⟩, refl, end,
}
infix `↖*`:110 := pullback_map

@[simp]
lemma pullback_map.def {B' B : Type} (f : B' → B) {E F G : bundle B}
  (φ' : F →→ G) (φ : E →→ F) {b' : B'} {e : E.space} {h : f b' = E.π e} :
  (f ↖* φ) ⟨(b', e), h⟩ =
    ⟨(b', φ e), begin change f b' = (F.π ∘ φ.map) e, rw φ.h, exact h, end⟩ := rfl

lemma pullback_map.comp {B' B : Type} (f : B' → B) {E F G : bundle B}
  (φ' : F →→ G) (φ : E →→ F) :
  (f ↖* φ') ∘∘ (f ↖* φ) = f ↖* (φ' ∘∘ φ) := rfl

lemma pullback_map.of_id {B' B : Type} (f : B' → B) (E : bundle B) :
  (f ↖* (bundle_map.id E)) = (bundle_map.id (f ** E)) :=
begin
  ext ⟨⟨e, b'⟩, h⟩, refl, refl,
end

def pullback_bundle_equiv {B' B : Type} (f : B' → B) {E F : bundle B}
  (φ : E ≃≃ F) : (f ** E) ≃≃ (f ** F) :=
{ to_bundle_map  := f ↖* φ.to_bundle_map,
  inv_bundle_map := f ↖* φ.inv_bundle_map,
  left_inv       := by rw [pullback_map.comp,
                           φ.left_inv,
                           pullback_map.of_id],
  right_inv      := by rw [pullback_map.comp,
                           φ.right_inv,
                           pullback_map.of_id], }
infix `↖≃`:110 := pullback_bundle_equiv

def pullback_comp {B'' B' B : Type} (g : B'' → B') (f : B' → B) (E : bundle B) :
  g ** (f ** E) ≃≃ (f ∘ g) ** E :=
  @bundle_equiv.mk' B'' (g ** (f ** E)) ((f ∘ g) ** E)
  (fiber_product.comp_base E.π f g)
  rfl rfl

end pullback

section trivial_bundle
-- Trivial bundles

@[reducible] def trivial_bundle (B fiber : Type) : bundle B :=
  { space := B × fiber,
    π     := prod.fst }
infix `××`:110 := trivial_bundle

@[reducible]
def trivial_equiv_pullback_from_pt (B fiber : Type) :
  B ×× fiber ≃≃ (topology.map_to_point B) ** (trivial_bundle topology.point fiber) :=
  bundle_equiv.mk'
  (equiv.trans
    (prod_equiv_left B (prod_point_left fiber)).symm
    { to_fun    := restrict_cod id (λ b, (topology.point.is_singleton b.snd.fst).symm),
      inv_fun   := coe,
      left_inv  := begin rintro ⟨x, y⟩, refl, end,
      right_inv := begin rintro ⟨x, h⟩, refl, end }
      )
  rfl rfl

end trivial_bundle

section trivialization
-- Trivializations.

@[reducible]
def trivialization {B : Type} (E : bundle B) (fiber : Type) := (B ×× fiber) ≃≃ E

/-
-- Trivializing the pullback of a trivial bundle along any map.
-- This has to be done "by hand".
def trivialization_of_pullback_of_trivial {B B' : Type} (fiber : Type) (f : B' → B) :
  trivialization (f ** (B ×× fiber)) fiber :=
  bundle_equiv.mk'
    (equiv.trans (prod_equiv_right (domain_equiv_graph f) fiber)
                 (graph_equiv_pullback_of_trivial fiber f))
    rfl
    begin ext ⟨⟨b', b, v⟩, h⟩, refl, end

-- Pullback of a *trivialization* along any map. 🎉
def trivialization.pullback' {B B' : Type} (E : bundle B) (fiber : Type)
  (f : B' → B) (triv : trivialization E fiber) :
  trivialization (f ** E) fiber :=
  bundle_equiv.trans
    (trivialization_of_pullback_of_trivial fiber f) (f ↖≃ triv)
-/

-- Pullback of a *trivialization* along any map. 🎉
def trivialization.pullback {B B' : Type} {E : bundle B} {fiber : Type}
  (f : B' → B) (triv : trivialization E fiber) :
  trivialization (f ** E) fiber :=
    trivial_equiv_pullback_from_pt B' fiber
    ≃∘≃ (pullback_comp f (topology.map_to_point B) (topology.point ×× fiber)).symm
    ≃∘≃ (f ↖≃ (triv.symm ≃∘≃ trivial_equiv_pullback_from_pt B fiber)).symm

-- This says:
--       B' ×× fiber
--   ≃≃ (B' → point) ** (point ×× fiber)
--   ≃≃ (B' → B) ** ((B → point) ** (point ×× fiber))
--   ≃≃ f ** (B ×× fiber)
--   ≃≃ f ** E
-- As desired.

def trivialization.subset {B : Type} (U : set B) {E : bundle B} {fiber : Type}
  (triv : trivialization E fiber) :
  trivialization ((coe : U → B) ** E) fiber :=
  trivialization.pullback coe triv

-- Given a trivialization over A ⊆ B, obtain a trivialization over A ∩ V.
-- (By pulling back along A ∩ V → A.)
def trivialization.subset_of_subset {B fiber : Type} (E : bundle B) (A V : set B)
  (triv : trivialization ((coe : A → B) ** E) fiber) :
  trivialization ((coe : (A ∩ V) → B) ** E) fiber :=
  let c1 : (A ∩ V) → A := set.inclusion (set.inter_subset_left _ _) in
  bundle_equiv.trans
    (@trivialization.pullback _ _ _ fiber c1 triv)
    (pullback_comp c1 (coe : A → B) E)

end trivialization

section locally_trivial_fiber_bundle

variables {B : Type} (E : bundle B) (fiber : Type)
  [topology B] [topology E.space] [topology fiber]
  {I : Type} (U : open_cover I B)

-- 🎉 🎉 🎉 --
structure local_trivialization (h : cts E.π) :=
  (triv      : ∀ i, trivialization ((coe : U i → B) ** E) fiber)
  (htriv     : ∀ i, cts (triv i).to_bundle_map)
  (htriv_inv : ∀ i, cts (triv i).inv_bundle_map)

example {J : Type} (V : open_cover J B) (h : cts E.π)
  (loc_triv : local_trivialization E fiber U h) :
  @local_trivialization B E fiber _ _ _ (I × J) (open_cover.refine U V) h :=
  { triv      := λ ij, trivialization.subset_of_subset E (U ij.1) (V ij.2)
                          (loc_triv.triv ij.1),
    htriv     := begin rintro ⟨i, j⟩,
      unfold trivialization.subset_of_subset,
      sorry, -- make continuity lemmas for ≃≃s
     end,
    htriv_inv := sorry,
  }

end locally_trivial_fiber_bundle

section cts_bundle

-- Bundle maps

variables {B : Type} --[topology B]

lemma bundle_map.id.cts  (E : bundle B) [topology E.space] : cts (bundle_map.id E) := cts.id

variables {E F G : bundle B} [topology E.space] [topology F.space] [topology G.space]

lemma bundle_map.comp.cts {φ' : F →→ G} {φ : E →→ F} (hφ' : cts φ'.map) (hφ : cts φ.map) :
  cts (φ' ∘∘ φ).map := cts_of_comp _ _ hφ hφ'

-- Bundle equivalences

lemma bundle_equiv.symm.cts {φ : E ≃≃ F} (hφ_inv : cts φ.inv_bundle_map) :
  cts φ.symm.to_bundle_map := hφ_inv
lemma bundle_equiv.symm.inv_cts {φ : E ≃≃ F} (hφ : cts φ.to_bundle_map) :
  cts φ.symm.inv_bundle_map := hφ

lemma bundle_equiv.trans.cts {φ : E ≃≃ F} {φ' : F ≃≃ G}
  (hφ'_cts : cts φ'.to_bundle_map) (hφ_cts : cts φ.to_bundle_map):
  cts (bundle_equiv.trans φ φ').to_bundle_map.map := bundle_map.comp.cts hφ'_cts hφ_cts
lemma bundle_equiv.trans.inv_cts {φ : E ≃≃ F} {φ' : F ≃≃ G}
  (hφ'_inv_cts : cts φ'.inv_bundle_map) (hφ_inv_cts : cts φ.inv_bundle_map):
  cts (bundle_equiv.trans φ φ').inv_bundle_map.map := bundle_map.comp.cts hφ_inv_cts hφ'_inv_cts

lemma bundle_equiv.mk'.cts {φ : E.space ≃ F.space}
  {hφ : F.π ∘ φ.to_fun = E.π} {hφ_inv : E.π ∘ φ.inv_fun = F.π} (hφ_cts : cts φ) :
  cts (bundle_equiv.mk' φ hφ hφ_inv).to_bundle_map := hφ_cts
lemma bundle_equiv.mk'.inv_cts {φ : E.space ≃ F.space}
  {hφ : F.π ∘ φ.to_fun = E.π} {hφ_inv : E.π ∘ φ.inv_fun = F.π} (hφ_inv_cts : cts φ.inv_fun) :
  cts (bundle_equiv.mk' φ hφ hφ_inv).inv_bundle_map := hφ_inv_cts

-- Pullback maps and equivs

variables {B' : Type} (f : B' → B) [topology B] [topology B'] --(hf : cts f)

lemma pullback_map.cts {φ : E →→ F} (hφ : cts φ.map) :
  cts (f ↖* φ).map :=
begin
  apply fiber_product.exact.map.cts,
  exact fiber_product.fst.cts _ _,
  apply cts_of_comp _ φ.map _ hφ,
  exact fiber_product.snd.cts _ _,
end

lemma pullback_bundle_equiv.cts {φ : E ≃≃ F} (hφ_cts : cts φ.to_bundle_map) :
  cts (f ↖≃ φ).to_bundle_map := pullback_map.cts f hφ_cts

lemma pullback_bundle_equiv.inv_cts {φ : E ≃≃ F} (hφ_inv_cts : cts φ.inv_bundle_map) :
  cts (f ↖≃ φ).inv_bundle_map := pullback_map.cts f hφ_inv_cts

variables {B'' : Type} [topology B''] (g : B'' → B')

lemma pullback_comp.cts (hf : cts f) : cts (pullback_comp g f E).to_bundle_map :=
  bundle_equiv.mk'.cts (fiber_product.comp_base.cts _ _ _ hf)

lemma pullback_comp.inv_cts (hg : cts g) : cts (pullback_comp g f E).inv_bundle_map :=
  bundle_equiv.mk'.inv_cts (fiber_product.comp_base.inv_cts _ _ _ hg)

-- Trivializations

variables (fiber : Type) [topology fiber]

lemma trivial_equiv_pullback_from_pt.cts :
  cts (trivial_equiv_pullback_from_pt B fiber).to_bundle_map :=
begin
  apply bundle_equiv.mk'.cts _,
  apply restrict_cod_cts _,
  apply prod_equiv_left.cts,
  exact prod_point_left.inv_cts fiber,
  exact prod_point_left.cts fiber,
end

lemma trivial_equiv_pullback_from_pt.inv_cts :
  cts (trivial_equiv_pullback_from_pt B fiber).inv_bundle_map :=
begin
  apply bundle_equiv.mk'.inv_cts _,
  apply cts_of_comp _ _ coe_cts,
  apply prod_equiv_left.cts,
  exact prod_point_left.cts fiber,
  exact prod_point_left.inv_cts fiber,
end

lemma trivialization.pullback.cts (hf : cts f) {triv : trivialization E fiber}
  (htriv_cts : cts triv.to_bundle_map) :
  cts (trivialization.pullback f triv).to_bundle_map :=
begin
  apply bundle_equiv.trans.cts _ _, by apply_instance,
    apply bundle_equiv.symm.cts,
    apply pullback_map.cts,
    apply bundle_equiv.trans.inv_cts _ _, by apply_instance,
      apply trivial_equiv_pullback_from_pt.inv_cts,
      exact htriv_cts, -- assumption used!!
    apply bundle_equiv.trans.cts _ _, by apply_instance,
      apply bundle_equiv.symm.cts,
      apply pullback_comp.inv_cts, exact hf, -- assumption used!!
      apply trivial_equiv_pullback_from_pt.cts,
end

lemma trivialization.pullback.inv_cts {triv : trivialization E fiber}
  (htriv_inv_cts : cts triv.inv_bundle_map) :
  cts (trivialization.pullback f triv).inv_bundle_map :=
begin
  apply bundle_equiv.trans.inv_cts _ _, by apply_instance,
    apply bundle_equiv.symm.inv_cts,
    apply pullback_map.cts,
    apply bundle_equiv.trans.cts _ _, by apply_instance,
      apply trivial_equiv_pullback_from_pt.cts,
      exact htriv_inv_cts, -- assumption used!!
    apply bundle_equiv.trans.inv_cts _ _, by apply_instance,
      apply bundle_equiv.symm.inv_cts,
      apply pullback_comp.cts, apply map_to_point_cts,
      apply trivial_equiv_pullback_from_pt.inv_cts,
end

/-
structure cts_bundle (B : Type) [topology B] :=
  (space : Type)
  (top : topology space)
  (π : space → B)
  (hπ : cts π)

instance cts_bundle_to_bundle (B : Type) [topology B] :
  has_coe (cts_bundle B) (bundle B) := ⟨λ E, ⟨E.space, E.π⟩⟩

attribute [instance] cts_bundle.top

variables {B : Type} [topology B] (E F : cts_bundle B)

structure cts_bundle_map :=
  (map : E.space → F.space)
  (h : F.π ∘ map = E.π)
  (map_cts : cts map)

instance cts_bundle_map_to_bundle_map : has_coe (cts_bundle_map E F) (@bundle_map B ↑E ↑F) :=
  ⟨λ φ, ⟨φ.map, φ.h⟩⟩

structure cts_bundle_equiv :=
  (map  : cts_bundle_map E F)
  (inv_map : cts_bundle_map F E)
  (left_inv : ↑inv_map ∘∘ ↑map = bundle_map.id ↑E)
  (right_inv : ↑map ∘∘ ↑inv_map = bundle_map.id ↑F) :

def cts_bundle_equiv.mk' {B : Type} [topology B] {E F : cts_bundle B}
  (map  : cts_bundle_map E F)
  (inv_map : cts_bundle_map F E)
  (left_inv : inv_map.to_bundle_map ∘∘ map.to_bundle_map = bundle_map.id E.to_bundle)
  (right_inv : map.to_bundle_map ∘∘ inv_map.to_bundle_map = bundle_map.id F.to_bundle) :
  cts_bundle_equiv E F :=
  { to_bundle_equiv :=
    { to_bundle_map := map.to_bundle_map,
       inv_bundle_map := inv_map.to_bundle_map,
      left_inv := left_inv,
      right_inv := right_inv },
     map_cts := map.map_cts,
     inv_cts := inv_map.map_cts}

def cts_bundle_equiv.to_cts_bundle_map {B : Type} [topology B] {E F : cts_bundle B}
  (φ : cts_bundle_equiv E F) : cts_bundle_map E F := ⟨φ.to_bundle_map, φ.map_cts⟩

def cts_bundle_equiv.inv_cts_bundle_map {B : Type} [topology B] {E F : cts_bundle B}
  (φ : cts_bundle_equiv E F) : cts_bundle_map F E := ⟨φ.inv_bundle_map, φ.inv_cts⟩

def cts_bundle_map.id {B : Type} [topology B] (E : cts_bundle B) : cts_bundle_map E E :=
  { map_cts := cts.id, ..(bundle_map.id E.to_bundle) }

def cts_bundle_map.comp {B : Type}

-- What is the most appropriate / efficient thing to do here?

/-

structure cts_bundle (B : Type) [topology B] extends (bundle B) :=
  (top : topology to_bundle.space)
  (hπ : cts to_bundle.π)

structure cts_bundle_map {B : Type} [topology B] {E F : cts_bundle B} extends
  (bundle_map E.to_bundle F.to_bundle) :=
  (hcts : @cts _ _ E.top F.top to_bundle_map.map)

...

But then we have to start explicitly referring to the topology everywhere.

Or: just assume [topology t] for all relevant spaces t and (hf: cts f) for
all relevant f?

Or: put back in an assumption (hf : adjective f) throughout, where the adjective is part
of the data of the bundle.

-/
-/

end cts_bundle

end fiber_bundle


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

/-!
# Functions functorial with respect to equivalences

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

An `equiv_functor` is a function from `Type → Type` equipped with the additional data of
coherently mapping equivalences to equivalences.

In categorical language, it is an endofunctor of the "core" of the category `Type`.
-/

universes u₀ u₁ u₂ v₀ v₁ v₂

open function

/--
An `equiv_functor` is only functorial with respect to equivalences.

To construct an `equiv_functor`, it suffices to supply just the function `f α → f β` from
an equivalence `α ≃ β`, and then prove the functor laws. It's then a consequence that
this function is part of an equivalence, provided by `equiv_functor.map_equiv`.
-/
class equiv_functor (f : Type u₀ → Type u₁) :=
(map : Π {α β}, (α ≃ β) → (f α → f β))
(map_refl' : Π α, map (equiv.refl α) = @id (f α) . obviously)
(map_trans' : Π {α β γ} (k : α ≃ β) (h : β ≃ γ),
  map (k.trans h) = (map h) ∘ (map k) . obviously)

restate_axiom equiv_functor.map_refl'
restate_axiom equiv_functor.map_trans'
attribute [simp] equiv_functor.map_refl

namespace equiv_functor

section
variables (f : Type u₀ → Type u₁) [equiv_functor f] {α β : Type u₀} (e : α ≃ β)

/-- An `equiv_functor` in fact takes every equiv to an equiv. -/
def map_equiv :
  f α ≃ f β :=
{ to_fun := equiv_functor.map e,
  inv_fun := equiv_functor.map e.symm,
  left_inv := λ x, by { convert (congr_fun (equiv_functor.map_trans e e.symm) x).symm, simp, },
  right_inv := λ y, by { convert (congr_fun (equiv_functor.map_trans e.symm e) y).symm, simp, }, }

@[simp] lemma map_equiv_apply (x : f α) :
  map_equiv f e x = equiv_functor.map e x := rfl

lemma map_equiv_symm_apply (y : f β) :
  (map_equiv f e).symm y = equiv_functor.map e.symm y := rfl

@[simp] lemma map_equiv_refl (α) :
  map_equiv f (equiv.refl α) = equiv.refl (f α) :=
by simpa [equiv_functor.map_equiv]

@[simp] lemma map_equiv_symm :
  (map_equiv f e).symm = map_equiv f e.symm :=
equiv.ext $ map_equiv_symm_apply f e

/--
The composition of `map_equiv`s is carried over the `equiv_functor`.
For plain `functor`s, this lemma is named `map_map` when applied
or `map_comp_map` when not applied.
-/
@[simp] lemma map_equiv_trans {γ : Type u₀} (ab : α ≃ β) (bc : β ≃ γ) :
  (map_equiv f ab).trans (map_equiv f bc) = map_equiv f (ab.trans bc) :=
equiv.ext $ λ x, by simp [map_equiv, map_trans']

end

@[priority 100]
instance of_is_lawful_functor
  (f : Type u₀ → Type u₁) [functor f] [is_lawful_functor f] : equiv_functor f :=
{ map := λ α β e, functor.map e,
  map_refl' := λ α, by { ext, apply is_lawful_functor.id_map, },
  map_trans' := λ α β γ k h, by { ext x, apply (is_lawful_functor.comp_map k h x), } }

lemma map_equiv.injective
  (f : Type u₀ → Type u₁) [applicative f] [is_lawful_applicative f] {α β : Type u₀}
  (h : ∀ γ, function.injective (pure : γ → f γ)) :
  function.injective (@equiv_functor.map_equiv f _ α β) :=
λ e₁ e₂ H, equiv.ext $ λ x, h β (by simpa [equiv_functor.map] using equiv.congr_fun H (pure x))

end equiv_functor


/-
Copyright (c) 2022 Alex J. Best. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alex J. Best
-/
import Lean
import Mathlib.Lean.Expr.Basic

/-!
# The `generalize_proofs` tactic

Generalize any proofs occuring in the goal or in chosen hypotheses, replacing them by
named hypotheses so that they can be referred to later in the proof easily.
Commonly useful when dealing with functions like `Classical.choose` that produce data from proofs.

For example:
```lean
example : list.nth_le [1, 2] 1 dec_trivial = 2 := by
  -- ⊢ [1, 2].nth_le 1 _ = 2
  generalize_proofs h,
  -- h : 1 < [1, 2].length
  -- ⊢ [1, 2].nth_le 1 h = 2
```
-/

namespace Mathlib.Tactic.GeneralizeProofs
open Lean Meta Elab Parser.Tactic Elab.Tactic

/- The following set up are the visit function are based on the file
Lean.Meta.AbstractNestedProofs in core -/

/-- State for the generalize proofs tactic, contains the remaining names to be used and the
list of generalizations so far -/
structure State where
  /-- The user provided names, may be anonymous -/
  nextIdx : List (TSyntax ``binderIdent)
  /-- The generalizations made so far -/
  curIdx : Array GeneralizeArg := #[]

/-- Monad used by the `generalizeProofs` tactic, carries an expr cache and state with
names to use and previous generalizations -/
abbrev M := MonadCacheT ExprStructEq Expr $ StateRefT State MetaM

/-- generalize the given e -/
private def mkGen (e : Expr) : M Unit := do
  let s ← get
  let t ← match s.nextIdx with
  | [] => mkFreshUserName `h
  | n :: rest =>
    modify fun s ↦ { s with nextIdx := rest }
    match n with
    | `(binderIdent| $s:ident) => pure s.getId
    | _ => mkFreshUserName `h
  modify fun s ↦ { s with curIdx := s.curIdx.push ⟨e, t, none⟩ }

/-- Recursively generalize proofs occuring in e -/
partial def visit (e : Expr) : M Expr := do
  if e.isAtomic then
    pure e
  else
    let visitBinders (xs : Array Expr) (k : M Expr) : M Expr := do
      let localInstances ← getLocalInstances
      let mut lctx ← getLCtx
      for x in xs do
        let xFVarId := x.fvarId!
        let localDecl ← xFVarId.getDecl
        let type      ← visit localDecl.type
        let localDecl := localDecl.setType type
        let localDecl ← match localDecl.value? with
           | some value => let value ← visit value; pure <| localDecl.setValue value
           | none       => pure localDecl
        lctx := lctx.modifyLocalDecl xFVarId fun _ ↦ localDecl
      withLCtx lctx localInstances k
    checkCache (e : ExprStructEq) fun _ ↦ do
      if (← AbstractNestedProofs.isNonTrivialProof e) then
        mkGen e
        return e
      else match e with
        | .lam ..      => lambdaLetTelescope e fun xs b ↦ visitBinders xs do
          mkLambdaFVars xs (← visit b) (usedLetOnly := false)
        | .letE ..     => lambdaLetTelescope e fun xs b ↦ visitBinders xs do
          mkLambdaFVars xs (← visit b) (usedLetOnly := false)
        | .forallE ..  => forallTelescope e fun xs b ↦ visitBinders xs do
          mkForallFVars xs (← visit b)
        | .mdata _ b   => return e.updateMData! (← visit b)
        | .proj _ _ b  => return e.updateProj! (← visit b)
        | .app ..      => e.withApp fun f args ↦ return mkAppN f (← args.mapM visit)
        | _            => pure e

/--
Generalize proofs in the goal, naming them with the provided list.

For example:
```lean
example : list.nth_le [1, 2] 1 dec_trivial = 2 := by
  -- ⊢ [1, 2].nth_le 1 _ = 2
  generalize_proofs h,
  -- h : 1 < [1, 2].length
  -- ⊢ [1, 2].nth_le 1 h = 2
```
-/
elab (name := generalizeProofs) "generalize_proofs"
    hs:(ppSpace (colGt binderIdent))* loc:(ppSpace location)? : tactic => do
  let ou := if loc.isSome then
    match expandLocation loc.get! with
    | .wildcard => #[]
    | .targets t _ => t
  else #[]
  let fvs ← getFVarIds ou
  let goal ← getMainGoal
  let ty ← instantiateMVars (← goal.getType)
  let (_, ⟨_, out⟩) ← GeneralizeProofs.visit ty |>.run.run { nextIdx := hs.toList }
  let (_, fvarIds, goal) ← goal.generalizeHyp out fvs
  for h in hs, fvar in fvarIds do
    goal.withContext <| (Expr.fvar fvar).addLocalVarInfoForBinderIdent h
  replaceMainGoal [goal]


import deprecated.subfield
import field_theory.separable
import field_theory.tower
import data.set.finite
import algebra.gcd_monoid

section

variables (F : Type*) [field F] (E : Type*) [field E] [algebra F E]

def base_field_image := set.range (algebra_map F E)

instance : has_coe_t F (set.range (algebra_map F E)) :=
{coe := λ x, ⟨algebra_map F E x, ⟨x,rfl⟩⟩}

instance : is_subfield (set.range (algebra_map F E)) := {
    inv_mem := begin
        intros x hx,
        cases hx with f hf,
        use f⁻¹,
        rw ←hf,
        exact (algebra_map F E).map_inv f,
    end,
}

definition inclusion_ring_hom : F →+* (set.range (algebra_map F E)) := {
    to_fun := λ f, f,
    map_zero' :=
    begin
        ext1, unfold_coes, simp,
    end,
    map_add' :=
    begin
        intros f e,
        ext1, unfold_coes, simp,
    end,
    map_one' :=
    begin
        ext1, unfold_coes, simp,
    end,
    map_mul' :=
    begin
        intros f e,
        ext1, unfold_coes, simp,
    end,
}

lemma algebra_map_comp : (algebra_map (set.range (algebra_map F E)) E).comp(inclusion_ring_hom F E) = algebra_map F E :=
begin
    ext,
    refl,
end

instance : algebra F (set.range (algebra_map F E)) := {
    smul := λ f e, f * e,
    to_fun := inclusion_ring_hom F E,
    map_zero' := (inclusion_ring_hom F E).map_zero',
    map_add' := (inclusion_ring_hom F E).map_add',
    map_one' := (inclusion_ring_hom F E).map_one',
    map_mul' := (inclusion_ring_hom F E).map_mul',
    smul_def' := λ f e, rfl,
    commutes' :=
    begin
        intros f e,
        ext1, unfold_coes, simp[mul_comm],
    end,
}

definition inclusion_algebra_hom : F →ₐ[F] set.range (algebra_map F E) := {
    to_fun := λ f, f,
    map_zero' := (inclusion_ring_hom F E).map_zero',
    map_add' := (inclusion_ring_hom F E).map_add',
    map_one' := (inclusion_ring_hom F E).map_one',
    map_mul' := (inclusion_ring_hom F E).map_mul',
    commutes' := λ f, rfl,
}

noncomputable def algebra_equiv_of_bij_hom {A : Type*} [ring A] [algebra F A] {B : Type*} [ring B] [algebra F B] (f : A →ₐ[F] B) (h : function.bijective f) : A ≃ₐ[F] B :=
{ .. f, .. equiv.of_bijective _ h }

noncomputable def inclusion_isomorphism : F ≃ₐ[F] set.range (algebra_map F E) :=
algebra_equiv_of_bij_hom F (inclusion_algebra_hom F E)
begin
    split,
    apply ring_hom.injective ((inclusion_algebra_hom F E) : F →+* set.range (algebra_map F E)),
    intro e,
    cases e with e he,
    cases he with f hf,
    use f,
    ext1,
    unfold_coes,
    simp,
    exact hf,
end

noncomputable def reverse_inclusion_ring_hom : set.range (algebra_map F E) →+* F :=
(inclusion_isomorphism F E).symm

lemma reverse_inclusion_comp :
(algebra_map F E).comp(reverse_inclusion_ring_hom F E) = algebra_map _ E :=
begin
    ext,
    cases x with x hx,
    cases hx with f hf,
    have swap : (⟨x,⟨f,hf⟩⟩ : set.range(algebra_map F E)) = inclusion_ring_hom F E f,
    ext,
    exact hf.symm,
    rw swap,
    change algebra_map F E ((inclusion_isomorphism F E).symm (inclusion_isomorphism F E f)) = _,
    rw alg_equiv.symm_apply_apply,
    refl,
end

lemma reverse_inclusion_of_field (f : F) :
reverse_inclusion_ring_hom F E ↑f = f :=
begin
    change (inclusion_isomorphism F E).symm (inclusion_isomorphism F E f) = f,
    rw alg_equiv.symm_apply_apply,
end

end

variables {F : Type*} [field F] {E : Type*} [field E] [algebra F E] {x : E}

lemma inclusion.integral (hx : is_integral F x) : is_integral (set.range (algebra_map F E)) x :=
begin
    let F' := set.range (algebra_map F E),
    cases hx with p hp,
    use p.map (algebra_map F F'),
    split,
    apply polynomial.monic_map,
    exact hp.1,
    dsimp[polynomial.aeval],
    rw polynomial.eval₂_map,
    have h : (algebra_map F' E).comp(algebra_map F F') = algebra_map F E := by ext;refl,
    rw h,
    exact hp.2,
end

lemma inclusion.minimal_polynomial (hx : is_integral F x) : minimal_polynomial (inclusion.integral hx) = (minimal_polynomial hx).map (inclusion_ring_hom F E) :=
begin
    set F' := set.range (algebra_map F E),
    set f := inclusion_ring_hom F E,
    symmetry,
    apply minimal_polynomial.unique,
    apply polynomial.monic_map,
    apply minimal_polynomial.monic,
    dsimp[polynomial.aeval],
    rw polynomial.eval₂_map,
    rw algebra_map_comp,
    apply minimal_polynomial.aeval,
    intros q hq1 hq2,
    set f' := reverse_inclusion_ring_hom F E,
    set p := q.map f',
    rw polynomial.degree_map_eq_of_leading_coeff_ne_zero,
    apply ge_trans (polynomial.degree_map_le f'),
    apply minimal_polynomial.degree_le_of_ne_zero,
    exact polynomial.map_monic_ne_zero hq1,
    dsimp[polynomial.aeval],
    rw polynomial.eval₂_map,
    rw reverse_inclusion_comp,
    exact hq2,
    rw ring_hom.map_ne_zero,
    intro h,
    rw polynomial.leading_coeff_eq_zero at h,
    exact minimal_polynomial.ne_zero hx h,
end

lemma inclusion.separable : is_separable F E → is_separable (set.range (algebra_map F E)) E :=
begin
    intros h x,
    cases h x with hx hs,
    use inclusion.integral hx,
    rw inclusion.minimal_polynomial,
    exact polynomial.separable.map hs,
end

noncomputable instance algebra_of_range : algebra (set.range (algebra_map F E)) F := {
    smul := λ e f, reverse_inclusion_ring_hom F E (e * f),
    to_fun := (reverse_inclusion_ring_hom F E),
    map_zero' := (reverse_inclusion_ring_hom F E).map_zero',
    map_add' := (reverse_inclusion_ring_hom F E).map_add',
    map_one' := (reverse_inclusion_ring_hom F E).map_one',
    map_mul' := (reverse_inclusion_ring_hom F E).map_mul',
    smul_def' :=
    begin
        intros e f,
        change reverse_inclusion_ring_hom F E (e * f) = (reverse_inclusion_ring_hom F E e) * f,
        rw ring_hom.map_mul,
        rw reverse_inclusion_of_field,
    end,
    commutes' := λ e f, mul_comm _ _,
}

instance why_does_this_also_need_a_name : is_scalar_tower (set.range (algebra_map F E)) F E := {
    smul_assoc :=
    begin
        intros x y z,
        rw algebra.smul_def'',
        change ↑(inclusion_isomorphism F E ((inclusion_isomorphism F E).symm (x * y))) * z = _,
        rw alg_equiv.apply_symm_apply,
        rw is_submonoid.coe_mul,
        rw mul_assoc,
        rw algebra.smul_def'',
        rw algebra.smul_def'',
        refl,
    end
}

noncomputable def inclusion_linear_equiv : F ≃ₗ[set.range (algebra_map F E)] set.range (algebra_map F E) := {
    to_fun := (inclusion_isomorphism F E),
    map_add' := (inclusion_isomorphism F E).map_add',
    inv_fun := (inclusion_isomorphism F E).inv_fun,
    left_inv := (inclusion_isomorphism F E).left_inv,
    right_inv := (inclusion_isomorphism F E).right_inv,
    map_smul' :=
    begin
        intros x y,
        change (inclusion_isomorphism F E ((inclusion_isomorphism F E).symm (x * y))) = x * ↑y,
        rw alg_equiv.apply_symm_apply,
    end
}

instance finite_dimensional_of_field : finite_dimensional F F :=
begin
    rw finite_dimensional.finite_dimensional_iff_dim_lt_omega,
    rw ←finite_dimensional.findim_eq_dim,
    rw finite_dimensional.findim_of_field,
    exact cardinal.nat_lt_omega 1,
end

instance finite_dimensional_of_range : finite_dimensional (set.range (algebra_map F E)) F :=
linear_equiv.finite_dimensional ((@inclusion_linear_equiv F _ E _ _).symm)

lemma inclusion.finite_dimensional : finite_dimensional F E → finite_dimensional (set.range (algebra_map F E)) E :=
λ h, @finite_dimensional.trans (set.range (algebra_map F E)) F E _ _ _ _ _ _ _ _ h


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Floris van Doorn, Mario Carneiro
-/

import logic.function.basic
import tactic.core

/-!
# `choose` tactic

Performs Skolemization, that is, given `h : ∀ a:α, ∃ b:β, p a b |- G` produces
`f : α → β, hf: ∀ a, p a (f a) |- G`.
-/

namespace tactic

/-- Given `α : Sort u`, `nonemp : nonempty α`, `p : α → Prop`, a context of local variables
`ctxt`, and a pair of an element `val : α` and `spec : p val`,
`mk_sometimes u α nonemp p ctx (val, spec)` produces another pair `val', spec'`
such that `val'` does not have any free variables from elements of `ctxt` whose types are
propositions. This is done by applying `function.sometimes` to abstract over all the propositional
arguments. -/
meta def mk_sometimes (u : level) (α nonemp p : expr) :
  list expr → expr × expr → tactic (expr × expr)
| [] (val, spec) := pure (val, spec)
| (e :: ctxt) (val, spec) := do
  (val, spec) ← mk_sometimes ctxt (val, spec),
  t ← infer_type e,
  b ← is_prop t,
  pure $ if b then
    let val' := expr.bind_lambda val e in
    (expr.const ``function.sometimes [level.zero, u] t α nonemp val',
     expr.const ``function.sometimes_spec [u] t α nonemp p val' e spec)
  else (val, spec)

/-- Changes `(h : ∀xs, ∃a:α, p a) ⊢ g` to `(d : ∀xs, a) (s : ∀xs, p (d xs)) ⊢ g` and
`(h : ∀xs, p xs ∧ q xs) ⊢ g` to `(d : ∀xs, p xs) (s : ∀xs, q xs) ⊢ g`.
`choose1` returns a pair of the second local constant it introduces,
and the error result (see below).

If `nondep` is true and `α` is inhabited, then it will remove the dependency of `d` on
all propositional assumptions in `xs`. For example if `ys` are propositions then
`(h : ∀xs ys, ∃a:α, p a) ⊢ g` becomes `(d : ∀xs, a) (s : ∀xs ys, p (d xs)) ⊢ g`.

The second value returned by `choose1` is the result of nondep elimination:
* `none`: nondep elimination was not attempted or was not applicable
* `some none`: nondep elimination was successful
* ``some (some `(nonempty α))``: nondep elimination was unsuccessful
  because we could not find a `nonempty α` instance
-/
meta def choose1 (nondep : bool) (h : expr) (data : name) (spec : name) :
  tactic (expr × option (option expr)) := do
  t ← infer_type h,
  (ctxt, t) ← whnf t >>= open_pis,
  t ← whnf t transparency.all,
  match t with
  | `(@Exists %%α %%p) := do
    α_t ← infer_type α,
    expr.sort u ← whnf α_t transparency.all,
    (ne_fail, nonemp) ← if nondep then do
      let ne := expr.const ``nonempty [u] α,
      nonemp ← try_core (mk_instance ne <|> retrieve' (do
        m ← mk_meta_var ne,
        set_goals [m],
        ctxt.mmap' (λ e, do
          b ← is_proof e,
          monad.unlessb b $
            (mk_app ``nonempty.intro [e] >>= note_anon none) $> ()),
        reset_instance_cache,
        apply_instance,
        instantiate_mvars m)),
      pure (some (option.guard (λ _, nonemp.is_none) ne), nonemp)
    else pure (none, none),
    ctxt' ← if nonemp.is_some then ctxt.mfilter (λ e, bnot <$> is_proof e) else pure ctxt,
    value ← mk_local_def data (α.pis ctxt'),
    t' ← head_beta (p.app (value.mk_app ctxt')),
    spec ← mk_local_def spec (t'.pis ctxt),
    (value_proof, spec_proof) ← nonemp.elim pure (λ nonemp, mk_sometimes u α nonemp p ctxt)
      (expr.const ``classical.some [u] α p (h.mk_app ctxt),
       expr.const ``classical.some_spec [u] α p (h.mk_app ctxt)),
    dependent_pose_core [(value, value_proof.lambdas ctxt'), (spec, spec_proof.lambdas ctxt)],
    try (tactic.clear h),
    intro1,
    e ← intro1,
    pure (e, ne_fail)
  | `(%%p ∧ %%q) := do
    mk_app ``and.elim_left [h.mk_app ctxt] >>= lambdas ctxt >>= note data none,
    hq ← mk_app ``and.elim_right [h.mk_app ctxt] >>= lambdas ctxt >>= note spec none,
    try (tactic.clear h),
    pure (hq, none)
  | _ := fail "expected a term of the shape `∀xs, ∃a, p xs a` or `∀xs, p xs ∧ q xs`"
  end

/-- Changes `(h : ∀xs, ∃as, p as ∧ q as) ⊢ g` to a list of functions `as`,
and a final hypothesis on `p as` and `q as`. If `nondep` is true then the functions will
be made to not depend on propositional arguments, when possible.

The last argument is an internal recursion variable, indicating whether nondep elimination
has been useful so far. The tactic fails if `nondep` is true, and nondep elimination is
attempted at least once, and it fails every time it is attempted, in which case it returns
an error complaining about the first attempt.
-/
meta def choose (nondep : bool) : expr → list name →
  opt_param (option (option expr)) none → tactic unit
| h [] _ := fail "expect list of variables"
| h [n] (some (some ne)) := do
  g ← mk_meta_var ne, set_goals [g], -- make a reasonable error state
  fail "choose: failed to synthesize nonempty instance"
| h [n] _ := do
  cnt ← revert h,
  intro n,
  intron (cnt - 1),
  return ()
| h (n::ns) ne_fail₁ := do
  (v, ne_fail₂) ← get_unused_name >>= choose1 nondep h n,
  choose v ns $
    match ne_fail₁, ne_fail₂ with
    | none, _ := ne_fail₂
    | some none, _ := some none
    | _, some none := some none
    | _, _ := ne_fail₁
    end

namespace interactive
setup_tactic_parser

/-- `choose a b h h' using hyp` takes an hypothesis `hyp` of the form
`∀ (x : X) (y : Y), ∃ (a : A) (b : B), P x y a b ∧ Q x y a b`
for some `P Q : X → Y → A → B → Prop` and outputs
into context two functions `a : X → Y → A`, `b : X → Y → B` and two assumptions:
`h : ∀ (x : X) (y : Y), P x y (a x y) (b x y)` and
`h' : ∀ (x : X) (y : Y), Q x y (a x y) (b x y)`. It also works with dependent versions.

`choose! a b h h' using hyp` does the same, except that it will remove dependency of
the functions on propositional arguments if possible. For example if `Y` is a proposition
and `A` and `B` are nonempty in the above example then we will instead get
`a : X → A`, `b : X → B`, and the assumptions
`h : ∀ (x : X) (y : Y), P x y (a x) (b x)` and
`h' : ∀ (x : X) (y : Y), Q x y (a x) (b x)`.

Examples:

```lean
example (h : ∀n m : ℕ, ∃i j, m = n + i ∨ m + j = n) : true :=
begin
  choose i j h using h,
  guard_hyp i : ℕ → ℕ → ℕ,
  guard_hyp j : ℕ → ℕ → ℕ,
  guard_hyp h : ∀ (n m : ℕ), m = n + i n m ∨ m + j n m = n,
  trivial
end
```

```lean
example (h : ∀ i : ℕ, i < 7 → ∃ j, i < j ∧ j < i+i) : true :=
begin
  choose! f h h' using h,
  guard_hyp f : ℕ → ℕ,
  guard_hyp h : ∀ (i : ℕ), i < 7 → i < f i,
  guard_hyp h' : ∀ (i : ℕ), i < 7 → f i < i + i,
  trivial,
end
```
-/
meta def choose (nondep : parse (tk "!")?) (first : parse ident) (names : parse ident*)
  (tgt : parse (tk "using" *> texpr)?) : tactic unit := do
tgt ← match tgt with
  | none := get_local `this
  | some e := tactic.i_to_expr_strict e
  end,
tactic.choose nondep.is_some tgt (first :: names),
try (interactive.simp none none tt [simp_arg_type.expr
  ``(exists_prop)] [] (loc.ns $ some <$> names)),
try (tactic.clear tgt)

add_tactic_doc
{ name       := "choose",
  category   := doc_category.tactic,
  decl_names := [`tactic.interactive.choose],
  tags       := ["classical logic"] }

end interactive
end tactic


import category_theory.yoneda
open category_theory

variables (C : Type) [category.{0} C]

def thing : ((Cᵒᵖ ⥤ Type)ᵒᵖ ⥤ Type) ⥤ Cᵒᵖ ⥤ Type :=
functor.flip (functor.op yoneda ⋙ functor.flip (𝟭 ((Cᵒᵖ ⥤ Type)ᵒᵖ ⥤ Type)))

example : faithful (thing C) :=
{ map_injective' := begin
    intros X Y f g h,
    dsimp [thing] at h,
    ext F x,
    injection h with h,
    simp [function.funext_iff] at h,
    clear h,
    tidy,
    simp [function.funext_iff] at h_1,

end }


/-
Copyright (c) 2019 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import topology.category.Top.opens

/-!
# The category of open neighborhoods of a point

Given an object `X` of the category `Top` of topological spaces and a point `x : X`, this file
builds the type `open_nhds x` of open neighborhoods of `x` in `X` and endows it with the partial
order given by inclusion and the corresponding category structure (as a full subcategory of the
poset category `set X`). This is used in `topology.sheaves.stalks` to build the stalk of a sheaf
at `x` as a limit over `open_nhds x`.

## Main declarations

Besides `open_nhds`, the main constructions here are:

* `inclusion (x : X)`: the obvious functor `open_nhds x ⥤ opens X`
* `functor_nhds`: An open map `f : X ⟶ Y` induces a functor `open_nhds x ⥤ open_nhds (f x)`
* `adjunction_nhds`: An open map `f : X ⟶ Y` induces an adjunction between `open_nhds x` and
                     `open_nhds (f x)`.
-/

open category_theory
open topological_space
open opposite

universe u

variables {X Y : Top.{u}} (f : X ⟶ Y)

namespace topological_space

/-- The type of open neighbourhoods of a point `x` in a (bundled) topological space. -/
def open_nhds (x : X) := { U : opens X // x ∈ U }

namespace open_nhds

instance (x : X) : partial_order (open_nhds x) :=
{ le := λ U V, U.1 ≤ V.1,
  le_refl := λ _, le_refl _,
  le_trans := λ _ _ _, le_trans,
  le_antisymm := λ _ _ i j, subtype.eq $ le_antisymm i j }

instance (x : X) : lattice (open_nhds x) :=
{ inf := λ U V, ⟨U.1 ⊓ V.1, ⟨U.2, V.2⟩⟩,
  le_inf := λ U V W, @le_inf _ _ U.1.1 V.1.1 W.1.1,
  inf_le_left := λ U V, @inf_le_left _ _ U.1.1 V.1.1,
  inf_le_right := λ U V, @inf_le_right _ _ U.1.1 V.1.1,
  sup := λ U V, ⟨U.1 ⊔ V.1, V.1.1.mem_union_left U.2⟩,
  sup_le := λ U V W, @sup_le _ _ U.1.1 V.1.1 W.1.1,
  le_sup_left := λ U V, @le_sup_left _ _ U.1.1 V.1.1,
  le_sup_right := λ U V, @le_sup_right _ _ U.1.1 V.1.1,
  ..open_nhds.partial_order x }

instance (x : X) : order_top (open_nhds x) :=
{ top := ⟨⊤, trivial⟩,
  le_top := λ _, le_top }

instance (x : X) : inhabited (open_nhds x) := ⟨⊤⟩

instance open_nhds_category (x : X) : category.{u} (open_nhds x) :=
by {unfold open_nhds, apply_instance}

instance opens_nhds_hom_has_coe_to_fun {x : X} {U V : open_nhds x} :
  has_coe_to_fun (U ⟶ V) (λ _, U.1 → V.1) :=
⟨λ f x, ⟨x, f.le x.2⟩⟩

/--
The inclusion `U ⊓ V ⟶ U` as a morphism in the category of open sets.
-/
def inf_le_left {x : X} (U V : open_nhds x) : U ⊓ V ⟶ U :=
hom_of_le inf_le_left

/--
The inclusion `U ⊓ V ⟶ V` as a morphism in the category of open sets.
-/
def inf_le_right {x : X} (U V : open_nhds x) : U ⊓ V ⟶ V :=
hom_of_le inf_le_right

/-- The inclusion functor from open neighbourhoods of `x`
to open sets in the ambient topological space. -/
def inclusion (x : X) : open_nhds x ⥤ opens X :=
full_subcategory_inclusion _

@[simp] lemma inclusion_obj (x : X) (U) (p) : (inclusion x).obj ⟨U,p⟩ = U := rfl

lemma open_embedding {x : X} (U : open_nhds x) : open_embedding (U.1.inclusion) :=
U.1.open_embedding

def map (x : X) : open_nhds (f x) ⥤ open_nhds x :=
{ obj := λ U, ⟨(opens.map f).obj U.1, by tidy⟩,
  map := λ U V i, (opens.map f).map i }

@[simp] lemma map_obj (x : X) (U) (q) : (map f x).obj ⟨U, q⟩ = ⟨(opens.map f).obj U, by tidy⟩ :=
rfl
@[simp] lemma map_id_obj (x : X) (U) : (map (𝟙 X) x).obj U = U :=
by tidy
@[simp] lemma map_id_obj' (x : X) (U) (p) (q) : (map (𝟙 X) x).obj ⟨⟨U, p⟩, q⟩ = ⟨⟨U, p⟩, q⟩ :=
rfl

@[simp] lemma map_id_obj_unop (x : X) (U : (open_nhds x)ᵒᵖ) : (map (𝟙 X) x).obj (unop U) = unop U :=
by simp
@[simp] lemma op_map_id_obj (x : X) (U : (open_nhds x)ᵒᵖ) : (map (𝟙 X) x).op.obj U = U :=
by simp

/-- `opens.map f` and `open_nhds.map f` form a commuting square (up to natural isomorphism)
with the inclusion functors into `opens X`. -/
def inclusion_map_iso (x : X) : inclusion (f x) ⋙ opens.map f ≅ map f x ⋙ inclusion x :=
nat_iso.of_components
  (λ U, begin split, exact 𝟙 _, exact 𝟙 _ end)
  (by tidy)

@[simp] lemma inclusion_map_iso_hom (x : X) : (inclusion_map_iso f x).hom = 𝟙 _ := rfl
@[simp] lemma inclusion_map_iso_inv (x : X) : (inclusion_map_iso f x).inv = 𝟙 _ := rfl

end open_nhds

end topological_space

namespace is_open_map

open topological_space

variables {f}

/--
An open map `f : X ⟶ Y` induces a functor `open_nhds x ⥤ open_nhds (f x)`.
-/
@[simps]
def functor_nhds (h : is_open_map f) (x : X) :
  open_nhds x ⥤ open_nhds (f x) :=
{ obj := λ U, ⟨h.functor.obj U.1, ⟨x, U.2, rfl⟩⟩,
  map := λ U V i, h.functor.map i }

/--
An open map `f : X ⟶ Y` induces an adjunction between `open_nhds x` and `open_nhds (f x)`.
-/
def adjunction_nhds (h : is_open_map f) (x : X) :
  is_open_map.functor_nhds h x ⊣ open_nhds.map f x :=
adjunction.mk_of_unit_counit
{ unit := { app := λ U, hom_of_le $ λ x hxU, ⟨x, hxU, rfl⟩ },
  counit := { app := λ V, hom_of_le $ λ y ⟨x, hfxV, hxy⟩, hxy ▸ hfxV } }

end is_open_map


lemma one_mul (m : mynat) : 1 * m = m :=
begin
induction m with k Pk,
rw mul_zero, refl,
rw mul_succ,
rw Pk,
symmetry,
exact succ_eq_add_one _,
end


import Lbar.finsupp_instance

--  The lemmas in this file are likely no longer needed
open finset finsupp
open_locale big_operators

section families_of_add_comm_groups

variables {S : Fintype} {α β : Type*}

--  Not needed anymore: the `semi_normed_group` instance has been removed
lemma sum_nnnorm_add_le [semi_normed_group α] (F G : S → α) :
  ∥F + G∥₊ ≤ ∥F∥₊ + ∥G∥₊ :=
show ∑ s, ∥F s + G s∥₊ ≤ ∑ s, ∥F s∥₊ + ∑ s, ∥G s∥₊, from
le_trans (sum_le_sum (λ i hi, nnnorm_add_le _ _)) sum_add_distrib.le

--  Not needed anymore: this was a helper lemma for the triangle inequality
lemma add_zero_dists [decidable_eq α] [add_zero_class β] {l : α} {x y z : α →₀ β}
  (h : x l + y l + z l = 0) (hl : l ∈ x.support) :
  l ∈ y.support ∪ z.support :=
begin
  simp only [mem_support_iff, ne.def, mem_union] at hl ⊢,
  contrapose! hl,
  simpa only [hl, add_zero] using h,
end

--  Not needed anymore: this was a helper lemma for the triangle inequality
lemma dists [decidable_eq α] [add_group β] {l : α} {x y z : α →₀ β} (hl : l ∈ (x - z).support) :
  l ∈ (x - y).support ∪ (y - z).support :=
have xz : l ∈ (- (x - z)).support, by rwa support_neg,
add_zero_dists (by simp only [neg_sub, finsupp.coe_sub, pi.sub_apply, sub_add_sub_cancel, sub_self]) xz

end families_of_add_comm_groups


/-
Copyright (c) 2020 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.full_subcategory
import category_theory.limits.shapes.equalizers
import category_theory.limits.shapes.products
import topology.sheaves.presheaf

/-!
# The sheaf condition in terms of an equalizer of products

Here we set up the machinery for the "usual" definition of the sheaf condition,
e.g. as in https://stacks.math.columbia.edu/tag/0072
in terms of an equalizer diagram where the two objects are
`∏ F.obj (U i)` and `∏ F.obj (U i) ⊓ (U j)`.

-/

universes v' v u

noncomputable theory

open category_theory
open category_theory.limits
open topological_space
open opposite
open topological_space.opens

namespace Top

variables {C : Type u} [category.{v} C] [has_products.{v} C]
variables {X : Top.{v'}} (F : presheaf C X) {ι : Type v} (U : ι → opens X)

namespace presheaf

namespace sheaf_condition_equalizer_products

/-- The product of the sections of a presheaf over a family of open sets. -/
def pi_opens : C := ∏ (λ i : ι, F.obj (op (U i)))
/--
The product of the sections of a presheaf over the pairwise intersections of
a family of open sets.
-/
def pi_inters : C := ∏ (λ p : ι × ι, F.obj (op (U p.1 ⊓ U p.2)))

/--
The morphism `Π F.obj (U i) ⟶ Π F.obj (U i) ⊓ (U j)` whose components
are given by the restriction maps from `U i` to `U i ⊓ U j`.
-/
def left_res : pi_opens F U ⟶ pi_inters F U :=
pi.lift (λ p : ι × ι, pi.π _ p.1 ≫ F.map (inf_le_left (U p.1) (U p.2)).op)

/--
The morphism `Π F.obj (U i) ⟶ Π F.obj (U i) ⊓ (U j)` whose components
are given by the restriction maps from `U j` to `U i ⊓ U j`.
-/
def right_res : pi_opens F U ⟶ pi_inters F U :=
pi.lift (λ p : ι × ι, pi.π _ p.2 ≫ F.map (inf_le_right (U p.1) (U p.2)).op)

/--
The morphism `F.obj U ⟶ Π F.obj (U i)` whose components
are given by the restriction maps from `U j` to `U i ⊓ U j`.
-/
def res : F.obj (op (supr U)) ⟶ pi_opens F U :=
pi.lift (λ i : ι, F.map (topological_space.opens.le_supr U i).op)

@[simp, elementwise]
lemma res_π (i : ι) : res F U ≫ limit.π _ ⟨i⟩ = F.map (opens.le_supr U i).op :=
by rw [res, limit.lift_π, fan.mk_π_app]

@[elementwise]
lemma w : res F U ≫ left_res F U = res F U ≫ right_res F U :=
begin
  dsimp [res, left_res, right_res],
  ext,
  simp only [limit.lift_π, limit.lift_π_assoc, fan.mk_π_app, category.assoc],
  rw [←F.map_comp],
  rw [←F.map_comp],
  congr,
end

/--
The equalizer diagram for the sheaf condition.
-/
@[reducible]
def diagram : walking_parallel_pair ⥤ C :=
parallel_pair (left_res F U) (right_res F U)

/--
The restriction map `F.obj U ⟶ Π F.obj (U i)` gives a cone over the equalizer diagram
for the sheaf condition. The sheaf condition asserts this cone is a limit cone.
-/
def fork : fork.{v} (left_res F U) (right_res F U) := fork.of_ι _ (w F U)

@[simp]
lemma fork_X : (fork F U).X = F.obj (op (supr U)) := rfl

@[simp]
lemma fork_ι : (fork F U).ι = res F U := rfl
@[simp]
lemma fork_π_app_walking_parallel_pair_zero :
  (fork F U).π.app walking_parallel_pair.zero = res F U := rfl
@[simp]
lemma fork_π_app_walking_parallel_pair_one :
  (fork F U).π.app walking_parallel_pair.one = res F U ≫ left_res F U := rfl

variables {F} {G : presheaf C X}

/-- Isomorphic presheaves have isomorphic `pi_opens` for any cover `U`. -/
@[simp]
def pi_opens.iso_of_iso (α : F ≅ G) : pi_opens F U ≅ pi_opens G U :=
pi.map_iso (λ X, α.app _)

/-- Isomorphic presheaves have isomorphic `pi_inters` for any cover `U`. -/
@[simp]
def pi_inters.iso_of_iso (α : F ≅ G) : pi_inters F U ≅ pi_inters G U :=
pi.map_iso (λ X, α.app _)

/-- Isomorphic presheaves have isomorphic sheaf condition diagrams. -/
def diagram.iso_of_iso (α : F ≅ G) : diagram F U ≅ diagram G U :=
nat_iso.of_components
  begin rintro ⟨⟩, exact pi_opens.iso_of_iso U α, exact pi_inters.iso_of_iso U α end
  begin
    rintro ⟨⟩ ⟨⟩ ⟨⟩,
    { simp, },
    { ext, simp [left_res], },
    { ext, simp [right_res], },
    { simp, },
  end.

/--
If `F G : presheaf C X` are isomorphic presheaves,
then the `fork F U`, the canonical cone of the sheaf condition diagram for `F`,
is isomorphic to `fork F G` postcomposed with the corresponding isomorphism between
sheaf condition diagrams.
-/
def fork.iso_of_iso (α : F ≅ G) :
  fork F U ≅ (cones.postcompose (diagram.iso_of_iso U α).inv).obj (fork G U) :=
begin
  fapply fork.ext,
  { apply α.app, },
  { ext,
    dunfold fork.ι, -- Ugh, `simp` can't unfold abbreviations.
    simp [res, diagram.iso_of_iso], }
end

section open_embedding

variables {V : Top.{v'}} {j : V ⟶ X} (oe : open_embedding j)
variables (𝒰 : ι → opens V)

/--
Push forward a cover along an open embedding.
-/
@[simp]
def cover.of_open_embedding : ι → opens X := (λ i, oe.is_open_map.functor.obj (𝒰 i))

/--
The isomorphism between `pi_opens` corresponding to an open embedding.
-/
@[simp]
def pi_opens.iso_of_open_embedding :
  pi_opens (oe.is_open_map.functor.op ⋙ F) 𝒰 ≅ pi_opens F (cover.of_open_embedding oe 𝒰) :=
pi.map_iso (λ X, F.map_iso (iso.refl _))

/--
The isomorphism between `pi_inters` corresponding to an open embedding.
-/
@[simp]
def pi_inters.iso_of_open_embedding :
  pi_inters (oe.is_open_map.functor.op ⋙ F) 𝒰 ≅ pi_inters F (cover.of_open_embedding oe 𝒰) :=
pi.map_iso (λ X, F.map_iso
  begin
    dsimp [is_open_map.functor],
    exact iso.op
    { hom := hom_of_le (by
      { simp only [oe.to_embedding.inj, set.image_inter],
        exact le_rfl, }),
      inv := hom_of_le (by
      { simp only [oe.to_embedding.inj, set.image_inter],
        exact le_rfl, }), },
  end)

/-- The isomorphism of sheaf condition diagrams corresponding to an open embedding. -/
def diagram.iso_of_open_embedding :
  diagram (oe.is_open_map.functor.op ⋙ F) 𝒰 ≅ diagram F (cover.of_open_embedding oe 𝒰) :=
nat_iso.of_components
  begin
    rintro ⟨⟩,
    exact pi_opens.iso_of_open_embedding oe 𝒰,
    exact pi_inters.iso_of_open_embedding oe 𝒰
  end
  begin
    rintro ⟨⟩ ⟨⟩ ⟨⟩,
    { simp, },
    { ext,
      dsimp [left_res, is_open_map.functor],
      simp only [limit.lift_π, cones.postcompose_obj_π, iso.op_hom, discrete.nat_iso_hom_app,
        functor.map_iso_refl, functor.map_iso_hom, lim_map_π_assoc, limit.lift_map, fan.mk_π_app,
        nat_trans.comp_app, category.assoc],
      dsimp,
      rw [category.id_comp, ←F.map_comp],
      refl, },
    { ext,
      dsimp [right_res, is_open_map.functor],
      simp only [limit.lift_π, cones.postcompose_obj_π, iso.op_hom, discrete.nat_iso_hom_app,
        functor.map_iso_refl, functor.map_iso_hom, lim_map_π_assoc, limit.lift_map, fan.mk_π_app,
        nat_trans.comp_app, category.assoc],
      dsimp,
      rw [category.id_comp, ←F.map_comp],
      refl, },
    { simp, },
  end.

/--
If `F : presheaf C X` is a presheaf, and `oe : U ⟶ X` is an open embedding,
then the sheaf condition fork for a cover `𝒰` in `U` for the composition of `oe` and `F` is
isomorphic to sheaf condition fork for `oe '' 𝒰`, precomposed with the isomorphism
of indexing diagrams `diagram.iso_of_open_embedding`.

We use this to show that the restriction of sheaf along an open embedding is still a sheaf.
-/
def fork.iso_of_open_embedding :
  fork (oe.is_open_map.functor.op ⋙ F) 𝒰 ≅
    (cones.postcompose (diagram.iso_of_open_embedding oe 𝒰).inv).obj
      (fork F (cover.of_open_embedding oe 𝒰)) :=
begin
  fapply fork.ext,
  { dsimp [is_open_map.functor],
    exact
    F.map_iso (iso.op
    { hom := hom_of_le
      (by simp only [supr_s, supr_mk, le_def, subtype.coe_mk, set.le_eq_subset, set.image_Union]),
      inv := hom_of_le
      (by simp only [supr_s, supr_mk, le_def, subtype.coe_mk, set.le_eq_subset,
                     set.image_Union]) }), },
  { ext ⟨j⟩,
    dunfold fork.ι, -- Ugh, it is unpleasant that we need this.
    simp only [res, diagram.iso_of_open_embedding, discrete.nat_iso_inv_app, functor.map_iso_inv,
      limit.lift_π, cones.postcompose_obj_π, functor.comp_map,
      fork_π_app_walking_parallel_pair_zero, pi_opens.iso_of_open_embedding,
      nat_iso.of_components.inv_app, functor.map_iso_refl, functor.op_map, limit.lift_map,
      fan.mk_π_app, nat_trans.comp_app, quiver.hom.unop_op, category.assoc, lim_map_eq_lim_map],
    dsimp,
    rw [category.comp_id, ←F.map_comp],
    refl, },
end

end open_embedding

end sheaf_condition_equalizer_products

end presheaf

end Top