import tactic

theorem expand : ∀ n : ℕ, (n + 1) ^ 2 = n ^ 2 + 2 * n + 1 :=
-- Tedious way
begin
    intro n,
    rw nat.pow_two,
    rw mul_add,
    rw add_mul,
    rw ← nat.pow_two,
    rw one_mul,
    rw mul_one,
    rw ← add_assoc,
    rw two_mul,
    rw ← add_assoc,
end

-- Neater way to do it
example : ∀ n : ℕ, (n + 1) ^ 2 = n ^ 2 + 2 * n + 1 := λ _, by ring


import tactic.linarith list.min.basic

-- tf = 2 if we are talking about chains and 4 otherwise

-- all games are assumed to consist only of loops or only of chains

/-- Let G be all chains or loops. If m is the length of a component of G, and
  vL = value of game G with that component removed, list.aux_fun this is the
  value of G given that we're playing in that component -/
def list.aux_fun (m tf vL : ℤ) := m - tf + abs(tf - vL)

/--if two components M1, M2 differ by at most d in length
  and v(G1;M1) = v(G2;M2), then the value given we are playing
  in any of them differs by at most d-/
theorem list.aux_fun_L1 {m1 m2 tf vL d : ℤ} (hm : abs (m1 - m2) ≤ d) :
  abs(list.aux_fun m1 tf vL - list.aux_fun m2 tf vL) ≤ d :=
begin
  unfold list.aux_fun, finish, -- Lean can prove this by itself
end

/--if we have two games with a component of length m of the same
   type and the values of each game with such a component removed
   differ by at most d then the value given we are playing in such
   a component in any of them differs by at most d-/
theorem list.aux_fun_L2 {m tf vL1 vL2 d : ℤ} (hm : abs (vL1 - vL2) ≤ d) :
  abs(list.aux_fun m tf vL1 - list.aux_fun m tf vL2) ≤ d :=
begin
 unfold list.aux_fun,
 rw sub_add_eq_sub_sub_swap,
 /- the goal is : abs (m - tf + abs (tf - vL1) - abs (tf - vL2) - (m - tf)) ≤ d-/

/- As we are dealing with integers, this is equivalent to
    abs (abs (tf - vL1) - abs (tf - vL2)) ≤ d -/
 rw add_comm,
 show abs (abs (tf + -vL1) + (m + -tf) + -abs (tf + -vL2) + -(m + -tf)) ≤ d,
 rw add_assoc,
 rw add_assoc,
 rw add_comm (m + -tf),
 rw add_assoc,
 rw add_comm (-(m+-tf)),
 rw add_neg_self (m+-tf),
 rw add_zero,

 /- we want to solve the goal by using that by hm, abs(tf - vL1 - (tf - vL2)) ≤ d
    and by another lemma abs (abs (tf - vL1) - abs (tf - vL2)) ≤ abs(tf - vL1 - (tf - vL2))
    through transitivity of ≤ -/

 have Q: abs(tf - vL1 - (tf - vL2)) ≤ d,
  {  rw ←  abs_neg, -- abs(tf - vL1 - (tf - vL2)) = abs(-(tf - vL1 - (tf - vL2)))
     convert hm, -- abs(-(tf - vL1 - (tf - vL2))) ≤ d is basically hm
     -- so what is left to prove for Q is that -(tf - vL1 - (tf - vL2)) = vL1 - vL2
     ring,},  -- using that ( ℤ, *, +) is a ring (so commutativity and associativity hold)

 have R: abs (abs (tf - vL1) - abs (tf - vL2)) ≤ abs ((tf - vL1) - (tf - vL2)),
  {exact abs_abs_sub_abs_le_abs_sub (tf - vL1) (tf - vL2)}, -- see misc_lemmas
 exact le_trans R Q, -- proven by Q, R and transitivity of ≤
end

/-- Value of all-chain or all-loop game L with n components
 given that we are opening the i'th component first-/
definition list.value_i (tf : ℤ) :
  ∀ (n : ℕ) (L : list ℤ) (i : fin n) (hL : L.length = n), ℤ
| (0) L i h := begin exfalso,  exact fin.elim0 i, end /- i.is_lt gives a contradiction (i < 0 is impossible)-/
| (d + 1) L i h := list.aux_fun (L.nth_le i.val (by rw h; exact i.is_lt)) tf (list.min' (list.of_fn $
    λ (j : fin d), list.value_i d (L.remove_nth i.val) j begin
      rw list.length_remove_nth L i.val _,
        rw h, simp,
      rw h, exact i.is_lt,
    end))

/-  The first case being a contradiction also makes sense for our definition.
     we cannot open a component first if the game is empty

     list.value_i tf n L i hL  is defined inductively on the number of components as
     L.nth_le i.val _ - tf + abs ( tf - v ),
      where v is the minimum value of list.value_i (n - 1) (L.remove_nth i.val) j _over all j in fin (n - 1).
      As we define he minimum element of the empty list to be zero, if our 'game' has only one component,
      (ie. n = 1) , we have list.value_i tf 1 L ⟨0,_⟩ hL =
      L.nth_le 0 _ - tf + abs ( tf - 0 ), which is the length of the component, as it should be.
      (i = ⟨0,_⟩ is the only possibility as we must have i.val < n)
      So this recursion terminates.-/


import topology.basic

/-
In this problem you will look at proving that the composition of two continuous maps is
continuous

Some things you should know:
- A subset of a space `X` is an element of the type `set X` in Lean
- The notation for the preimage of a set `U` along a map `f` is `f ⁻¹' U`
-/
/- Axiom : continuous_def : ∀ {α : Type} {β : Type} [topological_space α]
  [topological_space β] {f : α → β},
  continuous f ↔ ∀ (s : set β),is_open s → is_open (f ⁻¹' s)
-/
/- Axiom : set.preimage_comp : ∀ {α β γ : Type} {f : α → β} {g : β → γ} {s : set γ},
g ∘ f ⁻¹' s = f ⁻¹' (g ⁻¹' s)
-/
/-
You will need to use the tactics intros, rewrite, and apply for this problem!
And some new lemmas that are in the sidebar for you.
-/
/- Lemma :
-/
lemma image_compact
  (X Y Z : Type)
  [topological_space X]
  [topological_space Y]
  [topological_space Z]
  (f : X → Y)
  (g : Y → Z)
  (hf : continuous f)
  (hg : continuous g) :
  continuous (g ∘ f) :=
begin
  rw continuous_def at *,
  intros S hS,
  rw [set.preimage_comp],
  apply hf,
  apply hg,
  apply hS,
end


import subgroup.lagrange
import data.nat.modeq

noncomputable theory

namespace mygroup

open_locale classical

open set classical function

/-- A left action of some group `G` on some `S` is a function with type
  `to_fun : G → S → S` such that for all `s : S`, `to_fun 1 s = 1` and for all
  `g, h : G`, `s : S`, `to_fun g (to_fun h s) = to_fun (g * h) s` -/
structure laction (G : Type) [group G] (S : Type) :=
(to_fun    : G → S → S) (map_one' : ∀ s : S, to_fun 1 s = s)
(map_assoc' : ∀ g h : G, ∀ s : S, to_fun g (to_fun h s) = to_fun (g * h) s)

variables {G S : Type} [group G]
variables {μ : laction G S}

notation g ` •[`:70 μ `] `:0 s:70 := μ.to_fun g s
local notation g ` • `:70  s:70  := μ.to_fun g s

namespace laction

-- APIs for left actions

@[ext] lemma ext (μ1 μ2 : laction G S)
  (h : ∀ (g : G) (s : S), μ1.to_fun g s = μ2.to_fun g s) :
μ1 = μ2 :=
begin
  cases μ1, cases μ2, simp * at *,
  ext g s, apply h,
end

@[simp] lemma map_one (μ : laction G S) (s : S) : (1 •[μ] s) = s := μ.map_one' _

lemma map_assoc (g h : G) (s : S) : g • (h • s) = g * h • s :=
  μ.map_assoc' _ _ _

-- The user should prove these two lemmas below

lemma laction_mul_inv_cancel {g h : G} {s : S} :
  g • s = h • s ↔ s = (g⁻¹ * h) • s :=
begin
  split; intro hgh,
    { conv_lhs { rw ←map_one μ s },
      rw [←(group.mul_right_inv g⁻¹), ←map_assoc,
          ←map_assoc, ←hgh, group.inv_inv] },
    { conv_lhs { rw [hgh, map_assoc, ←group.mul_assoc,
                     group.mul_right_inv, group.one_mul] } }
end

lemma laction_mul_inv {g : G} {s t : S} : g • s = t ↔ s = g⁻¹ • t :=
begin
  split; intro h,
    { rw [←h, map_assoc, group.mul_left_inv, map_one] },
    { rw [h, map_assoc, group.mul_right_inv, map_one] }
end

end laction

/-- The orbit of some element of `s : S` is the image of the left action at `s` -/
def orbit (μ : laction G S) (s : S) : set S :=
  { m : S | ∃ g : G, m = g •[μ] s }

namespace laction

@[simp]
lemma orbit_def {s : S} : orbit μ s = { m : S | ∃ g : G, m = g • s } := rfl

@[simp]
lemma mem_orbit {s t : S} : t ∈ orbit μ s ↔ ∃ g : G, t = g • s :=
by rw [orbit_def, mem_set_of_eq]

/-- An element of `G` is in its own orbit -/
lemma mem_orbit_refl (s : S) : s ∈ orbit μ s := ⟨1, (map_one μ s).symm⟩

/-- If `s₁ : S` is in `s₂ : S`'s orbit, then `s₂` is in `s₁`'s orbit -/
lemma mem_orbit_symm {s₁ s₂ : S} (h : s₁ ∈ orbit μ s₂) : s₂ ∈ orbit μ s₁ :=
let ⟨g, hg⟩ := h in ⟨g⁻¹, by rw [hg, map_assoc, group.mul_left_inv, map_one]⟩

/-- If s₁ ∈ [s₂] and s₂ ∈ [s₃] then s₁ ∈ [s₃] -/
lemma mem_orbit_trans {s₁ s₂ s₃ : S}
  (hs₁ : s₁ ∈ orbit μ s₂) (hs₂ : s₂ ∈ orbit μ s₃) : s₁ ∈ orbit μ s₃ :=
begin
  cases hs₁ with g₁ hg₁,
  cases hs₂ with g₂ hg₂,
  refine ⟨g₁ * g₂, _⟩,
  rw [hg₁, hg₂, map_assoc]
end

/-- If two elements of `S` are in the same orbit then they are in eachothers orbit-/
lemma in_orbit_of_in_same_orbit {s₁ s₂ s₃ : S}
  (hs₁ : s₁ ∈ orbit μ s₃) (hs₂ : s₂ ∈ orbit μ s₃) : s₁ ∈ orbit μ s₂ :=
begin
  cases hs₁ with g₁ hg₁,
  cases hs₂ with g₂ hg₂,
  refine ⟨g₁ * g₂⁻¹, _⟩,
  rw [hg₁, hg₂, map_assoc, group.mul_assoc, group.mul_left_inv, group.mul_one]
end

lemma in_orbit_of_inv' {s₁ s₂ : S} {g : G} (h : s₁ = g • s₂) :
  s₂ = g⁻¹ • s₁ := by rw [h, map_assoc, group.mul_left_inv, map_one]

lemma eq_orbit {s₀ s₁ : S} (t : S)
  (hs₁ : t ∈ orbit μ s₀) (hs₂ : t ∈ orbit μ s₁) : orbit μ s₀ = orbit μ s₁ :=
begin
  cases hs₁ with g₁ hg₁,
  cases hs₂ with g₂ hg₂,
  ext, split; rintro ⟨g, rfl⟩,
    { rw [hg₁, laction_mul_inv, map_assoc] at hg₂,
      rw [mem_orbit, hg₂, map_assoc],
      exact ⟨g * (g₁⁻¹ * g₂), rfl⟩ },
    { rw [hg₂, laction_mul_inv, map_assoc] at hg₁,
      rw [mem_orbit, hg₁, map_assoc],
      exact ⟨g * (g₂⁻¹ * g₁), rfl⟩ }
end

end laction

/-- The stabilizer of `s : S` is the subgroup which elements fixes `s` under the
  left laction -/
def stabilizer (μ : laction G S) (s : S) : subgroup G :=
{ carrier := { g : G | (g •[μ] s) = s },
  one_mem' := laction.map_one μ _,
  mul_mem' := λ _ _ hg hh,
    by { rw mem_set_of_eq at *, rw [←laction.map_assoc, hh, hg] },
  inv_mem' := λ x hx,
    begin
      rw mem_set_of_eq at *,
      conv_lhs { rw ←hx },
      rw [laction.map_assoc, group.mul_left_inv _, μ.2]
    end }

/-- Two subgroups `H K` of group `G` are conjugates if and only if there exist
  some `g : G`, `g⁻¹ H g = K` -/
def is_conjugate (H K : subgroup G) :=
  ∃ g : G, { c | ∃ h ∈ H, c = g⁻¹ * h * g } = K

-- This will be used in one of the lemmas later
lemma nat.zero_or_one_of_le_one {n : ℕ} (hn : n ≤ 1) : n = 0 ∨ n = 1 :=
begin
  induction n, finish,
  rw nat.succ_le_iff at hn,
  change _ < 1 + 0 at hn,
  rw nat.lt_one_add_iff at hn,
  rw nat.le_zero_iff at hn,
  right, rw hn,
end

namespace laction

@[simp]
lemma mem_stabilizer (s : S) (g : G) : g ∈ stabilizer μ s ↔ g • s = s := iff.rfl

/-- If `H` is the conjugate of `K`, then `K` is the conjugate of `H` -/
lemma is_conjugate_symm {H K : subgroup G} (h : is_conjugate H K) :
  is_conjugate K H :=
begin
  cases h with g hg, refine ⟨g⁻¹, _⟩,
  ext, split; intro hx,
    { rcases hx with ⟨h, hh₀, hh₁⟩,
      change h ∈ (K : set G) at hh₀,
      rw ←hg at hh₀,
      rcases hh₀ with ⟨k, hk₀, hk₁⟩,
      rw [hh₁, hk₁], simpa [group.mul_assoc] },
    { rw mem_set_of_eq,
      refine ⟨g⁻¹ * x * g, _, by simp [group.mul_assoc]⟩,
      show g⁻¹ * x * g ∈ (K : set G),
      rw ←hg, exact ⟨x, hx, rfl⟩ }
end

/-- If two elements are in the same orbit, then their stabilizers are conjugates -/
theorem conjugate_stabilizer_of_in_same_orbit {s₁ s₂ s₃ : S}
  (hs₁ : s₁ ∈ orbit μ s₃) (hs₂ : s₂ ∈ orbit μ s₃) :
  is_conjugate (stabilizer μ s₁) (stabilizer μ s₂) :=
begin
  cases in_orbit_of_in_same_orbit hs₁ hs₂ with g hg,
  refine ⟨g, _⟩,
  ext, split; intro hx,
    { show x ∈ stabilizer μ s₂,
      rcases hx with ⟨h, hh₀, hh₁⟩,
      rw [mem_stabilizer, hh₁, ←map_assoc, ←map_assoc, ←hg,
         (show h • s₁ = s₁, by exact hh₀), hg, map_assoc,
         group.mul_left_inv, map_one] },
    { change x ∈ stabilizer μ s₂ at hx,
      refine ⟨g * x * g⁻¹, (mem_stabilizer _ _).2 _, _⟩,
      rw [←map_assoc, ←(in_orbit_of_inv' hg),
          ←map_assoc, (mem_stabilizer _ _).1 hx, hg], by simp [group.mul_assoc] }
end

private structure extract_struct {μ : laction G S} {a : S} (s : orbit μ a) :=
(val : G) (prop : s.1 = μ.to_fun val a)

@[reducible] private def extract {μ : laction G S} {a : S} (s : orbit μ a) :
  extract_struct s := ⟨some s.2, some_spec s.2⟩

@[reducible] private def aux_map (μ : laction G S) (a : S) :
  orbit μ a → { s | ∃ h : G, s = h ⋆ stabilizer μ a } :=
λ s, ⟨(extract s).1 ⋆ stabilizer μ a, (extract s).1, rfl⟩

private lemma aux_map_biject {a : S} : bijective $ aux_map μ a :=
begin
  split,
    { rintro ⟨x, hx⟩ ⟨y, hy⟩ hxy,
      rw [subtype.mk.inj_eq, lagrange.lcoset_eq] at hxy,
      change ((extract ⟨y, hy⟩).val)⁻¹ * (extract ⟨x, hx⟩).val ∈
        { g : G | g • a = a } at hxy,
      rw [mem_set_of_eq, ←μ.3, ←(extract ⟨x, hx⟩).2,
        @laction_mul_inv _ _ _ μ _ x a, group.inv_inv, ←(extract ⟨y, hy⟩).2] at hxy,
      simp only [hxy] },
    { rintro ⟨_, g, hg⟩, refine ⟨⟨g • a, g, rfl⟩, _⟩,
      rw [subtype.mk.inj_eq, hg, lagrange.lcoset_eq],
      show g⁻¹ * (extract ⟨μ.to_fun g a, _⟩).val ∈ { g : G | g • a = a },
      rw [mem_set_of_eq, ←μ.3, ←(extract ⟨μ.to_fun g a, _⟩).2,
        μ.3, group.mul_left_inv, μ.2] }
end

-- With this function defined, we see that the cardinality of orbit s equals
-- the number of left cosets of stabilizer s

lemma card_orbit_eq_num_lcoset {a : S} :
  fincard (orbit μ a) = fincard { s | ∃ h : G, s = h ⋆ stabilizer μ a } :=
fincard.of_equiv (equiv.of_bijective _ aux_map_biject)

/-- Orbit-Stabilizer : The cardinality of a finite group `G` given a laction `μ`
on some `S` equals the cardinality of the orbit of `s` multiplied by the
cardinality of the stabilizer of `s` for any `s : S` -/
theorem orbit_stabilizer [h: fintype G] {a : S} (μ : laction G S) :
  fincard G = fincard (orbit μ a) * fincard (stabilizer μ a) :=
by rw [card_orbit_eq_num_lcoset, mul_comm]; exact lagrange.lagrange

def to_equiv (μ : laction G S) (g : G) : S ≃ S :=
{ to_fun := λ s, g •[μ] s,
  inv_fun := λ t, g⁻¹ •[μ] t,
  left_inv := λ s, begin simp [laction.map_assoc] end,
  right_inv := λ s, begin simp [laction.map_assoc] end }

def equiv_hom : laction G S ≃ (G →* (S ≃ S)) :=
{ to_fun := λ μ,
  { to_fun := λ g, laction.to_equiv μ g,
    map_mul' :=
      begin
        intros x y, ext s,
        exact (laction.map_assoc x y s).symm,
      end },
  inv_fun := λ φ,
    { to_fun := λ g s, φ g s,
      map_one' := by { rw φ.map_one, intros, refl },
      map_assoc' := by { intros g h s, simp } },
  left_inv := λ μ, by ext _ _; simpa,
  right_inv := λ φ, by ext _ _; refl }

end laction

/-! # fixed points -/

def fixed_points (μ : laction G S) : set S := { s : S | ∀ g : G, g •[μ] s = s }

@[simp] lemma mem_fixed_points_iff (s : S) :
  s ∈ fixed_points μ ↔ ∀ (g : G) , g • s = s := iff.rfl

lemma mem_fixed_points_iff_stabilizer_univ (s : S) :
  s ∈ fixed_points μ ↔ stabilizer μ s = ⊤ :=
begin
  rw mem_fixed_points_iff,
  rw subgroup.eq_top_iff',
  apply forall_congr,
  intro a, refl
end

lemma orbit_eq_singleton {s : S} {μ : laction G S} (h : s ∈ fixed_points μ) :
  orbit μ s = {s} := by ext x; simp * at *

lemma mem_fixed_points {s : S} {μ : laction G S} (h : orbit μ s = {s}) :
  s ∈ fixed_points μ := λ k, mem_singleton_iff.1 begin exact h ▸ ⟨k, rfl⟩ end

lemma orbit_eq_singleton_iff {s : S} {μ : laction G S} :
  orbit μ s = {s} ↔ s ∈ fixed_points μ := ⟨mem_fixed_points, orbit_eq_singleton⟩

lemma mem_fixed_points_iff_card_orbit_eq_one {s : S} {μ : laction G S}:
  s ∈ fixed_points μ ↔ fincard (orbit μ s) = 1 :=
begin
  rw ← orbit_eq_singleton_iff,
  split; intro h,
    { simp [h] },
    { rw eq_singleton_iff_unique_mem,
      refine ⟨laction.mem_orbit_refl _, λ y hy, _⟩,
      rcases fincard.card_eq_one_iff_singleton.1 h with ⟨x, hx⟩,
      rw hx at hy,
      rw [mem_singleton_iff.1 hy, ← mem_singleton_iff, ← hx],
      exact laction.mem_orbit_refl _ }
end

-- should now prove that for G acting on S, size of S = sum
-- of size of orbits.

/-- Orbits of an action -/
def orbits (μ : laction G S) := setoid.classes
  { r := λ (x y : S), x ∈ orbit μ y,
    iseqv := ⟨laction.mem_orbit_refl,
            λ x y, laction.mem_orbit_symm,
            λ x y z, laction.mem_orbit_trans⟩ }

lemma orbit_mem_orbits (s : S) : orbit μ s ∈ orbits μ := ⟨s, rfl⟩

lemma orbit_unique {x : S} {s : set S} (hs : s ∈ orbits μ) :
  x ∈ s ↔ orbit μ x = s :=
begin
  unfold orbits at hs,
  change s ∈ {s | ∃ y, s = {x | x ∈ orbit μ y}} at hs,
  rcases hs with ⟨y, rfl⟩,
  split; intro hx,
    { change x ∈ orbit μ y at hx,
      exact laction.eq_orbit x (laction.mem_orbit_refl _) hx },
    { change orbit μ x = orbit μ y at hx,
      rw ←hx, exact laction.mem_orbit_refl _ }
end

lemma sum_card_orbits [fintype S] : ∑' o in (orbits μ), fincard o = fincard S :=
  (fincard.card_eq_finsum_partition (setoid.is_partition_classes _)).symm

lemma card_orbits_eq_one [fintype S] {s : set S}
  (hs₀ : s ∈ orbits μ) (hs₁ : fincard s ≤ 1) : fincard s = 1 :=
begin
  cases nat.zero_or_one_of_le_one hs₁,
    { change s ∈ {s | ∃ y, s = {x | x ∈ orbit μ y}} at hs₀,
      rcases hs₀ with ⟨x, hx⟩,
      change s = orbit μ x at hx,
      rw fincard.card_eq_zero_iff at h,
      exfalso,
      apply not_mem_empty x,
      rw [←h, hx],
      exact laction.mem_orbit_refl x },
    { assumption }
end

def map_singleton (μ : laction G S) : (fixed_points μ) →
  ({o ∈ orbits μ | fincard o ≤ 1} : set (set S)) :=
λ s, ⟨orbit μ s, orbit_mem_orbits _,
  let ⟨_, hs⟩ := s in le_of_eq (mem_fixed_points_iff_card_orbit_eq_one.1 hs)⟩

@[simp] lemma map_singleton_def (s : S) (hs : s ∈ fixed_points μ) :
  (map_singleton μ ⟨s, hs⟩ : set S) = {s} :=
begin
  suffices : {m : S | ∃ (g : G), m = g • s} = {s},
    simpa [map_singleton],
  finish,
end

lemma bijective_map_singleton [fintype S] (μ : laction G S) :
  function.bijective (map_singleton μ) :=
begin
  split,
    { rintros ⟨x, hx⟩ ⟨y, hy⟩ hxy, congr,
      rw ←singleton_eq_singleton_iff,
      iterate 2 { rw ←map_singleton_def _ }, rw hxy },
    { rintros ⟨y, hy₀, hy₁⟩,
      rcases fincard.card_eq_one_iff_singleton.1
        (card_orbits_eq_one hy₀ hy₁) with ⟨x, rfl⟩,
      refine ⟨⟨x, _⟩, _⟩,
        { rw ←orbit_eq_singleton_iff,
          exact (orbit_unique hy₀).1 (mem_singleton _) },
        { suffices : {m : S | ∃ (g : G), m = g • x} = {x},
            simpa [map_singleton],
          suffices : x ∈ fixed_points μ,
            finish,
          rw ←orbit_eq_singleton_iff,
          exact (orbit_unique hy₀).1 (mem_singleton _) } }
end

lemma card_fixed_points [fintype S] : fincard (fixed_points μ) =
  let p := λ s : set S, fincard s ≤ 1 in
  ∑' o in { o ∈ orbits μ | p o }, fincard o :=
begin
  dsimp only,
  rw @finsum_const_nat (set S) (by apply_instance) _ 1 _,
    { rw mul_one,
      exact fincard.of_equiv (equiv.of_bijective _ $ bijective_map_singleton μ) },
    { exact λ x ⟨hx₀, hx₁⟩, card_orbits_eq_one hx₀ hx₁ },
end

lemma card_set_eq_card_fixed_points_sum_card_orbits [fintype S] (μ : laction G S):
  fincard S = fincard (fixed_points μ)
             + let p := λ s : set S, fincard s ≤ 1 in
             ∑' o in { o ∈ (orbits μ) | ¬ p o }, fincard o :=
begin
  rw [card_fixed_points, fincard.finsum_in_filter],
  exact sum_card_orbits.symm
end

-- I don't think this is needed anymore
lemma pow_prime_eq_one_or_dvd_prime {p d n : ℕ} (hp: p.prime) (hd: d = p^n) :
  d = 1 ∨ p ∣ d :=
begin
  cases n,
  left, rw hd, refl,
  right, simp [hd, nat.succ_eq_add_one, nat.pow_succ]
end

-- Are these names okay? Should I leave these lemmas here?
lemma card_orbit_div_pow_p [fintype S] [fintype G] (μ : laction G S)
  (p : ℕ) (hp : p.prime) (n : ℕ) (hG : fincard G = p ^ n):
  ∀ s : S, fincard (orbit μ s) ∣ p^n :=
begin
  intro s, rw ← hG,
    use (fincard (stabilizer μ s)),
    rw laction.orbit_stabilizer,
end

lemma card_orbit_eq_one_or_dvd_p [fintype S] [fintype G] (μ : laction G S)
  (p : ℕ) (hp : p.prime) (n : ℕ) (hG : fincard G = p ^ n) :
  ∀ (s : S), fincard (orbit μ s) = 1 ∨ p ∣ fincard (orbit μ s) :=
begin
  intro s,
  cases (card_orbit_div_pow_p μ p hp n hG) s with _ _,
  have h1: fincard ↥(orbit μ s) ∣ p^n,
    { use w, exact h },
  rw nat.dvd_prime_pow hp at h1,
  rcases h1 with ⟨_ | a, _, ha⟩; rw ha,
    { rw nat.pow_zero, left, refl },
    { right, rw nat.pow_succ, use p ^ a, rw mul_comm }
end

lemma card_set_congr_card_fixed_points_mod_prime [fintype S] [fintype G]
  (μ : laction G S) (p : ℕ) (hp : p.prime) (n : ℕ) (hG : fincard G = p ^ n) :
  fincard S ≡ fincard (fixed_points μ) [MOD p] :=
begin
  rw card_set_eq_card_fixed_points_sum_card_orbits μ,
  refine nat.modeq.modeq_of_dvd _,
  suffices: ↑p ∣ ↑∑' (o : set S) in
    ({ o ∈ orbits μ | 1 < fincard o } : set (set S)), fincard o,
    { simpa [sub_eq_add_neg] },
  norm_cast, apply fincard.finsum_divisible_by,
  rintro x h,
  rcases h with ⟨⟨s, hs⟩, hr⟩,
  change x = orbit μ s at hs,
  rw hs, cases card_orbit_eq_one_or_dvd_p μ p hp n hG s,
  rw [hs, h] at hr,
  linarith, assumption
end

-- Given a subset H of a group G, its conjugate is also a subgroup of G
def conjugate_subgroup [group G] (g : G) (H : subgroup G) :  subgroup G :=
{ carrier := { k| ∃ h ∈ H, k = g * h * g⁻¹ },
  one_mem' := ⟨(1 : G), H.one_mem, by rw [group.mul_one, group.mul_right_inv]⟩,
  mul_mem' := λ x y ⟨s, hs, h1⟩ ⟨t, ht, h2⟩,
    ⟨s * t, H.mul_mem hs ht, by rw [h1, h2]; simp [group.mul_assoc]⟩,
  inv_mem' := λ x ⟨s, hs, hx⟩, ⟨s⁻¹, H.inv_mem hs,
    group.inv_eq_of_mul_eq_one (by rw hx; simp [group.mul_assoc])⟩ }

lemma conjugate_is_conjugate (g : G) (H : subgroup G) :
  is_conjugate H (conjugate_subgroup g H) :=
begin
  refine ⟨g⁻¹, _⟩, ext x,
  apply exists_congr,
  simp [conjugate_subgroup],
end

lemma mul_equiv_of_is_conjugate {H K : subgroup G} (e : is_conjugate H K) :
 H ≃* K :=
let ⟨g, hg⟩ := classical.indefinite_description _ e in
begin
  dsimp at hg,
  rw ext_iff at hg,
  change ∀ x : G, (∃ (h : G), _) ↔ x ∈ K at hg,
  exact
  { to_fun := λ h, ⟨g⁻¹ * h * g, show _ ∈ K,
      begin rw ←hg, use [h.1, h.2], refl end⟩,
    inv_fun := λ k, ⟨g * k.1 * g⁻¹,
      begin
        show _ ∈ H, cases k with k hk,
        rcases (hg k).2 hk with ⟨t, h1, h2⟩,
        convert h1, subst h2, simp [group.mul_assoc],
      end⟩,
    left_inv := λ ⟨_, _⟩, by simp [group.mul_assoc],
    right_inv := λ ⟨_, _⟩, by simp [group.mul_assoc],
    map_mul' := λ ⟨_, _⟩ ⟨_, _⟩, by ext; simp [group.mul_assoc] }
end

def conjugation_action [group G]: laction G (subgroup G) :=
{ to_fun := λ (g : G) (H : subgroup G), conjugate_subgroup g H,
  map_one' :=
    begin
      intro H,
      unfold conjugate_subgroup,
      norm_num, ext, split,
      repeat { intro hx, exact hx },
    end  ,
  map_assoc' :=
    begin
      intros s t H,
      ext, split, unfold conjugate_subgroup,
        { intro hx,
          rcases hx with ⟨h, ⟨⟨k, ⟨j, hj⟩⟩, h2⟩⟩,
          rw hj at h2,
          suffices: x = s * t * k * (t⁻¹ * s⁻¹), tidy,
          rw [← group.mul_assoc, h2, group.mul_assoc],
          apply group.mul_eq_of_eq_inv_mul,
          symmetry,
          iterate 4 { rw ← group.mul_assoc },
          rw [group.mul_left_inv, group.one_mul] },
        { intro hx,
          rcases hx with ⟨h, ⟨hh, hj⟩⟩,
          suffices: x ∈ conjugate_subgroup s (conjugate_subgroup t H), tidy,
          rw [← group.mul_assoc, ← group.mul_assoc, group.mul_assoc],
          assumption },
    end }

end mygroup


import group_theory.perm.cycles
import data.vector
import data.fin_extra
import group_theory.cyclic

open int.modeq

variables {α : Type*} [decidable_eq α]

def finperm (n : ℕ) := equiv.perm (fin n)

namespace finperm

variable (n : ℕ)

instance : group (finperm n)          := by { dsimp[finperm], apply_instance }
instance : decidable_eq (finperm n)   := by { dsimp[finperm], apply_instance }
instance : has_coe_to_fun (finperm n) (λ _, (fin n) → (fin n)) := by { dsimp[finperm], apply_instance }

variable {n}

@[ext] lemma ext {s t : finperm n} : s = t ↔ ∀ (i : fin n), s i = t i :=
begin
  split,
  { rintro ⟨_⟩ i, refl },
  { intro h, ext i, rw[h i] }
end

lemma ext' {s t : finperm n}
 (h : ∀ (i : ℕ) (hi : i < n), ((s ⟨i,hi⟩) : ℕ) = ((t ⟨i,hi⟩) : ℕ)) : s = t :=
begin
  ext i, rcases i with ⟨i,hi⟩, exact h i hi,
end

variable (n)

lemma fin_coe_int_inj {n : ℕ} {i₀ i₁ : fin n} (h : (i₀ : ℤ) = (i₁ : ℤ)) : i₀ = i₁ :=
  fin.coe_inj (int.coe_nat_inj h)

def fin_of_int (i : ℤ) : fin (n + 1) :=
⟨i.nat_mod n.succ,
begin
  cases i; let j := i % n.succ; have hj : j < n.succ := i.mod_lt n.succ_pos,
  { exact hj },
  { change int.to_nat (int.sub_nat_nat n.succ j.succ) < n.succ,
    rw [int.sub_nat_nat_eq_coe, ← int.coe_nat_sub (hj)],
    change n.succ - j.succ < n.succ,
    rw [nat.succ_sub_succ],
    exact lt_of_le_of_lt (n.sub_le j) n.lt_succ_self }
end⟩

lemma coe_fin_of_int  (i : ℤ) : ((fin_of_int n i) : ℕ) = i.nat_mod n.succ := rfl

lemma coe_fin_of_int' (i : ℤ) : ((fin_of_int n i) : ℤ) = i % n.succ :=
begin
  have : (n.succ : ℤ) ≠ 0 := λ h, by { cases h },
  exact int.to_nat_of_nonneg (i.mod_nonneg this),
end

def shift : ℤ → (fin (n + 1)) → (fin (n + 1)) :=
  λ k i, fin_of_int n (k + (i : ℤ))

lemma shift_zero (i : fin (n + 1)) : shift n 0 i = i :=
begin
  apply fin_coe_int_inj,
  dsimp [shift, fin_of_int, int.nat_mod],
  have : (n + 1 : ℤ) = n.succ := rfl,
  rw [this, zero_add, int.of_nat_mod],
  congr' 1, exact nat.mod_eq_of_lt i.is_lt,
end

lemma shift_shift (k₀ k₁ : ℤ) (i : fin (n + 1)) :
  shift n k₀ (shift n k₁ i) = shift n (k₀ + k₁) i :=
begin
  apply fin_coe_int_inj,
  simp only [shift, coe_fin_of_int'],
  rw [add_assoc k₀ k₁],
  change _ ≡ _ [ZMOD _],
  apply int.modeq.add, refl, apply int.mod_modeq,
end

lemma shift_of_zero (i : fin (n + 1)) : shift n i 0 = i :=
begin
  apply fin_coe_int_inj,
  have : ((0 : fin (n + 1)) : ℤ) = 0 := rfl,
  simp only [shift, coe_fin_of_int', this, add_zero],
  change ((i : ℕ) : ℤ) % n.succ = (i : ℕ),
  rw [int.of_nat_mod], rw[nat.mod_eq_of_lt i.is_lt], refl,
end

/-
def p {l₀ l₁ : list α} (h : list.perm l₀ l₁) : equiv.perm (fin l₀.length) :=
by {
  let n := l₀.length, change equiv.perm (fin n),
  induction l₀ with a₀ m₀ ih generalizing l₁ h,
  { exact equiv.refl _ },
  { rcases (list.cons_perm_iff_perm_erase.mp h) with ⟨hm,hp⟩ }
}
--/

end finperm


import data.bitvec.basic
import data.zmod.basic
import group_theory.specific_groups.cyclic
import group_theory.subgroup
import measure_theory.probability_mass_function

/-
 ---------------------------------------------------------
  To measure_theory.probability_mass_function
  with help from Yakov Pechersky
 ---------------------------------------------------------
-/

noncomputable theory

instance : monad pmf :=
{ pure := @pmf.pure,
  bind := @pmf.bind }

instance : is_lawful_functor pmf :=
{ id_map := @pmf.map_id,
  comp_map := λ _ _ _ f g x, (pmf.map_comp x f g).symm }

instance : is_lawful_monad pmf :=
{ pure_bind := @pmf.pure_bind,
  bind_assoc := @pmf.bind_bind }

/-
 ---------------------------------------------------------
  To multiset.range
 ---------------------------------------------------------
-/

lemma range_pos_ne_zero (n : ℕ) (n_pos : 0 < n): multiset.range n ≠ 0 :=
begin
  apply (multiset.card_pos).mp,
  rw multiset.card_range,
  exact n_pos,
end

/-
 ---------------------------------------------------------
  To group_theory.is_cyclic
 ---------------------------------------------------------
-/

def is_cyclic.generator {G : Type} [group G] [is_cyclic G] (g : G): Prop :=
   ∀ (x : G), x ∈ subgroup.gpowers g

/-
 ---------------------------------------------------------
  To bitvec.basic
 ---------------------------------------------------------
-/

namespace bitvec

instance fintype : Π (n : ℕ), fintype (bitvec n) := by {intro n, exact vector.fintype}

lemma card (n : ℕ) : fintype.card (bitvec n) = 2^n := card_vector n

lemma multiset_ne_zero (n : ℕ) : (bitvec.fintype n).elems.val ≠ 0 :=
begin
  apply (multiset.card_pos).mp,
  have h : multiset.card (fintype.elems (bitvec n)).val = 2^n := bitvec.card n,
  rw h,
  simp,
end

end bitvec

/-
 ---------------------------------------------------------
  To data.basic.zmod, TO-DO Ask why this isn't already there
 ---------------------------------------------------------
-/

namespace zmod

instance group : Π (n : ℕ) [fact (0 < n)], group (zmod n) :=
  by {intros n h, exact multiplicative.group}

end zmod

/-
 ---------------------------------------------------------
  To group_theory.subgroup (Already there, on newer update)
 ---------------------------------------------------------
-/

namespace subgroup

variables {G : Type*} [group G]

lemma mem_gpowers_iff {g h : G} :
  h ∈ subgroup.gpowers g ↔ ∃ (k : ℤ), g^k = h := iff.rfl

end subgroup

/-
 ---------------------------------------------------------
  To nat
 ---------------------------------------------------------
-/

lemma exists_mod_add_div (a b: ℕ) : ∃ (m : ℕ), a = a % b + b * m :=
begin
  use (a/b),
  exact (nat.mod_add_div a b).symm,
end

/-
 ---------------------------------------------------------
  To group
 ---------------------------------------------------------
-/

variables (G : Type) [fintype G] [group G]

namespace group

lemma multiset_ne_zero : (fintype.elems G).val ≠ 0 :=
begin
  have e : G := (_inst_2.one),
  have h1 : e ∈ (fintype.elems G).val :=  finset.mem_univ e,
  have h2 : 0 < multiset.card (fintype.elems G).val :=
  begin
    apply (multiset.card_pos_iff_exists_mem).mpr,
    exact Exists.intro e h1,
  end,
  exact multiset.card_pos.mp h2,
end

end group

lemma inv_pow_eq_card_sub_pow (g : G) (m : ℕ) (h : m ≤ fintype.card G) :
  (g ^ m)⁻¹ = g ^ (fintype.card G - m) :=
begin
  have h : (g ^ m) * g ^ (fintype.card G - m) = 1 :=
  begin
    rw <- pow_add,
    rw nat.add_sub_of_le,
    exact pow_card_eq_one,
    exact h,
  end,
  exact inv_eq_of_mul_eq_one h,
end

-- (Already there, on newer update as pow_eq_mod_card m )
lemma pow_eq_mod_card (g : G) (m : ℕ) : g ^ m = g ^ (m % fintype.card G) :=
begin
  conv_lhs {rw <- nat.mod_add_div m (fintype.card G), rw pow_add},
  rw pow_mul,
  simp only [one_pow, pow_card_eq_one],
  exact (self_eq_mul_right.mpr rfl).symm,
end


/-
Copyright (c) 2019 Neil Strickland. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Neil Strickland

(This is part of an attempt to formalise some material from
 a basic undergraduate combinatorics course.)

 We consider the equation x₀ + ... + xₘ = n,
 where the variables xᵢ are natural numbers.
 The set of solutions bijects with the set of
 (n,m) grid paths, so the number of solutions is
 (n + m) choose n.

 There are various possible modifications, where
 we might impose constraints xᵢ ≥ cᵢ for example.
-/

import data.pnat.basic data.finset combinatorics.enumeration

namespace combinatorics

def inc_list (α : Type) [linear_order α] : Type :=
  { l : list α // l.pairwise has_lt.lt }

namespace inc_list

variables {α : Type} [linear_order α]

instance : has_coe (inc_list α) (list α) := ⟨λ l, l.val⟩

lemma coe_inj {l₀ l₁ : inc_list α} :
  (l₀ : list α) = (l₁ : list α) → l₀ = l₁ := subtype.eq

instance : has_mem α (inc_list α) := ⟨λ a l, a ∈ (l : list α) ⟩

lemma nodup (l : inc_list α) : (l : list α).nodup :=
  list.pairwise.imp (λ a₀ a₁ h, ne_of_lt h) l.property

def to_finset (l : inc_list α) : finset α := ⟨(l : list α),l.nodup⟩

def of_finset (s : finset α) : inc_list α := ⟨ s.sort has_le.le,
begin
  have hx := list.pairwise.and
   (s.sort_sorted has_le.le) (s.sort_nodup has_le.le),
  have hi : ∀ (a b : α) (h : a ≤ b ∧ a ≠ b), a < b :=
    λ a b h, lt_of_le_of_ne h.1 h.2,
  exact list.pairwise.imp hi hx,
end⟩

lemma to_of_finset (s : finset α) :
  to_finset (of_finset s) = s :=
(list.to_finset_eq (s.sort_nodup has_le.le)).trans
 (s.sort_to_finset has_le.le)

lemma of_to_finset (l : inc_list α) :
  of_finset (to_finset l) = l :=
coe_inj $  list.eq_of_perm_of_sorted (list.perm_merge_sort _ _)
    (of_finset (to_finset l)).property l.property

def finset_equiv : inc_list α ≃ finset α := {
  to_fun := to_finset,
  inv_fun := of_finset,
  left_inv := of_to_finset,
  right_inv := to_of_finset
}

def nil : inc_list α := ⟨[],list.pairwise.nil⟩

def cons (a : α) (l : inc_list α) (h : ∀ b : α, b ∈ l → a < b) :
  inc_list α :=
    ⟨list.cons a (l : list α),list.pairwise.cons h l.property⟩

def map {β : Type} [linear_order β]
 (f : α → β) (hf : ∀ a₀ a₁, a₀ < a₁ → f a₀ < f a₁)
 (l : inc_list α) : (inc_list β) :=
⟨ (l : list α).map f,
  (list.pairwise_map f).mpr (list.pairwise.imp hf l.property) ⟩

end inc_list

def nondec_list (α : Type) [linear_order α] : Type :=
  { l : list α // l.pairwise has_le.le }

namespace nondec_list

variables {α : Type} [linear_order α]

instance : has_coe (nondec_list α) (list α) := ⟨λ l, l.val⟩

instance : has_mem α (nondec_list α) := ⟨λ a l, a ∈ (l : list α) ⟩

lemma coe_inj {l₀ l₁ : nondec_list α} :
  (l₀ : list α) = (l₁ : list α) → l₀ = l₁ := subtype.eq

def to_multiset (l : nondec_list α) : multiset α := (l : list α)

def of_multiset (s : multiset α) : nondec_list α :=
 ⟨ s.sort has_le.le, s.sort_sorted has_le.le ⟩

lemma to_of_multiset (s : multiset α) :
  to_multiset (of_multiset s) = s := s.sort_eq has_le.le

lemma of_to_multiset (l : nondec_list α) :
  of_multiset (to_multiset l) = l :=
coe_inj $  list.eq_of_perm_of_sorted (list.perm_merge_sort _ _)
    (of_multiset (to_multiset l)).property l.property

def multiset_equiv : nondec_list α ≃ multiset α := {
  to_fun := to_multiset,
  inv_fun := of_multiset,
  left_inv := of_to_multiset,
  right_inv := to_of_multiset
}

def nil : nondec_list α := ⟨[],list.pairwise.nil⟩

def cons (a : α) (l : nondec_list α) (h : ∀ b : α, b ∈ l → a ≤ b) :
  nondec_list α :=
    ⟨list.cons a (l : list α),list.pairwise.cons h l.property⟩

def map {β : Type} [linear_order β]
 (f : α → β) (hf : ∀ a₀ a₁, a₀ ≤ a₁ → f a₀ ≤ f a₁)
 (l : nondec_list α) : (nondec_list β) :=
⟨ (l : list α).map f,
  (list.pairwise_map f).mpr (list.pairwise.imp hf l.property) ⟩

end nondec_list

def acc : list ℕ → list ℕ
| [] := []
| (a :: bs) := a :: ((acc bs).map (has_add.add a))

namespace acc

def is_nondec : ∀ (l : list ℕ), (acc l).pairwise has_le.le
| [] := list.pairwise.nil
| (a :: l) :=
begin
  rw [acc], apply list.pairwise.cons,
  { intros x hx,
    rcases list.mem_map.mp hx with ⟨y,⟨hm,he⟩⟩,
    rw [← he], exact nat.le_add_right a y },
  { let h₀ := λ (a₀ a₁ : ℕ) (h : a₀ ≤ a₁), add_le_add_left h a,
    let h₁ := list.pairwise.imp h₀ (is_nondec l),
    exact (list.pairwise_map (has_add.add a)).mpr h₁ }
end

def nondec (l : list ℕ) : nondec_list ℕ :=
  ⟨acc l, acc.is_nondec l⟩

end acc

def diff₀ : list ℕ → list ℕ
| [] := []
| [a] := []
| (a :: b :: l) := (b - a) :: (diff₀ (b :: l))

lemma diff₀_add (a : ℕ) : ∀ (l : list ℕ),
  diff₀ (l.map (has_add.add a)) = diff₀ l
| [] := rfl
| [b] := by { rw[list.map_singleton], refl }
| (b :: c :: l) :=
begin
  rw [list.map_cons, list.map_cons, diff₀, diff₀],
  congr' 1,
  { exact nat.add_sub_add_left a c b },
  { have h := diff₀_add (c :: l),
    rw [list.map_cons] at h, exact h }
end

lemma diff₀_acc : ∀ (a : ℕ) (l : list ℕ), diff₀ (acc (a :: l)) = l
| a [] := rfl
| a (b :: l) :=
begin
  rw [acc, acc, list.map_cons, diff₀, add_comm a b, nat.add_sub_cancel b a],
  rw [add_comm b a],
  let h := diff₀_add a (b :: ((acc l).map (has_add.add b))),
  congr' 1,
  rw [list.map_cons] at h, rw [h],
  exact diff₀_acc b l,
end

def diff : list ℕ → list ℕ
| [] := []
| (a :: l) := a :: (diff₀ (a :: l))

lemma diff_acc : ∀ (l : list ℕ), diff (acc l) = l
| [] := rfl
| [a] := rfl
| (a :: b :: l) :=
begin
  rw [acc, diff], congr' 1, apply diff₀_acc
end

def pnat_sols (k n : ℕ) :=
 { l : list ℕ+ // l.length = k ∧ (l.map (coe : ℕ+ → ℕ)).sum = n }

namespace pnat_sols

def nil : pnat_sols 0 0 := ⟨[],⟨rfl,rfl⟩⟩

def cons {k n m : ℕ} (i : ℕ+) (e : (i : ℕ) + n = m) (l : pnat_sols k n) :
  pnat_sols (k + 1) m :=
⟨ i :: l.val,
  begin
   split,
   rw [list.length, l.property.left],
   rw [list.map, list.sum_cons, l.property.right, e]
  end ⟩

lemma cons_inj {k n m : ℕ} (i : ℕ+) (e : (i : ℕ) + n = m) :
  function.injective (cons i e : pnat_sols k n → pnat_sols (k + 1) m) :=
begin
  rintros ⟨l₀,⟨hl₀,hs₀⟩⟩ ⟨l₁,⟨hl₁,hs₁⟩⟩ el,
  apply subtype.eq, change l₀ = l₁,
  replace el := congr_arg subtype.val el,
  injection el
end

def cons' {k n : ℕ} (i : fin n) (l : pnat_sols k (n - 1 - i)) :
    pnat_sols (k + 1) n :=
cons (nat.succ_pnat i)
  ( by { cases n with m, { exact fin.elim0 i},
         let i0 : ℕ := i,
         change (i0 + 1) + ((m + 1) - 1 - i0) = m + 1,
         have : m + 1 - 1 = m := nat.pred_succ m,
         rw [this, add_comm, ← add_assoc],
         have : i0 ≤ m := nat.le_of_lt_succ i.is_lt,
         rw [nat.sub_add_cancel this] }) l

lemma cons'_inj {k n : ℕ} (i : fin n) :
  function.injective (cons' i : pnat_sols k (n - 1 - i) → pnat_sols (k + 1) n) :=
λ l₀ l₁ e, cons_inj _ _ e

instance enum : ∀ (k n : ℕ), enumeration (pnat_sols k n)
| 0 0 :=
  { elems := [nil],
    nodup := list.nodup_singleton nil,
    complete := λ l, list.mem_singleton.mpr $ subtype.eq $
                list.eq_nil_of_length_eq_zero $ l.property.left }
| 0 (n + 1) :=
  { elems := [],
    nodup := list.nodup_nil,
    complete := λ ⟨l,⟨hl,hs⟩⟩,
      begin
        exfalso,
        rw [list.eq_nil_of_length_eq_zero hl] at hs,
        exact (nat.succ_ne_zero n).symm hs,
      end }
| (k + 1) n :=
  { elems :=
     (fin.enum n).elems.bind (λ i, (enum k (n - 1 - i)).elems.map (cons' i)),
    nodup :=
    begin
      apply list.nodup_bind.mpr; split,
      { intros i hi,
        exact list.nodup.map (cons'_inj i) (enum k (n - 1 - i)).nodup },
      { have hd : ∀ (i₀ i₁ : fin n), i₀ ≠ i₁ →
          list.disjoint
            ((enum k (n - 1 - i₀)).elems.map (cons' i₀))
            ((enum k (n - 1 - i₁)).elems.map (cons' i₁)) :=
        λ i₀ i₁ hn, begin
          intros l h₀ h₁,
          rcases list.mem_map.mp h₀ with ⟨l₀,⟨hm₀,he₀⟩⟩,
          rcases list.mem_map.mp h₁ with ⟨l₁,⟨hm₁,he₁⟩⟩,
          let he := congr_arg subtype.val (he₀.trans he₁.symm),
          injection he with hei hel,
          exact hn (fin.eq_of_veq (nat.succ_pnat_inj hei)),
        end,
        apply list.pairwise.imp hd enumeration.nodup }
    end,
    complete := λ l,
    begin
      rcases l with ⟨l,⟨hl,hs⟩⟩,
      cases l with i l,
      { rcases hl },
      { rw [list.length] at hl, replace hl := nat.succ_inj'.mp hl,
        let i0 := (i : ℕ).pred,
        have hi0 : i = nat.succ_pnat i0 :=
          pnat.eq (nat.succ_pred_eq_of_pos i.pos).symm,
        rw [list.map, list.sum_cons, hi0, nat.succ_pnat_coe, add_comm,
            nat.succ_eq_add_one] at hs,
        have i0_is_lt := nat.lt_of_lt_of_le (i0.lt_succ_self)
         (nat.le_add_left (i0 + 1) (l.map (coe : ℕ+ → ℕ)).sum),
        rw [hs] at i0_is_lt,
        let i1 : fin n := ⟨i0,i0_is_lt⟩,
        have hi1 : i1 ∈ enumeration.elems :=
          enumeration.complete i1,
        apply list.mem_bind.mpr,
        use i1, use hi1,
        rw [list.mem_map],
        rw [add_comm, add_comm i0] at hs,
        let hs1 : n - (1 + i0) = (l.map coe).sum := tsub_eq_of_eq_add_rev hs.symm,
        rw [← nat.sub_sub] at hs1,
        use ⟨l,⟨hl,hs1.symm⟩⟩,
        split,
        { apply enumeration.complete },
        { rw [cons', cons], apply subtype.eq,
          change list.cons i0.succ_pnat l = list.cons i l,
          rw [hi0] } }
    end
  }

/-
def to_finset {n k : ℕ} : pnat_sols (k + 1) (n + 1) →
 { s : finset (fin n) // s.card = k} := sorry
-/

end pnat_sols

end combinatorics


import tactic
import data.set
import .lesson2

noncomputable theory
open_locale classical

open PreHilbertPlane
open HilbertPlane
open set

section plane_separation

variables {Ω : Type*} [HilbertPlane Ω]

variables {A B C : Ω}
variables {ℓ r s : Line Ω}

lemma same_side.refl : same_side ℓ A A :=
begin
    by_cases hA : A ∈ ℓ,
        exact or.inl ⟨hA, hA⟩,
    {
        unfold same_side,
        rw [point_is_segment A, set.singleton_inter_eq_empty],
        exact or.inr hA,
    }
end

lemma same_side.symm :
		same_side ℓ A B → same_side ℓ B A :=
begin
	unfold same_side,
	intro h,
	rw segments_are_symmetric,
	tauto,
end

lemma same_side.symm_iff :
		same_side ℓ A B ↔ same_side ℓ B A :=
begin
    split;
    apply same_side.symm,
end

lemma point_not_on_line_of_line_segment_not_intersect_left (h : (pts (A⬝B) ∩ ℓ) = ∅) : A ∉ ℓ :=
begin
    intro H,
    rw [set.eq_empty_iff_forall_not_mem] at h,
    apply h A,
    simpa,
end

lemma point_not_on_line_of_line_segment_not_intersect_right (h : pts (A⬝B) ∩ ℓ = ∅) : B ∉ ℓ :=
begin
    rw segments_are_symmetric at h,
    exact point_not_on_line_of_line_segment_not_intersect_left h,
end

lemma point_on_line_of_same_side (h : same_side ℓ A B) : A ∈ ℓ ↔ B ∈ ℓ :=
begin
    unfold same_side at h,
    cases h,
    tauto,
    {
        have hcl := point_not_on_line_of_line_segment_not_intersect_left h,
        have hcr := point_not_on_line_of_line_segment_not_intersect_right h,
        tauto,
    }
end

lemma same_side_trans_of_noncollinear (h : ¬ collinear_triple A C B):
	same_side ℓ A B → same_side ℓ B C → same_side ℓ A C :=
begin
	intros hAB hBC,
    unfold same_side at *,
    have H1 := point_on_line_of_same_side hAB,
    have H2 := point_on_line_of_same_side hBC,
    by_cases hA : A ∈ ℓ, by exact or.inl ⟨hA, H2.1 (H1.1 hA)⟩,
    replace hAB : pts (A⬝B) ∩ ℓ = ∅, tauto,
    have hB : B ∉ ℓ := point_not_on_line_of_line_segment_not_intersect_right hAB,
    replace hBC : pts (B⬝C) ∩ ℓ = ∅, tauto,
    have hC : C ∉ ℓ := point_not_on_line_of_line_segment_not_intersect_right hBC,
    right,
	rw set.eq_empty_iff_forall_not_mem,
    -- Now the main part of the proof. AC ∩ ℓ = ∅
    -- So let D be a point in AC and in ℓ. We'll prove False.
	rintro D ⟨ hDAC1, hD⟩,
    obtain rfl | hAD := em(D = A), exact hA hD, -- D ≠ A
    obtain rfl | hCD := em(D = C), exact hC hD, -- D ≠ C
    simp [segments_are_symmetric] at hDAC1,
    have hDAC : A * D * C, by tauto,
	rcases (B4 h hA hC hB hD hDAC) with
		⟨ ⟨E, hE, h1⟩, hF⟩ | ⟨ ⟨E, ⟨ hE, h1⟩ ⟩, hF⟩,
	{
        suffices l_meets_AB : (pts (A⬝B) ∩ ℓ ≠ ∅), by tauto,
        apply set.nmem_singleton_empty.mpr,
        exact ⟨E, ⟨or.inr (or.inr h1), hE⟩⟩,
	},
    {
        suffices l_meets_CB : pts (B⬝C) ∩ ℓ ≠ ∅, by tauto,
        apply set.nmem_singleton_empty.mpr,
        rw [segments_are_symmetric, set.nonempty_def],
        exact ⟨E, ⟨or.inr (or.inr h1), hE⟩⟩,
    },
end

end plane_separation


theorem prove_P_implies_Q (P Q : Prop) (HQ : Q) : P → Q :=
begin
  intro HP,
  exact HQ
end


import Mathlib.Data.Rat.Basic
import Mathlib.Data.List.Sort
import Std.Tactic.SimpTrace

-- (x^2+n)/(2x)

def rat_sqrt_aux (n : ℚ) (q : ℚ) : ℕ → ℚ
| 0 => q
| (k + 1) => rat_sqrt_aux n (q - (q ^ 2 - n) / (2 * q)) k

def rat_sqrt_approx (q : ℚ) : ℚ :=
  if q < 0 then
    0
  else
    (Nat.sqrt q.num.natAbs : ℚ) / (Nat.sqrt q.den)

def rat_sqrt (q : ℚ) : ℚ := rat_sqrt_aux q (rat_sqrt_approx q) 6

theorem will_converge (q : ℚ) (hq : q.den ≠ 1) : (q - q.floor)⁻¹.den < q.den := sorry

def continued_fraction : ℚ → List ℤ
| q =>
  if h : q.den = 1 then
    [q.num]
  else
    let _ := will_converge q h
    q.floor :: continued_fraction (1 / (q - q.floor))
  termination_by _ q => q.den

def func' (n : ℕ) (a0 : ℕ) (data : ℕ × ℕ × ℕ) : ℕ × ℕ × ℕ :=
  -- a * s - r, (n - (a * s - r) ^ 2) / s)
  let (a, r, s) := data
  let r' : ℕ := a * s - r
  let s' : ℕ := (n - r' ^ 2) / s
  let a' : ℕ := (r' + a0) / s'
  (a', r', s')

-- clearly aux naming
def cf_sqrt_aux (n k n0 : ℕ) : List (ℕ × ℕ × ℕ) :=
  match k with
  | 0 => [(n0, 0, 1)]
  | k + 1 =>
    let data := cf_sqrt_aux n k n0
    data ++ [func' n n0 data.getLast!]

theorem cf_sqrt_aux_ne_empty : cf_sqrt_aux n k n0 ≠ [] := by
  cases k
  rintro ⟨⟩
  rw [cf_sqrt_aux]
  apply List.append_ne_nil_of_ne_nil_right
  apply List.ne_nil_of_length_eq_succ
  apply List.length_singleton

def cf_sqrt (n k : ℕ) : List ℕ := (cf_sqrt_aux n k n.sqrt).map (λ s => s.1)

-- such great naming! this is only for *computation* not for *proving*
def cf_sqrt_convs (n k : ℕ) : List ℚ := Id.run do
  if k = 0 then
    return []
  else if k = 1 then
    return [n.sqrt]
  else
    let data := cf_sqrt n k
    let a1 ← data[1]!
    let mut f0 : ℚ := n.sqrt
    let mut f1 : ℚ := ((a1 * f0.num + 1) / (a1 * f0.den : ℚ))
    let mut res : Array ℚ := Array.mkArray k 0
    res ← res.set! 0 f0
    res ← res.set! 1 f1
    for i in [2 : k] do
      let ai := data[i]!
      res ← res.set! i ((ai * f1.num + f0.num) / (ai * f1.den + f0.den : ℚ))
      f0 ← f1
      f1 ← res[i]!
    return res.toList

-- finds minimal (x, y) such that x^2 - dy^2 = 1
-- only considers first 50 convergents (Sage says it's enough)
def solve_pell (d : ℕ) : Option (ℕ × ℕ) := Id.run do
  let data := cf_sqrt_convs d 50
  for q in data do
    let x := q.num.natAbs
    let y := q.den
    if x ^ 2 - d * y ^ 2 = 1 then
      return some (x, y)
  return none

-- instance decidableLoHiLe (lo hi : ℕ) (P : ℕ → Prop) [DecidablePred P] :
--     Decidable (∀ x, lo ≤ x → x ≤ hi → P x) :=
--   decidable_of_iff (∀ x, lo ≤ x → x < hi + 1 → P x) <|
--     ball_congr fun _ _ => imp_congr lt_succ_iff Iff.rfl

-- (859, 2058844771979643060124010, 70246877103894937291269)
#eval ((((List.range' 1 1000).filter (λ k => k.sqrt ^ 2 ≠ k)).map (λ k => (k, (solve_pell k).get!))).mergeSort (λ x y : ℕ × ℕ × ℕ => x.2.1 > y.2.1))[1]!


/-
Copyright (c) 2022 Robert Y. Lewis. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Robert Y. Lewis, Heather Macbeth
-/
import data.nat.cast.with_top
import field_theory.is_alg_closed.basic
import ring_theory.witt_vector.discrete_valuation_ring

/-!
# Solving equations about the Frobenius map on the field of fractions of `𝕎 k`

The goal of this file is to prove `witt_vector.exists_frobenius_solution_fraction_ring`,
which says that for an algebraically closed field `k` of characteristic `p` and `a, b` in the
field of fractions of Witt vectors over `k`,
there is a solution `b` to the equation `φ b * a = p ^ m * b`, where `φ` is the Frobenius map.

Most of this file builds up the equivalent theorem over `𝕎 k` directly,
moving to the field of fractions at the end.
See `witt_vector.frobenius_rotation` and its specification.

The construction proceeds by recursively defining a sequence of coefficients as solutions to a
polynomial equation in `k`. We must define these as generic polynomials using Witt vector API
(`witt_vector.witt_mul`, `witt_polynomial`) to show that they satisfy the desired equation.

Preliminary work is done in the dependency `ring_theory.witt_vector.mul_coeff`
to isolate the `n+1`st coefficients of `x` and `y` in the `n+1`st coefficient of `x*y`.

This construction is described in Dupuis, Lewis, and Macbeth,
[Formalized functional analysis via semilinear maps][dupuis-lewis-macbeth2022].
We approximately follow an approach sketched on MathOverflow:
<https://mathoverflow.net/questions/62468/about-frobenius-of-witt-vectors>

The result is a dependency for the proof of `witt_vector.isocrystal_classification`,
the classification of one-dimensional isocrystals over an algebraically closed field.
-/

noncomputable theory

namespace witt_vector

variables (p : ℕ) [hp : fact p.prime]
local notation `𝕎` := witt_vector p

namespace recursion_main

/-!

## The recursive case of the vector coefficients

The first coefficient of our solution vector is easy to define below.
In this section we focus on the recursive case.
The goal is to turn `witt_poly_prod n` into a univariate polynomial
whose variable represents the `n`th coefficient of `x` in `x * a`.

-/

section comm_ring
include hp
variables {k : Type*} [comm_ring k] [char_p k p]
open polynomial

/-- The root of this polynomial determines the `n+1`st coefficient of our solution. -/
def succ_nth_defining_poly (n : ℕ) (a₁ a₂ : 𝕎 k) (bs : fin (n+1) → k) : polynomial k :=
X^p * C (a₁.coeff 0 ^ (p^(n+1))) - X * C (a₂.coeff 0 ^ (p^(n+1)))
  + C (a₁.coeff (n+1) * ((bs 0)^p)^(p^(n+1)) +
      nth_remainder p n (λ v, (bs v)^p) (truncate_fun (n+1) a₁) -
      a₂.coeff (n+1) * (bs 0)^p^(n+1) - nth_remainder p n bs (truncate_fun (n+1) a₂))

lemma succ_nth_defining_poly_degree [is_domain k] (n : ℕ) (a₁ a₂ : 𝕎 k) (bs : fin (n+1) → k)
  (ha₁ : a₁.coeff 0 ≠ 0) (ha₂ : a₂.coeff 0 ≠ 0) :
  (succ_nth_defining_poly p n a₁ a₂ bs).degree = p :=
begin
  have : (X ^ p * C (a₁.coeff 0 ^ p ^ (n+1))).degree = p,
  { rw [degree_mul, degree_C],
    { simp only [nat.cast_with_bot, add_zero, degree_X, degree_pow, nat.smul_one_eq_coe] },
    { exact pow_ne_zero _ ha₁ } },
  have : (X ^ p * C (a₁.coeff 0 ^ p ^ (n+1)) - X * C (a₂.coeff 0 ^ p ^ (n+1))).degree = p,
  { rw [degree_sub_eq_left_of_degree_lt, this],
    rw [this, degree_mul, degree_C, degree_X, add_zero],
    { exact_mod_cast hp.out.one_lt },
    { exact pow_ne_zero _ ha₂ } },
  rw [succ_nth_defining_poly, degree_add_eq_left_of_degree_lt, this],
  apply lt_of_le_of_lt (degree_C_le),
  rw [this],
  exact_mod_cast hp.out.pos
end

end comm_ring

section is_alg_closed
include hp
variables {k : Type*} [field k] [char_p k p] [is_alg_closed k]

lemma root_exists (n : ℕ) (a₁ a₂ : 𝕎 k) (bs : fin (n+1) → k)
  (ha₁ : a₁.coeff 0 ≠ 0) (ha₂ : a₂.coeff 0 ≠ 0) :
  ∃ b : k, (succ_nth_defining_poly p n a₁ a₂ bs).is_root b :=
is_alg_closed.exists_root _ $
  by simp only [(succ_nth_defining_poly_degree p n a₁ a₂ bs ha₁ ha₂), hp.out.ne_zero,
    with_top.coe_eq_zero, ne.def, not_false_iff]

/-- This is the `n+1`st coefficient of our solution, projected from `root_exists`. -/
def succ_nth_val (n : ℕ) (a₁ a₂ : 𝕎 k) (bs : fin (n+1) → k)
  (ha₁ : a₁.coeff 0 ≠ 0) (ha₂ : a₂.coeff 0 ≠ 0) : k :=
classical.some (root_exists p n a₁ a₂ bs ha₁ ha₂)

lemma succ_nth_val_spec (n : ℕ) (a₁ a₂ : 𝕎 k) (bs : fin (n+1) → k)
  (ha₁ : a₁.coeff 0 ≠ 0) (ha₂ : a₂.coeff 0 ≠ 0) :
  (succ_nth_defining_poly p n a₁ a₂ bs).is_root (succ_nth_val p n a₁ a₂ bs ha₁ ha₂) :=
classical.some_spec (root_exists p n a₁ a₂ bs ha₁ ha₂)

lemma succ_nth_val_spec' (n : ℕ) (a₁ a₂ : 𝕎 k) (bs : fin (n+1) → k)
  (ha₁ : a₁.coeff 0 ≠ 0) (ha₂ : a₂.coeff 0 ≠ 0) :
  (succ_nth_val p n a₁ a₂ bs ha₁ ha₂)^p * a₁.coeff 0 ^ (p^(n+1)) +
    a₁.coeff (n+1) * ((bs 0)^p)^(p^(n+1)) +
    nth_remainder p n (λ v, (bs v)^p) (truncate_fun (n+1) a₁)
   = (succ_nth_val p n a₁ a₂ bs ha₁ ha₂) * a₂.coeff 0 ^ (p^(n+1)) +
     a₂.coeff (n+1) * (bs 0)^(p^(n+1)) + nth_remainder p n bs (truncate_fun (n+1) a₂) :=
begin
  rw ← sub_eq_zero,
  have := succ_nth_val_spec p n a₁ a₂ bs ha₁ ha₂,
  simp only [polynomial.map_add, polynomial.eval_X, polynomial.map_pow, polynomial.eval_C,
    polynomial.eval_pow, succ_nth_defining_poly, polynomial.eval_mul, polynomial.eval_add,
    polynomial.eval_sub, polynomial.map_mul, polynomial.map_sub, polynomial.is_root.def] at this,
  convert this using 1,
  ring
end

end is_alg_closed
end recursion_main

namespace recursion_base
include hp
variables {k : Type*} [field k] [is_alg_closed k]

lemma solution_pow (a₁ a₂ : 𝕎 k) :
  ∃ x : k, x^(p-1) = a₂.coeff 0 / a₁.coeff 0 :=
is_alg_closed.exists_pow_nat_eq _ $ by linarith [hp.out.one_lt, le_of_lt hp.out.one_lt]

/-- The base case (0th coefficient) of our solution vector. -/
def solution (a₁ a₂ : 𝕎 k) : k :=
classical.some $ solution_pow p a₁ a₂

lemma solution_spec (a₁ a₂ : 𝕎 k) :
  (solution p a₁ a₂)^(p-1) = a₂.coeff 0 / a₁.coeff 0 :=
classical.some_spec $ solution_pow p a₁ a₂

lemma solution_nonzero {a₁ a₂ : 𝕎 k} (ha₁ : a₁.coeff 0 ≠ 0) (ha₂ : a₂.coeff 0 ≠ 0) :
  solution p a₁ a₂ ≠ 0 :=
begin
  intro h,
  have := solution_spec p a₁ a₂,
  rw [h, zero_pow] at this,
  { simpa [ha₁, ha₂] using _root_.div_eq_zero_iff.mp this.symm },
  { linarith [hp.out.one_lt, le_of_lt hp.out.one_lt] }
end

lemma solution_spec' {a₁ : 𝕎 k} (ha₁ : a₁.coeff 0 ≠ 0) (a₂ : 𝕎 k) :
  (solution p a₁ a₂)^p * a₁.coeff 0 = (solution p a₁ a₂) * a₂.coeff 0 :=
begin
  have := solution_spec p a₁ a₂,
  cases nat.exists_eq_succ_of_ne_zero hp.out.ne_zero with q hq,
  have hq' : q = p - 1 := by simp only [hq, tsub_zero, nat.succ_sub_succ_eq_sub],
  conv_lhs {congr, congr, skip, rw hq},
  rw [pow_succ', hq', this],
  field_simp [ha₁, mul_comm],
end

end recursion_base

open recursion_main recursion_base

section frobenius_rotation

section is_alg_closed
include hp
variables {k : Type*} [field k] [char_p k p] [is_alg_closed k]

/--
Recursively defines the sequence of coefficients for `witt_vector.frobenius_rotation`.
-/
noncomputable def frobenius_rotation_coeff {a₁ a₂ : 𝕎 k}
  (ha₁ : a₁.coeff 0 ≠ 0) (ha₂ : a₂.coeff 0 ≠ 0) : ℕ → k
| 0       := solution p a₁ a₂
| (n + 1) := succ_nth_val p n a₁ a₂ (λ i, frobenius_rotation_coeff i.val) ha₁ ha₂
using_well_founded { dec_tac := `[apply fin.is_lt] }

/--
For nonzero `a₁` and `a₂`, `frobenius_rotation a₁ a₂` is a Witt vector that satisfies the
equation `frobenius (frobenius_rotation a₁ a₂) * a₁ = (frobenius_rotation a₁ a₂) * a₂`.
-/
def frobenius_rotation {a₁ a₂ : 𝕎 k} (ha₁ : a₁.coeff 0 ≠ 0) (ha₂ : a₂.coeff 0 ≠ 0) : 𝕎 k :=
witt_vector.mk p (frobenius_rotation_coeff p ha₁ ha₂)

lemma frobenius_rotation_nonzero {a₁ a₂ : 𝕎 k} (ha₁ : a₁.coeff 0 ≠ 0) (ha₂ : a₂.coeff 0 ≠ 0) :
  frobenius_rotation p ha₁ ha₂ ≠ 0 :=
begin
  intro h,
  apply solution_nonzero p ha₁ ha₂,
  simpa [← h, frobenius_rotation, frobenius_rotation_coeff] using witt_vector.zero_coeff p k 0
end

lemma frobenius_frobenius_rotation {a₁ a₂ : 𝕎 k} (ha₁ : a₁.coeff 0 ≠ 0) (ha₂ : a₂.coeff 0 ≠ 0) :
  frobenius (frobenius_rotation p ha₁ ha₂) * a₁ = (frobenius_rotation p ha₁ ha₂) * a₂ :=
begin
  ext n,
  induction n with n ih,
  { simp only [witt_vector.mul_coeff_zero, witt_vector.coeff_frobenius_char_p,
      frobenius_rotation, frobenius_rotation_coeff],
    apply solution_spec' _ ha₁ },
  { simp only [nth_remainder_spec, witt_vector.coeff_frobenius_char_p, frobenius_rotation_coeff,
      frobenius_rotation, fin.val_eq_coe],
    have := succ_nth_val_spec' p n a₁ a₂
      (λ (i : fin (n + 1)), frobenius_rotation_coeff p ha₁ ha₂ i.val) ha₁ ha₂,
    simp only [frobenius_rotation_coeff, fin.val_eq_coe, fin.val_zero] at this,
    convert this using 4,
    apply truncated_witt_vector.ext,
    intro i,
    simp only [fin.val_eq_coe, witt_vector.coeff_truncate_fun, witt_vector.coeff_frobenius_char_p],
    refl }
end

local notation `φ` := is_fraction_ring.field_equiv_of_ring_equiv (frobenius_equiv p k)

lemma exists_frobenius_solution_fraction_ring_aux
  (m n : ℕ) (r' q' : 𝕎 k) (hr' : r'.coeff 0 ≠ 0) (hq' : q'.coeff 0 ≠ 0)
  (hq : ↑p ^ n * q' ∈ non_zero_divisors (𝕎 k)) :
  let b : 𝕎 k := frobenius_rotation p hr' hq' in
  is_fraction_ring.field_equiv_of_ring_equiv
      (frobenius_equiv p k)
      (algebra_map (𝕎 k) (fraction_ring (𝕎 k)) b) *
    localization.mk (↑p ^ m * r') ⟨↑p ^ n * q', hq⟩ =
  ↑p ^ (m - n : ℤ) * algebra_map (𝕎 k) (fraction_ring (𝕎 k)) b :=
begin
  intros b,
  have key : witt_vector.frobenius b * p ^ m * r' * p ^ n = p ^ m * b * (p ^ n * q'),
  { have H := congr_arg (λ x : 𝕎 k, x * p ^ m * p ^ n) (frobenius_frobenius_rotation p hr' hq'),
    dsimp at H,
    refine (eq.trans _ H).trans _; ring },
  have hq'' : algebra_map (𝕎 k) (fraction_ring (𝕎 k)) q' ≠ 0,
  { have hq''' : q' ≠ 0 := λ h, hq' (by simp [h]),
    simpa only [ne.def, map_zero] using
      (is_fraction_ring.injective (𝕎 k) (fraction_ring (𝕎 k))).ne hq''' },
  rw zpow_sub₀ (fraction_ring.p_nonzero p k),
  field_simp [fraction_ring.p_nonzero p k],
  simp only [is_fraction_ring.field_equiv_of_ring_equiv,
    is_localization.ring_equiv_of_ring_equiv_eq, ring_equiv.coe_of_bijective],
  convert congr_arg (λ x, algebra_map (𝕎 k) (fraction_ring (𝕎 k)) x) key using 1,
  { simp only [ring_hom.map_mul, ring_hom.map_pow, map_nat_cast, frobenius_equiv_apply],
    ring },
  { simp only [ring_hom.map_mul, ring_hom.map_pow, map_nat_cast] }
end

end is_alg_closed

end frobenius_rotation

end witt_vector


import TutorialWorld.Level1
import TutorialWorld.Level2
import TutorialWorld.Level3
import TutorialWorld.Level4

/-!
# Natural Numbers Tutorial

This tutorial is based on the [Natural Number
Game](https://www.ma.imperial.ac.uk/~buzzard/xena/natural_number_game/)
by Kevin Buzzard and Mohammad Pedramfar.

This tutorial provides the same content in a book format that is designed to
be [read online](https://lovettsoftware.com/NaturalNumbers) or run in your
local Visual Studio Code with the Lean4 "extension".
The extension will install the Lean4 compiler and language
service for you so it is easy to setup - see the [Quick
Start](https://leanprover.github.io/lean4/doc/quickstart.html) for more information.

To run this tutorial in Visual Studio Code, first
clone the [https://github.com/leanprover/lean4-samples](https://github.com/leanprover/lean4-samples)
repo.  Then you must open the `NaturalNumbers` folder in Visual Studio Code using `File/Open folder` in order
for it to function correctly.

## How to use this sample

When reading this content in a web browser the code samples are annotated with type information
and you can see the proof tactic state by hovering your mouse over these little bubbles that
look like this:

![screen](./assets/screen.png)

When viewing this content in Visual Studio Code you will find this tactic state information
in the Lean extension "Info View" panel.

This sample is organized into sections called "worlds" and each section has a sequential set of
learning levels. The idea is that you should work through the worlds and levels in order.
Each level has a description of the goal and a set of tasks to complete.

In this sample you will not use the built in support for natural numbers in Lean because that would
be too easy.  You will start from scratch defining your own new type called `MyNat`. Your version of
the natural numbers will satisfy something called the principle of mathematical induction, and a
couple of other things too (Peano's axioms). Since you are starting from scratch, you will have to
prove all the basic theorems about your numbers like `x + y = y + x` and so on. This is your job.
You're going to prove mathematical theorems using the Lean theorem prover.

You're going to prove these theorems using tactics. The introductory world, Tutorial World, will
take you through some of these tactics. During your proofs, your "goal" (i.e. what you're supposed
to be proving) will be displayed in the Visual Studio Code InfoView with a `⊢` symbol in front of
it. If the InfoView says "Goals accomplished 🎉", you have closed all the goals in the level
and can move on to the next level in the world you're in.

You are now ready to dive into [Tutorial World: Level 1](./TutorialWorld/Level1.lean.md).

There is also an "online" version under development that works with Lean 4,
see [https://github.com/PatrickMassot/NNG4](https://github.com/PatrickMassot/NNG4).

If you want to see the original "Lean 3" game version of this content, go to
[https://github.com/ImperialCollegeLondon/natural_number_game](https://github.com/ImperialCollegeLondon/natural_number_game)
which is also hosted in this [online version](https://www.ma.imperial.ac.uk/~buzzard/xena/natural_number_game/).

-/


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

/-!
# Tangent cone

In this file, we define two predicates `unique_diff_within_at 𝕜 s x` and `unique_diff_on 𝕜 s`
ensuring that, if a function has two derivatives, then they have to coincide. As a direct
definition of this fact (quantifying on all target types and all functions) would depend on
universes, we use a more intrinsic definition: if all the possible tangent directions to the set
`s` at the point `x` span a dense subset of the whole subset, it is easy to check that the
derivative has to be unique.

Therefore, we introduce the set of all tangent directions, named `tangent_cone_at`,
and express `unique_diff_within_at` and `unique_diff_on` in terms of it.
One should however think of this definition as an implementation detail: the only reason to
introduce the predicates `unique_diff_within_at` and `unique_diff_on` is to ensure the uniqueness
of the derivative. This is why their names reflect their uses, and not how they are defined.

## Implementation details

Note that this file is imported by `fderiv.lean`. Hence, derivatives are not defined yet. The
property of uniqueness of the derivative is therefore proved in `fderiv.lean`, but based on the
properties of the tangent cone we prove here.
-/

variables (𝕜 : Type*) [nondiscrete_normed_field 𝕜]

open filter set
open_locale topological_space

section tangent_cone

variables {E : Type*} [add_comm_monoid E] [module 𝕜 E] [topological_space E]

/-- The set of all tangent directions to the set `s` at the point `x`. -/
def tangent_cone_at (s : set E) (x : E) : set E :=
{y : E | ∃(c : ℕ → 𝕜) (d : ℕ → E), (∀ᶠ n in at_top, x + d n ∈ s) ∧
  (tendsto (λn, ∥c n∥) at_top at_top) ∧ (tendsto (λn, c n • d n) at_top (𝓝 y))}

/-- A property ensuring that the tangent cone to `s` at `x` spans a dense subset of the whole space.
The main role of this property is to ensure that the differential within `s` at `x` is unique,
hence this name. The uniqueness it asserts is proved in `unique_diff_within_at.eq` in `fderiv.lean`.
To avoid pathologies in dimension 0, we also require that `x` belongs to the closure of `s` (which
is automatic when `E` is not `0`-dimensional).
 -/
@[mk_iff] structure unique_diff_within_at (s : set E) (x : E) : Prop :=
(dense_tangent_cone : dense ((submodule.span 𝕜 (tangent_cone_at 𝕜 s x)) : set E))
(mem_closure : x ∈ closure s)

/-- A property ensuring that the tangent cone to `s` at any of its points spans a dense subset of
the whole space.  The main role of this property is to ensure that the differential along `s` is
unique, hence this name. The uniqueness it asserts is proved in `unique_diff_on.eq` in
`fderiv.lean`. -/
def unique_diff_on (s : set E) : Prop :=
∀x ∈ s, unique_diff_within_at 𝕜 s x

end tangent_cone

variables {E : Type*} [normed_group E] [normed_space 𝕜 E]
variables {F : Type*} [normed_group F] [normed_space 𝕜 F]
variables {G : Type*} [normed_group G] [normed_space ℝ G]
variables {𝕜} {x y : E} {s t : set E}

section tangent_cone
/- This section is devoted to the properties of the tangent cone. -/

open normed_field

lemma tangent_cone_univ : tangent_cone_at 𝕜 univ x = univ :=
begin
  refine univ_subset_iff.1 (λy hy, _),
  rcases exists_one_lt_norm 𝕜 with ⟨w, hw⟩,
  refine ⟨λn, w^n, λn, (w^n)⁻¹ • y, univ_mem_sets' (λn, mem_univ _),  _, _⟩,
  { simp only [norm_pow],
    exact tendsto_pow_at_top_at_top_of_one_lt hw },
  { convert tendsto_const_nhds,
    ext n,
    have : w ^ n * (w ^ n)⁻¹ = 1,
    { apply mul_inv_cancel,
      apply pow_ne_zero,
      simpa [norm_eq_zero] using (ne_of_lt (lt_trans zero_lt_one hw)).symm },
    rw [smul_smul, this, one_smul] }
end

lemma tangent_cone_mono (h : s ⊆ t) :
  tangent_cone_at 𝕜 s x ⊆ tangent_cone_at 𝕜 t x :=
begin
  rintros y ⟨c, d, ds, ctop, clim⟩,
  exact ⟨c, d, mem_sets_of_superset ds (λn hn, h hn), ctop, clim⟩
end

/-- Auxiliary lemma ensuring that, under the assumptions defining the tangent cone,
the sequence `d` tends to 0 at infinity. -/
lemma tangent_cone_at.lim_zero {α : Type*} (l : filter α) {c : α → 𝕜} {d : α → E}
  (hc : tendsto (λn, ∥c n∥) l at_top) (hd : tendsto (λn, c n • d n) l (𝓝 y)) :
  tendsto d l (𝓝 0) :=
begin
  have A : tendsto (λn, ∥c n∥⁻¹) l (𝓝 0) := tendsto_inv_at_top_zero.comp hc,
  have B : tendsto (λn, ∥c n • d n∥) l (𝓝 ∥y∥) :=
    (continuous_norm.tendsto _).comp hd,
  have C : tendsto (λn, ∥c n∥⁻¹ * ∥c n • d n∥) l (𝓝 (0 * ∥y∥)) := A.mul B,
  rw zero_mul at C,
  have : ∀ᶠ n in l, ∥c n∥⁻¹ * ∥c n • d n∥ = ∥d n∥,
  { apply (eventually_ne_of_tendsto_norm_at_top hc 0).mono (λn hn, _),
    rw [norm_smul, ← mul_assoc, inv_mul_cancel, one_mul],
    rwa [ne.def, norm_eq_zero] },
  have D : tendsto (λ n, ∥d n∥) l (𝓝 0) :=
    tendsto.congr' this C,
  rw tendsto_zero_iff_norm_tendsto_zero,
  exact D
end

lemma tangent_cone_mono_nhds (h : 𝓝[s] x ≤ 𝓝[t] x) :
  tangent_cone_at 𝕜 s x ⊆ tangent_cone_at 𝕜 t x :=
begin
  rintros y ⟨c, d, ds, ctop, clim⟩,
  refine ⟨c, d, _, ctop, clim⟩,
  suffices : tendsto (λ n, x + d n) at_top (𝓝[t] x),
    from tendsto_principal.1 (tendsto_inf.1 this).2,
  refine (tendsto_inf.2 ⟨_, tendsto_principal.2 ds⟩).mono_right h,
  simpa only [add_zero] using tendsto_const_nhds.add (tangent_cone_at.lim_zero at_top ctop clim)
end

/-- Tangent cone of `s` at `x` depends only on `𝓝[s] x`. -/
lemma tangent_cone_congr (h : 𝓝[s] x = 𝓝[t] x) :
  tangent_cone_at 𝕜 s x = tangent_cone_at 𝕜 t x :=
subset.antisymm
  (tangent_cone_mono_nhds $ le_of_eq h)
  (tangent_cone_mono_nhds $ le_of_eq h.symm)

/-- Intersecting with a neighborhood of the point does not change the tangent cone. -/
lemma tangent_cone_inter_nhds (ht : t ∈ 𝓝 x) :
  tangent_cone_at 𝕜 (s ∩ t) x = tangent_cone_at 𝕜 s x :=
tangent_cone_congr (nhds_within_restrict' _ ht).symm

/-- The tangent cone of a product contains the tangent cone of its left factor. -/
lemma subset_tangent_cone_prod_left {t : set F} {y : F} (ht : y ∈ closure t) :
  linear_map.inl 𝕜 E F '' (tangent_cone_at 𝕜 s x) ⊆ tangent_cone_at 𝕜 (set.prod s t) (x, y) :=
begin
  rintros _ ⟨v, ⟨c, d, hd, hc, hy⟩, rfl⟩,
  have : ∀n, ∃d', y + d' ∈ t ∧ ∥c n • d'∥ < ((1:ℝ)/2)^n,
  { assume n,
    rcases mem_closure_iff_nhds.1 ht _ (eventually_nhds_norm_smul_sub_lt (c n) y
      (pow_pos one_half_pos n)) with ⟨z, hz, hzt⟩,
    exact ⟨z - y, by simpa using hzt, by simpa using hz⟩ },
  choose d' hd' using this,
  refine ⟨c, λn, (d n, d' n), _, hc, _⟩,
  show ∀ᶠ n in at_top, (x, y) + (d n, d' n) ∈ set.prod s t,
  { filter_upwards [hd],
    assume n hn,
    simp [hn, (hd' n).1] },
  { apply tendsto.prod_mk_nhds hy _,
    refine squeeze_zero_norm (λn, (hd' n).2.le) _,
    exact tendsto_pow_at_top_nhds_0_of_lt_1 one_half_pos.le one_half_lt_one }
end

/-- The tangent cone of a product contains the tangent cone of its right factor. -/
lemma subset_tangent_cone_prod_right {t : set F} {y : F}
  (hs : x ∈ closure s) :
  linear_map.inr 𝕜 E F '' (tangent_cone_at 𝕜 t y) ⊆ tangent_cone_at 𝕜 (set.prod s t) (x, y) :=
begin
  rintros _ ⟨w, ⟨c, d, hd, hc, hy⟩, rfl⟩,
  have : ∀n, ∃d', x + d' ∈ s ∧ ∥c n • d'∥ < ((1:ℝ)/2)^n,
  { assume n,
    rcases mem_closure_iff_nhds.1 hs _ (eventually_nhds_norm_smul_sub_lt (c n) x
      (pow_pos one_half_pos n)) with ⟨z, hz, hzs⟩,
    exact ⟨z - x, by simpa using hzs, by simpa using hz⟩ },
  choose d' hd' using this,
  refine ⟨c, λn, (d' n, d n), _, hc, _⟩,
  show ∀ᶠ n in at_top, (x, y) + (d' n, d n) ∈ set.prod s t,
  { filter_upwards [hd],
    assume n hn,
    simp [hn, (hd' n).1] },
  { apply tendsto.prod_mk_nhds _ hy,
    refine squeeze_zero_norm (λn, (hd' n).2.le) _,
    exact tendsto_pow_at_top_nhds_0_of_lt_1 one_half_pos.le one_half_lt_one }
end

/-- The tangent cone of a product contains the tangent cone of each factor. -/
lemma maps_to_tangent_cone_pi {ι : Type*} [decidable_eq ι] {E : ι → Type*}
  [Π i, normed_group (E i)] [Π i, normed_space 𝕜 (E i)]
  {s : Π i, set (E i)} {x : Π i, E i} {i : ι} (hi : ∀ j ≠ i, x j ∈ closure (s j)) :
  maps_to (linear_map.single i : E i →ₗ[𝕜] Π j, E j) (tangent_cone_at 𝕜 (s i) (x i))
    (tangent_cone_at 𝕜 (set.pi univ s) x) :=
begin
  rintros w ⟨c, d, hd, hc, hy⟩,
  have : ∀ n (j ≠ i), ∃ d', x j + d' ∈ s j ∧ ∥c n • d'∥ < (1 / 2 : ℝ) ^ n,
  { assume n j hj,
    rcases mem_closure_iff_nhds.1 (hi j hj) _ (eventually_nhds_norm_smul_sub_lt (c n) (x j)
      (pow_pos one_half_pos n)) with ⟨z, hz, hzs⟩,
    exact ⟨z - x j, by simpa using hzs, by simpa using hz⟩ },
  choose! d' hd's hcd',
  refine ⟨c, λ n, function.update (d' n) i (d n), hd.mono (λ n hn j hj', _), hc,
    tendsto_pi.2 $ λ j, _⟩,
  { rcases em (j = i) with rfl|hj; simp * },
  { rcases em (j = i) with rfl|hj,
    { simp [hy] },
    { suffices : tendsto (λ n, c n • d' n j) at_top (𝓝 0), by simpa [hj],
      refine squeeze_zero_norm (λ n, (hcd' n j hj).le) _,
      exact tendsto_pow_at_top_nhds_0_of_lt_1 one_half_pos.le one_half_lt_one } }
end

/-- If a subset of a real vector space contains a segment, then the direction of this
segment belongs to the tangent cone at its endpoints. -/
lemma mem_tangent_cone_of_segment_subset {s : set G} {x y : G} (h : segment x y ⊆ s) :
  y - x ∈ tangent_cone_at ℝ s x :=
begin
  let c := λn:ℕ, (2:ℝ)^n,
  let d := λn:ℕ, (c n)⁻¹ • (y-x),
  refine ⟨c, d, filter.univ_mem_sets' (λn, h _), _, _⟩,
  show x + d n ∈ segment x y,
  { rw segment_eq_image,
    refine ⟨(c n)⁻¹, ⟨_, _⟩, _⟩,
    { rw inv_nonneg, apply pow_nonneg, norm_num },
    { apply inv_le_one, apply one_le_pow_of_one_le, norm_num },
    { simp only [d, sub_smul, smul_sub, one_smul], abel } },
  show filter.tendsto (λ (n : ℕ), ∥c n∥) filter.at_top filter.at_top,
  { have : (λ (n : ℕ), ∥c n∥) = c,
      by { ext n, exact abs_of_nonneg (pow_nonneg (by norm_num) _) },
    rw this,
    exact tendsto_pow_at_top_at_top_of_one_lt (by norm_num) },
  show filter.tendsto (λ (n : ℕ), c n • d n) filter.at_top (𝓝 (y - x)),
  { have : (λ (n : ℕ), c n • d n) = (λn, y - x),
    { ext n,
      simp only [d, smul_smul],
      rw [mul_inv_cancel, one_smul],
      exact pow_ne_zero _ (by norm_num) },
    rw this,
    apply tendsto_const_nhds }
end

end tangent_cone

section unique_diff
/-!
### Properties of `unique_diff_within_at` and `unique_diff_on`

This section is devoted to properties of the predicates
`unique_diff_within_at` and `unique_diff_on`. -/

lemma unique_diff_on.unique_diff_within_at {s : set E} {x} (hs : unique_diff_on 𝕜 s) (h : x ∈ s) :
  unique_diff_within_at 𝕜 s x :=
hs x h

lemma unique_diff_within_at_univ : unique_diff_within_at 𝕜 univ x :=
by { rw [unique_diff_within_at_iff, tangent_cone_univ], simp }

lemma unique_diff_on_univ : unique_diff_on 𝕜 (univ : set E) :=
λx hx, unique_diff_within_at_univ

lemma unique_diff_on_empty : unique_diff_on 𝕜 (∅ : set E) :=
λ x hx, hx.elim

lemma unique_diff_within_at.mono_nhds (h : unique_diff_within_at 𝕜 s x)
  (st : 𝓝[s] x ≤ 𝓝[t] x) :
  unique_diff_within_at 𝕜 t x :=
begin
  simp only [unique_diff_within_at_iff] at *,
  rw [mem_closure_iff_nhds_within_ne_bot] at h ⊢,
  exact ⟨h.1.mono $ submodule.span_mono $ tangent_cone_mono_nhds st,
    h.2.mono st⟩
end

lemma unique_diff_within_at.mono (h : unique_diff_within_at 𝕜 s x) (st : s ⊆ t) :
  unique_diff_within_at 𝕜 t x :=
h.mono_nhds $ nhds_within_mono _ st

lemma unique_diff_within_at_congr (st : 𝓝[s] x = 𝓝[t] x) :
  unique_diff_within_at 𝕜 s x ↔ unique_diff_within_at 𝕜 t x :=
⟨λ h, h.mono_nhds $ le_of_eq st, λ h, h.mono_nhds $ le_of_eq st.symm⟩

lemma unique_diff_within_at_inter (ht : t ∈ 𝓝 x) :
  unique_diff_within_at 𝕜 (s ∩ t) x ↔ unique_diff_within_at 𝕜 s x :=
unique_diff_within_at_congr $ (nhds_within_restrict' _ ht).symm

lemma unique_diff_within_at.inter (hs : unique_diff_within_at 𝕜 s x) (ht : t ∈ 𝓝 x) :
  unique_diff_within_at 𝕜 (s ∩ t) x :=
(unique_diff_within_at_inter ht).2 hs

lemma unique_diff_within_at_inter' (ht : t ∈ 𝓝[s] x) :
  unique_diff_within_at 𝕜 (s ∩ t) x ↔ unique_diff_within_at 𝕜 s x :=
unique_diff_within_at_congr $ (nhds_within_restrict'' _ ht).symm

lemma unique_diff_within_at.inter' (hs : unique_diff_within_at 𝕜 s x) (ht : t ∈ 𝓝[s] x) :
  unique_diff_within_at 𝕜 (s ∩ t) x :=
(unique_diff_within_at_inter' ht).2 hs

lemma unique_diff_within_at_of_mem_nhds (h : s ∈ 𝓝 x) : unique_diff_within_at 𝕜 s x :=
by simpa only [univ_inter] using unique_diff_within_at_univ.inter h

lemma is_open.unique_diff_within_at (hs : is_open s) (xs : x ∈ s) : unique_diff_within_at 𝕜 s x :=
unique_diff_within_at_of_mem_nhds (mem_nhds_sets hs xs)

lemma unique_diff_on.inter (hs : unique_diff_on 𝕜 s) (ht : is_open t) : unique_diff_on 𝕜 (s ∩ t) :=
λx hx, (hs x hx.1).inter (mem_nhds_sets ht hx.2)

lemma is_open.unique_diff_on (hs : is_open s) : unique_diff_on 𝕜 s :=
λx hx, is_open.unique_diff_within_at hs hx

/-- The product of two sets of unique differentiability at points `x` and `y` has unique
differentiability at `(x, y)`. -/
lemma unique_diff_within_at.prod {t : set F} {y : F}
  (hs : unique_diff_within_at 𝕜 s x) (ht : unique_diff_within_at 𝕜 t y) :
  unique_diff_within_at 𝕜 (set.prod s t) (x, y) :=
begin
  rw [unique_diff_within_at_iff] at ⊢ hs ht,
  rw [closure_prod_eq],
  refine ⟨_, hs.2, ht.2⟩,
  have : _ ≤ submodule.span 𝕜 (tangent_cone_at 𝕜 (s.prod t) (x, y)) :=
    submodule.span_mono (union_subset (subset_tangent_cone_prod_left ht.2)
      (subset_tangent_cone_prod_right hs.2)),
  rw [linear_map.span_inl_union_inr, set_like.le_def] at this,
  exact (hs.1.prod ht.1).mono this
end

lemma unique_diff_within_at.univ_pi (ι : Type*) [fintype ι] (E : ι → Type*)
  [Π i, normed_group (E i)] [Π i, normed_space 𝕜 (E i)]
  (s : Π i, set (E i)) (x : Π i, E i) (h : ∀ i, unique_diff_within_at 𝕜 (s i) (x i)) :
  unique_diff_within_at 𝕜 (set.pi univ s) x :=
begin
  classical,
  simp only [unique_diff_within_at_iff, closure_pi_set] at h ⊢,
  refine ⟨(dense_pi univ (λ i _, (h i).1)).mono _, λ i _, (h i).2⟩,
  norm_cast,
  simp only [← submodule.supr_map_single, supr_le_iff, linear_map.map_span, submodule.span_le,
    ← maps_to'],
  exact λ i, (maps_to_tangent_cone_pi $ λ j hj, (h j).2).mono subset.rfl submodule.subset_span
end

lemma unique_diff_within_at.pi (ι : Type*) [fintype ι] (E : ι → Type*)
  [Π i, normed_group (E i)] [Π i, normed_space 𝕜 (E i)]
  (s : Π i, set (E i)) (x : Π i, E i) (I : set ι)
  (h : ∀ i ∈ I, unique_diff_within_at 𝕜 (s i) (x i)) :
  unique_diff_within_at 𝕜 (set.pi I s) x :=
begin
  classical,
  rw [← set.univ_pi_piecewise],
  refine unique_diff_within_at.univ_pi _ _ _ _ (λ i, _),
  by_cases hi : i ∈ I; simp [*, unique_diff_within_at_univ],
end

/-- The product of two sets of unique differentiability is a set of unique differentiability. -/
lemma unique_diff_on.prod {t : set F} (hs : unique_diff_on 𝕜 s) (ht : unique_diff_on 𝕜 t) :
  unique_diff_on 𝕜 (set.prod s t) :=
λ ⟨x, y⟩ h, unique_diff_within_at.prod (hs x h.1) (ht y h.2)

/-- The finite product of a family of sets of unique differentiability is a set of unique
differentiability. -/
lemma unique_diff_on.pi (ι : Type*) [fintype ι] (E : ι → Type*)
  [Π i, normed_group (E i)] [Π i, normed_space 𝕜 (E i)]
  (s : Π i, set (E i)) (I : set ι) (h : ∀ i ∈ I, unique_diff_on 𝕜 (s i)) :
  unique_diff_on 𝕜 (set.pi I s) :=
λ x hx, unique_diff_within_at.pi _ _ _ _ _ $ λ i hi, h i hi (x i) (hx i hi)

/-- The finite product of a family of sets of unique differentiability is a set of unique
differentiability. -/
lemma unique_diff_on.univ_pi (ι : Type*) [fintype ι] (E : ι → Type*)
  [Π i, normed_group (E i)] [Π i, normed_space 𝕜 (E i)]
  (s : Π i, set (E i)) (h : ∀ i, unique_diff_on 𝕜 (s i)) :
  unique_diff_on 𝕜 (set.pi univ s) :=
unique_diff_on.pi _ _ _ _ $ λ i _, h i

/-- In a real vector space, a convex set with nonempty interior is a set of unique
differentiability. -/
theorem unique_diff_on_convex {s : set G} (conv : convex s) (hs : (interior s).nonempty) :
  unique_diff_on ℝ s :=
begin
  assume x xs,
  rcases hs with ⟨y, hy⟩,
  suffices : y - x ∈ interior (tangent_cone_at ℝ s x),
  { refine ⟨dense.of_closure _, subset_closure xs⟩,
    simp [(submodule.span ℝ (tangent_cone_at ℝ s x)).eq_top_of_nonempty_interior'
      ⟨y - x, interior_mono submodule.subset_span this⟩] },
  rw [mem_interior_iff_mem_nhds] at hy ⊢,
  apply mem_sets_of_superset ((is_open_map_sub_right x).image_mem_nhds hy),
  rintros _ ⟨z, zs, rfl⟩,
  exact mem_tangent_cone_of_segment_subset (conv.segment_subset xs zs)
end

lemma unique_diff_on_Ici (a : ℝ) : unique_diff_on ℝ (Ici a) :=
unique_diff_on_convex (convex_Ici a) $ by simp only [interior_Ici, nonempty_Ioi]

lemma unique_diff_on_Iic (a : ℝ) : unique_diff_on ℝ (Iic a) :=
unique_diff_on_convex (convex_Iic a) $ by simp only [interior_Iic, nonempty_Iio]

lemma unique_diff_on_Ioi (a : ℝ) : unique_diff_on ℝ (Ioi a) :=
is_open_Ioi.unique_diff_on

lemma unique_diff_on_Iio (a : ℝ) : unique_diff_on ℝ (Iio a) :=
is_open_Iio.unique_diff_on

lemma unique_diff_on_Icc {a b : ℝ} (hab : a < b) : unique_diff_on ℝ (Icc a b) :=
unique_diff_on_convex (convex_Icc a b) $ by simp only [interior_Icc, nonempty_Ioo, hab]

lemma unique_diff_on_Ico (a b : ℝ) : unique_diff_on ℝ (Ico a b) :=
if hab : a < b
then unique_diff_on_convex (convex_Ico a b) $ by simp only [interior_Ico, nonempty_Ioo, hab]
else by simp only [Ico_eq_empty (le_of_not_lt hab), unique_diff_on_empty]

lemma unique_diff_on_Ioc (a b : ℝ) : unique_diff_on ℝ (Ioc a b) :=
if hab : a < b
then unique_diff_on_convex (convex_Ioc a b) $ by simp only [interior_Ioc, nonempty_Ioo, hab]
else by simp only [Ioc_eq_empty (le_of_not_lt hab), unique_diff_on_empty]

lemma unique_diff_on_Ioo (a b : ℝ) : unique_diff_on ℝ (Ioo a b) :=
is_open_Ioo.unique_diff_on

/-- The real interval `[0, 1]` is a set of unique differentiability. -/
lemma unique_diff_on_Icc_zero_one : unique_diff_on ℝ (Icc (0:ℝ) 1) :=
unique_diff_on_Icc zero_lt_one

end unique_diff