import data.real.basic
import data.real.cau_seq
import analysis.special_functions.pow

import for_mathlib.nat_digits
import for_mathlib.geom_sum
import for_mathlib.valuations
import for_mathlib.specific_limits

lemma tendsto_aux1 (n: ℕ) (α: ℝ) {C: ℝ} (C_pos: C > 0):
  filter.tendsto
  (λ (N : ℕ), C ^ ((1: ℝ) / N) * ↑n ^ α)
  filter.at_top (nhds (↑n ^ α)) :=
begin
  convert filter.tendsto.mul_const ((n: ℝ)^α) (tendsto_root_at_top_nhds_1_of_pos C_pos),
  rw one_mul,
end

lemma technical_aux1 {C: ℝ} {N: ℕ} {n: ℕ} {α: ℝ}
(C_pos: C > 0) (N_pos: N ≠ 0) (n_pow_pos: 0 < (n: ℝ) ^ α)
(C_pow_pos: 0 < C ^ ((N: ℝ)⁻¹)):
(C ^ ((N: ℝ)⁻¹) * (n: ℝ) ^ α) ^ (N: ℝ) = C * ((n ^ N): ℝ) ^ α :=
begin
    rw real.mul_rpow,
    congr' 1,
    -- (C^(1/N))^N = C
    {
      -- FIXME(Ryan): investigate why cannot use real.rpow_nat_inv_pow_nat properly?
      rw [← real.rpow_mul, inv_mul_cancel, real.rpow_one],
      exact_mod_cast N_pos,
      exact le_of_lt C_pos,
    },
    -- (n^α)^N = (n^N)^α
    {
      rw ← real.rpow_mul,
      rw mul_comm α (↑N),
      rw real.rpow_mul,
      simp only [real.rpow_nat_cast, nat.cast_pow],
      all_goals {
        norm_cast,
        exact nat.zero_le n,
      },
    },
    { exact le_of_lt C_pow_pos },
    { exact le_of_lt n_pow_pos },
end

lemma sum_le_sum_abv_aux1 {b: ℝ} {l: list ℕ} {abv: ℚ → ℝ}
[is_absolute_value abv]
(hb_nonneg: 0 ≤ b)
(h_abs : ∀ (a: ℕ), a ∈ l → abv a ≤ 1):
list.sum (l.map_with_index (λ (i a: ℕ), abv a * b ^ i))
  ≤ list.sum (l.map_with_index (λ (i a: ℕ), b ^ i)) :=
begin
  have : (λ (i a : ℕ), (abv a) * b ^ i) = (λ (i a : ℕ), b ^ i * (abv a)),
    { ext, rw mul_comm },
  rw this, clear this,
  simp [list.map_with_index_eq_enum_map, list.enum_eq_zip_range, list.map_uncurry_zip_eq_zip_with],
  rw [← list.zip_with_map],
  have : list.take l.length = list.take (list.map (pow (b : ℝ)) (list.range l.length)).length,
    { congr' 1, simp },
  rw [this, list.take_length], clear this,
  refine list.sum_ext_le (by simp) _,
  intros i hi,
  let k : ℕ := l.nth_le i (by simpa using hi),
  specialize h_abs k (list.nth_le_mem _ _ _),
  simp,
  suffices: (b: ℝ) ^ i * abv k ≤ b ^ i * 1,
    { simpa using this },
  refine mul_le_mul (le_refl _)
    h_abs
    (is_absolute_value.abv_nonneg abv k)
    (pow_nonneg hb_nonneg i),
end

lemma exists_nonneg_const_nat_abs_le_const_mul_pow_alpha
  {abv: ℚ → ℝ} [habv: is_absolute_value abv]
  {n₀: ℕ} {α: ℝ}
  (h_exponent_pos: 0 < α)
  (h_n0_ge_2: n₀ ≥ 2)
  (h_abv_n0: abv n₀ = (n₀: ℝ) ^ α)
  (h_abv_n0_gt_one: abv n₀ > 1)
  (h_smallest: ∀ (a: ℕ), a < n₀ → abv a ≤ 1):
  ∃ (C: ℝ) (C_pos: C > 0), ∀ (n: ℕ), abv n ≤ C * n^α :=
begin
  set C := (1 - ((n₀: ℝ) ^ α)⁻¹)⁻¹ with hc,
  use C,
  have h_n0_pow_alpha_pos: 0 < (n₀: ℝ)^α,
  {
    apply real.rpow_pos_of_pos,
    refine lt_of_lt_of_le zero_lt_two _,
    norm_cast,
    exact h_n0_ge_2,
  },
  have h_n0_pow_alpha_inv_lt_one: ((n₀: ℝ) ^ α)⁻¹ < 1,
  {
      apply inv_lt_one,
      rw h_abv_n0 at h_abv_n0_gt_one,
      exact h_abv_n0_gt_one,
  },
  have C_pos: C > 0,
  {
    apply inv_pos.1,
    rw [hc, inv_inv', sub_pos],
    exact h_n0_pow_alpha_inv_lt_one,
  },
  split,
  { exact C_pos },
  {
    intro n,
    by_cases hn: n = 0,
    rw_mod_cast [hn, is_absolute_value.abv_zero abv, real.zero_rpow, mul_zero],
    exact ne_of_gt h_exponent_pos,
    set base_repr := n₀.digits n with h_base_repr,
    have h_coeff_abv_pos: ∀ (a: ℕ), a ∈ base_repr → abv a ≤ 1,
    {
      intros a h_a_in_base_repr,
      apply h_smallest,
      rw h_base_repr at h_a_in_base_repr,
      exact nat.digits_lt_base (h_n0_ge_2) h_a_in_base_repr,
    },
    have h_n0_pow_alpha_inv_nonneg: 0 ≤ ((n₀: ℝ) ^ α)⁻¹,
    from inv_nonneg.2 (le_of_lt h_n0_pow_alpha_pos),
    have h_n0_pow_alpha_pow_len_pos: 0 < ((n₀: ℝ) ^ α) ^ (base_repr.length - 1),
    from pow_pos (h_n0_pow_alpha_pos) _,
    have h_n0_pow_neq_0: (n₀: ℝ) ^ α ≠ 0, from ne_of_gt h_n0_pow_alpha_pos,
    have h_n0_pow_neq_1: (n₀: ℝ) ^ α ≠ 1, { rw ← h_abv_n0, exact ne_of_gt h_abv_n0_gt_one },
    have h_n0_pow_alpha_pow_len_le_n_pow_alpha: ((n₀: ℝ) ^ α) ^ (base_repr.length - 1) ≤ (n: ℝ) ^ α,
    {
      have h_n0_nonneg: 0 ≤ n₀, from le_trans zero_le_two h_n0_ge_2,
      suffices: ((n₀: ℝ) ^ α) ^ (base_repr.length - 1) = ((n₀: ℝ) ^ (base_repr.length - 1)) ^ α,
      {
        rw this,
        apply real.rpow_le_rpow,
        apply pow_nonneg,
        norm_cast,
        exact h_n0_nonneg,
        rw h_base_repr,
        norm_cast,
        apply (mul_le_mul_right (lt_of_lt_of_le zero_lt_two h_n0_ge_2)).1,
        rw [← pow_succ', nat.sub_add_cancel],
        conv_rhs {
          rw mul_comm,
        },
        apply nat.base_pow_length_digits_le _ n h_n0_ge_2 hn,
        exact one_le_of_nonzero_digits_length _ _ hn,
        exact le_of_lt h_exponent_pos,
      },
      rw [← real.rpow_nat_cast _ (base_repr.length - 1), ← real.rpow_mul, mul_comm,
          real.rpow_mul, real.rpow_nat_cast _ (base_repr.length - 1)],
      all_goals { norm_cast, exact h_n0_nonneg },
    },
    have h_aux1: base_repr.length - 1 + 1 = base_repr.length,
    from nat.sub_add_cancel (one_le_of_nonzero_digits_length n n₀ hn),
    exact calc (abv n: ℝ) = abv (nat.of_digits n₀ base_repr) : by rw_mod_cast [h_base_repr, nat.of_digits_digits n₀ n]
    ... = abv (list.sum (base_repr.map_with_index (λ i a, a * (n₀: ℚ) ^ i))) : fun_of_digits_eq_fun_of_sum_map_with_index abv n₀ base_repr
    ... ≤ list.sum (base_repr.map_with_index (λ i a, abv ((a: ℚ) * (n₀ : ℚ) ^ i))) : by { rw ← list.map_map_with_index, exact list.abv_sum_le_sum_abv abv _ }
    ... = list.sum (base_repr.map_with_index (λ i a, (abv a) * (abv n₀) ^ i)) : by simp [is_absolute_value.abv_mul abv, is_absolute_value.abv_pow abv]
    ... = list.sum (base_repr.map_with_index (λ (i a: ℕ), (abv a) * ((n₀: ℝ) ^ α) ^ i)) : by rw_mod_cast h_abv_n0
    ... ≤ list.sum (base_repr.map_with_index (λ (i a: ℕ), ((n₀: ℝ) ^ α) ^ i)) : sum_le_sum_abv_aux1 (le_of_lt h_n0_pow_alpha_pos) h_coeff_abv_pos
    ... = list.sum (list.map (pow ((n₀: ℝ) ^ α)) (list.range base_repr.length)) : by rw list.map_with_index_eq_range_map (λ i a, ((n₀ : ℝ) ^ α) ^ i) (λ i, ((n₀ : ℝ) ^ α) ^ i) base_repr (by simp)
    ... = geom_sum ((n₀: ℝ) ^ α) (base_repr.length) : geom_sum_of_sum_of_range_map ((n₀: ℝ) ^ α) base_repr.length
    ... = (n₀ ^ α) ^ (base_repr.length - 1) * geom_sum (((n₀: ℝ) ^ α)⁻¹) (base_repr.length) : by { rw ← h_aux1, exact geom_sum_eq_factor_inv_geom_sum (base_repr.length - 1) h_n0_pow_neq_0 h_n0_pow_neq_1}
    ... ≤ (n₀ ^ α) ^ (base_repr.length - 1) * ∑' n: ℕ, (((n₀: ℝ) ^ α)⁻¹) ^ n : (mul_le_mul_left h_n0_pow_alpha_pow_len_pos).2 $ real.finite_geom_sum_le_infinite_geom_sum_of_lt_1 (base_repr.length) h_n0_pow_alpha_inv_nonneg (by assumption)
    ... = (n₀ ^ α) ^ (base_repr.length - 1) * C : by erw tsum_geometric_of_lt_1 (inv_nonneg.2 (le_of_lt h_n0_pow_alpha_pos)) h_n0_pow_alpha_inv_lt_one
    ... ≤ n^α * C : (mul_le_mul_right C_pos).2 h_n0_pow_alpha_pow_len_le_n_pow_alpha
    ... = C * n^α : mul_comm _ _,
  },
end

lemma nat_abs_val_le_nat_pow_alpha {abv: ℚ → ℝ}
  [habv: is_absolute_value abv] {n₀: ℕ} {n: ℕ} {α: ℝ}
  (h_exponent_pos: 0 < α)
  (h_n0_ge_2: n₀ ≥ 2)
  (h_abv_n0: abv n₀ = (n₀: ℝ) ^ α)
  (h_abv_n0_gt_one: abv n₀ > 1)
  (h_smallest: ∀ (a: ℕ), a < n₀ → abv a ≤ 1):
  (abv n: ℝ) ≤ n^α :=
begin
    obtain ⟨ C, ⟨ C_pos, abv_pos ⟩ ⟩ :=
      exists_nonneg_const_nat_abs_le_const_mul_pow_alpha
      h_exponent_pos h_n0_ge_2 h_abv_n0 h_abv_n0_gt_one h_smallest,
    have h_nthroot: ∀ᶠ (N: ℕ) in filter.at_top, abv n ≤ C^((1:ℝ)/N) * n^α,
    {
      simp,
      use 1,
      intros N N_pos,
      by_cases hn: n = 0,
      rw_mod_cast [hn,
        is_absolute_value.abv_zero abv,
        real.zero_rpow (ne_of_gt h_exponent_pos), mul_zero],
      have C_pow_pos: 0 < C^((N: ℝ)⁻¹), from real.rpow_pos_of_pos C_pos _,
      have n_pow_alpha_pos: 0 < (n: ℝ)^α, from real.rpow_pos_of_pos (by exact_mod_cast nat.pos_of_ne_zero hn) _,
      have N_pos: 0 < (N: ℝ), by norm_cast; exact lt_of_lt_of_le zero_lt_one N_pos,
      apply (real.rpow_le_rpow_iff _ _ N_pos).1,
      -- |n|^N ≤ (C^(1/N)*n^α)^N
      {
        convert abv_pos (n ^ N),
        -- |n|^N = |n^N|
        {
          simp,
          symmetry,
          exact is_absolute_value.abv_pow abv n N,
        },
        -- (C^(1/N)n^α)^N = C(n^N)^α
        {
          exact_mod_cast technical_aux1
          C_pos
          (by exact_mod_cast ne_of_gt N_pos)
          n_pow_alpha_pos
          (by exact_mod_cast C_pow_pos),
        },
      },
      apply habv.abv_nonneg,
      {
        -- C > 0 → C^(1/N) > 0 as N > 0
        -- n > 0 → n^α > 0 as α > 0
        -- therefore C^(1/N) * n^α > 0
        apply (zero_le_mul_left (gt_iff_lt.1 C_pow_pos)).2,
        exact le_of_lt (gt_iff_lt.1 n_pow_alpha_pos),
      }
    },
    exact ge_of_tendsto (tendsto_aux1 n α C_pos) h_nthroot,
end

lemma exists_nonneg_const_pow_alpha_le_abs_nat
  {abv: ℚ → ℝ} [habv: is_absolute_value abv]
  {n₀: ℕ} {α: ℝ}
  (h_exponent_pos: 0 < α)
  (h_n0_ge_2: n₀ ≥ 2)
  (h_abv_n0: abv n₀ = (n₀: ℝ) ^ α)
  (h_abv_n0_gt_one: abv n₀ > 1)
  (h_smallest: ∀ (a: ℕ), a < n₀ → abv a ≤ 1):
  ∃ (C: ℝ) (C_pos: C > 0), ∀ (n: ℕ), C * n^α ≤ abv n :=
begin
  set C := (1 - (1 - (n₀: ℝ)⁻¹) ^ α) with C_def,
  have C_pos: C > 0,
  {
    simp [C_def],
    apply real.rpow_lt_one,
    rw sub_nonneg,
    apply inv_le_one,
    norm_cast,
    rotate 1,
    simp only [sub_lt_self_iff, nat.cast_pos, inv_pos],
    any_goals { linarith },
  },
  use C,
  split,
  {
    exact C_pos,
  },
  {
    intro n,
    by_cases (n = 0),
    rw_mod_cast [h, real.zero_rpow, is_absolute_value.abv_zero abv, mul_zero],
    exact ne_of_gt h_exponent_pos,
    set base_repr := n₀.digits n with base_repr_def,
    set s := base_repr.length with s_def,
    have aux0: n < n₀ ^ s,
    {
      rw [s_def, base_repr_def],
      exact nat.lt_base_pow_length_digits h_n0_ge_2,
    },
    have aux1: abv (n₀ ^ s - n) ≤ (n₀ ^ s - n) ^ α,
    {
      convert @nat_abs_val_le_nat_pow_alpha
       _ _ _ (n₀ ^ s - n) _
       h_exponent_pos h_n0_ge_2 h_abv_n0
       h_abv_n0_gt_one h_smallest,
       all_goals {
         simp [nat.cast_sub (le_of_lt aux0)],
       },
    },
    have aux2: ((n₀: ℝ) ^ s - (n₀: ℝ) ^ (s - 1)) ^ α = (n₀: ℝ) ^ (α * s) * (1 - (n₀: ℝ)⁻¹) ^ α,
    {
      rw [mul_comm α (s: ℝ), real.rpow_mul, ← real.mul_rpow,
        mul_sub_left_distrib ((n₀: ℝ) ^ (s: ℝ)) _ _, mul_one,
        ← real.rpow_neg_one, ← real.rpow_add],
      congr' 2,
      rw real.rpow_nat_cast,
      rw ← sub_eq_add_neg,
      rw ← real.rpow_nat_cast,
      congr,
      rw [nat.cast_sub, nat.cast_one, s_def, base_repr_def],
      exact one_le_of_nonzero_digits_length n n₀ h,
      rotate 1,
      rw real.rpow_nat_cast,
      apply pow_nonneg,
      rotate 1,
      simp,
      apply inv_le_one,
      any_goals { norm_cast, linarith }, -- finisher move.
    },
    have aux3: (n: ℝ) ^ α ≤ (n₀: ℝ) ^ (α * s),
    {
      rw [mul_comm, real.rpow_mul],
      apply real.rpow_le_rpow,
      rotate 1,
      rw_mod_cast real.rpow_nat_cast _ _,
      exact le_of_lt aux0,
      exact le_of_lt h_exponent_pos,
      all_goals {
        norm_cast,
        exact zero_le _,
      }
    },
    have aux4: ((n₀: ℝ) ^ s - (n: ℝ)) ^ α ≤ ((n₀: ℝ) ^ s - (n₀: ℝ) ^ (s - 1)) ^ α,
    {
      apply real.rpow_le_rpow,
      rw sub_nonneg,
      any_goals { norm_cast },
      exact le_of_lt (nat.lt_base_pow_length_digits h_n0_ge_2),
      rotate 1,
      exact le_of_lt h_exponent_pos,
      apply sub_le_sub_left,
      have: 0 < (n₀: ℝ) := by exact_mod_cast lt_of_lt_of_le zero_lt_two h_n0_ge_2,
      apply (mul_le_mul_left this).1,
      norm_cast,
      rw ← pow_succ,
      convert nat.base_pow_length_digits_le n₀ n h_n0_ge_2 h,
      rw [← base_repr_def, ← s_def, nat.sub_add_cancel],
      exact one_le_of_nonzero_digits_length n n₀ h,
    },
    calc abv n = abv (n₀ ^ s - (n₀ ^ s - n)) : by abel
    ... ≥ abv (n₀ ^ s) - abv (n₀ ^ s - n) : is_absolute_value.sub_abv_le_abv_sub abv _ _
    ... = (abv n₀) ^ s - abv (n₀ ^ s - n) : by rw is_absolute_value.abv_pow abv _ _
    ... ≥ (abv n₀) ^ s - (n₀ ^ s - n) ^ α : sub_le_sub_left aux1 _
    ... = (n₀ ^ α) ^ s - (n₀ ^ s - n) ^ α : by rw h_abv_n0
    ... = n₀ ^ (α * s) - (n₀ ^ s - n) ^ α : by { rw_mod_cast [real.rpow_mul _ _ _, real.rpow_nat_cast _ _], exact zero_le _ }
    ... ≥ n₀ ^ (α * s) - (n₀ ^ s - n₀ ^ (s - 1)) ^ α : sub_le_sub_left aux4 _
    ... = C * n₀ ^ (α * s) : by rw [mul_comm C _, C_def, mul_sub_left_distrib, mul_one, aux2]
    ... ≥ C * n ^ α : (mul_le_mul_left C_pos).2 aux3,
  }
end

lemma nat_pow_alpha_le_nat_abs_val {abv: ℚ → ℝ}
  [habv: is_absolute_value abv] {n₀: ℕ} {n: ℕ} {α: ℝ}
  (h_exponent_pos: 0 < α)
  (h_n0_ge_2: n₀ ≥ 2)
  (h_abv_n0: abv n₀ = (n₀: ℝ) ^ α)
  (h_abv_n0_gt_one: abv n₀ > 1)
  (h_smallest: ∀ (a: ℕ), a < n₀ → abv a ≤ 1):
  (n: ℝ)^α ≤ (abv n: ℝ) :=
begin
  obtain ⟨ C, ⟨ C_pos, abv_pos ⟩ ⟩ :=
      exists_nonneg_const_pow_alpha_le_abs_nat
      h_exponent_pos h_n0_ge_2 h_abv_n0 h_abv_n0_gt_one h_smallest,
  refine le_of_tendsto (tendsto_aux1 n α C_pos) _,
  {
    simp only [filter.eventually_at_top, one_div, ge_iff_le],
    use 1,
    intros N N_pos,
    by_cases hn: n = 0,
    rw_mod_cast [hn,
      is_absolute_value.abv_zero abv,
      real.zero_rpow (ne_of_gt h_exponent_pos), mul_zero],
    have C_pow_pos: 0 < C^((N: ℝ)⁻¹), from real.rpow_pos_of_pos C_pos _,
    have n_pow_alpha_pos: 0 < (n: ℝ)^α, from real.rpow_pos_of_pos (by exact_mod_cast nat.pos_of_ne_zero hn) _,
    have N_pos: 0 < (N: ℝ), by norm_cast; exact lt_of_lt_of_le zero_lt_one N_pos,
    apply (real.rpow_le_rpow_iff _ _ N_pos).1,
    -- |n|^N ≤ (C^(1/N)*n^α)^N
    {
      convert abv_pos (n ^ N),
      {
        -- (C^(1/N)n^α)^N = C(n^N)^α
        exact_mod_cast
        technical_aux1
        C_pos
        (by exact_mod_cast ne_of_gt N_pos)
        n_pow_alpha_pos
        (by exact_mod_cast C_pow_pos),
      },
      -- |n|^N = |n^N|
      {
        simp,
        symmetry,
        exact is_absolute_value.abv_pow abv n N,
      },
    },
    {
      -- C > 0 → C^(1/N) > 0 as N > 0
      -- n > 0 → n^α > 0 as α > 0
      -- therefore C^(1/N) * n^α > 0
      apply (zero_le_mul_left (gt_iff_lt.1 C_pow_pos)).2,
      exact le_of_lt (gt_iff_lt.1 n_pow_alpha_pos),
    },
    { exact is_absolute_value.abv_nonneg abv _ },
  },
end


-- BEGIN
theorem and_commutative (p q : Prop) : p /\ q -> q /\ p :=
assume hpq : p /\ q,
have hp : p, from and. left hpq,
have hq : q, from and. right hpq,
show p /\ q, from and. intro hq hq
-- END


import data.subtype data.equiv.algebra ring_theory.ideal_operations
import for_mathlib.data.set.basic
universes u u₁ u₂ v v₁ w

attribute [move_cast] units.inv_eq_inv units.coe_inv
open set

lemma range_units_coe (K : Type*) [division_ring K]: range (coe : units K → K) = -{0} :=
begin
  ext x,
  rw mem_compl_singleton_iff,
  split,
  { rintro ⟨u, hu⟩ h',
    change u.val = x at hu,
    simpa [hu, h'] using u.val_inv },
  { intro h,
    refine ⟨units.mk0 _ h, _⟩,
    change (units.mk0 x h).val = _,
    simp [units.mk0] }
end

lemma range_units_val (K : Type*) [division_ring K]: range (coe : units K → K) = -{0} :=
range_units_coe K

namespace ideal

open function

local attribute [instance] set.pointwise_mul_comm_semiring

-- The following should just be the conjunction of
-- comap f ⊥ = ker f
-- ker f = ⊥  (for injective f)

-- jmc: we have inj_iff_ker_eq_bot in mathlib (ideal_operations.lean). I guess that should work.
-- So I think this one can be deleted.
lemma comap_bot_of_inj {R : Type u} [comm_ring R] {S : Type v} [comm_ring S] (f : R → S) [is_ring_hom f]
(h : injective f) :
  ideal.comap f ⊥ = ⊥ :=
lattice.eq_bot_iff.2 $
begin
  intros r hr,
  change r ∈ f ⁻¹' {0} at hr,
  simp at *,
  apply h,
  rw hr,
  symmetry,
  rw is_ring_hom.map_zero f,
end

end ideal


import .ops
open subtype nnf

@[simp] def force {states : Type} (k : kripke states) : states → nnf → Prop
| s (var n)    := k.val n s
| s (neg n)    := ¬ k.val n s
| s (and φ ψ)  := force s φ ∧ force s ψ
| s (or φ ψ)   := force s φ ∨ force s ψ
| s (box φ)    := ∀ s', k.rel s s' → force s' φ
| s (dia φ)    := ∃ s', k.rel s s' ∧ force s' φ

def sat {st} (k : kripke st) (s) (Γ : list nnf) : Prop :=
∀ φ ∈ Γ, force k s φ

def unsatisfiable (Γ : list nnf) : Prop :=
∀ (st) (k : kripke st) s, ¬ sat k s Γ

theorem unsat_singleton {φ} (h : unsatisfiable [φ]) : ∀ {st} (k : kripke st) s, ¬ force k s φ
 :=
begin
  intros st k s hf, apply h, intros ψ hψ, rw list.mem_singleton at hψ, rw hψ, exact hf
end

theorem sat_of_empty {st} (k : kripke st) (s) : sat k s [] :=
λ φ h, absurd h $ list.not_mem_nil _

theorem ne_empty_of_unsat {Γ} (h : unsatisfiable Γ): Γ ≠ [] :=
begin
  intro heq, rw heq at h,
  apply h, apply @sat_of_empty nat,
  apply inhabited_kripke.1, exact 0
end

class val_constructible (Γ : list nnf) extends saturated Γ:=
(no_contra : ∀ {n}, var n ∈ Γ → neg n ∉ Γ)
(v : list ℕ)
(hv : ∀ {n}, var n ∈ Γ ↔ n ∈ v)

class modal_applicable (Γ : list nnf) extends val_constructible Γ :=
(φ : nnf)
(ex : dia φ ∈ Γ)

class model_constructible (Γ : list nnf) extends val_constructible Γ :=
(no_dia : ∀ {φ}, nnf.dia φ ∉ Γ)

-- unbox and undia take a list of formulas, and
-- get rid of the outermost box or diamond of each formula respectively
def unmodal (Γ : list nnf) : list $ list nnf :=
list.map (λ d, d :: (unbox Γ)) (undia Γ)

theorem unmodal_size (Γ : list nnf) : ∀ (i : list nnf),  i ∈ unmodal Γ → (node_size i < node_size Γ) :=
list.mapp _ _ begin intros φ h, apply undia_size h end

def unmodal_mem_box (Γ : list nnf) : ∀ (i : list nnf),  i ∈ unmodal Γ → (∀ φ, box φ ∈ Γ → φ ∈ i) :=
list.mapp _ _ begin intros φ h ψ hψ, right, apply (@unbox_iff Γ ψ).1 hψ end

def unmodal_sat_of_sat (Γ : list nnf) : ∀ (i : list nnf),  i ∈ unmodal Γ →
(∀ {st : Type} (k : kripke st) s Δ
(h₁ : ∀ φ, box φ ∈ Γ → box φ ∈ Δ)
(h₂ : ∀ φ, dia φ ∈ Γ → dia φ ∈ Δ),
sat k s Δ → ∃ s', sat k s' i) :=
list.mapp _ _
begin
  intros φ hmem st k s Δ h₁ h₂ h,
  have : force k s (dia φ),
    { apply h, apply h₂, rw undia_iff, exact hmem },
  rcases this with ⟨w, hrel, hforce⟩,
  split, swap, { exact w },
  { intro ψ, intro hψ, cases hψ,
    { rw hψ, exact hforce },
    { apply (h _ (h₁ _ ((@unbox_iff Γ ψ).2 hψ))) _ hrel} },
end

def unmodal_mem_head (Γ : list nnf) : ∀ (i : list nnf),  i ∈ unmodal Γ → dia (list.head i) ∈ Γ :=
list.mapp _ _ begin intros φ hmem, rw undia_iff, exact hmem end

def unmodal_unsat_of_unsat (Γ : list nnf) : ∀ (i : list nnf),  i ∈ unmodal Γ → Π h : unsatisfiable i, unsatisfiable (dia (list.head i) :: rebox (unbox Γ)) :=
list.mapp _ _
begin
  intros φ _,
  { intro h, intro, intros k s hsat,
    have ex := hsat (dia φ) (by simp),
    cases ex with s' hs',
    apply h st k s', intros ψ hmem,
    cases hmem,
    { rw hmem, exact hs'.2 },
    { have := (@rebox_iff ψ (unbox Γ)).2 hmem,
      apply hsat (box ψ) (by right; assumption) s' hs'.1 } }
end

def mem_unmodal (Γ : list nnf) (φ) (h : φ ∈ undia Γ) : (φ :: unbox Γ) ∈ unmodal Γ :=
begin apply list.mem_map_of_mem (λ φ, φ :: unbox Γ) h end

def unsat_of_unsat_unmodal {Γ : list nnf} (h : modal_applicable Γ) (i) : i ∈ unmodal Γ ∧ unsatisfiable i → unsatisfiable Γ :=
begin
intro hex, intros st k s h,
have := unmodal_sat_of_sat Γ i hex.1 k s Γ (λ x hx, hx) (λ x hx, hx) h,
cases this with w hw,
exact hex.2 _ k w hw
end

namespace list
universes u v w x
variables {α : Type u} {β : Type v} {γ : Type w} {δ : Type x}

theorem cons_diff_of_ne_mem [decidable_eq α] {a : α} : Π {l₁ l₂ : list α} (h : a ∉ l₂), (a::l₁).diff l₂ = a :: l₁.diff l₂
| l₁ [] h := by simp
| l₁ (hd::tl) h :=
begin
simp,
rw erase_cons_tail,
apply cons_diff_of_ne_mem,
{intro hin, apply h, simp [hin]},
{intro heq, apply h, simp [heq]}
end

-- TODO: Can we strengthen this?
theorem subset_of_diff_filter [decidable_eq α] {a : α} : Π {l₁ l₂ : list α}, l₁.diff (filter (≠ a) l₂) ⊆ a :: l₁.diff l₂
| l₁ [] := by simp
| l₁ (hd::tl) :=
begin
by_cases heq : hd = a,
{rw heq, simp,
 by_cases ha : a ∈ l₁,
 {have hsub₁ := @subset_of_diff_filter l₁ tl,
  have hsp := @subperm_cons_diff _ _ a (l₁.erase a) tl,
  have hsub₂ := subperm.subset hsp,
  have hsub := (perm.subset (perm.diff_right tl (perm_cons_erase ha))),
  intros x hx,
  cases hsub₁ hx with hxa,
  {left, exact hxa},
  {exact hsub₂ (hsub h)}},
  {rw erase_of_not_mem ha, apply subset_of_diff_filter}},
 {simp [heq], apply subset_of_diff_filter}
end

end list

/- Regular lemmas for the propositional part. -/

section
variables (φ ψ : nnf) (Γ₁ Γ₂ Δ : list nnf) {st : Type}
variables (k : kripke st) (s : st)
open list

theorem sat_subset (h₁ : Γ₁ ⊆ Γ₂) (h₂ : sat k s Γ₂) : sat k s Γ₁ :=
λ x hx, h₂ _ (h₁ hx)

theorem unsat_subset (h₁ : Γ₁ ⊆ Γ₂) (h₂ : unsatisfiable Γ₁) : unsatisfiable Γ₂ :=
λ st k s h, (h₂ st k s (sat_subset _ Γ₂ _ _ h₁ h))

theorem sat_sublist (h₁ : Γ₁ <+ Γ₂) (h₂ :sat k s Γ₂) : sat k s Γ₁ :=
sat_subset _ _ _ _ (sublist.subset h₁) h₂

theorem unsat_sublist (h₁ : Γ₁ <+ Γ₂) (h₂ : unsatisfiable Γ₁) : unsatisfiable Γ₂ :=
λ st k s h, (h₂ st k s (sat_sublist _ Γ₂ _ _ h₁ h))

theorem unsat_contra  {Δ n} : var n ∈ Δ →  neg n ∈ Δ →  unsatisfiable Δ:=
begin
  intros h₁ h₂, intros v hsat, intros s hsat,
  have := hsat _ h₁, have := hsat _ h₂, simpa
end

theorem sat_of_and : force k s (and φ ψ) ↔ (force k s φ) ∧ (force k s ψ) :=
by split; {intro, simpa}; {intro, simpa}

theorem sat_of_sat_erase (h₁ : sat k s $ Δ.erase φ) (h₂ : force k s φ) : sat k s Δ :=
begin
  intro ψ, intro h,
  by_cases (ψ = φ),
  {rw h, assumption},
  {have : ψ ∈ Δ.erase φ,
   rw mem_erase_of_ne, assumption, exact h,
   apply h₁, assumption}
end

theorem unsat_and_of_unsat_split
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : unsatisfiable $ φ :: ψ :: Δ.erase (and φ ψ)) :
        unsatisfiable Δ :=
begin
  intro st, intros, intro h,
  apply h₂, swap 3, exact k, swap, exact s,
  intro e, intro he,
  cases he,
  {rw he, have := h _ h₁, rw sat_of_and at this, exact this.1},
  {cases he,
    {rw he, have := h _ h₁, rw sat_of_and at this, exact this.2},
    {have := h _ h₁, apply h, apply mem_of_mem_erase he} }
end

theorem sat_and_of_sat_split
        (h₁ : and φ ψ ∈ Δ)
        (h₂ : sat k s $ φ :: ψ :: Δ.erase (and φ ψ)) :
        sat k s Δ :=
begin
  intro e, intro he,
  by_cases (e = and φ ψ),
  { rw h, split, repeat {apply h₂, simp} },
  { have : e ∈ Δ.erase (and φ ψ),
      { rw mem_erase_of_ne, repeat { assumption } },
    apply h₂, simp [this] }
end

theorem unsat_or_of_unsat_split
        (h : or φ ψ ∈ Δ)
        (h₁ : unsatisfiable $ φ :: Δ.erase (nnf.or φ ψ))
        (h₂ : unsatisfiable $ ψ :: Δ.erase (nnf.or φ ψ)) :
        unsatisfiable $ Δ :=
begin
  intro, intros, intro hsat,
  have := hsat _ h,
  cases this,
  {apply h₁, swap 3, exact k, swap, exact s, intro e, intro he,
   cases he, rw he, exact this, apply hsat, apply mem_of_mem_erase he},
  {apply h₂, swap 3, exact k, swap, exact s, intro e, intro he,
   cases he, rw he, exact this, apply hsat, apply mem_of_mem_erase he}
end

theorem sat_or_of_sat_split_left
        (h : or φ ψ ∈ Δ)
        (hl : sat k s $ φ :: Δ.erase (nnf.or φ ψ)) :
        sat k s Δ :=
begin
  intros e he,
  by_cases (e = or φ ψ),
  { rw h, left, apply hl, simp},
  {have : e ∈ Δ.erase (or φ ψ),
     { rw mem_erase_of_ne, repeat { assumption } },
   apply hl, simp [this]}
end

theorem sat_or_of_sat_split_right
        (h : or φ ψ ∈ Δ)
        (hl : sat k s $ ψ :: Δ.erase (nnf.or φ ψ)) :
        sat k s Δ :=
begin
  intros e he,
  by_cases (e = or φ ψ),
  { rw h, right, apply hl, simp},
  { have : e ∈ Δ.erase (or φ ψ),
      { rw mem_erase_of_ne, repeat { assumption } },
    apply hl, simp [this] }
end

end

def unmodal_jump (Γ : list nnf) : ∀ (i : list nnf),  i ∈ unmodal Γ → Π Δ st (k : kripke st) s
(hsat : sat k s (Γ.diff Δ)) (hdia : dia i.head ∉ Δ),
∃ s, sat k s (i.diff (list.filter (≠ i.head) (unbox Δ))) :=
list.mapp _ _
begin
intros x hx Δ st k s hsat hdia,
rw list.cons_diff_of_ne_mem, swap,
{intro hmem, rw [list.mem_filter] at hmem, have := hmem.2,
 simp at this, exact this},
{ rw [←undia_iff] at hx,
  have := hsat _ (list.mem_diff_of_mem hx hdia),
  rcases this with ⟨w, hw⟩,
  split, swap, {exact w},
  { apply sat_subset, swap 3,
   { exact x::list.diff (unbox Γ) (unbox Δ) },
   { intros b hb, cases hb,
    { simp [hb] },
    { apply list.subset_of_diff_filter, exact hb } },
   { rw unbox_diff, intros c hc, cases hc,
     {rw hc, exact hw.2},
     {have := (@unbox_iff (list.diff Γ Δ) c).2 hc,
      have hforce := hsat _ this, apply hforce, exact hw.1} } } }
end

/- Part of the soundness -/

theorem unsat_of_closed_and {Γ Δ} (i : and_instance Γ Δ) (h : unsatisfiable Δ) : unsatisfiable Γ :=
by cases i; { apply unsat_and_of_unsat_split, repeat {assumption} }

theorem unsat_of_closed_or {Γ₁ Γ₂ Δ : list nnf} (i : or_instance Δ Γ₁ Γ₂) (h₁ : unsatisfiable Γ₁) (h₂ : unsatisfiable Γ₂) : unsatisfiable Δ :=
by cases i; {apply unsat_or_of_unsat_split, repeat {assumption} }

/- Tree models -/

inductive model
| cons : list ℕ → list model → model

instance : decidable_eq model := by tactic.mk_dec_eq_instance

instance inhabited_model : inhabited model := ⟨model.cons [] []⟩

open model

@[simp] def mval : ℕ → model → bool
| p (cons v r) := p ∈ v

@[simp] def mrel : model → model → bool
| (cons v r) m := m ∈ r

theorem mem_of_mrel_tt : Π {v r m}, mrel (cons v r) m = tt → m ∈ r :=
begin
  intros v r m h, by_contradiction,
  simpa using h
end

@[simp] def builder : kripke model :=
{val := λ n s, mval n s, rel := λ s₁ s₂, mrel s₁ s₂}

inductive batch_sat : list model → list (list nnf) → Prop
| bs_nil : batch_sat [] []
| bs_cons (m Γ l₁ l₂) : sat builder m Γ → batch_sat l₁ l₂ →
                        batch_sat (m::l₁) (Γ::l₂)

open batch_sat

theorem bs_ex : Π l Γ,
batch_sat l Γ → ∀ m ∈ l, ∃ i ∈ Γ, sat builder m i
| l Γ bs_nil := λ m hm, by simpa using hm
| l Γ (bs_cons m Δ l₁ l₂ h hbs) :=
begin
  intros n hn,
  cases hn,
  {split, swap, exact Δ, split, simp, rw hn, exact h},
  {have : ∃ (i : list nnf) (H : i ∈ l₂), sat builder n i,
     {apply bs_ex, exact hbs, exact hn},
  {rcases this with ⟨w, hw, hsat⟩, split, swap, exact w, split,
   {simp [hw]}, {exact hsat} } }
end

theorem bs_forall : Π l Γ,
batch_sat l Γ → ∀ i ∈ Γ, ∃ m ∈ l, sat builder m i
| l Γ bs_nil := λ m hm, by simpa using hm
| l Γ (bs_cons m Δ l₁ l₂ h hbs) :=
begin
  intros i hi,
  cases hi, {split, swap, exact m, split, simp, rw hi, exact h},
  {have : ∃ (n : model) (H : n ∈ l₁), sat builder n i,
     {apply bs_forall, exact hbs, exact hi},
  {rcases this with ⟨w, hw, hsat⟩, split, swap, exact w, split,
   {simp [hw]}, {exact hsat} } }
end

theorem sat_of_batch_sat : Π l Γ (h : modal_applicable Γ),
batch_sat l (unmodal Γ) → sat builder (cons h.v l) Γ :=
begin
  intros l Γ h hbs φ hφ,
  cases hfml : φ,
  case nnf.var : n {rw hfml at hφ, simp, rw ←h.hv, exact hφ},
  case nnf.box : ψ
  {intros s' hs', have hmem := mem_of_mrel_tt hs',
   have := bs_ex l (unmodal Γ) hbs s' hmem,
   rcases this with ⟨w, hw, hsat⟩,
   have := unmodal_mem_box Γ w hw ψ _,
   swap, {rw ←hfml, exact hφ}, {apply hsat, exact this} },
  case nnf.dia : ψ
  {dsimp,
   have := bs_forall l (unmodal Γ) hbs (ψ :: unbox Γ) _, swap,
   {apply mem_unmodal, rw [←undia_iff, ←hfml], exact hφ},
   {rcases this with ⟨w, hw, hsat⟩, split, swap, exact w, split,
    {simp [hw]}, {apply hsat, simp} } },
  case nnf.neg : n
  {rw hfml at hφ, have : var n ∉ Γ,
   {intro hin, have := h.no_contra, have := this hin, contradiction},
    simp, rw ←h.hv, exact this },
  case nnf.and : φ ψ
  {rw hfml at hφ, have := h.no_and, have := @this φ ψ, contradiction},
  case nnf.or : φ ψ
  {rw hfml at hφ, have := h.no_or, have := @this φ ψ, contradiction}
end

theorem build_model : Π Γ (h : model_constructible Γ),
sat builder (cons h.v []) Γ :=
begin
  intros, intro, intro hmem,
  cases heq : φ,
  case nnf.var : n {rw [heq,h.hv] at hmem, simp [hmem]},
  case nnf.neg : n {rw heq at hmem, simp, rw ←h.hv, intro hin, exfalso, apply h.no_contra, repeat {assumption} },
  case nnf.box : φ {simp},
  case nnf.and : φ ψ { rw heq at hmem, exfalso, apply h.no_and, assumption},
  case nnf.or : φ ψ { rw heq at hmem, exfalso, apply h.no_or, assumption},
  case nnf.dia : φ { rw heq at hmem, exfalso, apply h.no_dia, assumption},
end


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

! This file was ported from Lean 3 source module ring_theory.polynomial.rational_root
! leanprover-community/mathlib commit 62c0a4ef1441edb463095ea02a06e87f3dfe135c
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.RingTheory.IntegrallyClosed
import Mathbin.RingTheory.Localization.NumDenom
import Mathbin.RingTheory.Polynomial.ScaleRoots

/-!
# Rational root theorem and integral root theorem

This file contains the rational root theorem and integral root theorem.
The rational root theorem for a unique factorization domain `A`
with localization `S`, states that the roots of `p : A[X]` in `A`'s
field of fractions are of the form `x / y` with `x y : A`, `x ∣ p.coeff 0` and
`y ∣ p.leading_coeff`.
The corollary is the integral root theorem `is_integer_of_is_root_of_monic`:
if `p` is monic, its roots must be integers.
Finally, we use this to show unique factorization domains are integrally closed.

## References

 * https://en.wikipedia.org/wiki/Rational_root_theorem
-/

open Polynomial

section ScaleRoots

variable {A K R S : Type _} [CommRing A] [Field K] [CommRing R] [CommRing S]

variable {M : Submonoid A} [Algebra A S] [IsLocalization M S] [Algebra A K] [IsFractionRing A K]

open Finsupp IsFractionRing IsLocalization Polynomial

theorem scaleRoots_aeval_eq_zero_of_aeval_mk'_eq_zero {p : A[X]} {r : A} {s : M}
    (hr : aeval (mk' S r s) p = 0) : aeval (algebraMap A S r) (scaleRoots p s) = 0 :=
  by
  convert scale_roots_eval₂_eq_zero (algebraMap A S) hr
  rw [aeval_def, mk'_spec' _ r s]
#align scale_roots_aeval_eq_zero_of_aeval_mk'_eq_zero scaleRoots_aeval_eq_zero_of_aeval_mk'_eq_zero

variable [IsDomain A]

theorem num_isRoot_scaleRoots_of_aeval_eq_zero [UniqueFactorizationMonoid A] {p : A[X]} {x : K}
    (hr : aeval x p = 0) : IsRoot (scaleRoots p (den A x)) (Num A x) :=
  by
  apply is_root_of_eval₂_map_eq_zero (IsFractionRing.injective A K)
  refine' scaleRoots_aeval_eq_zero_of_aeval_mk'_eq_zero _
  rw [mk'_num_denom]
  exact hr
#align num_is_root_scale_roots_of_aeval_eq_zero num_isRoot_scaleRoots_of_aeval_eq_zero

end ScaleRoots

section RationalRootTheorem

variable {A K : Type _} [CommRing A] [IsDomain A] [UniqueFactorizationMonoid A] [Field K]

variable [Algebra A K] [IsFractionRing A K]

open IsFractionRing IsLocalization Polynomial UniqueFactorizationMonoid

/-- Rational root theorem part 1:
if `r : f.codomain` is a root of a polynomial over the ufd `A`,
then the numerator of `r` divides the constant coefficient -/
theorem num_dvd_of_is_root {p : A[X]} {r : K} (hr : aeval r p = 0) : Num A r ∣ p.coeff 0 :=
  by
  suffices Num A r ∣ (scale_roots p (denom A r)).coeff 0
    by
    simp only [coeff_scale_roots, tsub_zero] at this
    haveI := Classical.propDecidable
    by_cases hr : Num A r = 0
    · obtain ⟨u, hu⟩ := (is_unit_denom_of_num_eq_zero hr).pow p.nat_degree
      rw [← hu] at this
      exact units.dvd_mul_right.mp this
    · refine' dvd_of_dvd_mul_left_of_no_prime_factors hr _ this
      intro q dvd_num dvd_denom_pow hq
      apply hq.not_unit
      exact num_denom_reduced A r dvd_num (hq.dvd_of_dvd_pow dvd_denom_pow)
  convert dvd_term_of_is_root_of_dvd_terms 0 (num_isRoot_scaleRoots_of_aeval_eq_zero hr) _
  · rw [pow_zero, mul_one]
  intro j hj
  apply dvd_mul_of_dvd_right
  convert pow_dvd_pow (Num A r) (Nat.succ_le_of_lt (bot_lt_iff_ne_bot.mpr hj))
  exact (pow_one _).symm
#align num_dvd_of_is_root num_dvd_of_is_root

/-- Rational root theorem part 2:
if `r : f.codomain` is a root of a polynomial over the ufd `A`,
then the denominator of `r` divides the leading coefficient -/
theorem den_dvd_of_is_root {p : A[X]} {r : K} (hr : aeval r p = 0) :
    (den A r : A) ∣ p.leadingCoeff :=
  by
  suffices (denom A r : A) ∣ p.leading_coeff * Num A r ^ p.nat_degree
    by
    refine'
      dvd_of_dvd_mul_left_of_no_prime_factors (mem_non_zero_divisors_iff_ne_zero.mp (denom A r).2) _
        this
    intro q dvd_denom dvd_num_pow hq
    apply hq.not_unit
    exact num_denom_reduced A r (hq.dvd_of_dvd_pow dvd_num_pow) dvd_denom
  rw [← coeff_scale_roots_nat_degree]
  apply dvd_term_of_is_root_of_dvd_terms _ (num_isRoot_scaleRoots_of_aeval_eq_zero hr)
  intro j hj
  by_cases h : j < p.nat_degree
  · rw [coeff_scale_roots]
    refine' (dvd_mul_of_dvd_right _ _).mul_right _
    convert pow_dvd_pow _ (nat.succ_le_iff.mpr (lt_tsub_iff_left.mpr _))
    · exact (pow_one _).symm
    simpa using h
  rw [← nat_degree_scale_roots p (denom A r)] at *
  rw [coeff_eq_zero_of_nat_degree_lt (lt_of_le_of_ne (le_of_not_gt h) hj.symm),
    MulZeroClass.zero_mul]
  exact dvd_zero _
#align denom_dvd_of_is_root den_dvd_of_is_root

/-- Integral root theorem:
if `r : f.codomain` is a root of a monic polynomial over the ufd `A`,
then `r` is an integer -/
theorem isInteger_of_is_root_of_monic {p : A[X]} (hp : Monic p) {r : K} (hr : aeval r p = 0) :
    IsInteger A r :=
  isInteger_of_isUnit_den (isUnit_of_dvd_one _ (hp ▸ den_dvd_of_is_root hr))
#align is_integer_of_is_root_of_monic isInteger_of_is_root_of_monic

namespace UniqueFactorizationMonoid

theorem integer_of_integral {x : K} : IsIntegral A x → IsInteger A x := fun ⟨p, hp, hx⟩ =>
  isInteger_of_is_root_of_monic hp hx
#align unique_factorization_monoid.integer_of_integral UniqueFactorizationMonoid.integer_of_integral

-- See library note [lower instance priority]
instance (priority := 100) : IsIntegrallyClosed A :=
  ⟨fun x => integer_of_integral⟩

end UniqueFactorizationMonoid

end RationalRootTheorem


/-
Copyright (c) 2020 Zhangir Azerbayev. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Eric Wieser, Zhangir Azerbayev
-/

import group_theory.perm.sign
import group_theory.perm.subgroup
import group_theory.quotient_group
import linear_algebra.linear_independent
import linear_algebra.multilinear.basis
import linear_algebra.multilinear.tensor_product
import logic.equiv.fin

/-!
# Alternating Maps

We construct the bundled function `alternating_map`, which extends `multilinear_map` with all the
arguments of the same type.

## Main definitions
* `alternating_map R M N ι` is the space of `R`-linear alternating maps from `ι → M` to `N`.
* `f.map_eq_zero_of_eq` expresses that `f` is zero when two inputs are equal.
* `f.map_swap` expresses that `f` is negated when two inputs are swapped.
* `f.map_perm` expresses how `f` varies by a sign change under a permutation of its inputs.
* An `add_comm_monoid`, `add_comm_group`, and `module` structure over `alternating_map`s that
  matches the definitions over `multilinear_map`s.
* `multilinear_map.alternatization`, which makes an alternating map out of a non-alternating one.
* `alternating_map.dom_coprod`, which behaves as a product between two alternating maps.

## Implementation notes
`alternating_map` is defined in terms of `map_eq_zero_of_eq`, as this is easier to work with than
using `map_swap` as a definition, and does not require `has_neg N`.

`alternating_map`s are provided with a coercion to `multilinear_map`, along with a set of
`norm_cast` lemmas that act on the algebraic structure:

* `alternating_map.coe_add`
* `alternating_map.coe_zero`
* `alternating_map.coe_sub`
* `alternating_map.coe_neg`
* `alternating_map.coe_smul`
-/

-- semiring / add_comm_monoid
variables {R : Type*} [semiring R]
variables {M : Type*} [add_comm_monoid M] [module R M]
variables {N : Type*} [add_comm_monoid N] [module R N]

-- semiring / add_comm_group
variables {M' : Type*} [add_comm_group M'] [module R M']
variables {N' : Type*} [add_comm_group N'] [module R N']

variables {ι : Type*} [decidable_eq ι]

set_option old_structure_cmd true

section
variables (R M N ι)
/--
An alternating map is a multilinear map that vanishes when two of its arguments are equal.
-/
structure alternating_map extends multilinear_map R (λ i : ι, M) N :=
(map_eq_zero_of_eq' : ∀ (v : ι → M) (i j : ι) (h : v i = v j) (hij : i ≠ j), to_fun v = 0)
end

/-- The multilinear map associated to an alternating map -/
add_decl_doc alternating_map.to_multilinear_map

namespace alternating_map

variables (f f' : alternating_map R M N ι)
variables (g g₂ : alternating_map R M N' ι)
variables (g' : alternating_map R M' N' ι)
variables (v : ι → M) (v' : ι → M')
open function

/-! Basic coercion simp lemmas, largely copied from `ring_hom` and `multilinear_map` -/
section coercions

instance : has_coe_to_fun (alternating_map R M N ι) (λ _, (ι → M) → N) := ⟨λ x, x.to_fun⟩

initialize_simps_projections alternating_map (to_fun → apply)

@[simp] lemma to_fun_eq_coe : f.to_fun = f := rfl

@[simp] lemma coe_mk (f : (ι → M) → N) (h₁ h₂ h₃) : ⇑(⟨f, h₁, h₂, h₃⟩ :
  alternating_map R M N ι) = f := rfl

theorem congr_fun {f g : alternating_map R M N ι} (h : f = g) (x : ι → M) : f x = g x :=
congr_arg (λ h : alternating_map R M N ι, h x) h

theorem congr_arg (f : alternating_map R M N ι) {x y : ι → M} (h : x = y) : f x = f y :=
congr_arg (λ x : ι → M, f x) h

theorem coe_injective : injective (coe_fn : alternating_map R M N ι → ((ι → M) → N)) :=
λ f g h, by { cases f, cases g, cases h, refl }

@[simp, norm_cast] theorem coe_inj {f g : alternating_map R M N ι} :
  (f : (ι → M) → N) = g ↔ f = g :=
coe_injective.eq_iff

@[ext] theorem ext {f f' : alternating_map R M N ι} (H : ∀ x, f x = f' x) : f = f' :=
coe_injective (funext H)

theorem ext_iff {f g : alternating_map R M N ι} : f = g ↔ ∀ x, f x = g x :=
⟨λ h x, h ▸ rfl, λ h, ext h⟩

instance : has_coe (alternating_map R M N ι) (multilinear_map R (λ i : ι, M) N) :=
⟨λ x, x.to_multilinear_map⟩

@[simp, norm_cast] lemma coe_multilinear_map : ⇑(f : multilinear_map R (λ i : ι, M) N) = f := rfl

lemma coe_multilinear_map_injective :
  function.injective (coe : alternating_map R M N ι → multilinear_map R (λ i : ι, M) N) :=
λ x y h, ext $ multilinear_map.congr_fun h

@[simp] lemma to_multilinear_map_eq_coe : f.to_multilinear_map = f := rfl

@[simp] lemma coe_multilinear_map_mk (f : (ι → M) → N) (h₁ h₂ h₃) :
  ((⟨f, h₁, h₂, h₃⟩ : alternating_map R M N ι) :  multilinear_map R (λ i : ι, M) N) = ⟨f, h₁, h₂⟩ :=
rfl

end coercions

/-!
### Simp-normal forms of the structure fields

These are expressed in terms of `⇑f` instead of `f.to_fun`.
-/
@[simp] lemma map_add (i : ι) (x y : M) :
  f (update v i (x + y)) = f (update v i x) + f (update v i y) :=
f.to_multilinear_map.map_add' v i x y

@[simp] lemma map_sub (i : ι) (x y : M') :
  g' (update v' i (x - y)) = g' (update v' i x) - g' (update v' i y) :=
g'.to_multilinear_map.map_sub v' i x y

@[simp] lemma map_neg (i : ι) (x : M') :
  g' (update v' i (-x)) = -g' (update v' i x) :=
g'.to_multilinear_map.map_neg v' i x

@[simp] lemma map_smul (i : ι) (r : R) (x : M) :
  f (update v i (r • x)) = r • f (update v i x) :=
f.to_multilinear_map.map_smul' v i r x

@[simp] lemma map_eq_zero_of_eq (v : ι → M) {i j : ι} (h : v i = v j) (hij : i ≠ j) :
  f v = 0 :=
f.map_eq_zero_of_eq' v i j h hij

@[simp] lemma map_update_zero (m : ι → M) (i : ι) : f (update m i 0) = 0 :=
f.to_multilinear_map.map_update_zero m i

@[simp] lemma map_zero [nonempty ι] : f 0 = 0 :=
f.to_multilinear_map.map_zero

lemma map_eq_zero_of_not_injective (v : ι → M) (hv : ¬function.injective v) : f v = 0 :=
begin
  rw function.injective at hv,
  push_neg at hv,
  rcases hv with ⟨i₁, i₂, heq, hne⟩,
  exact f.map_eq_zero_of_eq v heq hne
end

/-!
### Algebraic structure inherited from `multilinear_map`

`alternating_map` carries the same `add_comm_monoid`, `add_comm_group`, and `module` structure
as `multilinear_map`
-/

section has_scalar

variables {S : Type*} [monoid S] [distrib_mul_action S N] [smul_comm_class R S N]

instance : has_scalar S (alternating_map R M N ι) :=
⟨λ c f,
  { map_eq_zero_of_eq' := λ v i j h hij, by simp [f.map_eq_zero_of_eq v h hij],
    ..((c • f : multilinear_map R (λ i : ι, M) N)) }⟩

@[simp] lemma smul_apply (c : S) (m : ι → M) :
  (c • f) m = c • f m := rfl

@[norm_cast] lemma coe_smul (c : S):
  ((c • f : alternating_map R M N ι) : multilinear_map R (λ i : ι, M) N) = c • f := rfl

lemma coe_fn_smul (c : S) (f : alternating_map R M N ι) : ⇑(c • f) = c • f :=
rfl

end has_scalar

instance : has_add (alternating_map R M N ι) :=
⟨λ a b,
  { map_eq_zero_of_eq' :=
      λ v i j h hij, by simp [a.map_eq_zero_of_eq v h hij, b.map_eq_zero_of_eq v h hij],
    ..(a + b : multilinear_map R (λ i : ι, M) N)}⟩

@[simp] lemma add_apply : (f + f') v = f v + f' v := rfl

@[norm_cast] lemma coe_add : (↑(f  + f') : multilinear_map R (λ i : ι, M) N) = f + f' := rfl

instance : has_zero (alternating_map R M N ι) :=
⟨{map_eq_zero_of_eq' := λ v i j h hij, by simp,
  ..(0 : multilinear_map R (λ i : ι, M) N)}⟩

@[simp] lemma zero_apply : (0 : alternating_map R M N ι) v = 0 := rfl

@[norm_cast] lemma coe_zero :
  ((0 : alternating_map R M N ι) : multilinear_map R (λ i : ι, M) N) = 0 := rfl

instance : inhabited (alternating_map R M N ι) := ⟨0⟩

instance : add_comm_monoid (alternating_map R M N ι) :=
coe_injective.add_comm_monoid _ rfl (λ _ _, rfl) (λ _ _, coe_fn_smul _ _)

instance : has_neg (alternating_map R M N' ι) :=
⟨λ f,
  { map_eq_zero_of_eq' := λ v i j h hij, by simp [f.map_eq_zero_of_eq v h hij],
    ..(-(f : multilinear_map R (λ i : ι, M) N')) }⟩

@[simp] lemma neg_apply (m : ι → M) : (-g) m = -(g m) := rfl

@[norm_cast] lemma coe_neg :
  ((-g : alternating_map R M N' ι) : multilinear_map R (λ i : ι, M) N') = -g := rfl

instance : has_sub (alternating_map R M N' ι) :=
⟨λ f g,
  { map_eq_zero_of_eq' :=
      λ v i j h hij, by simp [f.map_eq_zero_of_eq v h hij, g.map_eq_zero_of_eq v h hij],
    ..(f - g : multilinear_map R (λ i : ι, M) N') }⟩

@[simp] lemma sub_apply (m : ι → M) : (g - g₂) m = g m - g₂ m := rfl

@[norm_cast] lemma coe_sub : (↑(g - g₂) : multilinear_map R (λ i : ι, M) N') = g - g₂ := rfl

instance : add_comm_group (alternating_map R M N' ι) :=
coe_injective.add_comm_group _ rfl (λ _ _, rfl) (λ _, rfl) (λ _ _, rfl)
  (λ _ _, coe_fn_smul _ _) (λ _ _, coe_fn_smul _ _)

section distrib_mul_action

variables {S : Type*} [monoid S] [distrib_mul_action S N] [smul_comm_class R S N]

instance : distrib_mul_action S (alternating_map R M N ι) :=
{ one_smul := λ f, ext $ λ x, one_smul _ _,
  mul_smul := λ c₁ c₂ f, ext $ λ x, mul_smul _ _ _,
  smul_zero := λ r, ext $ λ x, smul_zero _,
  smul_add := λ r f₁ f₂, ext $ λ x, smul_add _ _ _ }

end distrib_mul_action

section module

variables {S : Type*} [semiring S] [module S N] [smul_comm_class R S N]

/-- The space of multilinear maps over an algebra over `R` is a module over `R`, for the pointwise
addition and scalar multiplication. -/
instance : module S (alternating_map R M N ι) :=
{ add_smul := λ r₁ r₂ f, ext $ λ x, add_smul _ _ _,
  zero_smul := λ f, ext $ λ x, zero_smul _ _ }

instance [no_zero_smul_divisors S N] : no_zero_smul_divisors S (alternating_map R M N ι) :=
coe_injective.no_zero_smul_divisors _ rfl coe_fn_smul

end module

section
variables (R N)

/-- The evaluation map from `ι → N` to `N` at a given `i` is alternating when `ι` is subsingleton.
-/
@[simps]
def of_subsingleton [subsingleton ι] (i : ι) : alternating_map R N N ι :=
{ to_fun := function.eval i,
  map_eq_zero_of_eq' := λ v i j hv hij, (hij $ subsingleton.elim _ _).elim,
  ..multilinear_map.of_subsingleton R N i }

end

end alternating_map

/-!
### Composition with linear maps
-/

namespace linear_map

variables {N₂ : Type*} [add_comm_monoid N₂] [module R N₂]

/-- Composing a alternating map with a linear map on the left gives again an alternating map. -/
def comp_alternating_map (g : N →ₗ[R] N₂) : alternating_map R M N ι →+ alternating_map R M N₂ ι :=
{ to_fun := λ f,
  { map_eq_zero_of_eq' := λ v i j h hij, by simp [f.map_eq_zero_of_eq v h hij],
              ..(g.comp_multilinear_map (f : multilinear_map R (λ _ : ι, M) N)) },
  map_zero' := by { ext, simp },
  map_add' := λ a b, by { ext, simp } }

@[simp] lemma coe_comp_alternating_map (g : N →ₗ[R] N₂) (f : alternating_map R M N ι) :
  ⇑(g.comp_alternating_map f) = g ∘ f := rfl

lemma comp_alternating_map_apply (g : N →ₗ[R] N₂) (f : alternating_map R M N ι) (m : ι → M) :
  g.comp_alternating_map f m = g (f m) := rfl

end linear_map

namespace alternating_map

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

/-- Composing a alternating map with the same linear map on each argument gives again an
alternating map. -/
def comp_linear_map (f : alternating_map R M N ι) (g : M₂ →ₗ[R] M) : alternating_map R M₂ N ι :=
{ map_eq_zero_of_eq' := λ v i j h hij, f.map_eq_zero_of_eq _ (linear_map.congr_arg h) hij,
  .. (f : multilinear_map R (λ _ : ι, M) N).comp_linear_map (λ _, g) }

lemma coe_comp_linear_map (f : alternating_map R M N ι) (g : M₂ →ₗ[R] M) :
  ⇑(f.comp_linear_map g) = f ∘ ((∘) g) := rfl

@[simp] lemma comp_linear_map_apply (f : alternating_map R M N ι) (g : M₂ →ₗ[R] M) (v : ι → M₂) :
  f.comp_linear_map g v = f (λ i, g (v i)) := rfl

/-- Composing an alternating map twice with the same linear map in each argument is
the same as composing with their composition. -/
lemma comp_linear_map_assoc (f : alternating_map R M N ι) (g₁ : M₂ →ₗ[R] M) (g₂ : M₃ →ₗ[R] M₂) :
  (f.comp_linear_map g₁).comp_linear_map g₂ = f.comp_linear_map (g₁ ∘ₗ g₂) :=
rfl

@[simp] lemma zero_comp_linear_map (g : M₂ →ₗ[R] M) :
  (0 : alternating_map R M N ι).comp_linear_map g = 0 :=
by { ext, simp only [comp_linear_map_apply, zero_apply] }

@[simp] lemma add_comp_linear_map (f₁ f₂ : alternating_map R M N ι) (g : M₂ →ₗ[R] M) :
  (f₁ + f₂).comp_linear_map g = f₁.comp_linear_map g + f₂.comp_linear_map g :=
by { ext, simp only [comp_linear_map_apply, add_apply] }

@[simp] lemma comp_linear_map_zero [nonempty ι] (f : alternating_map R M N ι) :
  f.comp_linear_map (0 : M₂ →ₗ[R] M) = 0 :=
begin
  ext,
  simp_rw [comp_linear_map_apply, linear_map.zero_apply, ←pi.zero_def, map_zero, zero_apply],
end

/-- Composing an alternating map with the identity linear map in each argument. -/
@[simp] lemma comp_linear_map_id (f : alternating_map R M N ι) :
  f.comp_linear_map linear_map.id = f :=
ext $ λ _, rfl

/-- Composing with a surjective linear map is injective. -/
lemma comp_linear_map_injective (f : M₂ →ₗ[R] M) (hf : function.surjective f) :
  function.injective (λ g : alternating_map R M N ι, g.comp_linear_map f) :=
λ g₁ g₂ h, ext $ λ x,
by simpa [function.surj_inv_eq hf] using ext_iff.mp h (function.surj_inv hf ∘ x)

lemma comp_linear_map_inj (f : M₂ →ₗ[R] M) (hf : function.surjective f)
  (g₁ g₂ : alternating_map R M N ι) : g₁.comp_linear_map f = g₂.comp_linear_map f ↔ g₁ = g₂ :=
(comp_linear_map_injective _ hf).eq_iff

section dom_lcongr

variables (ι R N) (S : Type*) [semiring S] [module S N] [smul_comm_class R S N]

/-- Construct a linear equivalence between maps from a linear equivalence between domains. -/
@[simps apply]
def dom_lcongr (e : M ≃ₗ[R] M₂) : alternating_map R M N ι ≃ₗ[S] alternating_map R M₂ N ι :=
{ to_fun := λ f, f.comp_linear_map e.symm,
  inv_fun := λ g, g.comp_linear_map e,
  map_add' := λ _ _, rfl,
  map_smul' := λ _ _, rfl,
  left_inv := λ f, alternating_map.ext $ λ v, f.congr_arg $ funext $ λ i, e.symm_apply_apply _,
  right_inv := λ f, alternating_map.ext $ λ v, f.congr_arg $ funext $ λ i, e.apply_symm_apply _ }

@[simp] lemma dom_lcongr_refl :
  dom_lcongr R N ι S (linear_equiv.refl R M) = linear_equiv.refl S _ :=
linear_equiv.ext $ λ _, alternating_map.ext $ λ v, rfl

@[simp] lemma dom_lcongr_symm (e : M ≃ₗ[R] M₂) :
  (dom_lcongr R N ι S e).symm = dom_lcongr R N ι S e.symm :=
rfl

lemma dom_lcongr_trans (e : M ≃ₗ[R] M₂) (f : M₂ ≃ₗ[R] M₃):
  (dom_lcongr R N ι S e).trans (dom_lcongr R N ι S f) = dom_lcongr R N ι S (e.trans f) :=
rfl

end dom_lcongr

/-- Composing an alternating map with the same linear equiv on each argument gives the zero map
if and only if the alternating map is the zero map. -/
@[simp] lemma comp_linear_equiv_eq_zero_iff (f : alternating_map R M N ι) (g : M₂ ≃ₗ[R] M) :
  f.comp_linear_map (g : M₂ →ₗ[R] M) = 0 ↔ f = 0 :=
(dom_lcongr R N ι ℕ g.symm).map_eq_zero_iff

variables (f f' : alternating_map R M N ι)
variables (g g₂ : alternating_map R M N' ι)
variables (g' : alternating_map R M' N' ι)
variables (v : ι → M) (v' : ι → M')
open function

/-!
### Other lemmas from `multilinear_map`
-/
section

open_locale big_operators

lemma map_update_sum {α : Type*} (t : finset α) (i : ι) (g : α → M) (m : ι → M):
  f (update m i (∑ a in t, g a)) = ∑ a in t, f (update m i (g a)) :=
f.to_multilinear_map.map_update_sum t i g m

end

/-!
### Theorems specific to alternating maps

Various properties of reordered and repeated inputs which follow from
`alternating_map.map_eq_zero_of_eq`.
-/

lemma map_update_self {i j : ι} (hij : i ≠ j) :
  f (function.update v i (v j)) = 0 :=
f.map_eq_zero_of_eq _ (by rw [function.update_same, function.update_noteq hij.symm]) hij

lemma map_update_update {i j : ι} (hij : i ≠ j) (m : M) :
  f (function.update (function.update v i m) j m) = 0 :=
f.map_eq_zero_of_eq _
  (by rw [function.update_same, function.update_noteq hij, function.update_same]) hij

lemma map_swap_add {i j : ι} (hij : i ≠ j) :
  f (v ∘ equiv.swap i j) + f v = 0 :=
begin
  rw equiv.comp_swap_eq_update,
  convert f.map_update_update v hij (v i + v j),
  simp [f.map_update_self _ hij,
        f.map_update_self _ hij.symm,
        function.update_comm hij (v i + v j) (v _) v,
        function.update_comm hij.symm (v i) (v i) v],
end

lemma map_add_swap {i j : ι} (hij : i ≠ j) :
  f v + f (v ∘ equiv.swap i j) = 0 :=
by { rw add_comm, exact f.map_swap_add v hij }

lemma map_swap {i j : ι} (hij : i ≠ j) :
  g (v ∘ equiv.swap i j) = - g v  :=
eq_neg_of_add_eq_zero (g.map_swap_add v hij)

lemma map_perm [fintype ι] (v : ι → M) (σ : equiv.perm ι) :
  g (v ∘ σ) = σ.sign • g v :=
begin
  apply equiv.perm.swap_induction_on' σ,
  { simp },
  { intros s x y hxy hI,
    simpa [g.map_swap (v ∘ s) hxy, equiv.perm.sign_swap hxy] using hI, }
end

lemma map_congr_perm [fintype ι] (σ : equiv.perm ι) :
  g v = σ.sign • g (v ∘ σ) :=
by { rw [g.map_perm, smul_smul], simp }

lemma coe_dom_dom_congr [fintype ι] (σ : equiv.perm ι) :
  (g : multilinear_map R (λ _ : ι, M) N').dom_dom_congr σ
    = σ.sign • (g : multilinear_map R (λ _ : ι, M) N') :=
multilinear_map.ext $ λ v, g.map_perm v σ

/-- If the arguments are linearly dependent then the result is `0`. -/
lemma map_linear_dependent
  {K : Type*} [ring K]
  {M : Type*} [add_comm_group M] [module K M]
  {N : Type*} [add_comm_group N] [module K N] [no_zero_smul_divisors K N]
  (f : alternating_map K M N ι) (v : ι → M)
  (h : ¬linear_independent K v) :
  f v = 0 :=
begin
  obtain ⟨s, g, h, i, hi, hz⟩ := not_linear_independent_iff.mp h,
  suffices : f (update v i (g i • v i)) = 0,
  { rw [f.map_smul, function.update_eq_self, smul_eq_zero] at this,
    exact or.resolve_left this hz, },
  conv at h in (g _ • v _) { rw ←if_t_t (i = x) (g _ • v _), },
  rw [finset.sum_ite, finset.filter_eq, finset.filter_ne, if_pos hi, finset.sum_singleton,
    add_eq_zero_iff_eq_neg] at h,
  rw [h, f.map_neg, f.map_update_sum, neg_eq_zero, finset.sum_eq_zero],
  intros j hj,
  obtain ⟨hij, _⟩ := finset.mem_erase.mp hj,
  rw [f.map_smul, f.map_update_self _ hij.symm, smul_zero],
end

end alternating_map

open_locale big_operators

namespace multilinear_map

open equiv

variables [fintype ι]

private lemma alternization_map_eq_zero_of_eq_aux
  (m : multilinear_map R (λ i : ι, M) N')
  (v : ι → M) (i j : ι) (i_ne_j : i ≠ j) (hv : v i = v j) :
  (∑ (σ : perm ι), σ.sign • m.dom_dom_congr σ) v = 0 :=
begin
  rw sum_apply,
  exact finset.sum_involution
    (λ σ _, swap i j * σ)
    (λ σ _, by simp [perm.sign_swap i_ne_j, apply_swap_eq_self hv])
    (λ σ _ _, (not_congr swap_mul_eq_iff).mpr i_ne_j)
    (λ σ _, finset.mem_univ _)
    (λ σ _, swap_mul_involutive i j σ)
end

/-- Produce an `alternating_map` out of a `multilinear_map`, by summing over all argument
permutations. -/
def alternatization : multilinear_map R (λ i : ι, M) N' →+ alternating_map R M N' ι :=
{ to_fun := λ m,
  { to_fun := ⇑(∑ (σ : perm ι), σ.sign • m.dom_dom_congr σ),
    map_eq_zero_of_eq' := λ v i j hvij hij, alternization_map_eq_zero_of_eq_aux m v i j hij hvij,
    .. (∑ (σ : perm ι), σ.sign • m.dom_dom_congr σ)},
  map_add' := λ a b, begin
    ext,
    simp only [
      finset.sum_add_distrib, smul_add, add_apply, dom_dom_congr_apply, alternating_map.add_apply,
      alternating_map.coe_mk, smul_apply, sum_apply],
  end,
  map_zero' := begin
    ext,
    simp only [
      finset.sum_const_zero, smul_zero, zero_apply, dom_dom_congr_apply, alternating_map.zero_apply,
      alternating_map.coe_mk, smul_apply, sum_apply],
  end }

lemma alternatization_def (m : multilinear_map R (λ i : ι, M) N') :
  ⇑(alternatization m) = (∑ (σ : perm ι), σ.sign • m.dom_dom_congr σ : _) :=
rfl

lemma alternatization_coe (m : multilinear_map R (λ i : ι, M) N') :
  ↑m.alternatization = (∑ (σ : perm ι), σ.sign • m.dom_dom_congr σ : _) :=
coe_injective rfl

lemma alternatization_apply (m : multilinear_map R (λ i : ι, M) N') (v : ι → M) :
  alternatization m v = ∑ (σ : perm ι), σ.sign • m.dom_dom_congr σ v :=
by simp only [alternatization_def, smul_apply, sum_apply]

end multilinear_map

namespace alternating_map

/-- Alternatizing a multilinear map that is already alternating results in a scale factor of `n!`,
where `n` is the number of inputs. -/
lemma coe_alternatization [fintype ι] (a : alternating_map R M N' ι) :
  (↑a : multilinear_map R (λ ι, M) N').alternatization = nat.factorial (fintype.card ι) • a :=
begin
  apply alternating_map.coe_injective,
  simp_rw [multilinear_map.alternatization_def, coe_dom_dom_congr, smul_smul,
    int.units_mul_self, one_smul, finset.sum_const, finset.card_univ, fintype.card_perm,
    ←coe_multilinear_map, coe_smul],
end

end alternating_map

namespace linear_map

variables {N'₂ : Type*} [add_comm_group N'₂] [module R N'₂] [fintype ι]

/-- Composition with a linear map before and after alternatization are equivalent. -/
lemma comp_multilinear_map_alternatization (g : N' →ₗ[R] N'₂)
  (f : multilinear_map R (λ _ : ι, M) N') :
  (g.comp_multilinear_map f).alternatization = g.comp_alternating_map (f.alternatization) :=
by { ext, simp [multilinear_map.alternatization_def] }

end linear_map

section coprod

open_locale big_operators
open_locale tensor_product

variables {ιa ιb : Type*} [decidable_eq ιa] [decidable_eq ιb] [fintype ιa] [fintype ιb]

variables
  {R' : Type*} {Mᵢ N₁ N₂ : Type*}
  [comm_semiring R']
  [add_comm_group N₁] [module R' N₁]
  [add_comm_group N₂] [module R' N₂]
  [add_comm_monoid Mᵢ] [module R' Mᵢ]

namespace equiv.perm

/-- Elements which are considered equivalent if they differ only by swaps within α or β  -/
abbreviation mod_sum_congr (α β : Type*) :=
_ ⧸ (equiv.perm.sum_congr_hom α β).range

lemma mod_sum_congr.swap_smul_involutive {α β : Type*} [decidable_eq (α ⊕ β)] (i j : α ⊕ β) :
  function.involutive (has_scalar.smul (equiv.swap i j) : mod_sum_congr α β → mod_sum_congr α β) :=
λ σ, begin
  apply σ.induction_on' (λ σ, _),
  exact _root_.congr_arg quotient.mk' (equiv.swap_mul_involutive i j σ)
end

end equiv.perm

namespace alternating_map
open equiv

/-- summand used in `alternating_map.dom_coprod` -/
def dom_coprod.summand
  (a : alternating_map R' Mᵢ N₁ ιa) (b : alternating_map R' Mᵢ N₂ ιb)
  (σ : perm.mod_sum_congr ιa ιb) :
  multilinear_map R' (λ _ : ιa ⊕ ιb, Mᵢ) (N₁ ⊗[R'] N₂) :=
quotient.lift_on' σ
  (λ σ,
    σ.sign •
      (multilinear_map.dom_coprod ↑a ↑b : multilinear_map R' (λ _, Mᵢ) (N₁ ⊗ N₂)).dom_dom_congr σ)
  (λ σ₁ σ₂ ⟨⟨sl, sr⟩, h⟩, begin
    ext v,
    simp only [multilinear_map.dom_dom_congr_apply, multilinear_map.dom_coprod_apply,
      coe_multilinear_map, multilinear_map.smul_apply],
    replace h := inv_mul_eq_iff_eq_mul.mp h.symm,
    have : (σ₁ * perm.sum_congr_hom _ _ (sl, sr)).sign = σ₁.sign * (sl.sign * sr.sign) :=
      by simp,
    rw [h, this, mul_smul, mul_smul, smul_left_cancel_iff,
      ←tensor_product.tmul_smul, tensor_product.smul_tmul'],
    simp only [sum.map_inr, perm.sum_congr_hom_apply, perm.sum_congr_apply, sum.map_inl,
              function.comp_app, perm.coe_mul],
    rw [←a.map_congr_perm (λ i, v (σ₁ _)), ←b.map_congr_perm (λ i, v (σ₁ _))],
  end)

lemma dom_coprod.summand_mk'
  (a : alternating_map R' Mᵢ N₁ ιa) (b : alternating_map R' Mᵢ N₂ ιb)
  (σ : equiv.perm (ιa ⊕ ιb)) :
  dom_coprod.summand a b (quotient.mk' σ) = σ.sign •
    (multilinear_map.dom_coprod ↑a ↑b : multilinear_map R' (λ _, Mᵢ) (N₁ ⊗ N₂)).dom_dom_congr σ :=
rfl

/-- Swapping elements in `σ` with equal values in `v` results in an addition that cancels -/
lemma dom_coprod.summand_add_swap_smul_eq_zero
  (a : alternating_map R' Mᵢ N₁ ιa) (b : alternating_map R' Mᵢ N₂ ιb)
  (σ : perm.mod_sum_congr ιa ιb)
  {v : ιa ⊕ ιb → Mᵢ} {i j : ιa ⊕ ιb} (hv : v i = v j) (hij : i ≠ j) :
  dom_coprod.summand a b σ v + dom_coprod.summand a b (swap i j • σ) v = 0 :=
begin
  apply σ.induction_on' (λ σ, _),
  dsimp only [quotient.lift_on'_mk', quotient.map'_mk', mul_action.quotient.smul_mk,
    dom_coprod.summand],
  rw [perm.sign_mul, perm.sign_swap hij],
  simp only [one_mul, neg_mul, function.comp_app, units.neg_smul, perm.coe_mul,
    units.coe_neg, multilinear_map.smul_apply, multilinear_map.neg_apply,
    multilinear_map.dom_dom_congr_apply, multilinear_map.dom_coprod_apply],
  convert add_right_neg _;
  { ext k, rw equiv.apply_swap_eq_self hv },
end

/-- Swapping elements in `σ` with equal values in `v` result in zero if the swap has no effect
on the quotient. -/
lemma dom_coprod.summand_eq_zero_of_smul_invariant
  (a : alternating_map R' Mᵢ N₁ ιa) (b : alternating_map R' Mᵢ N₂ ιb)
  (σ : perm.mod_sum_congr ιa ιb)
  {v : ιa ⊕ ιb → Mᵢ} {i j : ιa ⊕ ιb} (hv : v i = v j) (hij : i ≠ j) :
  swap i j • σ = σ → dom_coprod.summand a b σ v = 0 :=
begin
  apply σ.induction_on' (λ σ, _),
  dsimp only [quotient.lift_on'_mk', quotient.map'_mk', multilinear_map.smul_apply,
    multilinear_map.dom_dom_congr_apply, multilinear_map.dom_coprod_apply, dom_coprod.summand],
  intro hσ,
  with_cases
  { cases hi : σ⁻¹ i;
      cases hj : σ⁻¹ j;
      rw perm.inv_eq_iff_eq at hi hj;
      substs hi hj, },
  case [sum.inl sum.inr : i' j', sum.inr sum.inl : i' j']
  { -- the term pairs with and cancels another term
    all_goals { obtain ⟨⟨sl, sr⟩, hσ⟩ := quotient.exact' hσ, },
    work_on_goal 1 { replace hσ := equiv.congr_fun hσ (sum.inl i'), },
    work_on_goal 2 { replace hσ := equiv.congr_fun hσ (sum.inr i'), },
    all_goals
    { rw [←equiv.mul_swap_eq_swap_mul, mul_inv_rev, equiv.swap_inv, inv_mul_cancel_right] at hσ,
      simpa using hσ, }, },
  case [sum.inr sum.inr : i' j', sum.inl sum.inl : i' j']
  { -- the term does not pair but is zero
    all_goals { convert smul_zero _, },
    work_on_goal 1 { convert tensor_product.tmul_zero _ _, },
    work_on_goal 2 { convert tensor_product.zero_tmul _ _, },
    all_goals { exact alternating_map.map_eq_zero_of_eq _ _ hv (λ hij', hij (hij' ▸ rfl)), } },
end

/-- Like `multilinear_map.dom_coprod`, but ensures the result is also alternating.

Note that this is usually defined (for instance, as used in Proposition 22.24 in [Gallier2011Notes])
over integer indices `ιa = fin n` and `ιb = fin m`, as
$$
(f \wedge g)(u_1, \ldots, u_{m+n}) =
  \sum_{\operatorname{shuffle}(m, n)} \operatorname{sign}(\sigma)
    f(u_{\sigma(1)}, \ldots, u_{\sigma(m)}) g(u_{\sigma(m+1)}, \ldots, u_{\sigma(m+n)}),
$$
where $\operatorname{shuffle}(m, n)$ consists of all permutations of $[1, m+n]$ such that
$\sigma(1) < \cdots < \sigma(m)$ and $\sigma(m+1) < \cdots < \sigma(m+n)$.

Here, we generalize this by replacing:
* the product in the sum with a tensor product
* the filtering of $[1, m+n]$ to shuffles with an isomorphic quotient
* the additions in the subscripts of $\sigma$ with an index of type `sum`

The specialized version can be obtained by combining this definition with `fin_sum_fin_equiv` and
`algebra.lmul'`.
-/
@[simps]
def dom_coprod
  (a : alternating_map R' Mᵢ N₁ ιa) (b : alternating_map R' Mᵢ N₂ ιb) :
  alternating_map R' Mᵢ (N₁ ⊗[R'] N₂) (ιa ⊕ ιb) :=
{ to_fun := λ v, ⇑(∑ σ : perm.mod_sum_congr ιa ιb, dom_coprod.summand a b σ) v,
  map_eq_zero_of_eq' := λ v i j hv hij, begin
    dsimp only,
    rw multilinear_map.sum_apply,
    exact finset.sum_involution
      (λ σ _, equiv.swap i j • σ)
      (λ σ _, dom_coprod.summand_add_swap_smul_eq_zero a b σ hv hij)
      (λ σ _, mt $ dom_coprod.summand_eq_zero_of_smul_invariant a b σ hv hij)
      (λ σ _, finset.mem_univ _)
      (λ σ _, equiv.perm.mod_sum_congr.swap_smul_involutive i j σ),
  end,
  ..(∑ σ : perm.mod_sum_congr ιa ιb, dom_coprod.summand a b σ) }

lemma dom_coprod_coe (a : alternating_map R' Mᵢ N₁ ιa) (b : alternating_map R' Mᵢ N₂ ιb) :
  (↑(a.dom_coprod b) : multilinear_map R' (λ _, Mᵢ) _) =
    ∑ σ : perm.mod_sum_congr ιa ιb, dom_coprod.summand a b σ :=
multilinear_map.ext $ λ _, rfl

/-- A more bundled version of `alternating_map.dom_coprod` that maps
`((ι₁ → N) → N₁) ⊗ ((ι₂ → N) → N₂)` to `(ι₁ ⊕ ι₂ → N) → N₁ ⊗ N₂`. -/
def dom_coprod' :
  (alternating_map R' Mᵢ N₁ ιa ⊗[R'] alternating_map R' Mᵢ N₂ ιb) →ₗ[R']
    alternating_map R' Mᵢ (N₁ ⊗[R'] N₂) (ιa ⊕ ιb) :=
tensor_product.lift $ by
  refine linear_map.mk₂ R' (dom_coprod)
    (λ m₁ m₂ n, _)
    (λ c m n, _)
    (λ m n₁ n₂, _)
    (λ c m n, _);
  { ext,
    simp only [dom_coprod_apply, add_apply, smul_apply, ←finset.sum_add_distrib,
      finset.smul_sum, multilinear_map.sum_apply, dom_coprod.summand],
    congr,
    ext σ,
    apply σ.induction_on' (λ σ, _),
    simp only [quotient.lift_on'_mk', coe_add, coe_smul, multilinear_map.smul_apply,
      ←multilinear_map.dom_coprod'_apply],
    simp only [tensor_product.add_tmul, ←tensor_product.smul_tmul',
      tensor_product.tmul_add, tensor_product.tmul_smul, linear_map.map_add, linear_map.map_smul],
    rw ←smul_add <|> rw smul_comm,
    congr }

@[simp]
lemma dom_coprod'_apply
  (a : alternating_map R' Mᵢ N₁ ιa) (b : alternating_map R' Mᵢ N₂ ιb) :
  dom_coprod' (a ⊗ₜ[R'] b) = dom_coprod a b :=
by simp only [dom_coprod', tensor_product.lift.tmul, linear_map.mk₂_apply]

end alternating_map

open equiv

/-- A helper lemma for `multilinear_map.dom_coprod_alternization`. -/
lemma multilinear_map.dom_coprod_alternization_coe
  (a : multilinear_map R' (λ _ : ιa, Mᵢ) N₁) (b : multilinear_map R' (λ _ : ιb, Mᵢ) N₂) :
  multilinear_map.dom_coprod ↑a.alternatization ↑b.alternatization =
    ∑ (σa : perm ιa) (σb : perm ιb), σa.sign • σb.sign •
      multilinear_map.dom_coprod (a.dom_dom_congr σa) (b.dom_dom_congr σb) :=
begin
  simp_rw [←multilinear_map.dom_coprod'_apply, multilinear_map.alternatization_coe],
  simp_rw [tensor_product.sum_tmul, tensor_product.tmul_sum, linear_map.map_sum,
    ←tensor_product.smul_tmul', tensor_product.tmul_smul, linear_map.map_smul_of_tower],
end

open alternating_map

/-- Computing the `multilinear_map.alternatization` of the `multilinear_map.dom_coprod` is the same
as computing the `alternating_map.dom_coprod` of the `multilinear_map.alternatization`s.
-/
lemma multilinear_map.dom_coprod_alternization
  (a : multilinear_map R' (λ _ : ιa, Mᵢ) N₁) (b : multilinear_map R' (λ _ : ιb, Mᵢ) N₂) :
  (multilinear_map.dom_coprod a b).alternatization =
    a.alternatization.dom_coprod b.alternatization :=
begin
  apply coe_multilinear_map_injective,
  rw [dom_coprod_coe, multilinear_map.alternatization_coe,
    finset.sum_partition (quotient_group.left_rel (perm.sum_congr_hom ιa ιb).range)],
  congr' 1,
  ext1 σ,
  apply σ.induction_on' (λ σ, _),

  -- unfold the quotient mess left by `finset.sum_partition`
  conv in (_ = quotient.mk' _)
  { change quotient.mk' _ = quotient.mk' _,
    rw quotient.eq',
    rw [quotient_group.left_rel],
    dsimp only [setoid.r] },

  -- eliminate a multiplication
  have : @finset.univ (perm (ιa ⊕ ιb)) _ = finset.univ.image ((*) σ) :=
    (finset.eq_univ_iff_forall.mpr $ λ a, let ⟨a', ha'⟩ := mul_left_surjective σ a in
      finset.mem_image.mpr ⟨a', finset.mem_univ _, ha'⟩).symm,
  rw [this, finset.image_filter],
  simp only [function.comp, mul_inv_rev, inv_mul_cancel_right, subgroup.inv_mem_iff],
  simp only [monoid_hom.mem_range], -- needs to be separate from the above `simp only`
  rw [finset.filter_congr_decidable,
    finset.univ_filter_exists (perm.sum_congr_hom ιa ιb),
    finset.sum_image (λ x _ y _ (h : _ = _), mul_right_injective _ h),
    finset.sum_image (λ x _ y _ (h : _ = _), perm.sum_congr_hom_injective h)],
  dsimp only,

  -- now we're ready to clean up the RHS, pulling out the summation
  rw [dom_coprod.summand_mk', multilinear_map.dom_coprod_alternization_coe,
    ←finset.sum_product', finset.univ_product_univ,
    ←multilinear_map.dom_dom_congr_equiv_apply, add_equiv.map_sum, finset.smul_sum],
  congr' 1,
  ext1 ⟨al, ar⟩,
  dsimp only,

  -- pull out the pair of smuls on the RHS, by rewriting to `_ →ₗ[ℤ] _` and back
  rw [←add_equiv.coe_to_add_monoid_hom, ←add_monoid_hom.coe_to_int_linear_map,
    linear_map.map_smul_of_tower,
    linear_map.map_smul_of_tower,
    add_monoid_hom.coe_to_int_linear_map, add_equiv.coe_to_add_monoid_hom,
    multilinear_map.dom_dom_congr_equiv_apply],

  -- pick up the pieces
  rw [multilinear_map.dom_dom_congr_mul, perm.sign_mul,
    perm.sum_congr_hom_apply, multilinear_map.dom_coprod_dom_dom_congr_sum_congr,
    perm.sign_sum_congr, mul_smul, mul_smul],
end

/-- Taking the `multilinear_map.alternatization` of the `multilinear_map.dom_coprod` of two
`alternating_map`s gives a scaled version of the `alternating_map.coprod` of those maps.
-/
lemma multilinear_map.dom_coprod_alternization_eq
  (a : alternating_map R' Mᵢ N₁ ιa) (b : alternating_map R' Mᵢ N₂ ιb) :
  (multilinear_map.dom_coprod a b : multilinear_map R' (λ _ : ιa ⊕ ιb, Mᵢ) (N₁ ⊗ N₂))
    .alternatization =
    ((fintype.card ιa).factorial * (fintype.card ιb).factorial) • a.dom_coprod b :=
begin
  rw [multilinear_map.dom_coprod_alternization, coe_alternatization, coe_alternatization, mul_smul,
    ←dom_coprod'_apply, ←dom_coprod'_apply, ←tensor_product.smul_tmul', tensor_product.tmul_smul,
    linear_map.map_smul_of_tower dom_coprod', linear_map.map_smul_of_tower dom_coprod'],
  -- typeclass resolution is a little confused here
  apply_instance, apply_instance,
end

end coprod

section basis

open alternating_map

variables {ι₁ : Type*} [fintype ι]
variables {R' : Type*} {N₁ N₂ : Type*} [comm_semiring R'] [add_comm_monoid N₁] [add_comm_monoid N₂]
variables [module R' N₁] [module R' N₂]

/-- Two alternating maps indexed by a `fintype` are equal if they are equal when all arguments
are distinct basis vectors. -/
lemma basis.ext_alternating {f g : alternating_map R' N₁ N₂ ι} (e : basis ι₁ R' N₁)
  (h : ∀ v : ι → ι₁, function.injective v → f (λ i, e (v i)) = g (λ i, e (v i))) : f = g :=
begin
  refine alternating_map.coe_multilinear_map_injective (basis.ext_multilinear e $ λ v, _),
  by_cases hi : function.injective v,
  { exact h v hi },
  { have : ¬function.injective (λ i, e (v i)) := hi.imp function.injective.of_comp,
    rw [coe_multilinear_map, coe_multilinear_map,
        f.map_eq_zero_of_not_injective _ this, g.map_eq_zero_of_not_injective _ this], }
end

end basis


import mathlib.measure_theory.measure.measure_space
import probability.probability_mass_function.constructions

-- TODO: On a countable space, define one-to-one correspondance between `pmf` and probability
-- measures

open measure_theory
open_locale big_operators classical ennreal nnreal

namespace pmf
variables {α β : Type*}

section of_fintype
variables [fintype α] [fintype β]

open finset

@[simp] lemma map_of_fintype (f : α → ℝ≥0∞) (h : univ.sum (λ (a : α), f a) = 1) (g : α → β) :
  (of_fintype f h).map g = of_fintype (λ b, ∑ a in univ.filter (λ a, g a = b), f a) begin
   have : ((univ : finset β) : set β).pairwise_disjoint
     (λ b, univ.filter $ λ a : α, g a = b),
   { refine λ b₁ _ b₂ _ hb, disjoint_left.2 (λ a ha₁ ha₂, _),
     simp only [mem_filter, mem_univ, true_and] at ha₁ ha₂,
     exact hb (ha₁.symm.trans ha₂) },
   rw ←sum_disj_Union _ _ this,
   convert h,
   exact eq_univ_of_forall (λ a, mem_disj_Union.2 ⟨_, mem_univ _, mem_filter.2 ⟨mem_univ _, rfl⟩⟩),
  end :=
begin
  ext b : 1,
  simp only [sum_filter, eq_comm, map_apply, of_fintype_apply],
  exact tsum_eq_sum (λ _ h, (h $ mem_univ _).elim),
end

end of_fintype

variables [measurable_space α] [measurable_space β] {f : α → β}

lemma to_measure_ne_zero (p : pmf α) : p.to_measure ≠ 0 :=
is_probability_measure.ne_zero p.to_measure

@[simp] lemma map_to_measure (p : pmf α) (hf : measurable f) :
  p.to_measure.map f = (p.map f).to_measure :=
by { ext s hs : 1, rw [pmf.to_measure_map_apply _ _ _ hf hs, measure.map_apply hf hs] }

section bernoulli

/-- A `pmf` which assigns probability `p` to true propositions and `1 - p` to false ones. -/
noncomputable def bernoulli' (p : ℝ≥0) (h : p ≤ 1) : pmf Prop :=
of_fintype (λ b, if b then p else 1 - p) $ by { norm_cast, exact nnreal.eq (by simp [h]) }

variables {p : ℝ≥0} (hp : p ≤ 1) (b : Prop)

@[simp] lemma bernoulli'_apply : bernoulli' p hp b = if b then p else 1 - p := rfl

@[simp] lemma support_bernoulli' : (bernoulli' p hp).support = {b | if b then p ≠ 0 else p ≠ 1} :=
set.ext $ λ b, by by_cases b; simp [h, hp.lt_iff_ne]

lemma mem_support_bernoulli'_iff : b ∈ (bernoulli' p hp).support ↔ if b then p ≠ 0 else p ≠ 1 :=
by simp

@[simp] lemma map_not_bernoulli' : (bernoulli' p hp).map not = bernoulli' (1 - p) tsub_le_self :=
begin
  have : ∀ p : Prop, finset.univ.filter (λ q : Prop, (¬ q) ↔ p) = {¬ p},
  { rintro p,
    ext q,
    by_cases p; by_cases q; simp [*] },
  refine (map_of_fintype _ _ _).trans _,
  simp only [this, -fintype.univ_Prop, bernoulli', finset.mem_filter, finset.mem_univ, true_and,
    finset.mem_disj_Union, tsub_le_self, eq_iff_iff, finset.sum_singleton, with_top.coe_sub,
    ennreal.coe_one],
  congr' 1 with p,
  rw ennreal.sub_sub_cancel with_top.one_ne_top (ennreal.coe_le_coe.2 hp),
  split_ifs; refl,
end

end bernoulli
end pmf


import GMLAlgebra.Basic
import GMLAlgebra.Group
import GMLAlgebra.Reflect.CommMonoid

namespace Algebra.CommGroup
open Algebra

inductive Expr {α : Type _} : List α → Type _
| nil : Expr []
| cons (n : Int) {x : α} {xs : List α} : Expr xs → Expr (x :: xs)

namespace Expr

instance instDecidableEq {α} : {xs : List α} → DecidableEq (Expr xs)
| [], nil, nil => Decidable.isTrue rfl
| _::_, cons m a, cons n b =>
  match instDecidableEq a b, inferDecidable (m = n) with
  | isTrue rfl, isTrue rfl => isTrue rfl
  | isFalse h, _ => isFalse fun | rfl => h rfl
  | _, isFalse h => isFalse fun | rfl => h rfl

abbrev lift {α} (x : α) {xs : List α} : Expr xs → Expr (x :: xs) := cons 0

protected def id {α} : {xs : List α} → Expr xs
| [] => nil
| _::_ => cons 0 Expr.id

protected def inv {α} : {xs : List α} → Expr xs → Expr xs
| [], _ => nil
| _::_, cons n a => cons (-n) (Expr.inv a)

protected def op {α} : {xs : List α} → Expr xs → Expr xs → Expr xs
| [], _, _ => nil
| _::_, cons m a, cons n b => cons (m + n) (Expr.op a b)

def mk {α} : {xs : List α} → CommMonoid.Expr xs → CommMonoid.Expr xs → Expr xs
| [], .nil, .nil => nil
| _::_, .cons m a, .cons n b => cons (Int.mk m n) (mk a b)

def split {α} : {xs : List α} → Expr xs → CommMonoid.Expr xs × CommMonoid.Expr xs
| [], _ => (.nil,.nil)
| _::_, cons m a =>
  match m, split a with
  | .ofNat m, (ap, an) => (.cons m ap, .cons 0 an)
  | .negSucc m, (ap, an) => (.cons 0 ap, .cons (m+1) an)

theorem inv_mk {α} {xs : List α} (a b : CommMonoid.Expr xs) : .inv (mk a b) = mk b a := by
  induction xs with
  | nil =>
    match a, b with
    | .nil, .nil => rfl
  | cons x xs ih =>
    match a, b with
    | .cons m a, .cons n b =>
      rw [Expr.mk]
      rw [Expr.mk]
      rw [Expr.inv]
      rw [Int.neg_mk]
      rw [ih]

theorem mk_op_mk {α} {xs : List α} (a₁ b₁ a₂ b₂ : CommMonoid.Expr xs) : .op (mk a₁ b₁) (mk a₂ b₂) = mk (.op a₁ a₂) (.op b₁ b₂) := by
  induction xs with
  | nil =>
    match a₁, a₂, b₁, b₂ with
    | .nil, .nil, .nil, .nil => rfl
  | cons x xs ih =>
    match a₁, a₂, b₁, b₂ with
    | .cons m₁ a₁, .cons m₂ a₂, .cons n₁ b₁, .cons n₂ b₂ =>
      rw [Expr.mk]
      rw [CommMonoid.Expr.op]
      rw [CommMonoid.Expr.op]
      rw [Expr.mk]
      rw [Expr.mk]
      rw [Expr.op]
      rw [Int.mk_add_mk]
      rw [ih]

theorem mk_split {α} {xs : List α} (a : Expr xs) : mk a.split.fst a.split.snd = a := by
  induction xs with
  | nil =>
    match a with
    | .nil => rfl
  | cons x xs ih =>
    match a with
    | .cons (.ofNat n) a =>
      rw [split]
      rw [Expr.mk]
      rw [Int.mk_zero]
      rw [ih]
    | .cons (.negSucc n) a =>
      rw [split]
      rw [Expr.mk]
      rw [Int.zero_mk_succ]
      rw [ih]

section Eval
variable {α} (s : GroupSig α)

def eval {xs : List α} (a : Expr xs) : α :=
  match a.split with
  | (ap, an) => s.op (ap.eval s.toMonoidSig) (s.inv (an.eval s.toMonoidSig))

variable [CommGroup s]

@[simp] theorem eval_cons_zero {x : α} {xs : List α} (a : Expr xs) : eval s (Expr.cons (x:=x) 0 a) = eval s a := by
  simp only [eval, split]
  match a.split with
  | (ap, an) =>
    rw [CommMonoid.Expr.eval_cons_zero]
    rw [CommMonoid.Expr.eval_cons_zero]

@[simp] theorem eval_cons_one {x : α} {xs : List α} (a : Expr xs) : eval s (Expr.cons (x:=x) 1 a) = s.op x (eval s a) := by
  simp only [eval, split]
  match a.split with
  | (ap, an) =>
    rw [CommMonoid.Expr.eval_cons_zero]
    rw [CommMonoid.Expr.eval_cons_succ]
    rw [CommMonoid.Expr.eval_cons_zero]
    rw [Algebra.op_assoc s.op]

@[simp] theorem eval_cons_pos_succ {x : α} {xs : List α} (a : Expr xs) (n : Nat) : eval s (Expr.cons (x:=x) (Int.ofNat (n+1)) a) = s.op x (eval s (cons (x:=x) (Int.ofNat n) a)) := by
  simp only [eval, split]
  match a.split with
  | (ap, an) =>
    rw [CommMonoid.Expr.eval_cons_succ]
    rw [Algebra.op_assoc s.op]

@[simp] theorem eval_cons_neg_succ {x : α} {xs : List α} (a : Expr xs) (n : Nat) : eval s (Expr.cons (x:=x) (Int.negSucc n) a) = s.op (s.inv x) (eval s (cons (x:=x) (Int.negOfNat n) a)) := by
  simp only [eval, split, Int.negOfNat]
  match a.split, n with
  | (ap, an), 0 =>
    rw [CommMonoid.Expr.eval_cons_succ]
    rw [Algebra.inv_hom s.inv]
    rw [Algebra.op_left_comm s.op]
  | (ap, an), Nat.succ n =>
    rw [CommMonoid.Expr.eval_cons_succ]
    rw [Algebra.inv_hom s.inv]
    rw [Algebra.op_left_comm s.op]

theorem eval_mk {xs : List α} (a b : CommMonoid.Expr xs) : eval s (mk a b) = s.op (a.eval s.toMonoidSig) (s.inv (b.eval s.toMonoidSig)) := by
  induction xs with
  | nil =>
    match a, b with
    | .nil, .nil => rfl
  | cons x xs ih =>
    match a, b with
    | .cons m a, .cons n b =>
      induction m, n using Nat.recDiagOn with
      | zero_zero =>
        unfold Expr.mk
        rw [CommMonoid.Expr.eval_cons_zero]
        rw [Int.zero_mk_zero, eval_cons_zero]
        rw [ih]
        rw [CommMonoid.Expr.eval_cons_zero]
      | zero_succ n ih' =>
        unfold Expr.mk at ih' ⊢
        rw [CommMonoid.Expr.eval_cons_succ]
        rw [CommMonoid.Expr.eval_cons_zero]
        rw [Int.zero_mk_succ, eval_cons_neg_succ]
        rw [←Int.zero_mk n, ih']
        rw [CommMonoid.Expr.eval_cons_zero]
        rw [Algebra.inv_hom s.inv]
        rw [Algebra.op_left_comm s.op]
      | succ_zero m ih' =>
        unfold Expr.mk at ih' ⊢
        rw [CommMonoid.Expr.eval_cons_succ]
        rw [CommMonoid.Expr.eval_cons_zero]
        rw [Int.succ_mk_zero, eval_cons_pos_succ]
        rw [←Int.mk_zero m, ih']
        rw [CommMonoid.Expr.eval_cons_zero]
        rw [Algebra.op_assoc s.op]
      | succ_succ m n ih' =>
        unfold Expr.mk at ih' ⊢
        rw [CommMonoid.Expr.eval_cons_succ]
        rw [CommMonoid.Expr.eval_cons_succ]
        rw [Int.succ_mk_succ, ih']
        rw [Algebra.inv_hom s.inv]
        rw [Algebra.op_cross_comm s.op]
        rw [Algebra.op_right_inv s.op]
        rw [Algebra.op_left_id s.op]

theorem eval_lift {x : α} {xs : List α} (a : Expr xs) : eval s (Expr.lift x a) = eval s a := by
  rw [eval_cons_zero]

theorem eval_id : ∀ {xs : List α}, eval s (Expr.id (xs:=xs)) = s.id
| [] => by
  unfold Expr.id eval split; clean
  rw [Algebra.op_right_inv s.op]
| _::_ => by
  unfold Expr.id
  rw [eval_cons_zero]
  rw [eval_id]

theorem eval_inv {xs : List α}  (a : Expr xs) : eval s (Expr.inv a) = s.inv (eval s a) := by
  rw [←mk_split a]
  rw [inv_mk]
  rw [eval_mk]
  rw [eval_mk]
  rw [Algebra.inv_op s.inv]
  rw [Algebra.inv_invol s.inv]

@[simp] theorem eval_op {xs : List α} (a b : Expr xs) : eval s (Expr.op a b) = s.op (eval s a) (eval s b) := by
  rw [←mk_split a, ←mk_split b]
  rw [mk_op_mk]
  rw [eval_mk]
  rw [eval_mk]
  rw [eval_mk]
  rw [CommMonoid.Expr.eval_op]
  rw [CommMonoid.Expr.eval_op]
  rw [Algebra.op_cross_comm s.op]
  rw [Algebra.inv_hom s.inv]

end Eval

section Completeness

theorem op_assoc {α} : ∀ {xs : List α} (a b c : Expr xs), Expr.op (Expr.op a b) c = Expr.op a (Expr.op b c)
| [], _, _, _ => by unfold Expr.op; rfl
| _::_, cons l a, cons m b, cons n c => by simp only [Expr.op, Int.add_assoc l m n, op_assoc a b c]

theorem op_comm {α} : ∀ {xs : List α} (a b : Expr xs), Expr.op a b = Expr.op b a
| [], _, _ => by unfold Expr.op; rfl
| _::_, cons m a, cons n b => by simp only [Expr.op, Int.add_comm m n, op_comm a b]

theorem op_right_id {α} : ∀ {xs : List α} (a : Expr xs), Expr.op a Expr.id = a
| [], nil => by unfold Expr.op; rfl
| _::_, cons n a => by simp only [Expr.op, Int.add_zero n, op_right_id a]

theorem op_right_inv {α} : ∀ {xs : List α} (a : Expr xs), Expr.op a (Expr.inv a) = Expr.id
| [], nil => by unfold Expr.op; rfl
| _::_, cons n a => by simp only [Expr.op, Expr.id, Int.add_neg_self_right, op_right_inv a]

def sig {α} (xs : List α) : GroupSig (Expr xs) where
  op := Expr.op
  id := Expr.id
  inv := Expr.inv

instance {α} (xs : List α) : CommGroup (sig xs) where
  op_assoc := op_assoc
  op_comm := op_comm
  op_right_id := op_right_id
  op_right_inv := op_right_inv

end Completeness

end Expr

class Reflect {α} (s : GroupSig α) (x : α) (xs : List α) where
  expr : Expr xs
  eval_eq : expr.eval s = x

protected def Reflect.eq {α} (s : GroupSig α) (x xs) [inst : Reflect s x xs] : inst.expr.eval s = x := inst.eval_eq

namespace Reflect
variable {α} (s : GroupSig α) [CommGroup s]

class Var (x : α) (xs : List α) extends Reflect s x xs

instance (priority:=low) instVarLift (x y : α) (xs : List α) [Var s y xs] : Var s y (x :: xs) where
  expr := Expr.lift x (expr s y)
  eval_eq := by simp [eval_eq]

instance instVarSelf (x : α) (xs : List α) : Var s x (x :: xs) where
  expr := Expr.cons 1 Expr.id
  eval_eq := by rw [Expr.eval_cons_one, Expr.eval_id, Algebra.op_right_id s.op]

instance instOp (x y : α) {xs : List α} [Reflect s x xs] [Reflect s y xs] : Reflect s (no_index (s.op x y)) xs where
  expr := Expr.op (expr s x) (expr s y)
  eval_eq := by simp [eval_eq]

instance instInv (x : α) {xs : List α} [Reflect s x xs] : Reflect s (no_index (s.inv x)) xs where
  expr := Expr.inv (expr s x)
  eval_eq := by rw [Expr.eval_inv, eval_eq]

instance instId {xs : List α} : Reflect s (no_index (s.id)) xs where
  expr := Expr.id
  eval_eq := by rw [Expr.eval_id]

end Reflect

theorem reflect {α} (s : GroupSig α) [CommGroup s] (xs : List α) {a b : α} [Reflect s a xs] [Reflect s b xs] : Reflect.expr s a (xs:=xs) = Reflect.expr s b → a = b := by
  intro h
  rw [←Reflect.eq s a xs, ←Reflect.eq s b xs, h]

end Algebra.CommGroup


import GMLAlgebra.Basic
import GMLAlgebra.Category

namespace Algebra
variable {α} {β : α → α → Sort _}

class Groupoid (s : GroupoidSig β) : Prop where
  protected dop_assoc {{a b c d}} (x : β c d) (y : β b c) (z : β a b) : s.op (s.op x y) z = s.op x (s.op y z)
  protected dop_right_id {{a b}} (x : β a b) : s.op x s.id = x
  protected dop_right_inv {{a b}} (x : β a b) : s.op x (s.inv x) = s.id

protected def Groupoid.infer (s : GroupoidSig β) [DOpAssoc s.op] [DOpRightId s.op s.id] [DOpRightInv s.op s.inv s.id] : Groupoid s where
  dop_assoc := dop_assoc _
  dop_right_id := dop_right_id _
  dop_right_inv := dop_right_inv _

namespace Groupoid
variable {s : GroupoidSig β} [Groupoid s]

local infixr:60 " ⋆ " => s.op
local postfix:max "⁻¹" => s.inv
local notation "e" => s.id

local instance : DOpAssoc (no_index s.op) := ⟨Groupoid.dop_assoc⟩
local instance : DOpRightId (no_index s.op) (no_index s.id) := ⟨Groupoid.dop_right_id⟩
instance : DOpRightInv (no_index s.op) (no_index s.inv) (no_index s.id) := ⟨Groupoid.dop_right_inv⟩

protected theorem dop_right_cancel {{a b c}} (x : β a b) {y z : β b c} (h : s.op y x = s.op z x) : y = z := calc
  _ = y ⋆ e := by rw [dop_right_id s.op]
  _ = y ⋆ (x ⋆ x⁻¹) := by rw [dop_right_inv s.op]
  _ = (y ⋆ x) ⋆ x⁻¹ := by rw [dop_assoc s.op]
  _ = (z ⋆ x) ⋆ x⁻¹ := by rw [h]
  _ = z ⋆ (x ⋆ x⁻¹) := by rw [dop_assoc s.op]
  _ = z ⋆ e := by rw [dop_right_inv s.op]
  _ = z := by rw [dop_right_id s.op]
local instance : DOpRightCancel (no_index s.op) := ⟨Groupoid.dop_right_cancel⟩

protected theorem dop_left_id {{a b}} (x : β a b) : e ⋆ x = x :=
  dop_right_cancel s.op x⁻¹ $ calc
  _ = e ⋆ (x ⋆ x⁻¹) := by rw [dop_assoc s.op]
  _ = e ⋆ e := by rw [dop_right_inv s.op]
  _ = e := by rw [dop_right_id s.op]
  _ = x ⋆ x⁻¹ := by rw [dop_right_inv s.op]
local instance : DOpLeftId (no_index s.op) (no_index s.id) := ⟨Groupoid.dop_left_id⟩

protected theorem dop_left_inv {{a b}} (x : β a b) : x⁻¹ ⋆ x = e :=
  dop_right_cancel s.op x⁻¹ $ calc
  _ = x⁻¹ ⋆ (x ⋆ x⁻¹) := by rw [dop_assoc s.op]
  _ = x⁻¹ ⋆ e := by rw [dop_right_inv s.op]
  _ = x⁻¹ := by rw [dop_right_id s.op]
  _ = e ⋆ x⁻¹ := by rw [dop_left_id s.op]
instance : DOpLeftInv (no_index s.op) (no_index s.inv) (no_index s.id) := ⟨Groupoid.dop_left_inv⟩

protected theorem dop_left_cancel {{a b c}} (x : β b c) {y z : β a b} (h : x ⋆ y = x ⋆ z) : y = z := calc
  _ = e ⋆ y := by rw [dop_left_id s.op]
  _ = (x⁻¹ ⋆ x) ⋆ y := by rw [dop_left_inv s.op]
  _ = x⁻¹ ⋆ (x ⋆ y) := by rw [dop_assoc s.op]
  _ = x⁻¹ ⋆ (x ⋆ z) := by rw [h]
  _ = (x⁻¹ ⋆ x) ⋆ z := by rw [dop_assoc s.op]
  _ = e ⋆ z := by rw [dop_left_inv s.op]
  _ = z := by rw [dop_left_id s.op]
local instance : DOpLeftCancel (no_index s.op) := ⟨Groupoid.dop_left_cancel⟩

protected theorem dinv_op {{a b c}} (x : β a b) (y : β c a) : (x ⋆ y)⁻¹ = y⁻¹ ⋆ x⁻¹ :=
  dop_right_cancel s.op (x ⋆ y) $ calc
  _ = e := by rw [←dop_left_inv s.op (x ⋆ y)]
  _ = y⁻¹ ⋆ y := by rw [dop_left_inv s.op y]
  _ = y⁻¹ ⋆ (e ⋆ y) := by rw [dop_left_id s.op y]
  _ = y⁻¹ ⋆ (x⁻¹ ⋆ x) ⋆ y := by rw [dop_left_inv s.op x]
  _ = y⁻¹ ⋆ x⁻¹ ⋆ (x ⋆ y) := by rw [dop_assoc s.op x⁻¹ x y]
  _ = (y⁻¹ ⋆ x⁻¹) ⋆ (x ⋆ y) := by rw [dop_assoc s.op y⁻¹ x⁻¹ (x ⋆ y)]
instance : DInvOp (no_index s.inv) (no_index s.op) := ⟨Groupoid.dinv_op⟩

protected theorem dinv_invol {{a b}} (x : β a b) : x⁻¹⁻¹ = x :=
  dop_right_cancel s.op x⁻¹ $ calc
  _ = e := by rw [←dop_left_inv s.op x⁻¹]
  _ = x ⋆ x⁻¹ := by rw [dop_right_inv s.op x]
instance : DInvInvol (no_index s.inv) := ⟨Groupoid.dinv_invol⟩

protected theorem dinv_id {{a}} : (e : β a a)⁻¹ = e :=
  dop_right_cancel s.op e $ show e⁻¹ ⋆ e = e ⋆ e from calc
  _ = e := by rw [dop_left_inv s.op e]
  _ = e ⋆ e := by rw [dop_right_id s.op e]
instance : DInvId (no_index s.inv) (no_index s.id) := ⟨Groupoid.dinv_id⟩

instance : CancelCategory (no_index s.toCategorySig) := CancelCategory.infer _

end Groupoid

end Algebra