mirror of https://github.com/nmvdw/HITs-Examples
136 lines
4.2 KiB
Coq
136 lines
4.2 KiB
Coq
(* Bishop-finiteness is that "default" notion of finiteness in the HoTT library *)
|
||
Require Import HoTT.
|
||
Require Import Sub notation.
|
||
|
||
Section finite_hott.
|
||
Variable A : Type.
|
||
Context `{Univalence} `{IsHSet A}.
|
||
|
||
(* A subobject is B-finite if its extension is B-finite as a type *)
|
||
Definition Bfin (X : Sub A) : hProp := BuildhProp (Finite {a : A & a ∈ X}).
|
||
|
||
Global Instance singleton_contr a : Contr {b : A & b ∈ {|a|}}.
|
||
Proof.
|
||
exists (a; tr idpath).
|
||
intros [b p].
|
||
simple refine (Trunc_ind (fun p => (a; tr 1%path) = (b; p)) _ p).
|
||
clear p; intro p. simpl.
|
||
apply path_sigma' with (p^).
|
||
apply path_ishprop.
|
||
Defined.
|
||
|
||
Definition singleton_fin_equiv' a : Fin 1 -> {b : A & b ∈ {|a|}}.
|
||
Proof.
|
||
intros _. apply (center {b : A & b ∈ {|a|}}).
|
||
Defined.
|
||
|
||
Global Instance singleton_fin_equiv a : IsEquiv (singleton_fin_equiv' a).
|
||
Proof. apply _. Defined.
|
||
|
||
Definition singleton : closedSingleton Bfin.
|
||
Proof.
|
||
intros a.
|
||
simple refine (Build_Finite _ 1 _).
|
||
apply tr.
|
||
symmetry.
|
||
refine (BuildEquiv _ _ (singleton_fin_equiv' a) _).
|
||
Defined.
|
||
|
||
Definition empty_finite : closedEmpty Bfin.
|
||
Proof.
|
||
simple refine (Build_Finite _ 0 _).
|
||
apply tr.
|
||
simple refine (BuildEquiv _ _ _ _).
|
||
intros [a p]; apply p.
|
||
Defined.
|
||
|
||
Definition decidable_empty_finite : hasDecidableEmpty Bfin.
|
||
Proof.
|
||
intros X Y.
|
||
destruct Y as [n Xn].
|
||
strip_truncations.
|
||
destruct Xn as [f [g fg gf adj]].
|
||
destruct n.
|
||
- refine (tr(inl _)).
|
||
apply path_forall. intro z.
|
||
apply path_iff_hprop.
|
||
* intros p.
|
||
contradiction (f (z;p)).
|
||
* contradiction.
|
||
- refine (tr(inr _)).
|
||
apply (tr(g(inr tt))).
|
||
Defined.
|
||
|
||
Lemma no_union
|
||
(f : forall (X Y : Sub A),
|
||
Bfin X -> Bfin Y -> Bfin (X ∪ Y))
|
||
(a b : A) :
|
||
hor (a = b) (a = b -> Empty).
|
||
Proof.
|
||
specialize (f {|a|} {|b|} (singleton a) (singleton b)).
|
||
unfold Bfin in f.
|
||
destruct f as [n pn].
|
||
strip_truncations.
|
||
destruct pn as [f [g fg gf _]].
|
||
destruct n as [|n].
|
||
unfold Sect in *.
|
||
- contradiction f.
|
||
exists a. apply (tr(inl(tr idpath))).
|
||
- destruct n as [|n].
|
||
+ (* If the size of the union is 1, then (a = b) *)
|
||
refine (tr (inl _)).
|
||
pose (s1 := (a;tr(inl(tr idpath)))
|
||
: {c : A & Trunc (-1) (Trunc (-1) (c = a) + Trunc (-1) (c = b))}).
|
||
pose (s2 := (b;tr(inr(tr idpath)))
|
||
: {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))).
|
||
assert (fs_eq : f s1 = f s2).
|
||
{ by apply path_ishprop. }
|
||
refine (ap (fun x => (g x).1) fs_eq).
|
||
+ (* Otherwise, ¬(a = b) *)
|
||
refine (tr (inr _)).
|
||
intros p.
|
||
pose (s1 := inl (inr tt) : Fin n + Unit + Unit).
|
||
pose (s2 := inr tt : Fin n + Unit + Unit).
|
||
pose (gs1 := g s1).
|
||
pose (c := g s1).
|
||
pose (gs2 := g s2).
|
||
pose (d := g s2).
|
||
assert (Hgs1 : gs1 = c) by reflexivity.
|
||
assert (Hgs2 : gs2 = d) by reflexivity.
|
||
destruct c as [x px'].
|
||
destruct d as [y py'].
|
||
simple refine (Trunc_ind _ _ px') ; intros px.
|
||
simple refine (Trunc_ind _ _ py') ; intros py.
|
||
simpl.
|
||
cut (x = y).
|
||
{
|
||
enough (s1 = s2) as X.
|
||
{
|
||
intros.
|
||
unfold s1, s2 in X.
|
||
refine (not_is_inl_and_inr' (inl(inr tt)) _ _).
|
||
+ apply tt.
|
||
+ rewrite X ; apply tt.
|
||
}
|
||
transitivity (f gs1).
|
||
{ apply (fg s1)^. }
|
||
symmetry ; transitivity (f gs2).
|
||
{ apply (fg s2)^. }
|
||
rewrite Hgs1, Hgs2.
|
||
f_ap.
|
||
simple refine (path_sigma _ _ _ _ _); [ | apply path_ishprop ]; simpl.
|
||
destruct px as [p1 | p1] ; destruct py as [p2 | p2] ; strip_truncations.
|
||
* apply (p2 @ p1^).
|
||
* refine (p2 @ _^ @ p1^). auto.
|
||
* refine (p2 @ _ @ p1^). auto.
|
||
* apply (p2 @ p1^).
|
||
}
|
||
destruct px as [px | px] ; destruct py as [py | py]; strip_truncations.
|
||
** apply (px @ py^).
|
||
** refine (px @ _ @ py^). auto.
|
||
** refine (px @ _ @ py^). symmetry. auto.
|
||
** apply (px @ py^).
|
||
Defined.
|
||
End finite_hott.
|