A negligible change in the structure

FiniteSets/subobjects/Sub.v

@@ -0,0 +1,78 @@
+Require Import HoTT.
+Require Import disjunction lattice notation plumbing.
+
+Section subobjects.
+  Variable A : Type.
+
+  Definition Sub := A -> hProp.
+
+  Global Instance sub_empty : hasEmpty Sub := fun _ => False_hp.
+  Global Instance sub_union : hasUnion Sub := max_fun.
+  Global Instance sub_intersection : hasIntersection Sub := min_fun.
+  Global Instance sub_singleton : hasSingleton Sub A
+    := fun a b => BuildhProp (Trunc (-1) (b = a)).
+  Global Instance sub_membership : hasMembership Sub A := fun a X => X a.
+  Global Instance sub_comprehension : hasComprehension Sub A
+    := fun ϕ X a => BuildhProp (X a * (ϕ a = true)).
+  Global Instance sub_subset `{Univalence} : hasSubset Sub
+    := fun X Y => BuildhProp (forall a, X a -> Y a).
+
+End subobjects.
+
+Section sub_classes.
+  Context {A : Type}.
+  Variable C : (A -> hProp) -> hProp.
+  Context `{Univalence}.
+
+  Instance subobject_lattice : Lattice (Sub A).
+  Proof.
+    apply _.
+  Defined.  
+
+  Definition closedUnion := forall X Y, C X -> C Y -> C (X ∪ Y).
+  Definition closedIntersection := forall X Y, C X -> C Y -> C (X ∩ Y).
+  Definition closedEmpty := C ∅.
+  Definition closedSingleton := forall a, C {|a|}.
+  Definition hasDecidableEmpty := forall X, C X -> hor (X = ∅) (hexists (fun a => a ∈ X)).
+End sub_classes.
+
+Section isIn.
+  Variable A : Type.
+  Variable C : (A -> hProp) -> hProp.
+
+  Context `{Univalence}.
+  Context {HS : closedSingleton C} {HIn : forall X, C X -> forall a, Decidable (X a)}.
+
+  Theorem decidable_A_isIn (a b : A) : Decidable (Trunc (-1) (b = a)).
+  Proof.
+    destruct (HIn {|a|} (HS a) b).
+    - apply (inl t).
+    - refine (inr(fun p => _)).
+      strip_truncations.
+      contradiction (n (tr p)).
+  Defined.
+
+End isIn.
+
+Section intersect.
+  Variable A : Type.
+  Variable C : (Sub A) -> hProp.
+  Context `{Univalence}
+    {HI : closedIntersection C} {HE : closedEmpty C}
+    {HS : closedSingleton C} {HDE : hasDecidableEmpty C}.
+
+  Theorem decidable_A_intersect (a b : A) : Decidable (Trunc (-1) (b = a)).
+  Proof.
+    unfold Decidable.
+    pose (HI {|a|} {|b|} (HS a) (HS b)) as IntAB.
+    pose (HDE ({|a|} ∪ {|b|}) IntAB) as IntE.
+    refine (Trunc_rec _ IntE) ; intros [p | p].
+    - refine (inr(fun q => _)).
+      strip_truncations.
+      refine (transport (fun Z => a ∈ Z) p (tr idpath, tr q^)).
+    - strip_truncations.
+      destruct p as [? [t1 t2]].
+      strip_truncations.
+      apply (inl (tr (t2^ @ t1))).
+  Defined.
+End intersect.

FiniteSets/subobjects/b_finite.v

@@ -0,0 +1,514 @@
+(* Bishop-finiteness is that "default" notion of finiteness in the HoTT library *)
+Require Import HoTT HitTactics.
+Require Import sub subobjects.k_finite FSets prelude.
+
+Section finite_hott.
+  Variable (A : Type).
+  Context `{Univalence}.
+
+  (* 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 `{IsHSet 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_hprop; simpl.
+    apply p^.
+  Defined.
+  
+  Definition singleton_fin_equiv' a : Fin 1 -> {b : A & b ∈ {|a|}}.
+  Proof.  
+    intros _. apply (a; tr idpath).
+  Defined.
+
+  Global Instance singleton_fin_equiv a `{IsHSet A} : IsEquiv (singleton_fin_equiv' a).
+  Proof. apply _. Defined.
+
+  Definition singleton `{IsHSet A} : 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 f].
+    strip_truncations.
+    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(f^-1(inr tt))).
+  Defined.
+  
+  Lemma no_union `{IsHSet A}
+        (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.
+
+Section empty.
+  Variable (A : Type).
+  Variable (X : A -> hProp)
+           (Xequiv : {a : A & a ∈ X} <~> Fin 0).
+  Context `{Univalence}.
+  Lemma X_empty : X = ∅.
+  Proof.
+    apply path_forall.
+    intro z.
+    apply path_iff_hprop ; try contradiction.
+    intro x.
+    destruct Xequiv as [f fequiv].
+    contradiction (f(z;x)).
+  Defined.  
+End empty.
+
+Section split.
+  Context `{Univalence}.
+  Variable (A : Type).
+  Variable (P : A -> hProp)
+           (n : nat)
+           (f : {a : A & P a } <~> Fin n + Unit).
+
+  Definition split : exists P' : Sub A, exists b : A,
+        ({a : A & P' a} <~> Fin n) * (forall x, P x = (P' x ∨ merely (x = b))).
+  Proof.
+    pose (fun x : A => sig (fun y : Fin n => x = (f^-1 (inl y)).1)) as P'.
+    assert (forall x, IsHProp (P' x)).
+    {
+      intros a. unfold P'.
+      apply hprop_allpath.
+      intros [x px] [y py].
+      pose (p := px^ @ py).
+      assert (p2 : p # (f^-1 (inl x)).2 = (f^-1 (inl y)).2).
+      { apply path_ishprop. }
+      simple refine (path_sigma' _ _ _).
+      - apply path_sum_inl with Unit.
+        refine (transport (fun z => z = inl y) (eisretr f (inl x)) _).
+        refine (transport (fun z => _ = z) (eisretr f (inl y)) _).
+        apply (ap f).
+        apply path_sigma_hprop. apply p.
+      - rewrite transport_paths_FlFr.
+        hott_simpl; cbn.
+        rewrite ap_compose.
+        rewrite (ap_compose inl f^-1).
+        rewrite ap_inl_path_sum_inl.
+        repeat (rewrite transport_paths_FlFr; hott_simpl).
+        rewrite !ap_pp.
+        rewrite ap_V.
+        rewrite <- !other_adj.
+        rewrite <- (ap_compose f (f^-1)).
+        rewrite ap_equiv.
+        rewrite !ap_pp.
+        rewrite ap_pr1_path_sigma_hprop.
+        rewrite !concat_pp_p.
+        rewrite !ap_V.
+        rewrite concat_Vp.
+        rewrite (concat_p_pp (ap pr1 (eissect f (f^-1 (inl x))))^).
+        rewrite concat_Vp.
+        hott_simpl. }
+    exists (fun a => BuildhProp (P' a)).
+    exists (f^-1 (inr tt)).1.
+    split.
+    { unshelve eapply BuildEquiv.
+      { refine (fun x => x.2.1). }
+      apply isequiv_biinv.
+      unshelve esplit;
+        exists (fun x => (((f^-1 (inl x)).1; (x; idpath)))).
+      - intros [a [y p]]; cbn.
+        eapply path_sigma with p^.
+        apply path_ishprop.
+      - intros x; cbn.
+        reflexivity. }
+    { intros a.
+      unfold P'.
+      apply path_iff_hprop.
+      - intros Ha.
+        pose (y := f (a;Ha)).
+        assert (Hy : y = f (a; Ha)) by reflexivity.
+        destruct y as [y | []].
+        + refine (tr (inl _)).
+          exists y.
+          rewrite Hy.
+          by rewrite eissect.
+        + refine (tr (inr (tr _))).
+          rewrite Hy.
+          by rewrite eissect.
+      - intros Hstuff.
+        strip_truncations.
+        destruct Hstuff as [[y Hy] | Ha].
+        + rewrite Hy.
+          apply (f^-1 (inl y)).2.
+        + strip_truncations.
+          rewrite Ha.
+          apply (f^-1 (inr tt)).2. }
+  Defined.
+End split.
+
+Arguments Bfin {_} _.
+Arguments split {_} {_} _ _ _.
+
+Section Bfin_no_singletons.
+  Definition S1toSig (x : S1) : {x : S1 & merely(x = base)}.
+  Proof.
+    exists x.
+    simple refine (S1_ind (fun z => merely(z = base)) _ _ x) ; simpl.
+    - apply (tr idpath).
+    - apply path_ishprop.
+  Defined.
+
+  Instance S1toSig_equiv : IsEquiv S1toSig.
+  Proof.
+    apply isequiv_biinv.
+    split.
+    - exists (fun x => x.1).
+      simple refine (S1_ind _ _ _) ; simpl.
+      * reflexivity.
+      * rewrite transport_paths_FlFr.
+        hott_simpl.
+    - exists (fun x => x.1).
+      intros [z x].
+      simple refine (path_sigma _ _ _ _ _) ; simpl.
+      * reflexivity.
+      * apply path_ishprop.
+  Defined.
+
+  Theorem no_singleton `{Univalence} (Hsing : Bfin {|base|}) : Empty.
+  Proof.
+    destruct Hsing as [n equiv].
+    strip_truncations.
+    assert (S1 <~> Fin n) as X.
+    { apply (equiv_compose equiv S1toSig). }
+    assert (IsHSet S1) as X1.
+    {
+      rewrite (path_universe X).
+      apply _.
+    }
+    enough (idpath = loop). 
+    - assert (S1_encode _ idpath = S1_encode _ (loopexp loop (pos Int.one))) as H' by f_ap.
+      rewrite S1_encode_loopexp in H'. simpl in H'. symmetry in H'.
+      apply (pos_neq_zero H').
+    - apply set_path2.
+  Defined.
+End Bfin_no_singletons.
+
+(* If A has decidable equality, then every Bfin subobject has decidable membership *)
+Section dec_membership.
+  Variable (A : Type).
+  Context `{DecidablePaths A} `{Univalence}.
+  Global Instance DecidableMembership (P : Sub A) (Hfin : Bfin P) (a : A) :
+    Decidable (a ∈ P).
+  Proof.
+    destruct Hfin as [n Hequiv].
+    strip_truncations.
+    revert Hequiv.
+    revert P.
+    induction n.
+    - intros.
+      pose (X_empty _ P Hequiv) as p.
+      rewrite p.
+      apply _.
+    - intros.
+      destruct (split P n Hequiv) as
+        (P' & b & HP' & HP).
+      unfold member, sub_membership.
+      rewrite (HP a).
+      destruct (IHn P' HP') as [IH | IH].
+      + left. apply (tr (inl IH)).
+      + destruct (dec (a = b)) as [Hab | Hab].
+        left. apply (tr (inr (tr Hab))).
+        right. intros α. strip_truncations.
+        destruct α as [? | ?]; [ | strip_truncations]; contradiction.
+  Defined.
+End dec_membership.
+
+Section bfin_kfin.
+  Context `{Univalence}.
+  Lemma bfin_to_kfin : forall (B : Type), Finite B -> Kf B.
+  Proof.
+    apply finite_ind_hprop.
+    - intros. apply _.
+    - apply Kf_unfold.
+      exists ∅. intros [].
+    - intros B [n f] IH.
+      strip_truncations.
+      apply Kf_unfold in IH.
+      destruct IH as [X HX].
+      apply Kf_unfold.
+      exists ((fmap FSet inl X) ∪ {|inr tt|}); simpl.
+      intros [a | []]; apply tr.
+      + left.
+        apply fmap_isIn.
+        apply (HX a).
+      + right. apply (tr idpath).
+  Defined.
+
+  Definition bfin_to_kfin_sub A : forall (P : Sub A), Bfin P -> Kf_sub _ P.
+  Proof.
+    intros P [n f].
+    strip_truncations.
+    revert f. revert P.
+    induction n; intros P f.
+    - exists ∅.
+      apply path_forall; intro a; simpl.
+      apply path_iff_hprop; [ | contradiction ].
+      intros p.
+      apply (f (a;p)).
+    - destruct (split P n f) as
+        (P' & b & HP' & HP).
+      destruct (IHn P' HP') as [Y HY].
+      exists (Y ∪ {|b|}).
+      apply path_forall; intro a. simpl.
+      rewrite <- HY.
+      apply HP.
+  Defined.
+End bfin_kfin.
+
+Section kfin_bfin.
+  Variable (A : Type).
+  Context `{DecidablePaths A} `{Univalence}.
+
+  Lemma bfin_union : @closedUnion A Bfin.
+  Proof.
+    intros X Y HX HY.
+    destruct HX as [n fX].
+    strip_truncations.
+    revert fX. revert X.
+    induction n; intros X fX.
+    - destruct HY as [m fY]. strip_truncations.
+      exists m. apply tr.
+      transitivity {a : A & a ∈ Y}; [ | assumption ].
+      apply equiv_functor_sigma_id.
+      intros a.
+      apply equiv_iff_hprop.
+      * intros Ha. strip_truncations.
+        destruct Ha as [Ha | Ha]; [ | apply Ha ].
+        contradiction (fX (a;Ha)).
+      * intros Ha. apply tr. by right.
+    - destruct (split X n fX) as
+        (X' & b & HX' & HX).
+      assert (Bfin X') by (eexists; apply (tr HX')).
+      destruct (dec (b ∈ X')) as [HX'b | HX'b].
+      + cut (X ∪ Y = X' ∪ Y).
+        { intros HXY. rewrite HXY.
+          by apply IHn. }
+        apply path_forall. intro a.
+        apply path_iff_hprop.
+        * intros Ha.
+          strip_truncations.
+          destruct Ha as [HXa | HYa]; [ | apply tr; by right ].
+          rewrite HX in HXa.
+          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.
+          unshelve eapply BuildEquiv.
+          { intros [a Ha]. cbn in Ha.
+            destruct (dec (BuildhProp (a = b))) as [Hab | Hab].
+            - right. apply tt.
+            - left. refine (fw (a;_)).
+              strip_truncations. apply tr.
+              destruct Ha as [HXa | HYa].
+              + left. rewrite HX in HXa.
+                strip_truncations.
+                destruct HXa as [HX'a | Hab']; [apply HX'a |].
+                strip_truncations. contradiction.
+              + right. apply HYa. }
+          { apply isequiv_biinv.
+            unshelve esplit; cbn.
+            - unshelve eexists.
+              + intros [m | []].
+                * destruct (fw^-1 m) as [a Ha].
+                  exists a.
+                  strip_truncations. apply tr.
+                  destruct Ha as [HX'a | HYa]; [ left | by right ].
+                  rewrite HX.
+                  apply (tr (inl HX'a)).
+                * exists b.
+                  rewrite HX.
+                  apply (tr (inl (tr (inr (tr idpath))))).
+              + intros [a Ha]; cbn.
+                strip_truncations.
+                simple refine (path_sigma' _ _ _); [ | apply path_ishprop ].
+                destruct (H a b); cbn.
+                * apply p^.
+                * rewrite eissect; cbn.
+                  reflexivity.
+            - unshelve eexists. (* TODO: Duplication!! *)
+              + intros [m | []].
+                * exists (fw^-1 m).1.
+                  simple refine (Trunc_rec _ (fw^-1 m).2).
+                  intros [HX'a | HYa]; apply tr; [ left | by right ].
+                  rewrite HX.
+                  apply (tr (inl HX'a)).
+                * exists b.
+                  rewrite HX.
+                  apply (tr (inl (tr (inr (tr idpath))))).
+              + intros [m | []]; cbn.
+                destruct (dec (_ = b)) as [Hb | Hb]; cbn.
+                { destruct (fw^-1 m) as [a Ha]. simpl in Hb.
+                  simple refine (Trunc_rec _ Ha). clear Ha.
+                  rewrite Hb.
+                  intros [HX'b2 | HYb2]; contradiction. }
+                { f_ap. transitivity (fw (fw^-1 m)).
+                  - f_ap.
+                    apply path_sigma' with idpath.
+                    apply path_ishprop.
+                  - apply eisretr. }
+                destruct (dec (b = b)); [ reflexivity | contradiction ]. } }
+  Defined.
+
+  Definition FSet_to_Bfin : forall (X : FSet A), Bfin (map X).
+  Proof.
+    hinduction; try (intros; apply path_ishprop).
+    - exists 0. apply tr. simpl.
+      simple refine (BuildEquiv _ _ _ _).
+      destruct 1 as [? []].
+    - intros a.
+      exists 1. apply tr. simpl.
+      transitivity Unit; [ | symmetry; apply sum_empty_l ].
+      unshelve esplit.
+      + exact (fun _ => tt).
+      + apply isequiv_biinv. split.
+        * exists (fun _ => (a; tr(idpath))).
+          intros [b Hb]. strip_truncations.
+          apply path_sigma' with Hb^.
+          apply path_ishprop.
+        * exists (fun _ => (a; tr(idpath))).
+          intros []. reflexivity.
+    - intros Y1 Y2 HY1 HY2.
+      apply bfin_union; auto.
+  Defined.
+
+End kfin_bfin.
+
+Instance Kf_to_Bf (X : Type) `{Univalence} `{DecidablePaths X} (Hfin : Kf X) : Finite X.
+Proof.
+  apply Kf_unfold in Hfin.
+  destruct Hfin as [Y HY].
+  pose (X' := FSet_to_Bfin _ Y).
+  unfold Bfin in X'.
+  simple refine (finite_equiv' _ _ X').
+  unshelve esplit.
+  - intros [a ?]. apply a.
+  - apply isequiv_biinv. split.
+    * exists (fun a => (a;HY a)).
+      intros [b Hb].
+      apply path_sigma' with idpath.
+      apply path_ishprop.
+    * exists (fun a => (a;HY a)).
+      intros b. reflexivity.
+Defined.

FiniteSets/subobjects/enumerated.v

@@ -0,0 +1,452 @@
+(* Enumerated finite sets *)
+Require Import HoTT HitTactics.
+Require Import sub prelude FSets list_representation subobjects.k_finite
+        list_representation.isomorphism
+        lattice_interface lattice_examples.
+
+Fixpoint listExt {A} (ls : list A) : Sub A := fun x =>
+  match ls with
+  | nil => False_hp
+  | cons a ls' => BuildhProp (Trunc (-1) (x = a)) ∨ listExt ls' x
+  end.
+
+Fixpoint map {A B} (f : A -> B) (ls : list A) : list B :=
+  match ls with
+  | nil       => nil
+  | cons x xs => cons (f x) (map f xs)
+  end.
+
+Fixpoint filterD {A} (P : A -> Bool) (ls : list A) : list { x : A | P x = true }.
+Proof.
+destruct ls as [|x xs].
+- exact nil.
+- enough ((P x = true) + (P x = false)) as HP.
+  { destruct HP as [HP | HP].
+    + refine (cons (exist _ x HP) (filterD _ P xs)).
+    + refine (filterD _ P xs).
+  }
+  { destruct (P x); [left | right]; reflexivity. }
+Defined.
+
+Lemma filterD_cons {A} (P : A -> Bool) (a : A) (ls : list A) (Pa : P a = true) :
+  filterD P (cons a ls) = cons (a;Pa) (filterD P ls).
+Proof.
+  simpl.
+  destruct (if P a as b return ((b = true) + (b = false))
+     then inl 1%path
+     else inr 1%path) as [Pa' | Pa'].
+  - rewrite (set_path2 Pa Pa'). reflexivity.
+  - rewrite Pa in Pa'. contradiction (true_ne_false Pa').
+Defined.
+
+Lemma filterD_cons_no {A} (P : A -> Bool) (a : A) (ls : list A) (Pa : P a = false) :
+  filterD P (cons a ls) = filterD P ls.
+Proof.
+  simpl.
+  destruct (if P a as b return ((b = true) + (b = false))
+     then inl 1%path
+     else inr 1%path) as [Pa' | Pa'].
+  - rewrite Pa' in Pa. contradiction (true_ne_false Pa).
+  - reflexivity.
+Defined.
+
+Lemma filterD_lookup {A} (P : A -> Bool) (x : A) (ls : list A) (Px : P x = true) :
+  listExt ls x -> listExt (filterD P ls) (x;Px).
+Proof.
+induction ls as [| a ls].
+- simpl. exact idmap.
+- assert ((P a = true) + (P a = false)) as HPA.
+  { destruct (P a); [left | right]; reflexivity. }
+  destruct HPA as [Pa | Pa].
+  + rewrite (filterD_cons P a ls Pa). simpl.
+    simple refine (Trunc_ind _ _). intros [Hxa | HIH]; apply tr.
+    * left. strip_truncations.
+      apply tr.
+      apply path_sigma' with Hxa.
+      apply set_path2.
+    * right. apply (IHls HIH).
+  + rewrite (filterD_cons_no P a ls Pa). simpl.
+    simple refine (Trunc_ind _ _). intros [Hxa | HIH].
+    * strip_truncations.
+      rewrite <- Hxa in Pa. rewrite Px in Pa.
+      contradiction (true_ne_false Pa).
+    * apply IHls. apply HIH.
+Defined.
+
+(** Definition of finite sets in an enumerated sense *)
+Definition enumerated (A : Type) : hProp :=
+  hexists (fun ls => forall (a : A), listExt ls a).
+
+(** Properties of enumerated sets: closed under decidable subsets *)
+Lemma enumerated_comprehension (A : Type) (P : A -> Bool) :
+  enumerated A -> enumerated { x : A | P x = true }.
+Proof.
+  intros HeA. strip_truncations. destruct HeA as [eA HeA].
+  apply tr.
+  exists (filterD P eA).
+  intros [x Px].
+  apply filterD_lookup.
+  apply (HeA x).
+Defined.
+
+Lemma map_listExt {A B} (f : A -> B) (ls : list A) (y : A) :
+  listExt ls y -> listExt (map f ls) (f y).
+Proof.
+induction ls.
+- simpl. apply idmap.
+- simpl. simple refine (Trunc_ind _ _). intros [Hxa | HIH]; apply tr.
+  + left. strip_truncations. apply tr. f_ap.
+  + right. apply IHls. apply HIH.
+Defined.
+
+(** Properties of enumerated sets: closed under surjections *)
+Lemma enumerated_surj (A B : Type) (f : A -> B) :
+  IsSurjection f -> enumerated A -> enumerated B.
+Proof.
+  intros Hsurj HeA. strip_truncations; apply tr.
+  destruct HeA as [eA HeA].
+  exists (map f eA).
+  intros x. specialize (Hsurj x).
+  pose (t := center (merely (hfiber f x))).
+  simple refine (@Trunc_rec (-1) (hfiber f x) (listExt (map f eA) x) _ _ t).
+  intros [y Hfy].
+  specialize (HeA y). rewrite <- Hfy.
+  apply map_listExt. apply HeA.
+Defined.
+
+Lemma listExt_app_r {A} (ls ls' : list A) (x : A) :
+  listExt ls x -> listExt (ls ++ ls') x.
+Proof.
+induction ls; simpl.
+- exact Empty_rec.
+- simple refine (Trunc_ind _ _). intros [Hxa | HIH]; apply tr.
+  + left. apply Hxa.
+  + right. apply IHls. apply HIH.
+Defined.
+
+Lemma listExt_app_l {A} (ls ls' : list A) (x : A) :
+  listExt ls x -> listExt (ls' ++ ls) x.
+Proof.
+induction ls'; simpl.
+- apply idmap.
+- intros Hls.
+  apply tr.
+  right. apply IHls'. apply Hls.
+Defined.
+
+(** Properties of enumerated sets: closed under sums *)
+Lemma enumerated_sum (A B : Type) :
+  enumerated A -> enumerated B -> enumerated (A + B).
+Proof.
+  intros HeA HeB.
+  strip_truncations; apply tr.
+  destruct HeA as [eA HeA], HeB as [eB HeB].
+  exists (app (map inl eA) (map inr eB)).
+  intros [x | x].
+  - apply listExt_app_r. apply map_listExt. apply HeA.
+  - apply listExt_app_l. apply map_listExt. apply HeB.
+Defined.
+
+Fixpoint listProd_sing {A B} (x : A) (ys : list B) : list (A * B).
+Proof.
+destruct ys as [|y ys].
+- exact nil.
+- refine (cons (x,y) _).
+  apply (listProd_sing _ _ x ys).
+Defined.
+
+Fixpoint listProd {A B} (xs : list A) (ys : list B) : list (A * B).
+Proof.
+destruct xs as [|x xs].
+- exact nil.
+- refine (app _ _).
+  + exact (listProd_sing x ys).
+  + exact (listProd _ _ xs ys).
+Defined.
+
+Lemma listExt_prod_sing {A B} (x : A) (y : B) (ys : list B) :
+  listExt ys y -> listExt (listProd_sing x ys) (x, y).
+Proof.
+induction ys; simpl.
+- exact idmap.
+- simple refine (Trunc_ind _ _). intros [Hxy | HIH]; simpl; apply tr.
+  + left. strip_truncations. apply tr. f_ap.
+  + right. apply IHys. apply HIH.
+Defined.
+
+Lemma listExt_prod `{Funext} {A B} (xs : list A) (ys : list B) : forall (x : A) (y : B),
+  listExt xs x -> listExt ys y -> listExt (listProd xs ys) (x,y).
+Proof.
+induction xs as [| x' xs]; intros x y.
+- simpl. contradiction.
+- simpl. simple refine (Trunc_ind _ _). intros Htx. simpl.
+  induction ys as [| y' ys].
+  + simpl. contradiction.
+  + simpl. simple refine (Trunc_ind _ _). intros Hty. simpl. apply tr.
+    destruct Htx as [Hxx' | Hxs], Hty as [Hyy' | Hys].
+    * left. strip_truncations. apply tr. f_ap.
+    * right. strip_truncations. rewrite <- Hxx'. clear Hxx'.
+      apply listExt_app_r.
+      apply listExt_prod_sing. assumption.
+    * right. strip_truncations. rewrite <- Hyy'.
+      rewrite <- Hyy' in IHxs.
+      apply listExt_app_l. apply IHxs. assumption.
+      simpl. apply tr. left. apply tr. reflexivity.
+    * right.
+      apply listExt_app_l.
+      apply IHxs. assumption.
+      simpl. apply tr. right. assumption.
+Defined.
+
+(** Properties of enumerated sets: closed under products *)
+Lemma enumerated_prod (A B : Type) `{Funext} :
+  enumerated A -> enumerated B -> enumerated (A * B).
+Proof.
+  intros HeA HeB.
+  strip_truncations; apply tr.
+  destruct HeA as [eA HeA], HeB as [eB HeB].
+  exists (listProd eA eB).
+  intros [x y].
+  apply listExt_prod; [ apply HeA | apply HeB ].
+Defined.
+
+(** If a set is enumerated is it Kuratowski-finite *)
+Section enumerated_fset.
+  Variable A : Type.
+  Context `{Univalence}.
+
+  Fixpoint list_to_fset (ls : list A) : FSet A :=
+    match ls with
+    | nil => ∅
+    | cons x xs => {|x|} ∪ (list_to_fset xs)
+    end.
+
+  Lemma list_to_fset_ext (ls : list A) (a : A):
+    listExt ls a -> a ∈ (list_to_fset ls).
+  Proof.
+    induction ls as [|x xs]; simpl.
+    - apply idmap.
+    - intros Hin.
+      strip_truncations. apply tr.
+      destruct Hin as [Hax | Hin].
+      + left. exact Hax.
+      + right. by apply IHxs.
+  Defined.
+
+  Lemma enumerated_Kf : enumerated A -> Kf A.
+  Proof.
+    intros Hls.
+    strip_truncations.
+    destruct Hls as [ls Hls].
+    exists (list_to_fset ls).
+    apply path_forall. intro a.
+    symmetry. apply path_hprop.
+    apply if_hprop_then_equiv_Unit. apply _.
+    by apply list_to_fset_ext.
+  Defined.
+End enumerated_fset.
+
+Section fset_dec_enumerated.
+  Variable A : Type.
+  Context `{Univalence}.
+
+  Definition merely_enumeration_FSet :
+    forall (X : FSet A),
+    hexists (fun (ls : list A) => forall a, a ∈ X = listExt ls a).
+  Proof.
+    simple refine (FSet_cons_ind _ _ _ _ _ _); simpl.
+    - apply tr. exists nil. simpl. done.
+    - intros a X Hls.
+      strip_truncations. apply tr.
+      destruct Hls as [ls Hls].
+      exists (cons a ls). intros b. cbn.
+      apply (ap (fun z => _ ∨ z) (Hls b)).
+    - intros. apply path_ishprop.
+    - intros. apply path_ishprop.
+  Defined.
+
+  Definition Kf_enumerated : Kf A -> enumerated A.
+  Proof.
+    intros HKf. apply Kf_unfold in HKf.
+    destruct HKf as [X HX].
+    pose (ls' := (merely_enumeration_FSet X)).
+    simple refine (@Trunc_rec _ _ _ _ _ ls'). clear ls'.
+    intros [ls Hls].
+    apply tr. exists ls.
+    intros a. rewrite <- Hls. apply (HX a).
+  Defined.
+End fset_dec_enumerated.
+
+Section subobjects.
+  Variable A : Type.
+  Context `{Univalence}.
+
+  Definition enumeratedS (P : Sub A) : hProp :=
+    enumerated (sigT P).
+
+  Lemma enumeratedS_empty : closedEmpty enumeratedS.
+  Proof.
+    unfold enumeratedS.
+    apply tr. exists nil. simpl.
+    intros [a Ha]. assumption.
+  Defined.
+
+  Lemma enumeratedS_singleton : closedSingleton enumeratedS.
+  Proof.
+    intros x. apply tr. simpl.
+    exists (cons (x;tr idpath) nil).
+    intros [y Hxy]. simpl.
+    strip_truncations. apply tr.
+    left. apply tr.
+    apply path_sigma with Hxy.
+    simpl. apply path_ishprop.
+  Defined.
+
+  Fixpoint weaken_list_r (P Q : Sub A) (ls : list (sigT Q)) : list (sigT (max_L P Q)).
+  Proof.
+    destruct ls as [|[x Hx] ls].
+    - exact nil.
+    - apply (cons (x; tr (inr Hx))).
+      apply (weaken_list_r _ _ ls).
+  Defined.
+
+  Lemma listExt_weaken (P Q : Sub A) (ls : list (sigT Q)) (x : A) (Hx : Q x) :
+    listExt ls (x; Hx) -> listExt (weaken_list_r P Q ls) (x; tr (inr Hx)).
+  Proof.
+    induction ls as [|[y Hy] ls]; simpl.
+    - exact idmap.
+    - intros Hls.
+      strip_truncations; apply tr.
+      destruct Hls as [Hxy | Hls].
+      + left. strip_truncations. apply tr.
+        apply path_sigma_uncurried. simpl.
+        exists (Hxy..1). apply path_ishprop.
+      + right. apply IHls. assumption.
+  Defined.
+
+  Fixpoint concatD {P Q : Sub A}
+    (ls : list (sigT P)) (ls' : list (sigT Q)) : list (sigT (max_L P Q)).
+  Proof.
+    destruct ls as [|[y Hy] ls].
+    - apply weaken_list_r. exact ls'.
+    - apply (cons (y; tr (inl Hy))).
+      apply (concatD _ _ ls ls').
+  Defined.
+
+  (* TODO: this proof basically duplicates a similar proof for weaken_list_r *)
+  Lemma listExt_concatD_r (P Q : Sub A) (ls : list (sigT P)) (ls' : list (sigT Q)) (x : A) (Hx : P x) :
+    listExt ls (x; Hx) -> listExt (concatD ls ls') (x;tr (inl Hx)).
+  Proof.
+    induction ls as [|[y Hy] ls]; simpl.
+    - exact Empty_rec.
+    - intros Hls.
+      strip_truncations. apply tr.
+      destruct Hls as [Hxy | Hls].
+      + left. strip_truncations. apply tr.
+        apply path_sigma_uncurried. simpl.
+        exists (Hxy..1). apply path_ishprop.
+      + right. apply IHls. assumption.
+  Defined.
+
+  Lemma listExt_concatD_l (P Q : Sub A) (ls : list (sigT P)) (ls' : list (sigT Q)) (x : A) (Hx : Q x) :
+    listExt ls' (x; Hx) -> listExt (concatD ls ls') (x;tr (inr Hx)).
+  Proof.
+    induction ls as [|[y Hy] ls]; simpl.
+    - apply listExt_weaken.
+    - intros Hls'. apply tr.
+      right. apply IHls. assumption.
+  Defined.
+
+  Lemma enumeratedS_union (P Q : Sub A) :
+    enumeratedS P -> enumeratedS Q -> enumeratedS (max_L P Q).
+  Proof.
+    intros HP HQ.
+    strip_truncations; apply tr.
+    destruct HP as [ep HP], HQ as [eq HQ].
+    exists (concatD ep eq).
+    intros [x Hx].
+    strip_truncations.
+    destruct Hx as [Hxp | Hxq].
+    - apply listExt_concatD_r. apply HP.
+    - apply listExt_concatD_l. apply HQ.
+  Defined.
+
+  Opaque enumeratedS.
+  Definition FSet_to_enumeratedS :
+    forall (X : FSet A), enumeratedS (k_finite.map X).
+  Proof.
+    hinduction.
+    - apply enumeratedS_empty.
+    - intros a. apply enumeratedS_singleton.
+    - unfold k_finite.map; simpl.
+      intros X Y Xs Ys.
+      apply enumeratedS_union; assumption.
+    - intros. apply path_ishprop.
+    - intros. apply path_ishprop.
+    - intros. apply path_ishprop.
+    - intros. apply path_ishprop.
+    - intros. apply path_ishprop.
+  Defined.
+  Transparent enumeratedS.
+
+  Instance hprop_sub_fset (P : Sub A) :
+    IsHProp {X : FSet A & k_finite.map X = P}.
+  Proof.
+    apply hprop_allpath. intros [X HX] [Y HY].
+    assert (X = Y) as HXY.
+    { apply (isinj_embedding k_finite.map). apply _.
+      apply (HX @ HY^). }
+    apply path_sigma with HXY.
+    apply set_path2.
+  Defined.
+
+  Fixpoint list_weaken_to_fset (P : Sub A) (ls : list (sigT P)) : FSet A :=
+    match ls with
+    | nil => ∅
+    | cons x xs => {|x.1|} ∪ (list_weaken_to_fset P xs)
+    end.
+
+  Lemma list_weaken_to_fset_ext (P : Sub A) (ls : list (sigT P)) (a : A) (Ha : P a):
+    listExt ls (a;Ha) -> a ∈ (list_weaken_to_fset P ls).
+  Proof.
+    induction ls as [|[x Hx] xs]; simpl.
+    - apply idmap.
+    - intros Hin.
+      strip_truncations. apply tr.
+      destruct Hin as [Hax | Hin].
+      + left.
+        strip_truncations. apply tr.
+        exact (Hax..1).
+      + right. by apply IHxs.
+  Defined.
+
+  Lemma list_weaken_to_fset_in_sub (P : Sub A) (ls : list (sigT P)) (a : A) :
+    a ∈ (list_weaken_to_fset P ls) -> P a.
+  Proof.
+    induction ls as [|[x Hx] xs]; simpl.
+    - apply Empty_rec.
+    - intros Ha.
+      strip_truncations.
+      destruct Ha as [Hax | Hin].
+      + strip_truncations.
+        by rewrite Hax.
+      + by apply IHxs.
+  Defined.
+
+  Definition enumeratedS_to_FSet :
+    forall (P : Sub A), enumeratedS P ->
+    {X : FSet A & k_finite.map X = P}.
+  Proof.
+    intros P HP.
+    strip_truncations.
+    destruct HP as [ls Hls].
+    exists (list_weaken_to_fset _ ls).
+    apply path_forall. intro a.
+    symmetry. apply path_iff_hprop.
+    - intros Ha.
+      apply list_weaken_to_fset_ext with Ha.
+      apply Hls.
+    - unfold k_finite.map.
+      apply list_weaken_to_fset_in_sub.
+  Defined.
+End subobjects.

FiniteSets/subobjects/k_finite.v

@@ -0,0 +1,246 @@
+Require Import HoTT HitTactics.
+Require Import sub lattice_interface lattice_examples FSets.
+
+Section k_finite.
+
+  Context (A : Type).
+  Context `{Univalence}.
+
+  Definition map (X : FSet A) : Sub A := fun a => a ∈ X.
+
+  Global Instance map_injective : IsEmbedding map.
+  Proof.
+    apply isembedding_isinj_hset. (* We use the fact that both [FSet A] and [Sub A] are hSets *)
+    intros X Y HXY.
+    apply fset_ext.
+    apply apD10. exact HXY.
+  Defined.
+
+  Definition Kf_sub_intern (B : Sub A) := exists (X : FSet A), B = map X.
+
+  Instance Kf_sub_hprop B : IsHProp (Kf_sub_intern B).
+  Proof.
+    apply hprop_allpath.
+    intros [X PX] [Y PY].
+    assert (X = Y) as HXY.
+    { apply fset_ext. apply apD10.
+      transitivity B; [ symmetry | ]; assumption. }
+    apply path_sigma with HXY. simpl.
+    apply set_path2.
+  Defined.
+
+  Definition Kf_sub (B : Sub A) : hProp := BuildhProp (Kf_sub_intern B).
+
+  Definition Kf : hProp := Kf_sub (fun x => True).
+
+  Instance: IsHProp {X : FSet A & forall a : A, map X a}.
+  Proof.
+    apply hprop_allpath.
+    intros [X PX] [Y PY].
+    assert (X = Y) as HXY.
+    { apply fset_ext. intros a.
+      unfold map in *.
+      apply path_hprop.
+      apply equiv_iff_hprop; intros.
+      + apply PY.
+      + apply PX. }
+    apply path_sigma with HXY. simpl.
+    apply path_forall. intro.
+    apply path_ishprop.
+  Defined.
+
+  Lemma Kf_unfold : Kf <~> (exists (X : FSet A), forall (a : A), map X a).
+  Proof.
+    apply equiv_equiv_iff_hprop. apply _. apply _.
+    split.
+    - intros [X PX]. exists X. intro a.
+      rewrite <- PX. done.
+    - intros [X PX]. exists X. apply path_forall; intro a.
+      apply path_hprop.
+      symmetry. apply if_hprop_then_equiv_Unit; [ apply _ | ].
+      apply PX.
+  Defined.
+
+End k_finite.
+
+Arguments map {_} {_} _.
+
+Section structure_k_finite.
+  Context (A : Type).
+  Context `{Univalence}.
+
+  Lemma map_union : forall X Y : FSet A, map (X ∪ Y) = max_fun (map X) (map Y).
+  Proof.
+    intros.
+    unfold map, max_fun.
+    reflexivity.
+  Defined.
+
+  Lemma k_finite_union : closedUnion (Kf_sub A).
+  Proof.
+    unfold closedUnion, Kf_sub, Kf_sub_intern.
+    intros.
+    destruct X0 as [SX XP].
+    destruct X1 as [SY YP].
+    exists (SX ∪ SY).
+    rewrite map_union.
+    rewrite XP, YP.
+    reflexivity.
+  Defined.
+
+  Lemma k_finite_empty : closedEmpty (Kf_sub A).
+  Proof.
+    exists ∅.
+    reflexivity.
+  Defined.
+
+  Lemma k_finite_singleton : closedSingleton (Kf_sub A).
+  Proof.
+    intro.
+    exists {|a|}.
+    cbn.
+    apply path_forall.
+    intro z.
+    reflexivity.
+  Defined.
+
+  Lemma k_finite_hasDecidableEmpty : hasDecidableEmpty (Kf_sub A).
+  Proof.
+    unfold hasDecidableEmpty, closedEmpty, Kf_sub, Kf_sub_intern, map.
+    intros.
+    destruct X0 as [SX EX].
+    rewrite EX.
+    destruct (merely_choice SX) as [SXE | H1].
+    - rewrite SXE.
+      apply (tr (inl idpath)).
+    - apply (tr (inr H1)).
+  Defined.
+End structure_k_finite.
+
+Section k_properties.
+  Context `{Univalence}.
+
+  Lemma Kf_surjection {X Y : Type} (f : X -> Y) `{IsSurjection f} :
+    Kf X -> Kf Y.
+  Proof.
+    intros HX. apply Kf_unfold. apply Kf_unfold in HX.
+    destruct HX as [Xf HXf].
+    exists (fmap FSet f Xf).
+    intro y.
+    pose (x' := center (merely (hfiber f y))).
+    simple refine (@Trunc_rec (-1) (hfiber f y) _ _ _ x'). clear x'; intro x.
+    destruct x as [x Hfx]. rewrite <- Hfx.
+    apply fmap_isIn.
+    apply (HXf x).
+  Defined.
+
+  Lemma S1_Kfinite : Kf S1.
+  Proof.
+    apply Kf_unfold.
+    exists {|base|}.
+    intro a. simpl.
+    simple refine (S1_ind (fun z => Trunc (-1) (z = base)) _ _ a); simpl.
+    - apply (tr loop).
+    - apply path_ishprop.
+  Defined.
+  
+  Lemma I_Kfinite : Kf interval.
+  Proof.
+    apply Kf_unfold.
+    exists {|Interval.one|}.
+    intro a. simpl.
+    simple refine (interval_ind (fun z => Trunc (-1) (z = Interval.one)) _ _ _ a); simpl.
+    - apply (tr seg).
+    - apply (tr idpath).
+    - apply path_ishprop.
+  Defined.
+  
+End k_properties.
+
+Section alternative_definition.
+  Context `{Univalence} {A : Type}.
+
+  Definition kf_sub (P : A -> hProp) :=
+    BuildhProp(forall (K' : (A -> hProp) -> hProp),
+               K' ∅ -> (forall a, K' {|a|}) -> (forall U V, K' U -> K' V -> K'(U ∪ V))
+               -> K' P).
+
+  Local Ltac help_solve :=
+    repeat (let x := fresh in intro x ; destruct x) ; intros
+    ; try (simple refine (path_sigma _ _ _ _ _)) ; try (apply path_ishprop) ; simpl
+    ; unfold union, sub_union, max_fun
+    ; apply path_forall
+    ; intro z
+    ; eauto with lattice_hints typeclass_instances.
+  
+  Definition fset_to_k : FSet A -> {P : A -> hProp & kf_sub P}.
+  Proof.
+    hinduction.
+    - exists ∅.
+      auto.
+    - intros a.
+      exists {|a|}.
+      auto.
+    - intros [P1 HP1] [P2 HP2].
+      exists (P1 ∪ P2).
+      intros ? ? ? HP.
+      apply HP.
+      * apply HP1 ; assumption.
+      * apply HP2 ; assumption.
+    - help_solve.
+    - help_solve.
+    - help_solve.
+    - help_solve.
+    - help_solve.
+  Defined.
+
+  Definition k_to_fset : {P : A -> hProp & kf_sub P} -> FSet A.
+  Proof.
+    intros [P HP].
+    destruct (HP (Kf_sub _) (k_finite_empty _) (k_finite_singleton _) (k_finite_union _)).
+    assumption.
+  Defined.
+
+  Lemma fset_to_k_to_fset X : k_to_fset(fset_to_k X) = X.
+  Proof.
+    hinduction X ; try (intros ; apply path_ishprop) ; try (intros ; reflexivity).
+    intros X1 X2 HX1 HX2.
+    refine ((ap (fun z => _ ∪ z) HX2^)^ @ (ap (fun z => z ∪ X2) HX1^)^).
+  Defined.
+    
+  Lemma k_to_fset_to_k (X : {P : A -> hProp & kf_sub P}) : fset_to_k(k_to_fset X) = X.
+  Proof.
+    simple refine (path_sigma _ _ _ _ _) ; try (apply path_ishprop).
+    apply path_forall.
+    intro z.
+    destruct X as [P HP].
+    unfold kf_sub in HP.
+    unfold k_to_fset.
+    pose (HP (Kf_sub A) (k_finite_empty A) (k_finite_singleton A) (k_finite_union A)) as t.
+    assert (HP (Kf_sub A) (k_finite_empty A) (k_finite_singleton A) (k_finite_union A) = t) as X0.
+    { reflexivity. }
+    rewrite X0 ; clear X0.
+    destruct t as [X HX].
+    assert (P z = map X z) as X1.
+    { rewrite HX. reflexivity. }
+    simpl.
+    rewrite X1 ; clear HX X1.
+    hinduction X ; try (intros ; apply path_ishprop).
+    - apply idpath.
+    - apply (fun a => idpath). 
+    - intros X1 X2 H1 H2.
+      rewrite <- H1, <- H2.
+      reflexivity.
+  Defined.
+
+  Theorem equiv_definition : IsEquiv fset_to_k.
+  Proof.
+    apply isequiv_biinv.
+    split.
+    - exists k_to_fset.
+      intro x ; apply fset_to_k_to_fset.
+    - exists k_to_fset.
+      intro x ; apply k_to_fset_to_k.
+  Defined.
+  
+End alternative_definition.