Require Export Reals Omega.
Require Export Classical_Prop.

Definition Complex : Set := R*R.

Delimit Scope C_scope with C.

Definition Cplus ( x y : Complex ) : Complex := match x, y with
                                | (a,b) , (c,d) => (a+c,b+d)%R
                              end.

Definition Cmult ( x y : Complex ) : Complex := match x, y with
                                | (a,b) , (c,d) => (a*c-b*d,a*d+b*c)%R
                              end.

Definition C0 : Complex := (0,0)%R.
Definition C1 : Complex := (1,0)%R.
Definition Ci : Complex := (0,1)%R.

Definition Copp ( x: Complex ) : Complex := match x with
                                | (a,b) => (-a,-b)%R
                              end.
Definition Cinv ( x: Complex ) : Complex := match x with
                                | (a,b) => (a/(a*a+b*b),-b/(a*a+b*b))%R
                              end.

Theorem Real_eq_dec : forall r1 r2 : R , ({ r1 = r2 } + { r1 <> r2 })%R.
Proof.

  intros.
  assert ({r1 < r2} + {r1 = r2} + {r1 > r2})%R.
  apply total_order_T.
  destruct H in H.
  destruct s.
  right.
Admitted.

Definition Clt ( x y : Complex ) : Prop := match x, y with
                                | (a,b) , (c,d) => if (Real_eq_dec a c)%R then (b<d)%R else (a<c)%R
                              end.

Infix "+" := Cplus : C_scope.
Infix "*" := Cmult : C_scope.
Notation "- x" := (Copp x) : C_scope.
Notation "/ x" := (Cinv x) : C_scope.

Infix "<" := Clt : C_scope.

Definition Cgt (r1 r2:Complex) : Prop := (r2 < r1)%C.

Definition Cle (r1 r2:Complex) : Prop := (r1 < r2 \/ r1 = r2)%C.

Definition Cge (r1 r2:Complex) : Prop := (Cgt r1 r2 \/ r1 = r2)%C.

Definition Cminus (r1 r2:Complex) : Complex := (r1 + - r2)%C.

Definition Cdiv (r1 r2:Complex) : Complex := (r1 * / r2)%C.

Infix "-" := Cminus : C_scope.
Infix "/" := Cdiv : C_scope.

Infix "<=" := Cle : C_scope.
Infix ">=" := Cge : C_scope.
Infix ">" := Cgt : C_scope.

Notation "x <= y <= z" := (x <= y /\ y <= z) : C_scope.
Notation "x <= y < z" := (x <= y /\ y < z) : C_scope.
Notation "x < y < z" := (x < y /\ y < z) : C_scope.
Notation "x < y <= z" := (x < y /\ y <= z) : C_scope.

(* end Cdefinition *)

Definition real_p ( z: Complex ) := fst z.
Definition imag_p ( z: Complex ) := snd z.

Lemma Cdecompose : forall z : Complex , z = ( real_p z , imag_p z ).
Proof.
  intros.
  apply surjective_pairing.
Qed.

Lemma Cplus_decompose : forall z1 z2 : Complex , ( z1 + z2 )%C = ( real_p z1 + real_p z2 , imag_p z1 + imag_p z2 )%R.
Proof.
  intros.
  replace (z1 + z2)%C with (( real_p z1 , imag_p z1 )+( real_p z2 , imag_p z2 ))%C.
  unfold Cplus.
  auto.
  rewrite <- ! Cdecompose.
  auto.
Qed.

Lemma Cplus_comm : forall z1 z2:Complex, (z1 + z2 = z2 + z1)%C.
Proof.
  intros.
  rewrite ! Cplus_decompose.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
Qed.

Hint Resolve Cplus_comm : complex.

Lemma Cplus_assoc : forall r1 r2 r3:Complex , (r1 + (r2 + r3) = r1 + r2 + r3)%C.
Proof.
  intros.
  rewrite ! Cplus_decompose.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
Qed.

Hint Resolve Cplus_assoc: complex.

Lemma Cplus_opp_r : forall r:Complex, (r + -r = C0 )%C.
Proof.
  intros.
  replace (r) with ( real_p r , imag_p r ).
  unfold Copp.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
  apply eq_sym.
  apply Cdecompose.
Qed.
Hint Resolve Cplus_opp_r: complex.

Lemma Cplus_0_l : forall r:Complex , (C0 + r = r)%C.
Proof.
  intros.
  rewrite ! Cplus_decompose.
  unfold real_p.
  unfold imag_p.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
Qed.

Hint Resolve Cplus_0_l: complex.

Lemma Cmult_decompose : forall z1 z2 : Complex , ( z1 * z2 )%C = ( real_p z1 * real_p z2 - imag_p z1 * imag_p z2 , real_p z1 * imag_p z2 + imag_p z1 * real_p z2 )%R.
Proof.
  intros.
  replace (z1 * z2)%C with (( real_p z1 , imag_p z1 )*( real_p z2 , imag_p z2 ))%C.
  unfold Cplus.
  auto.
  rewrite <- ! Cdecompose.
  auto.
Qed.

Lemma Cmult_comm : forall r1 r2:Complex, (r1 * r2 = r2 * r1)%C.
Proof.
  intros.
  rewrite ! Cmult_decompose.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
Qed.
Hint Resolve Cmult_comm: complex.

Lemma Cmult_assoc : forall r1 r2 r3:Complex, (r1 * (r2 * r3) = r1 * r2 * r3)%C.
Proof.
  intros.
  rewrite ! Cmult_decompose.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
Qed.
Hint Resolve Cmult_assoc: complex.

Local Open Scope R_scope.

Lemma Ra2b2n0 : forall a b : R , a<>0 \/ b<>0 -> 0<a*a+b*b.
Proof.
  intros.
  assert ( 0 <= a * a ).
  replace ( a * a ) with (a^2) ; [idtac | ring ].
  apply pow2_ge_0 with ( x := a ).
  assert ( 0 <= b * b ).
  replace ( b * b ) with (b^2) ; [idtac | ring ].
  apply pow2_ge_0 with ( x := b ).
  unfold Rle in H0.
  case H0.
  intros.
  replace 0 with (0+0); [ idtac | ring ].
  apply Rplus_gt_ge_compat.
  auto.
  apply Rle_ge.
  auto.
  intros.
  assert (b<>0).
  assert ( a=0).
  apply eq_sym in H2.
  apply Rmult_integral in H2.
  case H2.
  auto.
  auto.
  case H.
  contradiction.
  auto.
  assert ( b * b <> 0).
  auto.
  assert ( 0 < b * b ).
  case H1.
  auto.
  intros.
  apply eq_sym in H5.
  contradiction.
  replace 0 with (0+0); [ idtac | ring ].
  apply Rplus_ge_gt_compat.
  rewrite <- H2.
  auto with real.
  auto with real.
Qed.

Local Close Scope R_scope.

Lemma Cinv_l : forall r:Complex, (r <> C0 -> / r * r = C1)%C.
Proof.
  intros.
  replace (r) with ( real_p r , imag_p r ).
  assert ( real_p r <> 0 \/ imag_p r <> 0)%R as orenq.
  apply Peirce.
  intros.
  apply not_or_and in H0.
  destruct H0 as [rp0 ip0].
  apply NNPP in rp0.
  apply NNPP in ip0.
  elim H.
  replace (r) with ( real_p r , imag_p r ).
  unfold C0.
  apply injective_projections.
  auto.
  auto.
  apply eq_sym.
  apply Cdecompose.

  assert((real_p r * real_p r + imag_p r * imag_p r)%R <> 0%R).
  unfold not.
  intros.
  assert ( 0<(real_p r * real_p r + imag_p r * imag_p r)%R )%R.
  apply Ra2b2n0.
  auto.
  rewrite H0 in H1.
  apply Rlt_irrefl in H1.
  auto.

  unfold Cinv.
  unfold C1.
  apply injective_projections.
  simpl.
  field.
  auto.
  simpl.
  field.
  auto.
  rewrite Cdecompose.
  auto.
Qed.
Hint Resolve Cinv_l: complex.

Lemma Cmult_1_l : forall r:Complex, (C1 * r = r)%C.
Proof.
  intros.
  replace (r) with ( real_p r , imag_p r ).
  rewrite ! Cmult_decompose.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
  rewrite Cdecompose.
  auto.
Qed.
Hint Resolve Cmult_1_l: complex.

Lemma Cmult_0_l : forall r:Complex, (C0 * r = C0)%C.
Proof.
  intros.
  unfold C0.
  replace (r) with ( real_p r , imag_p r ).
  rewrite ! Cmult_decompose.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
  rewrite Cdecompose.
  auto.
Qed.
Hint Resolve Cmult_0_l: complex.

Lemma C1_neq_C0 : C1 <> C0.
Proof.
  unfold not.
  intros.
  assert ( real_p C1 = 1 )%R.
  auto.
  assert ( real_p C1 = 0 )%R.
  rewrite H.
  auto.
  auto with real.
Qed.
Hint Resolve C1_neq_C0: complex.

Lemma Cmult_plus_distr_r : forall r2 r3 r1:Complex, ((r2 + r3)*r1 = r2*r1 + r3 * r1)%C.
Proof.
  intros.
  rewrite ! Cplus_decompose.
  rewrite ! Cmult_decompose.
  apply injective_projections.
  simpl.
  ring.
  simpl.
  ring.
Qed.
Hint Resolve Cmult_plus_distr_r: complex.

Lemma complexSRth : ring_theory C0 C1 Cplus Cmult Cminus Copp (@eq Complex).
 Proof.
  constructor. exact Cplus_0_l. exact Cplus_comm. exact Cplus_assoc.
  exact Cmult_1_l. exact Cmult_comm. exact Cmult_assoc.
  exact Cmult_plus_distr_r. auto. exact Cplus_opp_r.
 Qed.

Add Ring complexr : complexSRth.


Require Export Elementary_Logic.

Module ElementSet.

(* ELEMENTARY ALGEBRA OF CLASSES *)

(* 2 Definition  x∪y = { z : z∈x or z∈y }. *)

Definition Union x y : Class := \{ λ z, z∈x \/ z∈y \}.

Notation "x ∪ y" := (Union x y) (at level 65, right associativity).

Hint Unfold Union : set.

(* 3 Definition  x∩y = { z : z∈x and z∈y }. *)

Definition Intersection x y : Class := \{ λ z, z∈x /\ z∈y \}.

Notation "x ∩ y" := (Intersection x y) (at level 60, right associativity).

Hint Unfold Intersection : set.

(* 4 Theorem  z∈x∪y if and only if z∈x or z∈y, and z∈x∩y if and only if
   z∈x and z∈y. *)

Theorem Theorem4 : forall (x y: Class) (z: Class),
  z∈x \/ z∈y <-> z ∈ (x ∪ y).
Proof.
  intros.
  split; intros.
  - apply Axiom_Scheme; split.
    + destruct H; Ens.
    + apply H.
  - apply Axiom_Scheme in H.
    apply H.
Qed.

Theorem Theorem4' : forall x y z, z∈x /\ z∈y <-> z∈(x∩y).
Proof.
  intros; unfold Intersection; split; intros.
  - apply Axiom_Scheme; split; Ens; exists y; apply H.
  - apply Axiom_Scheme in H; apply H.
Qed.

Hint Resolve Theorem4 Theorem4' : set.

(* 5 Theorem  x∪x=x and x∩x=x. *)

Theorem Theorem5 : forall x, x ∪ x = x.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Theorem4 in H; tauto.
  - apply Theorem4; tauto.
Qed.

Theorem Theorem5' : forall x, x ∩ x = x.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Theorem4' in H; tauto.
  - apply Theorem4'; tauto.
Qed.

Hint Rewrite Theorem5 Theorem5' : set.

(* 6 Theorem  x∪y=y∪x and x∩y=y∩x. *)

Theorem Theorem6 : forall x y, x ∪ y = y ∪ x.
Proof.
  intros; apply Axiom_Extent; split; intro.
  - apply Theorem4 in H; apply Theorem4; tauto.
  - apply Theorem4 in H; apply Theorem4; tauto.
Qed.

Theorem Theorem6' : forall x y, x ∩ y = y ∩ x.
Proof.
  intros; apply Axiom_Extent; split; intro.
  - apply Theorem4' in H; apply Theorem4'; tauto.
  - apply Theorem4' in H; apply Theorem4'; tauto.
Qed.

Hint Rewrite Theorem6 Theorem6' : set.

(* 7 Theorem  (x∪y)∪z=x∪(y∪z) and (x∩y)∩z=x∩(y∩z). *)

Theorem Theorem7 : forall x y z, (x ∪ y) ∪ z = x ∪ (y ∪ z).
Proof.
  intros; apply Axiom_Extent; split; intro.
  - apply Theorem4 in H; apply Theorem4; destruct H.
    + apply Theorem4 in H; destruct H; try tauto.
      right; apply Theorem4; auto.
    + right; apply Theorem4; auto.
  - apply Theorem4 in H; apply Theorem4; destruct H.
    + left; apply Theorem4; auto.
    + apply Theorem4 in H; destruct H; try tauto.
      left; apply Theorem4; tauto.
Qed.

Theorem Theorem7' : forall x y z, (x ∩ y) ∩ z = x ∩ (y ∩ z).
Proof.
  intros; apply Axiom_Extent; split; intro.
  - repeat (apply Theorem4' in H; destruct H).
    apply Theorem4'; split; auto; apply Theorem4'; auto.
  - apply Theorem4' in H; destruct H; apply Theorem4'.
    apply Theorem4' in H0; destruct H0; split; auto.
    apply Theorem4'; split; auto.
Qed.

Hint Rewrite Theorem7 Theorem7' : set.

(* 8 Theorem  x∩(y∪z)=(x∩y)∪(x∩z) and x∪(y∩z)=(x∪y)∩(x∪z). *)

Theorem Theorem8 : forall x y z, x ∩ (y ∪ z) = (x ∩ y) ∪ (x ∩ z).
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Theorem4; apply Theorem4' in H; destruct H.
    apply Theorem4 in H0; destruct H0.
    + left; apply Theorem4'; split; auto.
    + right; apply Theorem4'; split; auto.
  - apply Theorem4 in H; apply Theorem4'; destruct H.
    + apply Theorem4' in H; destruct H; split; auto.
      apply Theorem4; left; auto.
    + apply Theorem4' in H; destruct H; split; auto.
      apply Theorem4; right; auto.
Qed.

Theorem Theorem8' : forall x y z, x ∪ (y ∩ z) = (x ∪ y) ∩ (x ∪ z).
Proof.
  intros; apply Axiom_Extent; split; intro.
  - apply Theorem4'; apply Theorem4 in H.
    destruct H; split; try apply Theorem4; auto.
    + apply Theorem4' in H; tauto.
    + apply Theorem4' in H; tauto.
  - apply Theorem4; apply Theorem4' in H; destruct H.
    apply Theorem4 in H; apply Theorem4 in H0.
    destruct H, H0; auto; right; apply Theorem4'; auto.
Qed.

Hint Rewrite Theorem8 Theorem8' : set.

(* 9 Definition  x∉y if and only if it is false that x∈y. *)

Definition NotIn x y : Prop := ~ x∈y.

Notation "x ∉ y" := (NotIn x y) (at level 10).

Hint Unfold NotIn : set.

(* 10 Definition  ¬x = { y : y ∉ x }. *)

Definition Complement x : Class := \{λ y, y ∉ x \}.

Notation "¬ x" := (Complement x) (at level 5, right associativity).

Hint Unfold Complement : set.

(* 11 Theorem  ¬ (¬ x) = x *)

Theorem Theorem11: forall x, ¬ (¬ x) = x.
Proof.
  intros; apply Axiom_Extent; split; intro.
  - apply Axiom_Scheme in H; unfold NotIn in H; destruct H.
    assert (z ∈ ¬ x <-> Ensemble z /\ z∉x ).
    { split; intros.
      - apply Axiom_Scheme in H1; auto.
      - apply Axiom_Scheme; auto. }
    apply definition_not in H1; auto.
    apply not_and_or in H1; destruct H1; tauto.
  - apply Axiom_Scheme; split; Ens; unfold NotIn; intro.
    apply Axiom_Scheme in H0; destruct H0; contradiction.
Qed.

Hint Rewrite Theorem11 : set.

(* 12 Theorem (De Morgan)  ¬(x∪y)=(¬x)∩(¬y) and ¬(x∩y)=(¬x)∪(¬y). *)

Theorem Theorem12 : forall x y, ¬ (x ∪ y) = (¬ x) ∩ (¬ y).
Proof.
  intros; generalize (Theorem4 x y); intros.
  apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme in H0; destruct H0; unfold NotIn in H1.
    apply definition_not with (B:= z∈x \/ z∈y ) in H1.
    + apply not_or_and in H1; apply Theorem4'; split.
      * apply Axiom_Scheme; split; auto; unfold NotIn; tauto.
      * apply Axiom_Scheme; split; auto; unfold NotIn; tauto.
    + split; apply H.
  - apply Theorem4' in H0; destruct H0.
    apply Axiom_Scheme in H0; apply Axiom_Scheme in H1.
    apply Axiom_Scheme; split; try tauto.
    destruct H0, H1; unfold NotIn in H2,H3; unfold NotIn.
    apply definition_not with (A:= z∈x \/ z∈y ); auto.
    apply and_not_or; split; auto.
Qed.

Theorem Theorem12' : forall x y, ¬ (x ∩ y) = (¬ x) ∪ (¬ y).
Proof.
  intros; generalize (Theorem4' x y); intros.
  apply Axiom_Extent; split; intro.
  - apply Axiom_Scheme in H0; unfold NotIn in H0; destruct H0.
    apply definition_not with (B:= z∈x /\ z∈y) in H1.
    + apply Theorem4; apply not_and_or in H1; destruct H1.
      * left; apply Axiom_Scheme; split; auto.
      * right; apply Axiom_Scheme; split; auto.
    + split; apply H.
  - apply Axiom_Scheme; split; Ens.
    unfold NotIn; apply definition_not with (A:= z∈x /\ z∈y); auto.
    apply or_not_and; apply Theorem4 in H0; destruct H0.
    + apply Axiom_Scheme in H0; unfold NotIn in H0; tauto.
    + apply Axiom_Scheme in H0; unfold NotIn in H0; tauto.
Qed.

Hint Rewrite Theorem12 Theorem12' : set.

(* 13 Definition  x~y = x ∩ (¬ y). *)

Definition Difference x y : Class := x ∩ (¬ y).

Notation "x ~ y" := (Difference x y) (at level 50, left associativity).

Hint Unfold Difference : set.

(* 14 Theorem  x ∩ (y~z) = (x∩y) ~ z. *)

Theorem Theorem14 : forall x y z, x ∩ (y ~ z) = (x ∩ y) ~ z.
Proof.
  intros; unfold Difference; rewrite Theorem7'; auto.
Qed.

Hint Rewrite Theorem14 : set.

(* Definition (85)  x≠y if and only if it is false that x=y. *)

Definition Inequality (x y: Class) : Prop := ~ (x = y).

Notation "x ≠ y" := (Inequality x y) (at level 70).

Corollary Property_Ineq : forall x y, (x ≠ y) <-> (y ≠ x).
Proof.
 intros; split; intros; intro; apply H; auto.
Qed.

Hint Unfold Inequality: set.
Hint Resolve Property_Ineq: set.

(* 15 Definition  Φ = { x : x ≠ x }. *)

Definition Φ : Class := \{λ x, x ≠ x \}.

Hint Unfold Φ : set.

(* 16 Theorem  x ∉ Φ. *)

Theorem Theorem16 : forall x, x ∉ Φ.
Proof.
  intros; unfold NotIn; intro.
  apply Axiom_Scheme in H; destruct H; contradiction.
Qed.

Hint Resolve Theorem16 : set.

(* 17 Theorem  Φ ∪ x = x and Φ ∩ x = Φ. *)

Theorem Theorem17 : forall x, Φ ∪ x = x.
Proof.
  intros; apply Axiom_Extent; split; intro.
  - apply Theorem4 in H; destruct H; try tauto.
    generalize (Theorem16 z); contradiction.
  - apply Theorem4; tauto.
Qed.

Theorem Theorem17' : forall x, Φ ∩ x = Φ.
Proof.
  intros; apply Axiom_Extent; split; intro.
  - apply Theorem4' in H; destruct H; auto.
  - generalize (Theorem16 z); contradiction.
Qed.

Hint Rewrite Theorem17 Theorem17' : set.

(* 18 Definition  μ = { x : x = x }. *)

Definition μ : Class := \{ λ x, x = x \}.

Corollary Property_μ : forall x, x ∪ (¬ x) = μ.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme; split; Ens.
  - apply Axiom_Scheme in H; destruct H; apply Theorem4.
    generalize (classic (z∈x)); intros; destruct H1; try tauto.
    right; apply Axiom_Scheme; split; auto.
Qed.

Hint Unfold μ : set.
Hint Rewrite Property_μ : set.

(* 19 Theorem  x∈μ if and only if x is a set.  *)

Theorem Theorem19 : forall x, x ∈ μ <-> Ensemble x.
Proof.
  intros; split; intro.
  - apply Axiom_Scheme in H; destruct H; tauto.
  - apply Axiom_Scheme; split; auto.
Qed.

Hint Resolve Theorem19 : set.

(* 20 Theorem  x ∪ μ = μ and x ∩ μ = x. *)

Theorem Theorem20 : forall x, x ∪ μ = μ.
Proof.
  intros; apply Axiom_Extent; split; intro.
  - apply Theorem4 in H; destruct H; try tauto.
    apply Theorem19; Ens.
  - apply Theorem4; tauto.
Qed.

Theorem Theorem20' : forall x, x ∩ μ = x.
Proof.
  intros; apply Axiom_Extent; split; intro.
  - apply Theorem4' in H; tauto.
  - apply Theorem4'; split; auto.
    apply Theorem19; Ens.
Qed.

Hint Rewrite Theorem20 Theorem20' : set.

(* 21 Theorem  ¬ Φ = μ and ¬ μ = Φ. *)

Theorem Theorem21 : ¬ Φ = μ.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Theorem19; Ens.
  - apply Theorem19 in H; apply Axiom_Scheme; split; auto.
    apply Theorem16; auto.
Qed.

Theorem Theorem21' : ¬ μ = Φ.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme in H; destruct H.
    apply Theorem19 in H; contradiction.
  - apply Axiom_Scheme in H; destruct H; contradiction.
Qed.

Hint Rewrite Theorem21 Theorem21' : set.

(* 22 Definition  ∩x = { z : for each y, if y∈x, then z∈y }. *)

Definition Element_I x : Class := \{ λ z, forall y, y ∈ x -> z ∈ y \}.

Notation "∩ x" := (Element_I x) (at level 66).

Hint Unfold Element_I : set.

(* 23 Definition  ∪x = { z : for some y, z∈y and y∈x }. *)

Definition Element_U x : Class := \{ λ z, exists y, z ∈ y /\ y ∈ x \}.

Notation "∪ x" := (Element_U x) (at level 66).

Hint Unfold Element_U : set.

(* 24 Theorem  ∩Φ = μ and ∪Φ = Φ. *)

Theorem Theorem24 : ∩ Φ = μ.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Theorem19; Ens.
  - apply Axiom_Scheme; apply Theorem19 in H; split; auto.
    intros; generalize (Theorem16 y); contradiction.
Qed.

Theorem Theorem24' : ∪ Φ = Φ.
Proof.
  intros; apply Axiom_Extent; split; intro.
  - apply Axiom_Scheme in H; destruct H, H0, H0.
    generalize (Theorem16 x); contradiction.
  - generalize (Theorem16 z); contradiction.
Qed.

Hint Rewrite Theorem24 Theorem24' : set.

(* 25 Definition  x ⊂ y iff for each z, if z∈x, then z∈y. *)

Definition Subclass x y : Prop := forall z, z∈x -> z∈y.

Notation "x ⊂ y" := (Subclass x y) (at level 70).

Hint Unfold Subclass : set.

(* 26 Theorem  Φ ⊂ x and x ⊂ μ. *)

Theorem Theorem26 : forall x, Φ ⊂ x.
Proof.
  intros; unfold Subclass; intros.
  generalize (Theorem16 z); contradiction.
Qed.

Theorem Theorem26' : forall x, x ⊂ μ.
Proof.
  intros; unfold Subclass; intros; apply Theorem19; Ens.
Qed.

Hint Resolve Theorem26 Theorem26' : set.

(* 27 Theorem  x=y iff x⊂y and y⊂x. *)

Theorem Theorem27 : forall x y, (x ⊂ y /\ y ⊂ x) <-> x=y.
Proof.
  intros; split; intros.
  - destruct H; intros; apply Axiom_Extent; split; auto.
  - rewrite <- H; split; unfold Subclass; auto.
Qed.

Hint Resolve Theorem27 : set.

(* 28 Theorem  If x⊂y and y⊂z, then x⊂z. *)

Theorem Theorem28 : forall x y z, x ⊂ y /\ y ⊂ z -> x ⊂ z.
Proof.
  intros; destruct H; unfold Subclass; auto.
Qed.

Hint Resolve Theorem28 : set.

(* 29 Theorem  x⊂y iff x∪y = y. *)

Theorem Theorem29 : forall x y, x ∪ y = y <-> x ⊂ y.
Proof.
  intros; split; intros.
  - unfold Subclass; intros; apply Axiom_Extent with (z:=z) in H.
    apply H; apply Theorem4; tauto.
  - apply Axiom_Extent; split; intros.
    + apply Theorem4 in H0; destruct H0; auto.
    + apply Theorem4; tauto.
Qed.

Hint Resolve Theorem29 : set.

(* 30 Theorem  x⊂y iff x∩y = x. *)

Theorem Theorem30 : forall x y, x ∩ y = x <-> x ⊂ y.
Proof.
  intros; split; intros.
  - unfold Subclass; intros; apply Axiom_Extent with (z:=z) in H.
    apply H in H0; apply Theorem4' in H0; tauto.
  - apply Axiom_Extent; split; intros.
    + apply Theorem4' in H0; tauto.
    + apply Theorem4'; split; auto.
Qed.

Hint Resolve Theorem30 : set.

(* 31 Theorem  If x ⊂ y, then ∪x ⊂ ∪y and ∩y ⊂ ∩x. *)

Theorem Theorem31 : forall x y, x ⊂ y -> (∪x ⊂ ∪y) /\ (∩y ⊂ ∩x).
Proof.
  intros; split.
  - unfold Subclass; intros; apply Axiom_Scheme in H0; destruct H0.
    apply Axiom_Scheme; split; auto; intros; destruct H1.
    exists x0; split; unfold Subclass in H; destruct H1; auto.
  - unfold Subclass in H; unfold Subclass; intros.
    apply Axiom_Scheme in H0; destruct H0; apply Axiom_Scheme; split; auto.
Qed.

Hint Resolve Theorem31 : set.

(* 32 Theorem  If x∈y, then x ⊂ ∪y and ∩y ⊂ x. *)

Theorem Theorem32 : forall x y, x ∈ y -> (x ⊂ ∪y) /\ (∩y ⊂ x).
Proof.
  intros; split.
  - unfold Subclass; intros; apply Axiom_Scheme; split; Ens.
  - unfold Subclass; intros; apply Axiom_Scheme in H0.
    destruct H0; apply H1; auto.
Qed.

Hint Resolve Theorem32 : set.

(* Proper Subclass *)

Definition ProperSubclass x y : Prop := x ⊂ y /\ x ≠ y.

Notation "x ⊊ y" := (ProperSubclass x y) (at level 70).

Corollary Property_ProperSubclass : forall (x y: Class),
  x ⊂ y -> (x ⊊ y) \/ x = y.
Proof.
  intros.
  generalize (classic (x = y)); intros.
  destruct H0; auto.
  left; unfold ProperSubclass; auto.
Qed.

Corollary Property_ProperSubclass' : forall (x y: Class),
  x ⊊ y -> exists z, z ∈ y /\ z ∉ x.
Proof.
  intros.
  unfold ProperSubclass in H; destruct H.
  generalize (Theorem27 x y); intros.
  apply definition_not with (B:= (x ⊂ y /\ y ⊂ x)) in H0; try tauto.
  apply not_and_or in H0; destruct H0; try tauto.
  unfold Subclass in H0; apply not_all_ex_not in H0; destruct H0.
  apply imply_to_and in H0; Ens.
Qed.

Hint Unfold ProperSubclass : set.
Hint Resolve Property_ProperSubclass Property_ProperSubclass' : set.

(* Property_Φ *)

Lemma Property_Φ : forall x y, y ⊂ x -> x ~ y = Φ <-> x = y.
Proof.
  intros; split; intros.
  - apply Property_ProperSubclass in H; destruct H; auto.
    apply Property_ProperSubclass' in H; destruct H as [z H], H.
    assert (z ∈ (x ~ y)).
    { unfold Difference; apply Theorem4'; split; auto.
      unfold Complement; apply Axiom_Scheme; split; Ens. }
    rewrite H0 in H2; generalize (Theorem16 z); intros.
    contradiction.
  - rewrite <- H0; apply Axiom_Extent; split; intros.
    + unfold Difference in H1; apply Theorem4' in H1.
      destruct H1; unfold Complement in H2.
      apply Axiom_Scheme in H2; destruct H2; contradiction.
    + generalize (Theorem16 z); intros; contradiction.
Qed.

Hint Resolve Property_Φ : set.

(* EXISTENCE OF SETS *)

(* III Axiom of subsets  If x is a set there is a set y such that for each z,
   if z⊂x, then z∈y. *)

Axiom Axiom_Subsets : forall (x: Class),
  Ensemble x -> exists y, Ensemble y /\ (forall z, z⊂x -> z∈y).

Hint Resolve Axiom_Subsets : set.

(* 33 Theorem  If x is a set and z⊂x, then z is a set. *)

Theorem Theorem33 : forall x z,
  Ensemble x -> z ⊂ x -> Ensemble z.
Proof.
  intros; apply Axiom_Subsets in H; destruct H.
  apply H in H0; Ens.
Qed.

Hint Resolve Theorem33 : set.

(* 34 Theorem  Φ = ∩μ and ∪μ = μ. *)

Theorem Theorem34 : Φ = ∩μ.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - generalize (Theorem16 z); contradiction.
  - apply Axiom_Scheme in H; destruct H; apply H0.
    apply Theorem19; generalize (Theorem26 z); intros.
    apply Theorem33 in H1; auto.
Qed.

Theorem Theorem34' : μ = ∪μ.
Proof.
  apply Axiom_Extent; split; intros.
  - apply Lemma_x in H; destruct H; apply Axiom_Scheme in H.
    destruct H; apply Axiom_Scheme; split; try auto.
    generalize (Axiom_Subsets z H); intros.
    destruct H2; destruct H2; exists x; split.
    + apply H3; unfold Subclass; auto.
    + apply Theorem19; auto.
  - apply Axiom_Scheme in H; destruct H; apply Theorem19; auto.
Qed.

Hint Rewrite Theorem34 Theorem34' : set.

(* 35 Theorem  If x ≠ Φ, then ∩x is a set. *)

Lemma Lemma35 : forall x, x ≠ Φ <-> exists z, z∈x.
Proof.
  intros; assert (x = Φ <-> ~ (exists y, y∈x)).
  { split; intros.
    - intro; destruct H0; rewrite H in H0.
      apply Axiom_Scheme in H0; destruct H0; case H1; auto.
    - apply Axiom_Extent; split; intros.
      + elim H; exists z; auto.
      + generalize (Theorem16 z); contradiction. }
  split; intros.
  - apply definition_not with (B:= ~(exists y, y∈x)) in H0; auto.
    apply NNPP in H0; destruct H0; exists x0; auto.
  - apply definition_not with (A:=(~ (exists y, y∈x))); auto.
    destruct H; split; auto.
Qed.

Theorem Theorem35 : forall x, x ≠ Φ -> Ensemble (∩x).
Proof.
  intros; apply Lemma35 in H; destruct H; AssE x0.
  generalize (Theorem32 x0 x H); intros.
  destruct H1; apply Theorem33 in H2; auto.
Qed.

Hint Resolve Lemma35 Theorem35 : set.

(* 36 Definition  pow(x) = { y : y ⊂ x }. *)

Definition PowerClass x : Class := \{ λ y, y ⊂ x \}.

Notation "pow( x )" := (PowerClass x) (at level 0, right associativity).

Hint Unfold PowerClass : set.

(* 37 Theorem  μ = pow(μ). *)

Theorem Theorem37 : μ = pow(μ).
Proof.
  apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme; split; Ens; apply Theorem26'.
  - apply Axiom_Scheme in H; destruct H; apply Theorem19; auto.
Qed.

Hint Rewrite Theorem37 : set.

(* 38 Theorem  If x is a set, then pow(x) is a set, and for each y, y ⊂ x iff
   y ∈ pow(x). *)

Theorem Theorem38 : forall x y,
  Ensemble x -> Ensemble pow(x) /\ (y ⊂ x <-> y ∈ pow(x)).
Proof.
  intros; split.
  - apply Axiom_Subsets in H; destruct H, H.
    assert (pow(x) ⊂ x0).
    { unfold Subclass; intros; apply Axiom_Scheme in H1.
      destruct H1; apply H0 in H2; auto. }
    apply Theorem33 in H1; auto.
  - split; intros.
    + apply Theorem33 with (z:=y) in H; auto.
      apply Axiom_Scheme; split; auto.
    + apply Axiom_Scheme in H0; apply H0.
Qed.

Hint Resolve Theorem38 : set.

(* 39 Theorem  μ is not a set. *)

(* Russell paradox *)

Lemma Lemma_N : ~ Ensemble \{ λ x, x ∉ x \}.
Proof.
  generalize (classic (\{ λ x, x ∉ x \} ∈ \{ λ x, x ∉ x \})).
  intros; destruct H.
  - double H; apply Axiom_Scheme in H; destruct H; contradiction.
  - intro; elim H; apply Axiom_Scheme; split; auto.
Qed.

Theorem Theorem39 : ~ Ensemble μ.
Proof.
  unfold not; generalize Lemma_N; intros.
  generalize (Theorem26' \{ λ x, x ∉ x \}); intros.
  apply Theorem33 in H1; auto.
Qed.

Hint Resolve Lemma_N Theorem39 : set.

(* 40 Definition  [x] = { z : if x∈μ, then z=x }. *)

Definition Singleton x : Class := \{ λ z, x∈μ -> z=x \}.

Notation "[ x ]" := (Singleton x) (at level 0, right associativity).

Hint Unfold Singleton : set.

(* 41 Theorem  If x is a set, for each y, y∈[x] iff y=x. *)

Theorem Theorem41 : forall x, Ensemble x -> (forall y, y∈[x] <-> y=x).
Proof.
  intros; split; intros.
  - apply Axiom_Scheme in H0; destruct H0; apply H1.
    apply Theorem19 in H; auto.
  - apply Axiom_Scheme; split; intros; auto.
    rewrite <- H0 in H; auto.
Qed.

Hint Resolve Theorem41 : set.

(* 42 Theorem  If x is a set, then [x] is a set. *)

Theorem Theorem42 : forall x, Ensemble x -> Ensemble [x].
Proof.
  intros; double H; apply Theorem33 with (x:= pow(x)).
  - apply Theorem38 with (y:=x) in H0; destruct H0; auto.
  - unfold Subclass; intros.
    apply Theorem38 with (y:=z) in H0; destruct H0.
    apply H2; apply Axiom_Scheme in H1; destruct H1.
    apply Theorem19 in H; apply H3 in H.
    rewrite H; unfold Subclass; auto.
Qed.

Hint Resolve Theorem42 : set.

(* 43 Theorem  [x] = μ if and only if x is not a set. *)

Theorem Theorem43 : forall x, [x] = μ <-> ~ Ensemble x.
Proof.
  split; intros.
  - unfold not; intros; apply Theorem42 in H0.
    rewrite H in H0; generalize Theorem39; contradiction.
  - generalize (Theorem19 x); intros.
    apply definition_not with (B:= x∈μ) in H; try tauto.
    apply Axiom_Extent; split; intros.
    * apply Axiom_Scheme in H1; destruct H1; apply Theorem19; auto.
    * apply Axiom_Scheme; split; try contradiction.
      apply Theorem19 in H1; auto.
Qed.

Hint Rewrite Theorem43 : set.

(* 42' Theorem  If [x] is a set, then x is a set. *)

Theorem Theorem42' : forall x, Ensemble [x] -> Ensemble x.
Proof.
  intros.
  generalize (classic (Ensemble x)); intros.
  destruct H0; auto; generalize (Theorem39); intros.
  apply Theorem43 in H0; auto.
  rewrite H0 in H; contradiction.
Qed.

Hint Resolve Theorem42' : set.

(* 44 Theorem  If x is a set, then ∩[x] = x and ∪[x] = x; if x is not a set,
   then ∩[x] = Φ and ∪[x] = μ. *)

Theorem Theorem44 : forall x, Ensemble x -> ∩[x] = x /\ ∪[x] = x.
Proof.
  intros; generalize (Theorem41 x H); intros.
  split; apply Axiom_Extent.
  - split; intros.
    + apply Axiom_Scheme in H1; destruct H1; apply H2; apply H0; auto.
    + apply Axiom_Scheme; split; Ens; intros.
      apply H0 in H2; rewrite H2; auto.
  - split; intros.
    + apply Axiom_Scheme in H1; destruct H1, H2, H2.
      unfold Singleton in H3; apply Axiom_Scheme in H3; destruct H3.
      rewrite H4 in H2; auto; apply Theorem19; auto.
    + apply Axiom_Scheme; split; Ens; exists x; split; auto.
      unfold Singleton; apply Axiom_Scheme; auto.
Qed.

Theorem Theorem44' : forall x, ~ Ensemble x -> ∩[x] = Φ /\ ∪[x] = μ.
Proof.
  intros; apply Theorem43 in H; split; rewrite H.
  - rewrite Theorem34; auto.
  - rewrite <- Theorem34'; auto.
Qed.

Hint Resolve Theorem44 Theorem44' : set.

(* IV Axiom of union  If x is a set and y is a set so is x∪y. *)

Axiom Axiom_Union : forall (x y: Class),
  Ensemble x /\ Ensemble y -> Ensemble (x∪y).

Corollary Axiom_Union': forall x y,
  Ensemble (x∪y) -> Ensemble x /\ Ensemble y.
Proof.
  intros; split.
  - assert (x ⊂ (x∪y)).
    { unfold Subclass; intros; apply Theorem4; tauto. }
    apply Theorem33 in H0; auto.
  - assert (y ⊂ (x∪y)).
    { unfold Subclass; intros; apply Theorem4; tauto. }
    apply Theorem33 in H0; auto.
Qed.

Hint Resolve Axiom_Union Axiom_Union' : set.

(* 45 Definition  [x|y] = [x] ∪ [y]. *)

Definition Unordered x y : Class := [x]∪[y].

Notation "[ x | y ]" := (Unordered x y) (at level 0).

Hint Unfold Unordered : set.

(* 46 Theorem  If x is a set and y is a set, then [x|y] is a set and z∈[x|y]
   iff z=x or z=y; [x|y] = μ iff x is not a set or y is not a set. *)

Theorem Theorem46 : forall x y z,
  Ensemble x /\ Ensemble y -> Ensemble [x|y] /\ (z∈[x|y] <-> (z=x \/ z=y)).
Proof.
  split; intros; destruct H.
  - apply Theorem42 in H; apply Theorem42 in H0; apply Axiom_Union; auto.
  - split; intros.
    + apply Axiom_Scheme in H1; destruct H1.
      destruct H2; apply Axiom_Scheme in H2; destruct H2.
      * left; apply H3; apply Theorem19; auto.
      * right; apply H3; apply Theorem19; auto.
    + apply Axiom_Scheme; split.
      * destruct H1; try rewrite <- H1 in H; auto.
        rewrite <- H1 in H0; auto.
      * destruct H1.
        -- left; apply Axiom_Scheme; split; rewrite <- H1 in H; auto.
        -- right; apply Axiom_Scheme; split; rewrite <- H1 in H0; auto.
Qed.

Theorem Theorem46' : forall x y, [x|y] = μ <-> ~ Ensemble x \/ ~ Ensemble y.
Proof.
  unfold Unordered; split; intros.
  - generalize (Theorem43 ([x] ∪ [y])); intros.
    destruct H0; rewrite H in H0.
    assert ([μ] = μ); try apply Theorem43; try apply Theorem39.
    apply H0 in H2; rewrite <- H in H2.
    assert (Ensemble([x]∪[y]) <-> Ensemble [x] /\ Ensemble [y]).
    { split; try apply Axiom_Union; try apply Axiom_Union'. }
    apply definition_not in H3; auto.
    generalize (not_and_or (Ensemble [x]) (Ensemble [y])); intros.
    apply H4 in H3; destruct H3.
    + assert (Ensemble [x] <-> Ensemble x).
      { split; try apply Theorem42'; try apply Theorem42; auto. }
      apply definition_not in H5; auto.
    + assert (Ensemble [y] <-> Ensemble y).
      { split; try apply Theorem42'; try apply Theorem42; auto. }
      apply definition_not in H5; auto.
  - destruct H; apply Theorem43 in H; rewrite H; try apply Theorem20.
    generalize (Theorem6 μ [y]); intros; rewrite H0; apply Theorem20.
Qed.

Hint Resolve Theorem46 Theorem46' : set.

(* 47 Theorem  If x and y are sets, then ∩[x|y] = x ∩ y and ∪[x|y] = x ∪ y;
   if either x or y is not a set, then ∩[x|y] = Φ and ∪[x|y] = μ. *)

Theorem Theorem47 : forall x y,
  Ensemble x /\ Ensemble y -> (∩[x|y] = x ∩ y) /\ (∪[x|y] = x ∪ y).
Proof.
  intros; split; apply Axiom_Extent; intros.
  - split; intros.
    + apply Theorem4'.
      split; apply Axiom_Scheme in H0; destruct H0; apply H1; apply Theorem4.
      * left; apply Axiom_Scheme; split; try apply H; auto.
      * right; apply Axiom_Scheme; split; try apply H; auto.
    + apply Theorem4' in H0; destruct H0.
      apply Axiom_Scheme; split; intros; try AssE z.
      apply Theorem4 in H2; destruct H2.
      * apply Axiom_Scheme in H2; destruct H2; destruct H.
        apply Theorem19 in H; apply H4 in H; rewrite H; auto.
      * apply Axiom_Scheme in H2; destruct H2; destruct H.
        apply Theorem19 in H5; apply H4 in H5; rewrite H5; auto.
  - split; intros.
    + apply Axiom_Scheme in H0; destruct H0; destruct H1; destruct H1.
      apply Theorem4 in H2; apply Theorem4.
      destruct H2; apply Axiom_Scheme in H2; destruct H2.
      * left; destruct H; apply Theorem19 in H.
        apply H3 in H; rewrite H in H1; auto.
      * right; destruct H; apply Theorem19 in H4.
        apply H3 in H4; rewrite H4 in H1; auto.
    + apply Theorem4 in H0; apply Axiom_Scheme.
      split; destruct H0; try AssE z.
      * exists x; split; auto; apply Theorem4; left.
        apply Axiom_Scheme; split; try apply H; trivial.
      * exists y; split; auto; apply Theorem4; right.
        apply Axiom_Scheme; split; try apply H; trivial.
Qed.

Theorem Theorem47' : forall x y,
  ~ Ensemble x \/ ~ Ensemble y -> (∩[x|y] = Φ) /\ (∪[x|y] = μ).
Proof.
  intros; split; apply Theorem46' in H; rewrite H.
  - rewrite Theorem34; auto.
  - rewrite <- Theorem34'; auto.
Qed.

Hint Resolve Theorem47 Theorem47' : set.

(* ORDERED PAIRS: RELATIONS *)

(* 48 Definition  [x,y] = [[x]|[x|y]] *)

Definition Ordered x y : Class := [ [x] | [x|y]].

Notation "[ x , y ]" := (Ordered x y) (at level 0).

Hint Unfold Ordered : set.

(* 49 Theorem  [x,y] is a set if and only if x is a set and y is a set;
   if [x,y] is not a set, then [x,y] = μ. *)

Theorem Theorem49 : forall (x y: Class),
  Ensemble [x,y] <-> Ensemble x /\ Ensemble y.
Proof.
  intros; split; intro.
  - unfold Ordered in H; unfold Unordered in H.
    apply Axiom_Union' in H; destruct H; apply Theorem42' in H.
    apply Theorem42' in H; apply Theorem42' in H0; split; auto.
    unfold Unordered in H0; apply Axiom_Union' in H0.
    destruct H0; apply Theorem42' in H1; auto.
  - destruct H; unfold Ordered, Unordered; apply Axiom_Union; split.
    + apply Theorem42; auto; apply Theorem42; auto.
    + apply Theorem42; auto; apply Theorem46; auto.
Qed.

Theorem Theorem49' : forall (x y: Class),
  ~ Ensemble [x,y] -> [x,y] = μ.
Proof.
  intros; generalize (Theorem49 x y); intros.
  apply definition_not with (B:= Ensemble x /\ Ensemble y) in H; try tauto.
  apply not_and_or in H; apply Theorem46' in H; auto.
  generalize Theorem39; intros; rewrite <-H in H1.
  unfold Ordered; apply Theorem46'; auto.
Qed.

Hint Resolve Theorem49 Theorem49' : set.

(* 50 Theorem  If x and y are sets, then ∪[x,y]=[x|y], ∩[x,y]=[x], ∪∩[x,y]=x,
   ∩∩[x,y]=x, ∪∪[x,y]=x∪y, ∩∪[x,y]=x∩y. If either x or y is not a set,
   then ∪∩[x,y]=Φ, ∩∩[x,y]=Φ, ∪∪[x,y]=Φ, ∩∪[x,y]=Φ. *)

Lemma Lemma50 : forall (x y: Class),
  Ensemble x /\ Ensemble y -> Ensemble [x] /\ Ensemble [x | y].
Proof.
  intros; apply Theorem49 in H; auto.
  unfold Ordered in H; unfold Unordered in H.
  apply Axiom_Union' in H; destruct H.
  apply Theorem42' in H; auto.
  apply Theorem42' in H0; auto.
Qed.

Theorem Theorem50 : forall (x y: Class),
  Ensemble x /\ Ensemble y -> (∪[x,y] = [x|y]) /\ (∩[x,y] = [x]) /\
  (∪(∩[x,y]) = x) /\ (∩(∩[x,y]) = x) /\ (∪(∪[x,y]) = x∪y) /\ (∩(∪[x,y]) = x∩y).
Proof.
  intros; elim H; intros.
  repeat unfold Ordered; apply Lemma50 in H.
  apply Theorem47 in H; auto; elim H; intros; repeat split.
  - rewrite H3; apply Axiom_Extent; split; intros; try (apply Theorem4; tauto).
    apply Theorem4 in H4; destruct H4; auto; apply Theorem4; tauto.
  - rewrite H2; apply Axiom_Extent; split; intros.
    + apply Theorem4' in H4; apply H4.
    + apply Theorem4'; split; auto; apply Theorem4; tauto.
  - rewrite H2; apply Axiom_Extent; split; intros.
    + apply Axiom_Scheme in H4; destruct H4, H5, H5.
      apply Theorem4' in H6; destruct H6; apply Axiom_Scheme in H6.
      destruct H6; rewrite <- H8; auto.
      apply Theorem19; auto.
    + apply Axiom_Scheme; split; Ens; exists x.
      split; auto; apply Theorem4'; split.
      * apply Axiom_Scheme; split; auto.
      * apply Theorem4; left; apply Axiom_Scheme.
        split; try apply H0; trivial.
  - rewrite H2; apply Axiom_Extent; split; intros.
    + apply Axiom_Scheme in H4; destruct H4.
      apply H5; apply Theorem4'; split.
      * apply Axiom_Scheme; split; auto.
      * apply Theorem4; left; apply Axiom_Scheme; split; auto.
    + apply Axiom_Scheme; split; Ens.
      intros; apply Theorem4' in H5. destruct H5.
      apply Axiom_Scheme in H5. destruct H5. rewrite H7; auto.
      apply Theorem19; auto.
  - rewrite H3; apply Axiom_Extent; split; intros.
    + apply Theorem4; apply Axiom_Scheme in H4; destruct H4, H5, H5.
      apply Theorem4 in H6; destruct H6.
      * apply Axiom_Scheme in H6; destruct H6; left; rewrite <- H7; auto.
        apply Theorem19; auto.
      * apply Theorem4 in H6; destruct H6.
        -- apply Axiom_Scheme in H6; destruct H6.
           left; rewrite <- H7; auto; apply Theorem19; auto.
        -- apply Axiom_Scheme in H6; destruct H6.
           right; rewrite <- H7; auto; apply Theorem19; auto.
    + apply Axiom_Scheme; apply Theorem4 in H4; split.
      * unfold Ensemble; destruct H4; Ens.
      * destruct H4.
        -- exists x; split; auto; apply Theorem4; left.
           apply Axiom_Scheme; split; auto.
        -- exists y; split; auto; apply Theorem4; right.
           apply Theorem4; right; apply Axiom_Scheme; split; auto.
  - rewrite H3; apply Axiom_Extent; split; intros.
    + apply Lemma_x in H4; elim H4; intros.
      apply Axiom_Scheme in H5; apply Axiom_Scheme in H6.
      destruct H4; apply Theorem4'; split; auto.
      * apply H5; apply Theorem4; left.
        apply Axiom_Scheme; split; auto.
      * apply H6; apply Theorem4; right.
        apply Theorem4; right.
        apply Axiom_Scheme; split; auto.
    + apply Theorem4' in H4; destruct H4.
      apply Axiom_Scheme; split; Ens.
      intros; apply Theorem4 in H6; destruct H6.
      * apply Axiom_Scheme in H6; destruct H6; rewrite H7; auto.
        apply Theorem19; auto.
      * apply Axiom_Scheme in H6; destruct H6, H7.
        -- apply Axiom_Scheme in H7; destruct H7.
           rewrite H8; auto; apply Theorem19; auto.
        -- apply Axiom_Scheme in H7; destruct H7.
           rewrite H8; auto; apply Theorem19; auto.
Qed.

Lemma Lemma50' : forall (x y: Class),
  ~Ensemble x \/ ~Ensemble y -> ~Ensemble [x] \/ ~Ensemble [x | y].
Proof.
  intros; elim H; intros.
  - left; apply Theorem43 in H0; auto.
    rewrite H0; apply Theorem39; auto.
  - right; apply Theorem46' in H; auto.
    rewrite H; apply Theorem39; auto.
Qed.

Theorem Theorem50' : forall (x y: Class),
  ~Ensemble x \/ ~Ensemble y -> (∪(∩[x,y]) = Φ) /\ (∩(∩[x,y]) = μ)
  /\ (∪(∪[x,y]) = μ) /\ (∩(∪[x,y]) = Φ).
Proof.
  intros; apply Lemma50' in H; auto.
  apply Theorem47' in H; destruct H.
  repeat unfold Ordered; repeat split.
  - rewrite H; apply Theorem24'; auto.
  - rewrite H; apply Theorem24; auto.
  - rewrite H0; rewrite <- Theorem34'; auto.
  - rewrite H0; rewrite <- Theorem34; auto.
Qed.

Hint Resolve Theorem50 Theorem50' : set.

(* 51 Definition  1st coord z = ∩∩z. *)

Definition First z := ∩∩z.

Hint Unfold First : set.

(* 52 Definition  2nd coord z = (∩∪z)∪(∪∪z)~(∪∩z). *)

Definition Second z := (∩∪z)∪(∪∪z)~(∪∩z).

Hint Unfold Second : set.

(* 53 Theorem  2nd coord μ = μ. *)

Lemma Lemma53 : μ ~ Φ = μ.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Theorem4' in H; destruct H; auto.
  - apply Theorem4'; split; auto.
    apply Axiom_Scheme; split.
    * apply Theorem19 in H; auto.
    * apply Theorem16; auto.
Qed.

Theorem Theorem53 : Second μ = μ.
Proof.
  intros; unfold Second.
  repeat rewrite <-Theorem34'; auto.
  repeat rewrite <-Theorem34 ; auto.
  rewrite Theorem24'; auto.
  rewrite Lemma53; auto.
  apply Theorem20; auto.
Qed.

Hint Rewrite Theorem53 : set.

(* 54 Theorem  If x and y are sets, 1st coord [x,y] = x and 2nd coord [x,y] = y.
   If either of x and y is not a set, then 1st coord [x,y] = μ and
   2nd coord [x,y] = μ. *)

Lemma Lemma54 : forall (x y: Class),
  (x ∪ y) ~ x = y ~ x.
Proof.
  intros.
  apply Axiom_Extent; split; intros.
  - apply Theorem4' in H; apply Theorem4'.
    destruct H; apply Theorem4 in H; split; auto.
    destruct H; auto; apply Axiom_Scheme in H0.
    destruct H0; elim H1; auto.
  - apply Theorem4' in H; apply Theorem4'.
    destruct H; split; auto.
    apply Theorem4; tauto.
Qed.

Theorem Theorem54 : forall (x y: Class),
  Ensemble x /\ Ensemble y -> First [x,y] = x /\ Second [x,y] = y.
Proof.
  intros; apply Theorem50 in H; auto; split.
  - unfold First; apply H.
  - destruct H, H0, H1, H2, H3; unfold Second.
    rewrite H4; rewrite H3; rewrite H1.
    rewrite Lemma54; auto; unfold Difference.
    rewrite Theorem6'; auto; rewrite <- Theorem8; auto.
    rewrite Property_μ; auto; rewrite Theorem20'; auto.
Qed.

Theorem Theorem54' : forall (x y: Class),
  ~Ensemble x \/ ~Ensemble y -> First [x,y] = μ /\ Second [x,y] = μ.
Proof.
  intros; apply Theorem50' in H; auto; split.
  - unfold First; apply H.
  - destruct H, H0, H1; unfold Second.
    rewrite H2; rewrite H1; rewrite H.
    rewrite Lemma53; auto.
    apply Theorem20; auto.
Qed.

Hint Resolve Theorem54 Theorem54' : set.

(* 55 Theorem  If x and y are sets and [x,y] = [u,v], then x=u and y=v. *)

Theorem Theorem55 : forall (x y u v: Class),
  Ensemble x /\ Ensemble y -> ([x,y] = [u,v] <-> x = u /\ y = v).
Proof.
  intros; split; intros.
  - double H; apply Theorem49 in H; apply Theorem54 in H1; destruct H1.
    rewrite H0 in H, H1, H2; apply Theorem49 in H; apply Theorem54 in H.
    destruct H; rewrite H1 in H; rewrite H2 in H3; split; auto.
  - destruct H0; rewrite H0, H1; auto.
Qed.

Hint Resolve Theorem55 : set.

(* 56 Definition  r is a relation if and only if for each member z of r there
   is x and y such that z = [x,y]. *)

Definition Relation r : Prop :=
  forall z, z∈r -> exists x y, z = [x,y].

Hint Unfold Relation: set.

(* II Classification axiom-scheme  For each b, b ∈ { a : A } if and only if
   b is a set and B. *)

(* { [x,y] : ... }  If the member is a ordered pair, then { [x,y] : ... } is
   used. The definition of { [x,y] : ... } is to avoid excessive notation. We
   agree that { [x,y] : ... } is to be identical with { u : for some x, some y,
   u = (x,y) and ... }. *)

Parameter Classifier_P : (Class -> Class -> Prop) -> Class.

Notation "\{\ P \}\" := (Classifier_P P) (at level 0).

Axiom Axiom_SchemeP : forall (a b: Class) (P: Class -> Class -> Prop),
  [a,b] ∈ \{\ P \}\ <-> Ensemble [a,b] /\ (P a b).

Axiom Property_P : forall (z: Class) (P: Class -> Class -> Prop),
  z ∈ \{\ P \}\ -> (exists a b, z = [a,b]) /\ z ∈ \{\ P \}\.

Ltac PP H a b := apply Property_P in H; destruct H as [[a [b H]]];
  rewrite H in *.

Hint Resolve Axiom_SchemeP Property_P : set.

(* 57 Definition  r ∘ s = { [x,z] : for some y, [x,y]∈s and [y,z]∈r }. *)

Definition Composition r s : Class :=
 \{\ λ x z, exists y, [x,y]∈s /\ [y,z]∈r \}\.

Notation "r ∘ s" := (Composition r s) (at level 50, no associativity).

(* r∘s = {u : for some x, some y and some z, u=[x,z], [x,y]∈s and [y,z]∈r}. *)

Definition Composition' r s : Class :=
  \{ λ u, exists x y z, u = [x,z] /\ [x,y] ∈ s /\ [y,z] ∈ r \}.

Hint Unfold Composition Composition' : set.

(* 58 Theorem  (r∘s)∘t = r∘(s∘t). *)

Theorem Theorem58 : forall (r s t: Class),
  (r ∘ s) ∘ t = r ∘ (s ∘ t).
Proof.
  intros; apply Axiom_Extent; split; intros.
  - PP H a b. apply Axiom_SchemeP in H0; destruct H0, H1 as [y H1], H1.
    apply Axiom_SchemeP in H2; destruct H2, H3, H3.
    apply Axiom_SchemeP; split; auto.
    exists x; split; try tauto; apply Axiom_SchemeP; split; Ens.
    AssE [a,y]; AssE [y,x]; apply Theorem49 in H5; apply Theorem49 in H6.
    destruct H5, H6; apply Theorem49; auto.
  - PP H a b; apply Axiom_SchemeP in H0; destruct H0, H1 as [y H1], H1.
    apply Axiom_SchemeP in H1; destruct H1, H3, H3.
    apply Axiom_SchemeP; split; auto.
    exists x; split; auto; apply Axiom_SchemeP; split; Ens.
    AssE [a,x]; AssE [y,b]; apply Theorem49 in H5; apply Theorem49 in H6.
    destruct H5, H6; apply Theorem49; Ens.
Qed.

Hint Rewrite Theorem58 : set.

(* 59 Theorem  r∘(s∪t) = r∘s ∪ r∘t and r∘(s∩t) ⊂ r∘s ∩ r∘t. *)

Theorem Theorem59 : forall (r s t: Class),
  Relation r /\ Relation s -> r ∘ (s ∪ t) = (r ∘ s) ∪ (r ∘ t) /\
  r ∘ (s ∩ t) ⊂ (r ∘ s) ∩ (r ∘ t).
Proof.
  intros; split.
  - apply Axiom_Extent; split; intros.
    + PP H0 a b; apply Axiom_SchemeP in H1; destruct H1.
      apply Theorem4.
      destruct H2 as [y H2]; destruct H2.
      apply Theorem4 in H2; destruct H2.
      * left; apply Axiom_SchemeP; split; auto.
        exists y; split; auto.
      * right; apply Axiom_SchemeP; split; auto.
        exists y; split; auto.
    + apply Theorem4 in H0; destruct H0; PP H0 a b; apply Axiom_SchemeP.
      * apply Axiom_SchemeP in H1; destruct H1.
        destruct H2 as [y H2]; destruct H2; split; auto.
        exists y; split; auto; apply Theorem4; try tauto.
      * apply Axiom_SchemeP in H1; destruct H1.
        destruct H2 as [y H2]; destruct H2; split; auto.
        exists y; split; auto; apply Theorem4; try tauto.
  - unfold Subclass; intros; PP H0 a b.
    apply Axiom_SchemeP in H1; destruct H1.
    destruct H2 as [y H2]; destruct H2.
    apply Theorem4' in H2; apply Theorem4'; split.
    + apply Axiom_SchemeP; split; auto.
      exists y; split; try apply H2; auto.
    + apply Axiom_SchemeP; split; auto.
      exists y; split; try apply H2; auto.
Qed.

Hint Resolve Theorem59 : set.

(* 60 Definition  r⁻¹ = { [x,y] : [y,x] ∈ r }. *)

Definition Inverse r : Class := \{\ λ x y, [y,x]∈r \}\.

Notation "r ⁻¹" := (Inverse r)(at level 5).

Hint Unfold Inverse : set.

(* 61 Theorem  If r is a relation, then (r⁻¹)⁻¹ = r. *)

Lemma Lemma61 : forall (x y: Class),
  Ensemble [x,y] <-> Ensemble [y,x].
Proof.
  intros; split; intros.
  - apply Theorem49 in H; auto.
    destruct H; apply Theorem49; auto.
  - apply Theorem49 in H; auto.
    destruct H; apply Theorem49; auto.
Qed.

Theorem Theorem61 : forall (r: Class),
  Relation r -> (r ⁻¹)⁻¹ = r.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - PP H0 a b; apply Axiom_SchemeP in H1; destruct H1.
    apply Axiom_SchemeP in H2; apply H2.
  - unfold Relation in H; double H0; apply H in H1.
    destruct H1 as [a [b H1]]; rewrite H1 in *; clear H1.
    apply Axiom_SchemeP; split; Ens; apply Axiom_SchemeP; split; auto.
    apply Lemma61; auto; Ens.
Qed.

Hint Rewrite Theorem61 : set.

(* 62 Theorem  (r∘s)⁻¹ = (s⁻¹) ∘ (r⁻¹). *)

Theorem Theorem62 : forall (r s: Class),
  (r ∘ s)⁻¹ = (s⁻¹) ∘ (r⁻¹).
Proof.
  intros; apply Axiom_Extent; split; intros.
  - PP H a b; apply Axiom_SchemeP in H0; destruct H0 as [H0 H1].
    apply Axiom_SchemeP; split; auto.
    apply Axiom_SchemeP in H1; destruct H1, H2, H2.
    exists x; split.
    + apply Axiom_SchemeP; split; auto.
      apply Lemma61; Ens; exists r; auto.
    + apply Axiom_SchemeP; split; auto.
      apply Lemma61; Ens.
  - PP H a b; apply Axiom_SchemeP in H0; destruct H0, H1, H1.
    apply Axiom_SchemeP; split; auto.
    apply Axiom_SchemeP in H1; apply Axiom_SchemeP in H2.
    apply Axiom_SchemeP; split.
    + apply Lemma61; auto.
    + exists x; split; try apply H0; try apply H2.
      destruct H1; auto.
Qed.

Hint Rewrite Theorem62 : set.

(* FUNCTIONS *)

(* 63 Definition  f is a function if and only if f is a relation and for each x,
   each y, each z, if [x,y]∈f and [x,z]∈f, then y = z. *)

Definition Function f : Prop :=
  Relation f /\ (forall x y z, [x,y] ∈ f /\ [x,z] ∈ f -> y=z).

Hint Unfold Function : set.

(* 64 Theorem  If f is a function and g is a function so is f∘g. *)

Theorem Theorem64 : forall f g,
  Function f /\ Function g -> Function (f ∘ g).
Proof.
  intros; destruct H.
  unfold Function; split; intros.
  - unfold Relation; intros; PP H1 a b; eauto.
  - destruct H1; apply Axiom_SchemeP in H1; apply Axiom_SchemeP in H2.
    destruct H1, H2, H3, H4, H3, H4.
    unfold Function in H, H0; destruct H; destruct H0.
    assert (x0=x1). { apply H8 with x; split; auto. }
    rewrite H9 in H5; apply H7 with x1; split; auto.
Qed.

Hint Resolve Theorem64 : set.

(* 65 Definition  domain f = { x : for some y, [x,y]∈f }. *)

Definition Domain f : Class := \{ λ x, exists y, [x,y] ∈ f \}.

Notation "dom( f )" := (Domain f)(at level 5).

Corollary Property_dom : forall x y f,
  [x,y] ∈ f -> x ∈ dom( f ).
Proof.
  intros; unfold Domain; apply Axiom_Scheme; split; eauto.
  AssE [x,y]; apply Theorem49 in H0; apply H0.
Qed.

Hint Unfold Domain : set.

(* 66 Definition  range f = { y : for some x, [x,y]∈f }. *)

Definition Range f : Class := \{ λ y, exists x, [x,y] ∈ f \}.

Notation "ran( f )" := (Range f)(at level 5).

Corollary Property_ran : forall x y f,
  [x,y] ∈ f -> y ∈ ran( f ).
Proof.
  intros; apply Axiom_Scheme.
  split; eauto; AssE [x,y].
  apply Theorem49 in H0; apply H0.
Qed.

Hint Unfold Range : set.

(* 67 Theorem  domain μ = μ and range μ = μ. *)

Theorem Theorem67 : dom( μ ) = μ /\ ran( μ ) = μ.
Proof.
  intros; split; apply Axiom_Extent; split; intros.
  - AssE z; apply Theorem19; auto.
  - apply Theorem19 in H.
    unfold Domain; apply Axiom_Scheme; split; auto.
    exists z; apply Theorem19.
    apply Theorem49; split; auto.
  - AssE z; apply Theorem19; auto.
  - apply Theorem19 in H.
    unfold Range; apply Axiom_Scheme; split; auto.
    exists z; apply Theorem19.
    apply Theorem49; split; auto.
Qed.

Hint Rewrite Theorem67 : set.

(* 68 Definition  f[x] = ∩{ y : [x,y]∈f }. *)

Definition Value f x : Class := ∩ \{ λ y, [x,y] ∈ f \}.

Notation "f [ x ]" := (Value f x)(at level 5).

Corollary Property_Value : forall f x,
  Function f -> x ∈ dom( f ) -> [x,f[x]] ∈ f.
Proof.
  intros; unfold Function in H;destruct H as [_ H].
  apply Axiom_Scheme in H0; destruct H0, H1.
  assert (x0=f[x]).
  - apply Axiom_Extent; split; intros.
    + apply Axiom_Scheme; split; intros; try Ens.
      apply Axiom_Scheme in H3; destruct H3.
      assert (x0=y). { apply H with x; split; auto. }
      rewrite <- H5; auto.
    + apply Axiom_Scheme in H2; destruct H2 as [_ H2].
      apply H2; apply Axiom_Scheme; split; auto.
      AssE [x, x0]; apply Theorem49 in H3; apply H3.
  - rewrite <- H2; auto.
Qed.

Hint Unfold Value : set.
Hint Resolve Property_Value : set.

(* 69 Theorem  If x ∉ domain f, then f[x]=μ; if x ∈ domain f, then f[x]∈μ. *)

Lemma Lemma69 : forall x f,
  Function f -> (x ∉ dom(f) -> \{ λ y, [x,y] ∈ f \} = Φ) /\
  (x ∈ dom(f) -> \{ λ y, [x,y] ∈ f \} <> Φ).
Proof.
  intros; split; intros.
  - generalize (classic (\{ λ y0, [x, y0] ∈ f \} = Φ)); intro.
    destruct H1; auto; apply Lemma35 in H1; auto.
    elim H1; intro z; intros; apply Axiom_Scheme in H2.
    destruct H2 as [H2 H3]; apply Property_dom in H3; contradiction.
  - apply Lemma35; auto; exists f[x].
    apply Axiom_Scheme; eapply Property_Value in H0; auto.
    split; auto; apply Property_ran in H0; Ens.
Qed.

Theorem Theorem69 : forall x f,
  ( x ∉ dom( f ) -> f[x] = μ ) /\ ( x ∈ dom( f ) -> f[x] ∈  μ ).
Proof.
  intros; split; intros.
  - assert (\{ λ y, [x,y] ∈ f \} = Φ).
    { apply Axiom_Extent; split; intros.
      apply Axiom_Scheme in H0; destruct H0.
      apply Property_dom in H1; contradiction.
      generalize (Theorem16 z); intro; contradiction. }
    unfold Value; rewrite H0; apply Theorem24.
  - assert (\{ λ y, [x,y] ∈ f \} <> Φ).
    { intro; apply Axiom_Scheme in H; destruct H, H1.
      generalize (Axiom_Extent \{ λ y, [x, y] ∈ f \} Φ); intro.
      destruct H2; apply H2 with x0 in H0; destruct H0.
      assert (x0 ∈ Φ).
      { apply H0; apply Axiom_Scheme; split; auto.
        AssE [x, x0];  apply Theorem49 in H5; tauto. }
      eapply Theorem16; eauto. }
    apply Theorem35 in H0; apply Theorem19; auto.
Qed.

Corollary Property_Value' : forall f x,
  Function f -> f[x] ∈ ran(f) -> [x,f[x]] ∈ f.
Proof.
  intros; apply Property_Value; auto.
  apply Axiom_Scheme in H0; destruct H0, H1.
  generalize (classic (x ∈ dom( f))); intros.
  destruct H2; auto; apply Theorem69 in H2; auto.
  rewrite H2 in H0; generalize (Theorem39); intro; contradiction.
Qed.

Hint Resolve Theorem69 : set.
Hint Resolve Property_Value' : set.

(* 70 Theorem  If f is a function, then f = { [x,y] : y = f[x] }. *)

Theorem Theorem70 : forall f,
  Function f -> f = \{\ λ x y, y = f[x] \}\.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - double H0; unfold Function, Relation in H; destruct H.
    apply H in H1; destruct H1 as [a [b H1]]; rewrite H1 in *; clear H1.
    apply Axiom_SchemeP; split; try Ens; apply Axiom_Extent; split; intros.
    + apply Axiom_Scheme; split; intros; try Ens.
      apply Axiom_Scheme in H3; destruct H3.
      apply Lemma_xy with (y:=[a, y] ∈ f) in H0; auto.
      apply H2 in H0; rewrite <- H0; auto.
    + unfold Value, Element_I in H1; apply Axiom_Scheme in H1; destruct H1.
      apply H3; apply Axiom_Scheme; split; auto; AssE [a,b].
      apply Theorem49 in H4; try apply H4.
  - PP H0 a b; apply Axiom_SchemeP in H1; destruct H1.
    generalize (classic (a ∈ dom( f ))); intros; destruct H3.
    + apply Property_Value in H3; auto; rewrite H2; auto.
    + apply Theorem69 in H3; auto.
      rewrite H3 in H2; rewrite H2 in H1.
      apply Theorem49 in H1; destruct H1 as [_ H1].
      generalize Theorem39; intro; contradiction.
Qed.

Hint Resolve Theorem70 : set.

(* 71 Theorem  If f and g are functions, then f=g iff f[x]=g[x] for each x. *)

Theorem Theorem71 : forall f g,
  Function f /\ Function g -> (f = g <-> forall x, f[x] = g[x]).
Proof.
  intros; split; intros; try rewrite H0; trivial.
  destruct H; intros; apply (Theorem70 f) in H; apply (Theorem70 g) in H1.
  rewrite H; rewrite H1; apply Axiom_Extent; split; intros.
  - PP H2 a b; apply Axiom_SchemeP in H3; apply Axiom_SchemeP.
    destruct H3; split; auto; rewrite <- H0; auto.
  - PP H2 a b; apply Axiom_SchemeP in H3; apply Axiom_SchemeP.
    destruct H3; split; auto; rewrite -> H0; auto.
Qed.

Hint Resolve Theorem71 : set.

(* V Axiom of substitution  If f is a function and domain f is a set, then
   range f is a set. *)

Axiom Axiom_Substitution : forall f,
  Function f -> Ensemble dom(f) -> Ensemble ran(f).

Hint Resolve Axiom_Substitution : set.

(* VI Axiom of amalgamation  If x is a set so is ∪x. *)

Axiom Axiom_Amalgamation : forall x, Ensemble x -> Ensemble (∪ x).

Hint Resolve Axiom_Amalgamation : set.

(* 72 Definition  x × y = { [u,v] : u∈x /\ v∈y }. *)

Definition Cartesian x y : Class := \{\ λ u v, u∈x /\ v∈y \}\.

Notation "x × y" := (Cartesian x y)(at level 2, right associativity).

Hint Unfold Cartesian : set.

(* 73 Theorem  If u and y are sets so is [u] × y. *)

Lemma Ex_Lemma73 : forall u y,
  Ensemble u /\ Ensemble y ->
  exists f, Function f /\ dom(f) = y /\ ran(f) = [u] × y.
Proof.
  intros; destruct H.
  exists (\{\ λ w z, w∈y /\ z = [u,w] \}\).
  repeat split; intros.
  - red; intros; PP H1 a b; Ens.
  - destruct H1; apply Axiom_SchemeP in H1; apply Axiom_SchemeP in H2.
    destruct H1 as [_ [_ H1]]; destruct H2 as [_ [_ H2]].
    rewrite H2; auto.
  - apply Axiom_Extent; split; intros.
    + apply Axiom_Scheme in H1; destruct H1 as [_ [t H1]].
      apply Axiom_SchemeP in H1; tauto.
    + apply Axiom_Scheme; split; try Ens.
      exists [u,z]; apply Axiom_SchemeP; split; auto.
      AssE z; apply Theorem49; split; auto.
      apply Theorem49; tauto.
  - apply Axiom_Extent; split; intros.
    + apply Axiom_Scheme in H1; destruct H1, H1, H2.
      apply Axiom_SchemeP in H2; destruct H2, H3.
      rewrite H4; apply Axiom_SchemeP; repeat split; auto.
      * apply Theorem49; split; auto; AssE x0.
      * apply Axiom_Scheme; split; auto.
    + PP H1 a b; apply Axiom_SchemeP in H2; destruct H2, H3.
      apply Axiom_Scheme; split; auto; exists b.
      apply Axiom_SchemeP; repeat split; auto.
      * apply Theorem49; split; auto; AssE b.
      * apply Theorem19 in H; apply Axiom_Scheme in H3.
        destruct H3; rewrite H5; auto.
Qed.

Theorem Theorem73 : forall u y,
  Ensemble u /\ Ensemble y -> Ensemble ([u] × y).
Proof.
  intros.
  elim H; intros; apply Ex_Lemma73 in H; auto.
  destruct H, H, H2; rewrite <- H3; apply Axiom_Substitution; auto.
  rewrite H2; auto.
Qed.

Hint Resolve Theorem73 : set.

(* 74 Theorem  If x and y are sets so is x × y. *)

Lemma Ex_Lemma74 : forall x y,
  Ensemble x /\ Ensemble y -> exists f, Function f /\ dom( f ) = x /\
  ran( f ) = \{ λ z, exists u, u∈x /\ z = [u] × y \}.
Proof.
  intros; destruct H.
  exists (\{\ λ u z, u∈x /\ z = [u] × y \}\).
  repeat split; intros.
  - red; intros; PP H1 a b; Ens.
  - destruct H1; apply Axiom_SchemeP in H1; apply Axiom_SchemeP in H2.
    destruct H1, H2, H3, H4; subst z; auto.
  - apply Axiom_Extent; split; intros.
    + apply Axiom_Scheme in H1; destruct H1, H2.
      apply Axiom_SchemeP in H2; tauto.
    + apply Axiom_Scheme; split; try AssE z.
      exists (([z]) × y); apply Axiom_SchemeP.
      repeat split; auto; apply Theorem49; split; auto.
      apply Theorem73; auto.
  - apply Axiom_Extent; split; intros.
    + apply Axiom_Scheme in H1; destruct H1, H2.
      apply Axiom_SchemeP in H2; apply Axiom_Scheme.
      split; auto; exists x0; tauto.
    + apply Axiom_Scheme in H1; destruct H1, H2, H2.
      apply Axiom_Scheme; split; auto.
      exists x0; apply Axiom_SchemeP; repeat split; auto.
      apply Theorem49; split; auto; AssE x0.
Qed.

Lemma Lemma74 : forall x y,
  Ensemble x /\ Ensemble y ->
  ∪ \{ λ z, exists u, u∈x /\ z = [u] × y \} = x × y.
Proof.
  intros; apply Axiom_Extent; split; intros.
  - apply Axiom_Scheme in H0; destruct H0, H1, H1.
    apply Axiom_Scheme in H2; destruct H2, H3, H3.
    rewrite H4 in H1; PP H1 a b.
    apply Axiom_SchemeP in H5; destruct H5, H6.
    apply Axiom_SchemeP; repeat split; auto.
    apply Axiom_Scheme in H6; destruct H6 as [_ H6].
    AssE x1; apply Theorem19 in H8.
    rewrite <- H6 in H3; auto.
  - PP H0 a b; apply Axiom_SchemeP in H1; destruct H1, H2.
    apply Axiom_Scheme; split; auto.
    exists (([a]) × y); split; AssE a.
    + apply Axiom_SchemeP; repeat split; auto.
      apply Axiom_Scheme; intros; auto.
    + apply Axiom_Scheme; split.
      * apply Theorem73; split; try apply H; auto.
      * exists a; split; auto.
Qed.

Theorem Theorem74 : forall x y,
  Ensemble x /\ Ensemble y -> Ensemble x × y.
Proof.
  intros; double H; double H0; destruct H0.
  apply Ex_Lemma74 in H; destruct H, H, H3.
  rewrite <- H3 in H0; apply Axiom_Substitution in H0; auto.
  rewrite H4 in H0; apply Axiom_Amalgamation in H0.
  rewrite Lemma74 in H0; auto.
Qed.

Hint Resolve Theorem74 : set.

(* 75 Theorem  If f is a function and domain f is a set, then f is a set. *)

Theorem Theorem75 : forall f,
  Function f /\ Ensemble dom( f ) -> Ensemble f.
Proof.
  intros; destruct H.
  assert (Ensemble ran(f)); try apply Axiom_Substitution; auto.
  assert (Ensemble (dom(f) × ran(f))).
  { apply Theorem74; split; auto. }
  apply Theorem33 with (x:=(dom( f ) × ran( f ))); auto.
  unfold Subclass; intros; rewrite Theorem70 in H3; auto.
  PP H3 a b; rewrite <- Theorem70 in H4; auto; AssE [a,b].
  repeat split; auto; apply Axiom_SchemeP; split; auto.
  generalize (Property_dom a b f H4); intro.
  generalize (Property_ran a b f H4); intro; tauto.
Qed.

Hint Resolve Theorem75 : set.

(* 76 Definition  Exponent y x = { f : f is a function, domain f = x and
   range f ⊂ y }. *)

Definition Exponent y x : Class :=
  \{ λ f, Function f /\ dom( f ) = x /\ ran( f ) ⊂ y \}.

Hint Unfold Exponent : set.

(* 77 Theorem  If x and y are sets so is Exponent y x. *)

Theorem Theorem77 : forall x y,
  Ensemble x /\ Ensemble y -> Ensemble (Exponent y x).
Proof.
  intros; apply Theorem33 with (x:=(pow(x × y))).
  - apply Theorem38; auto; apply Theorem74; auto.
  - unfold Subclass; intros; apply Theorem38.
    + apply Theorem74; auto.
    + apply Axiom_Scheme in H0; destruct H0, H1, H2.
    unfold Subclass; intros; rewrite Theorem70 in H4; auto.
    PP H4 a b; rewrite <- Theorem70 in H5; auto.
    AssE [a,b]; apply Axiom_SchemeP; split; auto.
    generalize (Property_dom a b z H5); intro; rewrite H2 in H7.
    generalize (Property_ran a b z H5); intro.
    unfold Subclass in H3; apply H3 in H8; split; auto.
Qed.

Hint Resolve Theorem77 : set.

(* 78 Definition  f is on x if and only if f is a function and x = domain f. *)

Definition On f x : Prop := Function f /\ dom( f ) = x.

Hint Unfold On : set.

(* 79 Definition  f is to y if and only if f is a function and rang f ⊂ y. *)

Definition To f y : Prop := Function f /\ ran(f) ⊂ y.

Hint Unfold To : set.

(* 80 Definition  f is onto y if and only if f is a function and range f = y. *)

Definition Onto f y : Prop := Function f /\ ran(f) = y.

Hint Unfold Onto : set.

End ElementSet.

Export ElementSet.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (y : natural) (x : natural) : natural :=
  plus lf1 (Succ (mult y x)).


Parameter G : Set.
Parameter mult : G -> G -> G.
Notation "x * y" := (mult x y).
Parameter one : G.
Notation "1" := one.
Parameter inv : G -> G.
Notation "/ x" := (inv x).
Notation "x / y" := (mult x (inv y)).

Axiom mult_assoc : forall x y z, x * (y * z) = (x * y) * z.
Axiom one_unit_l : forall x, 1 * x = x.
Axiom inv_l : forall x, /x * x = 1.

Lemma inv_r : forall x, x * / x = 1.
Proof.
  intros.
  replace (x / x) with (1 * x / x).
  replace (1 * x / x) with (/ x * x * x / x).
  replace (/ x * x * x / x) with (/ / x * (/ x) * x / x).
  replace (/ / x * (/ x) * x / x) with ( / / x * ( / x * x ) / x).
  rewrite inv_l.
  rewrite <-mult_assoc.
  rewrite one_unit_l.
  rewrite inv_l.
  reflexivity.

  rewrite mult_assoc.
  rewrite inv_l.
  rewrite one_unit_l.
  reflexivity.

  rewrite inv_l.
  rewrite one_unit_l.
  rewrite inv_l.
  rewrite one_unit_l.
  reflexivity.

  rewrite inv_l.
  reflexivity.

  rewrite one_unit_l.
  reflexivity.

Qed.

Lemma one_unit_r : forall x, x * 1 = x.
Proof.
  intros.
  replace (x * 1) with (x / x * x).
  rewrite inv_r.
  rewrite one_unit_l.
  reflexivity.

  rewrite <-mult_assoc.
  rewrite inv_l.
  reflexivity.
Qed.


(* Exercise 16 *)

Require Import BenB.

Variable D : Set.
Variables P Q S T : D -> Prop.
Variable R : D -> D -> Prop.

Theorem exercise_016 :
  (forall x : D, P x \/ R x x)
->
    (forall x : D, P x -> (exists y : D, R x y /\ R y x))
  ->
    forall x : D, exists y : D, R x y.
Proof.
imp_i a1.
imp_i a2.
all_i a.
dis_e (P a \/ R a a) a3 a3.
all_e (forall x:D, P x \/ R x x) a.
hyp a1.
exi_e (exists y:D, R a y /\ R y a) b a4.
imp_e (P a).
all_e (forall x:D, P x -> exists y:D, R x y /\ R y x) a.
hyp a2.
hyp a3.
exi_i b.
con_e1 (R b a).
hyp a4.
exi_i a.
hyp a3.
Qed.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (lf1 : natural) (x : natural) : natural :=
  plus y (mult x (Succ y)).


Require Export Logic.

Definition even (n:nat) : Prop :=
  evenb n = true.

Print even.

Inductive ev : nat -> Prop :=
  | ev_0 : ev O
  | ev_SS : forall n : nat, ev n -> ev (S (S n)).

Theorem double_even:
  forall n : nat,
    ev (double n).
Proof.
  intros n.
  induction n as [| n'].
  Case "n = 0".
    simpl. apply ev_0.
  Case "n = S n'".
    simpl.
    apply ev_SS.
    apply IHn'.
Qed.

Theorem ev__even:
  forall n,
    ev n -> even n.
Proof.
  intros n H.
  induction H as [| n' H'].
  Case "E = ev_0".
    unfold even. reflexivity.
  Case "E = ev_SS n' H'".
    unfold even.
    apply IHH'.
Qed.

Theorem l:
  forall n,
    ev n.
Proof.
  intros n.
  induction n.
  Case "0".
    simpl. apply ev_0.
  Case "S n".
    simpl.
Abort.

Theorem ev_sum:
  forall n m,
    ev n -> ev m -> ev (n+m).
Proof.
  intros n m H.
  induction H as [| n' H'].
  Case "ev_0".
    intros H.
    simpl. apply H.
  Case "ev_SS n' H'".
    intros H.
    simpl.
    apply ev_SS.
    apply IHH'.
    apply H.
Qed.

Inductive beautiful : nat -> Prop :=
  b_0 : beautiful 0
| b_3 : beautiful 3
| b_5 : beautiful 5
| b_sum : forall n m, beautiful n -> beautiful m -> beautiful (n+m).

Theorem three_is_beautiful: beautiful 3.
Proof.
  apply b_3.
Qed.

Theorem eight_is_beautiful: beautiful 8.
Proof.
  apply b_sum with (n:=3) (m:=5).
  apply b_3.
  apply b_5.
Qed.

Theorem beautiful_plus_eight:
  forall n,
    beautiful n -> beautiful (8+n).
Proof.
  intros n H.
  apply b_sum with (n:=8) (m:=n).
  apply eight_is_beautiful.
  apply H.
Qed.

Theorem beautiful_plus_zero:
  forall n,
    beautiful n -> beautiful (n + 0).
Proof.
  intros n H.
  apply b_sum with (n:=n) (m:=0).
  apply H.
  apply b_0.
Qed.

Theorem b_times2:
  forall n,
    beautiful n -> beautiful (2 * n).
Proof.
  intros n H.
  simpl.
  apply b_sum with (n:=n) (m:=n+0).
  apply H.
  apply beautiful_plus_zero.
  apply H.
Qed.

Theorem beautiful_times_zero:
  forall n,
    beautiful 0 -> beautiful (n * 0).
Proof.
  intros n H.
  induction n as [| n].
    simpl.
    apply b_0.

    simpl.
    apply IHn.
Qed.

Theorem b_timesm:
  forall n m,
    beautiful n -> beautiful (m * n).
Proof.
  intros n m H.
  generalize dependent n.
  induction m as [| m'].
  Case "m = 0".
    intros n H.
    simpl.
    apply b_0.
  Case "m = S m'".
    intros n H.
    simpl.

    apply b_sum with (n:=n) (m:=m' * n).
      apply H.

      apply IHm'. apply H.
Qed.

Inductive gorgeous : nat -> Prop :=
  g_0 : gorgeous 0
| g_plus3 : forall n, gorgeous n -> gorgeous (3+n)
| g_plus5 : forall n, gorgeous n -> gorgeous (5+n).

Theorem gorgeous_plus13:
  forall n,
    gorgeous n -> gorgeous (13+n).
Proof.
  intros n H.
  induction n as [| n'].
  Case "n = 0".
    simpl.
    apply g_plus5 with (n:=8).
    apply g_plus5 with (n:=3).
    apply g_plus3 with (n:=0).
    apply H.
  Case "n = S n'".
    apply g_plus5 with (n:=8 + S n').
    apply g_plus5 with (n:=3 + S n').
    apply g_plus3 with (n:=S n').
    apply H.
Qed.


(* Exercise 107 *)

Require Import BenB.

Variables A B C D : Prop.

(* de Morgan's conjunction law variant *)

Theorem exercise_107 : ~(A /\ B) -> ~~ (~A \/ ~B).
Proof.
imp_i a1.
neg_i (A /\ B) a2.
hyp a1.
con_i.
neg_e' (~A \/ ~B) a3.
hyp a2.
dis_i1.
hyp a3.
neg_e' (~A \/ ~B) a3.
hyp a2.
dis_i2.
hyp a3.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.micromega.Lia.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.Tactics.BreakMatch.
Local Open Scope Z_scope.

Module Z.
  Lemma mul_split_at_bitwidth_mod bw x y : fst (Z.mul_split_at_bitwidth bw x y)  = (x * y) mod 2^bw.
  Proof.
    unfold Z.mul_split_at_bitwidth, LetIn.Let_In; break_innermost_match; Z.ltb_to_lt; try reflexivity;
      apply Z.land_ones; lia.
  Qed.
  Lemma mul_split_at_bitwidth_div bw x y : snd (Z.mul_split_at_bitwidth bw x y)  = (x * y) / 2^bw.
  Proof.
    unfold Z.mul_split_at_bitwidth, LetIn.Let_In; break_innermost_match; Z.ltb_to_lt; try reflexivity;
      apply Z.shiftr_div_pow2; lia.
  Qed.
  Lemma mul_split_mod s x y : fst (Z.mul_split s x y)  = (x * y) mod s.
  Proof.
    unfold Z.mul_split; break_match; Z.ltb_to_lt;
      [ rewrite mul_split_at_bitwidth_mod; congruence | reflexivity ].
  Qed.
#[global]
  Hint Rewrite mul_split_mod : to_div_mod.
  Lemma mul_split_div s x y : snd (Z.mul_split s x y)  = (x * y) / s.
  Proof.
    unfold Z.mul_split; break_match; Z.ltb_to_lt;
      [ rewrite mul_split_at_bitwidth_div; congruence | reflexivity ].
  Qed.
#[global]
  Hint Rewrite mul_split_div : to_div_mod.

  Lemma mul_high_div s x y : Z.mul_high s x y = (x * y) / s.
  Proof. cbv [Z.mul_high]; now apply mul_split_div. Qed.
#[global]
  Hint Rewrite mul_high_div : to_div_mod.

  Lemma mul_split_high s x y : snd (Z.mul_split s x y) = Z.mul_high s x y.
  Proof. reflexivity. Qed.
End Z.


Require Import Bool List Arith Bool_nat.
Set Implicit Arguments.

(** * Typed Expressions *)

(** In this section, we will build on the initial example by adding additional expression forms that depend on static typing of terms for safety. *)

(** ** Source Language *)

Inductive type : Set := Tint | Tbool.

Inductive tbinop : type -> type -> type -> Set :=
| TPlus : tbinop Tint Tint Tint
| TTimes : tbinop Tint Tint Tint
| TEq : forall t, tbinop t t Tbool
| TLt : tbinop Tint Tint Tbool.

Inductive texp : type -> Set :=
| TNConst : nat -> texp Tint
| TBConst : bool -> texp Tbool
| TBinop : forall t1 t2 t, tbinop t1 t2 t -> texp t1 -> texp t2 -> texp t.

Definition typeDenote (t : type) : Set :=
  match t with
    | Tint => nat
    | Tbool => bool
  end.

Definition tbinopDenote arg1 arg2 res (b : tbinop arg1 arg2 res)
  : typeDenote arg1 -> typeDenote arg2 -> typeDenote res :=
  match b in tbinop arg1 arg2 res with
    | TPlus => plus
    | TTimes => mult
    | TEq Tint => beq_nat
    | TEq Tbool => eqb
    | TLt => leb
  end.

Fixpoint texpDenote t (e : texp t) : typeDenote t :=
  match e with
    | TNConst n => n
    | TBConst b => b
    | TBinop b e1 e2 => (tbinopDenote b) (texpDenote e1) (texpDenote e2)
  end.

Eval simpl in texpDenote (TNConst 42).
(** [= 42 : typeDenote Tint] *)

(* begin hide *)
Eval simpl in texpDenote (TBConst false).
(* end hide *)
Eval simpl in texpDenote (TBConst true).
(** [= true : typeDenote Tbool] *)

Eval simpl in texpDenote (TBinop TTimes (TBinop TPlus (TNConst 2) (TNConst 2))
  (TNConst 7)).
(** [= 28 : typeDenote Tint] *)

Eval simpl in texpDenote (TBinop (TEq Tint) (TBinop TPlus (TNConst 2) (TNConst 2))
  (TNConst 7)).
(** [= false : typeDenote Tbool] *)

Eval simpl in texpDenote (TBinop TLt (TBinop TPlus (TNConst 2) (TNConst 2))
  (TNConst 7)).
(** [= true : typeDenote Tbool] *)

(** ** Target Language *)

Definition tstack := list type.

Inductive tinstr : tstack -> tstack -> Set :=
| TiNConst : forall s, nat -> tinstr s (Tint :: s)
| TiBConst : forall s, bool -> tinstr s (Tbool :: s)
| TiBinop : forall arg1 arg2 res s,
  tbinop arg1 arg2 res
  -> tinstr (arg1 :: arg2 :: s) (res :: s).

Inductive tprog : tstack -> tstack -> Set :=
| TNil : forall s, tprog s s
| TCons : forall s1 s2 s3,
  tinstr s1 s2
  -> tprog s2 s3
  -> tprog s1 s3.

Fixpoint vstack (ts : tstack) : Set :=
  match ts with
    | nil => unit
    | t :: ts' => typeDenote t * vstack ts'
  end%type.

Definition tinstrDenote ts ts' (i : tinstr ts ts') : vstack ts -> vstack ts' :=
  match i with
    | TiNConst _ n => fun s => (n, s)
    | TiBConst _ b => fun s => (b, s)
    | TiBinop _ b => fun s =>
      let '(arg1, (arg2, s')) := s in
        ((tbinopDenote b) arg1 arg2, s')
  end.

Fixpoint tprogDenote ts ts' (p : tprog ts ts') : vstack ts -> vstack ts' :=
  match p with
    | TNil _ => fun s => s
    | TCons i p' => fun s => tprogDenote p' (tinstrDenote i s)
  end.

(** ** Translation *)

Fixpoint tconcat ts ts' ts'' (p : tprog ts ts') : tprog ts' ts'' -> tprog ts ts'' :=
  match p with
    | TNil _ => fun p' => p'
    | TCons i p1 => fun p' => TCons i (tconcat p1 p')
  end.

Fixpoint tcompile t (e : texp t) (ts : tstack) : tprog ts (t :: ts) :=
  match e with
    | TNConst n => TCons (TiNConst _ n) (TNil _)
    | TBConst b => TCons (TiBConst _ b) (TNil _)
    | TBinop b e1 e2 => tconcat (tcompile e2 _)
      (tconcat (tcompile e1 _) (TCons (TiBinop _ b) (TNil _)))
  end.

Eval simpl in tprogDenote (tcompile (TNConst 42) nil) tt.
(** [= (42, tt) : vstack (Tint :: nil)] *)

Eval simpl in tprogDenote (tcompile (TBConst true) nil) tt.
(** [= (true, tt) : vstack (Tbool :: nil)] *)

Eval simpl in tprogDenote (tcompile (TBinop TTimes (TBinop TPlus (TNConst 2)
  (TNConst 2)) (TNConst 7)) nil) tt.
(** [= (28, tt) : vstack (Tint :: nil)] *)

Eval simpl in tprogDenote (tcompile (TBinop (TEq Tint) (TBinop TPlus (TNConst 2)
  (TNConst 2)) (TNConst 7)) nil) tt.
(** [= (false, tt) : vstack (Tbool :: nil)] *)

Eval simpl in tprogDenote (tcompile (TBinop TLt (TBinop TPlus (TNConst 2) (TNConst 2))
  (TNConst 7)) nil) tt.
(** [= (true, tt) : vstack (Tbool :: nil)] *)

(** %\smallskip{}%The compiler seems to be working, so let us turn to proving that it _always_ works. *)

(** ** Translation Correctness *)

(** Again, we need to strengthen the theorem statement so that the induction will go through.  This time, to provide an excuse to demonstrate different tactics, I will develop an alternative approach to this kind of proof, stating the key lemma as: *)
(* We need an analogue to the [app_assoc_reverse] theorem that we used to rewrite the goal in the last section.  We can abort this proof and prove such a lemma about [tconcat].
*)

Lemma tconcat_correct : forall ts ts' ts'' (p : tprog ts ts') (p' : tprog ts' ts'')
  (s : vstack ts),
  tprogDenote (tconcat p p') s
  = tprogDenote p' (tprogDenote p s).
Proof.
  induction p; intros.
  * reflexivity.
  * intros.
    simpl.
    apply IHp.
Qed.

Lemma tcompile_correct' : forall t (e : texp t) ts (s : vstack ts),
  tprogDenote (tcompile e ts) s = (texpDenote e, s).
Proof.
  induction e; intros; try reflexivity.
  * simpl.
    rewrite tconcat_correct.
    rewrite tconcat_correct.
    rewrite IHe1.
    rewrite IHe2.
    reflexivity.
Qed.

Theorem tcompile_correct : forall t (e : texp t),
  tprogDenote (tcompile e nil) tt = (texpDenote e, tt).
Proof.
  intros.
  apply (tcompile_correct' e nil tt).
Qed.

Extraction tcompile.

(* End: *)


Theorem id: forall A:Prop, A -> A.
Proof.
  exact (fun A:Prop => fun x:A => x).
Qed.

Theorem id2: forall A:Prop, A -> A.
Proof.
  intros.
  exact H.
Qed.

Theorem syllogism: forall A B:Prop,
  A->((A->B)->B).
Proof.
  intros.
  apply H0.
  apply H.
Qed.

Theorem cap: forall A B:Prop,
  (A/\B)->A.
Proof.
  intros.
  apply H.
Qed.

Section contraposition.

Hypothesis classical:forall A:Prop,
  ~~A->A.

Theorem contraposition1: forall A B:Prop,
  (A->B)->(~B->~A).
Proof.
  intros A B ab notb a.
  apply notb.
  apply ab.
  apply a.
Qed.

Theorem contraposition2: forall A B:Prop,
  (~B->~A)->(A->B).
Proof.
  intros A B nbna a.
  apply classical.
  intros nb.
  apply nbna.
  apply nb.
  apply a.
Qed.

End contraposition.

Section contraposition'.
Hypothesis classical':forall A:Prop,
  A\/~A.

Theorem contraposition2':forall A B:Prop,
  (~B->~A)->(A->B).
Proof.
  intros A B nbna a.
  destruct (classical' B) as [b|nb].
  -apply b.
  -elimtype False.
  apply nbna.
  apply nb.
  apply a.
Qed.

End contraposition'.

Theorem dnot: forall A:Prop,
  A->~~A.
Proof.
  intros A a na.
  apply na.
  apply a.
Qed.

Theorem final: forall A:Prop,
  ~~(A\/~A).
Proof.
  intros A naorna.
  apply naorna.
  right.
  intros a.
  apply naorna.
  left.
  apply a.
Qed.

Inductive mynat: Set:=
  Z:mynat
  | S:mynat -> mynat.

Fixpoint plus (m n:mynat){struct m}:mynat:=
  match m with
    Z=>n
    | S m' => S(plus m' n)
  end.
Compute plus (S Z) (S Z).


From Coq Require Import Reals.

(** * Real number utility lemmas *)

(** This lemma is needed in fault_weight_state_backwards **)
Lemma Rplusminus_assoc : forall r1 r2 r3,
  (r1 + r2 - r3)%R = (r1 + (r2 - r3))%R.
Proof.
  intros. unfold Rminus.
  apply Rplus_assoc.
Qed.

(** This lemma is needed in fault_weight_state_sorted_subset **)
Lemma Rplusminus_assoc_r : forall r1 r2 r3,
  (r1 - r2 + r3)%R = (r1 + (- r2 + r3))%R.
Proof.
  intros. unfold Rminus.
  apply Rplus_assoc.
Qed.

(** This lemma is needed in fault_weight_state_sorted_subset **)
Lemma Rplus_opp_l : forall r, (Ropp r + r)%R = 0%R.
Proof.
  intros.
  rewrite Rplus_comm.
  apply Rplus_opp_r.
Qed.

(** This lemma is needed in fault_weight_state_sorted_subset **)
Lemma Rplus_ge_reg_neg_r : forall r1 r2 r3,
  (r2 <= 0)%R -> (r3 <= r1 + r2)%R -> (r3 <= r1)%R.
Proof.
  intros.
  apply Rge_le.
  apply Rle_ge in H.
  apply Rle_ge in H0.
  apply (Rplus_ge_reg_neg_r r1 r2 r3 H H0).
Qed.

(** This lemma is needed in fault_weight_state_sorted_subset **)
Lemma Rminus_lt_r : forall r1 r2,
  (0 <= r2)%R -> (r1 - r2 <= r1)%R.
Proof.
  intros.
  rewrite <- Rplus_0_r.
  unfold Rminus.
  apply Rplus_le_compat_l.
  apply Rge_le.
  apply Ropp_0_le_ge_contravar.
  assumption.
Qed.

Lemma Rminus_lt_r_strict : forall r1 r2,
  (0 < r2)%R -> (r1 - r2 <= r1)%R.
Proof.
  intros.
  rewrite <- Rplus_0_r.
  unfold Rminus.
  apply Rplus_le_compat_l.
  apply Rge_le.
  apply Ropp_0_le_ge_contravar.
  apply Rlt_le in H.
  assumption.
Qed.

Lemma Rtotal_le_gt : forall x y,
  (x <= y)%R \/ (x > y)%R.
Proof.
  intros.
  destruct (Rtotal_order x y) as [Hlt | [Heq | Hgt]].
  - left. unfold Rle. left. assumption.
  - left. unfold Rle. right. assumption.
  - right. assumption.
Qed.


(**
フィボナッチ数列の和
========================

@suharahiromichi

2020/07/01

2020/07/02 構成をみなおした。

2020/07/03 総和を0からにした。
*)

From mathcomp Require Import all_ssreflect.
Require Import ssromega.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**
# はじめに

フィボナッチ ffibonacci 数列の和はいくつかのおもしろい性質があります（文献[1]）。
どれも、中学の数学で証明できるものですが、
ここでは、``Σ``の定義と関連する
補題を含む MathComp の bigop.v ライブラリ（文献[3][4]）を使って証明してみましょう。

扱う数は、0以上の整数だけとします。

このファイルは、以下にあります。

https://github.com/suharahiromichi/coq/blob/master/math/ssr_fib_sum.v

また、

https://github.com/suharahiromichi/coq/blob/master/common/ssromega.v

も必要です。
 *)

(**
# Σの補題

bigop.v は、モノイド則の成り立つ演算子と単位元に対して、繰返し演算を提供するものです。
自然数の加算 addn と 0 に対応するのが ``Σ`` (``sum``) ですが、
補題は繰返し演算(``big``)の一般で示されているので、必要なもを探すのが大変です。

今回は、もっぱら``Σ``を通して bigop.v に慣れることを目標にしますから、
煩瑣になりますが、``Σ``についてだけの補題を証明して置きます。
慣れたならば、直接 bigop.v の補題を使うほうがよいかもしれません。

なお、本節において $a_n$ は任意の数列の項を示します（フィボナッチ数列に
限定しません）。
 *)

Section Summation.
(**
## 総和の結合と分配

高校で習う、総和についての公式です。

総和の範囲は、$m \lt n$ としてmからnとします。
$m \ge n$ の場合は、Σの中身が単位元となり成立しません。

```math

\sum_{i=m}^{n-1}a_i + \sum_{i=m}^{n-1}b_i = \sum_{i=m}^{n-1}(a_i + b_i) \\

\sum_{i=m}^{n-1}c a_i = c \sum_{i=m}^{n-1}a_i \\

\sum_{i=m}^{n-1}(a_i c) = (\sum_{i=m}^{n-1}a_i) c \\

```
*)
  Lemma sum_split m n a b :
    m < n ->
    \sum_(m <= i < n)(a i) + \sum_(m <= i < n)(b i) = \sum_(m <= i < n)(a i + b i).
  Proof. by rewrite big_split. Qed.

  Lemma sum_distrr m n c a :
    m < n ->
    \sum_(m <= i < n)(c * (a i)) = c * (\sum_(m <= i < n)(a i)).
  Proof. by rewrite big_distrr. Qed.

  Lemma sum_distrl m n a c :
    m < n ->
    \sum_(m <= i < n)((a i) * c) = (\sum_(m <= i < n)(a i)) * c.
  Proof. by rewrite big_distrl. Qed.

(**
## 0を取り出す。

$$ \sum_{i \in \emptyset}a_i = 0 $$

総和をとる範囲が無い場合（0以上0未満）は、単位元``0``になります。
 *)
  Lemma sum_nil' a : \sum_(0 <= i < 0)(a i) = 0.
  Proof.
      by rewrite big_nil.
  Qed.

(**
上記の補題は、1以上1未満などの場合にも適用できてしまいますが、任意のmとnで証明しておきます。
*)
  Lemma sum_nil m n a : n <= m -> \sum_(m <= i < n)(a i) = 0.
  Proof.
    move=> Hmn.
    have H : \sum_(m <= i < n)(a i) = \sum_(i <- [::])(a i).
    - apply: congr_big => //=.
      rewrite /index_iota.
      have -> : n - m = 0 by ssromega. (* apply/eqP; rewrite subn_eq0. *)
      done.
    - rewrite H.
        by rewrite big_nil.
  Qed.

(**
## ``a n``項を取り出す。

$$ \sum_{i=n}^{n}a_i = a_n $$

総和をとる範囲がひとつの項の場合（n以上n以下）は、``a n`` となります。
 *)
  Lemma sum_nat1 n a :
    \sum_(n <= i < n.+1)(a i) = a n.
  Proof. by rewrite big_nat1. Qed.

(**
## 総和の範囲を0起源に振りなおす。

項のインデックスを調整して（ずらして）、mからn+mまでの総和の範囲を0からnまでにします。

$$ \sum_{i=m}^{n+m-1}a_i = \sum_{i=0}^{n-1}a_{i+m} $$
 *)
  Lemma sum_addn (m n : nat) a :
    \sum_(m <= i < n + m)(a i) = \sum_(0 <= i < n)(a (i + m)).
  Proof.
    rewrite -{1}[m]add0n.
    rewrite big_addn.
    have -> : n + m - m = n by ssromega.
    done.
  Qed.

(**
これは、任意のmで成り立ちますが、``Σ``の中の項のインデックスの``i.+1``を
``i + 1`` に書き換えられないため、``i.+1`` と ``i.+2`` の場合については、
個別に用意する必要があります。実際はこちらの方を使います。
*)
  Lemma sum_add1 n a :
    \sum_(1 <= i < n.+1)(a i) = \sum_(0 <= i < n)(a i.+1).
  Proof. by rewrite big_add1 succnK. Qed.

  Lemma sum_add2 n a :
    \sum_(2 <= i < n.+2)(a i) = \sum_(0 <= i < n)(a i.+2).
  Proof. by rewrite 2!big_add1 2!succnK. Qed.

(**
## 最初の項をΣの外に出す。

$$ \sum_{i=m}^{n-1}a_i = a_m + \sum_{i=m+1}^{n-1}a_i $$
 *)
  Lemma sum_first m n a :
    m < n ->
    \sum_(m <= i < n)(a i) = a m + \sum_(m.+1 <= i < n)(a i).
  Proof.
    move=> Hn.
      by rewrite big_ltn.
  Qed.

(**
総和の範囲の起点を変えずに、インデックスをずらす補題もあります。

$$ \sum_{i=m}^{n}a_i = a_m + \sum_{i=m}^{n-1}a_{i + 1} $$
*)
  Lemma sum_first' m n a :
    m <= n ->
    \sum_(m <= i < n.+1)(a i) = a m + \sum_(m <= i < n)(a i.+1).
  Proof.
    move=> Hn.
      by rewrite big_nat_recl.
  Qed.

(**
## 最後の項をΣの外に出す。

$$ \sum_{i=m}^{n}a_i = \sum_{i=m}^{n-1}a_i + a_n $$
 *)
  Lemma sum_last m n a :
    m <= n ->
    \sum_(m <= i < n.+1)(a i) = \sum_(m <= i < n)(a i) + a n.
  Proof.
    move=> Hmn.
      by rewrite big_nat_recr.
  Qed.
End Summation.

Section Fib_1.
(**
# フィボナッチ fibonacci 数列の定義

フィボナッチ数列 $ a_n $ を index についての関数として定義します。

```math

\begin{eqnarray}
F_0 &=& 0 \\
F_1 &=& 1 \\
F_n &=& F_{n - 2} + F_{n - 1} \\
\end{eqnarray}

```

フィボナッチ数列の定義そのままなので、再帰関数になります。

*)
  Fixpoint fib n : nat :=
    match n with
    | 0 => 0
    | 1 => 1
    | (m.+1 as n).+1 => fib m + fib n (* fib n.-2 + fib n.-1 *)
    end.

(**
# 簡単な補題

定義から導かれる補題を証明しておきます。
*)
  Lemma fib_n n : fib n.+2 = fib n + fib n.+1.
  Proof. done. Qed.

  Lemma fibn1_ge_1 n : 1 <= fib n.+1.
  Proof.
    elim: n => // n IHn.
    rewrite fib_n.
    rewrite addn_gt0.
      by apply/orP/or_intror.
  Qed.

  Lemma fibn2_ge_1 n : 1 <= fib n.+2.
  Proof.
    elim: n => // n IHn.
    rewrite fib_n.
    rewrite addn_gt0.
      by apply/orP/or_intror.
  Qed.

(**
# フィボナッチ数列の性質

定理は、概ね文献[2]にそいます。n は $ 0 \le n $ の自然数として、
総和の範囲は 0 から n とします（$ \sum_{i=0}^{n}a_i $）。
MathCompでは ``\sum_(0 <= i < n.+1)(a i)`` となります。

$F_0 = 0$なので、1からの総和でも結果に変わりがないのですが（奇数の和をのぞく）、
nに対する数学的帰納法を使うときなどで、$n=0$の
場合に、$\sum_{i=0}^{0}a_i = a_0$ であるようにすると気持ちがよいからです。

1からの場合は、(1から0の)空の総和となり、$\sum_{i=1}^{0}a_i = 0$
と単位元になってしまいます（それでも、成立する場合があります）。
*)

(**
## 性質0 (数列の和の加算)

$$ \sum_{i=0}^{n}F_i + \sum_{i=0}^{n}F_{i+1} = \sum_{i=0}^{n}F_{i+2} $$
*)
  Lemma add_of_sum_of_seq_of_fib n :
    \sum_(0 <= i < n.+1)(fib i) + \sum_(0 <= i < n.+1)(fib i.+1) =
    \sum_(0 <= i < n.+1)(fib i.+2).
  Proof. by rewrite sum_split. Qed.

(**
## 性質1 (フィボナッチ数列の和)

$$ \sum_{i=0}^{n}F_i = F_{n+2} - 1 $$
 *)
  Lemma sum_of_seq_of_fib n :
    \sum_(0 <= i < n.+1)(fib i) = fib n.+2 - 1.
  Proof.
    have H := add_of_sum_of_seq_of_fib n.
    rewrite -sum_add1 -sum_add2 in H.
    rewrite [\sum_(1 <= i < n.+2)(fib i)]sum_first in H; last done.
    rewrite [\sum_(2 <= i < n.+3)(fib i)]sum_last in H; last done.
    rewrite addnA in H.
    rewrite [\sum_(2 <= i < n.+2) fib i + fib n.+2]addnC in H.

    (* 前提 H の両辺の共通項を消す。 *)
    move/eqP in H.
    rewrite eqn_add2r in H.
    move/eqP in H.

    rewrite -H.
    rewrite [fib 1]/=.
      by ssromega.                   (* rewrite addn1 subn1 succnK. *)
  Qed.

(**
別証明として、n についての数学的帰納法で解いてみます。

こちらのほうが随分簡単そうなので、
以降の性質も帰納法で証明してみます。
 *)
  Lemma sum_of_seq_of_fib' n :
    \sum_(0 <= i < n.+1)(fib i) = fib n.+2 - 1.
  Proof.
    elim: n => [| n IHn].
    - by rewrite sum_nat1.
    - rewrite sum_last; last done.
      rewrite IHn.
      rewrite addnBAC; last by rewrite fibn2_ge_1.
      congr (_ - _).
        by rewrite addnC.
  Qed.

(**
## 性質2 (二乗の和)

$$ \sum_{i=0}^{n}(F_i)^2 = F_{n} F_{n + 1} $$

*)
  Lemma sum_of_seq_of_sqr_of_fib n :
    \sum_(0 <= i < n.+1)((fib i)^2) = fib n * fib n.+1.
  Proof.
    elim: n => [| n IHn].
    - by rewrite sum_nat1.
    - rewrite sum_last; last done.
      rewrite IHn.
      rewrite -mulnDl.
      rewrite mulnC.
        by congr (_ * _).
  Qed.

(**
## 性質3 (奇数の和)

これは、0からの総和と、1からの総和で結果が異なるので、両方証明しておきます。

```math

\sum_{i=0}^{n-1}F_{2 i + 1} = F_{2n} \\

\sum_{i=1}^{n}F_{2 i - 1} = F_{2n}
```

*)
  Lemma sum_of_seq_of_odd_index_of_fib n :
    \sum_(0 <= i < n)(fib i.*2.+1) = fib n.*2.
    elim: n => [| n IHn].
    - by rewrite sum_nil.
    - have -> : n.+1.*2 = n.*2.+2
        by rewrite -addn1 -!muln2; ssromega.
      rewrite fib_n.                        (* 右辺 *)
      rewrite sum_last; last done.          (* 左辺 *)
      rewrite IHn.
        by congr (_ + _).
  Qed.

  Lemma sum_of_seq_of_odd_index_of_fib' n :
    \sum_(1 <= i < n.+1)(fib i.*2.-1) = fib n.*2.
  Proof.
    elim: n => [| n IHn].
    - by rewrite sum_nil.
    - have -> : n.+1.*2 = n.*2.+2
        by rewrite -addn1 -!muln2; ssromega.
      rewrite fib_n.                        (* 右辺 *)
      rewrite sum_last; last done.          (* 左辺 *)
      rewrite IHn.
        by congr (_ + _).
  Qed.

(**
## 性質4 (偶数の和)

$$ \sum_{i=0}^{n}F_{2 i} = F_{2 n + 1} - 1 $$

*)
  Lemma l_sum_of_seq_of_even_index_of_fib n :
    \sum_(0 <= i < n.+1)(fib i.*2) + 1 = fib n.*2.+1.
  Proof.
    elim: n => [| n IHn].
    - by rewrite sum_nat1.
    - have H : n.+1.*2 = n.*2.+2
        by rewrite doubleS; ssromega.
      (* rewrite -addn1 -!muln2 addn1 2!muln2 doubleS. *)

      (* 右辺 *)
      rewrite H !fib_n -{1}IHn -addnA -fib_n.
      rewrite [1 + fib n.*2.+2]addnC.

      (* 左辺 *)
      rewrite sum_last; last done.
      rewrite -H -addnA.
      done.
  Qed.

  Lemma sum_of_seq_of_even_index_of_fib n :
    \sum_(0 <= i < n.+1)(fib i.*2) = fib n.*2.+1 - 1.
  Proof.
    rewrite -l_sum_of_seq_of_even_index_of_fib.
      by rewrite addn1 subn1 -pred_Sn.
  Qed.

(**
# おまけ

## 性質5 (となりどうしのフィボナッチ数列は互いに素である)
 *)
  Lemma coprime_cons_fibs n : coprime (fib n) (fib n.+1).
  Proof.
    rewrite /coprime.
    elim: n => [//= | n IHn].
    rewrite fib_n.
      by rewrite gcdnDr gcdnC.
  Qed.
End Fib_1.

(**
# 文献

[1] フィボナッチ数列と中学入試問題

http://www.suguru.jp/Fibonacci/

[2] ProofWiki
- https://proofwiki.org/wiki/Sum_of_Sequence_of_Fibonacci_Numbers
- https://proofwiki.org/wiki/Sum_of_Sequence_of_Squares_of_Fibonacci_Numbers
- https://proofwiki.org/wiki/Sum_of_Sequence_of_Odd_Index_Fibonacci_Numbers
- https://proofwiki.org/wiki/Sum_of_Sequence_of_Even_Index_Fibonacci_Numbers
- https://proofwiki.org/wiki/Consecutive_Fibonacci_Numbers_are_Coprime

[3] 萩原学 アフェルト・レナルド、「Coq/SSReflect/MathCompによる定理証明」、森北出版

[4] Reynald Affeldt, cheat sheet bigop.v

https://staff.aist.go.jp/reynald.affeldt/ssrcoq/bigop_doc.pdf
*)

(* END *)


Require Import List Relations ZArith Lia Program ssreflect.

Section Maximum.
  Variable A : Set.
  Variable max : A -> A -> A.
  Definition maximum x xs := fold_left max xs x.

  Hypothesis max_select : forall x y, max x y = x \/ max x y = y.

  Theorem maximum_select : forall xs x, In (maximum x xs) (x :: xs).
  Proof.
    elim => /= [ | x ? IH x' ]; eauto.
    case (max_select x' x) => ->; [ case (IH x') | case (IH x) ]; eauto.
  Qed.

  Variable le : relation A.
  Hypothesis le_refl : forall x, le x x.
  Hypothesis le_trans : forall x y z, le x y -> le y z -> le x z.
  Hypothesis max_left : forall x y, le x (max x y).
  Hypothesis max_right : forall x y, le y (max x y).

  Theorem maximum_join : forall xs x y, In y (x :: xs) -> le y (maximum x xs).
  Proof.
    elim => /= [ ? ? [ -> | [ ] ] | x xs IHxs x' y [ -> | [ -> | ] ] ]; eauto.
  Qed.

  Definition maximum_spec x xs := conj (maximum_select xs x) (maximum_join xs x).

  Definition maximum_concrete x xs :
    fold_left max xs x = maximum x xs := eq_refl.
End Maximum.

Section ZMaximum.
  Local Open Scope Z_scope.

  Definition Zmaximum := maximum _ Z.max.
  Definition Zminimum := maximum _ Z.min.

  Corollary Zmaximum_spec : forall x xs,
    (In (Zmaximum x xs) (x :: xs)) /\
    (forall y, In y (x :: xs) -> y <= Zmaximum x xs).
  Proof. by apply /maximum_spec; lia. Qed.

  Corollary Zminimum_spec : forall x xs,
    In (Zminimum x xs) (x :: xs) /\
    (forall y, In y (x :: xs) -> y >= Zminimum x xs).
  Proof. by apply /maximum_spec; lia. Qed.

  Corollary neg_Zmaximum_distr x xs :
    - Zmaximum x xs = Zminimum (- x) (map Z.opp xs).
  Proof.
    case (Zmaximum_spec x xs) => HmaxIn Hmax.
    case (Zminimum_spec (- x) (map Z.opp xs)) => HminIn Hmin.
    have /Hmin : In (- Zmaximum x xs) (map Z.opp (x :: xs)) by apply /in_map.
    have : In (- Zminimum (- x) (map Z.opp xs)) (map Z.opp (map Z.opp (x :: xs))) by apply /in_map.
    rewrite map_map (map_ext (fun x => - - x) id) /id ?map_id => [ | /Hmax ]; lia.
  Qed.

  Corollary neg_Zminimum_distr x xs :
    - Zminimum x xs = Zmaximum (- x) (map Z.opp xs).
  Proof.
    have -> : Zminimum x xs = Zminimum (- - x) (map Z.opp (map Z.opp xs)).
    { congr (Zminimum _ _).
      - by lia.
      - rewrite map_map -(map_ext id) ?map_id // /id. by lia. }
    rewrite -neg_Zmaximum_distr. by lia.
  Qed.

  Corollary Zmaximum_concrete : forall x xs,
    fold_left Z.max xs x = Zmaximum x xs.
  Proof. exact /maximum_concrete. Qed.
End ZMaximum.

Section MinMax.
  Local Open Scope Z_scope.

  Variable board : Set.
  Variable succ : board -> list board.
  Variable eval : board -> Z.

  Fixpoint minimax b n :=
    match n with
    | O => eval b
    | S n =>
        match succ b with
        | nil => eval b
        | b :: bs =>
            Zmaximum
              (minimax' b n)
              (map (fun b => minimax' b n) bs)
        end
    end
  with minimax' b n :=
    match n with
    | O => eval b
    | S n =>
        match succ b with
        | nil => eval b
        | b :: bs =>
            Zminimum
              (minimax b n)
              (map (fun b => minimax b n) bs)
        end
    end.

  Fixpoint negmax (turn : bool) b n :=
    match n with
    | O =>
        if turn then eval b
        else - eval b
    | S n =>
        match succ b with
        | nil =>
            if turn then eval b
            else - eval b
        | b :: bs =>
            Zmaximum
              (- negmax (negb turn) b n)
              (map Z.opp (map (fun b => negmax (negb turn) b n) bs))
        end
    end.

  Theorem negmax_corresponds_minimax : forall n b turn,
    negmax turn b n = if turn then minimax b n else - minimax' b n.
  Proof.
    elim => /= [ ? [ ] | ? IH b [ ] ] //; case (succ b) => // ? ?.
    - rewrite map_map.
      congr (Zmaximum _ _); [ | apply /map_ext => ? ]; rewrite IH /=; by lia.
    - rewrite -neg_Zminimum_distr.
      congr (- Zminimum _ _); [ | apply /map_ext => ? ]; rewrite IH /=; by lia.
  Qed.

  Definition Zmaximum_with_alpha {A} alphabeta alpha beta := (fix Zmaximum_with_alpha alpha (xs : list A) :=
    match xs with
    | nil => alpha
    | x :: xs =>
        let value := alphabeta alpha x in
        match Z_le_dec beta value with
        | left _ => value
        | right _ => Zmaximum_with_alpha (Z.max alpha value) xs
        end
    end) alpha.

  Lemma Zmaximum_with_alpha_spec_aux A minimax alphabeta beta
    (Halphabeta_spec : forall alpha (x : A),
      alpha < beta ->
      minimax x <= alpha /\ alphabeta alpha x <= alpha \/
      alpha <= minimax x /\ minimax x = alphabeta alpha x /\ minimax x < beta \/
      beta <= minimax x /\ beta <= alphabeta alpha x) :
    forall xs alpha,
    alpha < beta ->
    fold_left Z.max (map minimax xs) alpha = Zmaximum_with_alpha alphabeta alpha beta xs /\
    fold_left Z.max (map minimax xs) alpha < beta \/
    beta <= fold_left Z.max (map minimax xs) alpha /\ beta <= Zmaximum_with_alpha alphabeta alpha beta xs.
  Proof.
    elim => /= [ | x xs IH alpha ? ].
    - lia.
    - case (Halphabeta_spec alpha x) => //= [ [ ? ? ] | [ [ ? [ <- ? ] ] | [ ? ? ] ] ].
      + case (Z_le_dec beta (alphabeta alpha x)) => ?; try lia.
        rewrite !Z.max_l; try lia.
        exact /IH.
      + case (Z_le_dec beta (minimax x)) => ?; try lia.
        rewrite !Z.max_r; try lia.
        exact /IH.
      + case (Z_le_dec beta (alphabeta alpha x)) => ?; try lia.
        rewrite Zmaximum_concrete !Z.max_r; try lia.
        move: (proj2 (Zmaximum_spec (minimax x) (map minimax xs)) _ (or_introl eq_refl)).
        lia.
  Qed.

  Corollary Zmaximum_with_alpha_spec A minimax alphabeta alpha beta xs
    (Halphabeta : alpha < beta)
    (Halphabeta_spec : forall alpha (x : A),
      alpha < beta ->
      minimax x <= alpha /\ alphabeta alpha x <= alpha \/
      alpha <= minimax x /\ minimax x = alphabeta alpha x /\ minimax x < beta \/
      beta <= minimax x /\ beta <= alphabeta alpha x) :
    alpha <= Zmaximum alpha (map minimax xs) /\
    Zmaximum alpha (map minimax xs) = Zmaximum_with_alpha alphabeta alpha beta xs /\
    Zmaximum alpha (map minimax xs) < beta \/
    beta <= Zmaximum alpha (map minimax xs) /\ beta <= Zmaximum_with_alpha alphabeta alpha beta xs.
  Proof.
    rewrite -Zmaximum_concrete.
    move: (Zmaximum_with_alpha_spec_aux _ _ _ _ Halphabeta_spec xs _ Halphabeta) => [ ] [ ? ? ]; [ left | right ]; repeat split; eauto.
    rewrite Zmaximum_concrete.
    apply /(proj2 (Zmaximum_spec _ _)). by left.
  Qed.

  Fixpoint alphabeta (turn : bool) alpha beta b n :=
    match n with
    | O =>
        if turn then eval b
        else - eval b
    | S n =>
        match succ b with
        | nil =>
            if turn then eval b
            else - eval b
        | bs =>
            Zmaximum_with_alpha
              (fun alpha b => - alphabeta (negb turn) (- beta) (- alpha) b n)
              alpha beta bs
        end
    end.

  Theorem alphabeta_corresponds_negmax : forall n b beta turn alpha,
    alpha < beta ->
    negmax turn b n <= alpha /\ alphabeta turn alpha beta b n <= alpha \/
    alpha <= negmax turn b n /\
    negmax turn b n = alphabeta turn alpha beta b n /\
    negmax turn b n < beta \/
    beta <= negmax turn b n /\ beta <= alphabeta turn alpha beta b n.
  Proof.
    elim => /= [ | n IHn b beta ]; try lia.
    case (succ b) => [ | b_ bs ] turn alpha ?; try lia.
    rewrite map_map.
    case (Z_lt_dec alpha (Zmaximum (- negmax (negb turn) b_ n) (map (fun b => - negmax (negb turn) b n) bs))) => ?.
    - right.
      have -> : Zmaximum (- negmax (negb turn) b_ n) (map (fun x => - negmax (negb turn) x n) bs) = Zmaximum alpha (map (fun x => - negmax (negb turn) x n) (b_ :: bs)).
      { case (Zmaximum_spec (- negmax (negb turn) b_ n) (map (fun b => - negmax (negb turn) b n) bs)) => HIn1 Hmax1.
        case (Zmaximum_spec alpha (map (fun b => - negmax (negb turn) b n) (b_ :: bs))) => [ [ ? | HIn2 ] Hmax2 ]; have := Hmax2 _ (or_intror HIn1); [ | have := (Hmax1 _ HIn2) ]; lia. }
      { apply /(Zmaximum_with_alpha_spec _ _ (fun alpha b => - alphabeta (negb turn) (- beta) (- alpha) b n) _ beta (b_ :: bs)) => // alpha0 b0 ?.
        case (IHn b0 (- alpha0) (negb turn) (- beta)) => [ | [ ] | [ [ ? [ ] ] | [ ] ] ]; lia. }
    - left.
      have : Zmaximum alpha (map (fun b => - negmax (negb turn) b n) (b_ :: bs)) = alpha.
      { case (Zmaximum_spec (- negmax (negb turn) b_ n) (map (fun b => - negmax (negb turn) b n) bs)) => HIn1 Hmax1.
        case (Zmaximum_spec alpha (map (fun b => - negmax (negb turn) b n) (b_ :: bs))) => [ [ | HIn2 ] Hmax2 ];
        [ | move: (Hmax2 _ (or_intror HIn1)) (Hmax2 _ (or_introl eq_refl)) (Hmax1 _ HIn2) ]; lia. }
      case (Zmaximum_with_alpha_spec _
        (fun b => - negmax (negb turn) b n)
        (fun alpha b => - alphabeta (negb turn) (- beta) (- alpha) b n) alpha beta (b_ :: bs)) => /= [ | alpha0 b0 ? | | ]; try lia.
      case (IHn b0 (- alpha0) (negb turn) (- beta)) => [ | [ ] | [ [ ? [ ] ] | [ ] ] ]; lia.
  Qed.
End MinMax.


Require Import Nat.

Definition task :=
  forall (f : nat -> nat) (n m x : nat),
    iter (m^n) (A:=nat) f x = iter n (A:=nat->nat) (iter m (A:=nat)) f x.


Require Export GeoCoq.Elements.OriginalProofs.lemma_lessthancongruence.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma proposition_03 :
   forall A B C D E F,
   Lt C D A B -> Cong E F A B ->
   exists X, BetS E X F /\ Cong E X C D.
Proof.
intros.
assert (Cong A B E F) by (conclude lemma_congruencesymmetric).
assert (Lt C D E F) by (conclude lemma_lessthancongruence).
let Tf:=fresh in
assert (Tf:exists G, (BetS E G F /\ Cong E G C D)) by (conclude_def Lt );destruct Tf as [G];spliter.
close.
Qed.

End Euclid.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) (z : natural) : natural :=
  plus y (mult x y).


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

Inductive nat : Set :=
| O : nat
| S : nat -> nat.

Inductive natural : Set :=
| Zero : natural
| Succ : natural -> natural.

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (lf1 : natural) (x : natural) : natural :=
  plus (mult lf1 x) lf1.