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

! This file was ported from Lean 3 source module topology.homotopy.basic
! leanprover-community/mathlib commit 11c53f174270aa43140c0b26dabce5fc4a253e80
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Topology.Algebra.Order.ProjIcc
import Mathlib.Topology.ContinuousFunction.Ordered
import Mathlib.Topology.CompactOpen
import Mathlib.Topology.UnitInterval

/-!
# Homotopy between functions

In this file, we define a homotopy between two functions `f₀` and `f₁`. First we define
`ContinuousMap.Homotopy` between the two functions, with no restrictions on the intermediate
maps. Then, as in the formalisation in HOL-Analysis, we define
`ContinuousMap.HomotopyWith f₀ f₁ P`, for homotopies between `f₀` and `f₁`, where the
intermediate maps satisfy the predicate `P`. Finally, we define
`ContinuousMap.HomotopyRel f₀ f₁ S`, for homotopies between `f₀` and `f₁` which are fixed
on `S`.

## Definitions

* `ContinuousMap.Homotopy f₀ f₁` is the type of homotopies between `f₀` and `f₁`.
* `ContinuousMap.HomotopyWith f₀ f₁ P` is the type of homotopies between `f₀` and `f₁`, where
  the intermediate maps satisfy the predicate `P`.
* `ContinuousMap.HomotopyEel f₀ f₁ S` is the type of homotopies between `f₀` and `f₁` which
  are fixed on `S`.

For each of the above, we have

* `refl f`, which is the constant homotopy from `f` to `f`.
* `symm F`, which reverses the homotopy `F`. For example, if `F : ContinuousMap.Homotopy f₀ f₁`,
  then `F.symm : ContinuousMap.Homotopy f₁ f₀`.
* `trans F G`, which concatenates the homotopies `F` and `G`. For example, if
  `F : ContinuousMap.Homotopy f₀ f₁` and `G : ContinuousMap.Homotopy f₁ f₂`, then
  `F.trans G : ContinuousMap.Homotopy f₀ f₂`.

We also define the relations

* `ContinuousMap.Homotopic f₀ f₁` is defined to be `Nonempty (ContinuousMap.Homotopy f₀ f₁)`
* `ContinuousMap.HomotopicWith f₀ f₁ P` is defined to be
  `Nonempty (ContinuousMap.HomotopyWith f₀ f₁ P)`
* `ContinuousMap.HomotopicRel f₀ f₁ P` is defined to be
  `Nonempty (ContinuousMap.HomotopyRel f₀ f₁ P)`

and for `ContinuousMap.homotopic` and `ContinuousMap.homotopic_rel`, we also define the
`setoid` and `quotient` in `C(X, Y)` by these relations.

## References

- [HOL-Analysis formalisation](https://isabelle.in.tum.de/library/HOL/HOL-Analysis/Homotopy.html)
-/

noncomputable section

universe u v w

variable {F : Type _} {X : Type u} {Y : Type v} {Z : Type w}

variable [TopologicalSpace X] [TopologicalSpace Y] [TopologicalSpace Z]

open unitInterval

namespace ContinuousMap

/-- `ContinuousMap.Homotopy f₀ f₁` is the type of homotopies from `f₀` to `f₁`.

When possible, instead of parametrizing results over `(f : Homotopy f₀ f₁)`,
you should parametrize over `{F : Type*} [HomotopyLike F f₀ f₁] (f : F)`.

When you extend this structure, make sure to extend `ContinuousMap.HomotopyLike`. -/
structure Homotopy (f₀ f₁ : C(X, Y)) extends C(I × X, Y) where
  /-- value of the homotopy at 0 -/
  map_zero_left : ∀ x, toFun (0, x) = f₀ x
  /-- value of the homotopy at 1 -/
  map_one_left : ∀ x, toFun (1, x) = f₁ x
#align continuous_map.homotopy ContinuousMap.Homotopy

section

/-- `ContinuousMap.HomotopyLike F f₀ f₁` states that `F` is a type of homotopies between `f₀` and
`f₁`.

You should extend this class when you extend `ContinuousMap.Homotopy`. -/
class HomotopyLike {X Y : outParam (Type _)} [TopologicalSpace X] [TopologicalSpace Y]
    (F : Type _) (f₀ f₁ : outParam <| C(X, Y)) extends ContinuousMapClass F (I × X) Y where
  /-- value of the homotopy at 0 -/
  map_zero_left (f : F) : ∀ x, f (0, x) = f₀ x
  /-- value of the homotopy at 1 -/
  map_one_left (f : F) : ∀ x, f (1, x) = f₁ x
#align continuous_map.homotopy_like ContinuousMap.HomotopyLike

end

namespace Homotopy

section

variable {f₀ f₁ : C(X, Y)}

instance : HomotopyLike (Homotopy f₀ f₁) f₀ f₁
    where
  coe f := f.toFun
  coe_injective' f g h := by
    obtain ⟨⟨_, _⟩, _⟩ := f
    obtain ⟨⟨_, _⟩, _⟩ := g
    congr
  map_continuous f := f.continuous_toFun
  map_zero_left f := f.map_zero_left
  map_one_left f := f.map_one_left

/- porting note: probably not needed anymore
/-- Helper instance for when there's too many metavariables to apply `FunLike.hasCoeToFun`
directly. -/
instance : CoeFun (Homotopy f₀ f₁) fun _ => I × X → Y :=
  FunLike.hasCoeToFun -/

@[ext]
theorem ext {F G : Homotopy f₀ f₁} (h : ∀ x, F x = G x) : F = G :=
  FunLike.ext _ _ h
#align continuous_map.homotopy.ext ContinuousMap.Homotopy.ext

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
because it is a composition of multiple projections. -/
def Simps.apply (F : Homotopy f₀ f₁) : I × X → Y :=
  F
#align continuous_map.homotopy.simps.apply ContinuousMap.Homotopy.Simps.apply

initialize_simps_projections Homotopy (toContinuousMap_toFun → apply, -toContinuousMap)

/-- Deprecated. Use `map_continuous` instead. -/
protected theorem continuous (F : Homotopy f₀ f₁) : Continuous F :=
  F.continuous_toFun
#align continuous_map.homotopy.continuous ContinuousMap.Homotopy.continuous

@[simp]
theorem apply_zero (F : Homotopy f₀ f₁) (x : X) : F (0, x) = f₀ x :=
  F.map_zero_left x
#align continuous_map.homotopy.apply_zero ContinuousMap.Homotopy.apply_zero

@[simp]
theorem apply_one (F : Homotopy f₀ f₁) (x : X) : F (1, x) = f₁ x :=
  F.map_one_left x
#align continuous_map.homotopy.apply_one ContinuousMap.Homotopy.apply_one

@[simp]
theorem coe_toContinuousMap (F : Homotopy f₀ f₁) : ⇑F.toContinuousMap = F :=
  rfl
#align continuous_map.homotopy.coe_to_continuous_map ContinuousMap.Homotopy.coe_toContinuousMap

/-- Currying a homotopy to a continuous function fron `I` to `C(X, Y)`.
-/
def curry (F : Homotopy f₀ f₁) : C(I, C(X, Y)) :=
  F.toContinuousMap.curry
#align continuous_map.homotopy.curry ContinuousMap.Homotopy.curry

@[simp]
theorem curry_apply (F : Homotopy f₀ f₁) (t : I) (x : X) : F.curry t x = F (t, x) :=
  rfl
#align continuous_map.homotopy.curry_apply ContinuousMap.Homotopy.curry_apply

/-- Continuously extending a curried homotopy to a function from `ℝ` to `C(X, Y)`.
-/
def extend (F : Homotopy f₀ f₁) : C(ℝ, C(X, Y)) :=
  F.curry.IccExtend zero_le_one
#align continuous_map.homotopy.extend ContinuousMap.Homotopy.extend

theorem extend_apply_of_le_zero (F : Homotopy f₀ f₁) {t : ℝ} (ht : t ≤ 0) (x : X) :
    F.extend t x = f₀ x := by
  rw [← F.apply_zero]
  exact ContinuousMap.congr_fun (Set.IccExtend_of_le_left (zero_le_one' ℝ) F.curry ht) x
#align continuous_map.homotopy.extend_apply_of_le_zero ContinuousMap.Homotopy.extend_apply_of_le_zero

theorem extend_apply_of_one_le (F : Homotopy f₀ f₁) {t : ℝ} (ht : 1 ≤ t) (x : X) :
    F.extend t x = f₁ x := by
  rw [← F.apply_one]
  exact ContinuousMap.congr_fun (Set.IccExtend_of_right_le (zero_le_one' ℝ) F.curry ht) x
#align continuous_map.homotopy.extend_apply_of_one_le ContinuousMap.Homotopy.extend_apply_of_one_le

@[simp]
theorem extend_apply_coe (F : Homotopy f₀ f₁) (t : I) (x : X) : F.extend t x = F (t, x) :=
  ContinuousMap.congr_fun (Set.Icc_extend_coe (zero_le_one' ℝ) F.curry t) x
#align continuous_map.homotopy.extend_apply_coe ContinuousMap.Homotopy.extend_apply_coe

@[simp]
theorem extend_apply_of_mem_I (F : Homotopy f₀ f₁) {t : ℝ} (ht : t ∈ I) (x : X) :
    F.extend t x = F (⟨t, ht⟩, x) :=
  ContinuousMap.congr_fun (Set.IccExtend_of_mem (zero_le_one' ℝ) F.curry ht) x
set_option linter.uppercaseLean3 false in
#align continuous_map.homotopy.extend_apply_of_mem_I ContinuousMap.Homotopy.extend_apply_of_mem_I

theorem congr_fun {F G : Homotopy f₀ f₁} (h : F = G) (x : I × X) : F x = G x :=
  ContinuousMap.congr_fun (congr_arg _ h) x
#align continuous_map.homotopy.congr_fun ContinuousMap.Homotopy.congr_fun

theorem congr_arg (F : Homotopy f₀ f₁) {x y : I × X} (h : x = y) : F x = F y :=
  F.toContinuousMap.congr_arg h
#align continuous_map.homotopy.congr_arg ContinuousMap.Homotopy.congr_arg

end

/-- Given a continuous function `f`, we can define a `Homotopy f f` by `F (t, x) = f x`
-/
@[simps]
def refl (f : C(X, Y)) : Homotopy f f where
  toFun x := f x.2
  map_zero_left _ := rfl
  map_one_left _ := rfl
#align continuous_map.homotopy.refl ContinuousMap.Homotopy.refl

instance : Inhabited (Homotopy (ContinuousMap.id X) (ContinuousMap.id X)) :=
  ⟨Homotopy.refl _⟩

/-- Given a `Homotopy f₀ f₁`, we can define a `Homotopy f₁ f₀` by reversing the homotopy.
-/
@[simps]
def symm {f₀ f₁ : C(X, Y)} (F : Homotopy f₀ f₁) : Homotopy f₁ f₀
    where
  toFun x := F (σ x.1, x.2)
  map_zero_left := by norm_num
  map_one_left := by norm_num
#align continuous_map.homotopy.symm ContinuousMap.Homotopy.symm

@[simp]
theorem symm_symm {f₀ f₁ : C(X, Y)} (F : Homotopy f₀ f₁) : F.symm.symm = F := by
  ext
  simp
#align continuous_map.homotopy.symm_symm ContinuousMap.Homotopy.symm_symm

/--
Given `Homotopy f₀ f₁` and `Homotopy f₁ f₂`, we can define a `Homotopy f₀ f₂` by putting the first
homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans {f₀ f₁ f₂ : C(X, Y)} (F : Homotopy f₀ f₁) (G : Homotopy f₁ f₂) : Homotopy f₀ f₂
    where
  toFun x := if (x.1 : ℝ) ≤ 1 / 2 then F.extend (2 * x.1) x.2 else G.extend (2 * x.1 - 1) x.2
  continuous_toFun :=
    by
    refine'
      continuous_if_le (continuous_induced_dom.comp continuous_fst) continuous_const
        (F.continuous.comp (by continuity)).continuousOn
        (G.continuous.comp (by continuity)).continuousOn _
    rintro x hx
    rw [hx]
    norm_num
  map_zero_left x := by norm_num
  map_one_left x := by norm_num
#align continuous_map.homotopy.trans ContinuousMap.Homotopy.trans

theorem trans_apply {f₀ f₁ f₂ : C(X, Y)} (F : Homotopy f₀ f₁) (G : Homotopy f₁ f₂) (x : I × X) :
    (F.trans G) x =
      if h : (x.1 : ℝ) ≤ 1 / 2 then
        F (⟨2 * x.1, (unitInterval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
      else
        G (⟨2 * x.1 - 1, unitInterval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
  show ite _ _ _ = _ by
    split_ifs <;>
      · rw [extend, ContinuousMap.coe_IccExtend, Set.IccExtend_of_mem]
        rfl
#align continuous_map.homotopy.trans_apply ContinuousMap.Homotopy.trans_apply

theorem symm_trans {f₀ f₁ f₂ : C(X, Y)} (F : Homotopy f₀ f₁) (G : Homotopy f₁ f₂) :
    (F.trans G).symm = G.symm.trans F.symm := by
  ext ⟨t, _⟩
  rw [trans_apply, symm_apply, trans_apply]
  simp only [coe_symm_eq, symm_apply]
  split_ifs with h₁ h₂ h₂
  . have ht : (t : ℝ) = 1 / 2 :=
      -- porting note: this was proved by linarith in mathlib
      le_antisymm h₂ (by convert sub_le_comm.mp h₁ using 1; norm_num)
    simp only [ht]
    norm_num
  . congr 2
    apply Subtype.ext
    simp only [coe_symm_eq]
    linarith
  . congr 2
    apply Subtype.ext
    simp only [coe_symm_eq]
    linarith
  . exfalso
    -- porting note: this was proved by linarith in mathlib
    apply h₂
    rw [sub_le_comm, not_le] at h₁
    convert le_of_lt h₁ using 1
    norm_num
#align continuous_map.homotopy.symm_trans ContinuousMap.Homotopy.symm_trans

/-- Casting a `Homotopy f₀ f₁` to a `Homotopy g₀ g₁` where `f₀ = g₀` and `f₁ = g₁`.
-/
@[simps]
def cast {f₀ f₁ g₀ g₁ : C(X, Y)} (F : Homotopy f₀ f₁) (h₀ : f₀ = g₀) (h₁ : f₁ = g₁) : Homotopy g₀ g₁
    where
  toFun := F
  map_zero_left := by simp [← h₀]
  map_one_left := by simp [← h₁]
#align continuous_map.homotopy.cast ContinuousMap.Homotopy.cast

/-- If we have a `Homotopy f₀ f₁` and a `Homotopy g₀ g₁`, then we can compose them and get a
`Homotopy (g₀.comp f₀) (g₁.comp f₁)`.
-/
@[simps]
def hcomp {f₀ f₁ : C(X, Y)} {g₀ g₁ : C(Y, Z)} (F : Homotopy f₀ f₁) (G : Homotopy g₀ g₁) :
    Homotopy (g₀.comp f₀) (g₁.comp f₁)
    where
  toFun x := G (x.1, F x)
  map_zero_left := by simp
  map_one_left := by simp
#align continuous_map.homotopy.hcomp ContinuousMap.Homotopy.hcomp

end Homotopy

/-- Given continuous maps `f₀` and `f₁`, we say `f₀` and `f₁` are homotopic if there exists a
`Homotopy f₀ f₁`.
-/
def Homotopic (f₀ f₁ : C(X, Y)) : Prop :=
  Nonempty (Homotopy f₀ f₁)
#align continuous_map.homotopic ContinuousMap.Homotopic

namespace Homotopic

@[refl]
theorem refl (f : C(X, Y)) : Homotopic f f :=
  ⟨Homotopy.refl f⟩
#align continuous_map.homotopic.refl ContinuousMap.Homotopic.refl

@[symm]
theorem symm ⦃f g : C(X, Y)⦄ (h : Homotopic f g) : Homotopic g f :=
  h.map Homotopy.symm
#align continuous_map.homotopic.symm ContinuousMap.Homotopic.symm

@[trans]
theorem trans ⦃f g h : C(X, Y)⦄ (h₀ : Homotopic f g) (h₁ : Homotopic g h) : Homotopic f h :=
  h₀.map2 Homotopy.trans h₁
#align continuous_map.homotopic.trans ContinuousMap.Homotopic.trans

theorem hcomp {f₀ f₁ : C(X, Y)} {g₀ g₁ : C(Y, Z)} (h₀ : Homotopic f₀ f₁) (h₁ : Homotopic g₀ g₁) :
    Homotopic (g₀.comp f₀) (g₁.comp f₁) :=
  h₀.map2 Homotopy.hcomp h₁
#align continuous_map.homotopic.hcomp ContinuousMap.Homotopic.hcomp

theorem equivalence : Equivalence (@Homotopic X Y _ _) :=
  ⟨refl, by apply symm, by apply trans⟩
#align continuous_map.homotopic.equivalence ContinuousMap.Homotopic.equivalence

end Homotopic

/--
The type of homotopies between `f₀ f₁ : C(X, Y)`, where the intermediate maps satisfy the predicate
`P : C(X, Y) → Prop`
-/
structure HomotopyWith (f₀ f₁ : C(X, Y)) (P : C(X, Y) → Prop) extends Homotopy f₀ f₁ where
  -- porting note: todo: use `toHomotopy.curry t`
  /-- the intermediate maps of the homotopy satisfy the property -/
  prop' : ∀ t, P ⟨fun x => toFun (t, x),
    Continuous.comp continuous_toFun (continuous_const.prod_mk continuous_id')⟩
#align continuous_map.homotopy_with ContinuousMap.HomotopyWith

namespace HomotopyWith

section

variable {f₀ f₁ : C(X, Y)} {P : C(X, Y) → Prop}

instance : CoeFun (HomotopyWith f₀ f₁ P) fun _ => I × X → Y :=
  ⟨fun F => F.toFun⟩

/- porting note: this lemma seems unnecessary
@[simp]
theorem coe_toFun (F : HomotopyWith f₀ f₁ P) : ⇑F = F.toFun := by rfl-/

theorem coeFn_injective : @Function.Injective (HomotopyWith f₀ f₁ P) (I × X → Y) (⇑) := by
  rintro ⟨⟨⟨F, _⟩, _⟩, _⟩ ⟨⟨⟨G, _⟩, _⟩, _⟩ h
  congr 3
#align continuous_map.homotopy_with.coe_fn_injective ContinuousMap.HomotopyWith.coeFn_injective

@[ext]
theorem ext {F G : HomotopyWith f₀ f₁ P} (h : ∀ x, F x = G x) : F = G := by
  apply coeFn_injective
  funext
  apply h
#align continuous_map.homotopy_with.ext ContinuousMap.HomotopyWith.ext

/-- See Note [custom simps projection]. We need to specify this projection explicitly in this case,
because it is a composition of multiple projections. -/
def Simps.apply (F : HomotopyWith f₀ f₁ P) : I × X → Y :=
  F
#align continuous_map.homotopy_with.simps.apply ContinuousMap.HomotopyWith.Simps.apply

initialize_simps_projections HomotopyWith (toHomotopy_toContinuousMap_toFun → apply,
  -toHomotopy_toContinuousMap)

@[continuity]
protected theorem continuous (F : HomotopyWith f₀ f₁ P) : Continuous F :=
  F.continuous_toFun
#align continuous_map.homotopy_with.continuous ContinuousMap.HomotopyWith.continuous

@[simp]
theorem apply_zero (F : HomotopyWith f₀ f₁ P) (x : X) : F (0, x) = f₀ x :=
  F.map_zero_left x
#align continuous_map.homotopy_with.apply_zero ContinuousMap.HomotopyWith.apply_zero

@[simp]
theorem apply_one (F : HomotopyWith f₀ f₁ P) (x : X) : F (1, x) = f₁ x :=
  F.map_one_left x
#align continuous_map.homotopy_with.apply_one ContinuousMap.HomotopyWith.apply_one

@[simp]
theorem coe_toContinuousMap (F : HomotopyWith f₀ f₁ P) : ⇑F.toContinuousMap = F :=
  rfl
#align continuous_map.homotopy_with.coe_to_continuous_map ContinuousMap.HomotopyWith.coe_toContinuousMap

-- porting note: removed @[simp] as it makes the linter timeout
theorem coe_toHomotopy (F : HomotopyWith f₀ f₁ P) : ⇑F.toHomotopy = F :=
  rfl
#align continuous_map.homotopy_with.coe_to_homotopy ContinuousMap.HomotopyWith.coe_toHomotopy

theorem prop (F : HomotopyWith f₀ f₁ P) (t : I) : P (F.toHomotopy.curry t) := F.prop' t
#align continuous_map.homotopy_with.prop ContinuousMap.HomotopyWith.prop

end

variable {P : C(X, Y) → Prop}

/-- Given a continuous function `f`, and a proof `h : P f`, we can define a `HomotopyWith f f P` by
`F (t, x) = f x`
-/
@[simps!]
def refl (f : C(X, Y)) (hf : P f) : HomotopyWith f f P :=
  { Homotopy.refl f with
    prop' := fun _ => hf }
#align continuous_map.homotopy_with.refl ContinuousMap.HomotopyWith.refl

instance : Inhabited (HomotopyWith (ContinuousMap.id X) (ContinuousMap.id X) fun _ => True) :=
  ⟨HomotopyWith.refl _ trivial⟩

/--
Given a `HomotopyWith f₀ f₁ P`, we can define a `HomotopyWith f₁ f₀ P` by reversing the homotopy.
-/
--@[simps]
def symm {f₀ f₁ : C(X, Y)} (F : HomotopyWith f₀ f₁ P) : HomotopyWith f₁ f₀ P :=
  { F.toHomotopy.symm with
      prop' := fun t => F.prop (σ t) }
#align continuous_map.homotopy_with.symm ContinuousMap.HomotopyWith.symm

@[simp]
theorem symm_symm {f₀ f₁ : C(X, Y)} (F : HomotopyWith f₀ f₁ P) : F.symm.symm = F :=
  ext <| Homotopy.congr_fun <| Homotopy.symm_symm _
#align continuous_map.homotopy_with.symm_symm ContinuousMap.HomotopyWith.symm_symm

/--
Given `HomotopyWith f₀ f₁ P` and `HomotopyWith f₁ f₂ P`, we can define a `HomotopyWith f₀ f₂ P`
by putting the first homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans {f₀ f₁ f₂ : C(X, Y)} (F : HomotopyWith f₀ f₁ P) (G : HomotopyWith f₁ f₂ P) :
    HomotopyWith f₀ f₂ P :=
  { F.toHomotopy.trans G.toHomotopy with
    prop' := fun t => by
      simp only [Homotopy.trans]
      change P ⟨fun _ => ite ((t : ℝ) ≤ _) _ _, _⟩
      split_ifs
      · exact F.extendProp _
      · exact G.extendProp _ }
#align continuous_map.homotopy_with.trans ContinuousMap.HomotopyWith.trans

theorem trans_apply {f₀ f₁ f₂ : C(X, Y)} (F : HomotopyWith f₀ f₁ P) (G : HomotopyWith f₁ f₂ P)
    (x : I × X) :
    (F.trans G) x =
      if h : (x.1 : ℝ) ≤ 1 / 2 then
        F (⟨2 * x.1, (unitInterval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
      else
        G (⟨2 * x.1 - 1, unitInterval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
  Homotopy.trans_apply _ _ _
#align continuous_map.homotopy_with.trans_apply ContinuousMap.HomotopyWith.trans_apply

theorem symm_trans {f₀ f₁ f₂ : C(X, Y)} (F : HomotopyWith f₀ f₁ P) (G : HomotopyWith f₁ f₂ P) :
    (F.trans G).symm = G.symm.trans F.symm :=
  ext <| Homotopy.congr_fun <| Homotopy.symm_trans _ _
#align continuous_map.homotopy_with.symm_trans ContinuousMap.HomotopyWith.symm_trans

/-- Casting a `HomotopyWith f₀ f₁ P` to a `HomotopyWith g₀ g₁ P` where `f₀ = g₀` and `f₁ = g₁`.
-/
@[simp]
def cast {f₀ f₁ g₀ g₁ : C(X, Y)} (F : HomotopyWith f₀ f₁ P) (h₀ : f₀ = g₀) (h₁ : f₁ = g₁) :
    HomotopyWith g₀ g₁ P :=
  { F.toHomotopy.cast h₀ h₁ with prop' := F.prop }
#align continuous_map.homotopy_with.cast ContinuousMap.HomotopyWith.cast

end HomotopyWith

/-- Given continuous maps `f₀` and `f₁`, we say `f₀` and `f₁` are homotopic with respect to the
predicate `P` if there exists a `HomotopyWith f₀ f₁ P`.
-/
def HomotopicWith (f₀ f₁ : C(X, Y)) (P : C(X, Y) → Prop) : Prop :=
  Nonempty (HomotopyWith f₀ f₁ P)
#align continuous_map.homotopic_with ContinuousMap.HomotopicWith

namespace HomotopicWith

variable {P : C(X, Y) → Prop}

-- porting note: removed @[refl]
theorem refl (f : C(X, Y)) (hf : P f) : HomotopicWith f f P :=
  ⟨HomotopyWith.refl f hf⟩
#align continuous_map.homotopic_with.refl ContinuousMap.HomotopicWith.refl

@[symm]
theorem symm ⦃f g : C(X, Y)⦄ (h : HomotopicWith f g P) : HomotopicWith g f P :=
  ⟨h.some.symm⟩
#align continuous_map.homotopic_with.symm ContinuousMap.HomotopicWith.symm

@[trans]
theorem trans ⦃f g h : C(X, Y)⦄ (h₀ : HomotopicWith f g P) (h₁ : HomotopicWith g h P) :
    HomotopicWith f h P :=
  ⟨h₀.some.trans h₁.some⟩
#align continuous_map.homotopic_with.trans ContinuousMap.HomotopicWith.trans

end HomotopicWith

/--
A `HomotopyRel f₀ f₁ S` is a homotopy between `f₀` and `f₁` which is fixed on the points in `S`.
-/
abbrev HomotopyRel (f₀ f₁ : C(X, Y)) (S : Set X) :=
  HomotopyWith f₀ f₁ fun f => ∀ x ∈ S, f x = f₀ x ∧ f x = f₁ x
#align continuous_map.homotopy_rel ContinuousMap.HomotopyRel

namespace HomotopyRel

section

variable {f₀ f₁ : C(X, Y)} {S : Set X}

theorem eq_fst (F : HomotopyRel f₀ f₁ S) (t : I) {x : X} (hx : x ∈ S) : F (t, x) = f₀ x :=
  (F.prop t x hx).1
#align continuous_map.homotopy_rel.eq_fst ContinuousMap.HomotopyRel.eq_fst

theorem eq_snd (F : HomotopyRel f₀ f₁ S) (t : I) {x : X} (hx : x ∈ S) : F (t, x) = f₁ x :=
  (F.prop t x hx).2
#align continuous_map.homotopy_rel.eq_snd ContinuousMap.HomotopyRel.eq_snd

theorem fst_eq_snd (F : HomotopyRel f₀ f₁ S) {x : X} (hx : x ∈ S) : f₀ x = f₁ x :=
  F.eq_fst 0 hx ▸ F.eq_snd 0 hx
#align continuous_map.homotopy_rel.fst_eq_snd ContinuousMap.HomotopyRel.fst_eq_snd

end

variable {f₀ f₁ f₂ : C(X, Y)} {S : Set X}

/-- Given a map `f : C(X, Y)` and a set `S`, we can define a `HomotopyEel f f S` by setting
`F (t, x) = f x` for all `t`. This is defined using `HomotopyWith.refl`, but with the proof
filled in.
-/
@[simps!]
def refl (f : C(X, Y)) (S : Set X) : HomotopyRel f f S :=
  HomotopyWith.refl f fun _ _ => ⟨rfl, rfl⟩
#align continuous_map.homotopy_rel.refl ContinuousMap.HomotopyRel.refl

/--
Given a `HomotopyRel f₀ f₁ S`, we can define a `HomotopyRel f₁ f₀ S` by reversing the homotopy.
-/
@[simp]
def symm (F : HomotopyRel f₀ f₁ S) : HomotopyRel f₁ f₀ S :=
  { HomotopyWith.symm F with
      prop' := fun _ _ hx => ⟨F.eq_snd _ hx, F.eq_fst _ hx⟩ }
#align continuous_map.homotopy_rel.symm ContinuousMap.HomotopyRel.symm

-- porting note: removed @[simp] as the linter complains
theorem symm_symm (F : HomotopyRel f₀ f₁ S) : F.symm.symm = F :=
  HomotopyWith.symm_symm F
#align continuous_map.homotopy_rel.symm_symm ContinuousMap.HomotopyRel.symm_symm

/-- Given `HomotopyRel f₀ f₁ S` and `HomotopyRel f₁ f₂ S`, we can define a `HomotopyRel f₀ f₂ S`
by putting the first homotopy on `[0, 1/2]` and the second on `[1/2, 1]`.
-/
def trans (F : HomotopyRel f₀ f₁ S) (G : HomotopyRel f₁ f₂ S) : HomotopyRel f₀ f₂ S :=
  { Homotopy.trans F.toHomotopy G.toHomotopy with
    prop' := fun t => by
      intro x hx
      simp only [Homotopy.trans]
      change (⟨fun _ => ite ((t : ℝ) ≤ _) _ _, _⟩ : C(X, Y)) _ = _ ∧ _ = _
      split_ifs
      · simp [(HomotopyWith.extendProp F (2 * t) x hx).1, F.fst_eq_snd hx, G.fst_eq_snd hx]
      · simp [(HomotopyWith.extendProp G (2 * t - 1) x hx).1, F.fst_eq_snd hx, G.fst_eq_snd hx] }
#align continuous_map.homotopy_rel.trans ContinuousMap.HomotopyRel.trans

theorem trans_apply (F : HomotopyRel f₀ f₁ S) (G : HomotopyRel f₁ f₂ S) (x : I × X) :
    (F.trans G) x =
      if h : (x.1 : ℝ) ≤ 1 / 2 then
        F (⟨2 * x.1, (unitInterval.mul_pos_mem_iff zero_lt_two).2 ⟨x.1.2.1, h⟩⟩, x.2)
      else
        G (⟨2 * x.1 - 1, unitInterval.two_mul_sub_one_mem_iff.2 ⟨(not_le.1 h).le, x.1.2.2⟩⟩, x.2) :=
  Homotopy.trans_apply _ _ _
#align continuous_map.homotopy_rel.trans_apply ContinuousMap.HomotopyRel.trans_apply

theorem symm_trans (F : HomotopyRel f₀ f₁ S) (G : HomotopyRel f₁ f₂ S) :
    (F.trans G).symm = G.symm.trans F.symm :=
  HomotopyWith.ext <| Homotopy.congr_fun <| Homotopy.symm_trans _ _
#align continuous_map.homotopy_rel.symm_trans ContinuousMap.HomotopyRel.symm_trans

/-- Casting a `HomotopyRel f₀ f₁ S` to a `HomotopyRel g₀ g₁ S` where `f₀ = g₀` and `f₁ = g₁`.
-/
@[simp]
def cast {f₀ f₁ g₀ g₁ : C(X, Y)} (F : HomotopyRel f₀ f₁ S) (h₀ : f₀ = g₀) (h₁ : f₁ = g₁) :
    HomotopyRel g₀ g₁ S :=
  { Homotopy.cast F.toHomotopy h₀ h₁ with
    prop' := fun t x hx => by
      simp only [← h₀, ← h₁]
      exact F.prop t x hx }
#align continuous_map.homotopy_rel.cast ContinuousMap.HomotopyRel.cast

end HomotopyRel

/-- Given continuous maps `f₀` and `f₁`, we say `f₀` and `f₁` are homotopic relative to a set `S` if
there exists a `HomotopyRel f₀ f₁ S`.
-/
def HomotopicRel (f₀ f₁ : C(X, Y)) (S : Set X) : Prop :=
  Nonempty (HomotopyRel f₀ f₁ S)
#align continuous_map.homotopic_rel ContinuousMap.HomotopicRel

namespace HomotopicRel

variable {S : Set X}

-- porting note: removed @[refl]
theorem refl (f : C(X, Y)) : HomotopicRel f f S :=
  ⟨HomotopyRel.refl f S⟩
#align continuous_map.homotopic_rel.refl ContinuousMap.HomotopicRel.refl

@[symm]
theorem symm ⦃f g : C(X, Y)⦄ (h : HomotopicRel f g S) : HomotopicRel g f S :=
  h.map HomotopyRel.symm
#align continuous_map.homotopic_rel.symm ContinuousMap.HomotopicRel.symm

@[trans]
theorem trans ⦃f g h : C(X, Y)⦄ (h₀ : HomotopicRel f g S) (h₁ : HomotopicRel g h S) :
    HomotopicRel f h S :=
  h₀.map2 HomotopyRel.trans h₁
#align continuous_map.homotopic_rel.trans ContinuousMap.HomotopicRel.trans

theorem equivalence : Equivalence fun f g : C(X, Y) => HomotopicRel f g S :=
  ⟨refl, by apply symm, by apply trans⟩
#align continuous_map.homotopic_rel.equivalence ContinuousMap.HomotopicRel.equivalence

end HomotopicRel

end ContinuousMap


import algebra.category.Group

open category_theory

universe u

@[to_additive add_monoid_hom.mono_of_inj]
instance monoid_hom.mono_of_inj {A B : CommGroup.{u}} (f : A ⟶ B) (hf : function.injective f) : mono f :=
{ right_cancellation := λ C g h eq1, begin
  ext x,
  apply_fun f,
  erw [monoid_hom.congr_fun eq1],
  refl,
end }

lemma monoid_hom.inj_of_ker_eq_bot {A B : CommGroup.{u}} (f : A ⟶ B) (hf : f.ker = ⊥) : function.injective f :=
(monoid_hom.ker_eq_bot_iff f).mp hf

@[to_additive add_monoid_hom.inj_of_mono]
lemma monoid_hom.inj_of_mono {A B : CommGroup.{u}} (f : A ⟶ B) [hf : mono f] : function.injective f :=
begin
  rw ← monoid_hom.ker_eq_bot_iff,
  set g : (⟨f.ker⟩ : CommGroup) ⟶ A := { to_fun := λ x, x.1, map_one' := rfl, map_mul' := λ _ _, rfl },
  have := (@cancel_mono CommGroup _ A B ⟨f.ker⟩ f _ g 1).mp _,
  { apply_fun monoid_hom.range at this,
    have eq1 : monoid_hom.range (1 : (⟨f.ker⟩ : CommGroup) ⟶ A) = ⊥,
    { ext,
      split;
      intros hx,
      { rcases hx with ⟨⟨x, hx⟩, rfl⟩,
        change (1 : A) ∈ ⊥,
        exact subgroup.mem_bot.mpr rfl, },
      { simp only [subgroup.mem_bot] at hx,
        rw hx,
        refine ⟨1, rfl⟩, }, },
    rw eq1 at this,
    convert this,
    ext,
    split;
    intros hx,
    { exact ⟨⟨x, hx⟩, rfl⟩, },
    { rcases hx with ⟨⟨x, hx⟩, rfl⟩,
      exact hx, } },
  { ext,
    simp only [comp_apply, monoid_hom.one_apply, map_one, monoid_hom.coe_mk, subtype.val_eq_coe],
    exact x.2, },
end

@[to_additive add_monoid_hom.mono_iff_inj]
lemma monoid_hom.mono_iff_inj {A B : CommGroup.{u}} (f : A ⟶ B) : mono f ↔ function.injective f :=
⟨λ h, by {resetI, exact monoid_hom.inj_of_mono f }, monoid_hom.mono_of_inj f⟩


import group_theory.free_group
import free_pq
import pq_to_group

universe u

section pq_group_free_pq

variables {S : Type u}

def from_free_group : free_group S →* pq_group (free_pq S) :=
begin
  apply free_group.to_group,
  intro s,
  exact of (free_pq_of s),
end

def from_free_pq : pq_group (free_pq S) →* free_group S :=
begin
  fapply pq_morph_to_L_morph_adj,
  {
    apply free_pq_adjoint,
    exact free_group.of,
  },
  {
    apply free_pq_adjoint_is_pq_morphism,
  },
end

theorem from_free_pq_composition (x : pq_group (free_pq S)) : from_free_group (from_free_pq x) = x :=
begin
  induction x,
  {
    rw quot_mk_helper,
    induction x,
    {
      rw incl_unit_eq_unit,
      simp only [monoid_hom.map_one],
    },
    {
      rw ←of_def,
      unfold from_free_pq,
      rw pq_morph_to_L_morph_adj_comm_of,
      induction x,
      {
        rw quot_mk_helper_free_pq,
        induction x,
        {
          rw free_pq_one_def,
          rw one_preserved_by_morphism (free_pq_adjoint _),
          swap, apply free_pq_adjoint_is_pq_morphism,
          simp only [monoid_hom.map_one, of_one],
        },
        {
          rw ←free_pq_of_def,
          rw free_pq_adjoint_comm_of,
          unfold from_free_group,
          rw free_group.to_group.of,
        },
        {
          rw free_pq_rhd_def,
          rw ←rhd_of_eq_of_rhd,
          rw rhd_preserved_by_morphism (free_pq_adjoint _),
          swap, apply free_pq_adjoint_is_pq_morphism,
          rw rhd_def_group,
          simp only [monoid_hom.map_mul, monoid_hom.map_mul_inv],
          rw ←rhd_def_group,
          rw x_ih_x,
          rw x_ih_y,
        },
        {
          rw free_pq_pow_def,
          rw of_pow_eq_pow_of,
          rw pow_preserved_by_morphism (free_pq_adjoint _),
          swap, apply free_pq_adjoint_is_pq_morphism,
          rw monoid_hom.map_gpow,
          rw x_ih,
        },
      },
      {refl,},
    },
    {
      rw ←mul_def,
      simp only [monoid_hom.map_mul],
      rw x_ih_a,
      rw x_ih_b,
    },
    {
      rw ←inv_def,
      simp only [inv_inj, monoid_hom.map_inv],
      assumption,
    },
  },
  {refl,},
end

theorem free_group_composition (x : free_group S) : from_free_pq (from_free_group x) = x :=
begin
  apply @free_group.induction_on S (λ x, from_free_pq (from_free_group x) = x),
  {
    simp only [monoid_hom.map_one],
  },
  {
    intro x,
    unfold pure,
    unfold from_free_group,
    rw free_group.to_group.of,
    refl,
  },
  {
    clear x,
    intro x,
    intro hx,
    simp only [inv_inj, monoid_hom.map_inv],
    assumption,
  },
  {
    clear x,
    intros x y hx hy,
    simp only [monoid_hom.map_mul],
    rw hx,
    rw hy,
  },
end

def pq_group_free_pq_iso_free_group : free_group S ≃* pq_group (free_pq S) := {
  to_fun := from_free_group,
  inv_fun := from_free_pq,
  left_inv := free_group_composition,
  right_inv := from_free_pq_composition,
  map_mul' := begin
    intros x y,
    simp only [monoid_hom.map_mul],
  end }

end pq_group_free_pq


variable A : Prop
variable hA : A
variable hB : not A
theorem ab_ : not (A <-> not A) :=
assume h1 : A <-> not A,
    have h2 : A, from iff.elim_right h1 hB,
    have h3 : not A, from iff.elim_left h1 hA,
show false, from h3 h2

variables p q : Prop
#check ab_ p


/-
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.perm
! leanprover-community/mathlib commit 0a0ec35061ed9960bf0e7ffb0335f44447b58977
! 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.GroupTheory.Perm.Basic

/-!
# fintype instances for `equiv` and `perm`

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

Main declarations:
* `perms_of_finset s`: The finset of permutations of the finset `s`.

-/

open Function

open Nat

universe u v

variable {α β γ : Type _}

open Finset Function List Equiv Equiv.Perm

variable [DecidableEq α] [DecidableEq β]

#print permsOfList /-
/-- Given a list, produce a list of all permutations of its elements. -/
def permsOfList : List α → List (Perm α)
  | [] => [1]
  | a :: l => permsOfList l ++ l.bind fun b => (permsOfList l).map fun f => swap a b * f
#align perms_of_list permsOfList
-/

#print length_permsOfList /-
theorem length_permsOfList : ∀ l : List α, length (permsOfList l) = l.length !
  | [] => rfl
  | a :: l => by
    rw [length_cons, Nat.factorial_succ]
    simp [permsOfList, length_bind, length_permsOfList, Function.comp, Nat.succ_mul]
    cc
#align length_perms_of_list length_permsOfList
-/

#print mem_permsOfList_of_mem /-
theorem mem_permsOfList_of_mem {l : List α} {f : Perm α} (h : ∀ x, f x ≠ x → x ∈ l) :
    f ∈ permsOfList l := by
  induction' l with a l IH generalizing f h
  · exact List.mem_singleton.2 (Equiv.ext fun x => Decidable.by_contradiction <| h _)
  by_cases hfa : f a = a
  · refine' mem_append_left _ (IH fun x hx => mem_of_ne_of_mem _ (h x hx))
    rintro rfl
    exact hx hfa
  have hfa' : f (f a) ≠ f a := mt (fun h => f.injective h) hfa
  have : ∀ x : α, (swap a (f a) * f) x ≠ x → x ∈ l :=
    by
    intro x hx
    have hxa : x ≠ a := by
      rintro rfl
      apply hx
      simp only [mul_apply, swap_apply_right]
    refine' List.mem_of_ne_of_mem hxa (h x fun h => _)
    simp only [h, mul_apply, swap_apply_def, mul_apply, Ne.def, apply_eq_iff_eq] at hx <;>
      split_ifs  at hx
    exacts[hxa (h.symm.trans h_1), hx h]
  suffices f ∈ permsOfList l ∨ ∃ b ∈ l, ∃ g ∈ permsOfList l, swap a b * g = f by
    simpa only [permsOfList, exists_prop, List.mem_map, mem_append, List.mem_bind]
  refine' or_iff_not_imp_left.2 fun hfl => ⟨f a, _, swap a (f a) * f, IH this, _⟩
  · exact mem_of_ne_of_mem hfa (h _ hfa')
  · rw [← mul_assoc, mul_def (swap a (f a)) (swap a (f a)), swap_swap, ← perm.one_def, one_mul]
#align mem_perms_of_list_of_mem mem_permsOfList_of_mem
-/

#print mem_of_mem_permsOfList /-
theorem mem_of_mem_permsOfList :
    ∀ {l : List α} {f : Perm α}, f ∈ permsOfList l → ∀ {x}, f x ≠ x → x ∈ l
  | [], f, h => by
    have : f = 1 := by simpa [permsOfList] using h
    rw [this] <;> simp
  | a :: l, f, h =>
    (mem_append.1 h).elim (fun h x hx => mem_cons_of_mem _ (mem_of_mem_permsOfList h hx))
      fun h x hx =>
      let ⟨y, hy, hy'⟩ := List.mem_bind.1 h
      let ⟨g, hg₁, hg₂⟩ := List.mem_map.1 hy'
      if hxa : x = a then by simp [hxa]
      else
        if hxy : x = y then mem_cons_of_mem _ <| by rwa [hxy]
        else
          mem_cons_of_mem _ <|
            mem_of_mem_permsOfList hg₁ <| by
              rw [eq_inv_mul_iff_mul_eq.2 hg₂, mul_apply, swap_inv, swap_apply_def] <;>
                  split_ifs <;>
                [exact Ne.symm hxy, exact Ne.symm hxa, exact hx]
#align mem_of_mem_perms_of_list mem_of_mem_permsOfList
-/

#print mem_permsOfList_iff /-
theorem mem_permsOfList_iff {l : List α} {f : Perm α} :
    f ∈ permsOfList l ↔ ∀ {x}, f x ≠ x → x ∈ l :=
  ⟨mem_of_mem_permsOfList, mem_permsOfList_of_mem⟩
#align mem_perms_of_list_iff mem_permsOfList_iff
-/

#print nodup_permsOfList /-
theorem nodup_permsOfList : ∀ {l : List α} (hl : l.Nodup), (permsOfList l).Nodup
  | [], hl => by simp [permsOfList]
  | a :: l, hl => by
    have hl' : l.Nodup := hl.of_cons
    have hln' : (permsOfList l).Nodup := nodup_permsOfList hl'
    have hmeml : ∀ {f : Perm α}, f ∈ permsOfList l → f a = a := fun f hf =>
      Classical.not_not.1 (mt (mem_of_mem_permsOfList hf) (nodup_cons.1 hl).1)
    rw [permsOfList, List.nodup_append, List.nodup_bind, pairwise_iff_nth_le] <;>
      exact
        ⟨hln',
          ⟨fun _ _ => hln'.map fun _ _ => mul_left_cancel, fun i j hj hij x hx₁ hx₂ =>
            let ⟨f, hf⟩ := List.mem_map.1 hx₁
            let ⟨g, hg⟩ := List.mem_map.1 hx₂
            have hix : x a = nth_le l i (lt_trans hij hj) := by
              rw [← hf.2, mul_apply, hmeml hf.1, swap_apply_left]
            have hiy : x a = nth_le l j hj := by rw [← hg.2, mul_apply, hmeml hg.1, swap_apply_left]
            absurd (hf.2.trans hg.2.symm) fun h =>
              ne_of_lt hij <|
                nodup_iff_nth_le_inj.1 hl' i j (lt_trans hij hj) hj <| by rw [← hix, hiy]⟩,
          fun f hf₁ hf₂ =>
          let ⟨x, hx, hx'⟩ := List.mem_bind.1 hf₂
          let ⟨g, hg⟩ := List.mem_map.1 hx'
          have hgxa : g⁻¹ x = a := f.Injective <| by rw [hmeml hf₁, ← hg.2] <;> simp
          have hxa : x ≠ a := fun h => (List.nodup_cons.1 hl).1 (h ▸ hx)
          (List.nodup_cons.1 hl).1 <|
            hgxa ▸ mem_of_mem_permsOfList hg.1 (by rwa [apply_inv_self, hgxa])⟩
#align nodup_perms_of_list nodup_permsOfList
-/

#print permsOfFinset /-
/-- Given a finset, produce the finset of all permutations of its elements. -/
def permsOfFinset (s : Finset α) : Finset (Perm α) :=
  Quotient.hrecOn s.1 (fun l hl => ⟨permsOfList l, nodup_permsOfList hl⟩)
    (fun a b hab =>
      hfunext (congr_arg _ (Quotient.sound hab)) fun ha hb _ =>
        hEq_of_eq <| Finset.ext <| by simp [mem_permsOfList_iff, hab.mem_iff])
    s.2
#align perms_of_finset permsOfFinset
-/

#print mem_perms_of_finset_iff /-
theorem mem_perms_of_finset_iff :
    ∀ {s : Finset α} {f : Perm α}, f ∈ permsOfFinset s ↔ ∀ {x}, f x ≠ x → x ∈ s := by
  rintro ⟨⟨l⟩, hs⟩ f <;> exact mem_permsOfList_iff
#align mem_perms_of_finset_iff mem_perms_of_finset_iff
-/

#print card_perms_of_finset /-
theorem card_perms_of_finset : ∀ s : Finset α, (permsOfFinset s).card = s.card ! := by
  rintro ⟨⟨l⟩, hs⟩ <;> exact length_permsOfList l
#align card_perms_of_finset card_perms_of_finset
-/

#print fintypePerm /-
/-- The collection of permutations of a fintype is a fintype. -/
def fintypePerm [Fintype α] : Fintype (Perm α) :=
  ⟨permsOfFinset (@Finset.univ α _), by simp [mem_perms_of_finset_iff]⟩
#align fintype_perm fintypePerm
-/

instance [Fintype α] [Fintype β] : Fintype (α ≃ β) :=
  if h : Fintype.card β = Fintype.card α then
    Trunc.recOnSubsingleton (Fintype.truncEquivFin α) fun eα =>
      Trunc.recOnSubsingleton (Fintype.truncEquivFin β) fun eβ =>
        @Fintype.ofEquiv _ (Perm α) fintypePerm
          (equivCongr (Equiv.refl α) (eα.trans (Eq.recOn h eβ.symm)) : α ≃ α ≃ (α ≃ β))
  else ⟨∅, fun x => False.elim (h (Fintype.card_eq.2 ⟨x.symm⟩))⟩

/- warning: fintype.card_perm -> Fintype.card_perm is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] [_inst_3 : Fintype.{u1} α], Eq.{1} Nat (Fintype.card.{u1} (Equiv.Perm.{succ u1} α) (Equiv.fintype.{u1, u1} α α (fun (a : α) (b : α) => _inst_1 a b) (fun (a : α) (b : α) => _inst_1 a b) _inst_3 _inst_3)) (Nat.factorial (Fintype.card.{u1} α _inst_3))
but is expected to have type
  forall {α : Type.{u1}} [_inst_1 : DecidableEq.{succ u1} α] [_inst_3 : Fintype.{u1} α], Eq.{1} Nat (Fintype.card.{u1} (Equiv.Perm.{succ u1} α) (equivFintype.{u1, u1} α α (fun (a : α) (b : α) => _inst_1 a b) (fun (a : α) (b : α) => _inst_1 a b) _inst_3 _inst_3)) (Nat.factorial (Fintype.card.{u1} α _inst_3))
Case conversion may be inaccurate. Consider using '#align fintype.card_perm Fintype.card_permₓ'. -/
theorem Fintype.card_perm [Fintype α] : Fintype.card (Perm α) = (Fintype.card α)! :=
  Subsingleton.elim (@fintypePerm α _ _) (@Equiv.fintype α α _ _ _ _) ▸ card_perms_of_finset _
#align fintype.card_perm Fintype.card_perm

/- warning: fintype.card_equiv -> Fintype.card_equiv is a dubious translation:
lean 3 declaration is
  forall {α : Type.{u1}} {β : Type.{u2}} [_inst_1 : DecidableEq.{succ u1} α] [_inst_2 : DecidableEq.{succ u2} β] [_inst_3 : Fintype.{u1} α] [_inst_4 : Fintype.{u2} β], (Equiv.{succ u1, succ u2} α β) -> (Eq.{1} Nat (Fintype.card.{max (max u1 u2) u2 u1} (Equiv.{succ u1, succ u2} α β) (Equiv.fintype.{u1, u2} α β (fun (a : α) (b : α) => _inst_1 a b) (fun (a : β) (b : β) => _inst_2 a b) _inst_3 _inst_4)) (Nat.factorial (Fintype.card.{u1} α _inst_3)))
but is expected to have type
  forall {α : Type.{u2}} {β : Type.{u1}} [_inst_1 : DecidableEq.{succ u2} α] [_inst_2 : DecidableEq.{succ u1} β] [_inst_3 : Fintype.{u2} α] [_inst_4 : Fintype.{u1} β], (Equiv.{succ u2, succ u1} α β) -> (Eq.{1} Nat (Fintype.card.{max u2 u1} (Equiv.{succ u2, succ u1} α β) (equivFintype.{u2, u1} α β (fun (a : α) (b : α) => _inst_1 a b) (fun (a : β) (b : β) => _inst_2 a b) _inst_3 _inst_4)) (Nat.factorial (Fintype.card.{u2} α _inst_3)))
Case conversion may be inaccurate. Consider using '#align fintype.card_equiv Fintype.card_equivₓ'. -/
theorem Fintype.card_equiv [Fintype α] [Fintype β] (e : α ≃ β) :
    Fintype.card (α ≃ β) = (Fintype.card α)! :=
  Fintype.card_congr (equivCongr (Equiv.refl α) e) ▸ Fintype.card_perm
#align fintype.card_equiv Fintype.card_equiv


/-
Copyright (c) 2014 Parikshit Khanna. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Parikshit Khanna, Jeremy Avigad, Leonardo de Moura, Floris van Doorn, Mario Carneiro

! This file was ported from Lean 3 source module data.list.count
! leanprover-community/mathlib commit 47adfab39a11a072db552f47594bf8ed2cf8a722
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathlib.Data.List.BigOperators.Basic

/-!
# Counting in lists

This file proves basic properties of `List.countp` and `List.count`, which count the number of
elements of a list satisfying a predicate and equal to a given element respectively. Their
definitions can be found in `Std.Data.List.Basic`.
-/

open Nat

variable {l : List α}

namespace List

section Countp

variable (p q : α → Bool)

@[simp]
theorem countp_nil : countp p [] = 0 := rfl
#align list.countp_nil List.countp_nil

-- Porting note: added to aid in the following proof.
protected theorem countp_go_eq_add (l) : countp.go p l n = n + countp.go p l 0 := by
  induction' l with head tail ih generalizing n
  · rfl
  · unfold countp.go
    rw [ih (n := n + 1), ih (n := n), ih (n := 1)]
    by_cases h : p head
    · simp [h, add_assoc]
    · simp [h]

@[simp]
theorem countp_cons_of_pos {a : α} (l) (pa : p a) : countp p (a :: l) = countp p l + 1 := by
  have : countp.go p (a :: l) 0 = countp.go p l 1
  · change (bif _ then _ else _) = countp.go _ _ _
    rw [pa]
    rfl
  unfold countp
  rw [this, add_comm, List.countp_go_eq_add]

#align list.countp_cons_of_pos List.countp_cons_of_pos

@[simp]
theorem countp_cons_of_neg {a : α} (l) (pa : ¬p a) : countp p (a :: l) = countp p l := by
  change (bif _ then _ else _) = countp.go _ _ _
  rw [Bool.of_not_eq_true pa]
  rfl
#align list.countp_cons_of_neg List.countp_cons_of_neg

theorem countp_cons (a : α) (l) : countp p (a :: l) = countp p l + if p a then 1 else 0 := by
  by_cases h : p a <;> simp [h]
#align list.countp_cons List.countp_cons

theorem length_eq_countp_add_countp (l) : length l = countp p l + countp (fun a => ¬p a) l := by
  induction' l with x h ih
  · rfl
  by_cases h : p x
  · rw [countp_cons_of_pos _ _ h, countp_cons_of_neg _ _ _, length, ih]
    · ac_rfl
    · simp only [h]
  · rw [countp_cons_of_pos (fun a => ¬p a) _ _, countp_cons_of_neg _ _ h, length, ih]
    · ac_rfl
    · simp only [h]
#align list.length_eq_countp_add_countp List.length_eq_countp_add_countp

theorem countp_le_length : countp p l ≤ l.length := by
  simpa only [countp_eq_length_filter] using length_filter_le _ _
#align list.countp_le_length List.countp_le_length

@[simp]
theorem countp_append (l₁ l₂) : countp p (l₁ ++ l₂) = countp p l₁ + countp p l₂ := by
  simp only [countp_eq_length_filter, filter_append, length_append]
#align list.countp_append List.countp_append

theorem countp_join : ∀ l : List (List α), countp p l.join = (l.map (countp p)).sum
  | [] => rfl
  | a :: l => by rw [join, countp_append, map_cons, sum_cons, countp_join l]
#align list.countp_join List.countp_join

theorem countp_pos : 0 < countp p l ↔ ∃ a ∈ l, p a := by
  simp only [countp_eq_length_filter, length_pos_iff_exists_mem, mem_filter, exists_prop]
#align list.countp_pos List.countp_pos

@[simp]
theorem countp_eq_zero : countp p l = 0 ↔ ∀ a ∈ l, ¬p a := by
  rw [← not_iff_not, ← Ne.def, ← pos_iff_ne_zero, countp_pos]
  simp
#align list.countp_eq_zero List.countp_eq_zero

@[simp]
theorem countp_eq_length : countp p l = l.length ↔ ∀ a ∈ l, p a := by
  rw [countp_eq_length_filter, filter_length_eq_length]
#align list.countp_eq_length List.countp_eq_length

theorem length_filter_lt_length_iff_exists (l) :
    length (filter p l) < length l ↔ ∃ x ∈ l, ¬p x := by
  simpa [length_eq_countp_add_countp p l, countp_eq_length_filter] using
  countp_pos (fun x => ¬p x) (l := l)
#align list.length_filter_lt_length_iff_exists List.length_filter_lt_length_iff_exists

theorem Sublist.countp_le (s : l₁ <+ l₂) : countp p l₁ ≤ countp p l₂ := by
  simpa only [countp_eq_length_filter] using length_le_of_sublist (s.filter p)
#align list.sublist.countp_le List.Sublist.countp_le

@[simp]
theorem countp_filter (l : List α) : countp p (filter q l) = countp (fun a => p a ∧ q a) l := by
  simp only [countp_eq_length_filter, filter_filter]
#align list.countp_filter List.countp_filter

@[simp]
theorem countp_true : (l.countp fun _ => true) = l.length := by simp
#align list.countp_true List.countp_true

@[simp]
theorem countp_false : (l.countp fun _ => false) = 0 := by simp
#align list.countp_false List.countp_false

@[simp]
theorem countp_map (p : β → Bool) (f : α → β) :
    ∀ l, countp p (map f l) = countp (p ∘ f) l
  | [] => rfl
  | a :: l => by rw [map_cons, countp_cons, countp_cons, countp_map p f l]; rfl
#align list.countp_map List.countp_map

variable {p q}

theorem countp_mono_left (h : ∀ x ∈ l, p x → q x) : countp p l ≤ countp q l := by
  induction' l with a l ihl
  · rfl
  rw [forall_mem_cons] at h
  cases' h with ha hl
  rw [countp_cons, countp_cons]
  refine' _root_.add_le_add (ihl hl) _
  split_ifs <;> simp only [le_rfl, _root_.zero_le]
  exact absurd (ha ‹_›) ‹_›
#align list.countp_mono_left List.countp_mono_left

theorem countp_congr (h : ∀ x ∈ l, p x ↔ q x) : countp p l = countp q l :=
  _root_.le_antisymm
    (countp_mono_left fun x hx => (h x hx).1)
    (countp_mono_left fun x hx => (h x hx).2)
#align list.countp_congr List.countp_congr

end Countp

/-! ### count -/

section Count

variable [DecidableEq α]

@[simp]
theorem count_nil (a : α) : count a [] = 0 := rfl
#align list.count_nil List.count_nil

theorem count_cons' (a b : α) (l : List α) :
    count a (b :: l) = count a l + if a = b then 1 else 0 := by conv =>
  simp [count, countp_cons]
  lhs
  simp only [eq_comm]
#align list.count_cons' List.count_cons'

theorem count_cons (a b : α) (l : List α) :
    count a (b :: l) = if a = b then succ (count a l) else count a l := by
  simp [count_cons']
  split_ifs <;> rfl
#align list.count_cons List.count_cons

@[simp]
theorem count_cons_self (a : α) (l : List α) : count a (a :: l) = count a l + 1 := by
  simp [count_cons']
#align list.count_cons_self List.count_cons_self

@[simp]
theorem count_cons_of_ne (h : a ≠ b) (l : List α) : count a (b :: l) = count a l := by
  simp [count_cons']
  exact h
#align list.count_cons_of_ne List.count_cons_of_ne

theorem count_tail :
    ∀ (l : List α) (a : α) (h : 0 < l.length),
      l.tail.count a = l.count a - if a = List.get l ⟨0, h⟩ then 1 else 0
  | head :: tail, a, h => by
    rw [count_cons']
    split_ifs <;> simp at * <;> contradiction
#align list.count_tail List.count_tail

theorem count_le_length (a : α) (l : List α) : count a l ≤ l.length :=
  countp_le_length _
#align list.count_le_length List.count_le_length

theorem Sublist.count_le (h : l₁ <+ l₂) (a : α) : count a l₁ ≤ count a l₂ :=
  h.countp_le _
#align list.sublist.count_le List.Sublist.count_le

theorem count_le_count_cons (a b : α) (l : List α) : count a l ≤ count a (b :: l) :=
  (sublist_cons _ _).count_le _
#align list.count_le_count_cons List.count_le_count_cons

theorem count_singleton (a : α) : count a [a] = 1 := by
  rw [count_cons]
  simp
#align list.count_singleton List.count_singleton

theorem count_singleton' (a b : α) : count a [b] = if a = b then 1 else 0 := by
  rw [count_cons]
  rfl
#align list.count_singleton' List.count_singleton'

@[simp]
theorem count_append (a : α) : ∀ l₁ l₂, count a (l₁ ++ l₂) = count a l₁ + count a l₂ :=
  countp_append _
#align list.count_append List.count_append

theorem count_join (l : List (List α)) (a : α) : l.join.count a = (l.map (count a)).sum :=
  countp_join _ _
#align list.count_join List.count_join

theorem count_concat (a : α) (l : List α) : count a (concat l a) = succ (count a l) := by simp
#align list.count_concat List.count_concat

@[simp]
theorem count_pos {a : α} {l : List α} : 0 < count a l ↔ a ∈ l := by
  simp only [count, countp_pos, beq_iff_eq, exists_eq_right]
#align list.count_pos List.count_pos

@[simp]
theorem one_le_count_iff_mem {a : α} {l : List α} : 1 ≤ count a l ↔ a ∈ l := count_pos
#align list.one_le_count_iff_mem List.one_le_count_iff_mem

-- Porting note: lower priority to make simpNF linter happy
@[simp 900]
theorem count_eq_zero_of_not_mem {a : α} {l : List α} (h : a ∉ l) : count a l = 0 :=
  Decidable.by_contradiction fun h' => h <| count_pos.1 (Nat.pos_of_ne_zero h')
#align list.count_eq_zero_of_not_mem List.count_eq_zero_of_not_mem

theorem not_mem_of_count_eq_zero {a : α} {l : List α} (h : count a l = 0) : a ∉ l :=
  fun h' => (count_pos.2 h').ne' h
#align list.not_mem_of_count_eq_zero List.not_mem_of_count_eq_zero

@[simp]
theorem count_eq_zero : count a l = 0 ↔ a ∉ l :=
  ⟨not_mem_of_count_eq_zero, count_eq_zero_of_not_mem⟩
#align list.count_eq_zero List.count_eq_zero

@[simp]
theorem count_eq_length : count a l = l.length ↔ ∀ b ∈ l, a = b := by
  simp_rw [count, countp_eq_length, beq_iff_eq, eq_comm]
#align list.count_eq_length List.count_eq_length

@[simp]
theorem count_replicate_self (a : α) (n : ℕ) : count a (replicate n a) = n :=
  (count_eq_length.2 <| fun _ h => (eq_of_mem_replicate h).symm).trans (length_replicate _ _)
#align list.count_replicate_self List.count_replicate_self

theorem count_replicate (a b : α) (n : ℕ) : count a (replicate n b) = if a = b then n else 0 := by
  split
  exacts [‹a = b› ▸ count_replicate_self _ _, count_eq_zero.2 <| mt eq_of_mem_replicate ‹a ≠ b›]
#align list.count_replicate List.count_replicate

-- porting note: new lemma
theorem filter_beq' (l : List α) (a : α) : l.filter (· == a) = replicate (count a l) a := by
  simp only [count, countp_eq_length_filter, eq_replicate, mem_filter, beq_iff_eq]
  exact ⟨trivial, fun _ h => h.2⟩

theorem filter_eq' (l : List α) (a : α) : l.filter (· = a) = replicate (count a l) a :=
  filter_beq' l a
#align list.filter_eq' List.filter_eq'

theorem filter_eq (l : List α) (a : α) : l.filter (a = ·) = replicate (count a l) a := by
  simpa only [eq_comm] using filter_eq' l a
#align list.filter_eq List.filter_eq

-- porting note: new lemma
theorem filter_beq (l : List α) (a : α) : l.filter (a == ·) = replicate (count a l) a :=
  filter_eq l a

theorem le_count_iff_replicate_sublist : n ≤ count a l ↔ replicate n a <+ l :=
  ⟨fun h => ((replicate_sublist_replicate a).2 h).trans <| filter_eq l a ▸ filter_sublist _,
    fun h => by simpa only [count_replicate_self] using h.count_le a⟩
#align list.le_count_iff_replicate_sublist List.le_count_iff_replicate_sublist

theorem replicate_count_eq_of_count_eq_length (h : count a l = length l) :
    replicate (count a l) a = l :=
  (le_count_iff_replicate_sublist.mp le_rfl).eq_of_length <|
    (length_replicate (count a l) a).trans h
#align list.replicate_count_eq_of_count_eq_length List.replicate_count_eq_of_count_eq_length

@[simp]
theorem count_filter (h : p a) : count a (filter p l) = count a l := by
  rw [count, countp_filter]
  congr
  funext b
  rw [Bool.beq_eq_decide_eq]
  by_cases hb : b = a
  · simp [hb, h]
  · simp [hb]
#align list.count_filter List.count_filter

theorem count_bind {α β} [DecidableEq β] (l : List α) (f : α → List β) (x : β) :
    count x (l.bind f) = sum (map (count x ∘ f) l) := by rw [List.bind, count_join, map_map]
#align list.count_bind List.count_bind

@[simp]
theorem count_map_of_injective {α β} [DecidableEq α] [DecidableEq β] (l : List α) (f : α → β)
    (hf : Function.Injective f) (x : α) : count (f x) (map f l) = count x l := by
  simp only [count, countp_map, (· ∘ ·), hf.beq_eq]

#align list.count_map_of_injective List.count_map_of_injective

theorem count_le_count_map [DecidableEq β] (l : List α) (f : α → β) (x : α) :
    count x l ≤ count (f x) (map f l) := by
  rw [count, count, countp_map]
  exact countp_mono_left <| by simp (config := {contextual := true})
#align list.count_le_count_map List.count_le_count_map

theorem count_erase (a b : α) :
    ∀ l : List α, count a (l.erase b) = count a l - if a = b then 1 else 0
  | [] => by simp
  | c :: l => by
    rw [erase_cons]
    by_cases hc : c = b
    · rw [if_pos hc, hc, count_cons', Nat.add_sub_cancel]
    · rw [if_neg hc, count_cons', count_cons', count_erase a b l]
      by_cases ha : a = b
      · rw [← ha, eq_comm] at hc
        rw [if_pos ha, if_neg hc, add_zero, add_zero]
      · rw [if_neg ha, tsub_zero, tsub_zero]
#align list.count_erase List.count_erase

@[simp]
theorem count_erase_self (a : α) (l : List α) : count a (List.erase l a) = count a l - 1 := by
  rw [count_erase, if_pos rfl]
#align list.count_erase_self List.count_erase_self

@[simp]
theorem count_erase_of_ne (ab : a ≠ b) (l : List α) : count a (l.erase b) = count a l :=
  by rw [count_erase, if_neg ab, tsub_zero]
#align list.count_erase_of_ne List.count_erase_of_ne

@[to_additive]
theorem prod_map_eq_pow_single [Monoid β] (a : α) (f : α → β)
    (hf : ∀ a', a' ≠ a → a' ∈ l → f a' = 1) : (l.map f).prod = f a ^ l.count a := by
  induction' l with a' as h generalizing a
  · rw [map_nil, prod_nil, count_nil, _root_.pow_zero]
  · specialize h a fun a' ha' hfa' => hf a' ha' (mem_cons_of_mem _ hfa')
    rw [List.map_cons, List.prod_cons, count_cons, h]
    split_ifs with ha'
    · rw [ha', _root_.pow_succ]
    · rw [hf a' (Ne.symm ha') (List.mem_cons_self a' as), one_mul]
#align list.prod_map_eq_pow_single List.prod_map_eq_pow_single
#align list.sum_map_eq_nsmul_single List.sum_map_eq_nsmul_single

@[to_additive]
theorem prod_eq_pow_single [Monoid α] (a : α)
    (h : ∀ a', a' ≠ a → a' ∈ l → a' = 1) : l.prod = a ^ l.count a :=
  _root_.trans (by rw [map_id]) (prod_map_eq_pow_single a id h)
#align list.prod_eq_pow_single List.prod_eq_pow_single
#align list.sum_eq_nsmul_single List.sum_eq_nsmul_single

end Count

end List


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

Given a semiring `R`, this file defines the power series semiring `R[[x]]`
-/

import data.fintype.basic data.finsupp algebra.big_operators data.pi.algebra
import data.list_extra algebra.biadditive algebra.prod_equiv algebra.convolution
import algebra.order.sub
import tactic.squeeze tactic.pi_instances

def power_series (R : Type*) := convolution.map ℕ R

namespace power_series

open finset

variable {R : Type*}

def coeff₀ : ℕ → (power_series R) → R := λ n f, f n

instance [has_zero R] : has_zero (power_series R) :=
 by {dsimp[power_series], apply_instance}

instance [add_comm_monoid R] : add_comm_monoid (power_series R) :=
 by {dsimp[power_series], apply_instance}

instance [semiring R] : semiring (power_series R) :=
 by {dsimp[power_series], apply_instance}

instance [comm_semiring R] : comm_semiring (power_series R) :=
 by {dsimp[power_series], apply_instance}

instance [ring R] : ring (power_series R) :=
 by {dsimp[power_series], apply_instance}

instance [comm_ring R] : comm_ring (power_series R) :=
 by {dsimp[power_series], apply_instance}

/- `C a` is the constant power series with value `a`, so the zeroth
   coefficient is `a` and the other coefficients are zero.
-/
def C [semiring R] : R →+* power_series R := {
 to_fun := convolution.map.delta,
 map_zero' := convolution.map.delta_zero,
 map_one' := by {dsimp[power_series,has_one.one,monoid.one,semiring.one],refl},
 map_add' := λ x y, by {apply convolution.map.delta_add},
 map_mul' := λ x y, by {symmetry,apply convolution.delta_convolve_delta}
}

/- `X` denotes the standard generator of the power series
   semiring `R[[X]]`.
-/

def X [semiring R] : power_series R := convolution.map.single (1 : ℕ) (1 : R)

def coeff [add_comm_monoid R] (n : ℕ) : (power_series R →+ R) := {
  to_fun := λ f, f n,
  map_zero' := rfl,
  map_add' := λ f g, rfl,
}

@[ext]
lemma ext [add_comm_monoid R] :
 ∀ {f g : power_series R}, (∀ n, coeff n f = coeff n g) → f = g := @funext _ _

lemma coeff_n_one [semiring R] (n : ℕ) :
 coeff n (1 : power_series R) = ite (0 = n) 1 0 := rfl

lemma coeff_zero_one [semiring R] : coeff 0 (1 : power_series R) = 1 := rfl
lemma coeff_succ_one [semiring R] (n : ℕ) : coeff (n + 1) (1 : power_series R) = 0 := rfl

lemma coeff_n_C [semiring R] (n : ℕ) (a : R) :
 coeff n (C a) = ite (0 = n) a 0 := rfl

lemma coeff_zero_C [semiring R] (a : R) : coeff 0 (C a) = a := rfl
lemma coeff_succ_C [semiring R] (n : ℕ) (a : R) : coeff (n + 1) (C a) = 0 := rfl

lemma coeff_n_X [semiring R] (n : ℕ) :
 coeff n (X : power_series R) = ite (1 = n) 1 0 := rfl

lemma coeff_zero_X [semiring R] : coeff 0 (X : power_series R) = 0 := rfl
lemma coeff_one_X  [semiring R] : coeff 1 (X : power_series R) = 1 := rfl
lemma coeff_ss_X   [semiring R] (n : ℕ) : coeff (n + 2) (X : power_series R) = 0 := rfl

lemma coeff_mul [semiring R] (n : ℕ) (f g : power_series R) :
 coeff n (f * g) = (range n.succ).sum (λ i, (coeff i f) * (coeff (n - i) g)) :=
begin
 change convolution.convolve ((*) : R → R → R) f g n =
  (range n.succ).sum (λ i, (coeff i f) * (coeff (n - i) g)),
 dsimp[convolution.convolve,convolution.sum_set.els,coeff],
 let h_inj :
  ∀ (i₁ : ℕ) (h₁ : i₁ ∈ range n.succ)
    (i₂ : ℕ) (h₂ : i₂ ∈ range n.succ)
    (e : prod.mk i₁ (n - i₁) = prod.mk i₂ (n - i₂)), i₁ = i₂ :=
  by { intros,injection e, },
 have := @sum_image R (ℕ × ℕ) ℕ (λ x, (f x.1) * (g x.2)) _ _
  (range n.succ) (λ i, prod.mk i (n - i)) h_inj,
 simp only [] at this ⊢, rw[← this]
end

/- Left multiplication by `C a` is termwise left multiplication by `a` -/
lemma coeff_C_mul [semiring R] (n : ℕ) (a : R) (f : power_series R) :
 coeff n ((C a) * f) = a * coeff n f :=
begin
 rw[coeff_mul],
 let h := @sum_eq_single R ℕ _ (range (n + 1))
  (λ i, coeff i (C a) * coeff (n - i) f) 0
   (λ i _ h, by { simp only[], rw[coeff_n_C i a,if_neg h.symm,zero_mul], })
   (λ h, by { exfalso,
              exact h (mem_range_succ.mpr (nat.zero_le n)) }),
 rw[h],simp only[],rw[coeff_n_C,if_pos rfl,nat.sub_zero],
end

/- Right multiplication by `C a` is termwise right multiplication by `a` -/
lemma coeff_mul_C [semiring R] (n : ℕ) (f : power_series R) (a : R) :
 coeff n (f * (C a)) = (coeff n f) * a :=
begin
 rw[coeff_mul],
 let h := @sum_eq_single R ℕ _ (range (n + 1))
  (λ i, coeff i f * coeff (n - i) (C a)) n
   (λ i h_le h_ne, by {
     replace h_le : i ≤ n := mem_range_succ.mp h_le,
     have h_lt : i < n := lt_of_le_of_ne h_le h_ne,
     have : n - i ≠ 0 := λ e, not_lt_of_ge (nat.sub_eq_zero_iff_le.mp e) h_lt,
     simp only[], rw[coeff_n_C (n - i),if_neg this.symm,mul_zero],
    })
   (λ h, by { exfalso, exact h (mem_range_succ.mpr (le_refl n)),}),
 rw[h],simp only[],rw[nat.sub_self,coeff_n_C,if_pos rfl],
end

lemma coeff_X_mul_zero [semiring R] (f : power_series R) :
 coeff 0 (X * f) = 0 :=
begin
 rw[coeff_mul,sum_range_one,coeff_n_X,if_neg (dec_trivial : 1 ≠ 0),zero_mul],
end

lemma coeff_X_mul_succ [semiring R] (n : ℕ) (f : power_series R) :
 coeff (n + 1) (X * f) = coeff n f :=
begin
 rw[coeff_mul],
 let h₀ := @sum_eq_single R ℕ _ (range (n + 2))
  (λ i, coeff i X * coeff (n + 1 - i) f) 1
   (λ i _ h, by { simp only[], rw[coeff_n_X i,if_neg h.symm,zero_mul], })
   (λ h, by { have : 1 < n + 2 := nat.succ_lt_succ (nat.zero_lt_succ n),
              have : 1 ∈ range (n + 2) := mem_range.mpr this,
              exact (h this).elim}),
  rw[h₀],simp only[coeff_one_X],rw[one_mul],refl,
end

/- `E` is the homomorphism sending a power series to its constant term. -/
def E [semiring R] : (power_series R) →+* R := {
  to_fun := λ f, coeff 0 f,
  map_zero' := rfl,
  map_one' := rfl,
  map_add' := λ f g, rfl,
  map_mul' := λ f g, by { rw[coeff_mul,sum_range_one] }
}

lemma E_C [semiring R] (a : R) : E (C a) = a := rfl

/- `val_ge n f` means that `f` has valuation at least `n`, or in other
   words that `f` is divisible by `X ^ n`.
-/
@[irreducible]
def val_ge [add_comm_monoid R] (n : ℕ) (f : power_series R) : Prop :=
 ∀ {i : ℕ} (hi : i < n), coeff i f = 0

lemma val_ge_zero_all [add_comm_monoid R] (f : power_series R) : val_ge 0 f :=
begin dsimp[val_ge],intros i hi, exact (nat.not_lt_zero i hi).elim end

lemma val_ge_all_zero [add_comm_monoid R] (n : ℕ) : val_ge n (0 : power_series R) :=
 by {dsimp[val_ge], intros i hi, refl}

lemma val_ge_one_iff [add_comm_monoid R] (f : power_series R) :
 val_ge 1 f ↔ coeff 0 f = 0 :=
  by { dsimp[val_ge], split,
   {intro h,exact h (nat.lt_succ_self 0)},
   {intros h i i_lt,cases i with i,{exact h},
    {exact (nat.not_lt_zero i (nat.lt_of_succ_lt_succ i_lt)).elim,}}
  }

lemma val_ge_add [add_comm_monoid R] {n : ℕ} {f g : power_series R} :
 val_ge n f → val_ge n g → val_ge n (f + g) :=
  by {dsimp[val_ge], intros hf hg i i_is_lt,
      show coeff i f + coeff i g = 0,rw[hf i_is_lt,hg i_is_lt,zero_add],}

lemma val_ge_mul [semiring R] {n m : ℕ} {f g : power_series R} :
 val_ge n f → val_ge m g → val_ge (n + m) (f * g) :=
  λ hf hg,
begin
 dsimp[val_ge] at hf hg ⊢,
 intros k k_is_lt,
 change (convolution.sum_set.els k).sum (λ ij, (f ij.1) * (g ij.2)) = 0,
 have : (convolution.sum_set.els k).sum (λ ij, (0 : R)) = (0 : R) := sum_const_zero,
 rw[← this],apply sum_congr rfl,
 rintros ⟨i,j⟩ ij_sum,
 replace ij_sum : i + j = k := (convolution.sum_set.mem_els _ _).mp ij_sum,
 change (coeff i f) * (coeff j g) = 0,
 by_cases hi : i < n, {rw[hf hi,zero_mul],},
 by_cases hj : j < m, {rw[hg hj,mul_zero],},
 let hk : n + m ≤ k :=
  ij_sum ▸ (add_le_add (le_of_not_gt hi) (le_of_not_gt hj)),
 exact (not_le_of_gt k_is_lt hk).elim,
end

lemma val_ge_pow [semiring R] {n : ℕ} {f : power_series R} (hf : val_ge n f) (k : ℕ) :
 val_ge (k * n) (f ^ k) :=
begin
 induction k with k ih,
 {rw[zero_mul],apply val_ge_zero_all},
 {rw[nat.succ_eq_add_one,pow_add,pow_one,add_mul,one_mul],
  exact val_ge_mul ih hf,
 }
end

lemma val_ge_pow' [semiring R] {f : power_series R} (hf : coeff 0 f = 0) (k : ℕ) :
 val_ge k (f ^ k) :=
  by {have := val_ge_pow ((val_ge_one_iff f).mpr hf) k,
      rw[mul_one] at this, exact this,}

lemma val_ge_X [semiring R] : val_ge 1 (X : power_series R) :=
 by {dsimp[val_ge,X,coeff],intros i hi,
     apply convolution.map.single_eq_of_ne  (ne_of_lt hi).symm,}

lemma coeff_X_pow [semiring R] (n i : ℕ) :
 coeff i ((X : power_series R) ^ n) = ite (n = i) 1 0 :=
begin
 induction n with n ih generalizing i,
 {rw[pow_zero,coeff_n_one]},
 {rw[pow_succ],cases i with i,
  {rw[coeff_X_mul_zero],rw[if_neg (nat.succ_ne_zero n)],},
  {rw[coeff_X_mul_succ,ih i],by_cases h : n = i,
   {rw[if_pos h,if_pos (congr_arg nat.succ h)]},
   {have : n.succ ≠ i.succ := λ e, h (nat.succ_inj'.mp e),
    rw[if_neg h,if_neg this]}}}
end

section compose

variable [comm_semiring R]

/-
 Note: this definition is only sensible with the side condition `coeff 0 g = 0`
-/

def compose (f g : power_series R) : power_series R :=
 λ n, ((range n.succ).sum (λ j, C (coeff j f) * (g ^ j))) n

lemma coeff_compose (n : ℕ) (f g : power_series R) :
 coeff n (compose f g) =
  (range n.succ).sum (λ j, (coeff j f) * (coeff n (g ^ j))) :=
begin
 let hh := (coeff n : power_series R →+ R).map_sum,
 have := calc
  coeff n (compose f g) =
   coeff n ((range n.succ).sum (λ j, C (coeff j f) * (g ^ j))) : rfl
   ... = (range n.succ).sum (λ j, coeff n (C (coeff j f) * (g ^ j))) :
    by {rw[← hh]},
 rw[this],congr,funext j,rw[coeff_C_mul],
end

lemma coeff_compose_extra {n m : ℕ} (f g : power_series R)
 (hg : coeff 0 g = 0) (hnm : n ≤ m) :
 coeff n (compose f g) =
  (range m.succ).sum (λ j, (coeff j f) * (coeff n (g ^ j))) :=
begin
 rw[coeff_compose],
 have : range n.succ = (range m.succ).filter (λ i, i ≤ n) :=
  by {ext i,rw[mem_filter,mem_range_succ,mem_range_succ],split,
      {intro hn,exact ⟨le_trans hn hnm,hn⟩,},{exact λ h,h.2}},
 rw[this,sum_filter],congr,ext j,split_ifs with h,refl,
 replace h : n < j := lt_of_not_ge h,
 have hv := val_ge_pow' hg j, dsimp[val_ge] at hv, rw[hv h,mul_zero],
end

lemma zero_compose (g : power_series R) : compose 0 g = 0 :=
begin
 ext n,rw[coeff_compose],
 apply sum_eq_zero_of_terms_eq_zero,
 intros i _,rw[(coeff i).map_zero,zero_mul],
end

/- `f ∘ g` is an additive function of `f`. -/
lemma add_compose (f₁ f₂ g : power_series R) :
 compose (f₁ + f₂) g = compose f₁ g + compose f₂ g :=
begin
 ext n,rw[(coeff n).map_add,coeff_compose,coeff_compose,coeff_compose],
 rw[← sum_add_distrib],congr,ext j,
 rw[(coeff _).map_add,add_mul],
end

/- `f ∘ g` is a multiplicative function of `f`. -/
lemma mul_compose (f₁ f₂ g : power_series R) (hg : coeff 0 g = 0):
 compose (f₁ * f₂) g = compose f₁ g * compose f₂ g :=
begin
 ext n,
 let r := range n.succ,
 let r2 := r.product r,
 let r3 := r.product r2,
 let r3' := r2.product r,
 let t₁ : (ℕ × ℕ × ℕ) → R :=
  λ jpq, coeff jpq.2.1 f₁ * coeff jpq.2.2 f₂ *
          coeff jpq.1 (g ^ jpq.2.1) * coeff (n - jpq.1) (g ^ jpq.2.2),
 let t'₁ := λ pqj : ((ℕ × ℕ) × ℕ), t₁ ⟨pqj.2,pqj.1⟩,
 let inc₁ : ∀ (k : ℕ), ℕ ↪ (ℕ × ℕ) := λ k, {
    to_fun := λ p, ⟨p,k - p⟩, inj' := λ p₁ p₂ e, congr_arg prod.fst e,
 },
 let r2' := r.bUnion (λ k, (range k.succ).map (inc₁ k)),
 have r2_filter : r2' = r2.filter (λ pq, pq.1 + pq.2 ≤ n) := by {
  ext ⟨p,q⟩,rw[mem_bUnion,mem_filter,mem_product,mem_range_succ,mem_range_succ],
  simp only [],split,
  {rintro ⟨k,k_le,hk⟩,rcases mem_map.mp hk with ⟨p',p_le,hpq⟩,
   injection hpq with hp hq,rw[hp] at p_le hq,
   replace k_le := mem_range_succ.mp k_le,
   replace p_le := mem_range_succ.mp p_le,
   repeat {split}; apply le_trans _ k_le,
   {exact p_le},
   {rw[← hq],apply tsub_le_self},
   {rw[← hq,nat.add_sub_of_le p_le]}
  },
  {rintro ⟨⟨p_le,q_le⟩,k_le⟩,
   use p + q,use mem_range_succ.mpr k_le,
   apply mem_map.mpr,use p,use mem_range_succ.mpr (nat.le_add_right p q),
   show prod.mk p ((p + q) - p) = prod.mk p q,
   congr,rw[add_comm,nat.add_sub_cancel],
  }
 },
 let e₁ := calc
  coeff n (compose (f₁ * f₂) g) =
    r.sum (λ k, coeff k (f₁ * f₂) * (coeff n (g ^ k))) : by rw[coeff_compose]
  ... = r.sum (λ k, (range k.succ).sum (λ p, coeff p f₁ * coeff (k - p) f₂ * coeff n (g ^ k))) :
   by {apply sum_congr rfl,intros k k_le,rw[coeff_mul,sum_mul],}
  ... = r2'.sum (λ pq, coeff pq.1 f₁ * coeff pq.2 f₂ * coeff n (g ^ (pq.1 + pq.2))) :
   by {rw[sum_bUnion],apply sum_congr rfl,intros k k_le,
       rw[sum_map],{
         apply sum_congr rfl,intros p p_le,dsimp[inc₁],
         replace p_le : p ≤ k := mem_range_succ.mp p_le,
         rw[nat.add_sub_of_le p_le],
       },{-- side condition for sum_map
         intros k₁ k₁_le k₂ k₂_le k_ne,
         change disjoint _ _, simp only [],
         rw [disjoint, le_bot_iff],
         apply eq_empty_iff_forall_not_mem.mpr,rintros ⟨p,q⟩ hpq,
         change _ ∈ _ ∩ _ at hpq,
         rw[mem_inter] at hpq,
         rcases mem_map.mp hpq.1 with ⟨p₁,p₁_le,hpq₁⟩,injection hpq₁ with hp₁ hq₁,
         rcases mem_map.mp hpq.2 with ⟨p₂,p₂_le,hpq₂⟩,injection hpq₂ with hp₂ hq₂,
         replace p₁_le := mem_range_succ.mp p₁_le,
         replace p₂_le := mem_range_succ.mp p₂_le,
         rw[← nat.add_sub_of_le p₁_le,← nat.add_sub_of_le p₂_le,hq₁,hq₂,hp₁,hp₂] at k_ne,
         exact k_ne rfl,
       }
   }
  ... = r2.sum (λ pq, coeff pq.1 f₁ * coeff pq.2 f₂ * coeff n (g ^ (pq.1 + pq.2))) :
   by {
     rw[r2_filter,sum_filter],apply sum_congr rfl,rintros ⟨p,q⟩ hpq,
     split_ifs,refl,
     replace h : n < p + q := lt_of_not_ge h,
     have := val_ge_pow' hg (p + q),dsimp[val_ge] at this,rw[this h,mul_zero],
   }
  ... = r2.sum (λ pq,r.sum (λ j, t₁ ⟨j,pq⟩)) :
   by {dsimp[t₁],
       apply finset.sum_congr rfl,rintros ⟨p,q⟩ hpq,rw[pow_add,coeff_mul,mul_sum],
       apply finset.sum_congr rfl,rintros j hj,repeat {rw[mul_assoc]},}
  ... = r3'.sum t'₁ :
   by {dsimp[r3'],rw[@sum_product _ _ _ _ r2 r],}
   ,rw[e₁],clear e₁,
 let e₂ := calc
  coeff n (compose f₁ g * compose f₂ g) =
   r.sum (λ j, coeff j (compose f₁ g) * coeff (n - j) (compose f₂ g)) :
    by rw[coeff_mul]
   ... = r.sum (λ j,   r.sum (λ p, coeff p f₁ * coeff j (g ^ p))
                     * r.sum (λ q, coeff q f₂ * coeff (n - j) (g ^ q))) :
    by {apply sum_congr rfl,intros j j_le,
     replace j_le := mem_range_succ.mp j_le,
     rw[coeff_compose_extra f₁ g hg j_le],
     have : n - j ≤ n := tsub_le_self,
     rw[coeff_compose_extra f₂ g hg this],
    }
   ... = r.sum (λ j, r.sum (λ p, coeff p f₁ * coeff j (g ^ p) *
           r.sum (λ q, coeff q f₂ * coeff (n - j) (g ^ q)))) :
    by {apply sum_congr rfl,intros j j_le,rw[sum_mul]}
   ... = r.sum (λ j, r.sum (λ p, r.sum (λ q,
          coeff p f₁ * coeff j (g ^ p) * (coeff q f₂ * coeff (n - j) (g ^ q))))) :
    by {apply sum_congr rfl,intros j j_le,
        apply sum_congr rfl,intros k k_le,rw[mul_sum]}
   ... = r.sum (λ j, r.sum (λ p, r.sum (λ q, t₁ ⟨j,p,q⟩))) :
    by {apply sum_congr rfl,intros j j_le,
        apply sum_congr rfl,intros k k_le,
        apply sum_congr rfl,intros p p_le,
        rw[mul_assoc,← mul_assoc (coeff j (g ^ k)),mul_comm (coeff j (g ^ k))],
        rw[← mul_assoc,← mul_assoc],}
   ... = r.sum (λ j, r2.sum (λ pq, t₁ ⟨j,pq⟩)) :
    by {apply sum_congr rfl,intros j j_le,rw[sum_product],}
   ... = r3.sum t₁ : by rw[← sum_product],
  rw[e₂], clear e₂,
  let s := λ (jpq : ℕ × ℕ × ℕ) (h : jpq ∈ r3), prod.mk jpq.2 jpq.1,
  let e := @sum_bij _ _ _ _ r3 r3' t₁ t'₁ s
   (λ ⟨j,p,q⟩ h, by {dsimp[s],repeat {rw[mem_product] at h ⊢},
                    rcases h with ⟨hj,hp,hq⟩,repeat {split}; assumption,})
   (λ ⟨j,p,q⟩ h, rfl)
   (λ ⟨j₁,p₁,q₁⟩ ⟨j₂,p₂,q₂⟩ h₁ h₂ e,
      by {dsimp[s] at e,injection e with epq ej,injection epq with ep eq,
          rw[ej,ep,eq],})
   (λ ⟨⟨p,q⟩,j⟩ h,
      by {use ⟨j,p,q⟩,have : (⟨j,p,q⟩ : ℕ × ℕ × ℕ) ∈ r3,
           {repeat {rw[mem_product] at h ⊢},
            rcases h with ⟨⟨hp,hq⟩,hj⟩,repeat {split}; assumption,},
            use this}),
  exact e.symm,
end

lemma C_compose (a : R) (g : power_series R) : compose (C a) g = C a :=
begin
 ext n,rw[coeff_compose],
 let f := λ (j : ℕ), coeff j (C a) * coeff n (g ^ j),
 change (range n.succ).sum f = coeff n (C a),
 have : f 0 = coeff n (C a) :=
  by {dsimp[f],rw[pow_zero,coeff_zero_C,coeff_n_one,coeff_n_C],
      split_ifs,rw[mul_one],rw[mul_zero]},
 rw[← this],apply sum_eq_single,
 {intros j h_le h_ne,rw[coeff_n_C,if_neg h_ne.symm,zero_mul]},
 {intro h,exfalso,exact h (mem_range_succ.mpr (nat.zero_le n))}
end

lemma X_compose (a : R) (g : power_series R) (hg : coeff 0 g = 0) : compose X g = g :=
begin
 ext n,rw[coeff_compose],
 let f := λ (j : ℕ), coeff j X * coeff n (g ^ j),
 change (range n.succ).sum f = coeff n g,
 have : f 1 = coeff n g :=
  by {dsimp[f],rw[coeff_one_X,pow_one,one_mul]},
 rw[← this],apply sum_eq_single,
 {intros j h_le h_ne,rw[coeff_n_X,if_neg h_ne.symm,zero_mul]},
 {cases n with n,
  {intro h,rw[pow_one,hg,mul_zero]},
  {intro h,exfalso,
   exact h (mem_range_succ.mpr (nat.succ_le_succ (nat.zero_le n))),
  }}
end

end compose
end power_series


/-
Copyright (c) 2020 David Wärn. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: David Wärn
-/
import order.ideal
import data.finset

/-!
# The back and forth method and countable dense linear orders

## Results

Suppose `α β` are linear orders, with `α` countable and `β` dense, nonempty, without endpoints.
Then there is an order embedding `α ↪ β`. If in addition `α` is dense, nonempty, without
endpoints and `β` is countable, then we can upgrade this to an order isomorhpism `α ≃ β`.

The idea for both results is to consider "partial isomorphisms", which
identify a finite subset of `α` with a finite subset of `β`, and prove that
for any such partial isomorphism `f` and `a : α`, we can extend `f` to
include `a` in its domain.

## References

https://en.wikipedia.org/wiki/Back-and-forth_method

## Tags

back and forth, dense, countable, order

-/

noncomputable theory
open_locale classical

namespace order

/-- Suppose `α` is a nonempty dense linear order without endpoints, and
    suppose `lo`, `hi`, are finite subssets with all of `lo` strictly
    before `hi`. Then there is an element of `α` strictly between `lo`
    and `hi`. -/
lemma exists_between_finsets {α : Type*} [linear_order α]
  [densely_ordered α] [no_bot_order α] [no_top_order α] [nonem : nonempty α]
  (lo hi : finset α) (lo_lt_hi : ∀ (x ∈ lo) (y ∈ hi), x < y) :
  ∃ m : α, (∀ x ∈ lo, x < m) ∧ (∀ y ∈ hi, m < y) :=
if nlo : lo.nonempty then
  if nhi : hi.nonempty then -- both sets are nonempty, use densely_ordered
    exists.elim (exists_between (lo_lt_hi _ (finset.max'_mem _ nlo) _ (finset.min'_mem _ nhi)))
      (λ m hm, ⟨m, λ x hx, lt_of_le_of_lt (finset.le_max' lo x hx) hm.1,
                   λ y hy, lt_of_lt_of_le hm.2 (finset.min'_le hi y hy)⟩)
  else -- upper set is empty, use no_top_order
    exists.elim (no_top (finset.max' lo nlo)) (λ m hm,
    ⟨m, λ x hx, lt_of_le_of_lt (finset.le_max' lo x hx) hm,
        λ y hy, (nhi ⟨y, hy⟩).elim⟩)
else
  if nhi : hi.nonempty then -- lower set is empty, use no_bot_order
    exists.elim (no_bot (finset.min' hi nhi)) (λ m hm,
    ⟨m, λ x hx, (nlo ⟨x, hx⟩).elim,
        λ y hy, lt_of_lt_of_le hm (finset.min'_le hi y hy)⟩)
  else -- both sets are empty, use nonempty
    nonem.elim (λ m,
    ⟨m, λ x hx, (nlo ⟨x, hx⟩).elim,
        λ y hy, (nhi ⟨y, hy⟩).elim⟩)

variables (α β : Type*) [linear_order α] [linear_order β]

/-- The type of partial order isomorphisms between `α` and `β` defined on finite subsets.
    A partial order isomorphism is encoded as a finite subset of `α × β`, consisting
    of pairs which should be identified. -/
def partial_iso : Type* :=
{ f : finset (α × β) // ∀ (p q ∈ f),
  cmp (prod.fst p) (prod.fst q) = cmp (prod.snd p) (prod.snd q) }

namespace partial_iso

instance : inhabited (partial_iso α β) := ⟨⟨∅, λ p q h, h.elim⟩⟩
instance : preorder (partial_iso α β) := subtype.preorder _

variables {α β}

/-- For each `a`, we can find a `b` in the codomain, such that `a`'s relation to
the domain of `f` is `b`'s relation to the image of `f`.

Thus, if `a` is not already in `f`, then we can extend `f` by sending `a` to `b`.
-/
lemma exists_across [densely_ordered β] [no_bot_order β] [no_top_order β] [nonempty β]
  (f : partial_iso α β) (a : α) :
  ∃ b : β, ∀ (p ∈ f.val), cmp (prod.fst p) a = cmp (prod.snd p) b :=
begin
  by_cases h : ∃ b, (a, b) ∈ f.val,
  { cases h with b hb, exact ⟨b, λ p hp, f.property _ _ hp hb⟩, },
  have : ∀ (x ∈ (f.val.filter (λ (p : α × β), p.fst < a)).image prod.snd)
           (y ∈ (f.val.filter (λ (p : α × β), a < p.fst)).image prod.snd),
    x < y,
  { intros x hx y hy,
    rw finset.mem_image at hx hy,
    rcases hx with ⟨p, hp1, rfl⟩,
    rcases hy with ⟨q, hq1, rfl⟩,
    rw finset.mem_filter at hp1 hq1,
    rw ←lt_iff_lt_of_cmp_eq_cmp (f.property _ _ hp1.1 hq1.1),
    exact lt_trans hp1.right hq1.right, },
  cases exists_between_finsets _ _ this with b hb,
  use b,
  rintros ⟨p1, p2⟩ hp,
  have : p1 ≠ a := λ he, h ⟨p2, he ▸ hp⟩,
  cases lt_or_gt_of_ne this with hl hr,
  { have : p1 < a ∧ p2 < b := ⟨hl, hb.1 _ (finset.mem_image.mpr ⟨(p1, p2),
                        finset.mem_filter.mpr ⟨hp, hl⟩, rfl⟩)⟩,
    rw [←cmp_eq_lt_iff, ←cmp_eq_lt_iff] at this, cc, },
  { have : a < p1 ∧ b < p2 := ⟨hr, hb.2 _ (finset.mem_image.mpr ⟨(p1, p2),
                        finset.mem_filter.mpr ⟨hp, hr⟩, rfl⟩)⟩,
    rw [←cmp_eq_gt_iff, ←cmp_eq_gt_iff] at this, cc, },
end

/-- A partial isomorphism between `α` and `β` is also a partial isomorphism between `β` and `α`. -/
protected def comm : partial_iso α β → partial_iso β α :=
subtype.map (finset.image (equiv.prod_comm _ _)) $ λ f hf p q hp hq,
  eq.symm $ hf ((equiv.prod_comm α β).symm p) ((equiv.prod_comm α β).symm q)
(by { rw [←finset.mem_coe, finset.coe_image, equiv.image_eq_preimage] at hp, rwa ←finset.mem_coe })
(by { rw [←finset.mem_coe, finset.coe_image, equiv.image_eq_preimage] at hq, rwa ←finset.mem_coe })

variable (β)
/-- The set of partial isomorphisms defined at `a : α`, together with a proof that any
    partial isomorphism can be extended to one defined at `a`. -/
def defined_at_left [densely_ordered β] [no_bot_order β] [no_top_order β] [nonempty β]
  (a : α) : cofinal (partial_iso α β) :=
{ carrier := λ f, ∃ b : β, (a, b) ∈ f.val,
  mem_gt :=
  begin
    intro f,
    cases exists_across f a with b a_b,
    refine ⟨⟨insert (a, b) f.val, _⟩, ⟨b, finset.mem_insert_self _ _⟩, finset.subset_insert _ _⟩,
    intros p q hp hq,
    rw finset.mem_insert at hp hq,
    rcases hp with rfl | pf;
    rcases hq with rfl | qf,
    { simp },
    { rw cmp_eq_cmp_symm, exact a_b _ qf },
    { exact a_b _ pf },
    { exact f.property _ _ pf qf },
  end }

variables (α) {β}
/-- The set of partial isomorphisms defined at `b : β`, together with a proof that any
    partial isomorphism can be extended to include `b`. We prove this by symmetry. -/
def defined_at_right [densely_ordered α] [no_bot_order α] [no_top_order α] [nonempty α]
  (b : β) : cofinal (partial_iso α β) :=
{ carrier := λ f, ∃ a, (a, b) ∈ f.val,
  mem_gt :=
  begin
    intro f,
    rcases (defined_at_left α b).mem_gt f.comm with ⟨f', ⟨a, ha⟩, hl⟩,
    use f'.comm,
    split,
    { use a,
      change (a, b) ∈ f'.val.image _,
      rwa [←finset.mem_coe, finset.coe_image, equiv.image_eq_preimage] },
    { change _ ⊆ f'.val.image _,
      rw [←finset.coe_subset, finset.coe_image, equiv.subset_image],
      change f.val.image _ ⊆ _ at hl,
      rwa [←finset.coe_subset, finset.coe_image] at hl }
  end }

variable {α}

/-- Given an ideal which intersects `defined_at_left β a`, pick `b : β` such that
    some partial function in the ideal maps `a` to `b`. -/
def fun_of_ideal [densely_ordered β] [no_bot_order β] [no_top_order β] [nonempty β]
  (a : α) (I : ideal (partial_iso α β)) :
  (∃ f, f ∈ defined_at_left β a ∧ f ∈ I) → { b // ∃ f ∈ I, (a, b) ∈ subtype.val f } :=
classical.indefinite_description _ ∘ (λ ⟨f, ⟨b, hb⟩, hf⟩, ⟨b, f, hf, hb⟩)

/-- Given an ideal which intersects `defined_at_right α b`, pick `a : α` such that
    some partial function in the ideal maps `a` to `b`. -/
def inv_of_ideal [densely_ordered α] [no_bot_order α] [no_top_order α] [nonempty α]
  (b : β) (I : ideal (partial_iso α β)) :
  (∃ f, f ∈ defined_at_right α b ∧ f ∈ I) → { a // ∃ f ∈ I, (a, b) ∈ subtype.val f } :=
classical.indefinite_description _ ∘ (λ ⟨f, ⟨a, ha⟩, hf⟩, ⟨a, f, hf, ha⟩)

end partial_iso
open partial_iso

variables (α β)

/-- Any countable linear order embeds in any nonempty dense linear order without endpoints. -/
def embedding_from_countable_to_dense
  [encodable α] [densely_ordered β] [no_bot_order β] [no_top_order β] [nonempty β] :
  α ↪o β :=
let our_ideal : ideal (partial_iso α β) := ideal_of_cofinals (default _) (defined_at_left β) in
let F := λ a, fun_of_ideal a our_ideal (cofinal_meets_ideal_of_cofinals _ _ a) in
order_embedding.of_strict_mono (λ a, (F a).val)
begin
  intros a₁ a₂,
  rcases (F a₁).property with ⟨f, hf, ha₁⟩,
  rcases (F a₂).property with ⟨g, hg, ha₂⟩,
  rcases our_ideal.directed _ hf _ hg with ⟨m, hm, fm, gm⟩,
  exact (lt_iff_lt_of_cmp_eq_cmp $ m.property (a₁, _) (a₂, _) (fm ha₁) (gm ha₂)).mp
end

/-- Any two countable dense, nonempty linear orders without endpoints are order isomorphic. -/
def iso_of_countable_dense
  [encodable α] [densely_ordered α] [no_bot_order α] [no_top_order α] [nonempty α]
  [encodable β] [densely_ordered β] [no_bot_order β] [no_top_order β] [nonempty β] :
  α ≃o β :=
let to_cofinal : α ⊕ β → cofinal (partial_iso α β) :=
  λ p, sum.rec_on p (defined_at_left β) (defined_at_right α) in
let our_ideal : ideal (partial_iso α β) := ideal_of_cofinals (default _) to_cofinal in
let F := λ a, fun_of_ideal a our_ideal (cofinal_meets_ideal_of_cofinals _ to_cofinal (sum.inl a)) in
let G := λ b, inv_of_ideal b our_ideal (cofinal_meets_ideal_of_cofinals _ to_cofinal (sum.inr b)) in
order_iso.of_cmp_eq_cmp (λ a, (F a).val) (λ b, (G b).val)
begin
  intros a b,
  rcases (F a).property with ⟨f, hf, ha⟩,
  rcases (G b).property with ⟨g, hg, hb⟩,
  rcases our_ideal.directed _ hf _ hg with ⟨m, hm, fm, gm⟩,
  exact m.property (a, _) (_, b) (fm ha) (gm hb)
end

end order


/-
Copyright (c) 2018 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Jens Wagemaker, Anne Baanen
-/

import algebra.associated
import algebra.big_operators.basic
import data.finsupp.basic

/-!
# Products of associated, prime, and irreducible elements.

This file contains some theorems relating definitions in `algebra.associated`
and products of multisets, finsets, and finsupps.

-/

variables {α β γ δ : Type*}

-- the same local notation used in `algebra.associated`
local infix ` ~ᵤ ` : 50 := associated
open_locale big_operators

namespace prime

variables [comm_monoid_with_zero α] {p : α} (hp : prime p)

lemma exists_mem_multiset_dvd {s : multiset α} :
  p ∣ s.prod → ∃ a ∈ s, p ∣ a :=
multiset.induction_on s (λ h, (hp.not_dvd_one h).elim) $
λ a s ih h,
  have p ∣ a * s.prod, by simpa using h,
  match hp.dvd_or_dvd this with
  | or.inl h := ⟨a, multiset.mem_cons_self a s, h⟩
  | or.inr h := let ⟨a, has, h⟩ := ih h in ⟨a, multiset.mem_cons_of_mem has, h⟩
  end

include hp

lemma exists_mem_multiset_map_dvd {s : multiset β} {f : β → α} :
  p ∣ (s.map f).prod → ∃ a ∈ s, p ∣ f a :=
λ h, by simpa only [exists_prop, multiset.mem_map, exists_exists_and_eq_and]
  using hp.exists_mem_multiset_dvd h

lemma exists_mem_finset_dvd {s : finset β} {f : β → α} :
  p ∣ s.prod f → ∃ i ∈ s, p ∣ f i :=
hp.exists_mem_multiset_map_dvd

end prime

lemma exists_associated_mem_of_dvd_prod [cancel_comm_monoid_with_zero α] {p : α}
  (hp : prime p) {s : multiset α} : (∀ r ∈ s, prime r) → p ∣ s.prod → ∃ q ∈ s, p ~ᵤ q :=
multiset.induction_on s (by simp [mt is_unit_iff_dvd_one.2 hp.not_unit])
  (λ a s ih hs hps, begin
    rw [multiset.prod_cons] at hps,
    cases hp.dvd_or_dvd hps with h h,
    { have hap := hs a (multiset.mem_cons.2 (or.inl rfl)),
      exact ⟨a, multiset.mem_cons_self a _, hp.associated_of_dvd hap h⟩ },
    { rcases ih (λ r hr, hs _ (multiset.mem_cons.2 (or.inr hr))) h with ⟨q, hq₁, hq₂⟩,
      exact ⟨q, multiset.mem_cons.2 (or.inr hq₁), hq₂⟩ }
  end)

lemma multiset.prod_primes_dvd
  [cancel_comm_monoid_with_zero α] [Π a : α, decidable_pred (associated a)]
  {s : multiset α} (n : α) (h : ∀ a ∈ s, prime a) (div : ∀ a ∈ s, a ∣ n)
  (uniq : ∀ a, s.countp (associated a) ≤ 1) :
  s.prod ∣ n :=
begin
  induction s using multiset.induction_on with a s induct n primes divs generalizing n,
  { simp only [multiset.prod_zero, one_dvd] },
  { rw multiset.prod_cons,
    obtain ⟨k, rfl⟩ : a ∣ n := div a (multiset.mem_cons_self a s),
    apply mul_dvd_mul_left a,
    refine induct
      (λ a ha, h a (multiset.mem_cons_of_mem ha))
      (λ a, (multiset.countp_le_of_le _ (multiset.le_cons_self _ _)).trans (uniq a))
      k (λ b b_in_s, _),
    { have b_div_n := div b (multiset.mem_cons_of_mem b_in_s),
      have a_prime := h a (multiset.mem_cons_self a s),
      have b_prime := h b (multiset.mem_cons_of_mem b_in_s),
      refine (b_prime.dvd_or_dvd b_div_n).resolve_left (λ b_div_a, _),
      have assoc := b_prime.associated_of_dvd a_prime b_div_a,
      have := uniq a,
      rw [multiset.countp_cons_of_pos _ (associated.refl _), nat.succ_le_succ_iff, ←not_lt,
        multiset.countp_pos] at this,
      exact this ⟨b, b_in_s, assoc.symm⟩ } }
end

lemma finset.prod_primes_dvd
  [cancel_comm_monoid_with_zero α] [unique αˣ]
  {s : finset α} (n : α) (h : ∀ a ∈ s, prime a) (div : ∀ a ∈ s, a ∣ n) :
  (∏ p in s, p) ∣ n :=
begin
  classical,
  exact multiset.prod_primes_dvd n
    (by simpa only [multiset.map_id', finset.mem_def] using h)
    (by simpa only [multiset.map_id', finset.mem_def] using div)
    (by simp only [multiset.map_id', associated_eq_eq, multiset.countp_eq_card_filter,
        ←multiset.count_eq_card_filter_eq, ←multiset.nodup_iff_count_le_one, s.nodup]),
end

namespace associates

section comm_monoid

variables [comm_monoid α]

theorem prod_mk {p : multiset α} : (p.map associates.mk).prod = associates.mk p.prod :=
multiset.induction_on p (by simp) $ λ a s ih, by simp [ih, associates.mk_mul_mk]

theorem finset_prod_mk {p : finset β} {f : β → α} :
  ∏ i in p, associates.mk (f i) = associates.mk (∏ i in p, f i) :=
by rw [finset.prod_eq_multiset_prod, ← multiset.map_map, prod_mk, ← finset.prod_eq_multiset_prod]

theorem rel_associated_iff_map_eq_map {p q : multiset α} :
  multiset.rel associated p q ↔ p.map associates.mk = q.map associates.mk :=
by { rw [← multiset.rel_eq, multiset.rel_map], simp only [mk_eq_mk_iff_associated] }

theorem prod_eq_one_iff {p : multiset (associates α)} :
  p.prod = 1 ↔ (∀a ∈ p, (a:associates α) = 1) :=
multiset.induction_on p
  (by simp)
  (by simp [mul_eq_one_iff, or_imp_distrib, forall_and_distrib] {contextual := tt})

theorem prod_le_prod {p q : multiset (associates α)} (h : p ≤ q) : p.prod ≤ q.prod :=
begin
  haveI := classical.dec_eq (associates α),
  haveI := classical.dec_eq α,
  suffices : p.prod ≤ (p + (q - p)).prod, { rwa [add_tsub_cancel_of_le h] at this },
  suffices : p.prod * 1 ≤ p.prod * (q - p).prod, { simpa },
  exact mul_mono (le_refl p.prod) one_le
end

end comm_monoid

section cancel_comm_monoid_with_zero

variables [cancel_comm_monoid_with_zero α]

lemma exists_mem_multiset_le_of_prime {s : multiset (associates α)} {p : associates α}
  (hp : prime p) :
  p ≤ s.prod → ∃a∈s, p ≤ a :=
multiset.induction_on s (assume ⟨d, eq⟩, (hp.ne_one (mul_eq_one_iff.1 eq.symm).1).elim) $
assume a s ih h,
  have p ≤ a * s.prod, by simpa using h,
  match prime.le_or_le hp this with
  | or.inl h := ⟨a, multiset.mem_cons_self a s, h⟩
  | or.inr h := let ⟨a, has, h⟩ := ih h in ⟨a, multiset.mem_cons_of_mem has, h⟩
  end

end cancel_comm_monoid_with_zero

end associates

namespace multiset

lemma prod_ne_zero_of_prime [cancel_comm_monoid_with_zero α] [nontrivial α]
 (s : multiset α) (h : ∀ x ∈ s, prime x) : s.prod ≠ 0 :=
multiset.prod_ne_zero (λ h0, prime.ne_zero (h 0 h0) rfl)

end multiset

open finset finsupp

section comm_monoid_with_zero

variables {M : Type*} [comm_monoid_with_zero M]

lemma prime.dvd_finset_prod_iff {S : finset α} {p : M} (pp : prime p) (g : α → M) :
  p ∣ S.prod g ↔ ∃ a ∈ S, p ∣ g a :=
⟨pp.exists_mem_finset_dvd, λ ⟨a, ha1, ha2⟩, dvd_trans ha2 (dvd_prod_of_mem g ha1)⟩

lemma prime.dvd_finsupp_prod_iff  {f: α →₀ M} {g : α → M → ℕ} {p : ℕ} (pp : prime p) :
  p ∣ f.prod g ↔ ∃ a ∈ f.support, p ∣ g a (f a) :=
prime.dvd_finset_prod_iff pp _

end comm_monoid_with_zero


import tactic natree.natree

namespace chapter3

  --equational "axioms"
  @[simp] def kernel {y z} : △⬝△⬝y⬝z = y := natree.kernel
  @[simp] def stem {x y z} : △⬝(△⬝x)⬝y⬝z = y⬝z⬝(x⬝z) := natree.stem
  @[simp] def fork {w x y z} : △⬝(△⬝w⬝x)⬝y⬝z = z⬝w⬝x := natree.fork

  --------------------------------------------------------------------

  --Definitions introduced in this chapter:

  --Fundamental Combinators
  def K := △⬝△
  lemma K_prop {a b} : K⬝a⬝b = a := by simp [K]

  def I := △⬝K⬝K
  lemma I_prop {x} : I⬝x = x := by simp [I, K]

  def D := △⬝K⬝(K⬝△)
  lemma D_prop {x y z} : D⬝x⬝y⬝z = y⬝z⬝(x⬝z) := by simp [D, K]

  def d (x) := △⬝(△⬝x)
  lemma d_prop {x y z} : (d x)⬝y⬝z = y⬝z⬝(x⬝z) := by simp [d]

  def S := (d (K⬝D))⬝((d K)⬝(K⬝D))
  lemma S_prop {x y z} : S⬝x⬝y⬝z = x⬝z⬝(y⬝z) := by simp [S, d, D, K]

  --Programs
  inductive is_program : 𝕋 → Prop
  | kernel : is_program △
  | stem {a} (h : is_program a) : is_program (△⬝a)
  | fork {a b} (h₁ : is_program a) (h₂ : is_program b) : is_program (△⬝a⬝b)

  def program := {t : 𝕋 // is_program t}

  --Propositional Logic
  def true := K
  def false := K⬝I

  def and := d (K⬝(K⬝I))
  def or := (d (K⬝K))⬝I
  def implies := d (K⬝K)
  def not := (d (K⬝K))⬝((d (K⬝(K⬝I)))⬝I)
  def iff := △⬝(△⬝I⬝not)⬝△

  --Pairs
  def Pair := △

  def first (p) := △⬝p⬝△⬝K
  def second (p) := △⬝p⬝△⬝(K⬝I)

  --Iterated Application
  def iterate : ℕ → 𝕋 → 𝕋 → 𝕋
  | 0 a b := b
  | (n+1) a b := a⬝(iterate n a b)

  notation a ^ n ⬝ b := iterate n a b

  --Natural Numbers
  def nat_to_natree (n) := K^n⬝△

  def zero := △
  def successor := K
  def isZero := (d (K^4⬝I))⬝((d (K⬝K))⬝△)
  def predecessor := (d (K^2⬝I))⬝((d (K⬝△))⬝△)

  --Fundamental Queries
  def query (is0 is1 is2) := (d (K⬝is1))⬝((d (K^2⬝I))⬝((d (K^5⬝is2))⬝((d (K^3⬝is0))⬝△)))
  def isLeaf := query K (K⬝I) (K⬝I)
  def isStem := query (K⬝I) K (K⬝I)
  def isFork := query (K⬝I) (K⬝I) K

  --------------------------------------------------------------------

  --Exercise 1
  lemma K_prop {x y} : K⬝x⬝y = x := by simp [K]
  lemma S_prop {x y z} : S⬝x⬝y⬝z = x⬝z⬝(y⬝z) := by simp [S, d, D, K]

  def D'_deriv : {D' // ∀ x y z, D'⬝x⬝y⬝z = y⬝z⬝(x⬝z)} := begin
    split,
    intros x y z,

    rw ←S_prop,

    apply congr,
    apply congr,
    refl,

    symmetry,
    transitivity,
    apply congr,
    refl,
    symmetry,
    apply K_prop,
    exact y,
    symmetry,

    rw ←S_prop,

    apply congr,
    apply congr,
    refl,

    symmetry,
    transitivity,
    apply congr,
    apply congr,
    refl,
    symmetry,
    apply K_prop,
    exact x,
    refl,
    symmetry,

    symmetry,
    transitivity,
    symmetry,
    apply S_prop,
    symmetry,

    apply congr,
    apply congr,
    refl,

    repeat {refl},
  end
  def D' := S⬝(K⬝(S⬝S))⬝K
  example : D'_deriv.val = D' := rfl

  --Exercise 2
  example {y} : and⬝false⬝y = false := by simp [and, d, D, false, I, K]

  --Exercise 3
  example : or⬝true⬝true = true := by simp [or, d, D, true, false, I, K]
  example : or⬝true⬝false = true := by simp [or, d, D, true, false, I, K]
  example : or⬝false⬝true = true := by simp [or, d, D, true, false, I, K]
  example : or⬝false⬝false = false := by simp [or, d, D, true, false, I, K]

  example : implies⬝true⬝true = true := by simp [implies, d, D, true, false, I, K]
  example : implies⬝true⬝false = false := by simp [implies, d, D, true, false, I, K]
  example : implies⬝false⬝true = true := by simp [implies, d, D, true, false, I, K]
  example : implies⬝false⬝false = true := by simp [implies, d, D, true, false, I, K]

  example : not⬝true = false := by simp [not, d, D, true, false, I, K]
  example : not⬝false = true := by simp [not, d, D, true, false, I, K]

  example : iff⬝true⬝true = true := by simp [iff, not, d, D, true, false, I, K]
  example : iff⬝true⬝false = false := by simp [iff, not, d, D, true, false, I, K]
  example : iff⬝false⬝true = false := by simp [iff, not, d, D, true, false, I, K]
  example : iff⬝false⬝false = true := by simp [iff, not, d, D, true, false, I, K]

  --Exercise 4
  def fst_deriv : {fst // ∀ p, fst⬝p = first p} := begin
    split,
    intro p,
    rw first,

    symmetry,
    transitivity,
    symmetry,
    apply fork,
    exact △,
    symmetry,

    rw ←K,

    symmetry,
    transitivity,
    apply congr,
    apply congr,
    refl,
    symmetry,
    apply K_prop,
    exact p,
    refl,
    symmetry,

    symmetry,
    transitivity,
    symmetry,
    apply S_prop,
    symmetry,

    apply congr,
    apply congr,
    refl,

    repeat {refl},
  end
  def fst := S⬝(K⬝(△⬝(K⬝K)⬝△))⬝△
  example : fst_deriv.val = fst := rfl
  lemma fst_prop {x y} : fst⬝(Pair⬝x⬝y) = x := by simp [fst, Pair, S, d, D, K]

  def snd := S⬝(K⬝(△⬝(K⬝(K⬝I))⬝△))⬝△
  lemma snd_prop {x y} : snd⬝(Pair⬝x⬝y) = y := by simp [snd, Pair, S, d, D, I, K]

  --Exercise 5
  lemma predecessor_prop_1 : predecessor⬝zero = zero := by simp [predecessor, zero, d, iterate, I, K]
  lemma predecessor_prop_2 {n} : predecessor⬝(successor⬝n) = n := by simp [predecessor, successor, d, iterate, I, K]

  --Exercise 6
  def nat_to_natree' (n) := △^n⬝△

  def zero' := △
  example : nat_to_natree' 0 = zero := rfl

  def successor' := △
  example {n} : successor'⬝(nat_to_natree' n) = nat_to_natree' n.succ := rfl

  def isZero' := S⬝(S⬝△⬝(K⬝K))⬝(K⬝(K⬝I))
  example : isZero'⬝zero' = true := by simp [isZero', zero', true, S, d, D, I, K]
  example {n} : isZero'⬝(successor'⬝n) = false := by simp [isZero', successor', false, S, d, D, I, K]

  def predecessor' := S⬝(K⬝(△⬝(K⬝K)⬝△))⬝(S⬝(K⬝△)⬝(S⬝(S⬝isZero'⬝I)⬝(S⬝I⬝(K⬝△))))
  example : predecessor'⬝zero' = zero' := by simp [predecessor', zero', isZero', S, d, D, I, K]
  example {n} : predecessor'⬝(successor'⬝n) = n := by simp [predecessor', successor', isZero', S, d, D, I, K]

  --Exercise 7
  #reduce isLeaf
  def isLeafVal := (△⬝(△⬝(△⬝△⬝(△⬝△⬝(△⬝(△⬝△)⬝(△⬝△)))))⬝(△⬝(△⬝(△⬝△⬝(△⬝△⬝(△⬝(△⬝△)⬝(△⬝△)))))⬝(△⬝(△⬝(△⬝△⬝(△⬝△⬝(△⬝△⬝(△⬝△⬝(△⬝△⬝(△⬝△⬝(△⬝(△⬝△)⬝(△⬝△)))))))))⬝(△⬝(△⬝(△⬝△⬝(△⬝△⬝(△⬝△⬝(△⬝△)))))⬝△))))
  example : isLeafVal = isLeaf := rfl

  example : isLeafVal⬝△ = true := by simp [isLeafVal, true, K]
  example : isLeafVal⬝K = false := by simp [isLeafVal, false, K, I]
  example : isLeafVal⬝(K⬝△) = false := by simp [isLeafVal, false, K, I]

  --Exercise 8
  /-
  a(n) gives number of binary trees where depth <= n
  a(0) = 1
  a(n) = a(n-1) + a(n-1)^2 + 1

  b(n) gives number of binary trees where depth = n
  b(0) = 1
  b(n) = a(n-1)^2 + 1
  -/

end chapter3