import .distance
import .definitions
import .gcd
import .nat_extra
import .list_extra
import .decidable_relations

namespace nt

/-
Uniqueness is subtle as always. Most proofs of this I saw come in one of two flavors:
  (i) Assume two different (distinct) pairs and derive a contradiction
  (ii) Show that -1 < difference < 1 and conclude that there is no difference
       (because the numbers in question must be integers)
I chose the second approach here, but I wanted to avoid talking about integers (this
would require pulling in the whole ℤ library and setting up some possibly messy
correspondences between ℕ and ℤ). So instead, I modified approach (ii) to use
distances instead of differences; the whole argument goes through and we completely
avoid talking about negative numbers. The tradeoff is that we need to develop some
theory about the distance function (see .distance).
-/
lemma division (m n : ℕ) (h: m > 0) : ∃!k : ℕ, ∃!r : ℕ, n = m*k + r ∧ r < m :=
begin
apply exists_unique.intro (n/m),
{ apply exists_unique.intro (n%m),
  { apply and.intro,
    { simp [nat.mod_add_div n m] },
    { exact nat.mod_lt n h }
  },
  { intro r', intro hr',
    have : m*(n/m) + (n%m) = m*(n/m) + r', from
    calc m*(n/m) + (n%m) = n             : by simp [nat.mod_add_div n m]
                    ...  = m*(n/m) + r'  : by rw [←(and.left hr')],
    show r' = n%m, by simp [add_left_cancel this]
  }
},
{
  intro k', intro he, apply exists_unique.elim he,
  intro r', intro hnrk, intro ha,
  have hdiv : m*(n/m) + (n%m) = n, by simp [nat.mod_add_div n m],

  -- why did I need to write this out where the hnrk rearrangement just works below?
  have hrearrange : n - (n%m) = m*(n/m), from
  calc n - (n%m) = m*(n/m) + (n%m) - (n%m) : by rw [hdiv]
             ... = m*(n/m)                 : by simp only [nat.add_sub_cancel],

  -- again, why is hdiv more of a pain to deal with than hnrk?
  have hrln : r' ≤ n, from
    have r' + m*k' = n, by simp [hnrk.left],
    nat.le.intro (this),
  have hnmln : n%m ≤ n, from
    have m*(n/m) + n%m = n, by simp [hdiv],
    have n%m + m*(n/m) = n, by rw [nat.add_comm, this],
    nat.le.intro (this),

  have : dist (m*k') (m*(n/m)) < 1*m, from
  calc dist (m*k') (m*(n/m)) = dist (n - r') (m*(n/m))   : by rw [hnrk.left]; simp only [nat.add_sub_cancel]
                         ... = dist (n - r') (n - (n%m)) : by rw [hrearrange]
                         ... = dist r' (n%m)             : dist_cancel_sub hrln hnmln
                         ... < m                         : bounded_dist hnrk.right (nat.mod_lt n h)
                         ... = 1*m                       : eq.symm (one_mul m),

  have hbound : (dist (m*k') (m*(n/m)))/m < 1, from
    (iff.elim_right (nat.div_lt_iff_lt_mul (dist (m*k') (m*(n/m))) 1 h)) this,

  have hmul : dist (m*k') (m*(n/m)) = m * dist k' (n/m),
    by repeat { rw [mul_comm m] }; from dist_mul k' (n/m) m,

  have : dist k' (n/m) < 1, from
  calc dist k' (n/m) = (m * dist k' (n/m)) / m     : by rw [nat.mul_div_right (dist k' (n/m)) h]
                 ... = (dist (m*k') (m*(n/m))) / m : by rw [hmul]
                 ... < 1                           : hbound,

  have : dist k' (n/m) = 0, from nat.lt_one_zero (dist k' (n/m)) this,
  exact (dist_iden k' (n/m)).elim_left this
}
end

/-
Euclid's lemma irreducible p → prime p is used as a lemma to prove the
fundamental theorem of arithmetic in the traditional development. The
other direction also holds.
-/
lemma euclid (p : ℕ) : irreducible p ↔ prime p :=
begin
apply iff.intro,
{ intro h,
  have hi : irreducible p, from h,
  simp [irreducible] at h, simp [prime],
  by_cases (p = 0) with h0,
  { have : ¬p = 0, from h.right.left, contradiction },
  { by_cases (p = 1) with h1,
    { have : ¬p = 1, from h.left, contradiction },
    { apply and.intro, exact h1, apply and.intro, exact h0,
      have ha : ∀ (k : ℕ), k ∣ p → k = p ∨ k = 1, from h.right.right,
      intros, by_cases (m % p = 0) with hmp,
      { have : p ∣ m, by simp [nat.dvd_iff_mod_eq_zero]; exact hmp,
        apply or.intro_left, exact this
      },
      { have : ¬ p ∣ m, by simp [nat.dvd_iff_mod_eq_zero]; exact hmp,
        have hpdiv : p ∣ nat.gcd (p*n) (m*n), by simp [dvd_gcd nat.m_dvd_mn a],
        apply or.intro_right,
        have : nat.gcd (p*n) (m*n) = n, from calc
              nat.gcd (p*n) (m*n) = n * nat.gcd p m  : by simp [gcd_mul_right p n m]
                              ... = n                : by simp [p_not_dvd_coprime this hi],
        from this ▸ hpdiv
      }
    }
  }
},
{ intro hprime,
  have h : ∀ m n, (p ∣ m*n) → ((p ∣ m) ∨ (p ∣ n)), from and.elim_right (and.elim_right hprime),
  apply and.intro,
  { exact and.elim_left hprime },
  { apply and.intro,
    { exact and.elim_left (and.elim_right hprime) },
    { intro k, intro hkp, apply dvd.elim hkp,
      intro r, intro hrkp,
      have : r*k ≠ 0, by simp only [nat.mul_comm]; rw [←hrkp]; apply (and.left hprime),
      have nzrk : r ≠ 0 ∧ k ≠ 0, from nat.no_zero_divisors this,
      have hrgz : r > 0, from nat.pos_of_ne_zero (and.left nzrk),
      have hkgz : k > 0, from nat.pos_of_ne_zero (and.right nzrk),
      have : p ∣ r*k, from exists.intro 1 (by simp [hrkp]),
      apply or.elim (h r k this),
      { intro hpr, apply dvd.elim hpr, intro s, intro hspr,
        have : 1*r = (s*k)*r, from
        calc 1*r = r           : one_mul r
        ...     = s*p         : by simp [hspr,nat.mul_comm]
        ...     = s*(k*r)     : by simp [hrkp,nat.mul_comm]
        ...     = (s*k)*r     : eq.symm (nat.mul_assoc s k r),
        have : s*k = 1, from nat.eq_of_mul_eq_mul_right hrgz (eq.symm this),
        apply or.intro_left, exact and.right (nat.unique_unit this)
      },
      { intro hpk, apply dvd.elim hpk, intro s, intro hspk,
        have : 1*k = (s*r)*k, from
        calc 1*k = k           : one_mul k
        ...     = s*p         : by rw [hspk]; simp
        ...     = s*(r*k)     : by simp [hrkp]
        ...     = (s*r)*k     : eq.symm (nat.mul_assoc s r k),
        have : 1 = s*r, from nat.eq_of_mul_eq_mul_right hkgz this,
        have : s = 1, from and.left (nat.unique_unit (eq.symm this)),
        have : 1*p = k, by simp [this,hspk],
        apply or.intro_right, exact eq.symm (this ▸ eq.symm (nat.one_mul p))
      }
    }
  }
}
end

/-
Warm-up to FTA: existence of prime factorizations
-/

-- First we prove existence
lemma prime_factorization (n : ℕ) : n ≠ 0 → ∃ l : list ℕ, plist l = tt ∧ product l = n :=
begin
induction n using nat.case_strong_induction_on with n ih,
{
  intros; contradiction
},
{ cases n with n,
  { intro, apply exists.intro [], apply and.intro, simp [plist], simp [product] },
  { intro hmz,
    let m := nat.succ (nat.succ n),
    have hg1 : m ≠ 0 ∧ m ≠ 1, by { apply and.intro,
      { exact nat.succ_ne_zero (nat.succ n) },
      { exact λ k, nat.no_confusion k (λ k, nat.no_confusion k) }
    },
    -- this is the big excluded middle claim!
    -- we did all that legwork in .decidable_relations for this
    have h : irreducible m ∨ composite m, by {
      by_cases (is_composite m = tt) with hicm,
      { simp [computable_composite] at hicm,
        apply or.intro_right, assumption
      },
      { simp [computable_composite] at hicm,
        apply or.intro_left, exact (not_composite hg1).1 hicm
      }
    },
    apply or.elim h,
    { intro hm, apply exists.intro [m], apply and.intro,
      { simp [plist], exact to_bool_true hm },
      { simp [product] }
    },
    { intro hm',
      have hab : ∃ a : ℕ, ∃ b : ℕ, a ≠ 1 ∧ b ≠ 1 ∧ m = a*b, by
        delta composite at hm'; exact hm'.right,
      cases hab with a hab1, cases hab1 with b hprod,
      have hrl : ∃ rl, plist rl ∧ product rl = a, by {
        have han : a ≤ nat.succ n, by {
          have : a ∣ m, from dvd.intro b (eq.symm hprod.right.right),
          have haltm : a ≤ m, from nat.le_of_dvd (nat.pos_of_ne_zero hmz) this,
          have hanm : a ≠ m, by {
            -- can we abstract this logic out as a lemma?
            -- it appears again below and in not_composite
            by_cases (a = m) with ham,
            { have : m = m*b, by rw [ham] at hprod; exact hprod.right.right,
              have : m*1 = m*b, by simp; exact this,
              have : 1 = b, from nat.eq_of_mul_eq_mul_left (nat.pos_of_ne_zero hmz) this,
              from absurd (eq.symm this) hprod.right.left
            },
            { assumption }
          },
          from nat.le_ne_succ haltm hanm
        },
        have hanz : a ≠ 0, by {
          have : a*b = m, from eq.symm hprod.right.right,
          have : a*b ≠ 0, by rw [this]; exact hg1.left,
          apply (nat.no_zero_divisors this).left
        },
        apply ih a han hanz
      },
      have hsl : ∃ sl, plist sl ∧ product sl = b, by {
        -- this whole argument is almost copy-pasted from case above
        have hbn : b ≤ nat.succ n, by {
          have hmba : m = b*a, by simp [nat.mul_comm, hprod.right.right],
          have : b ∣ m, from dvd.intro a (eq.symm hmba),
          have haltm : b ≤ m, from nat.le_of_dvd (nat.pos_of_ne_zero hmz) this,
          have hanm : b ≠ m, by {
            by_cases (b = m) with hbm,
            { have : m = m*a, by rw [hbm] at hmba; exact hmba,
              have : m*1 = m*a, by simp; exact this,
              have : 1 = a, from nat.eq_of_mul_eq_mul_left (nat.pos_of_ne_zero hmz) this,
              from absurd (eq.symm this) hprod.left
            },
            { assumption }
          },
          from nat.le_ne_succ haltm hanm
        },
        have hbnz : b ≠ 0, by {
          have : a*b = m, from eq.symm hprod.right.right,
          have : a*b ≠ 0, by rw [this]; exact hg1.left,
          apply (nat.no_zero_divisors this).right
        },
        exact ih b hbn hbnz,
      },
      apply exists.elim hrl, intro rl, intro hrla,
      apply exists.elim hsl, intro sl, intro hslb,
      apply exists.intro (rl ++ sl), apply and.intro,
      { exact list.plist_concat rl sl (and.left hrla) (and.left hslb) },
      { rw [list.product_concat rl sl, and.right hrla, and.right hslb],
        exact eq.symm hprod.right.right
      }
    }
  }
}
end

/-
The Fundamental Theorem of Arithmetic
-/

-- the statement of this lemma is a bit obscure, the idea is that:
--   (1) if (prime) p divides a product of primes then it divides a term in that product (euclid for list)
--   (2) if the term in (1) is a prime, then p equals that term
--   (3) if the terms are sorted, then p must be no larger than the first term
lemma plist_lte
  {p q : ℕ}
  {t : list ℕ}
  (hp : irreducible p)
  (hq : irreducible q)
  (hd : p ∣ product (q :: t))
  (hl : plist t  = tt ∧ sorted (q :: t) = tt)
: p ≤ q :=
begin
  have pn1 : p ≠ 1, from hp.right.left,
  revert q, induction t with q' t' ih,
  { intro q, intro hq, intro hd, intro hl,
    simp [product] at hd, simp [irreducible] at hp,
    have : p = 1 ∨ p = q, from hq.right.right p hd,
    cases this,
    { contradiction },
    { exact nat.le_of_eq a }
  },
  { intro q, intro hq, intro hd, intro hl,
    have hd : p ∣ q * (q' * product t'), by simp [nat.mul_comm]; simp [product] at hd; exact hd,
    have hpp : prime p, by simp [euclid] at hp; exact hp,
    have : p ∣ q ∨ p ∣ q' * product t', by exact hpp.right.right q (q' * product t') hd,
    cases this,
    { have : p = 1 ∨ p = q, from hq.right.right p a,
      cases this,
      { contradiction },
      { exact nat.le_of_eq a_1 }
    },
    { have hqq' : q' ≤ q, from list.lmax_head hl.right,
      have hiq' : irreducible q', by simp [plist, computable_irreducible] at hl; exact of_to_bool_true hl.right.left,
      have hd' : p ∣ product (q' :: t'), by simp [product]; exact a,
      have hl' : plist t' = tt ∧ sorted (q' :: t') = tt,
      begin
        apply and.intro,
        { simp [plist] at hl, exact hl.left },
        { rw [sorted] at hl, simp at hl, exact hl.right.left }
      end,
      have : p ≤ q', from ih hiq' hd' hl',
      exact nat.le_trans this hqq'
    }
  }
end

theorem prime_uniqueness (n : ℕ) : n ≠ 0 → ∃! l : list ℕ,
  plist l = tt ∧ sorted l = tt ∧ product l = n :=
begin
intro hn,
have : ∃ l : list ℕ, plist l ∧ product l = n, from prime_factorization n hn,
apply exists.elim this, intro l, intro hl,
apply exists_unique.intro (list.insertion_sort l),
{ have : l ~ list.insertion_sort l, by symmetry; exact list.perm_insertion_sort l,
  apply and.intro,
  { exact list.perm_plist this hl.left },
  { apply and.intro,
    { exact list.sorted_insertion_sort l },
    { symmetry, rw [←hl.right], apply list.perm_product this }
  }
},
{
  revert l, induction n using nat.case_strong_induction_on with n ih,
  {
    contradiction
  },
  { simp at ih, intro l, intro hl, intro sl', intro hsl',

    -- seem to need to state these up-front so they get picked up when we move to cases later
    have hslprod : product (list.insertion_sort l) = product l,
      by apply list.perm_product; exact list.perm_insertion_sort l,
    have hslplist : plist (list.insertion_sort l) = tt,
    begin
      have : l ~ list.insertion_sort l, by symmetry; exact list.perm_insertion_sort l,
      exact list.perm_plist this hl.left
    end,
    have hslsorted : sorted (list.insertion_sort l) = tt, from list.sorted_insertion_sort l,

    cases (list.insertion_sort l) with p t,
    { simp [product] at hslprod, rw [←hslprod] at hl, rw [←hl.right] at hsl',
      exact list.plist_prod_one hsl'.left hsl'.right.right
    },
    { cases sl' with q t',
      { simp [product] at hsl', rw [←hsl'.right.right] at hl, rw [hl.right] at hslprod,
        exact eq.symm (list.plist_prod_one hslplist hslprod)
      },
      { have hiq : irreducible q, by simp [plist, computable_irreducible] at hsl'; exact of_to_bool_true hsl'.right.right.left,
        have hip : irreducible p, by simp [plist, computable_irreducible] at hslplist; exact of_to_bool_true hslplist.right,

        have hqd : q ∣ product (p :: t),
        begin
          have : product (q :: t') = nat.succ n, from hsl'.right.right,
          simp [product] at this,
          simp [hl.right] at hslprod, rw [hslprod],
          exact dvd.intro (product t') this
        end,
        have hpd : p ∣ product (q :: t'),
        begin
          simp [product,hl.right] at hslprod,
          rw [hsl'.right.right,←hslprod],
          exact dvd.intro (product t) (eq.refl (p * product t))
        end,

        have hpt : plist t = tt ∧ sorted (p :: t) = tt,
        begin
          apply and.intro,
          { simp [plist] at hslplist, exact hslplist.left },
          { exact hslsorted }
        end,
        have hqt' : plist t' = tt ∧ sorted (q :: t') = tt,
        begin
          apply and.intro,
          { simp [plist] at hsl', exact hsl'.left },
          { exact hsl'.right.left }
        end,

        have hplq: p ≤ q, from plist_lte hip hiq hpd hqt',
        have hqlp : q ≤ p, from plist_lte hiq hip hqd hpt,
        have hpq: p = q, from le_antisymm hplq hqlp,

        have : q * product t' = nat.succ n, by simp [product] at hsl'; exact hsl'.right.right,
        have ht' : product t' = nat.succ n / q,
          from eq.symm (nat.div_eq_of_eq_mul_right (nat.pos_of_ne_zero hiq.left) (eq.symm this)),

        have hprod : p * product t = nat.succ n, by simp [product] at hslprod; rw [hslprod]; exact hl.right,
        have ht : product t = nat.succ n / p,
          from eq.symm (nat.div_eq_of_eq_mul_right (nat.pos_of_ne_zero hip.left) (eq.symm hprod)),

        let m := product t,
        have handt : plist t = tt ∧ product t = m, by {apply and.intro, exact hpt.left, simp},
        have hst : sorted t = tt, by simp [sorted] at hpt; exact hpt.right.left,
        have handt' : plist t' = tt ∧ sorted t' = tt ∧ product t' = m,
        begin
          apply and.intro,
          { exact hqt'.left },
          { apply and.intro,
            { simp [sorted] at hsl', exact hsl'.left },
            { rw [ht',←hpq,←ht] }
          }
        end,
        have hmt : product t = m, by simp,
        have hmt': product t' = m, by rw [ht',←hpq,←ht],
        have hmnz : m ≠ 0, from list.plist_prod_nonzero handt.left,
        have hmltn : m ≤ n,
        begin
          suffices hmltn' : m < nat.succ n, from nat.le_of_lt_succ hmltn',
          rw [←hprod,←nat.one_mul m,hmt],
          have h1ltp : 1 < p,
          begin
            cases p with p,
            { have : q ≠ 0, from hiq.left, contradiction },
            { cases p with p,
              { have : q ≠ 1, from hiq.right.left, exact absurd (eq.symm hpq) this },
              { have : nat.succ p ≠ 0, from nat.succ_ne_zero p,
                have : 0 < nat.succ p, from nat.pos_of_ne_zero this,
                have : 1 + 0 < 1 + nat.succ p, from nat.add_lt_add_left this 1,
                simp [nat.one_add] at this, exact this
              }
            }
          end,
          have hmgt0: m > 0, from nat.pos_of_ne_zero hmnz,
          exact nat.mul_lt_mul_of_pos_right h1ltp hmgt0
        end,
        have hxl : ∃ (l : list ℕ), plist l ∧ product l = m, by existsi t; exact handt,
        have htt' : t = t',
        begin
          have : t' = list.insertion_sort t, from ih m hmltn hmnz hxl t handt t' handt',
          simp [list.idem_insertion_sort hst] at this, simp [this]
        end,
        rw [hpq, htt']
      }
    }
  }
}
end

end nt


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

! This file was ported from Lean 3 source module group_theory.perm.cycle.type
! leanprover-community/mathlib commit 47adfab39a11a072db552f47594bf8ed2cf8a722
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.GcdMonoid.Multiset
import Mathbin.Combinatorics.Partition
import Mathbin.Data.List.Rotate
import Mathbin.GroupTheory.Perm.Cycle.Basic
import Mathbin.RingTheory.Int.Basic
import Mathbin.Tactic.Linarith.Default

/-!
# Cycle Types

In this file we define the cycle type of a permutation.

## Main definitions

- `σ.cycle_type` where `σ` is a permutation of a `fintype`
- `σ.partition` where `σ` is a permutation of a `fintype`

## Main results

- `sum_cycle_type` : The sum of `σ.cycle_type` equals `σ.support.card`
- `lcm_cycle_type` : The lcm of `σ.cycle_type` equals `order_of σ`
- `is_conj_iff_cycle_type_eq` : Two permutations are conjugate if and only if they have the same
  cycle type.
- `exists_prime_order_of_dvd_card`: For every prime `p` dividing the order of a finite group `G`
  there exists an element of order `p` in `G`. This is known as Cauchy's theorem.
-/

namespace Equiv.Perm

open Equiv List Multiset

variable {α : Type _} [Fintype α]

section CycleType

variable [DecidableEq α]

/-- The cycle type of a permutation -/
def cycleType (σ : Perm α) : Multiset ℕ :=
  σ.cycleFactorsFinset.1.map (Finset.card ∘ support)
#align equiv.perm.cycle_type Equiv.Perm.cycleType

theorem cycleType_def (σ : Perm α) :
    σ.cycleType = σ.cycleFactorsFinset.1.map (Finset.card ∘ support) :=
  rfl
#align equiv.perm.cycle_type_def Equiv.Perm.cycleType_def

theorem cycleType_eq' {σ : Perm α} (s : Finset (Perm α)) (h1 : ∀ f : Perm α, f ∈ s → f.IsCycle)
    (h2 : (s : Set (Perm α)).Pairwise Disjoint)
    (h0 : s.noncommProd id (h2.imp fun _ _ => Disjoint.commute) = σ) :
    σ.cycleType = s.1.map (Finset.card ∘ support) :=
  by
  rw [cycle_type_def]
  congr
  rw [cycle_factors_finset_eq_finset]
  exact ⟨h1, h2, h0⟩
#align equiv.perm.cycle_type_eq' Equiv.Perm.cycleType_eq'

theorem cycleType_eq {σ : Perm α} (l : List (Perm α)) (h0 : l.Prod = σ)
    (h1 : ∀ σ : Perm α, σ ∈ l → σ.IsCycle) (h2 : l.Pairwise Disjoint) :
    σ.cycleType = l.map (Finset.card ∘ support) :=
  by
  have hl : l.nodup := nodup_of_pairwise_disjoint_cycles h1 h2
  rw [cycle_type_eq' l.to_finset]
  · simp [list.dedup_eq_self.mpr hl]
  · simpa using h1
  · simpa [hl] using h0
  · simpa [list.dedup_eq_self.mpr hl] using h2.forall disjoint.symmetric
#align equiv.perm.cycle_type_eq Equiv.Perm.cycleType_eq

theorem cycleType_one : (1 : Perm α).cycleType = 0 :=
  cycleType_eq [] rfl (fun _ => False.elim) Pairwise.nil
#align equiv.perm.cycle_type_one Equiv.Perm.cycleType_one

theorem cycleType_eq_zero {σ : Perm α} : σ.cycleType = 0 ↔ σ = 1 := by
  simp [cycle_type_def, cycle_factors_finset_eq_empty_iff]
#align equiv.perm.cycle_type_eq_zero Equiv.Perm.cycleType_eq_zero

theorem card_cycleType_eq_zero {σ : Perm α} : σ.cycleType.card = 0 ↔ σ = 1 := by
  rw [card_eq_zero, cycle_type_eq_zero]
#align equiv.perm.card_cycle_type_eq_zero Equiv.Perm.card_cycleType_eq_zero

theorem two_le_of_mem_cycleType {σ : Perm α} {n : ℕ} (h : n ∈ σ.cycleType) : 2 ≤ n :=
  by
  simp only [cycle_type_def, ← Finset.mem_def, Function.comp_apply, Multiset.mem_map,
    mem_cycle_factors_finset_iff] at h
  obtain ⟨_, ⟨hc, -⟩, rfl⟩ := h
  exact hc.two_le_card_support
#align equiv.perm.two_le_of_mem_cycle_type Equiv.Perm.two_le_of_mem_cycleType

theorem one_lt_of_mem_cycleType {σ : Perm α} {n : ℕ} (h : n ∈ σ.cycleType) : 1 < n :=
  two_le_of_mem_cycleType h
#align equiv.perm.one_lt_of_mem_cycle_type Equiv.Perm.one_lt_of_mem_cycleType

theorem IsCycle.cycleType {σ : Perm α} (hσ : IsCycle σ) : σ.cycleType = [σ.support.card] :=
  cycleType_eq [σ] (mul_one σ) (fun τ hτ => (congr_arg IsCycle (List.mem_singleton.mp hτ)).mpr hσ)
    (pairwise_singleton Disjoint σ)
#align equiv.perm.is_cycle.cycle_type Equiv.Perm.IsCycle.cycleType

theorem card_cycleType_eq_one {σ : Perm α} : σ.cycleType.card = 1 ↔ σ.IsCycle :=
  by
  rw [card_eq_one]
  simp_rw [cycle_type_def, Multiset.map_eq_singleton, ← Finset.singleton_val, Finset.val_inj,
    cycle_factors_finset_eq_singleton_iff]
  constructor
  · rintro ⟨_, _, ⟨h, -⟩, -⟩
    exact h
  · intro h
    use σ.support.card, σ
    simp [h]
#align equiv.perm.card_cycle_type_eq_one Equiv.Perm.card_cycleType_eq_one

theorem Disjoint.cycleType {σ τ : Perm α} (h : Disjoint σ τ) :
    (σ * τ).cycleType = σ.cycleType + τ.cycleType :=
  by
  rw [cycle_type_def, cycle_type_def, cycle_type_def, h.cycle_factors_finset_mul_eq_union, ←
    Multiset.map_add, Finset.union_val, multiset.add_eq_union_iff_disjoint.mpr _]
  exact Finset.disjoint_val.2 h.disjoint_cycle_factors_finset
#align equiv.perm.disjoint.cycle_type Equiv.Perm.Disjoint.cycleType

theorem cycleType_inv (σ : Perm α) : σ⁻¹.cycleType = σ.cycleType :=
  cycle_induction_on (fun τ : Perm α => τ⁻¹.cycleType = τ.cycleType) σ rfl
    (fun σ hσ => by rw [hσ.cycle_type, hσ.inv.cycle_type, support_inv]) fun σ τ hστ hc hσ hτ => by
    rw [mul_inv_rev, hστ.cycle_type, ← hσ, ← hτ, add_comm,
      disjoint.cycle_type fun x =>
        Or.imp (fun h : τ x = x => inv_eq_iff_eq.mpr h.symm)
          (fun h : σ x = x => inv_eq_iff_eq.mpr h.symm) (hστ x).symm]
#align equiv.perm.cycle_type_inv Equiv.Perm.cycleType_inv

theorem cycleType_conj {σ τ : Perm α} : (τ * σ * τ⁻¹).cycleType = σ.cycleType :=
  by
  revert τ
  apply cycle_induction_on _ σ
  · intro
    simp
  · intro σ hσ τ
    rw [hσ.cycle_type, hσ.conj.cycle_type, card_support_conj]
  · intro σ τ hd hc hσ hτ π
    rw [← conj_mul, hd.cycle_type, disjoint.cycle_type, hσ, hτ]
    intro a
    apply (hd (π⁻¹ a)).imp _ _ <;>
      · intro h
        rw [perm.mul_apply, perm.mul_apply, h, apply_inv_self]
#align equiv.perm.cycle_type_conj Equiv.Perm.cycleType_conj

theorem sum_cycleType (σ : Perm α) : σ.cycleType.Sum = σ.support.card :=
  cycle_induction_on (fun τ : Perm α => τ.cycleType.Sum = τ.support.card) σ
    (by rw [cycle_type_one, sum_zero, support_one, Finset.card_empty])
    (fun σ hσ => by rw [hσ.cycle_type, coe_sum, List.sum_singleton]) fun σ τ hστ hc hσ hτ => by
    rw [hστ.cycle_type, sum_add, hσ, hτ, hστ.card_support_mul]
#align equiv.perm.sum_cycle_type Equiv.Perm.sum_cycleType

theorem sign_of_cycle_type' (σ : Perm α) :
    sign σ = (σ.cycleType.map fun n => -(-1 : ℤˣ) ^ n).Prod :=
  cycle_induction_on (fun τ : Perm α => sign τ = (τ.cycleType.map fun n => -(-1 : ℤˣ) ^ n).Prod) σ
    (by rw [sign_one, cycle_type_one, Multiset.map_zero, prod_zero])
    (fun σ hσ => by
      rw [hσ.sign, hσ.cycle_type, coe_map, coe_prod, List.map_singleton, List.prod_singleton])
    fun σ τ hστ hc hσ hτ => by rw [sign_mul, hσ, hτ, hστ.cycle_type, Multiset.map_add, prod_add]
#align equiv.perm.sign_of_cycle_type' Equiv.Perm.sign_of_cycle_type'

theorem sign_of_cycleType (f : Perm α) :
    sign f = (-1 : ℤˣ) ^ (f.cycleType.Sum + f.cycleType.card) :=
  cycle_induction_on (fun f : Perm α => sign f = (-1 : ℤˣ) ^ (f.cycleType.Sum + f.cycleType.card)) f
    (-- base_one
    by rw [Equiv.Perm.cycleType_one, sign_one, Multiset.sum_zero, Multiset.card_zero, pow_zero])
    (-- base_cycles
    fun f hf => by
      rw [Equiv.Perm.IsCycle.cycleType hf, hf.sign, coe_sum, List.sum_cons, sum_nil, add_zero,
        coe_card, length_singleton, pow_add, pow_one, mul_comm, neg_mul,
        one_mul])-- induction_disjoint
  fun f g hfg hf Pf Pg => by
    rw [Equiv.Perm.Disjoint.cycleType hfg, Multiset.sum_add, Multiset.card_add, ← add_assoc,
      add_comm f.cycle_type.sum g.cycle_type.sum, add_assoc g.cycle_type.sum _ _,
      add_comm g.cycle_type.sum _, add_assoc, pow_add, ← Pf, ← Pg, Equiv.Perm.sign_mul]
#align equiv.perm.sign_of_cycle_type Equiv.Perm.sign_of_cycleType

theorem lcm_cycleType (σ : Perm α) : σ.cycleType.lcm = orderOf σ :=
  cycle_induction_on (fun τ : Perm α => τ.cycleType.lcm = orderOf τ) σ
    (by rw [cycle_type_one, lcm_zero, orderOf_one])
    (fun σ hσ => by rw [hσ.cycle_type, coe_singleton, lcm_singleton, hσ.order_of, normalize_eq])
    fun σ τ hστ hc hσ hτ => by rw [hστ.cycle_type, lcm_add, lcm_eq_nat_lcm, hστ.order_of, hσ, hτ]
#align equiv.perm.lcm_cycle_type Equiv.Perm.lcm_cycleType

theorem dvd_of_mem_cycleType {σ : Perm α} {n : ℕ} (h : n ∈ σ.cycleType) : n ∣ orderOf σ :=
  by
  rw [← lcm_cycle_type]
  exact dvd_lcm h
#align equiv.perm.dvd_of_mem_cycle_type Equiv.Perm.dvd_of_mem_cycleType

theorem orderOf_cycleOf_dvd_orderOf (f : Perm α) (x : α) : orderOf (cycleOf f x) ∣ orderOf f :=
  by
  by_cases hx : f x = x
  · rw [← cycle_of_eq_one_iff] at hx
    simp [hx]
  · refine' dvd_of_mem_cycle_type _
    rw [cycle_type, Multiset.mem_map]
    refine' ⟨f.cycle_of x, _, _⟩
    · rwa [← Finset.mem_def, cycle_of_mem_cycle_factors_finset_iff, mem_support]
    · simp [(is_cycle_cycle_of _ hx).orderOf]
#align equiv.perm.order_of_cycle_of_dvd_order_of Equiv.Perm.orderOf_cycleOf_dvd_orderOf

theorem two_dvd_card_support {σ : Perm α} (hσ : σ ^ 2 = 1) : 2 ∣ σ.support.card :=
  (congr_arg (Dvd.Dvd 2) σ.sum_cycleType).mp
    (Multiset.dvd_sum fun n hn => by
      rw [le_antisymm
          (Nat.le_of_dvd zero_lt_two <|
            (dvd_of_mem_cycle_type hn).trans <| orderOf_dvd_of_pow_eq_one hσ)
          (two_le_of_mem_cycle_type hn)])
#align equiv.perm.two_dvd_card_support Equiv.Perm.two_dvd_card_support

theorem cycleType_prime_order {σ : Perm α} (hσ : (orderOf σ).Prime) :
    ∃ n : ℕ, σ.cycleType = replicate (n + 1) (orderOf σ) :=
  by
  rw [eq_replicate_of_mem fun n hn =>
      or_iff_not_imp_left.mp (hσ.eq_one_or_self_of_dvd n (dvd_of_mem_cycle_type hn))
        (one_lt_of_mem_cycle_type hn).ne']
  use σ.cycle_type.card - 1
  rw [tsub_add_cancel_of_le]
  rw [Nat.succ_le_iff, pos_iff_ne_zero, Ne, card_cycle_type_eq_zero]
  intro H
  rw [H, orderOf_one] at hσ
  exact hσ.ne_one rfl
#align equiv.perm.cycle_type_prime_order Equiv.Perm.cycleType_prime_order

theorem isCycle_of_prime_order {σ : Perm α} (h1 : (orderOf σ).Prime)
    (h2 : σ.support.card < 2 * orderOf σ) : σ.IsCycle :=
  by
  obtain ⟨n, hn⟩ := cycle_type_prime_order h1
  rw [← σ.sum_cycle_type, hn, Multiset.sum_replicate, nsmul_eq_mul, Nat.cast_id,
    mul_lt_mul_right (orderOf_pos σ), Nat.succ_lt_succ_iff, Nat.lt_succ_iff, le_zero_iff] at h2
  rw [← card_cycle_type_eq_one, hn, card_replicate, h2]
#align equiv.perm.is_cycle_of_prime_order Equiv.Perm.isCycle_of_prime_order

theorem cycleType_le_of_mem_cycleFactorsFinset {f g : Perm α} (hf : f ∈ g.cycleFactorsFinset) :
    f.cycleType ≤ g.cycleType :=
  by
  rw [mem_cycle_factors_finset_iff] at hf
  rw [cycle_type_def, cycle_type_def, hf.left.cycle_factors_finset_eq_singleton]
  refine' map_le_map _
  simpa [← Finset.mem_def, mem_cycle_factors_finset_iff] using hf
#align equiv.perm.cycle_type_le_of_mem_cycle_factors_finset Equiv.Perm.cycleType_le_of_mem_cycleFactorsFinset

theorem cycleType_mul_mem_cycleFactorsFinset_eq_sub {f g : Perm α} (hf : f ∈ g.cycleFactorsFinset) :
    (g * f⁻¹).cycleType = g.cycleType - f.cycleType :=
  by
  suffices (g * f⁻¹).cycleType + f.cycle_type = g.cycle_type - f.cycle_type + f.cycle_type
    by
    rw [tsub_add_cancel_of_le (cycle_type_le_of_mem_cycle_factors_finset hf)] at this
    simp [← this]
  simp [← (disjoint_mul_inv_of_mem_cycle_factors_finset hf).cycleType,
    tsub_add_cancel_of_le (cycle_type_le_of_mem_cycle_factors_finset hf)]
#align equiv.perm.cycle_type_mul_mem_cycle_factors_finset_eq_sub Equiv.Perm.cycleType_mul_mem_cycleFactorsFinset_eq_sub

theorem isConj_of_cycleType_eq {σ τ : Perm α} (h : cycleType σ = cycleType τ) : IsConj σ τ :=
  by
  revert τ
  apply cycle_induction_on _ σ
  · intro τ h
    rw [cycle_type_one, eq_comm, cycle_type_eq_zero] at h
    rw [h]
  · intro σ hσ τ hστ
    have hτ := card_cycle_type_eq_one.2 hσ
    rw [hστ, card_cycle_type_eq_one] at hτ
    apply hσ.is_conj hτ
    rw [hσ.cycle_type, hτ.cycle_type, coe_eq_coe, singleton_perm] at hστ
    simp only [and_true_iff, eq_self_iff_true] at hστ
    exact hστ
  · intro σ τ hστ hσ h1 h2 π hπ
    rw [hστ.cycle_type] at hπ
    · have h : σ.support.card ∈ map (Finset.card ∘ perm.support) π.cycle_factors_finset.val := by
        simp [← cycle_type_def, ← hπ, hσ.cycle_type]
      obtain ⟨σ', hσ'l, hσ'⟩ := multiset.mem_map.mp h
      have key : IsConj (σ' * (π * σ'⁻¹)) π :=
        by
        rw [isConj_iff]
        use σ'⁻¹
        simp [mul_assoc]
      refine' IsConj.trans _ key
      have hs : σ.cycle_type = σ'.cycle_type :=
        by
        rw [← Finset.mem_def, mem_cycle_factors_finset_iff] at hσ'l
        rw [hσ.cycle_type, ← hσ', hσ'l.left.cycle_type]
      refine' hστ.is_conj_mul (h1 hs) (h2 _) _
      · rw [cycle_type_mul_mem_cycle_factors_finset_eq_sub, ← hπ, add_comm, hs,
          add_tsub_cancel_right]
        rwa [Finset.mem_def]
      · exact (disjoint_mul_inv_of_mem_cycle_factors_finset hσ'l).symm
#align equiv.perm.is_conj_of_cycle_type_eq Equiv.Perm.isConj_of_cycleType_eq

theorem isConj_iff_cycleType_eq {σ τ : Perm α} : IsConj σ τ ↔ σ.cycleType = τ.cycleType :=
  ⟨fun h => by
    obtain ⟨π, rfl⟩ := isConj_iff.1 h
    rw [cycle_type_conj], isConj_of_cycleType_eq⟩
#align equiv.perm.is_conj_iff_cycle_type_eq Equiv.Perm.isConj_iff_cycleType_eq

@[simp]
theorem cycleType_extendDomain {β : Type _} [Fintype β] [DecidableEq β] {p : β → Prop}
    [DecidablePred p] (f : α ≃ Subtype p) {g : Perm α} :
    cycleType (g.extendDomain f) = cycleType g :=
  by
  apply cycle_induction_on _ g
  · rw [extend_domain_one, cycle_type_one, cycle_type_one]
  · intro σ hσ
    rw [(hσ.extend_domain f).cycleType, hσ.cycle_type, card_support_extend_domain]
  · intro σ τ hd hc hσ hτ
    rw [hd.cycle_type, ← extend_domain_mul, (hd.extend_domain f).cycleType, hσ, hτ]
#align equiv.perm.cycle_type_extend_domain Equiv.Perm.cycleType_extendDomain

theorem cycleType_ofSubtype {p : α → Prop} [DecidablePred p] {g : Perm (Subtype p)} :
    cycleType g.ofSubtype = cycleType g :=
  cycleType_extendDomain (Equiv.refl (Subtype p))
#align equiv.perm.cycle_type_of_subtype Equiv.Perm.cycleType_ofSubtype

theorem mem_cycleType_iff {n : ℕ} {σ : Perm α} :
    n ∈ cycleType σ ↔ ∃ c τ : Perm α, σ = c * τ ∧ Disjoint c τ ∧ IsCycle c ∧ c.support.card = n :=
  by
  constructor
  · intro h
    obtain ⟨l, rfl, hlc, hld⟩ := trunc_cycle_factors σ
    rw [cycle_type_eq _ rfl hlc hld] at h
    obtain ⟨c, cl, rfl⟩ := List.exists_of_mem_map h
    rw [(List.perm_cons_erase cl).pairwise_iff fun _ _ hd => _] at hld
    swap
    · exact hd.symm
    refine' ⟨c, (l.erase c).Prod, _, _, hlc _ cl, rfl⟩
    ·
      rw [← List.prod_cons,
        (List.perm_cons_erase cl).symm.prod_eq' (hld.imp fun _ _ => disjoint.commute)]
    · exact disjoint_prod_right _ fun g => List.rel_of_pairwise_cons hld
  · rintro ⟨c, t, rfl, hd, hc, rfl⟩
    simp [hd.cycle_type, hc.cycle_type]
#align equiv.perm.mem_cycle_type_iff Equiv.Perm.mem_cycleType_iff

theorem le_card_support_of_mem_cycleType {n : ℕ} {σ : Perm α} (h : n ∈ cycleType σ) :
    n ≤ σ.support.card :=
  (le_sum_of_mem h).trans (le_of_eq σ.sum_cycleType)
#align equiv.perm.le_card_support_of_mem_cycle_type Equiv.Perm.le_card_support_of_mem_cycleType

theorem cycleType_of_card_le_mem_cycleType_add_two {n : ℕ} {g : Perm α}
    (hn2 : Fintype.card α < n + 2) (hng : n ∈ g.cycleType) : g.cycleType = {n} :=
  by
  obtain ⟨c, g', rfl, hd, hc, rfl⟩ := mem_cycle_type_iff.1 hng
  by_cases g'1 : g' = 1
  · rw [hd.cycle_type, hc.cycle_type, coe_singleton, g'1, cycle_type_one, add_zero]
  contrapose! hn2
  apply le_trans _ (c * g').support.card_le_univ
  rw [hd.card_support_mul]
  exact add_le_add_left (two_le_card_support_of_ne_one g'1) _
#align equiv.perm.cycle_type_of_card_le_mem_cycle_type_add_two Equiv.Perm.cycleType_of_card_le_mem_cycleType_add_two

end CycleType

theorem card_compl_support_modEq [DecidableEq α] {p n : ℕ} [hp : Fact p.Prime] {σ : Perm α}
    (hσ : σ ^ p ^ n = 1) : σ.supportᶜ.card ≡ Fintype.card α [MOD p] :=
  by
  rw [Nat.modEq_iff_dvd' σ.supportᶜ.card_le_univ, ← Finset.card_compl, compl_compl]
  refine' (congr_arg _ σ.sum_cycle_type).mp (Multiset.dvd_sum fun k hk => _)
  obtain ⟨m, -, hm⟩ := (Nat.dvd_prime_pow hp.out).mp (orderOf_dvd_of_pow_eq_one hσ)
  obtain ⟨l, -, rfl⟩ :=
    (Nat.dvd_prime_pow hp.out).mp ((congr_arg _ hm).mp (dvd_of_mem_cycle_type hk))
  exact dvd_pow_self _ fun h => (one_lt_of_mem_cycle_type hk).Ne <| by rw [h, pow_zero]
#align equiv.perm.card_compl_support_modeq Equiv.Perm.card_compl_support_modEq

theorem exists_fixed_point_of_prime {p n : ℕ} [hp : Fact p.Prime] (hα : ¬p ∣ Fintype.card α)
    {σ : Perm α} (hσ : σ ^ p ^ n = 1) : ∃ a : α, σ a = a := by
  classical
    contrapose! hα
    simp_rw [← mem_support] at hα
    exact
      nat.modeq_zero_iff_dvd.mp
        ((congr_arg _
              (finset.card_eq_zero.mpr (compl_eq_bot.mpr (finset.eq_univ_iff_forall.mpr hα)))).mp
          (card_compl_support_modeq hσ).symm)
#align equiv.perm.exists_fixed_point_of_prime Equiv.Perm.exists_fixed_point_of_prime

theorem exists_fixed_point_of_prime' {p n : ℕ} [hp : Fact p.Prime] (hα : p ∣ Fintype.card α)
    {σ : Perm α} (hσ : σ ^ p ^ n = 1) {a : α} (ha : σ a = a) : ∃ b : α, σ b = b ∧ b ≠ a := by
  classical
    have h : ∀ b : α, b ∈ σ.supportᶜ ↔ σ b = b := fun b => by
      rw [Finset.mem_compl, mem_support, Classical.not_not]
    obtain ⟨b, hb1, hb2⟩ :=
      Finset.exists_ne_of_one_lt_card
        (lt_of_lt_of_le hp.out.one_lt
          (Nat.le_of_dvd (finset.card_pos.mpr ⟨a, (h a).mpr ha⟩)
            (nat.modeq_zero_iff_dvd.mp
              ((card_compl_support_modeq hσ).trans (nat.modeq_zero_iff_dvd.mpr hα)))))
        a
    exact ⟨b, (h b).mp hb1, hb2⟩
#align equiv.perm.exists_fixed_point_of_prime' Equiv.Perm.exists_fixed_point_of_prime'

theorem isCycle_of_prime_order' {σ : Perm α} (h1 : (orderOf σ).Prime)
    (h2 : Fintype.card α < 2 * orderOf σ) : σ.IsCycle := by
  classical exact is_cycle_of_prime_order h1 (lt_of_le_of_lt σ.support.card_le_univ h2)
#align equiv.perm.is_cycle_of_prime_order' Equiv.Perm.isCycle_of_prime_order'

theorem isCycle_of_prime_order'' {σ : Perm α} (h1 : (Fintype.card α).Prime)
    (h2 : orderOf σ = Fintype.card α) : σ.IsCycle :=
  isCycle_of_prime_order' ((congr_arg Nat.Prime h2).mpr h1)
    (by
      classical
        rw [← one_mul (Fintype.card α), ← h2, mul_lt_mul_right (orderOf_pos σ)]
        exact one_lt_two)
#align equiv.perm.is_cycle_of_prime_order'' Equiv.Perm.isCycle_of_prime_order''

section Cauchy

variable (G : Type _) [Group G] (n : ℕ)

/-- The type of vectors with terms from `G`, length `n`, and product equal to `1:G`. -/
def vectorsProdEqOne : Set (Vector G n) :=
  { v | v.toList.Prod = 1 }
#align equiv.perm.vectors_prod_eq_one Equiv.Perm.vectorsProdEqOne

namespace VectorsProdEqOne

theorem mem_iff {n : ℕ} (v : Vector G n) : v ∈ vectorsProdEqOne G n ↔ v.toList.Prod = 1 :=
  Iff.rfl
#align equiv.perm.vectors_prod_eq_one.mem_iff Equiv.Perm.vectorsProdEqOne.mem_iff

theorem zero_eq : vectorsProdEqOne G 0 = {Vector.nil} :=
  Set.eq_singleton_iff_unique_mem.mpr ⟨Eq.refl (1 : G), fun v hv => v.eq_nil⟩
#align equiv.perm.vectors_prod_eq_one.zero_eq Equiv.Perm.vectorsProdEqOne.zero_eq

theorem one_eq : vectorsProdEqOne G 1 = {Vector.nil.cons 1} :=
  by
  simp_rw [Set.eq_singleton_iff_unique_mem, mem_iff, Vector.toList_singleton, List.prod_singleton,
    Vector.head_cons]
  exact ⟨rfl, fun v hv => v.cons_head_tail.symm.trans (congr_arg₂ Vector.cons hv v.tail.eq_nil)⟩
#align equiv.perm.vectors_prod_eq_one.one_eq Equiv.Perm.vectorsProdEqOne.one_eq

instance zeroUnique : Unique (vectorsProdEqOne G 0) :=
  by
  rw [zero_eq]
  exact Set.uniqueSingleton Vector.nil
#align equiv.perm.vectors_prod_eq_one.zero_unique Equiv.Perm.vectorsProdEqOne.zeroUnique

instance oneUnique : Unique (vectorsProdEqOne G 1) :=
  by
  rw [one_eq]
  exact Set.uniqueSingleton (vector.nil.cons 1)
#align equiv.perm.vectors_prod_eq_one.one_unique Equiv.Perm.vectorsProdEqOne.oneUnique

/-- Given a vector `v` of length `n`, make a vector of length `n + 1` whose product is `1`,
by appending the inverse of the product of `v`. -/
@[simps]
def vectorEquiv : Vector G n ≃ vectorsProdEqOne G (n + 1)
    where
  toFun v :=
    ⟨v.toList.Prod⁻¹ ::ᵥ v, by rw [mem_iff, Vector.toList_cons, List.prod_cons, inv_mul_self]⟩
  invFun v := v.1.tail
  left_inv v := v.tail_cons v.toList.Prod⁻¹
  right_inv v :=
    Subtype.ext
      ((congr_arg₂ Vector.cons
            (eq_inv_of_mul_eq_one_left
                (by
                  rw [← List.prod_cons, ← Vector.toList_cons, v.1.cons_head!_tail]
                  exact v.2)).symm
            rfl).trans
        v.1.cons_head!_tail)
#align equiv.perm.vectors_prod_eq_one.vector_equiv Equiv.Perm.vectorsProdEqOne.vectorEquiv

/-- Given a vector `v` of length `n` whose product is 1, make a vector of length `n - 1`,
by deleting the last entry of `v`. -/
def equivVector : vectorsProdEqOne G n ≃ Vector G (n - 1) :=
  ((vectorEquiv G (n - 1)).trans
      (if hn : n = 0 then
        show vectorsProdEqOne G (n - 1 + 1) ≃ vectorsProdEqOne G n
          by
          rw [hn]
          apply equiv_of_unique
      else by rw [tsub_add_cancel_of_le (Nat.pos_of_ne_zero hn).nat_succ_le])).symm
#align equiv.perm.vectors_prod_eq_one.equiv_vector Equiv.Perm.vectorsProdEqOne.equivVector

instance [Fintype G] : Fintype (vectorsProdEqOne G n) :=
  Fintype.ofEquiv (Vector G (n - 1)) (equivVector G n).symm

theorem card [Fintype G] : Fintype.card (vectorsProdEqOne G n) = Fintype.card G ^ (n - 1) :=
  (Fintype.card_congr (equivVector G n)).trans (card_vector (n - 1))
#align equiv.perm.vectors_prod_eq_one.card Equiv.Perm.vectorsProdEqOne.card

variable {G n} {g : G} (v : vectorsProdEqOne G n) (j k : ℕ)

/-- Rotate a vector whose product is 1. -/
def rotate : vectorsProdEqOne G n :=
  ⟨⟨_, (v.1.1.length_rotate k).trans v.1.2⟩, List.prod_rotate_eq_one_of_prod_eq_one v.2 k⟩
#align equiv.perm.vectors_prod_eq_one.rotate Equiv.Perm.vectorsProdEqOne.rotate

theorem rotate_zero : rotate v 0 = v :=
  Subtype.ext (Subtype.ext v.1.1.rotate_zero)
#align equiv.perm.vectors_prod_eq_one.rotate_zero Equiv.Perm.vectorsProdEqOne.rotate_zero

theorem rotate_rotate : rotate (rotate v j) k = rotate v (j + k) :=
  Subtype.ext (Subtype.ext (v.1.1.rotate_rotate j k))
#align equiv.perm.vectors_prod_eq_one.rotate_rotate Equiv.Perm.vectorsProdEqOne.rotate_rotate

theorem rotate_length : rotate v n = v :=
  Subtype.ext (Subtype.ext ((congr_arg _ v.1.2.symm).trans v.1.1.rotate_length))
#align equiv.perm.vectors_prod_eq_one.rotate_length Equiv.Perm.vectorsProdEqOne.rotate_length

end VectorsProdEqOne

/-- For every prime `p` dividing the order of a finite group `G` there exists an element of order
`p` in `G`. This is known as Cauchy's theorem. -/
theorem exists_prime_orderOf_dvd_card {G : Type _} [Group G] [Fintype G] (p : ℕ) [hp : Fact p.Prime]
    (hdvd : p ∣ Fintype.card G) : ∃ x : G, orderOf x = p :=
  by
  have hp' : p - 1 ≠ 0 := mt tsub_eq_zero_iff_le.mp (not_le_of_lt hp.out.one_lt)
  have Scard :=
    calc
      p ∣ Fintype.card G ^ (p - 1) := hdvd.trans (dvd_pow (dvd_refl _) hp')
      _ = Fintype.card (vectors_prod_eq_one G p) := (vectors_prod_eq_one.card G p).symm

  let f : ℕ → vectors_prod_eq_one G p → vectors_prod_eq_one G p := fun k v =>
    vectors_prod_eq_one.rotate v k
  have hf1 : ∀ v, f 0 v = v := vectors_prod_eq_one.rotate_zero
  have hf2 : ∀ j k v, f k (f j v) = f (j + k) v := fun j k v =>
    vectors_prod_eq_one.rotate_rotate v j k
  have hf3 : ∀ v, f p v = v := vectors_prod_eq_one.rotate_length
  let σ :=
    Equiv.mk (f 1) (f (p - 1)) (fun s => by rw [hf2, add_tsub_cancel_of_le hp.out.one_lt.le, hf3])
      fun s => by rw [hf2, tsub_add_cancel_of_le hp.out.one_lt.le, hf3]
  have hσ : ∀ k v, (σ ^ k) v = f k v := fun k v =>
    Nat.rec (hf1 v).symm (fun k hk => Eq.trans (congr_arg σ hk) (hf2 k 1 v)) k
  replace hσ : σ ^ p ^ 1 = 1 := perm.ext fun v => by rw [pow_one, hσ, hf3, one_apply]
  let v₀ : vectors_prod_eq_one G p :=
    ⟨Vector.replicate p 1, (List.prod_replicate p 1).trans (one_pow p)⟩
  have hv₀ : σ v₀ = v₀ := Subtype.ext (Subtype.ext (List.rotate_replicate (1 : G) p 1))
  obtain ⟨v, hv1, hv2⟩ := exists_fixed_point_of_prime' Scard hσ hv₀
  refine'
    Exists.imp (fun g hg => orderOf_eq_prime _ fun hg' => hv2 _)
      (list.rotate_one_eq_self_iff_eq_replicate.mp (subtype.ext_iff.mp (subtype.ext_iff.mp hv1)))
  · rw [← List.prod_replicate, ← v.1.2, ← hg, show v.val.val.prod = 1 from v.2]
  · rw [Subtype.ext_iff_val, Subtype.ext_iff_val, hg, hg', v.1.2]
    rfl
#align exists_prime_order_of_dvd_card exists_prime_orderOf_dvd_card

/-- For every prime `p` dividing the order of a finite additive group `G` there exists an element of
order `p` in `G`. This is the additive version of Cauchy's theorem. -/
theorem exists_prime_addOrderOf_dvd_card {G : Type _} [AddGroup G] [Fintype G] (p : ℕ)
    [hp : Fact p.Prime] (hdvd : p ∣ Fintype.card G) : ∃ x : G, addOrderOf x = p :=
  @exists_prime_orderOf_dvd_card (Multiplicative G) _ _ _ _ hdvd
#align exists_prime_add_order_of_dvd_card exists_prime_addOrderOf_dvd_card

attribute [to_additive exists_prime_addOrderOf_dvd_card] exists_prime_orderOf_dvd_card

end Cauchy

theorem subgroup_eq_top_of_swap_mem [DecidableEq α] {H : Subgroup (Perm α)}
    [d : DecidablePred (· ∈ H)] {τ : Perm α} (h0 : (Fintype.card α).Prime)
    (h1 : Fintype.card α ∣ Fintype.card H) (h2 : τ ∈ H) (h3 : IsSwap τ) : H = ⊤ :=
  by
  haveI : Fact (Fintype.card α).Prime := ⟨h0⟩
  obtain ⟨σ, hσ⟩ := exists_prime_orderOf_dvd_card (Fintype.card α) h1
  have hσ1 : orderOf (σ : perm α) = Fintype.card α := (orderOf_subgroup σ).trans hσ
  have hσ2 : is_cycle ↑σ := is_cycle_of_prime_order'' h0 hσ1
  have hσ3 : (σ : perm α).support = ⊤ :=
    Finset.eq_univ_of_card (σ : perm α).support (hσ2.order_of.symm.trans hσ1)
  have hσ4 : Subgroup.closure {↑σ, τ} = ⊤ := closure_prime_cycle_swap h0 hσ2 hσ3 h3
  rw [eq_top_iff, ← hσ4, Subgroup.closure_le, Set.insert_subset, Set.singleton_subset_iff]
  exact ⟨Subtype.mem σ, h2⟩
#align equiv.perm.subgroup_eq_top_of_swap_mem Equiv.Perm.subgroup_eq_top_of_swap_mem

section Partition

variable [DecidableEq α]

/-- The partition corresponding to a permutation -/
def partition (σ : Perm α) : (Fintype.card α).partitionₓ
    where
  parts := σ.cycleType + replicate (Fintype.card α - σ.support.card) 1
  parts_pos n hn := by
    cases' mem_add.mp hn with hn hn
    · exact zero_lt_one.trans (one_lt_of_mem_cycle_type hn)
    · exact lt_of_lt_of_le zero_lt_one (ge_of_eq (Multiset.eq_of_mem_replicate hn))
  parts_sum := by
    rw [sum_add, sum_cycle_type, Multiset.sum_replicate, nsmul_eq_mul, Nat.cast_id, mul_one,
      add_tsub_cancel_of_le σ.support.card_le_univ]
#align equiv.perm.partition Equiv.Perm.partition

theorem parts_partition {σ : Perm α} :
    σ.partitionₓ.parts = σ.cycleType + replicate (Fintype.card α - σ.support.card) 1 :=
  rfl
#align equiv.perm.parts_partition Equiv.Perm.parts_partition

theorem filter_parts_partition_eq_cycleType {σ : Perm α} :
    ((partition σ).parts.filterₓ fun n => 2 ≤ n) = σ.cycleType :=
  by
  rw [parts_partition, filter_add, Multiset.filter_eq_self.2 fun _ => two_le_of_mem_cycle_type,
    Multiset.filter_eq_nil.2 fun a h => _, add_zero]
  rw [Multiset.eq_of_mem_replicate h]
  decide
#align equiv.perm.filter_parts_partition_eq_cycle_type Equiv.Perm.filter_parts_partition_eq_cycleType

theorem partition_eq_of_isConj {σ τ : Perm α} : IsConj σ τ ↔ σ.partitionₓ = τ.partitionₓ :=
  by
  rw [is_conj_iff_cycle_type_eq]
  refine' ⟨fun h => _, fun h => _⟩
  ·
    rw [Nat.Partition.ext_iff, parts_partition, parts_partition, ← sum_cycle_type, ← sum_cycle_type,
      h]
  · rw [← filter_parts_partition_eq_cycle_type, ← filter_parts_partition_eq_cycle_type, h]
#align equiv.perm.partition_eq_of_is_conj Equiv.Perm.partition_eq_of_isConj

end Partition

/-!
### 3-cycles
-/

/-- A three-cycle is a cycle of length 3. -/
def IsThreeCycle [DecidableEq α] (σ : Perm α) : Prop :=
  σ.cycleType = {3}
#align equiv.perm.is_three_cycle Equiv.Perm.IsThreeCycle

namespace IsThreeCycle

variable [DecidableEq α] {σ : Perm α}

theorem cycleType (h : IsThreeCycle σ) : σ.cycleType = {3} :=
  h
#align equiv.perm.is_three_cycle.cycle_type Equiv.Perm.IsThreeCycle.cycleType

theorem card_support (h : IsThreeCycle σ) : σ.support.card = 3 := by
  rw [← sum_cycle_type, h.cycle_type, Multiset.sum_singleton]
#align equiv.perm.is_three_cycle.card_support Equiv.Perm.IsThreeCycle.card_support

theorem card_support_eq_three_iff : σ.support.card = 3 ↔ σ.IsThreeCycle :=
  by
  refine' ⟨fun h => _, is_three_cycle.card_support⟩
  by_cases h0 : σ.cycle_type = 0
  · rw [← sum_cycle_type, h0, sum_zero] at h
    exact (ne_of_lt zero_lt_three h).elim
  obtain ⟨n, hn⟩ := exists_mem_of_ne_zero h0
  by_cases h1 : σ.cycle_type.erase n = 0
  · rw [← sum_cycle_type, ← cons_erase hn, h1, cons_zero, Multiset.sum_singleton] at h
    rw [is_three_cycle, ← cons_erase hn, h1, h, ← cons_zero]
  obtain ⟨m, hm⟩ := exists_mem_of_ne_zero h1
  rw [← sum_cycle_type, ← cons_erase hn, ← cons_erase hm, Multiset.sum_cons, Multiset.sum_cons] at h
  -- TODO: linarith [...] should solve this directly
  have : ∀ {k}, 2 ≤ m → 2 ≤ n → n + (m + k) = 3 → False :=
    by
    intros
    linarith
  cases this (two_le_of_mem_cycle_type (mem_of_mem_erase hm)) (two_le_of_mem_cycle_type hn) h
#align card_support_eq_three_iff card_support_eq_three_iff

theorem isCycle (h : IsThreeCycle σ) : IsCycle σ := by
  rw [← card_cycle_type_eq_one, h.cycle_type, card_singleton]
#align equiv.perm.is_three_cycle.is_cycle Equiv.Perm.IsThreeCycle.isCycle

theorem sign (h : IsThreeCycle σ) : sign σ = 1 :=
  by
  rw [Equiv.Perm.sign_of_cycleType, h.cycle_type]
  rfl
#align equiv.perm.is_three_cycle.sign Equiv.Perm.IsThreeCycle.sign

theorem inv {f : Perm α} (h : IsThreeCycle f) : IsThreeCycle f⁻¹ := by
  rwa [is_three_cycle, cycle_type_inv]
#align equiv.perm.is_three_cycle.inv Equiv.Perm.IsThreeCycle.inv

@[simp]
theorem inv_iff {f : Perm α} : IsThreeCycle f⁻¹ ↔ IsThreeCycle f :=
  ⟨by
    rw [← inv_inv f]
    apply inv, inv⟩
#align equiv.perm.is_three_cycle.inv_iff Equiv.Perm.IsThreeCycle.inv_iff

theorem orderOf {g : Perm α} (ht : IsThreeCycle g) : orderOf g = 3 := by
  rw [← lcm_cycle_type, ht.cycle_type, Multiset.lcm_singleton, normalize_eq]
#align equiv.perm.is_three_cycle.order_of Equiv.Perm.IsThreeCycle.orderOf

theorem isThreeCycle_sq {g : Perm α} (ht : IsThreeCycle g) : IsThreeCycle (g * g) :=
  by
  rw [← pow_two, ← card_support_eq_three_iff, support_pow_coprime, ht.card_support]
  rw [ht.order_of, Nat.coprime_iff_gcd_eq_one]
  norm_num
#align equiv.perm.is_three_cycle.is_three_cycle_sq Equiv.Perm.IsThreeCycle.isThreeCycle_sq

end IsThreeCycle

section

variable [DecidableEq α]

theorem isThreeCycle_swap_mul_swap_same {a b c : α} (ab : a ≠ b) (ac : a ≠ c) (bc : b ≠ c) :
    IsThreeCycle (swap a b * swap a c) :=
  by
  suffices h : support (swap a b * swap a c) = {a, b, c}
  · rw [← card_support_eq_three_iff, h]
    simp [ab, ac, bc]
  apply le_antisymm ((support_mul_le _ _).trans fun x => _) fun x hx => _
  · simp [ab, ac, bc]
  · simp only [Finset.mem_insert, Finset.mem_singleton] at hx
    rw [mem_support]
    simp only [perm.coe_mul, Function.comp_apply, Ne.def]
    obtain rfl | rfl | rfl := hx
    · rw [swap_apply_left, swap_apply_of_ne_of_ne ac.symm bc.symm]
      exact ac.symm
    · rw [swap_apply_of_ne_of_ne ab.symm bc, swap_apply_right]
      exact ab
    · rw [swap_apply_right, swap_apply_left]
      exact bc
#align equiv.perm.is_three_cycle_swap_mul_swap_same Equiv.Perm.isThreeCycle_swap_mul_swap_same

open Subgroup

theorem swap_mul_swap_same_mem_closure_three_cycles {a b c : α} (ab : a ≠ b) (ac : a ≠ c) :
    swap a b * swap a c ∈ closure { σ : Perm α | IsThreeCycle σ } :=
  by
  by_cases bc : b = c
  · subst bc
    simp [one_mem]
  exact subset_closure (is_three_cycle_swap_mul_swap_same ab ac bc)
#align equiv.perm.swap_mul_swap_same_mem_closure_three_cycles Equiv.Perm.swap_mul_swap_same_mem_closure_three_cycles

theorem IsSwap.mul_mem_closure_three_cycles {σ τ : Perm α} (hσ : IsSwap σ) (hτ : IsSwap τ) :
    σ * τ ∈ closure { σ : Perm α | IsThreeCycle σ } :=
  by
  obtain ⟨a, b, ab, rfl⟩ := hσ
  obtain ⟨c, d, cd, rfl⟩ := hτ
  by_cases ac : a = c
  · subst ac
    exact swap_mul_swap_same_mem_closure_three_cycles ab cd
  have h' : swap a b * swap c d = swap a b * swap a c * (swap c a * swap c d) := by
    simp [swap_comm c a, mul_assoc]
  rw [h']
  exact
    mul_mem (swap_mul_swap_same_mem_closure_three_cycles ab ac)
      (swap_mul_swap_same_mem_closure_three_cycles (Ne.symm ac) cd)
#align equiv.perm.is_swap.mul_mem_closure_three_cycles Equiv.Perm.IsSwap.mul_mem_closure_three_cycles

end

end Equiv.Perm


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

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

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

## Main definitions

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

-/

noncomputable theory
open_locale big_operators classical affine

section affine_space'

variables (k : Type*) {V : Type*} {P : Type*} [field k] [add_comm_group V] [module k V]
          [affine_space V P]
variables {ι : Type*}
include V

open affine_subspace finite_dimensional module

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

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

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

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

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

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

variables {k}

/-- The `vector_span` of a finite subset of an affinely independent
family has dimension one less than its cardinality. -/
lemma finrank_vector_span_image_finset_of_affine_independent {p : ι → P}
  (hi : affine_independent k p) {s : finset ι} {n : ℕ} (hc : finset.card s = n + 1) :
  finrank k (vector_span k (p '' ↑s)) = n :=
begin
  have hi' := affine_independent_of_subset_affine_independent
    (affine_independent_set_of_affine_independent hi) (set.image_subset_range p ↑s),
  have hc' : fintype.card (p '' ↑s) = n + 1,
  { rwa [set.card_image_of_injective ↑s (injective_of_affine_independent hi), fintype.card_coe] },
  have hn : (p '' ↑s).nonempty,
  { simp [hc, ←finset.card_pos] },
  rcases hn with ⟨p₁, hp₁⟩,
  rw affine_independent_set_iff_linear_independent_vsub k hp₁ at hi',
  have hfr : (p '' ↑s \ {p₁}).finite := ((set.finite_mem_finset _).image _).subset
    (set.diff_subset _ _),
  haveI := hfr.fintype,
  have hf : set.finite ((λ (p : P), p -ᵥ p₁) '' (p '' ↑s \ {p₁})) := hfr.image _,
  haveI := hf.fintype,
  have hc : hf.to_finset.card = n,
  { rw [hf.card_to_finset,
        set.card_image_of_injective (p '' ↑s \ {p₁}) (vsub_left_injective _)],
    have hd : insert p₁ (p '' ↑s \ {p₁}) = p '' ↑s,
    { rw [set.insert_diff_singleton, set.insert_eq_of_mem hp₁] },
    have hc'' : fintype.card ↥(insert p₁ (p '' ↑s \ {p₁})) = n + 1,
    { convert hc' },
    rw set.card_insert (p '' ↑s \ {p₁}) (λ h, ((set.mem_diff p₁).2 h).2 rfl) at hc'',
    simpa using hc'' },
  rw [vector_span_eq_span_vsub_set_right_ne k hp₁, finrank_span_set_eq_card _ hi', ←hc],
  congr
end

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

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

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

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

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

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

/-- The `affine_span` of a finite affinely independent family whose
cardinality is one more than that of the finite-dimensional space is
`⊤`. -/
lemma affine_span_eq_top_of_affine_independent_of_card_eq_finrank_add_one [finite_dimensional k V]
  [fintype ι] {p : ι → P} (hi : affine_independent k p) (hc : fintype.card ι = finrank k V + 1) :
  affine_span k (set.range p) = ⊤ :=
begin
  rw [←finrank_top, ←direction_top k V P] at hc,
  exact affine_span_eq_of_le_of_affine_independent_of_card_eq_finrank_add_one hi le_top hc
end

variables (k)

/-- The `vector_span` of `n + 1` points in an indexed family has
dimension at most `n`. -/
lemma finrank_vector_span_image_finset_le (p : ι → P) (s : finset ι) {n : ℕ}
  (hc : finset.card s = n + 1) : finrank k (vector_span k (p '' ↑s)) ≤ n :=
begin
  have hn : (p '' ↑s).nonempty,
  { simp [hc, ←finset.card_pos] },
  rcases hn with ⟨p₁, hp₁⟩,
  rw [vector_span_eq_span_vsub_set_right_ne k hp₁],
  have hfp₁ : (p '' ↑s \ {p₁}).finite :=
    ((finset.finite_to_set _).image _).subset (set.diff_subset _ _),
  haveI := hfp₁.fintype,
  have hf : ((λ p, p -ᵥ p₁) '' (p '' ↑s \ {p₁})).finite := hfp₁.image _,
  haveI := hf.fintype,
  convert le_trans (finrank_span_le_card ((λ p, p -ᵥ p₁) '' (p '' ↑s \ {p₁}))) _,
  have hm : p₁ ∉ p '' ↑s \ {p₁}, by simp,
  haveI := set.fintype_insert' (p '' ↑s \ {p₁}) hm,
  rw [set.to_finset_card, set.card_image_of_injective (p '' ↑s \ {p₁}) (vsub_left_injective p₁),
      ←add_le_add_iff_right 1, ←set.card_fintype_insert' _ hm],
  have h : fintype.card (↑(s.image p) : set P) ≤ n + 1,
  { rw [fintype.card_coe, ←hc],
    exact finset.card_image_le },
  convert h,
  simp [hp₁]
end

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

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

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

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

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

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

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

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

variables (P)

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

variables {P}

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

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

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

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

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

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

end affine_space'


/-
Copyright (c) 2021 Kevin Buzzard. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Kevin Buzzard, Antoine Labelle

! This file was ported from Lean 3 source module algebra.module.projective
! leanprover-community/mathlib commit 405ea5cee7a7070ff8fb8dcb4cfb003532e34bce
! Please do not edit these lines, except to modify the commit id
! if you have ported upstream changes.
-/
import Mathbin.Algebra.Module.Basic
import Mathbin.LinearAlgebra.Finsupp
import Mathbin.LinearAlgebra.FreeModule.Basic

/-!

# Projective modules

This file contains a definition of a projective module, the proof that
our definition is equivalent to a lifting property, and the
proof that all free modules are projective.

## Main definitions

Let `R` be a ring (or a semiring) and let `M` be an `R`-module.

* `is_projective R M` : the proposition saying that `M` is a projective `R`-module.

## Main theorems

* `is_projective.lifting_property` : a map from a projective module can be lifted along
  a surjection.

* `is_projective.of_lifting_property` : If for all R-module surjections `A →ₗ B`, all
  maps `M →ₗ B` lift to `M →ₗ A`, then `M` is projective.

* `is_projective.of_free` : Free modules are projective

## Implementation notes

The actual definition of projective we use is that the natural R-module map
from the free R-module on the type M down to M splits. This is more convenient
than certain other definitions which involve quantifying over universes,
and also universe-polymorphic (the ring and module can be in different universes).

We require that the module sits in at least as high a universe as the ring:
without this, free modules don't even exist,
and it's unclear if projective modules are even a useful notion.

## References

https://en.wikipedia.org/wiki/Projective_module

## TODO

- Direct sum of two projective modules is projective.
- Arbitrary sum of projective modules is projective.

All of these should be relatively straightforward.

## Tags

projective module

-/

universe u v

open LinearMap Finsupp

/- The actual implementation we choose: `P` is projective if the natural surjection
   from the free `R`-module on `P` to `P` splits. -/
/-- An R-module is projective if it is a direct summand of a free module, or equivalently
  if maps from the module lift along surjections. There are several other equivalent
  definitions. -/
class Module.Projective (R : Type _) [Semiring R] (P : Type _) [AddCommMonoid P] [Module R P] :
  Prop where
  out : ∃ s : P →ₗ[R] P →₀ R, Function.LeftInverse (Finsupp.total P P R id) s
#align module.projective Module.Projective

namespace Module

section Semiring

variable {R : Type _} [Semiring R] {P : Type _} [AddCommMonoid P] [Module R P] {M : Type _}
  [AddCommMonoid M] [Module R M] {N : Type _} [AddCommMonoid N] [Module R N]

theorem projective_def :
    Projective R P ↔ ∃ s : P →ₗ[R] P →₀ R, Function.LeftInverse (Finsupp.total P P R id) s :=
  ⟨fun h => h.1, fun h => ⟨h⟩⟩
#align module.projective_def Module.projective_def

theorem projective_def' : Projective R P ↔ ∃ s : P →ₗ[R] P →₀ R, Finsupp.total P P R id ∘ₗ s = id :=
  by simp_rw [projective_def, FunLike.ext_iff, Function.LeftInverse, coe_comp, id_coe, id.def]
#align module.projective_def' Module.projective_def'

/-- A projective R-module has the property that maps from it lift along surjections. -/
theorem projective_lifting_property [h : Projective R P] (f : M →ₗ[R] N) (g : P →ₗ[R] N)
    (hf : Function.Surjective f) : ∃ h : P →ₗ[R] M, f.comp h = g :=
  by
  /-
    Here's the first step of the proof.
    Recall that `X →₀ R` is Lean's way of talking about the free `R`-module
    on a type `X`. The universal property `finsupp.total` says that to a map
    `X → N` from a type to an `R`-module, we get an associated R-module map
    `(X →₀ R) →ₗ N`. Apply this to a (noncomputable) map `P → M` coming from the map
    `P →ₗ N` and a random splitting of the surjection `M →ₗ N`, and we get
    a map `φ : (P →₀ R) →ₗ M`.
    -/
  let φ : (P →₀ R) →ₗ[R] M := Finsupp.total _ _ _ fun p => Function.surjInv hf (g p)
  -- By projectivity we have a map `P →ₗ (P →₀ R)`;
  cases' h.out with s hs
  -- Compose to get `P →ₗ M`. This works.
  use φ.comp s
  ext p
  conv_rhs => rw [← hs p]
  simp [φ, Finsupp.total_apply, Function.surjInv_eq hf]
#align module.projective_lifting_property Module.projective_lifting_property

variable {Q : Type _} [AddCommMonoid Q] [Module R Q]

instance [hP : Projective R P] [hQ : Projective R Q] : Projective R (P × Q) :=
  by
  rw [Module.projective_def']
  cases' hP.out with sP hsP
  cases' hQ.out with sQ hsQ
  use coprod (lmap_domain R R (inl R P Q)) (lmap_domain R R (inr R P Q)) ∘ₗ sP.prod_map sQ
  ext <;>
    simp only [coe_inl, coe_inr, coe_comp, Function.comp_apply, prod_map_apply, map_zero,
      coprod_apply, lmap_domain_apply, map_domain_zero, add_zero, zero_add, id_comp,
      total_map_domain]
  · rw [← fst_apply _, apply_total R]
    exact hsP x
  · rw [← snd_apply _, apply_total R]
    exact Finsupp.total_zero_apply _ (sP x)
  · rw [← fst_apply _, apply_total R]
    exact Finsupp.total_zero_apply _ (sQ x)
  · rw [← snd_apply _, apply_total R]
    exact hsQ x

variable {ι : Type _} (A : ι → Type _) [∀ i : ι, AddCommMonoid (A i)] [∀ i : ι, Module R (A i)]

instance [h : ∀ i : ι, Projective R (A i)] : Projective R (Π₀ i, A i) := by
  classical
    rw [Module.projective_def']
    simp_rw [projective_def] at h
    choose s hs using h
    letI : ∀ i : ι, AddCommMonoid (A i →₀ R) := fun i => by infer_instance
    letI : ∀ i : ι, Module R (A i →₀ R) := fun i => by infer_instance
    letI : AddCommMonoid (Π₀ i : ι, A i →₀ R) := @Dfinsupp.addCommMonoid ι (fun i => A i →₀ R) _
    letI : Module R (Π₀ i : ι, A i →₀ R) := @Dfinsupp.module ι R (fun i => A i →₀ R) _ _ _
    let f i := lmap_domain R R (Dfinsupp.single i : A i → Π₀ i, A i)
    use Dfinsupp.coprodMap f ∘ₗ Dfinsupp.mapRange.linearMap s
    ext (i x j)
    simp only [Dfinsupp.coprodMap, DirectSum.lof, total_map_domain, coe_comp, coe_lsum, id_coe,
      LinearEquiv.coe_toLinearMap, finsuppLequivDfinsupp_symm_apply, Function.comp_apply,
      Dfinsupp.lsingle_apply, Dfinsupp.mapRange.linearMap_apply, Dfinsupp.mapRange_single,
      lmap_domain_apply, Dfinsupp.toFinsupp_single, Finsupp.sum_single_index, id.def,
      Function.comp.left_id, Dfinsupp.single_apply]
    rw [← Dfinsupp.lapply_apply j, apply_total R]
    obtain rfl | hij := eq_or_ne i j
    · convert(hs i) x
      · ext
        simp
      · simp
    · convert Finsupp.total_zero_apply _ ((s i) x)
      · ext
        simp [hij]
      · simp [hij]

end Semiring

section Ring

variable {R : Type _} [Ring R] {P : Type _} [AddCommGroup P] [Module R P]

/-- Free modules are projective. -/
theorem projectiveOfBasis {ι : Type _} (b : Basis ι R P) : Projective R P :=
  by
  -- need P →ₗ (P →₀ R) for definition of projective.
  -- get it from `ι → (P →₀ R)` coming from `b`.
  use b.constr ℕ fun i => Finsupp.single (b i) (1 : R)
  intro m
  simp only [b.constr_apply, mul_one, id.def, Finsupp.smul_single', Finsupp.total_single,
    LinearMap.map_finsupp_sum]
  exact b.total_repr m
#align module.projective_of_basis Module.projectiveOfBasis

instance (priority := 100) projectiveOfFree [Module.Free R P] : Module.Projective R P :=
  projectiveOfBasis <| Module.Free.chooseBasis R P
#align module.projective_of_free Module.projectiveOfFree

end Ring

--This is in a different section because special universe restrictions are required.
section OfLiftingProperty

/-- A module which satisfies the universal property is projective. Note that the universe variables
in `huniv` are somewhat restricted. -/
theorem projectiveOfLiftingProperty' {R : Type u} [Semiring R] {P : Type max u v} [AddCommMonoid P]
    [Module R P]
    -- If for all surjections of `R`-modules `M →ₗ N`, all maps `P →ₗ N` lift to `P →ₗ M`,
    (huniv :
      ∀ {M : Type max v u} {N : Type max u v} [AddCommMonoid M] [AddCommMonoid N],
        ∀ [Module R M] [Module R N],
          ∀ (f : M →ₗ[R] N) (g : P →ₗ[R] N),
            Function.Surjective f → ∃ h : P →ₗ[R] M, f.comp h = g) :-- then `P` is projective.
      Projective
      R P :=
  by
  -- let `s` be the universal map `(P →₀ R) →ₗ P` coming from the identity map `P →ₗ P`.
  obtain ⟨s, hs⟩ : ∃ s : P →ₗ[R] P →₀ R, (Finsupp.total P P R id).comp s = LinearMap.id :=
    huniv (Finsupp.total P P R (id : P → P)) (LinearMap.id : P →ₗ[R] P) _
  -- This `s` works.
  · use s
    rwa [LinearMap.ext_iff] at hs
  · intro p
    use Finsupp.single p 1
    simp
#align module.projective_of_lifting_property' Module.projectiveOfLiftingProperty'

/-- A variant of `of_lifting_property'` when we're working over a `[ring R]`,
which only requires quantifying over modules with an `add_comm_group` instance. -/
theorem projectiveOfLiftingProperty {R : Type u} [Ring R] {P : Type max u v} [AddCommGroup P]
    [Module R P]
    -- If for all surjections of `R`-modules `M →ₗ N`, all maps `P →ₗ N` lift to `P →ₗ M`,
    (huniv :
      ∀ {M : Type max v u} {N : Type max u v} [AddCommGroup M] [AddCommGroup N],
        ∀ [Module R M] [Module R N],
          ∀ (f : M →ₗ[R] N) (g : P →ₗ[R] N),
            Function.Surjective f → ∃ h : P →ₗ[R] M, f.comp h = g) :-- then `P` is projective.
      Projective
      R P :=
  by
  -- We could try and prove this *using* `of_lifting_property`,
  -- but this quickly leads to typeclass hell,
  -- so we just prove it over again.
  -- let `s` be the universal map `(P →₀ R) →ₗ P` coming from the identity map `P →ₗ P`.
  obtain ⟨s, hs⟩ : ∃ s : P →ₗ[R] P →₀ R, (Finsupp.total P P R id).comp s = LinearMap.id :=
    huniv (Finsupp.total P P R (id : P → P)) (LinearMap.id : P →ₗ[R] P) _
  -- This `s` works.
  · use s
    rwa [LinearMap.ext_iff] at hs
  · intro p
    use Finsupp.single p 1
    simp
#align module.projective_of_lifting_property Module.projectiveOfLiftingProperty

end OfLiftingProperty

end Module


/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/

import field_theory.finite.basic
import data.zmod.basic
import data.nat.parity

/-!
# Quadratic reciprocity.

This file contains results about quadratic residues modulo a prime number.

The main results are the law of quadratic reciprocity, `quadratic_reciprocity`, as well as the
interpretations in terms of existence of square roots depending on the congruence mod 4,
`exists_sq_eq_prime_iff_of_mod_four_eq_one`, and
`exists_sq_eq_prime_iff_of_mod_four_eq_three`.

Also proven are conditions for `-1` and `2` to be a square modulo a prime,
`exists_sq_eq_neg_one_iff_mod_four_ne_three` and
`exists_sq_eq_two_iff`

## Implementation notes

The proof of quadratic reciprocity implemented uses Gauss' lemma and Eisenstein's lemma
-/

open function finset nat finite_field zmod
open_locale big_operators nat

namespace zmod

variables (p q : ℕ) [fact p.prime] [fact q.prime]

/-- Euler's Criterion: A unit `x` of `zmod p` is a square if and only if `x ^ (p / 2) = 1`. -/
lemma euler_criterion_units (x : (zmod p)ˣ) :
  (∃ y : (zmod p)ˣ, y ^ 2 = x) ↔ x ^ (p / 2) = 1 :=
begin
  cases nat.prime.eq_two_or_odd (fact.out p.prime) with hp2 hp_odd,
  { substI p, refine iff_of_true ⟨1, _⟩ _; apply subsingleton.elim },
  obtain ⟨g, hg⟩ := is_cyclic.exists_generator (zmod p)ˣ,
  obtain ⟨n, hn⟩ : x ∈ submonoid.powers g, { rw mem_powers_iff_mem_zpowers, apply hg },
  split,
  { rintro ⟨y, rfl⟩, rw [← pow_mul, two_mul_odd_div_two hp_odd, units_pow_card_sub_one_eq_one], },
  { subst x, assume h,
    have key : 2 * (p / 2) ∣ n * (p / 2),
    { rw [← pow_mul] at h,
      rw [two_mul_odd_div_two hp_odd, ← card_units, ← order_of_eq_card_of_forall_mem_zpowers hg],
      apply order_of_dvd_of_pow_eq_one h },
    have : 0 < p / 2 := nat.div_pos (fact.out (1 < p)) dec_trivial,
    obtain ⟨m, rfl⟩ := dvd_of_mul_dvd_mul_right this key,
    refine ⟨g ^ m, _⟩,
    rw [mul_comm, pow_mul], },
end

/-- Euler's Criterion: a nonzero `a : zmod p` is a square if and only if `x ^ (p / 2) = 1`. -/
lemma euler_criterion {a : zmod p} (ha : a ≠ 0) :
  (∃ y : zmod p, y ^ 2 = a) ↔ a ^ (p / 2) = 1 :=
begin
  apply (iff_congr _ (by simp [units.ext_iff])).mp (euler_criterion_units p (units.mk0 a ha)),
  simp only [units.ext_iff, sq, units.coe_mk0, units.coe_mul],
  split, { rintro ⟨y, hy⟩, exact ⟨y, hy⟩ },
  { rintro ⟨y, rfl⟩,
    have hy : y ≠ 0, { rintro rfl, simpa [zero_pow] using ha, },
    refine ⟨units.mk0 y hy, _⟩, simp, }
end

lemma exists_sq_eq_neg_one_iff_mod_four_ne_three :
  (∃ y : zmod p, y ^ 2 = -1) ↔ p % 4 ≠ 3 :=
begin
  cases nat.prime.eq_two_or_odd (fact.out p.prime) with hp2 hp_odd,
  { substI p, exact dec_trivial },
  haveI := fact.mk hp_odd,
  have neg_one_ne_zero : (-1 : zmod p) ≠ 0, from mt neg_eq_zero.1 one_ne_zero,
  rw [euler_criterion p neg_one_ne_zero, neg_one_pow_eq_pow_mod_two],
  cases mod_two_eq_zero_or_one (p / 2) with p_half_even p_half_odd,
  { rw [p_half_even, pow_zero, eq_self_iff_true, true_iff],
    contrapose! p_half_even with hp,
    rw [← nat.mod_mul_right_div_self, show 2 * 2 = 4, from rfl, hp],
    exact dec_trivial },
  { rw [p_half_odd, pow_one,
        iff_false_intro (ne_neg_self p one_ne_zero).symm, false_iff, not_not],
    rw [← nat.mod_mul_right_div_self, show 2 * 2 = 4, from rfl] at p_half_odd,
    rw [← nat.mod_mul_left_mod _ 2, show 2 * 2 = 4, from rfl] at hp_odd,
    have hp : p % 4 < 4, from nat.mod_lt _ dec_trivial,
    revert hp hp_odd p_half_odd,
    generalize : p % 4 = k, dec_trivial! }
end

lemma pow_div_two_eq_neg_one_or_one {a : zmod p} (ha : a ≠ 0) :
  a ^ (p / 2) = 1 ∨ a ^ (p / 2) = -1 :=
begin
  cases nat.prime.eq_two_or_odd (fact.out p.prime) with hp2 hp_odd,
  { substI p, revert a ha, exact dec_trivial },
  rw [← mul_self_eq_one_iff, ← pow_add, ← two_mul, two_mul_odd_div_two hp_odd],
  exact pow_card_sub_one_eq_one ha
end

/-- **Wilson's Lemma**: the product of `1`, ..., `p-1` is `-1` modulo `p`. -/
@[simp] lemma wilsons_lemma : ((p - 1)! : zmod p) = -1 :=
begin
  refine
  calc ((p - 1)! : zmod p) = (∏ x in Ico 1 (succ (p - 1)), x) :
    by rw [← finset.prod_Ico_id_eq_factorial, prod_nat_cast]
                               ... = (∏ x : (zmod p)ˣ, x) : _
                               ... = -1 : by simp_rw [← units.coe_hom_apply,
    ← (units.coe_hom (zmod p)).map_prod, prod_univ_units_id_eq_neg_one, units.coe_hom_apply,
    units.coe_neg, units.coe_one],
  have hp : 0 < p := (fact.out p.prime).pos,
  symmetry,
  refine prod_bij (λ a _, (a : zmod p).val) _ _ _ _,
  { intros a ha,
    rw [mem_Ico, ← nat.succ_sub hp, nat.succ_sub_one],
    split,
    { apply nat.pos_of_ne_zero, rw ← @val_zero p,
      assume h, apply units.ne_zero a (val_injective p h) },
    { exact val_lt _ } },
  { intros a ha, simp only [cast_id, nat_cast_val], },
  { intros _ _ _ _ h, rw units.ext_iff, exact val_injective p h },
  { intros b hb,
    rw [mem_Ico, nat.succ_le_iff, ← succ_sub hp, succ_sub_one, pos_iff_ne_zero] at hb,
    refine ⟨units.mk0 b _, finset.mem_univ _, _⟩,
    { assume h, apply hb.1, apply_fun val at h,
      simpa only [val_cast_of_lt hb.right, val_zero] using h },
    { simp only [val_cast_of_lt hb.right, units.coe_mk0], } }
end

@[simp] lemma prod_Ico_one_prime : (∏ x in Ico 1 p, (x : zmod p)) = -1 :=
begin
  conv in (Ico 1 p) { rw [← succ_sub_one p, succ_sub (fact.out p.prime).pos] },
  rw [← prod_nat_cast, finset.prod_Ico_id_eq_factorial, wilsons_lemma]
end

end zmod

/-- The image of the map sending a non zero natural number `x ≤ p / 2` to the absolute value
  of the element of interger in the interval `(-p/2, p/2]` congruent to `a * x` mod p is the set
  of non zero natural numbers `x` such that `x ≤ p / 2` -/
lemma Ico_map_val_min_abs_nat_abs_eq_Ico_map_id
  (p : ℕ) [hp : fact p.prime] (a : zmod p) (hap : a ≠ 0) :
  (Ico 1 (p / 2).succ).1.map (λ x, (a * x).val_min_abs.nat_abs) =
  (Ico 1 (p / 2).succ).1.map (λ a, a) :=
begin
  have he : ∀ {x}, x ∈ Ico 1 (p / 2).succ → x ≠ 0 ∧ x ≤ p / 2,
    by simp [nat.lt_succ_iff, nat.succ_le_iff, pos_iff_ne_zero] {contextual := tt},
  have hep : ∀ {x}, x ∈ Ico 1 (p / 2).succ → x < p,
    from λ x hx, lt_of_le_of_lt (he hx).2 (nat.div_lt_self hp.1.pos dec_trivial),
  have hpe : ∀ {x}, x ∈ Ico 1 (p / 2).succ → ¬ p ∣ x,
    from λ x hx hpx, not_lt_of_ge (le_of_dvd (nat.pos_of_ne_zero (he hx).1) hpx) (hep hx),
  have hmem : ∀ (x : ℕ) (hx : x ∈ Ico 1 (p / 2).succ),
    (a * x : zmod p).val_min_abs.nat_abs ∈ Ico 1 (p / 2).succ,
  { assume x hx,
    simp [hap, char_p.cast_eq_zero_iff (zmod p) p, hpe hx, lt_succ_iff, succ_le_iff,
        pos_iff_ne_zero, nat_abs_val_min_abs_le _], },
  have hsurj : ∀ (b : ℕ) (hb : b ∈ Ico 1 (p / 2).succ),
    ∃ x ∈ Ico 1 (p / 2).succ, b = (a * x : zmod p).val_min_abs.nat_abs,
  { assume b hb,
    refine ⟨(b / a : zmod p).val_min_abs.nat_abs, mem_Ico.mpr ⟨_, _⟩, _⟩,
    { apply nat.pos_of_ne_zero,
      simp only [div_eq_mul_inv, hap, char_p.cast_eq_zero_iff (zmod p) p, hpe hb, not_false_iff,
        val_min_abs_eq_zero, inv_eq_zero, int.nat_abs_eq_zero, ne.def, mul_eq_zero, or_self] },
    { apply lt_succ_of_le, apply nat_abs_val_min_abs_le },
    { rw nat_cast_nat_abs_val_min_abs,
      split_ifs,
      { erw [mul_div_cancel' _ hap, val_min_abs_def_pos, val_cast_of_lt (hep hb),
          if_pos (le_of_lt_succ (mem_Ico.1 hb).2), int.nat_abs_of_nat], },
      { erw [mul_neg_eq_neg_mul_symm, mul_div_cancel' _ hap, nat_abs_val_min_abs_neg,
          val_min_abs_def_pos, val_cast_of_lt (hep hb), if_pos (le_of_lt_succ (mem_Ico.1 hb).2),
          int.nat_abs_of_nat] } } },
  exact multiset.map_eq_map_of_bij_of_nodup _ _ (finset.nodup _) (finset.nodup _)
    (λ x _, (a * x : zmod p).val_min_abs.nat_abs) hmem (λ _ _, rfl)
    (inj_on_of_surj_on_of_card_le _ hmem hsurj le_rfl) hsurj
end

private lemma gauss_lemma_aux₁ (p : ℕ) [fact p.prime] [fact (p % 2 = 1)]
  {a : ℕ} (hap : (a : zmod p) ≠ 0) :
  (a^(p / 2) * (p / 2)! : zmod p) =
  (-1)^((Ico 1 (p / 2).succ).filter
    (λ x : ℕ, ¬(a * x : zmod p).val ≤ p / 2)).card * (p / 2)! :=
calc (a ^ (p / 2) * (p / 2)! : zmod p) =
    (∏ x in Ico 1 (p / 2).succ, a * x) :
  by rw [prod_mul_distrib, ← prod_nat_cast, ← prod_nat_cast, prod_Ico_id_eq_factorial,
      prod_const, card_Ico, succ_sub_one]; simp
... = (∏ x in Ico 1 (p / 2).succ, (a * x : zmod p).val) : by simp
... = (∏ x in Ico 1 (p / 2).succ,
    (if (a * x : zmod p).val ≤ p / 2 then 1 else -1) *
      (a * x : zmod p).val_min_abs.nat_abs) :
  prod_congr rfl $ λ _ _, begin
    simp only [nat_cast_nat_abs_val_min_abs],
    split_ifs; simp
  end
... = (-1)^((Ico 1 (p / 2).succ).filter
      (λ x : ℕ, ¬(a * x : zmod p).val ≤ p / 2)).card *
    (∏ x in Ico 1 (p / 2).succ, (a * x : zmod p).val_min_abs.nat_abs) :
  have (∏ x in Ico 1 (p / 2).succ,
        if (a * x : zmod p).val ≤ p / 2 then (1 : zmod p) else -1) =
      (∏ x in (Ico 1 (p / 2).succ).filter
        (λ x : ℕ, ¬(a * x : zmod p).val ≤ p / 2), -1),
    from prod_bij_ne_one (λ x _ _, x)
      (λ x, by split_ifs; simp * at * {contextual := tt})
      (λ _ _ _ _ _ _, id)
      (λ b h _, ⟨b, by simp [-not_le, *] at *⟩)
      (by intros; split_ifs at *; simp * at *),
  by rw [prod_mul_distrib, this]; simp
... = (-1)^((Ico 1 (p / 2).succ).filter
      (λ x : ℕ, ¬(a * x : zmod p).val ≤ p / 2)).card * (p / 2)! :
  by rw [← prod_nat_cast, finset.prod_eq_multiset_prod,
      Ico_map_val_min_abs_nat_abs_eq_Ico_map_id p a hap,
      ← finset.prod_eq_multiset_prod, prod_Ico_id_eq_factorial]

private lemma gauss_lemma_aux₂ (p : ℕ) [hp : fact p.prime] [fact (p % 2 = 1)]
  {a : ℕ} (hap : (a : zmod p) ≠ 0) :
  (a^(p / 2) : zmod p) = (-1)^((Ico 1 (p / 2).succ).filter
    (λ x : ℕ, p / 2 < (a * x : zmod p).val)).card :=
(mul_left_inj'
    (show ((p / 2)! : zmod p) ≠ 0,
      by rw [ne.def, char_p.cast_eq_zero_iff (zmod p) p, hp.1.dvd_factorial, not_le];
          exact nat.div_lt_self hp.1.pos dec_trivial)).1 $
  by simpa using gauss_lemma_aux₁ p hap

private lemma eisenstein_lemma_aux₁ (p : ℕ) [fact p.prime] [hp2 : fact (p % 2 = 1)]
  {a : ℕ} (hap : (a : zmod p) ≠ 0) :
  ((∑ x in Ico 1 (p / 2).succ, a * x : ℕ) : zmod 2) =
    ((Ico 1 (p / 2).succ).filter
      ((λ x : ℕ, p / 2 < (a * x : zmod p).val))).card +
      ∑ x in Ico 1 (p / 2).succ, x
    + (∑ x in Ico 1 (p / 2).succ, (a * x) / p : ℕ) :=
have hp2 : (p : zmod 2) = (1 : ℕ), from (eq_iff_modeq_nat _).2 hp2.1,
calc ((∑ x in Ico 1 (p / 2).succ, a * x : ℕ) : zmod 2)
    = ((∑ x in Ico 1 (p / 2).succ, ((a * x) % p + p * ((a * x) / p)) : ℕ) : zmod 2) :
  by simp only [mod_add_div]
... = (∑ x in Ico 1 (p / 2).succ, ((a * x : ℕ) : zmod p).val : ℕ) +
    (∑ x in Ico 1 (p / 2).succ, (a * x) / p : ℕ) :
  by simp only [val_nat_cast];
    simp [sum_add_distrib, mul_sum.symm, nat.cast_add, nat.cast_mul, nat.cast_sum, hp2]
... = _ : congr_arg2 (+)
  (calc ((∑ x in Ico 1 (p / 2).succ, ((a * x : ℕ) : zmod p).val : ℕ) : zmod 2)
      = ∑ x in Ico 1 (p / 2).succ,
          ((((a * x : zmod p).val_min_abs +
            (if (a * x : zmod p).val ≤ p / 2 then 0 else p)) : ℤ) : zmod 2) :
        by simp only [(val_eq_ite_val_min_abs _).symm]; simp [nat.cast_sum]
  ... = ((Ico 1 (p / 2).succ).filter
        (λ x : ℕ, p / 2 < (a * x : zmod p).val)).card +
      ((∑ x in Ico 1 (p / 2).succ, (a * x : zmod p).val_min_abs.nat_abs) : ℕ) :
    by { simp [ite_cast, add_comm, sum_add_distrib, finset.sum_ite, hp2, nat.cast_sum], }
  ... = _ : by rw [finset.sum_eq_multiset_sum,
      Ico_map_val_min_abs_nat_abs_eq_Ico_map_id p a hap,
      ← finset.sum_eq_multiset_sum];
    simp [nat.cast_sum]) rfl

private lemma eisenstein_lemma_aux₂ (p : ℕ) [fact p.prime] [fact (p % 2 = 1)]
  {a : ℕ} (ha2 : a % 2 = 1) (hap : (a : zmod p) ≠ 0) :
  ((Ico 1 (p / 2).succ).filter
    ((λ x : ℕ, p / 2 < (a * x : zmod p).val))).card
  ≡ ∑ x in Ico 1 (p / 2).succ, (x * a) / p [MOD 2] :=
have ha2 : (a : zmod 2) = (1 : ℕ), from (eq_iff_modeq_nat _).2 ha2,
(eq_iff_modeq_nat 2).1 $ sub_eq_zero.1 $
  by simpa [add_left_comm, sub_eq_add_neg, finset.mul_sum.symm, mul_comm, ha2, nat.cast_sum,
            add_neg_eq_iff_eq_add.symm, neg_eq_self_mod_two, add_assoc]
    using eq.symm (eisenstein_lemma_aux₁ p hap)

lemma div_eq_filter_card {a b c : ℕ} (hb0 : 0 < b) (hc : a / b ≤ c) : a / b =
  ((Ico 1 c.succ).filter (λ x, x * b ≤ a)).card :=
calc a / b = (Ico 1 (a / b).succ).card : by simp
... = ((Ico 1 c.succ).filter (λ x, x * b ≤ a)).card :
  congr_arg _ $ finset.ext $ λ x,
    have x * b ≤ a → x ≤ c,
      from λ h, le_trans (by rwa [le_div_iff_mul_le _ _ hb0]) hc,
    by simp [lt_succ_iff, le_div_iff_mul_le _ _ hb0]; tauto

/-- The given sum is the number of integer points in the triangle formed by the diagonal of the
  rectangle `(0, p/2) × (0, q/2)`  -/
private lemma sum_Ico_eq_card_lt {p q : ℕ} :
  ∑ a in Ico 1 (p / 2).succ, (a * q) / p =
  (((Ico 1 (p / 2).succ).product (Ico 1 (q / 2).succ)).filter
  (λ x : ℕ × ℕ, x.2 * p ≤ x.1 * q)).card :=
if hp0 : p = 0 then by simp [hp0, finset.ext_iff]
else
  calc ∑ a in Ico 1 (p / 2).succ, (a * q) / p =
    ∑ a in Ico 1 (p / 2).succ,
      ((Ico 1 (q / 2).succ).filter (λ x, x * p ≤ a * q)).card :
    finset.sum_congr rfl $ λ x hx,
      div_eq_filter_card (nat.pos_of_ne_zero hp0)
        (calc x * q / p ≤ (p / 2) * q / p :
            nat.div_le_div_right (mul_le_mul_of_nonneg_right
              (le_of_lt_succ $ (mem_Ico.mp hx).2)
              (nat.zero_le _))
          ... ≤ _ : nat.div_mul_div_le_div _ _ _)
  ... = _ : by rw [← card_sigma];
    exact card_congr (λ a _, ⟨a.1, a.2⟩)
      (by simp only [mem_filter, mem_sigma, and_self, forall_true_iff, mem_product]
        {contextual := tt})
      (λ ⟨_, _⟩ ⟨_, _⟩, by simp only [prod.mk.inj_iff, eq_self_iff_true, and_self, heq_iff_eq,
        forall_true_iff] {contextual := tt})
      (λ ⟨b₁, b₂⟩ h, ⟨⟨b₁, b₂⟩,
        by revert h; simp only [mem_filter, eq_self_iff_true, exists_prop_of_true, mem_sigma,
          and_self, forall_true_iff, mem_product] {contextual := tt}⟩)

/-- Each of the sums in this lemma is the cardinality of the set integer points in each of the
  two triangles formed by the diagonal of the rectangle `(0, p/2) × (0, q/2)`. Adding them
  gives the number of points in the rectangle. -/
private lemma sum_mul_div_add_sum_mul_div_eq_mul (p q : ℕ) [hp : fact p.prime]
  (hq0 : (q : zmod p) ≠ 0) :
  ∑ a in Ico 1 (p / 2).succ, (a * q) / p +
  ∑ a in Ico 1 (q / 2).succ, (a * p) / q =
  (p / 2) * (q / 2) :=
begin
  have hswap : (((Ico 1 (q / 2).succ).product (Ico 1 (p / 2).succ)).filter
    (λ x : ℕ × ℕ, x.2 * q ≤ x.1 * p)).card =
  (((Ico 1 (p / 2).succ).product (Ico 1 (q / 2).succ)).filter
    (λ x : ℕ × ℕ, x.1 * q ≤ x.2 * p)).card :=
  card_congr (λ x _, prod.swap x)
    (λ ⟨_, _⟩, by simp only [mem_filter, and_self, prod.swap_prod_mk, forall_true_iff, mem_product]
      {contextual := tt})
    (λ ⟨_, _⟩ ⟨_, _⟩, by simp only [prod.mk.inj_iff, eq_self_iff_true, and_self, prod.swap_prod_mk,
      forall_true_iff] {contextual := tt})
    (λ ⟨x₁, x₂⟩ h, ⟨⟨x₂, x₁⟩, by revert h; simp only [mem_filter, eq_self_iff_true, and_self,
      exists_prop_of_true, prod.swap_prod_mk, forall_true_iff, mem_product] {contextual := tt}⟩),
  have hdisj : disjoint
    (((Ico 1 (p / 2).succ).product (Ico 1 (q / 2).succ)).filter
      (λ x : ℕ × ℕ, x.2 * p ≤ x.1 * q))
    (((Ico 1 (p / 2).succ).product (Ico 1 (q / 2).succ)).filter
      (λ x : ℕ × ℕ, x.1 * q ≤ x.2 * p)),
  { apply disjoint_filter.2 (λ x hx hpq hqp, _),
    have hxp : x.1 < p, from lt_of_le_of_lt
      (show x.1 ≤ p / 2, by simp only [*, lt_succ_iff, mem_Ico, mem_product] at *; tauto)
      (nat.div_lt_self hp.1.pos dec_trivial),
    have : (x.1 : zmod p) = 0,
    { simpa [hq0] using congr_arg (coe : ℕ → zmod p) (le_antisymm hpq hqp) },
    apply_fun zmod.val at this,
    rw [val_cast_of_lt hxp, val_zero] at this,
    simpa only [this, nonpos_iff_eq_zero, mem_Ico, one_ne_zero, false_and, mem_product] using hx },
  have hunion : ((Ico 1 (p / 2).succ).product (Ico 1 (q / 2).succ)).filter
      (λ x : ℕ × ℕ, x.2 * p ≤ x.1 * q) ∪
    ((Ico 1 (p / 2).succ).product (Ico 1 (q / 2).succ)).filter
      (λ x : ℕ × ℕ, x.1 * q ≤ x.2 * p) =
    ((Ico 1 (p / 2).succ).product (Ico 1 (q / 2).succ)),
  from finset.ext (λ x, by have := le_total (x.2 * p) (x.1 * q);
    simp only [mem_union, mem_filter, mem_Ico, mem_product]; tauto),
  rw [sum_Ico_eq_card_lt, sum_Ico_eq_card_lt, hswap, ← card_disjoint_union hdisj, hunion,
    card_product],
  simp only [card_Ico, tsub_zero, succ_sub_succ_eq_sub]
end

variables (p q : ℕ) [fact p.prime] [fact q.prime]

namespace zmod

/-- The Legendre symbol of `a` and `p` is an integer defined as

* `0` if `a` is `0` modulo `p`;
* `1` if `a ^ (p / 2)` is `1` modulo `p`
   (by `euler_criterion` this is equivalent to “`a` is a square modulo `p`”);
* `-1` otherwise.

-/
def legendre_sym (a : ℤ) (p : ℕ) : ℤ :=
if      (a : zmod p) = 0           then  0
else if (a : zmod p) ^ (p / 2) = 1 then  1
                                   else -1

lemma legendre_sym_eq_pow (a p : ℕ) [hp : fact p.prime] :
  (legendre_sym a p : zmod p) = (a ^ (p / 2)) :=
begin
  rw legendre_sym,
  by_cases ha : (a : zmod p) = 0,
  { simp only [int.cast_coe_nat, if_pos, ha,
      zero_pow (nat.div_pos (hp.1.two_le) (succ_pos 1)), int.cast_zero] },
  cases hp.1.eq_two_or_odd with hp2 hp_odd,
  { substI p,
    generalize : (a : (zmod 2)) = b, revert b, dec_trivial, },
  { haveI := fact.mk hp_odd,
    rw [int.cast_coe_nat, if_neg ha],
    have : (-1 : zmod p) ≠ 1, from (ne_neg_self p one_ne_zero).symm,
    cases pow_div_two_eq_neg_one_or_one p ha with h h,
    { rw [if_pos h, h, int.cast_one], },
    { rw [h, if_neg this, int.cast_neg, int.cast_one], } }
end

lemma legendre_sym_eq_one_or_neg_one (a p : ℕ) (ha : (a : zmod p) ≠ 0) :
  legendre_sym a p = -1 ∨ legendre_sym a p = 1 :=
begin
  unfold legendre_sym,
  split_ifs;
  simp only [*, eq_self_iff_true, or_true, true_or, int.cast_coe_nat] at *,
end

lemma legendre_sym_eq_zero_iff (a p : ℕ) :
  legendre_sym a p = 0 ↔ (a : zmod p) = 0 :=
begin
  split,
  { classical, contrapose,
    assume ha, cases legendre_sym_eq_one_or_neg_one a p ha with h h,
    all_goals { rw h, norm_num } },
  { assume ha, rw [legendre_sym, int.cast_coe_nat, if_pos ha] }
end

/-- Gauss' lemma. The legendre symbol can be computed by considering the number of naturals less
  than `p/2` such that `(a * x) % p > p / 2` -/
lemma gauss_lemma {a : ℕ} [fact (p % 2 = 1)] (ha0 : (a : zmod p) ≠ 0) :
  legendre_sym a p = (-1) ^ ((Ico 1 (p / 2).succ).filter
    (λ x : ℕ, p / 2 < (a * x : zmod p).val)).card :=
have (legendre_sym a p : zmod p) = (((-1)^((Ico 1 (p / 2).succ).filter
    (λ x : ℕ, p / 2 < (a * x : zmod p).val)).card : ℤ) : zmod p),
  by rw [legendre_sym_eq_pow, gauss_lemma_aux₂ p ha0]; simp,
begin
  cases legendre_sym_eq_one_or_neg_one a p ha0;
  cases neg_one_pow_eq_or ℤ ((Ico 1 (p / 2).succ).filter
    (λ x : ℕ, p / 2 < (a * x : zmod p).val)).card;
  simp [*, ne_neg_self p one_ne_zero, (ne_neg_self p one_ne_zero).symm] at *
end

lemma legendre_sym_eq_one_iff {a : ℕ} (ha0 : (a : zmod p) ≠ 0) :
  legendre_sym a p = 1 ↔ (∃ b : zmod p, b ^ 2 = a) :=
begin
  rw [euler_criterion p ha0, legendre_sym, int.cast_coe_nat, if_neg ha0],
  split_ifs,
  { simp only [h, eq_self_iff_true] },
  { simp only [h, iff_false], tauto }
end

lemma eisenstein_lemma [fact (p % 2 = 1)] {a : ℕ} (ha1 : a % 2 = 1) (ha0 : (a : zmod p) ≠ 0) :
  legendre_sym a p = (-1)^∑ x in Ico 1 (p / 2).succ, (x * a) / p :=
by rw [neg_one_pow_eq_pow_mod_two, gauss_lemma p ha0, neg_one_pow_eq_pow_mod_two,
    show _ = _, from eisenstein_lemma_aux₂ p ha1 ha0]

/-- **Quadratic reciprocity theorem** -/
theorem quadratic_reciprocity [hp1 : fact (p % 2 = 1)] [hq1 : fact (q % 2 = 1)] (hpq : p ≠ q) :
  legendre_sym p q * legendre_sym q p = (-1) ^ ((p / 2) * (q / 2)) :=
have hpq0 : (p : zmod q) ≠ 0, from prime_ne_zero q p hpq.symm,
have hqp0 : (q : zmod p) ≠ 0, from prime_ne_zero p q hpq,
by rw [eisenstein_lemma q hp1.1 hpq0, eisenstein_lemma p hq1.1 hqp0,
  ← pow_add, sum_mul_div_add_sum_mul_div_eq_mul q p hpq0, mul_comm]

lemma legendre_sym_two [hp1 : fact (p % 2 = 1)] : legendre_sym 2 p = (-1) ^ (p / 4 + p / 2) :=
have hp2 : p ≠ 2, from mt (congr_arg (% 2)) (by simpa using hp1.1),
have hp22 : p / 2 / 2 = _ := div_eq_filter_card (show 0 < 2, from dec_trivial)
  (nat.div_le_self (p / 2) 2),
have hcard : (Ico 1 (p / 2).succ).card = p / 2, by simp,
have hx2 : ∀ x ∈ Ico 1 (p / 2).succ, (2 * x : zmod p).val = 2 * x,
  from λ x hx, have h2xp : 2 * x < p,
      from calc 2 * x ≤ 2 * (p / 2) : mul_le_mul_of_nonneg_left
        (le_of_lt_succ $ (mem_Ico.mp hx).2) dec_trivial
      ... < _ : by conv_rhs {rw [← div_add_mod p 2, hp1.1]}; exact lt_succ_self _,
    by rw [← nat.cast_two, ← nat.cast_mul, val_cast_of_lt h2xp],
have hdisj : disjoint
    ((Ico 1 (p / 2).succ).filter (λ x, p / 2 < ((2 : ℕ) * x : zmod p).val))
    ((Ico 1 (p / 2).succ).filter (λ x, x * 2 ≤ p / 2)),
  from disjoint_filter.2 (λ x hx, by simp [hx2 _ hx, mul_comm]),
have hunion :
    ((Ico 1 (p / 2).succ).filter (λ x, p / 2 < ((2 : ℕ) * x : zmod p).val)) ∪
    ((Ico 1 (p / 2).succ).filter (λ x, x * 2 ≤ p / 2)) =
    Ico 1 (p / 2).succ,
  begin
    rw [filter_union_right],
    conv_rhs {rw [← @filter_true _ (Ico 1 (p / 2).succ)]},
    exact filter_congr (λ x hx, by simp [hx2 _ hx, lt_or_le, mul_comm])
  end,
begin
  erw [gauss_lemma p (prime_ne_zero p 2 hp2),
    neg_one_pow_eq_pow_mod_two, @neg_one_pow_eq_pow_mod_two _ _ (p / 4 + p / 2)],
  refine congr_arg2 _ rfl ((eq_iff_modeq_nat 2).1 _),
  rw [show 4 = 2 * 2, from rfl, ← nat.div_div_eq_div_mul, hp22, nat.cast_add,
    ← sub_eq_iff_eq_add', sub_eq_add_neg, neg_eq_self_mod_two,
    ← nat.cast_add, ← card_disjoint_union hdisj, hunion, hcard]
end

lemma exists_sq_eq_two_iff [hp1 : fact (p % 2 = 1)] :
  (∃ a : zmod p, a ^ 2 = 2) ↔ p % 8 = 1 ∨ p % 8 = 7 :=
have hp2 : ((2 : ℕ) : zmod p) ≠ 0,
  from prime_ne_zero p 2 (λ h, by simpa [h] using hp1.1),
have hpm4 : p % 4 = p % 8 % 4, from (nat.mod_mul_left_mod p 2 4).symm,
have hpm2 : p % 2 = p % 8 % 2, from (nat.mod_mul_left_mod p 4 2).symm,
begin
  rw [show (2 : zmod p) = (2 : ℕ), by simp, ← legendre_sym_eq_one_iff p hp2],
  erw [legendre_sym_two p, neg_one_pow_eq_one_iff_even (show (-1 : ℤ) ≠ 1, from dec_trivial),
    even_add, even_div, even_div],
  have := nat.mod_lt p (show 0 < 8, from dec_trivial),
  resetI, rw fact_iff at hp1,
  revert this hp1,
  erw [hpm4, hpm2],
  generalize hm : p % 8 = m, unfreezingI {clear_dependent p},
  dec_trivial!,
end

lemma exists_sq_eq_prime_iff_of_mod_four_eq_one (hp1 : p % 4 = 1) [hq1 : fact (q % 2 = 1)] :
  (∃ a : zmod p, a ^ 2 = q) ↔ ∃ b : zmod q, b ^ 2 = p :=
if hpq : p = q then by substI hpq else
have h1 : ((p / 2) * (q / 2)) % 2 = 0,
  from (dvd_iff_mod_eq_zero _ _).1
    (dvd_mul_of_dvd_left ((dvd_iff_mod_eq_zero _ _).2 $
    by rw [← mod_mul_right_div_self, show 2 * 2 = 4, from rfl, hp1]; refl) _),
begin
  haveI hp_odd : fact (p % 2 = 1) := ⟨odd_of_mod_four_eq_one hp1⟩,
  have hpq0 : (p : zmod q) ≠ 0 := prime_ne_zero q p (ne.symm hpq),
  have hqp0 : (q : zmod p) ≠ 0 := prime_ne_zero p q hpq,
  have := quadratic_reciprocity p q hpq,
  rw [neg_one_pow_eq_pow_mod_two, h1, legendre_sym, legendre_sym, int.cast_coe_nat,
    int.cast_coe_nat, if_neg hqp0, if_neg hpq0] at this,
  rw [euler_criterion q hpq0, euler_criterion p hqp0],
  split_ifs at this; simp *; contradiction,
end

lemma exists_sq_eq_prime_iff_of_mod_four_eq_three (hp3 : p % 4 = 3)
  (hq3 : q % 4 = 3) (hpq : p ≠ q) : (∃ a : zmod p, a ^ 2 = q) ↔ ¬∃ b : zmod q, b ^ 2 = p :=
have h1 : ((p / 2) * (q / 2)) % 2 = 1,
  from nat.odd_mul_odd
    (by rw [← mod_mul_right_div_self, show 2 * 2 = 4, from rfl, hp3]; refl)
    (by rw [← mod_mul_right_div_self, show 2 * 2 = 4, from rfl, hq3]; refl),
begin
  haveI hp_odd : fact (p % 2 = 1) := ⟨odd_of_mod_four_eq_three hp3⟩,
  haveI hq_odd : fact (q % 2 = 1) := ⟨odd_of_mod_four_eq_three hq3⟩,
  have hpq0 : (p : zmod q) ≠ 0 := prime_ne_zero q p (ne.symm hpq),
  have hqp0 : (q : zmod p) ≠ 0 := prime_ne_zero p q hpq,
  have := quadratic_reciprocity p q hpq,
  rw [neg_one_pow_eq_pow_mod_two, h1, legendre_sym, legendre_sym, int.cast_coe_nat,
    int.cast_coe_nat, if_neg hpq0, if_neg hqp0] at this,
  rw [euler_criterion q hpq0, euler_criterion p hqp0],
  split_ifs at this; simp *; contradiction
end

end zmod