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

/-!
# N-ary maps of filter

This file defines the binary and ternary maps of filters. This is mostly useful to define pointwise
operations on filters.

## Main declarations

* `filter.map₂`: Binary map of filters.
* `filter.map₃`: Ternary map of filters.

## Notes

This file is very similar to the n-ary section of `data.set.basic` and to `data.finset.n_ary`.
Please keep them in sync.
-/

open function set
open_locale filter

namespace filter
variables {α α' β β' γ γ' δ δ' ε ε' : Type*} {m : α → β → γ} {f f₁ f₂ : filter α}
  {g g₁ g₂ : filter β} {h h₁ h₂ : filter γ} {s s₁ s₂ : set α} {t t₁ t₂ : set β} {u : set γ}
  {v : set δ} {a : α} {b : β} {c : γ}

/-- The image of a binary function `m : α → β → γ` as a function `filter α → filter β → filter γ`.
Mathematically this should be thought of as the image of the corresponding function `α × β → γ`. -/
def map₂ (m : α → β → γ) (f : filter α) (g : filter β) : filter γ :=
{ sets := {s | ∃ u v, u ∈ f ∧ v ∈ g ∧ image2 m u v ⊆ s},
  univ_sets := ⟨univ, univ, univ_sets _, univ_sets _, subset_univ _⟩,
  sets_of_superset := λ s t hs hst,
    Exists₂.imp (λ u v, and.imp_right $ and.imp_right $ λ h, subset.trans h hst) hs,
  inter_sets := λ s t,
  begin
    simp only [exists_prop, mem_set_of_eq, subset_inter_iff],
    rintro ⟨s₁, s₂, hs₁, hs₂, hs⟩ ⟨t₁, t₂, ht₁, ht₂, ht⟩,
    exact ⟨s₁ ∩ t₁, s₂ ∩ t₂, inter_sets f hs₁ ht₁, inter_sets g hs₂ ht₂,
      (image2_subset (inter_subset_left _ _) $ inter_subset_left _ _).trans hs,
      (image2_subset (inter_subset_right _ _) $ inter_subset_right _ _).trans ht⟩,
  end }

@[simp] lemma mem_map₂_iff : u ∈ map₂ m f g ↔ ∃ s t, s ∈ f ∧ t ∈ g ∧ image2 m s t ⊆ u := iff.rfl

lemma image2_mem_map₂ (hs : s ∈ f) (ht : t ∈ g) : image2 m s t ∈ map₂ m f g :=
⟨_, _, hs, ht, subset.rfl⟩

lemma map_prod_eq_map₂ (m : α → β → γ) (f : filter α) (g : filter β) :
  filter.map (λ p : α × β, m p.1 p.2) (f ×ᶠ g) = map₂ m f g :=
begin
  ext s,
  split,
  { intro hmem,
    rw filter.mem_map_iff_exists_image at hmem,
    obtain ⟨s', hs', hsub⟩ := hmem,
    rw filter.mem_prod_iff at hs',
    obtain ⟨t, ht, t', ht', hsub'⟩ := hs',
    refine ⟨t, t', ht, ht', _⟩,
    rw ← set.image_prod,
    exact subset_trans (set.image_subset (λ (p : α × β), m p.fst p.snd) hsub') hsub },
  { intro hmem,
    rw mem_map₂_iff at hmem,
    obtain ⟨t, t', ht, ht', hsub⟩ := hmem,
    rw ← set.image_prod at hsub,
    rw filter.mem_map_iff_exists_image,
    exact ⟨t ×ˢ t', filter.prod_mem_prod ht ht', hsub⟩ },
end

lemma map_prod_eq_map₂' (m : α × β → γ) (f : filter α) (g : filter β) :
  filter.map m (f ×ᶠ g) = map₂ (λ a b, m (a, b)) f g :=
by { refine eq.trans _ (map_prod_eq_map₂ (curry m) f g), ext, simp }

-- lemma image2_mem_map₂_iff (hm : injective2 m) : image2 m s t ∈ map₂ m f g ↔ s ∈ f ∧ t ∈ g :=
-- ⟨by { rintro ⟨u, v, hu, hv, h⟩, rw image2_subset_image2_iff hm at h,
--   exact ⟨mem_of_superset hu h.1, mem_of_superset hv h.2⟩ }, λ h, image2_mem_map₂ h.1 h.2⟩

lemma map₂_mono (hf : f₁ ≤ f₂) (hg : g₁ ≤ g₂) : map₂ m f₁ g₁ ≤ map₂ m f₂ g₂ :=
λ _ ⟨s, t, hs, ht, hst⟩, ⟨s, t, hf hs, hg ht, hst⟩

lemma map₂_mono_left (h : g₁ ≤ g₂) : map₂ m f g₁ ≤ map₂ m f g₂ := map₂_mono subset.rfl h
lemma map₂_mono_right (h : f₁ ≤ f₂) : map₂ m f₁ g ≤ map₂ m f₂ g := map₂_mono h subset.rfl

@[simp] lemma le_map₂_iff {h : filter γ} :
  h ≤ map₂ m f g ↔ ∀ ⦃s⦄, s ∈ f → ∀ ⦃t⦄, t ∈ g → image2 m s t ∈ h :=
⟨λ H s hs t ht, H $ image2_mem_map₂ hs ht, λ H u ⟨s, t, hs, ht, hu⟩, mem_of_superset (H hs ht) hu⟩

@[simp] lemma map₂_bot_left : map₂ m ⊥ g = ⊥ :=
empty_mem_iff_bot.1 ⟨∅, univ, trivial, univ_mem, (image2_empty_left).subset⟩

@[simp] lemma map₂_bot_right : map₂ m f ⊥ = ⊥ :=
empty_mem_iff_bot.1 ⟨univ, ∅, univ_mem, trivial, (image2_empty_right).subset⟩

@[simp] lemma map₂_eq_bot_iff : map₂ m f g = ⊥ ↔ f = ⊥ ∨ g = ⊥ :=
begin
  simp only [←empty_mem_iff_bot, mem_map₂_iff, subset_empty_iff, image2_eq_empty_iff],
  split,
  { rintro ⟨s, t, hs, ht, rfl | rfl⟩,
    { exact or.inl hs },
    { exact or.inr ht } },
  { rintro (h | h),
    { exact ⟨_, _, h, univ_mem, or.inl rfl⟩ },
    { exact ⟨_, _, univ_mem, h, or.inr rfl⟩ } }
end

@[simp] lemma map₂_ne_bot_iff : (map₂ m f g).ne_bot ↔ f.ne_bot ∧ g.ne_bot :=
by { simp_rw ne_bot_iff, exact map₂_eq_bot_iff.not.trans not_or_distrib }

lemma ne_bot.map₂ (hf : f.ne_bot) (hg : g.ne_bot) : (map₂ m f g).ne_bot :=
map₂_ne_bot_iff.2 ⟨hf, hg⟩

lemma ne_bot.of_map₂_left (h : (map₂ m f g).ne_bot) : f.ne_bot := (map₂_ne_bot_iff.1 h).1
lemma ne_bot.of_map₂_right (h : (map₂ m f g).ne_bot) : g.ne_bot := (map₂_ne_bot_iff.1 h).2

lemma map₂_sup_left : map₂ m (f₁ ⊔ f₂) g = map₂ m f₁ g ⊔ map₂ m f₂ g :=
begin
  ext u,
  split,
  { rintro ⟨s, t, ⟨h₁, h₂⟩, ht, hu⟩,
    exact ⟨mem_of_superset (image2_mem_map₂ h₁ ht) hu,
      mem_of_superset (image2_mem_map₂ h₂ ht) hu⟩ },
  { rintro ⟨⟨s₁, t₁, hs₁, ht₁, hu₁⟩, s₂, t₂, hs₂, ht₂, hu₂⟩,
    refine ⟨s₁ ∪ s₂, t₁ ∩ t₂, union_mem_sup hs₁ hs₂, inter_mem ht₁ ht₂, _⟩,
    rw image2_union_left,
    exact union_subset ((image2_subset_left $ inter_subset_left _ _).trans hu₁)
      ((image2_subset_left $ inter_subset_right _ _).trans hu₂) }
end

lemma map₂_sup_right : map₂ m f (g₁ ⊔ g₂) = map₂ m f g₁ ⊔ map₂ m f g₂ :=
begin
  ext u,
  split,
  { rintro ⟨s, t, hs, ⟨h₁, h₂⟩, hu⟩,
    exact ⟨mem_of_superset (image2_mem_map₂ hs h₁) hu,
      mem_of_superset (image2_mem_map₂ hs h₂) hu⟩ },
  { rintro ⟨⟨s₁, t₁, hs₁, ht₁, hu₁⟩, s₂, t₂, hs₂, ht₂, hu₂⟩,
    refine ⟨s₁ ∩ s₂, t₁ ∪ t₂, inter_mem hs₁ hs₂, union_mem_sup ht₁ ht₂, _⟩,
    rw image2_union_right,
    exact union_subset ((image2_subset_right $ inter_subset_left _ _).trans hu₁)
      ((image2_subset_right $ inter_subset_right _ _).trans hu₂) }
end

lemma map₂_inf_subset_left : map₂ m (f₁ ⊓ f₂) g ≤ map₂ m f₁ g ⊓ map₂ m f₂ g :=
le_inf (map₂_mono_right inf_le_left) (map₂_mono_right inf_le_right)

lemma map₂_inf_subset_right : map₂ m f (g₁ ⊓ g₂) ≤ map₂ m f g₁ ⊓ map₂ m f g₂ :=
le_inf (map₂_mono_left inf_le_left) (map₂_mono_left inf_le_right)

@[simp] lemma map₂_pure_left : map₂ m (pure a) g = g.map (λ b, m a b) :=
filter.ext $ λ u, ⟨λ ⟨s, t, hs, ht, hu⟩,
  mem_of_superset (image_mem_map ht) ((image_subset_image2_right $ mem_pure.1 hs).trans hu),
    λ h, ⟨{a}, _, singleton_mem_pure, h, by rw [image2_singleton_left, image_subset_iff]⟩⟩

@[simp] lemma map₂_pure_right : map₂ m f (pure b) = f.map (λ a, m a b) :=
filter.ext $ λ u, ⟨λ ⟨s, t, hs, ht, hu⟩,
  mem_of_superset (image_mem_map hs) ((image_subset_image2_left $ mem_pure.1 ht).trans hu),
    λ h, ⟨_, {b}, h, singleton_mem_pure, by rw [image2_singleton_right, image_subset_iff]⟩⟩

lemma map₂_pure : map₂ m (pure a) (pure b) = pure (m a b) := by rw [map₂_pure_right, map_pure]

lemma map₂_swap (m : α → β → γ) (f : filter α) (g : filter β) :
  map₂ m f g = map₂ (λ a b, m b a) g f :=
by { ext u, split; rintro ⟨s, t, hs, ht, hu⟩; refine ⟨t, s, ht, hs, by rwa image2_swap⟩ }

@[simp] lemma map₂_left (h : g.ne_bot) : map₂ (λ x y, x) f g = f :=
begin
  ext u,
  refine ⟨_, λ hu, ⟨_, _, hu, univ_mem, (image2_left $ h.nonempty_of_mem univ_mem).subset⟩⟩,
  rintro ⟨s, t, hs, ht, hu⟩,
  rw image2_left (h.nonempty_of_mem ht) at hu,
  exact mem_of_superset hs hu,
end

@[simp] lemma map₂_right (h : f.ne_bot) : map₂ (λ x y, y) f g = g := by rw [map₂_swap, map₂_left h]

/-- The image of a ternary function `m : α → β → γ → δ` as a function
`filter α → filter β → filter γ → filter δ`. Mathematically this should be thought of as the image
of the corresponding function `α × β × γ → δ`. -/
def map₃ (m : α → β → γ → δ) (f : filter α) (g : filter β) (h : filter γ) : filter δ :=
{ sets := {s | ∃ u v w, u ∈ f ∧ v ∈ g ∧ w ∈ h ∧ image3 m u v w ⊆ s},
  univ_sets := ⟨univ, univ, univ, univ_sets _, univ_sets _, univ_sets _, subset_univ _⟩,
  sets_of_superset := λ s t hs hst, Exists₃.imp
    (λ u v w, and.imp_right $ and.imp_right $ and.imp_right $ λ h, subset.trans h hst) hs,
  inter_sets := λ s t,
  begin
    simp only [exists_prop, mem_set_of_eq, subset_inter_iff],
    rintro ⟨s₁, s₂, s₃, hs₁, hs₂, hs₃, hs⟩ ⟨t₁, t₂, t₃, ht₁, ht₂, ht₃, ht⟩,
    exact ⟨s₁ ∩ t₁, s₂ ∩ t₂, s₃ ∩ t₃, inter_mem hs₁ ht₁, inter_mem hs₂ ht₂, inter_mem hs₃ ht₃,
      (image3_mono (inter_subset_left _ _) (inter_subset_left _ _) $ inter_subset_left _ _).trans
        hs,
      (image3_mono (inter_subset_right _ _) (inter_subset_right _ _) $ inter_subset_right _ _).trans
        ht⟩,
  end }

lemma map₂_map₂_left (m : δ → γ → ε) (n : α → β → δ) :
  map₂ m (map₂ n f g) h = map₃ (λ a b c, m (n a b) c) f g h :=
begin
  ext w,
  split,
  { rintro ⟨s, t, ⟨u, v, hu, hv, hs⟩, ht, hw⟩,
    refine ⟨u, v, t, hu, hv, ht, _⟩,
    rw ←image2_image2_left,
    exact (image2_subset_right hs).trans hw },
  { rintro ⟨s, t, u, hs, ht, hu, hw⟩,
    exact ⟨_, u, image2_mem_map₂ hs ht, hu, by rwa image2_image2_left⟩ }
end

lemma map₂_map₂_right (m : α → δ → ε) (n : β → γ → δ) :
  map₂ m f (map₂ n g h) = map₃ (λ a b c, m a (n b c)) f g h :=
begin
  ext w,
  split,
  { rintro ⟨s, t, hs, ⟨u, v, hu, hv, ht⟩, hw⟩,
    refine ⟨s, u, v, hs, hu, hv, _⟩,
    rw ←image2_image2_right,
    exact (image2_subset_left ht).trans hw },
  { rintro ⟨s, t, u, hs, ht, hu, hw⟩,
    exact ⟨s, _, hs, image2_mem_map₂ ht hu, by rwa image2_image2_right⟩ }
end

lemma map_map₂ (m : α → β → γ) (n : γ → δ) : (map₂ m f g).map n = map₂ (λ a b, n (m a b)) f g :=
filter.ext $ λ u, exists₂_congr $ λ s t, by rw [←image_subset_iff, image_image2]

lemma map₂_map_left (m : γ → β → δ) (n : α → γ) :
  map₂ m (f.map n) g = map₂ (λ a b, m (n a) b) f g :=
begin
  ext u,
  split,
  { rintro ⟨s, t, hs, ht, hu⟩,
    refine ⟨_, t, hs, ht, _⟩,
    rw ←image2_image_left,
    exact (image2_subset_right $ image_preimage_subset _ _).trans hu },
  { rintro ⟨s, t, hs, ht, hu⟩,
    exact ⟨_, t, image_mem_map hs, ht, by rwa image2_image_left⟩ }
end

lemma map₂_map_right (m : α → γ → δ) (n : β → γ) :
  map₂ m f (g.map n) = map₂ (λ a b, m a (n b)) f g :=
by rw [map₂_swap, map₂_map_left, map₂_swap]

/-!
### Algebraic replacement rules

A collection of lemmas to transfer associativity, commutativity, distributivity, ... of operations
to the associativity, commutativity, distributivity, ... of `filter.map₂` of those operations.

The proof pattern is `map₂_lemma operation_lemma`. For example, `map₂_comm mul_comm` proves that
`map₂ (*) f g = map₂ (*) g f` in a `comm_semigroup`.
-/

lemma map₂_assoc {m : δ → γ → ε} {n : α → β → δ} {m' : α → ε' → ε} {n' : β → γ → ε'}
  {h : filter γ} (h_assoc : ∀ a b c, m (n a b) c = m' a (n' b c)) :
  map₂ m (map₂ n f g) h = map₂ m' f (map₂ n' g h) :=
by simp only [map₂_map₂_left, map₂_map₂_right, h_assoc]

lemma map₂_comm {n : β → α → γ} (h_comm : ∀ a b, m a b = n b a) : map₂ m f g = map₂ n g f :=
(map₂_swap _ _ _).trans $ by simp_rw h_comm

lemma map₂_left_comm {m : α → δ → ε} {n : β → γ → δ} {m' : α → γ → δ'} {n' : β → δ' → ε}
  (h_left_comm : ∀ a b c, m a (n b c) = n' b (m' a c)) :
  map₂ m f (map₂ n g h) = map₂ n' g (map₂ m' f h) :=
by { rw [map₂_swap m', map₂_swap m], exact map₂_assoc (λ _ _ _, h_left_comm _ _ _) }

lemma map₂_right_comm {m : δ → γ → ε} {n : α → β → δ} {m' : α → γ → δ'} {n' : δ' → β → ε}
  (h_right_comm : ∀ a b c, m (n a b) c = n' (m' a c) b) :
  map₂ m (map₂ n f g) h = map₂ n' (map₂ m' f h) g :=
by { rw [map₂_swap n, map₂_swap n'], exact map₂_assoc (λ _ _ _, h_right_comm _ _ _) }

lemma map_map₂_distrib {n : γ → δ} {m' : α' → β' → δ} {n₁ : α → α'} {n₂ : β → β'}
  (h_distrib : ∀ a b, n (m a b) = m' (n₁ a) (n₂ b)) :
  (map₂ m f g).map n = map₂ m' (f.map n₁) (g.map n₂) :=
by simp_rw [map_map₂, map₂_map_left, map₂_map_right, h_distrib]

/-- Symmetric of `filter.map₂_map_left_comm`. -/
lemma map_map₂_distrib_left {n : γ → δ} {m' : α' → β → δ} {n' : α → α'}
  (h_distrib : ∀ a b, n (m a b) = m' (n' a) b) :
  (map₂ m f g).map n = map₂ m' (f.map n') g :=
map_map₂_distrib h_distrib

/-- Symmetric of `filter.map_map₂_right_comm`. -/
lemma map_map₂_distrib_right {n : γ → δ} {m' : α → β' → δ} {n' : β → β'}
  (h_distrib : ∀ a b, n (m a b) = m' a (n' b)) :
  (map₂ m f g).map n = map₂ m' f (g.map n') :=
map_map₂_distrib h_distrib

/-- Symmetric of `filter.map_map₂_distrib_left`. -/
lemma map₂_map_left_comm {m : α' → β → γ} {n : α → α'} {m' : α → β → δ} {n' : δ → γ}
  (h_left_comm : ∀ a b, m (n a) b = n' (m' a b)) :
  map₂ m (f.map n) g = (map₂ m' f g).map n' :=
(map_map₂_distrib_left $ λ a b, (h_left_comm a b).symm).symm

/-- Symmetric of `filter.map_map₂_distrib_right`. -/

/-- The other direction does not hold because of the `f`-`f` cross terms on the RHS. -/
lemma map₂_distrib_le_left {m : α → δ → ε} {n : β → γ → δ} {m₁ : α → β → β'} {m₂ : α → γ → γ'}
  {n' : β' → γ' → ε} (h_distrib : ∀ a b c, m a (n b c) = n' (m₁ a b) (m₂ a c)) :
  map₂ m f (map₂ n g h) ≤ map₂ n' (map₂ m₁ f g) (map₂ m₂ f h) :=
begin
  rintro s ⟨t₁, t₂, ⟨u₁, v, hu₁, hv, ht₁⟩, ⟨u₂, w, hu₂, hw, ht₂⟩, hs⟩,
  refine ⟨u₁ ∩ u₂, _, inter_mem hu₁ hu₂, image2_mem_map₂ hv hw, _⟩,
  refine (image2_distrib_subset_left h_distrib).trans ((image2_subset _ _).trans hs),
  { exact (image2_subset_right $ inter_subset_left _ _).trans ht₁ },
  { exact (image2_subset_right $ inter_subset_right _ _).trans ht₂ }
end

/-- The other direction does not hold because of the `h`-`h` cross terms on the RHS. -/
lemma map₂_distrib_le_right {m : δ → γ → ε} {n : α → β → δ} {m₁ : α → γ → α'}
  {m₂ : β → γ → β'} {n' : α' → β' → ε} (h_distrib : ∀ a b c, m (n a b) c = n' (m₁ a c) (m₂ b c)) :
  map₂ m (map₂ n f g) h ≤ map₂ n' (map₂ m₁ f h) (map₂ m₂ g h) :=
begin
  rintro s ⟨t₁, t₂, ⟨u, w₁, hu, hw₁, ht₁⟩, ⟨v, w₂, hv, hw₂, ht₂⟩, hs⟩,
  refine ⟨_, w₁ ∩ w₂, image2_mem_map₂ hu hv, inter_mem hw₁ hw₂, _⟩,
  refine (image2_distrib_subset_right h_distrib).trans ((image2_subset _ _).trans hs),
  { exact (image2_subset_left $ inter_subset_left _ _).trans ht₁ },
  { exact (image2_subset_left $ inter_subset_right _ _).trans ht₂ }
end

lemma map_map₂_antidistrib {n : γ → δ} {m' : β' → α' → δ} {n₁ : β → β'} {n₂ : α → α'}
  (h_antidistrib : ∀ a b, n (m a b) = m' (n₁ b) (n₂ a)) :
  (map₂ m f g).map n = map₂ m' (g.map n₁) (f.map n₂) :=
by { rw map₂_swap m, exact map_map₂_distrib (λ _ _, h_antidistrib _ _) }

/-- Symmetric of `filter.map₂_map_left_anticomm`. -/
lemma map_map₂_antidistrib_left {n : γ → δ} {m' : β' → α → δ} {n' : β → β'}
  (h_antidistrib : ∀ a b, n (m a b) = m' (n' b) a) :
  (map₂ m f g).map n = map₂ m' (g.map n') f :=
map_map₂_antidistrib h_antidistrib

/-- Symmetric of `filter.map_map₂_right_anticomm`. -/
lemma map_map₂_antidistrib_right {n : γ → δ} {m' : β → α' → δ} {n' : α → α'}
  (h_antidistrib : ∀ a b, n (m a b) = m' b (n' a)) :
  (map₂ m f g).map n = map₂ m' g (f.map n') :=
map_map₂_antidistrib h_antidistrib

/-- Symmetric of `filter.map_map₂_antidistrib_left`. -/
lemma map₂_map_left_anticomm {m : α' → β → γ} {n : α → α'} {m' : β → α → δ} {n' : δ → γ}
  (h_left_anticomm : ∀ a b, m (n a) b = n' (m' b a)) :
  map₂ m (f.map n) g = (map₂ m' g f).map n' :=
(map_map₂_antidistrib_left $ λ a b, (h_left_anticomm b a).symm).symm

/-- Symmetric of `filter.map_map₂_antidistrib_right`. -/
lemma map_map₂_right_anticomm {m : α → β' → γ} {n : β → β'} {m' : β → α → δ} {n' : δ → γ}
  (h_right_anticomm : ∀ a b, m a (n b) = n' (m' b a)) :
  map₂ m f (g.map n) = (map₂ m' g f).map n' :=
(map_map₂_antidistrib_right $ λ a b, (h_right_anticomm b a).symm).symm

end filter


/-
Copyright (c) 2021 Riccardo Brasca. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Riccardo Brasca

! This file was ported from Lean 3 source module linear_algebra.free_module.finite.rank
! leanprover-community/mathlib commit bf2a9e0156cc11bf44893ea1b4b2da8ae655c901
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.LinearAlgebra.Finrank
import Mathbin.LinearAlgebra.FreeModule.Rank
import Mathbin.LinearAlgebra.FreeModule.Finite.Basic

/-!

# Rank of finite free modules

This is a basic API for the rank of finite free modules.

-/

--TODO: `linear_algebra/finite_dimensional` should import this file, and a lot of results should
--be moved here.
universe u v w

variable (R : Type u) (M : Type v) (N : Type w)

open TensorProduct DirectSum BigOperators Cardinal

open Cardinal FiniteDimensional Fintype

namespace Module.Free

section Ring

variable [Ring R] [StrongRankCondition R]

variable [AddCommGroup M] [Module R M] [Module.Free R M] [Module.Finite R M]

variable [AddCommGroup N] [Module R N] [Module.Free R N] [Module.Finite R N]

/-- The rank of a finite and free module is finite. -/
theorem rank_lt_aleph0 : Module.rank R M < ℵ₀ :=
  by
  letI := nontrivial_of_invariantBasisNumber R
  rw [← (choose_basis R M).mk_eq_dim'', lt_aleph_0_iff_fintype]
  exact Nonempty.intro inferInstance
#align module.free.rank_lt_aleph_0 Module.Free.rank_lt_aleph0

/-- If `M` is finite and free, `finrank M = rank M`. -/
@[simp]
theorem finrank_eq_rank : ↑(finrank R M) = Module.rank R M := by
  rw [finrank, cast_to_nat_of_lt_aleph_0 (rank_lt_aleph_0 R M)]
#align module.free.finrank_eq_rank Module.Free.finrank_eq_rank

/-- The finrank of a free module `M` over `R` is the cardinality of `choose_basis_index R M`. -/
theorem finrank_eq_card_chooseBasisIndex :
    finrank R M =
      @card (ChooseBasisIndex R M)
        (@ChooseBasisIndex.fintype R M _ _ _ _ (nontrivial_of_invariantBasisNumber R) _) :=
  by
  letI := nontrivial_of_invariantBasisNumber R
  simp [finrank, rank_eq_card_choose_basis_index]
#align module.free.finrank_eq_card_choose_basis_index Module.Free.finrank_eq_card_chooseBasisIndex

/-- The finrank of `(ι →₀ R)` is `fintype.card ι`. -/
@[simp]
theorem finrank_finsupp {ι : Type v} [Fintype ι] : finrank R (ι →₀ R) = card ι := by
  rw [finrank, rank_finsupp, ← mk_to_nat_eq_card, to_nat_lift]
#align module.free.finrank_finsupp Module.Free.finrank_finsupp

/-- The finrank of `(ι → R)` is `fintype.card ι`. -/
theorem finrank_pi {ι : Type v} [Fintype ι] : finrank R (ι → R) = card ι := by simp [finrank]
#align module.free.finrank_pi Module.Free.finrank_pi

/-- The finrank of the direct sum is the sum of the finranks. -/
@[simp]
theorem finrank_directSum {ι : Type v} [Fintype ι] (M : ι → Type w) [∀ i : ι, AddCommGroup (M i)]
    [∀ i : ι, Module R (M i)] [∀ i : ι, Module.Free R (M i)] [∀ i : ι, Module.Finite R (M i)] :
    finrank R (⨁ i, M i) = ∑ i, finrank R (M i) :=
  by
  letI := nontrivial_of_invariantBasisNumber R
  simp only [finrank, fun i => rank_eq_card_choose_basis_index R (M i), rank_direct_sum, ← mk_sigma,
    mk_to_nat_eq_card, card_sigma]
#align module.free.finrank_direct_sum Module.Free.finrank_directSum

/-- The finrank of `M × N` is `(finrank R M) + (finrank R N)`. -/
@[simp]
theorem finrank_prod : finrank R (M × N) = finrank R M + finrank R N := by
  simp [finrank, rank_lt_aleph_0 R M, rank_lt_aleph_0 R N]
#align module.free.finrank_prod Module.Free.finrank_prod

--TODO: this should follow from `linear_equiv.finrank_eq`, that is over a field.
/-- The finrank of a finite product is the sum of the finranks. -/
theorem finrank_pi_fintype {ι : Type v} [Fintype ι] {M : ι → Type w} [∀ i : ι, AddCommGroup (M i)]
    [∀ i : ι, Module R (M i)] [∀ i : ι, Module.Free R (M i)] [∀ i : ι, Module.Finite R (M i)] :
    finrank R (∀ i, M i) = ∑ i, finrank R (M i) :=
  by
  letI := nontrivial_of_invariantBasisNumber R
  simp only [finrank, fun i => rank_eq_card_choose_basis_index R (M i), rank_pi_finite, ← mk_sigma,
    mk_to_nat_eq_card, card_sigma]
#align module.free.finrank_pi_fintype Module.Free.finrank_pi_fintype

/-- If `m` and `n` are `fintype`, the finrank of `m × n` matrices is
  `(fintype.card m) * (fintype.card n)`. -/
theorem finrank_matrix (m n : Type v) [Fintype m] [Fintype n] :
    finrank R (Matrix m n R) = card m * card n := by simp [finrank]
#align module.free.finrank_matrix Module.Free.finrank_matrix

end Ring

section CommRing

variable [CommRing R] [StrongRankCondition R]

variable [AddCommGroup M] [Module R M] [Module.Free R M] [Module.Finite R M]

variable [AddCommGroup N] [Module R N] [Module.Free R N] [Module.Finite R N]

/-- The finrank of `M ⊗[R] N` is `(finrank R M) * (finrank R N)`. -/
@[simp]
theorem finrank_tensorProduct (M : Type v) (N : Type w) [AddCommGroup M] [Module R M]
    [Module.Free R M] [AddCommGroup N] [Module R N] [Module.Free R N] :
    finrank R (M ⊗[R] N) = finrank R M * finrank R N := by simp [finrank]
#align module.free.finrank_tensor_product Module.Free.finrank_tensorProduct

end CommRing

end Module.Free


/-
Copyright (c) 2014 Microsoft Corporation. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Leonardo de Moura
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.data.nat.basic
import Mathlib.Lean3Lib.init.data.prod

universes u l v

namespace Mathlib

inductive acc {α : Sort u} (r : α → α → Prop) : α → Prop where
| intro : ∀ (x : α), (∀ (y : α), r y x → acc r y) → acc r x

namespace acc

def inv {α : Sort u} {r : α → α → Prop} {x : α} {y : α} (h₁ : acc r x) (h₂ : r y x) : acc r y :=
  acc.rec_on h₁
    (fun (x₁ : α) (ac₁ : ∀ (y : α), r y x₁ → acc r y)
      (ih : ∀ (y_1 : α), r y_1 x₁ → r y y_1 → acc r y) (h₂ : r y x₁) => ac₁ y h₂)
    h₂

end acc

/-- A relation `r : α → α → Prop` is well-founded when `∀ x, (∀ y, r y x → P y → P x) → P x` for all predicates `P`.
Once you know that a relation is well_founded, you can use it to define fixpoint functions on `α`.-/
structure well_founded {α : Sort u} (r : α → α → Prop) where
  intro :: (apply : ∀ (a : α), acc r a)

class has_well_founded (α : Sort u) where
  r : α → α → Prop
  wf : well_founded r

namespace well_founded

def recursion {α : Sort u} {r : α → α → Prop} (hwf : well_founded r) {C : α → Sort v} (a : α)
    (h : (x : α) → ((y : α) → r y x → C y) → C x) : C a :=
  acc.rec_on (apply hwf a)
    fun (x₁ : α) (ac₁ : ∀ (y : α), r y x₁ → acc r y) (ih : (y : α) → r y x₁ → C y) => h x₁ ih

theorem induction {α : Sort u} {r : α → α → Prop} (hwf : well_founded r) {C : α → Prop} (a : α)
    (h : ∀ (x : α), (∀ (y : α), r y x → C y) → C x) : C a :=
  recursion hwf a h

def fix_F {α : Sort u} {r : α → α → Prop} {C : α → Sort v}
    (F : (x : α) → ((y : α) → r y x → C y) → C x) (x : α) (a : acc r x) : C x :=
  acc.rec_on a
    fun (x₁ : α) (ac₁ : ∀ (y : α), r y x₁ → acc r y) (ih : (y : α) → r y x₁ → C y) => F x₁ ih

theorem fix_F_eq {α : Sort u} {r : α → α → Prop} {C : α → Sort v}
    (F : (x : α) → ((y : α) → r y x → C y) → C x) (x : α) (acx : acc r x) :
    fix_F F x acx = F x fun (y : α) (p : r y x) => fix_F F y (acc.inv acx p) :=
  sorry

/-- Well-founded fixpoint -/
def fix {α : Sort u} {C : α → Sort v} {r : α → α → Prop} (hwf : well_founded r)
    (F : (x : α) → ((y : α) → r y x → C y) → C x) (x : α) : C x :=
  fix_F F x sorry

/-- Well-founded fixpoint satisfies fixpoint equation -/
theorem fix_eq {α : Sort u} {C : α → Sort v} {r : α → α → Prop} (hwf : well_founded r)
    (F : (x : α) → ((y : α) → r y x → C y) → C x) (x : α) :
    fix hwf F x = F x fun (y : α) (h : r y x) => fix hwf F y :=
  fix_F_eq F x (apply hwf x)

end well_founded

/-- Empty relation is well-founded -/
def empty_wf {α : Sort u} : well_founded empty_relation :=
  well_founded.intro fun (a : α) => acc.intro a fun (b : α) (lt : False) => False._oldrec lt

/- Subrelation of a well-founded relation is well-founded -/

namespace subrelation

def accessible {α : Sort u} {r : α → α → Prop} {Q : α → α → Prop} (h₁ : subrelation Q r) {a : α}
    (ac : acc r a) : acc Q a :=
  acc.rec_on ac
    fun (x : α) (ax : ∀ (y : α), r y x → acc r y) (ih : ∀ (y : α), r y x → acc Q y) =>
      acc.intro x fun (y : α) (lt : Q y x) => ih y (h₁ lt)

def wf {α : Sort u} {r : α → α → Prop} {Q : α → α → Prop} (h₁ : subrelation Q r)
    (h₂ : well_founded r) : well_founded Q :=
  well_founded.intro fun (a : α) => accessible h₁ (well_founded.apply h₂ a)

end subrelation

-- The inverse image of a well-founded relation is well-founded

namespace inv_image

def accessible {α : Sort u} {β : Sort v} {r : β → β → Prop} (f : α → β) {a : α} (ac : acc r (f a)) :
    acc (inv_image r f) a :=
  acc_aux f ac a rfl

def wf {α : Sort u} {β : Sort v} {r : β → β → Prop} (f : α → β) (h : well_founded r) :
    well_founded (inv_image r f) :=
  well_founded.intro fun (a : α) => accessible f (well_founded.apply h (f a))

end inv_image

-- The transitive closure of a well-founded relation is well-founded

namespace tc

def accessible {α : Sort u} {r : α → α → Prop} {z : α} (ac : acc r z) : acc (tc r) z :=
  acc.rec_on ac
    fun (x : α) (acx : ∀ (y : α), r y x → acc r y) (ih : ∀ (y : α), r y x → acc (tc r) y) =>
      acc.intro x
        fun (y : α) (rel : tc r y x) =>
          tc.rec_on rel
            (fun (a b : α) (rab : r a b) (acx : ∀ (y : α), r y b → acc r y)
              (ih : ∀ (y : α), r y b → acc (tc r) y) => ih a rab)
            (fun (a b c : α) (rab : tc r a b) (rbc : tc r b c)
              (ih₁ :
              (∀ (y : α), r y b → acc r y) → (∀ (y : α), r y b → acc (tc r) y) → acc (tc r) a)
              (ih₂ :
              (∀ (y : α), r y c → acc r y) → (∀ (y : α), r y c → acc (tc r) y) → acc (tc r) b)
              (acx : ∀ (y : α), r y c → acc r y) (ih : ∀ (y : α), r y c → acc (tc r) y) =>
              acc.inv (ih₂ acx ih) rab)
            acx ih

def wf {α : Sort u} {r : α → α → Prop} (h : well_founded r) : well_founded (tc r) :=
  well_founded.intro fun (a : α) => accessible (well_founded.apply h a)

end tc

/-- less-than is well-founded -/
def nat.lt_wf : well_founded nat.lt :=
  well_founded.intro
    (Nat.rec (acc.intro 0 fun (n : ℕ) (h : n < 0) => absurd h (nat.not_lt_zero n))
      fun (n : ℕ) (ih : acc Less n) =>
        acc.intro (Nat.succ n)
          fun (m : ℕ) (h : m < Nat.succ n) =>
            or.elim (nat.eq_or_lt_of_le (nat.le_of_succ_le_succ h))
              (fun (e : m = n) => eq.substr e ih) (acc.inv ih))

def measure {α : Sort u} : (α → ℕ) → α → α → Prop := inv_image Less

def measure_wf {α : Sort u} (f : α → ℕ) : well_founded (measure f) := inv_image.wf f nat.lt_wf

def sizeof_measure (α : Sort u) [SizeOf α] : α → α → Prop := measure sizeof

def sizeof_measure_wf (α : Sort u) [SizeOf α] : well_founded (sizeof_measure α) := measure_wf sizeof

protected instance has_well_founded_of_has_sizeof (α : Sort u) [SizeOf α] : has_well_founded α :=
  has_well_founded.mk (sizeof_measure α) (sizeof_measure_wf α)

namespace prod

inductive lex {α : Type u} {β : Type v} (ra : α → α → Prop) (rb : β → β → Prop) :
    α × β → α × β → Prop
    where
| left : ∀ {a₁ : α} (b₁ : β) {a₂ : α} (b₂ : β), ra a₁ a₂ → lex ra rb (a₁, b₁) (a₂, b₂)
| right : ∀ (a : α) {b₁ b₂ : β}, rb b₁ b₂ → lex ra rb (a, b₁) (a, b₂)

inductive rprod {α : Type u} {β : Type v} (ra : α → α → Prop) (rb : β → β → Prop) :
    α × β → α × β → Prop
    where
| intro : ∀ {a₁ : α} {b₁ : β} {a₂ : α} {b₂ : β}, ra a₁ a₂ → rb b₁ b₂ → rprod ra rb (a₁, b₁) (a₂, b₂)

def lex_accessible {α : Type u} {β : Type v} {ra : α → α → Prop} {rb : β → β → Prop} {a : α}
    (aca : acc ra a) (acb : ∀ (b : β), acc rb b) (b : β) : acc (lex ra rb) (a, b) :=
  acc.rec_on aca
    fun (xa : α) (aca : ∀ (y : α), ra y xa → acc ra y)
      (iha : ∀ (y : α), ra y xa → ∀ (b : β), acc (lex ra rb) (y, b)) (b : β) =>
      acc.rec_on (acb b)
        fun (xb : β) (acb : ∀ (y : β), rb y xb → acc rb y)
          (ihb : ∀ (y : β), rb y xb → acc (lex ra rb) (xa, y)) =>
          acc.intro (xa, xb)
            fun (p : α × β) (lt : lex ra rb p (xa, xb)) =>
              (fun (aux : xa = xa → xb = xb → acc (lex ra rb) p) => aux rfl rfl)
                (lex.rec_on lt
                  (fun (a₁ : α) (b₁ : β) (a₂ : α) (b₂ : β) (h : ra a₁ a₂) (eq₂ : a₂ = xa)
                    (eq₃ : b₂ = xb) => iha a₁ (eq.rec_on eq₂ h) b₁)
                  fun (a : α) (b₁ b₂ : β) (h : rb b₁ b₂) (eq₂ : a = xa) (eq₃ : b₂ = xb) =>
                    eq.rec_on (Eq.symm eq₂) (ihb b₁ (eq.rec_on eq₃ h)))

def lex_wf {α : Type u} {β : Type v} {ra : α → α → Prop} {rb : β → β → Prop} (ha : well_founded ra)
    (hb : well_founded rb) : well_founded (lex ra rb) :=
  well_founded.intro
    fun (p : α × β) =>
      cases_on p
        fun (a : α) (b : β) => lex_accessible (well_founded.apply ha a) (well_founded.apply hb) b

def rprod_sub_lex {α : Type u} {β : Type v} {ra : α → α → Prop} {rb : β → β → Prop} (a : α × β)
    (b : α × β) : rprod ra rb a b → lex ra rb a b :=
  fun (h : rprod ra rb a b) =>
    rprod.rec_on h
      fun (a₁ : α) (b₁ : β) (a₂ : α) (b₂ : β) (h₁ : ra a₁ a₂) (h₂ : rb b₁ b₂) => lex.left b₁ b₂ h₁

def rprod_wf {α : Type u} {β : Type v} {ra : α → α → Prop} {rb : β → β → Prop}
    (ha : well_founded ra) (hb : well_founded rb) : well_founded (rprod ra rb) :=
  subrelation.wf rprod_sub_lex (lex_wf ha hb)

protected instance has_well_founded {α : Type u} {β : Type v} [s₁ : has_well_founded α]
    [s₂ : has_well_founded β] : has_well_founded (α × β) :=
  has_well_founded.mk (lex has_well_founded.r has_well_founded.r) sorry

end Mathlib


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov
-/
import topology.algebra.monoid
import group_theory.group_action.prod
import group_theory.group_action.basic
import topology.homeomorph
import topology.algebra.mul_action2

/-!
# Continuous monoid action

In this file we define class `has_continuous_smul`. We say `has_continuous_smul M α` if `M` acts on
`α` and the map `(c, x) ↦ c • x` is continuous on `M × α`. We reuse this class for topological
(semi)modules, vector spaces and algebras.

## Main definitions

* `has_continuous_smul M α` : typeclass saying that the map `(c, x) ↦ c • x` is continuous
  on `M × α`;
* `homeomorph.smul_of_ne_zero`: if a group with zero `G₀` (e.g., a field) acts on `α` and `c : G₀`
  is a nonzero element of `G₀`, then scalar multiplication by `c` is a homeomorphism of `α`;
* `homeomorph.smul`: scalar multiplication by an element of a group `G` acting on `α`
  is a homeomorphism of `α`.
* `units.has_continuous_smul`: scalar multiplication by `Mˣ` is continuous when scalar
  multiplication by `M` is continuous. This allows `homeomorph.smul` to be used with on monoids
  with `G = Mˣ`.

## Main results

Besides homeomorphisms mentioned above, in this file we provide lemmas like `continuous.smul`
or `filter.tendsto.smul` that provide dot-syntax access to `continuous_smul`.
-/

open_locale topological_space pointwise
open filter

/-- Class `has_continuous_smul M α` says that the scalar multiplication `(•) : M → α → α`
is continuous in both arguments. We use the same class for all kinds of multiplicative actions,
including (semi)modules and algebras. -/
class has_continuous_smul (M α : Type*) [has_scalar M α]
  [topological_space M] [topological_space α] : Prop :=
(continuous_smul : continuous (λp : M × α, p.1 • p.2))

export has_continuous_smul (continuous_smul)

/-- Class `has_continuous_vadd M α` says that the additive action `(+ᵥ) : M → α → α`
is continuous in both arguments. We use the same class for all kinds of additive actions,
including (semi)modules and algebras. -/
class has_continuous_vadd (M α : Type*) [has_vadd M α]
  [topological_space M] [topological_space α] : Prop :=
(continuous_vadd : continuous (λp : M × α, p.1 +ᵥ p.2))

export has_continuous_vadd (continuous_vadd)

attribute [to_additive] has_continuous_smul

variables {M α β : Type*} [topological_space M] [topological_space α]

section has_scalar

variables [has_scalar M α] [has_continuous_smul M α]

@[priority 100, to_additive] instance has_continuous_smul.has_continuous_smul₂ :
  has_continuous_smul₂ M α :=
{ continuous_smul₂ := λ _, continuous_smul.comp (continuous_const.prod_mk continuous_id) }

@[to_additive]
lemma filter.tendsto.smul {f : β → M} {g : β → α} {l : filter β} {c : M} {a : α}
  (hf : tendsto f l (𝓝 c)) (hg : tendsto g l (𝓝 a)) :
  tendsto (λ x, f x • g x) l (𝓝 $ c • a) :=
(continuous_smul.tendsto _).comp (hf.prod_mk_nhds hg)

@[to_additive]
lemma filter.tendsto.const_smul {f : β → α} {l : filter β} {a : α} (hf : tendsto f l (𝓝 a))
  (c : M) :
  tendsto (λ x, c • f x) l (𝓝 (c • a)) :=
tendsto_const_nhds.smul hf

@[to_additive]
lemma filter.tendsto.smul_const {f : β → M} {l : filter β} {c : M}
  (hf : tendsto f l (𝓝 c)) (a : α) :
  tendsto (λ x, (f x) • a) l (𝓝 (c • a)) :=
hf.smul tendsto_const_nhds

variables [topological_space β] {f : β → M} {g : β → α} {b : β} {s : set β}

@[to_additive]
lemma continuous_within_at.smul (hf : continuous_within_at f s b)
  (hg : continuous_within_at g s b) :
  continuous_within_at (λ x, f x • g x) s b :=
hf.smul hg

@[to_additive]
lemma continuous_within_at.const_smul (hg : continuous_within_at g s b) (c : M) :
  continuous_within_at (λ x, c • g x) s b :=
hg.const_smul c

@[to_additive]
lemma continuous_at.smul (hf : continuous_at f b) (hg : continuous_at g b) :
  continuous_at (λ x, f x • g x) b :=
hf.smul hg

@[to_additive]
lemma continuous_at.const_smul (hg : continuous_at g b) (c : M) :
  continuous_at (λ x, c • g x) b :=
hg.const_smul c

@[to_additive]
lemma continuous_on.smul (hf : continuous_on f s) (hg : continuous_on g s) :
  continuous_on (λ x, f x • g x) s :=
λ x hx, (hf x hx).smul (hg x hx)

@[to_additive]
lemma continuous_on.const_smul (hg : continuous_on g s) (c : M) :
  continuous_on (λ x, c • g x) s :=
λ x hx, (hg x hx).const_smul c

@[continuity, to_additive]
lemma continuous.smul (hf : continuous f) (hg : continuous g) :
  continuous (λ x, f x • g x) :=
continuous_smul.comp (hf.prod_mk hg)

@[to_additive]
lemma continuous.const_smul (hg : continuous g) (c : M) :
  continuous (λ x, c • g x) :=
continuous_smul.comp (continuous_const.prod_mk hg)

/-- If a scalar is central, then its right action is continuous when its left action is. -/
instance has_continuous_smul.op [has_scalar Mᵐᵒᵖ α] [is_central_scalar M α] :
  has_continuous_smul Mᵐᵒᵖ α :=
⟨ suffices continuous (λ p : M × α, mul_opposite.op p.fst • p.snd),
  from this.comp (continuous_unop.prod_map continuous_id),
  by simpa only [op_smul_eq_smul] using (continuous_smul : continuous (λ p : M × α, _)) ⟩

end has_scalar

section monoid

variables [monoid M] [mul_action M α] [has_continuous_smul M α]

instance units.has_continuous_smul : has_continuous_smul Mˣ α :=
{ continuous_smul :=
    show continuous ((λ p : M × α, p.fst • p.snd) ∘ (λ p : Mˣ × α, (p.1, p.2))),
    from continuous_smul.comp ((units.continuous_coe.comp continuous_fst).prod_mk continuous_snd) }

@[to_additive]
lemma smul_closure_subset (c : M) (s : set α) : c • closure s ⊆ closure (c • s) :=
((set.maps_to_image _ _).closure $ continuous_id.const_smul c).image_subset

@[to_additive]
lemma smul_closure_orbit_subset (c : M) (x : α) :
  c • closure (mul_action.orbit M x) ⊆ closure (mul_action.orbit M x) :=
(smul_closure_subset c _).trans $ closure_mono $ mul_action.smul_orbit_subset _ _

end monoid

section group

variables {G : Type*} [topological_space G] [group G] [mul_action G α]
  [has_continuous_smul G α]

@[to_additive]
lemma tendsto_const_smul_iff {f : β → α} {l : filter β} {a : α} (c : G) :
  tendsto (λ x, c • f x) l (𝓝 $ c • a) ↔ tendsto f l (𝓝 a) :=
⟨λ h, by simpa only [inv_smul_smul] using h.const_smul c⁻¹,
  λ h, h.const_smul _⟩

variables [topological_space β] {f : β → α} {b : β}  {s : set β}

@[to_additive]
lemma continuous_within_at_const_smul_iff (c : G) :
  continuous_within_at (λ x, c • f x) s b ↔ continuous_within_at f s b :=
tendsto_const_smul_iff c

@[to_additive]
lemma continuous_on_const_smul_iff (c : G) : continuous_on (λ x, c • f x) s ↔ continuous_on f s :=
forall₂_congr $ λ b hb, continuous_within_at_const_smul_iff c

@[to_additive]
lemma continuous_at_const_smul_iff (c : G) :
  continuous_at (λ x, c • f x) b ↔ continuous_at f b :=
tendsto_const_smul_iff c

@[to_additive]
lemma continuous_const_smul_iff (c : G) :
  continuous (λ x, c • f x) ↔ continuous f :=
by simp only [continuous_iff_continuous_at, continuous_at_const_smul_iff]

@[to_additive]
lemma is_open_map_smul (c : G) : is_open_map (λ x : α, c • x) :=
(homeomorph.smul c).is_open_map

@[to_additive] lemma is_open.smul {s : set α} (hs : is_open s) (c : G) : is_open (c • s) :=
is_open_map_smul c s hs

@[to_additive]
lemma is_closed_map_smul (c : G) : is_closed_map (λ x : α, c • x) :=
(homeomorph.smul c).is_closed_map

@[to_additive] lemma is_closed.smul {s : set α} (hs : is_closed s) (c : G) : is_closed (c • s) :=
is_closed_map_smul c s hs

end group

section group_with_zero

variables {G₀ : Type*} [topological_space G₀] [group_with_zero G₀] [mul_action G₀ α]
  [has_continuous_smul G₀ α]

lemma tendsto_const_smul_iff₀ {f : β → α} {l : filter β} {a : α} {c : G₀} (hc : c ≠ 0) :
  tendsto (λ x, c • f x) l (𝓝 $ c • a) ↔ tendsto f l (𝓝 a) :=
tendsto_const_smul_iff (units.mk0 c hc)

variables [topological_space β] {f : β → α} {b : β} {c : G₀} {s : set β}

lemma continuous_within_at_const_smul_iff₀ (hc : c ≠ 0) :
  continuous_within_at (λ x, c • f x) s b ↔ continuous_within_at f s b :=
tendsto_const_smul_iff (units.mk0 c hc)

lemma continuous_on_const_smul_iff₀ (hc : c ≠ 0) :
  continuous_on (λ x, c • f x) s ↔ continuous_on f s :=
continuous_on_const_smul_iff (units.mk0 c hc)

lemma continuous_at_const_smul_iff₀ (hc : c ≠ 0) :
  continuous_at (λ x, c • f x) b ↔ continuous_at f b :=
continuous_at_const_smul_iff (units.mk0 c hc)

lemma continuous_const_smul_iff₀ (hc : c ≠ 0) :
  continuous (λ x, c • f x) ↔ continuous f :=
continuous_const_smul_iff (units.mk0 c hc)

/-- Scalar multiplication by a non-zero element of a group with zero acting on `α` is a
homeomorphism from `α` onto itself. -/
protected def homeomorph.smul_of_ne_zero (c : G₀) (hc : c ≠ 0) : α ≃ₜ α :=
homeomorph.smul (units.mk0 c hc)

lemma is_open_map_smul₀ {c : G₀} (hc : c ≠ 0) : is_open_map (λ x : α, c • x) :=
(homeomorph.smul_of_ne_zero c hc).is_open_map

lemma is_open.smul₀ {c : G₀} {s : set α} (hs : is_open s) (hc : c ≠ 0) : is_open (c • s) :=
is_open_map_smul₀ hc s hs

lemma interior_smul₀ {c : G₀} (hc : c ≠ 0) (s : set α) : interior (c • s) = c • interior s :=
((homeomorph.smul_of_ne_zero c hc).image_interior s).symm

/-- `smul` is a closed map in the second argument.

The lemma that `smul` is a closed map in the first argument (for a normed space over a complete
normed field) is `is_closed_map_smul_left` in `analysis.normed_space.finite_dimension`. -/
lemma is_closed_map_smul_of_ne_zero {c : G₀} (hc : c ≠ 0) : is_closed_map (λ x : α, c • x) :=
(homeomorph.smul_of_ne_zero c hc).is_closed_map

/-- `smul` is a closed map in the second argument.

The lemma that `smul` is a closed map in the first argument (for a normed space over a complete
normed field) is `is_closed_map_smul_left` in `analysis.normed_space.finite_dimension`. -/
lemma is_closed_map_smul₀ {𝕜 M : Type*} [division_ring 𝕜] [add_comm_monoid M] [topological_space M]
  [t1_space M] [module 𝕜 M] [topological_space 𝕜] [has_continuous_smul 𝕜 M] (c : 𝕜) :
  is_closed_map (λ x : M, c • x) :=
begin
  rcases eq_or_ne c 0 with (rfl|hne),
  { simp only [zero_smul], exact is_closed_map_const },
  { exact (homeomorph.smul_of_ne_zero c hne).is_closed_map },
end

end group_with_zero

namespace is_unit

variables [monoid M] [mul_action M α] [has_continuous_smul M α]

lemma tendsto_const_smul_iff {f : β → α} {l : filter β} {a : α} {c : M} (hc : is_unit c) :
  tendsto (λ x, c • f x) l (𝓝 $ c • a) ↔ tendsto f l (𝓝 a) :=
let ⟨u, hu⟩ := hc in hu ▸ tendsto_const_smul_iff u

variables [topological_space β] {f : β → α} {b : β} {c : M} {s : set β}

lemma continuous_within_at_const_smul_iff (hc : is_unit c) :
  continuous_within_at (λ x, c • f x) s b ↔ continuous_within_at f s b :=
let ⟨u, hu⟩ := hc in hu ▸ continuous_within_at_const_smul_iff u

lemma continuous_on_const_smul_iff (hc : is_unit c) :
  continuous_on (λ x, c • f x) s ↔ continuous_on f s :=
let ⟨u, hu⟩ := hc in hu ▸ continuous_on_const_smul_iff u

lemma continuous_at_const_smul_iff (hc : is_unit c) :
  continuous_at (λ x, c • f x) b ↔ continuous_at f b :=
let ⟨u, hu⟩ := hc in hu ▸ continuous_at_const_smul_iff u

lemma continuous_const_smul_iff (hc : is_unit c) :
  continuous (λ x, c • f x) ↔ continuous f :=
let ⟨u, hu⟩ := hc in hu ▸ continuous_const_smul_iff u

lemma is_open_map_smul (hc : is_unit c) : is_open_map (λ x : α, c • x) :=
let ⟨u, hu⟩ := hc in hu ▸ is_open_map_smul u

lemma is_closed_map_smul (hc : is_unit c) : is_closed_map (λ x : α, c • x) :=
let ⟨u, hu⟩ := hc in hu ▸ is_closed_map_smul u

end is_unit

@[to_additive]
instance has_continuous_mul.has_continuous_smul {M : Type*} [monoid M]
  [topological_space M] [has_continuous_mul M] :
  has_continuous_smul M M :=
⟨continuous_mul⟩

@[to_additive]
instance [topological_space β] [has_scalar M α] [has_scalar M β] [has_continuous_smul M α]
  [has_continuous_smul M β] :
  has_continuous_smul M (α × β) :=
⟨(continuous_fst.smul (continuous_fst.comp continuous_snd)).prod_mk
  (continuous_fst.smul (continuous_snd.comp continuous_snd))⟩

@[to_additive]
instance {ι : Type*} {γ : ι → Type*}
  [∀ i, topological_space (γ i)] [Π i, has_scalar M (γ i)] [∀ i, has_continuous_smul M (γ i)] :
  has_continuous_smul M (Π i, γ i) :=
⟨continuous_pi $ λ i,
  (continuous_fst.smul continuous_snd).comp $
    continuous_fst.prod_mk ((continuous_apply i).comp continuous_snd)⟩

section lattice_ops

variables {ι : Type*} [has_scalar M β]
  {ts : set (topological_space β)} (h : Π t ∈ ts, @has_continuous_smul M β _ _ t)
  {ts' : ι → topological_space β} (h' : Π i, @has_continuous_smul M β _ _ (ts' i))
  {t₁ t₂ : topological_space β} [h₁ : @has_continuous_smul M β _ _ t₁]
  [h₂ : @has_continuous_smul M β _ _ t₂]

include h

@[to_additive] lemma has_continuous_smul_Inf :
  @has_continuous_smul M β _ _ (Inf ts) :=
{ continuous_smul :=
  begin
    rw ← @Inf_singleton _ _ ‹topological_space M›,
    exact continuous_Inf_rng (λ t ht, continuous_Inf_dom₂ (eq.refl _) ht
      (@has_continuous_smul.continuous_smul _ _ _ _ t (h t ht)))
  end }

omit h

include h'

@[to_additive] lemma has_continuous_smul_infi :
  @has_continuous_smul M β _ _ (⨅ i, ts' i) :=
by {rw ← Inf_range, exact has_continuous_smul_Inf (set.forall_range_iff.mpr h')}

omit h'

include h₁ h₂

@[to_additive] lemma has_continuous_smul_inf :
  @has_continuous_smul M β _ _ (t₁ ⊓ t₂) :=
by {rw inf_eq_infi, refine has_continuous_smul_infi (λ b, _), cases b; assumption}

omit h₁ h₂

end lattice_ops


/-
Copyright (c) 2020 Aaron Anderson, Jalex Stark. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Author: Aaron Anderson, Jalex Stark.
-/

import linear_algebra.char_poly
import linear_algebra.matrix
import ring_theory.polynomial.basic
import data.zmod.basic
import number_theory.quadratic_reciprocity
import tactic.squeeze
import data.polynomial
import algebra.polynomial.basic
import algebra.polynomial.big_operators
import field_theory.separable

noncomputable theory

universes u_1 u_2 u_3 u_4

open polynomial matrix
open_locale big_operators

variables {R : Type u_1} [comm_ring R]
variables {n : Type u_2} [fintype n] [decidable_eq n]
variables {α : Type u_2} [decidable_eq α]

open finset
open polynomial

section fixed_points

lemma gt_one_nonfixed_point_of_nonrefl {σ : equiv.perm n} (h : σ ≠ equiv.refl n) :
1 < (filter (λ (x : n), ¬ σ x = x) univ).card :=
begin
  rw one_lt_card_iff,
  contrapose! h, ext, dsimp,
  have := h (σ x) x, simp only [true_and, mem_filter, equiv.apply_eq_iff_eq, mem_univ, ne.def] at this,
  tauto,
end

lemma lt_card_sub_one_fixed_point_of_nonrefl {σ : equiv.perm n} (h : σ ≠ equiv.refl n) :
(filter (λ (x : n), σ x = x) univ).card < fintype.card n - 1:=
begin
  have hun := @filter_union_filter_neg_eq _ (λ (x : n), σ x = x) _ _ _ univ,
  have hin : (filter (λ (x : n), σ x = x) univ) ∩ (filter (λ (x : n), ¬ σ x = x) univ) = ∅
    := filter_inter_filter_neg_eq univ,
  rw ← disjoint_iff_inter_eq_empty at hin,
  rw fintype.card, conv_rhs { rw ← hun },
  rw card_disjoint_union hin,
  have := gt_one_nonfixed_point_of_nonrefl h, omega,
end

end fixed_points

variable {M : matrix n n R}

lemma nat_degree_char_matrix_val [nontrivial R] (i j : n) :
  (char_matrix M i j).nat_degree = ite (i = j) 1 0 :=
by { by_cases i = j, simp [h, ← degree_eq_iff_nat_degree_eq_of_pos (nat.succ_pos 0)], simp [h], }

lemma nat_degree_char_matrix_val_le (i j : n) :
  (char_matrix M i j).nat_degree ≤ ite (i = j) 1 0 :=
begin
  by_cases i = j, swap, simp [h],
  rw [if_pos h, h, char_matrix_apply_eq], apply nat_degree_X_sub_C_le,
end

variable (M)
lemma low_degree_char_poly_sub_diagonal :
(char_poly M - ∏ (i : n), (X - C (M i i))).degree < ↑(fintype.card n - 1) :=
begin
  rw [char_poly, det, ← insert_erase (mem_univ (equiv.refl n)),
    sum_insert (not_mem_erase (equiv.refl n) univ), add_comm],
  simp only [char_matrix_apply_eq, one_mul, equiv.perm.sign_refl, id.def, int.cast_one,
    units.coe_one, add_sub_cancel, equiv.coe_refl],
  rw ← mem_degree_lt, apply submodule.sum_mem (degree_lt R (fintype.card n - 1)),
  intros c hc, rw [← C_eq_int_cast, C_mul'],
  apply submodule.smul_mem (degree_lt R (fintype.card n - 1)) ↑↑(equiv.perm.sign c),
  rw mem_degree_lt, apply lt_of_le_of_lt degree_le_nat_degree _, rw with_bot.coe_lt_coe,
  apply lt_of_le_of_lt _ (lt_card_sub_one_fixed_point_of_nonrefl (ne_of_mem_erase hc)),
  apply le_trans (polynomial.nat_degree_prod_le univ (λ i : n, (char_matrix M (c i) i))) _,
  rw card_eq_sum_ones, rw sum_filter, apply sum_le_sum,
  intros, apply nat_degree_char_matrix_val_le,
end

lemma high_coeff_char_poly_eq_coeff_prod_diag {k : ℕ} (h : fintype.card n - 1 ≤ k) :
  (char_poly M).coeff k = (univ.prod (λ (i : n), X - C (M i i))).coeff k :=
begin
  apply eq_of_sub_eq_zero, rw ← coeff_sub, apply polynomial.coeff_eq_zero_of_degree_lt,
  apply lt_of_lt_of_le (low_degree_char_poly_sub_diagonal M) _, rw with_bot.coe_le_coe, apply h,
end

lemma det_of_dim_zero (h : fintype.card n = 0) (M : matrix n n R) : M.det = 1 :=
begin
  rw fintype.card_eq_zero_iff at h,
  have hone : M = 1, ext, exfalso, apply h i, rw hone, simp,
end

theorem degree_char_poly_eq_dim [nontrivial R] (M: matrix n n R) :
(char_poly M).degree = fintype.card n :=
begin
  by_cases fintype.card n = 0, rw h, unfold char_poly, rw det_of_dim_zero, simpa,
  rw ← sub_add_cancel (char_poly M) (∏ (i : n), (X - C (M i i))),
  have h1 : (∏ (i : n), (X - C (M i i))).degree = fintype.card n,
  { rw degree_eq_iff_nat_degree_eq_of_pos, swap, apply nat.pos_of_ne_zero h,
    rw nat_degree_prod_eq', simp_rw nat_degree_X_sub_C, unfold fintype.card, simp,
    simp_rw (monic_X_sub_C _).leading_coeff, simp, },
  rw degree_add_eq_of_degree_lt, exact h1, rw h1,
  apply lt_trans (low_degree_char_poly_sub_diagonal M), rw with_bot.coe_lt_coe,
  rw ← nat.pred_eq_sub_one, apply nat.pred_lt, apply h,
end

theorem nat_degree_char_poly_eq_dim [nontrivial R] (M: matrix n n R) :
  (char_poly M).nat_degree = fintype.card n :=
nat_degree_eq_of_degree_eq_some (degree_char_poly_eq_dim M)

lemma char_poly_monic_of_nontrivial [nontrivial R] (M : matrix n n R):
  monic (char_poly M):=
begin
  by_cases fintype.card n = 0, rw [char_poly, det_of_dim_zero h], apply monic_one,
  have mon : (∏ (i : n), (X - C (M i i))).monic,
  { apply monic_prod_of_monic univ (λ i : n, (X - C (M i i))), simp [monic_X_sub_C], },
  rw ← sub_add_cancel (∏ (i : n), (X - C (M i i))) (char_poly M) at mon,
  rw monic at *, rw leading_coeff_add_of_degree_lt at mon, rw ← mon,
  rw degree_char_poly_eq_dim, rw ← neg_sub, rw degree_neg,
  apply lt_trans (low_degree_char_poly_sub_diagonal M), rw with_bot.coe_lt_coe,
  rw ← nat.pred_eq_sub_one, apply nat.pred_lt, apply h,
end

lemma char_poly_monic (M : matrix n n R):
  monic (char_poly M):=
begin
  classical,
  by_cases h : nontrivial R,
  { apply @char_poly_monic_of_nontrivial _ _ _ _ _ h, },
  { unfold monic, rw nontrivial_iff at h, push_neg at h, apply h, }
end

--shouldn't need these instances, but might need casework
theorem trace_from_char_poly [nontrivial R] [inhabited n] (M: matrix n n R) :
(matrix.trace n R R) M = -(char_poly M).coeff (fintype.card n - 1) :=
begin
  rw high_coeff_char_poly_eq_coeff_prod_diag, swap, refl,
  rw [fintype.card, card_pred_coeff_prod_X_sub_C univ (λ i : n, M i i)], simp,
  rw [← fintype.card, fintype.card_pos_iff], apply_instance,
end

lemma ring_hom_det {S : Type u_1} [comm_ring S] {M : matrix n n R} {f : R →+* S} :
  f M.det = matrix.det (f.map_matrix M) :=
by { unfold matrix.det, simp [f.map_sum, f.map_prod] }

lemma alg_hom_det {S : Type u_1} [comm_ring S] [algebra R S] {T : Type u_1} [comm_ring T] [algebra R T]
  {M : matrix n n S} {f : S →ₐ[R] T} :
  f M.det = matrix.det ((f : S →+* T).map_matrix M) :=
by { rw [← alg_hom.coe_to_ring_hom, ring_hom_det], }

lemma matrix.scalar.commute (r : R) (M : matrix n n R) : commute (scalar n r) M :=
by { unfold commute, unfold semiconj_by, simp }

-- I feel like this should use polynomial.alg_hom_eval₂_algebra_map
lemma eval_mat_poly_equiv (M : matrix n n (polynomial R)) (r : R) (i j : n) :
  polynomial.eval r (M i j) = polynomial.eval ((scalar n) r) (mat_poly_equiv M) i j :=
begin
  unfold polynomial.eval, unfold eval₂,
  transitivity finsupp.sum (mat_poly_equiv M) (λ (e : ℕ) (a : matrix n n R),
    (a * (scalar n) r ^ e) i j),
  { simp_rw ← (scalar n).map_pow, simp_rw ← (matrix.scalar.commute _ _).eq,
    simp only [coe_scalar, matrix.one_mul, ring_hom.id_apply,
      smul_val, mul_eq_mul, algebra.smul_mul_assoc],
    have h : ∀ x : ℕ, (λ (e : ℕ) (a : R), r ^ e * a) x 0 = 0 := by simp,
    rw ← finsupp.sum_map_range_index h, swap, refl,
    refine congr (congr rfl _) (by {ext, rw mul_comm}), ext, rw finsupp.map_range_apply,
    simp [apply_eq_coeff], },
  { unfold finsupp.sum, rw sum_apply, rw sum_apply, dsimp, refl, }
end

lemma eval_det (M : matrix n n (polynomial R)) (r : R) :
  polynomial.eval r M.det = (polynomial.eval (matrix.scalar n r) (mat_poly_equiv M)).det :=
begin
  rw [polynomial.eval, ← coe_eval₂_ring_hom, ring_hom_det], refine congr rfl _,
  rw [ring_hom.map_matrix_apply, coe_eval₂_ring_hom, ← polynomial.eval],
  ext, apply eval_mat_poly_equiv,
end

theorem det_from_char_poly (M: matrix n n R) :
M.det = (-1)^(fintype.card n) * (char_poly M).coeff 0:=
begin
  rw [coeff_zero_eq_eval_zero, char_poly, eval_det, mat_poly_equiv_char_matrix, ← det_smul],
  simp
end

section char_p

lemma matrix.scalar_inj [inhabited n] {r s : R} : scalar n r = scalar n s ↔ r = s :=
begin
  split; intro h, rw [← scalar_apply_eq r (arbitrary n), ← scalar_apply_eq s (arbitrary n), h],
  rw h,
end

instance matrix.char_p [inhabited n] (p : ℕ) [char_p R p] : char_p (matrix n n R) p :=
{ cast_eq_zero_iff :=
  begin
    intro k, rw ← char_p.cast_eq_zero_iff R p k,
    rw ← nat.cast_zero, repeat {rw ← (scalar n).map_nat_cast},
    rw matrix.scalar_inj, refl,
  end }

lemma det_pow (k : ℕ) (M : matrix n n R) :
(M ^ k).det = (M.det) ^ k :=
begin
  induction k with k hk, simp,
  repeat {rw pow_succ}, rw ← hk, simp,
end

--lemma comp_det (p : polynomial R) (M : matrix n n (polynomial R)) :
--  (M.det).comp p = matrix.det (λ i j : n, (M i j).comp p) :=
--by { unfold comp, rw ← coe_eval₂_ring_hom, rw ring_hom_det }

variables (p : ℕ) [fact p.prime]

lemma frobenius_fixed (a : zmod p): a ^ p = a :=
begin
  have posp : 0 < p, { apply nat.prime.pos, assumption, },
  by_cases a = 0, rw h, rw zero_pow posp,
  conv_rhs {rw ← one_mul a, rw ← pow_one a}, rw ← zmod.fermat_little p h,
  rw ← pow_add, refine congr rfl _, symmetry, apply nat.succ_pred_eq_of_pos posp,
end

lemma zmod.expand_p (f : polynomial (zmod p)) :
expand (zmod p) p f = f ^ p :=
begin
  apply f.induction_on', intros a b ha hb, rw add_pow_char, simp [ha, hb], assumption,
  intros n a, rw polynomial.expand_monomial, repeat {rw single_eq_C_mul_X},
  rw [mul_pow, ← C.map_pow, frobenius_fixed p a], ring_exp,
end

@[simp]
lemma empty_matrix_eq_zero {R : Type*} [ring R] (hn : ¬ nonempty n) (M : matrix n n R) :
M = 0 :=
begin
  ext, contrapose! hn, use i,
end

theorem sub_pow_char_of_commute (R : Type u_1) [ring R] {p : ℕ} [fact p.prime]
  [char_p R p] (x y : R) (h : commute x y):
(x - y)^p = x^p - y^p :=
begin
  rw [eq_sub_iff_add_eq, ← add_pow_char_of_commute], simp,
  unfold commute, unfold semiconj_by, rw [sub_mul, mul_sub, h.eq],
end

lemma char_poly_pow_p_char_p (M : matrix n n (zmod p)) :
char_poly (M ^ p) = char_poly M :=
begin
  classical,
  by_cases hn : nonempty n, letI := hn, haveI : inhabited n := by { inhabit n, assumption },
  clear _inst_1 hn,
  swap, { congr, rw empty_matrix_eq_zero hn M, apply empty_matrix_eq_zero hn },

  apply frobenius_inj (polynomial (zmod p)) p, repeat {rw frobenius_def},
  rw ← zmod.expand_p,
  unfold char_poly, rw alg_hom_det, rw ← det_pow, refine congr rfl _,
  unfold char_matrix,
  transitivity ((scalar n) X - C.map_matrix M) ^ p, swap, sorry,
  rw sub_pow_char_of_commute, swap, apply matrix.scalar.commute, rw ← C.map_matrix.map_pow, rw ← (scalar n).map_pow,
  ext, refine congr (congr rfl _) rfl, by_cases i = j; simp [h], sorry,
  {
    refine congr rfl _, refine congr (congr _ rfl) rfl,
    refine congr (congr _ rfl) rfl, sorry,
  }
end

end char_p


import .core galois.temporal.temporal order.complete_lattice

universes u

open temporal lattice

namespace sequent

instance subset_complete_lattice {A : Type u} : complete_lattice (subset A)
:= begin
apply lattice.complete_lattice_fun,
end

instance subset_cha {A : Type u} : cha (subset A)
:= begin
constructor, tactic.rotate 2, apply_instance,
constructor,
intros P Q, exact (λ x, P x → Q x),
intros, intros x Γx Px,
apply a, split; assumption,
intros, intros x ΓPx, induction ΓPx with Γx Px,
apply a; assumption
end

instance tProp_cha {T : Type u} : cha (tProp T)
  := sequent.subset_cha

lemma tautology {T : Type u} {A : tProp T}
  (H : rlist.nil ⊢ A)
  : ⊩ A
:= begin
intros tr, apply H, constructor,
end

lemma tautology_iff {T : Type u} {A : tProp T}
  : (rlist.nil ⊢ A) ↔ (⊩ A)
:= begin
split; intros H,
intros tr, apply H, constructor,
intros x Hx, apply H,
end

inductive formula (T : Type) (vTy : Type) : Type
| var {} : vTy → formula
| top {} : formula
| bot {} : formula
| and {} : formula → formula → formula
| or {} : formula → formula → formula
| always {} : formula → formula
| eventually {} : formula → formula

namespace formula
def interp {T : Type} {vTy : Type} (ctxt : vTy → tProp T)
  : formula T vTy → tProp T
| (var x) := ctxt x
| top := ⊤
| bot := ⊥
| (and P Q) := interp P ⊓ interp Q
| (or P Q) := interp P ⊔ interp Q
| (always P) := □ (interp P)
| (eventually P) := ◇ (interp P)
end formula

instance formula_decidable_eq {T : Type} {vTy : Type}
  [decidable_eq vTy] : decidable_eq (formula T vTy)
  := by tactic.mk_dec_eq_instance

def formula_entails {T : Type} {vTy : Type}
  (Γ : rlist (formula T vTy)) (A : formula T vTy)
  := ∀ ctxt, Γ.map (formula.interp ctxt) ⊢ A.interp ctxt

def interp_impl {T : Type} {vTy : Type}
  (Γ : rlist (formula T vTy)) (A : formula T vTy) (ctxt : vTy → tProp T)
  : formula_entails Γ A → Γ.map (formula.interp ctxt) ⊢ A.interp ctxt
:= begin
intros H, apply H,
end

def formula_entails_auto {T : Type} {vTy : Type}
  [decidable_eq vTy]
  (Γ : rlist (formula T vTy))
  : ∀ A : formula T vTy, option (plift (formula_entails Γ A))
| formula.top := some (plift.up
  begin
  dsimp [formula_entails, formula.interp], intros ctxt,
  apply @entails_top _ sequent.tProp_cha,
   end)
| formula.bot := none
| (formula.and P Q) := do
  plift.up HP ← formula_entails_auto P,
  plift.up HQ ← formula_entails_auto Q,
  some (plift.up begin
  unfold formula_entails, intros,
  dsimp [formula.interp],
  apply @split _ sequent.tProp_cha, apply HP, apply HQ,
  end)
| (formula.or P Q) := (do
  plift.up HP ← formula_entails_auto P,
  some (plift.up (begin
     intros x, dsimp [formula.interp],
     apply @left _ sequent.tProp_cha, apply HP
     end)))
  <|>
  (do
  plift.up HQ ← formula_entails_auto Q,
  some (plift.up (begin
     intros x, dsimp [formula.interp],
     apply @right _ sequent.tProp_cha, apply HQ
     end)))
| x := if H : x ∈ Γ then some (plift.up begin
     intros ctxt, apply @assumption _ sequent.tProp_cha,
     apply rlist.map_mem, assumption
  end) else none

meta def intern_var (xs : list expr) (e : expr) : list expr × ℕ
  := (if e ∈ xs then xs else xs ++ [e], xs.index_of e)

meta def reify_helper
  : list expr → expr → tactic (expr ff × list expr)
| xs `(@lattice.has_top.top %%TT %%Tc) := pure (``(formula.top), xs)
| xs `(@lattice.has_bot.bot %%TT %%Tc) := pure (``(formula.bot), xs)
| xs `(always %%P) := do
    (P', xs') ← reify_helper xs P,
    pure (``(formula.always %%P'), xs')
| xs `(eventually %%P) := do
    (P', xs') ← reify_helper xs P,
    pure (``(formula.eventually %%P'), xs')
| xs `(%%P ⊓ %%Q) := do
    (P', xs') ← reify_helper xs P,
    (Q', xs'') ← reify_helper xs' Q,
    pure (``(formula.and %%P' %%Q'), xs'')
| xs `(%%P ⊔ %%Q) := do
    (P', xs') ← reify_helper xs P,
    (Q', xs'') ← reify_helper xs' Q,
    pure (``(formula.or %%P' %%Q'), xs'')
| xs P := let (xs', n) := intern_var xs P in pure (``(formula.var %%(n.reflect)), xs')

meta def reify_all_helper (e : expr)
  : list expr → list expr → tactic (list (expr ff) × expr ff × list expr)
| ctxt [] := do
  (e', ctxt') ← reify_helper ctxt e,
  pure ([], e', ctxt')
| ctxt (x :: xs) := do
  (x', ctxt') ← reify_helper ctxt x,
  (xs', e', ctxt'') ← reify_all_helper ctxt' xs,
  pure (x' :: xs', e', ctxt'')

meta def reify (es : list expr) (e : expr)
  : tactic (list (expr ff) × expr ff × list expr)
  := reify_all_helper e [] es

end sequent

namespace tactic.interactive
namespace sequent

open tactic lean lean.parser
open interactive interactive.types expr

meta def get_rlist : expr → tactic (list expr)
| `(rlist.snoc %%xs %%x) := do
   xs' ← get_rlist xs,
   pure (x :: xs')
| `(rlist.nil) := pure []
| _ := tactic.fail "uh-oh"

meta def make_list : list expr → expr ff
| [] := ``(list.nil)
| (x :: xs) := ``(list.cons %%x %%(make_list xs))

meta def make_rlist : list (expr ff) → expr ff
| [] := ``(rlist.nil)
| (x :: xs) := ``(rlist.snoc %%(make_rlist xs) %%x)

def list.nth_def {α : Type u} (xs : list α) (default : α) (n : ℕ) : α
:= match xs.nth n with
| (some x) := x
| none := default
end

meta def on_sequent_goal {A} (f : expr → expr → tactic A)
  : tactic A := do
  tgt ← target,
  tgt' ← instantiate_mvars tgt,
  match tgt' with
  | `(%%Γ ⊢ %%P) := f Γ P
  | _ := tactic.fail "not a logical entailment"
  end

meta def reify_goal : tactic unit :=
  on_sequent_goal $ λ xs P, do
    ty ← infer_type P >>= whnf,
    xs' ← get_rlist xs,
    (xs', P', ctxt) ← sequent.reify xs' P,
    let ctxt' := make_list ctxt,
    let xs'' := make_rlist xs',
    xs''' ← i_to_expr xs'',
    P'' ← i_to_expr P',
    ctxtf ← i_to_expr ``(list.nth_def %%ctxt' ⊥),
    e ← i_to_expr ``(sequent.interp_impl %%xs''' %%P'' %%ctxtf),
    tactic.apply e

meta def entails_tactic (e : parse texpr) : tactic unit := do
  tgt ← target,
  tgt' ← instantiate_mvars tgt,
  match tgt' with
  | `(sequent.formula_entails %%Γ %%A) := do
    e' ← i_to_expr ``(%%e %%Γ %%A) >>= whnf,
    match e' with
    | `(some (plift.up %%x)) := tactic.apply x
    | _ := tactic.fail "Didn't get some"
    end
  | _ := tactic.fail "not a formula entailment"
  end

meta def intros := repeat (apply ``(sequent.intro _))
meta def revert := apply ``(sequent.revert _)
meta def left := apply ``(sequent.left _)
meta def right := apply ``(sequent.right _)
meta def split := apply ``(sequent.split _ _)
meta def prove_mem :=
  apply ``(rlist.mem.here) <|> (do apply ``(rlist.mem.there), prove_mem)
meta def assumption := do
  apply ``(sequent.assumption _),
  prove_mem
meta def apply (e : parse texpr) := do
  on_sequent_goal $ λ Γ P, do
    tactic.interactive.apply ``(sequent.apply_lemma %%Γ %%P %%e),
    repeat tactic.constructor

meta def assert (e : parse texpr) := do
  on_sequent_goal $ λ Γ P, do
    tactic.interactive.apply ``(sequent.cut %%Γ %%P %%e)

end sequent
end tactic.interactive


/-
Copyright (c) 2017 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Stephen Morgan, Scott Morrison
-/
import category_theory.equivalence

/-!
# Opposite categories

We provide a category instance on `Cᵒᵖ`.
The morphisms `X ⟶ Y` are defined to be the morphisms `unop Y ⟶ unop X` in `C`.

Here `Cᵒᵖ` is an irreducible typeclass synonym for `C`
(it is the same one used in the algebra library).

We also provide various mechanisms for constructing opposite morphisms, functors,
and natural transformations.

Unfortunately, because we do not have a definitional equality `op (op X) = X`,
there are quite a few variations that are needed in practice.
-/

universes v₁ v₂ u₁ u₂ -- morphism levels before object levels. See note [category_theory universes].

open opposite

variables {C : Type u₁}

section quiver

variables [quiver.{v₁} C]

lemma quiver.hom.op_inj {X Y : C} :
  function.injective (quiver.hom.op : (X ⟶ Y) → (op Y ⟶ op X)) :=
λ _ _ H, congr_arg quiver.hom.unop H

lemma quiver.hom.unop_inj {X Y : Cᵒᵖ} :
  function.injective (quiver.hom.unop : (X ⟶ Y) → (unop Y ⟶ unop X)) :=
λ _ _ H, congr_arg quiver.hom.op H

@[simp] lemma quiver.hom.unop_op {X Y : C} (f : X ⟶ Y) : f.op.unop = f := rfl
@[simp] lemma quiver.hom.op_unop {X Y : Cᵒᵖ} (f : X ⟶ Y) : f.unop.op = f := rfl

end quiver

namespace category_theory

variables [category.{v₁} C]

/--
The opposite category.

See https://stacks.math.columbia.edu/tag/001M.
-/
instance category.opposite : category.{v₁} Cᵒᵖ :=
{ comp := λ _ _ _ f g, (g.unop ≫ f.unop).op,
  id   := λ X, (𝟙 (unop X)).op }

@[simp] lemma op_comp {X Y Z : C} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).op = g.op ≫ f.op := rfl
@[simp] lemma op_id {X : C} : (𝟙 X).op = 𝟙 (op X) := rfl

@[simp] lemma unop_comp {X Y Z : Cᵒᵖ} {f : X ⟶ Y} {g : Y ⟶ Z} :
  (f ≫ g).unop = g.unop ≫ f.unop := rfl
@[simp] lemma unop_id {X : Cᵒᵖ} : (𝟙 X).unop = 𝟙 (unop X) := rfl

@[simp] lemma unop_id_op {X : C} : (𝟙 (op X)).unop = 𝟙 X := rfl
@[simp] lemma op_id_unop {X : Cᵒᵖ} : (𝟙 (unop X)).op = 𝟙 X := rfl

section
variables (C)

/-- The functor from the double-opposite of a category to the underlying category. -/
@[simps]
def op_op : (Cᵒᵖ)ᵒᵖ ⥤ C :=
{ obj := λ X, unop (unop X),
  map := λ X Y f, f.unop.unop }

/-- The functor from a category to its double-opposite.  -/
@[simps]
def unop_unop : C ⥤ Cᵒᵖᵒᵖ :=
{ obj := λ X, op (op X),
  map := λ X Y f, f.op.op }

/-- The double opposite category is equivalent to the original. -/
@[simps]
def op_op_equivalence : Cᵒᵖᵒᵖ ≌ C :=
{ functor := op_op C,
  inverse := unop_unop C,
  unit_iso := iso.refl (𝟭 Cᵒᵖᵒᵖ),
  counit_iso := iso.refl (unop_unop C ⋙ op_op C) }

end

/-- If `f` is an isomorphism, so is `f.op` -/
instance is_iso_op {X Y : C} (f : X ⟶ Y) [is_iso f] : is_iso f.op :=
⟨⟨(inv f).op,
  ⟨quiver.hom.unop_inj (by tidy), quiver.hom.unop_inj (by tidy)⟩⟩⟩

/--
If `f.op` is an isomorphism `f` must be too.
(This cannot be an instance as it would immediately loop!)
-/
lemma is_iso_of_op {X Y : C} (f : X ⟶ Y) [is_iso f.op] : is_iso f :=
⟨⟨(inv (f.op)).unop,
  ⟨quiver.hom.op_inj (by simp), quiver.hom.op_inj (by simp)⟩⟩⟩

@[simp] lemma op_inv {X Y : C} (f : X ⟶ Y) [f_iso : is_iso f] : (inv f).op = inv f.op :=
by { ext, rw [← op_comp, is_iso.inv_hom_id, op_id] }

namespace functor

section

variables {D : Type u₂} [category.{v₂} D]

variables {C D}

/--
The opposite of a functor, i.e. considering a functor `F : C ⥤ D` as a functor `Cᵒᵖ ⥤ Dᵒᵖ`.
In informal mathematics no distinction is made between these.
-/
@[simps]
protected def op (F : C ⥤ D) : Cᵒᵖ ⥤ Dᵒᵖ :=
{ obj := λ X, op (F.obj (unop X)),
  map := λ X Y f, (F.map f.unop).op }

/--
Given a functor `F : Cᵒᵖ ⥤ Dᵒᵖ` we can take the "unopposite" functor `F : C ⥤ D`.
In informal mathematics no distinction is made between these.
-/
@[simps]
protected def unop (F : Cᵒᵖ ⥤ Dᵒᵖ) : C ⥤ D :=
{ obj := λ X, unop (F.obj (op X)),
  map := λ X Y f, (F.map f.op).unop }

/-- The isomorphism between `F.op.unop` and `F`. -/
@[simps] def op_unop_iso (F : C ⥤ D) : F.op.unop ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

/-- The isomorphism between `F.unop.op` and `F`. -/
@[simps] def unop_op_iso (F : Cᵒᵖ ⥤ Dᵒᵖ) : F.unop.op ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

variables (C D)

/--
Taking the opposite of a functor is functorial.
-/
@[simps]
def op_hom : (C ⥤ D)ᵒᵖ ⥤ (Cᵒᵖ ⥤ Dᵒᵖ) :=
{ obj := λ F, (unop F).op,
  map := λ F G α,
  { app := λ X, (α.unop.app (unop X)).op,
    naturality' := λ X Y f, quiver.hom.unop_inj (α.unop.naturality f.unop).symm } }

/--
Take the "unopposite" of a functor is functorial.
-/
@[simps]
def op_inv : (Cᵒᵖ ⥤ Dᵒᵖ) ⥤ (C ⥤ D)ᵒᵖ :=
{ obj := λ F, op F.unop,
  map := λ F G α, quiver.hom.op
  { app := λ X, (α.app (op X)).unop,
    naturality' := λ X Y f, quiver.hom.op_inj $ (α.naturality f.op).symm } }

variables {C D}

/--
Another variant of the opposite of functor, turning a functor `C ⥤ Dᵒᵖ` into a functor `Cᵒᵖ ⥤ D`.
In informal mathematics no distinction is made.
-/
@[simps]
protected def left_op (F : C ⥤ Dᵒᵖ) : Cᵒᵖ ⥤ D :=
{ obj := λ X, unop (F.obj (unop X)),
  map := λ X Y f, (F.map f.unop).unop }

/--
Another variant of the opposite of functor, turning a functor `Cᵒᵖ ⥤ D` into a functor `C ⥤ Dᵒᵖ`.
In informal mathematics no distinction is made.
-/
@[simps]
protected def right_op (F : Cᵒᵖ ⥤ D) : C ⥤ Dᵒᵖ :=
{ obj := λ X, op (F.obj (op X)),
  map := λ X Y f, (F.map f.op).op }

instance {F : C ⥤ D} [full F] : full F.op :=
{ preimage := λ X Y f, (F.preimage f.unop).op }

instance {F : C ⥤ D} [faithful F] : faithful F.op :=
{ map_injective' := λ X Y f g h,
    quiver.hom.unop_inj $ by simpa using map_injective F (quiver.hom.op_inj h) }

/-- If F is faithful then the right_op of F is also faithful. -/
instance right_op_faithful {F : Cᵒᵖ ⥤ D} [faithful F] : faithful F.right_op :=
{ map_injective' := λ X Y f g h, quiver.hom.op_inj (map_injective F (quiver.hom.op_inj h)) }

/-- If F is faithful then the left_op of F is also faithful. -/
instance left_op_faithful {F : C ⥤ Dᵒᵖ} [faithful F] : faithful F.left_op :=
{ map_injective' := λ X Y f g h, quiver.hom.unop_inj (map_injective F (quiver.hom.unop_inj h)) }

/-- The isomorphism between `F.left_op.right_op` and `F`. -/
@[simps]
def left_op_right_op_iso (F : C ⥤ Dᵒᵖ) : F.left_op.right_op ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

/-- The isomorphism between `F.right_op.left_op` and `F`. -/
@[simps]
def right_op_left_op_iso (F : Cᵒᵖ ⥤ D) : F.right_op.left_op ≅ F :=
nat_iso.of_components (λ X, iso.refl _) (by tidy)

end

end functor

namespace nat_trans

variables {D : Type u₂} [category.{v₂} D]

section
variables {F G : C ⥤ D}

/-- The opposite of a natural transformation. -/
@[simps] protected def op (α : F ⟶ G) : G.op ⟶ F.op :=
{ app         := λ X, (α.app (unop X)).op,
  naturality' := begin tidy, simp_rw [← op_comp, α.naturality] end }

@[simp] lemma op_id (F : C ⥤ D) : nat_trans.op (𝟙 F) = 𝟙 (F.op) := rfl

/-- The "unopposite" of a natural transformation. -/
@[simps] protected def unop {F G : Cᵒᵖ ⥤ Dᵒᵖ} (α : F ⟶ G) : G.unop ⟶ F.unop :=
{ app         := λ X, (α.app (op X)).unop,
  naturality' := begin tidy, simp_rw [← unop_comp, α.naturality] end }

@[simp] lemma unop_id (F : Cᵒᵖ ⥤ Dᵒᵖ) : nat_trans.unop (𝟙 F) = 𝟙 (F.unop) := rfl

/--
Given a natural transformation `α : F.op ⟶ G.op`,
we can take the "unopposite" of each component obtaining a natural transformation `G ⟶ F`.
-/
@[simps] protected def remove_op (α : F.op ⟶ G.op) : G ⟶ F :=
{ app         := λ X, (α.app (op X)).unop,
  naturality' :=
  begin
    intros X Y f,
    have := congr_arg quiver.hom.unop (α.naturality f.op),
    dsimp at this,
    rw this,
  end }

@[simp] lemma remove_op_id (F : C ⥤ D) : nat_trans.remove_op (𝟙 F.op) = 𝟙 F := rfl

end

section
variables {F G H : C ⥤ Dᵒᵖ}

/--
Given a natural transformation `α : F ⟶ G`, for `F G : C ⥤ Dᵒᵖ`,
taking `unop` of each component gives a natural transformation `G.left_op ⟶ F.left_op`.
-/
@[simps] protected def left_op (α : F ⟶ G) : G.left_op ⟶ F.left_op :=
{ app         := λ X, (α.app (unop X)).unop,
  naturality' := begin
    intros X Y f,
    dsimp,
    simp_rw [← unop_comp, α.naturality]
  end }

@[simp] lemma left_op_id : (𝟙 F : F ⟶ F).left_op = 𝟙 F.left_op := rfl

@[simp] lemma left_op_comp (α : F ⟶ G) (β : G ⟶ H) :
  (α ≫ β).left_op = β.left_op ≫ α.left_op := rfl

/--
Given a natural transformation `α : F.left_op ⟶ G.left_op`, for `F G : C ⥤ Dᵒᵖ`,
taking `op` of each component gives a natural transformation `G ⟶ F`.
-/
@[simps] protected def remove_left_op (α : F.left_op ⟶ G.left_op) : G ⟶ F :=
{ app         := λ X, (α.app (op X)).op,
  naturality' :=
  begin
    intros X Y f,
    have := congr_arg quiver.hom.op (α.naturality f.op),
    dsimp at this,
    erw this
  end }

end

section
variables {F G H : Cᵒᵖ ⥤ D}

/--
Given a natural transformation `α : F ⟶ G`, for `F G : Cᵒᵖ ⥤ D`,
taking `op` of each component gives a natural transformation `G.right_op ⟶ F.right_op`.
-/
@[simps] protected def right_op (α : F ⟶ G) : G.right_op ⟶ F.right_op :=
{ app := λ X, (α.app _).op,
  naturality' := begin
    intros X Y f,
    dsimp,
    simp_rw [← op_comp, α.naturality]
  end }

@[simp] lemma right_op_id : (𝟙 F : F ⟶ F).right_op = 𝟙 F.right_op := rfl

@[simp] lemma right_op_comp (α : F ⟶ G) (β : G ⟶ H) :
  (α ≫ β).right_op = β.right_op ≫ α.right_op := rfl

/--
Given a natural transformation `α : F.right_op ⟶ G.right_op`, for `F G : Cᵒᵖ ⥤ D`,
taking `unop` of each component gives a natural transformation `G ⟶ F`.
-/
@[simps] protected def remove_right_op (α : F.right_op ⟶ G.right_op) : G ⟶ F :=
{ app := λ X, (α.app X.unop).unop,
  naturality' := begin
    intros X Y f,
    have := congr_arg quiver.hom.unop (α.naturality f.unop),
    dsimp at this,
    erw this,
  end }

end
end nat_trans

namespace iso

variables {X Y : C}

/--
The opposite isomorphism.
-/
@[simps]
protected def op (α : X ≅ Y) : op Y ≅ op X :=
{ hom := α.hom.op,
  inv := α.inv.op,
  hom_inv_id' := quiver.hom.unop_inj α.inv_hom_id,
  inv_hom_id' := quiver.hom.unop_inj α.hom_inv_id }

/-- The isomorphism obtained from an isomorphism in the opposite category. -/
@[simps] def unop {X Y : Cᵒᵖ} (f : X ≅ Y) : Y.unop ≅ X.unop :=
{ hom := f.hom.unop,
  inv := f.inv.unop,
  hom_inv_id' := by simp only [← unop_comp, f.inv_hom_id, unop_id],
  inv_hom_id' := by simp only [← unop_comp, f.hom_inv_id, unop_id] }

@[simp] lemma unop_op {X Y : Cᵒᵖ} (f : X ≅ Y) : f.unop.op = f :=
by ext; refl

@[simp] lemma op_unop {X Y : C} (f : X ≅ Y) : f.op.unop = f :=
by ext; refl

end iso

namespace nat_iso

variables {D : Type u₂} [category.{v₂} D]
variables {F G : C ⥤ D}

/-- The natural isomorphism between opposite functors `G.op ≅ F.op` induced by a natural
isomorphism between the original functors `F ≅ G`. -/
@[simps] protected def op (α : F ≅ G) : G.op ≅ F.op :=
{ hom := nat_trans.op α.hom,
  inv := nat_trans.op α.inv,
  hom_inv_id' := begin ext, dsimp, rw ←op_comp, rw α.inv_hom_id_app, refl, end,
  inv_hom_id' := begin ext, dsimp, rw ←op_comp, rw α.hom_inv_id_app, refl, end }

/-- The natural isomorphism between functors `G ≅ F` induced by a natural isomorphism
between the opposite functors `F.op ≅ G.op`. -/
@[simps] protected def remove_op (α : F.op ≅ G.op) : G ≅ F :=
{ hom := nat_trans.remove_op α.hom,
  inv := nat_trans.remove_op α.inv,
  hom_inv_id' := begin ext, dsimp, rw ←unop_comp, rw α.inv_hom_id_app, refl, end,
  inv_hom_id' := begin ext, dsimp, rw ←unop_comp, rw α.hom_inv_id_app, refl, end }

/-- The natural isomorphism between functors `G.unop ≅ F.unop` induced by a natural isomorphism
between the original functors `F ≅ G`. -/
@[simps] protected def unop {F G : Cᵒᵖ ⥤ Dᵒᵖ} (α : F ≅ G) : G.unop ≅ F.unop :=
{ hom := nat_trans.unop α.hom,
  inv := nat_trans.unop α.inv,
  hom_inv_id' := begin ext, dsimp, rw ←unop_comp, rw α.inv_hom_id_app, refl, end,
  inv_hom_id' := begin ext, dsimp, rw ←unop_comp, rw α.hom_inv_id_app, refl, end }

end nat_iso

namespace equivalence

variables {D : Type u₂} [category.{v₂} D]

/--
An equivalence between categories gives an equivalence between the opposite categories.
-/
@[simps]
def op (e : C ≌ D) : Cᵒᵖ ≌ Dᵒᵖ :=
{ functor := e.functor.op,
  inverse := e.inverse.op,
  unit_iso := (nat_iso.op e.unit_iso).symm,
  counit_iso := (nat_iso.op e.counit_iso).symm,
  functor_unit_iso_comp' := λ X, by { apply quiver.hom.unop_inj, dsimp, simp, }, }

/--
An equivalence between opposite categories gives an equivalence between the original categories.
-/
@[simps]
def unop (e : Cᵒᵖ ≌ Dᵒᵖ) : C ≌ D :=
{ functor := e.functor.unop,
  inverse := e.inverse.unop,
  unit_iso := (nat_iso.unop e.unit_iso).symm,
  counit_iso := (nat_iso.unop e.counit_iso).symm,
  functor_unit_iso_comp' := λ X, by { apply quiver.hom.op_inj, dsimp, simp, }, }

end equivalence

/-- The equivalence between arrows of the form `A ⟶ B` and `B.unop ⟶ A.unop`. Useful for building
adjunctions.
Note that this (definitionally) gives variants
```
def op_equiv' (A : C) (B : Cᵒᵖ) : (opposite.op A ⟶ B) ≃ (B.unop ⟶ A) :=
op_equiv _ _

def op_equiv'' (A : Cᵒᵖ) (B : C) : (A ⟶ opposite.op B) ≃ (B ⟶ A.unop) :=
op_equiv _ _

def op_equiv''' (A B : C) : (opposite.op A ⟶ opposite.op B) ≃ (B ⟶ A) :=
op_equiv _ _
```
-/
@[simps] def op_equiv (A B : Cᵒᵖ) : (A ⟶ B) ≃ (B.unop ⟶ A.unop) :=
{ to_fun := λ f, f.unop,
  inv_fun := λ g, g.op,
  left_inv := λ _, rfl,
  right_inv := λ _, rfl }

instance subsingleton_of_unop (A B : Cᵒᵖ) [subsingleton (unop B ⟶ unop A)] : subsingleton (A ⟶ B) :=
(op_equiv A B).subsingleton

instance decidable_eq_of_unop (A B : Cᵒᵖ) [decidable_eq (unop B ⟶ unop A)] : decidable_eq (A ⟶ B) :=
(op_equiv A B).decidable_eq

namespace functor

variables (C)
variables (D : Type u₂) [category.{v₂} D]

/--
The equivalence of functor categories induced by `op` and `unop`.
-/
@[simps]
def op_unop_equiv : (C ⥤ D)ᵒᵖ ≌ Cᵒᵖ ⥤ Dᵒᵖ :=
{ functor := op_hom _ _,
  inverse := op_inv _ _,
  unit_iso := nat_iso.of_components (λ F, F.unop.op_unop_iso.op) begin
    intros F G f,
    dsimp [op_unop_iso],
    rw [(show f = f.unop.op, by simp), ← op_comp, ← op_comp],
    congr' 1,
    tidy,
  end,
  counit_iso := nat_iso.of_components (λ F, F.unop_op_iso) (by tidy) }.

/--
The equivalence of functor categories induced by `left_op` and `right_op`.
-/
@[simps]
def left_op_right_op_equiv : (Cᵒᵖ ⥤ D)ᵒᵖ ≌ (C ⥤ Dᵒᵖ) :=
{ functor :=
  { obj := λ F, F.unop.right_op,
    map := λ F G η, η.unop.right_op },
  inverse :=
  { obj := λ F, op F.left_op,
    map := λ F G η, η.left_op.op },
  unit_iso := nat_iso.of_components (λ F, F.unop.right_op_left_op_iso.op) begin
    intros F G η,
    dsimp,
    rw [(show η = η.unop.op, by simp), ← op_comp, ← op_comp],
    congr' 1,
    tidy,
  end,
  counit_iso := nat_iso.of_components (λ F, F.left_op_right_op_iso) (by tidy) }

end functor

end category_theory


/-
Copyright (c) 2018 Alexander Bentkamp. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Alexander Bentkamp
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.module.pi
import Mathlib.algebra.big_operators.basic
import Mathlib.PostPort

universes u u_1

namespace Mathlib

/-!
# Basic properties of holors

Holors are indexed collections of tensor coefficients. Confusingly,
they are often called tensors in physics and in the neural network
community.

A holor is simply a multidimensional array of values. The size of a
holor is specified by a `list ℕ`, whose length is called the dimension
of the holor.

The tensor product of `x₁ : holor α ds₁` and `x₂ : holor α ds₂` is the
holor given by `(x₁ ⊗ x₂) (i₁ ++ i₂) = x₁ i₁ * x₂ i₂`. A holor is "of
rank at most 1" if it is a tensor product of one-dimensional holors.
The CP rank of a holor `x` is the smallest N such that `x` is the sum
of N holors of rank at most 1.

Based on the tensor library found in <https://www.isa-afp.org/entries/Deep_Learning.html>

## References

* <https://en.wikipedia.org/wiki/Tensor_rank_decomposition>
-/

/-- `holor_index ds` is the type of valid index tuples to identify an entry of a holor of dimensions `ds` -/
def holor_index (ds : List ℕ) := Subtype fun (is : List ℕ) => list.forall₂ Less is ds

namespace holor_index

def take {ds₂ : List ℕ} {ds₁ : List ℕ} : holor_index (ds₁ ++ ds₂) → holor_index ds₁ := sorry

def drop {ds₂ : List ℕ} {ds₁ : List ℕ} : holor_index (ds₁ ++ ds₂) → holor_index ds₂ := sorry

theorem cast_type {ds₁ : List ℕ} {ds₂ : List ℕ} (is : List ℕ) (eq : ds₁ = ds₂)
    (h : list.forall₂ Less is ds₁) :
    subtype.val (cast (congr_arg holor_index eq) { val := is, property := h }) = is :=
  eq.drec
    (Eq.refl
      (subtype.val (cast (congr_arg holor_index (Eq.refl ds₁)) { val := is, property := h })))
    eq

def assoc_right {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} :
    holor_index (ds₁ ++ ds₂ ++ ds₃) → holor_index (ds₁ ++ (ds₂ ++ ds₃)) :=
  cast sorry

def assoc_left {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} :
    holor_index (ds₁ ++ (ds₂ ++ ds₃)) → holor_index (ds₁ ++ ds₂ ++ ds₃) :=
  cast sorry

theorem take_take {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ}
    (t : holor_index (ds₁ ++ ds₂ ++ ds₃)) : take (assoc_right t) = take (take t) :=
  sorry

theorem drop_take {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ}
    (t : holor_index (ds₁ ++ ds₂ ++ ds₃)) : take (drop (assoc_right t)) = drop (take t) :=
  sorry

theorem drop_drop {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ}
    (t : holor_index (ds₁ ++ ds₂ ++ ds₃)) : drop (drop (assoc_right t)) = drop t :=
  sorry

end holor_index

/-- Holor (indexed collections of tensor coefficients) -/
def holor (α : Type u) (ds : List ℕ) := holor_index ds → α

namespace holor

protected instance inhabited {α : Type} {ds : List ℕ} [Inhabited α] : Inhabited (holor α ds) :=
  { default := fun (t : holor_index ds) => Inhabited.default }

protected instance has_zero {α : Type} {ds : List ℕ} [HasZero α] : HasZero (holor α ds) :=
  { zero := fun (t : holor_index ds) => 0 }

protected instance has_add {α : Type} {ds : List ℕ} [Add α] : Add (holor α ds) :=
  { add := fun (x y : holor α ds) (t : holor_index ds) => x t + y t }

protected instance has_neg {α : Type} {ds : List ℕ} [Neg α] : Neg (holor α ds) :=
  { neg := fun (a : holor α ds) (t : holor_index ds) => -a t }

protected instance add_semigroup {α : Type} {ds : List ℕ} [add_semigroup α] :
    add_semigroup (holor α ds) :=
  add_semigroup.mk
    (fun (ᾰ ᾰ_1 : holor α ds) =>
      id fun (ᾰ_2 : holor_index ds) => add_semigroup.add (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2))
    sorry

protected instance add_comm_semigroup {α : Type} {ds : List ℕ} [add_comm_semigroup α] :
    add_comm_semigroup (holor α ds) :=
  add_comm_semigroup.mk
    (fun (ᾰ ᾰ_1 : holor α ds) =>
      id fun (ᾰ_2 : holor_index ds) => add_comm_semigroup.add (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2))
    sorry sorry

protected instance add_monoid {α : Type} {ds : List ℕ} [add_monoid α] : add_monoid (holor α ds) :=
  add_monoid.mk
    (fun (ᾰ ᾰ_1 : holor α ds) => id fun (ᾰ_2 : holor_index ds) => add_monoid.add (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2))
    sorry (id fun (ᾰ : holor_index ds) => add_monoid.zero) sorry sorry

protected instance add_comm_monoid {α : Type} {ds : List ℕ} [add_comm_monoid α] :
    add_comm_monoid (holor α ds) :=
  add_comm_monoid.mk
    (fun (ᾰ ᾰ_1 : holor α ds) =>
      id fun (ᾰ_2 : holor_index ds) => add_comm_monoid.add (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2))
    sorry (id fun (ᾰ : holor_index ds) => add_comm_monoid.zero) sorry sorry sorry

protected instance add_group {α : Type} {ds : List ℕ} [add_group α] : add_group (holor α ds) :=
  add_group.mk
    (fun (ᾰ ᾰ_1 : holor α ds) => id fun (ᾰ_2 : holor_index ds) => add_group.add (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2))
    sorry (id fun (ᾰ : holor_index ds) => add_group.zero) sorry sorry
    (fun (ᾰ : holor α ds) => id fun (ᾰ_1 : holor_index ds) => add_group.neg (ᾰ ᾰ_1))
    (fun (ᾰ ᾰ_1 : holor α ds) => id fun (ᾰ_2 : holor_index ds) => add_group.sub (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2))
    sorry

protected instance add_comm_group {α : Type} {ds : List ℕ} [add_comm_group α] :
    add_comm_group (holor α ds) :=
  add_comm_group.mk
    (fun (ᾰ ᾰ_1 : holor α ds) =>
      id fun (ᾰ_2 : holor_index ds) => add_comm_group.add (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2))
    sorry (id fun (ᾰ : holor_index ds) => add_comm_group.zero) sorry sorry
    (fun (ᾰ : holor α ds) => id fun (ᾰ_1 : holor_index ds) => add_comm_group.neg (ᾰ ᾰ_1))
    (fun (ᾰ ᾰ_1 : holor α ds) =>
      id fun (ᾰ_2 : holor_index ds) => add_comm_group.sub (ᾰ ᾰ_2) (ᾰ_1 ᾰ_2))
    sorry sorry

/- scalar product -/

protected instance has_scalar {α : Type} {ds : List ℕ} [Mul α] : has_scalar α (holor α ds) :=
  has_scalar.mk fun (a : α) (x : holor α ds) (t : holor_index ds) => a * x t

protected instance semimodule {α : Type} {ds : List ℕ} [semiring α] : semimodule α (holor α ds) :=
  pi.semimodule (holor_index ds) (fun (ᾰ : holor_index ds) => α) α

/-- The tensor product of two holors. -/
def mul {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} [s : Mul α] (x : holor α ds₁) (y : holor α ds₂) :
    holor α (ds₁ ++ ds₂) :=
  fun (t : holor_index (ds₁ ++ ds₂)) => x (holor_index.take t) * y (holor_index.drop t)

theorem cast_type {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} (eq : ds₁ = ds₂) (a : holor α ds₁) :
    cast (congr_arg (holor α) eq) a =
        fun (t : holor_index ds₂) => a (cast (congr_arg holor_index (Eq.symm eq)) t) :=
  eq.drec (Eq.refl (cast (congr_arg (holor α) (Eq.refl ds₁)) a)) eq

def assoc_right {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} :
    holor α (ds₁ ++ ds₂ ++ ds₃) → holor α (ds₁ ++ (ds₂ ++ ds₃)) :=
  cast sorry

def assoc_left {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} :
    holor α (ds₁ ++ (ds₂ ++ ds₃)) → holor α (ds₁ ++ ds₂ ++ ds₃) :=
  cast sorry

theorem mul_assoc0 {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} [semigroup α]
    (x : holor α ds₁) (y : holor α ds₂) (z : holor α ds₃) :
    mul (mul x y) z = assoc_left (mul x (mul y z)) :=
  sorry

theorem mul_assoc {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} {ds₃ : List ℕ} [semigroup α]
    (x : holor α ds₁) (y : holor α ds₂) (z : holor α ds₃) : mul (mul x y) z == mul x (mul y z) :=
  sorry

theorem mul_left_distrib {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} [distrib α] (x : holor α ds₁)
    (y : holor α ds₂) (z : holor α ds₂) : mul x (y + z) = mul x y + mul x z :=
  funext
    fun (t : holor_index (ds₁ ++ ds₂)) =>
      left_distrib (x (holor_index.take t)) (y (holor_index.drop t)) (z (holor_index.drop t))

theorem mul_right_distrib {α : Type} {ds₁ : List ℕ} {ds₂ : List ℕ} [distrib α] (x : holor α ds₁)
    (y : holor α ds₁) (z : holor α ds₂) : mul (x + y) z = mul x z + mul y z :=
  funext
    fun (t : holor_index (ds₁ ++ ds₂)) =>
      right_distrib (x (holor_index.take t)) (y (holor_index.take t)) (z (holor_index.drop t))

@[simp] theorem zero_mul {ds₁ : List ℕ} {ds₂ : List ℕ} {α : Type} [ring α] (x : holor α ds₂) :
    mul 0 x = 0 :=
  funext fun (t : holor_index (ds₁ ++ ds₂)) => zero_mul (x (holor_index.drop t))

@[simp] theorem mul_zero {ds₁ : List ℕ} {ds₂ : List ℕ} {α : Type} [ring α] (x : holor α ds₁) :
    mul x 0 = 0 :=
  funext fun (t : holor_index (ds₁ ++ ds₂)) => mul_zero (x (holor_index.take t))

theorem mul_scalar_mul {α : Type} {ds : List ℕ} [monoid α] (x : holor α []) (y : holor α ds) :
    mul x y = x { val := [], property := list.forall₂.nil } • y :=
  sorry

/- holor slices -/

/-- A slice is a subholor consisting of all entries with initial index i. -/
def slice {α : Type} {d : ℕ} {ds : List ℕ} (x : holor α (d :: ds)) (i : ℕ) (h : i < d) :
    holor α ds :=
  fun (is : holor_index ds) => x { val := i :: subtype.val is, property := sorry }

/-- The 1-dimensional "unit" holor with 1 in the `j`th position. -/
def unit_vec {α : Type} [monoid α] [add_monoid α] (d : ℕ) (j : ℕ) : holor α [d] :=
  fun (ti : holor_index [d]) => ite (subtype.val ti = [j]) 1 0

theorem holor_index_cons_decomp {d : ℕ} {ds : List ℕ} (p : holor_index (d :: ds) → Prop)
    (t : holor_index (d :: ds)) :
    (∀ (i : ℕ) (is : List ℕ) (h : subtype.val t = i :: is),
          p
            { val := i :: is,
              property :=
                eq.mpr
                  (id (Eq._oldrec (Eq.refl (list.forall₂ Less (i :: is) (d :: ds))) (Eq.symm h)))
                  (subtype.property t) }) →
        p t :=
  sorry

/-- Two holors are equal if all their slices are equal. -/
theorem slice_eq {α : Type} {d : ℕ} {ds : List ℕ} (x : holor α (d :: ds)) (y : holor α (d :: ds))
    (h : slice x = slice y) : x = y :=
  sorry

theorem slice_unit_vec_mul {α : Type} {d : ℕ} {ds : List ℕ} [ring α] {i : ℕ} {j : ℕ} (hid : i < d)
    (x : holor α ds) : slice (mul (unit_vec d j) x) i hid = ite (i = j) x 0 :=
  sorry

theorem slice_add {α : Type} {d : ℕ} {ds : List ℕ} [Add α] (i : ℕ) (hid : i < d)
    (x : holor α (d :: ds)) (y : holor α (d :: ds)) :
    slice x i hid + slice y i hid = slice (x + y) i hid :=
  sorry

theorem slice_zero {α : Type} {d : ℕ} {ds : List ℕ} [HasZero α] (i : ℕ) (hid : i < d) :
    slice 0 i hid = 0 :=
  rfl

theorem slice_sum {α : Type} {d : ℕ} {ds : List ℕ} [add_comm_monoid α] {β : Type} (i : ℕ)
    (hid : i < d) (s : finset β) (f : β → holor α (d :: ds)) :
    (finset.sum s fun (x : β) => slice (f x) i hid) =
        slice (finset.sum s fun (x : β) => f x) i hid :=
  sorry

/-- The original holor can be recovered from its slices by multiplying with unit vectors and summing up. -/
@[simp] theorem sum_unit_vec_mul_slice {α : Type} {d : ℕ} {ds : List ℕ} [ring α]
    (x : holor α (d :: ds)) :
    (finset.sum (finset.attach (finset.range d))
          fun (i : Subtype fun (x : ℕ) => x ∈ finset.range d) =>
            mul (unit_vec d ↑i)
              (slice x (↑i) (nat.succ_le_of_lt (iff.mp finset.mem_range (subtype.prop i))))) =
        x :=
  sorry

/- CP rank -/

/-- `cprank_max1 x` means `x` has CP rank at most 1, that is,
  it is the tensor product of 1-dimensional holors. -/
inductive cprank_max1 {α : Type} [Mul α] : {ds : List ℕ} → holor α ds → Prop where
| nil : ∀ (x : holor α []), cprank_max1 x
| cons :
    ∀ {d : ℕ} {ds : List ℕ} (x : holor α [d]) (y : holor α ds),
      cprank_max1 y → cprank_max1 (mul x y)

/-- `cprank_max N x` means `x` has CP rank at most `N`, that is,
  it can be written as the sum of N holors of rank at most 1. -/
inductive cprank_max {α : Type} [Mul α] [add_monoid α] : ℕ → {ds : List ℕ} → holor α ds → Prop where
| zero : ∀ {ds : List ℕ}, cprank_max 0 0
| succ :
    ∀ (n : ℕ) {ds : List ℕ} (x y : holor α ds),
      cprank_max1 x → cprank_max n y → cprank_max (n + 1) (x + y)

theorem cprank_max_nil {α : Type} [monoid α] [add_monoid α] (x : holor α []) : cprank_max 1 x :=
  sorry

theorem cprank_max_1 {α : Type} {ds : List ℕ} [monoid α] [add_monoid α] {x : holor α ds}
    (h : cprank_max1 x) : cprank_max 1 x :=
  sorry

theorem cprank_max_add {α : Type} {ds : List ℕ} [monoid α] [add_monoid α] {m : ℕ} {n : ℕ}
    {x : holor α ds} {y : holor α ds} :
    cprank_max m x → cprank_max n y → cprank_max (m + n) (x + y) :=
  sorry

theorem cprank_max_mul {α : Type} {d : ℕ} {ds : List ℕ} [ring α] (n : ℕ) (x : holor α [d])
    (y : holor α ds) : cprank_max n y → cprank_max n (mul x y) :=
  sorry

theorem cprank_max_sum {α : Type} {ds : List ℕ} [ring α] {β : Type u_1} {n : ℕ} (s : finset β)
    (f : β → holor α ds) :
    (∀ (x : β), x ∈ s → cprank_max n (f x)) →
        cprank_max (finset.card s * n) (finset.sum s fun (x : β) => f x) :=
  sorry

theorem cprank_max_upper_bound {α : Type} [ring α] {ds : List ℕ} (x : holor α ds) :
    cprank_max (list.prod ds) x :=
  sorry

/-- The CP rank of a holor `x`: the smallest N such that
  `x` can be written as the sum of N holors of rank at most 1. -/
def cprank {α : Type} {ds : List ℕ} [ring α] (x : holor α ds) : ℕ := nat.find sorry

theorem cprank_upper_bound {α : Type} [ring α] {ds : List ℕ} (x : holor α ds) :
    cprank x ≤ list.prod ds :=
  nat.find_min'
    (Exists.intro (list.prod ds)
      ((fun (this : cprank_max (list.prod ds) x) => this) (cprank_max_upper_bound x)))
    (cprank_max_upper_bound x)

end Mathlib


/-
Copyright (c) 2020 Kenny Lau. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kenny Lau
-/
import Mathlib.PrePort
import Mathlib.Lean3Lib.init.default
import Mathlib.algebra.polynomial.group_ring_action
import Mathlib.deprecated.subfield
import Mathlib.field_theory.normal
import Mathlib.field_theory.separable
import Mathlib.field_theory.tower
import Mathlib.linear_algebra.matrix
import Mathlib.ring_theory.polynomial.default
import Mathlib.PostPort

universes u v w

namespace Mathlib

/-!
# Fixed field under a group action.

This is the basis of the Fundamental Theorem of Galois Theory.
Given a (finite) group `G` that acts on a field `F`, we define `fixed_points G F`,
the subfield consisting of elements of `F` fixed_points by every element of `G`.

This subfield is then normal and separable, and in addition (TODO) if `G` acts faithfully on `F`
then `findim (fixed_points G F) F = fintype.card G`.

## Main Definitions

- `fixed_points G F`, the subfield consisting of elements of `F` fixed_points by every element of `G`, where
`G` is a group that acts on `F`.

-/

protected instance fixed_by.is_subfield (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] (g : G) : is_subfield (mul_action.fixed_by G F g) :=
  is_subfield.mk fun (x : F) (hx : x ∈ mul_action.fixed_by G F g) => Eq.trans (smul_inv F g x) (congr_arg has_inv.inv hx)

namespace fixed_points

protected instance mul_action.fixed_points.is_subfield (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] : is_subfield (mul_action.fixed_points G F) :=
  eq.mpr
    ((fun (S S_1 : set F) (e_2 : S = S_1) => congr_arg is_subfield e_2) (mul_action.fixed_points G F)
      (set.Inter (mul_action.fixed_by G F))
      (eq.mpr
        (id
          (Eq._oldrec (Eq.refl (mul_action.fixed_points G F = set.Inter (mul_action.fixed_by G F)))
            (mul_action.fixed_eq_Inter_fixed_by G F)))
        (Eq.refl (set.Inter fun (g : G) => mul_action.fixed_by G F g))))
    (is_subfield.Inter (mul_action.fixed_by G F))

protected instance mul_action.fixed_points.is_invariant_subring (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] : is_invariant_subring G (mul_action.fixed_points G F) :=
  is_invariant_subring.mk
    fun (g : G) (x : F) (hx : x ∈ mul_action.fixed_points G F) (g' : G) =>
      eq.mpr (id (Eq._oldrec (Eq.refl (g' • g • x = g • x)) (hx g)))
        (eq.mpr (id (Eq._oldrec (Eq.refl (g' • x = x)) (hx g'))) (Eq.refl x))

@[simp] theorem smul (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] (g : G) (x : ↥(mul_action.fixed_points G F)) : g • x = x :=
  subtype.eq (subtype.property x g)

-- Why is this so slow?

@[simp] theorem smul_polynomial (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] (g : G) (p : polynomial ↥(mul_action.fixed_points G F)) : g • p = p := sorry

protected instance algebra (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] : algebra (↥(mul_action.fixed_points G F)) F :=
  algebra.of_is_subring (mul_action.fixed_points G F)

theorem coe_algebra_map (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] : algebra_map (↥(mul_action.fixed_points G F)) F = is_subring.subtype (mul_action.fixed_points G F) :=
  rfl

theorem linear_independent_smul_of_linear_independent (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] {s : finset F} : (linear_independent ↥(mul_action.fixed_points G F) fun (i : ↥↑s) => ↑i) →
  linear_independent F fun (i : ↥↑s) => coe_fn (mul_action.to_fun G F) ↑i := sorry

/-- `minpoly G F x` is the minimal polynomial of `(x : F)` over `fixed_points G F`. -/
def minpoly (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] (x : F) : polynomial ↥(mul_action.fixed_points G F) :=
  polynomial.to_subring (prod_X_sub_smul G F x) (mul_action.fixed_points G F) sorry

namespace minpoly

theorem monic (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] (x : F) : polynomial.monic (minpoly G F x) :=
  subtype.eq (prod_X_sub_smul.monic G F x)

theorem eval₂ (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] (x : F) : polynomial.eval₂ (is_subring.subtype (mul_action.fixed_points G F)) x (minpoly G F x) = 0 := sorry

theorem ne_one (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] (x : F) : minpoly G F x ≠ 1 := sorry

theorem of_eval₂ (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] (x : F) (f : polynomial ↥(mul_action.fixed_points G F)) (hf : polynomial.eval₂ (is_subring.subtype (mul_action.fixed_points G F)) x f = 0) : minpoly G F x ∣ f := sorry

/- Why is this so slow? -/

theorem irreducible_aux (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] (x : F) (f : polynomial ↥(mul_action.fixed_points G F)) (g : polynomial ↥(mul_action.fixed_points G F)) (hf : polynomial.monic f) (hg : polynomial.monic g) (hfg : f * g = minpoly G F x) : f = 1 ∨ g = 1 := sorry

theorem irreducible (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] (x : F) : irreducible (minpoly G F x) :=
  iff.mpr (polynomial.irreducible_of_monic (monic G F x) (ne_one G F x)) (irreducible_aux G F x)

end minpoly

theorem is_integral (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] (x : F) : is_integral (↥(mul_action.fixed_points G F)) x :=
  Exists.intro (minpoly G F x) { left := minpoly.monic G F x, right := minpoly.eval₂ G F x }

theorem minpoly_eq_minpoly (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] (x : F) : minpoly G F x = minpoly (↥(mul_action.fixed_points G F)) x :=
  minpoly.unique' (is_integral G F x) (minpoly.irreducible G F x) (minpoly.eval₂ G F x) (minpoly.monic G F x)

protected instance normal (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] : normal (↥(mul_action.fixed_points G F)) F := sorry

protected instance separable (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] : is_separable (↥(mul_action.fixed_points G F)) F := sorry

theorem dim_le_card (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] : vector_space.dim (↥(mul_action.fixed_points G F)) F ≤ ↑(fintype.card G) := sorry

protected instance finite_dimensional (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] : finite_dimensional (↥(mul_action.fixed_points G F)) F :=
  iff.mpr finite_dimensional.finite_dimensional_iff_dim_lt_omega
    (lt_of_le_of_lt (dim_le_card G F) (cardinal.nat_lt_omega (fintype.card G)))

theorem findim_le_card (G : Type u) [group G] (F : Type v) [field F] [mul_semiring_action G F] [fintype G] : finite_dimensional.findim (↥(mul_action.fixed_points G F)) F ≤ fintype.card G :=
  eq.mp (propext cardinal.nat_cast_le)
    (trans_rel_right LessEq (finite_dimensional.findim_eq_dim (↥(mul_action.fixed_points G F)) F) (dim_le_card G F))

end fixed_points

theorem linear_independent_to_linear_map (R : Type u) (A : Type v) (B : Type w) [comm_semiring R] [integral_domain A] [algebra R A] [integral_domain B] [algebra R B] : linear_independent B alg_hom.to_linear_map := sorry

theorem cardinal_mk_alg_hom (K : Type u) (V : Type v) (W : Type w) [field K] [field V] [algebra K V] [finite_dimensional K V] [field W] [algebra K W] [finite_dimensional K W] : cardinal.mk (alg_hom K V W) ≤ ↑(finite_dimensional.findim W (linear_map K V W)) :=
  finite_dimensional.cardinal_mk_le_findim_of_linear_independent (linear_independent_to_linear_map K V W)

protected instance alg_hom.fintype (K : Type u) (V : Type v) (W : Type w) [field K] [field V] [algebra K V] [finite_dimensional K V] [field W] [algebra K W] [finite_dimensional K W] : fintype (alg_hom K V W) :=
  Classical.choice sorry

protected instance alg_equiv.fintype (K : Type u) (V : Type v) [field K] [field V] [algebra K V] [finite_dimensional K V] : fintype (alg_equiv K V V) :=
  fintype.of_equiv (alg_hom K V V) (equiv.symm (alg_equiv_equiv_alg_hom K V))

theorem findim_alg_hom (K : Type u) (V : Type v) [field K] [field V] [algebra K V] [finite_dimensional K V] : fintype.card (alg_hom K V V) ≤ finite_dimensional.findim V (linear_map K V V) :=
  finite_dimensional.fintype_card_le_findim_of_linear_independent (linear_independent_to_linear_map K V V)

namespace fixed_points

/-- Embedding produced from a faithful action. -/
@[simp] theorem to_alg_hom_apply (G : Type u) (F : Type v) [group G] [field F] [faithful_mul_semiring_action G F] : ⇑(to_alg_hom G F) =
  fun (g : G) =>
    alg_hom.mk (ring_hom.to_fun (mul_semiring_action.to_semiring_hom G F g)) (to_alg_hom._proof_3 G F g)
      (to_alg_hom._proof_4 G F g) (to_alg_hom._proof_5 G F g) (to_alg_hom._proof_6 G F g) (to_alg_hom._proof_7 G F g) :=
  Eq.refl ⇑(to_alg_hom G F)

theorem to_alg_hom_apply_apply {G : Type u} {F : Type v} [group G] [field F] [faithful_mul_semiring_action G F] (g : G) (x : F) : coe_fn (coe_fn (to_alg_hom G F) g) x = g • x :=
  rfl

theorem findim_eq_card (G : Type u) (F : Type v) [group G] [field F] [fintype G] [faithful_mul_semiring_action G F] : finite_dimensional.findim (↥(mul_action.fixed_points G F)) F = fintype.card G := sorry

theorem to_alg_hom_bijective (G : Type u) (F : Type v) [group G] [field F] [fintype G] [faithful_mul_semiring_action G F] : function.bijective ⇑(to_alg_hom G F) := sorry

/-- Bijection between G and algebra homomorphisms that fix the fixed points -/
def to_alg_hom_equiv (G : Type u) (F : Type v) [group G] [field F] [fintype G] [faithful_mul_semiring_action G F] : G ≃ alg_hom (↥(mul_action.fixed_points G F)) F F :=
  function.embedding.equiv_of_surjective (to_alg_hom G F) sorry