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

Get rid of cow induction for the proof of `closedUnion Bfin`

This commit is contained in:
Dan Frumin 2017-08-24 11:35:58 +02:00 committed by Dan Frumin
parent e1a8220ba0
commit eef533e345
1 changed files with 113 additions and 103 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

208
FiniteSets/variations/b_finite.v
View File

@ -156,7 +156,7 @@ Section finite_hott.
(Xequiv : {a : A & P a } <~> Fin n + Unit). (Xequiv : {a : A & P a } <~> Fin n + Unit).
Definition split : exists P' : Sub A, exists b : A, Definition split : exists P' : Sub A, exists b : A,
({a : A & P' a} <~> Fin n) * (forall x, P x = P' x ∨ merely (x = b)). ({a : A & P' a} <~> Fin n) * (forall x, P x = (P' x ∨ merely (x = b))).
Proof. Proof.
destruct Xequiv as [f [g fg gf adj]]. destruct Xequiv as [f [g fg gf adj]].
unfold Sect in *. unfold Sect in *.
@ -369,109 +369,119 @@ Section cowd.
Lemma kfin_is_bfin : @closedUnion A Bfin. Lemma kfin_is_bfin : @closedUnion A Bfin.
Proof. Proof.
intros X Y HX HY. intros X Y HX HY.
pose (Xcow := (X; HX) : cow). destruct HX as [n fX].
pose (Ycow := (Y; HY) : cow). strip_truncations.
simple refine (cowy (fun C => Bfin (C.1 ∪ Y)) _ _ Xcow); simpl. revert fX. revert X.
- assert ((fun a => Trunc (-1) (Empty + Y a)) = (fun a => Y a)) as Help. induction n; intros X fX.
{ apply path_forall. intros z; simpl. - destruct HY as [m fY]. strip_truncations.
apply path_iff_ishprop. exists m. apply tr.
+ intros; strip_truncations; auto. transitivity {a : A & a ∈ Y}; [ | assumption ].
destruct X0; auto. destruct e. apply equiv_functor_sigma_id.
+ intros ?. apply tr. right; assumption. intros a.
(* TODO FIX THIS with sum_empty_l *)
}
rewrite Help. apply HY.
- intros a [X' HX'] [n FX'Y]. strip_truncations.
destruct (dec(a ∈ X')) as [HaX' | HaX'].
* exists n. apply tr.
transitivity ({a : A & Trunc (-1) (X' a + Y a)}); [| assumption ].
apply equiv_functor_sigma_id. intro a'.
apply equiv_iff_hprop. apply equiv_iff_hprop.
{ intros Q. strip_truncations. * intros Ha. strip_truncations.
destruct Q as [Q | Q]. destruct Ha as [Ha | Ha]; [ | apply Ha ].
- strip_truncations. contradiction (fX (a;Ha)).
apply tr. left. * intros Ha. apply tr. by right.
destruct Q ; auto. - destruct (split _ X n fX) as
strip_truncations. rewrite t; assumption. (X' & b & HX' & HX).
- apply (tr (inr Q)). } assert (Bfin X') by (eexists; apply (tr HX')).
{ intros Q. strip_truncations. destruct (dec (b ∈ X')) as [HX'b | HX'b].
destruct Q as [Q | Q]; apply tr. + cut (X ∪ Y = X' ∪ Y).
- left. apply tr. left. done. { intros HXY. rewrite HXY.
- right. done. } by apply IHn. }
* destruct (dec (a ∈ Y)) as [HaY | HaY ]. apply path_forall. intro a.
** exists n. apply tr. unfold union, sub_union, lattice.max_fun.
transitivity ({a : A & Trunc (-1) (X' a + Y a)}); [| assumption ]. apply path_iff_hprop.
apply equiv_functor_sigma_id. intro a'. * intros Ha.
apply equiv_iff_hprop. strip_truncations.
{ intros Q. strip_truncations. destruct Ha as [HXa | HYa]; [ | apply tr; by right ].
destruct Q as [Q | Q]. rewrite HX in HXa.
- strip_truncations. strip_truncations.
destruct HXa as [HX'a | Hab];
[ | strip_truncations ]; apply tr; left.
** done.
** rewrite Hab. apply HX'b.
* intros Ha.
strip_truncations. apply tr.
destruct Ha as [HXa | HYa]; [ left | by right ].
rewrite HX. apply (tr (inl HXa)).
+ (* b ∉ X' *)
destruct (IHn X' HX') as [n' fw].
strip_truncations.
destruct (dec (b ∈ Y)) as [HYb | HYb].
{ exists n'. apply tr.
transitivity {a : A & a ∈ X' ∪ Y}; [ | apply fw ].
apply equiv_functor_sigma_id. intro a.
apply equiv_iff_hprop; cbn; simple refine (Trunc_rec _).
{ intros [HXa | HYa].
- rewrite HX in HXa.
strip_truncations.
destruct HXa as [HX'a | Hab]; apply tr.
* by left.
* right. strip_truncations.
rewrite Hab. apply HYb.
- apply tr. by right. }
{ intros [HX'a | HYa]; apply tr.
* left. rewrite HX.
apply (tr (inl HX'a)).
* by right. } }
{ exists (n'.+1).
apply tr. apply tr.
destruct Q. unshelve eapply BuildEquiv.
left. auto. { intros [a Ha]. cbn in Ha.
right. strip_truncations. rewrite t; assumption. destruct (dec (BuildhProp (a = b))) as [Hab | Hab].
- apply (tr (inr Q)). }
{ intros Q. strip_truncations.
destruct Q as [Q | Q]; apply tr.
- left. apply tr. left. done.
- right. done. }
** exists (n.+1). apply tr.
destruct FX'Y as [f [g Hfg Hgf adj]].
unshelve esplit.
{ intros [a' Ha']. cbn in Ha'.
destruct (dec (BuildhProp (a' = a))) as [Ha'a | Ha'a].
- right. apply tt. - right. apply tt.
- left. refine (f (a';_)). - left. refine (fw (a;_)).
strip_truncations. apply tr.
destruct Ha as [HXa | HYa].
+ left. rewrite HX in HXa.
strip_truncations. strip_truncations.
destruct Ha' as [Ha' | Ha']. destruct HXa as [HX'a | Hab']; [apply HX'a |].
+ strip_truncations. strip_truncations. contradiction.
destruct Ha' as [Ha' | Ha']. + right. apply HYa. }
* apply (tr (inl Ha')). { apply isequiv_biinv.
* strip_truncations. contradiction. unshelve esplit; cbn.
+ apply (tr (inr Ha')). } - unshelve eexists.
{ apply isequiv_biinv; simpl. + intros [m | []].
unshelve esplit; simpl. * destruct (fw^-1 m) as [a Ha].
- unfold Sect; simpl. exists a.
simple refine (_;_). strip_truncations. apply tr.
{ destruct 1 as [M | ?]. destruct Ha as [HX'a | HYa]; [ left | by right ].
- destruct (g M) as [a' Ha']. rewrite HX.
exists a'. apply (tr (inl HX'a)).
strip_truncations; apply tr. * exists b.
destruct Ha' as [Ha' | Ha']. rewrite HX.
+ left. apply (tr (inl Ha')). apply (tr (inl (tr (inr (tr idpath))))).
+ right. done. + intros [a Ha]; cbn.
- exists a. apply (tr (inl (tr (inr (tr idpath))))). }
{ intros [a' Ha']; simpl.
strip_truncations. strip_truncations.
destruct Ha' as [HXa' | Haa']; simpl; simple refine (path_sigma' _ _ _); [ | apply path_ishprop ].
destruct (dec (a' = a)); simpl. destruct (H a b); cbn.
** apply path_sigma' with p^. apply path_ishprop. * apply p^.
** rewrite Hgf; cbn. apply path_sigma' with idpath. apply path_ishprop. * rewrite eissect; cbn.
** apply path_sigma' with p^. apply path_ishprop. reflexivity.
** rewrite Hgf; cbn. done. } - unshelve eexists. (* TODO: Duplication!! *)
- unfold Sect; simpl. + intros [m | []].
simple refine (_;_). * exists (fw^-1 m).1.
{ destruct 1 as [M | ?]. simple refine (Trunc_rec _ (fw^-1 m).2).
- (* destruct (g M) as [a' Ha']. *) intros [HX'a | HYa]; apply tr; [ left | by right ].
exists (g M).1. rewrite HX.
simple refine (Trunc_rec _ (g M).2). apply (tr (inl HX'a)).
intros Ha'. * exists b.
apply tr. rewrite HX.
(* strip_truncations; apply tr. *) apply (tr (inl (tr (inr (tr idpath))))).
destruct Ha' as [Ha' | Ha']. + intros [m | []]; cbn.
+ left. apply (tr (inl Ha')). destruct (dec (_ = b)) as [Hb | Hb]; cbn.
+ right. done. { destruct (fw^-1 m) as [a Ha]. simpl in Hb.
- exists a. apply (tr (inl (tr (inr (tr idpath))))). } simple refine (Trunc_rec _ Ha). clear Ha.
simpl. intros [M | [] ]. rewrite Hb.
** destruct (dec (_ = a)) as [Haa' | Haa']; simpl. intros [HX'b2 | HYb2]; contradiction. }
{ destruct (g M) as [a' Ha']. simpl in Haa'. { f_ap. transitivity (fw (fw^-1 m)).
strip_truncations. - f_ap.
rewrite Haa' in Ha'. destruct Ha'; by contradiction. } apply path_sigma' with idpath.
{ f_ap. transitivity (f (g M)); [ | apply Hfg]. apply path_ishprop.
f_ap. apply path_sigma' with idpath. - apply eisretr. }
apply path_ishprop. } destruct (dec (b = b)); [ reflexivity | contradiction ]. } }
** destruct (dec (a = a)); try by contradiction.
reflexivity. }
Defined. Defined.
End cowd. End cowd.