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

import tactic.ring

/-!

# linear_combination Tactic
In this file, the `linear_combination` tactic is created.  This tactic, which
works over `ring`s, attempts to simplify the target by creating a linear combination
of a list of equalities and subtracting it from the target.  This file also includes a
definition for `linear_combination_config`.  A `linear_combination_config`
object can be passed into the tactic, allowing the user to specify a
normalization tactic.

## Implementation Notes

This tactic works by creating a weighted sum of the given equations with the
given coefficients.  Then, it subtracts the right side of the weighted sum
from the left side so that the right side equals 0, and it does the same with
the target.  Afterwards, it sets the goal to be the equality between the
lefthand side of the new goal and the lefthand side of the new weighted sum.
Lastly, calls a normalization tactic on this target.

## References

* <https://leanprover.zulipchat.com/#narrow/stream/239415-metaprogramming-.2F.20tactics/topic/Linear.20algebra.20tactic/near/213928196>

-/

namespace linear_combo
open tactic

/-! ### Lemmas -/

lemma left_mul_both_sides {α} [h : has_mul α] {x y : α} (z : α) (h1 : x = y) :
  z * x = z * y :=
congr_arg (has_mul.mul z) h1

lemma sum_two_equations {α} [h : has_add α] {x1 y1 x2 y2 : α} (h1 : x1 = y1)
  (h2: x2 = y2) : x1 + x2 = y1 + y2 :=
congr (congr_arg has_add.add h1) h2

lemma left_minus_right {α} [h : add_group α] {x y : α} (h1 : x = y) :
  x - y = 0 :=
sub_eq_zero.mpr h1

lemma all_on_left_equiv {α} [h : add_group α] (x y : α) :
  (x = y) = (x - y = 0) :=
propext (⟨left_minus_right, sub_eq_zero.mp⟩)

lemma replace_eq_expr {α} [h : has_zero α] {x y : α} (h1 : x = 0) (h2 : y = x) :
  y = 0 :=
by rwa h2

lemma eq_zero_of_sub_eq_zero {α} [add_group α] {x y : α} (h : y = 0) (h2 : x - y = 0) : x = 0 :=
by rwa [h, sub_zero] at h2

/-! ### Configuration -/

/--
A configuration object for `linear_combination`.

`normalize` describes whether or not the normalization step should be used.

`normalization_tactic` describes the tactic used for normalization when
checking if the weighted sum is equivalent to the goal (when `normalize` is `tt`).
-/
meta structure linear_combination_config : Type :=
(normalize : bool := tt)
(normalization_tactic : tactic unit := `[ring_nf SOP])
(exponent : ℕ := 1)

/-! ### Part 1: Multiplying Equations by Constants and Adding Them Together -/

/--
Given that `lhs = rhs`, this tactic returns an `expr` proving that
  `coeff * lhs = coeff * rhs`.

* Input:
  * `h_equality` : an `expr`, whose type should be an equality between terms of
      type `α`, where there is an instance of `has_mul α`
  * `coeff` : a `pexpr`, which should be a value of type `α`

* Output: an `expr`, which proves that the result of multiplying both sides
    of `h_equality` by the `coeff` holds
-/
meta def mul_equality_expr (h_equality : expr) (coeff : pexpr) : tactic expr :=
do
  `(%%lhs = %%rhs) ← infer_type h_equality,
  -- Mark the coefficient as having the same type as the sides of `h_equality` -
  --   this is necessary in order to use the left_mul_both_sides lemma
  left_type ← infer_type lhs,
  coeff_expr ← to_expr ``(%%coeff : %%left_type),
  mk_app ``left_mul_both_sides [coeff_expr, h_equality]

/--
Given two hypotheses that `a = b` and `c = d`, this tactic returns an `expr` proving
  that `a + c = b + d`.

* Input:
  * `h_equality1` : an `expr`, whose type should be an equality between terms of
      type `α`, where there is an instance of `has_add α`
  * `h_equality2` : an `expr`, whose type should be an equality between terms of
      type `α`

* Output: an `expr`, which proves that the result of adding the two
    equalities holds
-/
meta def sum_equalities (h_equality1 h_equality2 : expr) : tactic expr :=
mk_app ``sum_two_equations [h_equality1, h_equality2]

/--
Given that `a = b` and `c = d`, along with a coefficient, this tactic returns an
  `expr` proving that `a + coeff * c = b + coeff * d`.

* Input:
  * `h_equality1` : an `expr`, whose type should be an equality between terms of
      type `α`, where there are instances of `has_add α` and `has_mul α`
  * `h_equality2` : an `expr`, whose type should be an equality between terms of
      type `α`
  * `coeff_for_eq2` : a `pexpr`, which should be a value of type `α`

* Output: an `expr`, which proves that the result of adding the first
  equality to the result of multiplying `coeff_for_eq2` by the second equality
  holds
-/
meta def sum_two_hyps_one_mul_helper (h_equality1 h_equality2 : expr)
  (coeff_for_eq2 : pexpr) : tactic expr :=
mul_equality_expr h_equality2 coeff_for_eq2 >>= sum_equalities h_equality1

/--
Given that `l_sum1 = r_sum1`, `l_h1 = r_h1`, ..., `l_hn = r_hn`, and given
  coefficients `c_1`, ..., `c_n`, this tactic returns an `expr` proving that
    `l_sum1 + (c_1 * l_h1) + ... + (c_n * l_hn)`
  `= r_sum1 + (c_1 * r_h1) + ... + (c_n * r_hn)`

* Input:
  * `expected_tp`: the type of the terms being compared in the target equality
  * an `option (tactic expr)` : `none`, if there is no sum to add to yet, or
      `some` containing the base summation equation
  * a `list name` : a list of names, referring to equalities in the local context
  * a `list pexpr` : a list of coefficients to be multiplied with the
      corresponding equalities in the list of names

* Output: an `expr`, which proves that the weighted sum of the given
    equalities added to the base equation holds
-/
meta def make_sum_of_hyps_helper (expected_tp : expr) :
  option (tactic expr) → list expr → list pexpr → tactic expr
| none [] []                                                             :=
  to_expr ``(rfl : (0 : %%expected_tp) = 0)
| (some tactic_hcombo) [] []                                             :=
  do tactic_hcombo
| none (h_equality :: h_eqs_names) (coeff :: coeffs)                 :=
 do
    -- This is the first equality, and we do not have anything to add to it
    -- h_equality ← get_local h_equality_nam,
    `(@eq %%eqtp _ _) ← infer_type h_equality |
      fail!"{h_equality} is expected to be a proof of an equality",
    is_def_eq eqtp expected_tp <|>
      fail!("{h_equality} is an equality between terms of type {eqtp}, but is expected to be" ++
        " between terms of type {expected_tp}"),
    make_sum_of_hyps_helper
      (some (mul_equality_expr h_equality coeff))
      h_eqs_names
      coeffs
| (some tactic_hcombo) (h_equality :: h_eqs_names) (coeff :: coeffs) :=
  do
    -- h_equality ← get_local h_equality_nam,
    hcombo ← tactic_hcombo,
    -- We want to add this weighted equality to the current equality in
    --   the hypothesis
    make_sum_of_hyps_helper
      (some (sum_two_hyps_one_mul_helper hcombo h_equality coeff))
      h_eqs_names
      coeffs
| _ _ _                                                                  :=
  do fail ("The length of the input list of equalities should be the " ++
    "same as the length of the input list of coefficients")

/--
Given a list of names referencing equalities and a list of pexprs representing
  coefficients, this tactic proves that a weighted sum of the equalities
  (where each equation is multiplied by the corresponding coefficient) holds.

* Input:
  * `expected_tp`: the type of the terms being compared in the target equality
  * `h_eqs_names` : a list of names, referring to equalities in the local
      context
  * `coeffs` : a list of coefficients to be multiplied with the corresponding
      equalities in the list of names

* Output: an `expr`, which proves that the weighted sum of the equalities
    holds
-/
meta def make_sum_of_hyps (expected_tp : expr) (h_eqs_names : list expr) (coeffs : list pexpr) :
  tactic expr :=
make_sum_of_hyps_helper expected_tp none h_eqs_names coeffs

/-! ### Part 2: Simplifying -/

/--
This tactic proves that the result of moving all the terms in an equality to
  the left side of the equals sign by subtracting the right side of the
  equation from the left side holds.  In other words, given `lhs = rhs`,
  this tactic proves that `lhs - rhs = 0`.

* Input:
  * `h_equality` : an `expr`, whose type should be an equality between terms of
      type `α`, where there is an instance of `add_group α`

* Output: an `expr`, which proves that `lhs - rhs = 0`, where `lhs` and `rhs` are
   the left and right sides of `h_equality` respectively
-/
meta def move_to_left_side (h_equality : expr) : tactic expr :=
mk_app ``left_minus_right [h_equality]

/--
This tactic replaces the target with the result of moving all the terms in the
  target to the left side of the equals sign by subtracting the right side of
  the equation from the left side.  In other words, when the target is
  lhs = rhs, this tactic proves that `lhs - rhs = 0` and replaces the target
  with this new equality.
Note: The target must be an equality when this tactic is called, and the
  equality must have some type `α` on each side, where there is an instance of
  `add_group α`.

* Input: N/A

* Output: N/A
-/
meta def move_target_to_left_side : tactic unit :=
do
  -- Move all the terms in the target equality to the left side
  target ← target,
  (targ_lhs, targ_rhs) ← match_eq target,
  target_left_eq ← to_expr ``(%%targ_lhs - %%targ_rhs = 0),
  mk_app ``all_on_left_equiv [targ_lhs, targ_rhs] >>= replace_target target_left_eq

/-! ### Part 3: Matching the Linear Combination to the Target -/

/--
This tactic changes the goal to be that the lefthand side of the target minus the
  lefthand side of the given expression is equal to 0.  For example,
  if `hsum_on_left` is `5*x - 5*y = 0`, and the target is `-5*y + 5*x = 0`, this
  tactic will change the target to be `-5*y + 5*x - (5*x - 5*y) = 0`.

This tactic only should be used when the target's type is an equality whose
  right side is 0.

* Input:
  * `hsum_on_left` : expr, whose type should be an equality with 0 on the right
      side of the equals sign

* Output: N/A
-/
meta def set_goal_to_hleft_sub_tleft (hsum_on_left : expr) : tactic unit :=
do to_expr ``(eq_zero_of_sub_eq_zero %%hsum_on_left) >>= apply, skip

/--
If an exponent `n` is provided, changes the goal from `t = 0` to `t^n = 0`.
* Input:
  * `exponent : ℕ`, the power to raise the goal by. If `1`, this tactic is a no-op.

* Output: N/A
-/
meta def raise_goal_to_power : ℕ → tactic unit
| 1 := skip
| n := refine ``(@pow_eq_zero _ _ _ _ %%`(n) _)

/--
This tactic attempts to prove the goal by normalizing the target if the
`normalize` field of the given configuration is true.

* Input:
  * `config` : a `linear_combination_config`, which determines the tactic used
      for normalization if normalization is done

* Output: N/A
-/
meta def normalize_if_desired (config : linear_combination_config) :
  tactic unit :=
when config.normalize config.normalization_tactic

/-! ### Part 4: Completed Tactic -/

/--
This is a tactic that attempts to simplify the target by creating a linear combination
  of a list of equalities and subtracting it from the target.
  (If the `normalize` field of the
  configuration is set to ff, then the tactic will simply set the user up to
  prove their target using the linear combination instead of normalizing the subtraction.)

Note: The left and right sides of all the equalities should have the same
  ring type, and the coefficients should also have this type.  There must be
  instances of `has_mul` and `add_group` for this type.  Also note that the
  target must involve at least one variable.

* Input:
  * `h_eqs_names` : a list of names, referring to equations in the local
      context
  * `coeffs` : a list of coefficients to be multiplied with the corresponding
    equations in the list of names
  * `config` : a `linear_combination_config`, which determines the tactic used
      for normalization; by default, this value is the standard configuration
      for a `linear_combination_config`

* Output: N/A
-/
meta def linear_combination (h_eqs_names : list pexpr) (coeffs : list pexpr)
  (config : linear_combination_config := {}) : tactic unit :=
do
  `(@eq %%ext _ _) ← target | fail "linear_combination can only be used to prove equality goals",
  h_eqs ← h_eqs_names.mmap to_expr,
  hsum ← make_sum_of_hyps ext h_eqs coeffs,
  hsum_on_left ← move_to_left_side hsum,
  move_target_to_left_side,
  raise_goal_to_power config.exponent,
  set_goal_to_hleft_sub_tleft hsum_on_left,
  normalize_if_desired config

/-- `mk_mul [p₀, p₁, ..., pₙ]` produces the pexpr `p₀ * p₁ * ... * pₙ`. -/
meta def mk_mul : list pexpr → pexpr
| [] := ``(1)
| [e] := e
| (e::es) := ``(%%e * %%(mk_mul es))

/--
`as_linear_combo neg ms e` is used to parse the argument to `linear_combination`.
This argument is a sequence of literals `x`, `-x`, or `c*x` combined with `+` or `-`,
given by the pexpr `e`.
The `neg` and `ms` arguments are used recursively; called at the top level, its usage should be
`as_linear_combo ff [] e`.
-/
meta def as_linear_combo : bool → list pexpr → pexpr → list (pexpr × pexpr)
| neg ms e :=
  let (head, args) := pexpr.get_app_fn_args e in
  match head.get_frozen_name, args with
  | ``has_add.add, [e1, e2] := as_linear_combo neg ms e1 ++ as_linear_combo neg ms e2
  | ``has_sub.sub, [e1, e2] := as_linear_combo neg ms e1 ++ as_linear_combo (bnot neg) ms e2
  | ``has_mul.mul, [e1, e2] := as_linear_combo neg (e1::ms) e2
  | ``has_div.div, [e1, e2] := as_linear_combo neg (``((%%e2)⁻¹)::ms) e1
  | ``has_neg.neg, [e1] := as_linear_combo (bnot neg) ms e1
  | _, _ := let m := mk_mul ms in [(e, if neg then ``(-%%m) else m)]
  end

section interactive_mode
setup_tactic_parser

/--
`linear_combination` attempts to simplify the target by creating a linear combination
  of a list of equalities and subtracting it from the target.
  The tactic will create a linear
  combination by adding the equalities together from left to right, so the order
  of the input hypotheses does matter.  If the `normalize` field of the
  configuration is set to false, then the tactic will simply set the user up to
  prove their target using the linear combination instead of normalizing the subtraction.

Users may provide an optional `with { exponent := n }`. This will raise the goal to the power `n`
  before subtracting the linear combination.

Note: The left and right sides of all the equalities should have the same
  type, and the coefficients should also have this type.  There must be
  instances of `has_mul` and `add_group` for this type.

* Input:
  * `input` : the linear combination of proofs of equalities, given as a sum/difference
      of coefficients multiplied by expressions. The coefficients may be arbitrary
      pre-expressions; if a coefficient is an application of `+` or `-` it should be
      surrounded by parentheses. The expressions can be arbitrary proof terms proving
      equalities. Most commonly they are hypothesis names `h1, h2, ...`.

      If a coefficient is omitted, it is taken to be `1`.
  * `config` : a `linear_combination_config`, which determines the tactic used
      for normalization; by default, this value is the standard configuration
      for a linear_combination_config.  In the standard configuration,
      `normalize` is set to tt (meaning this tactic is set to use
      normalization), and `normalization_tactic` is set to  `ring_nf SOP`.

Example Usage:
```
example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y = -2*y + 1 :=
by linear_combination 1*h1 - 2*h2

example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y = -2*y + 1 :=
by linear_combination h1 - 2*h2

example (x y : ℤ) (h1 : x*y + 2*x = 1) (h2 : x = y) :
  x*y = -2*y + 1 :=
begin
 linear_combination -2*h2,
 /- Goal: x * y + x * 2 - 1 = 0 -/
end

example (x y z : ℝ) (ha : x + 2*y - z = 4) (hb : 2*x + y + z = -2)
    (hc : x + 2*y + z = 2) :
  -3*x - 3*y - 4*z = 2 :=
by linear_combination ha - hb - 2*hc

example (x y : ℚ) (h1 : x + y = 3) (h2 : 3*x = 7) :
  x*x*y + y*x*y + 6*x = 3*x*y + 14 :=
by linear_combination x*y*h1 + 2*h2

example (x y : ℤ) (h1 : x = -3) (h2 : y = 10) :
  2*x = -6 :=
begin
  linear_combination 2*h1 with {normalize := ff},
  simp,
  norm_cast
end

example (x y z : ℚ) (h : x = y) (h2 : x * y = 0) : x + y*z = 0 :=
by linear_combination (-y * z ^ 2 + x) * h + (z ^ 2 + 2 * z + 1) * h2 with { exponent := 2 }

constants (qc : ℚ) (hqc : qc = 2*qc)

example (a b : ℚ) (h : ∀ p q : ℚ, p = q) : 3*a + qc = 3*b + 2*qc :=
by linear_combination 3 * h a b + hqc
```
-/
meta def _root_.tactic.interactive.linear_combination
  (input : parse (as_linear_combo ff [] <$> texpr)?)
  (_ : parse (tk "with")?)
  (config : linear_combination_config := {})
  : tactic unit :=
let (h_eqs_names, coeffs) := list.unzip (input.get_or_else []) in
linear_combination h_eqs_names coeffs config

add_tactic_doc
{ name := "linear_combination",
  category := doc_category.tactic,
  decl_names := [`tactic.interactive.linear_combination],
  tags := ["arithmetic"] }

end interactive_mode
end linear_combo


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

! This file was ported from Lean 3 source module data.fintype.sum
! leanprover-community/mathlib commit 6623e6af705e97002a9054c1c05a980180276fc1
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Data.Fintype.Card
import Mathbin.Data.Finset.Sum
import Mathbin.Logic.Embedding.Set

/-!
## Instances

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

We provide the `fintype` instance for the sum of two fintypes.
-/

universe u v

variable {α β : Type _}

open Finset

instance (α : Type u) (β : Type v) [Fintype α] [Fintype β] : Fintype (Sum α β)
    where
  elems := univ.disjSum univ
  complete := by rintro (_ | _) <;> simp

/- warning: finset.univ_disj_sum_univ -> Finset.univ_disjSum_univ is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Fintype.{u1} α] [_inst_2 : Fintype.{u2} β], Eq.{succ (max u1 u2)} (Finset.{max u1 u2} (Sum.{u1, u2} α β)) (Finset.disjSum.{u1, u2} α β (Finset.univ.{u1} α _inst_1) (Finset.univ.{u2} β _inst_2)) (Finset.univ.{max u1 u2} (Sum.{u1, u2} α β) (Sum.fintype.{u1, u2} α β _inst_1 _inst_2))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Fintype.{u2} α] [_inst_2 : Fintype.{u1} β], Eq.{max (succ u2) (succ u1)} (Finset.{max u1 u2} (Sum.{u2, u1} α β)) (Finset.disjSum.{u2, u1} α β (Finset.univ.{u2} α _inst_1) (Finset.univ.{u1} β _inst_2)) (Finset.univ.{max u2 u1} (Sum.{u2, u1} α β) (instFintypeSum.{u2, u1} α β _inst_1 _inst_2))
Case conversion may be inaccurate. Consider using '#align finset.univ_disj_sum_univ Finset.univ_disjSum_univₓ'. -/
@[simp]
theorem Finset.univ_disjSum_univ {α β : Type _} [Fintype α] [Fintype β] :
    univ.disjSum univ = (univ : Finset (Sum α β)) :=
  rfl
#align finset.univ_disj_sum_univ Finset.univ_disjSum_univ

/- warning: fintype.card_sum -> Fintype.card_sum is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Fintype.{u1} α] [_inst_2 : Fintype.{u2} β], Eq.{1} Nat (Fintype.card.{max u1 u2} (Sum.{u1, u2} α β) (Sum.fintype.{u1, u2} α β _inst_1 _inst_2)) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat Nat.hasAdd) (Fintype.card.{u1} α _inst_1) (Fintype.card.{u2} β _inst_2))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Fintype.{u2} α] [_inst_2 : Fintype.{u1} β], Eq.{1} Nat (Fintype.card.{max u1 u2} (Sum.{u2, u1} α β) (instFintypeSum.{u2, u1} α β _inst_1 _inst_2)) (HAdd.hAdd.{0, 0, 0} Nat Nat Nat (instHAdd.{0} Nat instAddNat) (Fintype.card.{u2} α _inst_1) (Fintype.card.{u1} β _inst_2))
Case conversion may be inaccurate. Consider using '#align fintype.card_sum Fintype.card_sumₓ'. -/
@[simp]
theorem Fintype.card_sum [Fintype α] [Fintype β] :
    Fintype.card (Sum α β) = Fintype.card α + Fintype.card β :=
  card_disjSum _ _
#align fintype.card_sum Fintype.card_sum

#print fintypeOfFintypeNe /-
/-- If the subtype of all-but-one elements is a `fintype` then the type itself is a `fintype`. -/
def fintypeOfFintypeNe (a : α) (h : Fintype { b // b ≠ a }) : Fintype α :=
  Fintype.ofBijective (Sum.elim (coe : { b // b = a } → α) (coe : { b // b ≠ a } → α)) <| by
    classical exact (Equiv.sumCompl (· = a)).Bijective
#align fintype_of_fintype_ne fintypeOfFintypeNe
-/

/- warning: image_subtype_ne_univ_eq_image_erase -> image_subtype_ne_univ_eq_image_erase is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Fintype.{u1} α] [_inst_2 : DecidableEq.{succ u2} β] (k : β) (b : α -> β), Eq.{succ u2} (Finset.{u2} β) (Finset.image.{u1, u2} (Subtype.{succ u1} α (fun (a : α) => Ne.{succ u2} β (b a) k)) β (fun (a : β) (b : β) => _inst_2 a b) (fun (i : Subtype.{succ u1} α (fun (a : α) => Ne.{succ u2} β (b a) k)) => b ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Subtype.{succ u1} α (fun (a : α) => Ne.{succ u2} β (b a) k)) α (HasLiftT.mk.{succ u1, succ u1} (Subtype.{succ u1} α (fun (a : α) => Ne.{succ u2} β (b a) k)) α (CoeTCₓ.coe.{succ u1, succ u1} (Subtype.{succ u1} α (fun (a : α) => Ne.{succ u2} β (b a) k)) α (coeBase.{succ u1, succ u1} (Subtype.{succ u1} α (fun (a : α) => Ne.{succ u2} β (b a) k)) α (coeSubtype.{succ u1} α (fun (a : α) => Ne.{succ u2} β (b a) k))))) i)) (Finset.univ.{u1} (Subtype.{succ u1} α (fun (a : α) => Ne.{succ u2} β (b a) k)) (Subtype.fintype.{u1} α (fun (a : α) => Ne.{succ u2} β (b a) k) (fun (a : α) => Ne.decidable.{succ u2} β (fun (a : β) (b : β) => _inst_2 a b) (b a) k) _inst_1))) (Finset.erase.{u2} β (fun (a : β) (b : β) => _inst_2 a b) (Finset.image.{u1, u2} α β (fun (a : β) (b : β) => _inst_2 a b) b (Finset.univ.{u1} α _inst_1)) k)
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Fintype.{u2} α] [_inst_2 : DecidableEq.{succ u1} β] (k : β) (b : α -> β), Eq.{succ u1} (Finset.{u1} β) (Finset.image.{u2, u1} (Subtype.{succ u2} α (fun (a : α) => Ne.{succ u1} β (b a) k)) β (fun (a : β) (b : β) => _inst_2 a b) (fun (i : Subtype.{succ u2} α (fun (a : α) => Ne.{succ u1} β (b a) k)) => b (Subtype.val.{succ u2} α (fun (a : α) => Ne.{succ u1} β (b a) k) i)) (Finset.univ.{u2} (Subtype.{succ u2} α (fun (a : α) => Ne.{succ u1} β (b a) k)) (Subtype.fintype.{u2} α (fun (a : α) => Ne.{succ u1} β (b a) k) (fun (a : α) => instDecidableNot (Eq.{succ u1} β (b a) k) (_inst_2 (b a) k)) _inst_1))) (Finset.erase.{u1} β (fun (a : β) (b : β) => _inst_2 a b) (Finset.image.{u2, u1} α β (fun (a : β) (b : β) => _inst_2 a b) b (Finset.univ.{u2} α _inst_1)) k)
Case conversion may be inaccurate. Consider using '#align image_subtype_ne_univ_eq_image_erase image_subtype_ne_univ_eq_image_eraseₓ'. -/
theorem image_subtype_ne_univ_eq_image_erase [Fintype α] [DecidableEq β] (k : β) (b : α → β) :
    image (fun i : { a // b a ≠ k } => b ↑i) univ = (image b univ).eraseₓ k :=
  by
  apply subset_antisymm
  · rw [image_subset_iff]
    intro i _
    apply mem_erase_of_ne_of_mem i.2 (mem_image_of_mem _ (mem_univ _))
  · intro i hi
    rw [mem_image]
    rcases mem_image.1 (erase_subset _ _ hi) with ⟨a, _, ha⟩
    subst ha
    exact ⟨⟨a, ne_of_mem_erase hi⟩, mem_univ _, rfl⟩
#align image_subtype_ne_univ_eq_image_erase image_subtype_ne_univ_eq_image_erase

/- warning: image_subtype_univ_ssubset_image_univ -> image_subtype_univ_ssubset_image_univ is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Fintype.{u1} α] [_inst_2 : DecidableEq.{succ u2} β] (k : β) (b : α -> β), (Membership.Mem.{u2, u2} β (Finset.{u2} β) (Finset.hasMem.{u2} β) k (Finset.image.{u1, u2} α β (fun (a : β) (b : β) => _inst_2 a b) b (Finset.univ.{u1} α _inst_1))) -> (forall (p : β -> Prop) [_inst_3 : DecidablePred.{succ u2} β p], (Not (p k)) -> (HasSSubset.SSubset.{u2} (Finset.{u2} β) (Finset.hasSsubset.{u2} β) (Finset.image.{u1, u2} (Subtype.{succ u1} α (fun (a : α) => p (b a))) β (fun (a : β) (b : β) => _inst_2 a b) (fun (i : Subtype.{succ u1} α (fun (a : α) => p (b a))) => b ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Subtype.{succ u1} α (fun (a : α) => p (b a))) α (HasLiftT.mk.{succ u1, succ u1} (Subtype.{succ u1} α (fun (a : α) => p (b a))) α (CoeTCₓ.coe.{succ u1, succ u1} (Subtype.{succ u1} α (fun (a : α) => p (b a))) α (coeBase.{succ u1, succ u1} (Subtype.{succ u1} α (fun (a : α) => p (b a))) α (coeSubtype.{succ u1} α (fun (a : α) => p (b a)))))) i)) (Finset.univ.{u1} (Subtype.{succ u1} α (fun (a : α) => p (b a))) (Subtype.fintype.{u1} α (fun (a : α) => p (b a)) (fun (a : α) => _inst_3 (b a)) _inst_1))) (Finset.image.{u1, u2} α β (fun (a : β) (b : β) => _inst_2 a b) b (Finset.univ.{u1} α _inst_1))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Fintype.{u2} α] [_inst_2 : DecidableEq.{succ u1} β] (k : β) (b : α -> β), (Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) k (Finset.image.{u2, u1} α β (fun (a : β) (b : β) => _inst_2 a b) b (Finset.univ.{u2} α _inst_1))) -> (forall (p : β -> Prop) [_inst_3 : DecidablePred.{succ u1} β p], (Not (p k)) -> (HasSSubset.SSubset.{u1} (Finset.{u1} β) (Finset.instHasSSubsetFinset.{u1} β) (Finset.image.{u2, u1} (Subtype.{succ u2} α (fun (a : α) => p (b a))) β (fun (a : β) (b : β) => _inst_2 a b) (fun (i : Subtype.{succ u2} α (fun (a : α) => p (b a))) => b (Subtype.val.{succ u2} α (fun (a : α) => p (b a)) i)) (Finset.univ.{u2} (Subtype.{succ u2} α (fun (a : α) => p (b a))) (Subtype.fintype.{u2} α (fun (a : α) => p (b a)) (fun (a : α) => _inst_3 (b a)) _inst_1))) (Finset.image.{u2, u1} α β (fun (a : β) (b : β) => _inst_2 a b) b (Finset.univ.{u2} α _inst_1))))
Case conversion may be inaccurate. Consider using '#align image_subtype_univ_ssubset_image_univ image_subtype_univ_ssubset_image_univₓ'. -/
theorem image_subtype_univ_ssubset_image_univ [Fintype α] [DecidableEq β] (k : β) (b : α → β)
    (hk : k ∈ image b univ) (p : β → Prop) [DecidablePred p] (hp : ¬p k) :
    image (fun i : { a // p (b a) } => b ↑i) univ ⊂ image b univ :=
  by
  constructor
  · intro x hx
    rcases mem_image.1 hx with ⟨y, _, hy⟩
    exact hy ▸ mem_image_of_mem b (mem_univ y)
  · intro h
    rw [mem_image] at hk
    rcases hk with ⟨k', _, hk'⟩
    subst hk'
    have := h (mem_image_of_mem b (mem_univ k'))
    rw [mem_image] at this
    rcases this with ⟨j, hj, hj'⟩
    exact hp (hj' ▸ j.2)
#align image_subtype_univ_ssubset_image_univ image_subtype_univ_ssubset_image_univ

/- warning: finset.exists_equiv_extend_of_card_eq -> Finset.exists_equiv_extend_of_card_eq is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Fintype.{u1} α] [_inst_2 : DecidableEq.{succ u2} β] {t : Finset.{u2} β}, (Eq.{1} Nat (Fintype.card.{u1} α _inst_1) (Finset.card.{u2} β t)) -> (forall {s : Finset.{u1} α} {f : α -> β}, (HasSubset.Subset.{u2} (Finset.{u2} β) (Finset.hasSubset.{u2} β) (Finset.image.{u1, u2} α β (fun (a : β) (b : β) => _inst_2 a b) f s) t) -> (Set.InjOn.{u1, u2} α β f ((fun (a : Type.{u1}) (b : Type.{u1}) [self : HasLiftT.{succ u1, succ u1} a b] => self.0) (Finset.{u1} α) (Set.{u1} α) (HasLiftT.mk.{succ u1, succ u1} (Finset.{u1} α) (Set.{u1} α) (CoeTCₓ.coe.{succ u1, succ u1} (Finset.{u1} α) (Set.{u1} α) (Finset.Set.hasCoeT.{u1} α))) s)) -> (Exists.{max 1 (max (succ u1) (succ u2)) (succ u2) (succ u1)} (Equiv.{succ u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t)) (fun (g : Equiv.{succ u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t)) => forall (i : α), (Membership.Mem.{u1, u1} α (Finset.{u1} α) (Finset.hasMem.{u1} α) i s) -> (Eq.{succ u2} β ((fun (a : Type.{u2}) (b : Type.{u2}) [self : HasLiftT.{succ u2, succ u2} a b] => self.0) (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t) β (HasLiftT.mk.{succ u2, succ u2} (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t) β (CoeTCₓ.coe.{succ u2, succ u2} (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t) β (coeBase.{succ u2, succ u2} (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t) β (coeSubtype.{succ u2} β (fun (x : β) => Membership.Mem.{u2, u2} β (Finset.{u2} β) (Finset.hasMem.{u2} β) x t))))) (coeFn.{max 1 (max (succ u1) (succ u2)) (succ u2) (succ u1), max (succ u1) (succ u2)} (Equiv.{succ u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t)) (fun (_x : Equiv.{succ u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t)) => α -> (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t)) (Equiv.hasCoeToFun.{succ u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t)) g i)) (f i)))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Fintype.{u2} α] [_inst_2 : DecidableEq.{succ u1} β] {t : Finset.{u1} β}, (Eq.{1} Nat (Fintype.card.{u2} α _inst_1) (Finset.card.{u1} β t)) -> (forall {s : Finset.{u2} α} {f : α -> β}, (HasSubset.Subset.{u1} (Finset.{u1} β) (Finset.instHasSubsetFinset.{u1} β) (Finset.image.{u2, u1} α β (fun (a : β) (b : β) => _inst_2 a b) f s) t) -> (Set.InjOn.{u2, u1} α β f (Finset.toSet.{u2} α s)) -> (Exists.{max (succ u2) (succ u1)} (Equiv.{succ u2, succ u1} α (Subtype.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) x t))) (fun (g : Equiv.{succ u2, succ u1} α (Subtype.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) x t))) => forall (i : α), (Membership.mem.{u2, u2} α (Finset.{u2} α) (Finset.instMembershipFinset.{u2} α) i s) -> (Eq.{succ u1} β (Subtype.val.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) x t) (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (Equiv.{succ u2, succ u1} α (Subtype.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) x t))) α (fun (_x : α) => (fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : α) => Subtype.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) x t)) _x) (Equiv.instFunLikeEquiv.{succ u2, succ u1} α (Subtype.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) x t))) g i)) (f i)))))
Case conversion may be inaccurate. Consider using '#align finset.exists_equiv_extend_of_card_eq Finset.exists_equiv_extend_of_card_eqₓ'. -/
/-- Any injection from a finset `s` in a fintype `α` to a finset `t` of the same cardinality as `α`
can be extended to a bijection between `α` and `t`. -/
theorem Finset.exists_equiv_extend_of_card_eq [Fintype α] [DecidableEq β] {t : Finset β}
    (hαt : Fintype.card α = t.card) {s : Finset α} {f : α → β} (hfst : s.image f ⊆ t)
    (hfs : Set.InjOn f s) : ∃ g : α ≃ t, ∀ i ∈ s, (g i : β) = f i := by
  classical
    induction' s using Finset.induction with a s has H generalizing f
    · obtain ⟨e⟩ : Nonempty (α ≃ ↥t) := by rwa [← Fintype.card_eq, Fintype.card_coe]
      use e
      simp
    have hfst' : Finset.image f s ⊆ t := (Finset.image_mono _ (s.subset_insert a)).trans hfst
    have hfs' : Set.InjOn f s := hfs.mono (s.subset_insert a)
    obtain ⟨g', hg'⟩ := H hfst' hfs'
    have hfat : f a ∈ t := hfst (mem_image_of_mem _ (s.mem_insert_self a))
    use g'.trans (Equiv.swap (⟨f a, hfat⟩ : t) (g' a))
    simp_rw [mem_insert]
    rintro i (rfl | hi)
    · simp
    rw [Equiv.trans_apply, Equiv.swap_apply_of_ne_of_ne, hg' _ hi]
    ·
      exact
        ne_of_apply_ne Subtype.val
          (ne_of_eq_of_ne (hg' _ hi) <|
            hfs.ne (subset_insert _ _ hi) (mem_insert_self _ _) <| ne_of_mem_of_not_mem hi has)
    · exact g'.injective.ne (ne_of_mem_of_not_mem hi has)
#align finset.exists_equiv_extend_of_card_eq Finset.exists_equiv_extend_of_card_eq

/- warning: set.maps_to.exists_equiv_extend_of_card_eq -> Set.MapsTo.exists_equiv_extend_of_card_eq is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : Fintype.{u1} α] {t : Finset.{u2} β}, (Eq.{1} Nat (Fintype.card.{u1} α _inst_1) (Finset.card.{u2} β t)) -> (forall {s : Set.{u1} α} {f : α -> β}, (Set.MapsTo.{u1, u2} α β f s ((fun (a : Type.{u2}) (b : Type.{u2}) [self : HasLiftT.{succ u2, succ u2} a b] => self.0) (Finset.{u2} β) (Set.{u2} β) (HasLiftT.mk.{succ u2, succ u2} (Finset.{u2} β) (Set.{u2} β) (CoeTCₓ.coe.{succ u2, succ u2} (Finset.{u2} β) (Set.{u2} β) (Finset.Set.hasCoeT.{u2} β))) t)) -> (Set.InjOn.{u1, u2} α β f s) -> (Exists.{max 1 (max (succ u1) (succ u2)) (succ u2) (succ u1)} (Equiv.{succ u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t)) (fun (g : Equiv.{succ u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t)) => forall (i : α), (Membership.Mem.{u1, u1} α (Set.{u1} α) (Set.hasMem.{u1} α) i s) -> (Eq.{succ u2} β ((fun (a : Type.{u2}) (b : Type.{u2}) [self : HasLiftT.{succ u2, succ u2} a b] => self.0) (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t) β (HasLiftT.mk.{succ u2, succ u2} (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t) β (CoeTCₓ.coe.{succ u2, succ u2} (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t) β (coeBase.{succ u2, succ u2} (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t) β (coeSubtype.{succ u2} β (fun (x : β) => Membership.Mem.{u2, u2} β (Finset.{u2} β) (Finset.hasMem.{u2} β) x t))))) (coeFn.{max 1 (max (succ u1) (succ u2)) (succ u2) (succ u1), max (succ u1) (succ u2)} (Equiv.{succ u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t)) (fun (_x : Equiv.{succ u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t)) => α -> (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t)) (Equiv.hasCoeToFun.{succ u1, succ u2} α (coeSort.{succ u2, succ (succ u2)} (Finset.{u2} β) Type.{u2} (Finset.hasCoeToSort.{u2} β) t)) g i)) (f i)))))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : Fintype.{u2} α] {t : Finset.{u1} β}, (Eq.{1} Nat (Fintype.card.{u2} α _inst_1) (Finset.card.{u1} β t)) -> (forall {s : Set.{u2} α} {f : α -> β}, (Set.MapsTo.{u2, u1} α β f s (Finset.toSet.{u1} β t)) -> (Set.InjOn.{u2, u1} α β f s) -> (Exists.{max (succ u2) (succ u1)} (Equiv.{succ u2, succ u1} α (Subtype.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) x t))) (fun (g : Equiv.{succ u2, succ u1} α (Subtype.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) x t))) => forall (i : α), (Membership.mem.{u2, u2} α (Set.{u2} α) (Set.instMembershipSet.{u2} α) i s) -> (Eq.{succ u1} β (Subtype.val.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) x t) (FunLike.coe.{max (succ u2) (succ u1), succ u2, succ u1} (Equiv.{succ u2, succ u1} α (Subtype.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) x t))) α (fun (_x : α) => (fun (x._@.Mathlib.Logic.Equiv.Defs._hyg.808 : α) => Subtype.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) x t)) _x) (Equiv.instFunLikeEquiv.{succ u2, succ u1} α (Subtype.{succ u1} β (fun (x : β) => Membership.mem.{u1, u1} β (Finset.{u1} β) (Finset.instMembershipFinset.{u1} β) x t))) g i)) (f i)))))
Case conversion may be inaccurate. Consider using '#align set.maps_to.exists_equiv_extend_of_card_eq Set.MapsTo.exists_equiv_extend_of_card_eqₓ'. -/
/-- Any injection from a set `s` in a fintype `α` to a finset `t` of the same cardinality as `α`
can be extended to a bijection between `α` and `t`. -/
theorem Set.MapsTo.exists_equiv_extend_of_card_eq [Fintype α] {t : Finset β}
    (hαt : Fintype.card α = t.card) {s : Set α} {f : α → β} (hfst : s.MapsTo f t)
    (hfs : Set.InjOn f s) : ∃ g : α ≃ t, ∀ i ∈ s, (g i : β) = f i := by
  classical
    let s' : Finset α := s.to_finset
    have hfst' : s'.image f ⊆ t := by simpa [← Finset.coe_subset] using hfst
    have hfs' : Set.InjOn f s' := by simpa using hfs
    obtain ⟨g, hg⟩ := Finset.exists_equiv_extend_of_card_eq hαt hfst' hfs'
    refine' ⟨g, fun i hi => _⟩
    apply hg
    simpa using hi
#align set.maps_to.exists_equiv_extend_of_card_eq Set.MapsTo.exists_equiv_extend_of_card_eq

#print Fintype.card_subtype_or /-
theorem Fintype.card_subtype_or (p q : α → Prop) [Fintype { x // p x }] [Fintype { x // q x }]
    [Fintype { x // p x ∨ q x }] :
    Fintype.card { x // p x ∨ q x } ≤ Fintype.card { x // p x } + Fintype.card { x // q x } := by
  classical
    convert Fintype.card_le_of_embedding (subtypeOrLeftEmbedding p q)
    rw [Fintype.card_sum]
#align fintype.card_subtype_or Fintype.card_subtype_or
-/

#print Fintype.card_subtype_or_disjoint /-
theorem Fintype.card_subtype_or_disjoint (p q : α → Prop) (h : Disjoint p q) [Fintype { x // p x }]
    [Fintype { x // q x }] [Fintype { x // p x ∨ q x }] :
    Fintype.card { x // p x ∨ q x } = Fintype.card { x // p x } + Fintype.card { x // q x } := by
  classical
    convert Fintype.card_congr (subtypeOrEquiv p q h)
    simp
#align fintype.card_subtype_or_disjoint Fintype.card_subtype_or_disjoint
-/

section

open Classical

#print infinite_sum /-
@[simp]
theorem infinite_sum : Infinite (Sum α β) ↔ Infinite α ∨ Infinite β :=
  by
  refine' ⟨fun H => _, fun H => H.elim (@Sum.infinite_of_left α β) (@Sum.infinite_of_right α β)⟩
  contrapose! H; haveI := fintypeOfNotInfinite H.1; haveI := fintypeOfNotInfinite H.2
  exact Infinite.false
#align infinite_sum infinite_sum
-/

end


/-
Copyright (c) 2020 Patrick Massot. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Patrick Massot, Yury Kudryashov
-/
import topology.uniform_space.uniform_convergence
import topology.uniform_space.equicontinuity
import topology.separation
import topology.support

/-!
# Compact separated uniform spaces

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

## Main statements

* `compact_space_uniformity`: On a compact uniform space, the topology determines the
  uniform structure, entourages are exactly the neighborhoods of the diagonal.

* `uniform_space_of_compact_t2`: every compact T2 topological structure is induced by a uniform
  structure. This uniform structure is described in the previous item.

* **Heine-Cantor** theorem: continuous functions on compact uniform spaces with values in uniform
  spaces are automatically uniformly continuous. There are several variations, the main one is
  `compact_space.uniform_continuous_of_continuous`.

## Implementation notes

The construction `uniform_space_of_compact_t2` is not declared as an instance, as it would badly
loop.

## tags

uniform space, uniform continuity, compact space
-/

open_locale classical uniformity topology filter
open filter uniform_space set

variables {α β γ : Type*} [uniform_space α] [uniform_space β]

/-!
### Uniformity on compact spaces
-/

/-- On a compact uniform space, the topology determines the uniform structure, entourages are
exactly the neighborhoods of the diagonal. -/
lemma nhds_set_diagonal_eq_uniformity [compact_space α] : 𝓝ˢ (diagonal α) = 𝓤 α :=
begin
  refine nhds_set_diagonal_le_uniformity.antisymm _,
  have : (𝓤 (α × α)).has_basis (λ U, U ∈ 𝓤 α)
    (λ U, (λ p : (α × α) × α × α, ((p.1.1, p.2.1), p.1.2, p.2.2)) ⁻¹' U ×ˢ U),
  { rw [uniformity_prod_eq_comap_prod],
    exact (𝓤 α).basis_sets.prod_self.comap _ },
  refine (is_compact_diagonal.nhds_set_basis_uniformity this).ge_iff.2 (λ U hU, _),
  exact mem_of_superset hU (λ ⟨x, y⟩ hxy, mem_Union₂.2 ⟨(x, x), rfl, refl_mem_uniformity hU, hxy⟩)
end

/-- On a compact uniform space, the topology determines the uniform structure, entourages are
exactly the neighborhoods of the diagonal. -/
lemma compact_space_uniformity [compact_space α] : 𝓤 α = ⨆ x, 𝓝 (x, x) :=
nhds_set_diagonal_eq_uniformity.symm.trans (nhds_set_diagonal _)

lemma unique_uniformity_of_compact [t : topological_space γ] [compact_space γ]
  {u u' : uniform_space γ} (h : u.to_topological_space = t) (h' : u'.to_topological_space = t) :
  u = u' :=
begin
  apply uniform_space_eq,
  change uniformity _ = uniformity _,
  haveI : @compact_space γ u.to_topological_space, { rwa h },
  haveI : @compact_space γ u'.to_topological_space, { rwa h' },
  rw [compact_space_uniformity, compact_space_uniformity, h, h']
end

/-- The unique uniform structure inducing a given compact topological structure. -/
def uniform_space_of_compact_t2 [topological_space γ] [compact_space γ] [t2_space γ] :
  uniform_space γ :=
{ uniformity := 𝓝ˢ (diagonal γ),
  refl := principal_le_nhds_set,
  symm := continuous_swap.tendsto_nhds_set $ λ x, eq.symm,
  comp := begin
    /-
    This is the difficult part of the proof. We need to prove that, for each neighborhood `W`
    of the diagonal `Δ`, there exists a smaller neighborhood `V` such that `V ○ V ⊆ W`.
    -/
    set 𝓝Δ := 𝓝ˢ (diagonal γ), -- The filter of neighborhoods of Δ
    set F := 𝓝Δ.lift' (λ (s : set (γ × γ)), s ○ s), -- Compositions of neighborhoods of Δ
    -- If this weren't true, then there would be V ∈ 𝓝Δ such that F ⊓ 𝓟 Vᶜ ≠ ⊥
    rw le_iff_forall_inf_principal_compl,
    intros V V_in,
    by_contra H,
    haveI : ne_bot (F ⊓ 𝓟 Vᶜ) := ⟨H⟩,
    -- Hence compactness would give us a cluster point (x, y) for F ⊓ 𝓟 Vᶜ
    obtain ⟨⟨x, y⟩, hxy⟩ : ∃ (p : γ × γ), cluster_pt p (F ⊓ 𝓟 Vᶜ) := cluster_point_of_compact _,
    -- In particular (x, y) is a cluster point of 𝓟 Vᶜ, hence is not in the interior of V,
    -- and a fortiori not in Δ, so x ≠ y
    have clV : cluster_pt (x, y) (𝓟 $ Vᶜ) := hxy.of_inf_right,
    have : (x, y) ∉ interior V,
    { have : (x, y) ∈ closure (Vᶜ), by rwa mem_closure_iff_cluster_pt,
      rwa closure_compl at this },
    have diag_subset : diagonal γ ⊆ interior V,
      from subset_interior_iff_mem_nhds_set.2 V_in,
    have x_ne_y : x ≠ y,
      from mt (@diag_subset (x, y)) this,
    -- Since γ is compact and Hausdorff, it is normal, hence T₃.
    haveI : normal_space γ := normal_of_compact_t2,
    -- So there are closed neighboords V₁ and V₂ of x and y contained in disjoint open neighborhoods
    -- U₁ and U₂.
    obtain
      ⟨U₁, U₁_in, V₁, V₁_in, U₂, U₂_in₂, V₂, V₂_in, V₁_cl, V₂_cl, U₁_op, U₂_op, VU₁, VU₂, hU₁₂⟩ :=
       disjoint_nested_nhds x_ne_y,
    -- We set U₃ := (V₁ ∪ V₂)ᶜ so that W := U₁ ×ˢ U₁ ∪ U₂ ×ˢ U₂ ∪ U₃ ×ˢ U₃ is an open
    -- neighborhood of Δ.
    let U₃ := (V₁ ∪ V₂)ᶜ,
    have U₃_op : is_open U₃ := (V₁_cl.union V₂_cl).is_open_compl,
    let W := U₁ ×ˢ U₁ ∪ U₂ ×ˢ U₂ ∪ U₃ ×ˢ U₃,
    have W_in : W ∈ 𝓝Δ,
    { rw [mem_nhds_set_iff_forall],
      rintros ⟨z, z'⟩ (rfl : z = z'),
      refine is_open.mem_nhds _ _,
      { apply_rules [is_open.union, is_open.prod] },
      { simp only [mem_union, mem_prod, and_self],
        exact (em _).imp_left (λ h, union_subset_union VU₁ VU₂ h) } },
    -- So W ○ W ∈ F by definition of F
    have : W ○ W ∈ F, by simpa only using mem_lift' W_in,
    -- And V₁ ×ˢ V₂ ∈ 𝓝 (x, y)
    have hV₁₂ : V₁ ×ˢ V₂ ∈ 𝓝 (x, y) := prod_mem_nhds V₁_in V₂_in,
    -- But (x, y) is also a cluster point of F so (V₁ ×ˢ V₂) ∩ (W ○ W) ≠ ∅
    -- However the construction of W implies (V₁ ×ˢ V₂) ∩ (W ○ W) = ∅.
    -- Indeed assume for contradiction there is some (u, v) in the intersection.
    obtain ⟨⟨u, v⟩, ⟨u_in, v_in⟩, w, huw, hwv⟩ := cluster_pt_iff.mp (hxy.of_inf_left) hV₁₂ this,
    -- So u ∈ V₁, v ∈ V₂, and there exists some w such that (u, w) ∈ W and (w ,v) ∈ W.
    -- Because u is in V₁ which is disjoint from U₂ and U₃, (u, w) ∈ W forces (u, w) ∈ U₁ ×ˢ U₁.
    have uw_in : (u, w) ∈ U₁ ×ˢ U₁ := (huw.resolve_right $ λ h, (h.1 $ or.inl u_in)).resolve_right
      (λ h, hU₁₂.le_bot ⟨VU₁ u_in, h.1⟩),
    -- Similarly, because v ∈ V₂, (w ,v) ∈ W forces (w, v) ∈ U₂ ×ˢ U₂.
    have wv_in : (w, v) ∈ U₂ ×ˢ U₂ := (hwv.resolve_right $ λ h, (h.2 $ or.inr v_in)).resolve_left
      (λ h, hU₁₂.le_bot ⟨h.2, VU₂ v_in⟩),
    -- Hence w ∈ U₁ ∩ U₂ which is empty.
    -- So we have a contradiction
    exact hU₁₂.le_bot ⟨uw_in.2, wv_in.1⟩,
  end,
  is_open_uniformity := begin
    -- Here we need to prove the topology induced by the constructed uniformity is the
    -- topology we started with.
    suffices : ∀ x : γ, filter.comap (prod.mk x) (𝓝ˢ (diagonal γ)) = 𝓝 x,
    { intros s,
      simp_rw [is_open_fold, is_open_iff_mem_nhds, ← mem_comap_prod_mk, this] },
    intros x,
    simp_rw [nhds_set_diagonal, comap_supr, nhds_prod_eq, comap_prod, (∘), comap_id'],
    rw [supr_split_single _ x, comap_const_of_mem (λ V, mem_of_mem_nhds)],
    suffices : ∀ y ≠ x, comap (λ (y : γ), x) (𝓝 y) ⊓ 𝓝 y ≤ 𝓝 x,
      by simpa,
    intros y hxy,
    simp [comap_const_of_not_mem (compl_singleton_mem_nhds hxy) (not_not.2 rfl)]
  end }

/-!
### Heine-Cantor theorem
-/

/-- Heine-Cantor: a continuous function on a compact uniform space is uniformly
continuous. -/
lemma compact_space.uniform_continuous_of_continuous [compact_space α]
  {f : α → β} (h : continuous f) : uniform_continuous f :=
have tendsto (prod.map f f) (𝓝ˢ (diagonal α)) (𝓝ˢ (diagonal β)),
  from (h.prod_map h).tendsto_nhds_set maps_to_prod_map_diagonal,
(this.mono_left nhds_set_diagonal_eq_uniformity.ge).mono_right nhds_set_diagonal_le_uniformity

/-- Heine-Cantor: a continuous function on a compact set of a uniform space is uniformly
continuous. -/
lemma is_compact.uniform_continuous_on_of_continuous {s : set α} {f : α → β}
  (hs : is_compact s) (hf : continuous_on f s) : uniform_continuous_on f s :=
begin
  rw uniform_continuous_on_iff_restrict,
  rw is_compact_iff_compact_space at hs,
  rw continuous_on_iff_continuous_restrict at hf,
  resetI,
  exact compact_space.uniform_continuous_of_continuous hf,
end

/-- If `s` is compact and `f` is continuous at all points of `s`, then `f` is
"uniformly continuous at the set `s`", i.e. `f x` is close to `f y` whenever `x ∈ s` and `y` is
close to `x` (even if `y` is not itself in `s`, so this is a stronger assertion than
`uniform_continuous_on s`). -/
lemma is_compact.uniform_continuous_at_of_continuous_at {r : set (β × β)} {s : set α}
  (hs : is_compact s) (f : α → β) (hf : ∀ a ∈ s, continuous_at f a) (hr : r ∈ 𝓤 β) :
  {x : α × α | x.1 ∈ s → (f x.1, f x.2) ∈ r} ∈ 𝓤 α :=
begin
  obtain ⟨t, ht, htsymm, htr⟩ := comp_symm_mem_uniformity_sets hr,
  choose U hU T hT hb using λ a ha, exists_mem_nhds_ball_subset_of_mem_nhds
    ((hf a ha).preimage_mem_nhds $ mem_nhds_left _ ht),
  obtain ⟨fs, hsU⟩ := hs.elim_nhds_subcover' U hU,
  apply mem_of_superset ((bInter_finset_mem fs).2 $ λ a _, hT a a.2),
  rintro ⟨a₁, a₂⟩ h h₁,
  obtain ⟨a, ha, haU⟩ := set.mem_Union₂.1 (hsU h₁),
  apply htr,
  refine ⟨f a, htsymm.mk_mem_comm.1 (hb _ _ _ haU _), hb _ _ _ haU _⟩,
  exacts [mem_ball_self _ (hT a a.2), mem_Inter₂.1 h a ha],
end

lemma continuous.uniform_continuous_of_tendsto_cocompact {f : α → β} {x : β}
  (h_cont : continuous f) (hx : tendsto f (cocompact α) (𝓝 x)) : uniform_continuous f :=
uniform_continuous_def.2 $ λ r hr, begin
  obtain ⟨t, ht, htsymm, htr⟩ := comp_symm_mem_uniformity_sets hr,
  obtain ⟨s, hs, hst⟩ := mem_cocompact.1 (hx $ mem_nhds_left _ ht),
  apply mem_of_superset (symmetrize_mem_uniformity $ hs.uniform_continuous_at_of_continuous_at
    f (λ _ _, h_cont.continuous_at) $ symmetrize_mem_uniformity hr),
  rintro ⟨b₁, b₂⟩ h,
  by_cases h₁ : b₁ ∈ s, { exact (h.1 h₁).1 },
  by_cases h₂ : b₂ ∈ s, { exact (h.2 h₂).2 },
  apply htr,
  exact ⟨x, htsymm.mk_mem_comm.1 (hst h₁), hst h₂⟩,
end

/-- If `f` has compact multiplicative support, then `f` tends to 1 at infinity. -/
@[to_additive "If `f` has compact support, then `f` tends to zero at infinity."]
lemma has_compact_mul_support.is_one_at_infty {f : α → γ} [topological_space γ] [has_one γ]
  (h : has_compact_mul_support f) : tendsto f (cocompact α) (𝓝 1) :=
begin
  -- porting note: move to src/topology/support.lean once the port is over
  intros N hN,
  rw [mem_map, mem_cocompact'],
  refine ⟨mul_tsupport f, h.is_compact, _⟩,
  rw compl_subset_comm,
  intros v hv,
  rw [mem_preimage, image_eq_one_of_nmem_mul_tsupport hv],
  exact mem_of_mem_nhds hN,
end

@[to_additive]
lemma has_compact_mul_support.uniform_continuous_of_continuous {f : α → β} [has_one β]
  (h1 : has_compact_mul_support f) (h2 : continuous f) : uniform_continuous f :=
h2.uniform_continuous_of_tendsto_cocompact h1.is_one_at_infty

/-- A family of functions `α → β → γ` tends uniformly to its value at `x` if `α` is locally compact,
`β` is compact and `f` is continuous on `U × (univ : set β)` for some neighborhood `U` of `x`. -/
lemma continuous_on.tendsto_uniformly [locally_compact_space α] [compact_space β]
  [uniform_space γ] {f : α → β → γ} {x : α} {U : set α}
  (hxU : U ∈ 𝓝 x) (h : continuous_on ↿f (U ×ˢ univ)) :
  tendsto_uniformly f (f x) (𝓝 x) :=
begin
  rcases locally_compact_space.local_compact_nhds _ _ hxU with ⟨K, hxK, hKU, hK⟩,
  have : uniform_continuous_on ↿f (K ×ˢ univ),
    from is_compact.uniform_continuous_on_of_continuous (hK.prod is_compact_univ)
      (h.mono $ prod_mono hKU subset.rfl),
  exact this.tendsto_uniformly hxK
end

/-- A continuous family of functions `α → β → γ` tends uniformly to its value at `x` if `α` is
locally compact and `β` is compact. -/
lemma continuous.tendsto_uniformly [locally_compact_space α] [compact_space β] [uniform_space γ]
  (f : α → β → γ) (h : continuous ↿f) (x : α) : tendsto_uniformly f (f x) (𝓝 x) :=
h.continuous_on.tendsto_uniformly univ_mem

section uniform_convergence

/-- An equicontinuous family of functions defined on a compact uniform space is automatically
uniformly equicontinuous. -/
lemma compact_space.uniform_equicontinuous_of_equicontinuous {ι : Type*} {F : ι → β → α}
  [compact_space β] (h : equicontinuous F) :
  uniform_equicontinuous F :=
begin
  rw equicontinuous_iff_continuous at h,
  rw uniform_equicontinuous_iff_uniform_continuous,
  exact compact_space.uniform_continuous_of_continuous h
end

end uniform_convergence


import EggTactic
namespace Test

inductive List α
  | nil : List α
  | cons : α → List α → List α

notation a "::"  b => List.cons a b
notation "[" "]" => List.nil

-- From init/data/list/basic.lean

def append : List α → List α → List α
  | [],    bs => bs
  | a::as, bs => a :: append as bs

/- I should be able to derive these directly in the tactic... -/
def append_nil : ∀ (bs:  List α), append ([] : List α) bs = bs := by
  intros
  rfl

def append_cons : ∀ (a : α) (as bs : List α), append (a :: as) bs = a :: (append as bs) := by
  intros
  rfl

instance {α : Type _} : HAppend (List α) (List α) (List α) where hAppend := append

theorem append_assoc (as bs cs : List α) : (as ++ bs) ++ cs = as ++ (bs ++ cs) := by
  induction as with
  | nil => eggxplosion [append_nil, append_cons]
  | cons a as ih => eggxplosion [ih, append_nil, append_cons] -- could this also be automated?
  -- <;> eggxplosion

def reverseAux : List α → List α → List α
  | [],   r => r
  | a::l, r => reverseAux l (a::r)

def List.reverse (as : List α) :List α :=
  reverseAux as []

def reverseAux_nil : ∀ r : List α, reverseAux ([] : List α) r = r := by
  intros
  rfl

def reverseAux_cons : ∀ (l r : List α) (a : α) , reverseAux (a :: l) r = reverseAux l (a :: r) := by
  intros
  rfl

def reverse_def : ∀ l : List α, l.reverse = reverseAux l [] := by
  intros
  rfl

theorem reverseAux_eq_append (as bs : List α) : reverseAux as bs = reverseAux as [] ++ bs := by
  induction as generalizing bs with
  | nil => eggxplosion [reverseAux_nil, reverseAux_cons]
  | cons a as ih =>
    eggxplosion [reverseAux_nil, reverseAux_cons, append_assoc]
  -- <;> eggxplosion [reverseAux, append_assoc]

theorem reverse_cons (a : α) (as : List α) : List.reverse (a :: as) = List.reverse as ++ (a :: List.nil) := by
  eggxplosion [reverse_def, reverseAux_nil, reverseAux_cons, reverseAux_eq_append]

theorem reverse_append (as bs : List α) : (as ++ bs).reverse = bs.reverse ++ as.reverse := by
  induction as generalizing bs with
  | nil => eggxplosion []
  | cons a as ih => eggxplosion [ih, append_assoc]
  -- <;> eggxplosion [append_assoc]

def List.map : (α → β) → List α  → List β
  | _, [] => []
  | f, (a :: as) => (f a) :: (as.map f)

def List.foldr (f : α → β → β) (init : β) : List α → β
  | []     => init
  | a :: l => f a (foldr f init l)

-- A short cut to deforestation, Gill, Launchbury, Peyton Jones
def all (p : α → Bool) (xs : List α) : Bool := (List.map p xs).foldr and true

def all' : (α → Bool) → List α → Bool
  | _, [] => true
  | p, (x::xs) => (p x) && (all' p xs)

theorem all_deforestation {α} : ∀ (p : α → Bool) (xs : List α), all p xs = all' p xs := by
  -- eggxplosion [all, all', map, foldr]
  intros p xs
  try induction xs with
    | nil => simp [all, all', List.foldr, List.map]
    | cons a as ih => simp [all, all', List.foldr, List.map, ih]
  eggxplosion [all, all', List.foldr, List.map] -- add induction explicitly (like in Agda?)


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import linear_algebra.tensor_algebra.basic
import linear_algebra.tensor_power
/-!
# Tensor algebras as direct sums of tensor powers

In this file we show that `tensor_algebra R M` is isomorphic to a direct sum of tensor powers, as
`tensor_algebra.equiv_direct_sum`.
-/
open_locale direct_sum tensor_product

variables {R M : Type*} [comm_semiring R] [add_comm_monoid M] [module R M]

namespace tensor_power

/-- The canonical embedding from a tensor power to the tensor algebra -/
def to_tensor_algebra {n} : ⨂[R]^n M →ₗ[R] tensor_algebra R M :=
pi_tensor_product.lift (tensor_algebra.tprod R M n)

@[simp]
lemma to_tensor_algebra_tprod {n} (x : fin n → M) :
  tensor_power.to_tensor_algebra (pi_tensor_product.tprod R x) = tensor_algebra.tprod R M n x :=
pi_tensor_product.lift.tprod _

@[simp]
lemma to_tensor_algebra_ghas_one :
  (@graded_monoid.ghas_one.one _ (λ n, ⨂[R]^n M) _ _).to_tensor_algebra = 1 :=
tensor_power.to_tensor_algebra_tprod _

@[simp]
lemma to_tensor_algebra_ghas_mul {i j} (a : ⨂[R]^i M) (b : ⨂[R]^j M) :
  (@graded_monoid.ghas_mul.mul _ (λ n, ⨂[R]^n M) _ _ _ _ a b).to_tensor_algebra
    = a.to_tensor_algebra * b.to_tensor_algebra :=
begin
  -- change `a` and `b` to `tprod R a` and `tprod R b`
  rw [tensor_power.ghas_mul_eq_coe_linear_map, ←linear_map.compr₂_apply,
    ←@linear_map.mul_apply' R, ←linear_map.compl₂_apply, ←linear_map.comp_apply],
  refine linear_map.congr_fun (linear_map.congr_fun _ a) b,
  clear a b,
  ext a b,
  simp only [linear_map.compr₂_apply, linear_map.mul_apply',
    linear_map.compl₂_apply, linear_map.comp_apply, linear_map.comp_multilinear_map_apply,
    pi_tensor_product.lift.tprod, tensor_power.tprod_mul_tprod,
    tensor_power.to_tensor_algebra_tprod, tensor_algebra.tprod_apply, ←ghas_mul_eq_coe_linear_map],
  refine eq.trans _ list.prod_append,
  congr',
  rw [←list.map_of_fn _ (tensor_algebra.ι R), ←list.map_of_fn _ (tensor_algebra.ι R),
    ←list.map_of_fn _ (tensor_algebra.ι R), ←list.map_append, list.of_fn_fin_append],
end

@[simp]
lemma to_tensor_algebra_galgebra_to_fun (r : R) :
  (@direct_sum.galgebra.to_fun _ R (λ n, ⨂[R]^n M) _ _ _ _ _ _ _ r).to_tensor_algebra
    = algebra_map _ _ r :=
by rw [tensor_power.galgebra_to_fun_def, tensor_power.algebra_map₀_eq_smul_one, linear_map.map_smul,
    tensor_power.to_tensor_algebra_ghas_one, algebra.algebra_map_eq_smul_one]

end tensor_power

namespace tensor_algebra

/-- The canonical map from a direct sum of tensor powers to the tensor algebra. -/
def of_direct_sum : (⨁ n, ⨂[R]^n M) →ₐ[R] tensor_algebra R M :=
direct_sum.to_algebra _ _ (λ n, tensor_power.to_tensor_algebra)
  tensor_power.to_tensor_algebra_ghas_one
  (λ i j, tensor_power.to_tensor_algebra_ghas_mul)
  (tensor_power.to_tensor_algebra_galgebra_to_fun)

@[simp] lemma of_direct_sum_of_tprod {n} (x : fin n → M) :
  of_direct_sum (direct_sum.of _ n (pi_tensor_product.tprod R x)) = tprod R M n x :=
(direct_sum.to_add_monoid_of _ _ _).trans (tensor_power.to_tensor_algebra_tprod _)

/-- The canonical map from the tensor algebra to a direct sum of tensor powers. -/
def to_direct_sum : tensor_algebra R M →ₐ[R] ⨁ n, ⨂[R]^n M :=
tensor_algebra.lift R $
  direct_sum.lof R ℕ (λ n, ⨂[R]^n M) _ ∘ₗ
    (linear_equiv.symm $ pi_tensor_product.subsingleton_equiv (0 : fin 1) : M ≃ₗ[R] _).to_linear_map

@[simp] lemma to_direct_sum_ι (x : M) :
  to_direct_sum (ι R x) =
    direct_sum.of (λ n, ⨂[R]^n M) _ (pi_tensor_product.tprod R (λ _ : fin 1, x)) :=
tensor_algebra.lift_ι_apply _ _

lemma of_direct_sum_comp_to_direct_sum :
  of_direct_sum.comp to_direct_sum = alg_hom.id R (tensor_algebra R M) :=
begin
  ext,
  simp [direct_sum.lof_eq_of, tprod_apply],
end

@[simp] lemma of_direct_sum_to_direct_sum (x : tensor_algebra R M) :
  of_direct_sum x.to_direct_sum = x :=
alg_hom.congr_fun of_direct_sum_comp_to_direct_sum x

@[simp] lemma mk_reindex_cast {n m : ℕ} (h : n = m) (x : ⨂[R]^n M) :
  graded_monoid.mk m (pi_tensor_product.reindex R M (equiv.cast $ congr_arg fin h) x) =
    graded_monoid.mk n x :=
eq.symm (pi_tensor_product.graded_monoid_eq_of_reindex_cast h rfl)

@[simp] lemma mk_reindex_fin_cast {n m : ℕ} (h : n = m) (x : ⨂[R]^n M) :
  graded_monoid.mk m (pi_tensor_product.reindex R M (fin.cast h).to_equiv x) =
    graded_monoid.mk n x :=
by rw [fin.cast_to_equiv, mk_reindex_cast h]

/-- The product of tensor products made of a single vector is the same as a single product of
all the vectors. -/
lemma _root_.tensor_power.list_prod_graded_monoid_mk_single (n : ℕ) (x : fin n → M) :
  ((list.fin_range n).map
    (λ a, (graded_monoid.mk _ (pi_tensor_product.tprod R (λ i : fin 1, x a))
      : graded_monoid (λ n, ⨂[R]^n M)))).prod =
  graded_monoid.mk n (pi_tensor_product.tprod R x) :=
begin
  refine fin.cons_induction _ _ x; clear x,
  { rw [list.fin_range_zero, list.map_nil, list.prod_nil],
    refl, },
  { intros n x₀ x ih,
    rw [list.fin_range_succ_eq_map, list.map_cons, list.prod_cons, list.map_map, function.comp],
    simp_rw [fin.cons_zero, fin.cons_succ],
    rw [ih, graded_monoid.mk_mul_mk, tensor_power.tprod_mul_tprod],
    refine tensor_power.graded_monoid_eq_of_cast (add_comm _ _) _,
    dsimp only [graded_monoid.mk],
    rw [tensor_power.cast_tprod],
    simp_rw [fin.append_left_eq_cons, function.comp],
    congr' 1 with i,
    congr' 1,
    rw [fin.cast_trans, fin.cast_refl, order_iso.refl_apply] },
end

lemma to_direct_sum_tensor_power_tprod {n} (x : fin n → M) :
  to_direct_sum (tprod R M n x) = direct_sum.of _ n (pi_tensor_product.tprod R x) :=
begin
  rw [tprod_apply, alg_hom.map_list_prod, list.map_of_fn, function.comp],
  simp_rw to_direct_sum_ι,
  dsimp only,
  rw direct_sum.list_prod_of_fn_of_eq_dprod,
  apply direct_sum.of_eq_of_graded_monoid_eq,
  rw graded_monoid.mk_list_dprod,
  rw tensor_power.list_prod_graded_monoid_mk_single,
end

lemma to_direct_sum_comp_of_direct_sum :
  to_direct_sum.comp of_direct_sum = alg_hom.id R (⨁ n, ⨂[R]^n M) :=
begin
  ext,
  simp [direct_sum.lof_eq_of, -tprod_apply, to_direct_sum_tensor_power_tprod],
end

@[simp] lemma to_direct_sum_of_direct_sum (x : ⨁ n, ⨂[R]^n M) :
  (of_direct_sum x).to_direct_sum = x :=
alg_hom.congr_fun to_direct_sum_comp_of_direct_sum x

/-- The tensor algebra is isomorphic to a direct sum of tensor powers. -/
@[simps]
def equiv_direct_sum : tensor_algebra R M ≃ₐ[R] ⨁ n, ⨂[R]^n M :=
alg_equiv.of_alg_hom to_direct_sum of_direct_sum
  to_direct_sum_comp_of_direct_sum
  of_direct_sum_comp_to_direct_sum

end tensor_algebra


import tactic
import tactic.induction

noncomputable theory
open_locale classical

inductive Expr' : Type
| K' : Expr'
| S' : Expr'
| app' : Expr' → Expr' → Expr'
open Expr'

inductive Step : Expr' → Expr' → Prop
| k {a b} : Step (app' (app' K' a) b) a
| s {a b c} : Step (app' (app' (app' S' a) b) c) (app' (app' a c) (app' b c))
| func {a b c} : Step a b → Step (app' a c) (app' b c)
| arg {a b c} : Step a b → Step (app' c a) (app' c b)

def R := relation.refl_trans_gen Step

inductive Eq : Expr' → Expr' → Prop
| reduces {a b} : (∃ c, R a c ∧ R b c) → Eq a b
| ext {a b} : (∀ c, Eq (app' a c) (app' b c)) → Eq a b

-- lemma Eq.reflexive : reflexive Eq :=
-- by { intro a, left, use a, split; left }

-- lemma Eq.symmetric : symmetric Eq :=
-- begin
--   rintro a b h,
--   induction' h,
--   { left, tauto },
--   { right, exact ih },
-- end

lemma Eq.equivalence : equivalence Eq :=
begin
  refine ⟨_, _, _⟩,
  { intro a, left, use a, split; left },
  { rintro a b h,
    induction' h,
    { left, tauto },
    { right, exact ih }},
  {
    rintro a b x h₁ h₂,
    cases h₁ with _ _ h₁ _ _ h₁;
    cases h₂ with _ _ h₂ _ _ h₂,
    {
      left,
      rcases h₁ with ⟨c, hc₁, hc₂⟩,
      rcases h₂ with ⟨d, hd₁, hd₂⟩,
      sorry
    },
    sorry,
    sorry,
    sorry,
  },
end

-- #exit

instance : setoid Expr' := ⟨_, Eq.equivalence⟩

def Expr := quotient Expr'.setoid

def K : Expr := ⟦K'⟧
def S : Expr := ⟦S'⟧
def app (a b : Expr) : Expr := ⟦app' a.out b.out⟧
infixl ` ~ `:100 := app

def I := S ~ K ~ K

example {a b} : K ~ a ~ b = a :=
begin
  rw ←quotient.out_equiv_out,
  sorry
end


import tactic
import data.int.parity
import data.int.modeq
import data.nat.factorization.basic
import number_theory.legendre_symbol.quadratic_reciprocity

import Mordell.CongruencesMod4

lemma int.exists_nat_of_nonneg {z : ℤ} (hz : 0 ≤ z) : ∃ n : ℕ,
  (n : ℤ) = z :=
begin
  use z.nat_abs,
  exact int.nat_abs_of_nonneg hz,
end

theorem modeq_add_fac_self {a t n : ℤ} : a + n * t ≡ a [ZMOD n] :=
int.modeq_add_fac _ int.modeq.rfl

theorem modeq_iff_add_fac {a b n : ℤ} : a ≡ b [ZMOD n] ↔ ∃ t, b = a + n * t :=
begin
  rw int.modeq_iff_dvd,
  exact exists_congr (λ t, sub_eq_iff_eq_add'),
end

lemma prime_factor_congr_3_mod_4 (x : ℤ) (h : x^2 + x + 1 ≡ 3 [ZMOD 4]) :
  ∃ (p : ℕ), p.prime ∧ (p : int) ∣ (x^2 + x + 1)  ∧ p ≡ 3 [MOD 4] :=
begin
  have h1 : ((x^2 + x + 1): ℚ) = (x + 1/2)^2 + 3/4:= by ring,
  have h2 : 0 ≤ x^2 + x + 1,
  { nlinarith, },
  obtain ⟨n, hn⟩  := int.exists_nat_of_nonneg h2,
  rw ← hn at h,
  have h3 : n ≡ 3 [MOD 4],
  unfold int.modeq at h,
  unfold nat.modeq,
  assumption_mod_cast,
  obtain ⟨p, hp1, hp2, hp3⟩ := three_modulo_four_prime_factor n h3,
  refine ⟨p, hp1, _, hp3⟩,
  rwa [← hn, int.coe_nat_dvd],
end

lemma x_eq_1_zmod4 (x y : ℤ) (h : y^2 ≡ x^3 - 5 [ZMOD 4]) :
  (x ≡ 1 [ZMOD 4]) :=
begin
  change _ ≡ _ [ZMOD (4 : ℕ)] at h,
  change _ ≡ _ [ZMOD (4 : ℕ)],
  rw ← zmod.int_coe_eq_int_coe_iff at h ⊢,
  push_cast at h ⊢,
  revert h,
  generalize : (↑x : zmod 4) = xbar,
  generalize : (↑y : zmod 4) = ybar,
  intro h,
  dec_trivial!,
end

lemma useful_lemma (x y : ℤ)
  (h1 : ∀ (x y : ℤ), y ^ 2 ≡ x ^ 3 - 5 [ZMOD 4] → x ≡ 1 [ZMOD 4])
  (p : ℕ)
  (heq : y ^ 2 = x ^ 3 - 5)
  (oddx : odd x)
  (hxy : y ^ 2 ≡ x ^ 3 - 5 [ZMOD 4])
  (hx : x ≡ 1 [ZMOD 4])
  (h2 : y ^ 2 ≡ (x - 1) * (x ^ 2 + x + 1) [ZMOD 4])
  (h6 : x ^ 2 + x + 1 ≡ 3 [ZMOD 4])
  (hp : nat.prime p)
  (hpd : ↑p ∣ x ^ 2 + x + 1)
  (h8 : p ≡ 3 [MOD 4])
  (h9 : ↑p ∣ y ^ 2 + 4)
  [fact (nat.prime p)] :
  let yp : zmod p := ↑y
  in yp = ↑y → yp ^ 2 = -4 → (-4 : zmod p) / 4 = -1 :=
begin
  intros yp hyp0 hyp,
  have hpne2 : p ≠ 2,
  { unfreezingI {rintro rfl},
    delta nat.modeq at h8,
    norm_num at h8, },
  have hp : (4 : zmod p) ≠ 0,
  { intro h,
    have h2 : ((4 : ℕ) : zmod p) = 0,
      assumption_mod_cast,
    have h3 : p ∣ 4,
      exact (zmod.nat_coe_zmod_eq_zero_iff_dvd 4 p).mp h2,
    have h37 : 0 < 4 := by norm_num,
    have h4 : p ≤ 4 := nat.le_of_dvd h37 h3,
    have h5 : p = 3,
    { apply nat.modeq.eq_of_modeq_of_abs_lt h8,
      norm_num,
      rw abs_lt,
      norm_cast,
      split; linarith,
    },
    unfreezingI {subst h5},
    norm_num at h3, },
  simp [hp],
end

-- might help you dump oddx
example (x : ℤ) (hx : x ≡ 1 [ZMOD 4]) : x^2 + x + 1 ≡ 3 [ZMOD 4] :=
begin
  have bar : x ≡ 1 [ZMOD (4 : ℕ)],
    assumption_mod_cast,
  suffices : x^2 + x + 1 ≡ 3 [ZMOD (4 : ℕ)],
    assumption_mod_cast,
  rw ← zmod.int_coe_eq_int_coe_iff at bar ⊢,
  push_cast,
  rw bar,
  ring,
end

example (x y : ℤ) : y^2 ≠ x^3 - 5 :=
begin
intro heq,
  have oddx: odd x,
    { apply int.odd_iff_not_even.2,
      intro h,
      rw even_iff_two_dvd at h,
      have h3: 0 < 3:= by norm_num,
      rw ← int.pow_dvd_pow_iff h3 at h,
      norm_num at h,
      rw ← int.modeq_zero_iff_dvd at h,
      have h2 := int.modeq.sub_right 5 h,
      rw ← heq at h2,
      norm_num at h2,
      have h4:= int.square_ne_three_mod_four y,
      apply h4,
      clear h4,
      have h6: (4 : ℤ ) ∣ 8:= by norm_num,
      have h5:= int.modeq.modeq_of_dvd h6 h2,
      unfold int.modeq at h5 ⊢,
      rw h5,
      norm_num,
  },
  have hxy : y^2 ≡  x^3 - 5 [ZMOD 4],
  { rw heq, },
  have hx : x ≡ 1 [ZMOD 4],
  { have htemp := x_eq_1_zmod4,
    exact htemp x y hxy,},
      have h1 := x_eq_1_zmod4,
  have h2 : y^2 ≡ (x-1)*(x^2 + x + 1) [ZMOD 4],
    { rw heq,
      ring_nf,
      have htemp : -5 ≡ -1 [ZMOD 4],
      { unfold int.modeq,
        norm_num, },
      unfold int.modeq at htemp ⊢,
      rw int.mod_eq_mod_iff_mod_sub_eq_zero,
      ring_nf,
    },
  have h6 : x^2 + x + 1 ≡  3 [ZMOD 4],
    { have hx2: x^2 ≡ 1 [ZMOD 4],
      { exact int.square_eq_one_mod_four_of_odd x oddx, },
      have hx2px : x^2 + x ≡ 2 [ZMOD 4],
      { unfold int.modeq at hx2 hx ⊢,
        norm_num at hx2 hx ⊢,
        rw int.add_mod,
        rw hx,
        rw hx2,
        norm_num,},
      unfold int.modeq at hx2 hx hx2px ⊢,
      norm_num at hx2 hx hx2px ⊢,
      rw int.add_mod,
      rw hx2px,
      norm_num,},
  obtain ⟨p, hp, hpd, h8⟩  := prime_factor_congr_3_mod_4 x h6,
  have h9 : ↑p∣y^2 + 4,
  { have h3 : y^2 + 4 = (x - 1)*(x^2 + x + 1),
    { rw heq,
      ring,},
    rw h3,
    exact dvd_mul_of_dvd_right hpd (x - 1), },
  haveI : fact (nat.prime p) := ⟨hp⟩,
  set yp : zmod p := y with hyp0,
  have hyp : yp^2 = -4,
  { rw ← zmod.int_coe_zmod_eq_zero_iff_dvd at h9,
    push_cast at h9,
    linear_combination h9, },
  have hypdiv2 : (yp/2)^2 = -1,
  { norm_num,
    rw hyp,
    apply useful_lemma; try {assumption}, },
  apply zmod.mod_four_ne_three_of_sq_eq_neg_one hypdiv2,
  rw nat.modeq at h8,
  norm_num at h8,
  assumption,
end


variable f : nat -> bool.

def downward_closed :=
  forall m n, m <= n -> f n = tt -> f m = tt.

lemma l1: downward_closed f → ∀ (r n: ℕ), f r = ff → f n = tt → n < r :=
begin
    intros h r n h1 h2,
    have: ¬ n ≥ r,
        intro,
        have: f r = tt,
            apply h,
            apply a,
            assumption,
        simp * at *,
    sorry,
end

-- k: an extra parameter to convince termination checker
def binsearch : nat → nat → nat → nat
| l r 0 := match decidable.to_bool (nat.succ l = r) with
    | tt := l
    | ff := r
    end
| l r (k + 1) := match decidable.to_bool (nat.succ l = r) with
    | tt := l
    | ff :=
        let m := (l + r) / 2 in
        if f m then binsearch m r k else binsearch l m k
end

lemma success : downward_closed f → ∀ (l r : nat), l < r → f l = tt → f r = ff → f (binsearch f l r (r - l)) = tt :=
sorry

example: downward_closed f →
    ∀ (l r : nat), l < r → f l = tt → f r = ff →
        ∃ (k : nat), ∀ n, f n = tt ↔ n ≤ (binsearch f l r k) :=
begin
    intros h l r h_l_lt_r h_low h_up,
    fapply exists.intro,
        exact (r - l),
    intro n,
    split,
        intro h2,
        induction (r - l),
            unfold binsearch,
            cases (to_bool (nat.succ l = r)),
                unfold binsearch._match_1,
                sorry,
            unfold binsearch._match_1,
            sorry,
        sorry,
    sorry
end


/-
Copyright (c) 2023 María Inés de Frutos-Fernández. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: María Inés de Frutos-Fernández
-/
import analysis.normed_space.bounded_linear_maps
import seminorm_from_bounded
import smoothing_seminorm

/-!
# Basis.norm

In this file, we prove [BGR, Lemma 3.2.1./3]: if `K` is a normed field with a nonarchimedean
power-multiplicative norm and `L/K` is a finite extension, then there exists at least one
power-multiplicative `K`-algebra norm on `L` extending the norm on `K`.

## Main Definitions
* `basis.norm` : the function sending an element `x : L` to the maximum of the norms of its
  coefficients with respect to the `K`-basis `B` of `L`.

## Main Results
* `finite_extension_pow_mul_seminorm` : the proof of [BGR, Lemma 3.2.1./3].

## References
* [S. Bosch, U. Güntzer, R. Remmert, *Non-Archimedean Analysis*][bosch-guntzer-remmert]

## Tags

basis.norm, nonarchimedean
-/

noncomputable theory

open finset

open_locale big_operators

section continuous

/-- A continuous linear map between normed spaces. -/
structure is_continuous_linear_map (𝕜 : Type*) [normed_field 𝕜]
  {E : Type*} [normed_add_comm_group E] [normed_space 𝕜 E]
  {F : Type*} [normed_add_comm_group F] [normed_space 𝕜 F] (f : E → F)
  extends is_linear_map 𝕜 f : Prop :=
(cont : continuous f . tactic.interactive.continuity')

/-- A linear map between normed spaces is continuous if and only if it is bounded,-/
lemma is_continuous_linear_map_iff_is_bounded_linear_map {K : Type*} [nontrivially_normed_field K]
  {M : Type*} [normed_add_comm_group M] [normed_space K M] {N : Type*} [normed_add_comm_group N]
  [normed_space K N] (f : M → N) : is_continuous_linear_map K f ↔ is_bounded_linear_map K f :=
begin
  refine ⟨λ h_cont, _, λ h_bdd, ⟨h_bdd.to_is_linear_map, h_bdd.continuous⟩⟩,
  { set F : M →L[K] N :=
    by use [f, is_linear_map.map_add h_cont.1, is_linear_map.map_smul h_cont.1, h_cont.2],
    exact continuous_linear_map.is_bounded_linear_map F, },
end

end continuous

section finsum

/-- Given a function `f : α → M` and a linear equivalence `g : M ≃ₛₗ[σ] N`, we have
  `g ∑ᶠ f i = ∑ᶠ g(f i)`.  -/
theorem linear_equiv.map_finsum {R S : Type*} {α : Sort*} [semiring R] [semiring S] (σ : R →+* S)
  {σ' : S →+* R} [ring_hom_inv_pair σ σ'] [ring_hom_inv_pair σ' σ] (M N : Type*) [add_comm_monoid M]
  [add_comm_monoid N] [module R M] [module S N] (g : M ≃ₛₗ[σ] N) (f : α → M) :
  g (finsum (λ (i : α), f i)) = finsum (λ (i : α), g (f i)) :=
add_equiv.map_finsum g.to_add_equiv f

/-- Given a fintype `α`, a function `f : α → M` and a linear equivalence `g : M ≃ₛₗ[σ] N`, we have
  `g (∑ (i : α), f i) = ∑ (i : α), g (f i)`.  -/
theorem linear_equiv.map_finset_sum {R S : Type*} {α : Sort*} [fintype α] [semiring R] [semiring S]
  (σ : R →+* S) {σ' : S →+* R} [ring_hom_inv_pair σ σ'] [ring_hom_inv_pair σ' σ] (M N : Type*)
  [add_comm_monoid M] [add_comm_monoid N] [module R M] [module S N] (g : M ≃ₛₗ[σ] N)
  (f : α → M) : g (∑ (i : α), f i) = ∑ (i : α), g (f i) :=
by simp only [← finsum_eq_sum_of_fintype, linear_equiv.map_finsum]

theorem finsum_apply {α : Type*} {β : α → Type*} {γ : Type*} [finite γ]
  [Π (a : α), add_comm_monoid (β a)] (a : α) (g : γ → Π (a : α), β a) :
  finsum (λ (c : γ), g c) a = finsum (λ (c : γ), g c a) :=
begin
  casesI nonempty_fintype γ,
  simp only [finsum_eq_sum_of_fintype, sum_apply]
end

/-- If `∑ i, f i • v i = ∑ i, g i • v i`, then for all `i`, `f i = g i`. -/
lemma linear_independent.eq_coords_of_eq {R : Type*} [ring R] {M : Type*} [add_comm_group M]
  [module R M] {ι : Type*} [fintype ι] {v : ι → M} (hv : linear_independent R v) {f : ι → R}
  {g : ι → R} (heq : ∑ i, f i • v i = ∑ i, g i • v i) (i : ι) : f i = g i :=
begin
  rw [← sub_eq_zero, ← sum_sub_distrib] at heq,
  simp_rw ← sub_smul at heq,
  rw linear_independent_iff' at hv,
  exact sub_eq_zero.mp (hv univ (λ i, (f i - g i)) heq i (mem_univ i)),
end

end finsum

variables {K : Type*} [normed_field K] {L : Type*} [field L] [algebra K L]

/-- If `B` is a basis of the `K`-vector space `L` such that `B i = 1` for some index `i`, then
each `k:K` gets represented as `k • B i` as an element of `L`. -/
lemma basis_one {ι : Type*} [fintype ι] [decidable_eq ι] {B : basis ι K L} {i : ι}
  (hBi : B i = (1 : L)) (k : K) :
  B.equiv_fun ((algebra_map K L) k) = λ (j : ι), if (j = i) then k else 0 :=
begin
  ext j,
  apply linear_independent.eq_coords_of_eq B.linear_independent,
  rw basis.sum_equiv_fun B (algebra_map K L k),
  have h_sum : ∑ (j : ι), ite (j = i) k 0 • B j = ∑ (j : ι), ite (j = i) (k • B j) 0,
  { apply sum_congr (eq.refl _),
    { rintros h -,
      split_ifs,
      exacts [rfl, zero_smul _ _] }},
  rw [h_sum, algebra.algebra_map_eq_smul_one, sum_ite_eq' univ (i : ι) (λ j : ι, k • B j)],
  simp only [mem_univ, if_true, hBi],
end

namespace basis

/-- The function sending an element `x : L` to the maximum of the norms of its coefficients
  with respect to the `K`-basis `B` of `L`.-/
def norm {ι : Type*} [fintype ι] [nonempty ι] (B : basis ι K L) : L → ℝ :=
λ x, ‖B.equiv_fun x (classical.some (finite.exists_max (λ i : ι, ‖B.equiv_fun x i‖ )))‖

/-- The norm of a coefficient `x_i` is less than or equal to the norm of `x`. -/
lemma le_norm {ι : Type*} [fintype ι] [nonempty ι] (B : basis ι K L) (x : L) (i : ι) :
  ‖B.equiv_fun x i‖ ≤ B.norm x :=
classical.some_spec (finite.exists_max (λ i : ι, ‖B.equiv_fun x i‖)) i

/-- For any `K`-basis of `L`, we have `B.norm 0 = 0`. -/
lemma norm_zero' {ι : Type*} [fintype ι] [nonempty ι] (B : basis ι K L) :  B.norm 0 = 0 :=
by simp only [norm, map_zero, pi.zero_apply, norm_zero]

/-- For any `K`-basis of `L`, and any `x : L`, we have `B.norm (-x) = B.norm x`. -/
lemma norm_neg {ι : Type*} [fintype ι] [nonempty ι] (B : basis ι K L) (x : L) :
  B.norm (-x) = B.norm x :=
begin
  simp only [norm, map_neg],
  convert norm_neg _,
  ext x, simp only [pi.neg_apply, norm_neg]
end

/-- For any `K`-basis of `L`, `B.norm` extends the norm on `K`. -/
lemma norm_extends {ι : Type*} [fintype ι] [nonempty ι] {B : basis ι K L}
  {i : ι} (hBi : B i = (1 : L)) :
  function_extends (λ x : K, ‖x‖) B.norm :=
begin
  classical,
  intro k,
  { by_cases hk : k = 0,
  { simp only [hk, map_zero, norm_zero, norm_zero'] },
  { simp only [norm, basis_one hBi],
    have h_max : (classical.some (finite.exists_max (λ j : ι,
      ‖(λ (n : ι), if (n = i) then k else 0) j ‖))) = i,
    { by_contradiction h,
      have h_max := classical.some_spec (finite.exists_max (λ j : ι,
        ‖(λ (n : ι), if (n = i) then k else 0) j ‖)),
      simp only [if_neg h] at h_max,
      specialize h_max i,
      rw [if_pos rfl, norm_zero, norm_le_zero_iff] at h_max,
      exact hk h_max },
    rw if_pos h_max }}
end

/-- For any `K`-basis of `L`, if the norm on `K` is nonarchimedean, then so is `B.norm`. -/
lemma norm_is_nonarchimedean {ι : Type*} [fintype ι] [nonempty ι] {B : basis ι K L}
  (hna : is_nonarchimedean (has_norm.norm : K → ℝ)) : is_nonarchimedean B.norm  :=
begin
  classical,
  intros x y,
  simp only [basis.norm],
  set ixy := classical.some (finite.exists_max (λ i : ι, ‖B.equiv_fun (x + y) i‖)) with hixy_def,
  have hxy : ‖B.equiv_fun (x + y) ixy‖ ≤ max (‖B.equiv_fun x ixy‖) (‖B.equiv_fun y ixy‖),
  { rw [linear_equiv.map_add, pi.add_apply], exact hna _ _ },
  have hix := classical.some_spec (finite.exists_max (λ i : ι, ‖B.equiv_fun x i‖)),
  have hiy := classical.some_spec (finite.exists_max (λ i : ι, ‖B.equiv_fun y i‖)),
  cases le_max_iff.mp hxy with hx hy,
  { apply le_max_of_le_left (le_trans hx (hix ixy)) },
  { apply le_max_of_le_right (le_trans hy (hiy ixy)) },
end

/-- For any `K`-basis of `L`, `B.norm` is bounded with respect to multiplication. That is,
  `∃ (c : ℝ), c > 0` such that ` ∀ (x y : L), B.norm (x * y) ≤ c * B.norm x * B.norm y`. -/
lemma norm_is_bdd {ι : Type*} [fintype ι] [nonempty ι] {B : basis ι K L} {i : ι}
  (hBi : B i = (1 : L)) (hna : is_nonarchimedean (has_norm.norm : K → ℝ)) :
  ∃ (c : ℝ) (hc : 0 < c), ∀ (x y : L), B.norm (x * y) ≤ c * B.norm x * B.norm y :=
begin
  classical,
  -- The bounding constant `c` will be the maximum of the products `B.norm (B i * B j)`.
  set c := classical.some (finite.exists_max (λ (i : ι × ι), B.norm (B i.1 * B i.2))) with hc_def,
  have hc := classical.some_spec (finite.exists_max (λ (i : ι × ι), B.norm (B i.1 * B i.2))),
  use B.norm (B c.1 * B c.2),
  split,
  -- `B c.1 * B c.2` is positive
  {  have h_pos : (0 : ℝ) < B.norm (B i * B i),
    { have h1 : (1 : L) = (algebra_map K L) 1 := by rw map_one,
      rw [hBi, mul_one, h1, basis.norm_extends hBi],
      simp only [norm_one, zero_lt_one] },
    exact lt_of_lt_of_le h_pos (hc (i, i)) },
  -- ∀ (x y : L), B.norm (x * y) ≤ B.norm (⇑B c.fst * ⇑B c.snd) * B.norm x * B.norm y
  { intros x y,
    -- `ixy` is an index for which `‖B.equiv_fun (x*y) i‖` is maximum.
    set ixy := classical.some (finite.exists_max (λ i : ι, ‖B.equiv_fun (x*y) i‖)) with hixy_def,
    -- We rewrite the LHS using `ixy`.
    conv_lhs{ simp only [basis.norm],
      rw [← hixy_def, ← basis.sum_equiv_fun B x, ← basis.sum_equiv_fun B y] },
    rw [sum_mul, linear_equiv.map_finset_sum, sum_apply],
    simp_rw [smul_mul_assoc, linear_equiv.map_smul, mul_sum,
      linear_equiv.map_finset_sum, mul_smul_comm, linear_equiv.map_smul],
    /- Since the norm is nonarchimidean, the norm of a finite sum is bounded by the maximum of the
      norms of the summands. -/
    have hna' : is_nonarchimedean (normed_field.to_mul_ring_norm K) := hna,
    have hk : ∃ (k : ι) (hk : univ.nonempty → k ∈ univ),
     ‖∑ (i : ι),
       (B.equiv_fun x i • ∑ (i_1 : ι), B.equiv_fun y i_1 • B.equiv_fun (B i * B i_1)) ixy‖ ≤
     ‖ (B.equiv_fun x k • ∑ (j : ι),  B.equiv_fun y j • B.equiv_fun (B k * B j)) ixy‖ :=
    is_nonarchimedean_finset_image_add hna'
        (λ i, (B.equiv_fun x i • ∑ (i_1 : ι), B.equiv_fun y i_1 • B.equiv_fun (B i * B i_1)) ixy)
        (univ : finset ι),
    obtain ⟨k, -, hk⟩ := hk,
    apply le_trans hk,
    -- We use the above property again.
    have hk' :  ∃ (k' : ι) (hk' : univ.nonempty → k' ∈ univ),
      ‖∑ (j : ι), B.equiv_fun y j • B.equiv_fun (B k * B j) ixy‖ ≤
      ‖B.equiv_fun y k' • B.equiv_fun (B k * B k') ixy‖ :=
    is_nonarchimedean_finset_image_add hna'
      (λ i, B.equiv_fun y i • B.equiv_fun (B k * B i) ixy) (univ : finset ι),
    obtain ⟨k', -, hk'⟩ := hk',
    rw [pi.smul_apply, norm_smul, sum_apply],
    apply le_trans (mul_le_mul_of_nonneg_left hk' (norm_nonneg _)),
    -- Now an easy computation leads to the desired conclusion.
    rw [norm_smul, mul_assoc, mul_comm (B.norm (B c.fst * B c.snd)), ← mul_assoc],
    exact mul_le_mul (mul_le_mul (B.le_norm _ _) (B.le_norm _ _) (norm_nonneg _) (norm_nonneg _))
      (le_trans (B.le_norm _ _) (hc (k, k'))) (norm_nonneg _)
      (mul_nonneg (norm_nonneg _) (norm_nonneg _)) }
end

/-- For any `k : K`, `y : L`, we have
  `B.equiv_fun ((algebra_map K L k) * y) i = k * (B.equiv_fun y i) `. -/
lemma repr_smul {ι : Type*} [fintype ι] (B : basis ι K L) (i : ι) (k : K) (y : L) :
  B.equiv_fun ((algebra_map K L k) * y) i = k * (B.equiv_fun y i) :=
by rw [← smul_eq_mul, algebra_map_smul, linear_equiv.map_smul]; refl

/-- For any `k : K`, `y : L`, we have
  `B.norm ((algebra_map K L) k * y) = B.norm ((algebra_map K L) k) * B.norm y`. -/
lemma norm_smul {ι : Type*} [fintype ι] [nonempty ι] {B : basis ι K L}
  {i : ι} (hBi : B i = (1 : L)) (k : K) (y : L) :
  B.norm ((algebra_map K L) k * y) = B.norm ((algebra_map K L) k) * B.norm y :=
begin
  classical,
  by_cases hk : k = 0,
  { rw [hk, map_zero, zero_mul, B.norm_zero', zero_mul],},
  { rw norm_extends hBi,
    simp only [norm],
    set i := classical.some (finite.exists_max (λ i : ι, ‖B.equiv_fun y i‖)) with hi_def,
    have hi := classical.some_spec (finite.exists_max (λ i : ι, ‖B.equiv_fun y i‖)),
    set j := classical.some (finite.exists_max (λ i : ι, ‖B.equiv_fun ((algebra_map K L) k * y) i‖))
      with hj_def,
    have hj := classical.some_spec
      (finite.exists_max (λ i : ι, ‖B.equiv_fun ((algebra_map K L) k * y) i‖)),
    have hij : ‖B.equiv_fun y i‖ = ‖B.equiv_fun y j‖,
    { refine le_antisymm _ (hi j),
      { specialize hj i,
        rw ← hj_def at hj,
        simp only [repr_smul, norm_mul] at hj,
        exact (mul_le_mul_left (lt_of_le_of_ne (norm_nonneg _)
          (ne.symm (norm_ne_zero_iff.mpr hk)))).mp hj }},
    rw [repr_smul, norm_mul, ← hi_def, ← hj_def, hij] },
end

end basis

/-- If `K` is a nonarchimedean normed field `L/K` is a finite extension, then there exists a
power-multiplicative nonarchimedean `K`-algebra norm on `L` extending the norm on `K`. -/
lemma finite_extension_pow_mul_seminorm (hfd : finite_dimensional K L)
  (hna : is_nonarchimedean (norm : K → ℝ)) :
  ∃ (f : algebra_norm K L), is_pow_mul f ∧ function_extends (norm : K → ℝ) f ∧
    is_nonarchimedean f :=
begin
  -- Choose a basis B = {1, e2,..., en} of the K-vector space L
  classical,
  set h1 : linear_independent K (λ (x : ({1} : set L)), (x : L)) :=
  linear_independent_singleton one_ne_zero,
  set ι := {x // x ∈ (h1.extend (set.subset_univ ({1} : set L)))} with hι,
  set B : basis ι K L  := basis.extend h1 with hB,
  letI hfin : fintype ι := finite_dimensional.fintype_basis_index B,
  haveI hem : nonempty ι := B.index_nonempty,
  have h1L : (1 : L) ∈ h1.extend _ := basis.subset_extend _ (set.mem_singleton (1 : L)),
  have hB1 : B ⟨1, h1L⟩ = (1 : L),
  { rw [basis.coe_extend, subtype.coe_mk] },
  -- For every k ∈ K, k = k • 1 + 0 • e2 + ... + 0 • en
  have h_k : ∀ (k : K), B.equiv_fun ((algebra_map K L) k) = λ (i : ι),
    if (i = ⟨(1 : L), h1L⟩) then k else 0 := basis_one hB1,
  -- Define a function g : L → ℝ by setting g (∑ki • ei) = maxᵢ ‖ ki ‖
  set g : L → ℝ := B.norm with hg,
  -- g 0 = 0
  have hg0 : g 0 = 0 := B.norm_zero',
  -- g takes nonnegative values
  have hg_nonneg : ∀ (x : L), 0 ≤ g x := λ x, norm_nonneg _,
  -- g extends the norm on K
  have hg_ext : function_extends (norm : K → ℝ) g := basis.norm_extends hB1,
  -- g is nonarchimedean
  have hg_na : is_nonarchimedean g := basis.norm_is_nonarchimedean hna,
  -- g satisfies the triangle inequality
  have hg_add : ∀ (a b : L), g (a + b) ≤ g a + g b,
  { exact add_le_of_is_nonarchimedean hg_nonneg hg_na },
  -- g (-a) = g a
  have hg_neg : ∀ (a : L), g (-a) = g a := B.norm_neg,
  -- g is multiplicatively bounded
  have hg_bdd : ∃ (c : ℝ) (hc : 0 < c), ∀ (x y : L), g (x * y) ≤ c * g x * g y,
  { exact basis.norm_is_bdd hB1 hna },
  -- g is a K-module norm
  have hg_mul : ∀ (k : K) (y : L), g ((algebra_map K L) k * y) = g ((algebra_map K L) k) * g y :=
  λ k y, basis.norm_smul hB1 k y,
  -- Using BGR Prop. 1.2.1/2, we can smooth g to a ring norm f on L that extends the norm on K.
  set f := seminorm_from_bounded hg0 hg_nonneg hg_bdd hg_add hg_neg with hf,
  have hf_na : is_nonarchimedean f :=
  seminorm_from_bounded_is_nonarchimedean hg_nonneg hg_bdd hg_na,
  have hf_1 : f 1 ≤ 1 := seminorm_from_bounded_is_norm_le_one_class hg_nonneg hg_bdd,
  have hf_ext : function_extends (norm : K → ℝ) f,
  { intro k,
    rw ← hg_ext,
    exact seminorm_from_bounded_of_mul_apply hg_nonneg hg_bdd (hg_mul k) },
  -- Using BGR Prop. 1.3.2/1, we obtain from f  a power multiplicative K-algebra norm on L
  -- extending the norm on K.
  set F' := smoothing_seminorm f hf_1 hf_na with hF',
  have hF'_ext : ∀ k : K,  F' ((algebra_map K L) k) = ‖k‖,
  { intro k,
    rw ← hf_ext _,
    exact smoothing_seminorm_apply_of_is_mul f hf_1 hf_na
      (seminorm_from_bounded_of_mul_is_mul hg_nonneg hg_bdd (hg_mul k)) },
  have hF'_1 : F' 1 = 1,
  { have h1 : (1 : L) = (algebra_map K L) 1 := by rw map_one,
    simp only [h1, hF'_ext (1 : K), norm_one], },
  have hF'_0 : F' ≠ 0 := fun_like.ne_iff.mpr ⟨(1 : L), by {rw hF'_1, exact one_ne_zero}⟩,

  set F : algebra_norm K L :=
  { smul' :=  λ k y,
    begin
      simp only [ring_norm.to_fun_eq_coe],
      have hk : ∀ y : L, f ((algebra_map K L k) * y) = f (algebra_map K L k) * f y,
      { exact seminorm_from_bounded_of_mul_is_mul hg_nonneg hg_bdd (hg_mul k), },
      have hfk : ‖k‖  = (smoothing_seminorm f hf_1 hf_na)((algebra_map K L) k),
      { rw [← hf_ext k, eq_comm, smoothing_seminorm_apply_of_is_mul f hf_1 hf_na hk] },
      simp only [hfk, hF'],
      erw [← smoothing_seminorm_of_mul f hf_1 hf_na hk y, algebra.smul_def],
      refl,
    end,
    ..(ring_seminorm.to_ring_norm F' hF'_0) },

    have hF_ext : ∀ k : K,  F ((algebra_map K L) k) = ‖k‖,
    { intro k,
      rw ← hf_ext _,
      exact smoothing_seminorm_apply_of_is_mul f hf_1 hf_na
        (seminorm_from_bounded_of_mul_is_mul hg_nonneg hg_bdd (hg_mul k)) },
    have hF_1 : F 1 = 1,
    { have h1 : (1 : L) = (algebra_map K L) 1 := by rw map_one,
      simp only [h1, hF_ext (1 : K), norm_one], },
    exact ⟨F, smoothing_seminorm_is_pow_mul f hf_1, hF_ext,
      smoothing_seminorm_is_nonarchimedean f hf_1 hf_na⟩,
end


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

! This file was ported from Lean 3 source module category_theory.abelian.diagram_lemmas.four
! leanprover-community/mathlib commit d34cbcf6c94953e965448c933cd9cc485115ebbd
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.CategoryTheory.Abelian.Pseudoelements

/-!
# The four and five lemmas

Consider the following commutative diagram with exact rows in an abelian category:

```
A ---f--> B ---g--> C ---h--> D ---i--> E
|         |         |         |         |
α         β         γ         δ         ε
|         |         |         |         |
v         v         v         v         v
A' --f'-> B' --g'-> C' --h'-> D' --i'-> E'
```

We show:
- the "mono" version of the four lemma: if `α` is an epimorphism and `β` and `δ` are monomorphisms,
  then `γ` is a monomorphism,
- the "epi" version of the four lemma: if `β` and `δ` are epimorphisms and `ε` is a monomorphism,
  then `γ` is an epimorphism,
- the five lemma: if `α`, `β`, `δ` and `ε` are isomorphisms, then `γ` is an isomorphism.

## Implementation details

To show the mono version, we use pseudoelements. For the epi version, we use a completely different
arrow-theoretic proof. In theory, it should be sufficient to have one version and the other should
follow automatically by duality. In practice, mathlib's knowledge about duality isn't quite at the
point where this is doable easily.

However, one key duality statement about exactness is needed in the proof of the epi version of the
four lemma: we need to know that exactness of a pair `(f, g)`, which we defined via the map from
the image of `f` to the kernel of `g`, is the same as "co-exactness", defined via the map from the
cokernel of `f` to the coimage of `g` (more precisely, we only need the consequence that if `(f, g)`
is exact, then the factorization of `g` through the cokernel of `f` is monomorphic). Luckily, in the
case of abelian categories, we have the characterization that `(f, g)` is exact if and only if
`f ≫ g = 0` and `kernel.ι g ≫ cokernel.π f = 0`, and the latter condition is self dual, so the
equivalence of exactness and co-exactness follows easily.

## Tags

four lemma, five lemma, diagram lemma, diagram chase
-/

open CategoryTheory hiding comp_apply

open CategoryTheory.Abelian.Pseudoelement

open CategoryTheory.Limits

universe v u

variable {V : Type u} [Category.{v} V] [Abelian V]

attribute [local instance] preadditive.has_equalizers_of_has_kernels

open Pseudoelement

namespace CategoryTheory.Abelian

variable {A B C D A' B' C' D' : V}

variable {f : A ⟶ B} {g : B ⟶ C} {h : C ⟶ D}

variable {f' : A' ⟶ B'} {g' : B' ⟶ C'} {h' : C' ⟶ D'}

variable {α : A ⟶ A'} {β : B ⟶ B'} {γ : C ⟶ C'} {δ : D ⟶ D'}

variable (comm₁ : α ≫ f' = f ≫ β) (comm₂ : β ≫ g' = g ≫ γ) (comm₃ : γ ≫ h' = h ≫ δ)

include comm₁ comm₂ comm₃

section

variable (hfg : Exact f g) (hgh : Exact g h) (hf'g' : Exact f' g')

/-- The four lemma, mono version. For names of objects and morphisms, refer to the following
    diagram:

```
A ---f--> B ---g--> C ---h--> D
|         |         |         |
α         β         γ         δ
|         |         |         |
v         v         v         v
A' --f'-> B' --g'-> C' --h'-> D'
```
-/
theorem mono_of_epi_of_mono_of_mono (hα : Epi α) (hβ : Mono β) (hδ : Mono δ) : Mono γ :=
  mono_of_zero_of_map_zero _ fun c hc =>
    have : h c = 0 :=
      suffices δ (h c) = 0 from zero_of_map_zero _ (pseudo_injective_of_mono _) _ this
      calc
        δ (h c) = h' (γ c) := by rw [← comp_apply, ← comm₃, comp_apply]
        _ = h' 0 := by rw [hc]
        _ = 0 := apply_zero _

    Exists.elim ((pseudo_exact_of_exact hgh).2 _ this) fun b hb =>
      have : g' (β b) = 0 :=
        calc
          g' (β b) = γ (g b) := by rw [← comp_apply, comm₂, comp_apply]
          _ = γ c := by rw [hb]
          _ = 0 := hc

      Exists.elim ((pseudo_exact_of_exact hf'g').2 _ this) fun a' ha' =>
        Exists.elim (pseudo_surjective_of_epi α a') fun a ha =>
          have : f a = b :=
            suffices β (f a) = β b from pseudo_injective_of_mono _ this
            calc
              β (f a) = f' (α a) := by rw [← comp_apply, ← comm₁, comp_apply]
              _ = f' a' := by rw [ha]
              _ = β b := ha'

          calc
            c = g b := hb.symm
            _ = g (f a) := by rw [this]
            _ = 0 := (pseudo_exact_of_exact hfg).1 _

#align category_theory.abelian.mono_of_epi_of_mono_of_mono CategoryTheory.Abelian.mono_of_epi_of_mono_of_mono

end

section

variable (hgh : Exact g h) (hf'g' : Exact f' g') (hg'h' : Exact g' h')

/-- The four lemma, epi version. For names of objects and morphisms, refer to the following
    diagram:

```
A ---f--> B ---g--> C ---h--> D
|         |         |         |
α         β         γ         δ
|         |         |         |
v         v         v         v
A' --f'-> B' --g'-> C' --h'-> D'
```
-/
theorem epi_of_epi_of_epi_of_mono (hα : Epi α) (hγ : Epi γ) (hδ : Mono δ) : Epi β :=
  Preadditive.epi_of_cancel_zero _ fun R r hβr =>
    have hf'r : f' ≫ r = 0 :=
      Limits.zero_of_epi_comp α <|
        calc
          α ≫ f' ≫ r = f ≫ β ≫ r := by rw [reassoc_of comm₁]
          _ = f ≫ 0 := by rw [hβr]
          _ = 0 := HasZeroMorphisms.comp_zero _ _

    let y : R ⟶ pushout r g' := pushout.inl
    let z : C' ⟶ pushout r g' := pushout.inr
    have : Mono y :=
      mono_inl_of_factor_thru_epi_mono_factorization r g' (cokernel.π f')
        (cokernel.desc f' g' hf'g'.w) (by simp) (cokernel.desc f' r hf'r) (by simp) _
        (colimit.isColimit _)
    have hz : g ≫ γ ≫ z = 0 :=
      calc
        g ≫ γ ≫ z = β ≫ g' ≫ z := by rw [← reassoc_of comm₂]
        _ = β ≫ r ≫ y := by rw [← pushout.condition]
        _ = 0 ≫ y := by rw [reassoc_of hβr]
        _ = 0 := HasZeroMorphisms.zero_comp _ _

    let v : pushout r g' ⟶ pushout (γ ≫ z) (h ≫ δ) := pushout.inl
    let w : D' ⟶ pushout (γ ≫ z) (h ≫ δ) := pushout.inr
    have : Mono v :=
      mono_inl_of_factor_thru_epi_mono_factorization _ _ (cokernel.π g)
        (cokernel.desc g h hgh.w ≫ δ) (by simp) (cokernel.desc _ _ hz) (by simp) _
        (colimit.isColimit _)
    have hzv : z ≫ v = h' ≫ w :=
      (cancel_epi γ).1 <|
        calc
          γ ≫ z ≫ v = h ≫ δ ≫ w := by rw [← category.assoc, pushout.condition, category.assoc]
          _ = γ ≫ h' ≫ w := by rw [reassoc_of comm₃]

    suffices (r ≫ y) ≫ v = 0 from zero_of_comp_mono _ (zero_of_comp_mono _ this)
    calc
      (r ≫ y) ≫ v = g' ≫ z ≫ v := by rw [pushout.condition, category.assoc]
      _ = g' ≫ h' ≫ w := by rw [hzv]
      _ = 0 ≫ w := (hg'h'.w_assoc _)
      _ = 0 := HasZeroMorphisms.zero_comp _ _

#align category_theory.abelian.epi_of_epi_of_epi_of_mono CategoryTheory.Abelian.epi_of_epi_of_epi_of_mono

end

section Five

variable {E E' : V} {i : D ⟶ E} {i' : D' ⟶ E'} {ε : E ⟶ E'} (comm₄ : δ ≫ i' = i ≫ ε)

variable (hfg : Exact f g) (hgh : Exact g h) (hhi : Exact h i)

variable (hf'g' : Exact f' g') (hg'h' : Exact g' h') (hh'i' : Exact h' i')

variable [IsIso α] [IsIso β] [IsIso δ] [IsIso ε]

include comm₄ hfg hgh hhi hf'g' hg'h' hh'i'

/-- The five lemma. For names of objects and morphisms, refer to the following diagram:

```
A ---f--> B ---g--> C ---h--> D ---i--> E
|         |         |         |         |
α         β         γ         δ         ε
|         |         |         |         |
v         v         v         v         v
A' --f'-> B' --g'-> C' --h'-> D' --i'-> E'
```
-/
theorem isIso_of_isIso_of_isIso_of_isIso_of_isIso : IsIso γ :=
  have : Mono γ := by
    apply mono_of_epi_of_mono_of_mono comm₁ comm₂ comm₃ hfg hgh hf'g' <;> infer_instance
  have : Epi γ := by
    apply epi_of_epi_of_epi_of_mono comm₂ comm₃ comm₄ hhi hg'h' hh'i' <;> infer_instance
  is_iso_of_mono_of_epi _
#align category_theory.abelian.is_iso_of_is_iso_of_is_iso_of_is_iso_of_is_iso CategoryTheory.Abelian.isIso_of_isIso_of_isIso_of_isIso_of_isIso

end Five

end CategoryTheory.Abelian


import .tactics .ScholzeHelpLemmas

open real set

variables {α : Type} {f : ℝ → ℝ} {s : set ℝ}

/-! # Finished-/

-- Jason's thing
lemma mono_helper (f : ℝ → ℝ) (hf : strict_mono f) : ∀ x ∈ set.Ioc (0 : ℝ) 1,
  f x ≤ f 1 :=
begin
  rintro _ ⟨_, hx⟩,
  rcases lt_or_eq_of_le hx with h | rfl,
  { exact (le_trans $ le_of_lt $ hf h) le_rfl },
  { exact le_rfl },
end

lemma continuous_on.id_log (hf : continuous_on f s) (h₀ : ∀ x ∈ s, f x ≠ 0) :
  continuous_on (λ x, x * log (f x)) s :=
--λ x hx, (hf x hx).log (h₀ x hx)
begin
  intros x hx,
  apply continuous_within_at.mul,
  { apply continuous_within_at_id},
  { apply continuous_within_at.log,
    { exact hf x hx,},
    { exact h₀ x hx},
  },
end

-- Right so I now need to prove that it's differentiable
lemma diff_helper (s : ℝ) (s_pos : 0 < s) : deriv (λ x, (x + 1) * log(x + 1) - x*log x) s = log(s+1) - log(s) :=
begin
  simp {discharger:= `[diff]},
  rw deriv.comp,
  simp only [add_zero, differentiable_at_const, mul_one, one_mul, differentiable_at_id', deriv_id'', deriv_log', deriv_const',
  deriv_add],
  rw [mul_inv_cancel, mul_inv_cancel];
  linarith,
  all_goals{diff},
end

/-! # Unfinished -/

lemma x_log_x_cont : continuous_on (λ x, (x + 1) * log (x + 1) - x * log x) (Icc 0 1) :=
begin
  apply continuous_on.add,
  { apply continuous_on.mul,
    { apply continuous_on.add,
      { apply continuous_on_id},
      { apply continuous_on_const},
    },
    { apply continuous_on.log,
      { apply continuous_on.add,
        { apply continuous_on_id},
        { apply continuous_on_const},
      },
      { intros x x_in,
        rw [← Icc_def, mem_set_of_eq] at x_in,
        linarith,},
    },
  },
  { -- prove the xlog x is continuous.
    apply continuous_on.neg,
    apply continuous_on.id_log,
    { apply continuous_on_id,},
    { -- needs me to prove that ∀ x ∈ Icc 0 1, x ≠ 0
      sorry},
  }
end


/-
Copyright (c) 2021 Eric Wieser. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser
-/
import group_theory.perm.sign
import data.equiv.option

/-!
# Permutations of `option α`
-/
open equiv

lemma equiv_functor.map_equiv_option_injective {α β : Type*} :
  function.injective (equiv_functor.map_equiv option : α ≃ β → option α ≃ option β) :=
equiv_functor.map_equiv.injective option option.some_injective

@[simp] lemma equiv_functor.option.map_none {α β : Type*} (e : α ≃ β) :
  equiv_functor.map e none = none :=
by simp [equiv_functor.map]

@[simp] lemma map_equiv_option_one {α : Type*} : equiv_functor.map_equiv option (1 : perm α) = 1 :=
by {ext, simp [equiv_functor.map_equiv, equiv_functor.map] }

@[simp] lemma map_equiv_option_refl {α : Type*} :
  equiv_functor.map_equiv option (equiv.refl α) = 1 := map_equiv_option_one

@[simp] lemma map_equiv_option_swap {α : Type*} [decidable_eq α] (x y : α) :
  equiv_functor.map_equiv option (swap x y) = swap (some x) (some y) :=
begin
  ext (_ | i),
  { simp [swap_apply_of_ne_of_ne] },
  { by_cases hx : i = x,
    simp [hx, swap_apply_of_ne_of_ne, equiv_functor.map],
    by_cases hy : i = y;
    simp [hx, hy, swap_apply_of_ne_of_ne, equiv_functor.map], }
end

@[simp] lemma equiv_functor.option.sign {α : Type*} [decidable_eq α] [fintype α] (e : perm α) :
  perm.sign (equiv_functor.map_equiv option e) = perm.sign e :=
begin
  apply perm.swap_induction_on e,
  { simp [perm.one_def] },
  { intros f x y hne h,
    simp [h, hne, perm.mul_def, ←equiv_functor.map_equiv_trans] }
end

@[simp] lemma map_equiv_remove_none {α : Type*} [decidable_eq α] (σ : perm (option α)) :
  equiv_functor.map_equiv option (remove_none σ) = swap none (σ none) * σ :=
begin
  ext1 x,
  have : option.map ⇑(remove_none σ) x = (swap none (σ none)) (σ x),
  { cases x,
    { simp },
    { cases h : σ (some x),
      { simp [remove_none_none _ h], },
      { have hn : σ (some x) ≠ none := by simp [h],
        have hσn : σ (some x) ≠ σ none := σ.injective.ne (by simp),
        simp [remove_none_some _ ⟨_, h⟩, ←h, swap_apply_of_ne_of_ne hn hσn] } } },
  simpa using this,
end

/-- Permutations of `option α` are equivalent to fixing an
`option α` and permuting the remaining with a `perm α`.
The fixed `option α` is swapped with `none`. -/
@[simps] def equiv.perm.decompose_option {α : Type*} [decidable_eq α] :
  perm (option α) ≃ option α × perm α :=
{ to_fun := λ σ, (σ none, remove_none σ),
  inv_fun := λ i, swap none i.1 * (equiv_functor.map_equiv option i.2),
  left_inv := λ σ, by simp,
  right_inv := λ ⟨x, σ⟩, begin
    have : remove_none (swap none x * equiv_functor.map_equiv option σ) = σ :=
      equiv_functor.map_equiv_option_injective (by simp [←mul_assoc, equiv_functor.map]),
    simp [←perm.eq_inv_iff_eq, equiv_functor.map, this],
  end }

lemma equiv.perm.decompose_option_symm_of_none_apply {α : Type*} [decidable_eq α]
  (e : perm α) (i : option α) :
  equiv.perm.decompose_option.symm (none, e) i = i.map e :=
by simp [equiv_functor.map]

lemma equiv.perm.decompose_option_symm_sign {α : Type*} [decidable_eq α] [fintype α] (e : perm α) :
  perm.sign (equiv.perm.decompose_option.symm (none, e)) = perm.sign e :=
by simp

/-- The set of all permutations of `option α` can be constructed by augmenting the set of
permutations of `α` by each element of `option α` in turn. -/
lemma finset.univ_perm_option {α : Type*} [decidable_eq α] [fintype α] :
  @finset.univ (perm $ option α) _ =
    (finset.univ : finset $ option α × perm α).map equiv.perm.decompose_option.symm.to_embedding :=
(finset.univ_map_equiv_to_embedding _).symm


lemma iff_trans (P Q R : Prop) : (P ↔ Q) → (Q ↔ R) → (P ↔ R) :=
begin
intro hpq,
intro hqr,
cases hpq with hpq hqp,
cases hqr with hqr hrq,
split,
cc,
cc,
end