import for_mathlib.closure
import o_minimal.o_minimal

/-
Construction of (o-minimal) structures of the type:
a subset of Rⁿ is definable if it is a finite union of sets of the form [...].

For example, the semialgebraic sets are the finite unions of sets of the form
{x ∈ Rⁿ | f(x) = 0, g₁(x) > 0, ..., gₖ(x) > 0}.
Semilinear sets and the "minimal" structure of sets definable in (R, <)
are also structures of this type.

Suppose D ("definable") and B ("basic") are classes of subsets of Rⁿ for each n
and the following conditions are satisfied.

* A set is definable if and only if it is a finite union of basic sets.
* Finite intersections of basic sets are definable.
* The complement of a basic set is definable.
* If A is a basic set then R × A and A × R are definable.
* {x ∈ Rⁿ | x₁ = xₙ} is definable.
* The projection of a basic set is definable.

Then D forms a structure on R.
Furthermore, if every basic subset of R¹ is tame,
then so is every definable subset.
(TODO: Last sentence above.)

-/

namespace o_minimal

open set
open_locale finvec

variables {R : Type*} (D B : Π ⦃n : ℕ⦄, set (set (finvec n R)))

/-- Standing hypotheses for this module. -/
structure finite_union_struc_hypotheses : Prop :=
(definable_iff_finite_union_basic :
  ∀ {n} {s : set (finvec n R)}, D s ↔ s ∈ finite_union_closure (@B n))
(definable_univ :
  ∀ {n}, D (set.univ : set (finvec n R)))
(definable_basic_inter_basic :
  ∀ {n} {s t : set (finvec n R)}, B s → B t → D (s ∩ t))
(definable_compl_basic :
  ∀ {n} {s : set (finvec n R)}, B s → D sᶜ)
(definable_r_prod_basic :
  ∀ {n} {s : set (finvec n R)}, B s → D (finvec.univ_prod 1 s))
(definable_basic_prod_r :
  ∀ {n} {s : set (finvec n R)}, B s → D (finvec.prod_univ s 1))
(definable_eq_outer :
  ∀ {n}, D ({x | x 0 = x.last} : set (finvec (n + 1) R)))
(definable_proj1_basic :
  ∀ {n} {s : set (finvec (n + 1) R)}, B s → D (finvec.left '' s))

variables {D B}

section struc

variables (H : finite_union_struc_hypotheses D B)
include H

lemma finite_union_struc_hypotheses.D_eq_finite_union_closure_B :
  D = λ n, finite_union_closure (@B n) :=
by { ext, apply H.definable_iff_finite_union_basic }

/--
Suppose Φ : set (finvec n R) → set (finvec m R) is an operation
which commutes with finite unions.
Then if (s ∈ B → Φ s ∈ D) then (s ∈ D → Φ s ∈ D).
Examples of Φ: product with R¹ on either side; projection.

Only uses the assumption `D = finite_union_closure B`.
TODO: Generalize this to the setting of for_mathlib.closure.
-/
lemma finite_union_struc_hypotheses.promote_hypothesis {n m : ℕ}
  (Φ : set (finvec n R) → set (finvec m R)) (hΦ₀ : Φ ∅ = ∅)
  (hΦ₂ : ∀ {s t}, Φ (s ∪ t) = Φ s ∪ Φ t) :
  (∀ ⦃s : set (finvec n R)⦄, B s → D (Φ s)) →
  (∀ ⦃s : set (finvec n R)⦄, D s → D (Φ s)) :=
begin
  cases H.D_eq_finite_union_closure_B,
  intros h,
  apply finite_union_closure.rec,
  { exact @h },
  { rw hΦ₀, apply finite_union_closure.empty },
  { rintros s t - - hs ht,
    rw hΦ₂,
    apply hs.union ht }
end

/-- The structure obtained from the hypotheses `finite_union_struc_hypotheses D B`.
By definition, the definable sets are given by `D`. -/
def struc_of_finite_union : struc R :=
{ definable := D,
  definable_empty := begin
    cases H.D_eq_finite_union_closure_B,
    intro n,
    exact finite_union_closure.empty
  end,
  definable_union := begin
    cases H.D_eq_finite_union_closure_B,
    intros _ _ _ hs ht,
    exact hs.union ht
  end,
  definable_compl := begin
    cases H.D_eq_finite_union_closure_B,
    intros n s hs,
    apply closed_under_complements_finite_union_closure,
    { apply H.definable_univ },
    { apply H.definable_basic_inter_basic },
    { apply H.definable_compl_basic },
    { exact hs }
  end,
  definable_r_prod := begin
    intro n,
    refine H.promote_hypothesis (λ s, finvec.univ_prod 1 s) _ _ (λ s h, H.definable_r_prod_basic h);
    intros; ext; simp [finvec.univ_prod]
  end,
  definable_prod_r := begin
    intro n,
    refine H.promote_hypothesis (λ s, finvec.prod_univ s 1) _ _ (λ s h, H.definable_basic_prod_r h);
    intros; ext; simp [finvec.prod_univ],
  end,
  definable_eq_outer := H.definable_eq_outer,
  definable_proj1 := begin
    intro n,
    refine H.promote_hypothesis (λ s, finvec.left '' s) _ _ (λ s h, H.definable_proj1_basic h);
    intros; ext; simp [image_union]
  end }

end struc

section o_minimal

variables (D B) [DUNLO R]

structure finite_union_o_minimal_hypotheses extends finite_union_struc_hypotheses D B : Prop :=
(definable_lt : D {x : finvec 2 R | x 0 < x 1})
(definable_const : ∀ {r}, D {x : finvec 1 R | x 0 = r})
(tame_of_basic : ∀ {s : set (finvec 1 R)}, B s → tame {r | (λ _, r : finvec 1 R) ∈ s})

variables {D B} (H : finite_union_o_minimal_hypotheses D B)

lemma o_minimal_of_finite_union :
  o_minimal (struc_of_finite_union H.to_finite_union_struc_hypotheses : struc R) :=
o_minimal.mk' _ H.definable_lt H.definable_const $
begin
  change ∀ s, D s → _,
  cases H.to_finite_union_struc_hypotheses.D_eq_finite_union_closure_B,
  refine preserves_finite_unions.bind' _ closed_under_finite_unions_finite_union_closure _,
  { split; intros; simp; refl },
  exact H.tame_of_basic
end

end o_minimal

end o_minimal


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import group_theory.perm.support
import group_theory.order_of_element
import data.finset.fin
import data.int.order.units

/-!
# Sign of a permutation

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

The main definition of this file is `equiv.perm.sign`, associating a `ℤˣ` sign with a
permutation.

This file also contains miscellaneous lemmas about `equiv.perm` and `equiv.swap`, building on top
of those in `data/equiv/basic` and other files in `group_theory/perm/*`.

-/

universes u v
open equiv function fintype finset
open_locale big_operators
variables {α : Type u} {β : Type v}

-- An example on how to determine the order of an element of a finite group.
example : order_of (-1 : ℤˣ) = 2 :=
order_of_eq_prime (int.units_sq _) dec_trivial

namespace equiv.perm

/--
`mod_swap i j` contains permutations up to swapping `i` and `j`.

We use this to partition permutations in `matrix.det_zero_of_row_eq`, such that each partition
sums up to `0`.
-/
def mod_swap [decidable_eq α] (i j : α) : setoid (perm α) :=
⟨λ σ τ, σ = τ ∨ σ = swap i j * τ,
 λ σ, or.inl (refl σ),
 λ σ τ h, or.cases_on h (λ h, or.inl h.symm) (λ h, or.inr (by rw [h, swap_mul_self_mul])),
 λ σ τ υ hστ hτυ, by cases hστ; cases hτυ; try {rw [hστ, hτυ, swap_mul_self_mul]}; simp [hστ, hτυ] ⟩

instance {α : Type*} [fintype α] [decidable_eq α] (i j : α) : decidable_rel (mod_swap i j).r :=
λ σ τ, or.decidable

lemma perm_inv_on_of_perm_on_finset {s : finset α} {f : perm α}
  (h : ∀ x ∈ s, f x ∈ s) {y : α} (hy : y ∈ s) : f⁻¹ y ∈ s :=
begin
  have h0 : ∀ y ∈ s, ∃ x (hx : x ∈ s), y = (λ i (hi : i ∈ s), f i) x hx :=
    finset.surj_on_of_inj_on_of_card_le (λ x hx, (λ i hi, f i) x hx)
    (λ a ha, h a ha) (λ a₁ a₂ ha₁ ha₂ heq, (equiv.apply_eq_iff_eq f).mp heq) rfl.ge,
  obtain ⟨y2, hy2, heq⟩ := h0 y hy,
  convert hy2,
  rw heq,
  simp only [inv_apply_self]
end

lemma perm_inv_maps_to_of_maps_to (f : perm α) {s : set α} [finite s] (h : set.maps_to f s s) :
  set.maps_to (f⁻¹ : _) s s :=
by casesI nonempty_fintype s; exact λ x hx, set.mem_to_finset.mp $
  perm_inv_on_of_perm_on_finset
   (λ a ha, set.mem_to_finset.mpr (h (set.mem_to_finset.mp ha)))
   (set.mem_to_finset.mpr hx)

@[simp] lemma perm_inv_maps_to_iff_maps_to {f : perm α} {s : set α} [finite s] :
  set.maps_to (f⁻¹ : _) s s ↔ set.maps_to f s s :=
⟨perm_inv_maps_to_of_maps_to f⁻¹, perm_inv_maps_to_of_maps_to f⟩

lemma perm_inv_on_of_perm_on_finite {f : perm α} {p : α → Prop} [finite {x // p x}]
  (h : ∀ x, p x → p (f x)) {x : α} (hx : p x) : p (f⁻¹ x) :=
perm_inv_maps_to_of_maps_to f h hx

/-- If the permutation `f` maps `{x // p x}` into itself, then this returns the permutation
  on `{x // p x}` induced by `f`. Note that the `h` hypothesis is weaker than for
  `equiv.perm.subtype_perm`. -/
abbreviation subtype_perm_of_fintype (f : perm α) {p : α → Prop} [fintype {x // p x}]
  (h : ∀ x, p x → p (f x)) : perm {x // p x} :=
f.subtype_perm (λ x, ⟨h x, λ h₂, f.inv_apply_self x ▸ perm_inv_on_of_perm_on_finite h h₂⟩)

@[simp] lemma subtype_perm_of_fintype_apply (f : perm α) {p : α → Prop} [fintype {x // p x}]
  (h : ∀ x, p x → p (f x)) (x : {x // p x}) : subtype_perm_of_fintype f h x = ⟨f x, h x x.2⟩ := rfl

@[simp] lemma subtype_perm_of_fintype_one (p : α → Prop) [fintype {x // p x}]
  (h : ∀ x, p x → p ((1 : perm α) x)) : @subtype_perm_of_fintype α 1 p _ h = 1 :=
equiv.ext $ λ ⟨_, _⟩, rfl

lemma perm_maps_to_inl_iff_maps_to_inr {m n : Type*} [finite m] [finite n] (σ : perm (m ⊕ n)) :
  set.maps_to σ (set.range sum.inl) (set.range sum.inl) ↔
  set.maps_to σ (set.range sum.inr) (set.range sum.inr) :=
begin
  casesI nonempty_fintype m,
  casesI nonempty_fintype n,
  split; id
  { intros h,
    classical,
    rw ←perm_inv_maps_to_iff_maps_to at h,
    intro x,
    cases hx : σ x with l r, },
  { rintros ⟨a, rfl⟩,
    obtain ⟨y, hy⟩ := h ⟨l, rfl⟩,
    rw [←hx, σ.inv_apply_self] at hy,
    exact absurd hy sum.inl_ne_inr},
  { rintros ⟨a, ha⟩, exact ⟨r, rfl⟩, },
  { rintros ⟨a, ha⟩, exact ⟨l, rfl⟩, },
  { rintros ⟨a, rfl⟩,
    obtain ⟨y, hy⟩ := h ⟨r, rfl⟩,
    rw [←hx, σ.inv_apply_self] at hy,
    exact absurd hy sum.inr_ne_inl},
end

lemma mem_sum_congr_hom_range_of_perm_maps_to_inl {m n : Type*} [finite m] [finite n]
  {σ : perm (m ⊕ n)} (h : set.maps_to σ (set.range sum.inl) (set.range sum.inl)) :
  σ ∈ (sum_congr_hom m n).range :=
begin
  casesI nonempty_fintype m,
  casesI nonempty_fintype n,
  classical,
  have h1 : ∀ (x : m ⊕ n), (∃ (a : m), sum.inl a = x) → (∃ (a : m), sum.inl a = σ x),
  { rintros x ⟨a, ha⟩, apply h, rw ← ha, exact ⟨a, rfl⟩ },
  have h3 : ∀ (x : m ⊕ n), (∃ (b : n), sum.inr b = x) → (∃ (b : n), sum.inr b = σ x),
  { rintros x ⟨b, hb⟩,
    apply (perm_maps_to_inl_iff_maps_to_inr σ).mp h,
    rw ← hb, exact ⟨b, rfl⟩ },
  let σ₁' := subtype_perm_of_fintype σ h1,
  let σ₂' := subtype_perm_of_fintype σ h3,
  let σ₁ := perm_congr (equiv.of_injective _ sum.inl_injective).symm σ₁',
  let σ₂ := perm_congr (equiv.of_injective _ sum.inr_injective).symm σ₂',
  rw [monoid_hom.mem_range, prod.exists],
  use [σ₁, σ₂],
  rw [perm.sum_congr_hom_apply],
  ext,
  cases x with a b,
  { rw [equiv.sum_congr_apply, sum.map_inl, perm_congr_apply, equiv.symm_symm,
        apply_of_injective_symm sum.inl_injective],
    erw subtype_perm_apply,
    rw [of_injective_apply, subtype.coe_mk, subtype.coe_mk] },
  { rw [equiv.sum_congr_apply, sum.map_inr, perm_congr_apply, equiv.symm_symm,
        apply_of_injective_symm sum.inr_injective],
    erw subtype_perm_apply,
    rw [of_injective_apply, subtype.coe_mk, subtype.coe_mk] }
end

lemma disjoint.order_of {σ τ : perm α} (hστ : disjoint σ τ) :
  order_of (σ * τ) = nat.lcm (order_of σ) (order_of τ) :=
begin
  have h : ∀ n : ℕ, (σ * τ) ^ n = 1 ↔ σ ^ n = 1 ∧ τ ^ n = 1 :=
  λ n, by rw [hστ.commute.mul_pow, disjoint.mul_eq_one_iff (hστ.pow_disjoint_pow n n)],
  exact nat.dvd_antisymm hστ.commute.order_of_mul_dvd_lcm (nat.lcm_dvd
    (order_of_dvd_of_pow_eq_one ((h (order_of (σ * τ))).mp (pow_order_of_eq_one (σ * τ))).1)
    (order_of_dvd_of_pow_eq_one ((h (order_of (σ * τ))).mp (pow_order_of_eq_one (σ * τ))).2)),
end

lemma disjoint.extend_domain {α : Type*} {p : β → Prop} [decidable_pred p]
  (f : α ≃ subtype p) {σ τ : perm α} (h : disjoint σ τ) :
  disjoint (σ.extend_domain f) (τ.extend_domain f) :=
begin
  intro b,
  by_cases pb : p b,
  { refine (h (f.symm ⟨b, pb⟩)).imp _ _;
    { intro h,
      rw [extend_domain_apply_subtype _ _ pb, h, apply_symm_apply, subtype.coe_mk] } },
  { left,
    rw [extend_domain_apply_not_subtype _ _ pb] }
end

variable [decidable_eq α]

section fintype
variable [fintype α]

lemma support_pow_coprime {σ : perm α} {n : ℕ} (h : nat.coprime n (order_of σ)) :
  (σ ^ n).support = σ.support :=
begin
  obtain ⟨m, hm⟩ := exists_pow_eq_self_of_coprime h,
  exact le_antisymm (support_pow_le σ n) (le_trans (ge_of_eq (congr_arg support hm))
    (support_pow_le (σ ^ n) m)),
end

end fintype

/-- Given a list `l : list α` and a permutation `f : perm α` such that the nonfixed points of `f`
  are in `l`, recursively factors `f` as a product of transpositions. -/
def swap_factors_aux : Π (l : list α) (f : perm α), (∀ {x}, f x ≠ x → x ∈ l) →
  {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g}
| []       := λ f h, ⟨[], equiv.ext $ λ x, by { rw [list.prod_nil],
    exact (not_not.1 (mt h (list.not_mem_nil _))).symm }, by simp⟩
| (x :: l) := λ f h,
if hfx : x = f x
then swap_factors_aux l f
  (λ y hy, list.mem_of_ne_of_mem (λ h : y = x, by simpa [h, hfx.symm] using hy) (h hy))
else let m := swap_factors_aux l (swap x (f x) * f)
      (λ y hy, have f y ≠ y ∧ y ≠ x, from ne_and_ne_of_swap_mul_apply_ne_self hy,
        list.mem_of_ne_of_mem this.2 (h this.1)) in
  ⟨swap x (f x) :: m.1,
  by rw [list.prod_cons, m.2.1, ← mul_assoc,
    mul_def (swap x (f x)), swap_swap, ← one_def, one_mul],
  λ g hg, ((list.mem_cons_iff _ _ _).1 hg).elim (λ h, ⟨x, f x, hfx, h⟩) (m.2.2 _)⟩

/-- `swap_factors` represents a permutation as a product of a list of transpositions.
The representation is non unique and depends on the linear order structure.
For types without linear order `trunc_swap_factors` can be used. -/
def swap_factors [fintype α] [linear_order α] (f : perm α) :
  {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g} :=
swap_factors_aux ((@univ α _).sort (≤)) f (λ _ _, (mem_sort _).2 (mem_univ _))

/-- This computably represents the fact that any permutation can be represented as the product of
  a list of transpositions. -/
def trunc_swap_factors [fintype α] (f : perm α) :
  trunc {l : list (perm α) // l.prod = f ∧ ∀ g ∈ l, is_swap g} :=
quotient.rec_on_subsingleton (@univ α _).1
  (λ l h, trunc.mk (swap_factors_aux l f h))
  (show ∀ x, f x ≠ x → x ∈ (@univ α _).1, from λ _ _, mem_univ _)

/-- An induction principle for permutations. If `P` holds for the identity permutation, and
is preserved under composition with a non-trivial swap, then `P` holds for all permutations. -/
@[elab_as_eliminator] lemma swap_induction_on [finite α] {P : perm α → Prop} (f : perm α) :
  P 1 → (∀ f x y, x ≠ y → P f → P (swap x y * f)) → P f :=
begin
  casesI nonempty_fintype α,
  cases (trunc_swap_factors f).out with l hl,
  induction l with g l ih generalizing f,
  { simp only [hl.left.symm, list.prod_nil, forall_true_iff] {contextual := tt} },
  { assume h1 hmul_swap,
    rcases hl.2 g (by simp) with ⟨x, y, hxy⟩,
    rw [← hl.1, list.prod_cons, hxy.2],
    exact hmul_swap _ _ _ hxy.1
      (ih _ ⟨rfl, λ v hv, hl.2 _ (list.mem_cons_of_mem _ hv)⟩ h1 hmul_swap) }
end

lemma closure_is_swap [finite α] : subgroup.closure {σ : perm α | is_swap σ} = ⊤ :=
begin
  casesI nonempty_fintype α,
  refine eq_top_iff.mpr (λ x hx, _),
  obtain ⟨h1, h2⟩ := subtype.mem (trunc_swap_factors x).out,
  rw ← h1,
  exact subgroup.list_prod_mem _ (λ y hy, subgroup.subset_closure (h2 y hy)),
end

/-- Like `swap_induction_on`, but with the composition on the right of `f`.

An induction principle for permutations. If `P` holds for the identity permutation, and
is preserved under composition with a non-trivial swap, then `P` holds for all permutations. -/
@[elab_as_eliminator] lemma swap_induction_on' [finite α] {P : perm α → Prop} (f : perm α) :
  P 1 → (∀ f x y, x ≠ y → P f → P (f * swap x y)) → P f :=
λ h1 IH, inv_inv f ▸ swap_induction_on f⁻¹ h1 (λ f, IH f⁻¹)

lemma is_conj_swap {w x y z : α} (hwx : w ≠ x) (hyz : y ≠ z) : is_conj (swap w x) (swap y z) :=
is_conj_iff.2 (have h : ∀ {y z : α}, y ≠ z → w ≠ z →
      (swap w y * swap x z) * swap w x * (swap w y * swap x z)⁻¹ = swap y z :=
    λ y z hyz hwz, by rw [mul_inv_rev, swap_inv, swap_inv, mul_assoc (swap w y),
      mul_assoc (swap w y), ← mul_assoc _ (swap x z), swap_mul_swap_mul_swap hwx hwz,
      ← mul_assoc, swap_mul_swap_mul_swap hwz.symm hyz.symm],
  if hwz : w = z
  then have hwy : w ≠ y, by cc,
    ⟨swap w z * swap x y, by rw [swap_comm y z, h hyz.symm hwy]⟩
  else ⟨swap w y * swap x z, h hyz hwz⟩)

/-- set of all pairs (⟨a, b⟩ : Σ a : fin n, fin n) such that b < a -/
def fin_pairs_lt (n : ℕ) : finset (Σ a : fin n, fin n) :=
(univ : finset (fin n)).sigma (λ a, (range a).attach_fin
  (λ m hm, (mem_range.1 hm).trans a.2))

lemma mem_fin_pairs_lt {n : ℕ} {a : Σ a : fin n, fin n} :
  a ∈ fin_pairs_lt n ↔ a.2 < a.1 :=
by simp only [fin_pairs_lt, fin.lt_iff_coe_lt_coe, true_and, mem_attach_fin, mem_range, mem_univ,
  mem_sigma]

/-- `sign_aux σ` is the sign of a permutation on `fin n`, defined as the parity of the number of
  pairs `(x₁, x₂)` such that `x₂ < x₁` but `σ x₁ ≤ σ x₂` -/
def sign_aux {n : ℕ} (a : perm (fin n)) : ℤˣ :=
∏ x in fin_pairs_lt n, if a x.1 ≤ a x.2 then -1 else 1

@[simp] lemma sign_aux_one (n : ℕ) : sign_aux (1 : perm (fin n)) = 1 :=
begin
  unfold sign_aux,
  conv { to_rhs, rw ← @finset.prod_const_one ℤˣ _
    (fin_pairs_lt n) },
  exact finset.prod_congr rfl (λ a ha, if_neg (mem_fin_pairs_lt.1 ha).not_le)
end

/-- `sign_bij_aux f ⟨a, b⟩` returns the pair consisting of `f a` and `f b` in decreasing order. -/
def sign_bij_aux {n : ℕ} (f : perm (fin n)) (a : Σ a : fin n, fin n) :
  Σ a : fin n, fin n :=
if hxa : f a.2 < f a.1 then ⟨f a.1, f a.2⟩ else ⟨f a.2, f a.1⟩

lemma sign_bij_aux_inj {n : ℕ} {f : perm (fin n)} : ∀ a b : Σ a : fin n, fin n,
   a ∈ fin_pairs_lt n → b ∈ fin_pairs_lt n →
   sign_bij_aux f a = sign_bij_aux f b → a = b :=
λ ⟨a₁, a₂⟩ ⟨b₁, b₂⟩ ha hb h, begin
  unfold sign_bij_aux at h,
  rw mem_fin_pairs_lt at *,
  have : ¬b₁ < b₂ := hb.le.not_lt,
  split_ifs at h;
  simp only [*, (equiv.injective f).eq_iff, eq_self_iff_true, and_self, heq_iff_eq] at *,
end

lemma sign_bij_aux_surj {n : ℕ} {f : perm (fin n)} : ∀ a ∈ fin_pairs_lt n,
  ∃ b ∈ fin_pairs_lt n, a = sign_bij_aux f b :=
λ ⟨a₁, a₂⟩ ha,
if hxa : f⁻¹ a₂ < f⁻¹ a₁
then ⟨⟨f⁻¹ a₁, f⁻¹ a₂⟩, mem_fin_pairs_lt.2 hxa,
  by { dsimp [sign_bij_aux],
    rw [apply_inv_self, apply_inv_self, if_pos (mem_fin_pairs_lt.1 ha)] }⟩
else ⟨⟨f⁻¹ a₂, f⁻¹ a₁⟩, mem_fin_pairs_lt.2 $ (le_of_not_gt hxa).lt_of_ne $ λ h,
    by simpa [mem_fin_pairs_lt, (f⁻¹).injective h, lt_irrefl] using ha,
  by { dsimp [sign_bij_aux],
    rw [apply_inv_self, apply_inv_self, if_neg (mem_fin_pairs_lt.1 ha).le.not_lt] }⟩

lemma sign_bij_aux_mem {n : ℕ} {f : perm (fin n)} : ∀ a : Σ a : fin n, fin n,
  a ∈ fin_pairs_lt n → sign_bij_aux f a ∈ fin_pairs_lt n :=
λ ⟨a₁, a₂⟩ ha, begin
  unfold sign_bij_aux,
  split_ifs with h,
  { exact mem_fin_pairs_lt.2 h },
  { exact mem_fin_pairs_lt.2
    ((le_of_not_gt h).lt_of_ne (λ h, (mem_fin_pairs_lt.1 ha).ne (f.injective h.symm))) }
end

@[simp] lemma sign_aux_inv {n : ℕ} (f : perm (fin n)) : sign_aux f⁻¹ = sign_aux f :=
prod_bij (λ a ha, sign_bij_aux f⁻¹ a)
  sign_bij_aux_mem
  (λ ⟨a, b⟩ hab, if h : f⁻¹ b < f⁻¹ a
    then by rw [sign_bij_aux, dif_pos h, if_neg h.not_le, apply_inv_self,
      apply_inv_self, if_neg (mem_fin_pairs_lt.1 hab).not_le]
    else by rw [sign_bij_aux, if_pos (le_of_not_gt h), dif_neg h, apply_inv_self,
      apply_inv_self, if_pos (mem_fin_pairs_lt.1 hab).le])
  sign_bij_aux_inj
  sign_bij_aux_surj

lemma sign_aux_mul {n : ℕ} (f g : perm (fin n)) :
  sign_aux (f * g) = sign_aux f * sign_aux g :=
begin
  rw ← sign_aux_inv g,
  unfold sign_aux,
  rw ← prod_mul_distrib,
  refine prod_bij (λ a ha, sign_bij_aux g a) sign_bij_aux_mem _ sign_bij_aux_inj sign_bij_aux_surj,
  rintros ⟨a, b⟩ hab,
  rw [sign_bij_aux, mul_apply, mul_apply],
  rw mem_fin_pairs_lt at hab,
  by_cases h : g b < g a,
  { rw dif_pos h,
    simp only [not_le_of_gt hab, mul_one, perm.inv_apply_self, if_false] },
  { rw [dif_neg h, inv_apply_self, inv_apply_self, if_pos hab.le],
    by_cases h₁ : f (g b) ≤ f (g a),
    { have : f (g b) ≠ f (g a),
      { rw [ne.def, f.injective.eq_iff, g.injective.eq_iff],
        exact ne_of_lt hab },
      rw [if_pos h₁, if_neg (h₁.lt_of_ne this).not_le],
      refl },
    { rw [if_neg h₁, if_pos (lt_of_not_ge h₁).le],
      refl } }
end

private lemma sign_aux_swap_zero_one' (n : ℕ) :
  sign_aux (swap (0 : fin (n + 2)) 1) = -1 :=
show _ = ∏ x : Σ a : fin (n + 2), fin (n + 2) in {(⟨1, 0⟩ : Σ a : fin (n + 2), fin (n + 2))},
  if (equiv.swap 0 1) x.1 ≤ swap 0 1 x.2 then (-1 : ℤˣ) else 1,
begin
  refine eq.symm (prod_subset (λ ⟨x₁, x₂⟩,
    by simp [mem_fin_pairs_lt, fin.one_pos] {contextual := tt}) (λ a ha₁ ha₂, _)),
  rcases a with ⟨a₁, a₂⟩,
  replace ha₁ : a₂ < a₁ := mem_fin_pairs_lt.1 ha₁,
  dsimp only,
  rcases a₁.zero_le.eq_or_lt with rfl|H,
  { exact absurd a₂.zero_le ha₁.not_le },
  rcases a₂.zero_le.eq_or_lt with rfl|H',
  { simp only [and_true, eq_self_iff_true, heq_iff_eq, mem_singleton] at ha₂,
    have : 1 < a₁ := lt_of_le_of_ne (nat.succ_le_of_lt ha₁) (ne.symm ha₂),
    have h01 : equiv.swap (0 : fin (n + 2)) 1 0 = 1, by simp, -- TODO : fix properly
    norm_num [swap_apply_of_ne_of_ne (ne_of_gt H) ha₂, this.not_le, h01] },
  { have le : 1 ≤ a₂ := nat.succ_le_of_lt H',
    have lt : 1 < a₁ := le.trans_lt ha₁,
    have h01 : equiv.swap (0 : fin (n + 2)) 1 1 = 0, by simp, -- TODO
    rcases le.eq_or_lt with rfl|lt',
    { norm_num [swap_apply_of_ne_of_ne H.ne' lt.ne', H.not_le, h01] },
    { norm_num [swap_apply_of_ne_of_ne (ne_of_gt H) (ne_of_gt lt),
        swap_apply_of_ne_of_ne (ne_of_gt H') (ne_of_gt lt'), ha₁.not_le] } }
end

private lemma sign_aux_swap_zero_one {n : ℕ} (hn : 2 ≤ n) :
  sign_aux (swap (⟨0, lt_of_lt_of_le dec_trivial hn⟩ : fin n)
  ⟨1, lt_of_lt_of_le dec_trivial hn⟩) = -1 :=
begin
  rcases n with _|_|n,
  { norm_num at hn },
  { norm_num at hn },
  { exact sign_aux_swap_zero_one' n }
end

lemma sign_aux_swap : ∀ {n : ℕ} {x y : fin n} (hxy : x ≠ y),
  sign_aux (swap x y) = -1
| 0 := dec_trivial
| 1 := dec_trivial
| (n+2) := λ x y hxy,
have h2n : 2 ≤ n + 2 := dec_trivial,
by { rw [← is_conj_iff_eq, ← sign_aux_swap_zero_one h2n],
  exact (monoid_hom.mk' sign_aux sign_aux_mul).map_is_conj (is_conj_swap hxy dec_trivial) }

/-- When the list `l : list α` contains all nonfixed points of the permutation `f : perm α`,
  `sign_aux2 l f` recursively calculates the sign of `f`. -/
def sign_aux2 : list α → perm α → ℤˣ
| []     f := 1
| (x::l) f := if x = f x then sign_aux2 l f else -sign_aux2 l (swap x (f x) * f)

lemma sign_aux_eq_sign_aux2 {n : ℕ} : ∀ (l : list α) (f : perm α) (e : α ≃ fin n)
  (h : ∀ x, f x ≠ x → x ∈ l), sign_aux ((e.symm.trans f).trans e) = sign_aux2 l f
| []     f e h := have f = 1, from equiv.ext $
  λ y, not_not.1 (mt (h y) (list.not_mem_nil _)),
by rw [this, one_def, equiv.trans_refl, equiv.symm_trans_self, ← one_def,
  sign_aux_one, sign_aux2]
| (x::l) f e h := begin
  rw sign_aux2,
  by_cases hfx : x = f x,
  { rw if_pos hfx,
    exact sign_aux_eq_sign_aux2 l f _ (λ y (hy : f y ≠ y), list.mem_of_ne_of_mem
      (λ h : y = x, by simpa [h, hfx.symm] using hy) (h y hy) ) },
  { have hy : ∀ y : α, (swap x (f x) * f) y ≠ y → y ∈ l, from λ y hy,
      have f y ≠ y ∧ y ≠ x, from ne_and_ne_of_swap_mul_apply_ne_self hy,
      list.mem_of_ne_of_mem this.2 (h _ this.1),
    have : (e.symm.trans (swap x (f x) * f)).trans e =
      (swap (e x) (e (f x))) * (e.symm.trans f).trans e,
      by ext; simp [← equiv.symm_trans_swap_trans, mul_def],
    have hefx : e x ≠ e (f x), from mt e.injective.eq_iff.1 hfx,
    rw [if_neg hfx, ← sign_aux_eq_sign_aux2 _ _ e hy, this, sign_aux_mul, sign_aux_swap hefx],
    simp only [neg_neg, one_mul, neg_mul]}
end

/-- When the multiset `s : multiset α` contains all nonfixed points of the permutation `f : perm α`,
  `sign_aux2 f _` recursively calculates the sign of `f`. -/
def sign_aux3 [fintype α] (f : perm α) {s : multiset α} : (∀ x, x ∈ s) → ℤˣ :=
quotient.hrec_on s (λ l h, sign_aux2 l f)
  (trunc.induction_on (fintype.trunc_equiv_fin α)
    (λ e l₁ l₂ h, function.hfunext
      (show (∀ x, x ∈ l₁) = ∀ x, x ∈ l₂, by simp only [h.mem_iff])
      (λ h₁ h₂ _, by rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, h₁ _),
        ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, h₂ _)])))

lemma sign_aux3_mul_and_swap [fintype α] (f g : perm α) (s : multiset α) (hs : ∀ x, x ∈ s) :
  sign_aux3 (f * g) hs = sign_aux3 f hs * sign_aux3 g hs ∧ ∀ x y, x ≠ y →
  sign_aux3 (swap x y) hs = -1 :=
let ⟨l, hl⟩ := quotient.exists_rep s in
let e := equiv_fin α in
begin
  clear _let_match,
  subst hl,
  show sign_aux2 l (f * g) = sign_aux2 l f * sign_aux2 l g ∧
    ∀ x y, x ≠ y → sign_aux2 l (swap x y) = -1,
  have hfg : (e.symm.trans (f * g)).trans e = (e.symm.trans f).trans e * (e.symm.trans g).trans e,
    from equiv.ext (λ h, by simp [mul_apply]),
  split,
  { rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _),
      ← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), hfg, sign_aux_mul] },
  { assume x y hxy,
    have hexy : e x ≠ e y, from mt e.injective.eq_iff.1 hxy,
    rw [← sign_aux_eq_sign_aux2 _ _ e (λ _ _, hs _), symm_trans_swap_trans, sign_aux_swap hexy] }
end

/-- `sign` of a permutation returns the signature or parity of a permutation, `1` for even
permutations, `-1` for odd permutations. It is the unique surjective group homomorphism from
`perm α` to the group with two elements.-/
def sign [fintype α] : perm α →* ℤˣ := monoid_hom.mk'
(λ f, sign_aux3 f mem_univ) (λ f g, (sign_aux3_mul_and_swap f g _ mem_univ).1)

section sign

variable [fintype α]

@[simp] lemma sign_mul (f g : perm α) : sign (f * g) = sign f * sign g :=
monoid_hom.map_mul sign f g

@[simp] lemma sign_trans (f g : perm α) : sign (f.trans g) = sign g * sign f :=
by rw [←mul_def, sign_mul]

@[simp] lemma sign_one : (sign (1 : perm α)) = 1 :=
monoid_hom.map_one sign

@[simp] lemma sign_refl : sign (equiv.refl α) = 1 :=
monoid_hom.map_one sign

@[simp] lemma sign_inv (f : perm α) : sign f⁻¹ = sign f :=
by rw [monoid_hom.map_inv sign f, int.units_inv_eq_self]

@[simp] lemma sign_symm (e : perm α) : sign e.symm = sign e :=
sign_inv e

lemma sign_swap {x y : α} (h : x ≠ y) : sign (swap x y) = -1 :=
(sign_aux3_mul_and_swap 1 1 _ mem_univ).2 x y h

@[simp] lemma sign_swap' {x y : α} :
  (swap x y).sign = if x = y then 1 else -1 :=
if H : x = y then by simp [H, swap_self] else
by simp [sign_swap H, H]

lemma is_swap.sign_eq {f : perm α} (h : f.is_swap) : sign f = -1 :=
let ⟨x, y, hxy⟩ := h in hxy.2.symm ▸ sign_swap hxy.1

@[simp] lemma sign_symm_trans_trans [decidable_eq β] [fintype β] (f : perm α) (e : α ≃ β) :
  sign ((e.symm.trans f).trans e) = sign f :=
sign_aux3_symm_trans_trans f e mem_univ mem_univ

@[simp] lemma sign_trans_trans_symm [decidable_eq β] [fintype β] (f : perm β) (e : α ≃ β) :
  sign ((e.trans f).trans e.symm) = sign f :=
sign_symm_trans_trans f e.symm

lemma sign_prod_list_swap {l : list (perm α)}
  (hl : ∀ g ∈ l, is_swap g) : sign l.prod = (-1) ^ l.length :=
have h₁ : l.map sign = list.replicate l.length (-1) :=
  list.eq_replicate.2 ⟨by simp, λ u hu,
  let ⟨g, hg⟩ := list.mem_map.1 hu in
  hg.2 ▸ (hl _ hg.1).sign_eq⟩,
by rw [← list.prod_replicate, ← h₁, list.prod_hom _ (@sign α _ _)]

variable (α)

lemma sign_surjective [nontrivial α] : function.surjective (sign : perm α → ℤˣ) :=
λ a, (int.units_eq_one_or a).elim
  (λ h, ⟨1, by simp [h]⟩)
  (λ h, let ⟨x, y, hxy⟩ := exists_pair_ne α in
    ⟨swap x y, by rw [sign_swap hxy, h]⟩ )

variable {α}

lemma eq_sign_of_surjective_hom {s : perm α →* ℤˣ} (hs : surjective s) : s = sign :=
have ∀ {f}, is_swap f → s f = -1 :=
  λ f ⟨x, y, hxy, hxy'⟩, hxy'.symm ▸ by_contradiction (λ h,
    have ∀ f, is_swap f → s f = 1 := λ f ⟨a, b, hab, hab'⟩,
      by { rw [← is_conj_iff_eq, ← or.resolve_right (int.units_eq_one_or _) h, hab'],
        exact s.map_is_conj (is_conj_swap hab hxy) },
  let ⟨g, hg⟩ := hs (-1) in
  let ⟨l, hl⟩ := (trunc_swap_factors g).out in
  have ∀ a ∈ l.map s, a = (1 : ℤˣ) := λ a ha,
    let ⟨g, hg⟩ := list.mem_map.1 ha in hg.2 ▸ this _ (hl.2 _ hg.1),
  have s l.prod = 1,
    by rw [← l.prod_hom s, list.eq_replicate_length.2 this, list.prod_replicate, one_pow],
  by { rw [hl.1, hg] at this,
    exact absurd this dec_trivial }),
monoid_hom.ext $ λ f,
let ⟨l, hl₁, hl₂⟩ := (trunc_swap_factors f).out in
have hsl : ∀ a ∈ l.map s, a = (-1 : ℤˣ) := λ a ha,
  let ⟨g, hg⟩ := list.mem_map.1 ha in hg.2 ▸  this (hl₂ _ hg.1),
by rw [← hl₁, ← l.prod_hom s, list.eq_replicate_length.2 hsl, list.length_map,
     list.prod_replicate, sign_prod_list_swap hl₂]

lemma sign_subtype_perm (f : perm α) {p : α → Prop} [decidable_pred p]
  (h₁ : ∀ x, p x ↔ p (f x)) (h₂ : ∀ x, f x ≠ x → p x) : sign (subtype_perm f h₁) = sign f :=
let l := (trunc_swap_factors (subtype_perm f h₁)).out in
have hl' : ∀ g' ∈ l.1.map of_subtype, is_swap g' :=
  λ g' hg',
  let ⟨g, hg⟩ := list.mem_map.1 hg' in
  hg.2 ▸ (l.2.2 _ hg.1).of_subtype_is_swap,
have hl'₂ : (l.1.map of_subtype).prod = f,
  by rw [l.1.prod_hom of_subtype, l.2.1, of_subtype_subtype_perm _ h₂],
by { conv { congr, rw ← l.2.1, skip, rw ← hl'₂ },
  rw [sign_prod_list_swap l.2.2, sign_prod_list_swap hl', list.length_map] }

lemma sign_eq_sign_of_equiv [decidable_eq β] [fintype β] (f : perm α) (g : perm β)
  (e : α ≃ β) (h : ∀ x, e (f x) = g (e x)) : sign f = sign g :=
have hg : g = (e.symm.trans f).trans e, from equiv.ext $ by simp [h],
by rw [hg, sign_symm_trans_trans]

lemma sign_bij [decidable_eq β] [fintype β]
  {f : perm α} {g : perm β} (i : Π x : α, f x ≠ x → β)
  (h : ∀ x hx hx', i (f x) hx' = g (i x hx))
  (hi : ∀ x₁ x₂ hx₁ hx₂, i x₁ hx₁ = i x₂ hx₂ → x₁ = x₂)
  (hg : ∀ y, g y ≠ y → ∃ x hx, i x hx = y) :
  sign f = sign g :=
calc sign f = sign (subtype_perm f $ by simp : perm {x // f x ≠ x}) :
  (sign_subtype_perm _ _ (λ _, id)).symm
... = sign (subtype_perm g $ by simp : perm {x // g x ≠ x}) :
  sign_eq_sign_of_equiv _ _
    (equiv.of_bijective (λ x : {x // f x ≠ x},
        (⟨i x.1 x.2, have f (f x) ≠ f x, from mt (λ h, f.injective h) x.2,
          by { rw [← h _ x.2 this], exact mt (hi _ _ this x.2) x.2 }⟩ : {y // g y ≠ y}))
        ⟨λ ⟨x, hx⟩ ⟨y, hy⟩ h, subtype.eq (hi _ _ _ _ (subtype.mk.inj h)),
          λ ⟨y, hy⟩, let ⟨x, hfx, hx⟩ := hg y hy in ⟨⟨x, hfx⟩, subtype.eq hx⟩⟩)
      (λ ⟨x, _⟩, subtype.eq (h x _ _))
... = sign g : sign_subtype_perm _ _ (λ _, id)

/-- If we apply `prod_extend_right a (σ a)` for all `a : α` in turn,
we get `prod_congr_right σ`. -/
lemma prod_prod_extend_right {α : Type*} [decidable_eq α] (σ : α → perm β)
  {l : list α} (hl : l.nodup) (mem_l : ∀ a, a ∈ l) :
  (l.map (λ a, prod_extend_right a (σ a))).prod = prod_congr_right σ :=
begin
  ext ⟨a, b⟩ : 1,
  -- We'll use induction on the list of elements,
  -- but we have to keep track of whether we already passed `a` in the list.
  suffices : (a ∈ l ∧ (l.map (λ a, prod_extend_right a (σ a))).prod (a, b) = (a, σ a b)) ∨
             (a ∉ l ∧ (l.map (λ a, prod_extend_right a (σ a))).prod (a, b) = (a, b)),
  { obtain ⟨_, prod_eq⟩ := or.resolve_right this (not_and.mpr (λ h _, h (mem_l a))),
    rw [prod_eq, prod_congr_right_apply] },
  clear mem_l,

  induction l with a' l ih,
  { refine or.inr ⟨list.not_mem_nil _, _⟩,
    rw [list.map_nil, list.prod_nil, one_apply] },

  rw [list.map_cons, list.prod_cons, mul_apply],
  rcases ih (list.nodup_cons.mp hl).2 with ⟨mem_l, prod_eq⟩ | ⟨not_mem_l, prod_eq⟩; rw prod_eq,
  { refine or.inl ⟨list.mem_cons_of_mem _ mem_l, _⟩,
    rw prod_extend_right_apply_ne _ (λ (h : a = a'), (list.nodup_cons.mp hl).1 (h ▸ mem_l)) },
  by_cases ha' : a = a',
  { rw ← ha' at *,
    refine or.inl ⟨l.mem_cons_self a, _⟩,
    rw prod_extend_right_apply_eq },
  { refine or.inr ⟨λ h, not_or ha' not_mem_l ((list.mem_cons_iff _ _ _).mp h), _⟩,
    rw prod_extend_right_apply_ne _ ha' },
end

section congr

variables [decidable_eq β] [fintype β]

@[simp] lemma sign_prod_extend_right (a : α) (σ : perm β) :
  (prod_extend_right a σ).sign = σ.sign :=
sign_bij (λ (ab : α × β) _, ab.snd)
  (λ ⟨a', b⟩ hab hab', by simp [eq_of_prod_extend_right_ne hab])
  (λ ⟨a₁, b₁⟩ ⟨a₂, b₂⟩ hab₁ hab₂ h,
    by simpa [eq_of_prod_extend_right_ne hab₁, eq_of_prod_extend_right_ne hab₂] using h)
  (λ y hy, ⟨(a, y), by simpa, by simp⟩)

lemma sign_prod_congr_right (σ : α → perm β) :
  sign (prod_congr_right σ) = ∏ k, (σ k).sign :=
begin
  obtain ⟨l, hl, mem_l⟩ := finite.exists_univ_list α,
  have l_to_finset : l.to_finset = finset.univ,
  { apply eq_top_iff.mpr,
    intros b _,
    exact list.mem_to_finset.mpr (mem_l b) },
  rw [← prod_prod_extend_right σ hl mem_l, sign.map_list_prod,
      list.map_map, ← l_to_finset, list.prod_to_finset _ hl],
  simp_rw ← λ a, sign_prod_extend_right a (σ a)
end

lemma sign_prod_congr_left (σ : α → perm β) :
  sign (prod_congr_left σ) = ∏ k, (σ k).sign :=
begin
  refine (sign_eq_sign_of_equiv _ _ (prod_comm β α) _).trans (sign_prod_congr_right σ),
  rintro ⟨b, α⟩,
  refl
end

@[simp] lemma sign_perm_congr (e : α ≃ β) (p : perm α) :
  (e.perm_congr p).sign = p.sign :=
sign_eq_sign_of_equiv _ _ e.symm (by simp)

@[simp] lemma sign_sum_congr (σa : perm α) (σb : perm β) :
  (sum_congr σa σb).sign = σa.sign * σb.sign :=
begin
  suffices : (sum_congr σa (1 : perm β)).sign = σa.sign ∧
             (sum_congr (1 : perm α) σb).sign = σb.sign,
  { rw [←this.1, ←this.2, ←sign_mul, sum_congr_mul, one_mul, mul_one], },
  split,
  { apply σa.swap_induction_on _ (λ σa' a₁ a₂ ha ih, _),
    { simp },
    { rw [←one_mul (1 : perm β), ←sum_congr_mul, sign_mul, sign_mul, ih, sum_congr_swap_one,
          sign_swap ha, sign_swap (sum.inl_injective.ne_iff.mpr ha)], }, },
  { apply σb.swap_induction_on _ (λ σb' b₁ b₂ hb ih, _),
    { simp },
    { rw [←one_mul (1 : perm α), ←sum_congr_mul, sign_mul, sign_mul, ih, sum_congr_one_swap,
          sign_swap hb, sign_swap (sum.inr_injective.ne_iff.mpr hb)], }, }
end

@[simp] lemma sign_subtype_congr {p : α → Prop} [decidable_pred p]
  (ep : perm {a // p a}) (en : perm {a // ¬ p a}) :
  (ep.subtype_congr en).sign = ep.sign * en.sign :=
by simp [subtype_congr]

@[simp] lemma sign_extend_domain (e : perm α)
  {p : β → Prop} [decidable_pred p] (f : α ≃ subtype p) :
  equiv.perm.sign (e.extend_domain f) = equiv.perm.sign e :=
by simp only [equiv.perm.extend_domain, sign_subtype_congr, sign_perm_congr, sign_refl, mul_one]

@[simp] lemma sign_of_subtype {p : α → Prop} [decidable_pred p]
  (f : equiv.perm (subtype p)) : equiv.perm.sign (f.of_subtype) = equiv.perm.sign f :=
sign_extend_domain f (equiv.refl (subtype p))

end congr

end sign

end equiv.perm


import SciLean.Core
import SciLean.Tactic.AutoDiff
import SciLean.Tactic.SyntacticRefl

open SciLean

variable {α β γ : Type}
variable {X Y Z W : Type} [Vec X] [Vec Y] [Vec Z] [Vec W]
variable {Y₁ Y₂ : Type} [Vec Y₁] [Vec Y₂]

set_option maxHeartbeats 4000
set_option synthInstance.maxHeartbeats 1000
set_option synthInstance.maxSize 80

opaque wait {α : Type} (a : α) : α := a
axiom wait_unfold (a : α) : wait a = a

example :
  ∂ (λ x : X =>
     let y := x
     let z := y
     z)
  =
  wait (
  λ x dx =>
    let y := x
    let dy := dx
    let z := y
    let dz := dy
    dz)
  := by (conv => lhs; autodiff); rw[wait_unfold];


/-
Copyright (c) 2021 Scott Morrison. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Scott Morrison
-/
import category_theory.subobject.basic
import category_theory.essentially_small

/-!
# Well-powered categories

A category `(C : Type u) [category.{v} C]` is `[well_powered C]` if
for every `X : C`, we have `small.{v} (subobject X)`.

(Note that in this situtation `subobject X : Type (max u v)`,
so this is a nontrivial condition for large categories,
but automatic for small categories.)

This is equivalent to the category `mono_over X` being `essentially_small.{v}` for all `X : C`.

When a category is well-powered, you can obtain nonconstructive witnesses as
`shrink (subobject X) : Type v`
and
`equiv_shrink (subobject X) : subobject X ≃ shrink (subobject X)`.
-/

universes v u₁ u₂

namespace category_theory

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

/--
A category (with morphisms in `Type v`) is well-powered if `subobject X` is `v`-small for every `X`.

We show in `well_powered_of_mono_over_essentially_small` and `mono_over_essentially_small`
that this is the case if and only if `mono_over X` is `v`-essentially small for every `X`.
-/
class well_powered : Prop :=
(subobject_small : ∀ X : C, small.{v} (subobject X) . tactic.apply_instance)

instance small_subobject [well_powered C] (X : C) : small.{v} (subobject X) :=
well_powered.subobject_small X

@[priority 100]
instance well_powered_of_small_category (C : Type u₁) [small_category C] : well_powered C :=
{}

variables {C}

theorem essentially_small_mono_over_iff_small_subobject (X : C) :
  essentially_small.{v} (mono_over X) ↔ small.{v} (subobject X) :=
essentially_small_iff_of_thin

theorem well_powered_of_essentially_small_mono_over
  (h : ∀ X : C, essentially_small.{v} (mono_over X)) :
  well_powered C :=
{ subobject_small := λ X, (essentially_small_mono_over_iff_small_subobject X).mp (h X), }

section
variables [well_powered C]

instance essentially_small_mono_over (X : C) :
  essentially_small.{v} (mono_over X) :=
(essentially_small_mono_over_iff_small_subobject X).mpr (well_powered.subobject_small X)

end

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

theorem well_powered_of_equiv (e : C ≌ D) [well_powered C] : well_powered D :=
well_powered_of_essentially_small_mono_over $
  λ X, (essentially_small_congr (mono_over.congr X e.symm)).2 $ by apply_instance

/-- Being well-powered is preserved by equivalences, as long as the two categories involved have
    their morphisms in the same universe. -/
theorem well_powered_congr (e : C ≌ D) : well_powered C ↔ well_powered D :=
⟨λ i, by exactI well_powered_of_equiv e, λ i, by exactI well_powered_of_equiv e.symm⟩

end equivalence

end category_theory


/-
Copyright (c) 2021 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Yury Kudryashov, Mario Carneiro, Sean Leather
-/
import data.finset.basic
import order.preorder_hom

/-!
# Finite sets in `option α`

In this file we define

* `option.to_finset`: construct an empty or singleton `finset α` from an `option α`;
* `finset.insert_none`: given `s : finset α`, lift it to a finset on `option α` using `option.some`
  and then insert `option.none`;
* `finset.erase_none`: given `s : finset (option α)`, returns `t : finset α` such that
  `x ∈ t ↔ some x ∈ s`.

Then we prove some basic lemmas about these definitions.

## Tags

finset, option
-/

variables {α β : Type*}

open function

namespace option

/-- Construct an empty or singleton finset from an `option` -/
def to_finset (o : option α) : finset α := o.elim ∅ singleton

@[simp] theorem to_finset_none : none.to_finset = (∅ : finset α) := rfl

@[simp] theorem to_finset_some {a : α} : (some a).to_finset = {a} := rfl

@[simp] theorem mem_to_finset {a : α} {o : option α} : a ∈ o.to_finset ↔ a ∈ o :=
by cases o; simp [eq_comm]

theorem card_to_finset (o : option α) : o.to_finset.card = o.elim 0 1 :=
by cases o; refl

end option

namespace finset

/-- Given a finset on `α`, lift it to being a finset on `option α`
using `option.some` and then insert `option.none`. -/
def insert_none : finset α ↪o finset (option α) :=
order_embedding.of_map_le_iff (λ s, cons none (s.map embedding.some) $ by simp) $ λ s t,
  cons_subset_cons.trans map_subset_map

/-⟨none ::ₘ s.1.map some, multiset.nodup_cons.2
  ⟨by simp, multiset.nodup_map (λ a b, option.some.inj) s.2⟩⟩-/

@[simp] theorem mem_insert_none {s : finset α} : ∀ {o : option α},
  o ∈ s.insert_none ↔ ∀ a ∈ o, a ∈ s
| none     := iff_of_true (multiset.mem_cons_self _ _) (λ a h, by cases h)
| (some a) := multiset.mem_cons.trans $ by simp; refl

theorem some_mem_insert_none {s : finset α} {a : α} :
  some a ∈ s.insert_none ↔ a ∈ s := by simp

@[simp] theorem card_insert_none (s : finset α) : s.insert_none.card = s.card + 1 :=
by simp [insert_none]

/-- Given `s : finset (option α)`, `s.erase_none : finset α` is the set of `x : α` such that
`some x ∈ s`. -/
def erase_none : finset (option α) →ₘ finset α :=
(finset.map_embedding (equiv.option_is_some_equiv α).to_embedding).to_preorder_hom.comp
  ⟨finset.subtype _, subtype_mono⟩

@[simp] lemma mem_erase_none {s : finset (option α)} {x : α} :
  x ∈ s.erase_none ↔ some x ∈ s :=
by simp [erase_none]

lemma erase_none_eq_bUnion [decidable_eq α] (s : finset (option α)) :
  s.erase_none = s.bUnion option.to_finset :=
by { ext, simp }

@[simp] lemma erase_none_map_some (s : finset α) : (s.map embedding.some).erase_none = s :=
by { ext, simp }

@[simp] lemma erase_none_image_some [decidable_eq (option α)] (s : finset α) :
  (s.image some).erase_none = s :=
by simpa only [map_eq_image] using erase_none_map_some s

@[simp] lemma coe_erase_none (s : finset (option α)) :
  (s.erase_none : set α) = some ⁻¹' s :=
set.ext $ λ x, mem_erase_none

@[simp] lemma erase_none_union [decidable_eq (option α)] [decidable_eq α]
  (s t : finset (option α)) :
  (s ∪ t).erase_none = s.erase_none ∪ t.erase_none :=
by { ext, simp }

@[simp] lemma erase_none_inter [decidable_eq (option α)] [decidable_eq α]
  (s t : finset (option α)) :
  (s ∩ t).erase_none = s.erase_none ∩ t.erase_none :=
by { ext, simp }

@[simp] lemma erase_none_empty : (∅ : finset (option α)).erase_none = ∅ := by { ext, simp }

@[simp] lemma erase_none_none : ({none} : finset (option α)).erase_none = ∅ := by { ext, simp }

@[simp] lemma image_some_erase_none [decidable_eq (option α)] (s : finset (option α)) :
  s.erase_none.image some = s.erase none :=
by ext (_|x); simp

@[simp] lemma map_some_erase_none [decidable_eq (option α)] (s : finset (option α)) :
  s.erase_none.map embedding.some = s.erase none :=
by rw [map_eq_image, embedding.some_apply, image_some_erase_none]

@[simp] lemma insert_none_erase_none [decidable_eq (option α)] (s : finset (option α)) :
  insert_none (erase_none s) = insert none s :=
by ext (_|x); simp

@[simp] lemma erase_none_insert_none (s : finset α) : erase_none (insert_none s) = s :=
by { ext, simp }

end finset


import tactic
import .sub_module
import tactic.push_neg
import .morphism
import .homothetic
import .kernel
open Kernel range morphism homothetic
open stability
universe variables u v w w'

lemma Fact {R : Type v}[ring R]{M1 : Type w}[add_comm_group M1] [module R M1]
 (p1 : submodule R M1) (hyp : p1 = ⊤ ∨  p1 = ⊥ )(z : M1)(hyp' : z ∈ p1)(hyp'' : z ≠ 0) : p1 = ⊤   := begin
    rcases hyp, assumption, rw hyp at hyp', rw submodule.mem_bot at hyp', by contradiction,
end

namespace Irreductible
variables {G : Type u} [group G] {R : Type v}[ring R]
variables  {M : Type w}[add_comm_group M] [module R M]  ( ρ : group_representation G R M)
def Irreductible :=  ∀ {p : submodule R M},   (stable_submodule ρ p) → (p = ⊤ ∨  p = ⊥)

end Irreductible

namespace morphism.from_irreductible
open Irreductible linear_map
variables {G : Type u} [group G] {R : Type v}[ring R]
variables {M1 : Type w}  [add_comm_group M1] [module R M1]
          {M2 : Type w'} [add_comm_group M2] [module R M2]
          { ρ1 : group_representation G R M1}
          {ρ2 : group_representation G R M2}
          (f : ρ1 ⟶ ρ2)

--
--  Faire les choses plus proprement en definissant une strucure ⊤ ⊥  sur les representation
--
theorem pre_Schur_ker  (hyp : Irreductible ρ1) :
(ker f.ℓ  = ⊤  ∨ ker f.ℓ   = ⊥  ) :=   hyp  (ker_is_stable_submodule f)

theorem pre_Schur_range (hyp : Irreductible ρ2) :
 (range f.ℓ  = ⊤  ∨ range f.ℓ   = ⊥  ) :=
 hyp (range_is_stable_submodule f)
 open linear_map
variables (hyp : Irreductible ρ2 )
#check f
#check  pre_Schur_range f (by assumption)
/--
    little modification of Serre `Representations linéaires des groupes  finis`.
    We have no assumption of field just a ring (`NOT` only commutative). `NOT` dimension.
-/

theorem Schur₁  (hyp1 : Irreductible ρ1)(hyp2 : Irreductible ρ2) : (∃ x : M1, (f.ℓ  x ≠ 0)) →
(ker f.ℓ  = ⊥ ) ∧  range f.ℓ  = ⊤ :=
begin
    intros hyp_not_nul,
    rcases hyp_not_nul with ⟨x,hyp_not_nul⟩,
    split, swap,
    apply Fact, -- ici ?
    apply pre_Schur_range, --- on ne comprend plus !
    assumption,
    rw linear_map.mem_range,
    use x,
    exact hyp_not_nul,
    let schur :=  (hyp1 (ker_is_stable_submodule f)),unfold Ker at schur,
    rcases schur, swap,assumption,
    rw schur,
    have R :  x ∈ ker f.ℓ ,
            rw schur, trivial,
    rw linear_map.mem_ker at R,
    trivial,
end
end morphism.from_irreductible
namespace Schur₂
open Irreductible morphism.from_irreductible
open_locale classical
variables {G : Type u} [group G] {R : Type v}[comm_ring R]{M : Type w}[add_comm_group M] [module R M]
variables  {ρ : group_representation G R M}
theorem Schur₂(f : ρ ⟶ ρ) [re : Irreductible ρ] :
        (∃ r : R, ∃ m0 : M, m0 ≠ 0 ∧  f.ℓ m0 + r • m0 = 0) → (∃ r : R, ∀ m : M, f.ℓ m + r • m = 0) :=
begin
    --intro hyp,
    rintros ⟨r,m0,⟨spec,spectral⟩⟩,
    use r,
    -- We proof  g = f + r id =0. The idea is ker g is stable, so equal to {0} or M. But m0 ∈ Ker f and m0 ≠ 0 so Ker f = M
    let g :=  f + r • 𝟙 ρ,
    -- first step g.ℓ m0 = 0
    have  certif_m0_in_ker : g.ℓ  m0 = 0,
        erw [add_ext,
         smul_ext, one_ext],
        exact spectral,

    let schur := (Schur₁ g) ( by assumption  ) (by assumption), -- swap, exact re
    by_contra,                  -- re doesnt work
    push_neg at a,
    rcases a with ⟨ζ,n ⟩,
    have R : (f.ℓ) ζ + r • ζ = g.ℓ ζ,
        erw  [add_ext,smul_ext,one_ext],
        exact rfl,
    rw R at n,
    let V := (schur ⟨ζ,n⟩).1,
    have : m0 ∈ linear_map.ker g.ℓ,
        rw linear_map.mem_ker,
        exact certif_m0_in_ker,
    rw V at this,
    rw submodule.mem_bot at this,
    by contradiction,
end
/-
example (P : Prop) (h : P ∨ ¬ P) : ¬ ¬ P → P := begin
    intros hnn,
    cases h,
    assumption,
    by contradiction,
end
example (P Q : Prop) : (P → Q) ↔ (¬ Q → ¬ P) := begin
        split,
        intro hpq,
        intro hnQ,
        intro hp,
        end

example (X :Type) (P : X → Prop ) (hyp : (∃ x : X, ¬ (P x)) → false ) : ∀ x, P x := begin
    intro,
    contrapose! hyp,
    use x,
end

example (X :Type) (P : X → Prop ) (hyp : (∃ x : X, ¬ (P x)) → false ) : ∀ x, P x := begin
  by_contra,
  rw not_forall at a,
  exact hyp a,
end
-/


universes u v w

-- We can typically set up the simplifier so that most theorems
-- can be proven by induction + simp

@[simp]
lemma reverse_nil {α : Type u} : [].reverse = ([] : list α) :=
rfl

lemma reverse_core {α : Type u} (xs ys : list α) :
    list.reverse_core xs ys = xs.reverse ++ ys :=
by induction xs generalizing ys;
   simp [list.reverse_core, list.reverse]; simp *

@[simp]
lemma reverse_cons {α : Type u} (x : α) (xs : list α) :
    (x :: xs).reverse = xs.reverse ++ [x] :=
by simp [list.reverse, list.reverse_core]; simp [reverse_core]

@[simp]
lemma reverse_concat {α : Type u} (xs ys : list α) :
    (xs ++ ys).reverse = ys.reverse ++ xs.reverse :=
by induction xs generalizing ys; simp *

@[simp]
lemma reverse_reverse {α : Type u} (xs : list α) : xs.reverse.reverse = xs :=
by induction xs; simp *

example {α : Type u} (xs ys : list α) :
    (xs.reverse ++ ys).reverse = ys.reverse ++ xs :=
by simp

@[simp]
lemma map_reverse {α : Type u} {β : Type v} (f : α → β) (xs : list α) :
    list.map f (list.reverse xs) = list.reverse (list.map f xs) :=
by induction xs; simp [*, list.map]

@[simp]
lemma map_id {α : Type u} (xs : list α) : list.map (λ x, x) xs = xs :=
by apply list.map_id

@[simp]
lemma map_map {α : Type u} {β : Type v} {γ : Type w} (f : α → β) (g : β → γ) (xs : list α) :
    list.map g (list.map f xs) = list.map (g ∘ f) xs :=
by apply list.map_map

example (xs : list ℕ) :
    (list.reverse $
     list.map (λ x, x - 2) $
     list.reverse $
     list.map (λ x, x + 2) xs)
    = xs :=
by simp [(∘)]

-- What lemmas do we need to add to prove the following?
example (xs : list ℕ) :
    let xs := xs.filter (λ x, x > 0) in
    let xs := xs.map (λ x, 3 * x / x) in
    ∀ x ∈ xs, x = 3 :=
by simp {contextual := tt}


example (P Q R : Type) : (P → (Q → R)) → ((P → Q) → (P → R)) :=
begin
    intro f,
    intro g,
    intro p,
    apply f,
    {
        exact p,
    },
    {
        apply g,
        exact p,
    }
end


/-
Copyright (c) 2016 Johannes Hölzl. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Mario Carneiro
-/
import logic.basic
import data.option.defs

/-!
# Miscellaneous function constructions and lemmas
-/

universes u v w

namespace function

section
variables {α β γ : Sort*} {f : α → β}

/-- Evaluate a function at an argument. Useful if you want to talk about the partially applied
  `function.eval x : (Π x, β x) → β x`. -/
@[reducible] def eval {β : α → Sort*} (x : α) (f : Π x, β x) : β x := f x

@[simp] lemma eval_apply {β : α → Sort*} (x : α) (f : Π x, β x) : eval x f = f x := rfl

lemma comp_apply {α : Sort u} {β : Sort v} {φ : Sort w} (f : β → φ) (g : α → β) (a : α) :
  (f ∘ g) a = f (g a) := rfl

lemma const_def {y : β} : (λ x : α, y) = const α y := rfl

@[simp] lemma const_apply {y : β} {x : α} : const α y x = y := rfl

@[simp] lemma const_comp {f : α → β} {c : γ} : const β c ∘ f = const α c := rfl

@[simp] lemma comp_const {f : β → γ} {b : β} : f ∘ const α b = const α (f b) := rfl

lemma id_def : @id α = λ x, x := rfl

lemma hfunext {α α': Sort u} {β : α → Sort v} {β' : α' → Sort v} {f : Πa, β a} {f' : Πa, β' a}
  (hα : α = α') (h : ∀a a', a == a' → f a == f' a') : f == f' :=
begin
  subst hα,
  have : ∀a, f a == f' a,
  { intro a, exact h a a (heq.refl a) },
  have : β = β',
  { funext a, exact type_eq_of_heq (this a) },
  subst this,
  apply heq_of_eq,
  funext a,
  exact eq_of_heq (this a)
end

lemma funext_iff {β : α → Sort*} {f₁ f₂ : Π (x : α), β x} : f₁ = f₂ ↔ (∀a, f₁ a = f₂ a) :=
iff.intro (assume h a, h ▸ rfl) funext

protected lemma bijective.injective {f : α → β} (hf : bijective f) : injective f := hf.1
protected lemma bijective.surjective {f : α → β} (hf : bijective f) : surjective f := hf.2

theorem injective.eq_iff (I : injective f) {a b : α} :
  f a = f b ↔ a = b :=
⟨@I _ _, congr_arg f⟩

theorem injective.eq_iff' (I : injective f) {a b : α} {c : β} (h : f b = c) :
  f a = c ↔ a = b :=
h ▸ I.eq_iff

lemma injective.ne (hf : injective f) {a₁ a₂ : α} : a₁ ≠ a₂ → f a₁ ≠ f a₂ :=
mt (assume h, hf h)

lemma injective.ne_iff (hf : injective f) {x y : α} : f x ≠ f y ↔ x ≠ y :=
⟨mt $ congr_arg f, hf.ne⟩

lemma injective.ne_iff' (hf : injective f) {x y : α} {z : β} (h : f y = z) :
  f x ≠ z ↔ x ≠ y :=
h ▸ hf.ne_iff

/-- If the co-domain `β` of an injective function `f : α → β` has decidable equality, then
the domain `α` also has decidable equality. -/
def injective.decidable_eq [decidable_eq β] (I : injective f) : decidable_eq α :=
λ a b, decidable_of_iff _ I.eq_iff

lemma injective.of_comp {g : γ → α} (I : injective (f ∘ g)) : injective g :=
λ x y h, I $ show f (g x) = f (g y), from congr_arg f h

lemma injective.of_comp_iff {f : α → β} (hf : injective f) (g : γ → α) :
  injective (f ∘ g) ↔ injective g :=
⟨injective.of_comp, hf.comp⟩

lemma injective.of_comp_iff' (f : α → β) {g : γ → α} (hg : bijective g) :
  injective (f ∘ g) ↔ injective f :=
⟨ λ h x y, let ⟨x', hx⟩ := hg.surjective x, ⟨y', hy⟩ := hg.surjective y in
    hx ▸ hy ▸ λ hf, h hf ▸ rfl,
  λ h, h.comp hg.injective⟩

lemma injective_of_subsingleton [subsingleton α] (f : α → β) :
  injective f :=
λ a b ab, subsingleton.elim _ _

lemma injective.dite (p : α → Prop) [decidable_pred p]
  {f : {a : α // p a} → β} {f' : {a : α // ¬ p a} → β}
  (hf : injective f) (hf' : injective f')
  (im_disj : ∀ {x x' : α} {hx : p x} {hx' : ¬ p x'}, f ⟨x, hx⟩ ≠ f' ⟨x', hx'⟩) :
  function.injective (λ x, if h : p x then f ⟨x, h⟩ else f' ⟨x, h⟩) :=
λ x₁ x₂ h, begin
  dsimp only at h,
  by_cases h₁ : p x₁; by_cases h₂ : p x₂,
  { rw [dif_pos h₁, dif_pos h₂] at h, injection (hf h), },
  { rw [dif_pos h₁, dif_neg h₂] at h, exact (im_disj h).elim, },
  { rw [dif_neg h₁, dif_pos h₂] at h, exact (im_disj h.symm).elim, },
  { rw [dif_neg h₁, dif_neg h₂] at h, injection (hf' h), },
end

lemma surjective.of_comp {g : γ → α} (S : surjective (f ∘ g)) : surjective f :=
λ y, let ⟨x, h⟩ := S y in ⟨g x, h⟩

lemma surjective.of_comp_iff (f : α → β) {g : γ → α} (hg : surjective g) :
  surjective (f ∘ g) ↔ surjective f :=
⟨surjective.of_comp, λ h, h.comp hg⟩

lemma surjective.of_comp_iff' {f : α → β} (hf : bijective f) (g : γ → α) :
  surjective (f ∘ g) ↔ surjective g :=
⟨λ h x, let ⟨x', hx'⟩ := h (f x) in ⟨x', hf.injective hx'⟩, hf.surjective.comp⟩

instance decidable_eq_pfun (p : Prop) [decidable p] (α : p → Type*)
  [Π hp, decidable_eq (α hp)] : decidable_eq (Π hp, α hp)
| f g := decidable_of_iff (∀ hp, f hp = g hp) funext_iff.symm

theorem surjective.forall {f : α → β} (hf : surjective f) {p : β → Prop} :
  (∀ y, p y) ↔ ∀ x, p (f x) :=
⟨λ h x, h (f x), λ h y, let ⟨x, hx⟩ := hf y in hx ▸ h x⟩

theorem surjective.forall₂ {f : α → β} (hf : surjective f) {p : β → β → Prop} :
  (∀ y₁ y₂, p y₁ y₂) ↔ ∀ x₁ x₂, p (f x₁) (f x₂) :=
hf.forall.trans $ forall_congr $ λ x, hf.forall

theorem surjective.forall₃ {f : α → β} (hf : surjective f) {p : β → β → β → Prop} :
  (∀ y₁ y₂ y₃, p y₁ y₂ y₃) ↔ ∀ x₁ x₂ x₃, p (f x₁) (f x₂) (f x₃) :=
hf.forall.trans $ forall_congr $ λ x, hf.forall₂

theorem surjective.exists {f : α → β} (hf : surjective f) {p : β → Prop} :
  (∃ y, p y) ↔ ∃ x, p (f x) :=
⟨λ ⟨y, hy⟩, let ⟨x, hx⟩ := hf y in ⟨x, hx.symm ▸ hy⟩, λ ⟨x, hx⟩, ⟨f x, hx⟩⟩

theorem surjective.exists₂ {f : α → β} (hf : surjective f) {p : β → β → Prop} :
  (∃ y₁ y₂, p y₁ y₂) ↔ ∃ x₁ x₂, p (f x₁) (f x₂) :=
hf.exists.trans $ exists_congr $ λ x, hf.exists

theorem surjective.exists₃ {f : α → β} (hf : surjective f) {p : β → β → β → Prop} :
  (∃ y₁ y₂ y₃, p y₁ y₂ y₃) ↔ ∃ x₁ x₂ x₃, p (f x₁) (f x₂) (f x₃) :=
hf.exists.trans $ exists_congr $ λ x, hf.exists₂

lemma bijective_iff_exists_unique (f : α → β) : bijective f ↔
  ∀ b : β, ∃! (a : α), f a = b :=
⟨ λ hf b, let ⟨a, ha⟩ := hf.surjective b in ⟨a, ha, λ a' ha', hf.injective (ha'.trans ha.symm)⟩,
  λ he, ⟨
    λ a a' h, unique_of_exists_unique (he (f a')) h rfl,
    λ b, exists_of_exists_unique (he b) ⟩⟩

/-- Shorthand for using projection notation with `function.bijective_iff_exists_unique`. -/
lemma bijective.exists_unique {f : α → β} (hf : bijective f) (b : β) : ∃! (a : α), f a = b :=
(bijective_iff_exists_unique f).mp hf b

lemma bijective.of_comp_iff (f : α → β) {g : γ → α} (hg : bijective g) :
  bijective (f ∘ g) ↔ bijective f :=
and_congr (injective.of_comp_iff' _ hg) (surjective.of_comp_iff _ hg.surjective)

lemma bijective.of_comp_iff' {f : α → β} (hf : bijective f) (g : γ → α) :
  function.bijective (f ∘ g) ↔ function.bijective g :=
and_congr (injective.of_comp_iff hf.injective _) (surjective.of_comp_iff' hf _)

/-- Cantor's diagonal argument implies that there are no surjective functions from `α`
to `set α`. -/
theorem cantor_surjective {α} (f : α → set α) : ¬ function.surjective f | h :=
let ⟨D, e⟩ := h (λ a, ¬ f a a) in
(iff_not_self (f D D)).1 $ iff_of_eq (congr_fun e D)

/-- Cantor's diagonal argument implies that there are no injective functions from `set α` to `α`. -/
theorem cantor_injective {α : Type*} (f : (set α) → α) :
  ¬ function.injective f | i :=
cantor_surjective (λ a b, ∀ U, a = f U → U b) $
right_inverse.surjective (λ U, funext $ λ a, propext ⟨λ h, h U rfl, λ h' U' e, i e ▸ h'⟩)

/-- `g` is a partial inverse to `f` (an injective but not necessarily
  surjective function) if `g y = some x` implies `f x = y`, and `g y = none`
  implies that `y` is not in the range of `f`. -/
def is_partial_inv {α β} (f : α → β) (g : β → option α) : Prop :=
∀ x y, g y = some x ↔ f x = y

theorem is_partial_inv_left {α β} {f : α → β} {g} (H : is_partial_inv f g) (x) : g (f x) = some x :=
(H _ _).2 rfl

theorem injective_of_partial_inv {α β} {f : α → β} {g} (H : is_partial_inv f g) : injective f :=
λ a b h, option.some.inj $ ((H _ _).2 h).symm.trans ((H _ _).2 rfl)

theorem injective_of_partial_inv_right {α β} {f : α → β} {g} (H : is_partial_inv f g)
 (x y b) (h₁ : b ∈ g x) (h₂ : b ∈ g y) : x = y :=
((H _ _).1 h₁).symm.trans ((H _ _).1 h₂)

theorem left_inverse.comp_eq_id {f : α → β} {g : β → α} (h : left_inverse f g) : f ∘ g = id :=
funext h

theorem left_inverse_iff_comp {f : α → β} {g : β → α} : left_inverse f g ↔ f ∘ g = id :=
⟨left_inverse.comp_eq_id, congr_fun⟩

theorem right_inverse.comp_eq_id {f : α → β} {g : β → α} (h : right_inverse f g) : g ∘ f = id :=
funext h

theorem right_inverse_iff_comp {f : α → β} {g : β → α} : right_inverse f g ↔ g ∘ f = id :=
⟨right_inverse.comp_eq_id, congr_fun⟩

theorem left_inverse.comp {f : α → β} {g : β → α} {h : β → γ} {i : γ → β}
  (hf : left_inverse f g) (hh : left_inverse h i) : left_inverse (h ∘ f) (g ∘ i) :=
assume a, show h (f (g (i a))) = a, by rw [hf (i a), hh a]

theorem right_inverse.comp {f : α → β} {g : β → α} {h : β → γ} {i : γ → β}
  (hf : right_inverse f g) (hh : right_inverse h i) : right_inverse (h ∘ f) (g ∘ i) :=
left_inverse.comp hh hf

theorem left_inverse.right_inverse {f : α → β} {g : β → α} (h : left_inverse g f) :
  right_inverse f g := h

theorem right_inverse.left_inverse {f : α → β} {g : β → α} (h : right_inverse g f) :
  left_inverse f g := h

theorem left_inverse.surjective {f : α → β} {g : β → α} (h : left_inverse f g) :
  surjective f :=
h.right_inverse.surjective

theorem right_inverse.injective {f : α → β} {g : β → α} (h : right_inverse f g) :
  injective f :=
h.left_inverse.injective

theorem left_inverse.eq_right_inverse {f : α → β} {g₁ g₂ : β → α} (h₁ : left_inverse g₁ f)
  (h₂ : right_inverse g₂ f) :
  g₁ = g₂ :=
calc g₁ = g₁ ∘ f ∘ g₂ : by rw [h₂.comp_eq_id, comp.right_id]
    ... = g₂          : by rw [← comp.assoc, h₁.comp_eq_id, comp.left_id]

local attribute [instance, priority 10] classical.prop_decidable

/-- We can use choice to construct explicitly a partial inverse for
  a given injective function `f`. -/
noncomputable def partial_inv {α β} (f : α → β) (b : β) : option α :=
if h : ∃ a, f a = b then some (classical.some h) else none

theorem partial_inv_of_injective {α β} {f : α → β} (I : injective f) :
  is_partial_inv f (partial_inv f) | a b :=
⟨λ h, if h' : ∃ a, f a = b then begin
    rw [partial_inv, dif_pos h'] at h,
    injection h with h, subst h,
    apply classical.some_spec h'
  end else by rw [partial_inv, dif_neg h'] at h; contradiction,
 λ e, e ▸ have h : ∃ a', f a' = f a, from ⟨_, rfl⟩,
   (dif_pos h).trans (congr_arg _ (I $ classical.some_spec h))⟩

theorem partial_inv_left {α β} {f : α → β} (I : injective f) : ∀ x, partial_inv f (f x) = some x :=
is_partial_inv_left (partial_inv_of_injective I)

end

section inv_fun
variables {α : Type u} [n : nonempty α] {β : Sort v} {f : α → β} {s : set α} {a : α} {b : β}
include n
local attribute [instance, priority 10] classical.prop_decidable

/-- Construct the inverse for a function `f` on domain `s`. This function is a right inverse of `f`
on `f '' s`. For a computable version, see `function.injective.inv_of_mem_range`. -/
noncomputable def inv_fun_on (f : α → β) (s : set α) (b : β) : α :=
if h : ∃a, a ∈ s ∧ f a = b then classical.some h else classical.choice n

theorem inv_fun_on_pos (h : ∃a∈s, f a = b) : inv_fun_on f s b ∈ s ∧ f (inv_fun_on f s b) = b :=
by rw [bex_def] at h; rw [inv_fun_on, dif_pos h]; exact classical.some_spec h

theorem inv_fun_on_mem (h : ∃a∈s, f a = b) : inv_fun_on f s b ∈ s := (inv_fun_on_pos h).left

theorem inv_fun_on_eq (h : ∃a∈s, f a = b) : f (inv_fun_on f s b) = b := (inv_fun_on_pos h).right

theorem inv_fun_on_eq' (h : ∀ (x ∈ s) (y ∈ s), f x = f y → x = y) (ha : a ∈ s) :
  inv_fun_on f s (f a) = a :=
have ∃a'∈s, f a' = f a, from ⟨a, ha, rfl⟩,
h _ (inv_fun_on_mem this) _ ha (inv_fun_on_eq this)

theorem inv_fun_on_neg (h : ¬ ∃a∈s, f a = b) : inv_fun_on f s b = classical.choice n :=
by rw [bex_def] at h; rw [inv_fun_on, dif_neg h]

/-- The inverse of a function (which is a left inverse if `f` is injective
  and a right inverse if `f` is surjective). -/
noncomputable def inv_fun (f : α → β) : β → α := inv_fun_on f set.univ

theorem inv_fun_eq (h : ∃a, f a = b) : f (inv_fun f b) = b :=
inv_fun_on_eq $ let ⟨a, ha⟩ := h in ⟨a, trivial, ha⟩

lemma inv_fun_neg (h : ¬ ∃ a, f a = b) : inv_fun f b = classical.choice n :=
by refine inv_fun_on_neg (mt _ h); exact assume ⟨a, _, ha⟩, ⟨a, ha⟩

theorem inv_fun_eq_of_injective_of_right_inverse {g : β → α}
  (hf : injective f) (hg : right_inverse g f) : inv_fun f = g :=
funext $ assume b,
hf begin rw [hg b], exact inv_fun_eq ⟨g b, hg b⟩ end

lemma right_inverse_inv_fun (hf : surjective f) : right_inverse (inv_fun f) f :=
assume b, inv_fun_eq $ hf b

lemma left_inverse_inv_fun (hf : injective f) : left_inverse (inv_fun f) f :=
assume b,
have f (inv_fun f (f b)) = f b,
  from inv_fun_eq ⟨b, rfl⟩,
hf this

lemma inv_fun_surjective (hf : injective f) : surjective (inv_fun f) :=
(left_inverse_inv_fun hf).surjective

lemma inv_fun_comp (hf : injective f) : inv_fun f ∘ f = id := funext $ left_inverse_inv_fun hf

end inv_fun

section inv_fun
variables {α : Type u} [i : nonempty α] {β : Sort v} {f : α → β}
include i

lemma injective.has_left_inverse (hf : injective f) : has_left_inverse f :=
⟨inv_fun f, left_inverse_inv_fun hf⟩

lemma injective_iff_has_left_inverse : injective f ↔ has_left_inverse f :=
⟨injective.has_left_inverse, has_left_inverse.injective⟩

end inv_fun

section surj_inv
variables {α : Sort u} {β : Sort v} {f : α → β}

/-- The inverse of a surjective function. (Unlike `inv_fun`, this does not require
  `α` to be inhabited.) -/
noncomputable def surj_inv {f : α → β} (h : surjective f) (b : β) : α := classical.some (h b)

lemma surj_inv_eq (h : surjective f) (b) : f (surj_inv h b) = b := classical.some_spec (h b)

lemma right_inverse_surj_inv (hf : surjective f) : right_inverse (surj_inv hf) f :=
surj_inv_eq hf

lemma left_inverse_surj_inv (hf : bijective f) : left_inverse (surj_inv hf.2) f :=
right_inverse_of_injective_of_left_inverse hf.1 (right_inverse_surj_inv hf.2)

lemma surjective.has_right_inverse (hf : surjective f) : has_right_inverse f :=
⟨_, right_inverse_surj_inv hf⟩

lemma surjective_iff_has_right_inverse : surjective f ↔ has_right_inverse f :=
⟨surjective.has_right_inverse, has_right_inverse.surjective⟩

lemma bijective_iff_has_inverse : bijective f ↔ ∃ g, left_inverse g f ∧ right_inverse g f :=
⟨λ hf, ⟨_, left_inverse_surj_inv hf, right_inverse_surj_inv hf.2⟩,
 λ ⟨g, gl, gr⟩, ⟨gl.injective,  gr.surjective⟩⟩

lemma injective_surj_inv (h : surjective f) : injective (surj_inv h) :=
(right_inverse_surj_inv h).injective

lemma surjective_to_subsingleton [na : nonempty α] [subsingleton β] (f : α → β) :
  surjective f :=
λ y, let ⟨a⟩ := na in ⟨a, subsingleton.elim _ _⟩

end surj_inv

section update
variables {α : Sort u} {β : α → Sort v} {α' : Sort w} [decidable_eq α] [decidable_eq α']

/-- Replacing the value of a function at a given point by a given value. -/
def update (f : Πa, β a) (a' : α) (v : β a') (a : α) : β a :=
if h : a = a' then eq.rec v h.symm else f a

/-- On non-dependent functions, `function.update` can be expressed as an `ite` -/
lemma update_apply {β : Sort*} (f : α → β) (a' : α) (b : β) (a : α) :
  update f a' b a = if a = a' then b else f a :=
begin
  dunfold update,
  congr,
  funext,
  rw eq_rec_constant,
end

@[simp] lemma update_same (a : α) (v : β a) (f : Πa, β a) : update f a v a = v :=
dif_pos rfl

lemma update_injective (f : Πa, β a) (a' : α) : injective (update f a') :=
λ v v' h, have _ := congr_fun h a', by rwa [update_same, update_same] at this

@[simp] lemma update_noteq {a a' : α} (h : a ≠ a') (v : β a') (f : Πa, β a) :
  update f a' v a = f a :=
dif_neg h

lemma forall_update_iff (f : Π a, β a) {a : α} {b : β a} (p : Π a, β a → Prop) :
  (∀ x, p x (update f a b x)) ↔ p a b ∧ ∀ x ≠ a, p x (f x) :=
calc (∀ x, p x (update f a b x)) ↔ ∀ x, (x = a ∨ x ≠ a) → p x (update f a b x) :
  by simp only [ne.def, classical.em, forall_prop_of_true]
... ↔ p a b ∧ ∀ x ≠ a, p x (f x) :
  by simp [or_imp_distrib, forall_and_distrib] { contextual := tt }

lemma update_eq_iff {a : α} {b : β a} {f g : Π a, β a} :
  update f a b = g ↔ b = g a ∧ ∀ x ≠ a, f x = g x :=
funext_iff.trans $ forall_update_iff _ (λ x y, y = g x)

lemma eq_update_iff {a : α} {b : β a} {f g : Π a, β a} :
  g = update f a b ↔ g a = b ∧ ∀ x ≠ a, g x = f x :=
funext_iff.trans $ forall_update_iff _ (λ x y, g x = y)

@[simp] lemma update_eq_self (a : α) (f : Πa, β a) : update f a (f a) = f :=
update_eq_iff.2 ⟨rfl, λ _ _, rfl⟩

lemma update_comp_eq_of_forall_ne' {α'} (g : Π a, β a) {f : α' → α} {i : α} (a : β i)
  (h : ∀ x, f x ≠ i) :
  (λ j, (update g i a) (f j)) = (λ j, g (f j)) :=
funext $ λ x, update_noteq (h _) _ _

/-- Non-dependent version of `function.update_comp_eq_of_forall_ne'` -/
lemma update_comp_eq_of_forall_ne {α β : Sort*} (g : α' → β) {f : α → α'} {i : α'} (a : β)
  (h : ∀ x, f x ≠ i) :
  (update g i a) ∘ f = g ∘ f :=
update_comp_eq_of_forall_ne' g a h

lemma update_comp_eq_of_injective' (g : Π a, β a) {f : α' → α} (hf : function.injective f)
  (i : α') (a : β (f i)) :
  (λ j, update g (f i) a (f j)) = update (λ i, g (f i)) i a :=
eq_update_iff.2 ⟨update_same _ _ _, λ j hj, update_noteq (hf.ne hj) _ _⟩

/-- Non-dependent version of `function.update_comp_eq_of_injective'` -/
lemma update_comp_eq_of_injective {β : Sort*} (g : α' → β) {f : α → α'}
  (hf : function.injective f) (i : α) (a : β) :
  (function.update g (f i) a) ∘ f = function.update (g ∘ f) i a :=
update_comp_eq_of_injective' g hf i a

lemma apply_update {ι : Sort*} [decidable_eq ι] {α β : ι → Sort*}
  (f : Π i, α i → β i) (g : Π i, α i) (i : ι) (v : α i) (j : ι) :
  f j (update g i v j) = update (λ k, f k (g k)) i (f i v) j :=
begin
  by_cases h : j = i,
  { subst j, simp },
  { simp [h] }
end

lemma comp_update {α' : Sort*} {β : Sort*} (f : α' → β) (g : α → α') (i : α) (v : α') :
  f ∘ (update g i v) = update (f ∘ g) i (f v) :=
funext $ apply_update _ _ _ _

theorem update_comm {α} [decidable_eq α] {β : α → Sort*}
  {a b : α} (h : a ≠ b) (v : β a) (w : β b) (f : Πa, β a) :
  update (update f a v) b w = update (update f b w) a v :=
begin
  funext c, simp only [update],
  by_cases h₁ : c = b; by_cases h₂ : c = a; try {simp [h₁, h₂]},
  cases h (h₂.symm.trans h₁),
end

@[simp] theorem update_idem {α} [decidable_eq α] {β : α → Sort*}
  {a : α} (v w : β a) (f : Πa, β a) : update (update f a v) a w = update f a w :=
by {funext b, by_cases b = a; simp [update, h]}

end update

section extend

noncomputable theory
local attribute [instance, priority 10] classical.prop_decidable

variables {α β γ : Type*} {f : α → β}

/-- `extend f g e'` extends a function `g : α → γ`
along a function `f : α → β` to a function `β → γ`,
by using the values of `g` on the range of `f`
and the values of an auxiliary function `e' : β → γ` elsewhere.

Mostly useful when `f` is injective. -/
def extend (f : α → β) (g : α → γ) (e' : β → γ) : β → γ :=
λ b, if h : ∃ a, f a = b then g (classical.some h) else e' b

lemma extend_def (f : α → β) (g : α → γ) (e' : β → γ) (b : β) [decidable (∃ a, f a = b)] :
  extend f g e' b = if h : ∃ a, f a = b then g (classical.some h) else e' b :=
by { unfold extend, congr }

@[simp] lemma extend_apply (hf : injective f) (g : α → γ) (e' : β → γ) (a : α) :
  extend f g e' (f a) = g a :=
begin
  simp only [extend_def, dif_pos, exists_apply_eq_apply],
  exact congr_arg g (hf $ classical.some_spec (exists_apply_eq_apply f a))
end

@[simp] lemma extend_comp (hf : injective f) (g : α → γ) (e' : β → γ) :
  extend f g e' ∘ f = g :=
funext $ λ a, extend_apply hf g e' a

end extend

lemma uncurry_def {α β γ} (f : α → β → γ) : uncurry f = (λp, f p.1 p.2) :=
rfl

@[simp] lemma uncurry_apply_pair {α β γ} (f : α → β → γ) (x : α) (y : β) :
  uncurry f (x, y) = f x y :=
rfl

@[simp] lemma curry_apply {α β γ} (f : α × β → γ) (x : α) (y : β) :
  curry f x y = f (x, y) :=
rfl

section bicomp
variables {α β γ δ ε : Type*}

/-- Compose a binary function `f` with a pair of unary functions `g` and `h`.
If both arguments of `f` have the same type and `g = h`, then `bicompl f g g = f on g`. -/
def bicompl (f : γ → δ → ε) (g : α → γ) (h : β → δ) (a b) :=
f (g a) (h b)

/-- Compose an unary function `f` with a binary function `g`. -/
def bicompr (f : γ → δ) (g : α → β → γ) (a b) :=
f (g a b)

-- Suggested local notation:
local notation f `∘₂` g := bicompr f g

lemma uncurry_bicompr (f : α → β → γ) (g : γ → δ) :
  uncurry (g ∘₂ f) = (g ∘ uncurry f) := rfl

end bicomp

section uncurry

variables {α β γ δ : Type*}

/-- Records a way to turn an element of `α` into a function from `β` to `γ`. The most generic use
is to recursively uncurry. For instance `f : α → β → γ → δ` will be turned into
`↿f : α × β × γ → δ`. One can also add instances for bundled maps. -/
class has_uncurry (α : Type*) (β : out_param Type*) (γ : out_param Type*) := (uncurry : α → (β → γ))

/-- Uncurrying operator. The most generic use is to recursively uncurry. For instance
`f : α → β → γ → δ` will be turned into `↿f : α × β × γ → δ`. One can also add instances
for bundled maps.-/
add_decl_doc has_uncurry.uncurry

notation `↿`:max x:max := has_uncurry.uncurry x

instance has_uncurry_base : has_uncurry (α → β) α β := ⟨id⟩

instance has_uncurry_induction [has_uncurry β γ δ] : has_uncurry (α → β) (α × γ) δ :=
⟨λ f p, ↿(f p.1) p.2⟩

end uncurry

/-- A function is involutive, if `f ∘ f = id`. -/
def involutive {α} (f : α → α) : Prop := ∀ x, f (f x) = x

lemma involutive_iff_iter_2_eq_id {α} {f : α → α} : involutive f ↔ (f^[2] = id) :=
funext_iff.symm

namespace involutive
variables {α : Sort u} {f : α → α} (h : involutive f)
include h

@[simp]
lemma comp_self : f ∘ f = id := funext h

protected lemma left_inverse : left_inverse f f := h
protected lemma right_inverse : right_inverse f f := h

protected lemma injective : injective f := h.left_inverse.injective
protected lemma surjective : surjective f := λ x, ⟨f x, h x⟩
protected lemma bijective : bijective f := ⟨h.injective, h.surjective⟩

/-- Involuting an `ite` of an involuted value `x : α` negates the `Prop` condition in the `ite`. -/
protected lemma ite_not (P : Prop) [decidable P] (x : α) :
  f (ite P x (f x)) = ite (¬ P) x (f x) :=
by rw [apply_ite f, h, ite_not]

/-- An involution commutes across an equality. Compare to `function.injective.eq_iff`. -/
protected lemma eq_iff {x y : α} : f x = y ↔ x = f y :=
h.injective.eq_iff' (h y)

end involutive

/-- The property of a binary function `f : α → β → γ` being injective.
Mathematically this should be thought of as the corresponding function `α × β → γ` being injective.
-/
@[reducible] def injective2 {α β γ} (f : α → β → γ) : Prop :=
∀ ⦃a₁ a₂ b₁ b₂⦄, f a₁ b₁ = f a₂ b₂ → a₁ = a₂ ∧ b₁ = b₂

namespace injective2
variables {α β γ : Type*} (f : α → β → γ)

protected lemma left (hf : injective2 f) ⦃a₁ a₂ b₁ b₂⦄ (h : f a₁ b₁ = f a₂ b₂) : a₁ = a₂ :=
(hf h).1

protected lemma right (hf : injective2 f) ⦃a₁ a₂ b₁ b₂⦄ (h : f a₁ b₁ = f a₂ b₂) : b₁ = b₂ :=
(hf h).2

lemma eq_iff (hf : injective2 f) ⦃a₁ a₂ b₁ b₂⦄ : f a₁ b₁ = f a₂ b₂ ↔ a₁ = a₂ ∧ b₁ = b₂ :=
⟨λ h, hf h, λ⟨h1, h2⟩, congr_arg2 f h1 h2⟩

end injective2

section sometimes
local attribute [instance, priority 10] classical.prop_decidable

/-- `sometimes f` evaluates to some value of `f`, if it exists. This function is especially
interesting in the case where `α` is a proposition, in which case `f` is necessarily a
constant function, so that `sometimes f = f a` for all `a`. -/
noncomputable def sometimes {α β} [nonempty β] (f : α → β) : β :=
if h : nonempty α then f (classical.choice h) else classical.choice ‹_›

theorem sometimes_eq {p : Prop} {α} [nonempty α] (f : p → α) (a : p) : sometimes f = f a :=
dif_pos ⟨a⟩

theorem sometimes_spec {p : Prop} {α} [nonempty α]
  (P : α → Prop) (f : p → α) (a : p) (h : P (f a)) : P (sometimes f) :=
by rwa sometimes_eq

end sometimes

end function

/-- `s.piecewise f g` is the function equal to `f` on the set `s`, and to `g` on its complement. -/
def set.piecewise {α : Type u} {β : α → Sort v} (s : set α) (f g : Πi, β i)
  [∀j, decidable (j ∈ s)] :
  Πi, β i :=
λi, if i ∈ s then f i else g i

/-! ### Bijectivity of `eq.rec`, `eq.mp`, `eq.mpr`, and `cast` -/

lemma eq_rec_on_bijective {α : Sort*} {C : α → Sort*} :
  ∀ {a a' : α} (h : a = a'), function.bijective (@eq.rec_on _ _ C _ h)
| _ _ rfl := ⟨λ x y, id, λ x, ⟨x, rfl⟩⟩

lemma eq_mp_bijective {α β : Sort*} (h : α = β) : function.bijective (eq.mp h) :=
eq_rec_on_bijective h

lemma eq_mpr_bijective {α β : Sort*} (h : α = β) : function.bijective (eq.mpr h) :=
eq_rec_on_bijective h.symm

lemma cast_bijective {α β : Sort*} (h : α = β) : function.bijective (cast h) :=
eq_rec_on_bijective h

/-! Note these lemmas apply to `Type*` not `Sort*`, as the latter interferes with `simp`, and
is trivial anyway.-/

@[simp]
lemma eq_rec_inj {α : Sort*} {a a' : α} (h : a = a') {C : α → Type*} (x y : C a) :
  (eq.rec x h : C a') = eq.rec y h ↔ x = y :=
(eq_rec_on_bijective h).injective.eq_iff

@[simp]
lemma cast_inj {α β : Type*} (h : α = β) {x y : α} : cast h x = cast h y ↔ x = y :=
(cast_bijective h).injective.eq_iff

/-- A set of functions "separates points"
if for each pair of distinct points there is a function taking different values on them. -/
def set.separates_points {α β : Type*} (A : set (α → β)) : Prop :=
∀ ⦃x y : α⦄, x ≠ y → ∃ f ∈ A, (f x : β) ≠ f y


import set_theory.cardinal
import Rings.ToMathlib.fol
import data.W.cardinal

universes u v

namespace fol

variables {L : Language.{u}}

open_locale cardinal

open fol.Language

@[simp] def bounded_formula.rec2_aux {C : Πn, bounded_formula L n → Sort v}
  (hfalsum : Π {n}, C n ⊥)
  (hequal : Π {n} (t₁ t₂ : bounded_term L n), C n (t₁ ≃ t₂))
  (hrel : Π {n l : ℕ} (R : L.relations l) (ts : dvector (bounded_term L n) l),
    C n (bd_apps_rel (bd_rel R) ts))
  (himp : Π {n} {f₁ f₂ : bounded_formula L n} (ih₁ : C n f₁) (ih₂ : C n f₂), C n (f₁ ⟹ f₂))
  (hall : Π {n} {f : bounded_formula L (n+1)} (ih : C (n+1) f), C n (∀' f)) :
  ∀{n l} (f : bounded_preformula L n l) (ts : dvector (bounded_term L n) l),
  C n (bd_apps_rel f ts)
| _ _ bd_falsum dvector.nil := hfalsum
| _ _ (t₁ ≃ t₂) dvector.nil := hequal _ _
| _ _ (bd_rel R)         ts := hrel _ _
| _ _ (bd_apprel f t)    ts := by {let x := bounded_formula.rec2_aux f (dvector.cons t ts),
  dsimp [bd_apps_rel] at x, exact x }
| _ _ (f₁ ⟹ f₂) dvector.nil := himp (bounded_formula.rec2_aux f₁ dvector.nil)
  (bounded_formula.rec2_aux f₂ dvector.nil)
| _ _ (∀' f)    dvector.nil := hall (bounded_formula.rec2_aux f dvector.nil)

@[simp] def bounded_formula.rec2 {C : Πn, bounded_formula L n → Sort v}
  (hfalsum : Π {n}, C n ⊥)
  (hequal : Π {n} (t₁ t₂ : bounded_term L n), C n (t₁ ≃ t₂))
  (hrel : Π {n l : ℕ} (R : L.relations l) (ts : dvector (bounded_term L n) l),
    C n (bd_apps_rel (bd_rel R) ts))
  (himp : Π {n} {f₁ f₂ : bounded_formula L n} (ih₁ : C n f₁) (ih₂ : C n f₂), C n (f₁ ⟹ f₂))
  (hall : Π {n} {f : bounded_formula L (n+1)} (ih : C (n+1) f), C n (∀' f)) :
  ∀{n : ℕ} (f : bounded_formula L n), C n f :=
λ n f, bounded_formula.rec2_aux (λ _, hfalsum) (λ _, hequal) (λ _ _, hrel) (λ _ _ _, himp)
  (λ _ _, hall) f dvector.nil

namespace cardinal

variables (L) (n : ℕ)

/-- Write preterms as lists of the following symbols -/
inductive preterm_symbol : Type u
| nat : ℕ → preterm_symbol
| var : Π {l}, fin l → preterm_symbol
| func : Π {l}, L.functions l → preterm_symbol
| app : preterm_symbol

instance : infinite (preterm_symbol L) :=
infinite.of_injective preterm_symbol.nat (λ _ _, preterm_symbol.nat.inj)

/-- Capture the cardinality of `preterm_symbol` by writing it equivalently in terms of a sum.
  The forward map of the equivalence. -/
def fin_sum_formula_sum_nat_of_preterm_symbol : preterm_symbol L →
  (Σ l : ulift.{u} ℕ, ulift.{u} (fin l.down)) ⊕ (Σ l : ulift.{u} ℕ, L.functions l.down) ⊕ ℕ
| (preterm_symbol.nat n) := sum.inr $ sum.inr $ n.succ
| (preterm_symbol.var k) := sum.inl $ ⟨ ⟨_⟩ , ulift.up k ⟩
| (preterm_symbol.func f) := sum.inr $ sum.inl ⟨ ⟨_⟩, f ⟩
| preterm_symbol.app := sum.inr $ sum.inr 0

/-- Capture the cardinality of `preterm_symbol` by writing it equivalently in terms of a sum.
  The backward map of the equivalence. -/
def preterm_symbol_of_fin_sum_formula_sum_nat :
  (Σ l : ulift.{u} ℕ, ulift.{u} (fin l.down)) ⊕ (Σ l : ulift.{u} ℕ, L.functions l.down) ⊕ ℕ → preterm_symbol L
| (sum.inl ⟨ l , ⟨k⟩ ⟩) := preterm_symbol.var k
| (sum.inr $ sum.inl ⟨ l , f ⟩) := preterm_symbol.func f
| (sum.inr $ sum.inr 0) := preterm_symbol.app
| (sum.inr $ sum.inr (n+1)) := preterm_symbol.nat n

/-- Capture the cardinality of `preterm_symbol` by writing it equivalently in terms of a sum. -/
def preterm_symbol_equiv_fin_sum_formula_sum_nat :
  _root_.equiv (preterm_symbol L) $
  (Σ l : ulift.{u} ℕ, ulift.{u} (fin l.down)) ⊕ (Σ l : ulift.{u} ℕ, L.functions l.down) ⊕ ℕ :=
{ to_fun := fin_sum_formula_sum_nat_of_preterm_symbol L,
  inv_fun := preterm_symbol_of_fin_sum_formula_sum_nat L,
  left_inv := λ x, match x with
    | (preterm_symbol.nat n)  := rfl
    | (preterm_symbol.var k)  := rfl
    | (preterm_symbol.func f) := rfl
    | preterm_symbol.app      := rfl end,
  right_inv := λ x, match x with
    | (sum.inl ⟨ ⟨l⟩ , ⟨k⟩ ⟩) := rfl
    | (sum.inr $ sum.inl ⟨ ⟨l⟩ , f ⟩) := rfl
    | (sum.inr $ sum.inr 0) := rfl
    | (sum.inr $ sum.inr (n+1)) := rfl end, }

/-- We inject `bounded_preterm L n l` into lists of symbols, keeping track
  of how the preterm is built.
  We always include the number of free variables, and number of missing applications,
  we keep track of the constructor,
  and then we keep the data of the any inductively attained list,
  even their lengths (useful in the proof of injectivity). -/
@[simp] def preterm_symbol_of_preterm {n} : ∀ {l},
  bounded_preterm L n l → list (preterm_symbol L)
| _ (&k)         := [ preterm_symbol.var k ]
| l (bd_func f)  := [ preterm_symbol.func f ]
| l (bd_app t s) := [ preterm_symbol.app,
  preterm_symbol.nat (preterm_symbol_of_preterm t).length ]
  ++ preterm_symbol_of_preterm t ++ preterm_symbol_of_preterm s

lemma preterm_symbol_of_preterm_injective {l} :
  function.injective (@preterm_symbol_of_preterm L n l) :=
begin
  intros x,
  induction x with k _ _ _ tx sx htx hsx,
  { intro y,
    cases y,
    { intro h,
      simp only [preterm_symbol_of_preterm, eq_self_iff_true, heq_iff_eq,
        true_and, and_true] at h,
      subst h },
    { intro h, cases h },
    { intro h, cases h } },
  { intro y,
    cases y,
    { intro h, cases h },
    { intro h,
      simp only [preterm_symbol_of_preterm, eq_self_iff_true, heq_iff_eq,
        true_and, and_true] at h,
      subst h },
    { intro h, cases h } },
  { intro y,
    cases y with _ _ _ _ ty sy,
    { intro h, cases h },
    { intro h, cases h },
    { intro h, simp only [preterm_symbol_of_preterm, list.cons_append,
      list.singleton_append, eq_self_iff_true, true_and] at h,
      obtain ⟨ ht , hs ⟩ := list.append_inj h.2 h.1,
      congr, { exact htx ht }, { exact hsx hs } } },
end

variable {L}

lemma bounded_preterm_le_functions {l} : #(bounded_preterm L n l) ≤
  max (cardinal.sum (λ n : ulift.{u} (ℕ), #(L.functions n.down))) ω :=
calc #(bounded_preterm L n l) ≤ # (list (preterm_symbol L)) :
    cardinal.mk_le_of_injective (@preterm_symbol_of_preterm_injective L n l)
  ... = # (preterm_symbol L) : cardinal.mk_list_eq_mk (preterm_symbol L)
  ... ≤ max (cardinal.sum (λ n : ulift.{u} (ℕ), #(L.functions n.down))) ω :
begin
  rw cardinal.mk_congr (preterm_symbol_equiv_fin_sum_formula_sum_nat L),
  simp only [cardinal.mk_sum, cardinal.mk_sigma, cardinal.mk_fintype, fintype.card_ulift,
    fintype.card_fin, cardinal.lift_id, cardinal.mk_denumerable, cardinal.lift_omega],
  apply le_trans (cardinal.add_le_max _ _) (max_le (max_le _ _) (le_max_right _ _)),
  { apply le_max_of_le_right,
    apply le_trans (cardinal.sum_le_sup.{u} (λ (i : ulift.{u} ℕ), (i.down : cardinal.{u}))),
    apply le_trans (cardinal.mul_le_max _ _) (max_le (max_le _ _) (le_of_eq rfl)),
    { simp },
    { rw cardinal.sup_le, intro i, apply le_of_lt, rw cardinal.lt_omega, simp, }
  },
  { apply le_trans (cardinal.add_le_max _ _) (max_le (max_le _ _) (le_max_right _ _)),
    { simp },
    { exact le_max_right _ _ } }
end

/-- Write formulas as lists of the following symbols -/
inductive formula_symbol (L : Language.{u}) : Type u
| bot : formula_symbol
| eq : formula_symbol
| imp : formula_symbol
| all : formula_symbol
| term : Π (l : ℕ), bounded_term L l → formula_symbol
| nat : ℕ → formula_symbol

instance : infinite (formula_symbol L) :=
infinite.of_injective formula_symbol.nat (λ x y, formula_symbol.nat.inj)

/-- Capture the cardinality of `formula_symbol` by writing it equivalently in terms of a sum.
  The forward map of the equivalence. -/
def bounded_term_sum_nat_of_formula_symbol : formula_symbol L →
  (Σ l : ulift.{u} ℕ, bounded_term L l.down) ⊕ ulift.{u} ℕ
| formula_symbol.bot := sum.inr ⟨0⟩
| formula_symbol.eq := sum.inr ⟨1⟩
| formula_symbol.imp := sum.inr ⟨2⟩
| formula_symbol.all := sum.inr ⟨3⟩
| (formula_symbol.term l f) := sum.inl ⟨ ⟨l⟩ , f ⟩
| (formula_symbol.nat n) := sum.inr ⟨ n+4 ⟩

/-- Capture the cardinality of `formula_symbol` by writing it equivalently in terms of a sum.
  The backward map of the equivalence. -/
def formula_symbol_of_bounded_term_sum_nat :
  (Σ l : ulift.{u} ℕ, bounded_term L l.down) ⊕ ulift.{u} ℕ → formula_symbol L
| (sum.inl ⟨ l , f ⟩) := formula_symbol.term l.down f
| (sum.inr ⟨0⟩) := formula_symbol.bot
| (sum.inr ⟨1⟩) := formula_symbol.eq
| (sum.inr ⟨2⟩) := formula_symbol.imp
| (sum.inr ⟨3⟩) := formula_symbol.all
| (sum.inr (⟨ n+4 ⟩)) := formula_symbol.nat n

/-- Capture the cardinality of `formula_symbol` by writing it equivalently in terms of a sum. -/
def formula_symbol_equiv_bounded_term_sum_nat :
  _root_.equiv (formula_symbol L) ((Σ l : ulift.{u} ℕ, bounded_term L l.down) ⊕ ulift.{u} ℕ) :=
{ to_fun := bounded_term_sum_nat_of_formula_symbol,
  inv_fun := formula_symbol_of_bounded_term_sum_nat,
  left_inv := λ x, match x with
    | formula_symbol.bot := rfl
    | formula_symbol.eq :=  rfl
    | formula_symbol.imp := rfl
    | formula_symbol.all := rfl
    | (formula_symbol.term l f) := rfl
    | (formula_symbol.nat n) := rfl end,
  right_inv := λ x, match x with
    | (sum.inl ⟨ ⟨l⟩ , f ⟩) := rfl
    | (sum.inr ⟨0⟩) :=       rfl
    | (sum.inr ⟨1⟩) :=       rfl
    | (sum.inr ⟨2⟩) :=       rfl
    | (sum.inr ⟨3⟩) :=       rfl
    | (sum.inr (⟨ n+4 ⟩)) := rfl end, }

/-- We inject `bounded_formula L n` into lists of symbols, keeping track
  of how the formula is built.
  We always include the number of variables of the formula at the beginning
  by adding `logic_symbo.nat l`,
  we then note the symbol for the constructor,
  and then we keep the data of the any inductively attained list. -/
@[simp] def formula_symbol_of_formula [is_algebraic L] {n} :
  bounded_formula L n → list (formula_symbol L) :=
bounded_formula.rec2
  (λ l, [formula_symbol.nat l, formula_symbol.bot]) -- ⊥
  (λ l t s, [ formula_symbol.nat l, formula_symbol.eq ,
    formula_symbol.term l t , formula_symbol.term l s ]) -- t ≃ s
  (λ _ _ r, false.elim $ Language.is_algebraic.empty_relations _ r) -- bd_rel
  (λ l ϕ ψ lϕ lψ, (formula_symbol.nat l) :: (formula_symbol.nat (list.length lϕ))
    :: (formula_symbol.nat (list.length lψ)) :: formula_symbol.imp :: lϕ.append lψ ) -- ϕ ⟹ ψ
  (λ l ϕ lϕ, (formula_symbol.nat l) :: formula_symbol.all :: lϕ) -- ∀ₗ ϕ

lemma formula_symbol_of_preformula_injective' [is_algebraic L] {n} : ∀ (x : bounded_formula L n)
  {m} (y : bounded_formula L m),
  formula_symbol_of_formula x = formula_symbol_of_formula y → x == y :=
begin
  -- apply bounded_formula.rec2,
  have hrel : ∀ {l} {p : Prop} (r : L.relations l), p,
  { intros _ _ r,
    exact false.elim (Language.is_algebraic.empty_relations _ r) },
  apply @bounded_formula.rec2 _ (λ _ x, ∀ {m} (y : bounded_formula L m),
    formula_symbol_of_formula x = formula_symbol_of_formula y → x == y),
  { intro l,
    apply @bounded_formula.rec2 _ (λ n y,
      formula_symbol_of_formula _ = formula_symbol_of_formula y → _ == y),
    { intros k h, simp only [formula_symbol_of_formula, bounded_formula.rec2_aux,
        bounded_formula.rec2, eq_self_iff_true, and_true] at h, subst h },
    { intros _ _ _ h, cases h },
    { intros _ _ r, apply hrel r },
    { intros _ _ _ _ _ h, cases h },
    { intros _ _ _ h, cases h } },
  { intros l t s,
    apply @bounded_formula.rec2 _ (λ n y,
      formula_symbol_of_formula _ = formula_symbol_of_formula y → _ == y),
    { intros k h, cases h },
    { intros _ _ _ h, simp at h, cases h with h h', subst h, cases h' with h h',
      cases h with h h1, subst h1, cases h' with h' h'1, subst h'1 },
    { intros _ _ r, apply hrel r },
    { intros _ _ _ _ _ h, cases h },
    { intros _ _ _ h, cases h } },
  { intros _ _ r, apply hrel r },
  { intros l f₁ f₂ hf₁ hf₂,
    apply @bounded_formula.rec2 _ (λ n y,
      formula_symbol_of_formula _ = formula_symbol_of_formula y → _ == y),
    { intros k h, cases h },
    { intros _ _ _ h, cases h },
    { intros _ _ r, apply hrel r },
    { intros l' f₁' f₂' hf₁' hf₂' h, simp at h, obtain ⟨ hll' , hlenϕ , hlenψ , h ⟩ := h,
      subst hll', obtain ⟨ hf₁f₁' , hf₂f₂'⟩ := list.append_inj h hlenϕ, congr,
      { simp at hf₁, specialize hf₁ f₁' hf₁f₁', subst hf₁ },
      { simp at hf₂, specialize hf₂ f₂' hf₂f₂', subst hf₂ } },
    { intros _ _ _ h, cases h } },
  { intros l f₁ hf₁ m, apply @bounded_formula.rec2 _
      (λ n y, formula_symbol_of_formula _ = formula_symbol_of_formula y → _ == y),
    { intros k h, cases h, },
    { intros _ _ _ h, cases h },
    { intros _ _ r, apply hrel r },
    { intros _ _ _ _ _ h, cases h },
    { intros k f₂ hf₂ h, simp only [formula_symbol_of_formula, bounded_formula.rec2_aux,
        bounded_formula.rec2, eq_self_iff_true, true_and] at h hf₁,
      cases h with hlk h, subst hlk, congr1, apply eq_of_heq, apply hf₁, exact h } },
end

lemma formula_symbol_of_preformula_injective [is_algebraic L] {n}:
  function.injective (@formula_symbol_of_formula L _ n) :=
begin
  intros x y hxy,
  have h := formula_symbol_of_preformula_injective' x y hxy,
  subst h,
end

variable (L)

lemma bounded_formula_le_bounded_term [is_algebraic L] {n} :
  #(bounded_formula L n) ≤ max (cardinal.sum (λ n : ulift.{u} ℕ, #(bounded_term L n.down))) ω :=
calc #(bounded_formula L n) ≤ # (list (formula_symbol L)) :
    cardinal.mk_le_of_injective (formula_symbol_of_preformula_injective)
  ... = # (formula_symbol L) : cardinal.mk_list_eq_mk _
  ... = _ : cardinal.mk_congr formula_symbol_equiv_bounded_term_sum_nat
  ... ≤ max (cardinal.sum (λ n : ulift.{u} ℕ, #(bounded_term L n.down))) ω : by {
  simp only [le_refl, and_true, cardinal.mk_denumerable, cardinal.mk_sum, cardinal.lift_omega,
    cardinal.mk_sigma, cardinal.lift_id],
  apply le_trans (cardinal.add_le_max _ _) (max_le (max_le _ _) (le_max_right _ _)),
  { exact le_max_left _ _ },
  { exact le_max_right _ _ } }

lemma bounded_formula_le_functions [is_algebraic L] {n} :
  #(bounded_formula L n) ≤ max (cardinal.sum (λ n : ulift.{u} ℕ, #(L.functions n.down))) ω :=
begin
  apply le_trans (bounded_formula_le_bounded_term L),
  apply max_le _ (le_max_right _ _),
  apply le_trans (cardinal.sum_le_sup _),
  simp only [cardinal.mk_denumerable],
  apply le_trans (cardinal.mul_le_max _ _),
  apply max_le _ (le_max_right _ _),
  apply max_le (le_max_right _ _),
  rw cardinal.sup_le,
  intro i,
  apply bounded_preterm_le_functions,
end

end cardinal

end fol


import data.vector
import data.nat.basic
import data.pnat.prime

def squarefree {k:ℕ} (w: vector (fin 2) k) : Prop :=
∀ l:ℕ, l < w.length → ∀ v : vector (fin 2) l,
v.1 ≠ list.nil → ¬ list.is_infix (v.1 ++ v.1) w.1

instance (w : vector (fin 2) 4) : decidable (squarefree w)
:=
decidable_of_iff (∀ l:ℕ, l < w.length → ∀ v : vector (fin 2) l,
v.1 ≠ list.nil → ¬ list.is_infix (v.1 ++ v.1) w.1
) (by rw squarefree)

example : ∀ w : vector (fin 2) 4,
¬ squarefree w := dec_trivial