/-
Copyright (c) 2018 Chris Hughes. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Chris Hughes
-/
import group_theory.perm.support
import data.fintype.basic
import group_theory.order_of_element
import tactic.norm_swap
import data.finset.sort

/-!
# Sign of a permutation

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

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

-/

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

namespace equiv.perm

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

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

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

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

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

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

lemma perm_inv_on_of_perm_on_fintype {f : perm α} {p : α → Prop} [fintype {x // p x}]
  (h : ∀ x, p x → p (f x)) {x : α} (hx : p x) : p (f⁻¹ x) :=
begin
  letI : fintype ↥(show set α, from p) := ‹fintype {x // p x}›,
  exact perm_inv_maps_to_of_maps_to f h hx
end

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

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

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

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

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

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

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

variable [decidable_eq α]

section fintype
variable [fintype α]

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

end fintype

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

section sign

variable [fintype α]

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

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

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

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

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

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

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

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

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

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

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

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

variable (α)

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

variable {α}

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

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

@[simp] lemma sign_of_subtype {p : α → Prop} [decidable_pred p]
  (f : perm (subtype p)) : sign (of_subtype f) = sign f :=
have ∀ x, of_subtype f x ≠ x → p x, from λ x, not_imp_comm.1 (of_subtype_apply_of_not_mem f),
by conv {to_rhs, rw [← subtype_perm_of_subtype f, sign_subtype_perm _ _ this]}

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

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

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

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

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

section congr

variables [decidable_eq β] [fintype β]

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

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

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

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

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

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

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

end congr

end sign

end equiv.perm


/-
Copyright (c) 2021 Oliver Nash. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Oliver Nash
-/
import algebra.lie.nilpotent

/-!
# Cartan subalgebras

Cartan subalgebras are one of the most important concepts in Lie theory. We define them here.
The standard example is the set of diagonal matrices in the Lie algebra of matrices.

## Main definitions

  * `lie_subalgebra.normalizer`
  * `lie_subalgebra.le_normalizer_of_ideal`
  * `lie_subalgebra.is_cartan_subalgebra`

## Tags

lie subalgebra, normalizer, idealizer, cartan subalgebra
-/

universes u v w w₁ w₂

variables {R : Type u} {L : Type v}
variables [comm_ring R] [lie_ring L] [lie_algebra R L] (H : lie_subalgebra R L)

namespace lie_subalgebra

/-- The normalizer of a Lie subalgebra `H` is the set of elements of the Lie algebra whose bracket
with any element of `H` lies in `H`. It is the Lie algebra equivalent of the group-theoretic
normalizer (see `subgroup.normalizer`) and is an idealizer in the sense of abstract algebra. -/
def normalizer : lie_subalgebra R L :=
{ carrier   := { x : L | ∀ (y : L), (y ∈ H) → ⁅x, y⁆ ∈ H },
  zero_mem' := λ y hy, by { rw zero_lie y, exact H.zero_mem, },
  add_mem'  := λ z₁ z₂ h₁ h₂ y hy, by { rw add_lie, exact H.add_mem (h₁ y hy) (h₂ y hy), },
  smul_mem' := λ t y hy z hz, by { rw smul_lie, exact H.smul_mem t (hy z hz), },
  lie_mem'  := λ z₁ z₂ h₁ h₂ y hy, by
    { rw lie_lie, exact H.sub_mem (h₁ _ (h₂ y hy)) (h₂ _ (h₁ y hy)), }, }

lemma mem_normalizer_iff (x : L) : x ∈ H.normalizer ↔ ∀ (y : L), (y ∈ H) → ⁅x, y⁆ ∈ H := iff.rfl

lemma mem_normalizer_iff' (x : L) : x ∈ H.normalizer ↔ ∀ (y : L), (y ∈ H) → ⁅y, x⁆ ∈ H :=
forall₂_congr $ λ y hy, by rw [← lie_skew, H.neg_mem_iff]

lemma le_normalizer : H ≤ H.normalizer :=
λ x hx, show ∀ (y : L), y ∈ H → ⁅x,y⁆ ∈ H, from λ y, H.lie_mem hx

variables {H}

lemma lie_mem_sup_of_mem_normalizer {x y z : L} (hx : x ∈ H.normalizer)
  (hy : y ∈ (R ∙ x) ⊔ ↑H) (hz : z ∈ (R ∙ x) ⊔ ↑H) : ⁅y, z⁆ ∈ (R ∙ x) ⊔ ↑H :=
begin
  rw submodule.mem_sup at hy hz,
  obtain ⟨u₁, hu₁, v, hv : v ∈ H, rfl⟩ := hy,
  obtain ⟨u₂, hu₂, w, hw : w ∈ H, rfl⟩ := hz,
  obtain ⟨t, rfl⟩ := submodule.mem_span_singleton.mp hu₁,
  obtain ⟨s, rfl⟩ := submodule.mem_span_singleton.mp hu₂,
  apply submodule.mem_sup_right,
  simp only [lie_subalgebra.mem_coe_submodule, smul_lie, add_lie, zero_add, lie_add, smul_zero,
    lie_smul, lie_self],
  refine H.add_mem (H.smul_mem s _) (H.add_mem (H.smul_mem t _) (H.lie_mem hv hw)),
  exacts [(H.mem_normalizer_iff' x).mp hx v hv, (H.mem_normalizer_iff x).mp hx w hw],
end

/-- A Lie subalgebra is an ideal of its normalizer. -/
lemma ideal_in_normalizer : ∀ {x y : L}, x ∈ H.normalizer → y ∈ H → ⁅x,y⁆ ∈ H :=
λ x y h, h y

/-- A Lie subalgebra `H` is an ideal of any Lie subalgebra `K` containing `H` and contained in the
normalizer of `H`. -/
lemma exists_nested_lie_ideal_of_le_normalizer
  {K : lie_subalgebra R L} (h₁ : H ≤ K) (h₂ : K ≤ H.normalizer) :
  ∃ (I : lie_ideal R K), (I : lie_subalgebra R K) = of_le h₁ :=
begin
  rw exists_nested_lie_ideal_coe_eq_iff,
  exact λ x y hx hy, ideal_in_normalizer (h₂ hx) hy,
end

/-- The normalizer of a Lie subalgebra `H` is the maximal Lie subalgebra in which `H` is a Lie
ideal. -/
lemma le_normalizer_of_ideal {N : lie_subalgebra R L}
  (h : ∀ (x y : L), x ∈ N → y ∈ H → ⁅x,y⁆ ∈ H) : N ≤ H.normalizer :=
λ x hx y, h x y hx

variables (H)

lemma normalizer_eq_self_iff :
  H.normalizer = H ↔ (lie_module.max_triv_submodule R H $ L ⧸ H.to_lie_submodule) = ⊥ :=
begin
  rw lie_submodule.eq_bot_iff,
  refine ⟨λ h, _, λ h, le_antisymm (λ x hx, _) H.le_normalizer⟩,
  { rintros ⟨x⟩ hx,
    suffices : x ∈ H, by simpa,
    rw [← h, H.mem_normalizer_iff'],
    intros y hy,
    replace hx : ⁅_, lie_submodule.quotient.mk' _ x⁆ = 0 := hx ⟨y, hy⟩,
    rwa [← lie_module_hom.map_lie, lie_submodule.quotient.mk_eq_zero] at hx, },
  { let y := lie_submodule.quotient.mk' H.to_lie_submodule x,
    have hy : y ∈ lie_module.max_triv_submodule R H (L ⧸ H.to_lie_submodule),
    { rintros ⟨z, hz⟩,
      rw [← lie_module_hom.map_lie, lie_submodule.quotient.mk_eq_zero, coe_bracket_of_module,
        submodule.coe_mk, mem_to_lie_submodule],
      exact (H.mem_normalizer_iff' x).mp hx z hz, },
    simpa using h y hy, },
end

/-- A Cartan subalgebra is a nilpotent, self-normalizing subalgebra. -/
class is_cartan_subalgebra : Prop :=
(nilpotent        : lie_algebra.is_nilpotent R H)
(self_normalizing : H.normalizer = H)

end lie_subalgebra

@[simp] lemma lie_ideal.normalizer_eq_top {R : Type u} {L : Type v}
  [comm_ring R] [lie_ring L] [lie_algebra R L] (I : lie_ideal R L) :
  (I : lie_subalgebra R L).normalizer = ⊤ :=
begin
  ext x,
  simpa only [lie_subalgebra.mem_normalizer_iff, lie_subalgebra.mem_top, iff_true]
    using λ y hy, I.lie_mem hy
end

open lie_ideal

/-- A nilpotent Lie algebra is its own Cartan subalgebra. -/
instance lie_algebra.top_is_cartan_subalgebra_of_nilpotent [lie_algebra.is_nilpotent R L] :
  lie_subalgebra.is_cartan_subalgebra (⊤ : lie_subalgebra R L) :=
{ nilpotent        := infer_instance,
  self_normalizing :=
    by { rw [← top_coe_lie_subalgebra, normalizer_eq_top, top_coe_lie_subalgebra], }, }


import fundamental_groupoid_product

noncomputable theory

variables {X : Type*} {Y : Type*} [topological_space X] [topological_space Y] {f g : C(X, Y)}
          (H : continuous_map.homotopy f g)

namespace continuous_map.homotopy

def to_path (x : X) : path (f x) (g x) :=
{ to_fun := λ t, H (t, x),
  source' := by simp only [continuous_map.homotopy.apply_zero],
  target' := by simp only [continuous_map.homotopy.apply_one], }

end continuous_map.homotopy

open_locale unit_interval

namespace path.homotopic

local attribute [instance] path.homotopic.setoid

section cast

variables {x₀ x₁ x₂ x₃ : X}

protected def cast (p₀ : x₀ = x₁) (p₁ : x₂ = x₃) (P : path.homotopic.quotient x₁ x₃) :
  (path.homotopic.quotient x₀ x₂) := by rwa [p₀, p₁]

@[simp] lemma cast_of_eq (P : path.homotopic.quotient x₀ x₁) : path.homotopic.cast rfl rfl P = P := rfl

lemma cast_lift (p₀ : x₀ = x₁) (p₁ : x₂ = x₃) (P₀ : path x₁ x₃) : ⟦P₀.cast p₀ p₁⟧ = path.homotopic.cast p₀ p₁ ⟦P₀⟧ :=
by { subst_vars, rw cast_of_eq, congr, ext, rw path.cast_coe, }

lemma path_heq_cast (p₀ : x₀ = x₁) (p₁ : x₂ = x₃) (P : path x₁ x₃) : P.cast p₀ p₁ == P :=
by { subst_vars, rw heq_iff_eq, ext, rw path.cast_coe, }

lemma path.homotopic.heq_cast (p₀ : x₀ = x₁) (p₁ : x₂ = x₃) (P : path.homotopic.quotient x₁ x₃) :
path.homotopic.cast p₀ p₁ P == P := by { subst_vars, refl, }

end cast

variables (x₀ x₁ : X) (p : path.homotopic.quotient x₀ x₁)

def straight_path : path (0 : I) (1 : I) := { to_fun := id, source' := rfl, target' := rfl }

def diagonal_path : path.homotopic.quotient (H (0, x₀)) (H (1, x₁)) :=
(path.homotopic.prod ⟦straight_path⟧ p).map_fn H.to_continuous_map

def diagonal_path' : path.homotopic.quotient (f x₀) (g x₁) :=
path.homotopic.cast (H.apply_zero x₀).symm (H.apply_one x₁).symm (diagonal_path H x₀ x₁ p)

lemma up_is_f : (p.map_fn f) = path.homotopic.cast (H.apply_zero x₀).symm (H.apply_zero x₁).symm ((path.homotopic.prod ⟦path.refl (0 : I)⟧ p).map_fn H.to_continuous_map) :=
begin
  apply quotient.induction_on p,
  intro p',
  rw [path.homotopic.prod_lift, ← path.homotopic.map_lift, ← path.homotopic.map_lift, ← cast_lift],
  congr, ext, simp,
end

lemma down_is_g : p.map_fn g = path.homotopic.cast (H.apply_one x₀).symm (H.apply_one x₁).symm ((path.homotopic.prod ⟦path.refl (1 : I)⟧ p).map_fn H.to_continuous_map) :=
begin
  apply quotient.induction_on p,
  intro p',
  rw [path.homotopic.prod_lift, ← path.homotopic.map_lift, ← path.homotopic.map_lift, ← cast_lift],
  congr, ext, simp,
end

lemma H_to_path (x : X) : ⟦H.to_path x⟧ =
  path.homotopic.cast (H.apply_zero x).symm (H.apply_one x).symm ((path.homotopic.prod ⟦straight_path⟧ ⟦path.refl x⟧).map_fn H.to_continuous_map) :=
by { rw [prod_lift, ← map_lift, ← cast_lift], refl, }

lemma up_right_is_diag : (p.map_fn f).comp ⟦H.to_path x₁⟧ = diagonal_path' H x₀ x₁ p :=
begin
  rw up_is_f H x₀ x₁ p,
  sorry,
end

end path.homotopic


import Saturn.Prover
import Saturn.FinSeq
import Saturn.Vector
import Saturn.Clause
import Saturn.Containment
import Saturn.Solverstep
import Saturn.Resolution
import Saturn.PosRestClause
import Saturn.PrependClause
import Saturn.SatSolution
import Saturn.LiftSolution
open Nat
open FinSeq

/-
The DPLL algorithm with proofs. Here we implement:
  - restricting to a branch.
  - the simple cases of having contradictions or no clauses.
  - the base case: length one clauses in our implementation
  - lifting of proofs from branches and combining them if necessary
-/

instance {n: Nat} : DecidableEq (Clause n) :=
  fun c1 c2 =>
  match decEq c1.coords c2.coords with
  | isTrue pf => isTrue (coords_eq_implies_vec_eq pf)
  | isFalse contra => isFalse (
      fun hyp =>
        contra (congrArg Vector.coords hyp)
  )

/-
We map to branches inductively. The main work is done earlier.
-/
def prependResData{dom n: Nat}(branch: Bool)(focus: Nat)(focusLt : focus < n + 1)
    (clauses: Vector (Clause (n + 1)) dom):
        (rd : ReductionData branch focus focusLt clauses) →
           (head : Clause (n + 1)) →
        ReductionData branch focus focusLt (head +: clauses) :=
        fun rd  head =>
          if c : head.coords focus focusLt = some branch then
            PosResClause.prependResData branch focus focusLt clauses head c rd
          else
            PrependClause.prependResData branch focus focusLt clauses head c rd

def restrictionDataAux{domHead domAccum dom n: Nat}(branch: Bool)
    (focus: Nat)(focusLt : focus < n + 1):
    (clausesHead: Vector (Clause (n + 1)) domHead) →
    (clausesAccum: Vector (Clause (n + 1)) domAccum) →
    (s : domHead + domAccum = dom) →
    (restAcum : ReductionData branch focus focusLt clausesAccum) →
    (clauses: Vector (Clause (n + 1)) dom) →
    (clsEq : concatSeqAux s clausesHead.coords clausesAccum.coords = clauses.coords) →
        ReductionData branch focus focusLt clauses :=
    match domHead with
    | zero =>
      by
        intro clausesHead clausesAccum s restAccum clauses clsEq
        have ss : dom = domAccum := by
          rw [← s]
          apply Nat.zero_add
          done
        have sf : FinSeq dom (Clause (n + 1))  = FinSeq domAccum (Clause (n + 1)):= by
          rw [ss]
        have clSeq : clauses = clauses.coords.vec := by
          apply coords_eq_implies_vec_eq
          rw [seq_to_vec_coords]
        have resolve : concatSeqAux s clausesHead.coords clausesAccum.coords =
            Eq.mpr sf clausesAccum.coords := by rfl
        rw [clSeq]
        rw [← clsEq]
        rw [resolve]
        match dom , domAccum, ss, sf, clausesAccum, restAccum with
        | d, .(d), rfl, rfl, cls,  ra =>
          have sm : FinSeq.vec (cls.coords) = cls := by
            apply coords_eq_implies_vec_eq
            rw [seq_to_vec_coords]
          rw [← sm] at ra
          exact ra
    | k + 1 => fun clausesHead clausesAccum s restAccum clauses clsEq =>
      let ss : k + (domAccum + 1)  = dom :=
        by
          rw [← s]
          rw [(Nat.add_comm domAccum 1)]
          rw [(Nat.add_assoc k 1 domAccum)]
          done
      let resolve : concatSeqAux s clausesHead.coords clausesAccum.coords =
        concatSeqAux ss (clausesHead.coords.init) ((clausesHead.coords.last) +| clausesAccum.coords) := rfl
      let recRestAccum :=
        prependResData branch focus focusLt clausesAccum restAccum (last clausesHead.coords)
      restrictionDataAux branch focus focusLt (FinSeq.vec (init clausesHead.coords))
          ((last clausesHead.coords) +: clausesAccum) ss recRestAccum clauses
          (by
            have sm : (FinSeq.vec (init clausesHead.coords)).coords =
                init (clausesHead.coords) := by rw [seq_to_vec_coords]
            rw [sm,
               (cons_commutes (last (clausesHead.coords)) clausesAccum),
               ← resolve,
               clsEq]
            done)

def restrictionData{dom n: Nat}(branch: Bool)(focus: Nat)(focusLt : focus < n + 1):
    (clauses: Vector (Clause (n + 1)) dom) →
        ReductionData branch focus focusLt clauses :=
        fun clauses =>
          let rc : ReductionClauses branch focus focusLt Vector.nil :=
              ⟨0, Vector.nil, Vector.nil,
                fun k w => nomatch w,
                Vector.nil, fun k w => nomatch w⟩
          let rd : ReductionData branch focus focusLt Vector.nil := ⟨rc,
            ⟨fun k w => nomatch w⟩,
            ⟨fun k w => nomatch w⟩,
            ⟨fun k w => nomatch w⟩,
            ⟨(by
                intro k kw
                have eq0 : rc.codom = 0 := by rfl
                rw [eq0] at kw
                have contra := not_lt_zero _ kw
                exact False.elim contra
            )⟩⟩
          restrictionDataAux branch focus focusLt clauses Vector.nil
              (Nat.add_zero dom) rd clauses (concat_empty_seq_id clauses.coords)

/-
The simple cases: having a contradiction or having no clauses.
-/

def contraSol{n dom: Nat}{clauses : Vector (Clause (n + 1)) dom}{j : Nat}{jw : j < dom}
                (eqn : clauses.coords j jw = contradiction (n + 1)): SatSolution clauses :=
                  SatSolution.unsat (ResolutionTree.assumption j jw _ eqn)

def emptySol{n: Nat}(clauses : Vector (Clause (n + 1)) zero) : SatSolution clauses :=
        SatSolution.sat (FinSeq.vec (fun k kw => true))  (fun k kw => nomatch kw)

/-
Solution for length one clauses
-/
def lengthOneEqual{cl1 cl2 : Clause 1}(eql : cl1.coords zero (zero_lt_succ zero) = cl2.coords zero (zero_lt_succ zero)) :
                          cl1 = cl2 :=
                            coords_eq_implies_vec_eq
                            (funext (fun j =>
                                    match j with
                                    | zero => funext (fun jw => eql)
                                    | i + 1 => funext (fun jw => nomatch jw)
                                    ))

def lengthOneUnit{cl: Clause 1}{b : Bool}(eql : cl.coords zero (zero_lt_succ zero) = some b):
                                cl = unitClause zero b zero (zero_lt_succ zero) :=
                                let lem1 :
                                  (unitClause zero b zero (zero_lt_succ zero)).coords zero (zero_lt_succ zero) =
                                    some b :=
                                          by
                                            apply unitDiag
                                let lem2 : cl.coords zero (zero_lt_succ zero) =
                                    (unitClause zero b zero (zero_lt_succ zero)).coords
                                      zero (zero_lt_succ zero)
                                      :=
                                          by
                                            rw [eql]
                                            exact Eq.symm lem1
                                            done
                                lengthOneEqual lem2

def lengthOneContra{cl: Clause 1}(eql : cl.coords zero (zero_lt_succ zero) = none):
                              cl = contradiction 1 := lengthOneEqual eql

def lengthOneSolution{dom : Nat}: (clauses : Vector (Clause 1) dom) →  SatSolution clauses :=
    match dom with
    | zero => fun cls => emptySol cls
    | l + 1 =>
      fun cls =>
      match searchElem cls.coords (contradiction 1) with
      | ExistsElem.exsts index bound eqn => contraSol eqn
      | ExistsElem.notExst noContra =>
        let head := cls.coords (zero) (zero_lt_succ l)
        if c : head.coords zero (zero_lt_succ zero) = none then
          let eqn := lengthOneContra c
          contraSol eqn
        else
          if ct : head.coords zero (zero_lt_succ zero) = some true then
              match searchElem cls.coords (unitClause zero false zero (zero_lt_succ zero)) with
              | ExistsElem.exsts index bound eqn =>
                  let treePf2 := unitProof eqn
                  let treePf1 :
                    ResolutionTree cls (unitClause zero true zero (zero_lt_succ zero)) :=
                    ResolutionTree.assumption zero (zero_lt_succ l) _ (lengthOneUnit ct)
                  let tree := mergeAlignUnitTrees treePf1 treePf2
                  SatSolution.unsat tree
              | ExistsElem.notExst noNeg =>
                 SatSolution.sat (FinSeq.vec (fun _ _ => true))
                    fun k kw =>
                      let lem1 : Not ((cls.coords k kw).coords zero (zero_lt_succ zero) = some false) :=
                        fun hyp => noNeg k kw (lengthOneUnit hyp)
                      let lem2 : Not ((cls.coords k kw).coords zero (zero_lt_succ zero) = none) :=
                        fun hyp => noContra k kw (lengthOneContra hyp)
                      let lem : (cls.coords k kw).coords zero (zero_lt_succ zero) = some true :=
                        match (cls.coords k kw).coords zero (zero_lt_succ zero), lem1, lem2 with
                        | some true, l1, l2 => rfl
                        | some false, l1, l2 => absurd (l1 rfl) id
                        | none, l1, l2 => absurd (l2 rfl) id
                      ⟨zero, zero_lt_succ _, lem⟩
          else
            if cf : head.coords zero (zero_lt_succ zero) = some false then
              match searchElem cls.coords (unitClause zero true zero (zero_lt_succ zero)) with
              | ExistsElem.exsts index bound eqn =>
                  let treePf2 := unitProof eqn
                  let treePf1 :
                    ResolutionTree cls (unitClause zero false zero (zero_lt_succ zero)) :=
                    ResolutionTree.assumption zero (zero_lt_succ l) _ (lengthOneUnit cf)
                  let tree := mergeAlignUnitTrees treePf1 treePf2
                  SatSolution.unsat tree
              | ExistsElem.notExst noNeg =>
                 SatSolution.sat (FinSeq.vec (fun _ _ => false))
                    fun k kw =>
                      let lem1 : Not ((cls.coords k kw).coords zero (zero_lt_succ zero) = some true) :=
                        fun hyp => noNeg k kw (lengthOneUnit hyp)
                      let lem2 : Not ((cls.coords k kw).coords zero (zero_lt_succ zero) = none) :=
                        fun hyp => noContra k kw (lengthOneContra hyp)
                      let lem : (cls.coords k kw).coords zero (zero_lt_succ zero) = some false :=
                        match (cls.coords k kw).coords zero (zero_lt_succ zero), lem1, lem2 with
                        | some false, l1, l2 => rfl
                        | some true, l1, l2 => False.elim (l1 rfl)
                        | none, l1, l2 => False.elim (l2 rfl)
                      ⟨zero, zero_lt_succ _, lem⟩
            else
                match head.coords zero (zero_lt_succ zero), c, ct, cf with
                | some true, l1, l2, l3 => False.elim (l2 rfl)
                | some false, l1, l2, l3 => False.elim (l3 rfl)
                | none, l1, l2, l3 => False.elim (l1 rfl)

-- a helper
theorem notpure_cases(b: Bool): (x : Option Bool) → x = none ∨  x = some b  →
        Not (x = some (not b)) :=
  fun x eqn  =>
     match b, eqn  with
     | true, Or.inr pf =>
            fun hyp =>
              let lem1 : some true = some false := by
                rw [← pf]
                rw [hyp]
                rfl
                done
              let lem2 : true = false := by
                  injection lem1
                  assumption
              Bool.noConfusion lem2
     | false, Or.inr pf =>
              fun hyp =>
              let lem1 : some true = some false := by
                rw [← pf]
                rw [hyp]
                rfl
                done
              let lem2 : true = false := by
                  injection lem1
                  assumption
              Bool.noConfusion lem2
     | _ , Or.inl pf => fun hyp =>
        let w := Eq.trans (Eq.symm pf) hyp
        Option.noConfusion w

/-
Lifting under containment and from branches and putting together lifts
-/
def containmentLift{dom n: Nat}(clauses : Vector (Clause (n + 1)) dom)
    (cntn : Containment clauses):
          SatSolution (cntn.imageSeq) → SatSolution clauses :=
          fun sol =>
          match sol with
          | SatSolution.sat val pf =>
              SatSolution.sat val (
                fun k kw =>
                        let ⟨ind, bd, w⟩ := cntn.forward k kw
                        let ev := pf ind bd
                        let lem := containsSat (clauses.coords k kw) (cntn.imageSeq.coords ind bd) w val
                        lem ev)

          | SatSolution.unsat tree =>
                let tree :=
                  transportResTree cntn.imageSeq clauses cntn.reverse (contradiction (n + 1))
                    tree
                SatSolution.unsat tree

def solveSAT{n dom : Nat}: (clauses : Vector (Clause (n + 1)) dom) →  SatSolution clauses :=
      match n with
      | zero => fun clauses => lengthOneSolution clauses
      | m + 1 =>
        fun clauses =>
        let posCount  := clauses.map (parityCount true)
        let negCount  := clauses.map (parityCount false)
        match findElem? clauses.coords (contradiction (m + 2)) with
        | some z => contraSol z.equation
        | none =>
          let cntn := simplifiedContainment clauses posCount negCount
          let cls := cntn.imageSeq
          let posCount  := cls.map (parityCount true)
          let negCount  := cls.map (parityCount false)
          let solution : SatSolution cls :=
              match someUnitClause cls.coords posCount negCount with
              | some ⟨i, iw, index, bd, par, eql⟩ =>
                  let rd := restrictionData par index bd cls
                  let subCls := rd.restrictionClauses.restClauses
                  let subSol := solveSAT subCls
                  match subSol with
                  | SatSolution.sat valuation pf =>
                    let pb :=  pullBackSolution par index bd cls
                        rd.restrictionClauses rd.droppedProof rd.forwardRelation valuation pf
                    let valuationN := insert par _ index bd valuation.coords
                    SatSolution.sat valuationN.vec pb
                  | SatSolution.unsat tree  =>
                      let liftedProof :=
                        pullBackResTree  par index bd cls
                            rd.restrictionClauses rd.nonPosReverse rd.reverseRelation
                            tree
                      match liftedProof with
                      | LiftedResTree.contra pf =>
                          SatSolution.unsat pf
                      | LiftedResTree.unit tree =>
                          let tree1 := unitProof eql
                          let merged := mergeAlignUnitTrees tree1 tree
                          SatSolution.unsat merged
              | none =>
                match hasPure cls with
                | some ⟨index, bd, par, evid⟩=>
                  let rd := restrictionData par index bd cls
                  let subCls := rd.restrictionClauses.restClauses
                  let subSol := solveSAT subCls
                  match subSol with
                  | SatSolution.sat valuation pf =>
                    let pb :=  pullBackSolution par index bd cls
                        rd.restrictionClauses rd.droppedProof rd.forwardRelation valuation pf
                    let valuationN := insert par _ index bd valuation.coords
                    SatSolution.sat valuationN.vec pb
                  | SatSolution.unsat tree =>
                      let liftedProof :=
                        pullBackResTree  par index bd cls
                            rd.restrictionClauses rd.nonPosReverse rd.reverseRelation
                            tree
                      match liftedProof with
                      | LiftedResTree.contra pf =>
                          SatSolution.unsat pf
                      | LiftedResTree.unit tree =>
                          let base : (j : Nat) → (lt : j < cntn.codom) →
                              Not ((cls.coords j lt).coords index bd = some (not par)) :=
                                fun j jw =>
                                  notpure_cases par ((cls.coords j jw).coords index bd) (evid j jw)
                          let pure :=
                            trees_preserve_notsomebranch (not par) index bd base
                                   (unitClause (m + 1) (!par) index bd)
                                   tree
                          let impure := unitDiag (m + 1) (not par) index bd
                          absurd impure pure
                | none =>
                  let index := zero
                  let bd := zero_lt_succ (m + 1)
                  let rd : ReductionData false zero bd cls :=
                      restrictionData false index bd cls
                  let subCls := rd.restrictionClauses.restClauses
                  let subSol: SatSolution subCls := solveSAT subCls
                  match subSol with
                  | SatSolution.sat valuation pf =>
                    let pb :=  pullBackSolution false index bd cls
                        rd.restrictionClauses rd.droppedProof rd.forwardRelation valuation pf
                    let valuationN := insert false _ index bd valuation.coords
                    SatSolution.sat valuationN.vec pb
                  | SatSolution.unsat tree =>
                      let liftedProof : LiftedResTree false zero bd cls :=
                        pullBackResTree  false index bd cls
                            rd.restrictionClauses rd.nonPosReverse rd.reverseRelation
                            tree
                      match liftedProof with
                      | LiftedResTree.contra pf =>
                          SatSolution.unsat pf
                      | LiftedResTree.unit tree1 =>
                          let rd : ReductionData true zero bd cls
                              := restrictionData true index bd cls
                          let subCls := rd.restrictionClauses.restClauses
                          let subSol := solveSAT subCls
                          match subSol with
                          | SatSolution.sat valuation pf =>
                            let pb :=  pullBackSolution true index bd cls
                                rd.restrictionClauses rd.droppedProof rd.forwardRelation valuation pf
                            let valuationN := insert true _ index bd valuation.coords
                            SatSolution.sat valuationN.vec pb
                          | SatSolution.unsat tree  =>
                              let liftedProof :=
                                pullBackResTree  true index bd cls
                                    rd.restrictionClauses rd.nonPosReverse rd.reverseRelation
                                    tree
                              match liftedProof with
                              | LiftedResTree.contra pf =>
                                  SatSolution.unsat pf
                              | LiftedResTree.unit tree2 =>
                                  let merged := mergeUnitTrees index bd tree2 tree1
                                  SatSolution.unsat merged
        containmentLift clauses cntn solution

/-
Decidability and convenience functions.
-/
instance {dom n: Nat}{clauses : Vector (Clause (n + 1)) dom}
                 : Prover (SatSolution clauses) where
      statement := fun sol => solutionProp sol
      proof := fun sol => solutionProof sol

def proveOrDisprove{n dom : Nat}(clauses : Vector (Clause (n + 1)) dom) :=
            getProof (solveSAT clauses)

instance {n dom : Nat}{clauses : Vector (Clause (n + 1)) dom} :
    Decidable (isSat clauses) :=
    match solveSAT clauses with
      | SatSolution.sat valuation evidence =>
          isTrue ⟨valuation, evidence⟩
      | SatSolution.unsat tree => isFalse $ fun hyp =>
            not_sat_and_unsat clauses hyp $ tree_unsat clauses tree

instance {n dom : Nat}{clauses : Vector (Clause (n + 1)) dom} :
    Decidable (isUnSat clauses) :=
    match solveSAT clauses with
      | SatSolution.sat valuation evidence => isFalse $ fun hyp =>
        not_sat_and_unsat clauses ⟨valuation, evidence⟩ hyp
      | SatSolution.unsat tree =>
        isTrue $ tree_unsat clauses tree


import data.hash_map .atom

namespace nominal
open list

inductive exp : Type
| var : atom → exp
| const : ℕ → exp
| abs : atom → exp → exp
| app : exp → exp → exp

open exp

def fvs : exp → list atom
| (var v)     := [v]
| (const n)   := []
| (abs v e)   := remove_all (fvs e) [v]
| (app e₁ e₂) := fvs e₁ ∪ fvs e₂

def swap_var (x y z : atom) : atom :=
  if z = x then y else if z = y then x else z.

def swap (x y : atom) : exp → exp
| (var z)     := var (swap_var x y z)
| (const n)   := const n
| (abs z e)   := abs (swap_var x y z) (swap e)
| (app e₁ e₂) := app (swap e₁) (swap e₂)

@[reducible] def heap := hash_map atom (λ x, exp)
structure frame := (val : exp)
def stack := list frame

structure config := (hp : heap) (t : exp) (stk : stack)

inductive step (α : Type) : Type
| error {}  : step
| done  {}  : exp → step
| take      : α → step

def machine_step (avoid : list atom) : config → step config
| ⟨hp, abs x e, []⟩ := step.done (abs x e)

| ⟨hp, abs x e, (⟨val⟩ :: stk)⟩ :=
 if x ∈ hp ∨ x ∈ avoid
 then let y := atom.fresh (hp^.keys ∪ avoid) in step.take ⟨hp^.insert y val, swap x y e, stk⟩
 else step.take ⟨hp^.insert x val, e, stk⟩

| ⟨hp, var x, stk⟩ := match hp^.find x with
                     | some e := step.take ⟨hp, e, stk⟩
                     | none   := step.error
                     end

| ⟨hp, app f a, stk⟩ := step.take ⟨hp, f, ⟨a⟩ :: stk⟩

| ⟨hp, const n, stk⟩ := step.done (const n)

def init_config (t : exp) : config := ⟨mk_hash_map (λ a : atom, a^.id), t, []⟩

def is_val : exp → Prop
| (abs _ _) := true
| _         := false

lemma values_are_done (avoid : list atom) : ∀ (t : exp), is_val t → machine_step avoid (init_config t) = step.done t
| (abs x e) _ := rfl
| (const n) _ := rfl
| (var v) H_contra := false.rec _ H_contra
| (app f a) H_contra := false.rec _ H_contra

def size : exp → ℕ
| (var x) := 1
| (const n) := 1
| (abs x e) := 1 + size e
| (app f a) := 1 + size f + size a

lemma swap_size_eq (x y : atom) : ∀ t, size (swap x y t) = size t :=
begin
intro t,
induction t,
reflexivity,
all_goals { simp [swap, size], try { cc } }
end

/-
inductive exp : Type
| var : atom → exp
| const : ℕ → exp
| abs : atom → exp → exp
| app : exp → exp → exp
-/
open exp

inductive result : Type
| error   : string → result
| done    : exp → result
| nofuel  : exp → result

def reduce (avoid : list atom) : ℕ → config → result
| 0     ⟨hp, e, stk⟩       := result.nofuel e
| (t+1) ⟨hp, abs x e, []⟩  := result.done (abs x e)
| (t+1) ⟨hp, const n, stk⟩ := result.done (const n)

| (t+1) ⟨hp, abs x e, (⟨val⟩ :: stk)⟩ :=
 if x ∈ hp ∨ x ∈ avoid
 then let y := atom.fresh (hp^.keys ∪ avoid) in reduce t ⟨hp^.insert y val, swap x y e, stk⟩
 else reduce t ⟨hp^.insert x val, e, stk⟩

| (t+1) ⟨hp, var x, stk⟩ :=
 match hp^.find x with
 | some e := reduce t ⟨hp, e, stk⟩
 | none   := result.error "variable not found"
 end

| (t+1) ⟨hp, app f a, stk⟩ := reduce t ⟨hp, f, ⟨a⟩ :: stk⟩

example : reduce [] 10 (init_config $ app (abs ⟨0⟩ (var ⟨0⟩)) (const 5)) = result.done (const 5) :=
begin
simp [reduce, init_config, hash_map.not_contains_empty, has_mem.mem, list.mem, hash_map.find_insert],
end

end nominal


/-
Copyright (c) 2022 Andrew Yang. All rights reserved.
Released under Apache 2.0 license as described in the file LICENSE.
Authors: Andrew Yang
-/
import algebraic_geometry.properties

/-!
# Function field of integral schemes

We define the function field of an irreducible scheme as the stalk of the generic point.
This is a field when the scheme is integral.

## Main definition
* `algebraic_geometry.Scheme.function_field`: The function field of an integral scheme.
* `algebraic_geometry.germ_to_function_field`: The canonical map from a component into the function
  field. This map is injective.
-/

universes u v

open topological_space opposite category_theory category_theory.limits Top

namespace algebraic_geometry

variable (X : Scheme)

/-- The function field of an irreducible scheme is the local ring at its generic point.
Despite the name, this is a field only when the scheme is integral. -/
noncomputable
abbreviation Scheme.function_field [irreducible_space X.carrier] : CommRing :=
X.presheaf.stalk (generic_point X.carrier)

/-- The restriction map from a component to the function field. -/
noncomputable
abbreviation Scheme.germ_to_function_field [irreducible_space X.carrier] (U : opens X.carrier)
  [h : nonempty U] : X.presheaf.obj (op U) ⟶ X.function_field :=
X.presheaf.germ ⟨generic_point X.carrier,
  ((generic_point_spec X.carrier).mem_open_set_iff U.is_open).mpr (by simpa using h)⟩

noncomputable
instance [irreducible_space X.carrier] (U : opens X.carrier) [nonempty U] :
  algebra (X.presheaf.obj (op U)) X.function_field :=
(X.germ_to_function_field U).to_algebra

noncomputable
instance [is_integral X] : field X.function_field :=
begin
  apply field_of_is_unit_or_eq_zero,
  intro a,
  obtain ⟨U, m, s, rfl⟩ := Top.presheaf.germ_exist _ _ a,
  rw [or_iff_not_imp_right, ← (X.presheaf.germ ⟨_, m⟩).map_zero],
  intro ha,
  replace ha := ne_of_apply_ne _ ha,
  have hs : generic_point X.carrier ∈ RingedSpace.basic_open _ s,
  { rw [← set_like.mem_coe, (generic_point_spec X.carrier).mem_open_set_iff, set.top_eq_univ,
      set.univ_inter, set.nonempty_iff_ne_empty, ne.def, ← opens.coe_bot,
      ← set_like.ext'_iff],
    erw basic_open_eq_bot_iff,
    exacts [ha, (RingedSpace.basic_open _ _).is_open] },
  have := (X.presheaf.germ ⟨_, hs⟩).is_unit_map (RingedSpace.is_unit_res_basic_open _ s),
  rwa Top.presheaf.germ_res_apply at this
end

lemma germ_injective_of_is_integral [is_integral X] {U : opens X.carrier} (x : U) :
  function.injective (X.presheaf.germ x) :=
begin
  rw injective_iff_map_eq_zero,
  intros y hy,
  rw ← (X.presheaf.germ x).map_zero at hy,
  obtain ⟨W, hW, iU, iV, e⟩ := X.presheaf.germ_eq _ x.prop x.prop _ _ hy,
  cases (show iU = iV, from subsingleton.elim _ _),
  haveI : nonempty W := ⟨⟨_, hW⟩⟩,
  exact map_injective_of_is_integral X iU e
end

lemma Scheme.germ_to_function_field_injective [is_integral X] (U : opens X.carrier)
  [nonempty U] : function.injective (X.germ_to_function_field U) :=
germ_injective_of_is_integral _ _

lemma generic_point_eq_of_is_open_immersion {X Y : Scheme} (f : X ⟶ Y) [H : is_open_immersion f]
  [hX : irreducible_space X.carrier] [irreducible_space Y.carrier] :
    f.1.base (generic_point X.carrier : _) = (generic_point Y.carrier : _) :=
begin
  apply ((generic_point_spec _).eq _).symm,
  show t0_space Y.carrier, by apply_instance,
  convert (generic_point_spec X.carrier).image (show continuous f.1.base, by continuity),
  symmetry,
  rw [eq_top_iff, set.top_eq_univ, set.top_eq_univ],
  convert subset_closure_inter_of_is_preirreducible_of_is_open _ H.base_open.open_range _,
  rw [set.univ_inter, set.image_univ],
  apply_with preirreducible_space.is_preirreducible_univ { instances := ff },
  show preirreducible_space Y.carrier, by apply_instance,
  exact ⟨_, trivial, set.mem_range_self hX.2.some⟩,
end

noncomputable
instance stalk_function_field_algebra [irreducible_space X.carrier] (x : X.carrier) :
  algebra (X.presheaf.stalk x) X.function_field :=
begin
  apply ring_hom.to_algebra,
  exact X.presheaf.stalk_specializes ((generic_point_spec X.carrier).specializes trivial)
end

instance function_field_is_scalar_tower [irreducible_space X.carrier] (U : opens X.carrier) (x : U)
  [nonempty U] :
  is_scalar_tower (X.presheaf.obj $ op U) (X.presheaf.stalk x) X.function_field :=
begin
  apply is_scalar_tower.of_algebra_map_eq',
  simp_rw [ring_hom.algebra_map_to_algebra],
  change _ = X.presheaf.germ x ≫ _,
  rw X.presheaf.germ_stalk_specializes,
  refl
end

noncomputable
instance (R : CommRing) [is_domain R] : algebra R (Scheme.Spec.obj $ op R).function_field :=
ring_hom.to_algebra $ by { change CommRing.of R ⟶ _, apply structure_sheaf.to_stalk }

@[simp] lemma generic_point_eq_bot_of_affine (R : CommRing) [is_domain R] :
  generic_point (Scheme.Spec.obj $ op R).carrier = (⟨0, ideal.bot_prime⟩ : prime_spectrum R) :=
begin
  apply (generic_point_spec (Scheme.Spec.obj $ op R).carrier).eq,
  simp [is_generic_point_def, ← prime_spectrum.zero_locus_vanishing_ideal_eq_closure]
end

instance function_field_is_fraction_ring_of_affine (R : CommRing.{u}) [is_domain R] :
  is_fraction_ring R (Scheme.Spec.obj $ op R).function_field :=
begin
  convert structure_sheaf.is_localization.to_stalk R _,
  delta is_fraction_ring is_localization.at_prime,
  congr' 1,
  rw generic_point_eq_bot_of_affine,
  ext,
  exact mem_non_zero_divisors_iff_ne_zero
end

instance {X : Scheme} [is_integral X] {U : opens X.carrier} [hU : nonempty U] :
  is_integral (X.restrict U.open_embedding) :=
begin
  haveI : nonempty (X.restrict U.open_embedding).carrier := hU,
  exact is_integral_of_open_immersion (X.of_restrict U.open_embedding)
end

lemma is_affine_open.prime_ideal_of_generic_point {X : Scheme} [is_integral X]
  {U : opens X.carrier} (hU : is_affine_open U) [h : nonempty U] :
  hU.prime_ideal_of ⟨generic_point X.carrier,
    ((generic_point_spec X.carrier).mem_open_set_iff U.is_open).mpr (by simpa using h)⟩ =
  generic_point (Scheme.Spec.obj $ op $ X.presheaf.obj $ op U).carrier :=
begin
  haveI : is_affine _ := hU,
  have e : U.open_embedding.is_open_map.functor.obj ⊤ = U,
  { ext1, exact set.image_univ.trans subtype.range_coe },
  delta is_affine_open.prime_ideal_of,
  rw ← Scheme.comp_val_base_apply,
  convert (generic_point_eq_of_is_open_immersion ((X.restrict U.open_embedding).iso_Spec.hom ≫
    Scheme.Spec.map (X.presheaf.map (eq_to_hom e).op).op)),
  ext1,
  exact (generic_point_eq_of_is_open_immersion (X.of_restrict U.open_embedding)).symm
end

lemma function_field_is_fraction_ring_of_is_affine_open [is_integral X] (U : opens X.carrier)
  (hU : is_affine_open U) [hU' : nonempty U] :
  is_fraction_ring (X.presheaf.obj $ op U) X.function_field :=
begin
  haveI : is_affine _ := hU,
  haveI : nonempty (X.restrict U.open_embedding).carrier := hU',
  haveI : is_integral (X.restrict U.open_embedding) := @@is_integral_of_is_affine_is_domain _ _ _
    (by { dsimp, rw opens.open_embedding_obj_top, apply_instance }),
  have e : U.open_embedding.is_open_map.functor.obj ⊤ = U,
  { ext1, exact set.image_univ.trans subtype.range_coe },
  delta is_fraction_ring Scheme.function_field,
  convert hU.is_localization_stalk ⟨generic_point X.carrier, _⟩ using 1,
  rw [hU.prime_ideal_of_generic_point, generic_point_eq_bot_of_affine],
  ext, exact mem_non_zero_divisors_iff_ne_zero
end

instance (x : X.carrier) : is_affine (X.affine_cover.obj x) :=
algebraic_geometry.Spec_is_affine _

instance [h : is_integral X] (x : X.carrier) :
  is_fraction_ring (X.presheaf.stalk x) X.function_field :=
begin
  let U : opens X.carrier := ⟨set.range (X.affine_cover.map x).1.base,
    PresheafedSpace.is_open_immersion.base_open.open_range⟩,
  haveI : nonempty U := ⟨⟨_, X.affine_cover.covers x⟩⟩,
  have hU : is_affine_open U := range_is_affine_open_of_open_immersion (X.affine_cover.map x),
  exact @@is_fraction_ring.is_fraction_ring_of_is_domain_of_is_localization _ _ _ _ _ _ _ _ _ _ _
    (hU.is_localization_stalk ⟨x, X.affine_cover.covers x⟩)
      (function_field_is_fraction_ring_of_is_affine_open X U hU)
end

end algebraic_geometry


import seplog.f_assertions

section axiomatic_semantics
  open TypeDecl

  /-
   - update the store used in an assertion using the value of an expr
   -/
	def update_store2 {α: TypeDecl} (x: Var α) (e: Expr α) (P: Assert)
                    : Assert :=
    λ s h, (eval e s).elim ⊤ (λ v, P (s.update v x.name) h).

  /-
   - update the store used in an assertion using the value held in a heap
   -/
	def lookup2 {α: TypeDecl} (x: Var α) (e: Expr (gPtr α)) (P: Assert)
              : Assert :=
	  λ s h,
	    ∃ p, val2loc (eval e s) = some p ∧
	      ∃ (z: Val α), h.lookup p = some z ∧
	        P (s.update z x.name) h.

	/-
   - update the heap used in an assertion
   -/
	def update_heap2 {α: TypeDecl} (e:Expr (gPtr α)) (e':Expr α) (P:Assert)
                  : Assert :=
	  λ s h ,
      (eval e' s).elim ⊤ (λ v, -- 2nd expr being an error gives trivial Assert
	    ∃ p, val2loc (eval e s) = some p ∧
	      ∃ (z: Val α), h.lookup p = some z ∧
	        P s (h.update v p)).

  open cmd

	inductive semax: Assert -> cmd -> Assert -> Prop
	  | semax_skip: ∀ P, semax P skip P
	  | semax_assign: ∀ {α: TypeDecl} (P: Assert) (x: Var α) (e: Expr α),
	    semax (update_store2 x e P) (x ⇐ e) P
	  | semax_lookup: ∀ {α: TypeDecl} (P: Assert) (x: Var α) (e: Expr (gPtr α)),
	    semax (lookup2 x e P) (x ↩ e) P
	  | semax_mutation: ∀ {α: TypeDecl} (P: Assert) (e: Expr (gPtr α))
                        (e': Expr α),
	    semax (update_heap2 e e' P) (e ≪ e') P

	  | semax_seq: ∀ P Q R c d,
	    semax P c Q -> semax Q d R -> semax P (c ∣ d) R
	  | semax_while: ∀ (P: Assert) (b: Expr gBool) c,
	    semax (λ s h, (P s h ∧ eval b s = some tt)) c P ->
	    semax P (while b c) (λ s h, P s h ∧ eval b s = some ff)
	  | semax_conseq: ∀ (P P' Q Q':Assert) c,
	    (Q' ⟹ Q) -> (P ⟹ P') ->
	    semax P' c Q' -> semax P c Q
	  | semax_ifte: ∀ (P Q: Assert) (b: Expr gBool) c d,
	    semax (λ s h, P s h ∧ eval b s = some tt) c Q ->
	    semax (λ s h, P s h ∧ eval b s = some ff) d Q ->
	    semax P (ifte b c d) Q.

  notation `{{ ` P ` }} ` c ` {{` Q `}} `   := (semax P c Q)

	/- axiomatic semantic lemmas -/

	lemma semax_weaken_post : ∀ (P Q Q': Assert) c,
	  (Q' ⟹ Q) -> {{ P }} c {{ Q' }} -> {{ P }} c {{ Q }} := sorry.

  lemma semax_strengthen_pre : ∀ (P P':Assert) Q c,
  	  (P ⟹ P') -> {{ P' }} c {{ Q }} -> {{ P }} c {{ Q }} := sorry.

    /- link to operational sematnics-/
  def semax' (P:Assert) (c:cmd) (Q:Assert) : Prop :=
        ∀ s h, (P s h -> ¬(exec (some (s, h)) c none)) ∧
          (∀ s' h', P s h -> (exec (some (s, h)) c  (some (s', h'))) -> Q s' h')

	lemma semax_sound : ∀ P Q c,
	  {{ P }} c {{ Q }} -> semax' P c Q
    := sorry.

  /-
   - Class-definition-dependent assertions
   -/
  def Assert' := Decls → Assert

  def wp_semantics (c: cmd) (Q: Assert'): Assert' :=
      λ d s h,
        ¬ (exec (some (s, h, d))  c none) ∧
        ∀ s' h',
          exec (some (s, h, d)) c  (some (s', h', d)) -> Q d s' h'
          .

	lemma exec_lookup_not_None:
    ∀ {α: TypeDecl} (s: Store) (h: Heap) (d: Decls) (v: Var α)
      (e: Expr (gPtr α)),
        ¬ (exec (some (s, h, d)) (v ↩ e) none) ->
          ∃ p : Address,
            val2loc (eval e s) = some p ∧
            (∃ z: Val α, h.lookup p = some z)
            := sorry.

  lemma exec_mutation_not_None:
    ∀ {α: TypeDecl} (s: Store) (h: Heap) (d: Decls) (e: Expr (gPtr α))
      (e0: Expr α),
        ¬ exec (some (s, h, d)) (e ≪ e0) none ->
        ∃ p : Address,
          val2loc (eval e s) = some p ∧
          (∃ z: Val α, h.lookup p = some z)
          := sorry.

  lemma exec_seq1_not_None: ∀ (s: Store) (h: Heap) (c1 c2: cmd),
      ¬ exec (some (s, h))  (c1 ∣ c2)  none ->
      ¬ exec (some (s, h)) c1 none
      := sorry.

  lemma exec_seq2_not_None:
    ∀ (s: Store) (h: Heap) (c1 c2: cmd) (s': Store) (h': Heap),
      ¬ exec (some (s, h)) (c1 ∣ c2) none ->
      exec (some (s, h)) c1 (some (s',h')) ->
      ¬ exec (some (s', h')) c2 none
      := sorry.

  lemma exec_ifte1_not_None: ∀ s h c1 c2 e,
      ¬ exec (some (s, h))  (ifte e  c1  c2)  none ->
      eval e s = some tt ->
      ¬ exec (some (s, h)) c1  none
      := sorry.

  lemma exec_ifte2_not_None: ∀ s h c1 c2 e,
      ¬ exec (some (s, h))  (ifte e  c1  c2)  none ->
      eval e s = some ff ->
      ¬ exec (some (s, h)) c2  none
      := sorry.

  lemma exec_while1_not_None: ∀ s h e c,
        ¬ exec (some (s, h)) (while e c) none ->
        eval e s = some tt ->
        ¬ exec (some (s, h)) c none
        := sorry.

  lemma exec_while2_not_None: ∀ s h e c s' h',
        ¬ exec (some (s, h)) (while e c) none ->
        eval e s = some tt ->
        exec (some (s, h)) c (some (s', h')) ->
      ¬ exec (some (s', h')) (while e c)  none
      := sorry.

  lemma wp_semantics_sound: ∀ c Q,
      {{wp_semantics c Q}} c {{Q}} := sorry.

  lemma semax_complete : ∀ P Q c,
      semax' P c Q -> {{ P }} c {{ Q }} := sorry.

  def semax_alternative (P:Assert) (c:cmd) (Q:Assert) : Prop :=
      ∀ s h, P s h ->
        (∀ s' h', exec (some (s, h))  c  (some (s', h')) -> (Q s' h')).

  lemma semax_sound_alternative : ∀ P Q c,
    {{ P }} c {{ Q }} -> semax_alternative P c Q := sorry.

  /- Derived reynolds' axioms-/
  lemma semax_lookup_backwards:
    ∀{α: TypeDecl} (x : Var α) (e: Expr (gPtr α)) (P: Assert),
      {{ λ s h, ∃ e0, (e ↦ e0 ∗ (e ↦ e0 ⊸ update_store2 x e0 P)) s h }}
       (x ↩ e) {{ P }} := sorry.

  lemma semax_lookup_backwards_alternative :
    ∀{α: TypeDecl} (x : Var ( α)) (e: Expr (gPtr α)) (P: Assert) (e0: Expr α),
      {{ ((e ↦ e0) ∗ ((e ↦ e0) ⊸ (update_store2 x e0 P))) }} (x ↩ e) {{ P }}
      := sorry.

  lemma semax_mutation_local: ∀{α: TypeDecl} (x : Expr (gPtr α)) v v',
        {{ (x ↦ v) }} (x ≪ v') {{ (x ↦ v') }} := sorry.

  /-
   - Frame rule
   -/

  /-
   - Get list of variables that are modified by a program
   -/
  def modified_cmd_var: cmd → list (Σ α: TypeDecl, Var α)
    | skip              := list.nil
    | (assign x e)      := [⟨_, x⟩]
    | (lookup x e)      := [⟨_, x⟩]
    | (mutation e f)    := list.nil
    | (seq c1 c2)       := modified_cmd_var c1 ++ modified_cmd_var c2
    | (ifte a c1 c2)    := modified_cmd_var c1 ++ modified_cmd_var c2
    | (while a c1)      := modified_cmd_var c1
    | (declare x)       := [⟨_, x⟩]
    | (new x)           := [⟨_, x⟩]
    | (call _ _ _ vars) := vars

  lemma inde_seq : ∀ R (c d: cmd),
	  inde (modified_cmd_var (c ∣ d)) R ->
	  inde (modified_cmd_var c) R ∧ inde (modified_cmd_var d) R := sorry.

  lemma inde_ifte : ∀ R b c d,
      inde (modified_cmd_var (ifte b  c  d)) R →
      inde (modified_cmd_var c) R ∧ inde (modified_cmd_var d) R := sorry.

  lemma frame_rule : ∀ (P: Assert) (c: cmd) (Q: Assert),
      {{P}} c {{Q}} ->
      ∀ (R: Assert) ,
        (inde (modified_cmd_var c) R ->
          {{ (P ∗ R) }} c {{ (Q ∗ R) }}) := sorry.

  /-
  - More reynolds axioms
  -/

	lemma semax_mutation_global :
    ∀ {α: TypeDecl} (P: Assert) (e: Expr (gPtr α)) e',
	  {{((λ s' h', ∃ e'', (((e ↦ e'') s' h'))) ∗ P) }} (e ≪ e') {{((e ↦ e')∗P)}}
    := sorry.

  lemma semax_mutation_global_alternative :
    ∀ {α: TypeDecl} (P: Assert) (e: Expr (gPtr α)) e' e'',
      {{ ((e ↦ e'') ∗ P) }} (e ≪ e') {{ ((e ↦ e') ∗ P) }} := sorry.

  lemma semax_mutation_backwards :
    ∀ {α: TypeDecl} (P: Assert) (e: Expr (gPtr α)) e',
      {{λ s h, ∃ e'', ((e ↦ e'')∗(e ↦ e' ⊸ P)) s h}} (e ≪ e') {{P}} := sorry.

	lemma semax_mutation_backwards_alternative :
   ∀ {α: TypeDecl} (P: Assert) (e: Expr (gPtr α)) e' e'',
	  {{ ((e ↦ e'') ∗ ((e ↦ e') ⊸ P)) }} (e ≪ e') {{ P }} := sorry.

end axiomatic_semantics


import topology.category.Profinite

namespace Profinite

-- A surjective map of compact Hausdorff spaces is a quotient map
-- TODO: This certainly belongs in mathlib, if not already there...
lemma quotient_map {X Y : Profinite} (f : X ⟶ Y) (hf : function.surjective f) :
  quotient_map f :=
begin
  rw quotient_map_iff,
  refine ⟨hf,_⟩,
  intro S,
  refine ⟨λ hS, hS.preimage f.continuous, λ hS, _⟩,
  rw ← is_closed_compl_iff at *,
  rw ← set.preimage_compl at hS,
  have : Sᶜ = f '' (f ⁻¹' Sᶜ),
  { ext,
    split,
    { intro h,
      obtain ⟨y,rfl⟩ := hf x,
      refine ⟨y,h,rfl⟩ },
    { rintro ⟨y,h,rfl⟩,
      exact h } },
  rw this,
  exact Profinite.is_closed_map f (⇑f ⁻¹' Sᶜ) hS
end

end Profinite