feat: Contractions and involutions

This commit is contained in:
jstoobysmith 2025-01-03 15:13:16 +00:00
parent bab9f10763
commit 7d1f15e18a
5 changed files with 662 additions and 99 deletions

View file

@ -17,15 +17,15 @@ open FieldStatistic
variable {𝓕 : Type}
/-- Given a list of fields `l`, the type of pairwise-contractions associated with `l`
which have the list `aux` uncontracted. -/
inductive ContractionsAux : (l : List 𝓕) → (aux : List 𝓕) → Type
/-- Given a list of fields `φs`, the type of pairwise-contractions associated with `φs`
which have the list `φsᵤₙ` uncontracted. -/
inductive ContractionsAux : (φs : List 𝓕) → (φsᵤₙ : List 𝓕) → Type
| nil : ContractionsAux [] []
| cons {l : List 𝓕} {aux : List 𝓕} {a : 𝓕} (i : Option (Fin aux.length)) :
ContractionsAux l aux → ContractionsAux (a :: l) (optionEraseZ aux a i)
| cons {φs : List 𝓕} {φsᵤₙ : List 𝓕} {φ : 𝓕} (i : Option (Fin φsᵤₙ.length)) :
ContractionsAux φs φsᵤₙ → ContractionsAux (φ :: φs) (optionEraseZ φsᵤₙ φ i)
/-- Given a list of fields `l`, the type of pairwise-contractions associated with `l`. -/
def Contractions (l : List 𝓕) : Type := Σ aux, ContractionsAux l aux
def Contractions (φs : List 𝓕) : Type := Σ aux, ContractionsAux φs aux
namespace Contractions
@ -40,6 +40,47 @@ lemma contractions_nil (a : Contractions ([] : List 𝓕)) : a = ⟨[], Contract
cases c
rfl
def embedUncontracted {l : List 𝓕} (c : Contractions l) : Fin c.normalize.length → Fin l.length :=
match l, c with
| [], ⟨[], ContractionsAux.nil⟩ => Fin.elim0
| φ :: φs, ⟨_, .cons (φsᵤₙ := aux) none c⟩ =>
Fin.cons ⟨0, Nat.zero_lt_succ φs.length⟩ (Fin.succ ∘ (embedUncontracted ⟨aux, c⟩))
| φ :: φs, ⟨_, .cons (φsᵤₙ := aux) (some n) c⟩ => by
let lc := embedUncontracted ⟨aux, c⟩
refine Fin.succ ∘ lc ∘ Fin.cast ?_ ∘ Fin.succAbove ⟨n, by
rw [normalize, optionEraseZ_some_length]
omega⟩
simp only [normalize, optionEraseZ_some_length]
have hq : aux.length ≠ 0 := by
by_contra hn
rw [hn] at n
exact Fin.elim0 n
omega
lemma embedUncontracted_injective {l : List 𝓕} (c : Contractions l) :
Function.Injective c.embedUncontracted := by
match l, c with
| [], ⟨[], ContractionsAux.nil⟩ =>
dsimp [embedUncontracted]
intro i
exact Fin.elim0 i
| φ :: φs, ⟨_, .cons (φsᵤₙ := aux) none c⟩ =>
dsimp [embedUncontracted]
refine Fin.cons_injective_iff.mpr ?_
apply And.intro
· simp only [Set.mem_range, Function.comp_apply, not_exists]
exact fun x => Fin.succ_ne_zero (embedUncontracted ⟨aux, c⟩ x)
· exact Function.Injective.comp (Fin.succ_injective φs.length)
(embedUncontracted_injective ⟨aux, c⟩)
| φ :: φs, ⟨_, .cons (φsᵤₙ := aux) (some i) c⟩ =>
dsimp [embedUncontracted]
refine Function.Injective.comp (Fin.succ_injective φs.length) ?hf
refine Function.Injective.comp (embedUncontracted_injective ⟨aux, c⟩) ?hf.hf
refine Function.Injective.comp (Fin.cast_injective (embedUncontracted.proof_5 φ φs aux i c))
Fin.succAbove_right_injective
/-- Establishes uniqueness of contractions for a single field, showing that any contraction
of a single field must be equivalent to the trivial contraction with no pairing. -/
lemma contractions_single {i : 𝓕} (a : Contractions [i]) : a =
@ -67,46 +108,46 @@ def nilEquiv : Contractions ([] : List 𝓕) ≃ Unit where
/-- The equivalence between contractions of `a :: l` and contractions of
`Contractions l` paired with an optional element of `Fin (c.normalize).length` specifying
what `a` contracts with if any. -/
def consEquiv {a : 𝓕} {l : List 𝓕} :
Contractions (a :: l) ≃ (c : Contractions l) × Option (Fin (c.normalize).length) where
def consEquiv {φ : 𝓕} {φs : List 𝓕} :
Contractions (φ :: φs) ≃ (c : Contractions φs) × Option (Fin c.normalize.length) where
toFun c :=
match c with
| ⟨aux, c⟩ =>
match c with
| ContractionsAux.cons (aux := aux') i c => ⟨⟨aux', c⟩, i⟩
| ContractionsAux.cons (φsᵤₙ := aux') i c => ⟨⟨aux', c⟩, i⟩
invFun ci :=
⟨(optionEraseZ (ci.fst.normalize) a ci.2), ContractionsAux.cons (a := a) ci.2 ci.1.2⟩
⟨(optionEraseZ (ci.fst.normalize) φ ci.2), ContractionsAux.cons (φ := φ) ci.2 ci.1.2⟩
left_inv c := by
match c with
| ⟨aux, c⟩ =>
match c with
| ContractionsAux.cons (aux := aux') i c => rfl
| ContractionsAux.cons (φsᵤₙ := aux') i c => rfl
right_inv ci := by rfl
/-- The type of contractions is decidable. -/
instance decidable : (l : List 𝓕) → DecidableEq (Contractions l)
instance decidable : (φs : List 𝓕) → DecidableEq (Contractions φs)
| [] => fun a b =>
match a, b with
| ⟨_, a⟩, ⟨_, b⟩ =>
match a, b with
| ContractionsAux.nil, ContractionsAux.nil => isTrue rfl
| _ :: l =>
haveI : DecidableEq (Contractions l) := decidable l
haveI : DecidableEq ((c : Contractions l) × Option (Fin (c.normalize).length)) :=
| _ :: φs =>
haveI : DecidableEq (Contractions φs) := decidable φs
haveI : DecidableEq ((c : Contractions φs) × Option (Fin (c.normalize).length)) :=
Sigma.instDecidableEqSigma
Equiv.decidableEq consEquiv
/-- The type of contractions is finite. -/
instance fintype : (l : List 𝓕) → Fintype (Contractions l)
instance fintype : (φs : List 𝓕) → Fintype (Contractions φs)
| [] => {
elems := {⟨[], ContractionsAux.nil⟩}
complete := by
intro a
rw [Finset.mem_singleton]
exact contractions_nil a}
| a :: l =>
haveI : Fintype (Contractions l) := fintype l
haveI : Fintype ((c : Contractions l) × Option (Fin (c.normalize).length)) :=
| φ :: φs =>
haveI : Fintype (Contractions φs) := fintype φs
haveI : Fintype ((c : Contractions φs) × Option (Fin (c.normalize).length)) :=
Sigma.instFintype
Fintype.ofEquiv _ consEquiv.symm
@ -120,10 +161,525 @@ instance isFull_decidable : Decidable c.IsFull := by
simp [IsFull]
apply decidable_of_decidable_of_iff hn.symm
def toOptionList : {l : List 𝓕} → (c : Contractions l) → List (Option (Fin l.length))
| [], ⟨[], ContractionsAux.nil⟩ => []
| _ :: _, ⟨_, .cons (φsᵤₙ := aux) none c⟩ => none ::
List.map (Option.map Fin.succ) (toOptionList ⟨aux, c⟩)
| _ :: φs, ⟨_, .cons (φsᵤₙ := aux) (some n) c⟩ =>
some (Fin.succ (embedUncontracted ⟨aux, c⟩ n)) ::
List.set ((List.map (Option.map Fin.succ) (toOptionList ⟨aux, c⟩)))
(embedUncontracted ⟨aux, c⟩ n) (some ⟨0, Nat.zero_lt_succ φs.length⟩)
lemma toOptionList_length {l : List 𝓕} (c : Contractions l) : c.toOptionList.length = l.length := by
match l, c with
| [], ⟨[], ContractionsAux.nil⟩ =>
dsimp [toOptionList]
| _ :: _, ⟨_, .cons (φsᵤₙ := aux) none c⟩ =>
dsimp [toOptionList]
rw [List.length_map, toOptionList_length ⟨aux, c⟩]
| _ :: φs, ⟨_, .cons (φsᵤₙ := aux) (some n) c⟩ =>
dsimp [toOptionList]
rw [List.length_set, List.length_map, toOptionList_length ⟨aux, c⟩]
def toFinOptionMap {l : List 𝓕} (c : Contractions l) : Fin l.length → Option (Fin l.length) :=
c.toOptionList.get ∘ Fin.cast (toOptionList_length c).symm
lemma toFinOptionMap_neq_self {l : List 𝓕} (c : Contractions l) (i : Fin l.length) :
c.toFinOptionMap i ≠ some i := by
match l, c with
| [], ⟨[], ContractionsAux.nil⟩ =>
exact Fin.elim0 i
| _ :: _, ⟨_, .cons (φsᵤₙ := aux) none c⟩ =>
dsimp [toFinOptionMap, toOptionList]
match i with
| ⟨0, _⟩ =>
exact Option.noConfusion
| ⟨n + 1, h⟩ =>
simp only [List.getElem_cons_succ, List.getElem_map, List.length_cons]
have hn := toFinOptionMap_neq_self ⟨aux, c⟩ ⟨n, Nat.succ_lt_succ_iff.mp h⟩
simp only [Option.map_eq_some', not_exists, not_and]
intro x hx
simp only [toFinOptionMap, Function.comp_apply, Fin.cast_mk, List.get_eq_getElem, hx, ne_eq,
Option.some.injEq] at hn
rw [Fin.ext_iff] at hn ⊢
simp_all
| _ :: φs, ⟨_, .cons (φsᵤₙ := aux) (some n) c⟩ =>
dsimp [toFinOptionMap, toOptionList]
match i with
| ⟨0, _⟩ =>
simp only [List.getElem_cons_zero, List.length_cons, Fin.zero_eta, Option.some.injEq, ne_eq]
exact Fin.succ_ne_zero (embedUncontracted ⟨aux, c⟩ n)
| ⟨n + 1, h⟩ =>
simp only [List.getElem_cons_succ, List.length_cons, ne_eq]
rw [List.getElem_set]
split
· exact ne_of_beq_false rfl
· simp only [List.getElem_map, Option.map_eq_some', not_exists, not_and]
intro x hx
have hn := toFinOptionMap_neq_self ⟨aux, c⟩ ⟨n, Nat.succ_lt_succ_iff.mp h⟩
simp only [toFinOptionMap, Function.comp_apply, Fin.cast_mk, List.get_eq_getElem, hx, ne_eq,
Option.some.injEq] at hn
rw [Fin.ext_iff] at hn ⊢
simp_all
@[simp]
lemma toFinOptionMap_embedUncontracted {l : List 𝓕} (c : Contractions l)
(i : Fin c.normalize.length) : c.toFinOptionMap (embedUncontracted c i) = none := by
match l, c with
| [], ⟨[], ContractionsAux.nil⟩ =>
exact Fin.elim0 i
| _ :: _, ⟨_, .cons (φsᵤₙ := aux) none c⟩ =>
dsimp [toFinOptionMap, toOptionList, embedUncontracted]
match i with
| ⟨0, _⟩ =>
rfl
| ⟨n + 1, h⟩ =>
rw [show ⟨n + 1, h⟩ = Fin.succ ⟨n, Nat.succ_lt_succ_iff.mp h⟩ by rfl]
rw [Fin.cons_succ]
simp only [Function.comp_apply, Fin.val_succ, List.getElem_cons_succ, List.getElem_map,
Option.map_eq_none']
exact toFinOptionMap_embedUncontracted ⟨aux, c⟩ ⟨n, Nat.succ_lt_succ_iff.mp h⟩
| _ :: φs, ⟨_, .cons (φsᵤₙ := aux) (some n) c⟩ =>
dsimp [toFinOptionMap, toOptionList, embedUncontracted]
rw [List.getElem_set]
split
· rename_i hs
have hx := embedUncontracted_injective ⟨aux, c⟩ (Fin.val_injective hs)
refine False.elim ?_
have hn := Fin.succAbove_ne ⟨n, embedUncontracted.proof_6 _ φs aux n c⟩ i
simp [Fin.ext_iff] at hx
simp [Fin.ext_iff] at hn
exact hn (id (Eq.symm hx))
· simp
exact toFinOptionMap_embedUncontracted ⟨aux, c⟩ _
lemma toFinOptionMap_involutive {l : List 𝓕} (c : Contractions l) (i j : Fin l.length) :
c.toFinOptionMap i = some j → c.toFinOptionMap j = some i := by
match l, c with
| [], ⟨[], ContractionsAux.nil⟩ =>
exact Fin.elim0 i
| _ :: _, ⟨_, .cons (φsᵤₙ := aux) none c⟩ =>
dsimp [toFinOptionMap, toOptionList]
match i, j with
| ⟨0, _⟩, j =>
exact Option.noConfusion
| ⟨n + 1, h⟩, ⟨0, _⟩ =>
simp
intro x hx
exact Fin.succ_ne_zero x
| ⟨n + 1, hn⟩, ⟨m + 1, hm⟩ =>
intro h1
have hnm := toFinOptionMap_involutive ⟨aux, c⟩ ⟨n, Nat.succ_lt_succ_iff.mp hn⟩
⟨m, Nat.succ_lt_succ_iff.mp hm⟩
simp
simp [toFinOptionMap] at hnm
have hnm' := hnm (by
simp at h1
obtain ⟨a, ha, ha2⟩ := h1
rw [ha]
simp only [Option.some.injEq]
rw [Fin.ext_iff] at ha2 ⊢
simp_all)
use ⟨n, Nat.succ_lt_succ_iff.mp hn⟩
simpa using hnm'
| _ :: φs, ⟨_, .cons (φsᵤₙ := aux) (some n) c⟩ =>
dsimp [toFinOptionMap, toOptionList]
match i, j with
| ⟨0, _⟩, j =>
intro hj
simp only [List.getElem_cons_zero, Option.some.injEq] at hj
subst hj
simp
| ⟨n' + 1, h⟩, ⟨0, _⟩ =>
intro hj
simp at hj
simp
rw [List.getElem_set] at hj
simp_all only [List.length_cons, lt_add_iff_pos_left, add_pos_iff, zero_lt_one, or_true, List.getElem_map,
ite_eq_left_iff, Option.map_eq_some']
simp [Fin.ext_iff]
by_contra hn
have hn' := hj hn
obtain ⟨a, ha, ha2⟩ := hn'
exact Fin.succ_ne_zero a ha2
| ⟨n' + 1, hn⟩, ⟨m + 1, hm⟩ =>
simp
rw [List.getElem_set, List.getElem_set]
simp
split
· intro h
simp [Fin.ext_iff] at h
rename_i hn'
intro h1
split
· rename_i hnx
have hnm := toFinOptionMap_involutive ⟨aux, c⟩ ⟨n', Nat.succ_lt_succ_iff.mp hn⟩
⟨m, Nat.succ_lt_succ_iff.mp hm⟩
subst hnx
simp at hnm
refine False.elim (hnm ?_)
simp at h1
obtain ⟨a, ha, ha2⟩ := h1
have ha' : (embedUncontracted ⟨aux, c⟩ n) = a := by
rw [Fin.ext_iff] at ha2 ⊢
simp_all
rw [ha']
rw [← ha]
rfl
· rename_i hnx
have hnm := toFinOptionMap_involutive ⟨aux, c⟩ ⟨n', Nat.succ_lt_succ_iff.mp hn⟩
⟨m, Nat.succ_lt_succ_iff.mp hm⟩ (by
dsimp [toFinOptionMap]
simp at h1
obtain ⟨a, ha, ha2⟩ := h1
have ha' : a = ⟨m, by exact Nat.succ_lt_succ_iff.mp hm⟩ := by
rw [Fin.ext_iff] at ha2 ⊢
simp_all
rw [← ha', ← ha])
change Option.map Fin.succ (toFinOptionMap ⟨aux, c⟩ ⟨m, Nat.succ_lt_succ_iff.mp hm⟩) = _
rw [hnm]
rfl
def toInvolution {l : List 𝓕} (c : Contractions l) : Fin l.length → Fin l.length :=
fun i =>
if h : Option.isSome (c.toFinOptionMap i) then Option.get (c.toFinOptionMap i) h else i
lemma toInvolution_of_isSome {l : List 𝓕} {c : Contractions l} {i : Fin l.length}
(hs : Option.isSome (c.toFinOptionMap i)) :
c.toInvolution i = Option.get (c.toFinOptionMap i) hs := by
dsimp [toInvolution]
rw [dif_pos hs]
lemma toInvolution_of_eq_none {l : List 𝓕} {c : Contractions l} {i : Fin l.length}
(hs : (c.toFinOptionMap i) = none) :
c.toInvolution i = i := by
dsimp [toInvolution]
rw [dif_neg]
simp_all
lemma toInvolution_image_isSome {l : List 𝓕} {c : Contractions l} {i : Fin l.length}
(hs : Option.isSome (c.toFinOptionMap i)) :
Option.isSome (c.toFinOptionMap (c.toInvolution i)) := by
dsimp [toInvolution]
rw [dif_pos hs]
have hx := toFinOptionMap_involutive c i ((c.toFinOptionMap i).get hs)
simp at hx
rw [hx]
rfl
lemma toInvolution_involutive {l : List 𝓕} (c : Contractions l) :
Function.Involutive c.toInvolution := by
intro i
by_cases h : Option.isSome (c.toFinOptionMap i)
· have hx := toFinOptionMap_involutive c i ((c.toFinOptionMap i).get h)
rw [toInvolution_of_isSome (toInvolution_image_isSome h)]
simp only [Option.some_get, forall_const] at hx
simp only [toInvolution_of_isSome h, hx, Option.get_some]
· simp at h
rw [toInvolution_of_eq_none h]
rw [toInvolution_of_eq_none h]
def involutionEquiv1 {l : List 𝓕} :
{f : Fin l.length → Fin l.length // Function.Involutive f } ≃
{f : Fin l.length → Option (Fin l.length) // (∀ i, f i ≠ some i) ∧
∀ i j, f i = some j → f j = some i} where
toFun f := ⟨fun i => if h : f.1 i = i then none else f.1 i,
fun i => by
simp,
fun i j => by
simp
intro hi hij
subst hij
rw [f.2]
simp
exact fun a => hi (id (Eq.symm a))⟩
invFun f := ⟨fun i => if h : (f.1 i).isSome then Option.get (f.1 i) h else i,
fun i => by
by_cases h : Option.isSome (f.1 i)
· simp [h]
have hf := f.2.2 i (Option.get (f.1 i) h) (by simp)
simp [hf]
· simp
rw [dif_neg]
· rw [dif_neg h]
· rw [dif_neg h]
exact h⟩
left_inv f := by
simp
ext i
simp
by_cases hf : f.1 i = i
· simp [hf]
· simp [hf]
right_inv f := by
simp
ext1
simp
funext i
obtain ⟨val, property⟩ := f
obtain ⟨left, right⟩ := property
simp_all only [ne_eq]
split
next h =>
ext a : 1
simp_all only [Option.mem_def, reduceCtorEq, false_iff]
apply Aesop.BuiltinRules.not_intro
intro a_1
simp_all only [Option.isSome_some, Option.get_some, forall_const]
next h =>
simp_all only [not_forall]
obtain ⟨w, h⟩ := h
simp_all only [↓reduceDIte, Option.some_get]
def involutionCons (n : ):
{f : Fin n.succ → Fin n.succ // Function.Involutive f } ≃
(f : {f : Fin n → Fin n // Function.Involutive f}) × {i : Option (Fin n) //
∀ (h : i.isSome), f.1 (Option.get i h) = (Option.get i h)} where
toFun f := ⟨⟨
fun i =>
if h : f.1 i.succ = 0 then i
else Fin.pred (f.1 i.succ) h , by
intro i
by_cases h : f.1 i.succ = 0
· simp [h]
· simp [h]
simp [f.2 i.succ]
intro h
exact False.elim (Fin.succ_ne_zero i h)⟩,
⟨if h : f.1 0 = 0 then none else Fin.pred (f.1 0) h , by
by_cases h0 : f.1 0 = 0
· simp [h0]
· simp [h0]
refine fun h => False.elim (h (f.2 0))⟩⟩
invFun f := ⟨
if h : (f.2.1).isSome then
Fin.cons (f.2.1.get h).succ (Function.update (Fin.succ ∘ f.1.1) (f.2.1.get h) 0)
else
Fin.cons 0 (Fin.succ ∘ f.1.1)
, by
by_cases hs : (f.2.1).isSome
· simp only [Nat.succ_eq_add_one, hs, ↓reduceDIte, Fin.coe_eq_castSucc]
let a := f.2.1.get hs
change Function.Involutive (Fin.cons a.succ (Function.update (Fin.succ ∘ ↑f.fst) a 0))
intro i
rcases Fin.eq_zero_or_eq_succ i with hi | ⟨j, hj⟩
· subst hi
rw [Fin.cons_zero, Fin.cons_succ]
simp
· subst hj
rw [Fin.cons_succ]
by_cases hja : j = a
· subst hja
simp
· rw [Function.update_apply ]
rw [if_neg hja]
simp
have hf2 := f.2.2 hs
change f.1.1 a = a at hf2
have hjf1 : f.1.1 j ≠ a := by
by_contra hn
have haj : j = f.1.1 a := by
rw [← hn]
rw [f.1.2]
rw [hf2] at haj
exact hja haj
rw [Function.update_apply, if_neg hjf1]
simp
rw [f.1.2]
· simp [hs]
intro i
rcases Fin.eq_zero_or_eq_succ i with hi | ⟨j, hj⟩
· subst hi
simp
· subst hj
simp
rw [f.1.2]⟩
left_inv f := by
match f with
| ⟨f, hf⟩ =>
simp
ext i
by_cases h0 : f 0 = 0
· simp [h0]
rcases Fin.eq_zero_or_eq_succ i with hi | ⟨j, hj⟩
· subst hi
simp [h0]
· subst hj
simp [h0]
by_cases hj : f j.succ =0
· rw [← h0] at hj
have hn := Function.Involutive.injective hf hj
exact False.elim (Fin.succ_ne_zero j hn)
· simp [hj]
rw [Fin.ext_iff] at hj
simp at hj
omega
· rw [if_neg h0]
by_cases hf' : i = f 0
· subst hf'
simp
rw [hf]
simp
· rw [Function.update_apply, if_neg hf']
rcases Fin.eq_zero_or_eq_succ i with hi | ⟨j, hj⟩
· subst hi
simp
· subst hj
simp
by_cases hj : f j.succ =0
· rw [← hj] at hf'
rw [hf] at hf'
simp at hf'
· simp [hj]
rw [Fin.ext_iff] at hj
simp at hj
omega
right_inv f := by
match f with
| ⟨⟨f, hf⟩, ⟨f0, hf0⟩⟩ =>
ext i
· simp
by_cases hs : f0.isSome
· simp [hs]
by_cases hi : i = f0.get hs
· simp [hi, Function.update_apply]
exact Eq.symm (Fin.val_eq_of_eq (hf0 hs))
· simp [hi]
split
· rename_i h
exact False.elim (Fin.succ_ne_zero (f i) h)
· rfl
· simp [hs]
split
· rename_i h
exact False.elim (Fin.succ_ne_zero (f i) h)
· rfl
· simp only [Nat.succ_eq_add_one, Option.mem_def,
Option.dite_none_left_eq_some, Option.some.injEq]
by_cases hs : f0.isSome
· simp only [hs, ↓reduceDIte]
simp [Fin.cons_zero]
have hx : ¬ (f0.get hs).succ = 0 := (Fin.succ_ne_zero (f0.get hs))
simp [hx]
refine Iff.intro (fun hi => ?_) (fun hi => ?_)
· rw [← hi]
exact
Option.eq_some_of_isSome
(Eq.mpr_prop (Eq.refl (f0.isSome = true))
(of_eq_true (Eq.trans (congrArg (fun x => x = true) hs) (eq_self true))))
· subst hi
exact rfl
· simp [hs]
simp at hs
subst hs
exact ne_of_beq_false rfl
def uncontractedFromInduction : {l : List 𝓕} → (f : {f : Fin l.length → Fin l.length // Function.Involutive f}) →
List 𝓕
| [], _ => []
| φ :: φs, f =>
let f' := involutionCons φs.length f
let c' := uncontractedFromInduction f'.1
if f'.2.1.isSome then
c'
else
φ :: c'
lemma uncontractedFromInduction_length : {l : List 𝓕} → (f : {f : Fin l.length → Fin l.length // Function.Involutive f}) →
(uncontractedFromInduction f).length = ∑ i, if f.1 i = i then 1 else 0
| [] => by
intro f
rfl
| φ :: φs => by
intro f
let f' := involutionCons φs.length f
let c' := uncontractedFromInduction f'.1
by_cases h : f'.2.1.isSome
· dsimp [uncontractedFromInduction]
rw [if_pos h]
rw [uncontractedFromInduction_length f'.1]
rw [Fin.sum_univ_succ]
simp [f', involutionCons] at h
rw [if_neg h]
simp
sorry
· sorry
def uncontractedEquiv {l : List 𝓕} (f : {f : Fin l.length → Fin l.length // Function.Involutive f}) :
{i : Option (Fin l.length) //
∀ (h : i.isSome), f.1 (Option.get i h) = (Option.get i h)} ≃
Option (Fin (uncontractedFromInduction f).length) := by
let e1 : {i : Option (Fin l.length) // ∀ (h : i.isSome), f.1 (Option.get i h) = (Option.get i h)}
≃ Option {i : Fin l.length // f.1 i = i} :=
{ toFun := fun i => match i with
| ⟨some i, h⟩ => some ⟨i, by simpa using h⟩
| ⟨none, h⟩ => none
invFun := fun i => match i with
| some ⟨i, h⟩ => ⟨some i, by simpa using h⟩
| none => ⟨none, by simp⟩
left_inv := by
intro a
cases a
aesop
right_inv := by
intro a
cases a
rfl
simp_all only [Subtype.coe_eta] }
let s : Finset (Fin l.length) := Finset.univ.filter fun i => f.1 i = i
let e2' : { i : Fin l.length // f.1 i = i} ≃ {i // i ∈ s} := by
refine Equiv.subtypeEquivProp ?h
funext i
simp [s]
let e2 : {i // i ∈ s} ≃ Fin (Finset.card s) := by
refine (Finset.orderIsoOfFin _ ?_).symm.toEquiv
simp [s]
have hcard : (uncontractedFromInduction f).length = Finset.card s := by
simp [s]
rw [Finset.card_filter]
rw [uncontractedFromInduction_length]
sorry
def involutionEquiv : (l : List 𝓕) → Contractions l ≃
{f : Fin l.length → Fin l.length // Function.Involutive f}
| [] => {
toFun := fun c => ⟨fun i => i, fun i => rfl⟩,
invFun := fun f => ⟨[], ContractionsAux.nil⟩,
left_inv := by
intro a
cases a
rename_i aux c
cases c
rfl
right_inv := by
intro f
ext i
exact Fin.elim0 i}
| φ :: φs => by
refine Equiv.trans consEquiv ?_
refine Equiv.trans ?_ (involutionCons φs.length).symm
refine Equiv.sigmaCongr (involutionEquiv φs) (fun c => ?_)
exact {
toFun := fun i? => ⟨Option.map c.embedUncontracted i?, by
intro h
sorry⟩
invFun := fun i => sorry
left_inv := by
sorry
right_inv := by sorry
}
/-- A structure specifying when a type `I` and a map `f :I → Type` corresponds to
the splitting of a fields `φ` into a creation `n` and annihlation part `p`. -/
structure Splitting (f : 𝓕 → Type) [∀ i, Fintype (f i)]
(le1 : (Σ i, f i) → (Σ i, f i) → Prop) [DecidableRel le1] where
(le : (Σ i, f i) → (Σ i, f i) → Prop) [DecidableRel le] where
/-- The creation part of the fields. The label `n` corresponds to the fact that
in normal ordering these feilds get pushed to the negative (left) direction. -/
𝓑n : 𝓕 → (Σ i, f i)
@ -135,22 +691,23 @@ structure Splitting (f : 𝓕 → Type) [∀ i, Fintype (f i)]
/-- The complex coefficent of annhilation part of a field `i`. This is usually `0` or `1`. -/
𝓧p : 𝓕
h𝓑 : ∀ i, ofListLift f [i] 1 = ofList [𝓑n i] (𝓧n i) + ofList [𝓑p i] (𝓧p i)
h𝓑n : ∀ i j, le1 (𝓑n i) j
h𝓑p : ∀ i j, le1 j (𝓑p i)
h𝓑n : ∀ i j, le (𝓑n i) j
h𝓑p : ∀ i j, le j (𝓑p i)
/-- In the static wick's theorem, the term associated with a contraction `c` containing
the contractions. -/
noncomputable def toCenterTerm (f : 𝓕 → Type) [∀ i, Fintype (f i)]
(q : 𝓕 → FieldStatistic)
(le1 : (Σ i, f i) → (Σ i, f i) → Prop) [DecidableRel le1]
(le : (Σ i, f i) → (Σ i, f i) → Prop) [DecidableRel le]
{A : Type} [Semiring A] [Algebra A]
(F : FreeAlgebra (Σ i, f i) →ₐ[] A) :
{r : List 𝓕} → (c : Contractions r) → (S : Splitting f le1) → A
{φs : List 𝓕} → (c : Contractions φs) → (S : Splitting f le) → A
| [], ⟨[], .nil⟩, _ => 1
| _ :: _, ⟨_, .cons (aux := aux') none c⟩, S => toCenterTerm f q le1 F ⟨aux', c⟩ S
| a :: _, ⟨_, .cons (aux := aux') (some n) c⟩, S => toCenterTerm f q le1 F ⟨aux', c⟩ S *
| _ :: _, ⟨_, .cons (φsᵤₙ := aux') none c⟩, S => toCenterTerm f q le F ⟨aux', c⟩ S
| a :: _, ⟨_, .cons (φsᵤₙ := aux') (some n) c⟩, S => toCenterTerm f q le F ⟨aux', c⟩ S *
superCommuteCoef q [aux'.get n] (List.take (↑n) aux') •
F (((superCommute fun i => q i.fst) (ofList [S.𝓑p a] (S.𝓧p a))) (ofListLift f [aux'.get n] 1))
F (((superCommute fun i => q i.fst) (ofList [S.𝓑p a] (S.𝓧p a)))
(ofListLift f [aux'.get n] 1))
/-- Shows that adding a field with no contractions (none) to an existing set of contractions
results in the same center term as the original contractions.
@ -158,13 +715,13 @@ noncomputable def toCenterTerm (f : 𝓕 → Type) [∀ i, Fintype (f i)]
Physically, this represents that an uncontracted (free) field does not affect
the contraction structure of other fields in Wick's theorem. -/
lemma toCenterTerm_none (f : 𝓕 → Type) [∀ i, Fintype (f i)]
(q : 𝓕 → FieldStatistic) {r : List 𝓕}
(le1 : (Σ i, f i) → (Σ i, f i) → Prop) [DecidableRel le1]
(q : 𝓕 → FieldStatistic) {φs : List 𝓕}
(le : (Σ i, f i) → (Σ i, f i) → Prop) [DecidableRel le]
{A : Type} [Semiring A] [Algebra A]
(F : FreeAlgebra (Σ i, f i) →ₐ A)
(S : Splitting f le1) (a : 𝓕) (c : Contractions r) :
toCenterTerm (r := a :: r) f q le1 F (Contractions.consEquiv.symm ⟨c, none⟩) S =
toCenterTerm f q le1 F c S := by
(S : Splitting f le) (φ : 𝓕) (c : Contractions φs) :
toCenterTerm (φs := φ :: φs) f q le F (Contractions.consEquiv.symm ⟨c, none⟩) S =
toCenterTerm f q le F c S := by
rw [consEquiv]
simp only [Equiv.coe_fn_symm_mk]
dsimp [toCenterTerm]
@ -177,15 +734,15 @@ lemma toCenterTerm_center (f : 𝓕 → Type) [∀ i, Fintype (f i)]
(le : (Σ i, f i) → (Σ i, f i) → Prop) [DecidableRel le]
{A : Type} [Semiring A] [Algebra A]
(F : FreeAlgebra (Σ i, f i) →ₐ A) [OperatorMap (fun i => q i.1) le F] :
{r : List 𝓕} → (c : Contractions r) → (S : Splitting f le) →
{φs : List 𝓕} → (c : Contractions φs) → (S : Splitting f le) →
(c.toCenterTerm f q le F S) ∈ Subalgebra.center A
| [], ⟨[], .nil⟩, _ => by
dsimp [toCenterTerm]
exact Subalgebra.one_mem (Subalgebra.center A)
| _ :: _, ⟨_, .cons (aux := aux') none c⟩, S => by
| _ :: _, ⟨_, .cons (φsᵤₙ := aux') none c⟩, S => by
dsimp [toCenterTerm]
exact toCenterTerm_center f q le F ⟨aux', c⟩ S
| a :: _, ⟨_, .cons (aux := aux') (some n) c⟩, S => by
| a :: _, ⟨_, .cons (φsᵤₙ := aux') (some n) c⟩, S => by
dsimp [toCenterTerm]
refine Subalgebra.mul_mem (Subalgebra.center A) ?hx ?hy
exact toCenterTerm_center f q le F ⟨aux', c⟩ S

View file

@ -14,37 +14,37 @@ namespace Wick
open HepLean.List
open FieldStatistic
/-- The sections of `Σ i, f i` over a list `l : List 𝓕`.
/-- The sections of `Σ i, f i` over a list `φs : List 𝓕`.
In terms of physics, given some fields `φ₁...φₙ`, the different ways one can associate
each field as a `creation` or an `annilation` operator. E.g. the number of terms
`φ₁⁰φ₂¹...φₙ⁰` `φ₁¹φ₂¹...φₙ⁰` etc. If some fields are exclusively creation or annhilation
operators at this point (e.g. ansymptotic states) this is accounted for. -/
def CreateAnnihilateSect {𝓕 : Type} (f : 𝓕 → Type) (l : List 𝓕) : Type :=
Π i, f (l.get i)
def CreateAnnihilateSect {𝓕 : Type} (f : 𝓕 → Type) (φs : List 𝓕) : Type :=
Π i, f (φs.get i)
namespace CreateAnnihilateSect
section basic_defs
variable {𝓕 : Type} {f : 𝓕 → Type} [∀ i, Fintype (f i)] {l : List 𝓕} (a : CreateAnnihilateSect f l)
variable {𝓕 : Type} {f : 𝓕 → Type} [∀ i, Fintype (f i)] {φs : List 𝓕} (a : CreateAnnihilateSect f φs)
/-- The type `CreateAnnihilateSect f l` is finite. -/
instance fintype : Fintype (CreateAnnihilateSect f l) := Pi.fintype
/-- The type `CreateAnnihilateSect f φs` is finite. -/
instance fintype : Fintype (CreateAnnihilateSect f φs) := Pi.fintype
/-- The section got by dropping the first element of `l` if it exists. -/
def tail : {l : List 𝓕} → (a : CreateAnnihilateSect f l) → CreateAnnihilateSect f l.tail
/-- The section got by dropping the first element of `φs` if it exists. -/
def tail : {φs : List 𝓕} → (a : CreateAnnihilateSect f φs) → CreateAnnihilateSect f φs.tail
| [], a => a
| _ :: _, a => fun i => a (Fin.succ i)
/-- For a list of fields `i :: l` the value of the section at the head `i`. -/
def head {i : 𝓕} (a : CreateAnnihilateSect f (i :: l)) : f i := a ⟨0, Nat.zero_lt_succ l.length⟩
def head {φ : 𝓕} (a : CreateAnnihilateSect f (φ :: φs)) : f φ := a ⟨0, Nat.zero_lt_succ φs.length⟩
end basic_defs
section toList_basic
variable {𝓕 : Type} {f : 𝓕 → Type} (q : 𝓕 → FieldStatistic)
{l : List 𝓕} (a : CreateAnnihilateSect f l)
{φs : List 𝓕} (a : CreateAnnihilateSect f φs)
/-- The list `List (Σ i, f i)` defined by `a`. -/
def toList : {l : List 𝓕} → (a : CreateAnnihilateSect f l) → List (Σ i, f i)
@ -52,8 +52,8 @@ def toList : {l : List 𝓕} → (a : CreateAnnihilateSect f l) → List (Σ i,
| i :: _, a => ⟨i, a.head⟩ :: toList a.tail
@[simp]
lemma toList_length : (toList a).length = l.length := by
induction l with
lemma toList_length : (toList a).length = φs.length := by
induction φs with
| nil => rfl
| cons i l ih =>
simp only [toList, List.length_cons, Fin.zero_eta]
@ -64,13 +64,13 @@ lemma toList_tail : {l : List 𝓕} → (a : CreateAnnihilateSect f l) → toLis
| i :: l, a => by
simp [toList]
lemma toList_cons {i : 𝓕} (a : CreateAnnihilateSect f (i :: l)) :
lemma toList_cons {i : 𝓕} (a : CreateAnnihilateSect f (i :: φs)) :
(toList a) = ⟨i, a.head⟩ :: toList a.tail := by
rfl
lemma toList_get (a : CreateAnnihilateSect f l) :
(toList a).get = (fun i => ⟨l.get i, a i⟩) ∘ Fin.cast (by simp) := by
induction l with
lemma toList_get (a : CreateAnnihilateSect f φs) :
(toList a).get = (fun i => ⟨φs.get i, a i⟩) ∘ Fin.cast (by simp) := by
induction φs with
| nil =>
funext i
exact Fin.elim0 i
@ -89,8 +89,8 @@ lemma toList_get (a : CreateAnnihilateSect f l) :
@[simp]
lemma toList_grade :
FieldStatistic.ofList (fun i => q i.fst) a.toList = fermionic ↔
FieldStatistic.ofList q l = fermionic := by
induction l with
FieldStatistic.ofList q φs = fermionic := by
induction φs with
| nil =>
simp [toList]
| cons i r ih =>

View file

@ -20,57 +20,57 @@ variable {𝓕 : Type} (q : 𝓕 → FieldStatistic) (le : 𝓕𝓕 → Pro
/-- Gives a factor of `-1` when inserting `a` into a list `List I` in the ordered position
for each fermion-fermion cross. -/
def koszulSignInsert {𝓕 : Type} (q : 𝓕 → FieldStatistic) (le : 𝓕𝓕 → Prop)
[DecidableRel le] (a : 𝓕) : List 𝓕
[DecidableRel le] (φ : 𝓕) : List 𝓕
| [] => 1
| b :: l => if le a b then koszulSignInsert q le a l else
if q a = fermionic ∧ q b = fermionic then - koszulSignInsert q le a l else
koszulSignInsert q le a l
| φ' :: φs => if le φ φ' then koszulSignInsert q le φ φs else
if q φ = fermionic ∧ q φ' = fermionic then - koszulSignInsert q le φ φs else
koszulSignInsert q le φ φs
/-- When inserting a boson the `koszulSignInsert` is always `1`. -/
lemma koszulSignInsert_boson (q : 𝓕 → FieldStatistic) (le : 𝓕𝓕 → Prop) [DecidableRel le]
(a : 𝓕) (ha : q a = bosonic) : (φs : List 𝓕) → koszulSignInsert q le a φs = 1
(φ : 𝓕) (ha : q φ = bosonic) : (φs : List 𝓕) → koszulSignInsert q le φ φs = 1
| [] => by
simp [koszulSignInsert]
| b :: l => by
| φ' :: φs => by
simp only [koszulSignInsert, Fin.isValue, ite_eq_left_iff]
rw [koszulSignInsert_boson q le a ha l, ha]
rw [koszulSignInsert_boson q le φ ha φs, ha]
simp only [reduceCtorEq, false_and, ↓reduceIte, ite_self]
@[simp]
lemma koszulSignInsert_mul_self (a : 𝓕) :
(φs : List 𝓕) → koszulSignInsert q le a φs * koszulSignInsert q le a φs = 1
lemma koszulSignInsert_mul_self (φ : 𝓕) :
(φs : List 𝓕) → koszulSignInsert q le φ φs * koszulSignInsert q le φ φs = 1
| [] => by
simp [koszulSignInsert]
| b :: l => by
| φ' :: φs => by
simp only [koszulSignInsert, Fin.isValue, mul_ite, ite_mul, neg_mul, mul_neg]
by_cases hr : le a b
by_cases hr : le φ φ'
· simp only [hr, ↓reduceIte]
rw [koszulSignInsert_mul_self]
· simp only [hr, ↓reduceIte]
by_cases hq : q a = fermionic ∧ q b = fermionic
by_cases hq : q φ = fermionic ∧ q φ' = fermionic
· simp only [hq, and_self, ↓reduceIte, neg_neg]
rw [koszulSignInsert_mul_self]
· simp only [hq, ↓reduceIte]
rw [koszulSignInsert_mul_self]
lemma koszulSignInsert_le_forall (a : 𝓕) (l : List 𝓕) (hi : ∀ b, le a b) :
koszulSignInsert q le a l = 1 := by
induction l with
lemma koszulSignInsert_le_forall (φ : 𝓕) (φs : List 𝓕) (hi : ∀ φ', le φ φ') :
koszulSignInsert q le φ φs = 1 := by
induction φs with
| nil => rfl
| cons j l ih =>
| cons φ' φs ih =>
simp only [koszulSignInsert, Fin.isValue, ite_eq_left_iff]
rw [ih]
simp only [Fin.isValue, ite_eq_left_iff, ite_eq_right_iff, and_imp]
intro h
exact False.elim (h (hi j))
exact False.elim (h (hi φ'))
lemma koszulSignInsert_ge_forall_append (φs : List 𝓕) (j i : 𝓕) (hi : ∀ j, le j i) :
koszulSignInsert q le j φs = koszulSignInsert q le j (φs ++ [i]) := by
lemma koszulSignInsert_ge_forall_append (φs : List 𝓕) (φ' φ : 𝓕) (hi : ∀ φ'', le φ'' φ) :
koszulSignInsert q le φ' φs = koszulSignInsert q le φ' (φs ++ [φ]) := by
induction φs with
| nil => simp [koszulSignInsert, hi]
| cons b l ih =>
| cons φ'' φs ih =>
simp only [koszulSignInsert, Fin.isValue, List.append_eq]
by_cases hr : le j b
by_cases hr : le φ' φ''
· rw [if_pos hr, if_pos hr, ih]
· rw [if_neg hr, if_neg hr, ih]
@ -136,20 +136,20 @@ lemma koszulSignInsert_eq_grade (φ : 𝓕) (φs : List 𝓕) :
simpa [ofList] using ih
simpa using hr1
lemma koszulSignInsert_eq_perm (φs φs' : List 𝓕) (a : 𝓕) (h : φs.Perm φs') :
koszulSignInsert q le a φs = koszulSignInsert q le a φs' := by
lemma koszulSignInsert_eq_perm (φs φs' : List 𝓕) (φ : 𝓕) (h : φs.Perm φs') :
koszulSignInsert q le φ φs = koszulSignInsert q le φ φs' := by
rw [koszulSignInsert_eq_grade, koszulSignInsert_eq_grade]
congr 1
simp only [Fin.isValue, decide_not, eq_iff_iff, and_congr_right_iff]
intro h'
have hg : ofList q (List.filter (fun i => !decide (le a i)) φs) =
ofList q (List.filter (fun i => !decide (le a i)) φs') := by
have hg : ofList q (List.filter (fun i => !decide (le φ i)) φs) =
ofList q (List.filter (fun i => !decide (le φ i)) φs') := by
apply ofList_perm
exact List.Perm.filter (fun i => !decide (le a i)) h
exact List.Perm.filter (fun i => !decide (le φ i)) h
rw [hg]
lemma koszulSignInsert_eq_sort (φs : List 𝓕) (a : 𝓕) :
koszulSignInsert q le a φs = koszulSignInsert q le a (List.insertionSort le φs) := by
lemma koszulSignInsert_eq_sort (φs : List 𝓕) (φ : 𝓕) :
koszulSignInsert q le φ φs = koszulSignInsert q le φ (List.insertionSort le φs) := by
apply koszulSignInsert_eq_perm
exact List.Perm.symm (List.perm_insertionSort le φs)

View file

@ -33,13 +33,13 @@ lemma static_wick_nil {A : Type} [Semiring A] [Algebra A]
simp [ofListLift_empty]
lemma static_wick_cons [IsTrans ((i : 𝓕) × f i) le] [IsTotal ((i : 𝓕) × f i) le]
{A : Type} [Semiring A] [Algebra A] (r : List 𝓕) (a : 𝓕)
{A : Type} [Semiring A] [Algebra A] (φs : List 𝓕) (φ : 𝓕)
(F : FreeAlgebra (Σ i, f i) →ₐ A) [OperatorMap (fun i => q i.1) le F]
(S : Contractions.Splitting f le)
(ih : F (ofListLift f r 1) =
∑ c : Contractions r, c.toCenterTerm f q le F S * F (koszulOrder (fun i => q i.fst) le
(ih : F (ofListLift f φs 1) =
∑ c : Contractions φs, c.toCenterTerm f q le F S * F (koszulOrder (fun i => q i.fst) le
(ofListLift f c.normalize 1))) :
F (ofListLift f (a :: r) 1) = ∑ c : Contractions (a :: r),
F (ofListLift f (φ :: φs) 1) = ∑ c : Contractions (φ :: φs),
c.toCenterTerm f q le F S *
F (koszulOrder (fun i => q i.fst) le (ofListLift f c.normalize 1)) := by
rw [ofListLift_cons_eq_ofListLift, map_mul, ih, Finset.mul_sum,
@ -47,7 +47,7 @@ lemma static_wick_cons [IsTrans ((i : 𝓕) × f i) le] [IsTotal ((i : 𝓕) ×
erw [Finset.sum_sigma]
congr
funext c
have hb := S.h𝓑 a
have hb := S.h𝓑 φ
rw [← mul_assoc]
have hi := c.toCenterTerm_center f q le F S
rw [Subalgebra.mem_center_iff] at hi
@ -80,16 +80,16 @@ lemma static_wick_cons [IsTrans ((i : 𝓕) × f i) le] [IsTotal ((i : 𝓕) ×
funext n
rw [← mul_assoc]
rfl
exact S.h𝓑p a
exact S.h𝓑n a
exact S.h𝓑p φ
exact S.h𝓑n φ
theorem static_wick_theorem [IsTrans ((i : 𝓕) × f i) le] [IsTotal ((i : 𝓕) × f i) le]
{A : Type} [Semiring A] [Algebra A] (r : List 𝓕)
{A : Type} [Semiring A] [Algebra A] (φs : List 𝓕)
(F : FreeAlgebra (Σ i, f i) →ₐ A) [OperatorMap (fun i => q i.1) le F]
(S : Contractions.Splitting f le) :
F (ofListLift f r 1) = ∑ c : Contractions r, c.toCenterTerm f q le F S *
F (ofListLift f φs 1) = ∑ c : Contractions φs, c.toCenterTerm f q le F S *
F (koszulOrder (fun i => q i.fst) le (ofListLift f c.normalize 1)) := by
induction r with
induction φs with
| nil => exact static_wick_nil q le F S
| cons a r ih => exact static_wick_cons q le r a F S ih