/-
if R is a ring, I and ideal of R and S a multiplicative subset of R, then S−1I is an ideal of S−1R, and we have S−1R/S−1I=S⎯⎯⎯−1(R/I), where S⎯⎯⎯ is the image of S in R/I,

[proof omitted]
-/

import Kenny_comm_alg.temp linear_algebra.quotient_module
import linear_algebra.linear_map_module
import group_theory.submonoid
universe u

def localize {α : Type u} [comm_ring α] (S : set α) [is_submonoid S]
  (I : set α) [is_submodule I] :
  set (localization.loc α S) :=
{y | ∃ (x s : α) (hx : x ∈ I) (hs : s ∈ S), ⟦(⟨x, s, hs⟩:α × S)⟧ = y}

abbreviation localize' {α : Type u} [comm_ring α] (I : set α) [is_submodule I]
  (S : set α) [is_submonoid S] :
  set (localization.loc α S) :=
localize S I

variables {α : Type u} [comm_ring α] (S : set α) [is_submonoid S]

variables (I : set α) [is_submodule I]

postfix ⁻¹ := localize
infix ` /ᵣ `:100 := localization.loc
infix ` /ᵣ `:100 := localize'
notation α` [1/`:max S `]` := localization.loc α S
notation I` [1/`:max S `]` := localize S I
notation S `ₑ`:max := quotient.mk '' S

instance localization.is_submodule.of_comm_ring : is_submodule (S⁻¹ I) :=
{ zero_ := ⟨(0:α), (1:α), @is_submodule.zero _ _ _ _ I _, is_submonoid.one_mem S, quotient.sound $ setoid.refl _⟩,
  add_  := λ m₁ m₂ ⟨x₁, s₁, hx₁, hs₁, h₁⟩ ⟨x₂, s₂, hx₂, hs₂, h₂⟩,
    ⟨s₁ * x₂ + s₂ * x₁, s₁ * s₂, is_submodule.add (is_submodule.smul _ hx₂) (is_submodule.smul _ hx₁),
     is_submonoid.mul_mem hs₁ hs₂, by rw [← h₁, ← h₂]; refl⟩,
  smul  := λ c m ⟨x, s, hx, hs, h⟩, quotient.induction_on c $ λ ⟨cr, cs, ch⟩,
    ⟨cr * x, cs * s, is_submodule.smul _ hx, is_submonoid.mul_mem ch hs, by rw [← h]; refl⟩ }

instance localization.is_submonoid.of_comm_ring : is_submonoid (quotient.mk '' S : set (α /ᵣ I)) :=
{ one_mem := ⟨1, is_submonoid.one_mem S, rfl⟩,
  mul_mem := λ x y, quotient.induction_on₂ x y $ λ m n ⟨mw, hms, hm⟩ ⟨nw, hns, hn⟩,
    ⟨mw * nw, is_submonoid.mul_mem hms hns, by rw [← hm, ← hn]; refl⟩ }

private def to_be_named_aux1 : α × S → (α /ᵣ I) [1/(S ₑ)] :=
λ x, ⟦⟨⟦x.1⟧, ⟦x.2.1⟧, x.2.1, x.2.2, rfl⟩⟧

private def to_be_named_aux2 : α [1/S] → (α /ᵣ I) [1/(S ₑ)] :=
quotient.lift (to_be_named_aux1 S I) $ λ ⟨r₁, s₁, hs₁⟩ ⟨r₂, s₂, hs₂⟩ ⟨w, hws, hw⟩,
quotient.sound $ ⟨⟦w⟧, ⟨w, hws, rfl⟩, quotient.sound $ begin simp at hw ⊢,rw hw,end⟩

--set_option pp.notation false
private def to_be_named_aux3 : α [1/S] /ᵣ (S⁻¹ I) → (α /ᵣ I) [1/(S ₑ)] :=
quotient.lift (to_be_named_aux2 S I) $ λ x y, quotient.induction_on₂ x y $
λ ⟨r₁, s₁, hs₁⟩ ⟨r₂, s₂, hs₂⟩ ⟨v, w, hv, hw, h⟩, quotient.sound $
let ⟨t, hts, hsv⟩ := quotient.exact h in
⟨⟦w * t⟧, ⟨w * t, is_submonoid.mul_mem hw hts, rfl⟩,
 quotient.sound $ suffices (s₁ * r₂ - s₂ * r₁) * (w * t) ∈ I,
 begin simp at this ⊢,
   show (s₁ * r₂ + -(s₂ * r₁)) * (w * t) - 0 ∈ I,
   simp [this],
  end,
 have (-(s₁ * s₂ * v) + w * (s₂ * r₁ + -(s₁ * r₂))) * t = 0,
 by simpa using hsv, calc
         (s₁ * r₂ - s₂ * r₁) * (w * t)
       = (-(s₁ * s₂ * v) + w * (s₂ * r₁ + -(s₁ * r₂))) * t + (s₁ * r₂ - s₂ * r₁) * (w * t) : by simp [this]
   ... = (-s₁ * s₂ * t) * v : by ring
   ... ∈ I : is_submodule.smul _ hv⟩

private lemma to_be_named_aux35 : (1:α [1/S])
  = ⟦⟨1, 1, is_submonoid.one_mem S⟩⟧ := rfl

private def to_be_named_aux4 : is_ring_hom (to_be_named_aux3 S I) :=
{ map_add := λ x y, quotient.induction_on₂ x y $
    λ m n, quotient.induction_on₂ m n $
    λ ⟨p, q, r⟩ ⟨s, t, u⟩, by simp [is_ideal.coset_eq, to_be_named_aux3,
      to_be_named_aux2, to_be_named_aux1, localization.mk_eq],
  map_mul := λ x y, quotient.induction_on₂ x y $
    λ m n, quotient.induction_on₂ m n $
    λ ⟨p, q, r⟩ ⟨s, t, u⟩, by simp [is_ideal.coset_eq, to_be_named_aux3,
      to_be_named_aux2, to_be_named_aux1, localization.mk_eq],
  map_one := by simp [is_ideal.coset_eq, to_be_named_aux3,
      to_be_named_aux2, to_be_named_aux1, localization.mk_eq];
      rw to_be_named_aux35; rw quotient.lift_beta; simp }

local attribute [instance] to_be_named_aux4
local attribute [instance] is_ring_hom.ker.is_ideal
instance deus : comm_ring (α [1/S] /ᵣ (S⁻¹ I)) := by apply_instance
instance salva : module (α [1/S] /ᵣ (S⁻¹ I)) (α [1/S] /ᵣ (S⁻¹ I)) := ring.to_module
instance me : is_submodule (is_ring_hom.ker (to_be_named_aux3 S I)) := is_ring_hom.ker.is_submodule (to_be_named_aux3 S I)

private def to_be_named_aux5 :
  α [1/S] /ᵣ (S⁻¹ I) ≃ᵣ
    α [1/S] /ᵣ (S⁻¹ I) /ᵣ is_ring_hom.ker (to_be_named_aux3 S I) :=
{ to_fun := quotient.mk,
  is_ring_hom := is_ideal.to_quotient _ _,
  inv_fun := quotient.lift (@id (α [1/S] /ᵣ (S⁻¹ I))) $
    λ x y, quotient.induction_on₂ x y $
    λ m n, quotient.induction_on₂ m n $
    λ ⟨b, c, d⟩ ⟨e, f, g⟩ h,
    begin
      change _ - _ ∈ _ at h,
      simp [is_ideal.coset_eq, to_be_named_aux3,
      to_be_named_aux2, to_be_named_aux1, localization.mk_eq] at h,
      replace h := quotient.exact h,
      rcases h with ⟨r, s, h⟩,
      rcases s with ⟨p, q, hp⟩,
      rw ← hp at h,
      replace h := quotient.exact h,
      change _ - _ ∈ _ at h,
      apply quotient.sound,
      existsi p * (f * b - c * e),
      existsi p * (c * f),
      have hx : p * (f * b - c * e) ∈ I,
        { have aux : p * (f * b - c * e) = -((c * f * 0 + -(1 * (f * b + -(c * e)))) * p - 0),
          { ring },
          rw aux,
          exact is_submodule.neg h },
      existsi hx,
      existsi is_submonoid.mul_mem q (is_submonoid.mul_mem d g),
      apply quotient.sound,
      existsi (1:α),
      existsi is_submonoid.one_mem S,
      simp,
      ring
    end,
  left_inv := λ x, rfl,
  right_inv := λ x, quotient.induction_on x $ λ m, rfl }

private def to_be_named_aux6 :
  ↥(is_ring_hom.im (to_be_named_aux3 S I)) ≃ᵣ
    (α /ᵣ I) [1/(S ₑ)] :=
{ to_fun := subtype.val,
  is_ring_hom := subring.is_ring_hom _ _,
  inv_fun := λ x, ⟨x, quotient.induction_on x $
    λ ⟨m, n, p, hp, hpn⟩, quotient.induction_on m $
    begin
      intro q,
      existsi @is_ideal.mk' _ (localization.comm_ring _ _) _ _ ⟦(⟨q, p, hp⟩ : α × S)⟧,
      simp [to_be_named_aux3,
        to_be_named_aux2, to_be_named_aux1, localization.mk_eq],
      apply quotient.sound,
      existsi ⟦(1:α)⟧,
      split,
      { existsi (1:α),
        existsi is_submonoid.one_mem S,
        refl },
      simp [hpn]
    end⟩,
  left_inv := λ x, by simp,
  right_inv := λ x, rfl }

noncomputable def to_be_named : α [1/S] /ᵣ (S⁻¹ I) ≃ᵣ (α /ᵣ I) [1/(S ₑ)] :=
(to_be_named_aux5 S I).trans $
(first_isom _ _ $ to_be_named_aux3 S I).trans $
to_be_named_aux6 S I


/-
Copyright (c) 2021 Martin Zinkevich. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Martin Zinkevich
-/
import measure_theory.integration
import probability_theory.independence

/-!
# Integration in Probability Theory

Integration results for independent random variables. Specifically, for two
independent random variables X and Y over the extended non-negative
reals, `E[X * Y] = E[X] * E[Y]`, and similar results.
-/

noncomputable theory
open set measure_theory
open_locale ennreal

variables {α : Type*}

namespace probability_theory

/-- This (roughly) proves that if a random variable `f` is independent of an event `T`,
   then if you restrict the random variable to `T`, then
   `E[f * indicator T c 0]=E[f] * E[indicator T c 0]`. It is useful for
   `lintegral_mul_eq_lintegral_mul_lintegral_of_independent_measurable_space`. -/
lemma lintegral_mul_indicator_eq_lintegral_mul_lintegral_indicator
  {Mf : measurable_space α} [M : measurable_space α] {μ : measure α}
  (hMf : Mf ≤ M) (c : ℝ≥0∞) {T : set α} (h_meas_T : M.measurable_set' T)
  (h_ind : indep_sets Mf.measurable_set' {T} μ)
  {f : α → ℝ≥0∞} (h_meas_f : @measurable α ℝ≥0∞ Mf _ f) :
  ∫⁻ a, f a * T.indicator (λ _, c) a ∂μ =
  ∫⁻ a, f a ∂μ * ∫⁻ a, T.indicator (λ _, c) a ∂μ :=
begin
  revert f,
  have h_mul_indicator : ∀ g, measurable g → measurable (λ a, g a * T.indicator (λ x, c) a) :=
  λ g h_mg, h_mg.mul (measurable_const.indicator h_meas_T),
  apply measurable.ennreal_induction,
  { intros c' s' h_meas_s',
    simp_rw [← inter_indicator_mul],
    rw [lintegral_indicator _ (measurable_set.inter (hMf _ h_meas_s') (h_meas_T)),
        lintegral_indicator _ (hMf _ h_meas_s'),
        lintegral_indicator _ h_meas_T],
    simp only [measurable_const, lintegral_const, univ_inter, lintegral_const_mul,
        measurable_set.univ, measure.restrict_apply],
    rw h_ind, { ring }, { apply h_meas_s' }, { simp } },
  { intros f' g h_univ h_meas_f' h_meas_g h_ind_f' h_ind_g,
    have h_measM_f' := h_meas_f'.mono hMf le_rfl,
    have h_measM_g := h_meas_g.mono hMf le_rfl,
    simp_rw [pi.add_apply, right_distrib],
    rw [lintegral_add (h_mul_indicator _ h_measM_f') (h_mul_indicator _ h_measM_g),
        lintegral_add h_measM_f' h_measM_g, right_distrib, h_ind_f', h_ind_g] },
  { intros f h_meas_f h_mono_f h_ind_f,
    have h_measM_f := λ n, (h_meas_f n).mono hMf le_rfl,
    simp_rw [ennreal.supr_mul],
    rw [lintegral_supr h_measM_f h_mono_f, lintegral_supr, ennreal.supr_mul],
    { simp_rw [← h_ind_f] },
    { exact λ n, h_mul_indicator _ (h_measM_f n) },
    { intros m n h_le a, apply ennreal.mul_le_mul _ le_rfl, apply h_mono_f h_le } },
end

/-- This (roughly) proves that if `f` and `g` are independent random variables,
   then `E[f * g] = E[f] * E[g]`. However, instead of directly using the independence
   of the random variables, it uses the independence of measurable spaces for the
   domains of `f` and `g`. This is similar to the sigma-algebra approach to
   independence. See `lintegral_mul_eq_lintegral_mul_lintegral_of_independent_fn` for
   a more common variant of the product of independent variables. -/
lemma lintegral_mul_eq_lintegral_mul_lintegral_of_independent_measurable_space
  {Mf : measurable_space α} {Mg : measurable_space α} [M : measurable_space α]
  {μ : measure α} (hMf : Mf ≤ M) (hMg : Mg ≤ M)
  (h_ind : indep Mf Mg μ)
  (f g : α → ℝ≥0∞) (h_meas_f : @measurable α ℝ≥0∞ Mf _ f)
  (h_meas_g : @measurable α ℝ≥0∞ Mg _ g) :
  ∫⁻ a, f a * g a ∂μ = ∫⁻ a, f a ∂μ * ∫⁻ a, g a ∂μ :=
begin
  revert g,
  have h_meas_Mg : ∀ ⦃f : α → ℝ≥0∞⦄, @measurable α ℝ≥0∞ Mg _ f → measurable f,
  { intros f' h_meas_f', apply h_meas_f'.mono hMg le_rfl },
  have h_measM_f := h_meas_f.mono hMf le_rfl,
  apply measurable.ennreal_induction,
  { intros c s h_s,
    apply lintegral_mul_indicator_eq_lintegral_mul_lintegral_indicator hMf _ (hMg _ h_s) _ h_meas_f,
    apply probability_theory.indep_sets_of_indep_sets_of_le_right h_ind,
    rw singleton_subset_iff, apply h_s },
  { intros f' g h_univ h_measMg_f' h_measMg_g h_ind_f' h_ind_g',
    have h_measM_f' := h_meas_Mg h_measMg_f',
    have h_measM_g := h_meas_Mg h_measMg_g,
    simp_rw [pi.add_apply, left_distrib],
    rw [lintegral_add h_measM_f' h_measM_g,
        lintegral_add (h_measM_f.mul h_measM_f') (h_measM_f.mul h_measM_g),
        left_distrib, h_ind_f', h_ind_g'] },
  { intros f' h_meas_f' h_mono_f' h_ind_f',
    have h_measM_f' := λ n, h_meas_Mg (h_meas_f' n),
    simp_rw [ennreal.mul_supr],
    rw [lintegral_supr, lintegral_supr h_measM_f' h_mono_f', ennreal.mul_supr],
    { simp_rw [← h_ind_f'] },
    { apply λ (n : ℕ), h_measM_f.mul (h_measM_f' n) },
    { apply λ (n : ℕ) (m : ℕ) (h_le : n ≤ m) a, ennreal.mul_le_mul le_rfl
      (h_mono_f' h_le a) } }
end

/-- This proves that if `f` and `g` are independent random variables,
   then `E[f * g] = E[f] * E[g]`. -/
lemma lintegral_mul_eq_lintegral_mul_lintegral_of_indep_fun [M : measurable_space α]
  (μ : measure α) (f g : α → ℝ≥0∞) (h_meas_f : measurable f) (h_meas_g : measurable g)
  (h_indep_fun : indep_fun (borel ennreal) (borel ennreal) f g μ) :
  ∫⁻ (a : α), (f * g) a ∂μ = ∫⁻ (a : α), f a ∂μ * ∫⁻ (a : α), g a ∂μ :=
begin
  apply lintegral_mul_eq_lintegral_mul_lintegral_of_independent_measurable_space
    (measurable_iff_comap_le.1 h_meas_f) (measurable_iff_comap_le.1 h_meas_g),
  apply h_indep_fun,
  repeat { apply measurable.of_comap_le le_rfl },
end

end probability_theory


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

! This file was ported from Lean 3 source module group_theory.group_action.option
! leanprover-community/mathlib commit 448144f7ae193a8990cb7473c9e9a01990f64ac7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.GroupTheory.GroupAction.Defs

/-!
# Option instances for additive and multiplicative actions

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

This file defines instances for additive and multiplicative actions on `option` type. Scalar
multiplication is defined by `a • some b = some (a • b)` and `a • none = none`.

## See also

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

variable {M N α : Type _}

namespace Option

section SMul

variable [SMul M α] [SMul N α] (a : M) (b : α) (x : Option α)

@[to_additive Option.hasVadd]
instance : SMul M (Option α) :=
  ⟨fun a => Option.map <| (· • ·) a⟩

#print Option.smul_def /-
@[to_additive]
theorem smul_def : a • x = x.map ((· • ·) a) :=
  rfl
#align option.smul_def Option.smul_def
#align option.vadd_def Option.vadd_def
-/

#print Option.smul_none /-
@[simp, to_additive]
theorem smul_none : a • (none : Option α) = none :=
  rfl
#align option.smul_none Option.smul_none
#align option.vadd_none Option.vadd_none
-/

#print Option.smul_some /-
@[simp, to_additive]
theorem smul_some : a • some b = some (a • b) :=
  rfl
#align option.smul_some Option.smul_some
#align option.vadd_some Option.vadd_some
-/

@[to_additive]
instance [SMul M N] [IsScalarTower M N α] : IsScalarTower M N (Option α) :=
  ⟨fun a b x => by
    cases x
    exacts[rfl, congr_arg some (smul_assoc _ _ _)]⟩

@[to_additive]
instance [SMulCommClass M N α] : SMulCommClass M N (Option α) :=
  ⟨fun a b => Function.Commute.option_map <| smul_comm _ _⟩

@[to_additive]
instance [SMul Mᵐᵒᵖ α] [IsCentralScalar M α] : IsCentralScalar M (Option α) :=
  ⟨fun a x => by
    cases x
    exacts[rfl, congr_arg some (op_smul_eq_smul _ _)]⟩

@[to_additive]
instance [FaithfulSMul M α] : FaithfulSMul M (Option α) :=
  ⟨fun x y h => eq_of_smul_eq_smul fun b : α => by injection h (some b)⟩

end SMul

instance [Monoid M] [MulAction M α] : MulAction M (Option α)
    where
  smul := (· • ·)
  one_smul b := by
    cases b
    exacts[rfl, congr_arg some (one_smul _ _)]
  mul_smul a₁ a₂ b := by
    cases b
    exacts[rfl, congr_arg some (mul_smul _ _ _)]

end Option


import data.equiv.basic algebra.field

universes u v
variables {α : Type u} {β : Type v} (e : α ≃ β)

namespace equiv

protected def has_zero [has_zero α] : has_zero β := ⟨e 0⟩
lemma zero_def [has_zero α] : @has_zero.zero _ (equiv.has_zero e) = e 0 := rfl

protected def has_one [has_one α] : has_one β := ⟨e 1⟩
lemma one_def [has_one α] : @has_one.one _ (equiv.has_one e) = e 1 := rfl

protected def has_mul [has_mul α] : has_mul β := ⟨λ x y, e (e.symm x * e.symm y)⟩
lemma mul_def [has_mul α] (x y : β) :
  @has_mul.mul _ (equiv.has_mul e) x y = e (e.symm x * e.symm y) := rfl

protected def has_add [has_add α] : has_add β := ⟨λ x y, e (e.symm x + e.symm y)⟩
lemma add_def [has_add α] (x y : β) :
  @has_add.add _ (equiv.has_add e) x y = e (e.symm x + e.symm y) := rfl

protected def has_inv [has_inv α] : has_inv β := ⟨λ x, e (e.symm x)⁻¹⟩
lemma inv_def [has_inv α] (x : β) : @has_inv.inv _ (equiv.has_inv e) x = e (e.symm x)⁻¹ := rfl

protected def has_neg [has_neg α] : has_neg β := ⟨λ x, e (- e.symm x)⟩
lemma neg_def [has_neg α] (x : β) : @has_neg.neg _ (equiv.has_neg e) x = e (-e.symm x) := rfl

protected def semigroup [semigroup α] : semigroup β :=
{ mul_assoc := by simp [mul_def, mul_assoc],
  ..equiv.has_mul e }

protected def comm_semigroup [comm_semigroup α] : comm_semigroup β :=
{ mul_comm := by simp [mul_def, mul_comm],
  ..equiv.semigroup e }

protected def monoid [monoid α] : monoid β :=
{ one_mul := by simp [mul_def, one_def],
  mul_one := by simp [mul_def, one_def],
  ..equiv.semigroup e,
  ..equiv.has_one e }

protected def comm_monoid [comm_monoid α] : comm_monoid β :=
{ ..equiv.comm_semigroup e,
  ..equiv.monoid e }

protected def group [group α] : group β :=
{ mul_left_inv := by simp [mul_def, inv_def, one_def],
  ..equiv.monoid e,
  ..equiv.has_inv e }

protected def comm_group [comm_group α] : comm_group β :=
{ ..equiv.group e,
  ..equiv.comm_semigroup e }

protected def add_semigroup [add_semigroup α] : add_semigroup β :=
@additive.add_semigroup _ (@equiv.semigroup _ _ e multiplicative.semigroup)

protected def add_comm_semigroup [add_comm_semigroup α] : add_comm_semigroup β :=
@additive.add_comm_semigroup _ (@equiv.comm_semigroup _ _ e multiplicative.comm_semigroup)

protected def add_monoid [add_monoid α] : add_monoid β :=
@additive.add_monoid _ (@equiv.monoid _ _ e multiplicative.monoid)

protected def add_comm_monoid [add_comm_monoid α] : add_comm_monoid β :=
@additive.add_comm_monoid _ (@equiv.comm_monoid _ _ e multiplicative.comm_monoid)

protected def add_group [add_group α] : add_group β :=
@additive.add_group _ (@equiv.group _ _ e multiplicative.group)

protected def add_comm_group [add_comm_group α] : add_comm_group β :=
@additive.add_comm_group _ (@equiv.comm_group _ _ e multiplicative.comm_group)

protected def ring [ring α] : ring β :=
{ right_distrib := by simp [mul_def, add_def, add_mul],
  left_distrib := by simp [mul_def, add_def, mul_add],
  ..equiv.has_mul e,
  ..equiv.has_add e,
  ..equiv.monoid e,
  ..equiv.add_comm_group e }

protected def comm_ring [comm_ring α] : comm_ring β :=
{ ..equiv.comm_monoid e,
  ..equiv.ring e }

protected def nonzero_comm_ring [nonzero_comm_ring α] : nonzero_comm_ring β :=
{ zero_ne_one := by simp [zero_def, one_def],
  ..equiv.has_zero e,
  ..equiv.has_one e,
  ..equiv.comm_ring e }

protected def integral_domain [integral_domain α] : integral_domain β :=
{ eq_zero_or_eq_zero_of_mul_eq_zero := by simp [mul_def, zero_def, equiv.symm_apply_eq],
  ..equiv.has_zero e,
  ..equiv.has_mul e,
  ..equiv.nonzero_comm_ring e }

protected def division_ring [division_ring α] : division_ring β :=
{ zero_ne_one := by simp [zero_def, one_def],
  inv_mul_cancel := λ _,
    by simp [mul_def, inv_def, zero_def, one_def, (equiv.symm_apply_eq _).symm];
      exact inv_mul_cancel,
  mul_inv_cancel := λ _,
    by simp [mul_def, inv_def, zero_def, one_def, (equiv.symm_apply_eq _).symm];
      exact mul_inv_cancel,
  ..equiv.has_zero e,
  ..equiv.has_one e,
  ..equiv.ring e,
  ..equiv.has_inv e }

protected def field [field α] : field β :=
{ ..equiv.comm_ring e,
  ..equiv.division_ring e }

protected def discrete_field [discrete_field α] : discrete_field β :=
{ has_decidable_eq := equiv.decidable_eq e.symm,
  inv_zero := by simp [mul_def, inv_def, zero_def],
  ..equiv.has_mul e,
  ..equiv.has_inv e,
  ..equiv.has_zero e,
  ..equiv.field e }

end equiv


-- Pruebas del principio del tercio excluso
-- ========================================

-- ----------------------------------------------------
-- Ej. 1. (p. 23) Demostrar que
--    F ∨ ¬F
-- ----------------------------------------------------

import tactic

variable (F : Prop)

open_locale classical

-- 1ª demostración
example : F ∨ ¬F :=
by_contradiction
  ( assume h1 : ¬(F ∨ ¬F),
    have h2 : ¬F, from
      assume h3 : F,
      have h4 : F ∨ ¬F, from or.inl h3,
      show false, from h1 h4,
    have h5 : F ∨ ¬F, from or.inr h2,
    show false, from h1 h5 )

-- 2ª demostración
example : F ∨ ¬F :=
by_contradiction
  ( assume h1 : ¬(F ∨ ¬F),
    have h2 : ¬F, from
      assume h3 : F,
      have h4 : F ∨ ¬F, from or.inl h3,
      show false, from h1 h4,
    have h5 : F ∨ ¬F, from or.inr h2,
    h1 h5 )

-- 3ª demostración
example : F ∨ ¬F :=
by_contradiction
  ( assume h1 : ¬(F ∨ ¬F),
    have h2 : ¬F, from
      assume h3 : F,
      have h4 : F ∨ ¬F, from or.inl h3,
      show false, from h1 h4,
    h1 (or.inr h2) )

-- 4ª demostración
example : F ∨ ¬F :=
by_contradiction
  ( assume h1 : ¬(F ∨ ¬F),
    have h2 : ¬F, from
      assume h3 : F,
      have h4 : F ∨ ¬F, from or.inl h3,
      h1 h4,
    h1 (or.inr h2) )

-- 5ª demostración
example : F ∨ ¬F :=
by_contradiction
  ( assume h1 : ¬(F ∨ ¬F),
    have h2 : ¬F, from
      assume h3 : F,
      h1 (or.inl h3),
    h1 (or.inr h2) )

-- 6ª demostración
example : F ∨ ¬F :=
by_contradiction
  ( assume h1 : ¬(F ∨ ¬F),
    have h2 : ¬F, from
      λ h3, h1 (or.inl h3),
    h1 (or.inr h2) )

-- 7ª demostración
example : F ∨ ¬F :=
by_contradiction
  ( assume h1 : ¬(F ∨ ¬F),
    h1 (or.inr (λ h3, h1 (or.inl h3))) )

-- 8ª demostración
example : F ∨ ¬F :=
by_contradiction
  ( λ h1, h1 (or.inr (λ h3, h1 (or.inl h3))) )

-- 9ª demostración
example : F ∨ ¬F :=
-- by library_search
em F

-- #print axioms em

-- 10ª demostración
example : F ∨ ¬F :=
begin
  by_contra h1,
  apply h1,
  right,
  intro h2,
  apply h1,
  left,
  exact h2,
end

-- 11ª demostración
example : F ∨ ¬F :=
begin
  by_contra h1,
  apply h1,
  apply or.inr,
  intro h2,
  exact h1 (or.inl h2),
end

-- 12ª demostración
example : F ∨ ¬F :=
begin
  by_contra h1,
  apply h1,
  apply or.inr,
  exact λ h2, h1 (or.inl h2),
end

-- 13ª demostración
example : F ∨ ¬F :=
begin
  by_contra h1,
  apply h1,
  exact or.inr (λ h2, h1 (or.inl h2)),
end

-- 14ª demostración
example : F ∨ ¬F :=
begin
  by_contra h1,
  exact h1 (or.inr (λ h2, h1 (or.inl h2))),
end

-- 15ª demostración
example : F ∨ ¬F :=
by_contra (λ h1, h1 (or.inr (λh2, h1 (or.inl h2))))

-- 16ª demostración
example : F ∨ ¬F :=
begin
  by_contra h1,
  apply h1,
  right,
  intro h2,
  apply h1,
  left,
  exact h2,
end

-- 17ª demostración
example : F ∨ ¬F :=
-- by hint
by tauto

-- 18ª demostración
example : F ∨ ¬F :=
by finish


lemma succ_le_succ (a b : mynat) (h : a ≤ b) : succ a ≤ succ b :=
begin
cases h with c hc,
use c,
rwa [hc, succ_add],
end


/-
Copyright (c) 2020 Johan Commelin. 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.data.mv_polynomial.counit
import Mathlib.data.mv_polynomial.invertible
import Mathlib.ring_theory.witt_vector.defs
import Mathlib.PostPort

universes u_4 u_5 u_1 u_2

namespace Mathlib

/-!
# Witt vectors

This file verifies that the ring operations on `witt_vector p R`
satisfy the axioms of a commutative ring.

## Main definitions

* `witt_vector.map`: lifts a ring homomorphism `R →+* S` to a ring homomorphism `𝕎 R →+* 𝕎 S`.
* `witt_vector.ghost_component n x`: evaluates the `n`th Witt polynomial
  on the first `n` coefficients of `x`, producing a value in `R`.
  This is a ring homomorphism.
* `witt_vector.ghost_map`: a ring homomorphism `𝕎 R →+* (ℕ → R)`, obtained by packaging
  all the ghost components together.
  If `p` is invertible in `R`, then the ghost map is an equivalence,
  which we use to define the ring operations on `𝕎 R`.
* `witt_vector.comm_ring`: the ring structure induced by the ghost components.

## Notation

We use notation `𝕎 R`, entered `\bbW`, for the Witt vectors over `R`.

## Implementation details

As we prove that the ghost components respect the ring operations, we face a number of repetitive
proofs. To avoid duplicating code we factor these proofs into a custom tactic, only slightly more
powerful than a tactic macro. This tactic is not particularly useful outside of its applications
in this file.
-/

namespace witt_vector

/-- `f : α → β` induces a map from `𝕎 α` to `𝕎 β` by applying `f` componentwise.
If `f` is a ring homomorphism, then so is `f`, see `witt_vector.map f`. -/
def map_fun {p : ℕ} {α : Type u_4} {β : Type u_5} (f : α → β) : witt_vector p α → witt_vector p β :=
  fun (x : witt_vector p α) => f ∘ x

namespace map_fun

theorem injective {p : ℕ} {α : Type u_4} {β : Type u_5} (f : α → β) (hf : function.injective f) : function.injective (map_fun f) :=
  fun (x y : witt_vector p α) (h : map_fun f x = map_fun f y) => funext fun (n : ℕ) => hf (congr_fun h n)

theorem surjective {p : ℕ} {α : Type u_4} {β : Type u_5} (f : α → β) (hf : function.surjective f) : function.surjective (map_fun f) := sorry

/-- Auxiliary tactic for showing that `map_fun` respects the ring operations. -/
/- We do not tag these lemmas as `@[simp]` because they will be bundled in `map` later on. -/

theorem zero {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S] (f : R →+* S) : map_fun (⇑f) 0 = 0 := sorry

theorem one {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S] (f : R →+* S) : map_fun (⇑f) 1 = 1 := sorry

theorem add {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S] (f : R →+* S) (x : witt_vector p R) (y : witt_vector p R) : map_fun (⇑f) (x + y) = map_fun (⇑f) x + map_fun (⇑f) y := sorry

theorem sub {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S] (f : R →+* S) (x : witt_vector p R) (y : witt_vector p R) : map_fun (⇑f) (x - y) = map_fun (⇑f) x - map_fun (⇑f) y := sorry

theorem mul {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S] (f : R →+* S) (x : witt_vector p R) (y : witt_vector p R) : map_fun (⇑f) (x * y) = map_fun (⇑f) x * map_fun (⇑f) y := sorry

theorem neg {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S] (f : R →+* S) (x : witt_vector p R) : map_fun (⇑f) (-x) = -map_fun (⇑f) x := sorry

end map_fun

end witt_vector

/-- An auxiliary tactic for proving that `ghost_fun` respects the ring operations. -/
namespace witt_vector

/-- Evaluates the `n`th Witt polynomial on the first `n` coefficients of `x`,
producing a value in `R`.
This function will be bundled as the ring homomorphism `witt_vector.ghost_map`
once the ring structure is available,
but we rely on it to set up the ring structure in the first place. -/
/- The following lemmas are not `@[simp]` because they will be bundled in `ghost_map` later on. -/

/-- The bijection between `𝕎 R` and `ℕ → R`, under the assumption that `p` is invertible in `R`.
In `witt_vector.ghost_equiv` we upgrade this to an isomorphism of rings. -/
/-- The commutative ring structure on `𝕎 R`. -/
protected instance comm_ring (p : ℕ) (R : Type u_1) [hp : fact (nat.prime p)] [comm_ring R] : comm_ring (witt_vector p R) :=
  function.surjective.comm_ring_sub (map_fun ⇑(mv_polynomial.counit R)) sorry sorry sorry sorry sorry sorry sorry

/-- `witt_vector.map f` is the ring homomorphism `𝕎 R →+* 𝕎 S` naturally induced
by a ring homomorphism `f : R →+* S`. It acts coefficientwise. -/
def map {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S] (f : R →+* S) : witt_vector p R →+* witt_vector p S :=
  ring_hom.mk (map_fun ⇑f) (map_fun.one f) (map_fun.mul f) (map_fun.zero f) (map_fun.add f)

theorem map_injective {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S] (f : R →+* S) (hf : function.injective ⇑f) : function.injective ⇑(map f) :=
  map_fun.injective (⇑f) hf

theorem map_surjective {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S] (f : R →+* S) (hf : function.surjective ⇑f) : function.surjective ⇑(map f) :=
  map_fun.surjective (⇑f) hf

@[simp] theorem map_coeff {p : ℕ} {R : Type u_1} {S : Type u_2} [hp : fact (nat.prime p)] [comm_ring R] [comm_ring S] (f : R →+* S) (x : witt_vector p R) (n : ℕ) : coeff (coe_fn (map f) x) n = coe_fn f (coeff x n) :=
  rfl

/-- `witt_vector.ghost_map` is a ring homomorphism that maps each Witt vector
to the sequence of its ghost components. -/
def ghost_map {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] : witt_vector p R →+* ℕ → R :=
  ring_hom.mk ghost_fun ghost_fun_one ghost_fun_mul ghost_fun_zero ghost_fun_add

/-- Evaluates the `n`th Witt polynomial on the first `n` coefficients of `x`,
producing a value in `R`. -/
def ghost_component {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (n : ℕ) : witt_vector p R →+* R :=
  ring_hom.comp (ring_hom.apply (fun (i : ℕ) => R) n) ghost_map

theorem ghost_component_apply {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (n : ℕ) (x : witt_vector p R) : coe_fn (ghost_component n) x = coe_fn (mv_polynomial.aeval (coeff x)) (witt_polynomial p ℤ n) :=
  rfl

@[simp] theorem ghost_map_apply {p : ℕ} {R : Type u_1} [hp : fact (nat.prime p)] [comm_ring R] (x : witt_vector p R) (n : ℕ) : coe_fn ghost_map x n = coe_fn (ghost_component n) x :=
  rfl

/-- `witt_vector.ghost_map` is a ring isomorphism when `p` is invertible in `R`. -/
def ghost_equiv (p : ℕ) (R : Type u_1) [hp : fact (nat.prime p)] [comm_ring R] [invertible ↑p] : witt_vector p R ≃+* (ℕ → R) :=
  ring_equiv.mk (ring_hom.to_fun ghost_map) (equiv.inv_fun (ghost_equiv' p R)) sorry sorry sorry sorry

@[simp] theorem ghost_equiv_coe (p : ℕ) (R : Type u_1) [hp : fact (nat.prime p)] [comm_ring R] [invertible ↑p] : ↑(ghost_equiv p R) = ghost_map :=
  rfl

theorem ghost_map.bijective_of_invertible (p : ℕ) (R : Type u_1) [hp : fact (nat.prime p)] [comm_ring R] [invertible ↑p] : function.bijective ⇑ghost_map :=
  ring_equiv.bijective (ghost_equiv p R)


/-
Copyright (c) 2020 Floris van Doorn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Floris van Doorn
-/
import tactic.interval_cases
import algebra.big_operators.order
import algebra.big_operators.enat
import data.nat.multiplicity

/-!
# IMO 2019 Q4

Find all pairs `(k, n)` of positive integers such that
```
  k! = (2 ^ n − 1)(2 ^ n − 2)(2 ^ n − 4)···(2 ^ n − 2 ^ (n − 1))
```
We show in this file that this property holds iff `(k, n) = (1, 1) ∨ (k, n) = (3, 2)`.

Proof sketch:
The idea of the proof is to count the factors of 2 on both sides. The LHS has less than `k` factors
of 2, and the RHS has exactly `n * (n - 1) / 2` factors of 2. So we know that `n * (n - 1) / 2 < k`.
Now for `n ≥ 6` we have `RHS < 2 ^ (n ^ 2) < (n(n-1)/2)! < k!`. We then treat the cases `n < 6`
individually.
-/

open_locale nat big_operators
open finset multiplicity nat (hiding zero_le prime)

theorem imo2019_q4_upper_bound {k n : ℕ} (hk : k > 0)
  (h : (k! : ℤ) = ∏ i in range n, (2 ^ n - 2 ^ i)) : n < 6 :=
begin
  have prime_2 : prime (2 : ℤ),
  { exact prime_iff_prime_int.mp prime_two },
  have h2 : n * (n - 1) / 2 < k,
  { suffices : multiplicity 2 (k! : ℤ) = (n * (n - 1) / 2 : ℕ),
    { rw [← enat.coe_lt_coe, ← this], change multiplicity ((2 : ℕ) : ℤ) _ < _,
      simp_rw [int.coe_nat_multiplicity, multiplicity_two_factorial_lt hk.lt.ne.symm] },
    rw [h, multiplicity.finset.prod prime_2, ← sum_range_id, ← sum_nat_coe_enat],
    apply sum_congr rfl, intros i hi,
    rw [multiplicity_sub_of_gt, multiplicity_pow_self_of_prime prime_2],
    rwa [multiplicity_pow_self_of_prime prime_2, multiplicity_pow_self_of_prime prime_2,
      enat.coe_lt_coe, ←mem_range] },
  rw [←not_le], intro hn,
  apply ne_of_lt _ h.symm,
  suffices : (∏ i in range n, 2 ^ n : ℤ) < ↑k!,
  { apply lt_of_le_of_lt _ this, apply prod_le_prod,
    { intros, rw [sub_nonneg], apply pow_le_pow, norm_num, apply le_of_lt, rwa [← mem_range] },
    { intros, apply sub_le_self, apply pow_nonneg, norm_num } },
  suffices : 2 ^ (n * n) < (n * (n - 1) / 2)!,
  { rw [prod_const, card_range, ← pow_mul], rw [← int.coe_nat_lt_coe_nat_iff] at this,
    clear h, convert this.trans _, norm_cast, rwa [int.coe_nat_lt_coe_nat_iff, factorial_lt],
    refine nat.div_pos _ (by norm_num),
    refine le_trans _ (mul_le_mul hn (pred_le_pred hn) (zero_le _) (zero_le _)),
    norm_num },
  refine le_induction _ _ n hn, { norm_num },
  intros n' hn' ih,
  have h5 : 1 ≤ 2 * n', { linarith },
  have : 2 ^ (2 + 2) ≤ (n' * (n' - 1) / 2).succ,
  { change succ (6 * (6 - 1) / 2) ≤ _,
    apply succ_le_succ, apply nat.div_le_div_right,
    exact mul_le_mul hn' (pred_le_pred hn') (zero_le _) (zero_le _) },
  rw [triangle_succ], apply lt_of_lt_of_le _ factorial_mul_pow_le_factorial,
  refine lt_of_le_of_lt _ (mul_lt_mul ih (nat.pow_le_pow_of_le_left this _)
    (pow_pos (by norm_num) _) (zero_le _)),
  rw [← pow_mul, ← pow_add], apply pow_le_pow_of_le_right, norm_num,
  rw [add_mul 2 2],
  convert add_le_add_left (add_le_add_left h5 (2 * n')) (n' * n') using 1, ring
end

theorem imo2019_q4 {k n : ℕ} (hk : k > 0) (hn : n > 0) :
  (k! : ℤ) = (∏ i in range n, (2 ^ n - 2 ^ i)) ↔ (k, n) = (1, 1) ∨ (k, n) = (3, 2) :=
begin
  /- The implication `←` holds. -/
  split, swap,
  { rintro (h|h); simp [prod.ext_iff] at h; rcases h with ⟨rfl, rfl⟩;
    norm_num [prod_range_succ, succ_mul] },
  intro h,
  /- We know that n < 6. -/
  have := imo2019_q4_upper_bound hk h,
  interval_cases n,
  /- n = 1 -/
  { left, congr, norm_num at h, norm_cast at h, rw [factorial_eq_one] at h, apply antisymm h,
    apply succ_le_of_lt hk },
  /- n = 2 -/
  { right, congr, norm_num [prod_range_succ] at h, norm_cast at h, rw [← factorial_inj],
    exact h, rw [h], norm_num },
  all_goals { exfalso, norm_num [prod_range_succ] at h, norm_cast at h, },
  /- n = 3 -/
  { refine monotone_factorial.ne_of_lt_of_lt_nat 5 _ _ _ h; norm_num },
  /- n = 4 -/
  { refine monotone_factorial.ne_of_lt_of_lt_nat 7 _ _ _ h; norm_num },
  /- n = 5 -/
  { refine monotone_factorial.ne_of_lt_of_lt_nat 10 _ _ _ h; norm_num },
end


/-
Copyright (c) 2019 Sébastien Gouëzel. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Sébastien Gouëzel
-/
import analysis.specific_limits.basic
import topology.metric_space.hausdorff_distance
import topology.sets.compacts

/-!
# Closed subsets

This file defines the metric and emetric space structure on the types of closed subsets and nonempty
compact subsets of a metric or emetric space.

The Hausdorff distance induces an emetric space structure on the type of closed subsets
of an emetric space, called `closeds`. Its completeness, resp. compactness, resp.
second-countability, follow from the corresponding properties of the original space.

In a metric space, the type of nonempty compact subsets (called `nonempty_compacts`) also
inherits a metric space structure from the Hausdorff distance, as the Hausdorff edistance is
always finite in this context.
-/

noncomputable theory
open_locale classical topology ennreal

universe u
open classical set function topological_space filter

namespace emetric
section
variables {α : Type u} [emetric_space α] {s : set α}

/-- In emetric spaces, the Hausdorff edistance defines an emetric space structure
on the type of closed subsets -/
instance closeds.emetric_space : emetric_space (closeds α) :=
{ edist               := λs t, Hausdorff_edist (s : set α) t,
  edist_self          := λs, Hausdorff_edist_self,
  edist_comm          := λs t, Hausdorff_edist_comm,
  edist_triangle      := λs t u, Hausdorff_edist_triangle,
  eq_of_edist_eq_zero :=
    λ s t h, closeds.ext $ (Hausdorff_edist_zero_iff_eq_of_closed s.closed t.closed).1 h }

/-- The edistance to a closed set depends continuously on the point and the set -/
lemma continuous_inf_edist_Hausdorff_edist :
  continuous (λ p : α × (closeds α), inf_edist p.1 p.2) :=
begin
  refine continuous_of_le_add_edist 2 (by simp) _,
  rintros ⟨x, s⟩ ⟨y, t⟩,
  calc inf_edist x s ≤ inf_edist x t + Hausdorff_edist (t : set α) s :
    inf_edist_le_inf_edist_add_Hausdorff_edist
  ... ≤ inf_edist y t + edist x y + Hausdorff_edist (t : set α) s :
    add_le_add_right inf_edist_le_inf_edist_add_edist _
  ... = inf_edist y t + (edist x y + Hausdorff_edist (s : set α) t)
      : by rw [add_assoc, Hausdorff_edist_comm]
  ... ≤ inf_edist y t + (edist (x, s) (y, t) + edist (x, s) (y, t)) :
    add_le_add_left (add_le_add (le_max_left _ _) (le_max_right _ _)) _
  ... = inf_edist y t + 2 * edist (x, s) (y, t) :
    by rw [← mul_two, mul_comm]
end

/-- Subsets of a given closed subset form a closed set -/
lemma is_closed_subsets_of_is_closed (hs : is_closed s) :
  is_closed {t : closeds α | (t : set α) ⊆ s} :=
begin
  refine is_closed_of_closure_subset (λt ht x hx, _),
  -- t : closeds α,  ht : t ∈ closure {t : closeds α | t ⊆ s},
  -- x : α,  hx : x ∈ t
  -- goal : x ∈ s
  have : x ∈ closure s,
  { refine mem_closure_iff.2 (λε εpos, _),
    rcases mem_closure_iff.1 ht ε εpos with ⟨u, hu, Dtu⟩,
    -- u : closeds α,  hu : u ∈ {t : closeds α | t ⊆ s},  hu' : edist t u < ε
    rcases exists_edist_lt_of_Hausdorff_edist_lt hx Dtu with ⟨y, hy, Dxy⟩,
    -- y : α,  hy : y ∈ u, Dxy : edist x y < ε
    exact ⟨y, hu hy, Dxy⟩ },
  rwa hs.closure_eq at this,
end

/-- By definition, the edistance on `closeds α` is given by the Hausdorff edistance -/
lemma closeds.edist_eq {s t : closeds α} : edist s t = Hausdorff_edist (s : set α) t := rfl

/-- In a complete space, the type of closed subsets is complete for the
Hausdorff edistance. -/
instance closeds.complete_space [complete_space α] : complete_space (closeds α) :=
begin
  /- We will show that, if a sequence of sets `s n` satisfies
  `edist (s n) (s (n+1)) < 2^{-n}`, then it converges. This is enough to guarantee
  completeness, by a standard completeness criterion.
  We use the shorthand `B n = 2^{-n}` in ennreal. -/
  let B : ℕ → ℝ≥0∞ := λ n, (2⁻¹)^n,
  have B_pos : ∀ n, (0:ℝ≥0∞) < B n,
    by simp [B, ennreal.pow_pos],
  have B_ne_top : ∀ n, B n ≠ ⊤,
    by simp [B, ennreal.pow_ne_top],
  /- Consider a sequence of closed sets `s n` with `edist (s n) (s (n+1)) < B n`.
  We will show that it converges. The limit set is t0 = ⋂n, closure (⋃m≥n, s m).
  We will have to show that a point in `s n` is close to a point in `t0`, and a point
  in `t0` is close to a point in `s n`. The completeness then follows from a
  standard criterion. -/
  refine complete_of_convergent_controlled_sequences B B_pos (λs hs, _),
  let t0 := ⋂ n, closure (⋃ m ≥ n, s m : set α),
  let t : closeds α := ⟨t0, is_closed_Inter (λ_, is_closed_closure)⟩,
  use t,
  -- The inequality is written this way to agree with `edist_le_of_edist_le_geometric_of_tendsto₀`
  have I1 : ∀ n, ∀ x ∈ s n, ∃ y ∈ t0, edist x y ≤ 2 * B n,
  { /- This is the main difficulty of the proof. Starting from `x ∈ s n`, we want
       to find a point in `t0` which is close to `x`. Define inductively a sequence of
       points `z m` with `z n = x` and `z m ∈ s m` and `edist (z m) (z (m+1)) ≤ B m`. This is
       possible since the Hausdorff distance between `s m` and `s (m+1)` is at most `B m`.
       This sequence is a Cauchy sequence, therefore converging as the space is complete, to
       a limit which satisfies the required properties. -/
    assume n x hx,
    obtain ⟨z, hz₀, hz⟩ : ∃ z : Π l, s (n + l), (z 0 : α) = x ∧
      ∀ k, edist (z k:α) (z (k+1):α) ≤ B n / 2^k,
    { -- We prove existence of the sequence by induction.
      have : ∀ l (z : s (n + l)), ∃ z' : s (n + l + 1), edist (z : α) z' ≤ B n / 2^l,
      { assume l z,
        obtain ⟨z', z'_mem, hz'⟩ : ∃ z' ∈ s (n + l + 1), edist (z : α) z' < B n / 2^l,
        { refine exists_edist_lt_of_Hausdorff_edist_lt _ _,
          { exact s (n + l) },
          { exact z.2 },
          simp only [B, ennreal.inv_pow, div_eq_mul_inv],
          rw [← pow_add],
          apply hs; simp },
        exact ⟨⟨z', z'_mem⟩, le_of_lt hz'⟩ },
      use [λ k, nat.rec_on k ⟨x, hx⟩ (λl z, some (this l z)), rfl],
      exact λ k, some_spec (this k _) },
    -- it follows from the previous bound that `z` is a Cauchy sequence
    have : cauchy_seq (λ k, ((z k):α)),
      from cauchy_seq_of_edist_le_geometric_two (B n) (B_ne_top n) hz,
    -- therefore, it converges
    rcases cauchy_seq_tendsto_of_complete this with ⟨y, y_lim⟩,
    use y,
    -- the limit point `y` will be the desired point, in `t0` and close to our initial point `x`.
    -- First, we check it belongs to `t0`.
    have : y ∈ t0 := mem_Inter.2 (λk, mem_closure_of_tendsto y_lim
    begin
      simp only [exists_prop, set.mem_Union, filter.eventually_at_top, set.mem_preimage,
        set.preimage_Union],
      exact ⟨k, λ m hm, ⟨n+m, zero_add k ▸ add_le_add (zero_le n) hm, (z m).2⟩⟩
    end),
    use this,
    -- Then, we check that `y` is close to `x = z n`. This follows from the fact that `y`
    -- is the limit of `z k`, and the distance between `z n` and `z k` has already been estimated.
    rw [← hz₀],
    exact edist_le_of_edist_le_geometric_two_of_tendsto₀ (B n) hz y_lim },
  have I2 : ∀ n, ∀ x ∈ t0, ∃ y ∈ s n, edist x y ≤ 2 * B n,
  { /- For the (much easier) reverse inequality, we start from a point `x ∈ t0` and we want
        to find a point `y ∈ s n` which is close to `x`.
        `x` belongs to `t0`, the intersection of the closures. In particular, it is well
        approximated by a point `z` in `⋃m≥n, s m`, say in `s m`. Since `s m` and
        `s n` are close, this point is itself well approximated by a point `y` in `s n`,
        as required. -/
    assume n x xt0,
    have : x ∈ closure (⋃ m ≥ n, s m : set α), by apply mem_Inter.1 xt0 n,
    rcases mem_closure_iff.1 this (B n) (B_pos n) with ⟨z, hz, Dxz⟩,
    -- z : α,  Dxz : edist x z < B n,
    simp only [exists_prop, set.mem_Union] at hz,
    rcases hz with ⟨m, ⟨m_ge_n, hm⟩⟩,
    -- m : ℕ, m_ge_n : m ≥ n, hm : z ∈ s m
    have : Hausdorff_edist (s m : set α) (s n) < B n := hs n m n m_ge_n (le_refl n),
    rcases exists_edist_lt_of_Hausdorff_edist_lt hm this with ⟨y, hy, Dzy⟩,
    -- y : α,  hy : y ∈ s n,  Dzy : edist z y < B n
    exact ⟨y, hy, calc
      edist x y ≤ edist x z + edist z y : edist_triangle _ _ _
            ... ≤ B n + B n : add_le_add (le_of_lt Dxz) (le_of_lt Dzy)
            ... = 2 * B n : (two_mul _).symm ⟩ },
  -- Deduce from the above inequalities that the distance between `s n` and `t0` is at most `2 B n`.
  have main : ∀n:ℕ, edist (s n) t ≤ 2 * B n := λn, Hausdorff_edist_le_of_mem_edist (I1 n) (I2 n),
  -- from this, the convergence of `s n` to `t0` follows.
  refine tendsto_at_top.2 (λε εpos, _),
  have : tendsto (λn, 2 * B n) at_top (𝓝 (2 * 0)),
    from ennreal.tendsto.const_mul
      (ennreal.tendsto_pow_at_top_nhds_0_of_lt_1 $ by simp [ennreal.one_lt_two])
      (or.inr $ by simp),
  rw mul_zero at this,
  obtain ⟨N, hN⟩ : ∃ N, ∀ b ≥ N, ε > 2 * B b,
    from ((tendsto_order.1 this).2 ε εpos).exists_forall_of_at_top,
  exact ⟨N, λn hn, lt_of_le_of_lt (main n) (hN n hn)⟩
end

/-- In a compact space, the type of closed subsets is compact. -/
instance closeds.compact_space [compact_space α] : compact_space (closeds α) :=
⟨begin
  /- by completeness, it suffices to show that it is totally bounded,
    i.e., for all ε>0, there is a finite set which is ε-dense.
    start from a set `s` which is ε-dense in α. Then the subsets of `s`
    are finitely many, and ε-dense for the Hausdorff distance. -/
  refine is_compact_of_totally_bounded_is_closed (emetric.totally_bounded_iff.2 (λε εpos, _))
    is_closed_univ,
  rcases exists_between εpos with ⟨δ, δpos, δlt⟩,
  rcases emetric.totally_bounded_iff.1
    (is_compact_iff_totally_bounded_is_complete.1 (@is_compact_univ α _ _)).1 δ δpos
    with ⟨s, fs, hs⟩,
  -- s : set α,  fs : s.finite,  hs : univ ⊆ ⋃ (y : α) (H : y ∈ s), eball y δ
  -- we first show that any set is well approximated by a subset of `s`.
  have main : ∀ u : set α, ∃v ⊆ s, Hausdorff_edist u v ≤ δ,
  { assume u,
    let v := {x : α | x ∈ s ∧ ∃y∈u, edist x y < δ},
    existsi [v, ((λx hx, hx.1) : v ⊆ s)],
    refine Hausdorff_edist_le_of_mem_edist _ _,
    { assume x hx,
      have : x ∈ ⋃y ∈ s, ball y δ := hs (by simp),
      rcases mem_Union₂.1 this with ⟨y, ys, dy⟩,
      have : edist y x < δ := by simp at dy; rwa [edist_comm] at dy,
      exact ⟨y, ⟨ys, ⟨x, hx, this⟩⟩, le_of_lt dy⟩ },
    { rintros x ⟨hx1, ⟨y, yu, hy⟩⟩,
      exact ⟨y, yu, le_of_lt hy⟩ }},
  -- introduce the set F of all subsets of `s` (seen as members of `closeds α`).
  let F := {f : closeds α | (f : set α) ⊆ s},
  refine ⟨F, _, λ u _, _⟩,
  -- `F` is finite
  { apply @finite.of_finite_image _ _ F coe,
    { apply fs.finite_subsets.subset (λb, _),
      simp only [and_imp, set.mem_image, set.mem_set_of_eq, exists_imp_distrib],
      assume x hx hx',
      rwa hx' at hx },
    { exact set_like.coe_injective.inj_on F } },

  -- `F` is ε-dense
  { obtain ⟨t0, t0s, Dut0⟩ := main u,
    have : is_closed t0 := (fs.subset t0s).is_compact.is_closed,
    let t : closeds α := ⟨t0, this⟩,
    have : t ∈ F := t0s,
    have : edist u t < ε := lt_of_le_of_lt Dut0 δlt,
    apply mem_Union₂.2,
    exact ⟨t, ‹t ∈ F›, this⟩ }
end⟩

/-- In an emetric space, the type of non-empty compact subsets is an emetric space,
where the edistance is the Hausdorff edistance -/
instance nonempty_compacts.emetric_space : emetric_space (nonempty_compacts α) :=
{ edist               := λ s t, Hausdorff_edist (s : set α) t,
  edist_self          := λs, Hausdorff_edist_self,
  edist_comm          := λs t, Hausdorff_edist_comm,
  edist_triangle      := λs t u, Hausdorff_edist_triangle,
  eq_of_edist_eq_zero := λ s t h, nonempty_compacts.ext $ begin
    have : closure (s : set α) = closure t := Hausdorff_edist_zero_iff_closure_eq_closure.1 h,
    rwa [s.is_compact.is_closed.closure_eq, t.is_compact.is_closed.closure_eq] at this,
  end }

/-- `nonempty_compacts.to_closeds` is a uniform embedding (as it is an isometry) -/
lemma nonempty_compacts.to_closeds.uniform_embedding :
  uniform_embedding (@nonempty_compacts.to_closeds α _ _) :=
isometry.uniform_embedding $ λx y, rfl

/-- The range of `nonempty_compacts.to_closeds` is closed in a complete space -/
lemma nonempty_compacts.is_closed_in_closeds [complete_space α] :
  is_closed (range $ @nonempty_compacts.to_closeds α _ _) :=
begin
  have : range nonempty_compacts.to_closeds =
    {s : closeds α | (s : set α).nonempty ∧ is_compact (s : set α) },
  { ext s,
    refine ⟨_, λ h, ⟨⟨⟨s, h.2⟩, h.1⟩, closeds.ext rfl⟩⟩,
    rintro ⟨s, hs, rfl⟩,
    exact ⟨s.nonempty, s.is_compact⟩ },
  rw this,
  refine is_closed_of_closure_subset (λs hs, ⟨_, _⟩),
  { -- take a set set t which is nonempty and at a finite distance of s
    rcases mem_closure_iff.1 hs ⊤ ennreal.coe_lt_top with ⟨t, ht, Dst⟩,
    rw edist_comm at Dst,
    -- since `t` is nonempty, so is `s`
    exact nonempty_of_Hausdorff_edist_ne_top ht.1 (ne_of_lt Dst) },
  { refine is_compact_iff_totally_bounded_is_complete.2 ⟨_, s.closed.is_complete⟩,
    refine totally_bounded_iff.2 (λε (εpos : 0 < ε), _),
    -- we have to show that s is covered by finitely many eballs of radius ε
    -- pick a nonempty compact set t at distance at most ε/2 of s
    rcases mem_closure_iff.1 hs (ε/2) (ennreal.half_pos εpos.ne') with ⟨t, ht, Dst⟩,
    -- cover this space with finitely many balls of radius ε/2
    rcases totally_bounded_iff.1 (is_compact_iff_totally_bounded_is_complete.1 ht.2).1 (ε/2)
      (ennreal.half_pos εpos.ne') with ⟨u, fu, ut⟩,
    refine ⟨u, ⟨fu, λx hx, _⟩⟩,
    -- u : set α,  fu : u.finite,  ut : t ⊆ ⋃ (y : α) (H : y ∈ u), eball y (ε / 2)
    -- then s is covered by the union of the balls centered at u of radius ε
    rcases exists_edist_lt_of_Hausdorff_edist_lt hx Dst with ⟨z, hz, Dxz⟩,
    rcases mem_Union₂.1 (ut hz) with ⟨y, hy, Dzy⟩,
    have : edist x y < ε := calc
      edist x y ≤ edist x z + edist z y : edist_triangle _ _ _
      ... < ε/2 + ε/2 : ennreal.add_lt_add Dxz Dzy
      ... = ε : ennreal.add_halves _,
    exact mem_bUnion hy this },
end

/-- In a complete space, the type of nonempty compact subsets is complete. This follows
from the same statement for closed subsets -/
instance nonempty_compacts.complete_space [complete_space α] :
  complete_space (nonempty_compacts α) :=
(complete_space_iff_is_complete_range
  nonempty_compacts.to_closeds.uniform_embedding.to_uniform_inducing).2 $
  nonempty_compacts.is_closed_in_closeds.is_complete

/-- In a compact space, the type of nonempty compact subsets is compact. This follows from
the same statement for closed subsets -/
instance nonempty_compacts.compact_space [compact_space α] : compact_space (nonempty_compacts α) :=
⟨begin
  rw nonempty_compacts.to_closeds.uniform_embedding.embedding.is_compact_iff_is_compact_image,
  rw [image_univ],
  exact nonempty_compacts.is_closed_in_closeds.is_compact
end⟩

/-- In a second countable space, the type of nonempty compact subsets is second countable -/
instance nonempty_compacts.second_countable_topology [second_countable_topology α] :
  second_countable_topology (nonempty_compacts α) :=
begin
  haveI : separable_space (nonempty_compacts α) :=
  begin
    /- To obtain a countable dense subset of `nonempty_compacts α`, start from
    a countable dense subset `s` of α, and then consider all its finite nonempty subsets.
    This set is countable and made of nonempty compact sets. It turns out to be dense:
    by total boundedness, any compact set `t` can be covered by finitely many small balls, and
    approximations in `s` of the centers of these balls give the required finite approximation
    of `t`. -/
    rcases exists_countable_dense α with ⟨s, cs, s_dense⟩,
    let v0 := {t : set α | t.finite ∧ t ⊆ s},
    let v : set (nonempty_compacts α) := {t : nonempty_compacts α | (t : set α) ∈ v0},
    refine  ⟨⟨v, _, _⟩⟩,
    { have : v0.countable, from countable_set_of_finite_subset cs,
      exact this.preimage set_like.coe_injective },
    { refine λt, mem_closure_iff.2 (λε εpos, _),
      -- t is a compact nonempty set, that we have to approximate uniformly by a a set in `v`.
      rcases exists_between εpos with ⟨δ, δpos, δlt⟩,
      have δpos' : 0 < δ / 2, from ennreal.half_pos δpos.ne',
      -- construct a map F associating to a point in α an approximating point in s, up to δ/2.
      have Exy : ∀x, ∃y, y ∈ s ∧ edist x y < δ/2,
      { assume x,
        rcases mem_closure_iff.1 (s_dense x) (δ/2) δpos' with ⟨y, ys, hy⟩,
        exact ⟨y, ⟨ys, hy⟩⟩ },
      let F := λx, some (Exy x),
      have Fspec : ∀x, F x ∈ s ∧ edist x (F x) < δ/2 := λx, some_spec (Exy x),

      -- cover `t` with finitely many balls. Their centers form a set `a`
      have : totally_bounded (t : set α) := t.is_compact.totally_bounded,
      rcases totally_bounded_iff.1 this (δ/2) δpos' with ⟨a, af, ta⟩,
      -- a : set α,  af : a.finite,  ta : t ⊆ ⋃ (y : α) (H : y ∈ a), eball y (δ / 2)
      -- replace each center by a nearby approximation in `s`, giving a new set `b`
      let b := F '' a,
      have : b.finite := af.image _,
      have tb : ∀ x ∈ t, ∃ y ∈ b, edist x y < δ,
      { assume x hx,
        rcases mem_Union₂.1 (ta hx) with ⟨z, za, Dxz⟩,
        existsi [F z, mem_image_of_mem _ za],
        calc edist x (F z) ≤ edist x z + edist z (F z) : edist_triangle _ _ _
             ... < δ/2 + δ/2 : ennreal.add_lt_add Dxz (Fspec z).2
             ... = δ : ennreal.add_halves _ },
      -- keep only the points in `b` that are close to point in `t`, yielding a new set `c`
      let c := {y ∈ b | ∃ x ∈ t, edist x y < δ},
      have : c.finite := ‹b.finite›.subset (λx hx, hx.1),
      -- points in `t` are well approximated by points in `c`
      have tc : ∀ x ∈ t, ∃ y ∈ c, edist x y ≤ δ,
      { assume x hx,
        rcases tb x hx with ⟨y, yv, Dxy⟩,
        have : y ∈ c := by simp [c, -mem_image]; exact ⟨yv, ⟨x, hx, Dxy⟩⟩,
        exact ⟨y, this, le_of_lt Dxy⟩ },
      -- points in `c` are well approximated by points in `t`
      have ct : ∀ y ∈ c, ∃ x ∈ t, edist y x ≤ δ,
      { rintro y ⟨hy1, x, xt, Dyx⟩,
        have : edist y x ≤ δ := calc
          edist y x = edist x y : edist_comm _ _
          ... ≤ δ : le_of_lt Dyx,
        exact ⟨x, xt, this⟩ },
      -- it follows that their Hausdorff distance is small
      have : Hausdorff_edist (t :set α) c ≤ δ :=
        Hausdorff_edist_le_of_mem_edist tc ct,
      have Dtc : Hausdorff_edist (t : set α) c < ε := this.trans_lt δlt,
      -- the set `c` is not empty, as it is well approximated by a nonempty set
      have hc : c.nonempty,
        from nonempty_of_Hausdorff_edist_ne_top t.nonempty (ne_top_of_lt Dtc),
      -- let `d` be the version of `c` in the type `nonempty_compacts α`
      let d : nonempty_compacts α := ⟨⟨c, ‹c.finite›.is_compact⟩, hc⟩,
      have : c ⊆ s,
      { assume x hx,
        rcases (mem_image _ _ _).1 hx.1 with ⟨y, ⟨ya, yx⟩⟩,
        rw ← yx,
        exact (Fspec y).1 },
      have : d ∈ v := ⟨‹c.finite›, this⟩,
      -- we have proved that `d` is a good approximation of `t` as requested
      exact ⟨d, ‹d ∈ v›, Dtc⟩ },
  end,
  exact uniform_space.second_countable_of_separable (nonempty_compacts α),
end

end --section
end emetric --namespace

namespace metric
section

variables {α : Type u} [metric_space α]

/-- `nonempty_compacts α` inherits a metric space structure, as the Hausdorff
edistance between two such sets is finite. -/
instance nonempty_compacts.metric_space : metric_space (nonempty_compacts α) :=
emetric_space.to_metric_space $ λ x y, Hausdorff_edist_ne_top_of_nonempty_of_bounded
  x.nonempty y.nonempty x.is_compact.bounded y.is_compact.bounded

/-- The distance on `nonempty_compacts α` is the Hausdorff distance, by construction -/
lemma nonempty_compacts.dist_eq {x y : nonempty_compacts α} :
  dist x y = Hausdorff_dist (x : set α) y := rfl

lemma lipschitz_inf_dist_set (x : α) : lipschitz_with 1 (λ s : nonempty_compacts α, inf_dist x s) :=
lipschitz_with.of_le_add $ assume s t,
by { rw dist_comm,
  exact inf_dist_le_inf_dist_add_Hausdorff_dist (edist_ne_top t s) }

lemma uniform_continuous_inf_dist_Hausdorff_dist :
  uniform_continuous (λ p : α × (nonempty_compacts α), inf_dist p.1 p.2) :=
lipschitz_inf_dist.uniform_continuous

end --section
end metric --namespace


import Playlean4.Group.Basic
import Playlean4.Group.Subgroup
import Playlean4.Group.Action
import Playlean4.Group.OnSet

set_option quotPrecheck.allowSectionVars true

namespace Group

namespace Subgroup

variable {G : Type} (law : G → G → G) [grp : Group G law]

local infixl:70 " * " => id' law
@[appUnexpander id'] def unexpandGMul' : Lean.PrettyPrinter.Unexpander
  | `(id' law $x $y) => `($x * $y)
  | _ => throw ()
local notation "one" => grp.one' -- HACK
local notation g"⁻¹" => grp.inv g

section

variable (H : Set G) [sg : Subgroup G law H]

local infixl:70 " * " => id' (subgroupLaw law H)
@[appUnexpander id'] def unexpandHMul : Lean.PrettyPrinter.Unexpander
  | `(id' (subgroupLaw law H) $x $y) => `($x * $y)
  | _ => throw ()

local infix:70 " •ₗ " => Action.Remarkable.OnSet.leftTranslationOnSet law
local notation:70 lhs:70 " •ᵣ " rhs:70 => Action.Remarkable.OnSet.rightTranslationOnSet law rhs lhs
local infix:70 " ••  " => Action.Remarkable.OnSet.conjugationOnSet law

def leftClasses : Set (Set G) := Action.orbit
  (Action.Remarkable.liftToSet (Action.Remarkable.onSelf law)) H
def leftClassesAction : G → leftClasses law H → leftClasses law H :=
  Action.Remarkable.onOrbit law
  (Action.Remarkable.liftToSet (Action.Remarkable.onSelf law)) H
def subgroupAsLeftClass : leftClasses law H := ⟨ H, (Action.memOfSelfOrbit law _ H) ⟩

def rightClasses : Set (Set G) := Action.orbit
  (Action.Remarkable.liftToSet (Action.Remarkable.onSelf (lawᵒᵖ))) H
def rightClassesAction : G → rightClasses law H → rightClasses law H :=
  Action.Remarkable.onOrbit (lawᵒᵖ)
  (Action.Remarkable.liftToSet (Action.Remarkable.onSelf (lawᵒᵖ))) H
def subgroupAsRightClass : rightClasses law H := ⟨ H, (Action.memOfSelfOrbit (lawᵒᵖ) _ H) ⟩

theorem leftClassesOnOp : leftClasses (lawᵒᵖ) H = rightClasses law H := rfl
theorem rightClassesOnOp : rightClasses (lawᵒᵖ) H = leftClasses law H := rfl

theorem leftClassIff (P : Set G) : P ∈ leftClasses law H ↔ ∃ g : G, P = g •ₗ H :=
by
  have p₀ : ∀ {p q : Prop}, (p = q) → (p ↔ q)
  by intro p q h; rw [h]; simp
  apply p₀
  rfl

theorem rightClassIff (P : Set G) : P ∈ rightClasses law H ↔ ∃ g : G, P = H •ᵣ g :=
by
  have p₀ : ∀ {p q : Prop}, (p = q) → (p ↔ q)
  by intro p q h; rw [h]; simp
  apply p₀
  rfl

theorem leftClassMemIff {P : Set G} (PIn : P ∈ leftClasses law H)
  {g : G} (gIn : g ∈ P) (g' : G) : g' ∈ P ↔ ∃ h, h ∈ H ∧ g' = g * h :=
by
  rw [PIn.2]
  rw [PIn.2] at gIn
  have p₀ : ∃ h, h ∈ H ∧ g = PIn.1 * h from gIn
  apply Iff.intro
  exact λ h => have p₁ : ∃ h, h ∈ H ∧ g' = PIn.1 * h from h
    match p₀, p₁ with
    | ⟨ h₀, ⟨ h₀Mem, p₀ ⟩ ⟩, ⟨ h₁, ⟨ h₁Mem, p₁ ⟩ ⟩ => ⟨ (h₀⁻¹ * h₁),
        And.intro (sg.mulMem (sg.invMem h₀Mem) h₁Mem) (by rw [p₀, p₁]; simp) ⟩
  exact λ p₁ => match p₀, p₁ with
    | ⟨ h₀, ⟨ h₀Mem, p₀ ⟩ ⟩, ⟨ h₁, ⟨ h₁Mem, p₁ ⟩ ⟩ => ⟨ h₀ * h₁,
        ⟨ (sg.mulMem h₀Mem h₁Mem), (by rw [p₁, p₀, assoc]; rfl) ⟩ ⟩

theorem rightClassMemIff {P : Set G} (PIn : P ∈ rightClasses law H)
  {g : G} (gIn : g ∈ P) (g' : G) : g' ∈ P ↔ ∃ h, h ∈ H ∧ g' = h * g :=
leftClassMemIff (lawᵒᵖ) H PIn gIn g'

def leftClassOf (g : G) : leftClasses law H :=
  leftClassesAction law H g ⟨ H, Action.memOfSelfOrbit law _ H ⟩
def rightClassOf (g : G) : rightClasses law H :=
  rightClassesAction law H g ⟨ H, Action.memOfSelfOrbit (lawᵒᵖ) _ H ⟩

theorem memOfLeftClassOf (g : G) : g ∈ leftClassOf law H g :=
⟨ one, ⟨ oneMem, (grp.oneNeutralRight g).symm ⟩ ⟩
theorem memOfRightClassOf (g : G) : g ∈ rightClassOf law H g :=
⟨ one, ⟨ oneMem, (grp.oneNeutralLeft g).symm ⟩ ⟩

theorem subgroupStabilizer :
  Action.stabilizer (leftClassesAction law H) (subgroupAsLeftClass law H) = H :=
by
  funext x
  apply propext
  apply Iff.intro
  focus
    intro h
    rw [← show _ = H x from (congrFun <| congrArg Subtype.val h) x]
    apply ⟨ one, ⟨ (sg.oneMem), (grp.oneNeutralRight x).symm ⟩ ⟩
  focus
    intro h
    apply Subtype.eq
    funext y
    apply propext
    suffices p : (∃ h₀, h₀ ∈ H ∧ y = x * h₀) ↔ y ∈ H
    by exact p
    exact ⟨ (λ h' => match h' with | ⟨ h₀, ⟨ h₀In, h' ⟩ ⟩ => h' ▸ sg.mulMem h h₀In),
      λ h' => ⟨ (x⁻¹ * y), ⟨ sg.mulMem (sg.invMem h) h', by simp ⟩ ⟩ ⟩

end

end Subgroup

end Group


/-
Copyright (c) 2021 Tianchen Zhao. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Tianchen Zhao
-/
import order.angle

/-!
# Congruence of segments, angles and triangles

This file extends incidence order geometry and defines congruence of segments and angles
to make a Hilbert plane, and then formalises supplementary angles and congruence of triangles.

## Main definitions

* `hilbert_plane` is a class extended `incidence_order_geometry` and defines congruence of `seg`
  and `ang` based on some axioms.

* `triang` is a structure consisting of the three vertices in order.

* `tri_congr` means two triangles are congruence i.e. their segments and angles are congruent.

* `supplementary` means two angles "add" to 180°.

## References

* See [Geometry: Euclid and Beyond]

-/

/--A Hilbert plane extends incidence order geometry. It contains two binary relations, seg
congruence and ang congruence. Intuitionally, they correspond to lengths of two segs and
radians of two angs equal. They subject to the following axioms.
C1 : Given a seg and two distinct points `a` `b`, we find uniquely find a point `c` on the
same side with `b` to `a` such that seg `a` `c` is congruent to the seg. This axiom
corresponds to I.2 and I.3 in Elements.
C2 : seg congruence is an equivalence relation.
C3 : Two segs are congruent if their two parts are congruent.
C4 : Given a proper ang `α` and points `a` `b`, we can find `c` such that `∠c a b`
     is congruent to `α`. `c` is uniquely defined given one side of line `a` `b`.
C5 : ang congruence is an equivalent relation.
C6 : Two triangs are congruent by SAS. This axiom corresponds to I.4 in Elements.
-/
class hilbert_plane extends incidence_order_geometry :=
(seg_congr : seg → seg → Prop)
(C1 : ∀ {a b : pts} {l : seg}, seg_proper l → a ≠ b → ∃ c : pts, same_side_pt a b c ∧
seg_congr l (a-ₛc) ∧ ∀ x : pts, same_side_pt a b x → seg_congr l (a-ₛx) → x = c)
(C2 : (∀ {s₁ s₂ s₃ : seg}, (seg_congr s₁ s₂ → seg_congr s₁ s₃ → seg_congr s₂ s₃))
∧ ∀ (s : seg),  seg_congr s s)
(C3 : ∀ {a b c d e f: pts}, between a b c → between d e f
  → seg_congr (a-ₛb) (d-ₛe) → seg_congr (b-ₛc) (e-ₛf) → seg_congr (a-ₛc) (d-ₛf))
(ang_congr : ang → ang → Prop)
(C4 : ∀ {α : ang} {a b p : pts}, ang_proper α → a ≠ b → p ∉ (a-ₗb)
→ ∃ c : pts, ang_congr α (∠c a b) ∧ same_side_line (a-ₗb) c p
∧ ∀ x : pts, same_side_line (a-ₗb) c x → ang_congr α (∠x a b) → x ∈ (a-ᵣc).inside)
(C5 : (∀ {α β γ : ang}, (ang_congr α β → ang_congr α γ → ang_congr β γ))
∧ ∀ (α : ang), ang_congr α α)
(C6 : ∀ {a b c d e f : pts}, noncol a b c → noncol d e f → seg_congr (a-ₛb) (d-ₛe)
→ seg_congr (a-ₛc) (d-ₛf) → ang_congr (∠b a c) (∠e d f)
→ seg_congr (b-ₛc) (e-ₛf) ∧ ang_congr (∠a b c) (∠d e f) ∧ ang_congr (∠a c b) (∠d f e))

open incidence_geometry incidence_order_geometry hilbert_plane

variables [C : hilbert_plane]

include C

notation a`≅ₛ`b := seg_congr a b

lemma extend_congr_seg {s : seg} {a b : pts} (hs : seg_proper s) (hab : a ≠ b) :
∃ c : pts, same_side_pt a b c ∧ (s ≅ₛ (a-ₛc))
∧ ∀ x : pts, same_side_pt a b x → (s ≅ₛ (a-ₛx)) → x = c := C1 hs hab

lemma extend_congr_seg' {s : seg} {a b : pts} (hs : seg_proper s) (hab : a ≠ b) :
∃ c : pts, diff_side_pt a b c ∧ (s ≅ₛ (a-ₛc))
∧ ∀ x : pts, diff_side_pt a b x → (s ≅ₛ (a-ₛx)) → x = c :=
begin
  cases between_extend hab.symm with c hbac,
  rcases extend_congr_seg hs (between_neq hbac).2.2 with ⟨d, hacd, hd, hu⟩,
  use d, split,
  exact diff_same_side_pt (diff_side_pt_symm (between_diff_side_pt.1 hbac)) hacd,
  split, exact hd,
  { intros x habx hx,
    apply hu x _ hx,
    exact diff_side_pt_cancel (between_diff_side_pt.1 hbac) habx }
end

lemma seg_congr_refl (s : seg) : s ≅ₛ s := C2.2 s

lemma seg_congr_symm {s₁ s₂ : seg} :
(s₁ ≅ₛ s₂) → (s₂ ≅ₛ s₁) := λ h, C2.1 h (seg_congr_refl s₁)

lemma seg_congr_trans {s₁ s₂ s₃ : seg} :
(s₁ ≅ₛ s₂) → (s₂ ≅ₛ s₃) → (s₁ ≅ₛ s₃) := λ h₁ h₂, C2.1 (seg_congr_symm h₁) h₂

lemma seg_unique_same_side {o a b : pts} (hab : same_side_pt o a b) :
((o-ₛa) ≅ₛ (o-ₛb)) → a = b :=
begin
  intro he,
  have hoa := (same_side_pt_neq hab).1.symm,
  rcases extend_congr_seg (seg_proper_iff_neq.2 hoa) hoa with ⟨d, hoad, hd, hu⟩,
  rw hu b hab he,
  exact hu a (same_side_pt_refl hoa) (seg_congr_refl _)
end

lemma congr_seg_add {a b c d e f: pts} : between a b c → between d e f
→ ((a-ₛb) ≅ₛ (d-ₛe)) → ((b-ₛc) ≅ₛ (e-ₛf)) → ((a-ₛc) ≅ₛ (d-ₛf)) :=
λh₁ h₂ h₃ h₄, C3 h₁ h₂ h₃ h₄

lemma congr_seg_sub {a b c d e f : pts} (habc : between a b c) (hdef : same_side_pt d e f)
(habde : (a-ₛb)≅ₛ(d-ₛe)) (hacdf : (a-ₛc)≅ₛ(d-ₛf)) : between d e f ∧ ((b-ₛc)≅ₛ(e-ₛf)) :=
begin
  have hbc := (between_neq habc).2.2,
  have hed := (same_side_pt_neq hdef).1,
  rcases extend_congr_seg' (seg_proper_iff_neq.2 hbc) hed with ⟨f', hdef', hbcef', -⟩,
  rw ←between_diff_side_pt at hdef',
  suffices : f = f',
    rw this, exact ⟨hdef', hbcef'⟩,
  apply seg_unique_same_side,
  exact same_side_pt_trans (same_side_pt_symm hdef) (between_same_side_pt.1 hdef').1,
  apply seg_congr_trans (seg_congr_symm hacdf),
  exact congr_seg_add habc hdef' habde hbcef'
end

notation a`≅ₐ`b := ang_congr a b

lemma ang_congr_refl (α : ang) : α ≅ₐ α := C5.2 α

lemma ang_congr_symm {α β : ang} :
(α ≅ₐ β) → (β ≅ₐ α) := λ h, C5.1 h (ang_congr_refl α)

lemma ang_congr_trans {α β γ : ang} :
(α ≅ₐ β) → (β ≅ₐ γ) → (α ≅ₐ γ) := λ h₁ h₂, C5.1 (ang_congr_symm h₁) h₂

lemma extend_congr_ang {α : ang} {a b p : pts} :
ang_proper α → a ≠ b → p ∉ (a-ₗb)
→ ∃ c : pts, ang_congr α (∠ c a b) ∧ same_side_line (a-ₗb) c p
∧ ∀ x : pts, same_side_line (a-ₗb) c x → ang_congr α (∠x a b) → x ∈ (a-ᵣc).inside := C4

lemma extend_congr_ang' {α : ang} {a b p : pts} :
ang_proper α → a ≠ b → p ∉ (a-ₗb)
→ ∃ c : pts, ang_congr α (∠ c a b) ∧ diff_side_line (a-ₗb) c p :=
begin
  intros hα hab hp,
  have hpa : p ≠ a,
    intro hpa, rw hpa at hp, exact hp (pt_left_in_line a b),
  cases between_extend hpa with q hpaq,
  have haq := (between_neq hpaq).2.2,
  have haqb := col_noncol (col12 (between_col hpaq))
    (noncol_in13' hab hp) haq,
  have := (diff_side_pt_line (between_diff_side_pt.1 hpaq))
    (line_in_lines hab) (pt_left_in_line a b) hp (noncol_in13 haqb),
  rcases extend_congr_ang hα hab (noncol_in13 haqb) with ⟨c, he, hcq, hu⟩,
  use c, split, exact he,
  exact diff_side_line_symm (diff_same_side_line (line_in_lines hab) this (same_side_line_symm hcq))
end

lemma ang_unique_same_side {o a b c : pts} (hoa : o ≠ a) (hbc : same_side_line (o-ₗa) b c)
(hoaboac : ∠ o a b ≅ₐ ∠ o a c) : same_side_pt a b c :=
begin
  have hoab := (same_side_line_noncol hbc hoa).1,
  rw line_symm at hbc,
  rcases extend_congr_ang (ang_proper_iff_noncol.2 hoab) hoa.symm (same_side_line_notin hbc).1
    with ⟨x, hoaboax, hxb, hu⟩,
  rw ang_symm x a o at hoaboax, rw ang_symm at hu,
  rw [ang_symm, ang_symm o a c] at hoaboac,
  have hb := hu b hxb (ang_congr_refl _),
  have hc := hu c (same_side_line_trans (line_in_lines hoa.symm) hxb hbc) hoaboac,
  have hba := (noncol_neq hoab).2.2.symm,
  have hca := (noncol_neq (same_side_line_noncol hbc hoa.symm).2).2.1.symm,
  exact same_side_pt_trans (same_side_pt_symm (ray_in_neq hba hb)) (ray_in_neq hca hc)
end

/--A triang consists of three vertices. Note that it is defined to be ordered. -/
structure triang := (v1 : pts) (v2 : pts) (v3 : pts)

/--Two triangs are congruent if their sides and angs are equal in order. -/
def tri_congr (t₁ t₂ : triang) : Prop :=
((t₁.v1-ₛt₁.v2) ≅ₛ (t₂.v1-ₛt₂.v2)) ∧ ((t₁.v1-ₛt₁.v3) ≅ₛ (t₂.v1-ₛt₂.v3))
∧ ((t₁.v2-ₛt₁.v3) ≅ₛ (t₂.v2-ₛt₂.v3))
∧ ((∠t₁.v2 t₁.v1 t₁.v3 ≅ₐ ∠t₂.v2 t₂.v1 t₂.v3)
∧ (∠t₁.v1 t₁.v2 t₁.v3 ≅ₐ ∠t₂.v1 t₂.v2 t₂.v3)
∧ (∠t₁.v1 t₁.v3 t₁.v2 ≅ₐ ∠t₂.v1 t₂.v3 t₂.v2))

notation a`≅ₜ`b := tri_congr a b

lemma tri_congr_refl (t : triang) : t ≅ₜ t :=
⟨seg_congr_refl _, seg_congr_refl _, seg_congr_refl _,
ang_congr_refl _, ang_congr_refl _, ang_congr_refl _⟩

lemma tri_congr_symm {t₁ t₂ : triang} : (t₁ ≅ₜ t₂) → (t₂ ≅ₜ t₁) :=
λh, ⟨seg_congr_symm h.1, seg_congr_symm h.2.1, seg_congr_symm h.2.2.1,
ang_congr_symm h.2.2.2.1, ang_congr_symm h.2.2.2.2.1, ang_congr_symm h.2.2.2.2.2⟩

lemma tri_congr_trans {t₁ t₂ t₃ : triang} : (t₁ ≅ₜ t₂) → (t₂ ≅ₜ t₃) → (t₁ ≅ₜ t₃) :=
λh₁ h₂, ⟨seg_congr_trans h₁.1 h₂.1, seg_congr_trans h₁.2.1 h₂.2.1,
seg_congr_trans h₁.2.2.1 h₂.2.2.1, ang_congr_trans h₁.2.2.2.1 h₂.2.2.2.1,
ang_congr_trans h₁.2.2.2.2.1 h₂.2.2.2.2.1, ang_congr_trans h₁.2.2.2.2.2 h₂.2.2.2.2.2⟩

/--Define a triang with three vertices. -/
def three_pt_triang (a b c : pts) : triang := ⟨a, b, c⟩

notation `Δ` := three_pt_triang

lemma three_pt_triang_v1 (a b c : pts) : (Δ a b c).v1 = a := rfl

lemma three_pt_triang_v2 (a b c : pts) : (Δ a b c).v2 = b := rfl

lemma three_pt_triang_v3 (a b c : pts) : (Δ a b c).v3 = c := rfl

lemma tri_congr12 {a b c a' b' c': pts} :
((Δ a b c) ≅ₜ (Δ a' b' c')) → ((Δ b a c) ≅ₜ (Δ b' a' c')) :=
begin
  unfold tri_congr,
  rw [three_pt_triang_v1, three_pt_triang_v2, three_pt_triang_v3,
    three_pt_triang_v1, three_pt_triang_v2, three_pt_triang_v3],
  rw [seg_symm, seg_symm a' b'],
  rw [ang_symm a c b, ang_symm a' c' b'],
  tauto
end

lemma tri_congr13 {a b c a' b' c': pts} :
((Δ a b c) ≅ₜ (Δ a' b' c')) → ((Δ c b a) ≅ₜ (Δ c' b' a')) :=
begin
  unfold tri_congr,
  rw [three_pt_triang_v1, three_pt_triang_v2, three_pt_triang_v3,
    three_pt_triang_v1, three_pt_triang_v2, three_pt_triang_v3],
  rw [seg_symm, seg_symm a' b'],
  rw [seg_symm a c, seg_symm a' c'],
  rw [seg_symm b c, seg_symm b' c'],
  rw [ang_symm b a c, ang_symm b' a' c'],
  rw [ang_symm a c b, ang_symm a' c' b'],
  rw [ang_symm a b c, ang_symm a' b' c'],
  tauto
end

lemma tri_congr23 {a b c a' b' c': pts} :
((Δ a b c) ≅ₜ (Δ a' b' c')) → ((Δ a c b) ≅ₜ (Δ a' c' b')) :=
begin
  unfold tri_congr,
  rw [three_pt_triang_v1, three_pt_triang_v1, three_pt_triang_v2, three_pt_triang_v2,
  three_pt_triang_v3, three_pt_triang_v3, three_pt_triang_v1, three_pt_triang_v1,
  three_pt_triang_v2, three_pt_triang_v2, three_pt_triang_v3, three_pt_triang_v3],
  rw [seg_symm, seg_symm a' b'],
  rw [seg_symm a c, seg_symm a' c'],
  rw [seg_symm b c, seg_symm b' c'],
  rw [ang_symm b a c, ang_symm b' a' c'],
  rw [ang_symm a c b, ang_symm a' c' b'],
  rw [ang_symm a b c, ang_symm a' b' c'],
  tauto
end

lemma tri_congr123 {a b c a' b' c': pts} :
((Δ a b c) ≅ₜ (Δ a' b' c')) → ((Δ b c a) ≅ₜ (Δ b' c' a')) := λh, tri_congr23 (tri_congr12 h)

lemma tri_congr132 {a b c a' b' c': pts} :
((Δ a b c) ≅ₜ (Δ a' b' c')) → ((Δ c a b) ≅ₜ (Δ c' a' b')) := λh, tri_congr23 (tri_congr13 h)

lemma tri_congr_seg {a b c a' b' c': pts} (h : (Δ a b c) ≅ₜ (Δ a' b' c')) :
((a-ₛb) ≅ₛ (a'-ₛb')) ∧ ((a-ₛc) ≅ₛ (a'-ₛc')) ∧ ((b-ₛc) ≅ₛ (b'-ₛc')) :=
begin
  unfold tri_congr three_pt_triang at h, simp at h,
  exact ⟨h.1, h.2.1, h.2.2.1⟩
end

lemma tri_congr_ang {a b c a' b' c': pts} (h : (Δ a b c) ≅ₜ (Δ a' b' c')) :
(∠ a b c ≅ₐ ∠ a' b' c') ∧ (∠ b a c ≅ₐ ∠ b' a' c') ∧ (∠ a c b ≅ₐ ∠ a' c' b') :=
begin
  unfold tri_congr three_pt_triang at h, simp at h,
  exact ⟨h.2.2.2.2.1, h.2.2.2.1, h.2.2.2.2.2⟩
end

lemma SAS {ABC DEF : triang}
(h₁ : noncol ABC.v1 ABC.v2 ABC.v3) (h₂ : noncol DEF.v1 DEF.v2 DEF.v3)
(hs₁ : (ABC.v1-ₛABC.v2) ≅ₛ (DEF.v1-ₛDEF.v2)) (hs₂ : (ABC.v1-ₛABC.v3) ≅ₛ (DEF.v1-ₛDEF.v3))
(ha : (∠ABC.v2 ABC.v1 ABC.v3 ≅ₐ ∠DEF.v2 DEF.v1 DEF.v3)) : ABC ≅ₜ DEF :=
⟨hs₁, hs₂, (C6 h₁ h₂ hs₁ hs₂ ha).1, ha, (C6 h₁ h₂ hs₁ hs₂ ha).2.1, (C6 h₁ h₂ hs₁ hs₂ ha).2.2⟩

lemma supplementary_congr {α α' β β' : ang}
(h : supplementary α α') (h' : supplementary β β') : (α ≅ₐ β) → (α' ≅ₐ β') :=
begin
  rcases h.1 with ⟨a, b, c, d, hα, hα', hcad⟩,
  rcases h'.1 with ⟨a', b', c', d', hβ, hβ', hc'a'd'⟩,
  intro hbacb'a'c',
  rw [hα, hα'] at h, rw [hβ, hβ'] at h',
  rw [hα, hβ] at hbacb'a'c', rw [hα', hβ'],
  have hac := (between_neq hcad).1.symm,
  have hbac := ang_proper_iff_noncol.1 h.2.1,
  have hbad := ang_proper_iff_noncol.1 h.2.2,
  have hab := (noncol_neq hbac).1.symm,
  have had := (noncol_neq hbad).2.2,
  have hcd := (between_neq hcad).2.1,
  have hb'a'c' := ang_proper_iff_noncol.1 h'.2.1,
  have hb'a'd' := ang_proper_iff_noncol.1 h'.2.2,
  have ha'b' := (noncol_neq hb'a'c').1.symm,
  have ha'c' := (noncol_neq hb'a'c').2.2,
  have ha'd' := (noncol_neq hb'a'd').2.2,
  have hab := (noncol_neq (ang_proper_iff_noncol.1 h.2.1)).1.symm,
  rcases extend_congr_seg (seg_proper_iff_neq.2 hac) ha'c' with ⟨c'', ha'c'', haca'c', -⟩,
  rcases extend_congr_seg (seg_proper_iff_neq.2 hab) ha'b' with ⟨b'', ha'b'', haba'b', -⟩,
  rcases extend_congr_seg (seg_proper_iff_neq.2 had) ha'd' with ⟨d'', ha'd'', hada'd', -⟩,
  rw [ang_eq_same_side_pt b' ha'c'', ang_symm b' a' c'', ang_eq_same_side_pt c'' ha'b''] at hbacb'a'c' h',
  rw [ang_eq_same_side_pt b' ha'd'', ang_symm b' a' d'', ang_eq_same_side_pt d'' ha'b''],
  rw [ang_eq_same_side_pt b' ha'd'', ang_symm b' a' d'', ang_eq_same_side_pt d'' ha'b''] at h',
  replace hc'a'd' : between c'' a' d'',
    rw between_diff_side_pt,
    exact diff_same_side_pt (diff_same_side_pt (between_diff_side_pt.1 hc'a'd') ha'c'') ha'd'',
  clear hα hα' hβ hβ' hb'a'c' hb'a'd' ha'b' ha'c' ha'd' ha'c'' ha'b'' ha'd'' b' c' d',
  rename [c'' c', b'' b', d'' d'],
  have hc'a'b' := ang_proper_iff_noncol.1 h'.2.1,
  have hd'a'b' := ang_proper_iff_noncol.1 h'.2.2,
  have hc'd' := (between_neq hc'a'd').2.1,
  rw ang_symm c' a' b' at hbacb'a'c',
  have h₁ : ((Δ a b c) ≅ₜ (Δ a' b' c')),
    apply SAS; unfold three_pt_triang; simp,
    exact noncol12 hbac, exact noncol123 hc'a'b',
    exact haba'b', exact haca'c', exact hbacb'a'c',
  have h₂ : ((Δ c b d) ≅ₜ (Δ c' b' d')),
    apply SAS; unfold three_pt_triang; simp,
    exact noncol23 (col_noncol (between_col hcad) (noncol13 hbac) hcd),
    exact noncol23 (col_noncol (between_col hc'a'd') hc'a'b' hc'd'),
    rw [seg_symm, seg_symm c' b'], exact (tri_congr_seg h₁).2.2,
    { apply congr_seg_add hcad hc'a'd' _ hada'd',
      rw [seg_symm, seg_symm c' a'], exact haca'c' },
    { rw [←ang_eq_same_side_pt b (between_same_side_pt.1 hcad).1,
        ←ang_eq_same_side_pt b' (between_same_side_pt.1 hc'a'd').1, ang_symm, ang_symm b' c' a'],
      exact (tri_congr_ang h₁).2.2 },
  have h₃ : ((Δ d a b) ≅ₜ (Δ d' a' b')),
    apply SAS; unfold three_pt_triang; simp,
    exact noncol13 hbad, exact hd'a'b',
    rw [seg_symm, seg_symm d' a'], exact hada'd',
    rw [seg_symm, seg_symm d' b'], exact (tri_congr_seg h₂).2.2,
    { rw [ang_symm, ←ang_eq_same_side_pt b (between_same_side_pt.1 hcad).2, ang_symm,
        ang_symm a' d' b', ←ang_eq_same_side_pt b' (between_same_side_pt.1 hc'a'd').2,
        ang_symm b' d' c'],
      exact (tri_congr_ang h₂).2.2 },
  rw ang_symm, exact (tri_congr_ang h₃).1
end

lemma congr_ang_add {a b c d a' b' c' d' : C.pts}
(hd : inside_ang d (∠ b a c)) (hb'c' : diff_side_line (a'-ₗd') b' c') (ha'd' : a' ≠ d')
(hbadb'a'd' : ∠ b a d ≅ₐ ∠ b' a' d') (hdacd'a'c' : ∠ d a c ≅ₐ ∠ d' a' c') :
inside_ang d' (∠ b' a' c') ∧ (∠ b a c ≅ₐ ∠ b' a' c') :=
begin
  have hbac := inside_ang_proper hd, rw ang_proper_iff_noncol at hbac,
  have hab := (noncol_neq hbac).1.symm,
  have hac := (noncol_neq hbac).2.2,
  have := diff_side_line_noncol hb'c' ha'd',
  have ha'b' := (noncol_neq (diff_side_line_noncol hb'c' ha'd').1).2.1,
  have ha'c' := (noncol_neq (diff_side_line_noncol hb'c' ha'd').2).2.1,
  cases crossbar hd with e he,
  have hda : e ≠ a,
    intro hf, rw hf at he, exact noncol_in13 hbac ((seg_in_line b c) he.2),
  have hdb : e ≠ b,
    intro hf, rw hf at he, apply ((same_side_line_noncol (inside_three_pt_ang.1 hd).1) hab).2,
    exact col_in13' ((ray_in_line a d) he.1),
  have hdc : e ≠ c,
    intro hf, rw hf at he, apply ((same_side_line_noncol (inside_three_pt_ang.1 hd).2) hac).2,
    exact col_in13' ((ray_in_line a d) he.1),
  have hbdc := seg_in_neq hdb hdc he.2,
  have hade := ray_in_neq hda he.1,
  replace hd := ray_inside_ang hd hade,
  rw ang_eq_same_side_pt b hade at hbadb'a'd',
  rw [ang_symm, ang_eq_same_side_pt c hade, ang_symm] at hdacd'a'c',
  clear he hade d, rename [e d],
  rw inside_three_pt_ang at hd,
  have habd := (same_side_line_noncol hd.1 hab).2,
  have hacd := (same_side_line_noncol hd.2 hac).2,
  have had := (noncol_neq habd).2.1,
  rcases extend_congr_seg (seg_proper_iff_neq.2 hac) ha'c' with ⟨c'', ha'c'c'', haca'c', -⟩,
  rcases extend_congr_seg (seg_proper_iff_neq.2 hab) ha'b' with ⟨b'', ha'b'b'', haba'b', -⟩,
  rcases extend_congr_seg (seg_proper_iff_neq.2 had) ha'd' with ⟨d'', ha'd'd'', hada'd', -⟩,
  have ha'd'' := (same_side_pt_neq ha'd'd'').2.symm,
  rw two_pt_one_line (line_in_lines ha'd') (line_in_lines ha'd'') ha'd' (pt_left_in_line a' d')
    (pt_right_in_line a' d') (pt_left_in_line a' d'') (col_in13 ha'd'd''.2 ha'd'') at hb'c',
  replace hb'c' := diff_side_line_symm (ray_diff_side_line ha'd'' hb'c' ha'b'b''),
  replace hb'c' := diff_side_line_symm (ray_diff_side_line ha'd'' hb'c' ha'c'c''),
  rw [ang_eq_same_side_pt b' ha'd'd'', ang_symm b' a' d'', ang_eq_same_side_pt d'' ha'b'b'',
    ang_symm d'' a' b''] at hbadb'a'd',
  rw [ang_eq_same_side_pt d' ha'c'c'', ang_symm d' a' c'', ang_eq_same_side_pt c'' ha'd'd'',
    ang_symm c'' a' d''] at hdacd'a'c',
  rw [ang_eq_same_side_pt b' ha'c'c'', ang_symm, ang_eq_same_side_pt c'' ha'b'b'', ang_symm],
  suffices : inside_ang d'' (∠ b'' a' c'') ∧ (∠ b a c≅ₐ∠ b'' a' c''),
    from ⟨ray_inside_ang this.1 (same_side_pt_symm ha'd'd''), this.2⟩,
  clear this ha'b' ha'c' ha'd' ha'c'c'' ha'b'b'' ha'd'd'' b' c' d',
  rename [b'' b', c'' c', d'' d', ha'd'' ha'd'],
  have ha'd'b' := (diff_side_line_noncol hb'c' ha'd').1,
  have ha'd'c' := (diff_side_line_noncol hb'c' ha'd').2,
  have h₁ : ((Δ a b d) ≅ₜ (Δ a' b' d')),
    apply SAS; unfold three_pt_triang; simp,
    exact habd, exact noncol23 ha'd'b',
    exact haba'b', exact hada'd', exact hbadb'a'd',
  have h₂ : ((Δ a d c) ≅ₜ (Δ a' d' c')),
    apply SAS; unfold three_pt_triang; simp,
    exact noncol23 hacd, exact ha'd'c',
    exact hada'd', exact haca'c', exact hdacd'a'c',
  have hb'd' := (noncol_neq ha'd'b').2.2.symm,
  cases between_extend hb'd' with e' hb'd'e',
  have hb'e' := (between_neq hb'd'e').2.1,
  have hd'e' := (between_neq hb'd'e').2.2,
  have hb'e'a' := col_noncol (between_col hb'd'e') (noncol13 ha'd'b') hb'e',
  have hd'e'a' := col_noncol (col12 (between_col hb'd'e')) (noncol123 ha'd'b') hd'e',
  have hd'e'c' : same_side_pt d' e' c',
    apply ang_unique_same_side ha'd',
    { apply diff_side_line_cancel (line_in_lines ha'd') _ hb'c',
      apply between_diff_side_line,
      exact noncol13 hb'e'a',
      rw between_symm, exact hb'd'e' },
    apply ang_congr_trans _ (tri_congr_ang h₂).1,
    apply supplementary_congr,
    { rw three_pt_ang_supplementary,
      exact ⟨hb'd'e', ha'd'b', noncol132 hd'e'a'⟩ },
    { rw three_pt_ang_supplementary,
      exact ⟨hbdc, noncol23 habd, noncol23 hacd⟩ },
    exact ang_congr_symm (tri_congr_ang h₁).2.2,
  have hb'd'c' := between_same_side_pt' hb'd'e' hd'e'c',
  have hb'c'a' := col_noncol (between_col hb'd'c') (noncol13 ha'd'b') (between_neq hb'd'c').2.1,
  split,
  exact hypo_inside_ang (noncol23 hb'c'a') hb'd'c',
  apply (tri_congr_ang _).1,
  apply SAS; unfold three_pt_triang; simp,
  exact hbac, exact noncol23 hb'c'a',
  rw [seg_symm, seg_symm b' a'], exact haba'b',
  exact congr_seg_add hbdc hb'd'c' (tri_congr_seg h₁).2.2 (tri_congr_seg h₂).2.2,
  { rw [←ang_eq_same_side_pt a (between_same_side_pt.1 hbdc).1,
      ←ang_eq_same_side_pt a' (between_same_side_pt.1 hb'd'c').1],
    exact (tri_congr_ang h₁).1 }
end

lemma congr_ang_sub {a b c d a' b' c' d' : C.pts}
(hd : inside_ang d (∠ b a c)) (h : same_side_line (a'-ₗb') d' c')
(ha'b' : a' ≠ b') (h₁ : ∠ b a c ≅ₐ ∠ b' a' c') (h₂ : ∠ b a d ≅ₐ ∠ b' a' d') :
inside_ang d' (∠ b' a' c') ∧ (∠ d a c ≅ₐ ∠ d' a' c') :=
begin
  have hbac := ang_proper_iff_noncol.1 (inside_ang_proper hd),
  have hac := (noncol_neq hbac).2.2,
  rw inside_three_pt_ang at hd,
  have hacd := (same_side_line_noncol hd.2 hac).2,
  have ha'd' := (same_side_line_neq h).1.symm,
  have ha'b'd' := (same_side_line_noncol h ha'b').1,
  rcases extend_congr_ang' (ang_proper_iff_noncol.2 (noncol132 hacd))
    ha'd' (noncol_in13 ha'b'd') with ⟨c'', hdacd'a'c'', hc''b'⟩,
  rw ang_symm c'' a' d' at hdacd'a'c'',
  have key := congr_ang_add (inside_three_pt_ang.2 hd) (diff_side_line_symm hc''b')
    ha'd' h₂ hdacd'a'c'',
  have hc'c'' := same_side_line_trans (line_in_lines ha'b') (same_side_line_symm h)
    (same_side_line_symm (inside_three_pt_ang.1 key.1).1),
  rw line_symm at hc'c'',
  have ha'c'c'' := ang_unique_same_side ha'b'.symm hc'c''
    (ang_congr_trans (ang_congr_symm h₁) key.2),
  rw [ang_eq_same_side_pt b' ha'c'c'', ang_eq_same_side_pt d' ha'c'c''],
  exact ⟨key.1, hdacd'a'c''⟩
end

/--I.15 in Elements -/
lemma vertical_ang_congr {a b a' b' o : pts} (haob : noncol a o b) :
between a o a' → between b o b' → (∠ a o b ≅ₐ ∠ a' o b') :=
begin
  intros haoa' hbob',
  have hoa' := (between_neq haoa').2.2,
  have hob' := (between_neq hbob').2.2,
  have hoa'b := col_noncol (col12 (between_col haoa')) (noncol12 haob) hoa',
  have hob'a' := col_noncol (col12 (between_col hbob')) (noncol23 hoa'b) hob',
  rw between_symm at haoa',
  apply supplementary_congr _ _ (ang_congr_refl (∠ b o a')),
  { rw [ang_symm a o b, three_pt_ang_supplementary],
    exact ⟨haoa', noncol132 hoa'b, noncol13 haob⟩ },
  { rw [ang_symm, three_pt_ang_supplementary],
    exact ⟨hbob', noncol12 hoa'b, noncol132 hob'a'⟩ }
end