Move the B-finiteness proofs and simplify them a bit

FiniteSets/variations/b_finite.v

@@ -0,0 +1,135 @@
+(* 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.