import topology.algebra.ordered

import for_mathlib.filter
import for_mathlib.topology

import valuation.linear_ordered_comm_group_with_zero

/-!
# The topology on linearly ordered commutative groups with zero

Let Γ₀ be a linearly ordered commutative group to which we have adjoined a zero element.
Then Γ₀ may naturally be endowed with a topology that turns Γ₀ into a topological monoid.
The topology is the following:
A subset U ⊆ Γ₀ is open if 0 ∉ U or if there is an invertible γ₀ ∈ Γ₀ such that {γ | γ < γ₀} ⊆ U.

-/

local attribute [instance, priority 0] classical.DLO
open_locale topological_space

namespace linear_ordered_comm_group_with_zero
open topological_space filter set linear_ordered_structure
variables (Γ₀ : Type*) [linear_ordered_comm_group_with_zero Γ₀]

/--The neighbourhoods around γ ∈ Γ₀, used in the definition of the topology on Γ₀.
These neighbourhoods are defined as follows:
A set s is a neighbourhood of 0 if there is an invertible γ₀ ∈ Γ₀ such that {γ | γ < γ₀} ⊆ s.
If γ ≠ 0, then every set that contains γ is a neighbourhood of γ. -/
def nhds_fun : Γ₀ → filter Γ₀ :=
  (λ x : Γ₀, if x = 0 then ⨅ (γ₀ : units Γ₀), principal {γ | γ < γ₀} else pure x)

/--The topology on a linearly ordered commutative group with a zero element adjoined.
A subset U is open if 0 ∉ U or if there is an invertible element γ₀ such that {γ | γ < γ₀} ⊆ U. -/
protected def topological_space : topological_space Γ₀ :=
topological_space.mk_of_nhds (nhds_fun Γ₀)

local attribute [instance] linear_ordered_comm_group_with_zero.topological_space

/--The neighbourhoods {γ | γ < γ₀} of 0 form a directed set indexed by the invertible elements γ₀.-/
@[nolint]
lemma directed_lt : directed (≥) (λ (γ₀ : units Γ₀), principal {γ : Γ₀ | γ < ↑γ₀}) :=
begin
  intros γ₁ γ₂,
  use min γ₁ γ₂,
  split,
  { change  principal {γ : Γ₀ | γ < ↑(min γ₁ γ₂)} ≤ principal {γ : Γ₀ | γ < ↑γ₁},
    rw [principal_mono, coe_min],
    intros x x_in,
    calc x < min ↑γ₁ ↑γ₂ : x_in
        ... ≤ γ₁ : min_le_left _ _ },
  { change  principal {γ : Γ₀ | γ < ↑(min γ₁ γ₂)} ≤ principal {γ : Γ₀ | γ < ↑γ₂},
    rw [principal_mono, coe_min],
    intros x x_in,
    calc x < min ↑γ₁ ↑γ₂ : x_in
        ... ≤ γ₂ : min_le_right _ _ }
end

-- We need two auxilliary lemmas to show that nhds_fun accurately describes the neighbourhoods
-- coming from the topology (that is defined in terms of nhds_fun).

/--At all points of a linearly ordered commutative group with a zero element adjoined,
the pure filter is smaller than the filter given by nhds_fun.-/
private lemma pure_le_nhds_fun : pure ≤ nhds_fun Γ₀ :=
λ x, by { by_cases hx : x = 0; simp [hx, nhds_fun] }

/--For every point Γ₀, and every “neighbourhood” s of it (described by nhds_fun), there is a
smaller “neighbourhood” t ⊆ s, such that s is a “neighbourhood“ of all the points in t.-/
private lemma nhds_fun_ok : ∀ (x : Γ₀) (s ∈ nhds_fun Γ₀ x),
  (∃ t ∈ nhds_fun Γ₀ x, t ⊆ s ∧ ∀ y ∈ t, s ∈ nhds_fun Γ₀ y) :=
begin
  intros x U U_in,
  by_cases hx : x = 0,
  { simp [hx, nhds_fun] at U_in ⊢,
    change U ∈ ⨅ (γ₀ : units Γ₀), principal {γ : Γ₀ | γ < ↑γ₀} at U_in,
    rw mem_infi (directed_lt Γ₀) ⟨1⟩ at U_in,
    cases U_in with γ₀ h,
    use {γ : Γ₀ | γ < ↑γ₀},
    rw mem_principal_sets at h,
    split,
    { apply mem_infi_sets γ₀,
      rw mem_principal_sets},
    { refine ⟨h, _⟩,
      intros y y_in,
      by_cases hy : y = 0 ; simp [hy, h y_in],
      { apply mem_infi_sets γ₀,
        rwa mem_principal_sets } } },
  { simp [hx, nhds_fun] at U_in ⊢,
    use {x},
    refine ⟨mem_singleton _, singleton_subset_iff.2 U_in, _⟩,
    intros y y_in,
    rw mem_singleton_iff at y_in,
    rw y_in,
    simpa [hx] }
end

variables  {Γ₀}
/--The neighbourhood filter of an invertible element consists of all sets containing that element.-/
@[simp] lemma nhds_coe (γ : units Γ₀) : 𝓝 (γ : Γ₀) = pure (γ : Γ₀) :=
calc 𝓝 (γ : Γ₀) = nhds_fun Γ₀ γ : nhds_mk_of_nhds (nhds_fun Γ₀) γ (pure_le_nhds_fun Γ₀) (nhds_fun_ok Γ₀)
              ... = pure (γ : Γ₀) : if_neg (group_with_zero.unit_ne_zero γ)

/--The neighbourhood filter of a nonzero element consists of all sets containing that element.-/
@[simp] lemma nhds_of_ne_zero (γ : Γ₀) (h : γ ≠ 0) :
  𝓝 γ = pure γ :=
nhds_coe (group_with_zero.mk₀ _ h)

/--If γ is an invertible element of a linearly ordered group with zero element adjoined,
then {γ} is a neighbourhood of γ.-/
lemma singleton_nhds_of_units (γ : units Γ₀) : ({γ} : set Γ₀) ∈ 𝓝 (γ : Γ₀) :=
by simp

/--If γ is a nonzero element of a linearly ordered group with zero element adjoined,
then {γ} is a neighbourhood of γ.-/
lemma singleton_nhds_of_ne_zero (γ : Γ₀) (h : γ ≠ 0) : ({γ} : set Γ₀) ∈ 𝓝 (γ : Γ₀) :=
by simp [h]

/--If U is a neighbourhood of 0 in a linearly ordered group with zero element adjoined,
then there exists an invertible element γ₀ such that {γ | γ < γ₀} ⊆ U.
-/
lemma nhds_zero_mem (U : set Γ₀) : U ∈ 𝓝 (0 : Γ₀) ↔ ∃ γ₀ : units Γ₀, {γ : Γ₀ | γ < γ₀} ⊆ U :=
begin
  rw nhds_mk_of_nhds (nhds_fun Γ₀) 0 (pure_le_nhds_fun Γ₀) (nhds_fun_ok Γ₀),
  simp [nhds_fun],
  rw mem_infi (directed_lt Γ₀) ⟨1⟩,
  { split,
    { rintro ⟨γ₀, H⟩,
      rw mem_principal_sets at H,
      use [γ₀, H] },
    { rintro ⟨γ₀, H⟩,
      use γ₀,
      rwa mem_principal_sets } }
end

/--If γ is an invertible element of a linearly ordered group with zero element adjoined,
then {x | x < γ} is a neighbourhood of 0.-/
lemma nhds_zero_of_units (γ : units Γ₀) : {x : Γ₀ | x < γ} ∈ 𝓝 (0 : Γ₀) :=
by { rw nhds_zero_mem, use γ }

/--If γ is a nonzero element of a linearly ordered group with zero element adjoined,
then {x | x < γ} is a neighbourhood of 0.-/
lemma nhds_zero_of_ne_zero (γ : Γ₀) (h : γ ≠ 0) : {x : Γ₀ | x < γ} ∈ 𝓝 (0 : Γ₀) :=
nhds_zero_of_units (group_with_zero.mk₀ _ h)

variable (Γ₀)

/--The topology on a linearly ordered group with zero element adjoined
is compatible with the order structure.-/
lemma ordered_topology : order_closed_topology Γ₀ :=
{ is_closed_le' :=
  begin
    show is_open {p : Γ₀ × Γ₀ | ¬p.fst ≤ p.snd},
    simp only [not_le],
    rw is_open_iff_mem_nhds,
    rintros ⟨a,b⟩ hab,
    change b < a at hab,
    have ha : a ≠ 0 := ne_zero_of_lt hab,
    rw [nhds_prod_eq, mem_prod_iff],
    by_cases hb : b = 0,
    { subst b,
      use [{a}, singleton_nhds_of_ne_zero _ ha, {x : Γ₀ | x < a}, nhds_zero_of_ne_zero _ ha],
      intros p p_in,
      cases mem_prod.1 p_in with h1 h2,
      rw mem_singleton_iff at h1,
      change p.2 < p.1,
      rwa h1 },
    { use [{a}, singleton_nhds_of_ne_zero _ ha, {b}, singleton_nhds_of_ne_zero _ hb],
      intros p p_in,
      cases mem_prod.1 p_in with h1 h2,
      rw mem_singleton_iff at h1 h2,
      change p.2 < p.1,
      rwa [h1, h2] }
  end }

local attribute [instance] ordered_topology

/--The topology on a linearly ordered group with zero element adjoined is T₂ (aka Hausdorff).-/
lemma t2_space : t2_space Γ₀ := order_closed_topology.to_t2_space

local attribute [instance] t2_space

/--The topology on a linearly ordered group with zero element adjoined is T₃ (aka regular).-/
lemma regular_space : regular_space Γ₀ :=
begin
  haveI : t1_space Γ₀ := t2_space.t1_space,
  split,
  intros s x s_closed x_not_in_s,
  by_cases hx : x = 0,
  { refine ⟨s, _, subset.refl _, _⟩,
    { subst x,
      rw is_open_iff_mem_nhds,
      intros y hy,
      by_cases hy' : y = 0, { subst y, contradiction },
      simpa [hy'] },
    { rw inf_eq_bot_iff,
      use -s,
      simp only [exists_prop, mem_principal_sets],
      split,
      exact mem_nhds_sets (by rwa is_open_compl_iff) (by rwa mem_compl_iff),
      exact ⟨s, subset.refl s, by simp⟩ } },
  { simp only [inf_eq_bot_iff, exists_prop, mem_principal_sets],
    exact ⟨-{x}, is_open_compl_iff.mpr is_closed_singleton, by rwa subset_compl_singleton_iff,
          {x}, singleton_nhds_of_ne_zero x hx, -{x}, by simp [subset.refl]⟩ }
end

/--The filter basis around the 0 element of a linearly ordered group with zero element adjoined.-/
def zero_filter_basis : filter_basis Γ₀ :=
{ sets := range (λ γ : units Γ₀, {x : Γ₀ | x < γ}),
  ne_empty := range_nonempty _,
  directed := begin
    intros s t hs ht,
    rw mem_range at hs ht,
    rcases hs with ⟨γs, rfl⟩,
    rcases ht with ⟨γt, rfl⟩,
    simp only [exists_prop, mem_range],
    rcases directed_lt Γ₀ γs γt with ⟨γ, hs, ht⟩,
    change principal {g : Γ₀ | g < ↑γ} ≤ principal {g : Γ₀ | g < ↑γt} at ht,
    change principal {g : Γ₀ | g < ↑γ} ≤ principal {g : Γ₀ | g < ↑γs} at hs,
    rw [le_principal_iff, mem_principal_sets] at hs ht,
    use [{x : Γ₀ | x < γ}, γ, rfl, subset_inter_iff.mpr ⟨hs, ht⟩]
  end}

variable {Γ₀}

-- TODO: Generalise the following definition into something like filter_basis.pure.

/--The filter basis around nonzero elements of
a linearly ordered group with zero element adjoined.-/
@[nolint]
def ne_zero_filter_basis (x : Γ₀) : filter_basis Γ₀ :=
{ sets := ({({x} : set Γ₀)} : set (set Γ₀)),
  ne_empty := by simp,
  directed := by finish }

variable (Γ₀)

/--The neighbourhood basis of a linearly ordered group with zero element adjoined.-/
def nhds_basis : nhds_basis Γ₀ :=
{ B := λ x, if h : x = 0 then zero_filter_basis Γ₀ else ne_zero_filter_basis x,
  is_nhds := begin
    intro x,
    ext s,
    split_ifs with hx,
    { subst x,
      rw nhds_zero_mem,
      simp [zero_filter_basis, filter_basis.mem_filter, filter_basis.mem_iff],
      split,
      { rintros ⟨γ₀, h⟩,
        use [{x : Γ₀ | x < ↑γ₀}, γ₀, h] },
      { rintros ⟨_, ⟨γ₀, rfl⟩, h⟩,
        exact ⟨γ₀, h⟩ } },
    { simp [hx, filter_basis.mem_filter, filter_basis.mem_iff, ne_zero_filter_basis], }
  end }

local attribute [instance] nhds_basis

lemma mem_nhds_basis_zero {U : set Γ₀} :
  U ∈ nhds_basis.B (0 : Γ₀) ↔ ∃ γ : units Γ₀, U = {x : Γ₀ | x < γ } :=
begin
  dsimp [nhds_basis, zero_filter_basis],
  simp only [dif_pos],
  convert iff.rfl,
  simp [eq_comm]
end

lemma mem_nhds_basis_ne_zero {U : set Γ₀} {γ₀ : Γ₀} (h : γ₀ ≠ 0) :
  U ∈ nhds_basis.B γ₀ ↔ U = {γ₀} :=
begin
  dsimp [nhds_basis],
  simp only [dif_neg h],
  dsimp [filter_basis.has_mem, ne_zero_filter_basis γ₀],
  exact set.mem_singleton_iff
end

variable {Γ₀}

-- until the end of this section, all linearly ordered commutative groups will be endowed with
-- the discrete topology
variables (α : Type*) [linear_ordered_comm_group α]

/--The discrete topology on a linearly ordered commutative group.-/
@[nolint] def discrete_ordered_comm_group : topological_space α := ⊥
local attribute [instance] discrete_ordered_comm_group

lemma ordered_comm_group_is_discrete : discrete_topology α := ⟨rfl⟩
local attribute [instance] ordered_comm_group_is_discrete

lemma comap_coe_nhds (γ : units Γ₀) : 𝓝 γ = comap coe (𝓝 (γ : Γ₀)) :=
begin
  rw [nhds_discrete, filter.comap_pure (λ _ _ h, units.ext h) γ],
  change comap coe (pure (γ : Γ₀)) = comap coe (𝓝 ↑γ),
  rw ← nhds_coe γ,
end

lemma tendsto_zero {α : Type*} {F : filter α} {f : α → Γ₀} :
  tendsto f F (𝓝 (0 : Γ₀)) ↔ ∀ γ₀ : units Γ₀, { x : α | f x < γ₀ } ∈ F :=
begin
  rw nhds_basis.tendsto_into,
  simp only [mem_nhds_basis_zero, exists_imp_distrib],
  split ; intro h,
  { intro γ₀,
    exact h {γ | γ < ↑γ₀} γ₀ rfl },
  { rintros _ γ₀ rfl,
    exact h γ₀ }
end

lemma mem_nhds_zero {s} :
  s ∈ 𝓝 (0 : Γ₀) ↔ ∃ γ : units Γ₀, { x : Γ₀ | x < γ } ⊆ s :=
begin
  rw nhds_basis.mem_nhds_iff,
  simp only [exists_prop, mem_nhds_basis_zero],
  split,
  { rintros ⟨_, ⟨⟨γ, rfl⟩, h⟩⟩,
    exact ⟨γ, h⟩ },
  { rintros ⟨γ, h⟩,
    exact ⟨{x : Γ₀ | x < γ}, ⟨γ, rfl⟩, h⟩ }
end

lemma mem_nhds_coe {s} {γ : Γ₀} (h : γ ≠ 0) :
  s ∈ 𝓝 γ ↔ γ ∈ s :=
begin
  rw nhds_basis.mem_nhds_iff,
  simp only [exists_prop, mem_nhds_basis_ne_zero _ h, h],
  split,
  { rintros ⟨_, rfl, h₂⟩,
    rwa singleton_subset_iff at h₂ },
  { intro h,
    use [{γ}, rfl],
    rwa singleton_subset_iff },
end

lemma tendsto_nonzero {α : Type*} {F : filter α} {f : α → Γ₀} {γ₀ : Γ₀} (h : γ₀ ≠ 0) :
  tendsto f F (𝓝 (γ₀ : Γ₀)) ↔ { x : α | f x = γ₀ } ∈ F :=
begin
  rw nhds_basis.tendsto_into,
  simp only [mem_nhds_basis_ne_zero _ h, forall_eq],
  convert iff.rfl,
  ext s,
  exact mem_singleton_iff.symm
end

/--A linearly ordered commutative group with zero Γ₀ is a topological monoid
if it is endowed with the following topology:
A subset U ⊆ Γ₀ is open if 0 ∉ U or if there is an invertible γ₀ ∈ Γ₀ such that {γ | γ < γ₀} ⊆ U.
-/
instance : topological_monoid Γ₀ :=
⟨begin
  rw continuous_iff_continuous_at,
  rintros ⟨x, y⟩,
  by_cases hx : x = 0; by_cases hy : y = 0,
  all_goals {
    try {subst x}, try {subst y},
    intros U U_in,
    rw nhds_prod_eq,
    try { simp only [_root_.mul_zero, _root_.zero_mul] at U_in},
    rw mem_nhds_zero at U_in <|> rw [mem_nhds_coe] at U_in,
    rw mem_map,
    rw mem_prod_same_iff <|> rw mem_prod_iff,
    try { cases U_in with γ hγ } },
  { cases linear_ordered_structure.exists_square_le γ with γ₀ hγ₀,
    simp only [mem_nhds_zero, exists_prop],
    refine ⟨{x : Γ₀ | x < ↑γ₀}, ⟨γ₀, subset.refl _⟩, _⟩,
    rw set.prod_subset_iff,
    intros x x_in y y_in,
    apply hγ,
    change x*y < γ,
    have := mul_lt_mul' x_in y_in,
    refine lt_of_lt_of_le this _,
    exact_mod_cast hγ₀ },
  { simp only [set.prod_subset_iff, mem_nhds_zero, mem_nhds_coe hy, exists_prop],
    use [{x : Γ₀ | x < γ*y⁻¹}, γ * (group_with_zero.mk₀ y hy)⁻¹, subset.refl _,
      {(group_with_zero.mk₀ y hy)}, mem_singleton y],
    intros x x_in y' y'_in,
    rw mem_singleton_iff at y'_in,
    rw y'_in,
    apply hγ,
    change x * y < γ,
    simpa [hy] using mul_lt_right' y x_in hy, },
  { simp only [set.prod_subset_iff, mem_nhds_zero, mem_nhds_coe hx, exists_prop],
    use [{(group_with_zero.mk₀ x hx)}, mem_singleton _, {y : Γ₀ | y < γ*x⁻¹},
      γ * (group_with_zero.mk₀ x hx)⁻¹, subset.refl _],
    intros x' x'_in y y_in,
    rw mem_singleton_iff at x'_in,
    rw x'_in,
    apply hγ,
    change x * y < γ,
    rw mul_comm,
    simpa [hx] using mul_lt_right' x y_in hx, },
  { simp [mem_nhds_coe, hx, hy],
    use [{x}, mem_singleton _, {y}, mem_singleton _],
    rw set.prod_subset_iff,
    intros x' x'_in y' y'_in,
    rw mem_singleton_iff at *,
    rw [x'_in, y'_in],
    simpa using U_in },
  { assume H, simp at H, tauto }
end⟩

end linear_ordered_comm_group_with_zero


theorem add_right_cancel_iff (t a b : mynat) :  a + t = b + t ↔ a = b :=
begin
split,
exact add_right_cancel a t b,
induction t with k Pk,
rw add_zero,
rw add_zero,
intro x, exact x,
intro f,
rw add_succ, rw add_succ,
have g := Pk(f),
rw g,
refl,
end


import permutation_representation.action_representation
import Tools.tools
import basic_definitions.matrix_representation
open is_basis linear_map character
universes u v  w w'

open general classical_basis
open finite_action
open fintype
variables (G : Type u) [group G]
          (R : Type v) [comm_ring R]
          (X : Type w)[fintype X][decidable_eq X]
          [mul_action G X]

@[simp]theorem valvl  (g : G) : mat (Perm G R X) g  = λ x y,  if   g • y = x  then 1 else 0 :=
begin
    apply matrix.ext,intros i j,
    unfold mat,  unfold to_matrix,unfold to_matrixₗ, dsimp, --- faire mieux
    erw ← finite_action.Perm_ext,
    erw action_on_basis_apply,
end

lemma Grall (g : G) : (λ i : X, mat (Perm G R X) g i i) = (λ i : X, if  g • i = i then  1 else 0 ) := begin
    funext,rw valvl,
end

@[simp]theorem χ_value_eq_fixed_point (g : G ): χ (Perm G R X) g = card ({x : X | g • x = x}  : set X):=
begin
    unfold χ,simp,exact rfl,
end
namespace Regular

def Cayley_action (G : Type u) [group G] : mul_action G G := {
    smul        := λ g r, g * r,
    one_smul    := begin intros, dsimp, rw one_mul, end,
    mul_smul    := begin  intros, dsimp, rw mul_assoc,end }

def Regular_representation (G : Type u) [group G][fintype G][decidable_eq G](R :Type v)[comm_ring R] :
group_representation G R (G → R) := @Perm G R G _ _(Cayley_action G)

variables [fintype G][decidable_eq G]

lemma terere (X : Type u)[fintype X][decidable_eq X]  : (fintype.card ({x : X | true })) =  (fintype.card X)   :=
begin
       exact fintype.card_congr (  equiv.set.univ X),
end
/--
   `χ (Regular_representation G R ) g = if g = 1 then card G else 0  `
-/
theorem character_of_regular_representation (g : G):  χ (Regular_representation G R ) g = if g = 1 then card G else (0  ) :=
begin
    erw χ_value_eq_fixed_point,
    split_ifs,
    rw h,simp,apply congr_arg nat.cast, apply fintype.card_congr,
    exact equiv.set.univ G,
    change _ = nat.cast 0,
    apply congr_arg nat.cast, simp,
    refine le_bot_iff.mp _,
    intro,
        intro hyp,
        simp at hyp, have r  : g * a = a,
            exact hyp,
        have rr : g = 1,
            exact mul_left_eq_self.mp (congr_arg (has_mul.mul g) (congr_arg (has_mul.mul g) hyp)),
            trivial,
end
end Regular


/-
This file defines and proves the correctness of the direct (or naive)
encoding of the n-variable boolean parity constraint.

Authors: Cayden Codel, Jeremy Avigad, Marijn Heule
Carnegie Mellon University
-/

import cnf.literal
import cnf.assignment
import cnf.clause
import cnf.cnf
import cnf.encoding
import parity.parity
import parity.explode
import basic

import data.list.basic
import data.nat.basic

-- Represents the type of the variable stored in the literal
variables {V : Type*} [decidable_eq V] [inhabited V]

namespace parity

open literal clause cnf encoding
open list nat explode
open parity

/-! # Direct encoding -/
section direct_encoding

variables {l : list (literal V)} {c : clause V}

/- The direct encoding is the set of all possible clauses with an even number
   of negations on the provided literals in a single CNF formula. -/
def direct_parity' : list (literal V) → cnf V
| []        := [[]]
| (l :: ls) := (explode (map var ls)).map
      (λ c, ite (!bodd (c.count_flips ls)) (l :: c) (l.flip :: c))

-- Translated into an encoding type
def direct_parity : enc_fn V := dir_enc direct_parity'

@[simp] theorem direct_parity_nil : direct_parity' ([] : list (literal V)) = [[]] := rfl
@[simp] theorem direct_parity_singleton (lit : literal V) : direct_parity' [lit] = [[lit]] := rfl

theorem mem_explode_of_mem_direct_parity : c ∈ direct_parity' l → c ∈ explode (map var l) :=
begin
  cases l with l ls,
  { simp only [explode_nil, imp_self, direct_parity_nil, map_nil] },
  { simp [direct_parity', explode],
    intros cl hcl,
    cases l,
    { cases (bodd (cl.count_flips ls)),
      { simp, intro h, use [cl, hcl, h] },
      { simp, intro h, unfold literal.flip at h,
        right, use [cl, hcl, h] } },
    { cases (bodd (cl.count_flips ls)),
      { simp, intro h, right, use [cl, hcl, h] },
      { simp, intro h, unfold literal.flip at h,
        use [cl, hcl, h] } } }
end

theorem length_direct_parity : l ≠ [] → length (direct_parity' l) = 2^(length l - 1) :=
begin
  cases l,
  { contradiction },
  { simp only [direct_parity', length_explode, add_zero, length, add_succ_sub_one,
      ne.def, forall_true_left, not_false_iff, length_map] }
end

theorem length_direct_parity_pos : l ≠ [] → length (direct_parity' l) > 0 :=
assume h, by simp only [length_direct_parity h, succ_pos', gt_iff_lt, pow_pos]

theorem exists_mem_direct_parity (l : list (literal V)) : ∃ (c : clause V), c ∈ direct_parity' l :=
begin
  cases l with l ls,
  { use [nil, mem_singleton_self nil] },
  { exact exists_mem_of_length_pos (length_direct_parity_pos (cons_ne_nil l ls)) }
end

-- These theorems begin to be dependent on order of encoding
-- If the underlying type of parity changes to (fin)set, must update
theorem map_var_eq_of_mem_direct_parity : c ∈ direct_parity' l → map var c = map var l :=
begin
  cases l with l ls,
  { simp only [direct_parity', imp_self, map_eq_nil, map_nil, mem_singleton] },
  { simp [direct_parity'],
    intros c hc,
    cases (bodd (c.count_flips ls)),
    { simp only [if_true, eq_self_iff_true],
      rintro rfl,
      simp [map_var_eq_iff_mem_explode.mpr hc] },
    { simp only [if_false],
      rintro rfl,
      simp [map_var_eq_iff_mem_explode.mpr hc, flip_var_eq] } }
end

theorem even_flips_iff_mem_direct_parity_of_map_var_eq : map var c = map var l →
  (bodd (c.count_flips l) = ff ↔ c ∈ direct_parity' l) :=
begin
  intro hc,
  cases l with l ls,
  { rw [map_nil, map_eq_nil] at hc, subst hc,
    simp only [count_flips_self, bodd_zero, eq_self_iff_true, direct_parity_nil, mem_singleton] },
  { split,
    { simp only [direct_parity', map_cons, bool.cond_to_bool, mem_map],
      intro hf,
      rcases exists_cons_of_map_cons hc with ⟨x, xs, rfl, hx, hxs⟩,
      use xs, split,
      { exact map_var_eq_iff_mem_explode.mp hxs },
      { cases h : (bodd (clause.count_flips xs ls)),
        { rcases var_eq_iff_eq_or_flip_eq.mp hx with rfl | hx,
          { simp only [bool.bnot_ff, coe_sort_tt, if_true], },
          { simp [clause.count_flips, hx] at hf,
            rw h at hf, contradiction } },
        { rcases var_eq_iff_eq_or_flip_eq.mp hx with hx | rfl,
          { simp [clause.count_flips, hx] at hf,
            rw h at hf, contradiction },
          { simp only [flip_flip, bool.bnot_tt, coe_sort_ff, if_false]} } } },
    { { simp only [direct_parity', bool.cond_to_bool, mem_map],
        rintro ⟨a, ha, hf⟩,
        rcases exists_cons_of_map_cons hc with ⟨x, xs, rfl, hx, hxs⟩,
        cases h : (nat.bodd (a.count_flips ls));
        { simp only [h, if_true, eq_self_iff_true, if_false] at hf,
          simp [← hf, clause.count_flips, literal.is_neg, bool.to_nat, h, flip_flip _, flip_ne] } } } }
end

theorem odd_flips_iff_not_mem_direct_parity_of_map_var_eq : map var c = map var l →
  (bodd (c.count_flips l) = tt ↔ c ∉ direct_parity' l) :=
begin
  intro hc, split,
  { intro hcount, by_contradiction,
    rw (even_flips_iff_mem_direct_parity_of_map_var_eq hc).mpr h at hcount,
    contradiction },
  { contrapose, simp only [eq_ff_eq_not_eq_tt, not_not],
    exact (even_flips_iff_mem_direct_parity_of_map_var_eq hc).mp }
end

theorem mem_direct_parity_self (l : list (literal V)) : l ∈ (direct_parity' l) :=
begin
  have hcount := clause.count_flips_self l,
  have := nat.bodd_zero,
  rw ← hcount at this,
  exact (even_flips_iff_mem_direct_parity_of_map_var_eq (refl _)).mp this
end

-- Some proofs require the stronger statement that direct is exactly parity
theorem eval_direct_parity_eq_eval_parity (l : list (literal V)) (τ : assignment V) :
  (direct_parity' l).eval τ = parity.eval τ l :=
begin
  cases l with l ls,
  { simp only [cnf.eval_singleton, eval_nil, direct_parity_nil, clause.eval_nil] },
  { have he := eval_eq_bodd_count_tt τ (l :: ls),
    cases h : (parity.eval τ (l :: ls)),
    { apply eval_ff_iff_exists_clause_eval_ff.mpr,
      use (clause.falsify τ (map var (l :: ls))),
      split,
      { rw [← clause.count_flips_falsify_eq_count_tt τ (l :: ls),
            clause.count_flips_comm] at he,
        apply (even_flips_iff_mem_direct_parity_of_map_var_eq
          (clause.falsify_map_var_eq τ (map var (l :: ls)))).mp,
        rw ← h,
        exact he.symm },
      { exact clause.falsify_eval_ff τ (map var (l :: ls)) } },
    { rw h at he,
      apply eval_tt_iff_forall_clause_eval_tt.mpr,
      intros c hc,
      have mve := map_var_eq_of_mem_direct_parity hc,
      have nagree_ond := ne_of_eq_ff_of_eq_tt
        ((even_flips_iff_mem_direct_parity_of_map_var_eq mve).mpr hc) he.symm,
      have neq := ne_of_apply_ne nat.bodd nagree_ond,
      rw clause.count_flips_comm at neq,
      exact clause.eval_tt_of_ne_flips mve.symm (ne.symm neq) } }
end

-- Formal proof of correctness, see encoding.lean
theorem direct_parity_formula_encodes_parity (l : list (literal V)) :
  formula_encodes parity (direct_parity' l) l :=
begin
  intro τ,
  split,
  { intro h,
    use τ,
    rw eval_direct_parity_eq_eval_parity l τ,
    exact ⟨h, assignment.agree_on.refl τ _⟩ },
  { rintros ⟨σ, he, hs⟩,
    rw [eval_eq_of_agree_on hs, ← eval_direct_parity_eq_eval_parity l σ],
    exact he }
end

theorem direct_parity_eq_direct_parity (l : list (literal V)) (g : gensym V) :
  direct_parity' l = (direct_parity l g).1 := rfl

theorem vars_direct_parity (l : list (literal V)) :
  (direct_parity' l).vars = clause.vars l :=
begin
  cases l with l ls,
  { simp only [cnf.vars_singleton, direct_parity_nil] },
  { rw finset.ext_iff, intro v, split,
    { intro hv,
      rcases mem_vars_iff_exists_mem_clause_and_mem.mp hv with ⟨c, hc⟩,
      rw [clause.mem_vars_iff_mem_map_vars],
      rw ← (map_var_eq_of_mem_direct_parity hc.1),
      exact clause.mem_vars_iff_mem_map_vars.mp hc.2 },
    { intro hv,
      apply mem_vars_iff_exists_mem_clause_and_mem.mpr,
      use (l :: ls),
      exact ⟨mem_direct_parity_self _, hv⟩ } }
end

theorem direct_parity_encodes_parity : encodes parity (direct_parity : enc_fn V) :=
begin
  split,
  { intros l g hdis,
    rw ← direct_parity_eq_direct_parity,
    exact direct_parity_formula_encodes_parity l },
  { intros l g hdis,
    simp [direct_parity, dir_enc, vars_direct_parity] }
end

end direct_encoding

end parity


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes, Abhimanyu Pallavi Sudhir, Jean Lo, Calle Sönne
-/
import analysis.calculus.inverse
import analysis.complex.real_deriv
import analysis.special_functions.exp

/-!
# Complex and real exponential

In this file we prove that `complex.exp` and `real.exp` are infinitely smooth functions.

## Tags

exp, derivative
-/

noncomputable theory

open filter asymptotics set function
open_locale classical topological_space

namespace complex

/-- The complex exponential is everywhere differentiable, with the derivative `exp x`. -/
lemma has_deriv_at_exp (x : ℂ) : has_deriv_at exp (exp x) x :=
begin
  rw has_deriv_at_iff_is_o_nhds_zero,
  have : (1 : ℕ) < 2 := by norm_num,
  refine (is_O.of_bound (∥exp x∥) _).trans_is_o (is_o_pow_id this),
  filter_upwards [metric.ball_mem_nhds (0 : ℂ) zero_lt_one],
  simp only [metric.mem_ball, dist_zero_right, norm_pow],
  exact λ z hz, exp_bound_sq x z hz.le,
end

lemma differentiable_exp : differentiable ℂ exp :=
λx, (has_deriv_at_exp x).differentiable_at

lemma differentiable_at_exp {x : ℂ} : differentiable_at ℂ exp x :=
differentiable_exp x

@[simp] lemma deriv_exp : deriv exp = exp :=
funext $ λ x, (has_deriv_at_exp x).deriv

@[simp] lemma iter_deriv_exp : ∀ n : ℕ, (deriv^[n] exp) = exp
| 0 := rfl
| (n+1) := by rw [iterate_succ_apply, deriv_exp, iter_deriv_exp n]

lemma cont_diff_exp : ∀ {n}, cont_diff ℂ n exp :=
begin
  refine cont_diff_all_iff_nat.2 (λ n, _),
  induction n with n ihn,
  { exact cont_diff_zero.2 continuous_exp },
  { rw cont_diff_succ_iff_deriv,
    use differentiable_exp,
    rwa deriv_exp }
end

lemma has_strict_deriv_at_exp (x : ℂ) : has_strict_deriv_at exp (exp x) x :=
cont_diff_exp.cont_diff_at.has_strict_deriv_at' (has_deriv_at_exp x) le_rfl

lemma has_strict_fderiv_at_exp_real (x : ℂ) :
  has_strict_fderiv_at exp (exp x • (1 : ℂ →L[ℝ] ℂ)) x :=
(has_strict_deriv_at_exp x).complex_to_real_fderiv

lemma is_open_map_exp : is_open_map exp :=
open_map_of_strict_deriv has_strict_deriv_at_exp exp_ne_zero

end complex

section
variables {f : ℂ → ℂ} {f' x : ℂ} {s : set ℂ}

lemma has_strict_deriv_at.cexp (hf : has_strict_deriv_at f f' x) :
  has_strict_deriv_at (λ x, complex.exp (f x)) (complex.exp (f x) * f') x :=
(complex.has_strict_deriv_at_exp (f x)).comp x hf

lemma has_deriv_at.cexp (hf : has_deriv_at f f' x) :
  has_deriv_at (λ x, complex.exp (f x)) (complex.exp (f x) * f') x :=
(complex.has_deriv_at_exp (f x)).comp x hf

lemma has_deriv_within_at.cexp (hf : has_deriv_within_at f f' s x) :
  has_deriv_within_at (λ x, complex.exp (f x)) (complex.exp (f x) * f') s x :=
(complex.has_deriv_at_exp (f x)).comp_has_deriv_within_at x hf

lemma deriv_within_cexp (hf : differentiable_within_at ℂ f s x)
  (hxs : unique_diff_within_at ℂ s x) :
  deriv_within (λx, complex.exp (f x)) s x = complex.exp (f x) * (deriv_within f s x) :=
hf.has_deriv_within_at.cexp.deriv_within hxs

@[simp] lemma deriv_cexp (hc : differentiable_at ℂ f x) :
  deriv (λx, complex.exp (f x)) x = complex.exp (f x) * (deriv f x) :=
hc.has_deriv_at.cexp.deriv

end

section
variables {f : ℝ → ℂ} {f' : ℂ} {x : ℝ} {s : set ℝ}

open complex

lemma has_strict_deriv_at.cexp_real (h : has_strict_deriv_at f f' x) :
  has_strict_deriv_at (λ x, exp (f x)) (exp (f x) * f') x :=
(has_strict_fderiv_at_exp_real (f x)).comp_has_strict_deriv_at x h

lemma has_deriv_at.cexp_real (h : has_deriv_at f f' x) :
  has_deriv_at (λ x, exp (f x)) (exp (f x) * f') x :=
(has_strict_fderiv_at_exp_real (f x)).has_fderiv_at.comp_has_deriv_at x h

lemma has_deriv_within_at.cexp_real (h : has_deriv_within_at f f' s x) :
  has_deriv_within_at (λ x, exp (f x)) (exp (f x) * f') s x :=
(has_strict_fderiv_at_exp_real (f x)).has_fderiv_at.comp_has_deriv_within_at x h

end

section

variables {E : Type*} [normed_group E] [normed_space ℂ E] {f : E → ℂ} {f' : E →L[ℂ] ℂ}
  {x : E} {s : set E}

lemma has_strict_fderiv_at.cexp (hf : has_strict_fderiv_at f f' x) :
  has_strict_fderiv_at (λ x, complex.exp (f x)) (complex.exp (f x) • f') x :=
(complex.has_strict_deriv_at_exp (f x)).comp_has_strict_fderiv_at x hf

lemma has_fderiv_within_at.cexp (hf : has_fderiv_within_at f f' s x) :
  has_fderiv_within_at (λ x, complex.exp (f x)) (complex.exp (f x) • f') s x :=
(complex.has_deriv_at_exp (f x)).comp_has_fderiv_within_at x hf

lemma has_fderiv_at.cexp (hf : has_fderiv_at f f' x) :
  has_fderiv_at (λ x, complex.exp (f x)) (complex.exp (f x) • f') x :=
has_fderiv_within_at_univ.1 $ hf.has_fderiv_within_at.cexp

lemma differentiable_within_at.cexp (hf : differentiable_within_at ℂ f s x) :
  differentiable_within_at ℂ (λ x, complex.exp (f x)) s x :=
hf.has_fderiv_within_at.cexp.differentiable_within_at

@[simp] lemma differentiable_at.cexp (hc : differentiable_at ℂ f x) :
  differentiable_at ℂ (λx, complex.exp (f x)) x :=
hc.has_fderiv_at.cexp.differentiable_at

lemma differentiable_on.cexp (hc : differentiable_on ℂ f s) :
  differentiable_on ℂ (λx, complex.exp (f x)) s :=
λx h, (hc x h).cexp

@[simp] lemma differentiable.cexp (hc : differentiable ℂ f) :
  differentiable ℂ (λx, complex.exp (f x)) :=
λx, (hc x).cexp

lemma cont_diff.cexp {n} (h : cont_diff ℂ n f) :
  cont_diff ℂ n (λ x, complex.exp (f x)) :=
complex.cont_diff_exp.comp h

lemma cont_diff_at.cexp {n} (hf : cont_diff_at ℂ n f x) :
  cont_diff_at ℂ n (λ x, complex.exp (f x)) x :=
complex.cont_diff_exp.cont_diff_at.comp x hf

lemma cont_diff_on.cexp {n} (hf : cont_diff_on ℂ n f s) :
  cont_diff_on ℂ n (λ x, complex.exp (f x)) s :=
complex.cont_diff_exp.comp_cont_diff_on  hf

lemma cont_diff_within_at.cexp {n} (hf : cont_diff_within_at ℂ n f s x) :
  cont_diff_within_at ℂ n (λ x, complex.exp (f x)) s x :=
complex.cont_diff_exp.cont_diff_at.comp_cont_diff_within_at x hf

end

namespace real

variables {x y z : ℝ}

lemma has_strict_deriv_at_exp (x : ℝ) : has_strict_deriv_at exp (exp x) x :=
(complex.has_strict_deriv_at_exp x).real_of_complex

lemma has_deriv_at_exp (x : ℝ) : has_deriv_at exp (exp x) x :=
(complex.has_deriv_at_exp x).real_of_complex

lemma cont_diff_exp {n} : cont_diff ℝ n exp :=
complex.cont_diff_exp.real_of_complex

lemma differentiable_exp : differentiable ℝ exp :=
λx, (has_deriv_at_exp x).differentiable_at

lemma differentiable_at_exp : differentiable_at ℝ exp x :=
differentiable_exp x

@[simp] lemma deriv_exp : deriv exp = exp :=
funext $ λ x, (has_deriv_at_exp x).deriv

@[simp] lemma iter_deriv_exp : ∀ n : ℕ, (deriv^[n] exp) = exp
| 0 := rfl
| (n+1) := by rw [iterate_succ_apply, deriv_exp, iter_deriv_exp n]

end real

section
/-! Register lemmas for the derivatives of the composition of `real.exp` with a differentiable
function, for standalone use and use with `simp`. -/

variables {f : ℝ → ℝ} {f' x : ℝ} {s : set ℝ}

lemma has_strict_deriv_at.exp (hf : has_strict_deriv_at f f' x) :
  has_strict_deriv_at (λ x, real.exp (f x)) (real.exp (f x) * f') x :=
(real.has_strict_deriv_at_exp (f x)).comp x hf

lemma has_deriv_at.exp (hf : has_deriv_at f f' x) :
  has_deriv_at (λ x, real.exp (f x)) (real.exp (f x) * f') x :=
(real.has_deriv_at_exp (f x)).comp x hf

lemma has_deriv_within_at.exp (hf : has_deriv_within_at f f' s x) :
  has_deriv_within_at (λ x, real.exp (f x)) (real.exp (f x) * f') s x :=
(real.has_deriv_at_exp (f x)).comp_has_deriv_within_at x hf

lemma deriv_within_exp (hf : differentiable_within_at ℝ f s x)
  (hxs : unique_diff_within_at ℝ s x) :
  deriv_within (λx, real.exp (f x)) s x = real.exp (f x) * (deriv_within f s x) :=
hf.has_deriv_within_at.exp.deriv_within hxs

@[simp] lemma deriv_exp (hc : differentiable_at ℝ f x) :
  deriv (λx, real.exp (f x)) x = real.exp (f x) * (deriv f x) :=
hc.has_deriv_at.exp.deriv

end

section
/-! Register lemmas for the derivatives of the composition of `real.exp` with a differentiable
function, for standalone use and use with `simp`. -/

variables {E : Type*} [normed_group E] [normed_space ℝ E] {f : E → ℝ} {f' : E →L[ℝ] ℝ}
  {x : E} {s : set E}

lemma cont_diff.exp {n} (hf : cont_diff ℝ n f) :
  cont_diff ℝ n (λ x, real.exp (f x)) :=
real.cont_diff_exp.comp hf

lemma cont_diff_at.exp {n} (hf : cont_diff_at ℝ n f x) :
  cont_diff_at ℝ n (λ x, real.exp (f x)) x :=
real.cont_diff_exp.cont_diff_at.comp x hf

lemma cont_diff_on.exp {n} (hf : cont_diff_on ℝ n f s) :
  cont_diff_on ℝ n (λ x, real.exp (f x)) s :=
real.cont_diff_exp.comp_cont_diff_on  hf

lemma cont_diff_within_at.exp {n} (hf : cont_diff_within_at ℝ n f s x) :
  cont_diff_within_at ℝ n (λ x, real.exp (f x)) s x :=
real.cont_diff_exp.cont_diff_at.comp_cont_diff_within_at x hf

lemma has_fderiv_within_at.exp (hf : has_fderiv_within_at f f' s x) :
  has_fderiv_within_at (λ x, real.exp (f x)) (real.exp (f x) • f') s x :=
(real.has_deriv_at_exp (f x)).comp_has_fderiv_within_at x hf

lemma has_fderiv_at.exp (hf : has_fderiv_at f f' x) :
  has_fderiv_at (λ x, real.exp (f x)) (real.exp (f x) • f') x :=
(real.has_deriv_at_exp (f x)).comp_has_fderiv_at x hf

lemma has_strict_fderiv_at.exp (hf : has_strict_fderiv_at f f' x) :
  has_strict_fderiv_at (λ x, real.exp (f x)) (real.exp (f x) • f') x :=
(real.has_strict_deriv_at_exp (f x)).comp_has_strict_fderiv_at x hf

lemma differentiable_within_at.exp (hf : differentiable_within_at ℝ f s x) :
  differentiable_within_at ℝ (λ x, real.exp (f x)) s x :=
hf.has_fderiv_within_at.exp.differentiable_within_at

@[simp] lemma differentiable_at.exp (hc : differentiable_at ℝ f x) :
  differentiable_at ℝ (λx, real.exp (f x)) x :=
hc.has_fderiv_at.exp.differentiable_at

lemma differentiable_on.exp (hc : differentiable_on ℝ f s) :
  differentiable_on ℝ (λx, real.exp (f x)) s :=
λ x h, (hc x h).exp

@[simp] lemma differentiable.exp (hc : differentiable ℝ f) :
  differentiable ℝ (λx, real.exp (f x)) :=
λ x, (hc x).exp

lemma fderiv_within_exp (hf : differentiable_within_at ℝ f s x)
  (hxs : unique_diff_within_at ℝ s x) :
  fderiv_within ℝ (λx, real.exp (f x)) s x = real.exp (f x) • (fderiv_within ℝ f s x) :=
hf.has_fderiv_within_at.exp.fderiv_within hxs

@[simp] lemma fderiv_exp (hc : differentiable_at ℝ f x) :
  fderiv ℝ (λx, real.exp (f x)) x = real.exp (f x) • (fderiv ℝ f x) :=
hc.has_fderiv_at.exp.fderiv

end


/-
Copyright (c) 2020 Yury Kudryashov. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Johannes Hölzl, Chris Hughes, Mario Carneiro, Yury Kudryashov
-/
import algebra.group.prod
import algebra.ring.basic
import algebra.ring.equiv

/-!
# Semiring, ring etc structures on `R × S`

In this file we define two-binop (`semiring`, `ring` etc) structures on `R × S`. We also prove
trivial `simp` lemmas, and define the following operations on `ring_hom`s:

* `fst R S : R × S →+* R`, `snd R S : R × S →+* S`: projections `prod.fst` and `prod.snd`
  as `ring_hom`s;
* `f.prod g : `R →+* S × T`: sends `x` to `(f x, g x)`;
* `f.prod_map g : `R × S → R' × S'`: `prod.map f g` as a `ring_hom`,
  sends `(x, y)` to `(f x, g y)`.
-/

variables {R : Type*} {R' : Type*} {S : Type*} {S' : Type*} {T : Type*} {T' : Type*}

namespace prod

/-- Product of two distributive types is distributive. -/
instance [distrib R] [distrib S] : distrib (R × S) :=
{ left_distrib := λ a b c, mk.inj_iff.mpr ⟨left_distrib _ _ _, left_distrib _ _ _⟩,
  right_distrib := λ a b c, mk.inj_iff.mpr ⟨right_distrib _ _ _, right_distrib _ _ _⟩,
  .. prod.has_add, .. prod.has_mul }

/-- Product of two `non_unital_non_assoc_semiring`s is a `non_unital_non_assoc_semiring`. -/
instance [non_unital_non_assoc_semiring R] [non_unital_non_assoc_semiring S] :
  non_unital_non_assoc_semiring (R × S) :=
{ .. prod.add_comm_monoid, .. prod.mul_zero_class, .. prod.distrib }

/-- Product of two `non_unital_semiring`s is a `non_unital_semiring`. -/
instance [non_unital_semiring R] [non_unital_semiring S] :
  non_unital_semiring (R × S) :=
{ .. prod.non_unital_non_assoc_semiring, .. prod.semigroup }

/-- Product of two `non_assoc_semiring`s is a `non_assoc_semiring`. -/
instance [non_assoc_semiring R] [non_assoc_semiring S] :
  non_assoc_semiring (R × S) :=
{ .. prod.non_unital_non_assoc_semiring, .. prod.mul_one_class }

/-- Product of two semirings is a semiring. -/
instance [semiring R] [semiring S] : semiring (R × S) :=
{ .. prod.add_comm_monoid, .. prod.monoid_with_zero, .. prod.distrib }

/-- Product of two commutative semirings is a commutative semiring. -/
instance [comm_semiring R] [comm_semiring S] : comm_semiring (R × S) :=
{ .. prod.semiring, .. prod.comm_monoid }

instance [non_unital_non_assoc_ring R] [non_unital_non_assoc_ring S] :
  non_unital_non_assoc_ring (R × S) :=
{ .. prod.add_comm_group, .. prod.non_unital_non_assoc_semiring }

instance [non_unital_ring R] [non_unital_ring S] :
  non_unital_ring (R × S) :=
{ .. prod.add_comm_group, .. prod.non_unital_semiring }

instance [non_assoc_ring R] [non_assoc_ring S] :
  non_assoc_ring (R × S) :=
{ .. prod.add_comm_group, .. prod.non_assoc_semiring }

/-- Product of two rings is a ring. -/
instance [ring R] [ring S] : ring (R × S) :=
{ .. prod.add_comm_group, .. prod.semiring }

/-- Product of two commutative rings is a commutative ring. -/
instance [comm_ring R] [comm_ring S] : comm_ring (R × S) :=
{ .. prod.ring, .. prod.comm_monoid }

end prod

namespace ring_hom

variables (R S) [non_assoc_semiring R] [non_assoc_semiring S]

/-- Given semirings `R`, `S`, the natural projection homomorphism from `R × S` to `R`.-/
def fst : R × S →+* R := { to_fun := prod.fst, .. monoid_hom.fst R S, .. add_monoid_hom.fst R S }

/-- Given semirings `R`, `S`, the natural projection homomorphism from `R × S` to `S`.-/
def snd : R × S →+* S := { to_fun := prod.snd, .. monoid_hom.snd R S, .. add_monoid_hom.snd R S }

variables {R S}

@[simp]

section prod

variables [non_assoc_semiring T] (f : R →+* S) (g : R →+* T)

/-- Combine two ring homomorphisms `f : R →+* S`, `g : R →+* T` into `f.prod g : R →+* S × T`
given by `(f.prod g) x = (f x, g x)` -/
protected def prod (f : R →+* S) (g : R →+* T) : R →+* S × T :=
{ to_fun := λ x, (f x, g x),
  .. monoid_hom.prod (f : R →* S) (g : R →* T), .. add_monoid_hom.prod (f : R →+ S) (g : R →+ T) }

@[simp] lemma prod_apply (x) : f.prod g x = (f x, g x) := rfl

@[simp] lemma fst_comp_prod : (fst S T).comp (f.prod g) = f :=
ext $ λ x, rfl

@[simp] lemma snd_comp_prod : (snd S T).comp (f.prod g) = g :=
ext $ λ x, rfl

lemma prod_unique (f : R →+* S × T) :
  ((fst S T).comp f).prod ((snd S T).comp f) = f :=
ext $ λ x, by simp only [prod_apply, coe_fst, coe_snd, comp_apply, prod.mk.eta]

end prod

section prod_map

variables [non_assoc_semiring R'] [non_assoc_semiring S'] [non_assoc_semiring T]
variables (f : R →+* R') (g : S →+* S')

/-- `prod.map` as a `ring_hom`. -/
def prod_map : R × S →* R' × S' := (f.comp (fst R S)).prod (g.comp (snd R S))

lemma prod_map_def : prod_map f g = (f.comp (fst R S)).prod (g.comp (snd R S)) := rfl

@[simp]
lemma coe_prod_map : ⇑(prod_map f g) = prod.map f g := rfl

lemma prod_comp_prod_map (f : T →* R) (g : T →* S) (f' : R →* R') (g' : S →* S') :
  (f'.prod_map g').comp (f.prod g) = (f'.comp f).prod (g'.comp g) :=
rfl

end prod_map

end ring_hom

namespace ring_equiv
variables {R S} [non_assoc_semiring R] [non_assoc_semiring S]

/-- Swapping components as an equivalence of (semi)rings. -/
def prod_comm : R × S ≃+* S × R :=
{ ..add_equiv.prod_comm, ..mul_equiv.prod_comm }

@[simp] lemma coe_prod_comm : ⇑(prod_comm : R × S ≃+* S × R) = prod.swap := rfl
@[simp] lemma coe_prod_comm_symm : ⇑((prod_comm : R × S ≃+* S × R).symm) = prod.swap := rfl

@[simp] lemma fst_comp_coe_prod_comm :
  (ring_hom.fst S R).comp ↑(prod_comm : R × S ≃+* S × R) = ring_hom.snd R S :=
ring_hom.ext $ λ _, rfl

@[simp] lemma snd_comp_coe_prod_comm :
  (ring_hom.snd S R).comp ↑(prod_comm : R × S ≃+* S × R) = ring_hom.fst R S :=
ring_hom.ext $ λ _, rfl

variables (R S) [subsingleton S]

/-- A ring `R` is isomorphic to `R × S` when `S` is the zero ring -/
@[simps] def prod_zero_ring : R ≃+* R × S :=
{ to_fun := λ x, (x, 0),
  inv_fun := prod.fst,
  map_add' := by simp,
  map_mul' := by simp,
  left_inv := λ x, rfl,
  right_inv := λ x, by cases x; simp }

/-- A ring `R` is isomorphic to `S × R` when `S` is the zero ring -/
@[simps] def zero_ring_prod : R ≃+* S × R :=
{ to_fun := λ x, (0, x),
  inv_fun := prod.snd,
  map_add' := by simp,
  map_mul' := by simp,
  left_inv := λ x, rfl,
  right_inv := λ x, by cases x; simp }

end ring_equiv

/-- The product of two nontrivial rings is not a domain -/
lemma false_of_nontrivial_of_product_domain (R S : Type*) [ring R] [ring S]
  [is_domain (R × S)] [nontrivial R] [nontrivial S] : false :=
begin
  have := is_domain.eq_zero_or_eq_zero_of_mul_eq_zero
    (show ((0 : R), (1 : S)) * (1, 0) = 0, by simp),
  rw [prod.mk_eq_zero,prod.mk_eq_zero] at this,
  rcases this with (⟨_,h⟩|⟨h,_⟩),
  { exact zero_ne_one h.symm },
  { exact zero_ne_one h.symm }
end


universe u

def concat {α} : List α → α → List α
  | [],    a => [a]
  | x::xs, a => x :: concat xs a

def last {α} : (xs : List α) → xs ≠ [] → α
  | [],       h => by contradiction
  | [a],      h => a
  | _::a::as, h => last (a::as) (fun h => by injection h)

def dropLast {α} : List α → List α
  | []    => []
  | [a]   => []
  | a::as => a :: dropLast as

variable {α}

theorem concatEq (xs : List α) (h : xs ≠ []) : concat (dropLast xs) (last xs h) = xs := by
  match xs, h with
  | [],  h        => contradiction
  | [x], h        => rfl
  | x₁::x₂::xs, h => simp [concat, last, concatEq (x₂::xs) List.noConfusion]

theorem lengthCons {α} (x : α) (xs : List α) : (x::xs).length = xs.length + 1 :=
  let rec aux (a : α) (xs : List α) : (n : Nat) → (a::xs).lengthAux n = xs.lengthAux n + 1 :=
    match xs with
    | []    => fun _ => rfl
    | x::xs => fun n => aux a xs (n+1)
  aux x xs 0

theorem eqNilOfLengthZero {α} : (xs : List α) → xs.length = 0 → xs = []
  | [],    h => rfl
  | x::xs, h => by rw [lengthCons] at h; contradiction

theorem dropLastLen {α} (xs : List α) : (n : Nat) → xs.length = n+1 → (dropLast xs).length = n := by
  match xs with
  | []    => intros; contradiction
  | [a]   =>
    intro n h
    have : 1 = n + 1 := h
    have : 0 = n := by injection this; assumption
    subst this
    rfl
  | x₁::x₂::xs =>
    intro n h
    cases n with
    | zero   =>
      simp [lengthCons] at h
      injection h
    | succ n =>
      have : (x₁ :: x₂ :: xs).length = xs.length + 2 := by simp [lengthCons]
      have : xs.length = n := by rw [this] at h; injection h with h; injection h with h; assumption
      simp [dropLast, lengthCons, dropLastLen (x₂::xs) xs.length (lengthCons ..), this]

@[inline]
def concatElim {α}
    (motive : List α → Sort u)
    (base   : Unit → motive [])
    (ind    : (xs : List α) → (a : α) → motive xs → motive (concat xs a))
    (xs : List α)
    : motive xs :=
  let rec @[specialize] aux : (n : Nat) → (xs : List α) → xs.length = n → motive xs
    | 0, xs, h   => by
      have aux := eqNilOfLengthZero _ h
      subst aux
      apply base ()
    | n+1, xs, h => by
      have notNil : xs ≠ [] := by intro h1; subst h1; injection h
      let ih  := aux n (dropLast xs) (dropLastLen _ _ h)
      let aux := ind (dropLast xs) (last xs notNil) ih
      rw [concatEq] at aux
      exact aux
  aux xs.length xs rfl

-- The generated code is tail recursive
def test (xs : List Nat) : IO Unit :=
  concatElim (motive := fun _ => IO Unit)
    (fun _ => pure ())
    (fun xs x r => do IO.println s!"step xs: {xs} x: {x}"; r)
    xs

#eval test [1, 2, 3, 4]


/-
Copyright (c) 2021 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import data.W.cardinal
import data.mv_polynomial.basic
/-!
# Cardinality of Polynomial Ring

The main result in this file is `mv_polynomial.cardinal_mk_le_max`, which says that
the cardinality of `mv_polynomial σ R` is bounded above by the maximum of `#R`, `#σ`
and `ω`.

-/
universes u
/-
The definitions `mv_polynomial_fun` and `arity` are motivated by defining the following
inductive type as a `W_type` in order to be able to use theorems about the cardinality
of `W_type`.

inductive mv_polynomial_term (σ R : Type u) : Type u
| of_ring : R → mv_polynomial_term
| X : σ → mv_polynomial_term
| add : mv_polynomial_term → mv_polynomial_term → mv_polynomial_term
| mul : mv_polynomial_term → mv_polynomial_term → mv_polynomial_term

`W_type (arity σ R)` is isomorphic to the above type.
-/
open cardinal
open_locale cardinal

/-- A type used to prove theorems about the cardinality of `mv_polynomial σ R`. The
`W_type (arity σ R)` has a constant for every element of `R` and `σ` and two binary functions. -/
private def mv_polynomial_fun (σ R : Type u) : Type u :=
R ⊕ σ ⊕ ulift.{u} bool

variables (σ R : Type u)
/-- A function used to prove theorems about the cardinality of `mv_polynomial σ R`.
  The type ``W_type (arity σ R)` has a constant for every element of `R` and `σ` and two binary
  functions. -/
private def arity : mv_polynomial_fun σ R → Type u
| (sum.inl _)              := pempty
| (sum.inr (sum.inl _))    := pempty
| (sum.inr (sum.inr ⟨ff⟩)) := ulift bool
| (sum.inr (sum.inr ⟨tt⟩)) := ulift bool

private def arity_fintype (x : mv_polynomial_fun σ R) : fintype (arity σ R x) :=
by rcases x with x | x | ⟨_ | _⟩; dsimp [arity]; apply_instance

local attribute [instance] arity_fintype

variables {σ R}

variables [comm_semiring R]

/-- The surjection from `W_type (arity σ R)` into `mv_polynomial σ R`. -/
private noncomputable def to_mv_polynomial :
  W_type (arity σ R) → mv_polynomial σ R
| ⟨sum.inl r, _⟩              := mv_polynomial.C r
| ⟨sum.inr (sum.inl i), _⟩    := mv_polynomial.X i
| ⟨sum.inr (sum.inr ⟨ff⟩), f⟩ :=
  to_mv_polynomial (f (ulift.up tt)) * to_mv_polynomial (f (ulift.up ff))
| ⟨sum.inr (sum.inr ⟨tt⟩), f⟩ :=
  to_mv_polynomial (f (ulift.up tt)) + to_mv_polynomial (f (ulift.up ff))

private lemma to_mv_polynomial_surjective : function.surjective (@to_mv_polynomial σ R _) :=
begin
  intro p,
  induction p using mv_polynomial.induction_on with x p₁ p₂ ih₁ ih₂ p i ih,
  { exact ⟨W_type.mk (sum.inl x) pempty.elim, rfl⟩ },
  { rcases ih₁ with ⟨w₁, rfl⟩,
    rcases ih₂ with ⟨w₂, rfl⟩,
    exact ⟨W_type.mk (sum.inr (sum.inr ⟨tt⟩)) (λ x, cond x.down w₁ w₂),
      by simp [to_mv_polynomial]⟩ },
  { rcases ih with ⟨w, rfl⟩,
    exact ⟨W_type.mk (sum.inr (sum.inr ⟨ff⟩)) (λ x, cond x.down w (W_type.mk
      (sum.inr (sum.inl i)) pempty.elim)), by simp [to_mv_polynomial]⟩ }
end

private lemma cardinal_mv_polynomial_fun_le : #(mv_polynomial_fun σ R) ≤ max (max (#R) (#σ)) ω :=
calc #(mv_polynomial_fun σ R) = #R + #σ + #(ulift bool) :
  by dsimp [mv_polynomial_fun]; simp only [← add_def, add_assoc, cardinal.mk_ulift]
... ≤ max (max (#R + #σ) (#(ulift bool))) ω : add_le_max _ _
... ≤ max (max (max (max (#R) (#σ)) ω) (#(ulift bool))) ω :
  max_le_max (max_le_max (add_le_max _ _) (le_refl _)) (le_refl _)
... ≤ _ : begin
  have : #(ulift.{u} bool) ≤ ω,
    from le_of_lt (lt_omega_iff_fintype.2 ⟨infer_instance⟩),
  simp only [max_comm omega.{u}, max_assoc, max_left_comm omega.{u}, max_self, max_eq_left this],
end

namespace mv_polynomial

/-- The cardinality of the multivariate polynomial ring, `mv_polynomial σ R` is at most the maximum
of `#R`, `#σ` and `ω` -/
lemma cardinal_mk_le_max {σ R : Type u} [comm_semiring R] :
  #(mv_polynomial σ R) ≤ max (max (#R) (#σ)) ω :=
calc #(mv_polynomial σ R) ≤ #(W_type (arity σ R)) :
  cardinal.mk_le_of_surjective to_mv_polynomial_surjective
... ≤ max (#(mv_polynomial_fun σ R)) ω : W_type.cardinal_mk_le_max_omega_of_fintype
... ≤ _ : max_le_max cardinal_mv_polynomial_fun_le (le_refl _)
... ≤ _ : by simp only [max_assoc, max_self]

end mv_polynomial


/-
Copyright (c) 2020 Joseph Myers. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Joseph Myers
-/
import linear_algebra.affine_space.independent
import linear_algebra.finite_dimensional

/-!
# Finite-dimensional subspaces of affine spaces.

This file provides a few results relating to finite-dimensional
subspaces of affine spaces.

## Main definitions

* `collinear` defines collinear sets of points as those that span a
  subspace of dimension at most 1.

-/

noncomputable theory
open_locale big_operators classical affine

section affine_space'

variables (k : Type*) {V : Type*} {P : Type*}
variables {ι : Type*}
include V

open affine_subspace finite_dimensional module

variables [division_ring k] [add_comm_group V] [module k V] [affine_space V P]

/-- The `vector_span` of a finite set is finite-dimensional. -/
lemma finite_dimensional_vector_span_of_finite {s : set P} (h : set.finite s) :
  finite_dimensional k (vector_span k s) :=
span_of_finite k $ h.vsub h

/-- The `vector_span` of a family indexed by a `fintype` is
finite-dimensional. -/
instance finite_dimensional_vector_span_of_fintype [fintype ι] (p : ι → P) :
  finite_dimensional k (vector_span k (set.range p)) :=
finite_dimensional_vector_span_of_finite k (set.finite_range _)

/-- The `vector_span` of a subset of a family indexed by a `fintype`
is finite-dimensional. -/
instance finite_dimensional_vector_span_image_of_fintype [fintype ι] (p : ι → P)
  (s : set ι) : finite_dimensional k (vector_span k (p '' s)) :=
finite_dimensional_vector_span_of_finite k ((set.finite.of_fintype _).image _)

/-- The direction of the affine span of a finite set is
finite-dimensional. -/
lemma finite_dimensional_direction_affine_span_of_finite {s : set P} (h : set.finite s) :
  finite_dimensional k (affine_span k s).direction :=
(direction_affine_span k s).symm ▸ finite_dimensional_vector_span_of_finite k h

/-- The direction of the affine span of a family indexed by a
`fintype` is finite-dimensional. -/
instance finite_dimensional_direction_affine_span_of_fintype [fintype ι] (p : ι → P) :
  finite_dimensional k (affine_span k (set.range p)).direction :=
finite_dimensional_direction_affine_span_of_finite k (set.finite_range _)

/-- The direction of the affine span of a subset of a family indexed
by a `fintype` is finite-dimensional. -/
instance finite_dimensional_direction_affine_span_image_of_fintype [fintype ι] (p : ι → P)
  (s : set ι) : finite_dimensional k (affine_span k (p '' s)).direction :=
finite_dimensional_direction_affine_span_of_finite k ((set.finite.of_fintype _).image _)

/-- An affine-independent family of points in a finite-dimensional affine space is finite. -/
noncomputable def fintype_of_fin_dim_affine_independent [finite_dimensional k V]
  {p : ι → P} (hi : affine_independent k p) : fintype ι :=
if hι : is_empty ι then (@fintype.of_is_empty _ hι) else
begin
  let q := (not_is_empty_iff.mp hι).some,
  rw affine_independent_iff_linear_independent_vsub k p q at hi,
  letI : is_noetherian k V := is_noetherian.iff_fg.2 infer_instance,
  exact fintype_of_fintype_ne _ (fintype_of_is_noetherian_linear_independent hi)
end

/-- An affine-independent subset of a finite-dimensional affine space is finite. -/
lemma finite_of_fin_dim_affine_independent [finite_dimensional k V]
  {s : set P} (hi : affine_independent k (coe : s → P)) : s.finite :=
⟨fintype_of_fin_dim_affine_independent k hi⟩

variables {k}

/-- The `vector_span` of a finite subset of an affinely independent
family has dimension one less than its cardinality. -/
lemma affine_independent.finrank_vector_span_image_finset {p : ι → P}
  (hi : affine_independent k p) {s : finset ι} {n : ℕ} (hc : finset.card s = n + 1) :
  finrank k (vector_span k (s.image p : set P)) = n :=
begin
  have hi' := hi.range.mono (set.image_subset_range p ↑s),
  have hc' : (s.image p).card = n + 1,
  { rwa s.card_image_of_injective hi.injective },
  have hn : (s.image p).nonempty,
  { simp [hc', ←finset.card_pos] },
  rcases hn with ⟨p₁, hp₁⟩,
  have hp₁' : p₁ ∈ p '' s := by simpa using hp₁,
  rw [affine_independent_set_iff_linear_independent_vsub k hp₁', ← finset.coe_singleton,
      ← finset.coe_image, ← finset.coe_sdiff, finset.sdiff_singleton_eq_erase,
      ← finset.coe_image] at hi',
  have hc : (finset.image (λ (p : P), p -ᵥ p₁) ((finset.image p s).erase p₁)).card = n,
  { rw [finset.card_image_of_injective _ (vsub_left_injective _),
        finset.card_erase_of_mem hp₁],
    exact nat.pred_eq_of_eq_succ hc' },
  rwa [vector_span_eq_span_vsub_finset_right_ne k hp₁, finrank_span_finset_eq_card, hc]
end

/-- The `vector_span` of a finite affinely independent family has
dimension one less than its cardinality. -/
lemma affine_independent.finrank_vector_span [fintype ι] {p : ι → P}
  (hi : affine_independent k p) {n : ℕ} (hc : fintype.card ι = n + 1) :
  finrank k (vector_span k (set.range p)) = n :=
begin
  rw ← finset.card_univ at hc,
  rw [← set.image_univ, ← finset.coe_univ, ← finset.coe_image],
  exact hi.finrank_vector_span_image_finset hc
end

/-- The `vector_span` of a finite affinely independent family whose
cardinality is one more than that of the finite-dimensional space is
`⊤`. -/
lemma affine_independent.vector_span_eq_top_of_card_eq_finrank_add_one [finite_dimensional k V]
  [fintype ι] {p : ι → P} (hi : affine_independent k p) (hc : fintype.card ι = finrank k V + 1) :
  vector_span k (set.range p) = ⊤ :=
eq_top_of_finrank_eq $ hi.finrank_vector_span hc

variables (k)

/-- The `vector_span` of `n + 1` points in an indexed family has
dimension at most `n`. -/
lemma finrank_vector_span_image_finset_le (p : ι → P) (s : finset ι) {n : ℕ}
  (hc : finset.card s = n + 1) : finrank k (vector_span k (s.image p : set P)) ≤ n :=
begin
  have hn : (s.image p).nonempty,
  { rw [finset.nonempty.image_iff, ← finset.card_pos, hc], apply nat.succ_pos },
  rcases hn with ⟨p₁, hp₁⟩,
  rw [vector_span_eq_span_vsub_finset_right_ne k hp₁],
  refine le_trans (finrank_span_finset_le_card (((s.image p).erase p₁).image (λ p, p -ᵥ p₁))) _,
  rw [finset.card_image_of_injective _ (vsub_left_injective p₁), finset.card_erase_of_mem hp₁,
      tsub_le_iff_right, ← hc],
  apply finset.card_image_le
end

/-- The `vector_span` of an indexed family of `n + 1` points has
dimension at most `n`. -/
lemma finrank_vector_span_range_le [fintype ι] (p : ι → P) {n : ℕ}
  (hc : fintype.card ι = n + 1) : finrank k (vector_span k (set.range p)) ≤ n :=
begin
  rw [←set.image_univ, ←finset.coe_univ, ← finset.coe_image],
  rw ←finset.card_univ at hc,
  exact finrank_vector_span_image_finset_le _ _ _ hc
end

/-- `n + 1` points are affinely independent if and only if their
`vector_span` has dimension `n`. -/
lemma affine_independent_iff_finrank_vector_span_eq [fintype ι] (p : ι → P) {n : ℕ}
  (hc : fintype.card ι = n + 1) :
  affine_independent k p ↔ finrank k (vector_span k (set.range p)) = n :=
begin
  have hn : nonempty ι, by simp [←fintype.card_pos_iff, hc],
  cases hn with i₁,
  rw [affine_independent_iff_linear_independent_vsub _ _ i₁,
      linear_independent_iff_card_eq_finrank_span, eq_comm,
      vector_span_range_eq_span_range_vsub_right_ne k p i₁],
  congr',
  rw ←finset.card_univ at hc,
  rw fintype.subtype_card,
  simp [finset.filter_ne', finset.card_erase_of_mem, hc]
end

/-- `n + 1` points are affinely independent if and only if their
`vector_span` has dimension at least `n`. -/
lemma affine_independent_iff_le_finrank_vector_span [fintype ι] (p : ι → P) {n : ℕ}
  (hc : fintype.card ι = n + 1) :
  affine_independent k p ↔ n ≤ finrank k (vector_span k (set.range p)) :=
begin
  rw affine_independent_iff_finrank_vector_span_eq k p hc,
  split,
  { rintro rfl,
    refl },
  { exact λ hle, le_antisymm (finrank_vector_span_range_le k p hc) hle }
end

/-- `n + 2` points are affinely independent if and only if their
`vector_span` does not have dimension at most `n`. -/
lemma affine_independent_iff_not_finrank_vector_span_le [fintype ι] (p : ι → P) {n : ℕ}
  (hc : fintype.card ι = n + 2) :
  affine_independent k p ↔ ¬ finrank k (vector_span k (set.range p)) ≤ n :=
by rw [affine_independent_iff_le_finrank_vector_span k p hc, ←nat.lt_iff_add_one_le, lt_iff_not_ge]

/-- `n + 2` points have a `vector_span` with dimension at most `n` if
and only if they are not affinely independent. -/
lemma finrank_vector_span_le_iff_not_affine_independent [fintype ι] (p : ι → P) {n : ℕ}
  (hc : fintype.card ι = n + 2) :
  finrank k (vector_span k (set.range p)) ≤ n ↔ ¬ affine_independent k p :=
(not_iff_comm.1 (affine_independent_iff_not_finrank_vector_span_le k p hc).symm).symm

variables {k}

/-- If the `vector_span` of a finite subset of an affinely independent
family lies in a submodule with dimension one less than its
cardinality, it equals that submodule. -/
lemma affine_independent.vector_span_image_finset_eq_of_le_of_card_eq_finrank_add_one
  {p : ι → P} (hi : affine_independent k p) {s : finset ι} {sm : submodule k V}
  [finite_dimensional k sm] (hle : vector_span k (s.image p : set P) ≤ sm)
  (hc : finset.card s = finrank k sm + 1) : vector_span k (s.image p : set P) = sm :=
eq_of_le_of_finrank_eq hle $ hi.finrank_vector_span_image_finset hc

/-- If the `vector_span` of a finite affinely independent
family lies in a submodule with dimension one less than its
cardinality, it equals that submodule. -/
lemma affine_independent.vector_span_eq_of_le_of_card_eq_finrank_add_one [fintype ι]
  {p : ι → P} (hi : affine_independent k p) {sm : submodule k V} [finite_dimensional k sm]
  (hle : vector_span k (set.range p) ≤ sm) (hc : fintype.card ι = finrank k sm + 1) :
  vector_span k (set.range p) = sm :=
eq_of_le_of_finrank_eq hle $ hi.finrank_vector_span hc

/-- If the `affine_span` of a finite subset of an affinely independent
family lies in an affine subspace whose direction has dimension one
less than its cardinality, it equals that subspace. -/
lemma affine_independent.affine_span_image_finset_eq_of_le_of_card_eq_finrank_add_one
  {p : ι → P} (hi : affine_independent k p) {s : finset ι} {sp : affine_subspace k P}
  [finite_dimensional k sp.direction] (hle : affine_span k (s.image p : set P) ≤ sp)
  (hc : finset.card s = finrank k sp.direction + 1) : affine_span k (s.image p : set P) = sp :=
begin
  have hn : (s.image p).nonempty,
  { rw [finset.nonempty.image_iff, ← finset.card_pos, hc], apply nat.succ_pos },
  refine eq_of_direction_eq_of_nonempty_of_le _ ((affine_span_nonempty k _).2 hn) hle,
  have hd := direction_le hle,
  rw direction_affine_span at ⊢ hd,
  exact hi.vector_span_image_finset_eq_of_le_of_card_eq_finrank_add_one hd hc
end

/-- If the `affine_span` of a finite affinely independent family lies
in an affine subspace whose direction has dimension one less than its
cardinality, it equals that subspace. -/
lemma affine_independent.affine_span_eq_of_le_of_card_eq_finrank_add_one [fintype ι]
  {p : ι → P} (hi : affine_independent k p) {sp : affine_subspace k P}
  [finite_dimensional k sp.direction] (hle : affine_span k (set.range p) ≤ sp)
  (hc : fintype.card ι = finrank k sp.direction + 1) : affine_span k (set.range p) = sp :=
begin
  rw ←finset.card_univ at hc,
  rw [←set.image_univ, ←finset.coe_univ, ← finset.coe_image] at ⊢ hle,
  exact hi.affine_span_image_finset_eq_of_le_of_card_eq_finrank_add_one hle hc
end

/-- The `affine_span` of a finite affinely independent family is `⊤` iff the
family's cardinality is one more than that of the finite-dimensional space. -/
lemma affine_independent.affine_span_eq_top_iff_card_eq_finrank_add_one [finite_dimensional k V]
  [fintype ι] {p : ι → P} (hi : affine_independent k p) :
  affine_span k (set.range p) = ⊤ ↔ fintype.card ι = finrank k V + 1 :=
begin
  split,
  { intros h_tot,
    let n := fintype.card ι - 1,
    have hn : fintype.card ι = n + 1,
    { exact (nat.succ_pred_eq_of_pos (card_pos_of_affine_span_eq_top k V P h_tot)).symm, },
    rw [hn, ← finrank_top, ← (vector_span_eq_top_of_affine_span_eq_top k V P) h_tot,
      ← hi.finrank_vector_span hn], },
  { intros hc,
    rw [← finrank_top, ← direction_top k V P] at hc,
    exact hi.affine_span_eq_of_le_of_card_eq_finrank_add_one le_top hc, },
end

variables (k)

/-- A set of points is collinear if their `vector_span` has dimension
at most `1`. -/
def collinear (s : set P) : Prop := module.rank k (vector_span k s) ≤ 1

/-- The definition of `collinear`. -/
lemma collinear_iff_dim_le_one (s : set P) : collinear k s ↔ module.rank k (vector_span k s) ≤ 1 :=
iff.rfl

/-- A set of points, whose `vector_span` is finite-dimensional, is
collinear if and only if their `vector_span` has dimension at most
`1`. -/
lemma collinear_iff_finrank_le_one (s : set P) [finite_dimensional k (vector_span k s)] :
  collinear k s ↔ finrank k (vector_span k s) ≤ 1 :=
begin
  have h := collinear_iff_dim_le_one k s,
  rw ←finrank_eq_dim at h,
  exact_mod_cast h
end

variables (P)

/-- The empty set is collinear. -/
lemma collinear_empty : collinear k (∅ : set P) :=
begin
  rw [collinear_iff_dim_le_one, vector_span_empty],
  simp
end

variables {P}

/-- A single point is collinear. -/
lemma collinear_singleton (p : P) : collinear k ({p} : set P) :=
begin
  rw [collinear_iff_dim_le_one, vector_span_singleton],
  simp
end

/-- Given a point `p₀` in a set of points, that set is collinear if and
only if the points can all be expressed as multiples of the same
vector, added to `p₀`. -/
lemma collinear_iff_of_mem {s : set P} {p₀ : P} (h : p₀ ∈ s) :
  collinear k s ↔ ∃ v : V, ∀ p ∈ s, ∃ r : k, p = r • v +ᵥ p₀ :=
begin
  simp_rw [collinear_iff_dim_le_one, dim_submodule_le_one_iff', submodule.le_span_singleton_iff],
  split,
  { rintro ⟨v₀, hv⟩,
    use v₀,
    intros p hp,
    obtain ⟨r, hr⟩ := hv (p -ᵥ p₀) (vsub_mem_vector_span k hp h),
    use r,
    rw eq_vadd_iff_vsub_eq,
    exact hr.symm },
  { rintro ⟨v, hp₀v⟩,
    use v,
    intros w hw,
    have hs : vector_span k s ≤ k ∙ v,
    { rw [vector_span_eq_span_vsub_set_right k h, submodule.span_le, set.subset_def],
      intros x hx,
      rw [set_like.mem_coe, submodule.mem_span_singleton],
      rw set.mem_image at hx,
      rcases hx with ⟨p, hp, rfl⟩,
      rcases hp₀v p hp with ⟨r, rfl⟩,
      use r,
      simp },
    have hw' := set_like.le_def.1 hs hw,
    rwa submodule.mem_span_singleton at hw' }
end

/-- A set of points is collinear if and only if they can all be
expressed as multiples of the same vector, added to the same base
point. -/
lemma collinear_iff_exists_forall_eq_smul_vadd (s : set P) :
  collinear k s ↔ ∃ (p₀ : P) (v : V), ∀ p ∈ s, ∃ r : k, p = r • v +ᵥ p₀ :=
begin
  rcases set.eq_empty_or_nonempty s with rfl | ⟨⟨p₁, hp₁⟩⟩,
  { simp [collinear_empty] },
  { rw collinear_iff_of_mem k hp₁,
    split,
    { exact λ h, ⟨p₁, h⟩ },
    { rintros ⟨p, v, hv⟩,
      use v,
      intros p₂ hp₂,
      rcases hv p₂ hp₂ with ⟨r, rfl⟩,
      rcases hv p₁ hp₁ with ⟨r₁, rfl⟩,
      use r - r₁,
      simp [vadd_vadd, ←add_smul] } }
end

/-- Two points are collinear. -/
lemma collinear_pair (p₁ p₂ : P) : collinear k ({p₁, p₂} : set P) :=
begin
  rw collinear_iff_exists_forall_eq_smul_vadd,
  use [p₁, p₂ -ᵥ p₁],
  intros p hp,
  rw [set.mem_insert_iff, set.mem_singleton_iff] at hp,
  cases hp,
  { use 0,
    simp [hp] },
  { use 1,
    simp [hp] }
end

/-- Three points are affinely independent if and only if they are not
collinear. -/
lemma affine_independent_iff_not_collinear (p : fin 3 → P) :
  affine_independent k p ↔ ¬ collinear k (set.range p) :=
by rw [collinear_iff_finrank_le_one,
       affine_independent_iff_not_finrank_vector_span_le k p (fintype.card_fin 3)]

/-- Three points are collinear if and only if they are not affinely
independent. -/
lemma collinear_iff_not_affine_independent (p : fin 3 → P) :
  collinear k (set.range p) ↔ ¬ affine_independent k p :=
by rw [collinear_iff_finrank_le_one,
       finrank_vector_span_le_iff_not_affine_independent k p (fintype.card_fin 3)]

end affine_space'


/-
Copyright (c) 2021 Lu-Ming Zhang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Lu-Ming Zhang
-/
import linear_algebra.matrix.trace

/-!
# Hadamard product of matrices

This file defines the Hadamard product `matrix.hadamard`
and contains basic properties about them.

## Main definition

- `matrix.hadamard`: defines the Hadamard product,
  which is the pointwise product of two matrices of the same size.

## Notation

* `⊙`: the Hadamard product `matrix.hadamard`;

## References

*  <https://en.wikipedia.org/wiki/hadamard_product_(matrices)>

## Tags

hadamard product, hadamard
-/

variables {α β γ m n : Type*}
variables {R : Type*}

namespace matrix
open_locale matrix big_operators

/-- `matrix.hadamard` defines the Hadamard product,
    which is the pointwise product of two matrices of the same size.-/
@[simp]
def hadamard [has_mul α] (A : matrix m n α) (B : matrix m n α) : matrix m n α
| i j := A i j * B i j

localized "infix ` ⊙ `:100 := matrix.hadamard" in matrix

section basic_properties

variables (A : matrix m n α) (B : matrix m n α) (C : matrix m n α)

/- commutativity -/
lemma hadamard_comm [comm_semigroup α] : A ⊙ B = B ⊙ A :=
ext $ λ _ _, mul_comm _ _

/- associativity -/
lemma hadamard_assoc [semigroup α] : A ⊙ B ⊙ C = A ⊙ (B ⊙ C) :=
ext $ λ _ _, mul_assoc _ _ _

/- distributivity -/
lemma hadamard_add [distrib α] : A ⊙ (B + C) = A ⊙ B + A ⊙ C :=
ext $ λ _ _, left_distrib _ _ _

lemma add_hadamard [distrib α] : (B + C) ⊙ A = B ⊙ A + C ⊙ A :=
ext $ λ _ _, right_distrib _ _ _

/- scalar multiplication -/
section scalar

@[simp] lemma smul_hadamard [has_mul α] [has_smul R α] [is_scalar_tower R α α] (k : R) :
  (k • A) ⊙ B = k • A ⊙ B :=
ext $ λ _ _, smul_mul_assoc _ _ _

@[simp] lemma hadamard_smul [has_mul α] [has_smul R α] [smul_comm_class R α α] (k : R):
  A ⊙ (k • B) = k • A ⊙ B :=
ext $ λ _ _, mul_smul_comm _ _ _

end scalar

section zero

variables [mul_zero_class α]

@[simp] lemma hadamard_zero : A ⊙ (0 : matrix m n α) = 0 :=
ext $ λ _ _, mul_zero _

@[simp] lemma zero_hadamard : (0 : matrix m n α) ⊙ A = 0 :=
ext $ λ _ _, zero_mul _

end zero

section one

variables [decidable_eq n] [mul_zero_one_class α]
variables (M : matrix n n α)

lemma hadamard_one : M ⊙ (1 : matrix n n α) = diagonal (λ i, M i i) :=
by { ext, by_cases h : i = j; simp [h] }

lemma one_hadamard : (1 : matrix n n α) ⊙ M = diagonal (λ i, M i i) :=
by { ext, by_cases h : i = j; simp [h] }

end one

section diagonal

variables [decidable_eq n] [mul_zero_class α]

lemma diagonal_hadamard_diagonal (v : n → α) (w : n → α) :
  diagonal v ⊙ diagonal w = diagonal (v * w) :=
ext $ λ _ _, (apply_ite2 _ _ _ _ _ _).trans (congr_arg _ $ zero_mul 0)

end diagonal

section trace

variables [fintype m] [fintype n]
variables (R) [semiring α] [semiring R] [module R α]

lemma sum_hadamard_eq : ∑ (i : m) (j : n), (A ⊙ B) i j = trace (A ⬝ Bᵀ) :=
rfl

lemma dot_product_vec_mul_hadamard [decidable_eq m] [decidable_eq n] (v : m → α) (w : n → α) :
  dot_product (vec_mul v (A ⊙ B)) w = trace (diagonal v ⬝ A ⬝ (B ⬝ diagonal w)ᵀ) :=
begin
  rw [←sum_hadamard_eq, finset.sum_comm],
  simp [dot_product, vec_mul, finset.sum_mul, mul_assoc],
end

end trace

end basic_properties

end matrix