(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)
(* Contribution to the Coq Library   V6.3 (July 1999)                    *)
(************************************************************************)
(*                      Zermolo Set Theory                              *)
(*                                                                      *)
(*                        Benjamin Werner                               *)
(************************************************************************)
(* This is an encoding of usual Set Theory, simillar to Peter Aczel's work *)
(* in the early 80's. The main difference is that the propositions here    *)
(* live in the impredicative world of "Prop". Thus, priority is given to   *)
(* expressivity against constructivity.                                    *)
(* Since the definition of Sets is the same for both approaches, I added   *)
(* most  of Aczel's encoding of CZF at the end of the file. Many           *)
(* definitions are common to both aproaches.                               *)
Set Asymmetric Patterns.
(* The type representing sets  (Ensemble = french for set) *)
Inductive Ens : Type :=
sup : forall A : Type, (A -> Ens) -> Ens.
(* Existential quantification *)
Inductive EXType (P : Type) (Q : P -> Prop) : Prop :=
EXTypei : forall x : P, Q x -> EXType P Q.
(* Cartesian product in Type *)
Inductive prod_t (A B : Type) : Type :=
pair_t : A -> B -> prod_t A B.
(* Existential on the Type level *)
Inductive depprod (A : Type) (P : A -> Type) : Type :=
dep_i : forall x : A, P x -> depprod A P.
(* Recursive Definition of the extentional equality on sets *)
Definition EQ : Ens -> Ens -> Prop.
simple induction 1; intros A f eq1.
simple induction 1; intros B g eq2.
apply and.
exact (forall x : A, EXType _ (fun y : B => eq1 x (g y))).
exact (forall y : B, EXType _ (fun x : A => eq1 x (g y))).
Defined.
(* Membership on sets *)
Definition IN (E1 E2 : Ens) : Prop :=
match E2 with
| sup A f => EXType _ (fun y : A => EQ E1 (f y))
end.
(* INCLUSION *)
Definition INC : Ens -> Ens -> Prop.
intros E1 E2.
exact (forall E : Ens, IN E E1 -> IN E E2).
Defined.
(* EQ is an equivalence relation  *)
simple induction E.
intros A f HR.
simpl in |- *.
split; intros.
exists x; auto.
exists y; auto.
Qed.
simple induction E1; intros A1 f1 r1; simple induction E2; intros A2 f2 r2;
simple induction E3; intros A3 f3 r3; simpl in |- *;
intros e1 e2.
split; (elim e1; intros I1 I2; elim e2; intros I3 I4).
intros a1; elim (I1 a1); intros a2.
elim (I3 a2); intros a3.
exists a3.
apply r1 with (f2 a2); auto.
intros a3; elim (I4 a3); intros a2; elim (I2 a2); intros a1; exists a1.
apply r1 with (f2 a2); auto.
Qed.
simple induction E1; intros A1 f1 r1; simple induction E2; intros A2 f2 r2;
simpl in |- *; simple induction 1; intros e1 e2; split.
intros a2; elim (e2 a2); intros a1 H1; exists a1; auto.
intros a1; elim (e1 a1); intros a2 H2; exists a2; auto.
Qed.
simple induction E; intros A f r; simple induction E'; intros A' f' r';
simpl in |- *; simple induction 1; intros e1 e2; unfold INC in |- *;
simpl in |- *.
intros C; simple induction 1; intros a ea; elim (e1 a); intros a' ea';
exists a'.
apply EQ_tran with (f a); assumption.
Qed.
Hint Resolve EQ_sym EQ_refl EQ_INC: zfc.
(* easy lemma *)
simple induction E; intros A f r; simple induction E'; intros A' f' r';
unfold INC in |- *; simpl in |- *; intros I1 I2; split.
intros a; apply I1.
exists a; auto with zfc.
intros a'; cut (EXType A (fun x : A => EQ (f' a') (f x))).
simple induction 1; intros a ea; exists a; auto with zfc.
apply I2; exists a'; auto with zfc.
Qed.
Hint Resolve INC_EQ: zfc.
(* Membership is extentional (i.e. is stable w.r.t. EQ)   *)
simple induction E''; intros A'' f'' r'' e; simpl in |- *; simple induction 1;
intros a'' p; exists a''; apply EQ_tran with E; auto with zfc.
Qed.
simple induction E'; intros A' f' r'; simple induction E'';
intros A'' f'' r''; simpl in |- *; simple induction 1;
intros e1 e2; simple induction 1; intros a' e'; elim (e1 a');
intros a'' e''; exists a''; apply EQ_tran with (f' a');
assumption.
Qed.
(* Inclusion is reflexive, transitive, extentional *)
unfold INC in |- *; auto with zfc.
Qed.
unfold INC in |- *; auto with zfc.
Qed.
simple induction E''; unfold INC in |- *; simpl in |- *;
intros A f HR e H1 E0 i; apply H1.
apply IN_sound_right with E'; auto with zfc.
Qed.
simple induction E'; simple induction E''; unfold INC in |- *; simpl in |- *;
intros.
elim (H2 E0); try assumption; intros.
elim H1; intros HA HB; elim (HA x); intros.
exists x0; apply EQ_tran with (e x); auto with zfc.
Qed.
(* Useful types (actually top and bottom)   *)
Inductive Un : Set :=
void : Un.
Inductive F : Set :=.
(* The empty set  (vide = french for empty)   *)
Definition Vide : Ens := sup F (fun f : F => match f return Ens with
end).
(* The axioms of the empty set *)
unfold Vide in |- *; simpl in |- *; intros E H; cut False.
simple induction 1.
elim H; intros x; elim x.
Qed.
unfold Vide in |- *; simple induction E; simpl in |- *; intros A e H H0;
split.
intros; elim (H0 (e x)); auto with zfc.
exists x; auto with zfc.
simple induction y.
Qed.
(* Pair *)
Definition Paire : forall E E' : Ens, Ens.
intros.
apply (sup bool).
simple induction 1.
exact E.
exact E'.
Defined.
(* The pair construction is extentional *)
unfold Paire in |- *.
simpl in |- *.
intros; split.
simple induction x.
exists true; auto with zfc.
exists false; auto with zfc.
simple induction y; simpl in |- *.
exists true; auto with zfc.
exists false; auto with zfc.
Qed.
unfold Paire in |- *; simpl in |- *; intros; split.
simple induction x.
exists true; auto with zfc.
exists false; auto with zfc.
simple induction y.
exists true; auto with zfc.
exists false; auto with zfc.
Qed.
Hint Resolve Paire_sound_right Paire_sound_left: zfc.
(* The axioms of the pair *)
unfold Paire in |- *; simpl in |- *; exists true; simpl in |- *;
auto with zfc.
Qed.
unfold Paire in |- *; simpl in |- *; exists false; simpl in |- *;
auto with zfc.
Qed.
unfold Paire in |- *; simpl in |- *.
simple induction 1; intros b; elim b; simpl in |- *; auto with zfc.
Qed.
Hint Resolve IN_Paire_left IN_Paire_right Vide_est_vide: zfc.
(* The singleton set  *)
(* Note that we could define it directly using the base type Un *)
Definition Sing (E : Ens) := Paire E E.
(* The axioms  *)
unfold Sing in |- *; auto with zfc.
Qed.
unfold Sing in |- *; intros E E' H; elim (Paire_IN E' E' E);
auto with zfc.
Qed.
Hint Resolve IN_Sing IN_Sing_EQ: zfc.
unfold Sing in |- *; intros; apply EQ_tran with (Paire A A');
auto with zfc.
Qed.
Hint Resolve Sing_sound: zfc.
intros; cut (IN E1 (Sing E2)).
intros; auto with zfc.
apply IN_sound_right with (Sing E1); auto with zfc.
Qed.
Hint Resolve EQ_Sing_EQ: zfc.
(* We here need sigma types -- i.e. computational existentials *)
Inductive sig (A : Type) (P : A -> Prop) : Type :=
exist : forall x : A, P x -> sig A P.
(* The set obtained by the comprehension (or separation) axiom *)
Definition Comp : Ens -> (Ens -> Prop) -> Ens.
simple induction 1; intros A f fr P.
apply (sup (sig A (fun x => P (f x)))).
simple induction 1; intros x p; exact (f x).
Defined.
(* The comprehension/separation axioms *)
unfold Comp, INC in |- *; simple induction E; simpl in |- *; intros.
elim H0; simple induction x; intros; exists x0; auto with zfc.
Qed.
simple induction E; simpl in |- *; intros B f Hr A P H i; elim i; intros c;
elim c; simpl in |- *; intros x q e; apply H with (f x);
auto with zfc.
Qed.
simple induction E; simpl in |- *; intros B f HR A P H i; elim i;
simpl in |- *; intros.
cut (P (f x)).
intros Pf.
exists (exist B (fun x : B => P (f x)) x Pf); simpl in |- *;
auto with zfc.
apply H with A; auto with zfc.
Qed.
(* Again, extentionality is not stated, but easy *)
(* Projections of a set: *)
(*  1: its base type     *)
Definition pi1 : Ens -> Type.
simple induction 1.
intros A f r.
exact A.
Defined.
(*  2: the function      *)
Definition pi2 : forall E : Ens, pi1 E -> Ens.
simple induction E.
intros A f r.
exact f.
Defined.
(* The Union set   *)
Definition Union : forall E : Ens, Ens.
simple induction 1; intros A f r.
apply (sup (depprod A (fun x : A => pi1 (f x)))).
simple induction 1; intros a b.
exact (pi2 (f a) b).
Defined.
simple induction E; intros A f r; simple induction E'; intros A' f' r';
simpl in |- *; simple induction 1; intros e1 e2 a.
apply e1.
Defined.
simple induction E; simpl in |- *.
intros A f r.
simple induction 1; simpl in |- *.
intros.
exists x; auto with zfc.
Qed.
(* The union axioms *)
simple induction E; intros A f r.
intros.
simpl in |- *.
elim (IN_EXType (sup A f) E' H).
intros x e.
cut (EQ (pi2 (sup A f) x) E'); auto with zfc.
intros e1.
cut (IN E'' (pi2 (sup A f) x)).
intros i1.
elim (IN_EXType _ _ i1).
intros x0 e2.
simpl in x0.
exists (dep_i A (fun x : A => pi1 (f x)) x x0).
simpl in |- *.
exact e2.
apply IN_sound_right with E'; auto with zfc.
Qed.
unfold INC in |- *; simple induction E; intros A f r; unfold Union in |- *.
intros E' i E'' i'; simpl in |- *; elim (IN_EXType (sup A f) E' i).
intros a e; simpl in a; simpl in e.
elim (IN_EXType E' E'' i').
cut (IN E'' (f a)).
intros i'' a' e''; elim (IN_EXType _ _ i''); simpl in |- *; intros aa ee.
exists (dep_i A (fun x : A => pi1 (f x)) a aa); auto with zfc.
apply IN_sound_right with E'; auto with zfc.
Qed.
simple induction E; unfold Union in |- *; simpl in |- *; intros A f r.
simple induction 1.
simple induction x.
intros a b; simpl in |- *.
intros.
exists (f a).
split.
exists a; auto with zfc.
apply IN_sound_left with (pi2 (f a) b); auto with zfc.
simpl in |- *.
generalize b; elim (f a); simpl in |- *.
intros.
exists b0; auto with zfc.
Qed.
(* extentionality of union  *)
unfold Union in |- *; simple induction E; intros A f r; simple induction E';
intros A' f' r'; simpl in |- *; simple induction 1;
intros e1 e2; split.
intros x; elim x; intros a aa; elim (e1 a); intros a' ea.
elim (EQ_EXType (f a) (f' a') ea aa); intros aa' eaa.
exists (dep_i A' (fun x : A' => pi1 (f' x)) a' aa'); simpl in |- *;
auto with zfc.
intros c'; elim c'; intros a' aa'; elim (e2 a'); intros a ea.
cut (EQ (f' a') (f a)).
2: auto with zfc.
intros ea'; elim (EQ_EXType (f' a') (f a) ea' aa'); intros aa eaa.
exists (dep_i A (fun x : A => pi1 (f x)) a aa); auto with zfc.
Qed.
(* The union construction is monotone w.r.t. inclusion   *)
unfold INC in |- *; intros E E' IEE E'' IEE''.
elim (Union_IN E E'').
intros E'''; simple induction 1; intros I1 I2.
apply IN_Union with E'''; auto with zfc.
auto with zfc.
Qed.
(* The  Intersection set   *)
Definition Inter (E : Ens) : Ens :=
match E with
| sup A f =>
sup _
(fun
c : depprod _
(fun a : A =>
depprod _
(fun b : pi1 (f a) =>
forall x : A, IN (pi2 (f a) b) (f x))) =>
match c with
| dep_i a (dep_i b p) => pi2 (f a) b
end)
end.
(* the axioms *)
simple induction E; intros A f r; simpl in |- *; intros E'.
simple induction 1; intros c; elim c; intros a ca; elim ca; intros aa paa;
simpl in |- *.
intros e E'' e''.
elim e''; intros a1 ea1.
apply IN_sound_right with (f a1); auto with zfc.
apply IN_sound_left with (pi2 (f a) aa); auto with zfc.
Qed.
simple induction E; intros A f r.
intros E' E'' i H.
elim (IN_EXType (sup A f) E'' i).
intros a e; simpl in a.
simpl in e.
cut (IN E' E''); auto with zfc.
intros i'.
cut (IN E' (f a)); auto with zfc.
intros i0.
elim (IN_EXType (f a) E' i0).
intros b e'.
simpl in |- *.
cut (forall x : A, IN (pi2 (f a) b) (f x)).
intros.
exists
(dep_i A
(fun a : A =>
depprod (pi1 (f a))
(fun b : pi1 (f a) => forall x : A, IN (pi2 (f a) b) (f x))) a
(dep_i (pi1 (f a))
(fun b : pi1 (f a) => forall x : A, IN (pi2 (f a) b) (f x)) b H0)).
simpl in |- *.
auto with zfc.
auto with zfc.
intros.
apply IN_sound_left with E'.
auto with zfc.
apply H.
auto with zfc.
simpl in |- *.
exists x; auto with zfc.
apply IN_sound_right with E''; auto with zfc.
Qed.
(*  The powerset and its axioms   *)
Definition Power (E : Ens) : Ens :=
match E with
| sup A f =>
sup _
(fun P : A -> Prop =>
sup _
(fun c : depprod A (fun a : A => P a) =>
match c with
| dep_i a p => f a
end))
end.
simple induction E.
intros A f r; unfold INC in |- *; simpl in |- *.
intros E'; simple induction 1; intros P.
elim E'; simpl in |- *.
intros A' f' r'.
simple induction 1; intros HA HB.
intros E''; simple induction 1; intros a' e.
elim (HA a').
simple induction x; intros a p.
intros; exists a.
auto with zfc.
apply EQ_tran with (f' a'); auto with zfc.
Qed.
simple induction E; intros A f r; unfold INC in |- *; simpl in |- *.
simple induction E'; intros A' f' r' i.
exists (fun a : A => IN (f a) (sup A' f')).
simpl in |- *.
split.
intros.
elim (i (f' x)); auto with zfc.
intros a e.
cut (EQ (f a) (f' x)); auto with zfc.
intros e1.
exists
(dep_i A (fun a : A => EXType A' (fun y : A' => EQ (f a) (f' y))) a
(EXTypei A' (fun y : A' => EQ (f a) (f' y)) x e1)).
simpl in |- *.
auto with zfc.
auto with zfc.
simpl in |- *.
exists x; auto with zfc.
simple induction y; simpl in |- *.
simple induction 1; intros.
exists x0; auto with zfc.
Qed.
intros.
unfold INC in |- *; intros.
apply INC_IN_Power.
cut (INC E0 E).
unfold INC in |- *; unfold INC in H; intros; auto with zfc.
apply IN_Power_INC; auto with zfc.
Qed.
intros E E' e.
apply INC_EQ; unfold INC in |- *.
intros A i.
cut (INC A E').
intros; apply INC_IN_Power; assumption.
cut (INC A E); intros.
apply INC_sound_right with E; auto with zfc.
apply IN_Power_INC; assumption.
intros A i.
cut (INC A E).
intros; apply INC_IN_Power; assumption.
cut (INC A E'); intros.
apply INC_sound_right with E'; auto with zfc.
apply IN_Power_INC; assumption.
Qed.
(* small lemma *)
intros E e; cut False.
simple induction 1.
cut (IN E Vide).
simpl in |- *; simple induction 1; intros xx; elim xx; simple induction 1.
apply IN_sound_right with (Sing E); auto with zfc.
Qed.
intros E e; cut False.
simple induction 1.
cut (IN E Vide).
simpl in |- *; simple induction 1; intros xx; elim xx; simple induction 1.
apply IN_sound_right with (Sing E); auto with zfc.
Qed.
(* The cartesian product and its properties *)
(* This definition of the ordered pair is slightly different from *)
(* the usual one, since we want it to work in an intuisionistic   *)
(* setting. Works the same, neitherless. The soundness proofs are *)
(* unpleasant.                                                    *)
Definition Couple (E E' : Ens) := Paire (Sing E) (Paire Vide (Sing E')).
unfold Couple in |- *; simpl in |- *.
simple induction 1.
intros HA HB; elim (HA true).
intros x; elim x; simpl in |- *; simple induction 1; intros H3 H4;
elim (H3 true); simpl in |- *; intros xx; elim xx;
simpl in |- *; auto with zfc.
elim (H4 false); simpl in |- *.
simple induction x0; simpl in |- *.
intros.
cut (EQ (Sing B') Vide).
simpl in |- *.
simple induction 1.
intros yy; elim (yy true).
simple induction x1.
apply EQ_tran with A; auto with zfc.
intros; cut (EQ (Sing B') Vide).
simpl in |- *.
simple induction 1.
intros yy; elim (yy true).
simple induction x1.
apply EQ_tran with A; auto with zfc.
intros yy.
elim (HB true); simpl in |- *.
simple induction x0.
change (EQ (Sing A) (Sing B) -> EQ A B) in |- *; intros EE.
apply IN_Sing_EQ.
apply IN_sound_right with (Sing A); auto with zfc.
change (EQ (Paire Vide (Sing A')) (Sing B) -> EQ A B) in |- *.
intros zz.
elimtype F.
apply (not_EQ_Sing_Vide A').
apply EQ_tran with B.
apply IN_Sing_EQ.
apply IN_sound_right with (Paire Vide (Sing A')); auto with zfc.
apply EQ_sym; apply IN_Sing_EQ;
apply IN_sound_right with (Paire Vide (Sing A'));
auto with zfc.
Qed.

Theorem Couple_inj_right :
forall A A' B B' : Ens, EQ (Couple A A') (Couple B B') -> EQ A' B'.