Require Export basic.

(******************************************************************************************)
(*It is the syntax model of the theory*)
(******************************************************************************************)
Module Type TheorySyn.

(*The set of first-order terms*)
Parameter foterm : Set.

(*Lift term*)
Parameter lift_term_rec : foterm -> nat -> nat -> foterm.
Definition lift_term t n := lift_term_rec t n 0.

(*Substitute term*)
Parameter subst_term_rec : foterm -> foterm -> nat -> foterm.
Definition subst_term M N := subst_term_rec M N 0.

(*fv_term_rec list all free variables in a term with a binder k*)
(*The free variables are used for indexes in a context in which the term is well typed*)
(*So, the free variables are subtracted by the binder k*)
Parameter fv_term_rec : foterm -> (*k*)nat -> list nat.
Definition fv_term t := fv_term_rec t 0.

(*First-order formula*)
Parameter
  (foformula : Set)
  (eq_foterm : foterm -> foterm -> foformula)
  (TF : foformula)
  (BF   : foformula)
  (neg : foformula -> foformula)
  (conj : foformula -> foformula -> foformula)
  (disj : foformula -> foformula -> foformula)
  (implf : foformula -> foformula -> foformula)
  (fall : foformula -> foformula)
  (exst : foformula -> foformula).

(*Lift formula*)
Parameter lift_fml_rec : foformula -> nat -> nat -> foformula.
Definition lift_fml t n := lift_fml_rec t n 0.
Parameter lift_fml_split : forall f n k,
  lift_fml_rec f (S n) k = lift_fml_rec (lift_fml_rec f n k) 1 k.

(*Substitute formula*)
Parameter subst_fml_rec : foformula -> foterm -> nat -> foformula.
Definition subst_fml f N := subst_fml_rec f N 0.

(*Free variables in a formula, the idea is the same with definition fv_term*)
Parameter fv_fml_rec : foformula -> nat -> list nat.
Definition fv_fml f := fv_fml_rec f 0.
Parameter fv_fml_eq_term : forall x y,
  fv_fml (eq_foterm x y) = (fv_term x) ++ (fv_term y).
Parameter fv_fml_neg : forall f,
  fv_fml (neg f) = fv_fml f.
Parameter fv_fml_conj : forall x y,
  fv_fml (conj x y) = (fv_fml x) ++ (fv_fml y).
Parameter fv_fml_disj : forall x y,
  fv_fml (disj x y) = (fv_fml x) ++ (fv_fml y).
Parameter fv_fml_implf : forall x y,
  fv_fml (implf x y) = (fv_fml x) ++ (fv_fml y).
Parameter fv_fml_fall : forall f,
  fv_fml (fall f) = (fv_fml_rec f 1).
Parameter fv_fml_exst : forall f,
  fv_fml (exst f) = (fv_fml_rec f 1).
Parameter in_S_fv_fml : forall f n k,
  In (S n) (fv_fml_rec f k) <-> In n (fv_fml_rec f (S k)).
Parameter in_fv_fml_subst : forall f n N k k',
  In (S n) (fv_fml_rec f (k+k')) ->
  In n (fv_fml_rec (subst_fml_rec f N k') (k+k')).

(*Well-typed term and foformula*)
Definition hyp_ok_term (hyp:list (option foformula)) t :=
  forall n, In n (fv_term t) -> nth_error hyp n = Some None.
Definition hyp_ok_fml (hyp:list (option foformula)) f :=
  forall n, In n (fv_fml f) -> nth_error hyp n = Some None.

(*Theory Axioms*)
Parameter ax : list (option foformula) -> foformula -> Prop.

(*Derivation rules for the first order theory*)
Inductive deriv : list (option foformula) -> foformula -> Prop :=
| hyp_judge : forall f hyp n,
  nth_error hyp n = Some (Some f) ->
  hyp_ok_fml hyp (lift_fml f (S n)) ->
  deriv hyp (lift_fml f (S n))
| ax_intro : forall f hyp, ax hyp f -> deriv hyp f
| true_intro : forall hyp, deriv hyp TF
| false_elim : forall hyp f, deriv hyp BF -> hyp_ok_fml hyp f -> deriv hyp f
| neg_intro : forall hyp f, deriv hyp (implf f BF) -> deriv hyp (neg f)
| neg_elim : forall hyp f, deriv hyp (neg f) -> deriv hyp (implf f BF)
| conj_intro : forall hyp f1 f2,
  deriv hyp f1 -> deriv hyp f2 -> deriv hyp (conj f1 f2)
| conj_elim1 : forall hyp f1 f2,
  deriv hyp (conj f1 f2) -> deriv hyp f1
| conj_elim2 : forall hyp f1 f2,
  deriv hyp (conj f1 f2) -> deriv hyp f2
| disj_intro1 : forall hyp f1 f2,
  deriv hyp f1 -> hyp_ok_fml hyp f2 -> deriv hyp (disj f1 f2)
| disj_intro2 : forall hyp f1 f2,
  hyp_ok_fml hyp f1 ->
  deriv hyp f2 -> deriv hyp (disj f1 f2)
| disj_elim : forall hyp f1 f2 f3,
  deriv hyp (disj f1 f2) -> deriv (Some f1::hyp) (lift_fml f3 1) ->
  deriv (Some f2::hyp) (lift_fml f3 1) -> deriv hyp f3
| impl_intro : forall hyp f1 f2,
  hyp_ok_fml hyp f1 ->
  deriv ((Some f1)::hyp) (lift_fml f2 1) -> deriv hyp (implf f1 f2)
| impl_elim : forall hyp f1 f2,
  deriv hyp (implf f1 f2) -> deriv hyp f1 -> deriv hyp f2
| fall_intro : forall hyp f,
  deriv (None::hyp) f -> deriv hyp (fall f)
| fall_elim : forall hyp f u,
  hyp_ok_term hyp u -> deriv hyp (fall f) -> deriv hyp (subst_fml f u)
| exst_intro : forall hyp f N, hyp_ok_term hyp N ->
  deriv hyp (subst_fml f N) -> deriv hyp (exst f)
| exst_elim : forall hyp f f1,
  deriv hyp (exst f) ->
  deriv (Some f::None::hyp) (lift_fml f1 2) -> deriv hyp f1.

(*Any derivable formula should well typed*)
Parameter deriv_well_typed : forall hyp f, deriv hyp f -> hyp_ok_fml hyp f.

Parameter hyp_ok_weakening : forall hyp t f',
  hyp_ok_fml (t :: hyp) (lift_fml f' 1) ->
  hyp_ok_fml hyp f'.

End TheorySyn.
(************************************************************************************)

Require Import GenLemmas.

Import ZFuniv_real SN_CC_Real.

(************************************************************************************)
(*Sematic model of the first order theory*)
(************************************************************************************)

(*Constant part of the first oder theory, independent with the signature*)
Module FOTheory_Cst.

(*False_symb for BF*)
Definition False_symb := Prod prop (Ref 0).

Lemma False_symb_typ : forall e, typ e False_symb prop.
intros; apply typ_prod; [right; trivial|left; apply typ_prop|].
 setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
   [apply typ_var; trivial|simpl; split; red; reflexivity].
Qed.

Lemma False_symb_elim : forall e t P,
  typ e t False_symb ->
  typ e P prop ->
  typ e (App t P) P.
red; intros e t P Ht HP i j Hok.
generalize HP; intros HSP.
apply red_typ with (1:=Hok) in HSP; [destruct HSP as (HSP, _)|discriminate].
revert i j Hok; fold (typ e (App t P) P).
setoid_replace P with (subst P (Ref 0)) using relation eq_term at 2;
  [|unfold subst; rewrite red_sigma_var_eq; [rewrite lift0; reflexivity|trivial]].
apply typ_app with (V:=prop); [| |discriminate|discriminate]; trivial.
Qed.

(*True_symb for TF*)
Definition True_symb := Prod prop (Prod (Ref 0) (Ref 1)).

Lemma True_symb_typ : forall e, typ e True_symb prop.
intro e.
apply typ_prod; [right; trivial|left; apply typ_prop|].
apply typ_prod; [right; trivial|right|].
 setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
   [apply typ_var; trivial|simpl; split; red; reflexivity].

 setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
   [apply typ_var; trivial|simpl; split; red; reflexivity].
Qed.

Lemma True_symb_intro : forall e, exists t, typ e t True_symb.
exists (Abs prop (Abs (Ref 0) (Ref 0))).
apply typ_abs; [left; apply typ_prop| |discriminate].
apply typ_abs; [right| |discriminate].
 setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
   [apply typ_var; trivial|simpl; split; red; reflexivity].

 rewrite <- (eq_term_lift_ref_fv 1 0 0); [apply typ_var; trivial|omega].
Qed.

(*Impl for implf*)
Definition Impl A B := Prod A (lift 1 B).

Lemma Impl_typ : forall e A B,
  typ e A prop ->
  typ e B prop ->
  typ e (Impl A B) prop.
intros. apply typ_prod; [right|right|]; trivial.
setoid_replace prop with (lift 1 prop) using relation eq_term;
  [apply weakening; trivial|simpl; split; red; reflexivity].
Qed.

Lemma Impl_intro : forall e b A B,
  typ e A prop ->
  B <> kind ->
  typ (A::e) b (lift 1 B) ->
  typ e (Abs A b) (Impl A B).
intros. apply typ_abs; [right| |destruct B; [discriminate|]]; trivial.
Qed.

Lemma Impl_elim : forall e t u A B,
  A <> kind ->
  B <> kind ->
  typ e t (Impl A B) ->
  typ e u A ->
  typ e (App t u) B.
intros.
setoid_replace B with (subst u (lift 1 B)) using relation eq_term;
  [|unfold subst; rewrite subst_lift_lt; [rewrite lift0; reflexivity|omega]].
apply typ_app with (V:=A); [| | |destruct B; [discriminate|]]; trivial.
Qed.

(*Neg for neg*)
Definition Neg t := Impl t False_symb.

Lemma Neg_typ : forall e t,
  typ e t prop ->
  typ e (Neg t) prop.
intros; unfold Neg; apply Impl_typ; [trivial|apply False_symb_typ].
Qed.

Lemma Neg_intro : forall na A e,
  typ e na (Impl A False_symb) ->
  typ e na (Neg A).
intros; unfold Neg; trivial.
Qed.

Lemma Neg_elim : forall na A e,
  typ e na (Neg A) ->
  typ e na (Impl A False_symb).
intros; unfold Neg; trivial.
Qed.

(*Conj for conj*)
Definition Conj A B :=
  Prod prop (Prod (Prod (lift 1 A) (Prod (lift 2 B) (Ref 2))) (Ref 1)).

Lemma Conj_typ : forall e A B,
  typ e A prop ->
  typ e B prop ->
  typ e (Conj A B) prop.
intros.
apply typ_prod; [right|left; apply typ_prop|]; trivial.
apply typ_prod; [right|right|]; trivial.
 apply typ_prod; [right|right|]; trivial.
  setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
    [apply weakening; trivial|simpl; split; red; reflexivity].

  apply typ_prod; [right; trivial|right|].
   setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
     [do 2 rewrite split_lift with (n:=1);
       do 2 apply weakening; trivial
       |simpl; split; red; reflexivity].

   setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

 setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
   [apply typ_var; trivial|simpl; split; red; reflexivity].
Qed.

Lemma Conj_intro : forall e A B u v,
  typ e A prop ->
  typ e B prop ->
  typ e u A /\ typ e v B ->
  exists t, typ e t (Conj A B).
intros e A B u v HTA HTB H. destruct H as (HA, HB).
exists (Abs prop (Abs (Prod (lift 1 A) (Prod (lift 2 B) (Ref 2)))
  (App (App (Ref 0) (lift 2 u)) (lift 2 v)))).
red; intros i j Hok.
generalize HTA; intros HSA.
generalize HTB; intros HSB.
apply red_typ with (1:=Hok) in HSA; [destruct HSA as (HSA, _)|discriminate].
apply red_typ with (1:=Hok) in HSB; [destruct HSB as (HSB, _)|discriminate].
revert i j Hok;
fold (typ e (Abs prop (Abs (Prod (lift 1 A) (Prod (lift 2 B) (Ref 2)))
  (App (App (Ref 0) (lift 2 u)) (lift 2 v)))) (Conj A B)).
apply typ_abs; [left; apply typ_prop| |discriminate].
apply typ_abs; [right| |discriminate].
 apply typ_prod; [right; trivial|right|].
  setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
    [apply weakening; trivial|simpl; split; red; reflexivity].

  apply typ_prod; [right; trivial|right|].
   setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
     [do 2 rewrite split_lift with (n:=1);
       do 2 apply weakening; trivial|simpl; split; red; reflexivity].

   setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

 setoid_replace (Ref 1) with (subst (lift 2 v) (Ref 2)) using relation eq_term;
  [|unfold subst; rewrite red_sigma_var_gt; [reflexivity|omega]].
 apply typ_app with (V:=(lift 2 B));
   [| |destruct B; [discriminate|]|discriminate]; trivial.
  rewrite split_lift with (n:=1) at 2.
  rewrite split_lift with (n:=1) (T:=v).
  do 2 apply weakening; trivial.

  setoid_replace (Prod (lift 2 B) (Ref 2)) with
    (subst (lift 2 u) (lift 1 (Prod (lift 2 B) (Ref 2)))) using relation eq_term at 2; [
      |unfold subst; unfold lift at 3; rewrite <- simpl_subst_lift_rec; reflexivity].
  apply typ_app with (V:=lift 2 A);
    [| |destruct A; [discriminate|]|discriminate]; trivial.
   rewrite split_lift with (T:=u). rewrite split_lift with (T:=A) (n:=1).
   do 2 apply weakening; trivial.

   unfold lift at 4. rewrite red_lift_prod.
   rewrite <- split_lift with (n:=2) (T:=B).
   rewrite eq_term_lift_ref_fv; [simpl|omega].
   assert (eq_term ((Prod (lift 2 A) (Prod (lift 3 B) (Ref 3))))
     (lift 1 (Prod (lift 1 A) (Prod (lift 2 B) (Ref 2))))).
    unfold lift at 3. rewrite red_lift_prod.
    rewrite <- split_lift with (T:=A) (n:=1).
    rewrite red_lift_prod.
    rewrite eq_term_lift_ref_fv; [|omega].
    unfold lift at 4. rewrite lift_rec_acc; [reflexivity|omega].

   rewrite H. apply typ_var; trivial.
Qed.

Lemma Conj_elim1 : forall e A B t,
  typ e A prop ->
  typ e B prop ->
  typ e t (Conj A B) ->
  exists u, typ e u A.
intros e A B t HA HB Ht;
  exists (App (App t A) (Abs A (Abs (lift 1 B) (Ref 1)))).
red; intros i j Hok.
generalize HA; intros HSA.
generalize HB; intros HSB.
apply red_typ with (1:=Hok) in HSA; [destruct HSA as (HSA, _)|discriminate].
apply red_typ with (1:=Hok) in HSB; [destruct HSB as (HSB, _)|discriminate].
revert i j Hok;
fold (typ e ((App (App t A) (Abs A (Abs (lift 1 B) (Ref 1))))) A).

rewrite (simpl_subst_lift_rec (Abs A (Abs (lift 1 B) (Ref 1))) A 0) at 3.
fold (lift 1 A). fold (subst (Abs A (Abs (lift 1 B) (Ref 1))) (lift 1 A)).
apply typ_app with (V:=Prod A (Prod (lift 1 B) (lift 2 A)));
  [| |discriminate|destruct A; [discriminate|trivial]].
 apply typ_abs; [right; trivial| |discriminate].
  apply typ_abs; [right|apply typ_var|destruct A; [discriminate|]]; trivial.
   setoid_replace prop with (lift 1 prop) using relation eq_term;
     [apply weakening; trivial|simpl; split; red; reflexivity].

 unfold Conj in Ht.
 assert (eq_term ((Prod (Prod A (Prod (lift 1 B) (lift 2 A))) (lift 1 A)))
   (subst A (Prod (Prod (lift 1 A) (Prod (lift 2 B) (Ref 2))) (Ref 1)))).
  unfold subst. do 3 rewrite red_sigma_prod.
  do 2 (rewrite red_sigma_var_eq; trivial).
  do 2 (rewrite subst_lift_lt; [|omega]).
  rewrite lift0; reflexivity.

 rewrite H; clear H.
 apply typ_app with (V:=prop); [trivial|trivial|discriminate|discriminate].
Qed.

Lemma Conj_elim2 : forall e A B t,
  typ e A prop ->
  typ e B prop ->
  typ e t (Conj A B) ->
  exists u, typ e u B.
intros e A B t HA HB Ht;
  exists (App (App t B) (Abs A (Abs (lift 1 B) (Ref 0)))).
red; intros i j Hok.
generalize HA; intros HSA.
generalize HB; intros HSB.
apply red_typ with (1:=Hok) in HSA; [destruct HSA as (HSA, _)|discriminate].
apply red_typ with (1:=Hok) in HSB; [destruct HSB as (HSB, _)|discriminate].
revert i j Hok;
fold (typ e ((App (App t B) (Abs A (Abs (lift 1 B) (Ref 0))))) B).

rewrite (simpl_subst_lift_rec (Abs A (Abs (lift 1 B) (Ref 0))) B 0) at 3.
fold (lift 1 B). fold (subst (Abs A (Abs (lift 1 B) (Ref 0))) (lift 1 B)).
apply typ_app with (V:=Prod A (Prod (lift 1 B) (lift 1 (lift 1 B))));
  [| |discriminate|destruct B; [discriminate|trivial]].
 apply typ_abs; [right; trivial| |discriminate].
  apply typ_abs; [right|apply typ_var|destruct B; [discriminate|]]; trivial.
   setoid_replace prop with (lift 1 prop) using relation eq_term;
     [apply weakening; trivial|simpl; split; red; reflexivity].

 unfold Conj in Ht.
 assert (eq_term ((Prod (Prod A (Prod (lift 1 B) (lift 2 B))) (lift 1 B)))
   (subst B (Prod (Prod (lift 1 A) (Prod (lift 2 B) (Ref 2))) (Ref 1)))).
  unfold subst. do 3 rewrite red_sigma_prod.
  do 2 (rewrite red_sigma_var_eq; trivial).
  do 2 (rewrite subst_lift_lt; [|omega]).
  rewrite lift0; reflexivity.

 rewrite <- split_lift. rewrite H; clear H.
 apply typ_app with (V:=prop); [trivial|trivial|discriminate|discriminate].
Qed.

(*Disj for disj*)
Definition Disj A B := Prod prop (Prod (Prod (lift 1 A) (Ref 1))
  (Prod (Prod (lift 2 B) (Ref 2)) (Ref 2))).

Lemma Disj_typ : forall e A B,
  typ e A prop ->
  typ e B prop ->
  typ e (Disj A B) prop.
intros. apply typ_prod; [right; trivial|left; apply typ_prop|].
apply typ_prod; [right; trivial|right|].
 apply typ_prod; [right; trivial|right|].
  setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
    [apply weakening; trivial|simpl; split; red; reflexivity].

  setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
    [apply typ_var; trivial|simpl; split; red; reflexivity].

 apply typ_prod; [right; trivial|right|].
  apply typ_prod; [right; trivial|right|].
   setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
     [do 2 rewrite split_lift with (n:=1); do 2 apply weakening; trivial
       |simpl; split; red; reflexivity].

   setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

  setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
    [apply typ_var; trivial|simpl; split; red; reflexivity].
Qed.

Lemma Disj_intro1 : forall e t A B,
  typ e A prop ->
  typ e B prop ->
  typ e t A  ->
  exists u, typ e u (Disj A B).
intros e t A B HA HB Ht.
exists (Abs prop (Abs (Prod (lift 1 A) (Ref 1))
  (Abs (Prod (lift 2 B) (Ref 2)) (App (Ref 1) (lift 3 t))))).
red; intros i j Hok.
generalize HA; intros HSA.
apply red_typ with (1:=Hok) in HSA; [destruct HSA as (HSA, _)|discriminate].
revert i j Hok;
fold (typ e (Abs prop (Abs (Prod (lift 1 A) (Ref 1))
  (Abs (Prod (lift 2 B) (Ref 2))
  (App (Ref 1) (lift 3 t))))) (Disj A B)).
apply typ_abs; [left; apply typ_prop| |discriminate].
 apply typ_abs; [right| |discriminate].
  apply typ_prod; [right; trivial|right|].
   setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
     [apply weakening; trivial|simpl; split; red; reflexivity].

   setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

  apply typ_abs; [right| |discriminate].
   apply typ_prod; [right; trivial|right|].
    setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
      [do 2 rewrite split_lift with (n:=1); do 2 apply weakening
        |simpl; split; red; reflexivity]; trivial.

    setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
      [apply typ_var; trivial|simpl; split; red; reflexivity].

   setoid_replace (Ref 2) with (subst (lift 3 t) (Ref 3)) using relation eq_term at 2; [
     |unfold subst; rewrite red_sigma_var_gt; [reflexivity|omega]].
   apply typ_app with (V:=(lift 3 A));
     [| |destruct A; [discriminate|trivial]|discriminate].
    do 2 rewrite split_lift with (T:=t).
    rewrite split_lift with (T:=A) (n:=2).
    rewrite split_lift with (T:=A) (n:=1).
    do 3 apply weakening; trivial.

    rewrite <- (eq_term_lift_ref_fv 1 1 2) by omega.
    rewrite split_lift with (n:=2).
    unfold lift at 3. rewrite <- red_lift_prod.
    fold (lift 1 (Prod (lift 2 A) (Ref 2))).
    rewrite <- (eq_term_lift_ref_fv 1 1 1) at 2 by omega.
    rewrite split_lift with (n:=1) (T:=A).
    unfold lift at 4. rewrite <- red_lift_prod.
    fold (lift 1 (Prod (lift 1 A) (Ref 1))).
    rewrite <- split_lift. apply typ_var; trivial.
Qed.

Lemma Disj_intro2 : forall e t A B,
  typ e A prop ->
  typ e B prop ->
  typ e t B  ->
  exists u, typ e u (Disj A B).
intros e t A B HA HB Ht.
exists (Abs prop (Abs (Prod (lift 1 A) (Ref 1))
  (Abs (Prod (lift 2 B) (Ref 2)) (App (Ref 0) (lift 3 t))))).
red; intros i j Hok.
generalize HB; intros HSB.
apply red_typ with (1:=Hok) in HSB; [destruct HSB as (HSB, _)|discriminate].
revert i j Hok;
fold (typ e (Abs prop (Abs (Prod (lift 1 A) (Ref 1))
  (Abs (Prod (lift 2 B) (Ref 2)) (App (Ref 0) (lift 3 t))))) (Disj A B)).
apply typ_abs; [left; apply typ_prop| |discriminate].
 apply typ_abs; [right| |discriminate].
  apply typ_prod; [right; trivial|right|].
   setoid_replace prop with (lift 1 prop) using relation eq_term at 2;
     [apply weakening; trivial|simpl; split; red; reflexivity].

   setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

  apply typ_abs; [right| |discriminate].
   apply typ_prod; [right; trivial|right|].
    setoid_replace prop with (lift 2 prop) using relation eq_term at 2;
      [do 2 rewrite split_lift with (n:=1); do 2 apply weakening
        |simpl; split; red; reflexivity]; trivial.

    setoid_replace prop with (lift 3 prop) using relation eq_term at 2;
      [apply typ_var; trivial|simpl; split; red; reflexivity].

   setoid_replace (Ref 2) with (subst (lift 3 t) (Ref 3)) using relation eq_term at 2; [
     |unfold subst; rewrite red_sigma_var_gt; [reflexivity|omega]].
   apply typ_app with (V:=(lift 3 B));
     [| |destruct B; [discriminate|trivial]|discriminate].
    do 2 rewrite split_lift with (T:=t).
    rewrite split_lift with (T:=B) (n:=2).
    rewrite split_lift with (T:=B) (n:=1) at 2.
    do 3 apply weakening; trivial.

    rewrite <- (eq_term_lift_ref_fv 1 1 2) by omega.
    rewrite split_lift with (n:=2).
    unfold lift at 3. rewrite <- red_lift_prod.
    fold (lift 1 (Prod (lift 2 B) (Ref 2))).
    apply typ_var; trivial.
Qed.

Lemma Disj_elim : forall e t t1 t2 A B C,
  typ e A prop ->
  typ e B prop ->
  typ e C prop ->
  typ e t (Disj A B) ->
  typ (A::e) t1 (lift 1 C) ->
  typ (B::e) t2 (lift 1 C) ->
  exists u, typ e u C.
intros e t t1 t2 A B C HA HB HC Ht Ht1 Ht2.
exists (App (App (App t C) (Abs A t1)) (Abs B t2)).
red; intros i j Hok.
generalize HC; intros HSC.
apply red_typ with (1:=Hok) in HSC; [destruct HSC as (HSC, _)|discriminate].
revert i j Hok;
fold (typ e (App (App (App t C) (Abs A t1)) (Abs B t2)) C).
apply Impl_intro in Ht1; [|exact HA|exact HSC].
apply Impl_intro in Ht2; [|exact HB|exact HSC].
setoid_replace C with (subst (Abs B t2) (lift 1 C)) using relation eq_term at 2; [
  |unfold subst; rewrite subst_lift_lt; [rewrite lift0; reflexivity|omega]].
apply typ_app with (V:=(Impl B C));
  [| |discriminate|destruct C; [discriminate|]]; trivial.
setoid_replace (Prod (Impl B C) (lift 1 C)) with
  (subst (Abs A t1) (lift 1 (Prod (Impl B C) (lift 1 C)))) using relation eq_term; [
    |unfold subst; rewrite subst_lift_lt; [rewrite lift0; reflexivity|omega]].
apply typ_app with (V:=(Impl A C)); [trivial| |discriminate|discriminate].
unfold Impl; unfold Disj in Ht.
unfold lift at 2 3 4. do 2 rewrite red_lift_prod.
rewrite lift_rec_acc; [simpl plus|omega].
fold (lift 1 B) (lift 2 C).
assert (eq_term
  (Prod (Prod A (lift 1 C)) (Prod (Prod (lift 1 B) (lift 2 C)) (lift 2 C)))
  (subst C (Prod (Prod (lift 1 A) (Ref 1))
    (Prod (Prod (lift 2 B) (Ref 2)) (Ref 2))))).
 unfold subst. do 4 rewrite red_sigma_prod.
 do 2 (rewrite subst_lift_lt by omega). rewrite lift0.
 do 2 (rewrite red_sigma_var_eq; trivial); reflexivity.

rewrite H; clear H.
apply typ_app with (V:=prop); [| |discriminate|discriminate]; trivial.
Qed.

End FOTheory_Cst.

(*Specific part of a first-order theory, provide the signature of the theory*)
Module Type TheorySem.

Include FOTheory_Cst.

(*The sort of the theory*)
Parameter sort : term.
Parameter sort_not_kind : sort <> kind.
Parameter sort_not_empty : exists t, forall e, typ e t sort.

(*The sort is closed, since it is first-order*)
Parameter sort_closed : forall i1 i2,
  int sort i1 == int sort i2.

(*The equivalence relation of the theory*)
Parameter EQ_term : term -> term -> term.

Parameter EQ_term_typ : forall x y e,
  typ e x sort ->
  typ e y sort ->
  typ e (EQ_term x y) prop.

Parameter const_env : nat -> list term.
Parameter const_env0 : const_env 0 = nil.
Parameter const_envS : forall n, const_env (S n) = sort :: (const_env n).

Parameter EQ_term_eq_typ : forall n x y t,
  typ (const_env n) x sort ->
  typ (const_env n) y sort ->
  typ (const_env n) t (EQ_term x y) ->
  eq_typ (const_env n) x y.

(*Fall for fall, dependent on the sort*)
Parameter Fall : term -> term.
Parameter Fall_typ : forall e A,
  typ (sort :: e) A prop ->
  typ e (Fall A) prop.
Parameter Fall_intro : forall e t B,
  typ (sort::e) B prop ->
  typ (sort::e) t B ->
  typ e (Abs sort t) (Fall B).
Parameter Fall_elim : forall e t u B,
  typ (sort::e) B prop ->
  typ e t (Fall B) ->
  typ e u sort ->
  typ e (App t u) (subst u B).

(*Exst for exst, dependent on the sort*)
Parameter Exst : term -> term.
Parameter Exst_typ : forall e A,
  typ (sort::e) A prop ->
  typ e (Exst A) prop.
Parameter Exst_intro : forall e A p a,
  typ (sort::e) A prop ->
  typ e a sort ->
  typ e p (subst a A) ->
  exists t, typ e t (Exst A).
Parameter Exst_elim : forall e t1 t2 A C,
  typ (sort::e) A prop ->
  typ e C prop ->
  typ e t1 (Exst A) ->
  typ (A::sort::e) t2 (lift 2 C) ->
  exists t, typ e t C.

(*Specific theory axioms. Required : they can be proved in the SN model*)
Parameter ax : Prop.
Parameter ax_provable : ax.

End TheorySem.
(************************************************************************************)

(************************************************************************************)
(*Interpretation form symtax model to sematic model*)
(************************************************************************************)

Require Import SN_nat.

Module Type InterpTheory (M1 : TheorySyn) (M2 : TheorySem).

Import M1 M2.

(*Interpretation first-order term*)
Parameter intp_foterm : foterm -> term.

(*Interpretation is not kind*)
Parameter intp_foterm_not_kind : forall t, intp_foterm t <> kind.

(*Properties about lift and interpretation term*)
Parameter lift_intp_lift_term_rec : forall t n k,
  eq_term (lift_rec n k (intp_foterm t))
         (intp_foterm (lift_term_rec t n k)).
Parameter lift_intp_lift_term : forall t n,
  eq_term (lift n (intp_foterm t))
         (intp_foterm (lift_term t n)).

(*Properties about substitution and interpretation term*)
Parameter subst_intp_subst_term_rec : forall t N k,
  eq_term (subst_rec (intp_foterm N) k (intp_foterm t))
         (intp_foterm (subst_term_rec t N k)).
Parameter subst_intp_subst_term : forall t N,
  eq_term (subst (intp_foterm N) (intp_foterm t))
         (intp_foterm (subst_term t N)).

(*Interpretation of foformula*)
Parameter intp_fofml : foformula -> term.
Parameter intp_fofml_not_kind : forall f, intp_fofml f <> kind.
Parameter intp_eq_fml : forall x y,
  intp_fofml (eq_foterm x y) = EQ_term (intp_foterm x) (intp_foterm y).
Parameter intp_TF : intp_fofml TF = True_symb.
Parameter intp_BF : intp_fofml BF = False_symb.
Parameter intp_neg : forall f,
  intp_fofml (neg f) = Neg (intp_fofml f).
Parameter intp_conj : forall x y,
  intp_fofml (conj x y) = Conj (intp_fofml x) (intp_fofml y).
Parameter intp_disj : forall x y,
  intp_fofml (disj x y) = Disj (intp_fofml x) (intp_fofml y).
Parameter intp_implf : forall x y,
  intp_fofml (implf x y) = Impl (intp_fofml x) (intp_fofml y).
Parameter intp_fall : forall f,
  intp_fofml (fall f) = Fall (intp_fofml f).
Parameter intp_exst : forall f,
  intp_fofml (exst f) = Exst (intp_fofml f).

(*Properties about lift and interpretation formula*)
Parameter lift_intp_lift_fml_rec : forall f n k,
  eq_term (lift_rec n k (intp_fofml f))
         (intp_fofml (lift_fml_rec f n k)).
Parameter lift_intp_lift_fml : forall f n,
  eq_term (lift n (intp_fofml f))
         (intp_fofml (lift_fml f n)).

(*Properties about substitution and interpretation foformula*)
Parameter subst_intp_subst_fml_rec : forall f N k,
  eq_term (subst_rec (intp_foterm N) k (intp_fofml f))
         (intp_fofml (subst_fml_rec f N k)).
Parameter subst_intp_subst_fml : forall f N,
  eq_term (subst (intp_foterm N) (intp_fofml f))
         (intp_fofml (subst_fml f N)).

(*Interpretation of the context*)
Parameter intp_hyp : list (option foformula) -> list term.
Parameter intp_nil : intp_hyp nil = nil.
Parameter intp_hyp_cons_fml : forall x e,
  intp_hyp (Some x :: e) = intp_fofml x :: intp_hyp e.
Parameter intp_hyp_cons_sort : forall e,
  intp_hyp (None :: e) = sort :: intp_hyp e.
Parameter intp_hyp_nth_fml : forall hyp f n,
  nth_error hyp n = Some (Some f) ->
  nth_error (intp_hyp hyp) n = Some (intp_fofml f).
Parameter intp_hyp_nth_term : forall hyp n,
  nth_error hyp n = value None ->
  nth_error (intp_hyp hyp) n = value sort.

(*The interpretation of foterm is sort*)
Parameter intp_foterm_sort : forall hyp t,
  hyp_ok_term hyp t ->
  typ (intp_hyp hyp) (intp_foterm t) sort.

(*The interpretation of the foformula is prop*)
Parameter intp_fofml_prop : forall f hyp,
  hyp_ok_fml hyp f ->
  typ (intp_hyp hyp) (intp_fofml f) prop.

(*Axioms in first-order theory is provable in the associated module*)
Parameter intp_ax : forall hyp f,
  M1.ax hyp f ->
  exists t, typ (intp_hyp hyp) t (intp_fofml f).

End InterpTheory.


Require Export XR_single_z_r_R1.

Local Open Scope R_scope.

Lemma tech_up : forall r z,
  r < IZR z ->
  IZR z <= r + R1 ->
  z = up r.
Proof.
  intros x n hl hu.
  destruct (archimed x) as [ al au ].
  apply single_z_r_R1 with x.
  { exact hl. }
  { exact hu. }
  { exact al. }
  {
    rewrite (Rplus_comm x).
    apply Rplus_le_reg_r with (-x).
    rewrite Rplus_assoc.
    rewrite Rplus_opp_r.
    rewrite Rplus_0_r.
    unfold Rminus in au.
    exact au.
  }
Qed.


(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega List Permutation.

Require Import utils ill_form ill_rules phase_sem.

Set Implicit Arguments.

Local Infix "~!" := perm_bang_t.

Section Rules.

  Variable (P : list ill_form -> ill_form -> Type).

  Notation "Γ ⊨ A" := (P Γ A) (at level 70, no associativity).

  Implicit Types (X Y : list ill_form -> Type).

  Definition cl_ctx X Ω := forall Γ Δ A, (forall ϴ, X ϴ -> Γ++ϴ++Δ ⊨ A)
                                       ->                  Γ++Ω++Δ ⊨ A.

  Definition comp_ctx (Γ Δ ϴ : list ill_form) := Γ++Δ ~! ϴ.

  Notation cl := cl_ctx.
  Notation comp := comp_ctx.

  Infix "∘" := (Composes comp_ctx) (at level 50, no associativity).

  Notation J := (fun Γ => cl (sg ∅) Γ * cl (sg Γ ∘ sg Γ) Γ)%type.
  Notation K := (fun Γ => { Δ | Γ = ‼Δ }).

  (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ ⟦ ⟧ ⟬߭ ⟭  ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ Γ Δ ϴ ⊨ *)

  Fact cl_ctx_increase X : X ⊆ cl X.
  Proof. intros ? ? ? ?; auto. Qed.

  Fact cl_ctx_mono X Y : X ⊆ Y -> cl X ⊆ cl Y.
  Proof.
    intros H1 om Hom ga de x HY.
    apply Hom.
    intros; apply HY, H1; auto.
  Qed.

  Fact cl_ctx_idem X : cl (cl X) ⊆ cl X.
  Proof.
    intros om Hom ga de x HX.
    apply Hom.
    intros th Hth.
    apply Hth, HX.
  Qed.

  Hint Resolve cl_ctx_increase cl_ctx_mono cl_ctx_idem.

  Hypothesis P_perm : forall Γ Δ A, Γ ~! Δ -> Γ ⊨ A -> Δ ⊨ A.

  Hint Resolve perm_bang_t_refl.

(*
  Local Fact cl_comm Γ Δ : sg Γ ∘ sg Δ ⊆ cl (sg Δ ∘ sg Γ).
  Proof.
    intros _ [ ga de th ? ? Hth ]; subst Γ Δ.
    intros rho x H; apply H.
    constructor 1 with de ga; auto.
    revert Hth; unfold comp.
    apply perm_t_trans; auto.
  Qed.
*)

  Local Fact cl_neutral_1 : forall Γ, cl (sg ∅ ∘ sg Γ) Γ.
  Proof.
    intros ga de th x H.
    apply H.
    constructor 1 with nil ga; auto.
    red; simpl; auto.
  Qed.

  Local Fact cl_neutral_3 : forall Γ, cl (sg Γ ∘ sg ∅) Γ.
  Proof.
    intros ga de th x H.
    apply H.
    constructor 1 with ga nil; auto.
    red; simpl; rewrite <- app_nil_end; auto.
  Qed.

  Local Fact cl_neutral_2 : forall Γ, sg ∅ ∘ sg Γ ⊆ cl (sg Γ).
  Proof.
    intros ga ? [ de th ka ? ? H1 ] rho om x G; subst th de.
    cbv in H1.
    generalize (G _ eq_refl).
    apply P_perm.
    do 2 (apply perm_bang_t_app; auto).
  Qed.

  Local Fact cl_neutral_4 : forall Γ, sg Γ ∘ sg ∅ ⊆ cl (sg Γ).
  Proof.
    intros ga ? [ de th ka ? ? H1 ] rho om x G; subst th de.
    red in H1; rewrite <- app_nil_end in H1.
    generalize (G _ eq_refl).
    apply P_perm.
    do 2 (apply perm_bang_t_app; auto).
  Qed.

  Fact cl_ctx_stable_l : forall X Y, cl X ∘ Y ⊆ cl (X ∘ Y).
  Proof.
    intros X Y _ [ ga de th H1 H2 H3 ] rho om x HXY.
    red in H1; red in H3.
    apply P_perm with (rho++ga++de++om).
    1: { apply perm_bang_t_app; auto.
         rewrite <- app_ass.
         apply perm_bang_t_app; auto. }
    apply H1.
    intros ka Hka.
    replace (rho ++ ka ++ de ++ om)
    with    (rho ++ (ka ++ de) ++ om) by solve list eq.
    apply HXY.
    constructor 1 with ka de; auto.
    red; auto.
  Qed.

  Fact cl_ctx_stable_r : forall X Y, X ∘ cl Y ⊆ cl (X ∘ Y).
  Proof.
    intros X Y _ [ ga de th H1 H2 H3 ] rho om x HXY.
    red in H2; red in H3.
    apply P_perm with ((rho++ga)++de++om).
    1: { rewrite app_ass.
         apply perm_bang_t_app; auto.
         rewrite <- app_ass.
         apply perm_bang_t_app; auto. }
    apply H2.
    intros ka Hka.
    replace ((rho ++ ga) ++ ka ++ om)
    with    (rho ++ (ga ++ ka) ++ om) by solve list eq.
    apply HXY.
    constructor 1 with ga ka; auto.
    red; auto.
  Qed.

  Local Fact cl_assoc_1 : forall Γ Δ ϴ, sg Γ ∘ (sg Δ ∘ sg ϴ) ⊆ cl ((sg Γ ∘ sg Δ) ∘ sg ϴ).
  Proof.
    intros ga de th _ [ ga' rho ka H2 H3 H4 ].
    destruct H3 as [ de' th' to ? ? H3 ]; subst ga' de' th'.
    red in H3, H4.
    intros u x v Hu.
    specialize (Hu ((ga++de)++th)).
    spec all in Hu.
    constructor 1 with (ga++de) th; auto.
    constructor 1 with ga de; auto.
    red; auto.
    red; auto.
    revert Hu.
    apply P_perm, perm_bang_t_app; auto.
    apply perm_bang_t_app; auto.
    rewrite app_ass.
    apply perm_bang_t_trans with (2 := H4).
    apply perm_bang_t_app; auto.
  Qed.

  Local Fact cl_assoc_2 : forall Γ Δ ϴ, (sg Γ ∘ sg Δ) ∘ sg ϴ ⊆ cl (sg Γ ∘ (sg Δ ∘ sg ϴ)).
  Proof.
    intros ga de th _ [ ga' rho ka H2 H3 H4 ].
    destruct H2 as [ de' th' to ? ? H2 ]. subst rho de' th'.
    red in H2, H4.
    intros u x v Hu.
    specialize (Hu (ga++de++th)).
    spec all in Hu.
    constructor 1 with (ga) (de++th); auto.
    constructor 1 with de th; auto.
    red; auto.
    red; auto.
    revert Hu.
    apply P_perm, perm_bang_t_app; auto.
    apply perm_bang_t_app; auto.
    apply perm_bang_t_trans with (2 := H4).
    rewrite <- app_ass.
    apply perm_bang_t_app; auto.
  Qed.

  Local Fact sub_monoid_1 : cl K ∅.
  Proof.
    intros ga de A H.
    apply H; exists ∅; auto.
  Qed.

  Local Fact sub_monoid_2 : K ∘ K ⊆ K.
  Proof.
    intros _ [ a b c [ga Ha] [de Hb] H ]; subst a b.
    red in H; simpl in H.
    unfold ill_lbang in H.
    rewrite <- map_app in H.
    revert H; apply perm_t_map_inv_t.
  Qed.

  Section sub_J_cs.

    Hypothesis P_weak : ∀ ϴ Γ Δ A, ϴ++Δ ⊨ A -> ϴ++‼Γ++Δ ⊨ A.
    Hypothesis P_cntr : ∀ ϴ Γ Δ A, ϴ++‼Γ++‼Γ++Δ ⊨ A -> ϴ++‼Γ++Δ ⊨ A.

    Local Fact sub_J_1 : K ⊆ J.
    Proof.
      intros x (de & Hde); subst x.
      constructor; red.
      + intros ga th A H.
        specialize (H _ eq_refl); simpl in H.
        apply P_weak; auto.
      + intros ga th A H.
        specialize (H (‼de++‼de)).
        spec all in H.
        { constructor 1 with (‼de) (‼de); auto; red; auto. }
        rewrite app_ass in H.
        apply P_cntr; auto.
    Qed.

    Definition rules_sound := ill_Form_sem_sound   cl_ctx_increase
                                                   cl_ctx_mono
                                                   cl_ctx_idem
                                                   cl_ctx_stable_l
                                                   cl_ctx_stable_r
                                                   cl_neutral_1
                                                   cl_neutral_2
                                                   cl_neutral_3
                                                   cl_neutral_4
                                                   cl_assoc_1
                                                   cl_assoc_2
                                                   sub_monoid_1
                                                   sub_monoid_2
                                                   sub_J_1.

  End sub_J_cs.

  Section sub_J_cn.

    Hypothesis K_inc_J : K ⊆ J.

    Let J_banged Γ : J (‼Γ).
    Proof. apply K_inc_J; exists Γ; auto. Qed.

    Let weak Γ : cl (sg nil) (‼Γ).
    Proof. apply J_banged. Qed.

    Let cntr Γ : cl (sg (‼Γ) ∘ sg (‼Γ)) (‼Γ).
    Proof. apply J_banged. Qed.

    Local Fact sub_J_2 ϴ Γ Δ A : ϴ++Δ ⊨ A -> ϴ++‼Γ++Δ ⊨ A.
    Proof.
      intros H; apply weak; intros _ []; apply H.
    Qed.

    Local Fact sub_J_3 ϴ Γ Δ A : ϴ++‼Γ++‼Γ++Δ ⊨ A -> ϴ++‼Γ++Δ ⊨ A.
    Proof.
      intros H; apply cntr.
      intros _ [ x y th [] [] H1 ].
      revert H; apply P_perm.
      apply perm_bang_t_app; auto.
      rewrite <- app_ass.
      apply perm_bang_t_app; auto.
    Qed.

  End sub_J_cn.

  Fact sub_J_eq : K ⊆ J ≡ (∀ ϴ Γ Δ A, ϴ++Δ ⊨ A -> ϴ++‼Γ++Δ ⊨ A)
                         * (∀ ϴ Γ Δ A, ϴ++‼Γ++‼Γ++Δ ⊨ A -> ϴ++‼Γ++Δ ⊨ A).
  Proof.
    split.
    + split.
      * apply sub_J_2; auto.
      * apply sub_J_3; auto.
    + intros; apply sub_J_1; tauto.
  Qed.

  Notation "↓" := (fun A Γ => Γ ⊨ A).

  Fact dc_closed A : cl (↓A) ⊆ ↓A.
  Proof.
    intros ga Hga; red in Hga.
    replace ga with (nil++ga++nil) by solve list eq.
    apply Hga.
    intro; rewrite <- app_nil_end; auto.
  Qed.

  Notation sg := (@eq _).
  Infix "⊸" := (Magicwand_l comp) (at level 51, right associativity).
  Infix "⟜" := (Magicwand_r comp) (at level 52, left associativity).

  Section equivalences.

    (* We show that each rule has an algebraic counterpart *)

    (* ⊆ ≃ ∩ ∪ ∘ ⊸ ⊛ ⟦ ⟧ ⟬߭ ⟭  ⟙   ⟘   𝝐  ﹠ ⊗  ⊕  ⊸  ❗   ‼  ∅  ⊢ Γ Δ ϴ ⊨ *)

    Fact rule_ax_eq A : ↓A (A::∅)
                    ≡ A::∅ ⊨ A.
    Proof. split; auto. Qed.

    Fact rule_limp_l_eq A B : (↓A ⊸ cl (sg (B::∅))) (A -o B::∅)
                          ≡ ∀ ϴ Γ Δ C, Γ ⊨ A -> ϴ++B::Δ ⊨ C -> ϴ++Γ++A -o B::Δ ⊨ C.
    Proof.
      split.
      + intros H Ga De Th C H1 H2.
        specialize (H (De++A -o B::nil)).
        spec all in H.
        constructor 1 with De (A -o B :: nil); auto; red; simpl; auto.
        replace (Ga++De++A -o B::Th) with (Ga++(De++A -o B::nil)++Th) by solve list eq.
        apply H; intros _ []; auto.
      + intros H0 th Hth de om C H.
        destruct Hth as [ rho ga th H1 H2 H3 ].
        subst ga; red in H3; simpl in H3.
        apply P_perm with (de++(rho++A -o B::nil)++om).
        { do 2 (apply perm_bang_t_app; auto). }
        rewrite app_ass; simpl; apply H0; auto.
        apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_limp_r_eq A B : sg (A::∅) ⊸ ↓B ⊆ ↓(A -o B)
                          ≡ ∀ Γ, A::Γ ⊨ B -> Γ ⊨ A -o B.
    Proof.
      split.
      + intros H Ga H1.
        apply H.
        intros _ [ ? ? De [] [] H2 ].
        apply P_perm with (1 := H2).
        apply P_perm with (2 := H1); auto.
      + intros H th Hth.
        apply H, Hth.
        constructor 1 with (A :: nil) th; auto.
        red; auto.
    Qed.

    Fact rule_rimp_l_eq A B : (cl (sg (B::∅)) ⟜ ↓A) (B o- A::∅)
                          ≡ ∀ ϴ Γ Δ C, Γ ⊨ A -> ϴ++B::Δ ⊨ C -> ϴ++B o- A::Γ++Δ ⊨ C.
    Proof.
      split.
      + intros H Ga De Th C H1 H2.
        specialize (H (B o- A::De)).
        spec all in H.
        constructor 1 with (B o- A::nil) De; auto; red; simpl; auto.
        replace (Ga++B o- A::De++Th) with (Ga++(B o- A::De)++Th) by solve list eq.
        apply H; intros _ []; auto.
      + intros H0 th Hth de om C H.
        destruct Hth as [ rho ga th H1 H2 H3 ].
        subst rho; red in H3; simpl in H3.
        apply P_perm with (de++(B o- A::ga)++om).
        { do 2 (apply perm_bang_t_app; auto). }
        simpl; apply H0; auto.
        apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_rimp_r_eq A B : ↓B ⟜ sg (A::∅) ⊆ ↓(B o- A)
                          ≡ ∀ Γ, Γ++A::nil ⊨ B -> Γ ⊨ B o- A.
    Proof.
      split.
      + intros H Ga H1.
        apply H.
        intros _ [ ? ? De [] [] H2 ].
        apply P_perm with (1 := H2).
        apply P_perm with (2 := H1); auto.
      + intros H th Hth.
        apply H, Hth.
        constructor 1 with th (A :: nil); auto.
        red; auto.
    Qed.

    Fact rule_times_l_eq A B : cl (sg (A::B::nil)) (A⊗B::nil)
                           ≡ ∀ ϴ Γ C, ϴ++A::B::Γ ⊨ C -> ϴ++A ⊗ B::Γ ⊨ C.
    Proof.
      split.
      + intros H Th Ga C H1.
        apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_times_r_eq A B : ↓A ∘ ↓B ⊆ ↓(A⊗B)
                           ≡ ∀ Γ Δ, Γ ⊨ A -> Δ ⊨ B -> Γ++Δ ⊨ A ⊗ B.
    Proof.
      split.
      + intros H Ga De H1 H2.
        apply H.
        constructor 1 with Ga De; auto; red; auto.
      + intros H _ [ Ga Gb Gc HGa HGb HGc ].
        apply P_perm with (1 := HGc).
        apply H; auto.
    Qed.

    Fact rule_with_l1_eq A B : cl (sg (A::∅)) (A&B::∅)
                           ≡ ∀ ϴ Γ C, ϴ++A::Γ ⊨ C -> ϴ++A﹠B::Γ ⊨ C.
    Proof.
      split.
      + intros H Th Ga C H1; apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_with_l2_eq A B : cl (sg (B::∅)) (A&B::∅)
                           ≡ ∀ ϴ Γ C, ϴ++B::Γ ⊨ C -> ϴ++A﹠B::Γ ⊨ C.
    Proof.
      split.
      + intros H The Ga C H1; apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_with_r_eq A B : ↓A ∩ ↓B ⊆ ↓(A & B)
                          ≡ ∀ Γ, Γ ⊨ A -> Γ ⊨ B -> Γ ⊨ A﹠B.
    Proof.
      split.
      + intros H Ga H1 H2; apply H; auto.
      + intros H ? []; apply H; auto.
    Qed.

    Fact rule_plus_l_eq A B : cl (sg (A::∅) ∪ sg (B::∅)) (A⊕B::∅)
                          ≡ ∀ ϴ Γ C, ϴ++A::Γ ⊨ C -> ϴ++B::Γ ⊨ C -> ϴ++A⊕B::Γ ⊨ C.
    Proof.
      split.
      + intros H Th Ga C H1 H2.
        apply H; intros _ [ [] | [] ]; auto.
      + intros H0 ? ? ? H; apply H0; apply H with (ϴ := _::∅); auto.
    Qed.

    Fact rule_plus_r1_eq A B : ↓A ⊆ ↓(A⊕B)
                           ≡ ∀ Γ, Γ ⊨ A -> Γ ⊨ A⊕B.
    Proof.
      split.
      + intros H ? ?; apply H; auto.
      + intros H0 ?; apply H0.
    Qed.

    Fact rule_plus_r2_eq A B : ↓B ⊆ ↓(A⊕B)
                           ≡ ∀ Γ, Γ ⊨ B -> Γ ⊨ A⊕B.
    Proof.
      split.
      + intros H ? ?; apply H; auto.
      + intros H0 ?; apply H0.
    Qed.

    Fact rule_bang_l_eq A : cl (sg (A::∅)) (!A::∅)
                        ≡ ∀ ϴ Γ B, ϴ++A::Γ ⊨ B -> ϴ++!A::Γ ⊨ B.
    Proof.
      split.
      + intros H Th Ga B H1; apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_bang_r_eq A : K ∩ ↓A ⊆ ↓(!A)
                        ≡   ∀ Γ, ‼ Γ ⊨ A -> ‼ Γ ⊨ !A.
    Proof.
      split.
      + intros H Ga H1.
        apply H; split; auto.
        exists Ga; auto.
      + intros H0 Ga [ (De & H1) H2 ]; subst.
        apply H0; auto.
    Qed.

    Fact rule_unit_l_eq : cl (sg ∅) (𝝐::nil)
                      ≡ ∀ ϴ Γ A, ϴ++Γ ⊨ A -> ϴ++𝝐 :: Γ ⊨ A.
    Proof.
      split.
      + intros H Th Ga A H1; apply H; intros _ []; auto.
      + intros H0 ? ? ? H; apply H0, H with (1 := eq_refl).
    Qed.

    Fact rule_unit_r_eq : sg ∅ ⊆ ↓𝝐  ≡ ∅ ⊨ 𝝐.
    Proof.
      split.
      + intros H; apply H; auto.
      + intros H x []; apply H.
    Qed.

    Fact rule_bot_l_eq : cl (fun _ => False) (⟘::∅)
                     ≡ ∀ ϴ Γ A, ϴ++⟘ :: Γ ⊨ A.
    Proof.
      split.
      + intros H Th Ga A; apply H; tauto.
      + intros H0 ? ? ? _; apply H0.
    Qed.

    Fact rule_top_r_eq : (fun _ => True) ⊆ ↓⟙ ≡ ∀ Γ, Γ ⊨ ⟙.
    Proof.
      split.
      + intros H Ga; apply H; auto.
      + intros H ? _; apply H.
    Qed.

  End equivalences.

End Rules.


(** Adapted from "Elements of Set Theory" Chapter 6 **)
(** Coq coding by choukh, Aug 2020 **)

Require Export ZFC.Elements.EST6_1.
Require Export ZFC.Elements.EST7_5.

(*** EST第六章2：无限基数，基数算术：加法，乘法，乘方 ***)

Check EST7_5.CardAx0.
(* Theorem CardAx0 : ∀ A, A ≈ |A|. *)
Check EST7_5.CardAx1.
(* Theorem CardAx1 : ∀ A B, |A| = |B| ↔ A ≈ B. *)
Check EST7_5.CardAx2.
(* Theorem CardAx2 : ∀ A, finite A → |A| = FinCard A. *)

Definition is_card := λ 𝜅, ∃ K, 𝜅 = |K|.
Notation 𝐂𝐃 := is_card.

Lemma card_is_card : ∀ A, |A| ⋵ 𝐂𝐃.
Proof. intros. exists A. reflexivity. Qed.
Global Hint Immediate card_is_card : core.

(* 基数的基数等于自身 *)
Lemma card_of_card : ∀𝜅 ⋵ 𝐂𝐃, 𝜅 = |𝜅|.
Proof.
  intros 𝜅 [K H𝜅]. rewrite H𝜅 at 1.
  apply CardAx1. rewrite H𝜅. apply CardAx0.
Qed.

(* 自然数的基数等于自身 *)
Lemma card_of_nat : ∀n ∈ ω, n = |n|.
Proof with auto.
  intros n Hn. rewrite CardAx2.
  rewrite fin_card_n... apply nat_finite...
Qed.

(* 自然数是基数 *)
Lemma nat_is_card : ω ⪽ 𝐂𝐃.
Proof. intros n Hn. exists n. apply (card_of_nat _ Hn). Qed.

Lemma embed_is_card : ∀ n : nat, n ⋵ 𝐂𝐃.
Proof. intros. apply nat_is_card. apply embed_ran. Qed.
Global Hint Immediate embed_is_card : number_hint.

(* 有限基数 *)
Definition fincard := λ n, n ⋵ 𝐂𝐃 ∧ finite n.
Notation 𝐂𝐃ᶠⁱⁿ := fincard.
(* 无限基数 *)
Definition infcard := λ 𝜅, 𝜅 ⋵ 𝐂𝐃 ∧ infinite 𝜅.
Notation 𝐂𝐃ⁱⁿᶠ := infcard.

(* 自然数等价于有限基数 *)
Lemma nat_iff_fincard : ∀ n, n ∈ ω ↔ n ⋵ 𝐂𝐃ᶠⁱⁿ.
Proof with auto; try congruence.
  split.
  - intros Hn. split. apply nat_is_card... apply nat_finite...
  - intros [Hcd Hfin]. apply CardAx2 in Hfin as Heqn.
    rewrite <- card_of_card in Heqn...
    apply fin_card_correct in Hfin as [m [Hm [Heqm _]]]...
Qed.

(* 空集的基数为零 *)
Lemma card_of_empty : |∅| = 0.
Proof. rewrite CardAx2, fin_card_n; nauto. Qed.

(* 集合的基数为零当且仅当它是空集 *)
Lemma card_eq_0 : ∀ A, |A| = 0 ↔ A = ∅.
Proof with nauto.
  split; intros.
  - rewrite <- eqnum_empty, <- CardAx1, (CardAx2 ∅), (fin_card_n ∅)...
  - subst A. apply card_of_empty.
Qed.

(* 集合的基数不为零当且仅当它非空 *)
Lemma card_neq_0 : ∀ A, |A| ≠ 0 ↔ ⦿ A.
Proof with auto.
  split; intros.
  - apply EmptyNE. intros Heq.
    apply H. apply card_eq_0...
  - intros Heq. rewrite card_eq_0 in Heq.
    apply EmptyNI in H...
Qed.

(* 单集的基数为1 *)
Lemma card_of_single : ∀ a, |{a,}| = 1.
Proof with nauto.
  intros. rewrite (card_of_nat 1)...
  apply CardAx1. apply eqnum_single.
Qed.

(* 基数为1的集合是单集 *)
Lemma card_eq_1 : ∀ A, |A| = 1 → ∃ a, A = {a,}.
Proof with nauto.
  intros A H1. rewrite (card_of_nat 1), one in H1...
  symmetry in H1. apply CardAx1 in H1 as [f [[Hf _] [Hd Hr]]].
  exists (f[0]). ext y Hy.
  - rewrite <- Hr in Hy. apply ranE in Hy as [x Hp].
    apply domI in Hp as Hx. rewrite Hd in Hx.
    apply SingE in Hx. subst x.
    apply func_ap in Hp... subst y...
  - apply SingE in Hy. subst y. rewrite <- Hr. eapply ranI.
    apply func_correct... rewrite Hd. apply SingI.
Qed.

(* 集合有限当且仅当其基数有限 *)
Lemma set_finite_iff_card_finite : ∀ A, finite A ↔ finite (|A|).
Proof.
  now split; intros Hfin; apply set_finite_iff_eqnum_finite_set;
  [exists A|exists (|A|)]; split; auto; rewrite <- CardAx0.
Qed.

(* 集合无限当且仅当其基数无限 *)
Lemma set_infinite_iff_card_infinite : ∀ A, infinite A ↔ infinite (|A|).
Proof.
  split; intros Hinf Hfin; apply Hinf.
  rewrite set_finite_iff_card_finite; auto.
  rewrite <- set_finite_iff_card_finite; auto.
Qed.

(* 集合的基数不为零当且仅当集合非空 *)
Lemma set_nonzero_card_nonzero : ∀ A, ⦿ A ↔ ⦿ |A|.
Proof with nauto.
  split; intros [a Ha].
  - apply EmptyNE. intro.
    rewrite card_eq_0 in H. subst. exfalso0.
  - apply EmptyNE. intro. subst A.
    rewrite CardAx2, fin_card_n in Ha... exfalso0.
Qed.

(* 任意集合都可以在任意非零基数的集合里 *)
Lemma any_set_in_set_with_any_nonzero_card :
  ∀ a, ∀𝜅 ⋵ 𝐂𝐃, ⦿ 𝜅 → ∃ A, |A| = 𝜅 ∧ a ∈ A.
Proof with auto; try congruence.
  intros a 𝜅 [K H𝜅] Hi. subst 𝜅.
  apply set_nonzero_card_nonzero in Hi as [k Hk].
  destruct (classic (a ∈ K)) as [|Ha]. exists K. split...
  pose proof (bijection_exists_between_set_and_element_replaced
    K k a Hk Ha) as [f Hf].
  exists {ReplaceElement k a x | x ∊ K}. split.
  - apply CardAx1. symmetry. exists f...
  - apply ReplAx. exists k. split...
    unfold ReplaceElement. destruct (ixm (k = k))...
Qed.

Declare Scope Card_scope.
Delimit Scope Card_scope with cd.
Open Scope Card_scope.

(* 基数算术：加法，乘法，乘方 *)
Definition CardAdd : set → set → set := λ 𝜅 𝜆, |𝜅 × {0,} ∪ 𝜆 × {1,}|.
Definition CardMul : set → set → set := λ 𝜅 𝜆, |𝜅 × 𝜆|.
Definition CardExp : set → set → set := λ 𝜅 𝜆, |𝜆 ⟶ 𝜅|.

Notation "𝜅 + 𝜆" := (CardAdd 𝜅 𝜆) : Card_scope.
Notation "𝜅 ⋅ 𝜆" := (CardMul 𝜅 𝜆) : Card_scope.
Notation "𝜅 ^ 𝜆" := (CardExp 𝜅 𝜆) : Card_scope.

(* 基数加法的和是基数 *)
Lemma cardAdd_is_card : ∀ 𝜅 𝜆, 𝜅 + 𝜆 ⋵ 𝐂𝐃.
Proof. intros. apply card_is_card. Qed.
Global Hint Immediate cardAdd_is_card : core.

(* 基数乘法的积是基数 *)
Lemma cardMul_is_card : ∀ 𝜅 𝜆, 𝜅 ⋅ 𝜆 ⋵ 𝐂𝐃.
Proof. intros. apply card_is_card. Qed.
Global Hint Immediate cardMul_is_card : core.

(* 基数乘方的幂是基数 *)
Lemma cardExp_is_card : ∀ 𝜅 𝜆, 𝜅 ^ 𝜆 ⋵ 𝐂𝐃.
Proof. intros. apply card_is_card. Qed.
Global Hint Immediate cardExp_is_card : core.

(* 壹与单集的笛卡尔积 *)
Lemma one_cp_single : ∀ n, 1 × {n,} = {<0, n>,}.
Proof.
  intros. rewrite one. ext Hx.
  - apply CPrdE1 in Hx as [a [Ha [b [Hb H0]]]].
    apply SingE in Ha. apply SingE in Hb. subst. auto.
  - apply SingE in Hx. subst. apply CPrdI; apply SingI.
Qed.

(* 基数算术的一加一等于二 *)
Example cardAdd_1_1_2 : 1 + 1 = 2.
Proof with neauto; try congruence.
  rewrite (card_of_nat 2)...
  unfold CardAdd. apply CardAx1.
  set (Func (1×{0,} ∪ 1×{1,}) 2 (λ x,
    match (ixm (x = <0, 0>)) with
    | inl _ => 0
    | inr _ => 1
    end
  )) as F.
  exists F. apply meta_bijection.
  - intros x Hx. destruct (ixm (x = <0, 0>))...
    apply BUnionI1. apply BUnionI2... apply BUnionI2...
  - intros x1 Hx1 x2 Hx2 Heq.
    destruct (ixm (x1 = <0, 0>)) as [H1|H1'];
    destruct (ixm (x2 = <0, 0>)) as [H2|H2']...
    + exfalso. eapply suc_neq_0...
    + exfalso. eapply suc_neq_0...
    + apply BUnionE in Hx1 as []; apply BUnionE in Hx2 as [].
      * rewrite one_cp_single in H. apply SingE in H. exfalso...
      * rewrite one_cp_single in H. apply SingE in H. exfalso...
      * rewrite one_cp_single in H0. apply SingE in H0. exfalso...
      * rewrite one_cp_single in H. apply SingE in H.
        rewrite one_cp_single in H0. apply SingE in H0...
  - intros y Hy. apply BUnionE in Hy as [Hy|Hy].
    + apply BUnionE in Hy as []. exfalso0.
      apply SingE in H. subst y. exists <0, 0>. split.
      apply BUnionI1. rewrite one_cp_single...
      destruct (ixm (<0, 0> = <0, 0>))...
    + apply SingE in Hy. subst y. exists <0, 1>. split.
      apply BUnionI2. rewrite one_cp_single...
      destruct (ixm (<0, 1> = <0, 0>)). {
        apply op_iff in e as [_ Contra].
        exfalso. eapply suc_neq_0...
      } reflexivity.
Qed.

(* 基数加法良定义 *)
Theorem cardAdd_well_defined : ∀ K₁ K₂ L₁ L₂, K₁ ≈ K₂ → L₁ ≈ L₂ →
  disjoint K₁ L₁ → disjoint K₂ L₂ → K₁ ∪ L₁ ≈ K₂ ∪ L₂.
Proof with eauto; try congruence.
  intros * [f [Hif [Hdf Hrf]]] [g [Hig [Hdg Hrg]]] Hdj1 Hdj2.
  assert (Hif' := Hif). destruct Hif' as [Hf Hsf].
  assert (Hig' := Hig). destruct Hig' as [Hg Hsg].
  set (Func (K₁ ∪ L₁) (K₂ ∪ L₂) (λ x,
    match (ixm (x ∈ K₁)) with
    | inl _ => f[x]
    | inr _ => g[x]
    end
  )) as F.
  exists F. apply meta_bijection.
  - intros x Hx. destruct (ixm (x ∈ K₁)).
    + apply BUnionI1. eapply ap_ran... split... split...
    + apply BUnionE in Hx as []... apply BUnionI2.
      eapply ap_ran... split... split...
  - intros x1 Hx1 x2 Hx2 Heq.
    destruct (ixm (x1 ∈ K₁)) as [H1|H1'];
    destruct (ixm (x2 ∈ K₁)) as [H2|H2'].
    + eapply injectiveE; revgoals...
    + exfalso. apply BUnionE in Hx2 as [|H2]...
      rewrite <- Hdf in H1. rewrite <- Hdg in H2.
      apply func_correct in H1... apply ranI in H1.
      apply func_correct in H2... apply ranI in H2.
      rewrite Hrf in H1. rewrite Hrg in H2.
      eapply disjointE; [apply Hdj2|..]...
    + exfalso. apply BUnionE in Hx1 as [|H1]...
      rewrite <- Hdg in H1. rewrite <- Hdf in H2.
      apply func_correct in H1... apply ranI in H1.
      apply func_correct in H2... apply ranI in H2.
      rewrite Hrg in H1. rewrite Hrf in H2.
      eapply disjointE; [apply Hdj2|..]...
    + apply BUnionE in Hx1 as [|H1]...
      apply BUnionE in Hx2 as [|H2]...
      eapply injectiveE; revgoals...
  - intros y Hy. apply BUnionE in Hy as [Hy|Hy].
    + rewrite <- Hrf in Hy. apply ranE in Hy as [x Hp].
      apply domI in Hp as Hd. apply func_ap in Hp...
      exists x. split. apply BUnionI1...
      destruct (ixm (x ∈ K₁))...
    + rewrite <- Hrg in Hy. apply ranE in Hy as [x Hp].
      apply domI in Hp as Hd. apply func_ap in Hp...
      exists x. split. apply BUnionI2...
      destruct (ixm (x ∈ K₁))...
      exfalso. eapply disjointE; [apply Hdj1|..]...
Qed.

(* 基数乘法良定义 *)
Theorem cardMul_well_defined : ∀ K₁ K₂ L₁ L₂,
  K₁ ≈ K₂ → L₁ ≈ L₂ → K₁ × L₁ ≈ K₂ × L₂.
Proof with eauto; try congruence.
  intros * [f [Hif [Hdf Hrf]]] [g [Hig [Hdg Hrg]]].
  assert (Hif' := Hif). destruct Hif' as [Hf Hsf].
  assert (Hig' := Hig). destruct Hig' as [Hg Hsg].
  set (Func (K₁ × L₁) (K₂ × L₂) (λ x,
    <f[π1 x], g[π2 x]>
  )) as F.
  exists F. apply meta_bijection.
  - intros x Hx.
    apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
    subst x. zfc_simple. apply CPrdI.
    eapply ap_ran... split... split...
    eapply ap_ran... split... split...
  - intros x1 Hx1 x2 Hx2 Heq.
    apply CPrdE1 in Hx1 as [a [Ha [b [Hb Hx1]]]].
    apply CPrdE1 in Hx2 as [c [Hc [d [Hd Hx2]]]].
    subst. zfc_simple. apply op_iff in Heq as [].
    apply injectiveE in H... apply injectiveE in H0...
  - intros y Hy.
    apply CPrdE1 in Hy as [a [Ha [b [Hb Hy]]]]. subst y.
    rewrite <- Hrf in Ha. apply ranE in Ha as [x1 H1].
    rewrite <- Hrg in Hb. apply ranE in Hb as [x2 H2].
    apply domI in H1 as Hd1. apply ranI in H1 as Hr1.
    apply domI in H2 as Hd2. apply ranI in H2 as Hr2.
    rewrite Hdf in Hd1. apply func_ap in H1...
    rewrite Hdg in Hd2. apply func_ap in H2...
    exists <x1, x2>. split. apply CPrdI... zfc_simple.
Qed.

(* 基数乘方良定义 *)
Theorem cardExp_well_defined : ∀ K₁ K₂ L₁ L₂,
  K₁ ≈ K₂ → L₁ ≈ L₂ → (L₁ ⟶ K₁) ≈ (L₂ ⟶ K₂).
Proof with eauto; try congruence.
  intros * [f [Hif [Hdf Hrf]]] [g [Hig [Hdg Hrg]]].
  assert (Hif' := Hif). destruct Hif' as [Hf Hsf].
  assert (Hig' := Hig). destruct Hig' as [Hg Hsg].
  assert (Hf': is_function f⁻¹) by (apply inv_func_iff_sr; auto).
  assert (Hg': is_function g⁻¹) by (apply inv_func_iff_sr; auto).
  set (Func (L₁ ⟶ K₁) (L₂ ⟶ K₂) (λ x, f ∘ x ∘ g⁻¹ )) as F.
  exists F. apply meta_bijection.
  - intros j Hj. apply arrow_iff in Hj as [Hfj [Hdj Hrj]].
    assert (Hffj: is_function (f ∘ j)) by (apply compo_func; auto).
    apply arrow_iff. split; [|split].
    + apply compo_func...
    + ext Hx.
      * rewrite compo_dom in Hx... apply SepE in Hx as [Hx _].
        rewrite inv_dom in Hx...
      * rewrite compo_dom... apply SepI. rewrite inv_dom...
        rewrite compo_dom... apply SepI. {
          rewrite Hdj, <- Hdg, <- inv_ran.
          eapply ap_ran... split... split... rewrite inv_dom...
        } {
          rewrite Hdf. apply Hrj. rewrite <- Hdg, <- inv_ran.
          eapply ap_ran... split... split... rewrite inv_dom...
        }
    + intros y Hy.
      assert (H1: (g ⁻¹) [y] ∈ L₁). {
        rewrite <- Hdg, <- inv_ran. eapply ranI.
        apply func_correct... rewrite inv_dom, Hrg...
      }
      assert (H2: j [(g ⁻¹) [y]] ∈ dom f). {
        rewrite Hdf. apply Hrj...
      }
      assert (H3: (g ⁻¹) [y] ∈ dom (f ∘ j)). {
        rewrite compo_dom... apply SepI...
      }
      rewrite compo_correct, compo_correct...
      * eapply ap_ran... split... split...
      * rewrite compo_dom... apply SepI... rewrite inv_dom...
  - intros j1 Hj1 j2 Hj2 Heq.
    cut (∀h1 ∈ L₁ ⟶ K₁, ∀h2 ∈ L₁ ⟶ K₁,
      (f ∘ h1) ∘ g ⁻¹ = (f ∘ h2) ∘ g ⁻¹ → h1 ⊆ h2). {
      intros H. apply sub_antisym; apply H...
    }
    clear Hj1 Hj2 Heq j1 j2.
    intros j1 Hj1 j2 Hj2 Heq p Hjp.
    apply arrow_iff in Hj1 as [Hfj1 [Hdj1 Hrj1]].
    apply arrow_iff in Hj2 as [Hfj2 [Hdj2 Hrj2]].
    assert (H1: is_function (f ∘ j1)) by (apply compo_func; auto).
    assert (H2: is_function (f ∘ j2)) by (apply compo_func; auto).
    apply func_pair' in Hjp as [x [y [Hjp Heqp]]]... subst p.
    apply domI in Hjp as Hx.
    apply func_ap in Hjp... subst y.
    rewrite Hdj1 in Hx. apply Hrj1 in Hx as Hjx.
    rewrite <- Hdg, <- inv_ran in Hx.
    apply ranE in Hx as [w Hgp]. apply domI in Hgp as Hw.
    apply ranI in Hgp as Hx. rewrite inv_ran in Hx.
    apply func_ap in Hgp... subst x.
    assert (H3: j2 [(g⁻¹)[w]] ∈ dom f). { rewrite Hdf. apply Hrj2... }
    assert (H4: (g⁻¹)[w] ∈ dom (f ∘ j1)). { rewrite compo_dom... apply SepI... }
    assert (H5: (g⁻¹)[w] ∈ dom (f ∘ j2)). { rewrite compo_dom... apply SepI... }
    assert (H6: w ∈ dom ((f ∘ j1) ∘ g⁻¹)). { rewrite compo_dom... apply SepI... }
    assert (H7: w ∈ dom ((f ∘ j2) ∘ g⁻¹)). { rewrite compo_dom... apply SepI... }
    rewrite <- Hdf in Hjx. apply func_correct in Hjx as Hfp...
    apply func_ap in Hfp...
    rewrite <- compo_correct, <- compo_correct in Hfp at 1...
    rewrite Heq, compo_correct, compo_correct in Hfp...
    apply injectiveE in Hfp... rewrite <- Hfp. apply func_correct...
  - intros y Hy.
    apply arrow_iff in Hy as [Hfy [Hdy Hry]].
    exists ((f⁻¹ ∘ y) ∘ g). split. apply arrow_iff.
    + assert (Hffy: is_function (f⁻¹ ∘ y)) by (apply compo_func; auto).
      assert (H1: ∀x ∈ L₁, g[x] ∈ dom y). {
        intros x Hx. rewrite Hdy. eapply ap_ran... split... split...
      }
      assert (H2: ∀x ∈ L₁, y[g[x]] ∈ dom f⁻¹). {
        intros x Hx. rewrite inv_dom, Hrf.
        apply Hry. rewrite <- Hdy. apply H1...
      }
      assert (H3: ∀x ∈ L₁, x ∈ dom ((f⁻¹ ∘ y) ∘ g)). {
        intros x Hx. rewrite compo_dom... apply SepI...
        rewrite compo_dom... apply SepI. apply H1... apply H2...
      }
      assert (H4: ∀x ∈ L₁, g[x] ∈ dom (f⁻¹ ∘ y)). {
        intros x Hx. rewrite compo_dom...
        apply SepI. apply H1... apply H2...
      }
      split; [|split].
      * apply compo_func...
      * ext w Hw.
        rewrite compo_dom in Hw... apply SepE1 in Hw... apply H3...
      * intros x Hx. rewrite compo_correct, compo_correct...
        rewrite <- Hdf, <- inv_ran. eapply ranI. apply func_correct...
    + assert (Hfy' := Hfy). destruct Hfy' as [Hrel _].
      rewrite compo_assoc, compo_assoc, compo_inv_ran_ident...
      rewrite compo_assoc, right_compo_ident.
      rewrite Hrg, <- Hdy, restr_to_dom...
      rewrite <- compo_assoc, compo_inv_ran_ident...
      rewrite left_compo_ident', Hrf...
      rewrite <- (inv_inv y) at 2...
      cut (y ⁻¹ ↾ K₂ = y⁻¹). congruence.
      ext Hx.
      * apply restrE1 in Hx as [a [b [Ha []]]]...
      * apply SepI... apply SepE in Hx as [Hcp [Hp _]].
        apply CPrdE0 in Hcp as [H _]. apply ranE in H as [w H].
        apply domI in H as Hw. apply func_ap in H...
        split... rewrite <- H. apply Hry...
Qed.

(* 不交集的二元并与基数加法的相互转化 *)
Lemma cardAdd_disjoint_iff : ∀ A B C, disjoint A B →
  A ∪ B ≈ C ↔ |A| + |B| = |C|.
Proof with auto.
  intros * Hdj. split; intros H.
  - apply CardAx1.
    eapply Equivalence_Transitive. {
      apply cardAdd_well_defined.
      - apply cardMul_well_defined.
        symmetry. apply CardAx0. reflexivity.
      - apply cardMul_well_defined.
        symmetry. apply CardAx0. reflexivity.
      - apply disjointify_0_1.
      - apply disjointify_0_1.
    }
    eapply Equivalence_Transitive. {
      apply cardAdd_well_defined.
      - symmetry. apply eqnum_cprd_single.
      - symmetry. apply eqnum_cprd_single.
      - apply disjointify_0_1.
      - apply Hdj.
    }
    apply H.
  - eapply Equivalence_Transitive. {
      apply cardAdd_well_defined.
      + apply (eqnum_cprd_single _ 0).
      + apply (eqnum_cprd_single _ 1).
      + apply Hdj.
      + apply disjointify_0_1.
    }
    eapply Equivalence_Transitive. {
      apply cardAdd_well_defined.
      - apply cardMul_well_defined. apply CardAx0. reflexivity.
      - apply cardMul_well_defined. apply CardAx0. reflexivity.
      - apply disjointify_0_1.
      - apply disjointify_0_1.
    }
    apply CardAx1. apply H.
Qed.

(* 二元并与基数加法的相互转化 *)
Lemma cardAdd_iff : ∀ A B C,
  A × {0,} ∪ B × {1,} ≈ C ↔ |A| + |B| = |C|.
Proof with auto.
  intros. split; intros H.
  - apply CardAx1.
    eapply Equivalence_Transitive. {
      apply cardAdd_well_defined.
      - apply cardMul_well_defined.
        symmetry. apply CardAx0. reflexivity.
      - apply cardMul_well_defined.
        symmetry. apply CardAx0. reflexivity.
      - apply disjointify_0_1.
      - apply disjointify_0_1.
    }
    apply H.
  - eapply Equivalence_Transitive. {
      apply cardAdd_well_defined.
      - apply cardMul_well_defined. apply CardAx0. reflexivity.
      - apply cardMul_well_defined. apply CardAx0. reflexivity.
      - apply disjointify_0_1.
      - apply disjointify_0_1.
    }
    apply CardAx1. apply H.
Qed.

(* 笛卡尔积与基数乘法的相互转化 *)
Lemma cardMul_iff : ∀ A B C, A × B ≈ C ↔ (|A| ⋅ |B|) = |C|.
Proof with auto.
  split; intros.
  - apply CardAx1. eapply Equivalence_Transitive.
    + apply cardMul_well_defined; symmetry; apply CardAx0.
    + apply H.
  - eapply Equivalence_Transitive.
    + apply cardMul_well_defined; apply CardAx0.
    + apply CardAx1. apply H.
Qed.

(* 函数空间与基数乘方的相互转化 *)
Lemma cardExp_iff : ∀ A B C, B ⟶ A ≈ C ↔ (|A| ^ |B|) = |C|.
Proof with auto.
  split; intros.
  - apply CardAx1. eapply Equivalence_Transitive.
    + apply cardExp_well_defined; symmetry; apply CardAx0.
    + apply H.
  - eapply Equivalence_Transitive.
    + apply cardExp_well_defined; apply CardAx0.
    + apply CardAx1. apply H.
Qed.

(* 不交集的基数的和等于它们的二元并的基数 *)
Lemma cardAdd_disjoint : ∀ A B, disjoint A B → |A| + |B| = |A ∪ B|.
Proof. intros. now apply cardAdd_disjoint_iff. Qed.

(* 基数的和等于它们的不交化二元并的基数 *)
Lemma cardAdd : ∀ A B, |A| + |B| = |A × {0,} ∪ B × {1,}|.
Proof. intros. now apply cardAdd_iff. Qed.

(* 集合的基数的积等于它们的笛卡尔积的基数*)
Lemma cardMul : ∀ A B, (|A| ⋅ |B|) = |A × B|.
Proof. intros. now apply cardMul_iff. Qed.

(* 集合的基数的幂等于它们张起的函数空间的基数*)
Lemma cardExp : ∀ A B, (|A| ^ |B|) = |B ⟶ A|.
Proof. intros. now apply cardExp_iff. Qed.

(* 零是基数加法单位元 *)
Lemma cardAdd_0_r : ∀𝜅 ⋵ 𝐂𝐃, 𝜅 + 0 = 𝜅.
Proof with auto.
  intros 𝜅 Hcd. apply card_of_card in Hcd. simpl.
  rewrite Hcd at 2. apply CardAx1.
  rewrite cprd_0_l, bunion_empty. symmetry.
  set (Func 𝜅 (𝜅 × {0,}) (λ x, <x, 0>)) as F.
  exists F. apply meta_bijection.
  - intros x Hx. apply CPrdI...
  - intros x1 Hx1 x2 Hx2 Heq. apply op_iff in Heq as []...
  - intros y Hy. apply CPrdE1 in Hy as [a [Ha [b [Hb Hy]]]].
    apply SingE in Hb. subst. exists a. split...
Qed.

(* 基数乘于零等于零 *)
Lemma cardMul_0_r_r : ∀ 𝜅, 𝜅 ⋅ 0 = 0.
Proof.
  intros 𝜅. apply card_eq_0. apply EmptyI.
  intros x Hx. apply CPrdE0 in Hx as []. exfalso0.
Qed.

(* 1是基数乘法单位元 *)
Lemma cardMul_1_r : ∀𝜅 ⋵ 𝐂𝐃, 𝜅 ⋅ 1 = 𝜅.
Proof.
  intros 𝜅 Hcd. apply card_of_card in Hcd. simpl.
  rewrite Hcd at 2. apply CardAx1. symmetry.
  rewrite one. apply eqnum_cprd_single.
Qed.

(* 壹到集合A的函数的集合与A等势 *)
Lemma arrow_from_one : ∀ A, 1 ⟶ A ≈ A.
Proof with neauto; try congruence.
  intros. symmetry.
  set (Func A (1 ⟶ A) (λ x, {<0, x>,})) as F.
  exists F. apply meta_bijection.
  - intros x Hx.
    destruct (single_pair_bijection 0 x) as [[Hf Hi] [Hd Hr]].
    rewrite one... apply arrow_iff. split; [|split]...
    intros w Hw. apply SingE in Hw. subst.
    eapply single_of_member_is_subset...
    apply (ap_ran {∅,})... split... split...
  - intros x1 Hx1 x2 Hx2 Heq.
    assert (<0, x1> ∈ {<0, x1>,}) by auto.
    rewrite Heq in H. apply SingE in H.
    apply op_iff in H as []...
  - intros f Hf. apply SepE in Hf as [Hsub [Hf [Hd Hr]]].
    assert (H0d: 0 ∈ dom f). { rewrite Hd. apply suc_has_0... }
    apply domE in H0d as [y H]. exists y. split.
    + apply Hr... eapply ranI...
    + ext p Hp.
      * apply SingE in Hp. subst p...
      * apply PowerAx in Hsub. apply Hsub in Hp as Hcp.
        apply CPrdE1 in Hcp as [a [Ha [b [Hb Hp']]]].
        subst p. rewrite one in Ha. apply SingE in Ha. subst a.
        cut (b = y). intros Heq. subst... eapply func_sv...
Qed.

(* 基数的1次幂等于自身 *)
Lemma cardExp_1_r : ∀𝜅 ⋵ 𝐂𝐃, 𝜅 ^ 1 = 𝜅.
Proof.
  intros 𝜅 Hcd. apply card_of_card in Hcd. simpl.
  rewrite Hcd at 2. apply CardAx1. apply arrow_from_one.
Qed.

(* 1的任意基数次幂等于1 *)
Lemma cardExp_1_l : ∀ 𝜅, 1 ^ 𝜅 = 1.
Proof with nauto.
  intros. rewrite (card_of_nat 1) at 2...
  apply CardAx1.
  set (Func (𝜅 ⟶ 1) 1 (λ _, 0)) as F.
  exists F. apply meta_bijection.
  - intros x Hx. apply suc_has_n.
  - intros f1 Hf1 f2 Hf2 Heq.
    cut (∀ g1 g2 𝜆, g1 ∈ 𝜆 ⟶ 1 → g2 ∈ 𝜆 ⟶ 1 → g1 ⊆ g2). {
      intros H. apply sub_antisym; eapply H; eauto.
    }
    clear Heq Hf1 Hf2 f1 f2 𝜅 F.
    intros f1 f2 𝜅 Hf1 Hf2 p Hp.
    apply arrow_iff in Hf1 as [Hf1 [Hd1 Hr1]].
    apply arrow_iff in Hf2 as [Hf2 [Hd2 Hr2]]. subst.
    apply func_pair in Hp as Hpeq...
    rewrite Hpeq. rewrite Hpeq in Hp.
    apply domI in Hp as Hd. apply func_ap in Hp as Hap...
    apply Hr1 in Hd as H1. rewrite one in H1. apply SingE in H1.
    apply Hr2 in Hd as H2. rewrite one in H2. apply SingE in H2.
    rewrite <- Hap, H1, <- H2. apply func_correct... rewrite Hd2...
  - intros y Hy. rewrite one in Hy. apply SingE in Hy. subst.
    set (Func 𝜅 1 (λ _, 0)) as G.
    exists G. split... apply SepI.
    + apply PowerAx. intros p Hp. apply SepE1 in Hp...
    + apply meta_function. intros _ _. apply suc_has_n.
Qed.

(* 空集到任意集合的函数的集合等于壹 *)
Lemma arrow_from_empty : ∀ A, 0 ⟶ A = 1.
Proof with nauto.
  intros. ext p Hp.
  - apply SepE in Hp as [Hp _].
    rewrite PowerAx, cprd_0_l, sub_empty in Hp.
    subst. apply suc_has_0...
  - apply BUnionE in Hp as []. exfalso0.
    apply SingE in H. subst. rewrite <- ident_empty.
    apply arrow_iff. split; [|split].
    + apply ident_is_func.
    + rewrite dom_ident...
    + intros x Hx. exfalso0.
Qed.

(* 任意非空集合到空集的函数的集合等于空集 *)
Lemma arrow_to_empty : ∀ A, ⦿ A → A ⟶ 0 = 0.
Proof with auto.
  intros A [a Ha]. ext p Hp.
  apply arrow_iff in Hp as [_ [_ Hr]].
  apply Hr in Ha. exfalso0. exfalso0.
Qed.

(* 基数的零次幂等于1 *)
Lemma cardExp_0_r : ∀ 𝜅, 𝜅 ^ 0 = 1.
Proof.
  intros. unfold CardExp. rewrite arrow_from_empty.
  symmetry. apply card_of_nat; nauto.
Qed.

(* 零的非零基数次幂等于零 *)
Lemma cardExp_0_l : ∀ 𝜅, 𝜅 ≠ ∅ → 0 ^ 𝜅 = 0.
Proof with auto.
  intros. unfold CardExp. rewrite arrow_to_empty.
  apply card_eq_0... apply EmptyNE. apply H.
Qed.

Fact cardExp_0_0 : 0 ^ 0 = 1.
Proof. apply cardExp_0_r. Qed.

(* 任意集合的幂集的基数等于2的该集合基数次幂 *)
Lemma card_of_power : ∀ A, |𝒫 A| = 2 ^ |A|.
Proof with auto.
  intros. pose proof (power_eqnum_func_to_2 A).
  apply CardAx1 in H. rewrite H. clear H.
  apply CardAx1. apply cardExp_well_defined. easy. apply CardAx0.
Qed.

(* 任意基数不等于2的该基数次幂 *)
Lemma card_neq_exp : ∀𝜅 ⋵ 𝐂𝐃, 𝜅 ≠ 2 ^ 𝜅.
Proof.
  intros 𝜅 Hcd Heq. apply card_of_card in Hcd.
  rewrite Hcd, <- card_of_power in Heq.
  apply CardAx1 in Heq. eapply Cantor's. apply Heq.
Qed.

(* 基数加法交换律 *)
Theorem cardAdd_comm : ∀ 𝜅 𝜆, 𝜅 + 𝜆 = 𝜆 + 𝜅.
Proof.
  intros. apply CardAx1. rewrite bunion_comm.
  apply cardAdd_well_defined.
  - rewrite <- eqnum_cprd_single.
    rewrite <- eqnum_cprd_single. reflexivity.
  - rewrite <- eqnum_cprd_single.
    rewrite <- eqnum_cprd_single. reflexivity.
  - unfold disjoint. rewrite binter_comm. apply disjointify_0_1.
  - apply disjointify_0_1.
Qed.

(* 基数乘法交换律 *)
Theorem cardMul_comm : ∀ 𝜅 𝜆, 𝜅 ⋅ 𝜆 = 𝜆 ⋅ 𝜅.
Proof with auto.
  intros. apply CardAx1.
  set (Func (𝜅 × 𝜆) (𝜆 × 𝜅) (λ x, <π2 x, π1 x>)) as F.
  exists F. apply meta_bijection.
  - intros x Hx. apply CPrdE0 in Hx as []. apply CPrdI...
  - intros x1 Hx1 x2 Hx2 Heq.
    apply cprd_is_pairs in Hx1 as [a [b Hx1]].
    apply cprd_is_pairs in Hx2 as [c [d Hx2]].
    apply op_iff in Heq as []. subst. zfc_simple.
  - intros y Hy.
    apply CPrdE1 in Hy as [a [Ha [b [Hb Hy]]]]. subst.
    exists <b, a>. split. apply CPrdI... zfc_simple.
Qed.

Fact cardAdd_k_k : ∀ 𝜅, 𝜅 + 𝜅 = 2 ⋅ 𝜅.
Proof with auto.
  intros. rewrite cardMul_comm. apply CardAx1.
  cut (𝜅 × {0,} ∪ 𝜅 × {1,} = 𝜅 × 2). { intros H. now rewrite H. }
  assert (H1_2: 1 ∈ 2). apply suc_has_n.
  assert (H0_2: 0 ∈ 2) by (apply suc_has_0; apply ω_inductive; nauto).
  ext Hx.
  - apply BUnionE in Hx as [].
    + apply CPrdE1 in H as [a [Ha [b [Hb H]]]].
      apply SingE in Hb. subst. apply CPrdI...
    + apply CPrdE1 in H as [a [Ha [b [Hb H]]]].
      apply SingE in Hb. subst. apply CPrdI...
  - apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]].
    subst. apply BUnionE in Hb as [].
    + apply BUnionE in H as []. exfalso0.
      apply BUnionI1. apply CPrdI...
    + apply SingE in H. subst b.
      apply BUnionI2. apply CPrdI...
Qed.

(* 基数加法结合律 *)
Theorem cardAdd_assoc : ∀ 𝜅 𝜆 𝜇, (𝜅 + 𝜆) + 𝜇 = 𝜅 + (𝜆 + 𝜇).
Proof with neauto; try congruence; try easy.
  intros. apply CardAx1.
  assert (Hnq: Embed 1 = Embed 2 → False). {
    intros. apply (nat_irrefl 2)...
    rewrite <- H at 1. apply suc_has_n.
  }
  eapply Equivalence_Transitive. {
    apply cardAdd_well_defined.
    - unfold CardAdd. rewrite <- eqnum_cprd_single, <- CardAx0...
    - rewrite <- eqnum_cprd_single, (eqnum_cprd_single _ 2)...
    - apply disjointify_0_1.
    - unfold disjoint. rewrite binter_comm, binter_bunion_distr.
      apply EmptyI. intros x Hx.
      apply BUnionE in Hx as []; apply BInterE in H as [].
      + eapply disjointE. apply (cprd_disjointify 𝜇 𝜅 2 0).
        apply suc_neq_0. apply H. apply H0.
      + eapply disjointE. apply (cprd_disjointify 𝜇 𝜆 2 1).
        intro. apply Hnq... apply H. apply H0.
  }
  symmetry. eapply Equivalence_Transitive. {
    apply cardAdd_well_defined.
    - reflexivity.
    - unfold CardAdd. rewrite <- eqnum_cprd_single, <- CardAx0.
      apply cardAdd_well_defined.
      + rewrite <- eqnum_cprd_single, (eqnum_cprd_single _ 1)...
      + rewrite <- eqnum_cprd_single, (eqnum_cprd_single _ 2)...
      + apply disjointify_0_1.
      + apply cprd_disjointify. intro. apply Hnq...
    - apply disjointify_0_1.
    - unfold disjoint. rewrite binter_bunion_distr.
      apply EmptyI. intros x Hx. apply BUnionE in Hx as [].
      + pose proof (disjointify_0_1 𝜅 𝜆).
        rewrite H0 in H. exfalso0.
      + apply BInterE in H as [].
        eapply disjointE. apply (cprd_disjointify 𝜅 𝜇 0 2).
        intro. eapply suc_neq_0... apply H. apply H0.
  }
  rewrite bunion_assoc...
Qed.

(* 基数乘法结合律 *)
Theorem cardMul_assoc : ∀ 𝜅 𝜆 𝜇, (𝜅 ⋅ 𝜆) ⋅ 𝜇 = 𝜅 ⋅ (𝜆 ⋅ 𝜇).
Proof.
  intros. apply CardAx1. eapply Equivalence_Transitive.
  - apply cardMul_well_defined.
    symmetry. apply CardAx0. reflexivity.
  - rewrite eqnum_cprd_assoc.
    apply cardMul_well_defined. easy. apply CardAx0.
Qed.

(* 基数乘法分配律 *)
Theorem cardMul_distr : ∀ 𝜅 𝜆 𝜇, 𝜅 ⋅ (𝜆 + 𝜇) = 𝜅 ⋅ 𝜆 + 𝜅 ⋅ 𝜇.
Proof with auto.
  intros. apply CardAx1.
  eapply Equivalence_Transitive. {
    apply cardMul_well_defined.
    reflexivity. symmetry. apply CardAx0...
  }
  rewrite ex3_2_a. apply cardAdd_well_defined.
  - rewrite <- eqnum_cprd_assoc.
    apply cardMul_well_defined... apply CardAx0.
  - rewrite <- eqnum_cprd_assoc.
    apply cardMul_well_defined... apply CardAx0.
  - apply disjointI. intros [x [H1 H2]].
    apply CPrdE0 in H1 as [_ H1].
    apply CPrdE0 in H2 as [_ H2].
    eapply disjointE; revgoals.
    apply H2. apply H1. apply disjointify_0_1.
  - apply disjointify_0_1.
Qed.

Corollary cardMul_distr' : ∀ 𝜅 𝜆 𝜇, (𝜆 + 𝜇) ⋅ 𝜅 = 𝜆 ⋅ 𝜅 + 𝜇 ⋅ 𝜅.
Proof.
  intros. rewrite cardMul_comm, cardMul_distr.
  rewrite cardMul_comm, (cardMul_comm 𝜅). reflexivity.
Qed.

Theorem cardExp_add : ∀ 𝜅 𝜆 𝜇, 𝜅 ^ (𝜆 + 𝜇) = 𝜅 ^ 𝜆 ⋅ 𝜅 ^ 𝜇.
Proof with eauto; try congruence.
  intros. apply CardAx1.
  eapply Equivalence_Transitive. {
    apply cardExp_well_defined.
    reflexivity. symmetry. apply CardAx0.
  }
  symmetry. eapply Equivalence_Transitive. {
    unfold CardExp. apply cardMul_well_defined.
    - rewrite <- CardAx0. apply cardExp_well_defined.
      reflexivity. apply (eqnum_cprd_single _ 0).
    - rewrite <- CardAx0. apply cardExp_well_defined.
      reflexivity. apply (eqnum_cprd_single _ 1).
  }
  remember (𝜆 × {0,}) as s. remember (𝜇 × {1,}) as t.
  assert (Hdj: disjoint s t). { subst. apply disjointify_0_1. }
  clear Heqs Heqt. symmetry.
  set (Func (s ∪ t ⟶ 𝜅) ((s ⟶ 𝜅) × (t ⟶ 𝜅)) (λ f,
    <Func s 𝜅 (λ x, f[x]), Func t 𝜅 (λ x, f[x])>
  )) as F.
  exists F. apply meta_bijection.
  - intros f Hf. apply arrow_iff in Hf as [Hf [Hd Hr]].
    apply CPrdI; apply SepI.
    + apply PowerAx. intros p Hp. apply SepE1 in Hp...
    + apply meta_function.
      intros x Hx. apply Hr. apply BUnionI1...
    + apply PowerAx. intros p Hp. apply SepE1 in Hp...
    + apply meta_function.
      intros x Hx. apply Hr. apply BUnionI2...
  - intros f1 Hf1 f2 Hf2 Heq.
    apply op_iff in Heq as [H1 H2].
    apply arrow_iff in Hf1 as [Hf1 [Hd1 Hr1]].
    apply arrow_iff in Hf2 as [Hf2 [Hd2 Hr2]].
    apply func_ext_intro... intros x Hx. rewrite Hd1 in Hx.
    apply BUnionE in Hx as [Hx|Hx].
    + assert (HF: <x, f1[x]> ∈ Func s 𝜅 (λ x, f1[x])). {
        apply SepI. apply CPrdI... apply Hr1.
        apply BUnionI1... zfc_simple.
      }
      rewrite H1 in HF. apply SepE in HF as [_ HF]. zfc_simple.
    + assert (HF: <x, f1[x]> ∈ Func t 𝜅 (λ x, f1[x])). {
        apply SepI. apply CPrdI... apply Hr1.
        apply BUnionI2... zfc_simple.
      }
      rewrite H2 in HF. apply SepE in HF as [_ HF]. zfc_simple.
  - intros y Hy. apply CPrdE1 in Hy as [g [Hg [h [Hh Heq]]]].
    apply arrow_iff in Hg as [Hgf [Hgd Hgr]].
    apply arrow_iff in Hh as [Hhf [Hhd Hhr]].
    set (Func (s ∪ t) 𝜅 (λ x, match (ixm (x ∈ s)) with
      | inl _ => g[x] | inr _ => h[x]
    end )) as f.
    assert (Hf: f: s ∪ t ⇒ 𝜅). {
      apply meta_function. intros x Hx.
      apply BUnionE in Hx as []; destruct (ixm (x ∈ s))...
    }
    exists f. split. apply SepI... apply PowerAx.
    intros p Hp. apply SepE1 in Hp...
    destruct Hf as [Hff [Hfd Hfr]].
    subst y. apply op_iff. split. {
      ext p Hp.
      - apply SepE in Hp as [H1 H2].
        apply CPrdE1 in H1 as [x [Hx [y [_ Hp]]]].
        subst p. zfc_simple. subst y.
        assert (x ∈ dom f). { rewrite Hfd. apply BUnionI1... }
        apply func_correct in H... apply SepE in H as [_ H2].
        zfc_simple. destruct (ixm (x ∈ s))...
        rewrite H2. apply func_correct...
      - apply func_pair' in Hp as [x [y [Hp Heqp]]]...
        subst p. apply domI in Hp as Hx. apply func_ap in Hp...
        subst y. apply SepI.
        + apply CPrdI... apply Hgr...
        + zfc_simple. rewrite Hgd in Hx.
          assert (x ∈ dom f). { rewrite Hfd. apply BUnionI1... }
          apply func_correct in H... apply SepE in H as [_ H].
          zfc_simple. destruct (ixm (x ∈ s))...
    } {
      ext p Hp.
      - apply SepE in Hp as [H1 H2].
        apply CPrdE1 in H1 as [x [Hx [y [_ Hp]]]].
        subst p. zfc_simple. subst y.
        assert (x ∈ dom f). { rewrite Hfd. apply BUnionI2... }
        apply func_correct in H... apply SepE in H as [_ H2].
        zfc_simple. destruct (ixm (x ∈ s))...
        + exfalso. eapply disjointE...
        + rewrite H2. apply func_correct...
      - apply func_pair' in Hp as [x [y [Hp Heqp]]]...
        subst p. apply domI in Hp as Hx. apply func_ap in Hp...
        subst y. apply SepI.
        + apply CPrdI... apply Hhr...
        + zfc_simple. rewrite Hhd in Hx.
          assert (x ∈ dom f). { rewrite Hfd. apply BUnionI2... }
          apply func_correct in H... apply SepE in H as [_ H].
          zfc_simple. destruct (ixm (x ∈ s))...
          exfalso. eapply disjointE...
    }
Qed.

Theorem cardExp_mul : ∀ 𝜅 𝜆 𝜇, (𝜅 ⋅ 𝜆) ^ 𝜇 = 𝜅 ^ 𝜇 ⋅ 𝜆 ^ 𝜇.
Proof with eauto; try congruence.
  intros. apply CardAx1.
  eapply Equivalence_Transitive. {
    apply cardExp_well_defined.
    symmetry. apply CardAx0. reflexivity.
  }
  symmetry. eapply Equivalence_Transitive. {
    unfold CardExp. apply cardMul_well_defined.
    - symmetry. apply CardAx0.
    - symmetry. apply CardAx0.
  }
  set (Func ((𝜇 ⟶ 𝜅) × (𝜇 ⟶ 𝜆)) (𝜇 ⟶ 𝜅 × 𝜆) (λ p,
    Func 𝜇 (𝜅 × 𝜆) (λ x, <(π1 p)[x], (π2 p)[x]>)
  )) as F.
  exists F. apply meta_bijection.
  - intros p Hp. apply CPrdE1 in Hp as [g [Hg [h [Hh Hp]]]].
    apply arrow_iff in Hg as [Hgf [Hgd Hgr]].
    apply arrow_iff in Hh as [Hhf [Hhd Hhr]].
    subst p. zfc_simple. apply SepI.
    + apply PowerAx. intros p Hp. apply SepE1 in Hp...
    + apply meta_function. intros x Hx. apply CPrdI.
      apply Hgr... apply Hhr...
  - intros p1 Hp1 p2 Hp2 Heq.
    apply CPrdE1 in Hp1 as [g1 [Hg1 [h1 [Hh1 H1]]]].
    apply CPrdE1 in Hp2 as [g2 [Hg2 [h2 [Hh2 H2]]]].
    subst p1 p2. zfc_simple. apply op_iff.
    cut (∀x ∈ 𝜇, <g1[x], h1[x]> = <g2[x], h2[x]>). {
      apply arrow_iff in Hg1 as [Hg1 [Hdg1 _]].
      apply arrow_iff in Hh1 as [Hh1 [Hdh1 _]].
      apply arrow_iff in Hg2 as [Hg2 [Hdg2 _]].
      apply arrow_iff in Hh2 as [Hh2 [Hdh2 _]].
      intros H; split; eapply func_ext_intro...
      - intros x Hx. rewrite Hdg1 in Hx.
        apply H in Hx. apply op_iff in Hx as []...
      - intros x Hx. rewrite Hdh1 in Hx.
        apply H in Hx. apply op_iff in Hx as []...
    }
    intros x Hx.
    cut (∀ g h, g ∈ 𝜇 ⟶ 𝜅 → h ∈ 𝜇 ⟶ 𝜆 →
      <x, <g[x], h[x]>> ∈ Func 𝜇 (𝜅 × 𝜆) (λ x, <g[x], h[x]>)). {
      intros H. pose proof (H _ _ Hg1 Hh1).
      rewrite Heq in H0. apply SepE in H0 as [_ H0]. zfc_simple.
    }
    intros g h Hg Hh.
    apply arrow_iff in Hg as [Hg [Hdg Hrg]].
    apply arrow_iff in Hh as [Hh [Hdh Hrh]].
    apply SepI; zfc_simple. apply CPrdI... apply CPrdI.
    apply Hrg... apply Hrh...
  - intros f Hf. apply SepE in Hf as [_ Hf].
    assert (Hf' := Hf). destruct Hf' as [Hff [Hdf Hrf]].
    set (Func 𝜇 𝜅 (λ x, π1 f[x])) as g.
    set (Func 𝜇 𝜆 (λ x, π2 f[x])) as h.
    assert (Hg: g: 𝜇 ⇒ 𝜅). {
      apply meta_function. intros x Hx. rewrite <- Hdf in Hx.
      apply func_correct in Hx... apply ranI in Hx.
      apply Hrf in Hx. apply CPrdE0 in Hx as []...
    }
    assert (Hh: h: 𝜇 ⇒ 𝜆). {
      apply meta_function. intros x Hx. rewrite <- Hdf in Hx.
      apply func_correct in Hx... apply ranI in Hx.
      apply Hrf in Hx. apply CPrdE0 in Hx as []...
    }
    exists <g, h>. split. {
      apply CPrdI; apply SepI...
      - apply PowerAx. intros p Hp. apply SepE1 in Hp...
      - apply PowerAx. intros p Hp. apply SepE1 in Hp...
    }
    destruct Hg as [Hgf [Hgd _]].
    destruct Hh as [Hhf [Hhd _]].
    assert (Hfx: ∀x ∈ 𝜇, f[x] = <g[x], h[x]>). {
      intros x Hx. rewrite <- Hdf in Hx.
      apply func_correct in Hx as Hfx...
      apply ranI in Hfx. apply Hrf in Hfx.
      apply CPrdE1 in Hfx as [a [Ha [b [Hb Hfx]]]].
      rewrite Hfx. apply op_iff.
      split; symmetry; apply func_ap; auto; (apply SepI;
      [apply CPrdI; congruence|zfc_simple; rewrite Hfx; zfc_simple]).
    }
    ext p Hp.
    + apply SepE in Hp as [Hp Heq].
      apply CPrdE1 in Hp as [x [Hx [y [_ Hp]]]].
      subst p. zfc_simple. subst y. apply Hfx in Hx as Hap.
      rewrite <- Hap. apply func_correct...
    + apply func_pair' in Hp as [x [y [Hp Heqp]]]...
      subst p. apply domI in Hp as Hx. apply ranI in Hp as Hy.
      apply Hrf in Hy. apply SepI; zfc_simple. apply CPrdI...
      rewrite Hdf in Hx. apply Hfx in Hx as Hap.
      rewrite <- Hap. symmetry. apply func_ap...
Qed.

Theorem cardExp_exp : ∀ 𝜅 𝜆 𝜇, (𝜅 ^ 𝜆) ^ 𝜇 = 𝜅 ^ (𝜆 ⋅ 𝜇).
Proof with eauto; try congruence.
  intros. apply CardAx1.
  eapply Equivalence_Transitive. {
    apply cardExp_well_defined.
    symmetry. apply CardAx0. reflexivity.
  }
  symmetry. eapply Equivalence_Transitive. {
    apply cardExp_well_defined.
    reflexivity. symmetry. apply CardAx0.
  }
  set (Func (𝜆 × 𝜇 ⟶ 𝜅) (𝜇 ⟶ (𝜆 ⟶ 𝜅)) (λ f,
    Func 𝜇 (𝜆 ⟶ 𝜅) (λ y,
      Func 𝜆 𝜅 (λ x, f[<x, y>])
  ))) as F.
  exists F. apply meta_bijection.
  - intros f Hf. apply SepI. {
      apply PowerAx. intros p Hp. apply SepE1 in Hp...
    }
    apply meta_function. intros y Hy. apply SepI. {
      apply PowerAx. intros p Hp. apply SepE1 in Hp...
    }
    apply meta_function. intros x Hx.
    apply SepE in Hf as [_ Hf].
    eapply ap_ran... apply CPrdI...
  - intros f1 Hf1 f2 Hf2 Heq.
    apply arrow_iff in Hf1 as [Hf1 [Hdf1 Hrf1]].
    apply arrow_iff in Hf2 as [Hf2 [Hdf2 _]].
    apply func_ext_intro... intros x Hx. rewrite Hdf1 in Hx.
    apply CPrdE1 in Hx as [a [Ha [b [Hb Hx]]]]. subst x.
    remember (Func 𝜇 (𝜆 ⟶ 𝜅) (λ y, Func 𝜆 𝜅 (λ x, f1[<x, y>]))) as F1.
    cut (<b, Func 𝜆 𝜅 (λ x, f1[<x, b>])> ∈ F1). {
      intros H1. rewrite Heq in H1.
      apply SepE in H1 as [_ H1]. zfc_simple.
      cut (<a, f1[<a, b>]> ∈ Func 𝜆 𝜅 (λ x, f1[<x, b>])). {
        intros H2. rewrite H1 in H2.
        apply SepE in H2 as [_ H2]. zfc_simple.
      }
      apply SepI; zfc_simple.
      apply CPrdI... apply Hrf1. apply CPrdI...
    }
    subst F1. apply SepI; zfc_simple.
    apply CPrdI... apply SepI. {
      apply PowerAx. intros p Hp. apply SepE1 in Hp...
    }
    apply meta_function. intros x Hx.
    apply Hrf1. apply CPrdI...
  - intros f Hf. apply SepE in Hf as [_ [Hff [Hdf Hrf]]].
    set (Func (𝜆 × 𝜇) 𝜅 (λ p, f[π2 p][π1 p])) as g.
    assert (H1: ∀x ∈ dom f, f[x] = Func 𝜆 𝜅 (λ y, g[<y, x>])). {
      intros x Hx. apply func_correct in Hx as Hfx...
      apply ranI in Hfx. apply Hrf in Hfx.
      apply arrow_iff in Hfx as [Hhf [Hhd Hhr]].
      apply func_ext_intro... apply func_is_func.
      - ext y Hy.
        + eapply domI. apply SepI.
          * apply CPrdI... apply Hhr. rewrite <- Hhd. apply Hy.
          * zfc_simple. symmetry.
            apply func_ap. apply func_is_func.
            apply SepI; zfc_simple. apply CPrdI.
            apply CPrdI... apply Hhr...
        + apply domE in Hy as [z Hp]. apply SepE in Hp as [Hy _].
          apply CPrdE2 in Hy as [Hy _]...
      - intros y Hy. symmetry. apply func_ap.
        apply func_is_func. apply SepI; zfc_simple.
        + apply CPrdI... apply Hhr...
        + symmetry. apply func_ap. apply func_is_func.
          apply SepI; zfc_simple. apply CPrdI.
          apply CPrdI... apply Hhr...
    }
    assert (H2: ∀x ∈ dom f, <x, f[x]> ∈ (Func 𝜇 (𝜆 ⟶ 𝜅) (λ b, Func 𝜆 𝜅 (λ a, g[<a, b>])))). {
      intros x Hx. apply SepI; zfc_simple.
      - apply CPrdI. rewrite <- Hdf... apply Hrf.
        eapply ap_ran... split...
      - apply H1...
    }
    assert (H3: dom (Func 𝜇 (𝜆 ⟶ 𝜅) (λ y, Func 𝜆 𝜅 (λ x, g[<x, y>]))) = dom f). {
      ext Hx.
      - apply domE in Hx as [y Hp]. apply SepE in Hp as [Hx _].
        apply CPrdE2 in Hx as [Hx _]...
      - eapply domI. apply H2...
    }
    exists g. split.
    + apply SepI. {
        apply PowerAx. intros p Hp. apply SepE1 in Hp...
      }
      apply meta_function. intros p Hp.
      apply CPrdE1 in Hp as [a [Ha [b [Hb Hp]]]].
      subst p. zfc_simple. rewrite <- Hdf in Hb.
      apply func_correct in Hb... apply ranI in Hb. apply Hrf in Hb.
      apply arrow_iff in Hb as [_ [_ Hr]]. apply Hr...
    + apply func_ext_intro... apply func_is_func.
      intros x Hx. rewrite H3 in Hx.
      apply func_ap. apply func_is_func. apply H2...
Qed.

Lemma cardAdd_suc : ∀ 𝜅 𝜆, 𝜅 + (𝜆 + 1) = (𝜅 + 𝜆) + 1.
Proof. intros. rewrite cardAdd_assoc. auto. Qed.

Lemma cardMul_suc : ∀𝜅 ⋵ 𝐂𝐃, ∀ 𝜆, 𝜅 ⋅ (𝜆 + 1) = 𝜅 ⋅ 𝜆 + 𝜅.
Proof. intros 𝜅 H 𝜆. rewrite cardMul_distr, cardMul_1_r; auto. Qed.

Lemma cardExp_suc : ∀𝜅 ⋵ 𝐂𝐃, ∀ 𝜆, 𝜅 ^ (𝜆 + 1) = 𝜅 ^ 𝜆 ⋅ 𝜅.
Proof. intros 𝜅 H 𝜆. rewrite cardExp_add, cardExp_1_r; auto. Qed.

Lemma card_suc : ∀n ∈ ω, n + 1 = n⁺.
Proof with auto; try easy.
  intros n Hn.
  rewrite (card_of_nat n⁺); [|apply ω_inductive]...
  apply CardAx1. apply cardAdd_well_defined.
  - rewrite <- eqnum_cprd_single...
  - rewrite <- eqnum_cprd_single, eqnum_single...
  - apply disjointify_0_1.
  - apply nat_disjoint...
Qed.

(* 有限基数加法等效于自然数加法 *)
Theorem fin_cardAdd_eq_add : ∀ m n ∈ ω, m + n = (m + n)%ω.
Proof with auto.
  intros m Hm n Hn. generalize dependent m.
  ω_induction n; intros k Hk.
  - rewrite cardAdd_0_r, add_0_r... apply nat_is_card...
  - rewrite <- card_suc at 1...
    rewrite <- cardAdd_assoc, IH, card_suc, add_suc...
    apply add_ran...
Qed.

(* 有限基数乘法等效于自然数乘法 *)
Theorem fin_cardMul_eq_mul : ∀ m n ∈ ω, m ⋅ n = (m ⋅ n)%ω.
Proof with auto.
  intros m Hm n Hn. generalize dependent m.
  ω_induction n; intros k Hk.
  - rewrite cardMul_0_r_r, mul_0_r...
  - rewrite <- card_suc at 1...
    rewrite cardMul_suc, IH, fin_cardAdd_eq_add, mul_suc, add_comm...
    apply mul_ran... apply mul_ran... apply nat_is_card...
Qed.

(* 有限基数乘方等效于自然数乘方 *)
Theorem fin_cardExp_eq_exp : ∀ m n ∈ ω, m ^ n = (m ^ n)%ω.
Proof with auto.
  intros m Hm n Hn. generalize dependent m.
  ω_induction n; intros k Hk.
  - rewrite cardExp_0_r, exp_0_r...
  - rewrite <- card_suc at 1...
    assert ((k ^ m)%ω ∈ ω) by (apply exp_ran; auto).
    rewrite cardExp_suc, IH, fin_cardMul_eq_mul, exp_suc, mul_comm...
    apply nat_is_card...
Qed.

(* 有限基数的和是自然数 *)
Corollary fin_cardAdd_ran : ∀ m n ∈ ω, m + n ∈ ω.
Proof with auto.
  intros m Hm n Hn. rewrite fin_cardAdd_eq_add... apply add_ran...
Qed.

(* 有限基数的积是自然数 *)
Corollary fin_cardMul_ran : ∀ m n ∈ ω, m ⋅ n ∈ ω.
Proof with auto.
  intros m Hm n Hn. rewrite fin_cardMul_eq_mul... apply mul_ran...
Qed.

(* 有限基数的幂是自然数 *)
Corollary fin_cardExp_ran : ∀ m n ∈ ω, m ^ n ∈ ω.
Proof with auto.
  intros m Hm n Hn. rewrite fin_cardExp_eq_exp... apply exp_ran...
Qed.

(* 有限集的二元并仍是有限集 *)
Corollary bunion_finite :
  ∀ A B, finite A → finite B → finite (A ∪ B).
Proof with auto.
  intros * Hfa Hfb. rewrite <- ex2_11_2.
  assert (Hfb': finite (B - A)). {
    apply (subset_of_finite_is_finite _ B)...
  }
  destruct Hfa as [m [Hm Ha]]. destruct Hfb' as [n [Hn Hb]].
  exists (m + n). split. apply fin_cardAdd_ran...
  unfold CardAdd. rewrite <- CardAx0.
  apply cardAdd_well_defined.
  - rewrite Ha. apply eqnum_cprd_single.
  - rewrite Hb. apply eqnum_cprd_single.
  - apply binter_comp_empty.
  - apply disjointify_0_1.
Qed.

(* 有限集的笛卡尔积仍是有限集 *)
Corollary cprd_finite :
  ∀ A B, finite A → finite B → finite (A × B).
Proof with auto.
  intros * [m [Hm Ha]] [n [Hn Hb]].
  exists (m ⋅ n). split. apply fin_cardMul_ran...
  unfold CardMul. rewrite <- CardAx0.
  apply cardMul_well_defined...
Qed.

(* 有限集张起的函数空间是有限集 *)
Corollary arrow_finite :
  ∀ A B, finite A → finite B → finite (B ⟶ A).
Proof with auto.
  intros * [m [Hm Ha]] [n [Hn Hb]].
  exists (m ^ n). split. apply fin_cardExp_ran...
  unfold CardExp. rewrite <- CardAx0.
  apply cardExp_well_defined...
Qed.

(* 与后继数等势的集合非空 *)
Lemma set_eqnum_suc_nonempty : ∀ A, ∀n ∈ ω, A ≈ n⁺ → ⦿ A.
Proof with eauto.
  intros A n Hn HA. apply EmptyNE.
  contra. apply NNPP in H. subst A.
  symmetry in HA. apply eqnum_empty in HA. eapply suc_neq_0...
Qed.

(* 有限集里的补集是有限集 *)
Lemma comp_finite : ∀ A B, finite A → finite (A - B).
Proof with auto.
  intros * [n [Hn Hqn]]. generalize dependent A.
  ω_induction n; intros A Hqn.
  - apply eqnum_empty in Hqn. subst A.
    rewrite empty_comp. apply empty_finite.
  - apply set_eqnum_suc_nonempty in Hqn as Hne...
    destruct Hne as [a Ha].
    apply split_one_element in Ha. rewrite Ha in *.
    apply finite_set_remove_one_member in Hqn... rewrite bunion_comp.
    apply bunion_finite. apply IH...
    destruct (classic (a ∈ B)).
    + replace ({a,} - B) with ∅. apply empty_finite.
      ext Hx. exfalso0. exfalso.
      apply SepE in Hx as [Hx Hx']. apply SingE in Hx; subst...
    + replace ({a,} - B) with ({a,})...
      ext Hx.
      * apply SingE in Hx; subst. apply SepI...
      * apply SepE1 in Hx...
Qed.

(* 有限集加上一个元素仍是有限集 *)
Lemma add_one_still_finite_1 :
  ∀ a A, finite (A - {a,}) → finite A.
Proof with auto.
  intros * Hfin.
  destruct (classic (a ∈ A)).
  - rewrite <- (remove_one_member_then_return A a)...
    apply bunion_finite...
  - rewrite remove_no_member in Hfin...
Qed.

(* 有限集加上一个元素仍是有限集 *)
Lemma add_one_still_finite_2 : ∀ A a,
  finite A → finite (A ∪ {a,}).
Proof with auto.
  intros * Hfa.
  destruct (classic (disjoint A {a,})).
  - destruct Hfa as [m [Hm HA]].
    exists m⁺. split. apply ω_inductive...
    apply cardAdd_well_defined... apply nat_disjoint...
  - apply EmptyNE in H as [a' Ha].
    apply BInterE in Ha as [Ha Heq].
    apply SingE in Heq. subst a'.
    replace (A ∪ {a,}) with A...
    ext Hx.
    + apply BUnionI1...
    + apply BUnionE in Hx as []... apply SingE in H. subst x...
Qed.

(* 无限集除去一个元素仍是无限集 *)
Lemma remove_one_member_from_infinite :
  ∀ a A, infinite A → infinite (A - {a,}).
Proof.
  intros * Hinf Hfin. apply Hinf.
  eapply add_one_still_finite_1; eauto.
Qed.

(* 任意集合与其一对一的替代等势 *)
Lemma eqnum_repl : ∀ F A B, A ≈ B → (∀ x1 x2 ∈ A, F x1 = F x2 → x1 = x2) →
  {F x | x ∊ A} ≈ B.
Proof with eauto; try congruence.
  intros * Hqn. symmetry.
  symmetry in Hqn. destruct Hqn as [f Hbi].
  assert (H' := Hbi). apply bijection_is_func in H' as [Hf [Hi Hr]].
  assert (H' := Hf). destruct H' as [_ [Hd _]].
  set (Func B {F x | x ∊ A} (λ x, F f[x])) as g.
  exists g. apply meta_bijection.
  - intros x Hx. apply ReplAx. exists (f[x]).
    split... eapply ap_ran...
  - intros x1 H1 x2 H2 Heq. apply H in Heq...
    2-3: eapply ap_ran... eapply injectiveE...
  - intros y Hy. apply ReplAx in Hy as [x [Hx HFx]].
    exists (f⁻¹[x]). split. eapply ap_ran...
    apply bijection_is_func. apply inv_bijection...
    rewrite inv_ran_reduction...
Qed.

(* 任意单集与其任意替代等势 *)
Lemma eqnum_repl_single : ∀ F a, {a,} ≈ {F x | x ∊ {a,}}.
Proof. intros. rewrite repl_single. apply all_single_eqnum. Qed.

(* 任意单集的任意替代是有限集 *)
Lemma repl_single_finite : ∀ F a, finite {F x | x ∊ {a,}}.
Proof. intros. rewrite repl_single. apply single_finite. Qed.

(* 有限集的替代仍是有限集 *)
Lemma repl_finite : ∀ F A, finite A → finite {F x | x ∊ A}.
Proof with auto.
  intros * [n [Hn Hqn]].
  generalize dependent A.
  ω_induction n; intros A Hqn.
  - apply eqnum_empty in Hqn. subst A.
    rewrite repl_empty. apply empty_finite.
  - apply set_eqnum_suc_nonempty in Hqn as Hne...
    destruct Hne as [a Ha].
    apply split_one_element in Ha. rewrite Ha in *.
    apply finite_set_remove_one_member in Hqn...
    rewrite repl_bunion_distr.
    apply bunion_finite. apply IH... apply repl_single_finite.
Qed.

(* 有限集与任意集合的交是有限集 *)
Lemma binter_finite_r : ∀ A B, finite B → finite (A ∩ B).
Proof with auto.
  intros * [n [Hn Hqn]].
  generalize dependent B.
  ω_induction n; intros B Hqn.
  - apply eqnum_empty in Hqn. subst B.
    rewrite binter_empty. apply empty_finite.
  - apply set_eqnum_suc_nonempty in Hqn as Hne...
    destruct Hne as [a Ha].
    apply split_one_element in Ha. rewrite Ha in *.
    apply finite_set_remove_one_member in Hqn...
    rewrite binter_bunion_distr.
    apply bunion_finite. apply IH...
    destruct (classic (a ∈ A)).
    + replace (A ∩ {a,}) with {a,}. apply single_finite.
      ext Hx.
      * apply SingE in Hx; subst. apply BInterI...
      * apply BInterE in Hx as []...
    + replace (A ∩ {a,}) with ∅. apply empty_finite.
      ext Hx. exfalso0. exfalso.
      apply BInterE in Hx as []. apply SingE in H1; subst...
Qed.

Corollary binter_finite_l : ∀ A B, finite A → finite (A ∩ B).
Proof.
  intros. rewrite binter_comm. apply binter_finite_r. apply H.
Qed.


Require Import HoTT.
Require Import HoTT_axioms.
Require Import Equiv_def.
From Coq Require Import ssreflect.

Set Universe Polymorphism.

Unset Universe Minimization ToSet.

(* ########################################################### *)
(* ###               Parametricity for CCω                 ### *)
(* ########################################################### *)

(* ########################################################### *)
(* ###                      Type ⋈ Type                   ### *)
(* ########################################################### *)

Instance FR_Type_def : Rel Type Type := FR_Type.

Instance FP_Type : Type ⋈ Type.
Proof.
  econstructor. unfold rel. unshelve econstructor => [A|B].
  + eapply (contr_equiv2 {B:Type & A = B}). 2: apply IsContrSingleton_r.
    apply EquivSigma; intro B. apply (@equiv_compose _ (Equiv A B) _).
    apply Univ. apply Equiv_Equiv_FR_Type.
  + eapply (contr_equiv2 {A:Type & A = B}). 2: apply IsContrSingleton_l.
    apply EquivSigma; intro A. apply (@equiv_compose _ (Equiv A B) _).
    apply Univ. apply Equiv_Equiv_FR_Type.
Defined.

Check (eq_refl : ↑ nat = nat).

(* ########################################################### *)
(* ###                      Prop ⋈ Prop                    ### *)
(* ########################################################### *)

Instance FR_Prop_def : Rel Prop Prop := FR_Type.

Instance FP_Prop : Prop ⋈ Prop.
Proof.
  econstructor. unfold rel. unshelve econstructor => [A|B].
  + eapply (contr_equiv2 {B:Prop & A = B}). 2: apply IsContrSingleton_r.
    apply EquivSigma; intro B. apply (@equiv_compose _ (Equiv A B) _).
    apply UnivP. apply Equiv_Equiv_FR_Type.
  + eapply (contr_equiv2 {A:Prop & A = B}). 2: apply IsContrSingleton_l.
    apply EquivSigma; intro A. apply (@equiv_compose _ (Equiv A B) _).
    apply UnivP. apply Equiv_Equiv_FR_Type.
Defined.

(* ########################################################### *)
(* ###                 Π(a:A) B ⋈ Π(a':A') B'              ### *)
(* ########################################################### *)

Definition FR_Forall {A A'} {B : A -> Type} {B' : A' -> Type} (RA : Rel A A')
          (RB: forall x y (H: x ≈ y), Rel (B x) (B' y)) :
  Rel (forall x, B x) (forall y, B' y)
  :=
  fun f g => forall x y (H:x ≈ y), f x ≈ g y.

#[export] Hint Extern 0 (Rel (forall x:_ , _) (forall x:_ , _)) =>
 refine (FR_Forall _ _) ; intros : typeclass_instances.

Definition IsFun_forall (A A' : Type) (B : A -> Type) (B' : A' -> Type)
  (RA : Rel A A') (RAEquiv : IsWeakEquiv RA)
  (RB: forall a a' (H: RA a a'), Rel (B a) (B' a'))
  (RBEquiv : forall a a' (H: RA a a'), IsWeakEquiv(RB a a' H)) :
IsFun (FR_Forall RA RB).
Proof.
  intro f. unfold FR_Forall. unfold rel. destruct RAEquiv as [WF WFsym].
  set CB := fun (a':A') => ((isWFun (RBEquiv (((WFsym a').1).1) a' (((WFsym a').1).2)) (f (((WFsym a').1).1))).1).1.
  apply (contr_equiv2 {g : forall a' : A', B' a' & CB = g }).
    2: apply IsContrSingleton_r.
  (* simpl g + a' *)
  apply Equiv_inverse. apply EquivSigma; intro g.
  eapply equiv_compose. eapply (@swap_forall A A' _). cbn.
  eapply (@equiv_compose _ (CB == g) _). 2: apply Fune.
  apply EquivPtype; intro a'.
  (* simpl forall *)
  eapply equiv_compose. apply ForallSigma. cbn.
  eapply equiv_compose. unshelve eapply IsContrForall_domain. exact (WFsym a').
  apply Equiv_inverse. unfold CB. apply EquivRabCenter.
Defined.

Definition Forall_sym_sym
           {A A'} {B : A -> Type} {B' : A' -> Type} (RA : Rel A A')
           (RB: forall x y (H: RA x y), Rel (B x) (B' y)) :
  forall f g, FR_Forall RA RB f g ≃ sym (FR_Forall (sym RA) (fun x y e => sym (RB y x e))) f g.
Proof.
  intros. unshelve econstructor; cbn.
  compute; intros; auto.
  unshelve econstructor; compute => //=.
Defined.

Definition FP_forall (A A' : Type) (eA : A ⋈ A')
           (B : A -> Type) (B' : A' -> Type)
           (eB : forall (a:A) (a':A') (H: (_R eA) a a'), B a ⋈ B' a') :
  (forall x : A,
      B x) ⋈ (forall x : A', B' x).
Proof.
  unshelve econstructor.
  * split.
    + apply IsFun_forall; typeclasses eauto.
    + eapply IsFun_Equiv. eapply Forall_sym_sym. apply IsFun_forall.
      - destruct eA as [RA FA]. apply IsWeakEquiv_sym. exact FA.
      - intros a' a H. destruct (eB a a' H) as [RB FB].
        apply IsWeakEquiv_sym. exact FB.
Defined.

#[export] Hint Extern 0 ((forall x : _ , _) ⋈ (forall y : _ , _)) =>
unshelve refine (FP_forall _ _ _ _ _ _) ; intros : typeclass_instances.