/-
Copyright (c) 2021 Frédéric Dupuis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Frédéric Dupuis

! This file was ported from Lean 3 source module algebra.star.self_adjoint
! leanprover-community/mathlib commit 9abfa6f0727d5adc99067e325e15d1a9de17fd8e
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.Star.Basic
import Mathlib.GroupTheory.Subgroup.Basic
import Mathlib.Init.Data.Subtype.Basic

/-!
# Self-adjoint, skew-adjoint and normal elements of a star additive group

This file defines `selfAdjoint R` (resp. `skewAdjoint R`), where `R` is a star additive group,
as the additive subgroup containing the elements that satisfy `star x = x` (resp. `star x = -x`).
This includes, for instance, (skew-)Hermitian operators on Hilbert spaces.

We also define `IsStarNormal R`, a `Prop` that states that an element `x` satisfies
`star x * x = x * star x`.

## Implementation notes

* When `R` is a `StarModule R₂ R`, then `selfAdjoint R` has a natural
  `Module (selfAdjoint R₂) (selfAdjoint R)` structure. However, doing this literally would be
  undesirable since in the main case of interest (`R₂ = ℂ`) we want `Module ℝ (selfAdjoint R)`
  and not `Module (selfAdjoint ℂ) (selfAdjoint R)`. We solve this issue by adding the typeclass
  `[TrivialStar R₃]`, of which `ℝ` is an instance (registered in `Data/Real/Basic`), and then
  add a `[Module R₃ (selfAdjoint R)]` instance whenever we have
  `[Module R₃ R] [TrivialStar R₃]`. (Another approach would have been to define
  `[StarInvariantScalars R₃ R]` to express the fact that `star (x • v) = x • star v`, but
  this typeclass would have the disadvantage of taking two type arguments.)

## TODO

* Define `IsSkewAdjoint` to match `IsSelfAdjoint`.
* Define `fun z x => z * x * star z` (i.e. conjugation by `z`) as a monoid action of `R` on `R`
  (similar to the existing `ConjAct` for groups), and then state the fact that `selfAdjoint R` is
  invariant under it.

-/

variable {R A : Type _}

/-- An element is self-adjoint if it is equal to its star. -/
def IsSelfAdjoint [Star R] (x : R) : Prop :=
  star x = x
#align is_self_adjoint IsSelfAdjoint

/-- An element of a star monoid is normal if it commutes with its adjoint. -/
class IsStarNormal [Mul R] [Star R] (x : R) : Prop where
  /-- A normal element of a star monoid commutes with its adjoint. -/
  star_comm_self : Commute (star x) x
#align is_star_normal IsStarNormal

export IsStarNormal (star_comm_self)

theorem star_comm_self' [Mul R] [Star R] (x : R) [IsStarNormal x] : star x * x = x * star x :=
  IsStarNormal.star_comm_self
#align star_comm_self' star_comm_self'

namespace IsSelfAdjoint

-- named to match `Commute.allₓ`
/-- All elements are self-adjoint when `star` is trivial. -/
theorem all [Star R] [TrivialStar R] (r : R) : IsSelfAdjoint r :=
  star_trivial _
#align is_self_adjoint.all IsSelfAdjoint.all

theorem star_eq [Star R] {x : R} (hx : IsSelfAdjoint x) : star x = x :=
  hx
#align is_self_adjoint.star_eq IsSelfAdjoint.star_eq

theorem _root_.isSelfAdjoint_iff [Star R] {x : R} : IsSelfAdjoint x ↔ star x = x :=
  Iff.rfl
#align is_self_adjoint_iff isSelfAdjoint_iff

@[simp]
theorem star_iff [InvolutiveStar R] {x : R} : IsSelfAdjoint (star x) ↔ IsSelfAdjoint x := by
  simpa only [IsSelfAdjoint, star_star] using eq_comm
#align is_self_adjoint.star_iff IsSelfAdjoint.star_iff

@[simp]
theorem star_mul_self [Semigroup R] [StarSemigroup R] (x : R) : IsSelfAdjoint (star x * x) := by
  simp only [IsSelfAdjoint, star_mul, star_star]
#align is_self_adjoint.star_mul_self IsSelfAdjoint.star_mul_self

@[simp]
theorem mul_star_self [Semigroup R] [StarSemigroup R] (x : R) : IsSelfAdjoint (x * star x) := by
  simpa only [star_star] using star_mul_self (star x)
#align is_self_adjoint.mul_star_self IsSelfAdjoint.mul_star_self

/-- Functions in a `StarHomClass` preserve self-adjoint elements. -/
theorem starHom_apply {F R S : Type _} [Star R] [Star S] [StarHomClass F R S] {x : R}
    (hx : IsSelfAdjoint x) (f : F) : IsSelfAdjoint (f x) :=
  show star (f x) = f x from map_star f x ▸ congr_arg f hx
#align is_self_adjoint.star_hom_apply IsSelfAdjoint.starHom_apply

section AddMonoid

variable [AddMonoid R] [StarAddMonoid R]

variable (R)

theorem _root_.isSelfAdjoint_zero : IsSelfAdjoint (0 : R) :=
  star_zero R
#align is_self_adjoint_zero isSelfAdjoint_zero

variable {R}

theorem add {x y : R} (hx : IsSelfAdjoint x) (hy : IsSelfAdjoint y) : IsSelfAdjoint (x + y) := by
  simp only [isSelfAdjoint_iff, star_add, hx.star_eq, hy.star_eq]
#align is_self_adjoint.add IsSelfAdjoint.add

set_option linter.deprecated false in
@[deprecated]
theorem bit0 {x : R} (hx : IsSelfAdjoint x) : IsSelfAdjoint (bit0 x) := by
  simp only [isSelfAdjoint_iff, star_bit0, hx.star_eq]
#align is_self_adjoint.bit0 IsSelfAdjoint.bit0

end AddMonoid

section AddGroup

variable [AddGroup R] [StarAddMonoid R]

theorem neg {x : R} (hx : IsSelfAdjoint x) : IsSelfAdjoint (-x) := by
  simp only [isSelfAdjoint_iff, star_neg, hx.star_eq]
#align is_self_adjoint.neg IsSelfAdjoint.neg

theorem sub {x y : R} (hx : IsSelfAdjoint x) (hy : IsSelfAdjoint y) : IsSelfAdjoint (x - y) := by
  simp only [isSelfAdjoint_iff, star_sub, hx.star_eq, hy.star_eq]
#align is_self_adjoint.sub IsSelfAdjoint.sub

end AddGroup

section AddCommMonoid

variable [AddCommMonoid R] [StarAddMonoid R]

theorem _root_.isSelfAdjoint_add_star_self (x : R) : IsSelfAdjoint (x + star x) := by
  simp only [isSelfAdjoint_iff, add_comm, star_add, star_star]
#align is_self_adjoint_add_star_self isSelfAdjoint_add_star_self

theorem _root_.isSelfAdjoint_star_add_self (x : R) : IsSelfAdjoint (star x + x) := by
  simp only [isSelfAdjoint_iff, add_comm, star_add, star_star]
#align is_self_adjoint_star_add_self isSelfAdjoint_star_add_self

end AddCommMonoid

section Semigroup

variable [Semigroup R] [StarSemigroup R]

theorem conjugate' {x : R} (hx : IsSelfAdjoint x) (z : R) : IsSelfAdjoint (star z * x * z) := by
  simp only [isSelfAdjoint_iff, star_mul, star_star, mul_assoc, hx.star_eq]
#align is_self_adjoint.conjugate' IsSelfAdjoint.conjugate'

theorem isStarNormal {x : R} (hx : IsSelfAdjoint x) : IsStarNormal x :=
  ⟨by simp only [Commute, SemiconjBy, hx.star_eq]⟩
#align is_self_adjoint.is_star_normal IsSelfAdjoint.isStarNormal

end Semigroup

section Monoid

variable [Monoid R] [StarSemigroup R]

variable (R)

theorem _root_.isSelfAdjoint_one : IsSelfAdjoint (1 : R) :=
  star_one R
#align is_self_adjoint_one isSelfAdjoint_one

variable {R}

theorem pow {x : R} (hx : IsSelfAdjoint x) (n : ℕ) : IsSelfAdjoint (x ^ n) := by
  simp only [isSelfAdjoint_iff, star_pow, hx.star_eq]
#align is_self_adjoint.pow IsSelfAdjoint.pow

end Monoid

section Semiring

variable [Semiring R] [StarRing R]

set_option linter.deprecated false in
@[deprecated]
theorem bit1 {x : R} (hx : IsSelfAdjoint x) : IsSelfAdjoint (bit1 x) := by
  simp only [isSelfAdjoint_iff, star_bit1, hx.star_eq]
#align is_self_adjoint.bit1 IsSelfAdjoint.bit1

@[simp]
theorem _root_.isSelfAdjoint_natCast (n : ℕ) : IsSelfAdjoint (n : R) :=
  star_natCast _
#align is_self_adjoint_nat_cast isSelfAdjoint_natCast

end Semiring

section CommSemigroup

variable [CommSemigroup R] [StarSemigroup R]

theorem mul {x y : R} (hx : IsSelfAdjoint x) (hy : IsSelfAdjoint y) : IsSelfAdjoint (x * y) := by
  simp only [isSelfAdjoint_iff, star_mul', hx.star_eq, hy.star_eq]
#align is_self_adjoint.mul IsSelfAdjoint.mul

end CommSemigroup

section Ring

variable [Ring R] [StarRing R]

@[simp]
theorem _root_.isSelfAdjoint_intCast (z : ℤ) : IsSelfAdjoint (z : R) :=
  star_intCast _
#align is_self_adjoint_int_cast isSelfAdjoint_intCast

end Ring

section DivisionSemiring

variable [DivisionSemiring R] [StarRing R]

theorem inv {x : R} (hx : IsSelfAdjoint x) : IsSelfAdjoint x⁻¹ := by
  simp only [isSelfAdjoint_iff, star_inv', hx.star_eq]
#align is_self_adjoint.inv IsSelfAdjoint.inv

theorem zpow {x : R} (hx : IsSelfAdjoint x) (n : ℤ) : IsSelfAdjoint (x ^ n) := by
  simp only [isSelfAdjoint_iff, star_zpow₀, hx.star_eq]
#align is_self_adjoint.zpow IsSelfAdjoint.zpow

end DivisionSemiring

section DivisionRing

variable [DivisionRing R] [StarRing R]

theorem _root_.isSelfAdjoint_ratCast (x : ℚ) : IsSelfAdjoint (x : R) :=
  star_ratCast _
#align is_self_adjoint_rat_cast isSelfAdjoint_ratCast

end DivisionRing

section Semifield

-- porting note: generalize to `Semifield` to fix lean4#2074-related errors
variable [Semifield R] [StarRing R]

theorem div {x y : R} (hx : IsSelfAdjoint x) (hy : IsSelfAdjoint y) : IsSelfAdjoint (x / y) := by
  simp only [isSelfAdjoint_iff, star_div', hx.star_eq, hy.star_eq]
#align is_self_adjoint.div IsSelfAdjoint.div

end Semifield

section SMul

variable [Star R] [AddMonoid A] [StarAddMonoid A] [SMul R A] [StarModule R A]

theorem smul {r : R} (hr : IsSelfAdjoint r) {x : A} (hx : IsSelfAdjoint x) :
    IsSelfAdjoint (r • x) := by simp only [isSelfAdjoint_iff, star_smul, hr.star_eq, hx.star_eq]
#align is_self_adjoint.smul IsSelfAdjoint.smul

end SMul

end IsSelfAdjoint

variable (R)

/-- The self-adjoint elements of a star additive group, as an additive subgroup. -/
def selfAdjoint [AddGroup R] [StarAddMonoid R] : AddSubgroup R where
  carrier := { x | IsSelfAdjoint x }
  zero_mem' := star_zero R
  add_mem' hx := hx.add
  neg_mem' hx := hx.neg
#align self_adjoint selfAdjoint

/-- The skew-adjoint elements of a star additive group, as an additive subgroup. -/
def skewAdjoint [AddCommGroup R] [StarAddMonoid R] : AddSubgroup R where
  carrier := { x | star x = -x }
  zero_mem' := show star (0 : R) = -0 by simp only [star_zero, neg_zero]
  add_mem' := @fun x y (hx : star x = -x) (hy : star y = -y) =>
    show star (x + y) = -(x + y) by rw [star_add x y, hx, hy, neg_add]
  neg_mem' := @fun x (hx : star x = -x) => show star (-x) = - -x by simp only [hx, star_neg]
#align skew_adjoint skewAdjoint

variable {R}

namespace selfAdjoint

section AddGroup

variable [AddGroup R] [StarAddMonoid R]

theorem mem_iff {x : R} : x ∈ selfAdjoint R ↔ star x = x := by
  rw [← AddSubgroup.mem_carrier]
  exact Iff.rfl
#align self_adjoint.mem_iff selfAdjoint.mem_iff

@[simp, norm_cast]
theorem star_val_eq {x : selfAdjoint R} : star (x : R) = x :=
  x.prop
#align self_adjoint.star_coe_eq selfAdjoint.star_val_eq

instance : Inhabited (selfAdjoint R) :=
  ⟨0⟩

end AddGroup

section Ring

variable [Ring R] [StarRing R]

instance : One (selfAdjoint R) :=
  ⟨⟨1, isSelfAdjoint_one R⟩⟩

@[simp, norm_cast]
theorem val_one : ↑(1 : selfAdjoint R) = (1 : R) :=
  rfl
#align self_adjoint.coe_one selfAdjoint.val_one

instance [Nontrivial R] : Nontrivial (selfAdjoint R) :=
  ⟨⟨0, 1, Subtype.ne_of_val_ne zero_ne_one⟩⟩

instance : NatCast (selfAdjoint R) where
  -- porting note: `(_)` works around lean4#2074
  natCast n := ⟨n, @isSelfAdjoint_natCast _ _ (_) n⟩

instance : IntCast (selfAdjoint R) where
  intCast n := ⟨n, isSelfAdjoint_intCast _⟩

instance : Pow (selfAdjoint R) ℕ where
  pow x n := ⟨(x : R) ^ n, x.prop.pow n⟩

@[simp, norm_cast]
theorem val_pow (x : selfAdjoint R) (n : ℕ) : ↑(x ^ n) = (x : R) ^ n :=
  rfl
#align self_adjoint.coe_pow selfAdjoint.val_pow

end Ring

section NonUnitalCommRing

variable [NonUnitalCommRing R] [StarRing R]

instance : Mul (selfAdjoint R) where
  mul x y := ⟨(x : R) * y, x.prop.mul y.prop⟩

@[simp, norm_cast]
theorem val_mul (x y : selfAdjoint R) : ↑(x * y) = (x : R) * y :=
  rfl
#align self_adjoint.coe_mul selfAdjoint.val_mul

end NonUnitalCommRing

section CommRing

variable [CommRing R] [StarRing R]

instance : CommRing (selfAdjoint R) :=
  Function.Injective.commRing _ Subtype.coe_injective (selfAdjoint R).coe_zero val_one
    (selfAdjoint R).coe_add val_mul (selfAdjoint R).coe_neg (selfAdjoint R).coe_sub
    (selfAdjoint R).coe_nsmul (selfAdjoint R).coe_zsmul val_pow
    (fun _ => rfl) fun _ => rfl

end CommRing

section Field

variable [Field R] [StarRing R]

instance : Inv (selfAdjoint R) where
  -- porting note: `(_)` works around lean4#2074
  inv x := ⟨x.val⁻¹, @IsSelfAdjoint.inv _ _ (_) _ x.prop⟩

@[simp, norm_cast]
theorem val_inv (x : selfAdjoint R) : ↑x⁻¹ = (x : R)⁻¹ :=
  rfl
#align self_adjoint.coe_inv selfAdjoint.val_inv

instance : Div (selfAdjoint R) where
  -- porting note: `(_)` works around lean4#2074
  div x y := ⟨x / y, @IsSelfAdjoint.div _ _ (_) _ _ x.prop y.prop⟩

@[simp, norm_cast]
theorem val_div (x y : selfAdjoint R) : ↑(x / y) = (x / y : R) :=
  rfl
#align self_adjoint.coe_div selfAdjoint.val_div

instance : Pow (selfAdjoint R) ℤ where
  -- porting note: `(_)` works around lean4#2074
  pow x z := ⟨(x : R) ^ z, @IsSelfAdjoint.zpow _ _ (_) _ x.prop z⟩

@[simp, norm_cast]
theorem val_zpow (x : selfAdjoint R) (z : ℤ) : ↑(x ^ z) = (x : R) ^ z :=
  rfl
#align self_adjoint.coe_zpow selfAdjoint.val_zpow

instance : RatCast (selfAdjoint R) where
  ratCast n := ⟨n, isSelfAdjoint_ratCast n⟩

@[simp, norm_cast]
theorem val_ratCast (x : ℚ) : ↑(x : selfAdjoint R) = (x : R) :=
  rfl
#align self_adjoint.coe_rat_cast selfAdjoint.val_ratCast

instance instQSMul : SMul ℚ (selfAdjoint R) where
  smul a x :=
    ⟨a • (x : R), by rw [Rat.smul_def]; exact IsSelfAdjoint.mul (isSelfAdjoint_ratCast a) x.prop⟩
#align self_adjoint.has_qsmul selfAdjoint.instQSMul

@[simp, norm_cast]
theorem val_rat_smul (x : selfAdjoint R) (a : ℚ) : ↑(a • x) = a • (x : R) :=
  rfl
#align self_adjoint.coe_rat_smul selfAdjoint.val_rat_smul

instance : Field (selfAdjoint R) :=
  Function.Injective.field _ Subtype.coe_injective (selfAdjoint R).coe_zero val_one
    (selfAdjoint R).coe_add val_mul (selfAdjoint R).coe_neg (selfAdjoint R).coe_sub
    val_inv val_div (selfAdjoint R).coe_nsmul (selfAdjoint R).coe_zsmul
    val_rat_smul val_pow val_zpow (fun _ => rfl) (fun _ => rfl) val_ratCast

end Field

section SMul

variable [Star R] [TrivialStar R] [AddGroup A] [StarAddMonoid A]

instance [SMul R A] [StarModule R A] : SMul R (selfAdjoint A) where
  smul r x := ⟨r • (x : A), (IsSelfAdjoint.all _).smul x.prop⟩

@[simp, norm_cast]
theorem val_smul [SMul R A] [StarModule R A] (r : R) (x : selfAdjoint A) : ↑(r • x) = r • (x : A) :=
  rfl
#align self_adjoint.coe_smul selfAdjoint.val_smul

instance [Monoid R] [MulAction R A] [StarModule R A] : MulAction R (selfAdjoint A) :=
  Function.Injective.mulAction (↑) Subtype.coe_injective val_smul

instance [Monoid R] [DistribMulAction R A] [StarModule R A] : DistribMulAction R (selfAdjoint A) :=
  Function.Injective.distribMulAction (selfAdjoint A).subtype Subtype.coe_injective val_smul

end SMul

section Module

variable [Star R] [TrivialStar R] [AddCommGroup A] [StarAddMonoid A]

instance [Semiring R] [Module R A] [StarModule R A] : Module R (selfAdjoint A) :=
  Function.Injective.module R (selfAdjoint A).subtype Subtype.coe_injective val_smul

end Module

end selfAdjoint

namespace skewAdjoint

section AddGroup

variable [AddCommGroup R] [StarAddMonoid R]

theorem mem_iff {x : R} : x ∈ skewAdjoint R ↔ star x = -x := by
  rw [← AddSubgroup.mem_carrier]
  exact Iff.rfl
#align skew_adjoint.mem_iff skewAdjoint.mem_iff

@[simp, norm_cast]
theorem star_val_eq {x : skewAdjoint R} : star (x : R) = -x :=
  x.prop
#align skew_adjoint.star_coe_eq skewAdjoint.star_val_eq

instance : Inhabited (skewAdjoint R) :=
  ⟨0⟩

set_option linter.deprecated false in
@[deprecated]
theorem bit0_mem {x : R} (hx : x ∈ skewAdjoint R) : bit0 x ∈ skewAdjoint R := by
  rw [mem_iff, star_bit0, mem_iff.mp hx, bit0, bit0, neg_add]
#align skew_adjoint.bit0_mem skewAdjoint.bit0_mem

end AddGroup

section Ring

variable [Ring R] [StarRing R]

theorem conjugate {x : R} (hx : x ∈ skewAdjoint R) (z : R) : z * x * star z ∈ skewAdjoint R := by
  simp only [mem_iff, star_mul, star_star, mem_iff.mp hx, neg_mul, mul_neg, mul_assoc]
#align skew_adjoint.conjugate skewAdjoint.conjugate

theorem conjugate' {x : R} (hx : x ∈ skewAdjoint R) (z : R) : star z * x * z ∈ skewAdjoint R := by
  simp only [mem_iff, star_mul, star_star, mem_iff.mp hx, neg_mul, mul_neg, mul_assoc]
#align skew_adjoint.conjugate' skewAdjoint.conjugate'

theorem isStarNormal_of_mem {x : R} (hx : x ∈ skewAdjoint R) : IsStarNormal x :=
  ⟨by
    simp only [mem_iff] at hx
    simp only [hx, Commute.neg_left, Commute.refl]⟩
#align skew_adjoint.is_star_normal_of_mem skewAdjoint.isStarNormal_of_mem

instance (x : skewAdjoint R) : IsStarNormal (x : R) :=
  isStarNormal_of_mem (SetLike.coe_mem _)

end Ring

section SMul

variable [Star R] [TrivialStar R] [AddCommGroup A] [StarAddMonoid A]

theorem smul_mem [Monoid R] [DistribMulAction R A] [StarModule R A] (r : R) {x : A}
    (h : x ∈ skewAdjoint A) : r • x ∈ skewAdjoint A := by
  rw [mem_iff, star_smul, star_trivial, mem_iff.mp h, smul_neg r]
#align skew_adjoint.smul_mem skewAdjoint.smul_mem

instance [Monoid R] [DistribMulAction R A] [StarModule R A] : SMul R (skewAdjoint A) where
  smul r x := ⟨r • (x : A), smul_mem r x.prop⟩

@[simp, norm_cast]
theorem val_smul [Monoid R] [DistribMulAction R A] [StarModule R A] (r : R) (x : skewAdjoint A) :
    ↑(r • x) = r • (x : A) :=
  rfl
#align skew_adjoint.coe_smul skewAdjoint.val_smul

instance [Monoid R] [DistribMulAction R A] [StarModule R A] : DistribMulAction R (skewAdjoint A) :=
  Function.Injective.distribMulAction (skewAdjoint A).subtype Subtype.coe_injective val_smul

instance [Semiring R] [Module R A] [StarModule R A] : Module R (skewAdjoint A) :=
  Function.Injective.module R (skewAdjoint A).subtype Subtype.coe_injective val_smul

end SMul

end skewAdjoint

/-- Scalar multiplication of a self-adjoint element by a skew-adjoint element produces a
skew-adjoint element. -/
theorem IsSelfAdjoint.smul_mem_skewAdjoint [Ring R] [AddCommGroup A] [Module R A] [StarAddMonoid R]
    [StarAddMonoid A] [StarModule R A] {r : R} (hr : r ∈ skewAdjoint R) {a : A}
    (ha : IsSelfAdjoint a) : r • a ∈ skewAdjoint A :=
  (star_smul _ _).trans <| (congr_arg₂ _ hr ha).trans <| neg_smul _ _
#align is_self_adjoint.smul_mem_skew_adjoint IsSelfAdjoint.smul_mem_skewAdjoint

/-- Scalar multiplication of a skew-adjoint element by a skew-adjoint element produces a
self-adjoint element. -/
theorem isSelfAdjoint_smul_of_mem_skewAdjoint [Ring R] [AddCommGroup A] [Module R A]
    [StarAddMonoid R] [StarAddMonoid A] [StarModule R A] {r : R} (hr : r ∈ skewAdjoint R) {a : A}
    (ha : a ∈ skewAdjoint A) : IsSelfAdjoint (r • a) :=
  (star_smul _ _).trans <| (congr_arg₂ _ hr ha).trans <| neg_smul_neg _ _
#align is_self_adjoint_smul_of_mem_skew_adjoint isSelfAdjoint_smul_of_mem_skewAdjoint

instance isStarNormal_zero [Semiring R] [StarRing R] : IsStarNormal (0 : R) :=
  ⟨by simp only [Commute.refl, star_comm_self, star_zero]⟩
#align is_star_normal_zero isStarNormal_zero

instance isStarNormal_one [Monoid R] [StarSemigroup R] : IsStarNormal (1 : R) :=
  ⟨by simp only [Commute.refl, star_comm_self, star_one]⟩
#align is_star_normal_one isStarNormal_one

instance isStarNormal_star_self [Monoid R] [StarSemigroup R] {x : R} [IsStarNormal x] :
    IsStarNormal (star x) :=
  ⟨show star (star x) * star x = star x * star (star x) by rw [star_star, star_comm_self']⟩
#align is_star_normal_star_self isStarNormal_star_self

-- see Note [lower instance priority]
instance (priority := 100) TrivialStar.isStarNormal [Monoid R] [StarSemigroup R] [TrivialStar R]
    {x : R} : IsStarNormal x :=
  ⟨by rw [star_trivial]⟩
#align has_trivial_star.is_star_normal TrivialStar.isStarNormal

-- see Note [lower instance priority]
instance (priority := 100) CommMonoid.isStarNormal [CommMonoid R] [StarSemigroup R] {x : R} :
    IsStarNormal x :=
  ⟨mul_comm _ _⟩
#align comm_monoid.is_star_normal CommMonoid.isStarNormal


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Patrick Massot
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.topology.algebra.ordered
import Mathlib.data.set.intervals.proj_Icc
import Mathlib.PostPort

universes u_1 u_2

namespace Mathlib

/-!
# Projection onto a closed interval

In this file we prove that the projection `set.proj_Icc f a b h` is a quotient map, and use it
to show that `Icc_extend h f` is continuous if and only if `f` is continuous.
-/

theorem continuous_proj_Icc {α : Type u_1} [topological_space α] [linear_order α] [order_topology α]
    {a : α} {b : α} {h : a ≤ b} : continuous (set.proj_Icc a b h) :=
  continuous_subtype_mk (fun (x : α) => set.proj_Icc._proof_1 a b h x)
    (continuous.max continuous_const (continuous.min continuous_const continuous_id))

theorem quotient_map_proj_Icc {α : Type u_1} [topological_space α] [linear_order α]
    [order_topology α] {a : α} {b : α} {h : a ≤ b} : quotient_map (set.proj_Icc a b h) :=
  sorry

@[simp] theorem continuous_Icc_extend_iff {α : Type u_1} {β : Type u_2} [topological_space α]
    [linear_order α] [order_topology α] [topological_space β] {a : α} {b : α} {h : a ≤ b}
    {f : ↥(set.Icc a b) → β} : continuous (set.Icc_extend h f) ↔ continuous f :=
  iff.symm (quotient_map.continuous_iff quotient_map_proj_Icc)

theorem continuous.Icc_extend {α : Type u_1} {β : Type u_2} [topological_space α] [linear_order α]
    [order_topology α] [topological_space β] {a : α} {b : α} {h : a ≤ b} {f : ↥(set.Icc a b) → β}
    (hf : continuous f) : continuous (set.Icc_extend h f) :=
  continuous.comp hf continuous_proj_Icc

end Mathlib


/- Exercise 3.3: Programming Semantics — Denotational Semantics -/

/- First we repeat some material from the lecture. -/

import .x33_library

set_option pp.beta true

class complete_lattice (α : Type) extends partial_order α :=
(Inf    : set α → α)
(Inf_le : ∀{s a}, a ∈ s → Inf s ≤ a)
(le_Inf : ∀{s a}, (∀a', a' ∈ s → a ≤ a') → a ≤ Inf s)

namespace set

lemma ext {α : Type} {s t : set α} (h : ∀a, a ∈ s ↔ a ∈ t) : s = t :=
by funext a; exact propext (h a)

instance (α : Type) : complete_lattice (set α) :=
{ le          := (⊆),
  le_refl     := assume s a, id,
  le_trans    := assume s t u hst htu a has, htu $ hst $ has,
  le_antisymm := assume s t hst hts, ext $ assume a, ⟨assume h, hst h, assume h, hts h⟩,
  Inf         := assume f, {a | ∀s, s ∈ f → a ∈ s},
  Inf_le      := assume f s hsf a h, h _ hsf,
  le_Inf      := assume f s h a has t htf, h t htf has }

end set

def monotone {α β} [partial_order α] [partial_order β] (f : α → β) :=
∀a₁ a₂, a₁ ≤ a₂ → f a₁ ≤ f a₂

namespace monotone

lemma id {α : Type} [partial_order α] : monotone (λa : α, a) :=
assume a₁ a₂ ha, ha

lemma const {α β : Type} [partial_order α] [partial_order β] (b : β) : monotone (λa : α, b) :=
assume a₁ a₂ ha, le_refl b

lemma union {α β : Type} [partial_order α] (f g : α → set β)
  (hf : monotone f) (hg : monotone g) : monotone (λa, f a ∪ g a) :=
begin
  intros a b asmalb,
  intros bs fg,
  cases fg,
  apply or.intro_left,
  apply hf a,
  repeat{assumption},
  apply or.intro_right,
  apply hg a,
  repeat{assumption}
end

end monotone

namespace complete_lattice

variables {α : Type} [complete_lattice α]

def lfp (f : α → α) : α := Inf {x | f x ≤ x}

lemma lfp_le (f : α → α) (a : α) (h : f a ≤ a) : lfp f ≤ a := sorry
lemma le_lfp (f : α → α) (a : α) (h : ∀a', f a' ≤ a' → a ≤ a') : a ≤ lfp f := sorry
lemma lfp_eq (f : α → α) (hf : monotone f) : lfp f = f (lfp f) := sorry

end complete_lattice

open complete_lattice

def Id (α : Type) : set (α × α) := {x | x.2 = x.1 }

@[simp] lemma mem_Id {α : Type} (a b : α) :
  (a, b) ∈ Id α ↔ b = a :=
iff.rfl

def comp {α : Type} (r₁ r₂ : set (α × α)) : set (α × α) :=
{ x | ∃m, (x.1, m) ∈ r₁ ∧ (m, x.2) ∈ r₂ }

infixl ` ◯ ` : 90 := comp

@[simp] lemma mem_comp {α : Type} (r₁ r₂ : set (α × α)) (a b : α) :
  (a, b) ∈ r₁ ◯ r₂ ↔ (∃c, (a, c) ∈ r₁ ∧ (c, b) ∈ r₂) :=
iff.rfl

def restrict {α : Type} (r : set (α × α)) (p : α → Prop) : set (α × α) :=
{ x | p x.1 ∧ x ∈ r }

infixl ` ⇃ ` : 90 := restrict

@[simp] lemma mem_restrict {α : Type} (r : set (α × α)) (p : α → Prop) (a b : α) :
  (a, b) ∈ r ⇃ p ↔ p a ∧ (a, b) ∈ r :=
by refl

/- Question 1: Monotonicity -/

/- Prove the following two lemmas from the lecture. -/

lemma monotone_comp {α β : Type} [partial_order α] (f g : α → set (β × β))
  (hf : monotone f) (hg : monotone g) : monotone (λa, f a ◯ g a) :=
  begin
   intros a b asmalb h hp,
   cases hp,
   cases hp_h,
   simp[comp],
   apply exists.intro hp_w,
   apply and.intro,
   apply hf a,
   repeat{assumption},
   apply hg a,
   repeat{assumption}
  end

lemma monotone_restrict {α β : Type} [partial_order α] (f : α → set (β × β)) (p : β → Prop)
  (hf : monotone f) : monotone (λa, f a ⇃ p) :=
  begin
    intros a b asmalb h hp,
    simp[restrict],
    apply and.intro,
    cases hp,
    assumption,
    cases hp,
    apply hf a,
    repeat{assumption}
  end

/- Question 2: Kleene's theorem -/

/- We can compute the fixpoint by iteration by taking the union of all finite iterations of `f`:

    lfp f = ⋃n, f^^[n] ∅

where

    f^^[n] = f ∘ ⋯ ∘ f ∘ id

iterates the function `f` `n` times. However, the above characterization of `lfp` only holds for
continuous functions, a concept we will introduce below. -/

def iterate {α : Type} (f : α → α) : ℕ → α → α
| 0       a := a
| (n + 1) a := f (iterate n a)

notation f`^^[`n`]` := iterate f n

/- 2.1. Fill in the missing proofs below. -/

def Union {α : Type} (s : ℕ → set α) : set α :=
{ a | ∃n, a ∈ s n }

lemma Union_le {α : Type} {s : ℕ → set α} (a : set α) (h : ∀i, s i ≤ a) : Union s ≤ a :=
begin
  intro u,
  intro us,
  cases us,
  apply h us_w,
  assumption
end

/- A continuous function `f` is a function that commutes with the union of any monotone sequence
`s`: -/

def continuous {α : Type} (f : set α → set α) : Prop :=
∀s : ℕ → set α, monotone s → f (Union s) = Union (λn, f (s n))

/- We need to prove that each continuous function is monotone. To achieve this, we will need the
following sequence: -/

def bi_seq {α : Type} (a₁ a₂ : set α) : ℕ → set α
| 0       := a₁
| (n + 1) := a₂

/- For example, `bi_seq 0 1` is the sequence 0, 1, 1, 1, etc. -/

lemma monotone_bi_seq {α : Type} (a₁ a₂ : set α) (h : a₁ ≤ a₂) :
  monotone (bi_seq a₁ a₂)
| 0       0       _ := le_refl _
| 0       (n + 1) _ := h
| (n + 1) (m + 1) _ := le_refl _

lemma Union_bi_seq {α : Type} (a₁ a₂ : set α) (ha : a₁ ≤ a₂) :
  Union (bi_seq a₁ a₂) = a₂ :=
begin
  apply le_antisymm,
  apply Union_le,
  intro i,
  intros a b,
  cases i,
  apply ha b,
  exact b,
  intros a1 a2,
  apply exists.intro
end

lemma monotone_of_continuous {α : Type} (f : set α → set α) (hf : continuous f) :
  monotone f :=
begin
intros a1 a2,
intros smaller,
apply Union_bi_seq,

end

/- 2.2. Provide the following proof, using a similar case distinction as for `monotone_bi_seq`
above. -/

lemma monotone_iterate {α : Type} (f : set α → set α) (hf : monotone f) :
  monotone (λn, f^^[n] ∅)
:= sorry

/- 2.3. Prove the main theorem. A proof sketch is given below.

We break the proof into two proofs of inclusion.

Case 1. lfp f ≤ Union (λn, f^[n] ∅): The key is to use the lemma `lfp_le` together with continuity
of `f`.

Case 2. Union (λn, f^[n] ∅) ≤ lfp f: The lemma `Union_le` gives us a natural number `i`, on which
you can perform induction. You will also need the lemma `lfp_eq` to unfold one iteration of
`lfp f`. -/

lemma lfp_Kleene {α : Type} (f : set α → set α) (hf : continuous f) :
  lfp f = Union (λn, f^^[n] ∅) :=
be

/- Question 3 **optional**: Regular expressions -/

inductive regex (α : Type) : Type
| empty     {} : regex
| nothing   {} : regex
| atom (a : α) : regex
| concat       : regex → regex → regex
| alt          : regex → regex → regex
| star         : regex → regex

open regex

/- 3.1 **optional**. Define a translation of regular expressions to relations. The idea is that an
atom corresponds to a relation, concatenation corresponds to composition of relations, and
alternation is union. -/

def rel_of_regex {α : Type} : regex (set (α × α)) → set (α × α)
| empty          := Id α
| _              := sorry

/- 3.2 **optional**. Prove the following recursive equation about your definition. -/

lemma rel_of_regex_star {α : Type} (r : regex (set (α × α))) :
  rel_of_regex (star r) = rel_of_regex (alt (concat r (star r)) empty) :=
sorry


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

! This file was ported from Lean 3 source module algebra.hom.group_action
! leanprover-community/mathlib commit e7bab9a85e92cf46c02cb4725a7be2f04691e3a7
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Algebra.GroupRingAction.Basic
import Mathlib.Algebra.Module.Basic

/-!
# Equivariant homomorphisms

## Main definitions

* `MulActionHom M X Y`, the type of equivariant functions from `X` to `Y`, where `M` is a monoid
  that acts on the types `X` and `Y`.
* `DistribMulActionHom M A B`, the type of equivariant additive monoid homomorphisms
  from `A` to `B`, where `M` is a monoid that acts on the additive monoids `A` and `B`.
* `MulSemiringActionHom M R S`, the type of equivariant ring homomorphisms
  from `R` to `S`, where `M` is a monoid that acts on the rings `R` and `S`.

The above types have corresponding classes:
* `SMulHomClass F M X Y` states that `F` is a type of bundled `X → Y` homs
  preserving scalar multiplication by `M`
* `DistribMulActionHomClass F M A B` states that `F` is a type of bundled `A → B` homs
  preserving the additive monoid structure and scalar multiplication by `M`
* `MulSemiringActionHomClass F M R S` states that `F` is a type of bundled `R → S` homs
  preserving the ring structure and scalar multiplication by `M`

## Notations

* `X →[M] Y` is `MulActionHom M X Y`.
* `A →+[M] B` is `DistribMulActionHom M A B`.
* `R →+*[M] S` is `MulSemiringActionHom M R S`.

-/

--Porting note: assert_not_exists is not yet implemented
--assert_not_exists Submonoid

variable (M' : Type _)
variable (X : Type _) [SMul M' X]
variable (Y : Type _) [SMul M' Y]
variable (Z : Type _) [SMul M' Z]
variable (M : Type _) [Monoid M]
variable (A : Type _) [AddMonoid A] [DistribMulAction M A]
variable (A' : Type _) [AddGroup A'] [DistribMulAction M A']
variable (B : Type _) [AddMonoid B] [DistribMulAction M B]
variable (B' : Type _) [AddGroup B'] [DistribMulAction M B']
variable (C : Type _) [AddMonoid C] [DistribMulAction M C]
variable (R : Type _) [Semiring R] [MulSemiringAction M R]
variable (R' : Type _) [Ring R'] [MulSemiringAction M R']
variable (S : Type _) [Semiring S] [MulSemiringAction M S]
variable (S' : Type _) [Ring S'] [MulSemiringAction M S']
variable (T : Type _) [Semiring T] [MulSemiringAction M T]

/-- Equivariant functions. -/
-- Porting note: This linter does not exist yet
-- @[nolint has_nonempty_instance]
structure MulActionHom where
  /-- The underlying function. -/
  toFun : X → Y
  /-- The proposition that the function preserves the action. -/
  map_smul' : ∀ (m : M') (x : X), toFun (m • x) = m • toFun x
#align mul_action_hom MulActionHom

/- Porting note: local notation given a name, conflict with Algebra.Hom.GroupAction
 see https://github.com/leanprover/lean4/issues/2000 -/
@[inherit_doc]
notation:25 (name := «MulActionHomLocal≺») X " →[" M:25 "] " Y:0 => MulActionHom M X Y

/-- `SMulHomClass F M X Y` states that `F` is a type of morphisms preserving
scalar multiplication by `M`.

You should extend this class when you extend `MulActionHom`. -/
class SMulHomClass (F : Type _) (M X Y : outParam <| Type _) [SMul M X] [SMul M Y] extends
  FunLike F X fun _ => Y where
  /-- The proposition that the function preserves the action. -/
  map_smul : ∀ (f : F) (c : M) (x : X), f (c • x) = c • f x
#align smul_hom_class SMulHomClass

/- porting note: Removed a @[nolint dangerousInstance] for SMulHomClass
 not dangerous due to outParam -/

export SMulHomClass (map_smul)

attribute [simp] map_smul

-- porting note: removed has_coe_to_fun instance, coercions handled differently now
#noalign mul_action_hom.has_coe_to_fun

instance : SMulHomClass (X →[M'] Y) M' X Y
    where
  coe := MulActionHom.toFun
  coe_injective' f g h := by cases f; cases g; congr
  map_smul := MulActionHom.map_smul'

namespace MulActionHom

variable {M M' X Y}

/- porting note: inserted following def & instance for consistent coercion behaviour,
see also Algebra.Hom.Group -/
/-- Turn an element of a type `F` satisfying `SMulHomClass F M X Y` into an actual
`MulActionHom`. This is declared as the default coercion from `F` to `MulActionHom M X Y`. -/
@[coe]
def _root_.SMulHomClass.toMulActionHom [SMul M X] [SMul M Y] [SMulHomClass F M X Y] (f : F) :
    X →[M] Y where
   toFun := FunLike.coe f
   map_smul' := map_smul f

/-- Any type satisfying `SMulHomClass` can be cast into `MulActionHom` via
  `SMulHomClass.toMulActionHom`. -/
instance [SMul M X] [SMul M Y] [SMulHomClass F M X Y] : CoeTC F (X →[M] Y) :=
  ⟨SMulHomClass.toMulActionHom⟩

protected theorem map_smul (f : X →[M'] Y) (m : M') (x : X) : f (m • x) = m • f x :=
  map_smul f m x
#align mul_action_hom.map_smul MulActionHom.map_smul

@[ext]
theorem ext {f g : X →[M'] Y} : (∀ x, f x = g x) → f = g :=
  FunLike.ext f g
#align mul_action_hom.ext MulActionHom.ext

theorem ext_iff {f g : X →[M'] Y} : f = g ↔ ∀ x, f x = g x :=
  FunLike.ext_iff
#align mul_action_hom.ext_iff MulActionHom.ext_iff

protected theorem congr_fun {f g : X →[M'] Y} (h : f = g) (x : X) : f x = g x :=
  FunLike.congr_fun h _
#align mul_action_hom.congr_fun MulActionHom.congr_fun

variable (M M')

/-- The identity map as an equivariant map. -/
protected def id : X →[M'] X :=
  ⟨id, fun _ _ => rfl⟩
#align mul_action_hom.id MulActionHom.id

@[simp]
theorem id_apply (x : X) : MulActionHom.id M' x = x :=
  rfl
#align mul_action_hom.id_apply MulActionHom.id_apply

variable {M M' Z}

/-- Composition of two equivariant maps. -/
def comp (g : Y →[M'] Z) (f : X →[M'] Y) : X →[M'] Z :=
  ⟨g ∘ f, fun m x =>
    calc
      g (f (m • x)) = g (m • f x) := by rw [f.map_smul]
      _ = m • g (f x) := g.map_smul _ _⟩
#align mul_action_hom.comp MulActionHom.comp

@[simp]
theorem comp_apply (g : Y →[M'] Z) (f : X →[M'] Y) (x : X) : g.comp f x = g (f x) :=
  rfl
#align mul_action_hom.comp_apply MulActionHom.comp_apply

@[simp]

@[simp]
theorem comp_id (f : X →[M'] Y) : f.comp (MulActionHom.id M') = f :=
  ext fun x => by rw [comp_apply, id_apply]
#align mul_action_hom.comp_id MulActionHom.comp_id

variable {A B}

/-- The inverse of a bijective equivariant map is equivariant. -/
@[simps]
def inverse (f : A →[M] B) (g : B → A) (h₁ : Function.LeftInverse g f)
    (h₂ : Function.RightInverse g f) : B →[M] A
    where
  toFun := g
  map_smul' m x :=
    calc
      g (m • x) = g (m • f (g x)) := by rw [h₂]
      _ = g (f (m • g x)) := by rw [f.map_smul]
      _ = m • g x := by rw [h₁]
#align mul_action_hom.inverse_to_fun MulActionHom.inverse_toFun

#align mul_action_hom.inverse MulActionHom.inverse

end MulActionHom

/-- Equivariant additive monoid homomorphisms. -/
structure DistribMulActionHom extends A →[M] B, A →+ B
#align distrib_mul_action_hom DistribMulActionHom

/-- Reinterpret an equivariant additive monoid homomorphism as an additive monoid homomorphism. -/
add_decl_doc DistribMulActionHom.toAddMonoidHom
#align distrib_mul_action_hom.to_add_monoid_hom DistribMulActionHom.toAddMonoidHom

/-- Reinterpret an equivariant additive monoid homomorphism as an equivariant function. -/
add_decl_doc DistribMulActionHom.toMulActionHom
#align distrib_mul_action_hom.to_mul_action_hom DistribMulActionHom.toMulActionHom

/- Porting note: local notation given a name, conflict with Algebra.Hom.Freiman
 see https://github.com/leanprover/lean4/issues/2000 -/
@[inherit_doc]
notation:25 (name := «DistribMulActionHomLocal≺»)
  A " →+[" M:25 "] " B:0 => DistribMulActionHom M A B

/-- `DistribMulActionHomClass F M A B` states that `F` is a type of morphisms preserving
the additive monoid structure and scalar multiplication by `M`.

You should extend this class when you extend `DistribMulActionHom`. -/
class DistribMulActionHomClass (F : Type _) (M A B : outParam <| Type _) [Monoid M] [AddMonoid A]
  [AddMonoid B] [DistribMulAction M A] [DistribMulAction M B] extends SMulHomClass F M A B,
  AddMonoidHomClass F A B
#align distrib_mul_action_hom_class DistribMulActionHomClass

/- porting note: Removed a @[nolint dangerousInstance] for
DistribMulActionHomClass.toAddMonoidHomClass not dangerous due to `outParam`s -/

namespace DistribMulActionHom

/- porting note: TODO decide whether the next two instances should be removed
Coercion is already handled by all the HomClass constructions I believe -/
-- instance coe : Coe (A →+[M] B) (A →+ B) :=
--   ⟨toAddMonoidHom⟩
-- #align distrib_mul_action_hom.has_coe DistribMulActionHom.coe

-- instance coe' : Coe (A →+[M] B) (A →[M] B) :=
--   ⟨toMulActionHom⟩
-- #align distrib_mul_action_hom.has_coe' DistribMulActionHom.coe'

-- porting note: removed has_coe_to_fun instance, coercions handled differently now

#noalign distrib_mul_action_hom.has_coe
#noalign distrib_mul_action_hom.has_coe'
#noalign distrib_mul_action_hom.has_coe_to_fun

instance : DistribMulActionHomClass (A →+[M] B) M A B
    where
  coe m := m.toFun
  coe_injective' f g h := by
    rcases f with ⟨tF, _, _⟩; rcases g with ⟨tG, _, _⟩
    cases tF; cases tG; congr
  map_smul m := m.map_smul'
  map_zero := DistribMulActionHom.map_zero'
  map_add := DistribMulActionHom.map_add'

variable {M A B}
/- porting note: inserted following def & instance for consistent coercion behaviour,
see also Algebra.Hom.Group -/
/-- Turn an element of a type `F` satisfying `SMulHomClass F M X Y` into an actual
`MulActionHom`. This is declared as the default coercion from `F` to `MulActionHom M X Y`. -/
@[coe]
def _root_.DistribMulActionHomClass.toDistribMulActionHom [DistribMulActionHomClass F M A B]
  (f : F) : A →+[M] B :=
  { (f : A →+ B),  (f : A →[M] B) with }

/-- Any type satisfying `SMulHomClass` can be cast into `MulActionHom` via
  `SMulHomClass.toMulActionHom`. -/
instance [DistribMulActionHomClass F M A B] : CoeTC F (A →+[M] B) :=
  ⟨DistribMulActionHomClass.toDistribMulActionHom⟩

@[simp]
theorem toFun_eq_coe (f : A →+[M] B): f.toFun = f := rfl
#align distrib_mul_action_hom.to_fun_eq_coe DistribMulActionHom.toFun_eq_coe

@[norm_cast]
theorem coe_fn_coe (f : A →+[M] B) : ⇑(f : A →+ B) = f :=
  rfl
#align distrib_mul_action_hom.coe_fn_coe DistribMulActionHom.coe_fn_coe

@[norm_cast]
theorem coe_fn_coe' (f : A →+[M] B) : ⇑(f : A →[M] B) = f :=
  rfl
#align distrib_mul_action_hom.coe_fn_coe' DistribMulActionHom.coe_fn_coe'

@[ext]
theorem ext {f g : A →+[M] B} : (∀ x, f x = g x) → f = g :=
  FunLike.ext f g
#align distrib_mul_action_hom.ext DistribMulActionHom.ext

theorem ext_iff {f g : A →+[M] B} : f = g ↔ ∀ x, f x = g x :=
  FunLike.ext_iff
#align distrib_mul_action_hom.ext_iff DistribMulActionHom.ext_iff

protected theorem congr_fun {f g : A →+[M] B} (h : f = g) (x : A) : f x = g x :=
  FunLike.congr_fun h _
#align distrib_mul_action_hom.congr_fun DistribMulActionHom.congr_fun

theorem toMulActionHom_injective {f g : A →+[M] B} (h : (f : A →[M] B) = (g : A →[M] B)) :
    f = g := by
  ext a
  exact MulActionHom.congr_fun h a
#align distrib_mul_action_hom.to_mul_action_hom_injective DistribMulActionHom.toMulActionHom_injective

theorem toAddMonoidHom_injective {f g : A →+[M] B} (h : (f : A →+ B) = (g : A →+ B)) : f = g :=
  by
  ext a
  exact FunLike.congr_fun h a
#align distrib_mul_action_hom.to_add_monoid_hom_injective DistribMulActionHom.toAddMonoidHom_injective

protected theorem map_zero (f : A →+[M] B) : f 0 = 0 :=
  map_zero f
#align distrib_mul_action_hom.map_zero DistribMulActionHom.map_zero

protected theorem map_add (f : A →+[M] B) (x y : A) : f (x + y) = f x + f y :=
  map_add f x y
#align distrib_mul_action_hom.map_add DistribMulActionHom.map_add

protected theorem map_neg (f : A' →+[M] B') (x : A') : f (-x) = -f x :=
  map_neg f x
#align distrib_mul_action_hom.map_neg DistribMulActionHom.map_neg

protected theorem map_sub (f : A' →+[M] B') (x y : A') : f (x - y) = f x - f y :=
  map_sub f x y
#align distrib_mul_action_hom.map_sub DistribMulActionHom.map_sub

protected theorem map_smul (f : A →+[M] B) (m : M) (x : A) : f (m • x) = m • f x :=
  map_smul f m x
#align distrib_mul_action_hom.map_smul DistribMulActionHom.map_smul

variable (M)
/-- The identity map as an equivariant additive monoid homomorphism. -/
protected def id : A →+[M] A :=
  ⟨.id _, rfl, fun _ _ => rfl⟩
#align distrib_mul_action_hom.id DistribMulActionHom.id

@[simp]
theorem id_apply (x : A) : DistribMulActionHom.id M x = x := by
  rfl
#align distrib_mul_action_hom.id_apply DistribMulActionHom.id_apply

variable {M C}

-- porting note:  `simp` used to prove this, but now `change` is needed to push past the coercions
instance : Zero (A →+[M] B) :=
  ⟨{ (0 : A →+ B) with map_smul' := fun m _ => by change (0 : B) = m • (0 : B); rw [smul_zero]}⟩

instance : One (A →+[M] A) :=
  ⟨DistribMulActionHom.id M⟩

@[simp]
theorem coe_zero : ⇑(0 : A →+[M] B) = 0 :=
  rfl
#align distrib_mul_action_hom.coe_zero DistribMulActionHom.coe_zero

@[simp]
theorem coe_one : ⇑(1 : A →+[M] A) = id :=
  rfl
#align distrib_mul_action_hom.coe_one DistribMulActionHom.coe_one

theorem zero_apply (a : A) : (0 : A →+[M] B) a = 0 :=
  rfl
#align distrib_mul_action_hom.zero_apply DistribMulActionHom.zero_apply

theorem one_apply (a : A) : (1 : A →+[M] A) a = a :=
  rfl
#align distrib_mul_action_hom.one_apply DistribMulActionHom.one_apply

instance : Inhabited (A →+[M] B) :=
  ⟨0⟩

/-- Composition of two equivariant additive monoid homomorphisms. -/
def comp (g : B →+[M] C) (f : A →+[M] B) : A →+[M] C :=
  { MulActionHom.comp (g : B →[M] C) (f : A →[M] B),
    AddMonoidHom.comp (g : B →+ C) (f : A →+ B) with }
#align distrib_mul_action_hom.comp DistribMulActionHom.comp

@[simp]
theorem comp_apply (g : B →+[M] C) (f : A →+[M] B) (x : A) : g.comp f x = g (f x) :=
  rfl
#align distrib_mul_action_hom.comp_apply DistribMulActionHom.comp_apply

@[simp]
theorem id_comp (f : A →+[M] B) : (DistribMulActionHom.id M).comp f = f :=
  ext fun x => by rw [comp_apply, id_apply]
#align distrib_mul_action_hom.id_comp DistribMulActionHom.id_comp

@[simp]
theorem comp_id (f : A →+[M] B) : f.comp (DistribMulActionHom.id M) = f :=
  ext fun x => by rw [comp_apply, id_apply]
#align distrib_mul_action_hom.comp_id DistribMulActionHom.comp_id

/-- The inverse of a bijective `DistribMulActionHom` is a `DistribMulActionHom`. -/
@[simps]
def inverse (f : A →+[M] B) (g : B → A) (h₁ : Function.LeftInverse g f)
    (h₂ : Function.RightInverse g f) : B →+[M] A :=
  { (f : A →+ B).inverse g h₁ h₂, (f : A →[M] B).inverse g h₁ h₂ with toFun := g }
#align distrib_mul_action_hom.inverse DistribMulActionHom.inverse

section Semiring

variable {R M'}
variable [AddMonoid M'] [DistribMulAction R M']

@[ext]
theorem ext_ring {f g : R →+[R] M'} (h : f 1 = g 1) : f = g :=
  by
  ext x
  rw [← mul_one x, ← smul_eq_mul R, f.map_smul, g.map_smul, h]
#align distrib_mul_action_hom.ext_ring DistribMulActionHom.ext_ring

theorem ext_ring_iff {f g : R →+[R] M'} : f = g ↔ f 1 = g 1 :=
  ⟨fun h => h ▸ rfl, ext_ring⟩
#align distrib_mul_action_hom.ext_ring_iff DistribMulActionHom.ext_ring_iff

end Semiring

end DistribMulActionHom

/-- Equivariant ring homomorphisms. -/
-- Porting note: This linter does not exist yet
-- @[nolint has_nonempty_instance]
structure MulSemiringActionHom extends R →+[M] S, R →+* S
#align mul_semiring_action_hom MulSemiringActionHom

/-- Reinterpret an equivariant ring homomorphism as a ring homomorphism. -/
add_decl_doc MulSemiringActionHom.toRingHom
#align mul_semiring_action_hom.to_ring_hom MulSemiringActionHom.toRingHom

/-- Reinterpret an equivariant ring homomorphism as an equivariant additive monoid homomorphism. -/
add_decl_doc MulSemiringActionHom.toDistribMulActionHom
#align mul_semiring_action_hom.to_distrib_mul_action_hom MulSemiringActionHom.toDistribMulActionHom

/- Porting note: local notation given a name, conflict with Algebra.Hom.Freiman
 see https://github.com/leanprover/lean4/issues/2000 -/
@[inherit_doc]
notation:25 (name := «MulSemiringActionHomLocal≺»)
  R " →+*[" M:25 "] " S:0 => MulSemiringActionHom M R S

/-- `MulSemiringActionHomClass F M R S` states that `F` is a type of morphisms preserving
the ring structure and scalar multiplication by `M`.

You should extend this class when you extend `MulSemiringActionHom`. -/
class MulSemiringActionHomClass (F : Type _) (M R S : outParam <| Type _) [Monoid M] [Semiring R]
  [Semiring S] [DistribMulAction M R] [DistribMulAction M S] extends
  DistribMulActionHomClass F M R S, RingHomClass F R S
#align mul_semiring_action_hom_class MulSemiringActionHomClass

/- porting note: Removed a @[nolint dangerousInstance] for MulSemiringActionHomClass.toRingHomClass
 not dangerous due to outParam -/

namespace MulSemiringActionHom

/- porting note: TODO decide whether the next two instances should be removed
Coercion is already handled by all the HomClass constructions I believe -/
-- @[coe]
-- instance coe : Coe (R →+*[M] S) (R →+* S) :=
--   ⟨toRingHom⟩
-- #align mul_semiring_action_hom.has_coe MulSemiringActionHom.coe

-- @[coe]
-- instance coe' : Coe (R →+*[M] S) (R →+[M] S) :=
--   ⟨toDistribMulActionHom⟩
-- #align mul_semiring_action_hom.has_coe' MulSemiringActionHom.coe'

-- porting note: removed has_coe_to_fun instance, coercions handled differently now

#noalign mul_semiring_action_hom.has_coe
#noalign mul_semiring_action_hom.has_coe'
#noalign mul_semiring_action_hom.has_coe_to_fun

instance : MulSemiringActionHomClass (R →+*[M] S) M R S
    where
  coe m := m.toFun
  coe_injective' f g h := by
    rcases f with ⟨⟨tF, _, _⟩, _, _⟩; rcases g with ⟨⟨tG, _, _⟩, _, _⟩
    cases tF; cases tG; congr
  map_smul m := m.map_smul'
  map_zero m := m.map_zero'
  map_add m := m.map_add'
  map_one := MulSemiringActionHom.map_one'
  map_mul := MulSemiringActionHom.map_mul'

variable {M R S}

/- porting note: inserted following def & instance for consistent coercion behaviour,
see also Algebra.Hom.Group -/
/-- Turn an element of a type `F` satisfying `MulSemiringActionHomClass F M R S` into an actual
`MulSemiringActionHom`. This is declared as the default coercion from `F` to
`MulSemiringActionHom M X Y`. -/
@[coe]
def _root_.MulSemiringActionHomClass.toMulSemiringActionHom [MulSemiringActionHomClass F M R S]
  (f : F) : R →+*[M] S :=
 { (f : R →+* S),  (f : R →+[M] S) with }

/-- Any type satisfying `MulSemiringActionHomClass` can be cast into `MulSemiringActionHom` via
  `MulSemiringActionHomClass.toMulSemiringActionHom`. -/
instance [MulSemiringActionHomClass F M R S] : CoeTC F (R →+*[M] S) :=
  ⟨MulSemiringActionHomClass.toMulSemiringActionHom⟩

@[norm_cast]
theorem coe_fn_coe (f : R →+*[M] S) : ⇑(f : R →+* S) = f :=
  rfl
#align mul_semiring_action_hom.coe_fn_coe MulSemiringActionHom.coe_fn_coe

@[norm_cast]
theorem coe_fn_coe' (f : R →+*[M] S) : ⇑(f : R →+[M] S) = f :=
  rfl
#align mul_semiring_action_hom.coe_fn_coe' MulSemiringActionHom.coe_fn_coe'

@[ext]
theorem ext {f g : R →+*[M] S} : (∀ x, f x = g x) → f = g :=
  FunLike.ext f g
#align mul_semiring_action_hom.ext MulSemiringActionHom.ext

theorem ext_iff {f g : R →+*[M] S} : f = g ↔ ∀ x, f x = g x :=
  FunLike.ext_iff
#align mul_semiring_action_hom.ext_iff MulSemiringActionHom.ext_iff

protected theorem map_zero (f : R →+*[M] S) : f 0 = 0 :=
  map_zero f
#align mul_semiring_action_hom.map_zero MulSemiringActionHom.map_zero

protected theorem map_add (f : R →+*[M] S) (x y : R) : f (x + y) = f x + f y :=
  map_add f x y
#align mul_semiring_action_hom.map_add MulSemiringActionHom.map_add

protected theorem map_neg (f : R' →+*[M] S') (x : R') : f (-x) = -f x :=
  map_neg f x
#align mul_semiring_action_hom.map_neg MulSemiringActionHom.map_neg

protected theorem map_sub (f : R' →+*[M] S') (x y : R') : f (x - y) = f x - f y :=
  map_sub f x y
#align mul_semiring_action_hom.map_sub MulSemiringActionHom.map_sub

protected theorem map_one (f : R →+*[M] S) : f 1 = 1 :=
  map_one f
#align mul_semiring_action_hom.map_one MulSemiringActionHom.map_one

protected theorem map_mul (f : R →+*[M] S) (x y : R) : f (x * y) = f x * f y :=
  map_mul f x y
#align mul_semiring_action_hom.map_mul MulSemiringActionHom.map_mul

protected theorem map_smul (f : R →+*[M] S) (m : M) (x : R) : f (m • x) = m • f x :=
  map_smul f m x
#align mul_semiring_action_hom.map_smul MulSemiringActionHom.map_smul

variable (M)

/-- The identity map as an equivariant ring homomorphism. -/
protected def id : R →+*[M] R :=
  ⟨.id _, rfl, (fun _ _ => rfl)⟩
#align mul_semiring_action_hom.id MulSemiringActionHom.id

@[simp]
theorem id_apply (x : R) : MulSemiringActionHom.id M x = x :=
  rfl
#align mul_semiring_action_hom.id_apply MulSemiringActionHom.id_apply

variable {M T}

/-- Composition of two equivariant additive monoid homomorphisms. -/
def comp (g : S →+*[M] T) (f : R →+*[M] S) : R →+*[M] T :=
  { DistribMulActionHom.comp (g : S →+[M] T) (f : R →+[M] S),
    RingHom.comp (g : S →+* T) (f : R →+* S) with }
#align mul_semiring_action_hom.comp MulSemiringActionHom.comp

@[simp]
theorem comp_apply (g : S →+*[M] T) (f : R →+*[M] S) (x : R) : g.comp f x = g (f x) :=
  rfl
#align mul_semiring_action_hom.comp_apply MulSemiringActionHom.comp_apply

@[simp]
theorem id_comp (f : R →+*[M] S) : (MulSemiringActionHom.id M).comp f = f :=
  ext fun x => by rw [comp_apply, id_apply]
#align mul_semiring_action_hom.id_comp MulSemiringActionHom.id_comp

@[simp]
theorem comp_id (f : R →+*[M] S) : f.comp (MulSemiringActionHom.id M) = f :=
  ext fun x => by rw [comp_apply, id_apply]
#align mul_semiring_action_hom.comp_id MulSemiringActionHom.comp_id

end MulSemiringActionHom


import algebra.module
import linear_algebra.basic
import tactic

variables (G : Type*) [group G] (𝕜 : Type*) [field 𝕜]
variables (V : Type*) [add_comm_group V] [has_scalar G V] [vector_space 𝕜 V]
variables (W : Type*) [add_comm_group W] [has_scalar G W] [vector_space 𝕜 W]

class group_module :=
(id : ∀ v : V, (1 : G) • v = v)
(action : ∀ g h : G, ∀ m : V, g • (h • m) = (g * h) • m)
(distrib : ∀ g : G, ∀ m n : V, g • (m + n) = g • m + g • n)

lemma act_zero [group_module G V] :
∀ g : G, g • (0 : V) = 0 :=
begin
    intro g,
    have h := (group_module.distrib) g (0 : V) (0 : V),
    rw add_zero at h,
    rw add_left_eq_self.1 h.symm,
end

lemma act_neg [group_module G V] :
∀ g : G, ∀ v : V, g • -v = -(g • v) :=
begin
    intros g v,
    have h := (group_module.distrib) g v (-v),
    rw add_right_neg at h,
    rw act_zero at h,
    rw neg_eq_of_add_eq_zero h.symm,
end

class rep extends group_module G V :=
(linear : ∀ k : 𝕜, ∀ v : V, ∀ g : G,  g • (k • v) = k • (g • v))

variables [rep G 𝕜 V] [rep G 𝕜 W]

structure subrep extends submodule 𝕜 V :=
(stable : ∀ g : G, ∀ v : carrier, g • ↑v ∈ carrier)

variables (V' : subrep G 𝕜 V) (W' : subrep G 𝕜 W)

instance : has_coe_t (subrep G 𝕜 V) (set V) := ⟨λ V', V'.carrier⟩
instance : has_mem V (subrep G 𝕜 V) := ⟨λ v V', v ∈ (V' : set V)⟩
instance : has_coe_to_sort (subrep G 𝕜 V) := ⟨_, λ V', {v : V // v ∈ V'}⟩

instance subrep.is_add_comm_group
[h : add_comm_group (V'.to_submodule)] : add_comm_group V' := {.. h}

instance subrep.is_has_scalar : has_scalar G V' :=
{smul := λ g, λ ⟨v,h⟩, ⟨g • v, V'.stable g ⟨v,h⟩⟩}

instance subrep.is_group_module : group_module G V' := {
    id :=
    begin
        intro v,
        cases v,
        change (⟨(1 : G) • _, _⟩ : V') = (⟨v_val, _⟩ : V'),
        rw subtype.mk_eq_mk,
        rw group_module.id,
    end,
    action :=
    begin
        intros g h v,
        cases v,
        change (⟨g • h • _, _⟩ : V') = (⟨(g * h) • _, _⟩ : V'),
        rw subtype.mk_eq_mk,
        rw group_module.action,
    end,
    distrib :=
    begin
        intros g v w,
        cases v,
        cases w,
        change (⟨g • (_ + _), _⟩ : V') = (⟨g • _ + g • _, _⟩ : V'),
        rw subtype.mk_eq_mk,
        rw group_module.distrib,
    end
}

instance subrep.is_vector_space
[h : vector_space 𝕜 (V'.to_submodule)] : vector_space 𝕜 V' := {.. h}

instance subrep.is_rep : rep G 𝕜 V' := {
    linear :=
    begin
        intros k v g,
        cases v,
        change (⟨g • k • _, _⟩ : V') = (⟨k • g • _, _⟩ : V'),
        rw subtype.mk_eq_mk,
        rw rep.linear,
    end
}

lemma bot_closed :
∀ g : G, ∀ (v : (⊥ : submodule 𝕜 V)), g • ↑v ∈ (⊥ : submodule 𝕜 V) :=
begin
    intros g v,
    rw submodule.mem_bot,
    rw (submodule.mem_bot 𝕜).1 (submodule.coe_mem v),
    exact act_zero G V g,
end

lemma top_closed :
∀ g : G, ∀ (v : (⊤ : submodule 𝕜 V)), g • ↑v ∈ (⊤ : submodule 𝕜 V) :=
begin
    intros g v,
    exact trivial,
end

instance : has_bot (subrep G 𝕜 V) := ⟨⟨⊥,bot_closed G 𝕜 V⟩⟩

instance : has_top (subrep G 𝕜 V) := ⟨⟨⊤,top_closed G 𝕜 V⟩⟩

definition irreducible : Prop :=
(∀ V' : subrep G 𝕜 V, (V' = ⊥) ∨ (V' = ⊤))


variable (α : Type) (p q : α → Prop)
variable (r : Prop)

example : α → ((∀ x : α, r) ↔ r) :=
  λ x : α =>
    Iff.intro
      (
        λ hr : ∀ x : α, r =>
          hr x
      )
      (
        λ hr : r =>
          λ y : α => hr
      )

open Classical

example : (∀ x, p x ∨ r) ↔ (∀ x, p x) ∨ r :=
  Iff.intro
    (
      λ h : ∀ x, p x ∨ r =>
        Or.elim (em r)
          Or.inr
          (
            λ hnr : ¬r =>
              Or.inl
                (
                  λ y : α =>
                    Or.elim (h y)
                      (
                        λ hp : p y => hp
                      )
                      (
                        λ hr : r => absurd hr hnr
                      )
                )
          )
    )
    (
      λ h : (∀ x, p x) ∨ r =>
        λ y : α =>
          Or.elim h
            (
              λ h' : ∀ x, p x =>
                Or.inl (h' y)
            )
            (
              λ hr : r => Or.inr hr
            )
    )

example : (∀ x, r → p x) ↔ (r → ∀ x, p x) :=
  Iff.intro
    (
      λ h : ∀ x, r → p x =>
        λ hr : r =>
          λ y : α =>
            (h y) hr
    )
    (
      λ h : r → ∀ x, p x =>
        λ y : α =>
          λ hr : r =>
            (h hr) y
    )


variable (men : Type) (barber : men)

variable  (shaves : men → men → Prop)

example (h : ∀ x : men, shaves barber x ↔ ¬ shaves x x) : False := by
  have h' := h barber
  have hnb := λ hs => (h'.mp hs) hs
  have hb := h'.mpr hnb
  contradiction


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.algebra.module
import topology.instances.real

/-!
# Continuous additive maps are `ℝ`-linear

In this file we prove that a continuous map `f : E →+ F` between two topological vector spaces
over `ℝ` is `ℝ`-linear
-/

variables {E : Type*} [add_comm_group E] [module ℝ E] [topological_space E]
  [has_continuous_smul ℝ E] {F : Type*} [add_comm_group F] [module ℝ F]
  [topological_space F] [has_continuous_smul ℝ F] [t2_space F]

namespace add_monoid_hom

/-- A continuous additive map between two vector spaces over `ℝ` is `ℝ`-linear. -/
lemma map_real_smul (f : E →+ F) (hf : continuous f) (c : ℝ) (x : E) :
  f (c • x) = c • f x :=
suffices (λ c : ℝ, f (c • x)) = λ c : ℝ, c • f x, from _root_.congr_fun this c,
dense_embedding_of_rat.dense.equalizer
  (hf.comp $ continuous_id.smul continuous_const)
  (continuous_id.smul continuous_const)
  (funext $ λ r, f.map_rat_cast_smul r x)

/-- Reinterpret a continuous additive homomorphism between two real vector spaces
as a continuous real-linear map. -/
def to_real_linear_map (f : E →+ F) (hf : continuous f) : E →L[ℝ] F :=
⟨⟨f, f.map_add, f.map_real_smul hf⟩, hf⟩

@[simp] lemma coe_to_real_linear_map (f : E →+ F) (hf : continuous f) :
  ⇑(f.to_real_linear_map hf) = f := rfl

end add_monoid_hom


import data.zmod.basic extra.periodic.big_operators data.nat.periodic

/-! # IMO 2009 N1 (P1) -/

namespace IMOSL
namespace IMO2009N1

open function finset extra

/-- Generalized version with commutative monoids -/
theorem final_solution_general_monoid {M : Type*} [comm_monoid M] {k : ℕ} (hk : 0 < k)
  {a : ℕ → M} (h : periodic a k) (h0 : ∀ i : ℕ, a i * a i.succ = a i) :
  ∀ i j : ℕ, a i = a j :=
begin
  suffices : ∀ i : ℕ, a i = (range k).prod a,
    intros i j; rw [this, this],
  intros i; rw ← periodic_prod_const h i,
  clear h; cases k with k k,
  exfalso; exact lt_irrefl 0 hk,
  clear hk; induction k with k k_ih,
  rw [prod_range_one, zero_add],
  rw [k_ih, prod_range_succ, prod_range_succ, prod_range_succ, mul_assoc, nat.succ_add, h0]
end

/-- Generalized version with commutative rings -/
theorem final_solution_general_ring {R : Type*} [comm_ring R] {k : ℕ} (hk : 0 < k)
  {a : ℕ → R} (h : periodic a k) (h0 : ∀ i : ℕ, a i * (a i.succ - 1) = 0) :
  ∀ i j : ℕ, a i = a j :=
  final_solution_general_monoid hk h
    (λ i, by rw [← sub_eq_zero, ← mul_sub_one]; exact h0 i)

/-- Generalized version with integers using divisibility -/
theorem final_solution_int_div {k : ℕ} (hk : 0 < k) {a : ℕ → ℤ} (h : periodic a k)
  (n : ℕ) (h0 : ∀ i : ℕ, (n : ℤ) ∣ a i * (a i.succ - 1)) :
  ∀ i j : ℕ, (n : ℤ) ∣ a i - a j :=
begin
  intros i j; rw [← int.modeq_iff_dvd, ← zmod.int_coe_eq_int_coe_iff, eq_comm],
  revert i j; refine final_solution_general_ring hk (periodic.comp h coe) (λ i, _),
  rw [← int.cast_one, ← int.cast_sub, ← int.cast_mul, zmod.int_coe_zmod_eq_zero_iff_dvd],
  exact h0 i
end

/-- Final solution -/
theorem final_solution {k : ℕ} (hk : 0 < k) {a : ℕ → ℤ} (h : periodic a k.succ)
  (h0 : ∀ i j : ℕ, i < k.succ → j < k.succ → a i = a j → i = j) (n : ℕ)
  (h1 : ∀ i : ℕ, 0 < a i ∧ a i ≤ n) (h2 : ∀ i : ℕ, i < k → (n : ℤ) ∣ a i * (a i.succ - 1)) :
  ¬(n : ℤ) ∣ a k * (a 0 - 1) :=
begin
  intros h3,
  refine zero_ne_one (h0 0 1 k.succ_pos (nat.succ_lt_succ hk) _),
  rw ← sub_eq_zero,
  refine int.eq_zero_of_abs_lt_dvd (final_solution_int_div k.succ_pos h n _ 0 1) _,
  { intros i,
    rw [← periodic.map_mod_nat h, ← periodic.map_mod_nat h i.succ,
        nat.succ_eq_add_one i, ← nat.mod_add_mod, periodic.map_mod_nat h (i % _ + 1)],
    have h4 := nat.mod_lt i k.succ_pos,
    rw [nat.lt_succ_iff, le_iff_lt_or_eq] at h4,
    cases h4 with h4 h4,
    exact h2 _ h4,
    rwa [h4, ← nat.succ_eq_add_one, ← zero_add k.succ, h] },
  { suffices : ∀ i j : ℕ, a i - a j < n,
    { rw abs_sub_lt_iff; split,
      exacts [this _ _, this _ _] },
    intros i j,
    rw sub_lt_iff_lt_add,
    refine lt_of_le_of_lt (h1 i).2 _,
    rw lt_add_iff_pos_right; exact (h1 j).1 }
end

end IMO2009N1
end IMOSL


/-
Copyright (c) 2020 Aaron Anderson. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Aaron Anderson
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.data.multiset.lattice
import Mathlib.algebra.gcd_monoid
import Mathlib.PostPort

universes u_1

namespace Mathlib

/-!
# GCD and LCM operations on multisets

## Main definitions

- `multiset.gcd` - the greatest common denominator of a `multiset` of elements of a `gcd_monoid`
- `multiset.lcm` - the least common multiple of a `multiset` of elements of a `gcd_monoid`

## Implementation notes

TODO: simplify with a tactic and `data.multiset.lattice`

## Tags

multiset, gcd
-/

namespace multiset

/-! ### lcm -/

/-- Least common multiple of a multiset -/
def lcm {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] (s : multiset α) : α :=
  fold lcm 1 s

@[simp] theorem lcm_zero {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] : lcm 0 = 1 :=
  fold_zero lcm 1

@[simp] theorem lcm_cons {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] (a : α) (s : multiset α) : lcm (a ::ₘ s) = lcm a (lcm s) :=
  fold_cons_left lcm 1 a s

@[simp] theorem lcm_singleton {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] {a : α} : lcm (a ::ₘ 0) = coe_fn normalize a := sorry

@[simp] theorem lcm_add {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] (s₁ : multiset α) (s₂ : multiset α) : lcm (s₁ + s₂) = lcm (lcm s₁) (lcm s₂) := sorry

theorem lcm_dvd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] {s : multiset α} {a : α} : lcm s ∣ a ↔ ∀ (b : α), b ∈ s → b ∣ a := sorry

theorem dvd_lcm {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] {s : multiset α} {a : α} (h : a ∈ s) : a ∣ lcm s :=
  iff.mp lcm_dvd (dvd_refl (lcm s)) a h

theorem lcm_mono {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] {s₁ : multiset α} {s₂ : multiset α} (h : s₁ ⊆ s₂) : lcm s₁ ∣ lcm s₂ :=
  iff.mpr lcm_dvd fun (b : α) (hb : b ∈ s₁) => dvd_lcm (h hb)

@[simp] theorem normalize_lcm {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] (s : multiset α) : coe_fn normalize (lcm s) = lcm s := sorry

@[simp] theorem lcm_erase_dup {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] [DecidableEq α] (s : multiset α) : lcm (erase_dup s) = lcm s := sorry

@[simp] theorem lcm_ndunion {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] [DecidableEq α] (s₁ : multiset α) (s₂ : multiset α) : lcm (ndunion s₁ s₂) = lcm (lcm s₁) (lcm s₂) := sorry

@[simp] theorem lcm_union {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] [DecidableEq α] (s₁ : multiset α) (s₂ : multiset α) : lcm (s₁ ∪ s₂) = lcm (lcm s₁) (lcm s₂) := sorry

@[simp] theorem lcm_ndinsert {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] [DecidableEq α] (a : α) (s : multiset α) : lcm (ndinsert a s) = lcm a (lcm s) := sorry

/-! ### gcd -/

/-- Greatest common divisor of a multiset -/
def gcd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] (s : multiset α) : α :=
  fold gcd 0 s

@[simp] theorem gcd_zero {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] : gcd 0 = 0 :=
  fold_zero gcd 0

@[simp] theorem gcd_cons {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] (a : α) (s : multiset α) : gcd (a ::ₘ s) = gcd a (gcd s) :=
  fold_cons_left gcd 0 a s

@[simp] theorem gcd_singleton {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] {a : α} : gcd (a ::ₘ 0) = coe_fn normalize a := sorry

@[simp] theorem gcd_add {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] (s₁ : multiset α) (s₂ : multiset α) : gcd (s₁ + s₂) = gcd (gcd s₁) (gcd s₂) := sorry

theorem dvd_gcd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] {s : multiset α} {a : α} : a ∣ gcd s ↔ ∀ (b : α), b ∈ s → a ∣ b := sorry

theorem gcd_dvd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] {s : multiset α} {a : α} (h : a ∈ s) : gcd s ∣ a :=
  iff.mp dvd_gcd (dvd_refl (gcd s)) a h

theorem gcd_mono {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] {s₁ : multiset α} {s₂ : multiset α} (h : s₁ ⊆ s₂) : gcd s₂ ∣ gcd s₁ :=
  iff.mpr dvd_gcd fun (b : α) (hb : b ∈ s₁) => gcd_dvd (h hb)

@[simp] theorem normalize_gcd {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] (s : multiset α) : coe_fn normalize (gcd s) = gcd s := sorry

theorem gcd_eq_zero_iff {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] (s : multiset α) : gcd s = 0 ↔ ∀ (x : α), x ∈ s → x = 0 := sorry

@[simp] theorem gcd_erase_dup {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] [DecidableEq α] (s : multiset α) : gcd (erase_dup s) = gcd s := sorry

@[simp] theorem gcd_ndunion {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] [DecidableEq α] (s₁ : multiset α) (s₂ : multiset α) : gcd (ndunion s₁ s₂) = gcd (gcd s₁) (gcd s₂) := sorry

@[simp] theorem gcd_union {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] [DecidableEq α] (s₁ : multiset α) (s₂ : multiset α) : gcd (s₁ ∪ s₂) = gcd (gcd s₁) (gcd s₂) := sorry

@[simp] theorem gcd_ndinsert {α : Type u_1} [comm_cancel_monoid_with_zero α] [nontrivial α] [gcd_monoid α] [DecidableEq α] (a : α) (s : multiset α) : gcd (ndinsert a s) = gcd a (gcd s) := sorry


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

Construction of a good coupling between nonempty compact metric spaces, minimizing
their Hausdorff distance. This construction is instrumental to study the Gromov-Hausdorff
distance between nonempty compact metric spaces -/
import topology.metric_space.gluing
import topology.metric_space.hausdorff_distance
import topology.continuous_function.bounded

noncomputable theory
open_locale classical topological_space nnreal
universes u v w

open classical set function topological_space filter metric quotient
open bounded_continuous_function
open sum (inl inr)

local attribute [instance] metric_space_sum

namespace Gromov_Hausdorff

section Gromov_Hausdorff_realized
/- This section shows that the Gromov-Hausdorff distance
is realized. For this, we consider candidate distances on the disjoint union
α ⊕ β of two compact nonempty metric spaces, almost realizing the Gromov-Hausdorff
distance, and show that they form a compact family by applying Arzela-Ascoli
theorem. The existence of a minimizer follows. -/

section definitions
variables (α : Type u) (β : Type v)
  [metric_space α] [compact_space α] [nonempty α]
  [metric_space β] [compact_space β] [nonempty β]

@[reducible] private def prod_space_fun : Type* := ((α ⊕ β) × (α ⊕ β)) → ℝ
@[reducible] private def Cb : Type* := bounded_continuous_function ((α ⊕ β) × (α ⊕ β)) ℝ

private def max_var : ℝ≥0 :=
2 * ⟨diam (univ : set α), diam_nonneg⟩ + 1 + 2 * ⟨diam (univ : set β), diam_nonneg⟩

private lemma one_le_max_var : 1 ≤ max_var α β := calc
  (1 : real) = 2 * 0 + 1 + 2 * 0 : by simp
  ... ≤ 2 * diam (univ : set α) + 1 + 2 * diam (univ : set β) :
  by apply_rules [add_le_add, mul_le_mul_of_nonneg_left, diam_nonneg]; norm_num

/-- The set of functions on α ⊕ β that are candidates distances to realize the
minimum of the Hausdorff distances between α and β in a coupling -/
def candidates : set (prod_space_fun α β) :=
  {f | (((((∀x y : α, f (sum.inl x, sum.inl y) = dist x y)
    ∧ (∀x y : β, f (sum.inr x, sum.inr y) = dist x y))
    ∧ (∀x y,     f (x, y) = f (y, x)))
    ∧ (∀x y z,   f (x, z) ≤ f (x, y) + f (y, z)))
    ∧ (∀x,       f (x, x) = 0))
    ∧ (∀x y,     f (x, y) ≤ max_var α β) }

/-- Version of the set of candidates in bounded_continuous_functions, to apply
Arzela-Ascoli -/
private def candidates_b : set (Cb α β) := {f : Cb α β | f.to_fun ∈ candidates α β}

end definitions --section

section constructions

variables {α : Type u} {β : Type v}
[metric_space α] [compact_space α] [nonempty α] [metric_space β] [compact_space β] [nonempty β]
{f : prod_space_fun α β} {x y z t : α ⊕ β}
local attribute [instance, priority 10] inhabited_of_nonempty'

private lemma max_var_bound : dist x y ≤ max_var α β := calc
  dist x y ≤ diam (univ : set (α ⊕ β)) :
    dist_le_diam_of_mem (bounded_of_compact compact_univ) (mem_univ _) (mem_univ _)
  ... = diam (inl '' (univ : set α) ∪ inr '' (univ : set β)) :
    by apply congr_arg; ext x y z; cases x; simp [mem_univ, mem_range_self]
  ... ≤ diam (inl '' (univ : set α)) + dist (inl (default α)) (inr (default β)) +
          diam (inr '' (univ : set β)) :
    diam_union (mem_image_of_mem _ (mem_univ _)) (mem_image_of_mem _ (mem_univ _))
  ... = diam (univ : set α) + (dist (default α) (default α) + 1 + dist (default β) (default β)) +
          diam (univ : set β) :
    by { rw [isometry_on_inl.diam_image, isometry_on_inr.diam_image], refl }
  ... = 1 * diam (univ : set α) + 1 + 1 * diam (univ : set β) : by simp
  ... ≤ 2 * diam (univ : set α) + 1 + 2 * diam (univ : set β) :
  begin
    apply_rules [add_le_add, mul_le_mul_of_nonneg_right, diam_nonneg, le_refl],
    norm_num, norm_num
  end

private lemma candidates_symm (fA : f ∈ candidates α β) : f (x, y) = f (y ,x) := fA.1.1.1.2 x y

private lemma candidates_triangle (fA : f ∈ candidates α β) : f (x, z) ≤ f (x, y) + f (y, z) :=
  fA.1.1.2 x y z

private lemma candidates_refl (fA : f ∈ candidates α β) : f (x, x) = 0 := fA.1.2 x

private lemma candidates_nonneg (fA : f ∈ candidates α β) : 0 ≤ f (x, y) :=
begin
  have : 0 ≤ 2 * f (x, y) := calc
    0 = f (x, x) : (candidates_refl fA).symm
    ... ≤ f (x, y) + f (y, x) : candidates_triangle fA
    ... = f (x, y) + f (x, y) : by rw [candidates_symm fA]
    ... = 2 * f (x, y) : by ring,
  by linarith
end

private lemma candidates_dist_inl (fA : f ∈ candidates α β) (x y: α) :
  f (inl x, inl y) = dist x y :=
fA.1.1.1.1.1 x y

private lemma candidates_dist_inr (fA : f ∈ candidates α β) (x y : β) :
  f (inr x, inr y) = dist x y :=
fA.1.1.1.1.2 x y

private lemma candidates_le_max_var (fA : f ∈ candidates α β) : f (x, y) ≤ max_var α β :=
fA.2 x y

/-- candidates are bounded by max_var α β -/
private lemma candidates_dist_bound  (fA : f ∈ candidates α β) :
  ∀ {x y : α ⊕ β}, f (x, y) ≤ max_var α β * dist x y
| (inl x) (inl y) := calc
    f (inl x, inl y) = dist x y : candidates_dist_inl fA x y
    ... = dist (inl x) (inl y) : by { rw @sum.dist_eq α β, refl }
    ... = 1 * dist (inl x) (inl y) : by simp
    ... ≤ max_var α β * dist (inl x) (inl y) :
      mul_le_mul_of_nonneg_right (one_le_max_var α β) dist_nonneg
| (inl x) (inr y) := calc
    f (inl x, inr y) ≤ max_var α β : candidates_le_max_var fA
    ... = max_var α β * 1 : by simp
    ... ≤ max_var α β * dist (inl x) (inr y) :
      mul_le_mul_of_nonneg_left sum.one_dist_le (le_trans (zero_le_one) (one_le_max_var α β))
| (inr x) (inl y) := calc
    f (inr x, inl y) ≤ max_var α β : candidates_le_max_var fA
    ... = max_var α β * 1 : by simp
    ... ≤ max_var α β * dist (inl x) (inr y) :
      mul_le_mul_of_nonneg_left sum.one_dist_le (le_trans (zero_le_one) (one_le_max_var α β))
| (inr x) (inr y) := calc
    f (inr x, inr y) = dist x y : candidates_dist_inr fA x y
    ... = dist (inr x) (inr y) : by { rw @sum.dist_eq α β, refl }
    ... = 1 * dist (inr x) (inr y) : by simp
    ... ≤ max_var α β * dist (inr x) (inr y) :
      mul_le_mul_of_nonneg_right (one_le_max_var α β) dist_nonneg

/-- Technical lemma to prove that candidates are Lipschitz -/
private lemma candidates_lipschitz_aux (fA : f ∈ candidates α β) :
  f (x, y) - f (z, t) ≤ 2 * max_var α β * dist (x, y) (z, t) :=
calc
  f (x, y) - f(z, t) ≤ f (x, t) + f (t, y) - f (z, t) : sub_le_sub_right (candidates_triangle fA) _
  ... ≤ (f (x, z) + f (z, t) + f(t, y)) - f (z, t) :
    sub_le_sub_right (add_le_add_right (candidates_triangle fA) _ ) _
  ... = f (x, z) + f (t, y) : by simp [sub_eq_add_neg, add_assoc]
  ... ≤ max_var α β * dist x z + max_var α β * dist t y :
    add_le_add (candidates_dist_bound fA) (candidates_dist_bound fA)
  ... ≤ max_var α β * max (dist x z) (dist t y) + max_var α β * max (dist x z) (dist t y) :
  begin
    apply add_le_add,
    apply mul_le_mul_of_nonneg_left (le_max_left (dist x z) (dist t y))
      (zero_le_one.trans (one_le_max_var α β)),
    apply mul_le_mul_of_nonneg_left (le_max_right (dist x z) (dist t y))
      (zero_le_one.trans (one_le_max_var α β)),
  end
  ... = 2 * max_var α β * max (dist x z) (dist y t) :
    by { simp [dist_comm], ring }
  ... = 2 * max_var α β * dist (x, y) (z, t) : by refl

/-- Candidates are Lipschitz -/
private lemma candidates_lipschitz (fA : f ∈ candidates α β) :
  lipschitz_with (2 * max_var α β) f :=
begin
  apply lipschitz_with.of_dist_le_mul,
  rintros ⟨x, y⟩ ⟨z, t⟩,
  rw [real.dist_eq, abs_sub_le_iff],
  use candidates_lipschitz_aux fA,
  rw [dist_comm],
  exact candidates_lipschitz_aux fA
end

/-- candidates give rise to elements of bounded_continuous_functions -/
def candidates_b_of_candidates (f : prod_space_fun α β) (fA : f ∈ candidates α β) : Cb α β :=
bounded_continuous_function.mk_of_compact ⟨f, (candidates_lipschitz fA).continuous⟩

lemma candidates_b_of_candidates_mem (f : prod_space_fun α β) (fA : f ∈ candidates α β) :
  candidates_b_of_candidates f fA ∈ candidates_b α β := fA

/-- The distance on α ⊕ β is a candidate -/
private lemma dist_mem_candidates : (λp : (α ⊕ β) × (α ⊕ β), dist p.1 p.2) ∈ candidates α β :=
begin
  simp only [candidates, dist_comm, forall_const, and_true, add_comm, eq_self_iff_true,
             and_self, sum.forall, set.mem_set_of_eq, dist_self],
  repeat { split
    <|> exact (λa y z, dist_triangle_left _ _ _)
    <|> exact (λx y, by refl)
    <|> exact (λx y, max_var_bound) }
end

def candidates_b_dist (α : Type u) (β : Type v) [metric_space α] [compact_space α] [inhabited α]
  [metric_space β] [compact_space β] [inhabited β] : Cb α β :=
candidates_b_of_candidates _ dist_mem_candidates

lemma candidates_b_dist_mem_candidates_b : candidates_b_dist α β ∈ candidates_b α β :=
candidates_b_of_candidates_mem _ _

private lemma candidates_b_nonempty : (candidates_b α β).nonempty :=
⟨_,  candidates_b_dist_mem_candidates_b⟩

/-- To apply Arzela-Ascoli, we need to check that the set of candidates is closed and
equicontinuous. Equicontinuity follows from the Lipschitz control, we check closedness. -/
private lemma closed_candidates_b : is_closed (candidates_b α β) :=
begin
  have I1 : ∀x y, is_closed {f : Cb α β | f (inl x, inl y) = dist x y} :=
    λx y, is_closed_eq continuous_evalx continuous_const,
  have I2 : ∀x y, is_closed {f : Cb α β | f (inr x, inr y) = dist x y } :=
    λx y, is_closed_eq continuous_evalx continuous_const,
  have I3 : ∀x y, is_closed {f : Cb α β | f (x, y) = f (y, x)} :=
    λx y, is_closed_eq continuous_evalx continuous_evalx,
  have I4 : ∀x y z, is_closed {f : Cb α β | f (x, z) ≤ f (x, y) + f (y, z)} :=
    λx y z, is_closed_le continuous_evalx (continuous_evalx.add continuous_evalx),
  have I5 : ∀x, is_closed {f : Cb α β | f (x, x) = 0} :=
    λx, is_closed_eq continuous_evalx continuous_const,
  have I6 : ∀x y, is_closed {f : Cb α β | f (x, y) ≤ max_var α β} :=
    λx y, is_closed_le continuous_evalx continuous_const,
  have : candidates_b α β = (⋂x y, {f : Cb α β | f ((@inl α β x), (@inl α β y)) = dist x y})
               ∩ (⋂x y, {f : Cb α β | f ((@inr α β x), (@inr α β y)) = dist x y})
               ∩ (⋂x y, {f : Cb α β | f (x, y) = f (y, x)})
               ∩ (⋂x y z, {f : Cb α β | f (x, z) ≤ f (x, y) + f (y, z)})
               ∩ (⋂x, {f : Cb α β | f (x, x) = 0})
               ∩ (⋂x y, {f : Cb α β | f (x, y) ≤ max_var α β}) :=
    begin ext, unfold candidates_b, unfold candidates, simp [-sum.forall], refl end,
  rw this,
  repeat { apply is_closed_inter _ _
       <|> apply is_closed_Inter _
       <|> apply I1 _ _
       <|> apply I2 _ _
       <|> apply I3 _ _
       <|> apply I4 _ _ _
       <|> apply I5 _
       <|> apply I6 _ _
       <|> assume x },
end

/-- Compactness of candidates (in bounded_continuous_functions) follows. -/
private lemma compact_candidates_b : is_compact (candidates_b α β) :=
begin
  refine arzela_ascoli₂ (Icc 0 (max_var α β)) compact_Icc (candidates_b α β)
  closed_candidates_b _ _,
  { rintros f ⟨x1, x2⟩ hf,
    simp only [set.mem_Icc],
    exact ⟨candidates_nonneg hf, candidates_le_max_var hf⟩ },
  { refine equicontinuous_of_continuity_modulus (λt, 2 * max_var α β * t) _ _ _,
    { have : tendsto (λ (t : ℝ), 2 * (max_var α β : ℝ) * t) (𝓝 0) (𝓝 (2 * max_var α β * 0)) :=
        tendsto_const_nhds.mul tendsto_id,
      simpa using this },
    { assume x y f hf,
      exact (candidates_lipschitz hf).dist_le_mul _ _ } }
end

/-- We will then choose the candidate minimizing the Hausdorff distance. Except that we are not
in a metric space setting, so we need to define our custom version of Hausdorff distance,
called HD, and prove its basic properties. -/
def HD (f : Cb α β) := max (⨆ x, ⨅ y, f (inl x, inr y)) (⨆ y, ⨅ x, f (inl x, inr y))

/- We will show that HD is continuous on bounded_continuous_functions, to deduce that its
minimum on the compact set candidates_b is attained. Since it is defined in terms of
infimum and supremum on ℝ, which is only conditionnally complete, we will need all the time
to check that the defining sets are bounded below or above. This is done in the next few
technical lemmas -/

lemma HD_below_aux1 {f : Cb α β} (C : ℝ) {x : α} :
  bdd_below (range (λ (y : β), f (inl x, inr y) + C)) :=
let ⟨cf, hcf⟩ := (real.bounded_iff_bdd_below_bdd_above.1 bounded_range).1 in
⟨cf + C, forall_range_iff.2 (λi, add_le_add_right ((λx, hcf (mem_range_self x)) _) _)⟩

private lemma HD_bound_aux1 (f : Cb α β) (C : ℝ) :
  bdd_above (range (λ (x : α), ⨅ y, f (inl x, inr y) + C)) :=
begin
  rcases (real.bounded_iff_bdd_below_bdd_above.1 bounded_range).2 with ⟨Cf, hCf⟩,
  refine ⟨Cf + C, forall_range_iff.2 (λx, _)⟩,
  calc (⨅ y, f (inl x, inr y) + C) ≤ f (inl x, inr (default β)) + C :
    cinfi_le (HD_below_aux1 C) (default β)
    ... ≤ Cf + C : add_le_add ((λx, hCf (mem_range_self x)) _) (le_refl _)
end

lemma HD_below_aux2 {f : Cb α β} (C : ℝ) {y : β} :
  bdd_below (range (λ (x : α), f (inl x, inr y) + C)) :=
let ⟨cf, hcf⟩ := (real.bounded_iff_bdd_below_bdd_above.1 bounded_range).1 in
⟨cf + C, forall_range_iff.2 (λi, add_le_add_right ((λx, hcf (mem_range_self x)) _) _)⟩

private lemma HD_bound_aux2 (f : Cb α β) (C : ℝ) :
  bdd_above (range (λ (y : β), ⨅ x, f (inl x, inr y) + C)) :=
begin
  rcases (real.bounded_iff_bdd_below_bdd_above.1 bounded_range).2 with ⟨Cf, hCf⟩,
  refine ⟨Cf + C, forall_range_iff.2 (λy, _)⟩,
  calc (⨅ x, f (inl x, inr y) + C) ≤ f (inl (default α), inr y) + C :
    cinfi_le (HD_below_aux2 C) (default α)
  ... ≤ Cf + C : add_le_add ((λx, hCf (mem_range_self x)) _) (le_refl _)
end

/-- Explicit bound on HD (dist). This means that when looking for minimizers it will
be sufficient to look for functions with HD(f) bounded by this bound. -/
lemma HD_candidates_b_dist_le :
  HD (candidates_b_dist α β) ≤ diam (univ : set α) + 1 + diam (univ : set β) :=
begin
  refine max_le (csupr_le (λx, _)) (csupr_le (λy, _)),
  { have A : (⨅ y, candidates_b_dist α β (inl x, inr y)) ≤
      candidates_b_dist α β (inl x, inr (default β)) :=
      cinfi_le (by simpa using HD_below_aux1 0) (default β),
    have B : dist (inl x) (inr (default β)) ≤ diam (univ : set α) + 1 + diam (univ : set β) := calc
      dist (inl x) (inr (default β)) = dist x (default α) + 1 + dist (default β) (default β) : rfl
      ... ≤ diam (univ : set α) + 1 + diam (univ : set β) :
      begin
        apply add_le_add (add_le_add _ (le_refl _)),
        exact dist_le_diam_of_mem (bounded_of_compact (compact_univ)) (mem_univ _) (mem_univ _),
        exact dist_le_diam_of_mem (bounded_of_compact (compact_univ)) (mem_univ _) (mem_univ _)
      end,
    exact le_trans A B },
  { have A : (⨅ x, candidates_b_dist α β (inl x, inr y)) ≤
      candidates_b_dist α β (inl (default α), inr y) :=
      cinfi_le (by simpa using HD_below_aux2 0) (default α),
    have B : dist (inl (default α)) (inr y) ≤ diam (univ : set α) + 1 + diam (univ : set β) := calc
      dist (inl (default α)) (inr y) = dist (default α) (default α) + 1 + dist (default β) y : rfl
      ... ≤ diam (univ : set α) + 1 + diam (univ : set β) :
      begin
        apply add_le_add (add_le_add _ (le_refl _)),
        exact dist_le_diam_of_mem (bounded_of_compact (compact_univ)) (mem_univ _) (mem_univ _),
        exact dist_le_diam_of_mem (bounded_of_compact (compact_univ)) (mem_univ _) (mem_univ _)
      end,
    exact le_trans A B },
end

/- To check that HD is continuous, we check that it is Lipschitz. As HD is a max, we
prove separately inequalities controlling the two terms (relying too heavily on copy-paste...) -/
private lemma HD_lipschitz_aux1 (f g : Cb α β) :
  (⨆ x, ⨅ y, f (inl x, inr y)) ≤ (⨆ x, ⨅ y, g (inl x, inr y)) + dist f g :=
begin
  rcases (real.bounded_iff_bdd_below_bdd_above.1 bounded_range).1 with ⟨cg, hcg⟩,
  have Hcg : ∀x, cg ≤ g x := λx, hcg (mem_range_self x),
  rcases (real.bounded_iff_bdd_below_bdd_above.1 bounded_range).1 with ⟨cf, hcf⟩,
  have Hcf : ∀x, cf ≤ f x := λx, hcf (mem_range_self x),

  -- prove the inequality but with `dist f g` inside, by using inequalities comparing
  -- supr to supr and infi to infi
  have Z : (⨆ x, ⨅ y, f (inl x, inr y)) ≤ ⨆ x, ⨅ y, g (inl x, inr y) + dist f g :=
    csupr_le_csupr (HD_bound_aux1 _ (dist f g))
      (λx, cinfi_le_cinfi ⟨cf, forall_range_iff.2(λi, Hcf _)⟩ (λy, coe_le_coe_add_dist)),
  -- move the `dist f g` out of the infimum and the supremum, arguing that continuous monotone maps
  -- (here the addition of `dist f g`) preserve infimum and supremum
  have E1 : ∀x, (⨅ y, g (inl x, inr y)) + dist f g = ⨅ y, g (inl x, inr y) + dist f g,
  { assume x,
    refine map_cinfi_of_continuous_at_of_monotone (continuous_at_id.add continuous_at_const) _ _,
    { assume x y hx, simpa },
    { show bdd_below (range (λ (y : β), g (inl x, inr y))),
        from ⟨cg, forall_range_iff.2(λi, Hcg _)⟩ } },
  have E2 : (⨆ x, ⨅ y, g (inl x, inr y)) + dist f g = ⨆ x, (⨅ y, g (inl x, inr y)) + dist f g,
  { refine map_csupr_of_continuous_at_of_monotone (continuous_at_id.add continuous_at_const) _ _,
    { assume x y hx, simpa },
    { by simpa using HD_bound_aux1 _ 0 } },
  -- deduce the result from the above two steps
  simpa [E2, E1, function.comp]
end

private lemma HD_lipschitz_aux2 (f g : Cb α β) :
  (⨆ y, ⨅ x, f (inl x, inr y)) ≤ (⨆ y, ⨅ x, g (inl x, inr y)) + dist f g :=
begin
  rcases (real.bounded_iff_bdd_below_bdd_above.1 bounded_range).1 with ⟨cg, hcg⟩,
  have Hcg : ∀x, cg ≤ g x := λx, hcg (mem_range_self x),
  rcases (real.bounded_iff_bdd_below_bdd_above.1 bounded_range).1 with ⟨cf, hcf⟩,
  have Hcf : ∀x, cf ≤ f x := λx, hcf (mem_range_self x),

  -- prove the inequality but with `dist f g` inside, by using inequalities comparing
  -- supr to supr and infi to infi
  have Z : (⨆ y, ⨅ x, f (inl x, inr y)) ≤ ⨆ y, ⨅ x, g (inl x, inr y) + dist f g :=
    csupr_le_csupr (HD_bound_aux2 _ (dist f g))
      (λy, cinfi_le_cinfi  ⟨cf, forall_range_iff.2(λi, Hcf _)⟩ (λy, coe_le_coe_add_dist)),
  -- move the `dist f g` out of the infimum and the supremum, arguing that continuous monotone maps
  -- (here the addition of `dist f g`) preserve infimum and supremum
  have E1 : ∀y, (⨅ x, g (inl x, inr y)) + dist f g = ⨅ x, g (inl x, inr y) + dist f g,
  { assume y,
    refine map_cinfi_of_continuous_at_of_monotone (continuous_at_id.add continuous_at_const) _ _,
    { assume x y hx, simpa },
    { show bdd_below (range (λx:α, g (inl x, inr y))),
        from ⟨cg, forall_range_iff.2 (λi, Hcg _)⟩ } },
  have E2 : (⨆ y, ⨅ x, g (inl x, inr y)) + dist f g = ⨆ y, (⨅ x, g (inl x, inr y)) + dist f g,
  { refine map_csupr_of_continuous_at_of_monotone (continuous_at_id.add continuous_at_const) _ _,
    { assume x y hx, simpa },
    { by simpa using HD_bound_aux2 _ 0 } },
  -- deduce the result from the above two steps
  simpa [E2, E1]
end

private lemma HD_lipschitz_aux3 (f g : Cb α β) : HD f ≤ HD g + dist f g :=
max_le (le_trans (HD_lipschitz_aux1 f g) (add_le_add_right (le_max_left _ _) _))
       (le_trans (HD_lipschitz_aux2 f g) (add_le_add_right (le_max_right _ _) _))

/-- Conclude that HD, being Lipschitz, is continuous -/
private lemma HD_continuous : continuous (HD : Cb α β → ℝ) :=
lipschitz_with.continuous (lipschitz_with.of_le_add HD_lipschitz_aux3)

end constructions --section

section consequences
variables (α : Type u) (β : Type v) [metric_space α] [compact_space α] [nonempty α] [metric_space β]
  [compact_space β] [nonempty β]

/- Now that we have proved that the set of candidates is compact, and that HD is continuous,
we can finally select a candidate minimizing HD. This will be the candidate realizing the
optimal coupling. -/
private lemma exists_minimizer : ∃f ∈ candidates_b α β, ∀g ∈ candidates_b α β, HD f ≤ HD g :=
compact_candidates_b.exists_forall_le candidates_b_nonempty HD_continuous.continuous_on

private definition optimal_GH_dist : Cb α β := classical.some (exists_minimizer α β)

private lemma optimal_GH_dist_mem_candidates_b : optimal_GH_dist α β ∈ candidates_b α β :=
by cases (classical.some_spec (exists_minimizer α β)); assumption

private lemma HD_optimal_GH_dist_le (g : Cb α β) (hg : g ∈ candidates_b α β) :
  HD (optimal_GH_dist α β) ≤ HD g :=
let ⟨Z1, Z2⟩ := classical.some_spec (exists_minimizer α β) in Z2 g hg

/-- With the optimal candidate, construct a premetric space structure on α ⊕ β, on which the
predistance is given by the candidate. Then, we will identify points at 0 predistance
to obtain a genuine metric space -/
def premetric_optimal_GH_dist : pseudo_metric_space (α ⊕ β) :=
{ dist := λp q, optimal_GH_dist α β (p, q),
  dist_self := λx, candidates_refl (optimal_GH_dist_mem_candidates_b α β),
  dist_comm := λx y, candidates_symm (optimal_GH_dist_mem_candidates_b α β),
  dist_triangle := λx y z, candidates_triangle (optimal_GH_dist_mem_candidates_b α β) }

local attribute [instance] premetric_optimal_GH_dist pseudo_metric.dist_setoid

/-- A metric space which realizes the optimal coupling between α and β -/
@[derive [metric_space]] definition optimal_GH_coupling : Type* :=
pseudo_metric_quot (α ⊕ β)

/-- Injection of α in the optimal coupling between α and β -/
def optimal_GH_injl (x : α) : optimal_GH_coupling α β := ⟦inl x⟧

/-- The injection of α in the optimal coupling between α and β is an isometry. -/
lemma isometry_optimal_GH_injl : isometry (optimal_GH_injl α β) :=
begin
  refine isometry_emetric_iff_metric.2 (λx y, _),
  change dist ⟦inl x⟧ ⟦inl y⟧ = dist x y,
  exact candidates_dist_inl (optimal_GH_dist_mem_candidates_b α β) _ _,
end

/-- Injection of β  in the optimal coupling between α and β -/
def optimal_GH_injr (y : β) : optimal_GH_coupling α β := ⟦inr y⟧

/-- The injection of β in the optimal coupling between α and β is an isometry. -/
lemma isometry_optimal_GH_injr : isometry (optimal_GH_injr α β) :=
begin
  refine isometry_emetric_iff_metric.2 (λx y, _),
  change dist ⟦inr x⟧ ⟦inr y⟧ = dist x y,
  exact candidates_dist_inr (optimal_GH_dist_mem_candidates_b α β) _ _,
end

/-- The optimal coupling between two compact spaces α and β is still a compact space -/
instance compact_space_optimal_GH_coupling : compact_space (optimal_GH_coupling α β) :=
⟨begin
  have : (univ : set (optimal_GH_coupling α β)) =
           (optimal_GH_injl α β '' univ) ∪ (optimal_GH_injr α β '' univ),
  { refine subset.antisymm (λxc hxc, _) (subset_univ _),
    rcases quotient.exists_rep xc with ⟨x, hx⟩,
    cases x; rw ← hx,
    { have : ⟦inl x⟧ = optimal_GH_injl α β x := rfl,
      rw this,
      exact mem_union_left _ (mem_image_of_mem _ (mem_univ _)) },
    { have : ⟦inr x⟧ = optimal_GH_injr α β x := rfl,
      rw this,
      exact mem_union_right _ (mem_image_of_mem _ (mem_univ _)) } },
  rw this,
  exact (compact_univ.image (isometry_optimal_GH_injl α β).continuous).union
    (compact_univ.image (isometry_optimal_GH_injr α β).continuous)
end⟩

/-- For any candidate f, HD(f) is larger than or equal to the Hausdorff distance in the
optimal coupling. This follows from the fact that HD of the optimal candidate is exactly
the Hausdorff distance in the optimal coupling, although we only prove here the inequality
we need. -/
lemma Hausdorff_dist_optimal_le_HD {f} (h : f ∈ candidates_b α β) :
  Hausdorff_dist (range (optimal_GH_injl α β)) (range (optimal_GH_injr α β)) ≤ HD f :=
begin
  refine le_trans (le_of_forall_le_of_dense (λr hr, _)) (HD_optimal_GH_dist_le α β f h),
  have A : ∀ x ∈ range (optimal_GH_injl α β), ∃ y ∈ range (optimal_GH_injr α β), dist x y ≤ r,
  { assume x hx,
    rcases mem_range.1 hx with ⟨z, hz⟩,
    rw ← hz,
    have I1 : (⨆ x, ⨅ y, optimal_GH_dist α β (inl x, inr y)) < r :=
      lt_of_le_of_lt (le_max_left _ _) hr,
    have I2 : (⨅ y, optimal_GH_dist α β (inl z, inr y)) ≤
        ⨆ x, ⨅ y, optimal_GH_dist α β (inl x, inr y) :=
      le_cSup (by simpa using HD_bound_aux1 _ 0) (mem_range_self _),
    have I : (⨅ y, optimal_GH_dist α β (inl z, inr y)) < r := lt_of_le_of_lt I2 I1,
    rcases exists_lt_of_cInf_lt (range_nonempty _) I with ⟨r', r'range, hr'⟩,
    rcases mem_range.1 r'range with ⟨z', hz'⟩,
    existsi [optimal_GH_injr α β z', mem_range_self _],
    have : (optimal_GH_dist α β) (inl z, inr z') ≤ r := begin rw hz', exact le_of_lt hr' end,
    exact this },
  refine Hausdorff_dist_le_of_mem_dist _ A _,
  { rcases exists_mem_of_nonempty α with ⟨xα, _⟩,
    have : optimal_GH_injl α β xα ∈ range (optimal_GH_injl α β) := mem_range_self _,
    rcases A _ this with ⟨y, yrange, hy⟩,
    exact le_trans dist_nonneg hy },
  { assume y hy,
    rcases mem_range.1 hy with ⟨z, hz⟩,
    rw ← hz,
    have I1 : (⨆ y, ⨅ x, optimal_GH_dist α β (inl x, inr y)) < r :=
      lt_of_le_of_lt (le_max_right _ _) hr,
    have I2 : (⨅ x, optimal_GH_dist α β (inl x, inr z)) ≤
        ⨆ y, ⨅ x, optimal_GH_dist α β (inl x, inr y) :=
      le_cSup (by simpa using HD_bound_aux2 _ 0) (mem_range_self _),
    have I : (⨅ x, optimal_GH_dist α β (inl x, inr z)) < r := lt_of_le_of_lt I2 I1,
    rcases exists_lt_of_cInf_lt (range_nonempty _) I with ⟨r', r'range, hr'⟩,
    rcases mem_range.1 r'range with ⟨z', hz'⟩,
    existsi [optimal_GH_injl α β z', mem_range_self _],
    have : (optimal_GH_dist α β) (inl z', inr z) ≤ r := begin rw hz', exact le_of_lt hr' end,
    rw dist_comm,
    exact this }
end

end consequences
/- We are done with the construction of the optimal coupling -/
end Gromov_Hausdorff_realized

end Gromov_Hausdorff