dan
/
HITs-Examples
mirror of https://github.com/nmvdw/HITs-Examples
1
0
Fork 0
Code Issues Releases Wiki Activity

Shortenings in b_finite

This commit is contained in:
Niels van der Weide 2017-10-04 23:00:14 +02:00
parent c7df8ae8aa
commit 16e0e6f63d
1 changed files with 125 additions and 148 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

273
FiniteSets/subobjects/b_finite.v
View File

@ -15,7 +15,7 @@ Section finite_hott.
exists (a; tr idpath). exists (a; tr idpath).
intros [b p]. intros [b p].
simple refine (Trunc_ind (fun p => (a; tr 1%path) = (b; p)) _ p). simple refine (Trunc_ind (fun p => (a; tr 1%path) = (b; p)) _ p).
clear p; intro p. simpl. clear p; intro p ; simpl.
apply path_sigma_hprop; simpl. apply path_sigma_hprop; simpl.
apply p^. apply p^.
Defined. Defined.
@ -32,7 +32,7 @@ Section finite_hott.
Proof. Proof.
intros a. intros a.
simple refine (Build_Finite _ 1 _). simple refine (Build_Finite _ 1 _).
apply tr. apply tr.
symmetry. symmetry.
refine (BuildEquiv _ _ (singleton_fin_equiv' a) _). refine (BuildEquiv _ _ (singleton_fin_equiv' a) _).
Defined. Defined.
@ -47,8 +47,7 @@ Section finite_hott.
Definition decidable_empty_finite : hasDecidableEmpty Bfin. Definition decidable_empty_finite : hasDecidableEmpty Bfin.
Proof. Proof.
intros X Y. intros X [n f].
destruct Y as [n f].
strip_truncations. strip_truncations.
destruct n. destruct n.
- refine (tr(inl _)). - refine (tr(inl _)).
@ -62,83 +61,66 @@ Section finite_hott.
Defined. Defined.
Lemma no_union `{IsHSet A} Lemma no_union `{IsHSet A}
(f : forall (X Y : Sub A), (U : forall (X Y : Sub A),
Bfin X -> Bfin Y -> Bfin (X ∪ Y)) Bfin X -> Bfin Y -> Bfin (X ∪ Y))
: DecidablePaths A. : DecidablePaths A.
Proof. Proof.
intros a b. intros a b.
specialize (f {|a|} {|b|} (singleton a) (singleton b)). destruct (U {|a|} {|b|} (singleton a) (singleton b)) as [n pn].
unfold Bfin in f.
destruct f as [n pn].
strip_truncations. strip_truncations.
destruct pn as [f [g fg gf _]].
destruct n as [|n].
unfold Sect in *. unfold Sect in *.
destruct pn as [f [g fg gf _]], n as [ | [ | n]].
- contradiction f. - contradiction f.
exists a. apply (tr(inl(tr idpath))). exists a.
- destruct n as [|n]. apply (tr(inl(tr idpath))).
+ (* If the size of the union is 1, then (a = b) *) - refine (inl _).
refine (inl _). pose (s1 := (a;tr(inl(tr idpath)))
pose (s1 := (a;tr(inl(tr idpath))) : {c : A & Trunc (-1) (Trunc (-1) (c = a) + Trunc (-1) (c = b))}).
: {c : A & Trunc (-1) (Trunc (-1) (c = a) + Trunc (-1) (c = b))}). pose (s2 := (b;tr(inr(tr idpath)))
pose (s2 := (b;tr(inr(tr idpath))) : {c : A & Trunc (-1) (Trunc (-1) (c = a) + Trunc (-1) (c = b))}).
: {c : A & Trunc (-1) (Trunc (-1) (c = a) + Trunc (-1) (c = b))}). refine (ap (fun x => x.1) (gf s1)^ @ _ @ (ap (fun x => x.1) (gf s2))).
refine (ap (fun x => x.1) (gf s1)^ @ _ @ (ap (fun x => x.1) (gf s2))). assert (fs_eq : f s1 = f s2).
assert (fs_eq : f s1 = f s2). { by apply path_ishprop. }
{ by apply path_ishprop. } refine (ap (fun x => (g x).1) fs_eq).
refine (ap (fun x => (g x).1) fs_eq). - (* Otherwise, ¬(a = b) *)
+ (* Otherwise, ¬(a = b) *) refine (inr (fun p => _)).
refine (inr (fun p => _)). pose (s1 := inl (inr tt) : Fin n + Unit + Unit).
pose (s1 := inl (inr tt) : Fin n + Unit + Unit). pose (s2 := inr tt : Fin n + Unit + Unit).
pose (s2 := inr tt : Fin n + Unit + Unit). pose (gs1 := g s1).
pose (gs1 := g s1). pose (c := gs1).
pose (c := g s1). pose (gs2 := g s2).
pose (gs2 := g s2). pose (d := gs2).
pose (d := g s2). assert (Hgs1 : gs1 = c) by reflexivity.
assert (Hgs1 : gs1 = c) by reflexivity. assert (Hgs2 : gs2 = d) by reflexivity.
assert (Hgs2 : gs2 = d) by reflexivity. destruct c as [x px'], d as [y py'].
destruct c as [x px']. simple refine (Trunc_ind _ _ px') ; intros px
destruct d as [y py']. ; simple refine (Trunc_ind _ _ py') ; intros py ; simpl.
simple refine (Trunc_ind _ _ px') ; intros px enough (s1 = s2) as X.
; simple refine (Trunc_ind _ _ py') ; intros py ; simpl. {
cut (x = y). unfold s1, s2 in X.
{ contradiction (inl_ne_inr _ _ X).
enough (s1 = s2) as X. }
{ refine ((fg s1)^ @ ap f (Hgs1 @ _ @ Hgs2^) @ fg s2).
unfold s1, s2 in X. simple refine (path_sigma _ _ _ _ _); [ | apply path_ishprop ]; simpl.
contradiction (inl_ne_inr _ _ X). destruct px as [px | px] ; destruct py as [py | py]
} ; refine (Trunc_rec _ px) ; clear px ; intro px
unfold gs1, gs2 in *. ; refine (Trunc_rec _ py) ; clear py ; intro py.
refine ((fg s1)^ @ _ @ fg s2). * apply (px @ py^).
rewrite Hgs1, Hgs2. * refine (px @ p @ py^).
f_ap. * refine (px @ p^ @ py^).
simple refine (path_sigma _ _ _ _ _); [ | apply path_ishprop ]; simpl. * apply (px @ py^).
destruct px as [px | px] ; destruct py as [py | py] Defined.
; refine (Trunc_rec _ px) ; clear px ; intro px
; refine (Trunc_rec _ py) ; clear py ; intro py.
* apply (px @ py^).
* refine (px @ _ @ py^). auto.
* refine (px @ _^ @ py^). auto.
* apply (px @ py^).
}
destruct px as [px | px] ; destruct py as [py | py]
; refine (Trunc_rec _ px) ; clear px ; intro px
; refine (Trunc_rec _ py) ; clear py ; intro py.
** apply (px @ py^).
** refine (px @ _ @ py^). auto.
** refine (px @ _^ @ py^). auto.
** apply (px @ py^).
Defined.
End finite_hott. End finite_hott.
Section singleton_set. Section singleton_set.
Variable (A : Type). Variable (A : Type).
Context `{Univalence}. Context `{Univalence}.
Variable (HA : forall a, {b : A & b ∈ {|a|}} <~> Fin 1).
Definition el x : {b : A & b ∈ {|x|}} := (x;tr idpath). Definition el x : {b : A & b ∈ {|x|}} := (x;tr idpath).
Theorem single_bfin_set (HA : forall a, {b : A & b ∈ {|a|}} <~> Fin 1) Theorem single_bfin_set : forall (x : A) (p : x = x), p = idpath.
: forall (x : A) (p : x = x), p = idpath.
Proof. Proof.
intros x p. intros x p.
specialize (HA x). specialize (HA x).
@ -172,6 +154,13 @@ Section singleton_set.
} }
apply path_ishprop. apply path_ishprop.
Defined. Defined.
Global Instance set_singleton : IsHSet A.
Proof.
refine hset_axiomK.
unfold axiomK.
apply single_bfin_set.
Defined.
End singleton_set. End singleton_set.
Section empty. Section empty.
@ -179,6 +168,7 @@ Section empty.
Variable (X : A -> hProp) Variable (X : A -> hProp)
(Xequiv : {a : A & a ∈ X} <~> Fin 0). (Xequiv : {a : A & a ∈ X} <~> Fin 0).
Context `{Univalence}. Context `{Univalence}.
Lemma X_empty : X = ∅. Lemma X_empty : X = ∅.
Proof. Proof.
apply path_forall. apply path_forall.
@ -217,8 +207,7 @@ Section split.
apply path_sigma_hprop. apply p. apply path_sigma_hprop. apply p.
- rewrite transport_paths_FlFr. - rewrite transport_paths_FlFr.
hott_simpl; cbn. hott_simpl; cbn.
rewrite ap_compose. rewrite ap_compose, (ap_compose inl f^-1).
rewrite (ap_compose inl f^-1).
rewrite ap_inl_path_sum_inl. rewrite ap_inl_path_sum_inl.
repeat (rewrite transport_paths_FlFr; hott_simpl). repeat (rewrite transport_paths_FlFr; hott_simpl).
rewrite !ap_pp. rewrite !ap_pp.
@ -233,7 +222,8 @@ Section split.
rewrite concat_Vp. rewrite concat_Vp.
rewrite (concat_p_pp (ap pr1 (eissect f (f^-1 (inl x))))^). rewrite (concat_p_pp (ap pr1 (eissect f (f^-1 (inl x))))^).
rewrite concat_Vp. rewrite concat_Vp.
hott_simpl. } hott_simpl.
}
exists (fun a => BuildhProp (P' a)). exists (fun a => BuildhProp (P' a)).
exists (f^-1 (inr tt)).1. exists (f^-1 (inr tt)).1.
split. split.
@ -245,8 +235,9 @@ Section split.
- intros [a [y p]]; cbn. - intros [a [y p]]; cbn.
eapply path_sigma with p^. eapply path_sigma with p^.
apply path_ishprop. apply path_ishprop.
- intros x; cbn. - intros x.
reflexivity. } reflexivity.
}
{ intros a. { intros a.
unfold P'. unfold P'.
apply path_iff_hprop. apply path_iff_hprop.
@ -279,9 +270,8 @@ Section Bfin_no_singletons.
Definition S1toSig (x : S1) : {x : S1 & merely(x = base)}. Definition S1toSig (x : S1) : {x : S1 & merely(x = base)}.
Proof. Proof.
exists x. exists x.
simple refine (S1_ind (fun z => merely(z = base)) _ _ x) ; simpl. simple refine (S1_ind (fun z => merely(z = base)) (tr idpath) _ x).
- apply (tr idpath). apply path_ishprop.
- apply path_ishprop.
Defined. Defined.
Instance S1toSig_equiv : IsEquiv S1toSig. Instance S1toSig_equiv : IsEquiv S1toSig.
@ -289,10 +279,9 @@ Section Bfin_no_singletons.
apply isequiv_biinv. apply isequiv_biinv.
split. split.
- exists (fun x => x.1). - exists (fun x => x.1).
simple refine (S1_ind _ _ _) ; simpl. simple refine (S1_ind _ idpath _) ; simpl.
* reflexivity. rewrite transport_paths_FlFr.
* rewrite transport_paths_FlFr. hott_simpl.
hott_simpl.
- exists (fun x => x.1). - exists (fun x => x.1).
intros [z x]. intros [z x].
simple refine (path_sigma _ _ _ _ _) ; simpl. simple refine (path_sigma _ _ _ _ _) ; simpl.
@ -322,7 +311,8 @@ End Bfin_no_singletons.
(* If A has decidable equality, then every Bfin subobject has decidable membership *) (* If A has decidable equality, then every Bfin subobject has decidable membership *)
Section dec_membership. Section dec_membership.
Variable (A : Type). Variable (A : Type).
Context `{DecidablePaths A} `{Univalence}. Context `{MerelyDecidablePaths A} `{Univalence}.
Global Instance DecidableMembership (P : Sub A) (Hfin : Bfin P) (a : A) : Global Instance DecidableMembership (P : Sub A) (Hfin : Bfin P) (a : A) :
Decidable (a ∈ P). Decidable (a ∈ P).
Proof. Proof.
@ -341,20 +331,23 @@ Section dec_membership.
unfold member, sub_membership. unfold member, sub_membership.
rewrite (HP a). rewrite (HP a).
destruct (IHn P' HP') as [IH | IH]. destruct (IHn P' HP') as [IH | IH].
+ left. apply (tr (inl IH)). * apply (inl (tr (inl IH))).
+ destruct (dec (a = b)) as [Hab | Hab]. * destruct (m_dec_path a b) as [Hab | Hab].
left. apply (tr (inr (tr Hab))). + apply (inl (tr (inr Hab))).
right. intros α. strip_truncations. + refine (inr(fun a => _)).
destruct α as [? | ?]; [ | strip_truncations]; contradiction. strip_truncations.
destruct a as [? | t] ; [ | strip_truncations] ; try contradiction.
contradiction (Hab (tr t)).
Defined. Defined.
End dec_membership. End dec_membership.
Section bfin_kfin. Section bfin_kfin.
Context `{Univalence}. Context `{Univalence}.
Lemma bfin_to_kfin : forall (B : Type), Finite B -> Kf B. Lemma bfin_to_kfin : forall (B : Type), Finite B -> Kf B.
Proof. Proof.
apply finite_ind_hprop. apply finite_ind_hprop.
- intros. apply _. - apply _.
- apply Kf_unfold. - apply Kf_unfold.
exists ∅. intros []. exists ∅. intros [].
- intros B [n f] IH. - intros B [n f] IH.
@ -393,56 +386,43 @@ Section kfin_bfin.
Proof. Proof.
intros HYb. intros HYb.
unshelve eapply BuildEquiv. unshelve eapply BuildEquiv.
{ intros [a Ha]. cbn in Ha. - intros [a Ha]. cbn in Ha.
destruct (dec (BuildhProp (a = b))) as [Hab | Hab]. destruct (dec (BuildhProp (a = b))) as [Hab | Hab].
- right. apply tt. + apply (inr tt).
- left. exists a. + refine (inl(a;_)).
strip_truncations. strip_truncations.
destruct Ha as [HXa | HYa]. destruct Ha as [HXa | HYa].
+ refine (Empty_rec _). * refine (Empty_rec _).
strip_truncations. strip_truncations.
by apply Hab. by apply Hab.
+ apply HYa. } * apply HYa.
{ apply isequiv_biinv. - apply isequiv_biinv.
unshelve esplit; cbn. unshelve esplit ; (unshelve eexists
- unshelve eexists. ; [intros [[a Ha] | []]
+ intros [[a Ha] | []]. ; [apply (a;(tr(inr Ha))) | apply (b;(tr(inl (tr idpath))))]
* exists a. | ]).
apply tr. + intros [a Ha]; cbn.
right. apply Ha. strip_truncations.
* exists b. simple refine (path_sigma' _ _ _); [ | apply path_ishprop ].
apply (tr (inl (tr idpath))). destruct (H a b); cbn.
+ intros [a Ha]; cbn. * apply p^.
strip_truncations. * reflexivity.
simple refine (path_sigma' _ _ _); [ | apply path_ishprop ]. + intros [[a Ha] | []]; cbn.
destruct (H a b); cbn. destruct (dec (a = b)) as [Hb | Hb]; cbn.
* apply p^. * refine (Empty_rec _).
* reflexivity. rewrite Hb in Ha.
- unshelve eexists. (* TODO ACHTUNG CODE DUPLICATION *) contradiction.
+ intros [[a Ha] | []]. * reflexivity.
* exists a. * destruct (dec (b = b)); [ reflexivity | contradiction ].
apply tr.
right. apply Ha.
* exists b.
apply (tr (inl (tr idpath))).
+ intros [[a Ha] | []]; cbn.
destruct (dec (_ = b)) as [Hb | Hb]; cbn.
{ refine (Empty_rec _).
rewrite Hb in Ha.
contradiction. }
{ reflexivity. }
destruct (dec (b = b)); [ reflexivity | contradiction ]. }
Defined. Defined.
Theorem bfin_union : @closedUnion A Bfin. Theorem bfin_union : @closedUnion A Bfin.
Proof. Proof.
intros X Y HX HY. intros X Y [n fX] HY.
destruct HX as [n fX].
strip_truncations. strip_truncations.
revert fX. revert X. revert fX. revert X.
induction n; intros X fX. induction n; intros X fX.
- rewrite (X_empty _ X fX). - rewrite (X_empty _ X fX), (neutralL_max (Sub A)).
rewrite (neutralL_max (Sub A)).
apply HY. apply HY.
- destruct (split X n fX) as - destruct (split X n fX) as
(X' & b & HX' & HX). (X' & b & HX' & HX).
@ -469,48 +449,45 @@ Section kfin_bfin.
exists (n'.+1). exists (n'.+1).
apply tr. apply tr.
transitivity ({a : A & a ∈ (fun a => merely (a = b)) ∪ (X' ∪ Y)}). transitivity ({a : A & a ∈ (fun a => merely (a = b)) ∪ (X' ∪ Y)}).
{ apply equiv_functor_sigma_id. * apply equiv_functor_sigma_id.
intro a. intro a.
rewrite <- (associative_max (Sub A)). rewrite <- (associative_max (Sub A)).
assert (X = X' ∪ (fun a => merely (a = b))) as HX_. assert (X = X' ∪ (fun a => merely (a = b))) as HX_.
{ apply path_forall. intros ?. ** apply path_forall. intros ?.
unfold union, sub_union, max_fun. unfold union, sub_union, max_fun.
apply HX. } apply HX.
rewrite HX_. ** rewrite HX_, <- (commutative_max (Sub A) X').
rewrite <- (commutative_max (Sub A) X'). reflexivity.
reflexivity. } * etransitivity.
cbn[Fin]. { apply (notIn_ext_union_singleton b _ HX'Yb). }
etransitivity. apply (notIn_ext_union_singleton b _ HX'Yb). by rewrite ((equiv_path _ _)^-1 fw).
by rewrite ((equiv_path _ _)^-1 fw).
Defined. Defined.
Definition FSet_to_Bfin : forall (X : FSet A), Bfin (map X). Definition FSet_to_Bfin : forall (X : FSet A), Bfin (map X).
Proof. Proof.
hinduction; try (intros; apply path_ishprop). hinduction; try (intros; apply path_ishprop).
- exists 0. apply tr. simpl. - exists 0.
apply tr.
simple refine (BuildEquiv _ _ _ _). simple refine (BuildEquiv _ _ _ _).
destruct 1 as [? []]. destruct 1 as [? []].
- intros a. - apply _.
apply _. - intros.
- intros Y1 Y2 HY1 HY2. apply bfin_union ; assumption.
apply bfin_union; auto.
Defined. Defined.
End kfin_bfin. End kfin_bfin.
Instance Kf_to_Bf (X : Type) `{Univalence} `{DecidablePaths X} (Hfin : Kf X) : Finite X. Global Instance Kf_to_Bf (X : Type) `{Univalence} `{DecidablePaths X} (Hfin : Kf X) : Finite X.
Proof. Proof.
apply Kf_unfold in Hfin. destruct (Kf_unfold _ Hfin) as [Y HY].
destruct Hfin as [Y HY]. simple refine (finite_equiv' _ _ (FSet_to_Bfin _ Y)).
pose (X' := FSet_to_Bfin _ Y).
unfold Bfin in X'.
simple refine (finite_equiv' _ _ X').
unshelve esplit. unshelve esplit.
- intros [a ?]. apply a. - apply (fun z => z.1).
- apply isequiv_biinv. split. - apply isequiv_biinv.
split.
* exists (fun a => (a;HY a)). * exists (fun a => (a;HY a)).
intros [b Hb]. intros [b Hb].
apply path_sigma' with idpath. apply path_sigma' with idpath.
apply path_ishprop. apply path_ishprop.
* exists (fun a => (a;HY a)). * refine (fun a => (a;HY a);fun _ => _).
intros b. reflexivity. reflexivity.
Defined. Defined.