import algebra.pi_instances algebra.half_ring data.finset

/-- A function which is defined everywhere, but only has "interesting" values in
    a finite set of locations.

    This is used to define a basic vector space, where every defined basis is
    known. -/
structure fin_fn (α : Type*) (β : Type*) [has_zero β] :=
  (space : α → β)
  (support : finset α)
  (support_iff : ∀ x, space x ≠ 0 ↔ x ∈ support)

namespace fin_fn

section helpers
  variables {α : Type*} {β₁ : Type*} {β₂ : Type*} {β : Type*} [has_zero β₁] [has_zero β₂] [has_zero β]

  /-- Map over a finite set, assuming the support set doesn't grow. -/
  def on_finset [decidable_eq β] (s : finset α) (f : α → β) (hf : ∀a, f a ≠ 0 → a ∈ s) : fin_fn α β :=
    ⟨ f,
      s.filter (λa, f a ≠ 0),
      λ x, ⟨ λ h, finset.mem_filter.mpr ⟨ hf x h, h ⟩, λ h, (finset.mem_filter.mp h).2 ⟩ ⟩

  /-- Zip over two support sets, assuming the operation preserves 0. -/
  def zip_with [decidable_eq α] [decidable_eq β₁] [decidable_eq β]
    (f : β₁ → β₂ → β) (zero : f 0 0 = 0) (g₁ : fin_fn α β₁) (g₂ : fin_fn α β₂) : (fin_fn α β) :=
    on_finset (g₁.support ∪ g₂.support) (λa, f (g₁.space a) (g₂.space a)) (λ a not_zero, begin
      rw [finset.mem_union, (g₁.support_iff _).symm, (g₂.support_iff _).symm, ne, ← not_and_distrib],
      rintro ⟨ h₁, h₂ ⟩, rw [h₁, h₂] at not_zero, from not_zero zero,
    end)

  /-- Function extensionality lifted to fin_fns. -/
  @[ext]
  lemma ext : ∀ {f g : fin_fn α β}, (∀ a, f.space a = g.space a) → f = g
  | ⟨ f, sf, iff_f ⟩ ⟨ g, sg, iff_g ⟩ lift := begin
    have : f = g := funext lift, subst this,
    have : sf = sg := finset.ext' (λ a, (iff_f a).symm.trans (iff_g a)), subst this,
  end

  /-- Apply a 0-preserving function over the range of our fin_fn. -/
  def map_range [decidable_eq β] (f : β₁ → β) (zero : f 0 = 0) (g : fin_fn α β₁) : fin_fn α β :=
    on_finset g.support (f ∘ g.space) (λ a not_zero, begin
      rw [(g.support_iff _).symm],
      assume is_zero, rw [function.comp_app, is_zero] at not_zero, from not_zero zero,
    end)

  lemma unsupported_zero [decidable_eq β] {x : α} {f : fin_fn α β} : x ∉ f.support ↔ f.space x = 0
    := ⟨ λ nmem, by_contradiction (λ h, nmem ((f.support_iff x).mp h)),
         λ zero mem, (f.support_iff x).mpr mem zero ⟩

  /-- Function extensionality lifted to fin_fns. -/
  lemma ext' [decidable_eq β] : ∀ {f g : fin_fn α β}, f.support = g.support → (∀ a ∈ f.support, f.space a = g.space a) → f = g
  | ⟨ f, sf, iff_f ⟩ ⟨ g, _, iff_g ⟩ eql lift := begin
    simp only [] at eql, subst eql,
    suffices : ∀ a, f a = g a, from ext this,

    assume a,
    cases classical.prop_decidable (a ∈ sf),
    case is_true { from lift a h },
    case is_false {
      have : f a = 0,
      { have : a ∉ (fin_fn.mk f sf iff_f).support := h,
        from (unsupported_zero.mp this) },
      have : g a = 0,
      { have : a ∉ (fin_fn.mk g sf iff_g).support := h,
        from (unsupported_zero.mp this) },

      rw [‹f a = 0›, ‹g a = 0›],
    }
  end

  /-- Convert this fin_fn to a string, using a specific separator (such as "+"). -/
  protected def to_string [has_repr α] [has_repr β] : string → fin_fn α β → string
  | sep x := string.intercalate sep ((x.support.val.map (λ a, repr (x.space a) ++ " • " ++ repr a)).sort (≤))
end helpers

section monoid_instances
  variables (α : Type*) (β : Type*)

  instance [has_repr α] [has_repr β] [has_zero β] : has_repr (fin_fn α β) := ⟨ fin_fn.to_string "+" ⟩

  instance [has_zero β] : has_zero (fin_fn α β)
    := ⟨ { space := λ _, 0,
          support := finset.empty,
          support_iff := λ x, ⟨ λ nZero, by contradiction, λ x, by cases x ⟩ } ⟩

  instance [has_zero β] : inhabited (fin_fn α β) := ⟨ 0 ⟩

  instance [add_monoid β] [decidable_eq α] [decidable_eq β] : has_add (fin_fn α β) :=
    { add := zip_with (+) (add_zero 0) }

  instance [add_monoid β] [decidable_eq α] [decidable_eq β] : add_monoid (fin_fn α β) :=
    { add_assoc := λ a b c, ext (λ x, add_assoc _ _ _),
      zero_add := λ a, ext (λ x, zero_add _),
      add_zero := λ a, ext (λ x, add_zero _),
      ..fin_fn.has_add α β,
      ..fin_fn.has_zero α β }

  instance [add_comm_monoid β] [decidable_eq α] [decidable_eq β]
    : add_comm_monoid (fin_fn α β) :=
    { add_comm := λ a b, ext (λ x, add_comm _ _),
      ..fin_fn.add_monoid α β }

  instance [add_group β] [decidable_eq β] : has_neg (fin_fn α β) :=
    { neg := map_range has_neg.neg neg_zero }

  instance [add_comm_group β] [decidable_eq α] [decidable_eq β] : add_comm_group (fin_fn α β) :=
    { add_left_neg := λ f, ext (λ a, add_left_neg _),
      ..fin_fn.add_comm_monoid α β,
      ..fin_fn.has_neg α β  }

  instance [semiring β] [decidable_eq β]
    : has_scalar β (fin_fn α β)
    := { smul := λ a, map_range ((•) a) (smul_zero _) }

  instance [comm_ring β] [decidable_eq β]
    : mul_action β (fin_fn α β) :=
    { one_smul := λ f, ext (λ a, one_smul _ _),
      mul_smul := λ x y f, ext (λ a, mul_smul _ _ _),
    ..fin_fn.has_scalar α β }

  instance [comm_ring β] [decidable_eq α] [decidable_eq β]
    : distrib_mul_action β (fin_fn α β) :=
    { smul_add := λ r x y, ext (λ a, smul_add _ _ _),
      smul_zero := λ r, ext (λ a, smul_zero _),
      ..fin_fn.mul_action α β }

  instance [comm_ring β] [decidable_eq α] [decidable_eq β]
    : semimodule β (fin_fn α β) :=
    { add_smul := λ r s f, ext (λ a, right_distrib _ _ _),
      zero_smul := λ f, ext (λ a, zero_mul _),
      ..fin_fn.distrib_mul_action α β,
    }

  instance [has_zero β] [decidable_eq α] [decidable_eq β] : decidable_eq (fin_fn α β)
  | ⟨ a_f, a_space, a_iff ⟩ ⟨ b_f, b_space, b_iff ⟩ :=
    if eq_space : a_space = b_space then
      if eq_f : ∀ a ∈ a_space, a_f a = b_f a then
        is_true (ext' eq_space eq_f)
      else is_false (λ x, begin
        have h := (fin_fn.mk.inj x).1, subst h,
        from eq_f (λ x mem, rfl),
      end)
    else is_false (λ x, eq_space (fin_fn.mk.inj x).2)

  instance [add_monoid β] [decidable_eq α] [decidable_eq β] (a : α) : is_add_monoid_hom (λ f : fin_fn α β, f.space a)
    := { map_add := λ a b, rfl, map_zero := rfl }

end monoid_instances

section bulk_operations
variables {α : Type*} {β : Type*}

/-- Construct a fin_fn from a single value A. This returns a unit vector in the
    basis of 'A'. -/
def single [has_zero β] [decidable_eq α] [decidable_eq β] (A : α) (b : β) : fin_fn α β :=
  { space := λ B, if A = B then b else 0,
    support := if 0 = b then ∅ else finset.singleton A,
    support_iff := λ B, begin
      by_cases is_zero : 0 = b; by_cases is_eq : A = B; simp only [is_zero, is_eq, if_pos, if_false],
      { from ⟨ λ x, by contradiction, false.elim ⟩ },
      { from ⟨ λ x, by contradiction, false.elim ⟩ },
      { from ⟨ λ _, finset.mem_singleton.mpr rfl, λ _, ne.symm is_zero ⟩ },
      { from ⟨ λ x, by contradiction, λ mem, absurd (finset.mem_singleton.mp mem).symm is_eq ⟩ },
    end }

lemma single.inj [has_zero β] [decidable_eq α] [decidable_eq β] (A : α)
  : function.injective (@single α β _ _ _ A)
| b₁ b₂ eql := begin
  have : (single A b₁).space A = (single A b₂).space A, rw eql,
  simpa only [single, if_pos] using this,
end

@[simp]
lemma single_zero [has_zero β] [decidable_eq α] [decidable_eq β] (a : α) : single a (0 : β) = 0
  := by { simp only [single, if_pos, if_t_t], from rfl }

@[simp]
lemma single_add [add_monoid β] [decidable_eq α] [decidable_eq β] (a : α) (b₁ b₂ : β) :
  single a (b₁ + b₂) = single a b₁ + single a b₂
  := ext (λ x, begin
    show ite (a = x) (b₁ + b₂) 0 = ite (a = x) b₁ 0 + ite (a = x) b₂ 0,
    by_cases a = x; simp only [h, if_pos, if_false, add_zero],
  end)

/-- `sum f g` is the sum of `g a (f a)` over the support of `f`. -/
def sum {γ : Type*} [has_zero β] [add_comm_monoid γ] (f : fin_fn α β) (g : α → β → γ) : γ
  := f.support.sum (λa, g a (f.space a))

@[simp]
lemma sum_single_index {γ : Type*} [add_comm_monoid γ] [comm_ring β] [decidable_eq α] [decidable_eq β]
  (a : α) (b : β) (f : α → β → γ) (zero : ∀ x, f x 0 = 0): (single a b).sum f = f a b := begin
  by_cases 0 = b; simp only [sum, single, if_pos, if_false, h],
  { simp only [finset.sum_empty, h.symm, zero] },
  { simp only [finset.sum_singleton, if_pos] },
end

lemma sum_distrib {γ : Type*} [decidable_eq α] [decidable_eq β] [add_comm_monoid β] [add_comm_monoid γ] {x y : fin_fn α β}
  {h : α → β → γ} (h_zero : ∀ a, h a 0 = 0) (h_add : ∀a b₁ b₂, h a (b₁ + b₂) = h a b₁ + h a b₂) :
  (x + y).sum h = x.sum h + y.sum h := begin
  show finset.sum (finset.filter (λ a, x.space a + y.space a ≠ 0) (x.support ∪ y.support))
          (λ a, h a (x.space a + y.space a))
     = x.sum h + y.sum h,

  have : finset.sum (finset.filter (λ a, x.space a + y.space a ≠ 0) (x.support ∪ y.support))
           (λ a, h a (x.space a + y.space a))
       = finset.sum (x.support ∪ y.support) (λ a, h a (x.space a + y.space a))
       := finset.sum_subset (finset.filter_subset (x.support ∪ y.support)) (λ a mem not_mem, begin
      suffices : x.space a + y.space a = 0, simp only [h_zero, this],

      by_contradiction not_zero,
      have h := finset.mem_sdiff.mpr ⟨ mem, not_mem ⟩,
      rw ← finset.filter_not at h,
      from (finset.mem_filter.mp h).2 not_zero,
    end),
  rw this,

  have hx : x.sum h = finset.sum (x.support ∪ y.support) (λ a, h a (x.space a))
    := finset.sum_subset (finset.subset_union_left x.support y.support)
        (λ a mem not_x, by simp only [unsupported_zero.mp not_x, h_zero]),
  have hy : y.sum h = finset.sum (x.support ∪ y.support) (λ a, h a (y.space a))
    := finset.sum_subset (finset.subset_union_right x.support y.support)
        (λ a mem not_y, by simp only [unsupported_zero.mp not_y, h_zero]),

  simp only [hx, hy, h_add, finset.sum_add_distrib],
end

@[simp]
lemma sum_zero {γ : Type*} [has_zero β] [add_comm_monoid γ] (f : α → β → γ) : sum 0 f = 0 := rfl

@[simp]
lemma sum_const_zero {γ : Type*} [has_zero β] [add_comm_monoid γ] (f : fin_fn α β): sum f (λ _ _, (0 : γ)) = 0
  := finset.sum_const_zero

/-- Map every basis in the fin_fn to another fin_fn, accumulating them together. -/
def bind {γ : Type*} [decidable_eq γ] [decidable_eq β] [semiring β] (f : fin_fn α β) (g : α → fin_fn γ β) : fin_fn γ β
  := sum f (λ x c, c • g x)

@[simp]
lemma bind_zero {γ : Type} [decidable_eq γ] [decidable_eq β] [semiring β] (f : α → fin_fn γ β) : bind 0 f = 0 := sum_zero _

lemma empty_zero [has_zero β] [decidable_eq β] : ∀ (f : fin_fn α β), f.support = ∅ → f = 0
| ⟨ f, _, iff ⟩ ⟨ _ ⟩ := ext (λ x, by_contradiction (iff x).mp)

@[simp]
lemma sum_sum_index {γ : Type*} {α₁: Type*} {β₁ : Type*} [decidable_eq α] [decidable_eq α₁] [decidable_eq β]
  [add_comm_monoid β₁] [add_comm_monoid β] [add_comm_monoid γ]
  {f : fin_fn α₁ β₁} {g : α₁ → β₁ → fin_fn α β}
  {h : α → β → γ} (h_zero : ∀a, h a 0 = 0) (h_add : ∀a b₁ b₂, h a (b₁ + b₂) = h a b₁ + h a b₂) :
  (f.sum g).sum h = f.sum (λa b, (g a b).sum h) := begin
    show (finset.sum f.support (λ (a : α₁), g a (f.space a))).sum h
       = finset.sum f.support _,
    induction f.support using finset.induction_on with a s not_mem ih,
    from rfl,
    { rw [finset.sum_insert not_mem, finset.sum_insert not_mem, ← ih, sum_distrib h_zero h_add], },
  end

lemma bind_distrib {γ : Type} [comm_ring β] [decidable_eq α] [decidable_eq γ] [decidable_eq β] :
  ∀ (x y : fin_fn α β) (f : α → fin_fn γ β)
  , bind (x + y) f = bind x f + bind y f
| x y f := begin
  have zero : ∀ a, (λ (x : α) (c : β), c • f x) a 0 = 0 := λ _, by simp only [zero_smul],
  have add : ∀ (a : α) (b₁ b₂ : β)
           , (λ (x : α) (c : β), c • f x) a (b₁ + b₂)
           = (λ (x : α) (c : β), c • f x) a b₁ + (λ (x : α) (c : β), c • f x) a b₂
           := λ _ _ _, by simp only [add_smul],
  simp only [sum_distrib zero add, bind],
end

lemma bind_smul {γ : Type} [comm_ring β] [decidable_eq α] [decidable_eq γ] [decidable_eq β] :
  ∀ (c : β) (x : fin_fn α β) (f : α → fin_fn γ β)
  , c • bind x f = bind (c • x) f
| c x f := begin
  simp only [bind, sum],

  have : (c • x).support ⊆ x.support := finset.filter_subset _,
  rw finset.sum_subset this (λ a mem not_mem, begin
    show (λ a, (c • x).space a • f a) a = 0,
    simp only [],
    rw [unsupported_zero.mp not_mem, zero_smul],
  end), simp only [], clear this,

  -- Then follow the same proof as prod_pow.
  induction x.support using finset.induction_on with a f not_mem ih,
  { simp only [finset.sum_empty, smul_zero] },
  {
    simp only [finset.sum_insert not_mem],
    rw [smul_add, ← mul_smul, ih],
    from rfl,
  },
end

/-- `bind`, lifted to two `fin_fn`s. -/
def bind₂ {γ η : Type} [decidable_eq η] [decidable_eq β] [semiring β]
  : fin_fn α β → fin_fn γ β → (α → γ → fin_fn η β) → fin_fn η β
| x y f := bind x (λ a, bind y (f a))

lemma bind₂_zero {γ η : Type} [decidable_eq η] [decidable_eq β] [semiring β]  (f : α → γ → fin_fn η β) :
  bind₂ 0 0 f = 0 := rfl

lemma bind₂_zero_right {γ η : Type} [decidable_eq η] [decidable_eq β] [semiring β]
  (x : fin_fn γ β) (f : α → γ → fin_fn η β) :
  bind₂ 0 x f = 0 := rfl

/-- It doesn't matter which order we do our bind in! -/
lemma bind₂_swap {α β γ η : Type*} [decidable_eq η] [decidable_eq β] [comm_ring β] :
  ∀ (x : fin_fn α β) (y : fin_fn γ β) (f : (α → γ → fin_fn η β))
  , bind₂ x y f = bind₂ y x (λ x y, f y x)
| x y f := begin
  show finset.sum x.support (λ a, x.space a • finset.sum y.support (λ b, y.space b • f a b))
     = finset.sum y.support (λ a, y.space a • finset.sum x.support (λ b, x.space b • f b a)),

  have : ∀ a b, y.space a • x.space b • f b a = x.space b • y.space a • f b a
    := λ a b, smul_comm (y.space a) _ _,
  simp only [finset.smul_sum, this],

  simp only [finset.sum_eq_multiset_sum],
  from multiset.sum_map_sum_map x.support.val y.support.val,
end

lemma bind₂_zero_left {α β γ η : Type} [decidable_eq β] [decidable_eq η] [comm_ring β]
  (x : fin_fn α β) (f : α → γ → fin_fn η β) :
  bind₂ x 0 f = 0 := by { rw (bind₂_swap x 0 f), from rfl }

@[simp]
lemma bind_single {γ : Type} [comm_ring β] [decidable_eq α] [decidable_eq γ] [decidable_eq β] :
  ∀ (a : α) (b : β) (f : α → fin_fn γ β)
  , bind (single a b) f = b • f a
| a b f := sum_single_index a b _ (λ x, zero_smul _ _)

@[simp]
lemma sum_single [decidable_eq α] [decidable_eq β] [add_comm_monoid β] (f : fin_fn α β)
  : f.sum single = f := begin
  suffices : ∀ (a : α), (sum f single).space a = f.space a, from ext this,
  assume a,

  suffices : finset.sum f.support (λ (x : α), ite (x = a) (f.space x) 0) = f.space a,
  { have h := (f.support.sum_hom (λ f : fin_fn α β, f.space a)).symm,
    refine trans h _,
    simp only [single, this] },

  by_cases h : a ∈ f.support,
  { have : (finset.singleton a : finset α) ⊆ f.support,
    { simpa only [finset.subset_iff, finset.mem_singleton, forall_eq] },

    rw ← finset.sum_subset this (λ b mem not_mem, begin
      show ite (b = a) (f.space b) 0 = 0,
      simp only [if_neg (finset.not_mem_singleton.mp not_mem)],
    end),
    simp only [finset.sum_singleton, if_pos (eq.refl a)],
  },

  {
    calc  finset.sum f.support (λ (x : α), ite (x = a) (f.space x) 0)
        = f.support.sum (λ a, (0 : β)) : finset.sum_congr rfl (λ b mem, begin
            by_cases (b = a), { subst h, contradiction },
            simp only [if_neg h],
          end)
    ... = 0 : finset.sum_const_zero
    ... = f.space a : (unsupported_zero.mp h).symm
  },
end

end bulk_operations

section group_instances
  variables (α : Type*) (β : Type*)

  instance [decidable_eq α] [decidable_eq β] [has_zero α] [has_zero β] [has_one β] : has_one (fin_fn α β) :=
    { one := single 0 1 }

  instance [decidable_eq α] [decidable_eq β] [has_add α] [semiring β] : has_mul (fin_fn α β) :=
    { mul := λ f g, f.sum $ λ a₁ b₁, g.sum $ λ a₂ b₂, single (a₁ + a₂) (b₁ * b₂) }

  instance [decidable_eq α] [decidable_eq β] [add_semigroup α] [comm_ring β] : semigroup (fin_fn α β)
    := { mul_assoc := λ a b c, begin
      show sum
        (sum a (λ (a₁ : α) (b₁ : β), sum b (λ (a₂ : α) (b₂ : β), single (a₁ + a₂) (b₁ * b₂))))
          (λ (a₁ : α) (b₁ : β), sum c (λ (a₂ : α) (b₂ : β), single (a₁ + a₂) (b₁ * b₂)))
      = sum a (λ (a₁ : α) (b₁ : β)
              , sum (sum b (λ (a₁ : α) (b₁ : β), sum c (λ (a₂ : α) (b₂ : β), single (a₁ + a₂) (b₁ * b₂))))
                    (λ (a₂ : α) (b₂ : β), single (a₁ + a₂) (b₁ * b₂))),

      have zero : ∀ (a' : α) (b' : β) a, (λ a b, single (a' + a) (b' * b)) a 0 = 0
        := λ _ _ a, by simp only [mul_zero, single_zero, sum_const_zero],

      have add : ∀ (a' : α) (b' : β) (a : α) (b₁ b₂ : β)
               , single (a' + a) (b' * (b₁ + b₂))
               = single (a' + a) (b' * b₁) + single (a' + a) (b' * b₂)
        := λ _ _ a b₁ b₂, by simp only [left_distrib, single_add],

      have this :
        ∀ (a : fin_fn α β) (f : α → β → fin_fn α β)
        , sum (sum a f) (λ a₁ b₁, sum c (λ a₂ b₂, single (a₁ + a₂) (b₁ * b₂)))
        = sum a (λ a b, sum (f a b) (λ a₁ b₁, sum c (λ a₂ b₂, single (a₁ + a₂) (b₁ * b₂))))
        := λ a f, sum_sum_index
            (λ a, by { simp only [zero_mul, single_zero, sum_const_zero] })
            (λ a b₁ b₂, by simp only [sum, right_distrib, single_add, finset.sum_add_distrib]),
      simp only [this], clear this,
      simp [sum_single_index, sum_sum_index (zero _ _) (add _ _), mul_assoc],
    end,
    ..fin_fn.has_mul α β }

  instance [decidable_eq α] [decidable_eq β] [add_monoid α] [comm_ring β] : monoid (fin_fn α β) :=
    { one_mul := λ a, begin
        show sum (single 0 1) (λ a₁ b₁, sum a (λ a₂ b₂, single (a₁ + a₂) (b₁ * b₂))) = a,
        simp,
      end,
      mul_one := λ a, begin
        show sum a (λ a₁ b₁, sum (single (0 : α) (1 : β)) (λ a₂ b₂, single (a₁ + a₂) (b₁ * b₂))) = a,
        simp,
      end,
      ..fin_fn.has_one α β,
      ..fin_fn.semigroup α β }

  instance [decidable_eq α] [decidable_eq β] [add_comm_monoid α] [comm_ring β] : comm_monoid (fin_fn α β) :=
    { mul_comm := λ a b, begin
        show sum a (λ a₁ b₁, sum b (λ a₂ b₂, single (a₁ + a₂) (b₁ * b₂)))
           = sum b (λ a₁ b₁, sum a (λ a₂ b₂, single (a₁ + a₂) (b₁ * b₂))),

        suffices : sum a (λ a₁ b₁, sum b (λ a₂ b₂, single (a₁ + a₂) (b₁ * b₂)))
                 = sum b (λ a₁ b₁, sum a (λ a₂ b₂, single (a₂ + a₁) (b₂ * b₁))),
        { simpa only [add_comm, mul_comm] using this },

        simp only [sum, finset.sum_eq_multiset_sum],
        from multiset.sum_map_sum_map a.support.val b.support.val,
      end
      ..fin_fn.monoid α β }

  instance [decidable_eq α] [decidable_eq β] [has_add α] [semiring β] : mul_zero_class (fin_fn α β) :=
    { zero_mul := λ x, by simp only [has_mul.mul, sum_zero],
      mul_zero := λ x, by simp only [has_mul.mul, sum_zero, sum_const_zero],
      ..fin_fn.has_zero α β,
      ..fin_fn.has_mul α β }

  instance [decidable_eq α] [decidable_eq β] [has_add α] [semiring β] : distrib (fin_fn α β) :=
    { left_distrib := λ a b c, begin
        show sum a (λ a₁ b₁, sum (b + c) (λ a₂ b₂, single (a₁ + a₂) (b₁ * b₂)))
           = sum a (λ a₁ b₁, sum b (λ a₂ b₂, single (a₁ + a₂) (b₁ * b₂)))
           + sum a (λ a₁ b₁, sum c (λ a₂ b₂, single (a₁ + a₂) (b₁ * b₂))),

        have zero : ∀ (a' : α) (b' : β) a, (λ a b, single (a' + a) (b' * b)) a 0 = 0
          := λ _ _ a, by simp only [mul_zero, single_zero, sum_const_zero],

        have add : ∀ (a' : α) (b' : β) (a : α) (b₁ b₂ : β)
                , single (a' + a) (b' * (b₁ + b₂))
                = single (a' + a) (b' * b₁) + single (a' + a) (b' * b₂)
          := λ _ _ a b₁ b₂, by simp only [left_distrib, single_add],

        simp only [sum_distrib (zero _ _) (add _ _)],
        from finset.sum_add_distrib,
      end,
      right_distrib := λ a b c, sum_distrib
          (λ a, by { simp only [zero_mul, single_zero, sum_const_zero] })
          (λ a b₁ b₂, by simp only [sum, right_distrib, single_add, finset.sum_add_distrib]),
      ..fin_fn.has_add α β,
      ..fin_fn.has_mul α β }

  instance [decidable_eq α] [decidable_eq β] [add_comm_monoid α] [comm_ring β] : comm_ring (fin_fn α β) :=
    { ..fin_fn.add_comm_group α β,
      ..fin_fn.comm_monoid α β,
      ..fin_fn.distrib α β }

  instance [decidable_eq α] [decidable_eq β] [add_comm_monoid α] [half_ring β] : half_ring (fin_fn α β) :=
    { half := fin_fn.single 0 ½,
      one_is_two_halves := ext (λ a, begin
        show ite (0 = a) (1 : β) 0 = ite (0 = a) ½ 0 + ite (0 = a) ½ 0,
        by_cases h : 0 = a; simp only [if_pos, if_false, h],
        from half_ring.one_is_two_halves _,
        from (add_zero 0).symm,
      end),
      ..fin_fn.comm_ring _ β }

end group_instances

end fin_fn

#lint-


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro

! This file was ported from Lean 3 source module data.fintype.prod
! leanprover-community/mathlib commit 327c3c0d9232d80e250dc8f65e7835b82b266ea5
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Card
import Mathbin.Data.Finset.Prod

/-!
# fintype instance for the product of two fintypes.

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

-/

open Function

open Nat

universe u v

variable {α β γ : Type _}

open Finset Function

namespace Set

variable {s t : Set α}

/- warning: set.to_finset_prod -> Set.toFinset_prod is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} (s : Set.{u1} α) (t : Set.{u2} β) [_inst_1 : Fintype.{u1} (coeSort.{succ u1, succ (succ u1)} (Set.{u1} α) Type.{u1} (Set.hasCoeToSort.{u1} α) s)] [_inst_2 : Fintype.{u2} (coeSort.{succ u2, succ (succ u2)} (Set.{u2} β) Type.{u2} (Set.hasCoeToSort.{u2} β) t)] [_inst_3 : Fintype.{max u1 u2} (coeSort.{succ (max u1 u2), succ (succ (max u1 u2))} (Set.{max u1 u2} (Prod.{u1, u2} α β)) Type.{max u1 u2} (Set.hasCoeToSort.{max u1 u2} (Prod.{u1, u2} α β)) (Set.prod.{u1, u2} α β s t))], Eq.{succ (max u1 u2)} (Finset.{max u1 u2} (Prod.{u1, u2} α β)) (Set.toFinset.{max u1 u2} (Prod.{u1, u2} α β) (Set.prod.{u1, u2} α β s t) _inst_3) (Finset.product.{u1, u2} α β (Set.toFinset.{u1} α s _inst_1) (Set.toFinset.{u2} β t _inst_2))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} (s : Set.{u2} α) (t : Set.{u1} β) [_inst_1 : Fintype.{u2} (Set.Elem.{u2} α s)] [_inst_2 : Fintype.{u1} (Set.Elem.{u1} β t)] [_inst_3 : Fintype.{max u2 u1} (Set.Elem.{max u2 u1} (Prod.{u2, u1} α β) (Set.prod.{u2, u1} α β s t))], Eq.{max (succ u2) (succ u1)} (Finset.{max u2 u1} (Prod.{u2, u1} α β)) (Set.toFinset.{max u2 u1} (Prod.{u2, u1} α β) (Set.prod.{u2, u1} α β s t) _inst_3) (Finset.product.{u2, u1} α β (Set.toFinset.{u2} α s _inst_1) (Set.toFinset.{u1} β t _inst_2))
Case conversion may be inaccurate. Consider using '#align set.to_finset_prod Set.toFinset_prodₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
theorem toFinset_prod (s : Set α) (t : Set β) [Fintype s] [Fintype t] [Fintype (s ×ˢ t)] :
    (s ×ˢ t).toFinset = s.toFinset ×ˢ t.toFinset :=
  by
  ext
  simp
#align set.to_finset_prod Set.toFinset_prod

#print Set.toFinset_off_diag /-
theorem toFinset_off_diag {s : Set α} [DecidableEq α] [Fintype s] [Fintype s.offDiag] :
    s.offDiag.toFinset = s.toFinset.offDiag :=
  Finset.ext <| by simp
#align set.to_finset_off_diag Set.toFinset_off_diag
-/

end Set

/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
instance (α β : Type _) [Fintype α] [Fintype β] : Fintype (α × β) :=
  ⟨univ ×ˢ univ, fun ⟨a, b⟩ => by simp⟩

/- warning: finset.univ_product_univ -> Finset.univ_product_univ is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Fintype.{u1} α] [_inst_2 : Fintype.{u2} β], Eq.{succ (max u1 u2)} (Finset.{max u1 u2} (Prod.{u1, u2} α β)) (Finset.product.{u1, u2} α β (Finset.univ.{u1} α _inst_1) (Finset.univ.{u2} β _inst_2)) (Finset.univ.{max u1 u2} (Prod.{u1, u2} α β) (Prod.fintype.{u1, u2} α β _inst_1 _inst_2))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Fintype.{u2} α] [_inst_2 : Fintype.{u1} β], Eq.{max (succ u2) (succ u1)} (Finset.{max u1 u2} (Prod.{u2, u1} α β)) (Finset.product.{u2, u1} α β (Finset.univ.{u2} α _inst_1) (Finset.univ.{u1} β _inst_2)) (Finset.univ.{max u2 u1} (Prod.{u2, u1} α β) (instFintypeProd.{u2, u1} α β _inst_1 _inst_2))
Case conversion may be inaccurate. Consider using '#align finset.univ_product_univ Finset.univ_product_univₓ'. -/
/- ./././Mathport/Syntax/Translate/Expr.lean:177:8: unsupported: ambiguous notation -/
@[simp]
theorem Finset.univ_product_univ {α β : Type _} [Fintype α] [Fintype β] :
    (univ : Finset α) ×ˢ (univ : Finset β) = univ :=
  rfl
#align finset.univ_product_univ Finset.univ_product_univ

/- warning: fintype.card_prod -> Fintype.card_prod is a dubious translation:
lean 3 declaration is
  forall (α : Type.{u1}) (β : Type.{u2}) [_inst_1 : Fintype.{u1} α] [_inst_2 : Fintype.{u2} β], Eq.{1} Nat (Fintype.card.{max u1 u2} (Prod.{u1, u2} α β) (Prod.fintype.{u1, u2} α β _inst_1 _inst_2)) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat Nat.hasMul) (Fintype.card.{u1} α _inst_1) (Fintype.card.{u2} β _inst_2))
but is expected to have type
  forall (α : Type.{u2}) (β : Type.{u1}) [_inst_1 : Fintype.{u2} α] [_inst_2 : Fintype.{u1} β], Eq.{1} Nat (Fintype.card.{max u1 u2} (Prod.{u2, u1} α β) (instFintypeProd.{u2, u1} α β _inst_1 _inst_2)) (HMul.hMul.{0, 0, 0} Nat Nat Nat (instHMul.{0} Nat instMulNat) (Fintype.card.{u2} α _inst_1) (Fintype.card.{u1} β _inst_2))
Case conversion may be inaccurate. Consider using '#align fintype.card_prod Fintype.card_prodₓ'. -/
@[simp]
theorem Fintype.card_prod (α β : Type _) [Fintype α] [Fintype β] :
    Fintype.card (α × β) = Fintype.card α * Fintype.card β :=
  card_product _ _
#align fintype.card_prod Fintype.card_prod

section

open Classical

#print infinite_prod /-
@[simp]
theorem infinite_prod : Infinite (α × β) ↔ Infinite α ∧ Nonempty β ∨ Nonempty α ∧ Infinite β :=
  by
  refine'
    ⟨fun H => _, fun H =>
      H.elim (and_imp.2 <| @Prod.infinite_of_left α β) (and_imp.2 <| @Prod.infinite_of_right α β)⟩
  rw [and_comm]; contrapose! H; intro H'
  rcases Infinite.nonempty (α × β) with ⟨a, b⟩
  haveI := fintypeOfNotInfinite (H.1 ⟨b⟩); haveI := fintypeOfNotInfinite (H.2 ⟨a⟩)
  exact H'.false
#align infinite_prod infinite_prod
-/

#print Pi.infinite_of_left /-
instance Pi.infinite_of_left {ι : Sort _} {π : ι → Sort _} [∀ i, Nontrivial <| π i] [Infinite ι] :
    Infinite (∀ i : ι, π i) :=
  by
  choose m n hm using fun i => exists_pair_ne (π i)
  refine'
    Infinite.of_injective (fun i => m.update i (n i)) fun x y h => Classical.not_not.1 fun hne => _
  simp_rw [update_eq_iff, update_noteq hne] at h
  exact (hm x h.1.symm).elim
#align pi.infinite_of_left Pi.infinite_of_left
-/

/- warning: pi.infinite_of_exists_right -> Pi.infinite_of_exists_right is a dubious translation:
lean 3 declaration is
  forall {ι : Type.{u1}} {π : ι -> Type.{u2}} (i : ι) [_inst_1 : Infinite.{succ u2} (π i)] [_inst_2 : forall (i : ι), Nonempty.{succ u2} (π i)], Infinite.{max (succ u1) (succ u2)} (forall (i : ι), π i)
but is expected to have type
  forall {ι : Type.{u2}} {π : ι -> Type.{u1}} (i : ι) [_inst_1 : Infinite.{succ u1} (π i)] [_inst_2 : forall (i : ι), Nonempty.{succ u1} (π i)], Infinite.{max (succ u2) (succ u1)} (forall (i : ι), π i)
Case conversion may be inaccurate. Consider using '#align pi.infinite_of_exists_right Pi.infinite_of_exists_rightₓ'. -/
/-- If at least one `π i` is infinite and the rest nonempty, the pi type of all `π` is infinite. -/
theorem Pi.infinite_of_exists_right {ι : Type _} {π : ι → Type _} (i : ι) [Infinite <| π i]
    [∀ i, Nonempty <| π i] : Infinite (∀ i : ι, π i) :=
  let ⟨m⟩ := @Pi.nonempty ι π _
  Infinite.of_injective _ (update_injective m i)
#align pi.infinite_of_exists_right Pi.infinite_of_exists_right

#print Pi.infinite_of_right /-
/-- See `pi.infinite_of_exists_right` for the case that only one `π i` is infinite. -/
instance Pi.infinite_of_right {ι : Sort _} {π : ι → Sort _} [∀ i, Infinite <| π i] [Nonempty ι] :
    Infinite (∀ i : ι, π i) :=
  Pi.infinite_of_exists_right (Classical.arbitrary ι)
#align pi.infinite_of_right Pi.infinite_of_right
-/

#print Function.infinite_of_left /-
/-- Non-dependent version of `pi.infinite_of_left`. -/
instance Function.infinite_of_left {ι π : Sort _} [Nontrivial π] [Infinite ι] : Infinite (ι → π) :=
  Pi.infinite_of_left
#align function.infinite_of_left Function.infinite_of_left
-/

#print Function.infinite_of_right /-
/-- Non-dependent version of `pi.infinite_of_exists_right` and `pi.infinite_of_right`. -/
instance Function.infinite_of_right {ι π : Sort _} [Infinite π] [Nonempty ι] : Infinite (ι → π) :=
  Pi.infinite_of_right
#align function.infinite_of_right Function.infinite_of_right
-/

end


/-
Copyright (c) 2019 Reid Barton. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Patrick Massot, Sébastien Gouëzel, Zhouhang Zhou, Reid Barton
-/
import logic.equiv.fin
import topology.dense_embedding
import topology.support

/-!
# Homeomorphisms

This file defines homeomorphisms between two topological spaces. They are bijections with both
directions continuous. We denote homeomorphisms with the notation `≃ₜ`.

# Main definitions

* `homeomorph α β`: The type of homeomorphisms from `α` to `β`.
  This type can be denoted using the following notation: `α ≃ₜ β`.

# Main results

* Pretty much every topological property is preserved under homeomorphisms.
* `homeomorph.homeomorph_of_continuous_open`: A continuous bijection that is
  an open map is a homeomorphism.

-/

open set filter
open_locale topological_space

variables {α : Type*} {β : Type*} {γ : Type*} {δ : Type*}

/-- Homeomorphism between `α` and `β`, also called topological isomorphism -/
@[nolint has_inhabited_instance] -- not all spaces are homeomorphic to each other
structure homeomorph (α : Type*) (β : Type*) [topological_space α] [topological_space β]
  extends α ≃ β :=
(continuous_to_fun  : continuous to_fun . tactic.interactive.continuity')
(continuous_inv_fun : continuous inv_fun . tactic.interactive.continuity')

infix ` ≃ₜ `:25 := homeomorph

namespace homeomorph
variables [topological_space α] [topological_space β] [topological_space γ] [topological_space δ]

instance : has_coe_to_fun (α ≃ₜ β) (λ _, α → β) := ⟨λe, e.to_equiv⟩

@[simp] lemma homeomorph_mk_coe (a : equiv α β) (b c) :
  ((homeomorph.mk a b c) : α → β) = a :=
rfl

@[simp] lemma coe_to_equiv (h : α ≃ₜ β) : ⇑h.to_equiv = h := rfl

/-- Inverse of a homeomorphism. -/
protected def symm (h : α ≃ₜ β) : β ≃ₜ α :=
{ continuous_to_fun  := h.continuous_inv_fun,
  continuous_inv_fun := h.continuous_to_fun,
  to_equiv := h.to_equiv.symm }

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
  because it is a composition of multiple projections. -/
def simps.apply (h : α ≃ₜ β) : α → β := h
/-- See Note [custom simps projection] -/
def simps.symm_apply (h : α ≃ₜ β) : β → α := h.symm

initialize_simps_projections homeomorph
  (to_equiv_to_fun → apply, to_equiv_inv_fun → symm_apply, -to_equiv)

lemma to_equiv_injective : function.injective (to_equiv : α ≃ₜ β → α ≃ β)
| ⟨e, h₁, h₂⟩ ⟨e', h₁', h₂'⟩ rfl := rfl

@[ext] lemma ext {h h' : α ≃ₜ β} (H : ∀ x, h x = h' x) : h = h' :=
to_equiv_injective $ equiv.ext H

/-- Identity map as a homeomorphism. -/
@[simps apply {fully_applied := ff}]
protected def refl (α : Type*) [topological_space α] : α ≃ₜ α :=
{ continuous_to_fun := continuous_id,
  continuous_inv_fun := continuous_id,
  to_equiv := equiv.refl α }

/-- Composition of two homeomorphisms. -/
protected def trans (h₁ : α ≃ₜ β) (h₂ : β ≃ₜ γ) : α ≃ₜ γ :=
{ continuous_to_fun  := h₂.continuous_to_fun.comp h₁.continuous_to_fun,
  continuous_inv_fun := h₁.continuous_inv_fun.comp h₂.continuous_inv_fun,
  to_equiv := equiv.trans h₁.to_equiv h₂.to_equiv }

@[simp] lemma trans_apply (h₁ : α ≃ₜ β) (h₂ : β ≃ₜ γ) (a : α) : h₁.trans h₂ a = h₂ (h₁ a) := rfl

@[simp] lemma homeomorph_mk_coe_symm (a : equiv α β) (b c) :
  ((homeomorph.mk a b c).symm : β → α) = a.symm :=
rfl

@[simp] lemma refl_symm : (homeomorph.refl α).symm = homeomorph.refl α := rfl

@[continuity]
protected lemma continuous (h : α ≃ₜ β) : continuous h := h.continuous_to_fun

@[continuity] -- otherwise `by continuity` can't prove continuity of `h.to_equiv.symm`
protected lemma continuous_symm (h : α ≃ₜ β) : continuous (h.symm) := h.continuous_inv_fun

@[simp] lemma apply_symm_apply (h : α ≃ₜ β) (x : β) : h (h.symm x) = x :=
h.to_equiv.apply_symm_apply x

@[simp] lemma symm_apply_apply (h : α ≃ₜ β) (x : α) : h.symm (h x) = x :=
h.to_equiv.symm_apply_apply x

protected lemma bijective (h : α ≃ₜ β) : function.bijective h := h.to_equiv.bijective
protected lemma injective (h : α ≃ₜ β) : function.injective h := h.to_equiv.injective
protected lemma surjective (h : α ≃ₜ β) : function.surjective h := h.to_equiv.surjective

/-- Change the homeomorphism `f` to make the inverse function definitionally equal to `g`. -/
def change_inv (f : α ≃ₜ β) (g : β → α) (hg : function.right_inverse g f) : α ≃ₜ β :=
have g = f.symm, from funext (λ x, calc g x = f.symm (f (g x)) : (f.left_inv (g x)).symm
                                        ... = f.symm x : by rw hg x),
{ to_fun := f,
  inv_fun := g,
  left_inv := by convert f.left_inv,
  right_inv := by convert f.right_inv,
  continuous_to_fun := f.continuous,
  continuous_inv_fun := by convert f.symm.continuous }

@[simp] lemma symm_comp_self (h : α ≃ₜ β) : ⇑h.symm ∘ ⇑h = id :=
funext h.symm_apply_apply

@[simp] lemma self_comp_symm (h : α ≃ₜ β) : ⇑h ∘ ⇑h.symm = id :=
funext h.apply_symm_apply

@[simp] lemma range_coe (h : α ≃ₜ β) : range h = univ :=
h.surjective.range_eq

lemma image_symm (h : α ≃ₜ β) : image h.symm = preimage h :=
funext h.symm.to_equiv.image_eq_preimage

lemma preimage_symm (h : α ≃ₜ β) : preimage h.symm = image h :=
(funext h.to_equiv.image_eq_preimage).symm

@[simp] lemma image_preimage (h : α ≃ₜ β) (s : set β) : h '' (h ⁻¹' s) = s :=
h.to_equiv.image_preimage s

@[simp] lemma preimage_image (h : α ≃ₜ β) (s : set α) : h ⁻¹' (h '' s) = s :=
h.to_equiv.preimage_image s

protected lemma inducing (h : α ≃ₜ β) : inducing h :=
inducing_of_inducing_compose h.continuous h.symm.continuous $
  by simp only [symm_comp_self, inducing_id]

lemma induced_eq (h : α ≃ₜ β) : topological_space.induced h ‹_› = ‹_› := h.inducing.1.symm

protected lemma quotient_map (h : α ≃ₜ β) : quotient_map h :=
quotient_map.of_quotient_map_compose h.symm.continuous h.continuous $
  by simp only [self_comp_symm, quotient_map.id]

lemma coinduced_eq (h : α ≃ₜ β) : topological_space.coinduced h ‹_› = ‹_› :=
h.quotient_map.2.symm

protected lemma embedding (h : α ≃ₜ β) : embedding h :=
⟨h.inducing, h.injective⟩

/-- Homeomorphism given an embedding. -/
noncomputable def of_embedding (f : α → β) (hf : embedding f) : α ≃ₜ (set.range f) :=
{ continuous_to_fun := continuous_subtype_mk _ hf.continuous,
  continuous_inv_fun := by simp [hf.continuous_iff, continuous_subtype_coe],
  .. equiv.of_injective f hf.inj }

protected lemma second_countable_topology [topological_space.second_countable_topology β]
  (h : α ≃ₜ β) :
  topological_space.second_countable_topology α :=
h.inducing.second_countable_topology

lemma compact_image {s : set α} (h : α ≃ₜ β) : is_compact (h '' s) ↔ is_compact s :=
h.embedding.is_compact_iff_is_compact_image.symm

lemma compact_preimage {s : set β} (h : α ≃ₜ β) : is_compact (h ⁻¹' s) ↔ is_compact s :=
by rw ← image_symm; exact h.symm.compact_image

protected lemma compact_space [compact_space α] (h : α ≃ₜ β) : compact_space β :=
{ compact_univ := by { rw [← image_univ_of_surjective h.surjective, h.compact_image],
    apply compact_space.compact_univ } }

protected lemma t2_space [t2_space α] (h : α ≃ₜ β) : t2_space β :=
{ t2 :=
  begin
    intros x y hxy,
    obtain ⟨u, v, hu, hv, hxu, hyv, huv⟩ := t2_separation (h.symm.injective.ne hxy),
    refine ⟨h.symm ⁻¹' u, h.symm ⁻¹' v,
      h.symm.continuous.is_open_preimage _ hu,
      h.symm.continuous.is_open_preimage _ hv,
      hxu, hyv, _⟩,
    rw [← preimage_inter, huv, preimage_empty],
  end }

protected lemma dense_embedding (h : α ≃ₜ β) : dense_embedding h :=
{ dense   := h.surjective.dense_range,
  .. h.embedding }

@[simp] lemma is_open_preimage (h : α ≃ₜ β) {s : set β} : is_open (h ⁻¹' s) ↔ is_open s :=
h.quotient_map.is_open_preimage

@[simp] lemma is_open_image (h : α ≃ₜ β) {s : set α} : is_open (h '' s) ↔ is_open s :=
by rw [← preimage_symm, is_open_preimage]

protected lemma is_open_map (h : α ≃ₜ β) : is_open_map h := λ s, h.is_open_image.2

@[simp] lemma is_closed_preimage (h : α ≃ₜ β) {s : set β} : is_closed (h ⁻¹' s) ↔ is_closed s :=
by simp only [← is_open_compl_iff, ← preimage_compl, is_open_preimage]

@[simp] lemma is_closed_image (h : α ≃ₜ β) {s : set α} : is_closed (h '' s) ↔ is_closed s :=
by rw [← preimage_symm, is_closed_preimage]

protected lemma is_closed_map (h : α ≃ₜ β) : is_closed_map h := λ s, h.is_closed_image.2

protected lemma open_embedding (h : α ≃ₜ β) : open_embedding h :=
open_embedding_of_embedding_open h.embedding h.is_open_map

protected lemma closed_embedding (h : α ≃ₜ β) : closed_embedding h :=
closed_embedding_of_embedding_closed h.embedding h.is_closed_map

lemma preimage_closure (h : α ≃ₜ β) (s : set β) : h ⁻¹' (closure s) = closure (h ⁻¹' s) :=
h.is_open_map.preimage_closure_eq_closure_preimage h.continuous _

lemma image_closure (h : α ≃ₜ β) (s : set α) : h '' (closure s) = closure (h '' s) :=
by rw [← preimage_symm, preimage_closure]

lemma image_interior (h : α ≃ₜ β) (s : set α) : h '' (interior s) = interior (h '' s) :=
by rw [← preimage_symm, preimage_interior]

lemma preimage_frontier (h : α ≃ₜ β) (s : set β) : h ⁻¹' (frontier s) = frontier (h ⁻¹' s) :=
h.is_open_map.preimage_frontier_eq_frontier_preimage h.continuous _

@[to_additive]
lemma _root_.has_compact_mul_support.comp_homeomorph {M} [has_one M] {f : β → M}
  (hf : has_compact_mul_support f) (φ : α ≃ₜ β) : has_compact_mul_support (f ∘ φ) :=
hf.comp_closed_embedding φ.closed_embedding

@[simp] lemma map_nhds_eq (h : α ≃ₜ β) (x : α) : map h (𝓝 x) = 𝓝 (h x) :=
h.embedding.map_nhds_of_mem _ (by simp)

lemma symm_map_nhds_eq (h : α ≃ₜ β) (x : α) : map h.symm (𝓝 (h x)) = 𝓝 x :=
by rw [h.symm.map_nhds_eq, h.symm_apply_apply]

lemma nhds_eq_comap (h : α ≃ₜ β) (x : α) : 𝓝 x = comap h (𝓝 (h x)) :=
h.embedding.to_inducing.nhds_eq_comap x

@[simp] lemma comap_nhds_eq (h : α ≃ₜ β) (y : β) : comap h (𝓝 y) = 𝓝 (h.symm y) :=
by rw [h.nhds_eq_comap, h.apply_symm_apply]

/-- If an bijective map `e : α ≃ β` is continuous and open, then it is a homeomorphism. -/
def homeomorph_of_continuous_open (e : α ≃ β) (h₁ : continuous e) (h₂ : is_open_map e) :
  α ≃ₜ β :=
{ continuous_to_fun := h₁,
  continuous_inv_fun := begin
    rw continuous_def,
    intros s hs,
    convert ← h₂ s hs using 1,
    apply e.image_eq_preimage
  end,
  to_equiv := e }

@[simp] lemma comp_continuous_on_iff (h : α ≃ₜ β) (f : γ → α) (s : set γ) :
  continuous_on (h ∘ f) s ↔ continuous_on f s :=
h.inducing.continuous_on_iff.symm

@[simp] lemma comp_continuous_iff (h : α ≃ₜ β) {f : γ → α} :
  continuous (h ∘ f) ↔ continuous f :=
h.inducing.continuous_iff.symm

@[simp] lemma comp_continuous_iff' (h : α ≃ₜ β) {f : β → γ} :
  continuous (f ∘ h) ↔ continuous f :=
h.quotient_map.continuous_iff.symm

lemma comp_continuous_at_iff (h : α ≃ₜ β) (f : γ → α) (x : γ) :
  continuous_at (h ∘ f) x ↔ continuous_at f x :=
h.inducing.continuous_at_iff.symm

lemma comp_continuous_at_iff' (h : α ≃ₜ β) (f : β → γ) (x : α) :
  continuous_at (f ∘ h) x ↔ continuous_at f (h x) :=
h.inducing.continuous_at_iff' (by simp)

lemma comp_continuous_within_at_iff (h : α ≃ₜ β) (f : γ → α) (s : set γ) (x : γ) :
  continuous_within_at f s x ↔ continuous_within_at (h ∘ f) s x :=
h.inducing.continuous_within_at_iff

@[simp] lemma comp_is_open_map_iff (h : α ≃ₜ β) {f : γ → α} :
  is_open_map (h ∘ f) ↔ is_open_map f :=
begin
  refine ⟨_, λ hf, h.is_open_map.comp hf⟩,
  intros hf,
  rw [← function.comp.left_id f, ← h.symm_comp_self, function.comp.assoc],
  exact h.symm.is_open_map.comp hf,
end

@[simp] lemma comp_is_open_map_iff' (h : α ≃ₜ β) {f : β → γ} :
  is_open_map (f ∘ h) ↔ is_open_map f :=
begin
  refine ⟨_, λ hf, hf.comp h.is_open_map⟩,
  intros hf,
  rw [← function.comp.right_id f, ← h.self_comp_symm, ← function.comp.assoc],
  exact hf.comp h.symm.is_open_map,
end

/-- If two sets are equal, then they are homeomorphic. -/
def set_congr {s t : set α} (h : s = t) : s ≃ₜ t :=
{ continuous_to_fun := continuous_subtype_mk _ continuous_subtype_val,
  continuous_inv_fun := continuous_subtype_mk _ continuous_subtype_val,
  to_equiv := equiv.set_congr h }

/-- Sum of two homeomorphisms. -/
def sum_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : α ⊕ γ ≃ₜ β ⊕ δ :=
{ continuous_to_fun  :=
  begin
    convert continuous_sum_rec (continuous_inl.comp h₁.continuous)
      (continuous_inr.comp h₂.continuous),
    ext x, cases x; refl,
  end,
  continuous_inv_fun :=
  begin
    convert continuous_sum_rec (continuous_inl.comp h₁.symm.continuous)
      (continuous_inr.comp h₂.symm.continuous),
    ext x, cases x; refl
  end,
  to_equiv := h₁.to_equiv.sum_congr h₂.to_equiv }

/-- Product of two homeomorphisms. -/
def prod_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) : α × γ ≃ₜ β × δ :=
{ continuous_to_fun  := (h₁.continuous.comp continuous_fst).prod_mk
    (h₂.continuous.comp continuous_snd),
  continuous_inv_fun := (h₁.symm.continuous.comp continuous_fst).prod_mk
    (h₂.symm.continuous.comp continuous_snd),
  to_equiv := h₁.to_equiv.prod_congr h₂.to_equiv }

@[simp] lemma prod_congr_symm (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) :
  (h₁.prod_congr h₂).symm = h₁.symm.prod_congr h₂.symm := rfl

@[simp] lemma coe_prod_congr (h₁ : α ≃ₜ β) (h₂ : γ ≃ₜ δ) :
  ⇑(h₁.prod_congr h₂) = prod.map h₁ h₂ := rfl

section
variables (α β γ)

/-- `α × β` is homeomorphic to `β × α`. -/
def prod_comm : α × β ≃ₜ β × α :=
{ continuous_to_fun  := continuous_snd.prod_mk continuous_fst,
  continuous_inv_fun := continuous_snd.prod_mk continuous_fst,
  to_equiv := equiv.prod_comm α β }

@[simp] lemma prod_comm_symm : (prod_comm α β).symm = prod_comm β α := rfl
@[simp] lemma coe_prod_comm : ⇑(prod_comm α β) = prod.swap := rfl

/-- `(α × β) × γ` is homeomorphic to `α × (β × γ)`. -/
def prod_assoc : (α × β) × γ ≃ₜ α × (β × γ) :=
{ continuous_to_fun  := (continuous_fst.comp continuous_fst).prod_mk
    ((continuous_snd.comp continuous_fst).prod_mk continuous_snd),
  continuous_inv_fun := (continuous_fst.prod_mk (continuous_fst.comp continuous_snd)).prod_mk
    (continuous_snd.comp continuous_snd),
  to_equiv := equiv.prod_assoc α β γ }

/-- `α × {*}` is homeomorphic to `α`. -/
@[simps apply {fully_applied := ff}]
def prod_punit : α × punit ≃ₜ α :=
{ to_equiv := equiv.prod_punit α,
  continuous_to_fun := continuous_fst,
  continuous_inv_fun := continuous_id.prod_mk continuous_const }

/-- `{*} × α` is homeomorphic to `α`. -/
def punit_prod : punit × α ≃ₜ α :=
(prod_comm _ _).trans (prod_punit _)

@[simp] lemma coe_punit_prod : ⇑(punit_prod α) = prod.snd := rfl

end

/-- `ulift α` is homeomorphic to `α`. -/
def {u v} ulift {α : Type u} [topological_space α] : ulift.{v u} α ≃ₜ α :=
{ continuous_to_fun := continuous_ulift_down,
  continuous_inv_fun := continuous_ulift_up,
  to_equiv := equiv.ulift }

section distrib

/-- `(α ⊕ β) × γ` is homeomorphic to `α × γ ⊕ β × γ`. -/
def sum_prod_distrib : (α ⊕ β) × γ ≃ₜ α × γ ⊕ β × γ :=
begin
  refine (homeomorph.homeomorph_of_continuous_open (equiv.sum_prod_distrib α β γ).symm _ _).symm,
  { convert continuous_sum_rec
      ((continuous_inl.comp continuous_fst).prod_mk continuous_snd)
      ((continuous_inr.comp continuous_fst).prod_mk continuous_snd),
    ext1 x, cases x; refl, },
  { exact (is_open_map_sum
    (open_embedding_inl.prod open_embedding_id).is_open_map
    (open_embedding_inr.prod open_embedding_id).is_open_map) }
end

/-- `α × (β ⊕ γ)` is homeomorphic to `α × β ⊕ α × γ`. -/
def prod_sum_distrib : α × (β ⊕ γ) ≃ₜ α × β ⊕ α × γ :=
(prod_comm _ _).trans $
sum_prod_distrib.trans $
sum_congr (prod_comm _ _) (prod_comm _ _)

variables {ι : Type*} {σ : ι → Type*} [Π i, topological_space (σ i)]

/-- `(Σ i, σ i) × β` is homeomorphic to `Σ i, (σ i × β)`. -/
def sigma_prod_distrib : ((Σ i, σ i) × β) ≃ₜ (Σ i, (σ i × β)) :=
homeomorph.symm $
homeomorph_of_continuous_open (equiv.sigma_prod_distrib σ β).symm
  (continuous_sigma $ λ i,
    (continuous_sigma_mk.comp continuous_fst).prod_mk continuous_snd)
  (is_open_map_sigma $ λ i,
    (open_embedding_sigma_mk.prod open_embedding_id).is_open_map)

end distrib

/-- If `ι` has a unique element, then `ι → α` is homeomorphic to `α`. -/
@[simps { fully_applied := ff }]
def fun_unique (ι α : Type*) [unique ι] [topological_space α] : (ι → α) ≃ₜ α :=
{ to_equiv := equiv.fun_unique ι α,
  continuous_to_fun := continuous_apply _,
  continuous_inv_fun := continuous_pi (λ _, continuous_id) }

/-- Homeomorphism between dependent functions `Π i : fin 2, α i` and `α 0 × α 1`. -/
@[simps { fully_applied := ff }]
def {u} pi_fin_two (α : fin 2 → Type u) [Π i, topological_space (α i)] : (Π i, α i) ≃ₜ α 0 × α 1 :=
{ to_equiv := pi_fin_two_equiv α,
  continuous_to_fun := (continuous_apply 0).prod_mk (continuous_apply 1),
  continuous_inv_fun := continuous_pi $ fin.forall_fin_two.2 ⟨continuous_fst, continuous_snd⟩ }

/-- Homeomorphism between `α² = fin 2 → α` and `α × α`. -/
@[simps { fully_applied := ff }] def fin_two_arrow : (fin 2 → α) ≃ₜ α × α :=
{ to_equiv := fin_two_arrow_equiv α, ..  pi_fin_two (λ _, α) }

/--
A subset of a topological space is homeomorphic to its image under a homeomorphism.
-/
def image (e : α ≃ₜ β) (s : set α) : s ≃ₜ e '' s :=
{ continuous_to_fun := by continuity!,
  continuous_inv_fun := by continuity!,
  ..e.to_equiv.image s, }

end homeomorph

/-- An inducing equiv between topological spaces is a homeomorphism. -/
@[simps] def equiv.to_homeomorph_of_inducing [topological_space α] [topological_space β] (f : α ≃ β)
  (hf : inducing f) :
  α ≃ₜ β :=
{ continuous_to_fun := hf.continuous,
  continuous_inv_fun := hf.continuous_iff.2 $ by simpa using continuous_id,
  .. f }

namespace continuous
variables [topological_space α] [topological_space β]

lemma continuous_symm_of_equiv_compact_to_t2 [compact_space α] [t2_space β]
  {f : α ≃ β} (hf : continuous f) : continuous f.symm :=
begin
  rw continuous_iff_is_closed,
  intros C hC,
  have hC' : is_closed (f '' C) := (hC.is_compact.image hf).is_closed,
  rwa equiv.image_eq_preimage at hC',
end

/-- Continuous equivalences from a compact space to a T2 space are homeomorphisms.

This is not true when T2 is weakened to T1
(see `continuous.homeo_of_equiv_compact_to_t2.t1_counterexample`). -/
@[simps]
def homeo_of_equiv_compact_to_t2 [compact_space α] [t2_space β]
  {f : α ≃ β} (hf : continuous f) : α ≃ₜ β :=
{ continuous_to_fun := hf,
  continuous_inv_fun := hf.continuous_symm_of_equiv_compact_to_t2,
  ..f }

end continuous


/- Library 3.2: Program Semantics — Hoare Logic -/

/- This file contains some basic material for the Hoare logic lecture, exercise, and homework.

This file contains the following concepts:

* `state`: representing the state space of an imperative program (defined as `string → ℕ`)
  * `∅` is the empty state; mapping every variable to `0`
  * `s.update n v` or `s & n ::= v`: replace the name `n` in the state `s` by value `v`
  * `s n` variable `n` of state `s`

* `program` syntax for WHILE programs over `state` as state space.
  This is a slight modification of the lecture 3.1. Instead of over an arbitrary state space `σ` we
  are now fixed on `state`; and also `assign` only allows changing one variable.

* `(p, s) ⟹ t`: big-step semantics over `program`

It is all under the `lecture` namespace. -/

meta def tactic.dec_trivial := `[exact dec_trivial]

@[simp] lemma not_not_iff (p : Prop) [decidable p] : ¬ (¬ p) ↔ p :=
by by_cases p; simp [h]

@[simp] lemma and_imp (p q r : Prop) : ((p ∧ q) → r) ↔ (p → q → r) :=
iff.intro
  (assume h hp hq, h ⟨hp, hq⟩)
  (assume h ⟨hp, hq⟩, h hp hq)

namespace lecture

/- `state` to represent state spaces -/

def state := string → ℕ

def state.update (name : string) (val : ℕ) (s : state) : state :=
λn, if n = name then val else s n

notation s ` & ` n ` ::= ` v := state.update n v s

namespace state

instance : has_emptyc state := ⟨λ_, 0⟩

@[simp] lemma update_apply (name : string) (val : ℕ) (s : state) :
  (s & name ::= val) name = val :=
if_pos rfl

@[simp] lemma update_apply_ne (name name' : string) (val : ℕ) (s : state)
  (h : name' ≠ name . tactic.dec_trivial):
  (s & name ::= val) name' = s name' :=
if_neg h

@[simp] lemma update_override (name : string) (val₁ val₂ : ℕ) (s : state) :
  (s & name ::= val₂ & name ::= val₁) = (s & name ::= val₁) :=
by funext name'; by_cases name' = name; simp [h]

@[simp] lemma update_swap
  (name₁ name₂ : string) (val₁ val₂ : ℕ) (s : state) (h : name₁ ≠ name₂ . tactic.dec_trivial):
  (s & name₂ ::= val₂ & name₁ ::= val₁) = (s & name₁ ::= val₁ & name₂ ::= val₂) :=
by funext name'; by_cases h₁ : name' = name₁; by_cases h₂ : name' = name₂; simp * at *

end state

example (s : state) : (s & "a" ::= 0 & "a" ::= 2) = (s & "a" ::= 2) :=
by simp

example (s : state) : (s & "a" ::= 0 & "b" ::= 2) = (s & "b" ::= 2 & "a" ::= 0) :=
by simp

/- A WHILE programming language -/

inductive program : Type
| skip {} : program
| assign  : string → (state → ℕ) → program
| seq     : program → program → program
| ite     : (state → Prop) → program → program → program
| while   : (state → Prop) → program → program
| unless  : program → (state → Prop) → program
| do_while: program → (state → Prop) → program

infixr ` ;; `:90 := program.seq

open program

/- We use the **big step** semantics -/

inductive big_step : (program × state) → state → Prop
| skip {s} :
  big_step (skip, s) s
| assign {n f s} :
  big_step (assign n f, s) (s.update n (f s))
| seq {p₁ p₂ s u} (t) (h₁ : big_step (p₁, s) t) (h₂ : big_step (p₂, t) u) :
  big_step (seq p₁ p₂, s) u

| ite_true {c : state → Prop} {p₁ p₀ s t} (hs : c s) (h : big_step (p₁, s) t) :
  big_step (ite c p₁ p₀, s) t
| ite_false {c : state → Prop} {p₁ p₀ s t} (hs : ¬ c s) (h : big_step (p₀, s) t) :
  big_step (ite c p₁ p₀, s) t

| while_true {c : state → Prop} {p s u} (t) (hs : c s) (hp : big_step (p, s) t)
  (hw : big_step (while c p, t) u) :
  big_step (while c p, s) u
| while_false {c : state → Prop} {p s} (hs : ¬ c s) : big_step (while c p, s) s

|unless_false {c : state → Prop} {p s t} (hs: ¬ c s) (h: big_step (p, s) t):
  big_step (unless p c, s) t

|unless_true {c : state → Prop} {p s t} (hs: c s) (h: big_step (p, s) t) :
  big_step (skip, s) t

 |do_while_true {c : state → Prop} {p s u} (t) (hp : big_step (p, s) t)
  (hw : big_step (while c p, t) u) (hs : c s)  :
  big_step (do_while p c, s) u
| do_while_false {c : state → Prop} {p s} (hs : ¬ c s) : big_step (do_while p c, s) s

infix ` ⟹ `:110 := big_step

end lecture


/-
Copyright (c) 2017 Mario Carneiro. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Mario Carneiro
-/
import data.list.basic

/-!
# Boolean quantifiers

This proves a few properties about `list.all` and `list.any`, which are the `bool` universal and
existential quantifiers. Their definitions are in core Lean.
-/

variables {α : Type*} {p : α → Prop} [decidable_pred p] {l : list α} {a : α}

namespace list

@[simp] theorem all_nil (p : α → bool) : all [] p = tt := rfl

@[simp] theorem all_cons (p : α → bool) (a : α) (l : list α) : all (a::l) p = (p a && all l p) :=
rfl

theorem all_iff_forall_prop : all l (λ a, p a) ↔ ∀ a ∈ l, p a :=
by simp only [all_iff_forall, bool.of_to_bool_iff]

@[simp] theorem any_nil (p : α → bool) : any [] p = ff := rfl

@[simp] theorem any_cons (p : α → bool) (a : α) (l : list α) : any (a :: l) p = (p a || any l p) :=
rfl

theorem any_iff_exists {p : α → bool} : any l p ↔ ∃ a ∈ l, p a :=
begin
  induction l with a l ih,
  { exact iff_of_false bool.not_ff (not_exists_mem_nil _) },
  simp only [any_cons, bor_coe_iff, ih, exists_mem_cons_iff]
end

theorem any_iff_exists_prop : any l (λ a, p a) ↔ ∃ a ∈ l, p a := by simp [any_iff_exists]

theorem any_of_mem {p : α → bool} (h₁ : a ∈ l) (h₂ : p a) : any l p := any_iff_exists.2 ⟨_, h₁, h₂⟩

@[priority 500] instance decidable_forall_mem (l : list α) : decidable (∀ x ∈ l, p x) :=
decidable_of_iff _ all_iff_forall_prop

instance decidable_exists_mem (l : list α) : decidable (∃ x ∈ l, p x) :=
decidable_of_iff _ any_iff_exists_prop

end list


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

! This file was ported from Lean 3 source module group_theory.noncomm_pi_coprod
! leanprover-community/mathlib commit 6f9f36364eae3f42368b04858fd66d6d9ae730d8
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.GroupTheory.OrderOfElement
import Mathlib.Data.Finset.NoncommProd
import Mathlib.Data.Fintype.BigOperators
import Mathlib.Data.Nat.GCD.BigOperators
import Mathlib.Order.SupIndep

/-!
# Canonical homomorphism from a finite family of monoids

This file defines the construction of the canonical homomorphism from a family of monoids.

Given a family of morphisms `ϕ i : N i →* M` for each `i : ι` where elements in the
images of different morphisms commute, we obtain a canonical morphism
`MonoidHom.noncommPiCoprod : (Π i, N i) →* M` that coincides with `ϕ`

## Main definitions

* `MonoidHom.noncommPiCoprod : (Π i, N i) →* M` is the main homomorphism
* `Subgroup.noncommPiCoprod : (Π i, H i) →* G` is the specialization to `H i : Subgroup G`
   and the subgroup embedding.

## Main theorems

* `MonoidHom.noncommPiCoprod` coincides with `ϕ i` when restricted to `N i`
* `MonoidHom.noncommPiCoprod_mrange`: The range of `MonoidHom.noncommPiCoprod` is
  `⨆ (i : ι), (ϕ i).mrange`
* `MonoidHom.noncommPiCoprod_range`: The range of `MonoidHom.noncommPiCoprod` is
  `⨆ (i : ι), (ϕ i).range`
* `Subgroup.noncommPiCoprod_range`: The range of `Subgroup.noncommPiCoprod` is `⨆ (i : ι), H i`.
* `MonoidHom.injective_noncommPiCoprod_of_independent`: in the case of groups, `pi_hom.hom` is
   injective if the `ϕ` are injective and the ranges of the `ϕ` are independent.
* `MonoidHom.independent_range_of_coprime_order`: If the `N i` have coprime orders, then the ranges
   of the `ϕ` are independent.
* `Subgroup.independent_of_coprime_order`: If commuting normal subgroups `H i` have coprime orders,
   they are independent.

-/

open BigOperators

namespace Subgroup

variable {G : Type _} [Group G]

/-- `Finset.noncommProd` is “injective” in `f` if `f` maps into independent subgroups.  This
generalizes (one direction of) `Subgroup.disjoint_iff_mul_eq_one`. -/
@[to_additive "`Finset.noncommSum` is “injective” in `f` if `f` maps into independent subgroups.
This generalizes (one direction of) `AddSubgroup.disjoint_iff_add_eq_zero`. "]
theorem eq_one_of_noncommProd_eq_one_of_independent {ι : Type _} (s : Finset ι) (f : ι → G) (comm)
    (K : ι → Subgroup G) (hind : CompleteLattice.Independent K) (hmem : ∀ x ∈ s, f x ∈ K x)
    (heq1 : s.noncommProd f comm = 1) : ∀ i ∈ s, f i = 1 := by
  classical
    revert heq1
    induction' s using Finset.induction_on with i s hnmem ih
    · simp
    · have hcomm := comm.mono (Finset.coe_subset.2 <| Finset.subset_insert _ _)
      simp only [Finset.forall_mem_insert] at hmem
      have hmem_bsupr : s.noncommProd f hcomm ∈ ⨆ i ∈ (s : Set ι), K i :=
        by
        refine' Subgroup.noncommProd_mem _ _ _
        intro x hx
        have : K x ≤ ⨆ i ∈ (s : Set ι), K i := le_supᵢ₂ (f := fun i _ => K i) x hx
        exact this (hmem.2 x hx)
      intro heq1
      rw [Finset.noncommProd_insert_of_not_mem _ _ _ _ hnmem] at heq1
      have hnmem' : i ∉ (s : Set ι) := by simpa
      obtain ⟨heq1i : f i = 1, heq1S : s.noncommProd f _ = 1⟩ :=
        Subgroup.disjoint_iff_mul_eq_one.mp (hind.disjoint_bsupᵢ hnmem') hmem.1 hmem_bsupr heq1
      intro i h
      simp only [Finset.mem_insert] at h
      rcases h with (rfl | h)
      · exact heq1i
      · refine' ih hcomm hmem.2 heq1S _ h

#align subgroup.eq_one_of_noncomm_prod_eq_one_of_independent Subgroup.eq_one_of_noncommProd_eq_one_of_independent
#align add_subgroup.eq_zero_of_noncomm_sum_eq_zero_of_independent AddSubgroup.eq_zero_of_noncommSum_eq_zero_of_independent

end Subgroup

section FamilyOfMonoids

variable {M : Type _} [Monoid M]

-- We have a family of monoids
-- The fintype assumption is not always used, but declared here, to keep things in order
variable {ι : Type _} [hdec : DecidableEq ι] [Fintype ι]

variable {N : ι → Type _} [∀ i, Monoid (N i)]

-- And morphisms ϕ into G
variable (ϕ : ∀ i : ι, N i →* M)

-- We assume that the elements of different morphism commute
variable (hcomm : Pairwise fun i j => ∀ x y, Commute (ϕ i x) (ϕ j y))

-- We use `f` and `g` to denote elements of `Π (i : ι), N i`
variable (f g : ∀ i : ι, N i)

namespace MonoidHom

/-- The canonical homomorphism from a family of monoids. -/
@[to_additive "The canonical homomorphism from a family of additive monoids. See also
`LinearMap.lsum` for a linear version without the commutativity assumption."]
def noncommPiCoprod : (∀ i : ι, N i) →* M
    where
  toFun f := Finset.univ.noncommProd (fun i => ϕ i (f i)) fun i _ j _ h => hcomm h _ _
  map_one' := by
    apply (Finset.noncommProd_eq_pow_card _ _ _ _ _).trans (one_pow _)
    simp
  map_mul' f g := by
    classical
      simp only
      have := @Finset.noncommProd_mul_distrib _ _ _ Finset.univ (fun i => ϕ i (f i))
        (fun i => ϕ i (g i)) ?_ ?_ ?_
      · convert this
        exact map_mul _ _ _
      · exact fun i _ j _ hij => hcomm hij _ _
      · exact fun i _ j _ hij => hcomm hij _ _
      · exact fun i _ j _ hij => hcomm hij _ _
#align monoid_hom.noncomm_pi_coprod MonoidHom.noncommPiCoprod
#align add_monoid_hom.noncomm_pi_coprod AddMonoidHom.noncommPiCoprod

variable {hcomm}

@[to_additive (attr := simp)]

/-- The universal property of `MonoidHom.noncommPiCoprod` -/
@[to_additive "The universal property of `AddMonoidHom.noncommPiCoprod`"]
def noncommPiCoprodEquiv :
    { ϕ : ∀ i, N i →* M // Pairwise fun i j => ∀ x y, Commute (ϕ i x) (ϕ j y) } ≃ ((∀ i, N i) →* M)
    where
  toFun ϕ := noncommPiCoprod ϕ.1 ϕ.2
  invFun f :=
    ⟨fun i => f.comp (MonoidHom.single N i), fun i j hij x y =>
      Commute.map (Pi.mulSingle_commute hij x y) f⟩
  left_inv ϕ := by
    ext
    simp
  right_inv f := pi_ext fun i x => by simp
#align monoid_hom.noncomm_pi_coprod_equiv MonoidHom.noncommPiCoprodEquiv
#align add_monoid_hom.noncomm_pi_coprod_equiv AddMonoidHom.noncommPiCoprodEquiv

@[to_additive]
theorem noncommPiCoprod_mrange :
    MonoidHom.mrange (noncommPiCoprod ϕ hcomm) = ⨆ i : ι, MonoidHom.mrange (ϕ i) := by
  classical
    apply le_antisymm
    · rintro x ⟨f, rfl⟩
      refine Submonoid.noncommProd_mem _ _ _ (fun _ _ _ _ h => hcomm h _ _) (fun i _ => ?_)
      apply Submonoid.mem_supₛ_of_mem
      · use i
      simp
    · refine' supᵢ_le _
      rintro i x ⟨y, rfl⟩
      refine' ⟨Pi.mulSingle i y, noncommPiCoprod_mulSingle _ _ _⟩
#align monoid_hom.noncomm_pi_coprod_mrange MonoidHom.noncommPiCoprod_mrange
#align add_monoid_hom.noncomm_pi_coprod_mrange AddMonoidHom.noncommPiCoprod_mrange

end MonoidHom

end FamilyOfMonoids

section FamilyOfGroups

variable {G : Type _} [Group G]

variable {ι : Type _} [hdec : DecidableEq ι] [hfin : Fintype ι]

variable {H : ι → Type _} [∀ i, Group (H i)]

variable (ϕ : ∀ i : ι, H i →* G)

variable {hcomm : ∀ i j : ι, i ≠ j → ∀ (x : H i) (y : H j), Commute (ϕ i x) (ϕ j y)}

-- We use `f` and `g` to denote elements of `Π (i : ι), H i`
variable (f g : ∀ i : ι, H i)

namespace MonoidHom

-- The subgroup version of `MonoidHom.noncommPiCoprod_mrange`
@[to_additive]
theorem noncommPiCoprod_range : (noncommPiCoprod ϕ hcomm).range = ⨆ i : ι, (ϕ i).range := by
  classical
    apply le_antisymm
    · rintro x ⟨f, rfl⟩
      refine Subgroup.noncommProd_mem _ (fun _ _ _ _ h => hcomm _ _ h _ _) ?_
      intro i _hi
      apply Subgroup.mem_supₛ_of_mem
      · use i
      simp
    · refine' supᵢ_le _
      rintro i x ⟨y, rfl⟩
      refine' ⟨Pi.mulSingle i y, noncommPiCoprod_mulSingle _ _ _⟩
#align monoid_hom.noncomm_pi_coprod_range MonoidHom.noncommPiCoprod_range
#align add_monoid_hom.noncomm_pi_coprod_range AddMonoidHom.noncommPiCoprod_range

@[to_additive]
theorem injective_noncommPiCoprod_of_independent
    (hind : CompleteLattice.Independent fun i => (ϕ i).range)
    (hinj : ∀ i, Function.Injective (ϕ i)) : Function.Injective (noncommPiCoprod ϕ hcomm) := by
  classical
    apply (MonoidHom.ker_eq_bot_iff _).mp
    apply eq_bot_iff.mpr
    intro f heq1
    have : ∀ i, i ∈ Finset.univ → ϕ i (f i) = 1 :=
      Subgroup.eq_one_of_noncommProd_eq_one_of_independent _ _ (fun _ _ _ _ h => hcomm _ _ h _ _)
        _ hind (by simp) heq1
    ext i
    apply hinj
    simp [this i (Finset.mem_univ i)]
#align monoid_hom.injective_noncomm_pi_coprod_of_independent MonoidHom.injective_noncommPiCoprod_of_independent
#align add_monoid_hom.injective_noncomm_pi_coprod_of_independent AddMonoidHom.injective_noncommPiCoprod_of_independent

variable (hcomm)

@[to_additive]
theorem independent_range_of_coprime_order [Finite ι] [∀ i, Fintype (H i)]
    (hcoprime : ∀ i j, i ≠ j → Nat.coprime (Fintype.card (H i)) (Fintype.card (H j))) :
    CompleteLattice.Independent fun i => (ϕ i).range := by
  cases nonempty_fintype ι
  classical
    rintro i
    rw [disjoint_iff_inf_le]
    rintro f ⟨hxi, hxp⟩
    dsimp at hxi hxp
    rw [supᵢ_subtype', ← noncommPiCoprod_range] at hxp
    rotate_left
    · intro _ _ hj
      apply hcomm
      exact hj ∘ Subtype.ext
    cases' hxp with g hgf
    cases' hxi with g' hg'f
    have hxi : orderOf f ∣ Fintype.card (H i) :=
      by
      rw [← hg'f]
      exact (orderOf_map_dvd _ _).trans orderOf_dvd_card_univ
    have hxp : orderOf f ∣ ∏ j : { j // j ≠ i }, Fintype.card (H j) :=
      by
      rw [← hgf, ← Fintype.card_pi]
      exact (orderOf_map_dvd _ _).trans orderOf_dvd_card_univ
    change f = 1
    rw [← pow_one f, ← orderOf_dvd_iff_pow_eq_one]
    -- porting note: ouch, had to replace an ugly `convert`
    obtain ⟨c, hc⟩ := Nat.dvd_gcd hxp hxi
    use c
    rw [← hc]
    symm
    rw [← Nat.coprime_iff_gcd_eq_one]
    apply Nat.coprime_prod_left
    intro j _
    apply hcoprime
    exact j.2
#align monoid_hom.independent_range_of_coprime_order MonoidHom.independent_range_of_coprime_order
#align add_monoid_hom.independent_range_of_coprime_order AddMonoidHom.independent_range_of_coprime_order

end MonoidHom

end FamilyOfGroups

namespace Subgroup

-- We have an family of subgroups
variable {G : Type _} [Group G]

variable {ι : Type _} [hdec : DecidableEq ι] [hfin : Fintype ι] {H : ι → Subgroup G}

-- Elements of `Π (i : ι), H i` are called `f` and `g` here
variable (f g : ∀ i : ι, H i)

section CommutingSubgroups

-- We assume that the elements of different subgroups commute
variable (hcomm : ∀ i j : ι, i ≠ j → ∀ x y : G, x ∈ H i → y ∈ H j → Commute x y)

@[to_additive]
theorem commute_subtype_of_commute (i j : ι) (hne : i ≠ j) :
    ∀ (x : H i) (y : H j), Commute ((H i).subtype x) ((H j).subtype y) := by
  rintro ⟨x, hx⟩ ⟨y, hy⟩
  exact hcomm i j hne x y hx hy
#align subgroup.commute_subtype_of_commute Subgroup.commute_subtype_of_commute
#align add_subgroup.commute_subtype_of_commute AddSubgroup.commute_subtype_of_commute

/-- The canonical homomorphism from a family of subgroups where elements from different subgroups
commute -/
@[to_additive "The canonical homomorphism from a family of additive subgroups where elements from
different subgroups commute"]
def noncommPiCoprod : (∀ i : ι, H i) →* G :=
  MonoidHom.noncommPiCoprod (fun i => (H i).subtype) (commute_subtype_of_commute hcomm)
#align subgroup.noncomm_pi_coprod Subgroup.noncommPiCoprod
#align add_subgroup.noncomm_pi_coprod AddSubgroup.noncommPiCoprod

variable {hcomm}

@[to_additive (attr := simp)]
theorem noncommPiCoprod_mulSingle (i : ι) (y : H i) :
    noncommPiCoprod hcomm (Pi.mulSingle i y) = y := by apply MonoidHom.noncommPiCoprod_mulSingle
#align subgroup.noncomm_pi_coprod_mul_single Subgroup.noncommPiCoprod_mulSingle
#align add_subgroup.noncomm_pi_coprod_single AddSubgroup.noncommPiCoprod_single

@[to_additive]
theorem noncommPiCoprod_range : (noncommPiCoprod hcomm).range = ⨆ i : ι, H i := by
  simp [noncommPiCoprod, MonoidHom.noncommPiCoprod_range]
#align subgroup.noncomm_pi_coprod_range Subgroup.noncommPiCoprod_range
#align add_subgroup.noncomm_pi_coprod_range AddSubgroup.noncommPiCoprod_range

@[to_additive]
theorem injective_noncommPiCoprod_of_independent (hind : CompleteLattice.Independent H) :
    Function.Injective (noncommPiCoprod hcomm) := by
  apply MonoidHom.injective_noncommPiCoprod_of_independent
  · simpa using hind
  · intro i
    exact Subtype.coe_injective
#align subgroup.injective_noncomm_pi_coprod_of_independent Subgroup.injective_noncommPiCoprod_of_independent
#align add_subgroup.injective_noncomm_pi_coprod_of_independent AddSubgroup.injective_noncommPiCoprod_of_independent

variable (hcomm)

@[to_additive]
theorem independent_of_coprime_order [Finite ι] [∀ i, Fintype (H i)]
    (hcoprime : ∀ i j, i ≠ j → Nat.coprime (Fintype.card (H i)) (Fintype.card (H j))) :
    CompleteLattice.Independent H := by
  simpa using
    MonoidHom.independent_range_of_coprime_order (fun i => (H i).subtype)
      (commute_subtype_of_commute hcomm) hcoprime
#align subgroup.independent_of_coprime_order Subgroup.independent_of_coprime_order
#align add_subgroup.independent_of_coprime_order AddSubgroup.independent_of_coprime_order

end CommutingSubgroups

end Subgroup


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

import data.part
import data.nat.upto
import data.stream.defs

/-!
# Fixed point

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

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

## Main definition

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

universes u v

open_locale classical
variables {α : Type*} {β : α → Type*}

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

namespace part

open part nat nat.upto

section basic

variables (f : (Π a, part $ β a) → (Π a, part $ β a))

/-- A series of successive, finite approximation of the fixed point of `f`, defined by
`approx f n = f^[n] ⊥`. The limit of this chain is the fixed point of `f`. -/
def fix.approx : stream $ Π a, part $ β a
| 0 := ⊥
| (nat.succ i) := f (fix.approx i)

/-- loop body for finding the fixed point of `f` -/
def fix_aux {p : ℕ → Prop} (i : nat.upto p)
  (g : Π j : nat.upto p, i < j → Π a, part $ β a) : Π a, part $ β a :=
f $ λ x : α,
assert (¬p (i.val)) $ λ h : ¬ p (i.val),
g (i.succ h) (nat.lt_succ_self _) x

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

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

  1. `fix f = f (fix f)`          (is a fixed point)
  2. `∀ X, f X ≤ X → fix f ≤ X`   (least fixed point)
-/
protected def fix (x : α) : part $ β x :=
part.assert (∃ i, (fix.approx f i x).dom) $ λ h,
well_founded.fix.{1} (nat.upto.wf h) (fix_aux f) nat.upto.zero x

protected lemma fix_def {x : α} (h' : ∃ i, (fix.approx f i x).dom) :
  part.fix f x = fix.approx f (nat.succ $ nat.find h') x :=
begin
  let p := λ (i : ℕ), (fix.approx f i x).dom,
  have : p (nat.find h') := nat.find_spec h',
  generalize hk : nat.find h' = k,
  replace hk : nat.find h' = k + (@upto.zero p).val := hk,
  rw hk at this,
  revert hk,
  dsimp [part.fix], rw assert_pos h', revert this,
  generalize : upto.zero = z, intros,
  suffices : ∀ x',
    well_founded.fix (fix._proof_1 f x h') (fix_aux f) z x' = fix.approx f (succ k) x',
    from this _,
  induction k generalizing z; intro,
  { rw [fix.approx,well_founded.fix_eq,fix_aux],
    congr, ext : 1, rw assert_neg, refl,
    rw nat.zero_add at this,
    simpa only [not_not, subtype.val_eq_coe] },
  { rw [fix.approx,well_founded.fix_eq,fix_aux],
    congr, ext : 1,
    have hh : ¬(fix.approx f (z.val) x).dom,
    { apply nat.find_min h',
      rw [hk,nat.succ_add,← nat.add_succ],
      apply nat.lt_of_succ_le,
      apply nat.le_add_left },
    rw succ_add_eq_succ_add at this hk,
    rw [assert_pos hh, k_ih (upto.succ z hh) this hk] }
end

end basic

end part

namespace part

instance : has_fix (part α) :=
⟨λ f, part.fix (λ x u, f (x u)) ()⟩

end part

open sigma

namespace pi

instance part.has_fix {β} : has_fix (α → part β) := ⟨part.fix⟩

end pi