/-
Copyright (c) 2014-15 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Floris van Doorn

Partially ported from Coq HoTT
Theorems about sigma-types (dependent sums)
-/
import .prod

universes u v w
hott_theory

namespace hott

open hott.eq sigma hott.equiv hott.is_equiv function hott.is_trunc sum unit

@[reducible, hott]
def dpair {α β} := @sigma.mk α β

namespace sigma
  variables {A : Type _} {A' : Type _} {B : A → Type _} {B' : A' → Type _} {C : Πa, B a → Type _}
            {D : Πa b, C a b → Type _}
            {a a' a'' : A} {b b₁ b₂ : B a} {b' : B a'} {b'' : B a''} {u v w : Σa, B a}

  @[hott] def destruct := @sigma.cases_on

  /- Paths in a sigma-type -/

  @[hott] protected def eta : Π (u : Σa, B a), (⟨u.1 , u.2⟩: sigma _) = u
  | ⟨u₁, u₂⟩ := idp

  @[hott] def eta2 : Π (u : Σa b, C a b), (⟨u.1, u.2.1, u.2.2⟩: Σ _ _, _) = u
  | ⟨u₁, u₂, u₃⟩ := idp

  @[hott] def eta3 : Π (u : Σa b c, D a b c), (⟨u.1, u.2.1, u.2.2.1, u.2.2.2⟩: Σ _ _ _, _) = u
  | ⟨u₁, u₂, u₃, u₄⟩ := idp

  @[hott] def dpair_eq_dpair (p : a = a') (q : b =[p] b') : (⟨a, b⟩: Σ _, _) = ⟨a', b'⟩ :=
  apd011 sigma.mk p q

  @[hott] def sigma_eq (p : u.1 = v.1) (q : u.2 =[p] v.2) : u = v :=
  by induction u; induction v; exact (dpair_eq_dpair p q)

  @[hott] def sigma_eq_right (q : b₁ = b₂) : (⟨a, b₁⟩: Σ _, _) = ⟨a, b₂⟩ :=
  ap (dpair a) q

  @[hott] def eq_fst (p : u = v) : u.1 = v.1 :=
  ap fst p

  postfix `..1`:(max+1) := eq_fst

  @[hott] def eq_snd (p : u = v) : u.2 =[p..1] v.2 :=
  by induction p; exact idpo

  postfix `..2`:(max+1) := eq_snd

  @[hott] def dpair_sigma_eq (p : u.1 = v.1) (q : u.2 =[p] v.2)
    : (⟨(sigma_eq p q)..1, (sigma_eq p q)..2⟩: Σ p, u.2 =[p] v.2) = ⟨p, q⟩ :=
  by induction u; induction v;dsimp at *;induction q;refl

  @[hott] def sigma_eq_fst (p : u.1 = v.1) (q : u.2 =[p] v.2) : (sigma_eq p q)..1 = p :=
  (dpair_sigma_eq p q)..1

  @[hott] def sigma_eq_snd (p : u.1 = v.1) (q : u.2 =[p] v.2)
    : (sigma_eq p q)..2 =[sigma_eq_fst p q; λ p, u.2 =[p] v.2] q :=
  (dpair_sigma_eq p q)..2

  @[hott] def sigma_eq_eta (p : u = v) : sigma_eq (p..1) (p..2) = p :=
  by induction p; induction u; reflexivity

  @[hott] def eq2_fst {p q : u = v} (r : p = q) : p..1 = q..1 :=
  ap eq_fst r

  @[hott] def eq2_snd {p q : u = v} (r : p = q) : p..2 =[eq2_fst r; λ x, u.2 =[x] v.2] q..2 :=
  by apply pathover_ap; apply (apd eq_snd r)

  @[hott] def tr_fst_sigma_eq {B' : A → Type _} (p : u.1 = v.1) (q : u.2 =[p] v.2)
    : transport (λx : sigma _, B' x.1) (sigma_eq p q) = transport B' p :=
  by induction u; induction v; dsimp at *;induction q; reflexivity

  @[hott] protected def ap_fst (p : u = v) : ap (λx : sigma B, x.1) p = p..1 := idp

  /- the uncurried version of sigma_eq. We will prove that this is an equivalence -/

  @[hott] def sigma_eq_unc : Π (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2), u = v
  | ⟨pq₁, pq₂⟩ := sigma_eq pq₁ pq₂

  @[hott] def dpair_sigma_eq_unc : Π (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2),
    (⟨(sigma_eq_unc pq)..1, (sigma_eq_unc pq)..2⟩: Σ p, u.2 =[p] v.2) = pq
  | ⟨pq₁, pq₂⟩ := dpair_sigma_eq pq₁ pq₂

  @[hott] def sigma_eq_fst_unc (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2)
    : (sigma_eq_unc pq)..1 = pq.1 :=
  (dpair_sigma_eq_unc pq)..1

  @[hott] def sigma_eq_snd_unc (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2) :
    (sigma_eq_unc pq)..2 =[sigma_eq_fst_unc pq; λ p, u.2 =[p] v.2] pq.2 :=
  (dpair_sigma_eq_unc pq)..2

  @[hott] def sigma_eq_eta_unc (p : u = v) : sigma_eq_unc ⟨p..1, p..2⟩ = p :=
  sigma_eq_eta p

  @[hott] def tr_sigma_eq_fst_unc {B' : A → Type _}
    (pq : Σ(p : u.1 = v.1), u.2 =[p] v.2)
      : transport (λx:sigma _, B' x.1) (@sigma_eq_unc A B u v pq) = transport B' pq.1 :=
  by apply destruct pq; apply tr_fst_sigma_eq

  @[hott, instance] def is_equiv_sigma_eq (u v : Σa, B a)
      : is_equiv (@sigma_eq_unc A B u v) :=
  adjointify sigma_eq_unc
             (λp, ⟨p..1, p..2⟩)
             sigma_eq_eta_unc
             dpair_sigma_eq_unc

  @[hott] def sigma_eq_equiv (u v : Σa, B a)
    : (u = v) ≃ (Σ(p : u.1 = v.1),  u.2 =[p] v.2) :=
  (equiv.mk sigma_eq_unc (by apply_instance))⁻¹ᵉ

  @[hott] def dpair_eq_dpair_con (p1 : a  = a' ) (q1 : b  =[p1] b' )
                                (p2 : a' = a'') (q2 : b' =[p2] b'') :
    dpair_eq_dpair (p1 ⬝ p2) (q1 ⬝o q2) = dpair_eq_dpair p1 q1 ⬝ dpair_eq_dpair  p2 q2 :=
  by induction q1; induction q2; reflexivity

  @[hott] def sigma_eq_con (p1 : u.1 = v.1) (q1 : u.2 =[p1] v.2)
                          (p2 : v.1 = w.1) (q2 : v.2 =[p2] w.2) :
    sigma_eq (p1 ⬝ p2) (q1 ⬝o q2) = sigma_eq p1 q1 ⬝ sigma_eq p2 q2 :=
  by induction u; induction v; induction w; apply dpair_eq_dpair_con

  @[hott] def dpair_eq_dpair_con_idp (p : a = a') (q : b =[p] b') :
    dpair_eq_dpair p q = dpair_eq_dpair p (pathover_tr _ _) ⬝
    dpair_eq_dpair idp (pathover_idp_of_eq _ (tr_eq_of_pathover q)) :=
  by induction q; reflexivity

  /- eq_fst commutes with the groupoid structure. -/

  @[hott] def eq_fst_idp (u : Σa, B a)           : (idpath u) ..1 = refl (u.1)      := idp
  @[hott] def eq_fst_con (p : u = v) (q : v = w) : (p ⬝ q)  ..1 = (p..1) ⬝ (q..1) := ap_con _ _ _
  @[hott] def eq_fst_inv (p : u = v)             : p⁻¹      ..1 = (p..1)⁻¹        := ap_inv _ _

  /- Applying dpair to one argument is the same as dpair_eq_dpair with reflexivity in the first place. -/

  @[hott] def ap_dpair (q : b₁ = b₂) :
    ap (sigma.mk a) q = dpair_eq_dpair idp (pathover_idp_of_eq _ q) :=
  by induction q; reflexivity

  /- Dependent transport is the same as transport along a sigma_eq. -/

  @[hott] def transportD_eq_transport (p : a = a') (c : C a b) :
      p ▸D c = transport (λu : sigma _, C (u.1) (u.2)) (dpair_eq_dpair p (pathover_tr _ _)) c :=
  by induction p; reflexivity

  @[hott] def sigma_eq_eq_sigma_eq {p1 q1 : a = a'} {p2 : b =[p1] b'} {q2 : b =[q1] b'}
      (r : p1 = q1) (s : p2 =[r; λ p, b =[p] b'] q2) : @sigma_eq _ _ ⟨a,b⟩ ⟨a',b'⟩ p1 p2 = sigma_eq q1 q2 :=
  by induction s; reflexivity

  /- A path between paths in a total space is commonly shown component wise. -/
  @[hott] def sigma_eq2 {p q : u = v} (r : p..1 = q..1) (s : p..2 =[r; λ p, u.2 =[p] v.2] q..2)
    : p = q :=
  begin
    induction p, induction u with u1 u2,
    transitivity sigma_eq q..1 q..2,
      apply sigma_eq_eq_sigma_eq r s,
      apply sigma_eq_eta,
  end

  @[hott] def sigma_eq2_unc {p q : u = v} (rs : Σ(r : p..1 = q..1), p..2 =[r; λ p, u.2 =[p] v.2] q..2) : p = q :=
  by apply destruct rs; apply sigma_eq2

  @[hott] def ap_dpair_eq_dpair (f : Πa, B a → A') (p : a = a') (q : b =[p] b')
    : @ap _ A' (@sigma.rec _ _ (λ _, A') f) _ _ (dpair_eq_dpair p q) = apd011 f p q :=
  by induction q; reflexivity

  /- Transport -/

  /- The concrete description of transport in sigmas (and also pis) is rather trickier than in the other types.  In particular, these cannot be described just in terms of transport in simpler types; they require also the dependent transport [transportD].

  In particular, this indicates why `transport` alone cannot be fully defined by induction on the structure of types, although Id-elim/transportD can be (cf. Observational Type _ Theory).  A more thorough set of lemmas, along the lines of the present ones but dealing with Id-elim rather than just transport, might be nice to have eventually? -/

  @[hott] def sigma_transport (p : a = a') (bc : Σ(b : B a), C a b)
    : p ▸ bc = ⟨p ▸ bc.1, p ▸D bc.2⟩ :=
  by induction p; induction bc; reflexivity

  /- The special case when the second variable doesn't depend on the first is simpler. -/
  @[hott] def sigma_transport_nondep {B : Type _} {C : A → B → Type _} (p : a = a')
    (bc : Σ(b : B), C a b) : p ▸ bc = ⟨bc.1, transport (λ a, C a bc.1) p bc.2⟩ :=
  by induction p; induction bc; reflexivity

  /- Or if the second variable contains a first component that doesn't depend on the first. -/

  @[hott] def sigma_transport2_nondep {C : A → Type _} {D : Π a:A, B a → C a → Type _} (p : a = a')
      (bcd : Σ(b : B a) (c : C a), D a b c) : p ▸ bcd = ⟨p ▸ bcd.1, p ▸ bcd.2.1, p ▸D2 bcd.2.2⟩ :=
  begin
    induction p, induction bcd with b cd, induction cd, reflexivity
  end

  /- Pathovers -/

  @[hott] def etao (p : a = a') (bc : Σ(b : B a), C a b)
    : bc =[p; λ a, Σ b, C a b] ⟨p ▸ bc.1, p ▸D bc.2⟩ :=
  by induction p; induction bc; apply idpo

  -- TODO: interchange sigma_pathover and sigma_pathover'
  @[hott] def sigma_pathover (p : a = a') (u : Σ(b : B a), C a b) (v : Σ(b : B a'), C a' b)
    (r : u.1 =[p] v.1) (s : u.2 =[apd011 C p r; id] v.2) : u =[p; λ a, Σ b, C a b] v :=
  begin
    induction u, induction v, dsimp at *, induction r,
    dsimp [apd011] at s, apply idp_rec_on s, apply idpo
  end

  @[hott] def sigma_pathover' (p : a = a') (u : Σ(b : B a), C a b) (v : Σ(b : B a'), C a' b)
    (r : u.1 =[p] v.1) (s : @pathover (sigma _) ⟨a,u.1⟩ (λ x, C x.1 x.2) u.2 ⟨a',v.1⟩ (sigma_eq p r) v.2) :
    u =[p; λ a, Σ b, C a b] v :=
  begin
    induction u, induction v, dsimp at *, induction r,
    apply idp_rec_on s, apply idpo
  end

  @[hott] def sigma_pathover_nondep {B : Type _} {C : A → B → Type _} (p : a = a')
    (u : Σ(b : B), C a b) (v : Σ(b : B), C a' b)
    (r : u.1 = v.1) (s : @pathover (prod _ _) (a,u.1) (λx, C x.1 x.2) u.2 (a',v.1) (prod.prod_eq p r) v.2) :
    u =[p; λ a, Σ b, C a b] v :=
  begin
    induction p, induction u, induction v, dsimp at *, induction r,
    apply idp_rec_on s, apply idpo
  end

  @[hott] def pathover_fst {A : Type _} {B : A → Type _} {C : Πa, B a → Type _}
    {a a' : A} {p : a = a'} {x : Σb, C a b} {x' : Σb', C a' b'}
    (q : x =[p; λ a, Σb, C a b] x') : x.1 =[p] x'.1 :=
  begin induction q, constructor end

  @[hott] def sigma_pathover_equiv_of_is_prop {A : Type _} {B : A → Type _} (C : Πa, B a → Type _)
    {a a' : A} (p : a = a') (x : Σb, C a b) (x' : Σb', C a' b')
    [Πa b, is_prop (C a b)] : x =[p; λa, Σb, C a b] x' ≃ x.1 =[p] x'.1 :=
  begin
    fapply equiv.MK,
    { exact pathover_fst },
    { intro q, induction x with b c, induction x' with b' c', dsimp at q, induction q,
      apply pathover_idp_of_eq, exact sigma_eq idp (is_prop.elimo _ _ _) },
    { intro q, induction x with b c, induction x' with b' c', dsimp at q, induction q,
      have: c = c', by apply is_prop.elim, induction this,
      dsimp, rwr is_prop_elimo_self, },
    { intro q, induction q, induction x with b c,
      dsimp [pathover_fst], rwr is_prop_elimo_self }
  end

  /-
    TODO:
    * define the projections from the type u =[p] v
    * show that the uncurried version of sigma_pathover is an equivalence
  -/
  /- Squares in a sigma type are characterized in cubical.squareover (to avoid circular imports) -/

  /- Functorial action -/
  variables (f : A → A') (g : Πa, B a → B' (f a))

  @[hott] def sigma_functor (u : Σa, B a) : Σa', B' a' :=
  ⟨f u.1, g u.1 u.2⟩

  @[hott] def total {B' : A → Type _} (g : Πa, B a → B' a) : (Σa, B a) → (Σa, B' a) :=
  sigma_functor id g

  /- Equivalences -/
  @[hott] def is_equiv_sigma_functor [H1 : is_equiv f] [H2 : Π a, is_equiv (g a)]
      : is_equiv (sigma_functor f g) :=
  adjointify (sigma_functor f g)
             (sigma_functor f⁻¹ᶠ (λ(a' : A') (b' : B' a'),
               ((g (f⁻¹ᶠ a'))⁻¹ᶠ (transport B' (right_inv f a')⁻¹ b'))))
  begin abstract {
    intro u', induction u' with a' b', fapply sigma_eq,
    {apply right_inv f},
    {dsimp [sigma_functor], rwr right_inv (g (f⁻¹ᶠ a')), apply tr_pathover}
  } end
  begin abstract {
    intro u, induction u with a b, fapply sigma_eq,
    {apply left_inv f},
    {apply pathover_of_tr_eq, dsimp only [sigma_functor],
      rwr [adj f, ← fn_tr_eq_tr_fn (left_inv f a) (λ a, (g a)⁻¹ᶠ),
        tr_compose B', tr_inv_tr], dsimp, rwr left_inv }
  } end

  @[hott] def sigma_equiv_sigma_of_is_equiv
    [H1 : is_equiv f] [H2 : Π a, is_equiv (g a)] : (Σa, B a) ≃ (Σa', B' a') :=
  equiv.mk (sigma_functor f g) (is_equiv_sigma_functor _ _)

  @[hott] def sigma_equiv_sigma (Hf : A ≃ A') (Hg : Π a, B a ≃ B' (Hf a)) :
      (Σa, B a) ≃ (Σa', B' a') :=
  sigma_equiv_sigma_of_is_equiv Hf (λ a, Hg a)

  @[hott] def sigma_equiv_sigma_right {B' : A → Type _} (Hg : Π a, B a ≃ B' a)
    : (Σa, B a) ≃ Σa, B' a :=
  sigma_equiv_sigma equiv.rfl Hg

  variable (B)
  @[hott] def sigma_equiv_sigma_left (Hf : A ≃ A') :
    (Σa, B a) ≃ (Σa', B (Hf⁻¹ᶠ a')) :=
  sigma_equiv_sigma Hf (λ a, equiv_ap B (right_inv Hf⁻¹ᶠ a)⁻¹ᵖ)

  @[hott] def sigma_equiv_sigma_left' (Hf : A' ≃ A) : (Σa, B (Hf a)) ≃ (Σa', B a') :=
  sigma_equiv_sigma Hf (λa, erfl)
  variable {B}

  @[hott] def ap_sigma_functor_eq_dpair (p : a = a') (q : b =[p] b') :
    ap (sigma_functor f g) (@sigma_eq _ _ ⟨a,b⟩ ⟨a',b'⟩ p q) =
      sigma_eq (ap f p) (by exact pathover.rec_on q idpo) :=
  by induction q; reflexivity

  @[hott] def sigma_ua {A B : Type _} (C : A ≃ B → Type _) :
    (Σ(p : A = B), C (equiv_of_eq p)) ≃ Σ(e : A ≃ B), C e :=
  sigma_equiv_sigma_left' C (eq_equiv_equiv _ _)

  -- @[hott] def ap_sigma_functor_eq (p : u.1 = v.1) (q : u.2 =[p] v.2)
  --   : ap (sigma_functor f g) (sigma_eq p q) =
  --     sigma_eq (ap f p)
  --      ((tr_compose B' f p (g u.1 u.2))⁻¹ ⬝ (fn_tr_eq_tr_fn p g u.2)⁻¹ ⬝ ap (g v.1) q) :=
  -- by induction u; induction v; apply ap_sigma_functor_eq_dpair

  /- definition 3.11.9(i): Summing up a contractible family of types does nothing. -/

  @[hott, instance] def is_equiv_fst (B : A → Type _) [H : Π a, is_contr (B a)]
      : is_equiv (@fst A B) :=
  adjointify fst
             (λa, ⟨a, center _⟩)
             (λa, idp)
             (λu, sigma_eq idp (pathover_idp_of_eq _ (center_eq _)))

  @[hott] def sigma_equiv_of_is_contr_right (B : A → Type _) [H : Π a, is_contr (B a)]
    : (Σa, B a) ≃ A :=
  equiv.mk fst (by apply_instance)

  /- definition 3.11.9(ii): Dually, summing up over a contractible type does nothing. -/

  @[hott] def sigma_equiv_of_is_contr_left (B : A → Type _) [H : is_contr A]
    : (Σa, B a) ≃ B (center A) :=
  equiv.MK
    (λu, (center_eq u.1)⁻¹ ▸ u.2)
    (λb, ⟨center _, b⟩)
    begin abstract { intro b, change _ = idpath (center A) ▸ b,
      apply ap (λx, x ▸ b), apply prop_eq_of_is_contr, } end
    begin abstract { exact λu, sigma_eq (center_eq _) (tr_pathover _ _) } end

  /- Associativity -/

  --this proof is harder than in Coq because we don't have eta definitionally for sigma
  @[hott] def sigma_assoc_equiv (C : (Σa, B a) → Type _)
    : (Σa b, C ⟨a, b⟩) ≃ (Σu, C u) :=
  equiv.mk _ (adjointify
    (λav, ⟨⟨av.1, av.2.1⟩, av.2.2⟩)
    (λuc, ⟨uc.1.1, uc.1.2, by rwr sigma.eta; exact uc.2⟩)
    begin abstract { intro uc, induction uc with u c, induction u, reflexivity } end
    begin abstract { intro av, induction av with a v, induction v, reflexivity } end)

  open prod
  @[hott] def assoc_equiv_prod (C : (A × A') → Type _) : (Σa a', C (a,a')) ≃ (Σu, C u) :=
  equiv.mk _ (adjointify
    (λav, ⟨(av.1, av.2.1), av.2.2⟩)
    (λuc, ⟨(uc.1).1, (uc.1).2, by rwr prod.eta; exact uc.2⟩)
    (λ ⟨⟨a,b⟩,c⟩, idp) (λ ⟨a,⟨b,c⟩⟩, idp))

  /- Symmetry -/

  @[hott] def comm_equiv_unc (C : A × A' → Type _) : (Σa a', C (a, a')) ≃ (Σa' a, C (a, a')) :=
  calc
    (Σa a', C (a, a')) ≃ Σu, C u          : assoc_equiv_prod _
                   ... ≃ Σv, C (flip v)   : sigma_equiv_sigma (prod.prod_comm_equiv _ _)
                                              (λ ⟨a,a'⟩, equiv.rfl)
                   ... ≃ Σa' a, C (a, a') : by symmetry; exact assoc_equiv_prod (C ∘ prod.flip)

  @[hott] def sigma_comm_equiv (C : A → A' → Type _)
    : (Σa a', C a a') ≃ (Σa' a, C a a') :=
  comm_equiv_unc (λu, C (fst u) (snd u))

  @[hott] def equiv_prod (A B : Type _) : (Σ(a : A), B) ≃ A × B :=
  equiv.mk _ (adjointify
    (λs, (s.1, s.2))
    (λp, ⟨fst p, snd p⟩)
    (λ⟨a,b⟩, idp) (λ⟨a,b⟩, idp))

  @[hott] def comm_equiv_nondep (A B : Type _) : (Σ(a : A), B) ≃ Σ(b : B), A :=
  calc
    (Σ(a : A), B) ≃ A × B       : by apply equiv_prod
              ... ≃ B × A       : by apply prod.prod_comm_equiv
              ... ≃ Σ(b : B), A : by symmetry; apply equiv_prod

  @[hott] def sigma_assoc_comm_equiv {A : Type _} (B C : A → Type _)
    : (Σ(v : Σa, B a), C v.1) ≃ (Σ(u : Σa, C a), B u.1) :=
  calc    (Σ(v : Σa, B a), C v.1)
        ≃ (Σa (b : B a), C a)     : by symmetry; apply sigma_assoc_equiv (C ∘ fst)
    ... ≃ (Σa (c : C a), B a)     : by apply sigma_equiv_sigma_right; intro a; apply comm_equiv_nondep
    ... ≃ (Σ(u : Σa, C a), B u.1) : by apply sigma_assoc_equiv (B ∘ fst)

  /- Interaction with other type constructors -/

  @[hott] def sigma_empty_left (B : empty → Type _) : (Σx, B x) ≃ empty :=
  begin
    fapply equiv.MK,
    { intro v, induction v, cases v_fst},
    { intro x, cases x},
    { intro x, cases x},
    { intro v, induction v, cases v_fst},
  end

  @[hott] def sigma_empty_right (A : Type _) : (Σ(a : A), empty) ≃ empty :=
  begin
    fapply equiv.MK,
    { intro v, induction v, cases v_snd},
    { intro x, cases x},
    { intro x, cases x},
    { intro v, induction v, cases v_snd},
  end

  @[hott] def sigma_unit_left (B : unit → Type _) : (Σx, B x) ≃ B star :=
  sigma_equiv_of_is_contr_left _

  @[hott] def sigma_unit_right (A : Type _) : (Σ(a : A), unit) ≃ A :=
  sigma_equiv_of_is_contr_right _

  @[hott] def sigma_sum_left (B : A ⊎ A' → Type _)
    : (Σp, B p) ≃ (Σa, B (inl a)) ⊎ (Σa, B (inr a)) :=
  begin
    fapply equiv.MK,
    { intro v,
      induction v with p b,
      induction p,
      { apply inl, constructor, assumption },
      { apply inr, constructor, assumption }},
    { intro p, induction p with v v; induction v; constructor; assumption},
    { intro p, induction p with v v; induction v; reflexivity},
    { intro v, induction v with p b, induction p; reflexivity},
  end

  @[hott] def sigma_sum_right (B C : A → Type _)
    : (Σa, B a ⊎ C a) ≃ (Σa, B a) ⊎ (Σa, C a) :=
  begin
    fapply equiv.MK,
    { intro v,
      induction v with a p,
      induction p,
      { apply inl, constructor, assumption},
      { apply inr, constructor, assumption}},
    { intro p,
      induction p with v v,
      { induction v, constructor, apply inl, assumption },
      { induction v, constructor, apply inr, assumption }},
    { intro p, induction p with v v; induction v; reflexivity},
    { intro v, induction v with a p, induction p; reflexivity},
  end

  @[hott] def sigma_sigma_eq_right {A : Type _} (a : A) (P : Π(b : A), a = b → Type _)
    : (Σ(b : A) (p : a = b), P b p) ≃ P a idp :=
  calc
    (Σ(b : A) (p : a = b), P b p) ≃ (Σ(v : Σ(b : A), a = b), P v.1 v.2) : by apply sigma_assoc_equiv (λ u, P u.fst u.snd)
      ... ≃ P a idp : by apply sigma_equiv_of_is_contr_left (λ v : Σ b, a=b, P v.fst v.snd)

  @[hott] def sigma_sigma_eq_left {A : Type _} (a : A) (P : Π(b : A), b = a → Type _)
    : (Σ(b : A) (p : b = a), P b p) ≃ P a idp :=
  calc
    (Σ(b : A) (p : b = a), P b p) ≃ (Σ(v : Σ(b : A), b = a), P v.1 v.2) : by apply sigma_assoc_equiv (λ u : Σ b, b=a, P u.fst u.snd)
      ... ≃ P a idp : by apply sigma_equiv_of_is_contr_left (λ v : Σ b, b=a, P v.fst v.snd)

  /- ** Universal mapping properties -/
  /- *** The positive universal property. -/

  section
  @[hott, instance] def is_equiv_sigma_rec (C : (Σa, B a) → Type _)
    : is_equiv (sigma.rec : (Πa b, C ⟨a, b⟩) → Πab, C ab) :=
  adjointify _ (λ g a b, g ⟨a, b⟩)
               (λ g, eq_of_homotopy (λ⟨a,b⟩, idp))
               (λ f, refl f)

  @[hott] def equiv_sigma_rec (C : (Σa, B a) → Type _)
    : (Π(a : A) (b: B a), C ⟨a, b⟩) ≃ (Πxy, C xy) :=
  equiv.mk sigma.rec (by apply_instance)

  /- *** The negative universal property. -/

  @[hott] protected def coind_unc (fg : Σ(f : Πa, B a), Πa, C a (f a)) (a : A)
    : Σ(b : B a), C a b :=
  ⟨fg.1 a, fg.2 a⟩

  @[hott] protected def coind (f : Π a, B a) (g : Π a, C a (f a)) (a : A) : Σ(b : B a), C a b :=
  sigma.coind_unc ⟨f, g⟩ a

  --is the instance below dangerous?
  --in Coq this can be done without function extensionality
  @[hott, instance] def is_equiv_coind (C : Πa, B a → Type _)
    : is_equiv (@sigma.coind_unc _ _ C) :=
  adjointify _ (λ h, ⟨λa, (h a).1, λa, (h a).2⟩)
               (λ h, eq_of_homotopy (λu, sigma.eta _))
               (λ⟨f,g⟩, idp)

  variable (C)
  @[hott] def sigma_pi_equiv_pi_sigma : (Σ(f : Πa, B a), Πa, C a (f a)) ≃ (Πa, Σb, C a b) :=
  equiv.mk sigma.coind_unc (by apply_instance)
  variable {C}
  end

  /- Subtypes (sigma types whose second components are props) -/

  @[hott] def subtype {A : Type _} (P : A → Type _) [H : Πa, is_prop (P a)] :=
  Σ(a : A), P a
  notation [parsing_only] `{` binder `|` r:(scoped:1 P, subtype P) `}` := r

  /- To prove equality in a subtype, we only need equality of the first component. -/
  @[hott] def subtype_eq [H : Πa, is_prop (B a)] {u v : {a | B a}} :
    u.1 = v.1 → u = v :=
  sigma_eq_unc ∘ inv fst

  @[hott] def is_equiv_subtype_eq [H : Πa, is_prop (B a)] (u v : {a | B a})
      : is_equiv (subtype_eq : u.1 = v.1 → u = v) :=
  is_equiv_compose _ _
  local attribute [instance] is_equiv_subtype_eq

  @[hott] def equiv_subtype [H : Πa, is_prop (B a)] (u v : {a | B a}) :
    (u.1 = v.1) ≃ (u = v) :=
  equiv.mk subtype_eq (by apply_instance)

  @[hott] def subtype_eq_equiv [H : Πa, is_prop (B a)] (u v : {a | B a}) :
    (u = v) ≃ (u.1 = v.1) :=
  (equiv_subtype u v)⁻¹ᵉ

  @[hott] def subtype_eq_inv {A : Type _} {B : A → Type _} [H : Πa, is_prop (B a)] (u v : Σa, B a)
    : u = v → u.1 = v.1 :=
  subtype_eq⁻¹ᶠ

  @[hott] def is_equiv_subtype_eq_inv {A : Type _} {B : A → Type _} [H : Πa, is_prop (B a)]
    (u v : Σa, B a) : is_equiv (subtype_eq_inv u v) :=
  by delta subtype_eq_inv; apply_instance

  /- truncatedness -/
  @[hott] def is_trunc_sigma (B : A → Type _) (n : trunc_index)
      [HA : is_trunc n A] [HB : Πa, is_trunc n (B a)] : is_trunc n (Σa, B a) :=
  begin
  unfreezeI, revert A B HA HB,
  induction n with n IH; resetI,
  { intros A B HA HB, apply is_trunc_equiv_closed_rev -2 (sigma_equiv_of_is_contr_left B) (HB _) },
  { intros A B HA HB, apply is_trunc_succ_intro, intros u v,
    apply is_trunc_equiv_closed_rev _ (sigma_eq_equiv _ _) (IH _);
    apply_instance }
  end

  @[hott] theorem is_trunc_subtype (B : A → Prop) (n : trunc_index)
      [HA : is_trunc (n.+1) A] : is_trunc (n.+1) (Σa, B a) :=
  @is_trunc_sigma _ (λ a, B a) (n.+1) _ (λa, is_trunc_succ_of_is_prop _ _)

  /- if the total space is a mere proposition, you can equate two points in the base type by
     finding points in their fibers -/
  @[hott] def eq_base_of_is_prop_sigma {A : Type _} (B : A → Type _) (H : is_prop (Σa, B a)) {a a' : A}
    (b : B a) (b' : B a') : a = a' :=
  (@is_prop.elim (Σa, B a) _ ⟨a, b⟩ ⟨a', b'⟩)..1

end sigma

attribute [instance] sigma.is_trunc_sigma
attribute [instance] sigma.is_trunc_subtype

namespace sigma

  /- pointed sigma type -/
  open pointed

  @[hott, instance] def pointed_sigma {A : Type _} (P : A → Type _) [G : pointed A]
      [H : pointed (P pt)] : pointed (Σx, P x) :=
  pointed.mk ⟨pt,pt⟩

  @[hott] def psigma {A : Type*} (P : A → Type*) : Type* :=
  pointed.mk' (Σa, P a)

  notation `Σ*` binders `, ` r:(scoped P, psigma P) := r

  @[hott] def pfst {A : Type*} {B : A → Type*} : (Σ*(x : A), B x) →* A :=
  pmap.mk fst idp

  @[hott] def psnd {A : Type*} {B : A → Type*} (v : (Σ*(x : A), B x)) : B (pfst.to_fun v) :=
  snd v

  @[hott] def ptsigma {n : ℕ₋₂} {A : n-Type*} (P : A → (n-Type*)) : n-Type* :=
  ptrunctype.mk' n (Σa, P a)

end sigma

end hott


/-
Copyright (c) 2014 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Jeremy Avigad, Leonardo de Moura
-/
import tactic.ext tactic.finish data.subtype tactic.interactive
open function

/- set coercion to a type -/
namespace set
instance {α : Type*} : has_coe_to_sort (set α) := ⟨_, λ s, {x // x ∈ s}⟩
end set

section set_coe
universe u
variables {α : Type u}
theorem set.set_coe_eq_subtype (s : set α) :
  coe_sort.{(u+1) (u+2)} s = {x // x ∈ s} := rfl

@[simp] theorem set_coe.forall {s : set α} {p : s → Prop} :
  (∀ x : s, p x) ↔ (∀ x (h : x ∈ s), p ⟨x, h⟩) :=
subtype.forall

@[simp] theorem set_coe.exists {s : set α} {p : s → Prop} :
  (∃ x : s, p x) ↔ (∃ x (h : x ∈ s), p ⟨x, h⟩) :=
subtype.exists

@[simp] theorem set_coe_cast : ∀ {s t : set α} (H' : s = t) (H : @eq (Type u) s t) (x : s),
  cast H x = ⟨x.1, H' ▸ x.2⟩
| s _ rfl _ ⟨x, h⟩ := rfl

theorem set_coe.ext {s : set α} {a b : s} : (↑a : α) = ↑b → a = b :=
subtype.eq

theorem set_coe.ext_iff {s : set α} {a b : s} : (↑a : α) = ↑b ↔ a = b :=
iff.intro set_coe.ext (assume h, h ▸ rfl)

end set_coe

lemma subtype.mem {α : Type*} {s : set α} (p : s) : (p : α) ∈ s := p.property

namespace set
universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {ι : Sort x} {a : α} {s t : set α}

instance : inhabited (set α) := ⟨∅⟩

@[extensionality]
theorem ext {a b : set α} (h : ∀ x, x ∈ a ↔ x ∈ b) : a = b :=
funext (assume x, propext (h x))

theorem ext_iff (s t : set α) : s = t ↔ ∀ x, x ∈ s ↔ x ∈ t :=
⟨λ h x, by rw h, ext⟩

@[trans] theorem mem_of_mem_of_subset {α : Type u} {x : α} {s t : set α} (hx : x ∈ s) (h : s ⊆ t) : x ∈ t :=
h hx

/- mem and set_of -/

@[simp] theorem mem_set_of_eq {a : α} {p : α → Prop} : a ∈ {a | p a} = p a := rfl

@[simp] theorem nmem_set_of_eq {a : α} {P : α → Prop} : a ∉ {a : α | P a} = ¬ P a := rfl

@[simp] theorem set_of_mem_eq {s : set α} : {x | x ∈ s} = s := rfl

theorem mem_def {a : α} {s : set α} : a ∈ s ↔ s a := iff.rfl

instance decidable_mem (s : set α) [H : decidable_pred s] : ∀ a, decidable (a ∈ s) := H

instance decidable_set_of (p : α → Prop) [H : decidable_pred p] : decidable_pred {a | p a} := H

@[simp] theorem set_of_subset_set_of {p q : α → Prop} : {a | p a} ⊆ {a | q a} ↔ (∀a, p a → q a) := iff.rfl

@[simp] lemma sep_set_of {α} {p q : α → Prop} : {a ∈ {a | p a } | q a} = {a | p a ∧ q a} :=
rfl

@[simp] lemma set_of_mem {α} {s : set α} : {a | a ∈ s} = s := rfl

/- subset -/

-- TODO(Jeremy): write a tactic to unfold specific instances of generic notation?
theorem subset_def {s t : set α} : (s ⊆ t) = ∀ x, x ∈ s → x ∈ t := rfl

@[refl] theorem subset.refl (a : set α) : a ⊆ a := assume x, id

@[trans] theorem subset.trans {a b c : set α} (ab : a ⊆ b) (bc : b ⊆ c) : a ⊆ c :=
assume x h, bc (ab h)

@[trans] theorem mem_of_eq_of_mem {α : Type u} {x y : α} {s : set α} (hx : x = y) (h : y ∈ s) : x ∈ s :=
hx.symm ▸ h

theorem subset.antisymm {a b : set α} (h₁ : a ⊆ b) (h₂ : b ⊆ a) : a = b :=
ext (λ x, iff.intro (λ ina, h₁ ina) (λ inb, h₂ inb))

theorem subset.antisymm_iff {a b : set α} : a = b ↔ a ⊆ b ∧ b ⊆ a :=
⟨λ e, e ▸ ⟨subset.refl _, subset.refl _⟩,
 λ ⟨h₁, h₂⟩, subset.antisymm h₁ h₂⟩

-- an alterantive name
theorem eq_of_subset_of_subset {a b : set α} (h₁ : a ⊆ b) (h₂ : b ⊆ a) : a = b :=
subset.antisymm h₁ h₂

theorem mem_of_subset_of_mem {s₁ s₂ : set α} {a : α} : s₁ ⊆ s₂ → a ∈ s₁ → a ∈ s₂ :=
assume h₁ h₂, h₁ h₂

theorem not_subset : (¬ s ⊆ t) ↔ ∃a, a ∈ s ∧ a ∉ t :=
by simp [subset_def, classical.not_forall]

/- strict subset -/

/-- `s ⊂ t` means that `s` is a strict subset of `t`, that is, `s ⊆ t` but `s ≠ t`. -/
def strict_subset (s t : set α) := s ⊆ t ∧ s ≠ t

instance : has_ssubset (set α) := ⟨strict_subset⟩

theorem ssubset_def : (s ⊂ t) = (s ⊆ t ∧ s ≠ t) := rfl

lemma exists_of_ssubset {α : Type u} {s t : set α} (h : s ⊂ t) : (∃x∈t, x ∉ s) :=
classical.by_contradiction $ assume hn,
  have t ⊆ s, from assume a hat, classical.by_contradiction $ assume has, hn ⟨a, hat, has⟩,
  h.2 $ subset.antisymm h.1 this

lemma ssubset_iff_subset_not_subset {s t : set α} : s ⊂ t ↔ s ⊆ t ∧ ¬ t ⊆ s :=
by split; simp [set.ssubset_def, ne.def, set.subset.antisymm_iff] {contextual := tt}

theorem not_mem_empty (x : α) : ¬ (x ∈ (∅ : set α)) :=
assume h : x ∈ ∅, h

@[simp] theorem not_not_mem [decidable (a ∈ s)] : ¬ (a ∉ s) ↔ a ∈ s :=
not_not

/- empty set -/

theorem empty_def : (∅ : set α) = {x | false} := rfl

@[simp] theorem mem_empty_eq (x : α) : x ∈ (∅ : set α) = false := rfl

@[simp] theorem set_of_false : {a : α | false} = ∅ := rfl

theorem eq_empty_iff_forall_not_mem {s : set α} : s = ∅ ↔ ∀ x, x ∉ s :=
by simp [ext_iff]

theorem ne_empty_of_mem {s : set α} {x : α} (h : x ∈ s) : s ≠ ∅ :=
by { intro hs, rw hs at h, apply not_mem_empty _ h }

@[simp] theorem empty_subset (s : set α) : ∅ ⊆ s :=
assume x, assume h, false.elim h

theorem subset_empty_iff {s : set α} : s ⊆ ∅ ↔ s = ∅ :=
by simp [subset.antisymm_iff]

theorem eq_empty_of_subset_empty {s : set α} : s ⊆ ∅ → s = ∅ :=
subset_empty_iff.1

theorem ne_empty_iff_exists_mem {s : set α} : s ≠ ∅ ↔ ∃ x, x ∈ s :=
by haveI := classical.prop_decidable;
   simp [eq_empty_iff_forall_not_mem]

theorem exists_mem_of_ne_empty {s : set α} : s ≠ ∅ → ∃ x, x ∈ s :=
ne_empty_iff_exists_mem.1

theorem coe_nonempty_iff_ne_empty {s : set α} : nonempty s ↔ s ≠ ∅ :=
nonempty_subtype.trans ne_empty_iff_exists_mem.symm

-- TODO: remove when simplifier stops rewriting `a ≠ b` to `¬ a = b`
theorem not_eq_empty_iff_exists {s : set α} : ¬ (s = ∅) ↔ ∃ x, x ∈ s :=
ne_empty_iff_exists_mem

theorem subset_eq_empty {s t : set α} (h : t ⊆ s) (e : s = ∅) : t = ∅ :=
subset_empty_iff.1 $ e ▸ h

theorem subset_ne_empty {s t : set α} (h : t ⊆ s) : t ≠ ∅ → s ≠ ∅ :=
mt (subset_eq_empty h)

theorem ball_empty_iff {p : α → Prop} :
  (∀ x ∈ (∅ : set α), p x) ↔ true :=
by simp [iff_def]

/- universal set -/

theorem univ_def : @univ α = {x | true} := rfl

@[simp] theorem mem_univ (x : α) : x ∈ @univ α := trivial

theorem empty_ne_univ [h : inhabited α] : (∅ : set α) ≠ univ :=
by simp [ext_iff]

@[simp] theorem subset_univ (s : set α) : s ⊆ univ := λ x H, trivial

theorem univ_subset_iff {s : set α} : univ ⊆ s ↔ s = univ :=
by simp [subset.antisymm_iff]

theorem eq_univ_of_univ_subset {s : set α} : univ ⊆ s → s = univ :=
univ_subset_iff.1

theorem eq_univ_iff_forall {s : set α} : s = univ ↔ ∀ x, x ∈ s :=
by simp [ext_iff]

theorem eq_univ_of_forall {s : set α} : (∀ x, x ∈ s) → s = univ := eq_univ_iff_forall.2

@[simp] lemma univ_eq_empty_iff {α : Type*} : (univ : set α) = ∅ ↔ ¬ nonempty α :=
eq_empty_iff_forall_not_mem.trans ⟨λ H ⟨x⟩, H x trivial, λ H x _, H ⟨x⟩⟩

lemma nonempty_iff_univ_ne_empty {α : Type*} : nonempty α ↔ (univ : set α) ≠ ∅ :=
by classical; exact iff_not_comm.1 univ_eq_empty_iff

lemma exists_mem_of_nonempty (α) : ∀ [nonempty α], ∃x:α, x ∈ (univ : set α)
| ⟨x⟩ := ⟨x, trivial⟩

@[simp] lemma univ_ne_empty {α} [h : nonempty α] : (univ : set α) ≠ ∅ :=
λ e, univ_eq_empty_iff.1 e h

instance univ_decidable : decidable_pred (@set.univ α) :=
λ x, is_true trivial

/- union -/

theorem union_def {s₁ s₂ : set α} : s₁ ∪ s₂ = {a | a ∈ s₁ ∨ a ∈ s₂} := rfl

theorem mem_union_left {x : α} {a : set α} (b : set α) : x ∈ a → x ∈ a ∪ b := or.inl

theorem mem_union_right {x : α} {b : set α} (a : set α) : x ∈ b → x ∈ a ∪ b := or.inr

theorem mem_or_mem_of_mem_union {x : α} {a b : set α} (H : x ∈ a ∪ b) : x ∈ a ∨ x ∈ b := H

theorem mem_union.elim {x : α} {a b : set α} {P : Prop}
    (H₁ : x ∈ a ∪ b) (H₂ : x ∈ a → P) (H₃ : x ∈ b → P) : P :=
or.elim H₁ H₂ H₃

theorem mem_union (x : α) (a b : set α) : x ∈ a ∪ b ↔ x ∈ a ∨ x ∈ b := iff.rfl

@[simp] theorem mem_union_eq (x : α) (a b : set α) : x ∈ a ∪ b = (x ∈ a ∨ x ∈ b) := rfl

@[simp] theorem union_self (a : set α) : a ∪ a = a :=
ext (assume x, or_self _)

@[simp] theorem union_empty (a : set α) : a ∪ ∅ = a :=
ext (assume x, or_false _)

@[simp] theorem empty_union (a : set α) : ∅ ∪ a = a :=
ext (assume x, false_or _)

theorem union_comm (a b : set α) : a ∪ b = b ∪ a :=
ext (assume x, or.comm)

theorem union_assoc (a b c : set α) : (a ∪ b) ∪ c = a ∪ (b ∪ c) :=
ext (assume x, or.assoc)

instance union_is_assoc : is_associative (set α) (∪) :=
⟨union_assoc⟩

instance union_is_comm : is_commutative (set α) (∪) :=
⟨union_comm⟩

theorem union_left_comm (s₁ s₂ s₃ : set α) : s₁ ∪ (s₂ ∪ s₃) = s₂ ∪ (s₁ ∪ s₃) :=
by finish

theorem union_right_comm (s₁ s₂ s₃ : set α) : (s₁ ∪ s₂) ∪ s₃ = (s₁ ∪ s₃) ∪ s₂ :=
by finish

theorem union_eq_self_of_subset_left {s t : set α} (h : s ⊆ t) : s ∪ t = t :=
by finish [subset_def, ext_iff, iff_def]

theorem union_eq_self_of_subset_right {s t : set α} (h : t ⊆ s) : s ∪ t = s :=
by finish [subset_def, ext_iff, iff_def]

@[simp] theorem subset_union_left (s t : set α) : s ⊆ s ∪ t := λ x, or.inl

@[simp] theorem subset_union_right (s t : set α) : t ⊆ s ∪ t := λ x, or.inr

theorem union_subset {s t r : set α} (sr : s ⊆ r) (tr : t ⊆ r) : s ∪ t ⊆ r :=
by finish [subset_def, union_def]

@[simp] theorem union_subset_iff {s t u : set α} : s ∪ t ⊆ u ↔ s ⊆ u ∧ t ⊆ u :=
by finish [iff_def, subset_def]

theorem union_subset_union {s₁ s₂ t₁ t₂ : set α} (h₁ : s₁ ⊆ s₂) (h₂ : t₁ ⊆ t₂) : s₁ ∪ t₁ ⊆ s₂ ∪ t₂ :=
by finish [subset_def]

theorem union_subset_union_left {s₁ s₂ : set α} (t) (h : s₁ ⊆ s₂) : s₁ ∪ t ⊆ s₂ ∪ t :=
union_subset_union h (by refl)

theorem union_subset_union_right (s) {t₁ t₂ : set α} (h : t₁ ⊆ t₂) : s ∪ t₁ ⊆ s ∪ t₂ :=
union_subset_union (by refl) h

@[simp] theorem union_empty_iff {s t : set α} : s ∪ t = ∅ ↔ s = ∅ ∧ t = ∅ :=
⟨by finish [ext_iff], by finish [ext_iff]⟩

/- intersection -/

theorem inter_def {s₁ s₂ : set α} : s₁ ∩ s₂ = {a | a ∈ s₁ ∧ a ∈ s₂} := rfl

theorem mem_inter_iff (x : α) (a b : set α) : x ∈ a ∩ b ↔ x ∈ a ∧ x ∈ b := iff.rfl

@[simp] theorem mem_inter_eq (x : α) (a b : set α) : x ∈ a ∩ b = (x ∈ a ∧ x ∈ b) := rfl

theorem mem_inter {x : α} {a b : set α} (ha : x ∈ a) (hb : x ∈ b) : x ∈ a ∩ b :=
⟨ha, hb⟩

theorem mem_of_mem_inter_left {x : α} {a b : set α} (h : x ∈ a ∩ b) : x ∈ a :=
h.left

theorem mem_of_mem_inter_right {x : α} {a b : set α} (h : x ∈ a ∩ b) : x ∈ b :=
h.right

@[simp] theorem inter_self (a : set α) : a ∩ a = a :=
ext (assume x, and_self _)

@[simp] theorem inter_empty (a : set α) : a ∩ ∅ = ∅ :=
ext (assume x, and_false _)

@[simp] theorem empty_inter (a : set α) : ∅ ∩ a = ∅ :=
ext (assume x, false_and _)

theorem inter_comm (a b : set α) : a ∩ b = b ∩ a :=
ext (assume x, and.comm)

theorem inter_assoc (a b c : set α) : (a ∩ b) ∩ c = a ∩ (b ∩ c) :=
ext (assume x, and.assoc)

instance inter_is_assoc : is_associative (set α) (∩) :=
⟨inter_assoc⟩

instance inter_is_comm : is_commutative (set α) (∩) :=
⟨inter_comm⟩

theorem inter_left_comm (s₁ s₂ s₃ : set α) : s₁ ∩ (s₂ ∩ s₃) = s₂ ∩ (s₁ ∩ s₃) :=
by finish

theorem inter_right_comm (s₁ s₂ s₃ : set α) : (s₁ ∩ s₂) ∩ s₃ = (s₁ ∩ s₃) ∩ s₂ :=
by finish

@[simp] theorem inter_subset_left (s t : set α) : s ∩ t ⊆ s := λ x H, and.left H

@[simp] theorem inter_subset_right (s t : set α) : s ∩ t ⊆ t := λ x H, and.right H

theorem subset_inter {s t r : set α} (rs : r ⊆ s) (rt : r ⊆ t) : r ⊆ s ∩ t :=
by finish [subset_def, inter_def]

@[simp] theorem subset_inter_iff {s t r : set α} : r ⊆ s ∩ t ↔ r ⊆ s ∧ r ⊆ t :=
⟨λ h, ⟨subset.trans h (inter_subset_left _ _), subset.trans h (inter_subset_right _ _)⟩,
 λ ⟨h₁, h₂⟩, subset_inter h₁ h₂⟩

@[simp] theorem inter_univ (a : set α) : a ∩ univ = a :=
ext (assume x, and_true _)

@[simp] theorem univ_inter (a : set α) : univ ∩ a = a :=
ext (assume x, true_and _)

theorem inter_subset_inter_left {s t : set α} (u : set α) (H : s ⊆ t) : s ∩ u ⊆ t ∩ u :=
by finish [subset_def]

theorem inter_subset_inter_right {s t : set α} (u : set α) (H : s ⊆ t) : u ∩ s ⊆ u ∩ t :=
by finish [subset_def]

theorem inter_subset_inter {s₁ s₂ t₁ t₂ : set α} (h₁ : s₁ ⊆ t₁) (h₂ : s₂ ⊆ t₂) : s₁ ∩ s₂ ⊆ t₁ ∩ t₂ :=
by finish [subset_def]

theorem inter_eq_self_of_subset_left {s t : set α} (h : s ⊆ t) : s ∩ t = s :=
by finish [subset_def, ext_iff, iff_def]

theorem inter_eq_self_of_subset_right {s t : set α} (h : t ⊆ s) : s ∩ t = t :=
by finish [subset_def, ext_iff, iff_def]

theorem union_inter_cancel_left {s t : set α} : (s ∪ t) ∩ s = s :=
by finish [ext_iff, iff_def]

theorem union_inter_cancel_right {s t : set α} : (s ∪ t) ∩ t = t :=
by finish [ext_iff, iff_def]

-- TODO(Mario): remove?
theorem nonempty_of_inter_nonempty_right {s t : set α} (h : s ∩ t ≠ ∅) : t ≠ ∅ :=
by finish [ext_iff, iff_def]

theorem nonempty_of_inter_nonempty_left {s t : set α} (h : s ∩ t ≠ ∅) : s ≠ ∅ :=
by finish [ext_iff, iff_def]

/- distributivity laws -/

theorem inter_distrib_left (s t u : set α) : s ∩ (t ∪ u) = (s ∩ t) ∪ (s ∩ u) :=
ext (assume x, and_or_distrib_left)

theorem inter_distrib_right (s t u : set α) : (s ∪ t) ∩ u = (s ∩ u) ∪ (t ∩ u) :=
ext (assume x, or_and_distrib_right)

theorem union_distrib_left (s t u : set α) : s ∪ (t ∩ u) = (s ∪ t) ∩ (s ∪ u) :=
ext (assume x, or_and_distrib_left)

theorem union_distrib_right (s t u : set α) : (s ∩ t) ∪ u = (s ∪ u) ∩ (t ∪ u) :=
ext (assume x, and_or_distrib_right)

/- insert -/

theorem insert_def (x : α) (s : set α) : insert x s = { y | y = x ∨ y ∈ s } := rfl

@[simp] theorem insert_of_has_insert (x : α) (s : set α) : has_insert.insert x s = insert x s := rfl

@[simp] theorem subset_insert (x : α) (s : set α) : s ⊆ insert x s :=
assume y ys, or.inr ys

theorem mem_insert (x : α) (s : set α) : x ∈ insert x s :=
or.inl rfl

theorem mem_insert_of_mem {x : α} {s : set α} (y : α) : x ∈ s → x ∈ insert y s := or.inr

theorem eq_or_mem_of_mem_insert {x a : α} {s : set α} : x ∈ insert a s → x = a ∨ x ∈ s := id

theorem mem_of_mem_insert_of_ne {x a : α} {s : set α} (xin : x ∈ insert a s) : x ≠ a → x ∈ s :=
by finish [insert_def]

@[simp] theorem mem_insert_iff {x a : α} {s : set α} : x ∈ insert a s ↔ (x = a ∨ x ∈ s) := iff.rfl

@[simp] theorem insert_eq_of_mem {a : α} {s : set α} (h : a ∈ s) : insert a s = s :=
by finish [ext_iff, iff_def]

theorem insert_subset : insert a s ⊆ t ↔ (a ∈ t ∧ s ⊆ t) :=
by simp [subset_def, or_imp_distrib, forall_and_distrib]

theorem insert_subset_insert (h : s ⊆ t) : insert a s ⊆ insert a t :=
assume a', or.imp_right (@h a')

theorem ssubset_insert {s : set α} {a : α} (h : a ∉ s) : s ⊂ insert a s :=
by finish [ssubset_def, ext_iff]

theorem insert_comm (a b : α) (s : set α) : insert a (insert b s) = insert b (insert a s) :=
ext $ by simp [or.left_comm]

theorem insert_union : insert a s ∪ t = insert a (s ∪ t) :=
ext $ assume a, by simp [or.comm, or.left_comm]

@[simp] theorem union_insert : s ∪ insert a t = insert a (s ∪ t) :=
ext $ assume a, by simp [or.comm, or.left_comm]

-- TODO(Jeremy): make this automatic
theorem insert_ne_empty (a : α) (s : set α) : insert a s ≠ ∅ :=
by safe [ext_iff, iff_def]; have h' := a_1 a; finish

-- useful in proofs by induction
theorem forall_of_forall_insert {P : α → Prop} {a : α} {s : set α} (h : ∀ x, x ∈ insert a s → P x) :
  ∀ x, x ∈ s → P x :=
by finish

theorem forall_insert_of_forall {P : α → Prop} {a : α} {s : set α} (h : ∀ x, x ∈ s → P x) (ha : P a) :
  ∀ x, x ∈ insert a s → P x :=
by finish

theorem ball_insert_iff {P : α → Prop} {a : α} {s : set α} :
  (∀ x ∈ insert a s, P x) ↔ P a ∧ (∀x ∈ s, P x) :=
by finish [iff_def]

/- singletons -/

theorem singleton_def (a : α) : ({a} : set α) = insert a ∅ := rfl

@[simp] theorem mem_singleton_iff {a b : α} : a ∈ ({b} : set α) ↔ a = b :=
by finish [singleton_def]

lemma set_of_eq_eq_singleton {a : α} : {n | n = a} = {a} := set.ext $ λ n, (set.mem_singleton_iff).symm

-- TODO: again, annotation needed
@[simp] theorem mem_singleton (a : α) : a ∈ ({a} : set α) := by finish

theorem eq_of_mem_singleton {x y : α} (h : x ∈ ({y} : set α)) : x = y :=
by finish

@[simp] theorem singleton_eq_singleton_iff {x y : α} : {x} = ({y} : set α) ↔ x = y :=
by finish [ext_iff, iff_def]

theorem mem_singleton_of_eq {x y : α} (H : x = y) : x ∈ ({y} : set α) :=
by finish

theorem insert_eq (x : α) (s : set α) : insert x s = ({x} : set α) ∪ s :=
by finish [ext_iff, or_comm]

@[simp] theorem pair_eq_singleton (a : α) : ({a, a} : set α) = {a} :=
by finish

@[simp] theorem singleton_ne_empty (a : α) : ({a} : set α) ≠ ∅ := insert_ne_empty _ _

@[simp] theorem singleton_subset_iff {a : α} {s : set α} : {a} ⊆ s ↔ a ∈ s :=
⟨λh, h (by simp), λh b e, by simp at e; simp [*]⟩

theorem set_compr_eq_eq_singleton {a : α} : {b | b = a} = {a} :=
ext $ by simp

@[simp] theorem union_singleton : s ∪ {a} = insert a s :=
by simp [singleton_def]

@[simp] theorem singleton_union : {a} ∪ s = insert a s :=
by rw [union_comm, union_singleton]

theorem singleton_inter_eq_empty : {a} ∩ s = ∅ ↔ a ∉ s :=
by simp [eq_empty_iff_forall_not_mem]

theorem inter_singleton_eq_empty : s ∩ {a} = ∅ ↔ a ∉ s :=
by rw [inter_comm, singleton_inter_eq_empty]

/- separation -/

theorem mem_sep {s : set α} {p : α → Prop} {x : α} (xs : x ∈ s) (px : p x) : x ∈ {x ∈ s | p x} :=
⟨xs, px⟩

@[simp] theorem mem_sep_eq {s : set α} {p : α → Prop} {x : α} : x ∈ {x ∈ s | p x} = (x ∈ s ∧ p x) := rfl

theorem mem_sep_iff {s : set α} {p : α → Prop} {x : α} : x ∈ {x ∈ s | p x} ↔ x ∈ s ∧ p x :=
iff.rfl

theorem eq_sep_of_subset {s t : set α} (ssubt : s ⊆ t) : s = {x ∈ t | x ∈ s} :=
by finish [ext_iff, iff_def, subset_def]

theorem sep_subset (s : set α) (p : α → Prop) : {x ∈ s | p x} ⊆ s :=
assume x, and.left

theorem forall_not_of_sep_empty {s : set α} {p : α → Prop} (h : {x ∈ s | p x} = ∅) :
  ∀ x ∈ s, ¬ p x :=
by finish [ext_iff]

@[simp] lemma sep_univ {α} {p : α → Prop} : {a ∈ (univ : set α) | p a} = {a | p a} :=
set.ext $ by simp

/- complement -/

theorem mem_compl {s : set α} {x : α} (h : x ∉ s) : x ∈ -s := h

lemma compl_set_of {α} (p : α → Prop) : - {a | p a} = { a | ¬ p a } := rfl

theorem not_mem_of_mem_compl {s : set α} {x : α} (h : x ∈ -s) : x ∉ s := h

@[simp] theorem mem_compl_eq (s : set α) (x : α) : x ∈ -s = (x ∉ s) := rfl

theorem mem_compl_iff (s : set α) (x : α) : x ∈ -s ↔ x ∉ s := iff.rfl

@[simp] theorem inter_compl_self (s : set α) : s ∩ -s = ∅ :=
by finish [ext_iff]

@[simp] theorem compl_inter_self (s : set α) : -s ∩ s = ∅ :=
by finish [ext_iff]

@[simp] theorem compl_empty : -(∅ : set α) = univ :=
by finish [ext_iff]

@[simp] theorem compl_union (s t : set α) : -(s ∪ t) = -s ∩ -t :=
by finish [ext_iff]

@[simp] theorem compl_compl (s : set α) : -(-s) = s :=
by finish [ext_iff]

-- ditto
theorem compl_inter (s t : set α) : -(s ∩ t) = -s ∪ -t :=
by finish [ext_iff]

@[simp] theorem compl_univ : -(univ : set α) = ∅ :=
by finish [ext_iff]

theorem union_eq_compl_compl_inter_compl (s t : set α) : s ∪ t = -(-s ∩ -t) :=
by simp [compl_inter, compl_compl]

theorem inter_eq_compl_compl_union_compl (s t : set α) : s ∩ t = -(-s ∪ -t) :=
by simp [compl_compl]

@[simp] theorem union_compl_self (s : set α) : s ∪ -s = univ :=
by finish [ext_iff]

@[simp] theorem compl_union_self (s : set α) : -s ∪ s = univ :=
by finish [ext_iff]

theorem compl_comp_compl : compl ∘ compl = @id (set α) :=
funext compl_compl

theorem compl_subset_comm {s t : set α} : -s ⊆ t ↔ -t ⊆ s :=
by haveI := classical.prop_decidable; exact
forall_congr (λ a, not_imp_comm)

lemma compl_subset_compl {s t : set α} : -s ⊆ -t ↔ t ⊆ s :=
by rw [compl_subset_comm, compl_compl]

theorem compl_subset_iff_union {s t : set α} : -s ⊆ t ↔ s ∪ t = univ :=
iff.symm $ eq_univ_iff_forall.trans $ forall_congr $ λ a,
by haveI := classical.prop_decidable; exact or_iff_not_imp_left

theorem subset_compl_comm {s t : set α} : s ⊆ -t ↔ t ⊆ -s :=
forall_congr $ λ a, imp_not_comm

theorem subset_compl_iff_disjoint {s t : set α} : s ⊆ -t ↔ s ∩ t = ∅ :=
iff.trans (forall_congr $ λ a, and_imp.symm) subset_empty_iff

theorem inter_subset (a b c : set α) : a ∩ b ⊆ c ↔ a ⊆ -b ∪ c :=
begin
  haveI := classical.prop_decidable,
  split,
  { intros h x xa, by_cases h' : x ∈ b, simp [h ⟨xa, h'⟩], simp [h'] },
  intros h x, rintro ⟨xa, xb⟩, cases h xa, contradiction, assumption
end

/- set difference -/

theorem diff_eq (s t : set α) : s \ t = s ∩ -t := rfl

@[simp] theorem mem_diff {s t : set α} (x : α) : x ∈ s \ t ↔ x ∈ s ∧ x ∉ t := iff.rfl

theorem mem_diff_of_mem {s t : set α} {x : α} (h1 : x ∈ s) (h2 : x ∉ t) : x ∈ s \ t :=
⟨h1, h2⟩

theorem mem_of_mem_diff {s t : set α} {x : α} (h : x ∈ s \ t) : x ∈ s :=
h.left

theorem not_mem_of_mem_diff {s t : set α} {x : α} (h : x ∈ s \ t) : x ∉ t :=
h.right

theorem union_diff_cancel {s t : set α} (h : s ⊆ t) : s ∪ (t \ s) = t :=
by finish [ext_iff, iff_def, subset_def]

theorem union_diff_cancel_left {s t : set α} (h : s ∩ t ⊆ ∅) : (s ∪ t) \ s = t :=
by finish [ext_iff, iff_def, subset_def]

theorem union_diff_cancel_right {s t : set α} (h : s ∩ t ⊆ ∅) : (s ∪ t) \ t = s :=
by finish [ext_iff, iff_def, subset_def]

theorem union_diff_left {s t : set α} : (s ∪ t) \ s = t \ s :=
by finish [ext_iff, iff_def]

theorem union_diff_right {s t : set α} : (s ∪ t) \ t = s \ t :=
by finish [ext_iff, iff_def]

theorem union_diff_distrib {s t u : set α} : (s ∪ t) \ u = s \ u ∪ t \ u :=
inter_distrib_right _ _ _

theorem inter_diff_assoc (a b c : set α) : (a ∩ b) \ c = a ∩ (b \ c) :=
inter_assoc _ _ _

theorem inter_diff_self (a b : set α) : a ∩ (b \ a) = ∅ :=
by finish [ext_iff]

theorem inter_union_diff (s t : set α) : (s ∩ t) ∪ (s \ t) = s :=
by finish [ext_iff, iff_def]

theorem diff_subset (s t : set α) : s \ t ⊆ s :=
by finish [subset_def]

theorem diff_subset_diff {s₁ s₂ t₁ t₂ : set α} : s₁ ⊆ s₂ → t₂ ⊆ t₁ → s₁ \ t₁ ⊆ s₂ \ t₂ :=
by finish [subset_def]

theorem diff_subset_diff_left {s₁ s₂ t : set α} (h : s₁ ⊆ s₂) : s₁ \ t ⊆ s₂ \ t :=
diff_subset_diff h (by refl)

theorem diff_subset_diff_right {s t u : set α} (h : t ⊆ u) : s \ u ⊆ s \ t :=
diff_subset_diff (subset.refl s) h

theorem compl_eq_univ_diff (s : set α) : -s = univ \ s :=
by finish [ext_iff]

@[simp] lemma empty_diff {α : Type*} (s : set α) : (∅ \ s : set α) = ∅ :=
eq_empty_of_subset_empty $ assume x ⟨hx, _⟩, hx

theorem diff_eq_empty {s t : set α} : s \ t = ∅ ↔ s ⊆ t :=
⟨assume h x hx, classical.by_contradiction $ assume : x ∉ t, show x ∈ (∅ : set α), from h ▸ ⟨hx, this⟩,
  assume h, eq_empty_of_subset_empty $ assume x ⟨hx, hnx⟩, hnx $ h hx⟩

@[simp] theorem diff_empty {s : set α} : s \ ∅ = s :=
ext $ assume x, ⟨assume ⟨hx, _⟩, hx, assume h, ⟨h, not_false⟩⟩

theorem diff_diff {u : set α} : s \ t \ u = s \ (t ∪ u) :=
ext $ by simp [not_or_distrib, and.comm, and.left_comm]

lemma diff_subset_iff {s t u : set α} : s \ t ⊆ u ↔ s ⊆ t ∪ u :=
⟨assume h x xs, classical.by_cases or.inl (assume nxt, or.inr (h ⟨xs, nxt⟩)),
 assume h x ⟨xs, nxt⟩, or.resolve_left (h xs) nxt⟩

lemma diff_subset_comm {s t u : set α} : s \ t ⊆ u ↔ s \ u ⊆ t :=
by rw [diff_subset_iff, diff_subset_iff, union_comm]

@[simp] theorem insert_diff (h : a ∈ t) : insert a s \ t = s \ t :=
ext $ by intro; constructor; simp [or_imp_distrib, h] {contextual := tt}

theorem union_diff_self {s t : set α} : s ∪ (t \ s) = s ∪ t :=
by finish [ext_iff, iff_def]

theorem diff_union_self {s t : set α} : (s \ t) ∪ t = s ∪ t :=
by rw [union_comm, union_diff_self, union_comm]

theorem diff_inter_self {a b : set α} : (b \ a) ∩ a = ∅ :=
ext $ by simp [iff_def] {contextual:=tt}

theorem diff_eq_self {s t : set α} : s \ t = s ↔ t ∩ s ⊆ ∅ :=
by finish [ext_iff, iff_def, subset_def]

@[simp] theorem diff_singleton_eq_self {a : α} {s : set α} (h : a ∉ s) : s \ {a} = s :=
diff_eq_self.2 $ by simp [singleton_inter_eq_empty.2 h]

@[simp] theorem insert_diff_singleton {a : α} {s : set α} :
  insert a (s \ {a}) = insert a s :=
by simp [insert_eq, union_diff_self, -union_singleton, -singleton_union]

@[simp] lemma diff_self {s : set α} : s \ s = ∅ := ext $ by simp

/- powerset -/

theorem mem_powerset {x s : set α} (h : x ⊆ s) : x ∈ powerset s := h

theorem subset_of_mem_powerset {x s : set α} (h : x ∈ powerset s) : x ⊆ s := h

theorem mem_powerset_iff (x s : set α) : x ∈ powerset s ↔ x ⊆ s := iff.rfl

/- inverse image -/

/-- The preimage of `s : set β` by `f : α → β`, written `f ⁻¹' s`,
  is the set of `x : α` such that `f x ∈ s`. -/
def preimage {α : Type u} {β : Type v} (f : α → β) (s : set β) : set α := {x | f x ∈ s}

infix ` ⁻¹' `:80 := preimage

section preimage
variables {f : α → β} {g : β → γ}

@[simp] theorem preimage_empty : f ⁻¹' ∅ = ∅ := rfl

@[simp] theorem mem_preimage_eq {s : set β} {a : α} : (a ∈ f ⁻¹' s) = (f a ∈ s) := rfl

theorem preimage_mono {s t : set β} (h : s ⊆ t) : f ⁻¹' s ⊆ f ⁻¹' t :=
assume x hx, h hx

@[simp] theorem preimage_univ : f ⁻¹' univ = univ := rfl

@[simp] theorem preimage_inter {s t : set β} : f ⁻¹' (s ∩ t) = f ⁻¹' s ∩ f ⁻¹' t := rfl

@[simp] theorem preimage_union {s t : set β} : f ⁻¹' (s ∪ t) = f ⁻¹' s ∪ f ⁻¹' t := rfl

@[simp] theorem preimage_compl {s : set β} : f ⁻¹' (- s) = - (f ⁻¹' s) := rfl

@[simp] theorem preimage_diff (f : α → β) (s t : set β) :
  f ⁻¹' (s \ t) = f ⁻¹' s \ f ⁻¹' t := rfl

@[simp] theorem preimage_set_of_eq {p : α → Prop} {f : β → α} : f ⁻¹' {a | p a} = {a | p (f a)} :=
rfl

theorem preimage_id {s : set α} : id ⁻¹' s = s := rfl

theorem preimage_comp {s : set γ} : (g ∘ f) ⁻¹' s = f ⁻¹' (g ⁻¹' s) := rfl

theorem eq_preimage_subtype_val_iff {p : α → Prop} {s : set (subtype p)} {t : set α} :
  s = subtype.val ⁻¹' t ↔ (∀x (h : p x), (⟨x, h⟩ : subtype p) ∈ s ↔ x ∈ t) :=
⟨assume s_eq x h, by rw [s_eq]; simp,
 assume h, ext $ assume ⟨x, hx⟩, by simp [h]⟩

end preimage

/- function image -/

section image

infix ` '' `:80 := image

/-- Two functions `f₁ f₂ : α → β` are equal on `s`
  if `f₁ x = f₂ x` for all `x ∈ a`. -/
@[reducible] def eq_on (f1 f2 : α → β) (a : set α) : Prop :=
∀ x ∈ a, f1 x = f2 x

-- TODO(Jeremy): use bounded exists in image

theorem mem_image_iff_bex {f : α → β} {s : set α} {y : β} :
  y ∈ f '' s ↔ ∃ x (_ : x ∈ s), f x = y := bex_def.symm

theorem mem_image_eq (f : α → β) (s : set α) (y: β) : y ∈ f '' s = ∃ x, x ∈ s ∧ f x = y := rfl

@[simp] theorem mem_image (f : α → β) (s : set α) (y : β) : y ∈ f '' s ↔ ∃ x, x ∈ s ∧ f x = y := iff.rfl

theorem mem_image_of_mem (f : α → β) {x : α} {a : set α} (h : x ∈ a) : f x ∈ f '' a :=
⟨_, h, rfl⟩

theorem mem_image_of_injective {f : α → β} {a : α} {s : set α} (hf : injective f) :
  f a ∈ f '' s ↔ a ∈ s :=
iff.intro
  (assume ⟨b, hb, eq⟩, (hf eq) ▸ hb)
  (assume h, mem_image_of_mem _ h)

theorem ball_image_of_ball {f : α → β} {s : set α} {p : β → Prop}
  (h : ∀ x ∈ s, p (f x)) : ∀ y ∈ f '' s, p y :=
by finish [mem_image_eq]

@[simp] theorem ball_image_iff {f : α → β} {s : set α} {p : β → Prop} :
  (∀ y ∈ f '' s, p y) ↔ (∀ x ∈ s, p (f x)) :=
iff.intro
  (assume h a ha, h _ $ mem_image_of_mem _ ha)
  (assume h b ⟨a, ha, eq⟩, eq ▸ h a ha)

theorem mono_image {f : α → β} {s t : set α} (h : s ⊆ t) : f '' s ⊆ f '' t :=
assume x ⟨y, hy, y_eq⟩, y_eq ▸ mem_image_of_mem _ $ h hy

theorem mem_image_elim {f : α → β} {s : set α} {C : β → Prop} (h : ∀ (x : α), x ∈ s → C (f x)) :
 ∀{y : β}, y ∈ f '' s → C y
| ._ ⟨a, a_in, rfl⟩ := h a a_in

theorem mem_image_elim_on {f : α → β} {s : set α} {C : β → Prop} {y : β} (h_y : y ∈ f '' s)
  (h : ∀ (x : α), x ∈ s → C (f x)) : C y :=
mem_image_elim h h_y

@[congr] lemma image_congr {f g : α → β} {s : set α}
  (h : ∀a∈s, f a = g a) : f '' s = g '' s :=
by safe [ext_iff, iff_def]

theorem image_eq_image_of_eq_on {f₁ f₂ : α → β} {s : set α} (heq : eq_on f₁ f₂ s) :
  f₁ '' s = f₂ '' s :=
image_congr heq

theorem image_comp (f : β → γ) (g : α → β) (a : set α) : (f ∘ g) '' a = f '' (g '' a) :=
subset.antisymm
  (ball_image_of_ball $ assume a ha, mem_image_of_mem _ $ mem_image_of_mem _ ha)
  (ball_image_of_ball $ ball_image_of_ball $ assume a ha, mem_image_of_mem _ ha)
/- Proof is removed as it uses generated names
TODO(Jeremy): make automatic,
begin
  safe [ext_iff, iff_def, mem_image, (∘)],
  have h' := h_2 (g a_2),
  finish
end -/

theorem image_subset {a b : set α} (f : α → β) (h : a ⊆ b) : f '' a ⊆ f '' b :=
by finish [subset_def, mem_image_eq]

theorem image_union (f : α → β) (s t : set α) :
  f '' (s ∪ t) = f '' s ∪ f '' t :=
by finish [ext_iff, iff_def, mem_image_eq]

@[simp] theorem image_empty (f : α → β) : f '' ∅ = ∅ := ext $ by simp

theorem image_inter_on {f : α → β} {s t : set α} (h : ∀x∈t, ∀y∈s, f x = f y → x = y) :
  f '' s ∩ f '' t = f '' (s ∩ t) :=
subset.antisymm
  (assume b ⟨⟨a₁, ha₁, h₁⟩, ⟨a₂, ha₂, h₂⟩⟩,
    have a₂ = a₁, from h _ ha₂ _ ha₁ (by simp *),
    ⟨a₁, ⟨ha₁, this ▸ ha₂⟩, h₁⟩)
  (subset_inter (mono_image $ inter_subset_left _ _) (mono_image $ inter_subset_right _ _))

theorem image_inter {f : α → β} {s t : set α} (H : injective f) :
  f '' s ∩ f '' t = f '' (s ∩ t) :=
image_inter_on (assume x _ y _ h, H h)

theorem image_univ_of_surjective {ι : Type*} {f : ι → β} (H : surjective f) : f '' univ = univ :=
eq_univ_of_forall $ by simp [image]; exact H

@[simp] theorem image_singleton {f : α → β} {a : α} : f '' {a} = {f a} :=
ext $ λ x, by simp [image]; rw eq_comm

@[simp] lemma image_eq_empty {α β} {f : α → β} {s : set α} : f '' s = ∅ ↔ s = ∅ :=
by simp only [eq_empty_iff_forall_not_mem]; exact
⟨λ H a ha, H _ ⟨_, ha, rfl⟩, λ H b ⟨_, ha, _⟩, H _ ha⟩

lemma inter_singleton_ne_empty {α : Type*} {s : set α} {a : α} : s ∩ {a} ≠ ∅ ↔ a ∈ s :=
by finish  [set.inter_singleton_eq_empty]

theorem fix_set_compl (t : set α) : compl t = - t := rfl

-- TODO(Jeremy): there is an issue with - t unfolding to compl t
theorem mem_compl_image (t : set α) (S : set (set α)) :
  t ∈ compl '' S ↔ -t ∈ S :=
begin
  suffices : ∀ x, -x = t ↔ -t = x, {simp [fix_set_compl, this]},
  intro x, split; { intro e, subst e, simp }
end

@[simp] theorem image_id (s : set α) : id '' s = s := ext $ by simp

theorem compl_compl_image (S : set (set α)) :
  compl '' (compl '' S) = S :=
by rw [← image_comp, compl_comp_compl, image_id]

theorem image_insert_eq {f : α → β} {a : α} {s : set α} :
  f '' (insert a s) = insert (f a) (f '' s) :=
ext $ by simp [and_or_distrib_left, exists_or_distrib, eq_comm, or_comm, and_comm]

theorem image_subset_preimage_of_inverse {f : α → β} {g : β → α}
  (I : left_inverse g f) (s : set α) : f '' s ⊆ g ⁻¹' s :=
λ b ⟨a, h, e⟩, e ▸ ((I a).symm ▸ h : g (f a) ∈ s)

theorem preimage_subset_image_of_inverse {f : α → β} {g : β → α}
  (I : left_inverse g f) (s : set β) : f ⁻¹' s ⊆ g '' s :=
λ b h, ⟨f b, h, I b⟩

theorem image_eq_preimage_of_inverse {f : α → β} {g : β → α}
  (h₁ : left_inverse g f) (h₂ : right_inverse g f) :
  image f = preimage g :=
funext $ λ s, subset.antisymm
  (image_subset_preimage_of_inverse h₁ s)
  (preimage_subset_image_of_inverse h₂ s)

theorem mem_image_iff_of_inverse {f : α → β} {g : β → α} {b : β} {s : set α}
  (h₁ : left_inverse g f) (h₂ : right_inverse g f) :
  b ∈ f '' s ↔ g b ∈ s :=
by rw image_eq_preimage_of_inverse h₁ h₂; refl

theorem image_compl_subset {f : α → β} {s : set α} (H : injective f) : f '' -s ⊆ -(f '' s) :=
subset_compl_iff_disjoint.2 $ by simp [image_inter H]

theorem subset_image_compl {f : α → β} {s : set α} (H : surjective f) : -(f '' s) ⊆ f '' -s :=
compl_subset_iff_union.2 $
by rw ← image_union; simp [image_univ_of_surjective H]

theorem image_compl_eq {f : α → β} {s : set α} (H : bijective f) : f '' -s = -(f '' s) :=
subset.antisymm (image_compl_subset H.1) (subset_image_compl H.2)

/- image and preimage are a Galois connection -/
theorem image_subset_iff {s : set α} {t : set β} {f : α → β} :
  f '' s ⊆ t ↔ s ⊆ f ⁻¹' t :=
ball_image_iff

theorem image_preimage_subset (f : α → β) (s : set β) :
  f '' (f ⁻¹' s) ⊆ s :=
image_subset_iff.2 (subset.refl _)

theorem subset_preimage_image (f : α → β) (s : set α) :
  s ⊆ f ⁻¹' (f '' s) :=
λ x, mem_image_of_mem f

theorem preimage_image_eq {f : α → β} (s : set α) (h : injective f) : f ⁻¹' (f '' s) = s :=
subset.antisymm
  (λ x ⟨y, hy, e⟩, h e ▸ hy)
  (subset_preimage_image f s)

theorem image_preimage_eq {f : α → β} {s : set β} (h : surjective f) : f '' (f ⁻¹' s) = s :=
subset.antisymm
  (image_preimage_subset f s)
  (λ x hx, let ⟨y, e⟩ := h x in ⟨y, (e.symm ▸ hx : f y ∈ s), e⟩)

lemma preimage_eq_preimage {f : β → α} (hf : surjective f) : f ⁻¹' s = preimage f t ↔ s = t :=
iff.intro
  (assume eq, by rw [← @image_preimage_eq β α f s hf, ← @image_preimage_eq β α f t hf, eq])
  (assume eq, eq ▸ rfl)

lemma surjective_preimage {f : β → α} (hf : surjective f) : injective (preimage f) :=
assume s t, (preimage_eq_preimage hf).1

theorem compl_image : image (@compl α) = preimage compl :=
image_eq_preimage_of_inverse compl_compl compl_compl

theorem compl_image_set_of {α : Type u} {p : set α → Prop} :
  compl '' {x | p x} = {x | p (- x)} :=
congr_fun compl_image p

theorem inter_preimage_subset (s : set α) (t : set β) (f : α → β) :
  s ∩ f ⁻¹' t ⊆ f ⁻¹' (f '' s ∩ t) :=
λ x h, ⟨mem_image_of_mem _ h.left, h.right⟩

theorem union_preimage_subset (s : set α) (t : set β) (f : α → β) :
  s ∪ f ⁻¹' t ⊆ f ⁻¹' (f '' s ∪ t) :=
λ x h, or.elim h (λ l, or.inl $ mem_image_of_mem _ l) (λ r, or.inr r)

theorem subset_image_union (f : α → β) (s : set α) (t : set β) :
  f '' (s ∪ f ⁻¹' t) ⊆ f '' s ∪ t :=
image_subset_iff.2 (union_preimage_subset _ _ _)

lemma preimage_subset_iff {A : set α} {B : set β} {f : α → β} :
  f⁻¹' B ⊆ A ↔ (∀ a : α, f a ∈ B → a ∈ A) := iff.rfl

lemma image_eq_image {f : α → β} (hf : injective f) : f '' s = f '' t ↔ s = t :=
iff.symm $ iff.intro (assume eq, eq ▸ rfl) $ assume eq,
  by rw [← preimage_image_eq s hf, ← preimage_image_eq t hf, eq]

lemma image_subset_image_iff {f : α → β} (hf : injective f) : f '' s ⊆ f '' t ↔ s ⊆ t :=
begin
  refine (iff.symm $ iff.intro (image_subset f) $ assume h, _),
  rw [← preimage_image_eq s hf, ← preimage_image_eq t hf],
  exact preimage_mono h
end

lemma injective_image {f : α → β} (hf : injective f) : injective (('') f) :=
assume s t, (image_eq_image hf).1

lemma prod_quotient_preimage_eq_image [s : setoid α] (g : quotient s → β) {h : α → β}
  (Hh : h = g ∘ quotient.mk) (r : set (β × β)) :
  {x : quotient s × quotient s | (g x.1, g x.2) ∈ r} =
  (λ a : α × α, (⟦a.1⟧, ⟦a.2⟧)) '' ((λ a : α × α, (h a.1, h a.2)) ⁻¹' r) :=
Hh.symm ▸ set.ext (λ ⟨a₁, a₂⟩, ⟨quotient.induction_on₂ a₁ a₂
  (λ a₁ a₂ h, ⟨(a₁, a₂), h, rfl⟩),
  λ ⟨⟨b₁, b₂⟩, h₁, h₂⟩, show (g a₁, g a₂) ∈ r, from
  have h₃ : ⟦b₁⟧ = a₁ ∧ ⟦b₂⟧ = a₂ := prod.ext_iff.1 h₂,
    h₃.1 ▸ h₃.2 ▸ h₁⟩)

def image_factorization (f : α → β) (s : set α) : s → f '' s :=
λ p, ⟨f p.1, mem_image_of_mem f p.2⟩

lemma image_factorization_eq {f : α → β} {s : set α} :
  subtype.val ∘ image_factorization f s = f ∘ subtype.val :=
funext $ λ p, rfl

lemma surjective_onto_image {f : α → β} {s : set α} :
  surjective (image_factorization f s) :=
λ ⟨_, ⟨a, ha, rfl⟩⟩, ⟨⟨a, ha⟩, rfl⟩

end image

theorem univ_eq_true_false : univ = ({true, false} : set Prop) :=
eq.symm $ eq_univ_of_forall $ classical.cases (by simp) (by simp)

section range
variables {f : ι → α}
open function

/-- Range of a function.

This function is more flexible than `f '' univ`, as the image requires that the domain is in Type
and not an arbitrary Sort. -/
def range (f : ι → α) : set α := {x | ∃y, f y = x}

@[simp] theorem mem_range {x : α} : x ∈ range f ↔ ∃ y, f y = x := iff.rfl

theorem mem_range_self (i : ι) : f i ∈ range f := ⟨i, rfl⟩

theorem forall_range_iff {p : α → Prop} : (∀ a ∈ range f, p a) ↔ (∀ i, p (f i)) :=
⟨assume h i, h (f i) (mem_range_self _), assume h a ⟨i, (hi : f i = a)⟩, hi ▸ h i⟩

theorem exists_range_iff {p : α → Prop} : (∃ a ∈ range f, p a) ↔ (∃ i, p (f i)) :=
⟨assume ⟨a, ⟨i, eq⟩, h⟩, ⟨i, eq.symm ▸ h⟩, assume ⟨i, h⟩, ⟨f i, mem_range_self _, h⟩⟩

theorem range_iff_surjective : range f = univ ↔ surjective f :=
eq_univ_iff_forall

@[simp] theorem range_id : range (@id α) = univ := range_iff_surjective.2 surjective_id

@[simp] theorem image_univ {ι : Type*} {f : ι → β} : f '' univ = range f :=
ext $ by simp [image, range]

theorem image_subset_range {ι : Type*} (f : ι → β) (s : set ι) : f '' s ⊆ range f :=
by rw ← image_univ; exact image_subset _ (subset_univ _)

theorem range_comp {g : α → β} : range (g ∘ f) = g '' range f :=
subset.antisymm
  (forall_range_iff.mpr $ assume i, mem_image_of_mem g (mem_range_self _))
  (ball_image_iff.mpr $ forall_range_iff.mpr mem_range_self)

theorem range_subset_iff {ι : Type*} {f : ι → β} {s : set β} : range f ⊆ s ↔ ∀ y, f y ∈ s :=
forall_range_iff

lemma nonempty_of_nonempty_range {α : Type*} {β : Type*} {f : α → β} (H : ¬range f = ∅) : nonempty α :=
begin
  cases exists_mem_of_ne_empty H with x h,
  cases mem_range.1 h with y _,
  exact ⟨y⟩
end

@[simp] lemma range_eq_empty {α : Type u} {β : Type v} {f : α → β} : range f = ∅ ↔ ¬ nonempty α :=
by rw ← set.image_univ; simp [-set.image_univ]

theorem image_preimage_eq_inter_range {f : α → β} {t : set β} :
  f '' (f ⁻¹' t) = t ∩ range f :=
ext $ assume x, ⟨assume ⟨x, hx, heq⟩, heq ▸ ⟨hx, mem_range_self _⟩,
  assume ⟨hx, ⟨y, h_eq⟩⟩, h_eq ▸ mem_image_of_mem f $
    show y ∈ f ⁻¹' t, by simp [preimage, h_eq, hx]⟩

lemma image_preimage_eq_of_subset {f : α → β} {s : set β} (hs : s ⊆ range f) :
  f '' (f ⁻¹' s) = s :=
by rw [image_preimage_eq_inter_range, inter_eq_self_of_subset_left hs]

theorem preimage_inter_range {f : α → β} {s : set β} : f ⁻¹' (s ∩ range f) = f ⁻¹' s :=
set.ext $ λ x, and_iff_left ⟨x, rfl⟩

theorem preimage_image_preimage {f : α → β} {s : set β} :
  f ⁻¹' (f '' (f ⁻¹' s)) = f ⁻¹' s :=
by rw [image_preimage_eq_inter_range, preimage_inter_range]

@[simp] theorem quot_mk_range_eq [setoid α] : range (λx : α, ⟦x⟧) = univ :=
range_iff_surjective.2 quot.exists_rep

lemma range_const_subset {c : β} : range (λx:α, c) ⊆ {c} :=
range_subset_iff.2 $ λ x, or.inl rfl

@[simp] lemma range_const [h : nonempty α] {c : β} : range (λx:α, c) = {c} :=
begin
  refine subset.antisymm range_const_subset (λy hy, _),
  rw set.mem_singleton_iff.1 hy,
  rcases exists_mem_of_nonempty α with ⟨x, _⟩,
  exact mem_range_self x
end

def range_factorization (f : ι → β) : ι → range f :=
λ i, ⟨f i, mem_range_self i⟩

lemma range_factorization_eq {f : ι → β} :
  subtype.val ∘ range_factorization f = f :=
funext $ λ i, rfl

lemma surjective_onto_range : surjective (range_factorization f) :=
λ ⟨_, ⟨i, rfl⟩⟩, ⟨i, rfl⟩

end range

/-- The set `s` is pairwise `r` if `r x y` for all *distinct* `x y ∈ s`. -/
def pairwise_on (s : set α) (r : α → α → Prop) := ∀ x ∈ s, ∀ y ∈ s, x ≠ y → r x y

theorem pairwise_on.mono {s t : set α} {r}
  (h : t ⊆ s) (hp : pairwise_on s r) : pairwise_on t r :=
λ x xt y yt, hp x (h xt) y (h yt)

theorem pairwise_on.mono' {s : set α} {r r' : α → α → Prop}
  (H : ∀ a b, r a b → r' a b) (hp : pairwise_on s r) : pairwise_on s r' :=
λ x xs y ys h, H _ _ (hp x xs y ys h)

end set

/- image and preimage on subtypes -/

namespace subtype

variable {α : Type*}

lemma val_image {p : α → Prop} {s : set (subtype p)} :
  subtype.val '' s = {x | ∃h : p x, (⟨x, h⟩ : subtype p) ∈ s} :=
set.ext $ assume a,
⟨assume ⟨⟨a', ha'⟩, in_s, h_eq⟩, h_eq ▸ ⟨ha', in_s⟩,
  assume ⟨ha, in_s⟩, ⟨⟨a, ha⟩, in_s, rfl⟩⟩

@[simp] lemma val_range {p : α → Prop} :
  set.range (@subtype.val _ p) = {x | p x} :=
by rw ← set.image_univ; simp [-set.image_univ, val_image]
theorem val_image_subset (s : set α) (t : set (subtype s)) : t.image val ⊆ s :=
λ x ⟨y, yt, yvaleq⟩, by rw ←yvaleq; exact y.property

theorem val_image_univ (s : set α) : @val _ s '' set.univ = s :=
set.eq_of_subset_of_subset (val_image_subset _ _) (λ x xs, ⟨⟨x, xs⟩, ⟨set.mem_univ _, rfl⟩⟩)

theorem image_preimage_val (s t : set α) :
  (@subtype.val _ s) '' ((@subtype.val _ s) ⁻¹' t) = t ∩ s :=
begin
  ext x, simp, split,
  { rintros ⟨y, ys, yt, yx⟩, rw ←yx, exact ⟨yt, ys⟩ },
  rintros ⟨xt, xs⟩, exact ⟨x, xs, xt, rfl⟩
end

theorem preimage_val_eq_preimage_val_iff (s t u : set α) :
  ((@subtype.val _ s) ⁻¹' t = (@subtype.val _ s) ⁻¹' u) ↔ (t ∩ s = u ∩ s) :=
begin
  rw [←image_preimage_val, ←image_preimage_val],
  split, { intro h, rw h },
  intro h, exact set.injective_image (val_injective) h
end
end subtype

namespace set

section range

variable {α : Type*}

@[simp] lemma subtype.val_range {p : α → Prop} :
  range (@subtype.val _ p) = {x | p x} :=
by rw ← image_univ; simp [-image_univ, subtype.val_image]

@[simp] lemma range_coe_subtype (s : set α): range (coe : s → α) = s :=
subtype.val_range

end range

section prod

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}
variables {s s₁ s₂ : set α} {t t₁ t₂ : set β}

/-- The cartesian product `prod s t` is the set of `(a, b)`
  such that `a ∈ s` and `b ∈ t`. -/
protected def prod (s : set α) (t : set β) : set (α × β) :=
{p | p.1 ∈ s ∧ p.2 ∈ t}

lemma prod_eq (s : set α) (t : set β) : set.prod s t = prod.fst ⁻¹' s ∩ prod.snd ⁻¹' t := rfl

theorem mem_prod_eq {p : α × β} : p ∈ set.prod s t = (p.1 ∈ s ∧ p.2 ∈ t) := rfl

@[simp] theorem mem_prod {p : α × β} : p ∈ set.prod s t ↔ p.1 ∈ s ∧ p.2 ∈ t := iff.rfl

lemma mk_mem_prod {a : α} {b : β} (a_in : a ∈ s) (b_in : b ∈ t) : (a, b) ∈ set.prod s t := ⟨a_in, b_in⟩

@[simp] theorem prod_empty {s : set α} : set.prod s ∅ = (∅ : set (α × β)) :=
ext $ by simp [set.prod]

@[simp] theorem empty_prod {t : set β} : set.prod ∅ t = (∅ : set (α × β)) :=
ext $ by simp [set.prod]

theorem insert_prod {a : α} {s : set α} {t : set β} :
  set.prod (insert a s) t = (prod.mk a '' t) ∪ set.prod s t :=
ext begin simp [set.prod, image, iff_def, or_imp_distrib] {contextual := tt}; cc end

theorem prod_insert {b : β} {s : set α} {t : set β} :
  set.prod s (insert b t) = ((λa, (a, b)) '' s) ∪ set.prod s t :=
ext begin simp [set.prod, image, iff_def, or_imp_distrib] {contextual := tt}; cc end

theorem prod_preimage_eq {f : γ → α} {g : δ → β} :
  set.prod (preimage f s) (preimage g t) = preimage (λp, (f p.1, g p.2)) (set.prod s t) := rfl

theorem prod_mono {s₁ s₂ : set α} {t₁ t₂ : set β} (hs : s₁ ⊆ s₂) (ht : t₁ ⊆ t₂) :
  set.prod s₁ t₁ ⊆ set.prod s₂ t₂ :=
assume x ⟨h₁, h₂⟩, ⟨hs h₁, ht h₂⟩

theorem prod_inter_prod : set.prod s₁ t₁ ∩ set.prod s₂ t₂ = set.prod (s₁ ∩ s₂) (t₁ ∩ t₂) :=
subset.antisymm
  (assume ⟨a, b⟩ ⟨⟨ha₁, hb₁⟩, ⟨ha₂, hb₂⟩⟩, ⟨⟨ha₁, ha₂⟩, ⟨hb₁, hb₂⟩⟩)
  (subset_inter
    (prod_mono (inter_subset_left _ _) (inter_subset_left _ _))
    (prod_mono (inter_subset_right _ _) (inter_subset_right _ _)))

theorem image_swap_prod : (λp:β×α, (p.2, p.1)) '' set.prod t s = set.prod s t :=
ext $ assume ⟨a, b⟩, by simp [mem_image_eq, set.prod, and_comm]; exact
⟨ assume ⟨b', a', ⟨h_a, h_b⟩, h⟩, by subst a'; subst b'; assumption,
  assume h, ⟨b, a, ⟨rfl, rfl⟩, h⟩⟩

theorem image_swap_eq_preimage_swap : image (@prod.swap α β) = preimage prod.swap :=
image_eq_preimage_of_inverse prod.swap_left_inverse prod.swap_right_inverse

theorem prod_image_image_eq {m₁ : α → γ} {m₂ : β → δ} :
  set.prod (image m₁ s) (image m₂ t) = image (λp:α×β, (m₁ p.1, m₂ p.2)) (set.prod s t) :=
ext $ by simp [-exists_and_distrib_right, exists_and_distrib_right.symm, and.left_comm, and.assoc, and.comm]

theorem prod_range_range_eq {α β γ δ} {m₁ : α → γ} {m₂ : β → δ} :
  set.prod (range m₁) (range m₂) = range (λp:α×β, (m₁ p.1, m₂ p.2)) :=
ext $ by simp [range]

@[simp] theorem prod_singleton_singleton {a : α} {b : β} :
  set.prod {a} {b} = ({(a, b)} : set (α×β)) :=
ext $ by simp [set.prod]

theorem prod_neq_empty_iff {s : set α} {t : set β} :
  set.prod s t ≠ ∅ ↔ (s ≠ ∅ ∧ t ≠ ∅) :=
by simp [not_eq_empty_iff_exists]

theorem prod_eq_empty_iff {s : set α} {t : set β} :
  set.prod s t = ∅ ↔ (s = ∅ ∨ t = ∅) :=
suffices (¬ set.prod s t ≠ ∅) ↔ (¬ s ≠ ∅ ∨ ¬ t ≠ ∅), by simpa only [(≠), classical.not_not],
by classical; rw [prod_neq_empty_iff, not_and_distrib]

@[simp] theorem prod_mk_mem_set_prod_eq {a : α} {b : β} {s : set α} {t : set β} :
  (a, b) ∈ set.prod s t = (a ∈ s ∧ b ∈ t) := rfl

@[simp] theorem univ_prod_univ : set.prod (@univ α) (@univ β) = univ :=
ext $ assume ⟨a, b⟩, by simp

lemma prod_sub_preimage_iff {W : set γ} {f : α × β → γ} :
  set.prod s t ⊆ f ⁻¹' W ↔ ∀ a b, a ∈ s → b ∈ t → f (a, b) ∈ W :=
by simp [subset_def]

end prod

section pi
variables {α : Type*} {π : α → Type*}

def pi (i : set α) (s : Πa, set (π a)) : set (Πa, π a) := { f | ∀a∈i, f a ∈ s a }

@[simp] lemma pi_empty_index (s : Πa, set (π a)) : pi ∅ s = univ := by ext; simp [pi]

@[simp] lemma pi_insert_index (a : α) (i : set α) (s : Πa, set (π a)) :
  pi (insert a i) s = ((λf, f a) ⁻¹' s a) ∩ pi i s :=
by ext; simp [pi, or_imp_distrib, forall_and_distrib]

@[simp] lemma pi_singleton_index (a : α) (s : Πa, set (π a)) :
  pi {a} s = ((λf:(Πa, π a), f a) ⁻¹' s a) :=
by ext; simp [pi]

lemma pi_if {p : α → Prop} [h : decidable_pred p] (i : set α) (s t : Πa, set (π a)) :
  pi i (λa, if p a then s a else t a) = pi {a ∈ i | p a} s ∩ pi {a ∈ i | ¬ p a} t :=
begin
  ext f,
  split,
  { assume h, split; { rintros a ⟨hai, hpa⟩, simpa [*] using h a } },
  { rintros ⟨hs, ht⟩ a hai,
    by_cases p a; simp [*, pi] at * }
end

end pi

end set


/-
Copyright (c) 2020 Johan Commelin and Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johan Commelin, Robert Y. Lewis
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.ring_theory.witt_vector.basic
import Mathlib.ring_theory.witt_vector.is_poly
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!

# `init` and `tail`

Given a Witt vector `x`, we are sometimes interested
in its components before and after an index `n`.
This file defines those operations, proves that `init` is polynomial,
and shows how that polynomial interacts with `mv_polynomial.bind₁`.

## Main declarations

* `witt_vector.init n x`: the first `n` coefficients of `x`, as a Witt vector. All coefficients at
  indices ≥ `n` are 0.
* `witt_vector.tail n x`: the complementary part to `init`. All coefficients at indices < `n` are 0,
  otherwise they are the same as in `x`.
* `witt_vector.coeff_add_of_disjoint`: if `x` and `y` are Witt vectors such that for every `n`
  the `n`-th coefficient of `x` or of `y` is `0`, then the coefficients of `x + y`
  are just `x.coeff n + y.coeff n`.
-/

namespace tactic

namespace interactive

/--
`init_ring` is an auxiliary tactic that discharges goals factoring `init` over ring operations.
-/
end interactive

end tactic

namespace witt_vector

/-- `witt_vector.select P x`, for a predicate `P : ℕ → Prop` is the Witt vector
whose `n`-th coefficient is `x.coeff n` if `P n` is true, and `0` otherwise.
-/
def select {p : ℕ} {R : Type u_1} [comm_ring R] (P : ℕ → Prop) (x : witt_vector p R) :
    witt_vector p R :=
  mk p fun (n : ℕ) => ite (P n) (coeff x n) 0

/-- The polynomial that witnesses that `witt_vector.select` is a polynomial function.
`select_poly n` is `X n` if `P n` holds, and `0` otherwise. -/
def select_poly (P : ℕ → Prop) (n : ℕ) : mv_polynomial ℕ ℤ := ite (P n) (mv_polynomial.X n) 0

theorem coeff_select {p : ℕ} {R : Type u_1} [comm_ring R] (P : ℕ → Prop) (x : witt_vector p R)
    (n : ℕ) : coeff (select P x) n = coe_fn (mv_polynomial.aeval (coeff x)) (select_poly P n) :=
  sorry

theorem select_is_poly {p : ℕ} (P : ℕ → Prop) :
    is_poly p fun (R : Type u_1) (_Rcr : comm_ring R) (x : witt_vector p R) => select P x :=
  Exists.intro (select_poly P)
    (id
      fun (R : Type u_1) (_Rcr : comm_ring R) (x : witt_vector p R) =>
        funext fun (i : ℕ) => coeff_select P x i)

theorem select_add_select_not {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    (P : ℕ → Prop) (x : witt_vector p R) : select P x + select (fun (i : ℕ) => ¬P i) x = x :=
  sorry

theorem coeff_add_of_disjoint {p : ℕ} [hp : fact (nat.prime p)] (n : ℕ) {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (y : witt_vector p R) (h : ∀ (n : ℕ), coeff x n = 0 ∨ coeff y n = 0) :
    coeff (x + y) n = coeff x n + coeff y n :=
  sorry

/-- `witt_vector.init n x` is the Witt vector of which the first `n` coefficients are those from `x`
and all other coefficients are `0`.
See `witt_vector.tail` for the complementary part.
-/
def init {p : ℕ} {R : Type u_1} [comm_ring R] (n : ℕ) : witt_vector p R → witt_vector p R :=
  select fun (i : ℕ) => i < n

/-- `witt_vector.tail n x` is the Witt vector of which the first `n` coefficients are `0`
and all other coefficients are those from `x`.
See `witt_vector.init` for the complementary part. -/
def tail {p : ℕ} {R : Type u_1} [comm_ring R] (n : ℕ) : witt_vector p R → witt_vector p R :=
  select fun (i : ℕ) => n ≤ i

@[simp] theorem init_add_tail {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (n : ℕ) : init n x + tail n x = x :=
  sorry

@[simp] theorem init_init {p : ℕ} {R : Type u_1} [comm_ring R] (x : witt_vector p R) (n : ℕ) :
    init n (init n x) = init n x :=
  sorry

theorem init_add {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (y : witt_vector p R) (n : ℕ) :
    init n (x + y) = init n (init n x + init n y) :=
  sorry

theorem init_mul {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (y : witt_vector p R) (n : ℕ) :
    init n (x * y) = init n (init n x * init n y) :=
  sorry

theorem init_neg {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (n : ℕ) : init n (-x) = init n (-init n x) :=
  sorry

theorem init_sub {p : ℕ} [hp : fact (nat.prime p)] {R : Type u_1} [comm_ring R]
    (x : witt_vector p R) (y : witt_vector p R) (n : ℕ) :
    init n (x - y) = init n (init n x - init n y) :=
  sorry

/-- `witt_vector.init n x` is polynomial in the coefficients of `x`. -/
theorem init_is_poly (p : ℕ) (n : ℕ) :
    is_poly p fun (R : Type u_1) (_Rcr : comm_ring R) => init n :=
  select_is_poly fun (i : ℕ) => i < n

end Mathlib


/-
Copyright (c) 2017 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default

universes u

namespace Mathlib

namespace rbnode

inductive is_node_of {α : Type u} : rbnode α → rbnode α → α → rbnode α → Prop where
| of_red : ∀ (l : rbnode α) (v : α) (r : rbnode α), is_node_of (red_node l v r) l v r
| of_black : ∀ (l : rbnode α) (v : α) (r : rbnode α), is_node_of (black_node l v r) l v r

def lift {α : Type u} (lt : α → α → Prop) : Option α → Option α → Prop := sorry

inductive is_searchable {α : Type u} (lt : α → α → Prop) : rbnode α → Option α → Option α → Prop
    where
| leaf_s : ∀ {lo hi : Option α}, lift lt lo hi → is_searchable lt leaf lo hi
| red_s :
    ∀ {l r : rbnode α} {v : α} {lo hi : Option α},
      is_searchable lt l lo (some v) →
        is_searchable lt r (some v) hi → is_searchable lt (red_node l v r) lo hi
| black_s :
    ∀ {l r : rbnode α} {v : α} {lo hi : Option α},
      is_searchable lt l lo (some v) →
        is_searchable lt r (some v) hi → is_searchable lt (black_node l v r) lo hi

theorem lo_lt_hi {α : Type u} {t : rbnode α} {lt : α → α → Prop} [is_trans α lt] {lo : Option α}
    {hi : Option α} : is_searchable lt t lo hi → lift lt lo hi :=
  sorry

theorem is_searchable_of_is_searchable_of_incomp {α : Type u} {lt : α → α → Prop} [DecidableRel lt]
    [is_strict_weak_order α lt] {t : rbnode α} {lo : Option α} {hi : α} {hi' : α}
    (hc : ¬lt hi' hi ∧ ¬lt hi hi') (hs : is_searchable lt t lo (some hi)) :
    is_searchable lt t lo (some hi') :=
  sorry

theorem is_searchable_of_incomp_of_is_searchable {α : Type u} {lt : α → α → Prop} [DecidableRel lt]
    [is_strict_weak_order α lt] {t : rbnode α} {lo : α} {lo' : α} {hi : Option α}
    (hc : ¬lt lo' lo ∧ ¬lt lo lo') (hs : is_searchable lt t (some lo) hi) :
    is_searchable lt t (some lo') hi :=
  sorry

theorem is_searchable_some_low_of_is_searchable_of_lt {α : Type u} {lt : α → α → Prop}
    [DecidableRel lt] {t : rbnode α} [is_trans α lt] {lo : α} {hi : Option α} {lo' : α}
    (hlt : lt lo' lo) (hs : is_searchable lt t (some lo) hi) : is_searchable lt t (some lo') hi :=
  sorry

theorem is_searchable_none_low_of_is_searchable_some_low {α : Type u} {lt : α → α → Prop}
    [DecidableRel lt] {t : rbnode α} {y : α} {hi : Option α}
    (hlt : is_searchable lt t (some y) hi) : is_searchable lt t none hi :=
  sorry

theorem is_searchable_some_high_of_is_searchable_of_lt {α : Type u} {lt : α → α → Prop}
    [DecidableRel lt] {t : rbnode α} [is_trans α lt] {lo : Option α} {hi : α} {hi' : α}
    (hlt : lt hi hi') (hs : is_searchable lt t lo (some hi)) : is_searchable lt t lo (some hi') :=
  sorry

theorem is_searchable_none_high_of_is_searchable_some_high {α : Type u} {lt : α → α → Prop}
    [DecidableRel lt] {t : rbnode α} {lo : Option α} {y : α}
    (hlt : is_searchable lt t lo (some y)) : is_searchable lt t lo none :=
  sorry

theorem range {α : Type u} {lt : α → α → Prop} [DecidableRel lt] [is_strict_weak_order α lt]
    {t : rbnode α} {x : α} {lo : Option α} {hi : Option α} :
    is_searchable lt t lo hi → mem lt x t → lift lt lo (some x) ∧ lift lt (some x) hi :=
  sorry

theorem lt_of_mem_left {α : Type u} {lt : α → α → Prop} [DecidableRel lt]
    [is_strict_weak_order α lt] {y : α} {t : rbnode α} {l : rbnode α} {r : rbnode α} {lo : Option α}
    {hi : Option α} :
    is_searchable lt t lo hi → is_node_of t l y r → ∀ {x : α}, mem lt x l → lt x y :=
  sorry

theorem lt_of_mem_right {α : Type u} {lt : α → α → Prop} [DecidableRel lt]
    [is_strict_weak_order α lt] {y : α} {t : rbnode α} {l : rbnode α} {r : rbnode α} {lo : Option α}
    {hi : Option α} :
    is_searchable lt t lo hi → is_node_of t l y r → ∀ {z : α}, mem lt z r → lt y z :=
  sorry

theorem lt_of_mem_left_right {α : Type u} {lt : α → α → Prop} [DecidableRel lt]
    [is_strict_weak_order α lt] {y : α} {t : rbnode α} {l : rbnode α} {r : rbnode α} {lo : Option α}
    {hi : Option α} :
    is_searchable lt t lo hi → is_node_of t l y r → ∀ {x z : α}, mem lt x l → mem lt z r → lt x z :=
  sorry

inductive is_red_black {α : Type u} : rbnode α → color → ℕ → Prop where
| leaf_rb : is_red_black leaf color.black 0
| red_rb :
    ∀ {v : α} {l r : rbnode α} {n : ℕ},
      is_red_black l color.black n →
        is_red_black r color.black n → is_red_black (red_node l v r) color.red n
| black_rb :
    ∀ {v : α} {l r : rbnode α} {n : ℕ} {c₁ c₂ : color},
      is_red_black l c₁ n →
        is_red_black r c₂ n → is_red_black (black_node l v r) color.black (Nat.succ n)

theorem depth_min {α : Type u} {c : color} {n : ℕ} {t : rbnode α} :
    is_red_black t c n → depth min t ≥ n :=
  sorry

theorem depth_max' {α : Type u} {c : color} {n : ℕ} {t : rbnode α} :
    is_red_black t c n → depth max t ≤ upper c n :=
  sorry

theorem depth_max {α : Type u} {c : color} {n : ℕ} {t : rbnode α} (h : is_red_black t c n) :
    depth max t ≤ bit0 1 * n + 1 :=
  le_trans (depth_max' h) (upper_le c n)

theorem balanced {α : Type u} {c : color} {n : ℕ} {t : rbnode α} (h : is_red_black t c n) :
    bit0 1 * depth min t + 1 ≥ depth max t :=
  le_trans (depth_max h) (nat.succ_le_succ (nat.mul_le_mul_left (bit0 1) (depth_min h)))

end Mathlib


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.urysohns_lemma
import topology.continuous_function.bounded

/-!
# Metrizability of a normal topological space with second countable topology

In this file we define metrizable topological spaces, i.e., topological spaces for which there
exists a metric space structure that generates the same topology.

We also show that a normal topological space with second countable topology `X` is metrizable.

First we prove that `X` can be embedded into `l^∞`, then use this embedding to pull back the metric
space structure.
-/

open set filter metric
open_locale bounded_continuous_function filter topological_space

namespace topological_space

/-- A topological space is metrizable if there exists a metric space structure compatible with the
topology. To endow such a space with a compatible distance, use
`letI : metric_space α := metrizable_space_metric α` -/
class metrizable_space (α : Type*) [t : topological_space α] : Prop :=
(exists_metric : ∃ (m : metric_space α), m.to_uniform_space.to_topological_space = t)

@[priority 100]
instance _root_.metric_space.to_metrizable_space {α : Type*} [m : metric_space α] :
  metrizable_space α :=
⟨⟨m, rfl⟩⟩

/-- Construct on a metrizable space a metric compatible with the topology. -/
noncomputable def metrizable_space_metric
  (α : Type*) [topological_space α] [h : metrizable_space α] :
  metric_space α :=
h.exists_metric.some.replace_topology h.exists_metric.some_spec.symm

@[priority 100]
instance t2_space_of_metrizable_space
  (α : Type*) [topological_space α] [metrizable_space α] : t2_space α :=
by { letI : metric_space α := metrizable_space_metric α, apply_instance }

instance metrizable_space_prod (α : Type*) [topological_space α] [metrizable_space α]
  (β : Type*) [topological_space β] [metrizable_space β] :
  metrizable_space (α × β) :=
begin
  letI : metric_space α := metrizable_space_metric α,
  letI : metric_space β := metrizable_space_metric β,
  apply_instance
end

instance metrizable_space.subtype {α : Type*} [topological_space α] [metrizable_space α]
  (s : set α) : metrizable_space s :=
by { letI := metrizable_space_metric α, apply_instance }

/-- Given an embedding of a topological space into a metrizable space, the source space is also
metrizable. -/
lemma _root_.embedding.metrizable_space {α β : Type*} [topological_space α] [topological_space β]
  [metrizable_space β] {f : α → β} (hf : embedding f) :
  metrizable_space α :=
begin
  letI : metric_space β := metrizable_space_metric β,
  exact ⟨⟨hf.comap_metric_space f, rfl⟩⟩
end

variables (X : Type*) [topological_space X] [normal_space X] [second_countable_topology X]

/-- A normal topological space with second countable topology can be embedded into `l^∞ = ℕ →ᵇ ℝ`.
-/
lemma exists_embedding_l_infty : ∃ f : X → (ℕ →ᵇ ℝ), embedding f :=
begin
  -- Choose a countable basis, and consider the set `s` of pairs of set `(U, V)` such that `U ∈ B`,
  -- `V ∈ B`, and `closure U ⊆ V`.
  rcases exists_countable_basis X with ⟨B, hBc, -, hB⟩,
  set s : set (set X × set X) := {UV ∈ B ×ˢ B| closure UV.1 ⊆ UV.2},
  -- `s` is a countable set.
  haveI : encodable s := ((hBc.prod hBc).mono (inter_subset_left _ _)).to_encodable,
  -- We don't have the space of bounded (possibly discontinuous) functions, so we equip `s`
  -- with the discrete topology and deal with `s →ᵇ ℝ` instead.
  letI : topological_space s := ⊥, haveI : discrete_topology s := ⟨rfl⟩,
  suffices : ∃ f : X → (s →ᵇ ℝ), embedding f,
  { rcases this with ⟨f, hf⟩,
    exact ⟨λ x, (f x).extend (encodable.encode' s) 0, (bounded_continuous_function.isometry_extend
      (encodable.encode' s) (0 : ℕ →ᵇ ℝ)).embedding.comp hf⟩ },
  have hd : ∀ UV : s, disjoint (closure UV.1.1) (UV.1.2ᶜ) :=
    λ UV, disjoint_compl_right.mono_right (compl_subset_compl.2 UV.2.2),
  -- Choose a sequence of `εₙ > 0`, `n : s`, that is bounded above by `1` and tends to zero
  -- along the `cofinite` filter.
  obtain ⟨ε, ε01, hε⟩ : ∃ ε : s → ℝ, (∀ UV, ε UV ∈ Ioc (0 : ℝ) 1) ∧ tendsto ε cofinite (𝓝 0),
  { rcases pos_sum_of_encodable zero_lt_one s with ⟨ε, ε0, c, hεc, hc1⟩,
    refine ⟨ε, λ UV, ⟨ε0 UV, _⟩, hεc.summable.tendsto_cofinite_zero⟩,
    exact (le_has_sum hεc UV $ λ _ _, (ε0 _).le).trans hc1 },
  /- For each `UV = (U, V) ∈ s` we use Urysohn's lemma to choose a function `f UV` that is equal to
  zero on `U` and is equal to `ε UV` on the complement to `V`. -/
  have : ∀ UV : s, ∃ f : C(X, ℝ), eq_on f 0 UV.1.1 ∧ eq_on f (λ _, ε UV) UV.1.2ᶜ ∧
    ∀ x, f x ∈ Icc 0 (ε UV),
  { intro UV,
    rcases exists_continuous_zero_one_of_closed is_closed_closure
      (hB.is_open UV.2.1.2).is_closed_compl (hd UV) with ⟨f, hf₀, hf₁, hf01⟩,
    exact ⟨ε UV • f, λ x hx, by simp [hf₀ (subset_closure hx)], λ x hx, by simp [hf₁ hx],
      λ x, ⟨mul_nonneg (ε01 _).1.le (hf01 _).1, mul_le_of_le_one_right (ε01 _).1.le (hf01 _).2⟩⟩ },
  choose f hf0 hfε hf0ε,
  have hf01 : ∀ UV x, f UV x ∈ Icc (0 : ℝ) 1,
    from λ UV x, Icc_subset_Icc_right (ε01 _).2 (hf0ε _ _),
  /- The embedding is given by `F x UV = f UV x`. -/
  set F : X → s →ᵇ ℝ := λ x, ⟨⟨λ UV, f UV x, continuous_of_discrete_topology⟩, 1, λ UV₁ UV₂,
    real.dist_le_of_mem_Icc_01 (hf01 _ _) (hf01 _ _)⟩,
  have hF : ∀ x UV, F x UV = f UV x := λ _ _, rfl,
  refine ⟨F, embedding.mk' _ (λ x y hxy, _) (λ x, le_antisymm _ _)⟩,
  { /- First we prove that `F` is injective. Indeed, if `F x = F y` and `x ≠ y`, then we can find
    `(U, V) ∈ s` such that `x ∈ U` and `y ∉ V`, hence `F x UV = 0 ≠ ε UV = F y UV`. -/
    refine not_not.1 (λ Hne, _), -- `by_contra Hne` timeouts
    rcases hB.mem_nhds_iff.1 (is_open_ne.mem_nhds Hne) with ⟨V, hVB, hxV, hVy⟩,
    rcases hB.exists_closure_subset (hB.mem_nhds hVB hxV) with ⟨U, hUB, hxU, hUV⟩,
    set UV : ↥s := ⟨(U, V), ⟨hUB, hVB⟩, hUV⟩,
    apply (ε01 UV).1.ne,
    calc (0 : ℝ) = F x UV : (hf0 UV hxU).symm
             ... = F y UV : by rw hxy
             ... = ε UV   : hfε UV (λ h : y ∈ V, hVy h rfl) },
  { /- Now we prove that each neighborhood `V` of `x : X` include a preimage of a neighborhood of
    `F x` under `F`. Without loss of generality, `V` belongs to `B`. Choose `U ∈ B` such that
    `x ∈ V` and `closure V ⊆ U`. Then the preimage of the `(ε (U, V))`-neighborhood of `F x`
    is included by `V`. -/
    refine ((nhds_basis_ball.comap _).le_basis_iff hB.nhds_has_basis).2 _,
    rintro V ⟨hVB, hxV⟩,
    rcases hB.exists_closure_subset (hB.mem_nhds hVB hxV) with ⟨U, hUB, hxU, hUV⟩,
    set UV : ↥s := ⟨(U, V), ⟨hUB, hVB⟩, hUV⟩,
    refine ⟨ε UV, (ε01 UV).1, λ y (hy : dist (F y) (F x) < ε UV), _⟩,
    replace hy : dist (F y UV) (F x UV) < ε UV,
      from (bounded_continuous_function.dist_coe_le_dist _).trans_lt hy,
    contrapose! hy,
    rw [hF, hF, hfε UV hy, hf0 UV hxU, pi.zero_apply, dist_zero_right],
    exact le_abs_self _ },
  { /- Finally, we prove that `F` is continuous. Given `δ > 0`, consider the set `T` of `(U, V) ∈ s`
    such that `ε (U, V) ≥ δ`. Since `ε` tends to zero, `T` is finite. Since each `f` is continuous,
    we can choose a neighborhood such that `dist (F y (U, V)) (F x (U, V)) ≤ δ` for any
    `(U, V) ∈ T`. For `(U, V) ∉ T`, the same inequality is true because both `F y (U, V)` and
    `F x (U, V)` belong to the interval `[0, ε (U, V)]`. -/
    refine (nhds_basis_closed_ball.comap _).ge_iff.2 (λ δ δ0, _),
    have h_fin : finite {UV : s | δ ≤ ε UV}, by simpa only [← not_lt] using hε (gt_mem_nhds δ0),
    have : ∀ᶠ y in 𝓝 x, ∀ UV, δ ≤ ε UV → dist (F y UV) (F x UV) ≤ δ,
    { refine (eventually_all_finite h_fin).2 (λ UV hUV, _),
      exact (f UV).continuous.tendsto x (closed_ball_mem_nhds _ δ0) },
    refine this.mono (λ y hy, (bounded_continuous_function.dist_le δ0.le).2 $ λ UV, _),
    cases le_total δ (ε UV) with hle hle,
    exacts [hy _ hle, (real.dist_le_of_mem_Icc (hf0ε _ _) (hf0ε _ _)).trans (by rwa sub_zero)] }
end

/-- A normal topological space with second countable topology `X` is metrizable: there exists a
metric space structure that generates the same topology. -/
lemma metrizable_space_of_normal_second_countable : metrizable_space X :=
let ⟨f, hf⟩ := exists_embedding_l_infty X in hf.metrizable_space

instance : metrizable_space ennreal := metrizable_space_of_normal_second_countable ennreal

end topological_space


/-
Copyright (c) 2020 Simon Hudon. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Simon Hudon
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.nat.upto
import Mathlib.data.stream.basic
import Mathlib.data.pfun
import Mathlib.PostPort

universes u_3 l u_1 u_2

namespace Mathlib

/-!
# Fixed point

This module defines a generic `fix` operator for defining recursive
computations that are not necessarily well-founded or productive.
An instance is defined for `roption`.

## Main definition

 * class `has_fix`
 * `roption.fix`
-/

/-- `has_fix α` gives us a way to calculate the fixed point
of function of type `α → α`. -/
class has_fix (α : Type u_3)
where
  fix : (α → α) → α

namespace roption

/-- A series of successive, finite approximation of the fixed point of `f`, defined by
`approx f n = f^[n] ⊥`. The limit of this chain is the fixed point of `f`. -/
def fix.approx {α : Type u_1} {β : α → Type u_2} (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) : stream ((a : α) → roption (β a)) :=
  sorry

/-- loop body for finding the fixed point of `f` -/
def fix_aux {α : Type u_1} {β : α → Type u_2} (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) {p : ℕ → Prop} (i : nat.upto p) (g : (j : nat.upto p) → i < j → (a : α) → roption (β a)) (a : α) : roption (β a) :=
  f fun (x : α) => assert (¬p (subtype.val i)) fun (h : ¬p (subtype.val i)) => g (nat.upto.succ i h) sorry x

/-- The least fixed point of `f`.

If `f` is a continuous function (according to complete partial orders),
it satisfies the equations:

  1. `fix f = f (fix f)`          (is a fixed point)
  2. `∀ X, f X ≤ X → fix f ≤ X`   (least fixed point)
-/
protected def fix {α : Type u_1} {β : α → Type u_2} (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) (x : α) : roption (β x) :=
  assert (∃ (i : ℕ), dom sorry) fun (h : ∃ (i : ℕ), dom sorry) => well_founded.fix sorry (fix_aux f) nat.upto.zero x

protected theorem fix_def {α : Type u_1} {β : α → Type u_2} (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) {x : α} (h' : ∃ (i : ℕ), dom (fix.approx f i x)) : roption.fix f x = fix.approx f (Nat.succ (nat.find h')) x := sorry

theorem fix_def' {α : Type u_1} {β : α → Type u_2} (f : ((a : α) → roption (β a)) → (a : α) → roption (β a)) {x : α} (h' : ¬∃ (i : ℕ), dom (fix.approx f i x)) : roption.fix f x = none := sorry

end roption

namespace roption

protected instance has_fix {α : Type u_1} : has_fix (roption α) :=
  has_fix.mk fun (f : roption α → roption α) => roption.fix (fun (x : Unit → roption α) (u : Unit) => f (x u)) Unit.unit

end roption

namespace pi

protected instance roption.has_fix {α : Type u_1} {β : Type u_2} : has_fix (α → roption β) :=
  has_fix.mk roption.fix


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

import category_theory.abelian.basic

/-!
# Idempotent complete categories

In this file, we define the notion of idempotent complete categories
(also known as Karoubian categories, or pseudoabelian in the case of
preadditive categories).

## Main definitions

- `is_idempotent_complete C` expresses that `C` is idempotent complete, i.e.
all idempotents in `C` split. Other characterisations of idempotent completeness are given
by `is_idempotent_complete_iff_has_equalizer_of_id_and_idempotent` and
`is_idempotent_complete_iff_idempotents_have_kernels`.
- `is_idempotent_complete_of_abelian` expresses that abelian categories are
idempotent complete.
- `is_idempotent_complete_iff_of_equivalence` expresses that if two categories `C` and `D`
are equivalent, then `C` is idempotent complete iff `D` is.
- `is_idempotent_complete_iff_opposite` expresses that `Cᵒᵖ` is idempotent complete
iff `C` is.

## References
* [Stacks: Karoubian categories] https://stacks.math.columbia.edu/tag/09SF

-/

open category_theory
open category_theory.category
open category_theory.limits
open category_theory.preadditive
open opposite

namespace category_theory

variables (C : Type*) [category C]

/-- A category is idempotent complete iff all idempotent endomorphisms `p`
split as a composition `p = e ≫ i` with `i ≫ e = 𝟙 _` -/
class is_idempotent_complete : Prop :=
(idempotents_split : ∀ (X : C) (p : X ⟶ X), p ≫ p = p →
  ∃ (Y : C) (i : Y ⟶ X) (e : X ⟶ Y), i ≫ e = 𝟙 Y ∧ e ≫ i = p)

namespace idempotents

/-- A category is idempotent complete iff for all idempotent endomorphisms,
the equalizer of the identity and this idempotent exists. -/
lemma is_idempotent_complete_iff_has_equalizer_of_id_and_idempotent :
  is_idempotent_complete C ↔ ∀ (X : C) (p : X ⟶ X), p ≫ p = p → has_equalizer (𝟙 X) p :=
begin
  split,
  { introI,
    intros X p hp,
    rcases is_idempotent_complete.idempotents_split X p hp with ⟨Y, i, e, ⟨h₁, h₂⟩⟩,
    exact ⟨nonempty.intro
      { cone := fork.of_ι i
          (show i ≫ 𝟙 X = i ≫ p, by rw [comp_id, ← h₂, ← assoc, h₁, id_comp]),
        is_limit := begin
          apply fork.is_limit.mk',
          intro s,
          refine ⟨s.ι ≫ e, _⟩,
          split,
          { erw [assoc, h₂, ← limits.fork.condition s, comp_id], },
          { intros m hm,
            rw fork.ι_of_ι at hm,
            rw [← hm],
            simp only [← hm, assoc, h₁],
            exact (comp_id m).symm }
        end }⟩, },
  { intro h,
    refine ⟨_⟩,
    intros X p hp,
    haveI := h X p hp,
    use equalizer (𝟙 X) p,
    use equalizer.ι (𝟙 X) p,
    use equalizer.lift p (show p ≫ 𝟙 X = p ≫ p, by rw [hp, comp_id]),
    split,
    { ext,
      rw [assoc, equalizer.lift_ι, id_comp],
      conv { to_rhs, erw [← comp_id (equalizer.ι (𝟙 X) p)], },
      exact (limits.fork.condition (equalizer.fork (𝟙 X) p)).symm, },
    { rw [equalizer.lift_ι], }, }
end

variables {C}

/-- In a preadditive category, when `p : X ⟶ X` is idempotent,
then `𝟙 X - p` is also idempotent. -/
lemma idem_of_id_sub_idem [preadditive C]
  {X : C} (p : X ⟶ X) (hp : p ≫ p = p) :
  (𝟙 _ - p) ≫ (𝟙 _ - p) = (𝟙 _ - p) :=
by simp only [comp_sub, sub_comp, id_comp, comp_id, hp, sub_self, sub_zero]

variables (C)

/-- A preadditive category is pseudoabelian iff all idempotent endomorphisms have a kernel. -/
lemma is_idempotent_complete_iff_idempotents_have_kernels [preadditive C] :
  is_idempotent_complete C ↔ ∀ (X : C) (p : X ⟶ X), p ≫ p = p → has_kernel p :=
begin
  rw is_idempotent_complete_iff_has_equalizer_of_id_and_idempotent,
  split,
  { intros h X p hp,
    haveI := h X (𝟙 _ - p) (idem_of_id_sub_idem p hp),
    convert has_kernel_of_has_equalizer (𝟙 X) (𝟙 X - p),
    rw [sub_sub_cancel], },
  { intros h X p hp,
    haveI : has_kernel (𝟙 _ - p) := h X (𝟙 _ - p) (idem_of_id_sub_idem p hp),
    apply preadditive.has_equalizer_of_has_kernel, },
end

/-- An abelian category is idempotent complete. -/
@[priority 100]
instance is_idempotent_complete_of_abelian (D : Type*) [category D] [abelian D] :
  is_idempotent_complete D :=
by { rw is_idempotent_complete_iff_idempotents_have_kernels, intros, apply_instance, }

variables {C}

lemma split_imp_of_iso {X X' : C} (φ : X ≅ X') (p : X ⟶ X) (p' : X' ⟶ X')
  (hpp' : p ≫ φ.hom = φ.hom ≫ p')
  (h : ∃ (Y : C) (i : Y ⟶ X) (e : X ⟶ Y), i ≫ e = 𝟙 Y ∧ e ≫ i = p) :
  (∃ (Y' : C) (i' : Y' ⟶ X') (e' : X' ⟶ Y'), i' ≫ e' = 𝟙 Y' ∧ e' ≫ i' = p') :=
begin
  rcases h with ⟨Y, i, e, ⟨h₁, h₂⟩⟩,
  use [Y, i ≫ φ.hom, φ.inv ≫ e],
  split,
  { slice_lhs 2 3 { rw φ.hom_inv_id, },
    rw [id_comp, h₁], },
  { slice_lhs 2 3 { rw h₂, },
    rw [hpp', ← assoc, φ.inv_hom_id, id_comp], }
end

lemma split_iff_of_iso {X X' : C} (φ : X ≅ X') (p : X ⟶ X) (p' : X' ⟶ X')
  (hpp' : p ≫ φ.hom = φ.hom ≫ p') :
  (∃ (Y : C) (i : Y ⟶ X) (e : X ⟶ Y), i ≫ e = 𝟙 Y ∧ e ≫ i = p) ↔
  (∃ (Y' : C) (i' : Y' ⟶ X') (e' : X' ⟶ Y'), i' ≫ e' = 𝟙 Y' ∧ e' ≫ i' = p') :=
begin
  split,
  { exact split_imp_of_iso φ p p' hpp', },
  { apply split_imp_of_iso φ.symm p' p,
    rw [← comp_id p, ← φ.hom_inv_id],
    slice_rhs 2 3 { rw hpp', },
    slice_rhs 1 2 { erw φ.inv_hom_id, },
    simpa only [id_comp], },
end

lemma equivalence.is_idempotent_complete {D : Type*} [category D] (ε : C ≌ D)
  (h : is_idempotent_complete C) : is_idempotent_complete D :=
begin
  refine ⟨_⟩,
  intros X' p hp,
  let φ := ε.counit_iso.symm.app X',
  erw split_iff_of_iso φ p (φ.inv ≫ p ≫ φ.hom)
    (by { slice_rhs 1 2 { rw φ.hom_inv_id, }, rw id_comp,}),
  rcases is_idempotent_complete.idempotents_split (ε.inverse.obj X') (ε.inverse.map p)
    (by rw [← ε.inverse.map_comp, hp]) with ⟨Y, i, e, ⟨h₁,h₂⟩⟩,
  use [ε.functor.obj Y, ε.functor.map i, ε.functor.map e],
  split,
  { rw [← ε.functor.map_comp, h₁, ε.functor.map_id], },
  { simpa only [← ε.functor.map_comp, h₂, equivalence.fun_inv_map], },
end

/-- If `C` and `D` are equivalent categories, that `C` is idempotent complete iff `D` is. -/
lemma is_idempotent_complete_iff_of_equivalence {D : Type*} [category D] (ε : C ≌ D) :
  is_idempotent_complete C ↔ is_idempotent_complete D :=
begin
  split,
  { exact equivalence.is_idempotent_complete ε, },
  { exact equivalence.is_idempotent_complete ε.symm, },
end

lemma is_idempotent_complete_of_is_idempotent_complete_opposite
  (h : is_idempotent_complete Cᵒᵖ) : is_idempotent_complete C :=
begin
  refine ⟨_⟩,
  intros X p hp,
  rcases is_idempotent_complete.idempotents_split (op X) p.op
    (by rw [← op_comp, hp]) with ⟨Y, i, e, ⟨h₁, h₂⟩⟩,
  use [Y.unop, e.unop, i.unop],
  split,
  { simpa only [← unop_comp, h₁], },
  { simpa only [← unop_comp, h₂], },
end

lemma is_idempotent_complete_iff_opposite :
  is_idempotent_complete Cᵒᵖ ↔ is_idempotent_complete C :=
begin
  split,
  { exact is_idempotent_complete_of_is_idempotent_complete_opposite, },
  { intro h,
    apply is_idempotent_complete_of_is_idempotent_complete_opposite,
    rw is_idempotent_complete_iff_of_equivalence (op_op_equivalence C),
    exact h, },
end

instance [is_idempotent_complete C] : is_idempotent_complete (Cᵒᵖ) :=
by rwa is_idempotent_complete_iff_opposite

end idempotents

end category_theory


import data.list algebra.ring tactic.omega defs

lemma single_complete: almost_complete [●] :=
begin
  apply almost_complete.cmp_rule,
  existsi ([]),
  intros t h,
  exfalso, apply h, apply grow_list.head_grow,
  apply grow.single_grow
end

lemma single_grow : ∀ t : bintree, (t ↣ ●) → t = ● :=
begin
  intros t H1,
  destruct t,
  begin intros, assumption end,
  repeat {
    intros a H2,
    rewrite H2 at H1,
    cases H1,
  }, -- this proves the first two goals
  begin
    intros a a1 H2,
    rewrite H2 at H1,
    cases H1,
  end -- this proves the last two goals
end