(** Based on Benjamin Pierce's "Software Foundations" *)

Require Import List.
Import ListNotations.
Require Export Arith Arith.EqNat.
Require Export Id.

From hahn Require Import HahnBase.

Section S.

  Set Implicit Arguments.

  Variable A : Type.

  Definition state := list (id * A).

  Reserved Notation "st / x => y" (at level 0).

  Inductive st_binds : state -> id -> A -> Prop :=
    st_binds_hd : forall st id x, ((id, x) :: st) / id => x
  | st_binds_tl : forall st id x id' x', id <> id' -> st / id => x -> ((id', x')::st) / id => x
  where "st / x => y" := (st_binds st x y).

  Definition update (st : state) (id : id) (a : A) : state := (id, a) :: st.

  Notation "st [ x '<-' y ]" := (update st x y) (at level 0).

  Lemma state_deterministic (st : state) (x : id) (n m : A)
        (SN : st / x => n)
        (SM : st / x => m) :
    n = m.
  Proof.
    induction st; inversion SN; subst; inversion SM; subst; auto; contradiction.
  Qed.

  Lemma update_eq (st : state) (x : id) (n : A) :
    st [x <- n] / x => n.
  Proof.
    unfold  update.
    constructor.
  Qed.

  Lemma update_neq (st : state) (x2 x1 : id) (n m : A)
        (NEQ : x2 <> x1) : st / x1 => m <-> st [x2 <- n] / x1 => m.
  Proof.
    split; unfold  update; try constructor; auto.
    intros. inversion H; subst; try contradiction; auto.
  Qed.

  Lemma update_shadow (st : state) (x1 x2 : id) (n1 n2 m : A) :
    st[x2 <- n1][x2 <- n2] / x1 => m <-> st[x2 <- n2] / x1 => m.
  Proof.
    split.
    {
      unfold  update. intros. inversion H; subst; constructor; auto.
      inversion H6; subst; auto; contradiction.
    }
    unfold  update. intros. inversion H; subst; constructor; auto.
    apply update_neq; auto.
  Qed.

  Lemma update_same (st : state) (x1 x2 : id) (n1 m : A)
        (SN : st / x1 => n1)
        (SM : st / x2 => m) :
    st [x1 <- n1] / x2 => m.
  Proof. destruct (id_eq_dec x1 x2) as [HH | HH]; subst.
    eapply state_deterministic with ( n:=m) in SN.
    {
      subst. apply update_eq.
    }
    auto.
    apply update_neq; auto.
  Qed.

  Lemma update_permute (st : state) (x1 x2 x3 : id) (n1 n2 m : A)
        (NEQ : x2 <> x1)
        (SM : st [x2 <- n1][x1 <- n2] / x3 => m) :
    st [x1 <- n2][x2 <- n1] / x3 => m.
  Proof.
    all: try by (apply update_neq; auto; apply update_eq ).
    inversion SM;subst.
    {
     apply update_neq; auto; apply update_eq.
    }
     inversion H5; subst.
     { apply update_eq. }
     repeat apply update_neq; auto.
  Qed.

End S.


Require Import Coq.Sorting.Permutation.
Require Import Coq.Lists.List.
Require Export Crypto.Util.FixCoqMistakes.
Import ListNotations.
Local Open Scope list_scope.

Module List.
  Lemma partition_permutation A f (ls : list A) xs ys
        (H : @partition A f ls = (xs, ys))
    : Permutation (xs ++ ys) ls.
  Proof.
    revert xs ys H.
    induction ls as [|x ls IH]; cbn [partition]; intros xs ys H; inversion H; subst; clear H.
    { constructor. }
    { destruct (partition f ls); specialize (IH _ _ eq_refl).
      destruct f; match goal with H : pair _ _ = pair _ _ |- _ => inversion H; clear H end.
      all: subst; cbn.
      { constructor; assumption. }
      { rewrite <- IH.
        cbn.
        rewrite Permutation_app_comm; cbn; rewrite Permutation_app_comm.
        reflexivity. } }
  Qed.

  Lemma Forall_partition A f ls xs ys
        (H : @partition A f ls = (xs, ys))
    : Forall (fun x => f x = true) xs /\ Forall (fun x => f x = false) ys.
  Proof.
    revert xs ys H.
    induction ls as [|x ls IH]; cbn [partition]; intros xs ys H; inversion H; subst; clear H; repeat constructor; destruct partition, (f x) eqn:Hf.
    all: match goal with H : pair _ _ = pair _ _ |- _ => inversion H; clear H end; subst.
    all: specialize (IH _ _ eq_refl).
    all: destruct IH.
    all: repeat first [ constructor | assumption ].
  Qed.

  Lemma partition_eq_filter A f (ls : list A) xs ys
        (H : @partition A f ls = (xs, ys))
    : filter f ls = xs /\ filter (fun x => negb (f x)) ls = ys.
  Proof.
    revert xs ys H.
    induction ls as [|x ls IH]; cbn [partition filter]; intros xs ys H; inversion H; subst; clear H.
    { repeat constructor. }
    { destruct (partition f ls); specialize (IH _ _ eq_refl).
      destruct IH; subst.
      destruct f; match goal with H : pair _ _ = pair _ _ |- _ => inversion H; clear H end.
      all: subst; cbn; repeat constructor. }
  Qed.
End List.


(** ** Impredicative Construction of Inductive Types that are Sets and Eliminate into Sets *)

(** This is based on Sam Speight's master's thesis

    A Lean formalization of this had been available at
    https://github.com/jonas-frey/Impredicative/blob/master/
    The aim of this project at the UniMath School 2019 was to have
    the same results within UniMath - for the time being only binary
    products, binary coproducts and natural numbers. This has been
    achieved (with a minor addition afterwards). The Lean code we
    used is always put into a comment at the end of the sections.

    Authors: Ralph Matthes (@rmatthes), Sam Speight (@sspeight93)

*)

Require Import UniMath.Foundations.Init.
Require Import UniMath.Foundations.Preamble.
Require Import UniMath.Foundations.PartA.
Require Import UniMath.Foundations.Sets.
Require Import UniMath.CategoryTheory.Core.Categories.
Require Import UniMath.CategoryTheory.Core.Functors.
Require Import UniMath.CategoryTheory.FunctorAlgebras.
Require Import UniMath.CategoryTheory.categories.HSET.Core.
Require Import UniMath.CategoryTheory.categories.HSET.Structures.

Local Open Scope cat.
Local Open Scope functions.

Section BinaryProduct.

Variable A B: HSET.

Definition pre_prod: UU := ∏ (X: HSET), (pr1hSet A -> pr1hSet B -> pr1hSet X) -> pr1hSet X.

Lemma pre_prod_isaset: isaset pre_prod.
Proof.
  change (isofhlevel 2 pre_prod).
  do 2 (apply impred; intro).
  apply setproperty.
Defined.

Definition pre_prod_as_set: HSET := make_hSet pre_prod pre_prod_isaset.

Definition nProduct (α: pre_prod): UU :=
  ∏(X Y : HSET) (f : pr1hSet X → pr1hSet Y) (h : pr1hSet A -> pr1hSet B -> pr1hSet X), f (α X h) = α Y (λ a b, f (h a b)).

Definition nProduct_isaset (α: pre_prod): isaset (nProduct α).
Proof.
  change (isofhlevel 2 (nProduct α)).
  do 4 (apply impred; intro).
  apply hlevelntosn.
  apply setproperty.
Defined.

Definition nProduct_as_set (α: pre_prod): HSET := make_hSet _ (nProduct_isaset α).

Definition Product: UU := ∑ α: pre_prod, pr1hSet (nProduct_as_set α).

Definition Product_isaset: isaset Product.
Proof.
  apply (isaset_total2_hSet pre_prod_as_set).
Defined.

Definition Product_as_set: HSET := make_hSet _ Product_isaset.

Definition Pair (a : pr1hSet A) (b : pr1hSet B) : Product.
Proof.
  use tpair.
  - exact (λ X f, f a b).
  - cbn. red.
    intros; apply idpath.
Defined.

Definition Proj1: HSET ⟦Product_as_set, A⟧.
Proof.
  cbn.
  intro p.
  induction p as [α H].
  apply α.
  exact (fun x y => x).
Defined.

Definition Proj2: HSET ⟦Product_as_set, B⟧.
Proof.
  cbn.
  intro p.
  induction p as [α H].
  apply α.
  exact (fun x y => y).
Defined.

Definition Product_rec {C: HSET} (f: pr1hSet A -> pr1hSet B -> pr1hSet C) (p: Product) : pr1hSet C.
Proof.
  induction p.
  apply (pr1 C f).
Defined.

Lemma Product_beta (C: HSET) (f: pr1hSet A -> pr1hSet B -> pr1hSet C) (a: pr1hSet A) (b: pr1hSet B) : Product_rec f (Pair a b) = f a b.
Proof.
  apply idpath.
Defined.

Lemma Product_weak_η (x: Product) : Product_rec (C := Product_as_set) Pair x = x.
Proof.
  induction x as [P H].
  use total2_paths_f.
  - cbn.
    (* UniMath.MoreFoundations.Tactics.show_id_type. *)
    unfold pre_prod in P.
    apply funextsec; intro X.
    apply funextfun; intro f.
    cbn in H; red in H.
    exact (H Product_as_set X (fun x => pr1 x X f) Pair).
  - cbn.
    cbn in H.
    red in H.
    do 4 (apply funextsec; intro).
    apply setproperty.
Defined.

Lemma Product_com_con {C D : HSET} (f : pr1hSet A → pr1hSet B → pr1hSet C) (g : pr1hSet C → pr1hSet D): Product_rec (λ a b, g (f a b)) = g ∘ Product_rec f.
Proof.
  apply funextfun.
  intro x.
  induction x as [p H].
  cbn in H. red in H.
  apply pathsinv0.
  exact (H C D g f).
Defined.

Lemma Product_η {C : HSET} (g : Product → pr1hSet C): Product_rec (λ a b, g (Pair a b)) = g.
Proof.
  eapply pathscomp0.
  - apply (Product_com_con (C := Product_as_set) Pair).
  - apply funextfun; intro p.
    simpl.
    apply maponpaths.
    apply Product_weak_η.
Defined.

Lemma Product_classical_η (p: Product) : Pair (Proj1 p) (Proj2 p) = p.
Proof.
  apply pathsinv0.
  eapply pathscomp0.
  - apply pathsinv0.
    apply Product_weak_η.
  - set (Product_η_inst := Product_η (C := Product_as_set) (fun x => Pair (Proj1 x) (Proj2 x))).
    cbn in Product_η_inst.
    apply toforallpaths in Product_η_inst.
    apply Product_η_inst.
Defined.

Lemma Product_univ_prop {C : HSET} : isweq (@Product_rec C).
Proof.
  use isweq_iso.
  - exact (λ f a b, f (Pair a b)).
  - apply idpath.
  - apply Product_η.
Defined.

(* copied from https://github.com/jonas-frey/Impredicative/blob/a75cb998/encode.hlean#L173 onwards:
/- Product A × B of sets -/

-- System F encoding
definition  preProduct (A B : USet) : USet :=
  tΠ (X : USet), (A ⇒ B ⇒ X) ⇒ X

-- naturality condition
definition nProduct {A B : USet} (α : preProduct A B) : UPrp
  := tΠ(X Y : USet) (f : X → Y) (h : A ⇒ B ⇒ X), f (α X h) == α Y (λ a, f ∘ h a)

-- refined encoding
definition  Product (A B : USet) : USet := σ(α : preProduct A B), nProduct α

-- constructor
definition Pair {A B : USet} (a : A) (b : B) : Product A B
  := ⟨λ X f, f a b, λ X Y f g, rfl⟩

-- eliminators
definition Proj1 {A B : USet} : Product A B → A
  := sigma.rec (λ alpha p, alpha A (λ x y, x))

definition Proj2 {A B : USet} : Product A B → B
  := sigma.rec (λ alpha p, alpha B (λ x y, y))

-- recursor
definition Product_rec {A B C : Set} (f : A ⇒ B ⇒ C) (p : Product A B) : C
  := p.1 C f

-- β rule
definition Product_β {A B C : USet} (f : A → B → C) (a : A) (b : B)
  :  Product_rec f (Pair a b) = f a b := rfl

-- weak η rule
definition Product_weak_η {A B : USet} (x : Product A B)
  :  Product_rec Pair x = x
  := begin induction x with p n, fapply sigma_eq, apply eq_of_homotopy2,
     intros X f, exact (n _ _ (Product_rec f) Pair), apply is_prop.elimo end

-- commuting conversion
definition Product_com_con {A B C D : USet} (f : A → B → C) (g : C → D)
  :  Product_rec (λ a b, g (f a b)) = g ∘ Product_rec f
  := (eq_of_homotopy (λ x, x.2 C D g f))⁻¹

-- strong η rule
definition Product_η {A B C : USet} (g : Product A B → C)
  :  Product_rec (λ a b, g (Pair a b)) = g
  := (Product_com_con Pair g) ⬝ eq_of_homotopy (λ x, ap g (Product_weak_η x))

-- classical η rule
definition Product_classical_η {A B : USet} (p : Product A B)
  :   Pair (Proj1 p) (Proj2 p) = p
  :=  ap (λ f, f p) (Product_η _)⁻¹ ⬝ (Product_weak_η p)

-- universal property
definition Product_univ_prop {A B C : USet} : is_equiv (@Product_rec A B C)
  := adjointify Product_rec
                (λ f a b, f (Pair a b))
                Product_η
                (λ g, eq_of_homotopy2 (Product_β g))
*)

End BinaryProduct.

Section BinaryCoproduct.

Variable A B: HSET.

Definition pre_sum: UU := ∏ (X: HSET), (pr1hSet A -> pr1hSet X) -> (pr1hSet B -> pr1hSet X) -> pr1hSet X.

Lemma pre_sum_isaset: isaset pre_sum.
Proof.
  change (isofhlevel 2 pre_sum).
  do 3 (apply impred; intro).
  apply setproperty.
Defined.

Definition pre_sum_as_set: HSET := make_hSet pre_sum pre_sum_isaset.

Definition nSum (α: pre_sum): UU :=
  ∏(X Y : HSET) (f : pr1hSet X → pr1hSet Y) (h : pr1hSet A -> pr1hSet X) (k: pr1hSet B -> pr1hSet X), f (α X h k) = α Y (f ∘ h) (f ∘ k).

Definition nSum_isaset (α: pre_sum): isaset (nSum α).
Proof.
  change (isofhlevel 2 (nSum α)).
  do 5 (apply impred; intro).
  apply hlevelntosn.
  apply setproperty.
Defined.

Definition nSum_as_set (α: pre_sum): HSET := make_hSet _ (nSum_isaset α).

Definition Sum: UU := ∑ α: pre_sum, pr1hSet (nSum_as_set α).

Definition Sum_isaset: isaset Sum.
Proof.
  apply (isaset_total2_hSet pre_sum_as_set).
Defined.

Definition Sum_as_set: HSET := make_hSet _ Sum_isaset.

Definition Sum_inl: HSET ⟦A, Sum_as_set⟧.
Proof.
  cbn.
  intro a.
  use tpair.
  - intros X f g.
    exact (f a).
  - cbn. red.
    intros ? ? ? ? k.
    apply idpath.
Defined.

Definition Sum_inr: HSET ⟦B, Sum_as_set⟧.
Proof.
  cbn.
  intro a.
  use tpair.
  - intros X f g.
    exact (g a).
  - cbn. red.
    intros ? ? ? ? k.
    apply idpath.
Defined.

Definition Sum_rec {C: HSET} (f: pr1hSet A -> pr1hSet C)
  (g: pr1hSet B -> pr1hSet C)(c: Sum) : pr1hSet C
  := pr1 c C f g.

Lemma Sum_β_l {C: HSET} (f: pr1hSet A -> pr1hSet C)
      (g: pr1hSet B -> pr1hSet C): (Sum_rec f g) ∘ Sum_inl = f.
Proof.
  apply idpath.
Defined.

Lemma Sum_β_r {C: HSET} (f: pr1hSet A -> pr1hSet C)
      (g: pr1hSet B -> pr1hSet C): (Sum_rec f g) ∘ Sum_inr = g.
Proof.
  apply idpath.
Defined.

Lemma Sum_weak_eta (x: Sum) : Sum_rec (C := Sum_as_set) Sum_inl Sum_inr x = x.
Proof.
  induction x as [c H].
  use total2_paths_f.
  - cbn.
    unfold pre_sum in c.
    apply funextsec; intro X.
    apply funextfun; intro f.
    apply funextfun; intro g.
    cbn in H; red in H.
    apply (H Sum_as_set X (fun x => pr1 x X f g)).
  - cbn.
    cbn in H; red in H.
    do 5 (apply funextsec; intro).
    apply setproperty.
Defined.

Lemma Sum_com_con {X Y: HSET} (f : pr1hSet A → pr1hSet X) (g : pr1hSet B → pr1hSet X) (h : pr1hSet X → pr1hSet Y): Sum_rec (h ∘ f) (h ∘ g) = h ∘ (Sum_rec f g).
Proof.
  apply funextfun.
  intro x.
  induction x as [c H].
  cbn in H; red in H.
  cbn.
  apply pathsinv0.
  apply H.
Defined.

Lemma Sum_η {X : HSET} (h : Sum → pr1hSet X)
  : Sum_rec (h ∘ Sum_inl) (h ∘ Sum_inr) = h.
Proof.
  eapply pathscomp0.
  apply Sum_com_con.
  apply funextfun; intro s.
  simpl.
  apply maponpaths.
  apply Sum_weak_eta.
Defined.

Lemma Sum_univ_prop {X: HSET} : (HSET ⟦Sum_as_set, X⟧) ≃ (Product (exponential_functor A X) (exponential_functor B X)).
Proof.
  use weq_iso.
  - intro h.
    apply Pair.
    + cbn. exact (h ∘ Sum_inl).
    + cbn. exact (h ∘ Sum_inr).
  - intro a. cbn.
    apply Sum_rec.
    + exact (Proj1 _ _ a).
    + exact (Proj2 _ _ a).
  - cbn. intro x.
    apply Sum_η.
  - cbn. intro y.
    intermediate_path (Pair _ _ (Proj1 _ _ y) (Proj2 _ _ y)).
    + apply idpath.
    + apply Product_classical_η.
Defined.

(* copied from https://github.com/jonas-frey/Impredicative/blob/a75cb998/encode.hlean#L233 onwards:
/- Sum A + B of sets -/

-- System F encoding
definition  preSum (A B : USet) : USet :=
  tΠ(X : USet), (A ⇒ X) ⇒ (B ⇒ X) ⇒ X

-- naturality condition
definition nSum {A B : USet} (a : preSum A B) : UPrp
  := tΠ(X Y : USet) (f : X→Y) (h : A→X) (k : B→X), f(a X h k) == a Y (f∘h) (f∘k)

-- refined encoding
definition Sum (A B : USet) : USet := σ(α : preSum A B), nSum α

-- constructors
definition Sum_inl {A B : USet} (a : A) : Sum A B
  := ⟨λ X f g, f a, λ X Y f h k, rfl⟩

definition Sum_inr {A B : USet} (b : B) : Sum A B
  := ⟨λ X f g, g b, λ X Y f h k, rfl⟩

-- recursor
definition Sum_rec {A B X : USet} (f : A → X) (g : B → X) (c : Sum A B) : X
  := c.1 X f g

-- β rules
definition Sum_β_l {A B X : USet} (f : A → X) (g : B → X)
  : Sum_rec f g ∘ Sum_inl = f := rfl

definition Sum_β_r {A B X : USet} (f : A → X) (g : B → X)
  : Sum_rec f g ∘ Sum_inr = g := rfl

-- weak η
definition Sum_weak_η {A B : USet} (x : Sum A B)
  : Sum_rec Sum_inl Sum_inr x = x
  := begin induction x with α p, fapply sigma_eq,
     apply eq_of_homotopy3, intro X f g,  unfold Sum_rec, apply p,
     apply is_prop.elimo end

--commuting conversion
definition Sum_com_con {A B X Y : USet} (f : A → X) (g : B → X) (h : X → Y)
  :  Sum_rec (h ∘ f) (h ∘ g) = h ∘ Sum_rec f g
  := begin apply eq_of_homotopy, intro α, induction α with α p, symmetry, apply p end

-- strong η
definition Sum_η {A B X : USet} (h : Sum A B → X)
  :  Sum_rec (h∘Sum_inl) (h∘Sum_inr) = h
  := !Sum_com_con ⬝ eq_of_homotopy (λ x, ap h (Sum_weak_η x))

--universal property
definition Sum_univ_prop {A B X : USet}
  :  (Sum A B ⇒ X) ≃ (Product (A ⇒ X) (B ⇒ X))
  := equiv.MK (λ h, Pair (h ∘ Sum_inl) (h ∘ Sum_inr))
              (λ a, Sum_rec (Proj1 a) (Proj2 a))
              Product_classical_η
              Sum_η

*)

End BinaryCoproduct.

Section NaturalNumbers.

Definition pre_nat: UU := ∏ (X: HSET), (pr1hSet X -> pr1hSet X) -> pr1hSet X -> pr1hSet X.

Lemma pre_nat_isaset: isaset pre_nat.
Proof.
  change (isofhlevel 2 pre_nat).
  do 3 (apply impred; intro).
  apply setproperty.
Defined.

Definition pre_nat_as_set: HSET := make_hSet _ pre_nat_isaset.

Definition nNat (α: pre_nat): UU :=
  ∏(X Y : HSET) (x: pr1hSet X) (y: pr1hSet Y)(h: pr1hSet X → pr1hSet X)(k: pr1hSet Y → pr1hSet Y) (f : pr1hSet X -> pr1hSet Y), f x = y -> f ∘ h = k ∘ f -> f (α X h x) = α Y k y.

Definition nNat_isaset (α: pre_nat): isaset (nNat α).
Proof.
  change (isofhlevel 2 (nNat α)).
  do 9 (apply impred; intro).
  apply hlevelntosn.
  apply setproperty.
Defined.

Definition nNat_as_set (α: pre_nat): HSET := make_hSet _ (nNat_isaset α).

Definition Nat: UU := ∑ α: pre_nat, pr1hSet (nNat_as_set α).

Definition Nat_isaset: isaset Nat.
Proof.
  apply (isaset_total2_hSet pre_nat_as_set).
Defined.

Definition Nat_as_set: HSET := make_hSet _ Nat_isaset.

Definition Z: Nat.
Proof.
  use tpair.
  - exact (λ X f x, x).
  - cbn; red.
    intros; assumption.
Defined.

Definition S: HSET ⟦Nat_as_set,Nat_as_set⟧.
Proof.
  cbn.
  intro n.
  use tpair.
  - exact (λ X h x, h (pr1 n X h x)).
  - cbn; red.
    intros ? ? ? ? ? ? ? H1 H2.
    induction n as [n1 n2].
    cbn in n2; red in n2.
    cbn.
    eapply pathscomp0.
    2: { apply maponpaths.
         apply (n2 X Y x y h k f); assumption. }
    apply (toforallpaths _ _ _ H2).
Defined.

Definition Nat_rec {C: HSET} (h: pr1hSet C -> pr1hSet C)
  (x: pr1hSet C)(n: Nat) : pr1hSet C := pr1 n C h x.

Lemma Nat_β {C: HSET} (h: pr1hSet C -> pr1hSet C)
  (x: pr1hSet C): Nat_rec h x Z = x.
Proof.
  apply idpath.
Defined.

Lemma Nat_β' {C: HSET} (h: pr1hSet C -> pr1hSet C)
  (x: pr1hSet C) (n: Nat): Nat_rec h x (S n) = h (Nat_rec h x n).
Proof.
  apply idpath.
Defined.

Lemma Nat_weak_eta (n: Nat) : Nat_rec (C := Nat_as_set) S Z n = n.
Proof.
  induction n as [n0 H].
  use total2_paths_f.
  - cbn.
    unfold pre_nat in n0.
    apply funextsec; intro X.
    apply funextfun; intro h.
    apply funextfun; intro x.
    cbn in H; red in H.
    apply (H Nat_as_set X Z x S h (fun n => pr1 n X h x)); apply idpath.
  - cbn.
    cbn in H; red in H.
    do 7 (apply funextsec; intro).
    do 2 (apply funextfun; intro).
    apply setproperty.
Defined.

Lemma Nat_η {C: HSET} (h: pr1hSet C -> pr1hSet C)
      (x: pr1hSet C) (f: Nat → pr1hSet C)
      (p : f Z = x) (q: funcomp S f = funcomp f h):
  f = Nat_rec h x.
Proof.
  apply funextfun.
  intro n.
  eapply pathscomp0.
  - apply maponpaths.
    apply pathsinv0.
    apply Nat_weak_eta.
  - unfold Nat_rec.
    induction n as [n0 H].
    cbn in H; red in H.
    cbn.
    apply H; assumption.
Defined.

(* copied from https://github.com/jonas-frey/Impredicative/blob/a75cb998/encode.hlean#L289 onwards:
/- Natural numbers -/

-- System F encoding
definition preNat : USet := tΠ X : USet, (X ⇒ X) ⇒ X ⇒ X

-- naturality condition
definition nNat (α : preNat) : UPrp
  := tΠ (X Y : USet) (x : X) (y : Y) (h : X → X) (k : Y → Y) (f : X → Y),
         f x = y ⇒ f ∘ h = k ∘ f ⇒ f (α X h x) == α Y k y

-- refined encoding
definition Nat : USet := σ(α : preNat), nNat α

-- constructors
definition Z : Nat := ⟨λ X f x, x, λ X Y x y h k f u v, u⟩

definition S (n : Nat) : Nat
  := begin fconstructor, λ X h x, h (n.1 X h x), intros X Y x y h k f u v,
     refine (ap (λ f, f (n.1 X h x)) v) ⬝ _, apply ap k, apply n.2, exact u,
     assumption end

-- recursor
definition Nat_rec {X : USet} (h : X → X) (x : X) (n : Nat) : X := n.1 X h x

-- β rules
definition Nat_β {X : USet} (h : X → X) (x : X) : Nat_rec h x Z = x := rfl
definition Nat_β' {X : USet} (h : X → X) (x : X) (n : Nat)
  :  Nat_rec h x (S n) = h (Nat_rec h x n) := rfl

-- η rules
definition Nat_weak_η (n : Nat) : Nat_rec S Z n = n
  := begin
     induction n with n p,
     fapply sigma_eq, apply eq_of_homotopy3, intro X h x,
     apply p Nat X Z x S h (Nat_rec h x), reflexivity, apply eq_of_homotopy,
     intro, reflexivity, apply is_prop.elimo end

definition Nat_η {X:USet} (h:X→X) (x:X) (f:Nat→X) (p : f Z = x) (q:f∘S=h∘ f)
  :  f = Nat_rec h x
  := begin fapply eq_of_homotopy, intro n, refine (ap f (Nat_weak_η n))⁻¹ ⬝ _,
unfold Nat_rec, induction n with m k, apply k, assumption, assumption end

*)

End NaturalNumbers.

(* preparation for the general case:
Variable F: HSET ⟦A, A⟧.
*)


Require Export Coq.Lists.List.

Set Implicit Arguments.

Section Lists.

Hint Resolve Lt.lt_S_n List.nth_indep.

Variable A : Type.

Fixpoint replace (n : nat) (a : A) (l : list A) {struct l} : list A :=
  match l with
  | nil => nil
  | cons a' l' =>
    match n with
    | O => cons a l'
    | S n' => cons a' (replace n' a l')
    end
  end.

Lemma replace_length:
  forall n l a,
  length (replace n a l) = length l.
Proof with auto.
  induction n.
  destruct l...
  destruct l...
  simpl. intros. apply f_equal. apply IHn...
  Qed.

(* TODO: Move not_eq_n to another library. *)

Lemma not_eq_n:
  forall n m : nat,
  S n <> S m ->
  n <> m.
Proof.
  auto.
  Qed.

Lemma replace_correct_1:
  forall l n m d1 d2 a,
  m < length l ->
  m <> n ->
  nth m (replace n a l) d1 = nth m l d2.
Proof with auto.
  induction l; try solve [intros; inversion H].
  destruct n; try solve [destruct m; simpl; auto].
  destruct m; try solve [intros; exfalso; auto].
  simpl...
  Qed.

Lemma replace_correct_2:
  forall l n d a,
  n < length l ->
  nth n (replace n a l) d = a.
Proof with auto.
  induction l. intros. inversion H.
  destruct n...
  simpl. intros...
  Qed.

Fixpoint repeat (x : A) (n : nat) : list A :=
  match n with
  | O => nil
  | S k => cons x (repeat x k)
  end.

Lemma repeat_length:
  forall n x,
  length (repeat x n) = n.
Proof with auto.
  induction n...
  intros. simpl. rewrite IHn...
  Qed.

Lemma repeat_correct:
  forall n m x default,
  lt m n ->
  nth m (repeat x n) default = x.
Proof with auto.
  induction n. intros. inversion H.
  destruct m...
  intros. simpl...
  Qed.

Fixpoint resize (n : nat) (l : list A) (default : A) : list A :=
  match n with
  | O => nil
  | S n' =>
    match l with
    | nil => cons default (resize n' l default)
    | cons a' l' => cons a' (resize n' l' default)
    end
  end.

Lemma resize_length:
  forall n l default,
  length (resize n l default) = n.
Proof with auto.
  induction n...
  destruct l; simpl...
  Qed.

Lemma resize_nil:
  forall n default,
  resize n nil default = repeat default n.
Proof with auto.
  induction n...
  intros. simpl. rewrite IHn...
  Qed.

Lemma resize_correct_1:
  forall l n m d1 d2 d3,
  lt m n ->
  lt m (length l) ->
  nth m (resize n l d1) d2 = nth m l d3.
Proof with auto.
  induction l.
  destruct n; try (intros; inversion H0).
  destruct n. intros. inversion H.
  destruct m...
  simpl...
  Qed.

Lemma resize_correct_2:
  forall l n m d1 d2,
  lt m n ->
  le (length l) m ->
  nth m (resize n l d1) d2 = d1.
Proof with auto.
  induction l.
  destruct n. intros. inversion H.
  destruct m... intros. simpl.
  intros. rewrite resize_nil.
  rewrite repeat_correct...
  destruct n. intros. inversion H.
  destruct m. intros. inversion H0.
  simpl. intros. apply Le.le_S_n in H0...
  Qed.

End Lists.


Require Import Classical.

(* symbol *)
Notation "∀ x .. y , P" := (forall x, .. (forall y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' ∀ x .. y ']' , '/' P ']'") : type_scope.
Notation "∃ x .. y , P" := (exists x, .. (exists y, P) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' ∃ x .. y ']' , '/' P ']'") : type_scope.
Notation "'λ' x .. y , t" := (fun x => .. (fun y => t) ..)
  (at level 200, x binder, y binder, right associativity,
  format "'[ ' '[ ' 'λ' x .. y ']' , '/' t ']'").

Notation "x ∧ y" := (x /\ y)
  (at level 80, right associativity) : type_scope.
Notation "x ∨ y" := (x \/ y)
  (at level 85, right associativity) : type_scope.

Notation "x → y" := (x -> y)
  (at level 99, y at level 200, right associativity): type_scope.
Notation "x ↔ y" := (x <-> y) (at level 95, no associativity): type_scope.
Notation "x ≠ y" := (x <> y) (at level 70) : type_scope.

Ltac PreandH := match goal with H : ?a ∧ ?b |- _ => destruct H end.
Ltac andH := repeat PreandH.

Ltac PreandG := match goal with |- ?a ∧ ?b => split end.
Ltac andG := repeat PreandG.

Ltac PreorH := match goal with H : ?a ∨ ?b |- _ => destruct H end.
Ltac orH := repeat PreorH.

(* Some logic *)
(* Axiom classic : ∀ P, P ∨ ~P. *)
Ltac DC P := destruct (classic P).

(* Logical property *)
Proposition NNPP : ∀ P, (~(~P) ↔ P).
Proof. intros; DC P; tauto. Qed.

Proposition inp : ∀ P Q : Prop, (P ↔ Q) → (~P → ~Q).
Proof. intros; intro. pose proof H1. elim H0. apply H; auto. Qed.

Proposition not_or_and : ∀ P Q, ~(P ∨ Q) → ~P ∧ ~Q.
Proof. intros. split; intro; apply H; auto. Qed.

(* Class *)
Parameter Class : Type.

(* Two primitive(undefined) constants *)
Parameter In : Class → Class → Prop.
Notation "a ∈ A" := (In a A)(at level 70).
Notation "a ∉ A" := (~(a ∈ A))(at level 70).

Parameter Classifier : ∀ P : Class → Prop, Class.
Notation "\{ P \}" := (Classifier P)(at level 0).

(* Set theory *)
Axiom ExtAx : ∀ A B, (∀ x, x ∈ A ↔ x ∈ B) → A = B.
Ltac AppE := apply ExtAx; split; intros.

Definition Ensemble x := ∃ y, x ∈ y.
Ltac Ens := unfold Ensemble; eauto.
Ltac AssE x := assert (Ensemble x); Ens.

Axiom ClaAx : ∀ x P, x ∈ \{P\} ↔ Ensemble x ∧ P x.
Ltac AppCG := apply ClaAx; split; eauto.
Ltac AppC H := apply ClaAx in H as [_ H]; eauto.

Definition NoEmpty A := ∃ x, x ∈ A.
Notation "⦿ A" := (NoEmpty A) (at level 45).

Definition Empty := \{ λ x, x ≠ x \}.
Notation " ∅ " := Empty.

Fact EmptyNI : ∀ x, x ∉ ∅.
Proof. intros x H. AppC H. Qed.
Hint Resolve EmptyNI : Ens_hint.
Ltac exfalso0 := exfalso; eapply EmptyNI; eauto.

Fact EmptyEq : ∀ x, x = ∅ ↔ ~ (⦿ x).
Proof.
  split; intros. subst x. intros [x H]. exfalso0.
  AppE. elim H. exists x0; auto. exfalso0.
Qed.

Fact EmptyNE : ∀ x, x ≠ ∅ ↔ ⦿ x.
Proof.
  intros. pose proof EmptyEq. split; intros.
  apply (inp _ (~(⦿ x))) in H; auto. apply -> NNPP in H; auto.
  intro; apply H in H0; auto.
Qed.

Definition μ := \{ λ x, x = x \}.
Fact UniveI : ∀ x, Ensemble x → x ∈ μ.
Proof. intros. AppCG. Qed.
Hint Immediate UniveI : Ens_hint.

Ltac ens := auto with Ens_hint.
Ltac eens := eauto with Ens_hint.

Definition Singleton x := \{ λ z, x ∈ μ → z = x \}.
Notation "[ x ]" := (Singleton x) (at level 0, right associativity).

Fact SingI : ∀ x, Ensemble x → ∀ y, y = x → y ∈ [x].
Proof. intros. subst. AppCG. Qed.
Hint Resolve SingI : Ens_hint.

Fact SingE : ∀ x, Ensemble x → ∀ y, y ∈ [x] → y = x.
Proof. intros. AppC H0; ens. Qed.
Ltac sing H := apply SingE in H; try (subst; eauto).

Definition Included A B := ∀ x, x ∈ A → x ∈ B.
Notation "A ⊂ B" := (Included A B)(at level 70).

Definition ProperSub A B := A ⊂ B ∧ A ≠ B.
Notation "A ⊊ B" := (ProperSub A B)(at level 70).

Axiom SubAx : ∀ x, Ensemble x → ∃ y, Ensemble y ∧ (∀z, z ⊂ x → z ∈ y).

Fact SubAxP : ∀ x, Ensemble x → ∀ z, z ⊂ x → Ensemble z.
Proof. intros. apply SubAx in H as [y []]. Ens. Qed.
Hint Resolve SubAxP : Ens_hint.

Fact EmptySub : ∀ A, ∅ ⊂ A.
Proof. intros A x Hx. exfalso0. Qed.

Fact IncRef : ∀ A, A ⊂ A.
Proof. intros * x; auto. Qed.

Fact IncAsym : ∀ A B, A ⊂ B → B ⊂ A → A = B.
Proof. intros. AppE; auto. Qed.

Fact IncTran : ∀ A B C, A ⊂ B → B ⊂ C → A ⊂ C.
Proof. intros * Ha Hb x Hx. auto. Qed.
Hint Resolve IncRef IncAsym IncTran : Ens_hint.

Fact ProperSubE : ∀ A B, A ⊊ B → ∃ x, x ∈ B ∧ x ∉ A.
Proof.
  intros * [Hs Hn]. assert (~(A ⊂ B ∧ B ⊂ A )).
  { intros []. assert (A = B); ens. }
  apply not_and_or in H as []. tauto.
  apply not_all_ex_not in H as [n H]. apply imply_to_and in H; eauto.
Qed.

Definition PowerSet X := \{λ A, A ⊂ X \}.
Notation " cP( X )" := (PowerSet X)(at level 9, right associativity).

Fact PowerI : ∀ X, Ensemble X → ∀ Y, Y ⊂ X → Y ∈ cP(X).
Proof. intros. AppCG. eens. Qed.

Fact PowerE : ∀ X Y, Y ∈ cP(X) → Y ⊂ X.
Proof. intros. AppC H. Qed.
Ltac pow H := apply PowerE in H; eauto.

Fact PowerEns : ∀ X, Ensemble X → Ensemble cP(X).
Proof.
  intros. apply SubAx in H as [B [Hbe Hb]].
  assert (cP(X) ⊂ B). { intros z Hz. pow Hz. } eens.
Qed.
Hint Resolve PowerI PowerEns : Ens_hint.

Fact UniveEns : ~Ensemble μ.
Proof.
  set \{λ x, x ∉ x\} as R. assert (~Ensemble R).
  { DC (R ∈ R). pose proof H; AppC H. intro; elim H; AppCG. }
  assert (R ⊂ μ). intros z Hz. AssE z; ens. intro; eens.
Qed.

Fact SingEns : ∀ x, Ensemble x → Ensemble [x].
Proof.
  intros. assert ([x] ⊂ cP(x)). { intros z Hz. sing Hz. ens. }
  apply PowerEns in H; eens.
Qed.

Fact SingEns' : ∀ x, Ensemble [x] → Ensemble x.
Proof.
  intros. DC (Ensemble x); auto. assert ([x] = μ).
  { apply (inp _ (x ∈ μ)) in H0. AppE; AssE x0. ens. AppCG.
    intro; tauto. split; ens. intro; Ens. }
  rewrite H1 in H. pose proof UniveEns. tauto.
Qed.
Hint Resolve SingEns SingEns' : Ens_hint.

Definition Union A B := \{λ x, x ∈ A ∨ x ∈ B\}.
Notation "A ⋃ B" := (Union A B)(at level 65, right associativity).

Fact UnionI : ∀ x A, x ∈ A → ∀ B, x ∈ A ⋃ B.
Proof. intros. AppCG; Ens. Qed.

Fact UnionI' : ∀ x B, x ∈ B → ∀ A, x ∈ A ⋃ B.
Proof. intros. AppCG; Ens. Qed.
Hint Resolve UnionI UnionI' : Ens_hint.

Fact UnionE : ∀ x A B, x ∈ A ⋃ B → x ∈ A ∨ x ∈ B.
Proof. intros. AppC H. Qed.

Ltac PreunH := match goal with H : ?c ∈ ?a ⋃ ?b
  |- _ => apply UnionE in H as [] end.
Ltac unH := repeat PreunH.

Ltac PreunG := match goal with
  |- ?c ∈ ?a ⋃ ?b => apply UnionI end.
Ltac unG := repeat PreunG.

Fact UnionNE : ∀ x A B, x ∉ A ⋃ B → x ∉ A ∧ x ∉ B.
Proof. intros. split; intro; ens. Qed.

Axiom UnionAx : ∀ x y, Ensemble x → Ensemble y → Ensemble (x ⋃ y).

Fact UnionEns : ∀ x y, Ensemble (x ⋃ y) → Ensemble x ∧ Ensemble y.
Proof.
  intros. assert (x ⊂ x ⋃ y ∧ y ⊂ x ⋃ y).
  split; intros z Hz; ens. andH. split; eens.
Qed.

Definition Inter A B := \{λ x, x ∈ A ∧ x ∈ B\}.
Notation "A ∩ B" := (Inter A B)(at level 60, right associativity).

Fact InterI : ∀ x A B, x ∈ A → x ∈ B → x ∈ A ∩ B.
Proof. intros. AppCG; Ens. Qed.
Hint Resolve InterI : Ens_hint.

Fact InterE : ∀ x A B, x ∈ A ∩ B → x ∈ A ∧ x ∈ B.
Proof. intros. AppC H. Qed.

Ltac PreinH := match goal with H : ?c ∈ ?a ∩ ?b
  |- _ => apply InterE in H as [] end.
Ltac inH := repeat PreinH.

Ltac PreinG := match goal with
  |- ?c ∈ ?a ∩ ?b => apply InterI end.
Ltac inG := repeat PreinG.

Fact InterEns : ∀ x y, Ensemble x → Ensemble y → Ensemble (x ∩ y).
Proof.
  intros. assert (x ∩ y ⊂ x). intros z Hz. AppC Hz; tauto. eens.
Qed.

(* Axiom RegAx : ∀ x, x ≠ ∅ → ∃ y, y ∈ x ∧ x ∩ y = ∅. *)
Definition Setmin A B := \{λ x, x ∈ A ∧ x ∉ B\}.
Notation "A - B" := (Setmin A B).

Fact SetminI : ∀ x A B, x ∈ A → x ∉ B → x ∈ A - B.
Proof. intros. AppCG; Ens. Qed.
Hint Resolve SetminI : Ens_hint.

Fact SetminE : ∀ x A B, x ∈ A - B → x ∈ A ∧ x ∉ B.
Proof. intros. AppC H. Qed.

Ltac PresmH := match goal with H : ?c ∈ ?a - ?b
  |- _ => apply SetminE in H as [] end.
Ltac smH := repeat PresmH.

Ltac PresmG := match goal with
  |- ?c ∈ ?a - ?b => apply SetminI end.
Ltac smG := repeat PresmG.

Fact SetminIE : ∀ A B X, A ⊂ X → B ⊂ X → A - B = A ∩ (X - B).
Proof. intros. AppE. smH; ens. inH; smH; ens. Qed.

Fact SetminNI : ∀ x A X, x ∈ A → x ∉ X - A.
Proof. intros * Hx Hs. smH; tauto. Qed.

Fact SetminId : ∀ X, X - X = ∅.
Proof. intro. AppE. smH; tauto. exfalso0. Qed.

Fact SetminEm : ∀ X, X - ∅ = X.
Proof. intro. AppE. smH; tauto. ens. Qed.

Fact SetminEq : ∀ A B X, A = B → X - A = X - B.
Proof. intros. subst. auto. Qed.

Fact SetminSubI : ∀ A X, X - A ⊂ X.
Proof. intros * x Hx. smH; tauto. Qed.

Fact SetminEns : ∀ x, Ensemble x → ∀ y, Ensemble (x - y).
Proof. intros. pose proof (SetminSubI y x). eens. Qed.
Hint Resolve UnionAx InterEns SetminEns : Ens_hint.

Fact UnionSetmin: ∀ A B, A ⋃ (B - A) = A ⋃ B.
Proof. intros. AppE. unH; ens. smH; ens. unH; ens. DC (x ∈ A); ens. Qed.

Fact InterSetmin : ∀ A B X, B ⊂ X → B ∩ X - A = ∅ → B ⊂ A.
Proof.
  intros * Hs Hp z Hz. assert (z ∉ X - A).
  { intro. assert (z ∈ B ∩ X - A); ens. rewrite Hp in H0; exfalso0. }
  DC(z ∈ A); auto. elim H; ens.
Qed.

Fact InterEqEmI : ∀ x U A, Ensemble x →
  U ∩ A - [x] = ∅ → x ∉ A → U ∩ A = ∅.
Proof.
  intros. assert (A - [x] = A). { AppE. smH; tauto.
  assert (x0 ∉ [x]). intro; sing H3. ens. } rewrite H2 in H0; auto.
Qed.

Fact InterEqEmE : ∀ x U A, U ∩ A = ∅ → U ∩ A - [x] = ∅.
Proof.
  intros. AppE; [|exfalso0]. inH. smH.
  assert (x0 ∈ U ∩ A); ens. rewrite H in H3; exfalso0.
Qed.

Fact SetminSub : ∀ A B X, A ⊂ X → A - B ⊂ X.
Proof. intros * Ha z Hz. smH; auto. Qed.

Fact SetminSub1 : ∀ A B C, A ⊂ B → A - C ⊂ B - C.
Proof. intros * Hab z Hz. smH; ens. Qed.

Fact SetminSub2 : ∀ A B X, A ⊂ B → X - B ⊂ X - A.
Proof. intros * Hab z Hz. smH; ens. Qed.

Fact SetminInter : ∀ A B X, A ⊂ X → A - B = A ∩ X - B.
Proof. intros. AppE. smH; ens. inH; smH; ens. Qed.

Fact InterRSub : ∀ A B X, A ⊂ B → A ∩ X ⊂ B ∩ X.
Proof. intros * Hab z Hz. inH; ens. Qed.

Fact IdemU : ∀ A, A ⋃ A = A.
Proof. intros. AppE. unH; auto. ens. Qed.

Fact IdemI : ∀ A, A ∩ A = A.
Proof. intros. AppE; inH; ens. Qed.

Fact CommuU : ∀ A B, A ⋃ B = B ⋃ A.
Proof. intros. AppE; unH; ens. Qed.

Fact CommuI : ∀ A B, A ∩ B = B ∩ A.
Proof. intros. AppE; inH; ens. Qed.

Fact AssocU : ∀ A B C, (A ⋃ B) ⋃ C = A ⋃ (B ⋃ C).
Proof. intros. AppE; unH; ens. Qed.

Fact AssocI : ∀ A B C, (A ∩ B) ∩ C = A ∩ (B ∩ C).
Proof. intros. AppE; inH; ens. Qed.

Fact DistribuU : ∀ A B C, (A ∩ B) ⋃ C = (A ⋃ C) ∩ (B ⋃ C).
Proof. intros. AppE. unH; inH; ens. inH; unH; ens. Qed.

Fact DistribuI : ∀ A B C, (A ⋃ B) ∩ C = (A ∩ C) ⋃ (B ∩ C).
Proof. intros. AppE. inH; unH; ens. unH; inH; ens. Qed.

Fact TwoDMU : ∀ A B C, A - (B ⋃ C) = (A - B) ∩ (A - C).
Proof.
  intros. AppE. smH; inG; ens. inH; smH. smG; auto. intro; unH; auto.
Qed.

Fact TwoDMI : ∀ A B C, A - (B ∩ C) = (A - B) ⋃ (A - C).
Proof.
  intros. AppE. smH; DC (x ∈ C); ens. unG; ens.
  unH; smH; smG; auto; intro; inH; auto.
Qed.

Fact DistribuLI : ∀ A B C, A ∩ (B ⋃ C) = A ∩ B ⋃ A ∩ C.
Proof. intros. rewrite CommuI, DistribuI, CommuI, (CommuI A C); auto. Qed.

Fact DistribuLU : ∀ A B C, A ⋃ (B ∩ C) = (A ⋃ B) ∩ (A ⋃ C).
Proof. intros. rewrite CommuU, DistribuU, CommuU, (CommuU C A); auto. Qed.

Fact EmptyU : ∀ A, A ⋃ ∅ = A.
Proof. intros. AppE. unH; auto. exfalso0. ens. Qed.

Fact EmptyI : ∀ A, A ∩ ∅ = ∅.
Proof. intros. AppE. inH; auto. exfalso0. Qed.

Fact IncU : ∀ A X, A ⊂ X → A ⋃ X = X.
Proof. intros. AppE. unH; auto. ens. Qed.

Fact IncI : ∀ A X, A ⊂ X → A ∩ X = A.
Proof. intros. AppE. inH; auto. ens. Qed.

Fact ComUn : ∀ A X, A ⊂ X → A ⋃ X - A = X.
Proof. intros. AppE. unH; auto. smH; auto. DC (x ∈ A); ens. Qed.

Fact ComIn : ∀ A X, A ⊂ X → A ∩ X - A = ∅.
Proof. intros. AppE; [|exfalso0]. inH; smH; tauto. Qed.

Fact UnionCompl : ∀ A B X, A ⊂ X → B ⊂ X →
  X - (A ⋃ B) = X - A ∩ X - B.
Proof. intros. rewrite TwoDMU; auto. Qed.

Fact InterCompl : ∀ A B X, A ⊂ X → B ⊂ X →
  X - (A ∩ B) = X - A ⋃ X - B.
Proof. intros. rewrite TwoDMI; auto. Qed.

Fact TwoCompl : ∀ A X, A ⊂ X → X - (X - A) = A.
Proof.
  intros. AppE. smH. DC (x ∈ A); auto. elim H1; ens.
  smG; auto. intro; smH; auto.
Qed.

Fact DisLII : ∀ A B C, (A ∩ B) ∩ C = (A ∩ C) ∩ (B ∩ C).
Proof. intros. AppE; inH; ens. Qed.

Fact two_union_Empty : ∀ A B, A ⋃ B = ∅ ↔ A = ∅ ∧ B = ∅.
Proof.
  split; intros. andG; AppE; try exfalso0; rewrite <- H; eens.
  andH; subst. rewrite EmptyU; auto.
Qed.

Fact two_inter_Empty : ∀ A B X, A ⊂ X → B ⊂ X →
  A ∩ B = ∅ → A ⋃ B = X → A = X - B.
Proof.
  intros. AppE; [DC (x ∈ B)|DC (x ∈ A)]; ens. assert (x ∈ A ∩ B); ens.
  rewrite H1 in H5; exfalso0. exfalso; smH; rewrite <- H2 in H3; unH; ens.
Qed.

Fact unEq_inEm_idEq : ∀ A B C, A ⋃ B = A ⋃ C → A ∩ B = ∅ → A ∩ C = ∅ → B = C.
Proof.
  intros. assert ((A⋃B)∩C = (A⋃C)∩C ∧ (A⋃B)∩B = (A⋃C)∩B). andG; rewrite H;
  auto. destruct H2 as [Hc Hb]. rewrite DistribuI, DistribuI, H1, IdemI,
    CommuU, EmptyU, CommuU, EmptyU, CommuI in Hc. rewrite DistribuI,
    DistribuI, H0, IdemI, CommuU, EmptyU, CommuU, EmptyU, Hc in Hb; auto.
Qed.

Definition EleU x := \{λ z, ∃ y, z ∈ y ∧ y ∈ x\}.
Notation "∪ x" := (EleU x)(at level 66).

Fact EleUI : ∀ x y z, x ∈ y → y ∈ z → x ∈ ∪z.
Proof. intros. AppCG; Ens. Qed.
Hint Resolve EleUI : Ens_hint.

Fact EleUE : ∀ x z, x ∈ ∪z → ∃ y, x ∈ y ∧ y ∈ z.
Proof. intros. AppC H. Qed.
Ltac eleU H := apply EleUE in H as [? []]; eauto.

Axiom EleUAx : ∀ x, Ensemble x → Ensemble (∪x).
Hint Resolve EleUAx : Ens_hint.

Axiom InfAx : ∃ y, Ensemble y ∧ ∅ ∈ y ∧ (∀ x, x ∈ y → (x ⋃ [x]) ∈ y).

Fact EmptyEns : Ensemble ∅.
Proof. destruct InfAx as [x [_ [He _]]]; Ens. Qed.
Hint Resolve EmptyEns : Ens_hint.

Fact EleUEm : ∪∅ = ∅.
Proof. AppE; [|exfalso0]. eleU H; exfalso0. Qed.

Fact EleUSin : ∀ x, Ensemble x → ∪[x] = x.
Proof. intros. AppE. eleU H0; sing H1. eens. Qed.

Fact EleUEleSub : ∀ A B, A ∈ B → A ⊂ ∪B.
Proof. intros * Ha x Hx. eens. Qed.

Fact EleUSub: ∀ A B, A ⊂ B → ∪A ⊂ ∪B.
Proof. intros * H x Hx. eleU Hx. eens. Qed.

Fact EleUTwoUn : ∀ a b, ∪(a ⋃ b) = (∪a) ⋃ (∪b).
Proof. intros. AppE. eleU H; unH; eens. unH; eleU H; eens. Qed.

Fact IntSinEm : ∀ A B C, Ensemble C →
  A ∈ [C] ⋃ [∅] → B ∈ [C] ⋃ [∅] → A ∩ B ∈ [C] ⋃ [∅].
Proof.
  intros. unH; sing H0; sing H1; ens; try (rewrite EmptyI); ens;
  [rewrite IdemI|rewrite CommuI, EmptyI]; ens.
Qed.

Fact EleUSinEm : ∀ a T, Ensemble a → T ⊂ [a] ⋃ [∅] → ∪T ∈ [a] ⋃ [∅].
Proof.
  intros * Hae Ht. assert (Hte : Ensemble T).
  { assert (Ensemble ([a] ⋃ [∅])). ens. eens. }
  assert (T ∈ cP([a] ⋃ [∅])). eens.
  assert (∀ c d, Ensemble c → Ensemble d → cP([c] ⋃ [d]) =
    \{ λ Z, Z = ∅ ∨ Z = [c] ∨ Z = [d] ∨ Z = [c] ⋃ [d] \}).
  { intros. AppE.
    - AppCG; Ens. pow H2. DC (c ∈ x); DC (d ∈ x);
      [right; right; right|right; left|right; right; left|left].
      + apply IncAsym; auto; intros z Hz; unH; sing H5.
      + AppE; [|sing H5]; AppCG; Ens;
        assert (H5' := H5); apply H2 in H5; unH; sing H5; tauto.
      + AppE; [|sing H5]. AppCG; Ens.
        assert (H5' := H5); apply H2 in H5; unH; sing H5; tauto.
      + AppE; [|exfalso0].
        assert (H5' := H5); apply H2 in H5; unH; sing H5; tauto.
    - AppCG; Ens. intros z Hz. AppC H2.
      orH; subst; [exfalso0| | |auto]; ens. }
  rewrite H0 in H; ens. AppC H; orH; subst; try rewrite EleUSin; eens.
  rewrite EleUEm; ens. assert (∪[a]⋃[∅] = a).
  { rewrite EleUTwoUn, EleUSin, EleUSin, EmptyU; ens. }
  rewrite H; ens.
Qed.

Definition EleI x := \{λ z, ∀ y, y ∈ x → z ∈ y\}.
Notation "⋂ x" := (EleI x)(at level 66).

Fact EleISin : ∀ x, Ensemble x → ⋂[x] = x.
Proof.
  intros. AppE. AppC H0; apply H0; ens. AppCG; Ens. intros; sing H1.
Qed.
Hint Immediate EleUSin EleISin : Ens_hint.

Fact EleIEle : ∀ A B, A ∈ B → ⋂B ⊂ A.
Proof. intros. intros x Hx. AppC Hx. Qed.

Fact EleIEns : ∀ cA, cA ≠ ∅ → Ensemble (⋂cA).
Proof.
  intros. apply EmptyNE in H as [A]. apply EleIEle in H as H'.
  assert (Ensemble A). Ens. eens.
Qed.
Hint Resolve EleIEns : Ens_hint.

Definition Unorder x y := [x] ⋃ [y].
Notation "[ x | y ] " := (Unorder x y) (at level 0).

Fact UnordIE : ∀ x y, Ensemble x → Ensemble y →
  ∀ z, z ∈ [x|y] ↔ z = x ∨ z = y.
Proof.
  intros. unfold Unorder. split; intros. unH; sing H1. orH; subst; ens.
Qed.

Fact UnordEns : ∀ x y, Ensemble x → Ensemble y → Ensemble [x|y].
Proof. intros. unfold Unorder. ens. Qed.
Hint Resolve UnordEns : Ens_hint.

Fact unord1 : ∀ x y, Ensemble x → Ensemble y → ∪[x|y] = x ⋃ y.
Proof.
  intros. unfold Unorder. AppE. eleU H1; unH; sing H2; ens.
  unH; eapply EleUI; eauto; ens.
Qed.

Fact unord2 : ∀ x y, Ensemble x → Ensemble y → ⋂[x|y] = x ∩ y.
Proof.
  intros. unfold Unorder. AppE. AppC H1; ens.
  inH. AppCG; Ens. intros. unH; sing H3.
Qed.

Definition Order x y := [ [x] | [x | y] ].
Notation "[ x , y , .. , z ]" :=
  (Order .. (Order x y ) .. z ) (z at level 69).

Fact OrdEns : ∀ x y, Ensemble x → Ensemble y → Ensemble [x,y].
Proof. intros. unfold Order. ens. Qed.

Fact OrdEns0 : ∀ x y, Ensemble [x,y] → Ensemble x ∧ Ensemble y.
Proof.
  intros. apply UnionEns in H as [].
  apply SingEns', UnionEns in H0 as []; ens.
Qed.

Fact OrdEns1 : ∀ x y, Ensemble [x,y] → Ensemble x.
Proof. intros. apply OrdEns0 in H; tauto. Qed.

Fact OrdEns2 : ∀ x y, Ensemble [x,y] → Ensemble y.
Proof. intros. apply OrdEns0 in H; tauto. Qed.

Fact OrdEns3 : ∀ x y, Ensemble [x,y] → Ensemble [y,x].
Proof. intros. apply OrdEns0 in H as []. apply OrdEns; auto. Qed.
Hint Resolve OrdEns OrdEns3 : Ens_hint.

Ltac orde1 := match goal with H : Ensemble [?x,?y]
  |- Ensemble ?x => eapply OrdEns1; eauto end.
Ltac orde2 := match goal with H : Ensemble [?x,?y]
  |- Ensemble ?y => eapply OrdEns2; eauto end.
Ltac orde := try orde1; try orde2.

Fact ord1 : ∀ x y, Ensemble x → Ensemble y → ∪[x,y] = [x|y].
Proof.
  intros. unfold Order. rewrite unord1; ens.
  AppE; ens. unH; unfold Unorder; ens.
Qed.

Fact ord2 : ∀ x y, Ensemble x → Ensemble y → ⋂[x,y] = [x].
Proof.
  intros. unfold Order. rewrite unord2; ens.
  AppE. inH; auto. unfold Unorder; ens.
Qed.

Fact ord3 : ∀ x y, Ensemble x → Ensemble y → ∪(⋂[x,y]) = x.
Proof. intros. rewrite ord2; ens. Qed.

Fact ord4 : ∀ x y, Ensemble x → Ensemble y → ⋂(⋂[x,y]) = x.
Proof. intros. rewrite ord2; ens. Qed.

Fact ord5 : ∀ x y, Ensemble x → Ensemble y → ∪(∪[x,y]) = x ⋃ y.
Proof. intros. rewrite ord1, unord1; ens. Qed.

Fact ord6 : ∀ x y, Ensemble x → Ensemble y → ⋂(∪[x,y]) = x ∩ y.
Proof. intros. rewrite ord1, unord2; ens. Qed.

Definition π1 z := ⋂⋂z.
Definition π2 z := (⋂∪z)⋃(∪∪z)-(∪⋂z).

Fact ordFis : ∀ x y, Ensemble x → Ensemble y → π1 [x,y] = x.
Proof. intros. apply ord4; ens. Qed.

Fact ordSec : ∀ x y, Ensemble x → Ensemble y → π2 [x,y] = y.
Proof.
  intros. unfold π2. rewrite ord6, ord5, ord3; ens.
  assert ((x ⋃ y) - x = y - x). { AppE; smH; ens. unH. tauto. ens. }
  rewrite H1, CommuI. AppE; [|DC (x0 ∈ x); ens].
  unH. inH; auto. smH; auto.
Qed.

Fact ordEq : ∀ x y a b, Ensemble x → Ensemble y →
  [x,y] = [a,b] ↔ x = a ∧ y = b.
Proof.
  split; intros; [|destruct H1; subst; auto]. assert (Ensemble [x,y]).
  eens. rewrite H1 in H2. apply OrdEns0 in H2 as [].
  rewrite <- (ordFis x y), H1, <- (ordSec x y), H1, ordFis, ordSec; auto.
Qed.

Notation " \{\ P \}\ " :=
  \{λ z, ∃ x y, z = [x,y] ∧ P x y \}(at level 0).
Ltac PP H a b := apply ClaAx in H as [_ [a [b [? H]]]]; subst; eauto.

Fact ClaAx' : ∀ x y P, [x,y] ∈ \{\P\}\ ↔ Ensemble [x,y] ∧ (P x y).
Proof.
  split; intros. AssE [x,y]. PP H a b. apply ordEq in H1 as []; orde.
  subst; auto. destruct H; AppCG; eauto.
Qed.
Ltac AppCG' := apply ClaAx'; split; eauto.
Ltac AppC' H := apply ClaAx' in H as [_ H]; eauto.

Definition Cartesian X Y := \{\ λ x y, x ∈ X ∧ y ∈ Y\}\.
Notation " X × Y " := (Cartesian X Y)(at level 2, right associativity).

Fact CProdI : ∀ A B a b, a ∈ A → b ∈ B → [a,b] ∈ A × B.
Proof. intros * Ha Hb. AppCG'. apply OrdEns; Ens. Qed.
Hint Resolve CProdI : Ens_hint.

Fact CProdE : ∀ A B a b, [a,b] ∈ A × B → a ∈ A ∧ b ∈ B.
Proof. intros. AppC' H. Qed.
Ltac cprod H := apply CProdE in H as []; eauto.

Definition relation R := ∀ z, z ∈ R → ∃ x y, z = [x,y].
Definition Relation R X Y := R ⊂ X × Y.

Definition Range R := \{λ y, ∃ x, [x,y] ∈ R\}.
Notation " ran( R )" := (Range R)(at level 5).

Fact ranI : ∀ R x y, [x,y] ∈ R → y ∈ ran(R).
Proof. intros. AssE [x,y]. AppCG; orde. Qed.
Hint Resolve ranI : Ens_hint.

Fact ranE : ∀ R y, y ∈ ran(R) → ∃ x, [x,y] ∈ R.
Proof. intros. AppC H. Qed.
Ltac ran H := apply ranE in H as [?]; eauto.

Definition Domain R := \{λ x, ∃ y, [x,y] ∈ R\}.
Notation " dom( R )" := (Domain R)(at level 5).

Fact domI : ∀ R x y, [x,y] ∈ R → x ∈ dom(R).
Proof. intros. AssE [x,y]. AppCG; orde. Qed.
Hint Resolve domI : Ens_hint.

Fact domE : ∀ R x, x ∈ dom(R) → ∃ y, [x, y] ∈ R.
Proof. intros. AppC H. Qed.
Ltac dom H := apply domE in H as [?]; eauto.

Definition Function f :=
  relation f ∧ ∀ x y z, [x,y] ∈ f ∧ [x,z] ∈ f → y = z.

Axiom RepAx : ∀ f, Function f → Ensemble dom(f) → Ensemble ran(f).
Hint Resolve RepAx : Ens_hint.

Fact CProdEns0 : ∀ u y, Ensemble u → Ensemble y → Ensemble ([u] × y).
Proof.
  intros. set \{\λ w z, w ∈ y ∧ z = [u,w]\}\ as f.
  assert (Function f ∧ dom(f) = y ∧ ran(f) = [u] × y).
  { andG. split. intros z Hz; PP Hz a b. intros * [].
    AppC' H1; AppC' H2; andH. subst; auto.
    - AppE. dom H1; AppC' H1; tauto. AssE x; eapply domI; AppCG; eens.
    - AppE. ran H1; AppC' H1; andH. subst; ens. PP H1 a b; andH.
      sing H1. AssE b. AppCG; ens. exists b. AppCG'; eens. }
  andH. rewrite <- H2 in H0. rewrite <- H3. ens.
Qed.

Fact CProdEns : ∀ x y, Ensemble x → Ensemble y → Ensemble x × y.
Proof.
  intros. set \{\λ u z, u ∈ x ∧ z = [u] × y\}\ as f.
  assert (Function f ∧ dom(f) = x ∧
    ran(f) = \{λ z, ∃ u, u ∈ x ∧ z = [u] × y\}).
  { repeat split. intros z Hz; PP Hz a b.
    intros * []; AppC' H1; AppC' H2; andH. subst; auto.
    - AppE. dom H1. AppC' H1; tauto. AssE x0; eapply domI; AppCG'.
      apply OrdEns; auto. apply CProdEns0; auto.
    - AppE. ran H1; AppC' H1; andH; subst. AssE x1; AppCG.
      apply CProdEns0; auto. AppC H1. destruct H1; andH. subst. AssE x1.
      eapply ranI; AppCG. apply OrdEns; auto. apply CProdEns0; auto. }
  assert (∪ran(f) = x × y).
  { AppE. eleU H2; ran H3; AppC' H3; destruct H3. AssE x2; subst.
    PP H2 a b; destruct H2; sing H2; ens. pose proof H2. PP H2 a b; andH.
    AssE a; AppCG; Ens. exists [a] × y. split; ens. eapply ranI.
    AppCG'; eauto; ens. apply OrdEns; auto. apply CProdEns0; auto. }
  andH. rewrite <- H2. rewrite <- H3 in H. ens.
Qed.
Hint Resolve CProdEns : Ens_hint.

Definition Mapping F X Y := Relation F X Y ∧
  (∀ x, x ∈ X → (∃ y, [x,y] ∈ F)) ∧
  (∀ x y1 y2, [x,y1] ∈ F → [x,y2] ∈ F → y1 = y2 ).

Definition Value F x := ⋂\{λ y, [x,y] ∈ F\}.
Notation "F [ x ]" := (Value F x)(at level 5).

Fact ValueEns :∀ f x, x ∈ dom(f) → Ensemble f[x].
Proof.
  intros. unfold Value. assert (\{λ y, [x,y] ∈ f\} ≠ ∅).
  { dom H. apply EmptyNE. exists x0. AssE [x,x0]. AppCG; orde. } ens.
Qed.

Fact ValueP : ∀ f X Y, Mapping f X Y → ∀ x, x ∈ X → [x,f[x]] ∈ f.
Proof.
  intros * [Hr [He Hu]] * Hx. apply He in Hx as [y]. assert (y = f[x]).
  { AssE [x,y]. AppE. AppCG; Ens. intros; AppC H2. assert (y = y0).
    eapply Hu; eauto. subst; auto. AppC H1; apply H1; AppCG; orde. }
  subst; auto.
Qed.
Hint Resolve ValueEns ValueP : Ens_hint.

Fact ValueP1 : ∀ f X Y, Mapping f X Y → ∀ x, x ∈ X → f[x] ∈ Y.
Proof. intros. assert ([x,f[x]] ∈ f). eens. apply H in H1. cprod H1. Qed.

Fact ValueP2 : ∀ f X Y,
  Mapping f X Y → ∀ x y, x ∈ X → [x,y] ∈ f → y = f[x].
Proof. intros. eapply H; eens. Qed.
Hint Resolve ValueP1 ValueP2 : Ens_hint.

Fact Map_dom : ∀ F X Y, Mapping F X Y → dom(F) = X.
Proof. intros. AppE; eens. dom H0. apply H in H0. cprod H0. Qed.

Definition Restriction f A := \{\λ a b, [a,b] ∈ f ∧ a ∈ A\}\.
Notation "f ↾ A" := (Restriction f A)(at level 30).

Fact RestrI : ∀ f a b A, [a,b] ∈ f → a ∈ A → [a,b] ∈ f↾A.
Proof. intros. AppCG'; Ens. Qed.
Hint Resolve RestrI : Ens_hint.

Fact RestrE : ∀ f A a b, [a,b] ∈ f↾A → [a,b] ∈ f ∧ a ∈ A.
Proof. intros. AppC' H. Qed.
Ltac restr H := apply RestrE in H as []; eauto.

Fact RestrDom : ∀ F A, dom(F↾A) ⊂ dom(F).
Proof. intros * x H. dom H. restr H. eens. Qed.

Fact RestrM : ∀ f X Y, Mapping f X Y → ∀ A, A ⊂ X → Mapping (f↾A) A Y.
Proof.
  intros. split; [|split; intros; eens]. intros z Hz; PP Hz a b; andH.
  apply H in H1; cprod H1; ens. restr H1; restr H2; eapply H; eauto.
Qed.

Fact RestrValue : ∀ f X Y, Mapping f X Y → ∀ A, A ⊂ X →
  ∀ a, a ∈ A → f[a] = (f↾A)[a].
Proof.
  intros. AppE; AppCG; Ens; AppC H2; intros; AssE y;
  AppC H3; [restr H3|]; apply H2; AppCG; ens.
Qed.

Definition neSub X := cP(X) - [∅].
Notation " X ^ " := (neSub X) (at level 0).

Fact neSubEm : ∅^ = ∅.
Proof.
  unfold neSub. AppE; [|exfalso0]. smH. pow H. assert (x ≠ ∅).
  { intro. subst. ens. } elim H1. AppE. auto. exfalso0.
Qed.

Definition ChoiceF ε X := Mapping ε X^ X ∧ ∀ A, A ∈ X^ → ε[A] ∈ A.

Axiom ChoiceAx : ∀ X, ∃ ε, ChoiceF ε X.

Fact ChoAx : ∀ cA, ∅ ∉ cA →
  (∃ ν, Mapping ν cA (∪cA) ∧ (∀ A, A ∈ cA → ν[A] ∈ A )).
Proof.
  intros * Hn. set (X := ∪cA). assert (cA ⊂ X^).
  { intros A Ha. AppCG; andG; Ens. AppCG; Ens.
    intros x Hx; AppCG; Ens. intro; sing H; ens. }
  pose proof (ChoiceAx X) as [ε [Hf Hp]]. set (ν := ε↾cA).
  exists ν. andG. eapply RestrM; eauto. intros. assert (ε[A] = ν[A]).
  eapply RestrValue; eauto. rewrite <- H1. apply Hp. auto.
Qed.

Fact ChoAx1 : ∀ U P, Ensemble P → (∀ x, x ∈ U → ∃ y, [x,y] ∈ P) →
  ∃ f, Mapping f U \{λ z, ∃ x, x ∈ U ∧ [x,z] ∈ P\} ∧
  (∀ x, x ∈ U → [x,f[x]] ∈ P).
Proof.
  intros * Hpe Hp. DC (U = ∅).
  - subst. set (\{\λ u v, u ∈ ∅\}\) as f. exists f. andG; [split|].
    intros z Hz; PP Hz a b; exfalso0. andG. intros; exfalso0.
    intros; AppC' H0; exfalso0. intros; exfalso0.
  - set (\{λ Y, ∃ x, x ∈ U ∧ Y = \{λ y, [x,y] ∈ P\} \}) as cA.
    assert (Hp1 : ∅ ∉ cA). { intro He. AppC He; destruct He as
      [x [Hx Hm]], (Hp _ Hx) as [y Hxy].
    AssE [x,y]; apply OrdEns2 in H0. assert (y ∈ ∅).
    rewrite Hm; AppCG. exfalso0. }
    assert (Hxf : ∀ x, x ∈ U → \{λ y, [x,y] ∈ P\} ∈ cA).
    { intros. AppCG. set \{\ λ a b, ∃ x, [x,b] ∈ P ∧ a = [x,b]\}\ as f.
      assert (\{λ y, [x, y] ∈ P \} ⊂ ran(f)).
      { intros y Hy. AssE y; AppC Hy. AppCG. exists ([x,y]).
        AppCG'. apply OrdEns; Ens. }
      eapply SubAxP; revgoals; eauto. apply RepAx.
      - split. intros z Hz; PP Hz a b. intros * []; AppC' H2; AppC' H3.
        destruct H2, H3; andH. subst. AssE [x1,y].
        apply OrdEns0 in H5; andH. apply ordEq in H4; tauto.
      - assert (dom(f) ⊂ P). intros z Hz. dom Hz. AppC' H2.
        destruct H2; andH. subst; auto. eens. }
    destruct (ChoAx _ Hp1) as [c [Hc Hcp]]. set \{\λ u v, u ∈ U ∧
      v = c[\{λ y, [u,y] ∈ P\}]\}\ as ν. exists ν. andG; [split; andG|].
    + intros z Hz. AssE z; PP Hz u v; andH. AppCG'. apply OrdEns2 in H0.
      andG; auto. AppCG. exists u. andG; auto.
      apply Hxf, Hcp in H1. rewrite <- H2 in H1. AppC H1.
    + intros. AssE x. exists c[\{λ y, [x,y] ∈ P\}]. AppCG'. apply OrdEns;
      auto. apply ValueEns. erewrite Map_dom; eauto.
    + intros. AppC' H0; AppC' H1; andH. subst; auto.
    + intros * Hx. pose proof Hx as Hx'; apply Hxf, Hcp in Hx. AppC Hx.
      assert (c[\{λ y, [x,y] ∈ P\}] = ν [x]).
      { AppE; AppCG; Ens; AppC H0; intros * Hy; apply H0; AppCG; Ens.
        - AppC Hy. AppC' Hy; andH. subst y. eapply ValueP; eauto.
        - AppCG'; andG; auto. apply OrdEns; Ens. AppC Hy.
          eapply ValueP2; eauto. } rewrite <- H0; auto.
Qed.


Require Import Coq.Lists.List Program Relation_Definitions.
Import ListNotations.
Set Implicit Arguments.

(** * Functions on the [option] Type *)

(** Removing the [Some] constructor using a proof that the argument is
    different from [None]. *)
Program Definition
  no_some(A:Type)(a:option A| a <> None) : A :=
  match a with
    | None => _
    | Some x => x
  end.

Lemma no_some_spec :
  forall (A:Type)(a:option A| a <> None),
    Some (no_some a) = `a.
Proof.
  intros A [[a| ] Ha]; unfold no_some; [auto | contradict Ha; trivial].
Qed.

(** Properties of [no_some] and [Some]. *)
Lemma some_no_some:
  forall(A:Type)(a:option A)(H:a<>None),
    Some(no_some(exist _ a H)) = a.
Proof.
  intros A a Ha;
  destruct a; simpl; auto; elim Ha; auto.
Qed.

Lemma some_inj_eq:
  forall(A:Type)(x y:A), x = y <-> Some x = Some y.
Proof.
  intros A x y; split;intro H;
  [ f_equal | inversion H ]; auto.
Qed.

#[export] Hint Rewrite some_no_some: option.

(** Conversion to [bool]. *)
Definition is_some (A:Type)(x:option A) : bool :=
  match x with
    | None => false
    | Some _ => true
  end.

Lemma is_some_true_not_none:
  forall (A:Type)(x: option A),
    is_some x = true -> x<>None.
Proof.
  destruct x; intro H; discriminate.
Qed.

(** [map_filter_some] applies a function [f:A->option B] to each
     element of a list. If [(f a)] is [None], the value is discarded,
     otherwise [no_some(f a)] is in the result list. *)
Fixpoint map_filter_some (A B :Type)(f: A->option B)(l:list A) :=
  match l with
    | nil => nil
    | cons h t =>
      match (f h) with
	| Some x => x::map_filter_some f t
        | None => map_filter_some f t
      end
  end.

Lemma map_filter_some_prop:
  forall (A B :Type)(f: A->option B)(l:list A),
    map Some (map_filter_some f l) = filter (@is_some B) (map f l).
Proof.
  induction l as [|x xs IH]; auto.
  case_eq (f x); [intros b Hfa | intros Hfa]; simpl;
  rewrite Hfa; simpl; f_equal; trivial.
Qed.

Lemma map_filter_some_ext :
  forall {A B} l (f f' : A -> option B),
    (forall a:A, f a = f' a) ->
    map_filter_some f l =  map_filter_some f' l.
Proof.
  intros A0 B l f f'  H.
  induction l as [|x xs IH].
  - trivial.
  - simpl; rewrite H, IH; trivial.
Qed.


(** * Library for retracts  *)

(* Author: Maximilian Wuttke *)

Require Import Shared.Base.

(*
 * A retraction between types [A] and [B] is a tuple of two functions,
 * [f : A -> B] (called the injection function) and [g : B -> option A] (called the retract function),
 * such that the following triangle shaped diagram commutes:
 *
 *          f
 *      A -----> B
 *      |      /
 * Some |     / g
 *      |    /
 *     \|/ |/_
 *    option A
 *
 * That informally means, that the injective function [f] can be reverted by the retract function [g].
 * Foramlly, for all values [x:A] and [y = f x], then [g y = Some x].  (Or: [forall x, g (f x) = Some x].)
 *
 * The retracts should also be "tight", which means that the retract function only reverts values in
 * the image of [f]. Foramlly this means that whenever [g y = Some x], then also [y = f x]
 *
 * Altogether, we have that [forall x y, g y = Some x <-> y = f x].
 *)

Section Retract.

  Variable X Y : Type.

  Definition retract (f : X -> Y) (g : Y -> option X) := forall x y, g y = Some x <-> y = f x.

  Class Retract :=
    {
      Retr_f : X -> Y;
      Retr_g : Y -> option X;
      Retr_retr : retract Retr_f Retr_g;
    }.

End Retract.

Arguments Retr_f { _ _ _ }.
Arguments Retr_g { _ _ _ }.

Section Retract_Properties.

  Variable X Y : Type.

  Hypothesis I : Retract X Y.

  Definition retract_g_adjoint : forall x, Retr_g (Retr_f x) = Some x.
  Proof. intros. pose proof @Retr_retr _ _ I. hnf in H. now rewrite H. Qed.

  Definition retract_g_inv : forall x y, Retr_g y = Some x -> y = Retr_f x.
  Proof. intros. now apply Retr_retr. Qed.

  Lemma retract_g_surjective : forall x, { y | Retr_g y = Some x }.
  Proof. intros x. pose proof retract_g_adjoint x. cbn in H. eauto. Defined.

  Lemma retract_f_injective : forall x1 x2, Retr_f x1 = Retr_f x2 -> x1 = x2.
  Proof.
    intros x1 x2 H.
    enough (Some x1 = Some x2) by congruence.
    erewrite <- !retract_g_adjoint.
    now rewrite H.
  Qed.

  Lemma retract_g_Some x y :
    Retr_g (Retr_f x) = Some y ->
    x = y.
  Proof. now intros H % retract_g_inv % retract_f_injective. Qed.

  Lemma retract_g_None b :
    Retr_g b = None ->
    forall a, Retr_f a <> b.
  Proof.
    intros H a <-.
    enough (Retr_g (Retr_f a) = Some a) by congruence.
    apply retract_g_adjoint.
  Qed.

End Retract_Properties.

(* This tactic replaces all occurrences of [g (f x)] with [Some x] for retracts. *)
Ltac retract_adjoint :=
  match goal with
  | [ H : context [ Retr_g (Retr_f _) ] |- _ ] => rewrite retract_g_adjoint in H
  | [   |- context [ Retr_g (Retr_f _) ]     ] => rewrite retract_g_adjoint
  end.

(*
 * We can compose retractions, as shown in the following commuting diagram
 *
 *            f1        f2
 *      A --------> B --------> C
 *      |         / |         /
 *      |        /  |Some    /
 *      |       /   |       /
 *      |      /    |      /
 * Some |     / g1  |     / g2
 *      |    /      |    /
 *     \|/ |/_     \|/ |/_
 *    option A <--- option B
 *            map g1
 *
 *
 * Where [map g1] is the function that takes an option [x : option B] and applys [Some] and [g1] if it is [Some],
 * and else returns [None].
 *
 * Now [f2 ∘ f1] and [map g1 ∘ g2] gives a retract between [A] and [C].
 *)

Section ComposeRetracts.
  Variable A B C : Type.

  Definition retr_comp_f (f1 : B -> C) (f2 : A -> B) : A -> C := fun a => f1 (f2 a).
  Definition retr_comp_g (g1 : C -> option B) (g2 : B -> option A) : C -> option A :=
    fun c => match g1 c with
          | Some b => g2 b
          | None => None
          end.

  (* No instance (outside of this section), for obvious reasons... *)
  Local Instance ComposeRetract (retr1 : Retract B C) (retr2 : Retract A B) : Retract A C :=
    {|
      Retr_f := retr_comp_f Retr_f Retr_f;
      Retr_g := retr_comp_g Retr_g Retr_g;
    |}.
  Proof.
    abstract now
      unfold retr_comp_f, retr_comp_g; intros a c; split;
      [intros H; destruct (Retr_g c) as [ | ] eqn:E;
       [ apply retract_g_inv in E as ->; now apply retract_g_inv in H as ->
       | congruence
       ]
      | intros ->; now do 2 retract_adjoint
      ].
  Defined.

End ComposeRetracts.

(** We define some useful retracts. *)
Section Usefull_Retracts.

  Variable (A B C D : Type).

  (** Identity retract *)
  Global Instance Retract_id : Retract A A :=
    {|
      Retr_f a := a;
      Retr_g b := Some b;
    |}.
  Proof. abstract now hnf; firstorder congruence. Defined.

  (** Empty retract *)
  Global Instance Retract_Empty : Retract Empty_set A :=
    {|
      Retr_f e := @Empty_set_rect (fun _ => A) e;
      Retr_g b := None;
    |}.
  Proof. abstract now intros x; elim x. Defined.

  (** Eliminate the [Empty_set] from the source sum type *)
  Global Instance Retract_Empty_left `{retr: Retract A B} : Retract (A + Empty_set) B :=
    {|
      Retr_f a := match a with
                  | inl a => Retr_f a
                  | inr e => @Empty_set_rect (fun _ => B) e
                  end;
      Retr_g b := match Retr_g b with
                  | Some a => Some (inl a)
                  | None => None
                  end;
    |}.
  Proof.
    abstract now intros [ a | [] ] b; split;
      [ intros H; destruct (Retr_g b) eqn:E; inv H; now apply retract_g_inv in E
      | intros ->; now retract_adjoint
      ].
  Defined.

  Global Instance Retract_Empty_right `{retr: Retract A B} : Retract (Empty_set + A) B :=
    {|
      Retr_f a := match a with
                  | inl e => @Empty_set_rect (fun _ => B) e
                  | inr a => Retr_f a
                  end;
      Retr_g b := match Retr_g b with
                  | Some a => Some (inr a)
                  | None => None
                  end;
    |}.
  Proof.
    abstract now intros [ [] | a ] b; split;
      [ intros H; destruct (Retr_g b) eqn:E; inv H; now apply retract_g_inv in E
      | intros ->; now retract_adjoint
      ].
  Defined.

  (** We can introduce an additional [Some] and use the identity as the retract function *)
  Global Instance Retract_option `{retr: Retract A B} : Retract A (option B) :=
    {|
      Retr_f a := Some (Retr_f a);
      Retr_g ob := match ob with
                    | Some b => Retr_g b
                    | None => None
                    end;
    |}.
  Proof.
    abstract now
      split;
      [ intros H; destruct y as [b|];
        [ now apply retract_g_inv in H as ->
        | inv H
        ]
      | intros ->; now retract_adjoint
      ].
  Defined.

  (** We can introduce an additional [inl] *)

  Definition retract_inl_f (f : A -> B) : A -> (B + C) := fun a => inl (f a).
  Definition retract_inl_g (g : B -> option A) : B+C -> option A :=
    fun x => match x with
          | inl b => g b
          | inr c => None
          end.

  Global Instance Retract_inl (retrAB : Retract A B) : Retract A (B + C) :=
    {|
      Retr_f := retract_inl_f Retr_f;
      Retr_g := retract_inl_g Retr_g;
    |}.
  Proof.
    abstract now
      unfold retract_inl_f, retract_inl_g; hnf; intros x y; split;
      [ destruct y as [a|b]; [ now intros -> % retract_g_inv | congruence ]
      | intros ->; now retract_adjoint
      ].
  Defined.

  (** The same for [inr] *)

  Definition retract_inr_f (f : A -> B) : A -> (C + B) := fun a => inr (f a).
  Definition retract_inr_g (g : B -> option A) : C+B -> option A :=
    fun x => match x with
          | inr b => g b
          | inl c => None
          end.

  Global Instance Retract_inr (retrAB : Retract A B) : Retract A (C + B) :=
    {|
      Retr_f := retract_inr_f Retr_f;
      Retr_g := retract_inr_g Retr_g;
    |}.
  Proof.
    abstract now
      unfold retract_inr_f, retract_inr_g; hnf; intros x y; split;
      [ destruct y as [a|b]; [ congruence | now intros -> % retract_g_inv ]
      | intros ->; now retract_adjoint
      ].
  Defined.

  (** We can map retracts over sums, similiary as we have done with inversions *)

  Section Retract_sum.

    Definition retract_sum_f (f1: A -> C) (f2: B -> D) : A+B -> C+D :=
      fun x => match x with
            | inl a => inl (f1 a)
            | inr b => inr (f2 b)
            end.

    Definition retract_sum_g (g1: C -> option A) (g2: D -> option B) : C+D -> option (A+B) :=
      fun y => match y with
            | inl c => match g1 c with
                      | Some a => Some (inl a)
                      | None => None
                      end
            | inr d => match g2 d with
                      | Some b => Some (inr b)
                      | None => None
                      end
            end.

    Local Instance Retract_sum (retr1 : Retract A C) (retr2 : Retract B D) : Retract (A+B) (C+D) :=
      {|
        Retr_f := retract_sum_f Retr_f Retr_f;
        Retr_g := retract_sum_g Retr_g Retr_g;
      |}.
    Proof.
      abstract now
        unfold retract_sum_f, retract_sum_g; intros x y; split;
        [ intros H; destruct y as [c|d];
          [ destruct (Retr_g c) eqn:E1; inv H; f_equal; now apply retract_g_inv
          | destruct (Retr_g d) eqn:E1; inv H; f_equal; now apply retract_g_inv
          ]
        | intros ->; destruct x as [a|b]; now retract_adjoint
        ].
    Defined.

  End Retract_sum.

End Usefull_Retracts.

(* If we have a retract from [A] to [Z] and a retract from [B] to Z, in general it is not possible
 * to build a retract from [A+B] to [Z]. For example, there can be no retract from [unit+unit] to
 * [unit]. However, it is possible when the images of the injections are distint.
 *)
Section Join.

  Variable A B Z : Type.

  Variable retr1 : Retract A Z.
  Variable retr2 : Retract B Z.

  Local Arguments Retr_f {_ _} (Retract).
  Local Arguments Retr_g {_ _} (Retract).

  Definition retract_join_f s :=
    match s with
    | inl a => Retr_f retr1 a
    | inr b => Retr_f retr2 b
    end.

  Definition retract_join_g z :=
    match Retr_g retr1 z with
    | Some a => Some (inl a)
    | None =>
      match Retr_g retr2 z with
      | Some b => Some (inr b)
      | None => None
      end
    end.

  Hypothesis disjoint : forall (a : A) (b : B), Retr_f _ a <> Retr_f _ b.

  Lemma retract_join : retract retract_join_f retract_join_g.
  Proof.
    unfold retract_join_f, retract_join_g. hnf; intros s z; split.
    - destruct s as [a|b]; intros H.
      + destruct (Retr_g retr1 z) eqn:E.
        * inv H. now apply retract_g_inv in E.
        * destruct (Retr_g retr2 z) eqn:E2; inv H.
      + destruct (Retr_g retr1 z) eqn:E.
        * inv H.
        * destruct (Retr_g retr2 z) eqn:E2.
          -- inv H. now apply retract_g_inv in E2.
          -- inv H.
    - intros ->. destruct s as [a|b]; retract_adjoint. reflexivity.
      destruct (Retr_g retr1 (Retr_f retr2 b)) eqn:E.
      + exfalso. apply retract_g_inv in E. symmetry in E. now apply disjoint in E.
      + reflexivity.
  Qed.

  Local Instance Retract_join : Retract (A+B) Z := Build_Retract retract_join.

End Join.

(** More instances like [Retract_sum] for bigger sums. *)

Section MoreSums.

  Local Instance Retract_sum3 (A A' B B' C C' : Type) (retr1 : Retract A A') (retr2 : Retract B B') (retr3 : Retract C C') :
    Retract (A+B+C) (A'+B'+C') := Retract_sum (Retract_sum retr1 retr2) retr3.

  Local Instance Retract_sum4 (A A' B B' C C' D D' : Type) (retr1 : Retract A A') (retr2 : Retract B B') (retr3 : Retract C C') (retr4 : Retract D D') :
    Retract (A+B+C+D) (A'+B'+C'+D') := Retract_sum (Retract_sum (Retract_sum retr1 retr2) retr3) retr4.

  Local Instance Retract_sum5 (A A' B B' C C' D D' E E' : Type) (retr1 : Retract A A') (retr2 : Retract B B') (retr3 : Retract C C') (retr4 : Retract D D') (retr5 : Retract E E') :
    Retract (A+B+C+D+E) (A'+B'+C'+D'+E') := Retract_sum (Retract_sum (Retract_sum (Retract_sum retr1 retr2) retr3) retr4) retr5.

  Local Instance Retract_sum6 (A A' B B' C C' D D' E E' F F' : Type) (retr1 : Retract A A') (retr2 : Retract B B') (retr3 : Retract C C') (retr4 : Retract D D') (retr5 : Retract E E') (retr6 : Retract F F') :
    Retract (A+B+C+D+E+F) (A'+B'+C'+D'+E'+F') := Retract_sum (Retract_sum (Retract_sum (Retract_sum (Retract_sum retr1 retr2) retr3) retr4) retr5) retr6.

  Local Instance Retract_sum7 (A A' B B' C C' D D' E E' F F' G G' : Type) (retr1 : Retract A A') (retr2 : Retract B B') (retr3 : Retract C C') (retr4 : Retract D D') (retr5 : Retract E E') (retr6 : Retract F F') (retr7 : Retract G G') :
    Retract (A+B+C+D+E+F+G) (A'+B'+C'+D'+E'+F'+G') := Retract_sum (Retract_sum (Retract_sum (Retract_sum (Retract_sum (Retract_sum retr1 retr2) retr3) retr4) retr5) retr6) retr7.

End MoreSums.


(*standart Coq*)

(*Definition Var := nat.*)
Axiom Var: Type.

Axiom eps: Var -> Var -> Prop.

Definition sub (X Y:Var): Prop := forall Z:Var, (eps Z X) -> (eps Z Y).
Definition eqc (X Y:Var): Prop := forall Z:Var, (eps Z X) <-> (eps Z Y).
Notation "X == Y" := (eqc X Y) (at level 85) : type_scope.
Check (_ = _).

(*Prop 4.1(a)*)
Definition p4_1 (X Y:Var): (X == Y) <-> (sub X Y /\ sub Y X).
Proof.
unfold iff.
apply conj.
+ intro p.
  apply conj.
  exact (fun Z => proj1 (p Z)).
  exact (fun Z => proj2 (p Z)).
+ intros w Z.
  apply conj.
  exact ((proj1 w) Z).
  exact ((proj2 w) Z).
Defined.

(*Prop 4.1(b)*)
Definition eqc_ref (X : Var) : (X == X).
Proof.
unfold eqc.
intro Z.
refine (conj (fun x => x) (fun x => x)).
Defined.

(*Prop 4.1(c)*)
Theorem eqc_sym (X:Var) (Y:Var) : (X == Y) -> (Y == X).
Proof.
unfold eqc.
intros q Z.
exact (iff_sym (q Z)).
Show Proof.
Defined.

(*Prop 4.1(d)*)
Definition eqc_trans (X Y Z: Var) : (X == Y) -> (Y == Z) -> (X == Z).
Proof.
unfold eqc.
intros Q1 Q2 W.
simple refine (iff_trans (Q1 W) (Q2 W) ).
Defined.

Definition M (X : Var): Prop := ex (fun (Y:Var) => eps X Y).
Definition Pr (X : Var): Prop :=  not (M X).

(*Ex. 4.1*)
Definition ex4_1 :forall X Y, eps X Y -> M X.
Proof.
intros X Y p.
refine (@ex_intro _ _ Y p).
Defined.

Axiom exc_mid : forall (A:Prop), A \/ (not A).

(*Extensionality principle *)
(*Ex. 4.2*)
Definition set_ext (X Y: Var) :X == Y <-> (forall Z:Var, (M Z) -> (eps Z X <-> eps Z Y)).
Proof.
apply conj.
+ intros p Z _.
  exact (p Z).
+ intros p Z .
  destruct (exc_mid (M Z)).
  - simple refine (p Z H).
  - apply conj.
    intro m.
    destruct (H (@ex4_1 Z X m)).
    intro m.
    destruct (H (@ex4_1 Z Y m)).
Defined.

Axiom axT: forall A B Z, (A == B) -> ((eps A Z) <-> (eps B Z)).
(*Ex. 4.3*)
Definition set_transport (Y Z: Var) : (M Z) /\ (Z == Y) -> (M Y).
Proof.
intro w.
pose(p1w:=proj1 w).
pose(p2w:=proj2 w).
unfold M in p1w.
destruct p1w as [q j].
pose(J:= @axT Z Y q p2w ).
exact (ex4_1 _ _(proj1 J j)).
Defined.

(*
Axiom axP: forall x:Var, M(x) ->
          (forall y:Var, M(y) -> (
           ex (fun z:Var => (M z) /\
          (forall u:Var, M(u) ->
          (eps u z <-> (eps u x /\ eps u y) )
           )))).*)

Definition forset (Q:Var->Prop): Prop := forall x:Var, (M x) -> (Q x).
Definition exiset (Q:Var->Prop): Prop := exists x:Var, (M x) /\ (Q x).
Definition exIset (Q:Var->Prop): Prop := (exiset Q) /\
 (forset (fun x =>
  forset (fun y =>
  (Q x) /\ (Q y) -> x == y )
  )).

Definition contra (A B : Prop) : (A -> B) <-> (~B -> ~A).
Proof.
intros.
apply conj.
+ tauto.
(*+ intros f nb a.
  exact (nb (f a)).*)
+ intros g a.
  destruct (exc_mid B) as [H1|H0].
  exact H1.
  destruct (g H0 a).
Defined.
(*
Notation forsetd := (fun (Q:Var->Prop) => forall x:Var, forall mx:M x, (Q x)).
Notation exisetd := (fun (Q:Var->Prop) => exists x:Var, (M x) /\ (Q x)).
Axiom par : forsetd (fun x:Var =>
           forsetd (fun y:Var => Var)).
Axiom axP2: forsetd (fun x:Var =>
           forsetd (fun y:Var =>
           forsetd (fun u:Var =>
           (eps u (par x _ y _) <-> (u == x \/ u == y)
           )))).*)

Axiom par : forall x:Var, forall mx : M x, (forall y:Var, forall my : M y, Var).
Axiom mpar: forall x:Var, forall mx : M x, (forall y:Var, forall my : M y, (M (par x mx y my))).
Axiom axP2: forall x:Var, forall mx : M x,
           (forall y:Var, forall my : M y,
           forset (fun u:Var =>
           (eps u (par x mx y my) <-> (u == x \/ u == y)
           ))).

Definition axP: forset (fun x:Var =>
           forset (fun y:Var =>
           exiset (fun z:Var =>
           forset (fun u:Var =>
           (eps u z) <-> (u == x \/ u == y)
           )))).
Proof.
intros x mx y my.
simple refine (@ex_intro Var _ _ _).
exact (par x mx y my).
apply conj.
exact (mpar x mx y my).
exact (axP2 x mx y my).
Defined.

(*Axiom par2 : forset (fun x:Var =>
            forset (fun y:Var => Prop)).*)

(*Axiom axP: forset (fun x:Var =>
           forset (fun y:Var =>
           exiset (fun z:Var =>
           forset (fun u:Var =>
           (eps u z) <-> (u == x \/ u == y)
           )))).*)

(*Notation "'forset' B ';' A '%'  " := (forall a:A, B) (at level 0) : type_scope.
Context (A B: Prop).
Check (forset B ; A % ).*)
(*Ex. 4.4*)
Definition pair_uniq : forset (fun x:Var =>
           forset (fun y:Var =>
           exIset (fun z:Var =>
           forset (fun u:Var =>
           (eps u z) <-> (u == x \/ u == y)
           )))).
Proof.
 intros X mX Y mY.
 apply conj.

 exact (axP X mX Y mY ).
 intros A mA B mB U H.
 apply conj.
 + intro w.
 Check ex4_1 _ _ w. (*(@ex_intro _ _ H w)*)
   pose (s:= proj2 (proj2 U H (ex4_1 _ _ w))).
   apply s.
   pose (s2:= proj1 (proj1 U H (ex4_1 _ _ w))).
   exact (s2 w).
 + intro w.
   pose (s:= proj2 (proj1 U H (ex4_1 _ _ w))).
   apply s.
   pose (s2:= proj1 (proj2 U H (ex4_1 _ _ w))).
   exact (s2 w).
Defined.

(*Ex. 4.5*)
Definition ex4_5: forall X:Var, ((M X) <-> exiset (fun y => eps X y) ).
Proof.
intro X.
apply conj.
+ intro mX.
  unfold exiset.
  pose (pai :=  axP X mX X mX).
  simpl in pai.
  destruct pai as [c n].
  simple refine (@ex_intro Var _ c _).
  simpl.
  apply conj.
  apply (proj1 n).
  apply (proj2 (proj2 n X mX)).
  Check (eqc_ref X).
  apply or_introl.
  apply eqc_ref.
+ intro q.
  destruct q as [i j].
  simple refine (@ex_intro Var _ i _).
  exact (proj2 j).
Defined.

(*Definition contra (A B : Prop) : (A -> B) <-> (~B -> ~A).
Proof.
apply conj.
+ intros f nb a.
  exact (nb (f a)).
+ intros g a.
  destruct (exc_mid B) as [H1|H0].
  exact H1.
  destruct (g H0 a).
Defined.*)

Definition  asdfgh (P : Var -> Prop)  :forall x : Var, (~ P x -> exists a : Var, ~ P a)
:= (@ex_intro Var (fun a=> ~P(a))).

Definition doub_neg : forall P:Prop, (~~ P) -> (P).
Proof.
intro P.
destruct (exc_mid P) as [H1|H0].
+ intros _ .
  exact H1.
+ intro f.
  destruct (f H0).
Defined.

Definition modul1 (P : Var -> Prop) : (~ exists X, ~ P(X) ) <-> (forall X, P X).
Proof.
apply conj.
+ intros q X.
  destruct (exc_mid (P X)).
  exact H.
  destruct  (q (@ex_intro Var _ X H)).
+ intros g y.
  destruct y as [A B].
  exact (B (g A)).
Defined.

Definition modul2 (*zero:Var*) (P : Var -> Prop) : (exists X, P(X) ) -> (~forall X, ~P X).
Proof.
(*apply conj.
+*) intros q X.
  destruct q as [A B].
  exact (X A B).
(*+ intros g.
  simple refine (@ex_intro Var _ zero _).
  simpl.*)
Defined.

Definition modul2c (P : Var -> Prop) : (~ exists X, P(X) ) -> (forall X, ~P X).
Proof.
intros Q X m.
exact (Q (@ex_intro Var _ X m)).
Defined.

Definition modul2d (P : Var -> Prop) := proj1 (@contra (~ exists X, P(X) ) (forall X, ~P X)) (modul2c P).
Check modul2d.

Definition modul2b (P : Var -> Prop) : (~forall X, ~P X) -> (exists X, P(X) ).
Proof.
intro q.
apply doub_neg.
revert q.
exact (modul2d P).
Defined.

Definition modul3 (P : Var -> Prop) : (exists X, ~P(X) ) -> (~forall X, P X).
Proof.
intros q f.
destruct q as [X H].
exact (H (f X)).
Defined.

Definition pairclass := (forall (Y Z:Var), exists W:Var, forall U:Var, eps U W <-> U == Y \/ U == Z).

(*Axiom axN : (exiset (fun x =>
              (forset (fun y =>
               ~(eps y x)
              ))
              )).*)
Check Var.

Axiom nullclass : Var.
(*Axiom nisset : M nullclass.*)
Axiom aNC : (M nullclass) /\ forset (fun y : Var => ~ eps y nullclass).

Definition axN : (exiset (fun x =>
              (forset (fun y =>
               ~(eps y x)
              ))
              )).
Proof.
simple refine (@ex_intro Var _ nullclass _).
apply aNC.
Defined.
(*Definition nullclass2:Var.
destruct axN. case error*)
(*Definition thmns : Prop.
destruct axN.*)

Definition nullisset: M nullclass := proj1 aNC.
(*Proof.
unfold M.
(*destruct axN.*)
destruct (proj1 aNC) as [A B].
simple refine (@ex_intro Var _ A _).
simpl.
exact B.
Defined.*)

Definition thmN : (exiset (fun x =>
              (forset (fun y =>
               ~(eps y x)
              ))
              )).
Proof.
simple refine (@ex_intro Var _ nullclass _ ).
simpl.
apply conj.
exact nullisset.
Check ex4_1 nullclass.
destruct (axP nullclass nullisset nullclass nullisset).
exact (proj2 aNC).
Defined.

(*destruct axN as [nullset noe]*)

(*Null set is unique*)
Definition nsu : (exIset (fun x =>
              (forset (fun y =>
               ~(eps y x)
              ))
              )).
Proof.
unfold exIset.
apply conj.
+(* apply (@ex_intro _ _ nullclass aNC).*)
apply axN.
+ intros X mX Y mY c K.
  apply conj.
  - intro s.
    destruct (proj1 c K (ex4_1 _ _ s) s).
  - intro s.
    destruct (proj2 c K (ex4_1 _ _ s) s).
Defined.

Notation "'{' X ',' Y '}'":= (axP X _ Y _) (at level 0) : type_scope.

(*delete Check ex.
Axiom pr1 : forall (P : Var -> Prop), (ex P) -> Var.
Axiom pr2 : forall (P : Var -> Prop), forall (s:ex P), (P (pr1 P s)).
*)

Definition pr (A : Prop) (P : A -> Prop): (ex P) -> A.
Proof.
intro s.
destruct s.
exact x.
Defined.
(*
Definition pr (P : Var -> Prop): (ex P) -> Var.
Proof.
intro s.
destruct s.
Check (exc_mid (ex P)).
Check  (exists x, P x) \/ ~ (exists x, P x).
destruct (exc_mid (ex P)).
destruct s.*)

(*Ex. 4.6*)
Definition ex4_6: (exists X, (Pr X)) ->
~pairclass.
Proof.
 pose (j:= contra (exists X:Var, Pr X) (~pairclass)).
 apply (proj2 j).
 unfold pairclass, Pr, M.

 intro t.
 apply modul1.
 pose (tt:= doub_neg pairclass t).
 unfold pairclass in tt.
 intro X.
 destruct (tt X X) as [A B].
 pose (W := proj2 (B X) (or_introl (eqc_ref X))).
 exact (@ex_intro Var _ _ W).
Defined.

(*Ex. 4.7a*)
(*Definition pair_sym : forset (fun x =>
forset (fun y =>
 (pr1 _ {x , y}) == (pr1 _ {y , x})
)
).*)

(*{|}*)

Definition E := exiset (fun x => exiset (fun y => eps x y) ).
Definition Trans (X:Var):= forset (fun u => (eps u X -> sub u X) ).

(*Check axN.
Axiom nullclass : Var.
Axiom aNC : forset (fun y : Var => ~ eps y nullclass).
*)
(*Ex.4.29c*)
Definition emptrans : Trans (nullclass).
Proof.
unfold Trans.
intros u l j.
(*destruct (aNC u l j).!!!*)
unfold sub.
destruct ((proj2 aNC) u l j).
Defined.

Axiom compl : forall X:Var, Var.
Axiom B3 : forall X, forset (fun u => eps u (compl X) <-> ~ eps u X).
(*Axiom B3 : forall X, exists Y, forset (fun u => eps u Y <-> ~ eps u X). (*complement*)*)

Definition V:= compl nullclass.
(* ================== end of file ==================
(*Prop. 4.8 Class Existence Theorem*)
Definition V2:=.
Definition Rel := sub X V2.
Definition Irr (X Y : Var) := (Rel X) /\ (forset (fun y=> eps y Y -> ~ eps (pair y y) X)).

Definition We (X Y : Var) := (Irr X Y) /\ (forall Z:Var, (sub Z Y /\ ~(Z==nullclass) ->
exiset (fun y => eps y Z /\
forset (fun v => eps v Z /\ ~(v==y) -> (eps (pair y v) X /\ ~eps (pair v y) X)
)
)
)).

Definition Ord (X:Var):=(We E X) /\ (Trans X)
(*Class of ordinal numbers*)
Definition On:=..

Definition forord (Q:Var->Prop): Prop := forall x:Var, (Ord x) -> (Q x).
Definition exiord (Q:Var->Prop): Prop := exists x:Var, (Ord x) /\ (Q x).
Definition exIord (Q:Var->Prop): Prop := (exiord Q) /\
 (forord (fun x =>
  forord (fun y =>
  (Q x) /\ (Q y) -> x == y )
  )).

*)
(*Prop. 4.9: Transfinite induction*)