import linear_algebra.basic algebra.field inner_product_spaces.norm_space data.complex.basic data.real.basic analysis.metric_space analysis.topology.uniform_space

open vector_space field set complex real
universes u v w

class herm_inner_product_space (V : Type u) extends vector_space ℂ V :=
(inprod : V → V → ℂ)
(is_fst_lin : ∀ (a b : ℂ), ∀ (x y z : V), inprod (a • x + b • y) z = a * (inprod x z) + b * (inprod y z))
(is_conj_sym : ∀ (x y : V), inprod x y = conj (inprod y x))
(is_pos_def : ∀ (x : V), (inprod x x).re ≥ 0 ∧ ((inprod x x) = 0 ↔ x = 0))

notation a ∘ b := herm_inner_product_space.inprod a b

open herm_inner_product_space

theorem is_anti_linear (V : Type u) [herm_inner_product_space V] :
∀ (a b : ℂ), ∀ (x y z : V), x ∘ ((a • y) + (b • z)) = conj(a) * (x ∘ y) + conj(b) * (x ∘ z):=
begin
intros,
rw [is_conj_sym, is_fst_lin, conj_add, conj_mul, ←is_conj_sym, conj_mul, ←is_conj_sym],
end

@[simp] lemma add_lin_left {V : Type u} [herm_inner_product_space V] (x y z : V) :
(x + y) ∘ z = x ∘ z + y ∘ z :=
begin
rw [←module.one_smul x, ←module.one_smul y],
rw is_fst_lin,
simp,
end

@[simp] lemma add_lin_right {V : Type u} [herm_inner_product_space V] (x y z : V) :
x ∘ (y + z) = x ∘ y + x ∘ z :=
begin
rw [←module.one_smul y, ←module.one_smul z],
rw is_anti_linear,
simp,
end

@[simp] lemma mul_lin_left {V : Type u} [herm_inner_product_space V] (a : ℂ) (x y : V) :
(a • x) ∘ y = a * (x ∘ y) :=
begin
rw ←add_zero (a • x),
rw ←zero_smul,
rw is_fst_lin,
simp,
exact 0,
end

@[simp] lemma mul_antilin_right {V : Type u} [herm_inner_product_space V] (a : ℂ) (x y : V) :
x ∘ (a • y) = conj(a) * (x ∘ y) :=
begin
rw ←add_zero (a • y),
rw ←zero_smul,
rw is_anti_linear,
simp,
exact 0,
end

@[simp] lemma zero_inprod {V: Type u} [herm_inner_product_space V] (x : V) :
0 ∘ x = 0 := by rw [←zero_smul, mul_lin_left, zero_mul]; exact 0

@[simp] lemma inprod_zero {V: Type u} [herm_inner_product_space V] (x : V) :
x ∘ 0 = 0 := by rw [is_conj_sym, conj_eq_zero, zero_inprod]

@[simp] lemma neg_smul_left_linear {V : Type u} [herm_inner_product_space V] (x y : V) :
-x ∘ y = -(x ∘ y) := by rw [←neg_one_smul, mul_lin_left, neg_one_mul]

@[simp] lemma neg_smul_right_antilinear {V : Type u} [herm_inner_product_space V] (x y : V) :
x ∘ -y = -(x ∘ y) := by rw [←neg_one_smul, mul_antilin_right, conj_neg, conj_one, neg_one_mul]

lemma conj_eq_real (x : ℂ) : x.im = 0 ↔ conj(x) = x :=
begin
split,
    intros H,
    have hn : -x.im = 0,
        rw neg_eq_zero,
        exact H,
    rw ←conj_im at hn,
    have hie : x.im = (conj(x)).im,
        simp [H, hn],
    have hre : x.re = (conj(x)).re,
        simp,
    rw eq_comm,
    apply complex.ext hre hie,

    intros H,
    have hie : (conj(x)).im = x.im,
        rw H,
    simp at hie,
    rw ←add_left_inj (x.im) at hie,
    simp at hie,
    rw eq_comm at hie,
    exact iff.elim_left add_self_eq_zero hie,
end

lemma ne_zero_im_zero_imp_re_ne_zero {x : ℂ} : x ≠  0 → x.im = 0 → x.re ≠ 0 :=
begin
intros H1 H2,
have Hx : x = ↑x.re,
    rw [←re_add_im x, H2, of_real_zero, zero_mul, field.add_zero, of_real_re],
rw Hx at H1,
exact of_real_ne_zero.mp H1,
end

lemma re_of_real (x : ℂ) : x.im = 0 → ↑(x.re) = x :=
begin
intros H,
rw [←re_add_im x, H, of_real_zero, zero_mul, field.add_zero, of_real_inj, of_real_re],
end

lemma ne_comm {α : Type u} (a b : α) : a ≠ b ↔ b ≠ a :=
begin
dunfold ne,
split,
    intros H,
    rw eq_comm,
    exact H,

    intros H,
    rw eq_comm,
    exact H,
end

theorem in_self_real {V : Type u} [herm_inner_product_space V] :
∀ (x : V), (x ∘ x).im = 0 :=
begin
intros,
have H : conj(x ∘ x) = x ∘ x,
    rw ←is_conj_sym,
rw conj_eq_real (x ∘ x),
exact H,
end

lemma ne_zero_iff_inprod_ne_zero {V : Type u} [herm_inner_product_space V] (x : V) :
(x ∘ x) ≠ 0 ↔ x ≠ 0 :=
begin
split,
    intros H,
    exact (iff_false_left H).mp (is_pos_def x).right,

    intros H,
    exact (iff_false_right H).mp (is_pos_def x).right,
end

noncomputable def herm_norm {V: Type u} [herm_inner_product_space V] (x : V) : ℝ := sqrt((x ∘ x).re)

local notation |a|  := herm_norm(a)

open classical

theorem cauchy_schwarz_innequality {V : Type u} [herm_inner_product_space V] :
∀ (x y : V), abs((x ∘ y)) ≤ |x|*|y| :=
begin
intros,
have ho : y = 0 ∨ y ≠ 0,
    apply em,
cases ho,
    rw ho,
    dunfold herm_norm,
    simp,

    have H : 0 ≤ |x - ((x ∘ y)/(↑( |y|*|y| ))) • y| * |x - ((x ∘ y)/(↑( |y|*|y| ))) • y| ,
        dunfold herm_norm,
        apply mul_nonneg (sqrt_nonneg (((x - (x ∘ y / ↑(sqrt ((y ∘ y).re) * sqrt ((y ∘ y).re))) • y) ∘ (x - (x ∘ y / ↑(sqrt ((y ∘ y).re) * sqrt ((y ∘ y).re))) • y)).re)) (sqrt_nonneg (((x - (x ∘ y / ↑(sqrt ((y ∘ y).re) * sqrt ((y ∘ y).re))) • y) ∘ (x - (x ∘ y / ↑(sqrt ((y ∘ y).re) * sqrt ((y ∘ y).re))) • y)).re)),
    simp at H,
    dunfold herm_norm at H,
    rw mul_self_sqrt (is_pos_def ((x + -((x ∘ y / (↑(sqrt ((y ∘ y).re)) * ↑(sqrt ((y ∘ y).re)))) • y)))).left at H,
    rw ←of_real_mul at H,
    rw of_real_inj.mpr (mul_self_sqrt (is_pos_def y).left) at H,
    simp [-neg_smul_left_linear, -neg_smul_right_antilinear]at H,
    rw is_conj_sym (-((x ∘ y / ↑((y ∘ y).re)) • y)) at H,
    rw conj_re at H,
    have he : (-((x ∘ y / ↑((y ∘ y).re)) • y) ∘ -((x ∘ y / ↑((y ∘ y).re)) • y)).re = -(x ∘ -((x ∘ y / ↑((y ∘ y).re)) • y)).re,
        rw neg_smul_right_antilinear,
        rw neg_smul_right_antilinear,
        rw neg_smul_left_linear,
        rw neg_neg,
        rw mul_lin_left,
        rw mul_antilin_right,
        rw mul_antilin_right,
        have hr : y ∘ y = ↑((y ∘ y).re),
            rw re_of_real (y ∘ y) (in_self_real y),
        rw conj_div,
        rw conj_of_real,
        rw ←hr,
        rw div_mul_cancel (conj(x ∘ y)) ((iff_false_right ho).mp (is_pos_def y).right),
        rw div_mul_eq_mul_div,
        rw div_mul_eq_mul_div,
        simp,
        rw field.mul_comm,
    rw he at H,
    rw add_neg_self at H,
    rw field.add_zero at H,
    rw neg_smul_right_antilinear at H,
    rw mul_antilin_right at H,
    rw conj_div at H,
    rw conj_of_real at H,
    dunfold herm_norm,
    dunfold complex.abs,
    rw ←sqrt_mul (is_pos_def x).left,
    rw sqrt_le (norm_sq_nonneg (x ∘ y)) (mul_nonneg (is_pos_def x).left (is_pos_def y).left),
    rw ←sub_le_iff_le_add' at H,
    rw sub_eq_neg_add at H,
    rw field.add_zero at H,
    rw div_mul_eq_mul_div at H,
    rw neg_re at H,
    rw neg_le_neg_iff at H,
    rw field.mul_comm at H,
    rw mul_conj at H,
    rw ←of_real_div at H,
    rw of_real_re at H,
    rw div_le_iff (lt_of_le_of_ne (is_pos_def y).left ((ne_comm ((y ∘ y).re) 0).mp (ne_zero_im_zero_imp_re_ne_zero  ((ne_zero_iff_inprod_ne_zero y).mpr ho) (in_self_real y)))) at H,
    exact H,
end

theorem parallelogram_law {V : Type u} [herm_inner_product_space V] (x y : V) :
|x + y|^2 + |x - y|^2 = 2*|x|^2 + 2*|y|^2 :=
begin
dunfold herm_norm,
rw sqr_sqrt (is_pos_def (x + y)).left,
rw sqr_sqrt (is_pos_def (x - y)).left,
rw sqr_sqrt (is_pos_def x).left,
rw sqr_sqrt (is_pos_def y).left,
simp,
rw is_conj_sym y,
rw conj_re,
ring,
end

open norm_space

theorem norm_parallelogram_iff_herm {W : Type v} [norm_space W] :
∀ (x y : W), N(x + y)^2 + N(x - y)^2 = 2*N(x)^2 + 2*N(y)^2 ↔
herm_inner_product_space W := sorry

noncomputable instance herm_space_is_norm_space {V : Type u} [herm_inner_product_space V] :
norm_space V :=
{
N := herm_norm,
norm_nonneg := begin intros, exact sqrt_nonneg ((x ∘ x).re), end,
norm_sub_add :=
    begin
    intros,
    have H : |x + y|*|x + y| = ((x + y) ∘ (x + y)).re,
        dunfold herm_norm,
        rw mul_self_sqrt (is_pos_def (x + y)).left,
    rw add_lin_left at H,
    rw add_lin_right at H,
    rw add_lin_right at H,
    rw is_conj_sym y at H,
    rw field.add_assoc at H,
    rw ←field.add_assoc (x ∘ y) at H,
    rw add_conj at H,
    rw add_re at H,
    rw add_re at H,
    rw of_real_re at H,
    have hle : 2*(x ∘ y).re ≤ 2*abs(x ∘ y),
        exact (mul_le_mul_left (lt_trans zero_lt_one (begin exact two_gt_one, end))).mpr (re_le_abs (x ∘ y)),
    rw ←sub_zero (2 * abs (x ∘ y)) at hle,
    rw le_sub at hle,
    have Hle : |x + y|*|x + y| + 0 ≤ (x ∘ x).re + (2 * (x ∘ y).re + (y ∘ y).re) + (2 * abs (x ∘ y) - 2 * (x ∘ y).re),
        exact add_le_add (le_of_eq H) hle,
    simp at Hle,
    rw ←field.add_assoc at Hle,
    have Hcs : 2*abs(x ∘ y) ≤ 2*|x|*|y|,
        rw field.mul_assoc,
        exact (mul_le_mul_left (lt_trans zero_lt_one (begin exact two_gt_one, end))).mpr (cauchy_schwarz_innequality x y),
    have hz : 2*abs(x ∘ y) ≥ 0,
        rw two_mul,
        have ha : abs(x ∘ y) ≥ 0,
            exact abs_nonneg (x ∘ y),
        exact le_add_of_le_of_nonneg ha ha,
    dunfold herm_norm at Hcs,
    rw ←sub_zero (2 * sqrt ((x ∘ x).re) * sqrt ((y ∘ y).re)) at Hcs,
    rw le_sub at Hcs,
    have Hs : |x + y|*|x + y| ≤ 2 * sqrt ((x ∘ x).re) * sqrt ((y ∘ y).re) - 2 * abs (x ∘ y) + ((x ∘ x).re + (y ∘ y).re + 2 * abs (x ∘ y)),
        apply le_add_of_nonneg_of_le Hcs Hle,
    simp at Hs,
    have He : (x ∘ x).re + ((y ∘ y).re + 2 * sqrt ((x ∘ x).re) * sqrt ((y ∘ y).re)) = (herm_norm(x) + herm_norm(y))*(herm_norm(x) + herm_norm(y)),
        dunfold herm_norm,
        ring,
        simp,
        rw sqr_sqrt (is_pos_def y).left,
        rw ring.right_distrib,
        rw ←sqrt_mul,
        rw sqrt_mul_self ((is_pos_def x).left),
        ring,
        exact (is_pos_def x).left,
    rw He at Hs,
    apply (mul_self_le_mul_self_iff (begin intros, exact sqrt_nonneg (((x + y) ∘ (x + y)).re), end) (add_nonneg (begin intros, exact sqrt_nonneg ((x ∘ x).re), end) (begin intros, exact sqrt_nonneg ((y ∘ y).re), end))).mpr Hs,
    end,
norm_abs_hom :=
    begin
    intros,
    dunfold herm_norm,
    rw mul_lin_left,
    rw mul_antilin_right,
    rw ←field.mul_assoc,
    rw mul_re,
    rw mul_conj,
    rw of_real_im,
    rw zero_mul,
    rw sub_zero,
    simp,
    rw sqrt_mul (norm_sq_nonneg a),
    refl,
    end,
norm_pos_def :=
    begin
    intros,
    dunfold herm_norm,
    have ho : (x ∘ x).im = 0,
        exact in_self_real x,
    split,
        intros H,
        rw ←sqrt_zero at H,
        rw sqrt_inj ((is_pos_def x).left) (le_of_eq (refl 0)) at H,
        rw ←zero_im at ho,
        rw ←zero_re at H,
        have hpo : x ∘ x = 0,
            exact complex.ext H ho,
        exact ((is_pos_def x).right).mp hpo,

        intros hz,
        rw ←sqrt_zero,
        rw sqrt_inj ((is_pos_def x).left) (le_of_eq (refl 0)),
        have hpo : x ∘ x = 0,
            exact ((is_pos_def x).right).mpr hz,
        rw ←zero_re,
        rw hpo,
    end,
}

@[simp] lemma herm_norm_smul {V : Type u} [herm_inner_product_space V] (x : V) (a : ℂ) :
|a • x| = abs(a)*|x| := norm_abs_hom x a

@[simp] lemma of_real_herm_norm_sqr {V : Type u} [herm_inner_product_space V] (x : V) :
↑( |x|^2 ) = x ∘ x :=
begin
dunfold herm_norm,
rw sqr_sqrt (is_pos_def x).left,
rw re_of_real (x ∘ x) (in_self_real x),
end

@[simp] lemma of_real_herm_norm_mul_self {V : Type u} [herm_inner_product_space V] (x : V) :
↑( |x|*|x| ) = x ∘ x :=
begin
dunfold herm_norm,
rw mul_self_sqrt (is_pos_def x).left,
rw re_of_real (x ∘ x) (in_self_real x),
end

lemma herm_normalise_normalises {V : Type u} [herm_inner_product_space V] (x : V) (ho : x ≠ 0) :
| ↑|x|⁻¹ • x| = 1 :=
begin
dunfold herm_norm,
simp [-sqrt_inv],
rw ←sqrt_one,
rw sqrt_inj (mul_nonneg (inv_nonneg.mpr (sqrt_nonneg (x ∘ x).re)) (mul_nonneg (inv_nonneg.mpr (sqrt_nonneg (x ∘ x).re)) (is_pos_def x).left)) (zero_le_one),
ring,
rw ←sqrt_inv,
rw sqr_sqrt (inv_nonneg.mpr (is_pos_def x).left),
rw field.inv_mul_cancel,
    exact (ne_zero_im_zero_imp_re_ne_zero ((ne_zero_iff_inprod_ne_zero x).mpr ho) (in_self_real x)),
end

def herm_normalise_set {V : Type u} [herm_inner_product_space V] :
set V → set V := image(λ x, ↑|x|⁻¹ • x)

lemma normalise_set_normalises {V : Type u} [herm_inner_product_space V]
(A : set V) (Ho : (0 : V) ∉ A) :
∀ x ∈ normalise_set(A), is_normalised x :=
begin
dunfold normalise_set,
dunfold image,
intros,
have Ha : ∃ (a : V), a ∈ A ∧ normalise a = x,
    rw mem_set_of_eq at H,
    exact H,
apply (exists.elim Ha),
intros a Hl,
rw ←Hl.right,
have ho : a ≠ 0,
    intros h,
    rw h at Hl,
    exact Ho Hl.left,
exact herm_normalise_normalises a ho,
end

/-
lemma normalised_linear_indep {V : Type u} [herm_inner_product_space V] (s : set V) :
linear_independent s → linear_independent (normalise_set s) :=
begin
dunfold linear_independent,
intros H1 l H3 H4,
have H5 : ∀ (x : V), x ∉ s → x ∈ normalise_set s,
    intros x hx,
end

#print finsupp.sum
#print finsupp
#print coe_fn

lemma normalised_span_spans {V : Type u} [herm_inner_product_space V] (s : set V) :
span s = span (normalise_set s) :=
begin
rw set_eq_def,
intros,
dunfold span,
split,
    intros H,
    rw mem_set_of_eq at H,
    apply exists.elim H,
    intros v Hv,

    admit,

    admit,
end

lemma normalised_basis_is_basis {V : Type u} [herm_inner_product_space V] (b : set V) :
is_basis b → is_basis (normalise_set b) :=
begin
dunfold is_basis,
intros H,
apply and.intro,
    exact normalised_linear_indep b H.left,

    exact (forall_congr ((set_eq_def (span b) (span (normalise_set b))).mp (normalised_span_spans b))).mp H.right,
end

theorem exists_normalised_basis {V : Type u} [herm_inner_product_space V] :
∃ (b : set V), is_basis b ∧ ∀ (x : V), x ∈ b → is_normalised x :=
begin
have H1 : ∃ (b : set V), is_basis b,
    exact exists_is_basis V,
apply exists.elim H1,
intros b Hb,
exact exists.intro (normalise_set b) (and.intro (normalised_basis_is_basis b Hb) (normalise_set_normalises b (zero_not_mem_of_linear_independent (zero_ne_one ℂ) Hb.left))),
end
-/

def is_ortho {V : Type u} [herm_inner_product_space V] (x y : V) : Prop :=
x ∘ y = 0

notation a ⊥ b := is_ortho a b

theorem ortho_refl_iff_zero {V : Type u} [herm_inner_product_space V] (x : V) :
(x ⊥ x) ↔ x = 0 := (is_pos_def x).right

theorem ortho_mul_left {V : Type u} [herm_inner_product_space V] (x y : V) (a : ℂ) (ha : a ≠ 0) :
(x ⊥ y) ↔ ((a • x) ⊥ y) :=
begin
dunfold is_ortho,
split,
    intros H,
    rw [mul_lin_left, H, mul_zero],

    intros H,
    rw [mul_lin_left, mul_eq_zero] at H,
    cases H,
        trivial,

        exact H,
end

theorem ortho_mul_right {V :Type u} [herm_inner_product_space V] (x y : V) (a : ℂ) (ha : a ≠ 0) :
(x ⊥ y) ↔ (x ⊥ (a • y)) :=
begin
dunfold is_ortho,
split,
    intros H,
    rw [mul_antilin_right, H, mul_zero],

    intros H,
    rw [mul_antilin_right, mul_eq_zero] at H,
    cases H,
        rw conj_eq_zero at H,
        trivial,

        exact H,
end

theorem ortho_imp_not_lindep {V :Type u} [herm_inner_product_space V] (x y : V) (hx : x ≠ 0) (hy : y ≠ 0) :
(x ⊥ y) → ¬∃ (a : ℂ), (a ≠ 0) ∧ (x = a • y ∨ a • x = y) :=
begin
    intros H1,
    apply not_exists.mpr,
    intros a,
    intros H2,
    dunfold is_ortho at H1,
    cases H2 with ha H2,
    cases H2,
        rw H2 at H1,
        rw mul_lin_left at H1,
        rw mul_eq_zero at H1,
        cases H1,
            trivial,

            exact hy (((is_pos_def y).right).mp H1),

        rw ←H2 at H1,
        rw mul_antilin_right at H1,
        rw mul_eq_zero at H1,
        cases H1,
            exact ha ((conj_eq_zero).mp H1),

            exact hx (((is_pos_def x).right).mp H1),
end

theorem pythag_iden {V : Type u} [herm_inner_product_space V] (x y : V) (H : x ⊥ y) :
|x + y|^2 = |x|^2 + |y|^2 :=
begin
dunfold herm_norm,
rw sqr_sqrt (is_pos_def (x + y)).left,
rw sqr_sqrt (is_pos_def x).left,
rw sqr_sqrt (is_pos_def y).left,
simp,
dunfold is_ortho at H,
rw [is_conj_sym y, H],
simp,
end

def is_ortho_set {V : Type u} [herm_inner_product_space V] (s : set V) :=
∀ x y ∈ s, (x ⊥ y) ↔ x ≠ y

def is_orthonormal_set {V : Type u} [herm_inner_product_space V] (s : set V) :=
is_ortho_set s ∧ ∀ x ∈ s, is_normalised x

noncomputable def proj {V : Type u} [herm_inner_product_space V] (x y : V) :=
((x ∘ y)/( ↑|y|*|y| )) • y

lemma zero_proj {V : Type u} [herm_inner_product_space V] (x : V) :
proj 0 x = 0 := by dunfold proj; simp

lemma proj_zero {V : Type u} [herm_inner_product_space V] (x : V) :
proj x 0 = 0 := by dunfold proj; simp

lemma proj_self_eq_self {V : Type u} [herm_inner_product_space V] (x : V) :
proj x x = x :=
begin
have ho : x = 0 ∨ x ≠ 0,
    apply em,
dunfold proj,
cases ho,
    rw ho,
    simp,

    rw ←of_real_mul,
    simp,
    rw div_self ((ne_zero_iff_inprod_ne_zero x).mpr ho),
    rw one_smul,
end

lemma smul_proj {V : Type u} [herm_inner_product_space V] (x y : V) {a : ℂ} :
proj (a • x) y = a • (proj x y) :=
begin
dunfold proj,
simp,
rw smul_smul,
ring,
end

lemma proj_smul {V : Type u} [herm_inner_product_space V] (x y : V) {a : ℂ} (ha : a ≠ 0) :
proj x (a • y) = proj x y :=
begin
have Hy : y = 0 ∨ y ≠ 0,
    apply em,
cases Hy,
    rw Hy,
    rw smul_zero,

    dunfold proj,
    simp,
    rw smul_smul,
    ring,
    rw field.mul_assoc,
    rw ←field.mul_comm a,
    rw mul_conj,
    rw ←field.mul_assoc ( ↑(abs a) * ↑|y| ),
    rw field.mul_comm (↑(abs a)),
    rw field.mul_assoc ( ↑|y| ),
    rw ←of_real_mul,
    rw mul_self_abs,
    rw field.mul_comm ( ↑|y| ),
    rw field.mul_comm,
    rw field.mul_assoc,
    rw mul_inv_eq,
    rw field.mul_comm,
    rw field.mul_assoc ((↑|y| * ↑|y| )⁻¹),
    rw field.mul_comm (↑(norm_sq a))⁻¹,
    rw field.mul_assoc,
    rw field.mul_assoc (x ∘ y),
    rw field.inv_mul_cancel,
    rw field.mul_one,
    refl,

    exact of_real_ne_zero.mpr ((iff_false_right ha).mp (norm_sq_eq_zero)),
    exact (mul_ne_zero (of_real_ne_zero.mpr ((norm_ne_zero_iff_ne_zero y).mpr Hy)) (of_real_ne_zero.mpr ((norm_ne_zero_iff_ne_zero y).mpr Hy))),
    exact of_real_ne_zero.mpr ((iff_false_right ha).mp (norm_sq_eq_zero)),
end

theorem exists_ortho_basis {V :Type u} [herm_inner_product_space V] :
∃ S : set V, is_basis S ∧ is_orthonormal_set S :=
begin
have H : ∃ S : set V, is_basis S,
    exact exists_is_basis V,
apply exists.elim H,
intros A H,
admit,
end

noncomputable def herm_dist {V : Type u} [herm_inner_product_space V] (x y : V) : ℝ := |x - y|

open metric_space

/-
noncomputable instance herm_space_is_metric_space {V : Type u} [herm_inner_product_space V] :
metric_space V := norm_space_is_metric_space
{
dist := herm_dist,
dist_self :=
    begin
    intros,
    dunfold herm_dist,
    dunfold herm_norm,
    simp,
    end,
eq_of_dist_eq_zero :=
    begin
    dunfold herm_dist,
    dunfold herm_norm,
    intros x y H,
    rw sqrt_eq_zero (is_pos_def (x - y)).left at H,
    rw ←zero_re at H,
    have H1 : (x - y) ∘ (x - y) = 0,
        exact complex.ext H (in_self_real (x - y)),
    rw (is_pos_def (x - y)).right at H1,
    exact sub_eq_zero.mp H1,
    end,
dist_comm :=
    begin
    intros,
    dunfold herm_dist,
    dunfold herm_norm,
    rw sqrt_inj (is_pos_def (x - y)).left (is_pos_def (y - x)).left,
    simp,
    end,
dist_triangle :=
    begin
    dunfold herm_dist,
    intros,
    have H : x - z = (x - y) + (y - z),
        simp,
    rw H,
    exact norm_sub_add (x - y) (y - z),
    end,
}
-/

class Hilbert_space (V : Type u) extends herm_inner_product_space V, uniform_space.core V :=
(is_open_uniformity : ∀s : set V, is_open s ↔ (∀x∈s, { p : V × V | p.1 = x → p.2 ∈ s } ∈ uniformity.sets))
(complete : ∀{f:filter V}, cauchy f → ∃x, f ≤ nhds x)

instance Hilbert_space.to_complete_space (V : Type u) [c : Hilbert_space V] : complete_space V :=
{ complete := @Hilbert_space.complete V c}


/-
Copyright (c) 2019 Johan Commelin. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Riccardo Brasca, Johan Commelin
-/
import data.polynomial.field_division
import field_theory.minpoly.basic
import ring_theory.algebraic

/-!
# Minimal polynomials on an algebra over a field

This file specializes the theory of minpoly to the setting of field extensions
and derives some well-known properties, amongst which the fact that minimal polynomials
are irreducible, and uniquely determined by their defining property.

-/

open_locale classical polynomial
open polynomial set function minpoly

namespace minpoly

variables {A B : Type*}
variables (A) [field A]

section ring

variables [ring B] [algebra A B] (x : B)

/-- If an element `x` is a root of a nonzero polynomial `p`, then the degree of `p` is at least the
degree of the minimal polynomial of `x`. See also `gcd_domain_degree_le_of_ne_zero` which relaxes
the assumptions on `A` in exchange for stronger assumptions on `B`. -/
lemma degree_le_of_ne_zero
  {p : A[X]} (pnz : p ≠ 0) (hp : polynomial.aeval x p = 0) :
  degree (minpoly A x) ≤ degree p :=
calc degree (minpoly A x) ≤ degree (p * C (leading_coeff p)⁻¹) :
    min A x (monic_mul_leading_coeff_inv pnz) (by simp [hp])
  ... = degree p : degree_mul_leading_coeff_inv p pnz

lemma ne_zero_of_finite_field_extension (e : B) [finite_dimensional A B] : minpoly A e ≠ 0 :=
minpoly.ne_zero $ is_integral_of_noetherian (is_noetherian.iff_fg.2 infer_instance) _

/-- The minimal polynomial of an element `x` is uniquely characterized by its defining property:
if there is another monic polynomial of minimal degree that has `x` as a root, then this polynomial
is equal to the minimal polynomial of `x`. See also `minpoly.gcd_unique` which relaxes the
assumptions on `A` in exchange for stronger assumptions on `B`. -/
lemma unique {p : A[X]}
  (pmonic : p.monic) (hp : polynomial.aeval x p = 0)
  (pmin : ∀ q : A[X], q.monic → polynomial.aeval x q = 0 → degree p ≤ degree q) :
  p = minpoly A x :=
begin
  have hx : is_integral A x := ⟨p, pmonic, hp⟩,
  symmetry, apply eq_of_sub_eq_zero,
  by_contra hnz,
  have := degree_le_of_ne_zero A x hnz (by simp [hp]),
  contrapose! this,
  apply degree_sub_lt _ (ne_zero hx),
  { rw [(monic hx).leading_coeff, pmonic.leading_coeff] },
  { exact le_antisymm (min A x pmonic hp)
      (pmin (minpoly A x) (monic hx) (aeval A x)) }
end

/-- If an element `x` is a root of a polynomial `p`, then the minimal polynomial of `x` divides `p`.
See also `minpoly.gcd_domain_dvd` which relaxes the assumptions on `A` in exchange for stronger
assumptions on `B`. -/
lemma dvd {p : A[X]} (hp : polynomial.aeval x p = 0) : minpoly A x ∣ p :=
begin
  by_cases hp0 : p = 0,
  { simp only [hp0, dvd_zero] },
  have hx : is_integral A x,
  { rw ← is_algebraic_iff_is_integral, exact ⟨p, hp0, hp⟩ },
  rw ← dvd_iff_mod_by_monic_eq_zero (monic hx),
  by_contra hnz,
  have := degree_le_of_ne_zero A x hnz _,
  { contrapose! this,
    exact degree_mod_by_monic_lt _ (monic hx) },
  { rw ← mod_by_monic_add_div p (monic hx) at hp,
    simpa using hp }
end

lemma dvd_map_of_is_scalar_tower (A K : Type*) {R : Type*} [comm_ring A] [field K] [comm_ring R]
  [algebra A K] [algebra A R] [algebra K R] [is_scalar_tower A K R] (x : R) :
  minpoly K x ∣ (minpoly A x).map (algebra_map A K) :=
by { refine minpoly.dvd K x _, rw [aeval_map_algebra_map, minpoly.aeval] }

lemma dvd_map_of_is_scalar_tower' (R : Type*) {S : Type*} (K L : Type*) [comm_ring R]
  [comm_ring S] [field K] [comm_ring L] [algebra R S] [algebra R K] [algebra S L] [algebra K L]
  [algebra R L] [is_scalar_tower R K L] [is_scalar_tower R S L] (s : S):
  minpoly K (algebra_map S L s) ∣ (map (algebra_map R K) (minpoly R s)) :=
begin
  apply minpoly.dvd K (algebra_map S L s),
  rw [← map_aeval_eq_aeval_map, minpoly.aeval, map_zero],
  rw [← is_scalar_tower.algebra_map_eq, ← is_scalar_tower.algebra_map_eq]
end

/-- If `y` is a conjugate of `x` over a field `K`, then it is a conjugate over a subring `R`. -/
lemma aeval_of_is_scalar_tower (R : Type*) {K T U : Type*} [comm_ring R] [field K] [comm_ring T]
  [algebra R K] [algebra K T] [algebra R T] [is_scalar_tower R K T]
  [comm_semiring U] [algebra K U] [algebra R U] [is_scalar_tower R K U]
  (x : T) (y : U)
  (hy : polynomial.aeval y (minpoly K x) = 0) : polynomial.aeval y (minpoly R x) = 0 :=
aeval_map_algebra_map K y (minpoly R x) ▸ eval₂_eq_zero_of_dvd_of_eval₂_eq_zero (algebra_map K U)
                                              y (minpoly.dvd_map_of_is_scalar_tower R K x) hy

variables {A x}

theorem eq_of_irreducible_of_monic
  [nontrivial B] {p : A[X]} (hp1 : _root_.irreducible p)
  (hp2 : polynomial.aeval x p = 0) (hp3 : p.monic) : p = minpoly A x :=
let ⟨q, hq⟩ := dvd A x hp2 in
eq_of_monic_of_associated hp3 (monic ⟨p, ⟨hp3, hp2⟩⟩) $
mul_one (minpoly A x) ▸ hq.symm ▸ associated.mul_left _ $
associated_one_iff_is_unit.2 $ (hp1.is_unit_or_is_unit hq).resolve_left $ not_is_unit A x

lemma eq_of_irreducible [nontrivial B] {p : A[X]}
  (hp1 : _root_.irreducible p) (hp2 : polynomial.aeval x p = 0) :
  p * C p.leading_coeff⁻¹ = minpoly A x :=
begin
  have : p.leading_coeff ≠ 0 := leading_coeff_ne_zero.mpr hp1.ne_zero,
  apply eq_of_irreducible_of_monic,
  { exact associated.irreducible ⟨⟨C p.leading_coeff⁻¹, C p.leading_coeff,
      by rwa [←C_mul, inv_mul_cancel, C_1], by rwa [←C_mul, mul_inv_cancel, C_1]⟩, rfl⟩ hp1 },
  { rw [aeval_mul, hp2, zero_mul] },
  { rwa [polynomial.monic, leading_coeff_mul, leading_coeff_C, mul_inv_cancel] },
end

/-- If `y` is the image of `x` in an extension, their minimal polynomials coincide.

We take `h : y = algebra_map L T x` as an argument because `rw h` typically fails
since `is_integral R y` depends on y.
-/
lemma eq_of_algebra_map_eq {K S T : Type*} [field K] [comm_ring S] [comm_ring T]
  [algebra K S] [algebra K T] [algebra S T]
  [is_scalar_tower K S T] (hST : function.injective (algebra_map S T))
  {x : S} {y : T} (hx : is_integral K x) (h : y = algebra_map S T x) :
  minpoly K x = minpoly K y :=
minpoly.unique _ _ (minpoly.monic hx)
  (by rw [h, aeval_algebra_map_apply, minpoly.aeval, ring_hom.map_zero])
  (λ q q_monic root_q, minpoly.min _ _ q_monic
    ((aeval_algebra_map_eq_zero_iff_of_injective hST).mp
      (h ▸ root_q : polynomial.aeval (algebra_map S T x) q = 0)))

lemma add_algebra_map {B : Type*} [comm_ring B] [algebra A B] {x : B}
  (hx : is_integral A x) (a : A) :
  minpoly A (x + (algebra_map A B a)) = (minpoly A x).comp (X - C a) :=
begin
  refine (minpoly.unique _ _ ((minpoly.monic hx).comp_X_sub_C _) _ (λ q qmo hq, _)).symm,
  { simp [aeval_comp] },
  { have : (polynomial.aeval x) (q.comp (X + C a)) = 0 := by simpa [aeval_comp] using hq,
    have H := minpoly.min A x (qmo.comp_X_add_C _) this,
    rw [degree_eq_nat_degree qmo.ne_zero, degree_eq_nat_degree
      ((minpoly.monic hx).comp_X_sub_C _).ne_zero, with_bot.coe_le_coe, nat_degree_comp,
      nat_degree_X_sub_C, mul_one],
    rwa [degree_eq_nat_degree (minpoly.ne_zero hx), degree_eq_nat_degree
      (qmo.comp_X_add_C _).ne_zero, with_bot.coe_le_coe, nat_degree_comp,
      nat_degree_X_add_C, mul_one] at H }
end

lemma sub_algebra_map {B : Type*} [comm_ring B] [algebra A B] {x : B}
  (hx : is_integral A x) (a : A) :
  minpoly A (x - (algebra_map A B a)) = (minpoly A x).comp (X + C a) :=
by simpa [sub_eq_add_neg] using add_algebra_map hx (-a)

section alg_hom_fintype

/-- A technical finiteness result. -/
noncomputable def fintype.subtype_prod {E : Type*} {X : set E} (hX : X.finite) {L : Type*}
  (F : E → multiset L) : fintype (Π x : X, {l : L // l ∈ F x}) :=
let hX := finite.fintype hX in by exactI pi.fintype

variables (F E K : Type*) [field F] [ring E] [comm_ring K] [is_domain K]
  [algebra F E] [algebra F K] [finite_dimensional F E]

/-- Function from Hom_K(E,L) to pi type Π (x : basis), roots of min poly of x -/
-- Marked as `noncomputable!` since this definition takes multiple seconds to compile,
-- and isn't very computable in practice (since neither `finrank` nor `fin_basis` are).
noncomputable! def roots_of_min_poly_pi_type (φ : E →ₐ[F] K)
  (x : range (finite_dimensional.fin_basis F E : _ → E)) :
  {l : K // l ∈ (((minpoly F x.1).map (algebra_map F K)).roots : multiset K)} :=
⟨φ x, by rw [mem_roots_map (minpoly.ne_zero_of_finite_field_extension F x.val),
  subtype.val_eq_coe, ←aeval_def, aeval_alg_hom_apply, minpoly.aeval, map_zero]⟩

lemma aux_inj_roots_of_min_poly : injective (roots_of_min_poly_pi_type F E K) :=
begin
  intros f g h,
  suffices : (f : E →ₗ[F] K) = g,
  { rwa fun_like.ext'_iff at this ⊢ },
  rw funext_iff at h,
  exact linear_map.ext_on (finite_dimensional.fin_basis F E).span_eq
    (λ e he, subtype.ext_iff.mp (h ⟨e, he⟩)),
end

/-- Given field extensions `E/F` and `K/F`, with `E/F` finite, there are finitely many `F`-algebra
  homomorphisms `E →ₐ[K] K`. -/
noncomputable instance alg_hom.fintype : fintype (E →ₐ[F] K) :=
@fintype.of_injective _ _ (fintype.subtype_prod (finite_range (finite_dimensional.fin_basis F E))
  (λ e, ((minpoly F e).map (algebra_map F K)).roots)) _ (aux_inj_roots_of_min_poly F E K)

end alg_hom_fintype

variables (B) [nontrivial B]

/-- If `B/K` is a nontrivial algebra over a field, and `x` is an element of `K`,
then the minimal polynomial of `algebra_map K B x` is `X - C x`. -/
lemma eq_X_sub_C (a : A) : minpoly A (algebra_map A B a) = X - C a :=
eq_X_sub_C_of_algebra_map_inj a (algebra_map A B).injective

lemma eq_X_sub_C' (a : A) : minpoly A a = X - C a := eq_X_sub_C A a

variables (A)

/-- The minimal polynomial of `0` is `X`. -/
@[simp] lemma zero : minpoly A (0:B) = X :=
by simpa only [add_zero, C_0, sub_eq_add_neg, neg_zero, ring_hom.map_zero]
  using eq_X_sub_C B (0:A)

/-- The minimal polynomial of `1` is `X - 1`. -/
@[simp] lemma one : minpoly A (1:B) = X - 1 :=
by simpa only [ring_hom.map_one, C_1, sub_eq_add_neg] using eq_X_sub_C B (1:A)

end ring

section is_domain

variables [ring B] [is_domain B] [algebra A B]
variables {A} {x : B}

/-- A minimal polynomial is prime. -/
lemma prime (hx : is_integral A x) : prime (minpoly A x) :=
begin
  refine ⟨ne_zero hx, not_is_unit A x, _⟩,
  rintros p q ⟨d, h⟩,
  have :    polynomial.aeval x (p*q) = 0 := by simp [h, aeval A x],
  replace : polynomial.aeval x p = 0 ∨ polynomial.aeval x q = 0 := by simpa,
  exact or.imp (dvd A x) (dvd A x) this
end

/-- If `L/K` is a field extension and an element `y` of `K` is a root of the minimal polynomial
of an element `x ∈ L`, then `y` maps to `x` under the field embedding. -/
lemma root {x : B} (hx : is_integral A x) {y : A} (h : is_root (minpoly A x) y) :
  algebra_map A B y = x :=
have key : minpoly A x = X - C y :=
eq_of_monic_of_associated (monic hx) (monic_X_sub_C y) (associated_of_dvd_dvd
  ((irreducible_X_sub_C y).dvd_symm (irreducible hx) (dvd_iff_is_root.2 h))
  (dvd_iff_is_root.2 h)),
by { have := aeval A x, rwa [key, alg_hom.map_sub, aeval_X, aeval_C, sub_eq_zero, eq_comm] at this }

/-- The constant coefficient of the minimal polynomial of `x` is `0` if and only if `x = 0`. -/
@[simp] lemma coeff_zero_eq_zero (hx : is_integral A x) : coeff (minpoly A x) 0 = 0 ↔ x = 0 :=
begin
  split,
  { intro h,
    have zero_root := zero_is_root_of_coeff_zero_eq_zero h,
    rw ← root hx zero_root,
    exact ring_hom.map_zero _ },
  { rintro rfl, simp }
end

/-- The minimal polynomial of a nonzero element has nonzero constant coefficient. -/
lemma coeff_zero_ne_zero (hx : is_integral A x) (h : x ≠ 0) : coeff (minpoly A x) 0 ≠ 0 :=
by { contrapose! h, simpa only [hx, coeff_zero_eq_zero] using h }

end is_domain

end minpoly


/-
Copyright (c) 2023 Jeremy Avigad. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Jeremy Avigad
-/

import Mathlib.Data.Finset.Powerset
import Mathlib.Data.Finset.Card
import Mathlib.Algebra.BigOperators.Ring
import ProofChecker.Data.Pog

open Finset

/-
This is the counting function for partitioned formulas, also known as POGs. The main theorem,
to be proved below, is that this really does count the number of models.
-/

namespace PropForm

def countModels (nVars : Nat) : PropForm ν → Nat
  | tr         => 2^nVars
  | fls        => 0
  | var _      => 2^(nVars - 1)
  | neg φ      => 2^nVars - φ.countModels nVars
  | disj φ ψ   => φ.countModels nVars + ψ.countModels nVars
  | conj φ ψ   => φ.countModels nVars * ψ.countModels nVars / 2^nVars
  | impl _ _   => 0
  | biImpl _ _ => 0

def ringEval {R : Type} [CommRing R] (weight : ν → R) : PropForm ν → R
  | tr         => 1
  | fls        => 0
  | var x      => weight x
  | neg φ      => 1 - φ.ringEval weight
  | disj φ ψ   => φ.ringEval weight + ψ.ringEval weight
  | conj φ ψ   => φ.ringEval weight * ψ.ringEval weight
  | impl _ _   => 0
  | biImpl _ _ => 0

end PropForm

/-
Propositional assignments and their restrictions to finsets.
-/

namespace PropAssignment

def defined_on (v : PropAssignment ν) (s : Finset ν) : Prop := ∀ ⦃x⦄, x ∉ s → v x = false

theorem eq_false_of_defined_on {v : PropAssignment ν} {s : Finset ν} {x : ν}
    (h : v.defined_on s) (h' : ¬ x ∈ s) : v x = false := h h'

theorem defined_on_mono {v : PropAssignment ν} {s t : Finset ν} (h : s ⊆ t) :
    v.defined_on s → v.defined_on t :=
  fun h' _ hnnt => h' fun hns => hnnt (h hns)

variable [DecidableEq ν]

def restrict (v : PropAssignment ν) (s : Finset ν) : PropAssignment ν := fun x => if x ∈ s then v x else false

@[simp] theorem defined_on_restrict (v : PropAssignment ν) (s : Finset ν) :
    (v.restrict s).defined_on s := by intro n hns; rw [restrict, if_neg hns]

@[simp] theorem restrict_pos (v : PropAssignment ν) {x : ν} {s : Finset ν} (h : x ∈ s) :
    v.restrict s x = v x := by simp [restrict, h]

end PropAssignment

namespace PropForm

variable [DecidableEq ν]

theorem eval_restrict_vars (φ : PropForm ν) (v : PropAssignment ν) :
    φ.eval (v.restrict φ.vars) = φ.eval v :=
  eval_ext fun _ hx => v.restrict_pos hx

end PropForm

namespace Finset

variable [DecidableEq ν]

/-- The characteristic funbction of `s`. -/
def toPropAssignment (s : Finset ν) : PropAssignment ν := fun x => if x ∈ s then true else false

theorem toPropAssignment_eq_true {x : ν} (s : Finset ν) :
    s.toPropAssignment x = true ↔ x ∈ s := by
  rw [toPropAssignment]; split <;> simp_all

theorem toPropAssignment_eq_false {x : ν} (s : Finset ν) :
    s.toPropAssignment x = false ↔ x ∉ s := by
  simp [←toPropAssignment_eq_true]

theorem injective_toPropAssignment : Function.Injective (@toPropAssignment ν _) := by
  intro s1 s2 heq
  ext x
  have := congr_fun heq x
  rw [←s1.toPropAssignment_eq_true, this, s2.toPropAssignment_eq_true]

end Finset

/-
Models of a propositional formula over a set of variables.

Note: we don't intend to use this theory computationally, so we use classical logic to declare
decidable equality on `PropAssignment ν`.
-/

variable [DecidableEq ν]

noncomputable instance : DecidableEq (PropAssignment ν) := fun _ _ => Classical.propDecidable _

namespace Finset

noncomputable def assignments (s : Finset ν) : Finset (PropAssignment ν) :=
  s.powerset.image toPropAssignment

@[simp] theorem mem_assignments (s : Finset ν) (v : PropAssignment ν) :
    v ∈ assignments s ↔ v.defined_on s := by
  simp only [assignments, mem_image, mem_powerset]
  constructor
  . rintro ⟨t, ht1, rfl⟩ x hx
    rw [toPropAssignment_eq_false]
    intro h; exact hx (ht1 h)
  . intro h
    use s.filter (v . = true)
    simp only [filter_subset, true_and]
    ext x
    simp only [toPropAssignment, mem_filter]
    by_cases hx : x ∈ s
    . cases (v x) <;> simp [hx]
    . simp [hx, h hx]

theorem InjOn_set_assignments (s : Finset ν) (hxs : x ∉ s) (b : Bool) :
    Set.InjOn (PropAssignment.set . x b) (assignments s) := by
  intro v1 hv1 v2 hv2 heq
  simp only [mem_coe, mem_assignments] at hv1 hv2
  ext x'
  have := congr_fun heq x'; dsimp at this
  by_cases h : x' = x
  . rw [h, hv1 hxs, hv2 hxs]
  . rwa [PropAssignment.set_get_of_ne _ _ (Ne.symm h),
      PropAssignment.set_get_of_ne _ _ (Ne.symm h)] at this

theorem assignments_empty : assignments (∅ : Finset ν) = {fun _ => false} := by
  ext τ; simp only [mem_assignments, PropAssignment.defined_on, not_mem_empty, not_false_iff,
    forall_true_left, mem_singleton]
  constructor
  . intro h; ext x; simp [h]
  . intro h; simp [h]

theorem card_assignments (s : Finset ν) : card (assignments s) = 2^(card s) := by
  rw [assignments, card_image_of_injective _ injective_toPropAssignment, card_powerset]

end Finset

def PropAssignment.cond (s : Finset ν) (p : PropAssignment ν × PropAssignment ν) :
    PropAssignment ν :=
  fun x => if x ∈ s then p.1 x else p.2 x

namespace PropForm

/-- Models of a propositional formula on a set of variables -/
noncomputable def models (φ : PropForm ν) (s : Finset ν) := s.assignments.filter (φ.eval .)

@[simp] theorem mem_models {φ : PropForm ν} {s : Finset ν} (v : PropAssignment ν) :
    v ∈ φ.models s ↔ v.defined_on s ∧ φ.eval v = true :=
  by rw [models, mem_filter, mem_assignments]

theorem models_tr (s : Finset ν) : tr.models s = assignments s := by
  simp [models]

theorem models_fls (s : Finset ν) : fls.models s = (∅ : Finset (PropAssignment ν)) := by
  ext τ; simp

theorem models_disj {φ ψ : PropForm ν} (s : Finset ν) :
    (φ.disj ψ).models s = (φ.models s) ∪ (ψ.models s) := by
  ext v; simp [mem_models, eval, and_or_left]

theorem models_Disjoint {φ ψ : PropForm ν} (s : Finset ν) (h : ∀ v, ¬ (φ.eval v ∧ ψ.eval v))  :
    Disjoint (φ.models s) (ψ.models s) := by
  rw [disjoint_iff_ne]
  rintro v hv1 _ hv2 rfl
  apply h v
  rw [mem_models] at hv1 hv2
  rw [hv1.2, hv2.2]; simp

theorem models_var {x : ν} {s : Finset ν} (hxs : x ∈ s) :
    (var x).models s = (assignments (s.erase x)).image (PropAssignment.set . x true) := by
    ext v; simp only [mem_models, eval, mem_image]
    constructor
    . intro ⟨hvdef, hvx⟩
      use v.set x false
      constructor
      . rw [mem_assignments]
        intro x' hx'
        rw [mem_erase, not_and] at hx'
        by_cases h : x' = x
        . rw [h, PropAssignment.set_get]
        . rw [PropAssignment.set_get_of_ne _ _ (Ne.symm h), hvdef (hx' h)]
      . rw [PropAssignment.set_set, ←hvx, PropAssignment.set_same]
    . rintro ⟨v', hv', rfl⟩
      rw [mem_assignments] at hv'
      constructor
      . intro x' hx'
        have h1 : x' ≠ x := by rintro rfl; contradiction
        have h2 : x' ∉ erase s x := by rw [mem_erase, not_and_or]; right; exact hx'
        rw [PropAssignment.set_get_of_ne _ _ (Ne.symm h1), hv' h2]
      . simp

theorem models_neg (φ : PropForm ν) (s : Finset ν) :
  φ.neg.models s ∪ φ.models s = assignments s := by
    ext v; simp only [mem_assignments, mem_union, mem_models, eval, Bool.bnot_eq_to_not_eq,
      Bool.not_eq_true]
    rw [←and_or_left]; cases (eval v φ) <;> simp

theorem models_neg_Disjoint (φ : PropForm ν) (s : Finset ν) :
    Disjoint (φ.neg.models s) (φ.models s) := by
  rw [disjoint_iff_ne]
  rintro v hv1 _ hv2 rfl
  rw [mem_models] at hv2
  rw [mem_models, eval, hv2.2] at hv1
  simp at hv1

theorem models_conj {φ ψ: PropForm ν} (hdisj : φ.vars ∩ ψ.vars = ∅) :
  (φ.conj ψ).models ((φ.conj ψ).vars) =
    ((φ.models φ.vars).product (ψ.models ψ.vars)).image (PropAssignment.cond φ.vars) := by
  symm; ext v
  simp only [mem_image, mem_product, mem_models, Prod.exists, eval, Bool.and_eq_true,
    PropAssignment.cond, vars]
  constructor
  . rintro ⟨v1, v2, ⟨⟨_, heval1⟩, ⟨hdef2, heval2⟩⟩, rfl⟩
    constructor
    . intro x hx
      rw [mem_union, not_or] at hx
      dsimp; rw [if_neg hx.1, hdef2 hx.2]
    . constructor
      . rw [←heval1]; apply eval_ext
        intro x hx; rw [if_pos hx]
      . rw [←heval2]; apply eval_ext
        intro x hx
        simp only [eq_empty_iff_forall_not_mem, mem_inter, not_and'] at hdisj
        have hx' : x ∉ φ.vars := hdisj _ hx
        rw [if_neg hx']
  . intro ⟨hdef, heval1, heval2⟩
    use fun x => if x ∈ φ.vars then v x else false
    use fun x => if x ∈ ψ.vars then v x else false
    dsimp
    constructor
    . constructor
      . constructor
        . intro x hx; dsimp; rw [if_neg hx]
        . rw [←heval1]
          apply eval_ext; intro x hx; rw [if_pos hx]
      . constructor
        . intro x hx; dsimp; rw [if_neg hx]
        . rw [←heval2]
          apply eval_ext; intro x hx; rw [if_pos hx]
    . ext x
      have := @hdef x
      split <;> simp_all

theorem InjOn_cond (φ ψ : PropForm ν) {s t : Finset ν} (hdisj : s ∩ t = ∅) :
  Set.InjOn (PropAssignment.cond s) <| (φ.models s).product (ψ.models t) := by
    intro ⟨p11, p12⟩ hp1 ⟨p21, p22⟩ hp2
    simp only [coe_product, Set.mem_prod, mem_coe, mem_models] at hp1 hp2
    simp only [PropAssignment.cond]
    dsimp; intro h
    rw [Prod.mk.injEq]
    constructor
    . ext x
      have := congr_fun h x
      by_cases h' : x ∈ s <;> simp_all
      rw [hp1.1.1 h', hp2.1.1 h']
    . ext x
      have := congr_fun h x
      by_cases h' : x ∈ s <;> simp_all
      simp only [eq_empty_iff_forall_not_mem, mem_inter, not_and] at hdisj
      rw [hp1.2.1 (hdisj _ h'), hp2.2.1 (hdisj _ h')]

theorem models_insert {φ : PropForm ν} {a : ν} {s : Finset ν} (h : φ.vars ⊆ s) (ha : a ∉ s) :
    φ.models (insert a s) = φ.models s ∪ (φ.models s).image (fun τ => τ.set a true) := by
  ext τ
  simp only [mem_models, mem_union, mem_image]
  constructor
  . intro ⟨hdef, heq⟩
    by_cases h' : τ a = true
    . right
      use (τ.set a false)
      constructor
      . constructor
        . intro x xns
          by_cases hx : x = a
          . rw [hx, PropAssignment.set_get]
          . rw [PropAssignment.set_get_of_ne _ _ (Ne.symm hx)]
            apply hdef; simp [xns, hx]
        . rw [eval_set_of_not_mem_vars, heq]
          intro h''; exact ha (h h'')
      . rw [PropAssignment.set_set, ←h', PropAssignment.set_same]
    . left; rw [Bool.not_eq_true] at h'
      constructor
      . intro x xns
        by_cases hx : x = a
        . rw [hx, h']
        . apply hdef; simp [xns, hx]
      . exact heq
  . rintro (⟨hdef, heq⟩ | ⟨τ', ⟨hdef, heval⟩, rfl⟩)
    . exact ⟨PropAssignment.defined_on_mono (Finset.subset_insert _ _) hdef, heq⟩
    . constructor
      . intro x xnas
        rw [mem_insert, not_or] at xnas
        rw [PropAssignment.set_get_of_ne _ _ (Ne.symm xnas.1)]
        exact hdef xnas.2
      . rw [←heval]
        apply eval_ext
        intro x hx
        rw [PropAssignment.set_get_of_ne]
        contrapose! ha; rw [ha]
        exact h hx

theorem models_insert_Disjoint {φ : PropForm ν} {a : ν} {s : Finset ν} (ha : a ∉ s) :
    Disjoint (φ.models s) ((φ.models s).image (fun τ => τ.set a true)) := by
  rw [disjoint_iff_ne]
  rintro τ hτ1 _ hτ2 rfl
  simp only [mem_image, mem_models] at hτ1 hτ2
  rcases hτ2 with ⟨τ', ⟨⟨_, _⟩, rfl⟩⟩
  have := hτ1.1
  specialize this ha
  rw [PropAssignment.set_get] at this
  contradiction

/-
Theorems about cardinality.
-/

@[simp] theorem card_models_tr (s : Finset ν) : card ((tr : PropForm ν).models s) = 2^(card s) := by
  simp [models_tr, card_assignments]

@[simp] theorem card_models_fls (s : Finset ν) : card ((fls : PropForm ν).models s) = 0 := by
  simp [models_fls, card_assignments]

@[simp] theorem card_models_var {x : ν} {s : Finset ν} (hxs : x ∈ s) :
    card ((var x).models s) = 2^(card s - 1) := by
  rw [models_var hxs,
    card_image_of_injOn (Finset.InjOn_set_assignments _ (Finset.not_mem_erase _ _) _),
    card_assignments, card_erase_of_mem hxs]

@[simp] theorem card_models_disj_disjoint {φ ψ : PropForm ν} (s : Finset ν)
      (h : ∀ v, ¬ (φ.eval v ∧ ψ.eval v)) :
    card ((φ.disj ψ).models s) = card (φ.models s) + card (ψ.models s) := by
  rw [models_disj, card_disjoint_union (models_Disjoint _ h)]

@[simp] theorem card_models_neg (φ : PropForm ν) (s : Finset ν) :
    card (φ.neg.models s) = 2^(card s) - card (φ.models s) := by
  symm; apply Nat.sub_eq_of_eq_add
  rw [←card_disjoint_union (models_neg_Disjoint _ _), models_neg, card_assignments]

theorem card_models_vars {φ : PropForm ν} {s : Finset ν} (h : φ.vars ⊆ s) :
    card (φ.models s) = card (φ.models φ.vars) * 2^(card s - card φ.vars) := by
  let f (p : PropAssignment ν × Finset ν) : PropAssignment ν :=
    fun x => if x ∈ φ.vars then p.1 x else p.2.toPropAssignment x
  have h1 : ((φ.models φ.vars).product (s \ φ.vars).powerset).image f = φ.models s := by
    ext v; simp only [mem_image, mem_product, mem_models, mem_powerset, Prod.exists]
    constructor
    { rintro ⟨v, t, ⟨⟨_, hevalv⟩, hh⟩, rfl⟩
      constructor
      . intro x hxns
        have : x ∉ φ.vars := fun h' => hxns (h h')
        dsimp; rw [if_neg this, toPropAssignment_eq_false]
        intro h'; apply hxns; exact subset_sdiff.mp hh |>.1 h'
      . rw [←hevalv]
        apply eval_ext
        intro x hx
        rw [if_pos hx] }
    intro ⟨hvdef, hevalv⟩
    use v.restrict φ.vars, (s \ φ.vars).filter (fun x => v x)
    constructor
    . constructor
      . constructor
        . simp
        . rw [eval_restrict_vars, hevalv]
      . apply filter_subset
    . ext x; dsimp; split
      . next h => rw [v.restrict_pos h]
      . next hmem =>
          unfold Finset.toPropAssignment
          by_cases hxs : x ∈ s <;> split <;> simp_all [@hvdef x]
  have h2 : Set.InjOn f <| (φ.models φ.vars).product (s \ φ.vars).powerset := by
    intro ⟨v1, t1⟩ h21 ⟨v2, t2⟩ h22 h23
    simp only [Set.mem_prod, mem_product, mem_coe, mem_models, Set.mem_preimage, mem_powerset,
      and_imp, subset_sdiff, Prod.forall, Prod.mk.injEq] at h21 h22 h23 |-
    constructor
    . ext x
      by_cases hx : x ∈ φ.vars
      . have := congr_fun h23 x
        simp [hx] at this; exact this
      . rw [h21.1.1 hx, h22.1.1 hx]
    . ext x
      simp at h21
      by_cases hx : x ∈ φ.vars
      . rw [eq_false (disjoint_right.mp h21.2.2 hx), eq_false (disjoint_right.mp h22.2.2 hx)]
      . have := congr_fun h23 x
        simp [hx] at this
        rw [←toPropAssignment_eq_true, this, toPropAssignment_eq_true]
  rw [←h1, card_image_of_injOn h2, card_product, card_powerset, card_sdiff h]

theorem card_models_conj_aux {φ ψ: PropForm ν} (hdisj : φ.vars ∩ ψ.vars = ∅) :
    card ((φ.conj ψ).models (φ.conj ψ).vars) =
      card (φ.models φ.vars) * card (ψ.models ψ.vars) := by
  rw [models_conj hdisj, card_image_of_injOn (InjOn_cond _ _ hdisj), card_product]

@[simp] theorem card_models_conj {φ ψ : PropForm ν} {s : Finset ν}
      (hsub : φ.vars ∪ ψ.vars ⊆ s) (hdisj : vars φ ∩ vars ψ = ∅) :
    card ((φ.conj ψ).models s) = card (φ.models s) * card (ψ.models s) / 2^(card s):= by
  symm; apply Nat.div_eq_of_eq_mul_left
  . apply pow_pos; apply zero_lt_two
  have hφ := union_subset_left hsub
  have hψ := union_subset_right hsub
  have card_un := card_disjoint_union (disjoint_iff_inter_eq_empty.mpr hdisj)
  have aux : card (vars ψ) ≤ card s - card (vars φ) := by
    apply Nat.le_sub_of_add_le
    rw [add_comm, ←card_un]
    exact card_le_of_subset hsub
  have : (φ.conj ψ).vars ⊆ s := by rw [vars, union_subset_iff]; exact ⟨hφ, hψ⟩
  rw [card_models_vars hφ, card_models_vars hψ, card_models_vars this, card_models_conj_aux hdisj]
  rw [mul_right_comm]; simp only [mul_assoc, ←pow_add]
  rw [←Nat.sub_add_comm (card_le_of_subset hψ)]
  rw [Nat.add_sub_assoc aux, add_comm (card s)]
  rw [vars, card_un, tsub_tsub]

/-
The main theorem.
-/

theorem countModels_eq_card_models {φ : PropForm ν} {s : Finset ν}
      (hvars : φ.vars ⊆ s) (hdec : φ.partitioned) :
    φ.countModels s.card = card (φ.models s) := by
  induction φ
  case var x      =>
    rw [vars, singleton_subset_iff] at hvars
    rw [countModels, card_models_var hvars]
  case tr         => simp [countModels]
  case fls        => simp [countModels]
  case neg φ ih   =>
    rw [vars] at hvars
    rw [partitioned] at hdec
    rw [countModels, card_models_neg φ, ih hvars hdec]
  case conj φ ψ ihφ ihψ =>
    rw [vars] at hvars
    have hφ := union_subset_left hvars
    have hψ := union_subset_right hvars
    rw [partitioned] at hdec
    rw [countModels, card_models_conj hvars hdec.2.2, ihφ hφ hdec.1, ihψ hψ hdec.2.1]
  case disj φ ψ ihφ ihψ =>
    rw [vars, union_subset_iff] at hvars
    rw [partitioned] at hdec
    rw [countModels, card_models_disj_disjoint s hdec.2.2, ihφ hvars.1 hdec.1, ihψ hvars.2 hdec.2.1]
  case impl  _    => rw [partitioned] at hdec; contradiction
  case biImpl _ _ => rw [partitioned] at hdec; contradiction

end PropForm

/-
Weighted models
-/

namespace PropForm

variable {R : Type} [CommRing R]

open BigOperators

noncomputable def weightSum (weight : ν → R) (φ : PropForm ν) (s : Finset ν) : R :=
  ∑ τ in φ.models s, ∏ x in s, if τ x then weight x else 1 - weight x

theorem injective_models_set {φ : PropForm ν} {a : ν} {s : Finset ν} {b : Bool} (h' : a ∉ s) :
  ∀ x ∈ models φ s, ∀ y ∈ models φ s,
      PropAssignment.set x a b = PropAssignment.set y a b → x = y := by
  simp only [mem_models]
  intro τ1 ⟨τ1def, _⟩ τ2 ⟨τ2def, _⟩ heq
  ext x
  have := congr_fun heq x
  by_cases h : a = x
  . rw [←h, τ1def h', τ2def h']
  . simp [PropAssignment.set_get_of_ne _ _ h] at this
    exact this

theorem weightSum_insert (weight : ν → R) {φ : PropForm ν} {a : ν} {s : Finset ν}
      (h : φ.vars ⊆ s) (h' : a ∉ s) :
    weightSum weight φ (insert a s) = weightSum weight φ s := by
  rw [weightSum, models_insert h h', Finset.sum_union (models_insert_Disjoint h')]
  rw [Finset.sum_image (injective_models_set h'), ←Finset.sum_add_distrib]
  apply Finset.sum_congr rfl
  intro τ hτ; rw [mem_models] at hτ
  rw [Finset.prod_insert h', Finset.prod_insert h']; dsimp
  have : τ a ≠ true := by rw [hτ.1 h']; simp
  rw [if_neg this, PropAssignment.set_get, if_pos rfl]
  have : ∀ x, x = (1 - weight a) * x + weight a * x :=
    by intro x; rw [←add_mul, sub_add_cancel, one_mul]
  symm; trans; apply this
  apply congr_arg; apply congr_arg; apply Finset.prod_congr rfl
  intro x xs; rw [PropAssignment.set_get_of_ne]; rintro rfl; exact h' xs

theorem weightSum_of_vars_subset (weight : ν → R) {φ : PropForm ν} {s : Finset ν}
    (h : φ.vars ⊆ s) : weightSum weight φ s = weightSum weight φ φ.vars := by
  suffices : ∀ t, φ.vars ∩ t = ∅ → weightSum weight φ φ.vars = weightSum weight φ (φ.vars ∪ t)
  . specialize this (s \ φ.vars) (Finset.inter_sdiff_self _ _)
    rw [this, Finset.union_sdiff_of_subset h]
  intro t
  induction t using Finset.induction
  . next => simp
  . next a t anint ih =>
    intro hdisj
    rw [weightSum, Finset.union_insert, weightSum_insert, ←ih]; rfl
    . rw [←subset_empty, ←hdisj]; apply inter_subset_inter_left
      apply subset_insert
    . apply subset_union_left
    rw [mem_union, not_or]
    refine ⟨?_, anint⟩
    intro ha
    apply not_mem_empty a
    rw [←hdisj, mem_inter]
    exact ⟨ha, mem_insert_self _ _⟩

theorem ringEval_eq_weightSum (weight : ν → R) {φ : PropForm ν} (hdec : φ.partitioned) :
    φ.ringEval weight = φ.weightSum weight φ.vars := by
  have weightSum_tr : weightSum weight tr (vars tr) = 1 := by
    rw [weightSum, models_tr, vars, assignments_empty, sum_singleton, prod_empty]
  induction φ
  case var x      =>
    rw [ringEval, weightSum, vars, models_var (mem_singleton_self x), erase_singleton,
         assignments_empty, image_singleton, sum_singleton, prod_singleton,
         PropAssignment.set_get, if_pos rfl]
  case tr         =>
    rw [ringEval, weightSum_tr]
  case fls        =>
    rw [ringEval, weightSum, models_fls, sum_empty]
  case neg φ ih   =>
    rw [partitioned] at hdec
    rw [ringEval, ih hdec, sub_eq_iff_eq_add, vars, weightSum, weightSum,
        ←sum_union (models_neg_Disjoint _ _), models_neg, ←models_tr, ←weightSum,
        weightSum_of_vars_subset, weightSum_tr]
    simp [vars]
  case conj φ ψ ihφ ihψ =>
    rw [partitioned] at hdec
    have hDisj : Disjoint φ.vars ψ.vars := by
      rw [disjoint_iff_inter_eq_empty]; exact hdec.2.2
    rw [ringEval, weightSum, models_conj hdec.2.2, ihφ hdec.1, ihψ hdec.2.1,
        sum_image (InjOn_cond _ _ hdec.2.2), sum_product, weightSum, mul_comm,
        mul_sum]
    apply sum_congr rfl
    intros τ _
    rw [mul_comm, weightSum, mul_sum]
    apply sum_congr rfl
    intros τ' _
    rw [vars, prod_union hDisj]
    apply congr; apply congr_arg
    . apply prod_congr rfl
      intros x hx; simp [hx, PropAssignment.cond]
    . apply prod_congr rfl
      intros x hx
      have hx' : x ∉ φ.vars := by
        intro h
        apply not_mem_empty x
        rw [←hdec.2.2, mem_inter]
        exact ⟨h, hx⟩
      simp [hx', PropAssignment.cond]
  case disj φ ψ ihφ ihψ =>
    rw [partitioned] at hdec
    have h1 : vars φ ⊆ vars (φ.disj ψ) := subset_union_left _ _
    have h2 : vars ψ ⊆ vars (φ.disj ψ) := subset_union_right _ _
    rw [ringEval, ihφ hdec.1, ihψ hdec.2.1, ←weightSum_of_vars_subset _ h1,
      ←weightSum_of_vars_subset _ h2]
    unfold weightSum
    rw [models_disj, sum_union (models_Disjoint _ hdec.2.2)]
  case impl  _    => rw [partitioned] at hdec; contradiction
  case biImpl _ _ => rw [partitioned] at hdec; contradiction

end PropForm