michael/Spectral
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge branch 'master' of https://github.com/cmu-phil/Spectral

Browse source
This commit is contained in:
Clive Newstead 2016-02-18 16:18:02 -05:00
commit efd5d25039
2 changed files with 182 additions and 42 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

182
homotopy/chain_complex.hlean Normal file
View file

@ -0,0 +1,182 @@
import types.pointed types.int types.fiber
open algebra nat int pointed unit sigma fiber sigma.ops eq equiv prod is_trunc equiv.ops
namespace chain_complex
structure chain_complex : Type :=
(car : ℤ → Type*)
(fn : Π{n : ℤ}, car (n + 1) →* car n)
(is_chain_complex : Π{n : ℤ} (x : car ((n + 1) + 1)), fn (fn x) = pt)
structure left_chain_complex : Type := -- chain complex on the naturals with maps going down
(car : ℕ → Type*)
(fn : Π{n : ℕ}, car (n + 1) →* car n)
(is_chain_complex : Π{n : ℕ} (x : car ((n + 1) + 1)), fn (fn x) = pt)
structure right_chain_complex : Type := -- chain complex on the naturals with maps going up
(car : ℕ → Type*)
(fn : Π{n : ℕ}, car n →* car (n + 1))
(is_chain_complex : Π{n : ℕ} (x : car n), fn (fn x) = pt)
definition cc_to_car [coercion] := @chain_complex.car
definition cc_to_fn := @chain_complex.fn
definition cc_is_chain_complex := @chain_complex.is_chain_complex
definition lcc_to_car [coercion] := @left_chain_complex.car
definition lcc_to_fn := @left_chain_complex.fn
definition lcc_is_chain_complex := @left_chain_complex.is_chain_complex
definition rcc_to_car [coercion] := @right_chain_complex.car
definition rcc_to_fn := @right_chain_complex.fn
definition rcc_is_chain_complex := @right_chain_complex.is_chain_complex
-- note: these notions are shifted by one!
definition is_exact_at [reducible] (X : chain_complex) (n : ℤ) : Type :=
Π(x : X (n + 1)), cc_to_fn X x = pt → Σ(y : X ((n + 1) + 1)), cc_to_fn X y = x
definition is_exact_at_l [reducible] (X : left_chain_complex) (n : ℕ) : Type :=
Π(x : X (n + 1)), lcc_to_fn X x = pt → Σ(y : X ((n + 1) + 1)), lcc_to_fn X y = x
definition is_exact_at_r [reducible] (X : right_chain_complex) (n : ℕ) : Type :=
Π(x : X (n + 1)), rcc_to_fn X x = pt → Σ(y : X n), rcc_to_fn X y = x
definition is_exact [reducible] (X : chain_complex) : Type := Π(n : ℤ), is_exact_at X n
definition is_exact_l [reducible] (X : left_chain_complex) : Type := Π(n : ℕ), is_exact_at_l X n
definition is_exact_r [reducible] (X : right_chain_complex) : Type := Π(n : ℕ), is_exact_at_r X n
definition chain_complex_from_left (X : left_chain_complex) : chain_complex :=
chain_complex.mk (int.rec X (λn, Unit))
begin
intro n, fconstructor,
{ induction n with n n,
{ exact @lcc_to_fn X n},
{ esimp, intro x, exact star}},
{ induction n with n n,
{ apply respect_pt},
{ reflexivity}}
end
begin
intro n, induction n with n n,
{ exact lcc_is_chain_complex X},
{ esimp, intro x, reflexivity}
end
definition is_exact_from_left {X : left_chain_complex} {n : ℕ} (H : is_exact_at_l X n)
: is_exact_at (chain_complex_from_left X) n :=
H
-- move to pointed
definition pfiber [constructor] {X Y : Type*} (f : X →* Y) : Type* :=
pointed.MK (fiber f pt) (fiber.mk pt !respect_pt)
definition pequiv_of_equiv [constructor] {A B : Type*} (f : A ≃ B) (H : f pt = pt) : A ≃* B :=
pequiv.mk' (pmap.mk f H)
definition fiber_sequence_helper [constructor] (v : Σ(X Y : Type*), X →* Y)
: Σ(Z X : Type*), Z →* X :=
⟨pfiber v.2.2, v.1, pmap.mk point rfl⟩
definition fiber_sequence_carrier {X Y : Type*} (f : X →* Y) (n : ℕ) : Type* :=
nat.cases_on n Y (λk, (iterate fiber_sequence_helper k ⟨X, Y, f⟩).1)
definition fiber_sequence_fun {X Y : Type*} (f : X →* Y) (n : ℕ)
: fiber_sequence_carrier f (n + 1) →* fiber_sequence_carrier f n :=
nat.cases_on n f proof (λk, pmap.mk point rfl) qed
/- Definition 8.4.3 -/
definition fiber_sequence.{u} {X Y : Pointed.{u}} (f : X →* Y) : left_chain_complex.{u} :=
begin
fconstructor,
{ exact fiber_sequence_carrier f},
{ exact fiber_sequence_fun f},
{ intro n x, cases n with n,
{ exact point_eq x},
{ exact point_eq x}}
end
definition is_exact_fiber_sequence {X Y : Type*} (f : X →* Y) : is_exact_l (fiber_sequence f) :=
begin
intro n x p, cases n with n,
{ exact ⟨fiber.mk x p, rfl⟩},
{ exact ⟨fiber.mk x p, rfl⟩}
end
-- move to types.sigma
definition sigma_assoc_comm_equiv [constructor] {A : Type} (B C : A → Type)
: (Σ(v : Σa, B a), C v.1) ≃ (Σ(u : Σa, C a), B u.1) :=
calc (Σ(v : Σa, B a), C v.1)
≃ (Σa (b : B a), C a) : !sigma_assoc_equiv⁻¹
... ≃ (Σa, B a × C a) : sigma_equiv_sigma_id (λa, !equiv_prod)
... ≃ (Σa, C a × B a) : sigma_equiv_sigma_id (λa, !prod_comm_equiv)
... ≃ (Σa (c : C a), B a) : sigma_equiv_sigma_id (λa, !equiv_prod)
... ≃ (Σ(u : Σa, C a), B u.1) : sigma_assoc_equiv
attribute is_equiv_sigma_functor is_equiv.is_equiv_id pequiv.mk' [constructor]
attribute sigma.eta [unfold 3]
-- set_option pp.notation false
/- Lemma 8.4.4(i) -/
definition fiber_sequence_carrier_equiv0.{u} {X Y : Pointed.{u}} (f : X →* Y)
: fiber_sequence_carrier f 3 ≃* Ω Y :=
pequiv_of_equiv
(calc
fiber_sequence_carrier f 3 ≃ fiber (fiber_sequence_fun f 1) pt : erfl
... ≃ Σ(x : fiber_sequence_carrier f 2), fiber_sequence_fun f 1 x = pt : fiber.sigma_char
... ≃ Σ(v : fiber f pt), fiber_sequence_fun f 1 v = pt : erfl
... ≃ Σ(v : Σ(x : X), f x = pt), fiber_sequence_fun f 1 (fiber.mk v.1 v.2) = pt
: sigma_equiv_sigma_left !fiber.sigma_char
... ≃ Σ(v : Σ(x : X), f x = pt), v.1 = pt : erfl
... ≃ Σ(v : Σ(x : X), x = pt), f v.1 = pt : sigma_assoc_comm_equiv
... ≃ f !center.1 = pt : sigma_equiv_of_is_contr_left _
... ≃ f pt = pt : erfl
... ≃ pt = pt : by exact !equiv_eq_closed_left !respect_pt
... ≃ Ω Y : erfl)
begin
change (respect_pt f)⁻¹ ⬝
((center_eq ⟨Pointed.Point X, refl (Pointed.Point X)⟩)⁻¹ ▸ respect_pt f) = idp,
rewrite tr_constant,
apply con.left_inv
end
/- (generalization of) Lemma 8.4.4(ii) -/
definition fiber_sequence_carrier_equiv1.{u} {X Y : Pointed.{u}} (f : X →* Y) (n : ℕ)
: fiber_sequence_carrier f (n+4) ≃* Ω(fiber_sequence_carrier f (n+1)) :=
pequiv_of_equiv
(calc
fiber_sequence_carrier f (n+4) ≃ fiber (fiber_sequence_fun f (n+2)) pt : erfl
... ≃ Σ(x : fiber_sequence_carrier f _), fiber_sequence_fun f (n+2) x = pt
: fiber.sigma_char
... ≃ Σ(x : fiber (fiber_sequence_fun f (n+1)) pt), fiber_sequence_fun f _ x = pt
: erfl
... ≃ Σ(v : Σ(x : fiber_sequence_carrier f _), fiber_sequence_fun f _ x = pt),
fiber_sequence_fun f _ (fiber.mk v.1 v.2) = pt
: by exact sigma_equiv_sigma !fiber.sigma_char (λa, erfl)
... ≃ Σ(v : Σ(x : fiber_sequence_carrier f _), fiber_sequence_fun f _ x = pt),
v.1 = pt
: erfl
... ≃ Σ(v : Σ(x : fiber_sequence_carrier f _), x = pt),
fiber_sequence_fun f _ v.1 = pt
: sigma_assoc_comm_equiv
... ≃ fiber_sequence_fun f _ !center.1 = pt
: @(sigma_equiv_of_is_contr_left _) !is_contr_sigma_eq'
... ≃ fiber_sequence_fun f _ pt = pt
: erfl
... ≃ pt = pt
: by exact !equiv_eq_closed_left !respect_pt
... ≃ Ω(fiber_sequence_carrier f (n+1)) : erfl)
begin reflexivity end
/- Lemma 8.4.4 (i)(ii), combined -/
definition fiber_sequence_carrier_equiv {X Y : Type*} (f : X →* Y) (n : ℕ)
: fiber_sequence_carrier f (n+3) ≃* Ω(fiber_sequence_carrier f n) :=
nat.cases_on n (fiber_sequence_carrier_equiv0 f) (fiber_sequence_carrier_equiv1 f)
exit
/- Lemma 8.4.4(iii) -/
definition fiber_sequence_function0 {X Y : Type*} (f : X →* Y)
: Π(x : fiber_sequence_carrier f 4), ap1 f (fiber_sequence_carrier_equiv f 1 x)⁻¹ᵖ =
fiber_sequence_carrier_equiv f 0 (fiber_sequence_fun f 3 x) :=
take (x : fiber (fiber_sequence_fun f 2) pt),
obtain (v : fiber (fiber_sequence_fun f 1) pt) (q : _), from x,
begin
unfold [fiber_sequence_carrier_equiv,fiber_sequence_carrier_equiv0,fiber_sequence_carrier_equiv1,equiv.trans, equiv.symm, pequiv._trans_of_to_pmap],
esimp [sigma_assoc_equiv, equiv.symm, equiv.trans], unfold [fiber_sequence_fun, fiber_sequence_carrier]
end
end chain_complex

42
homotopy/clive.hlean
View file

@ -1,42 +0,0 @@
/-----
This is Clive's file for playing around with (h)Lean/Git/Emacs
------/
import types.trunc types.arrow_2 types.fiber homotopy.circle
open eq is_trunc is_equiv nat equiv trunc function circle
namespace clive
/-- Very easy goal: prove (loop⁻¹)⁻¹ = loop : base = base --/
theorem symm_symm_loop_eq_loop : (loop⁻¹)⁻¹ = loop :=
eq.rec_on loop idp
/-- Another easy goal: define a group and prove that the left inverse law follows form the right inverse law --/
structure group (X : Type) :=
gpstr :: (unit : X)
(mult : X → X → X)
(inv : X → X)
(assoc_law : Π(a b c : X), mult (mult a b) c = mult a (mult b c))
(inv_law : Π(a : X), mult a (inv a) = unit)
(unit_law : Π(a : X), mult a unit = a)
constants (X : Type) (G : group X)
open group
theorem group_cancel_right : Π(X : Type), Π(G : group X), Π(a b c : X), (mult G a c = mult G b c) → a = b := sorry
theorem inv_mul_left_eq_unit : Π(X : Type), Π(G : group X), Π(a : X), mult G (inv G a) a = unit G :=
take (X : Type) (G : group X) (a : X),
have q : mult G (mult G (inv G a) a) (inv G a) = mult G (unit G) (inv G a), from
calc
mult G (mult G (inv G a) a) (inv G a) = mult G (inv G a) (mult G a (inv G a)) : assoc_law
... = mult G (inv G a) (unit G) : sorry
... = inv G a : unit_law
... = mult G (unit G) (inv G a) : sorry,
group_cancel_right X G (mult G (inv G a) a) (unit G) (inv G a) q
end clive