(* This file is generated by Why3's Coq driver *)
(* Beware! Only edit allowed sections below    *)
Require Import ZArith.
Require Import Rbase.
Require int.Int.
Require real.Real.
Require real.RealInfix.
Require real.FromInt.

Parameter pow2: Z -> R.

Axiom Power_0 : ((pow2 0%Z) = 1%R).

Axiom Power_s : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p : forall (n:Z), (n <= 0%Z)%Z ->
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_s_all : forall (n:Z), ((pow2 (n + 1%Z)%Z) = (2%R * (pow2 n))%R).

Axiom Power_p_all : forall (n:Z),
  ((pow2 (n - 1%Z)%Z) = ((05 / 10)%R * (pow2 n))%R).

Axiom Power_1_2 : ((05 / 10)%R = (Rdiv 1%R 2%R)%R).

Axiom Power_1 : ((pow2 1%Z) = 2%R).

Axiom Power_neg1 : ((pow2 (-1%Z)%Z) = (05 / 10)%R).

Axiom Power_non_null_aux : forall (n:Z), (0%Z <= n)%Z -> ~ ((pow2 n) = 0%R).

Axiom Power_neg_aux : forall (n:Z), (0%Z <= n)%Z ->
  ((pow2 (-n)%Z) = (Rdiv 1%R (pow2 n))%R).

Axiom Power_non_null : forall (n:Z), ~ ((pow2 n) = 0%R).

Axiom Power_neg : forall (n:Z), ((pow2 (-n)%Z) = (Rdiv 1%R (pow2 n))%R).

Axiom Power_sum_aux : forall (n:Z) (m:Z), (0%Z <= m)%Z ->
  ((pow2 (n + m)%Z) = ((pow2 n) * (pow2 m))%R).

Axiom Power_sum : forall (n:Z) (m:Z),
  ((pow2 (n + m)%Z) = ((pow2 n) * (pow2 m))%R).

Parameter pow21: Z -> Z.

Axiom Power_01 : ((pow21 0%Z) = 1%Z).

Axiom Power_s1 : forall (n:Z), (0%Z <= n)%Z ->
  ((pow21 (n + 1%Z)%Z) = (2%Z * (pow21 n))%Z).

Axiom Power_11 : ((pow21 1%Z) = 2%Z).

Axiom Power_sum1 : forall (n:Z) (m:Z), ((0%Z <= n)%Z /\ (0%Z <= m)%Z) ->
  ((pow21 (n + m)%Z) = ((pow21 n) * (pow21 m))%Z).

Axiom pow2_0 : ((pow21 0%Z) = 1%Z).

Axiom pow2_1 : ((pow21 1%Z) = 2%Z).

Axiom pow2_2 : ((pow21 2%Z) = 4%Z).

Axiom pow2_3 : ((pow21 3%Z) = 8%Z).

Axiom pow2_4 : ((pow21 4%Z) = 16%Z).

Axiom pow2_5 : ((pow21 5%Z) = 32%Z).

Axiom pow2_6 : ((pow21 6%Z) = 64%Z).

Axiom pow2_7 : ((pow21 7%Z) = 128%Z).

Axiom pow2_8 : ((pow21 8%Z) = 256%Z).

Axiom pow2_9 : ((pow21 9%Z) = 512%Z).

Axiom pow2_10 : ((pow21 10%Z) = 1024%Z).

Axiom pow2_11 : ((pow21 11%Z) = 2048%Z).

Axiom pow2_12 : ((pow21 12%Z) = 4096%Z).

Axiom pow2_13 : ((pow21 13%Z) = 8192%Z).

Axiom pow2_14 : ((pow21 14%Z) = 16384%Z).

Axiom pow2_15 : ((pow21 15%Z) = 32768%Z).

Axiom pow2_16 : ((pow21 16%Z) = 65536%Z).

Axiom pow2_17 : ((pow21 17%Z) = 131072%Z).

Axiom pow2_18 : ((pow21 18%Z) = 262144%Z).

Axiom pow2_19 : ((pow21 19%Z) = 524288%Z).

Axiom pow2_20 : ((pow21 20%Z) = 1048576%Z).

Axiom pow2_21 : ((pow21 21%Z) = 2097152%Z).

Axiom pow2_22 : ((pow21 22%Z) = 4194304%Z).

Axiom pow2_23 : ((pow21 23%Z) = 8388608%Z).

Axiom pow2_24 : ((pow21 24%Z) = 16777216%Z).

Axiom pow2_25 : ((pow21 25%Z) = 33554432%Z).

Axiom pow2_26 : ((pow21 26%Z) = 67108864%Z).

Axiom pow2_27 : ((pow21 27%Z) = 134217728%Z).

Axiom pow2_28 : ((pow21 28%Z) = 268435456%Z).

Axiom pow2_29 : ((pow21 29%Z) = 536870912%Z).

Axiom pow2_30 : ((pow21 30%Z) = 1073741824%Z).

Axiom pow2_31 : ((pow21 31%Z) = 2147483648%Z).

Axiom pow2_32 : ((pow21 32%Z) = 4294967296%Z).

Axiom pow2_33 : ((pow21 33%Z) = 8589934592%Z).

Axiom pow2_34 : ((pow21 34%Z) = 17179869184%Z).

Axiom pow2_35 : ((pow21 35%Z) = 34359738368%Z).

Axiom pow2_36 : ((pow21 36%Z) = 68719476736%Z).

Axiom pow2_37 : ((pow21 37%Z) = 137438953472%Z).

Axiom pow2_38 : ((pow21 38%Z) = 274877906944%Z).

Axiom pow2_39 : ((pow21 39%Z) = 549755813888%Z).

Axiom pow2_40 : ((pow21 40%Z) = 1099511627776%Z).

Axiom pow2_41 : ((pow21 41%Z) = 2199023255552%Z).

Axiom pow2_42 : ((pow21 42%Z) = 4398046511104%Z).

Axiom pow2_43 : ((pow21 43%Z) = 8796093022208%Z).

Axiom pow2_44 : ((pow21 44%Z) = 17592186044416%Z).

Axiom pow2_45 : ((pow21 45%Z) = 35184372088832%Z).

Axiom pow2_46 : ((pow21 46%Z) = 70368744177664%Z).

Axiom pow2_47 : ((pow21 47%Z) = 140737488355328%Z).

Axiom pow2_48 : ((pow21 48%Z) = 281474976710656%Z).

Axiom pow2_49 : ((pow21 49%Z) = 562949953421312%Z).

Axiom pow2_50 : ((pow21 50%Z) = 1125899906842624%Z).

Axiom pow2_51 : ((pow21 51%Z) = 2251799813685248%Z).

Axiom pow2_52 : ((pow21 52%Z) = 4503599627370496%Z).

Axiom pow2_53 : ((pow21 53%Z) = 9007199254740992%Z).

Axiom pow2_54 : ((pow21 54%Z) = 18014398509481984%Z).

Axiom pow2_55 : ((pow21 55%Z) = 36028797018963968%Z).

Axiom pow2_56 : ((pow21 56%Z) = 72057594037927936%Z).

Axiom pow2_57 : ((pow21 57%Z) = 144115188075855872%Z).

Axiom pow2_58 : ((pow21 58%Z) = 288230376151711744%Z).

Axiom pow2_59 : ((pow21 59%Z) = 576460752303423488%Z).

Axiom pow2_60 : ((pow21 60%Z) = 1152921504606846976%Z).

Axiom pow2_61 : ((pow21 61%Z) = 2305843009213693952%Z).

Axiom pow2_62 : ((pow21 62%Z) = 4611686018427387904%Z).

Axiom pow2_63 : ((pow21 63%Z) = 9223372036854775808%Z).

Require Import Why3.
Ltac ae := why3 "alt-ergo" timelimit 2.
Open Scope Z_scope.

(* Why3 goal *)
Theorem Pow2_int_real : forall (x:Z), (0%Z <= x)%Z ->
  ((pow2 x) = (IZR (pow21 x))).
intros x Hx.
generalize Hx.
pattern x; apply Z_lt_induction; auto.
clear x Hx.
intros x Hind Hx.
assert (h:x = 0 \/ x > 0) by omega; destruct h.
subst x.
rewrite Power_0.
rewrite pow2_0.
auto with zarith.
replace x with (x-1+1) by omega.
rewrite Power_s; auto with zarith.
rewrite Power_sum1; auto with zarith.
rewrite pow2_1.
rewrite Zmult_comm.
rewrite mult_IZR.
rewrite Hind; auto with zarith.
Qed.


From Coq Require Import Bool String List BinPos Compare_dec Lia Arith.
Require Import Equations.Prop.DepElim.
From Equations Require Import Equations.
From MetaCoq Require Import Ast utils Typing.
From Translation
Require Import util SAst Equality SLiftSubst SCommon.
Import ListNotations.

Open Scope s_scope.

(*! Reduction. *)

Section Red1.

Context `{Sort_notion : Sorts.notion}.

Inductive red1 : sterm -> sterm -> Prop :=
(*! Computation *)

(** β *)
| red_beta n A B A' B' t u :
    red1 (sApp (sLambda n A B t) A' B' u) (t{ 0 := u })

(** J-Refl *)
| red_JRefl A u P w v A' u' :
    red1 (sJ A u P w v (sRefl A' u')) w

(** Transport of Refl *)
| red_TransportRefl A A' A'' T t :
    red1 (sTransport A A' (sRefl T A'') t) t

(*! Subterm reduction *)

(** Lambda *)
| abs_red_dom na A A' B t :
    red1 A A' ->
    red1 (sLambda na A B t) (sLambda na A' B t)

| abs_red_codom na A B B' t :
    red1 B B' ->
    red1 (sLambda na A B t) (sLambda na A B' t)

| abs_red_body na A B t t' :
    red1 t t' ->
    red1 (sLambda na A B t) (sLambda na A B t')

(** App *)
| app_red_fun u u' A B v :
    red1 u u' ->
    red1 (sApp u A B v) (sApp u' A B v)

| app_red_dom u A A' B v :
    red1 A A' ->
    red1 (sApp u A B v) (sApp u A' B v)

| app_red_codom u A B B' v :
    red1 B B' ->
    red1 (sApp u A B v) (sApp u A B' v)

| app_red_arg u A B v v' :
    red1 v v' ->
    red1 (sApp u A B v) (sApp u A B v')

(** Prod *)
| prod_red_l na na' A A' B :
    red1 A A' ->
    red1 (sProd na A B) (sProd na' A' B)

| prod_red_r na na' A B B' :
    red1 B B' ->
    red1 (sProd na A B) (sProd na' A B')

(** Sum *)
| sum_red_l na na' A A' B :
    red1 A A' ->
    red1 (sSum na A B) (sSum na' A' B)

| sum_red_r na na' A B B' :
    red1 B B' ->
    red1 (sSum na A B) (sSum na' A B')

(** Pair *)
| pair_red_dom A B u v A' :
    red1 A A' ->
    red1 (sPair A B u v) (sPair A' B u v)

| pair_red_cod A B u v B' :
    red1 B B' ->
    red1 (sPair A B u v) (sPair A B' u v)

| pair_red_tm_l A B u v u' :
    red1 u u' ->
    red1 (sPair A B u v) (sPair A B u' v)

| pair_red_tm_r A B u v v' :
    red1 v v' ->
    red1 (sPair A B u v) (sPair A B u v')

(** Pi1 *)
| pi1_red_dom A B p A' :
    red1 A A' ->
    red1 (sPi1 A B p) (sPi1 A' B p)

| pi1_red_cod A B p B' :
    red1 B B' ->
    red1 (sPi1 A B p) (sPi1 A B' p)

| pi1_red_tm A B p p' :
    red1 p p' ->
    red1 (sPi1 A B p) (sPi1 A B p')

(** Pi2 *)
| pi2_red_dom A B p A' :
    red1 A A' ->
    red1 (sPi2 A B p) (sPi2 A' B p)

| pi2_red_cod A B p B' :
    red1 B B' ->
    red1 (sPi2 A B p) (sPi2 A B' p)

| pi2_red_tm A B p p' :
    red1 p p' ->
    red1 (sPi2 A B p) (sPi2 A B p')

(** Eq *)
| eq_red_ty A A' u v :
    red1 A A' ->
    red1 (sEq A u v) (sEq A' u v)

| eq_red_l A u u' v :
    red1 u u' ->
    red1 (sEq A u v) (sEq A u' v)

| eq_red_r A u v v' :
    red1 v v' ->
    red1 (sEq A u v) (sEq A u v')

(** Refl *)
| refl_red_ty A A' u :
    red1 A A' ->
    red1 (sRefl A u) (sRefl A' u)

| refl_red_tm A u u' :
    red1 u u' ->
    red1 (sRefl A u) (sRefl A u')

(** J *)
| j_red_ty A A' u v P p w :
    red1 A A' ->
    red1 (sJ A u P w v p) (sJ A' u P w v p)

| j_red_l A u u' v P p w :
    red1 u u' ->
    red1 (sJ A u P w v p) (sJ A u' P w v p)

| j_red_pred A u v P P' p w :
    red1 P P' ->
    red1 (sJ A u P w v p) (sJ A u P' w v p)

| j_red_prf A u v P p w w' :
    red1 w w' ->
    red1 (sJ A u P w v p) (sJ A u P w' v p)

| j_red_r A u v v' P p w :
    red1 v v' ->
    red1 (sJ A u P w v p) (sJ A u P w v' p)

| j_red_eq A u v P p p' w :
    red1 p p' ->
    red1 (sJ A u P w v p) (sJ A u P w v p')

(** Transport *)
| transport_red_ty_l A A' B p t :
    red1 A A' ->
    red1 (sTransport A B p t) (sTransport A' B p t)

| transport_red_ty_r A B B' p t :
    red1 B B' ->
    red1 (sTransport A B p t) (sTransport A B' p t)

| transport_red_eq A B p p' t :
    red1 p p' ->
    red1 (sTransport A B p t) (sTransport A B p' t)

| transport_red_tm A B p t t' :
    red1 t t' ->
    red1 (sTransport A B p t) (sTransport A B p t')

(** Heq *)
| heq_red_ty_l A A' a B b :
    red1 A A' ->
    red1 (sHeq A a B b) (sHeq A' a B b)

| heq_red_tm_l A a a' B b :
    red1 a a' ->
    red1 (sHeq A a B b) (sHeq A a' B b)

| heq_red_ty_r A a B B' b :
    red1 B B' ->
    red1 (sHeq A a B b) (sHeq A a B' b)

| heq_red_tm_r A a B b b' :
    red1 b b' ->
    red1 (sHeq A a B b) (sHeq A a B b')

(** HeqToEq *)
| heqtoeq_red p p' :
    red1 p p' ->
    red1 (sHeqToEq p) (sHeqToEq p')

(** HeqRefl *)
| heqrefl_red_ty A A' a :
    red1 A A' ->
    red1 (sHeqRefl A a) (sHeqRefl A' a)

| heqrefl_red_tm A a a' :
    red1 a a' ->
    red1 (sHeqRefl A a) (sHeqRefl A a')

(** HeqSym *)
| heqsym_red p p' :
    red1 p p' ->
    red1 (sHeqSym p) (sHeqSym p')

(** HeqTrans *)
| heqtrans_red_l p p' q :
    red1 p p' ->
    red1 (sHeqTrans p q) (sHeqTrans p' q)

| heqtrans_red_r p q q' :
    red1 q q' ->
    red1 (sHeqTrans p q) (sHeqTrans p q')

(** HeqTransport *)
| heqtransport_red_eq p p' t :
    red1 p p' ->
    red1 (sHeqTransport p t) (sHeqTransport p' t)

| heqtransport_red_tm p t t' :
    red1 t t' ->
    red1 (sHeqTransport p t) (sHeqTransport p t')

(** CongProd *)
| congprod_red_ty_l B1 B1' B2 pA pB :
    red1 B1 B1' ->
    red1 (sCongProd B1 B2 pA pB) (sCongProd B1' B2 pA pB)

| congprod_red_ty_r B1 B2 B2' pA pB :
    red1 B2 B2' ->
    red1 (sCongProd B1 B2 pA pB) (sCongProd B1 B2' pA pB)

| congprod_red_tm_l B1 B2 pA pA' pB :
    red1 pA pA' ->
    red1 (sCongProd B1 B2 pA pB) (sCongProd B1 B2 pA' pB)

| congprod_red_tm_r B1 B2 pA pB pB' :
    red1 pB pB' ->
    red1 (sCongProd B1 B2 pA pB) (sCongProd B1 B2 pA pB')

(** CongLambda *)
| conglambda_red_ty_l B1 B2 t1 t2 pA pB pt B1' :
    red1 B1 B1' ->
    red1 (sCongLambda B1 B2 t1 t2 pA pB pt)
             (sCongLambda B1' B2 t1 t2 pA pB pt)

| conglambda_red_ty_r B1 B2 t1 t2 pA pB pt B2' :
    red1 B2 B2' ->
    red1 (sCongLambda B1 B2 t1 t2 pA pB pt)
             (sCongLambda B1 B2' t1 t2 pA pB pt)

| conglambda_red_tm_l B1 B2 t1 t2 pA pB pt t1' :
    red1 t1 t1' ->
    red1 (sCongLambda B1 B2 t1 t2 pA pB pt)
             (sCongLambda B1 B2 t1' t2 pA pB pt)

| conglambda_red_tm_r B1 B2 t1 t2 pA pB pt t2' :
    red1 t2 t2' ->
    red1 (sCongLambda B1 B2 t1 t2 pA pB pt)
             (sCongLambda B1 B2 t1 t2' pA pB pt)

| conglambda_red_eq_dom B1 B2 t1 t2 pA pB pt pA' :
    red1 pA pA' ->
    red1 (sCongLambda B1 B2 t1 t2 pA pB pt)
             (sCongLambda B1 B2 t1 t2 pA' pB pt)

| conglambda_red_eq_codom B1 B2 t1 t2 pA pB pt pB' :
    red1 pB pB' ->
    red1 (sCongLambda B1 B2 t1 t2 pA pB pt)
             (sCongLambda B1 B2 t1 t2 pA pB' pt)

| conglambda_red_eq_tm B1 B2 t1 t2 pA pB pt pt' :
    red1 pt pt' ->
    red1 (sCongLambda B1 B2 t1 t2 pA pB pt)
             (sCongLambda B1 B2 t1 t2 pA pB pt')

(** CongApp *)
| congapp_red_ty_l B1 B2 pu pA pB pv B1' :
    red1 B1 B1' ->
    red1 (sCongApp B1 B2 pu pA pB pv)
             (sCongApp B1' B2 pu pA pB pv)

| congapp_red_ty_r B1 B2 pu pA pB pv B2' :
    red1 B2 B2' ->
    red1 (sCongApp B1 B2 pu pA pB pv)
             (sCongApp B1 B2' pu pA pB pv)

| congapp_red_eq_fun B1 B2 pu pA pB pv pu' :
    red1 pu pu' ->
    red1 (sCongApp B1 B2 pu pA pB pv)
             (sCongApp B1 B2 pu' pA pB pv)

| congapp_red_eq_dom B1 B2 pu pA pB pv pA' :
    red1 pA pA' ->
    red1 (sCongApp B1 B2 pu pA pB pv)
             (sCongApp B1 B2 pu pA' pB pv)

| congapp_red_eq_codom B1 B2 pu pA pB pv pB' :
    red1 pB pB' ->
    red1 (sCongApp B1 B2 pu pA pB pv)
             (sCongApp B1 B2 pu pA pB' pv)

| congapp_red_eq_arg B1 B2 pu pA pB pv pv' :
    red1 pv pv' ->
    red1 (sCongApp B1 B2 pu pA pB pv)
             (sCongApp B1 B2 pu pA pB pv')

(** CongSum *)
| congsum_red_ty_l B1 B1' B2 pA pB :
    red1 B1 B1' ->
    red1 (sCongSum B1 B2 pA pB) (sCongSum B1' B2 pA pB)

| congsum_red_ty_r B1 B2 B2' pA pB :
    red1 B2 B2' ->
    red1 (sCongSum B1 B2 pA pB) (sCongSum B1 B2' pA pB)

| congsum_red_tm_l B1 B2 pA pA' pB :
    red1 pA pA' ->
    red1 (sCongSum B1 B2 pA pB) (sCongSum B1 B2 pA' pB)

| congsum_red_tm_r B1 B2 pA pB pB' :
    red1 pB pB' ->
    red1 (sCongSum B1 B2 pA pB) (sCongSum B1 B2 pA pB')

(** CongPair *)
| congpair_red_ty_l B1 B1' B2 pA pB pu pv :
    red1 B1 B1' ->
    red1 (sCongPair B1 B2 pA pB pu pv) (sCongPair B1' B2 pA pB pu pv)

| congpair_red_ty_r B1 B2 B2' pA pB pu pv :
    red1 B2 B2' ->
    red1 (sCongPair B1 B2 pA pB pu pv) (sCongPair B1 B2' pA pB pu pv)

| congpair_red_tm_dom B1 B2 pA pA' pB pu pv :
    red1 pA pA' ->
    red1 (sCongPair B1 B2 pA pB pu pv) (sCongPair B1 B2 pA' pB pu pv)

| congpair_red_tm_cod B1 B2 pA pB pB' pu pv :
    red1 pB pB' ->
    red1 (sCongPair B1 B2 pA pB pu pv) (sCongPair B1 B2 pA pB' pu pv)

| congpair_red_tm_tm_l B1 B2 pA pB pu pv pu' :
    red1 pu pu' ->
    red1 (sCongPair B1 B2 pA pB pu pv) (sCongPair B1 B2 pA pB pu' pv)

| congpair_red_tm_tm_r B1 B2 pA pB pu pv pv' :
    red1 pv pv' ->
    red1 (sCongPair B1 B2 pA pB pu pv) (sCongPair B1 B2 pA pB pu pv')

(** CongPi1 *)
| congpi1_red_ty_l B1 B1' B2 pA pB pp :
    red1 B1 B1' ->
    red1 (sCongPi1 B1 B2 pA pB pp) (sCongPi1 B1' B2 pA pB pp)

| congpi1_red_ty_r B1 B2 B2' pA pB pp :
    red1 B2 B2' ->
    red1 (sCongPi1 B1 B2 pA pB pp) (sCongPi1 B1 B2' pA pB pp)

| congpi1_red_tm_dom B1 B2 pA pA' pB pp :
    red1 pA pA' ->
    red1 (sCongPi1 B1 B2 pA pB pp) (sCongPi1 B1 B2 pA' pB pp)

| congpi1_red_tm_cod B1 B2 pA pB pB' pp :
    red1 pB pB' ->
    red1 (sCongPi1 B1 B2 pA pB pp) (sCongPi1 B1 B2 pA pB' pp)

| congpi1_red_tm_tm B1 B2 pA pB pp pp' :
    red1 pp pp' ->
    red1 (sCongPi1 B1 B2 pA pB pp) (sCongPi1 B1 B2 pA pB pp')

(** CongPi2 *)
| congpi2_red_ty_l B1 B1' B2 pA pB pp :
    red1 B1 B1' ->
    red1 (sCongPi2 B1 B2 pA pB pp) (sCongPi2 B1' B2 pA pB pp)

| congpi2_red_ty_r B1 B2 B2' pA pB pp :
    red1 B2 B2' ->
    red1 (sCongPi2 B1 B2 pA pB pp) (sCongPi2 B1 B2' pA pB pp)

| congpi2_red_tm_dom B1 B2 pA pA' pB pp :
    red1 pA pA' ->
    red1 (sCongPi2 B1 B2 pA pB pp) (sCongPi2 B1 B2 pA' pB pp)

| congpi2_red_tm_cod B1 B2 pA pB pB' pp :
    red1 pB pB' ->
    red1 (sCongPi2 B1 B2 pA pB pp) (sCongPi2 B1 B2 pA pB' pp)

| congpi2_red_tm_tm B1 B2 pA pB pp pp' :
    red1 pp pp' ->
    red1 (sCongPi2 B1 B2 pA pB pp) (sCongPi2 B1 B2 pA pB pp')

(** CongEq *)
| congeq_red_eq_ty pA pu pv pA' :
    red1 pA pA' ->
    red1 (sCongEq pA pu pv) (sCongEq pA' pu pv)

| congeq_red_eq_tm_l pA pu pv pu' :
    red1 pu pu' ->
    red1 (sCongEq pA pu pv) (sCongEq pA pu' pv)

| congeq_red_eq_tm_r pA pu pv pv' :
    red1 pv pv' ->
    red1 (sCongEq pA pu pv) (sCongEq pA pu pv')

(* (** CongRefl *) *)
| congrefl_red_ty pA pu pA' :
    red1 pA pA' ->
    red1 (sCongRefl pA pu) (sCongRefl pA' pu)

| congrefl_red_tm pA pu pu' :
    red1 pu pu' ->
    red1 (sCongRefl pA pu) (sCongRefl pA pu')

(** EqToHeq *)
| eqtoheq_red p p' :
    red1 p p' ->
    red1 (sEqToHeq p) (sEqToHeq p')

(** HeqTypeEq *)
| heqtypeeq_red_ty_l A B p A' :
    red1 A A' ->
    red1 (sHeqTypeEq A B p) (sHeqTypeEq A' B p)

| heqtypeeq_red_ty_r A B p B' :
    red1 B B' ->
    red1 (sHeqTypeEq A B p) (sHeqTypeEq A B' p)

| heqtypeeq_red_prf A B p p' :
    red1 p p' ->
    red1 (sHeqTypeEq A B p) (sHeqTypeEq A B p')

(** Pack *)
| pack_red_l A1 A2 A1' :
    red1 A1 A1' ->
    red1 (sPack A1 A2) (sPack A1' A2)

| pack_red_r A1 A2 A2' :
    red1 A2 A2' ->
    red1 (sPack A1 A2) (sPack A1 A2')

(** ProjT1 *)
| projt1_red p p' :
    red1 p p' ->
    red1 (sProjT1 p) (sProjT1 p')

(** ProjT2 *)
| projt2_red p p' :
    red1 p p' ->
    red1 (sProjT2 p) (sProjT2 p')

(** ProjTe *)
| projte_red p p' :
    red1 p p' ->
    red1 (sProjTe p) (sProjTe p')
.

End Red1.

Derive Signature for red1.

Notation " t ▷ u " :=
  (red1 t u) (at level 50, u at next level).

Section Red.

Context `{Sort_notion : Sorts.notion}.

(* Reflexive and transitive closure of 1-step reduction. *)
Inductive red t : sterm -> Prop :=
| refl_red : red t t
| trans_red u v : red1 t u -> red u v -> red t v.

End Red.

Notation " t ▷⃰ u " :=
  (red t u) (at level 50, u at next level).

Section nlred.

  Context `{Sort_notion : Sorts.notion}.

  (* We have to use this definition to trick Equations into not doing anything
   about this equality.
   *)
  Definition nleq u v := nl u = nl v.

  Derive NoConfusion NoConfusionHom for sterm.

  Ltac nlred :=
    lazymatch goal with
    | h : ?t ▷ ?t', eq : nl ?t = _, ih : forall _ _, ?t ▷ _ -> _ |- _ =>
      destruct (ih _ _ h eq) as [? [? ?]] ;
      eexists ; split ; [
        econstructor ; eassumption
      | unfold nleq ; cbn ; f_equal ; assumption
      ]
    end.

  Lemma nl_red1 :
    forall {t t' u},
      t ▷ u ->
      nleq t t' ->
      exists u', (t' ▷ u') /\ (nleq u u').
  Proof.
    intros t t' u h.
    induction t in u, h, t' |- *.
    all: dependent destruction h.
    all: intros eq.
    all: destruct t' ; unfold nleq in eq ; simpl in eq ; try discriminate eq.
    all: inversion eq ; try nlred.
    - destruct t'1 ; simpl nl in H0 ; try discriminate H0.
      inversion H0.
      eexists. split.
      + eapply red_beta.
      + apply nl_subst ; easy.
    - destruct t'6 ; simpl nl in H5 ; try discriminate H5.
      inversion H5.
      eexists. split.
      + eapply red_JRefl.
      + assumption.
    - destruct t'3 ; simpl nl in H2 ; try discriminate H2.
      inversion H2.
      eexists. split.
      + eapply red_TransportRefl.
      + assumption.
    Unshelve. all: exact nAnon.
  Defined.

End nlred.

(*! Conversion *)

Section Conv.

Context `{Sort_notion : Sorts.notion}.

Declare Scope i_scope.

Reserved Notation " t ≡ u " (at level 50, u at next level).

Inductive conv : sterm -> sterm -> Prop :=
| conv_eq t u : nl t = nl u -> t ≡ u
| conv_red_l t u v : red1 t v -> v ≡ u -> t ≡ u
| conv_red_r t u v : t ≡ v -> red1 u v -> t ≡ u

where " t ≡ u " := (@conv t u) : i_scope.

End Conv.

Notation " t ≡ u " :=
  (@conv _ t u) (at level 50, u at next level) : i_scope.
Derive Signature for conv.

Open Scope i_scope.

Section Conversion.

Context `{Sort_notion : Sorts.notion}.

Lemma conv_refl :
  forall t, t ≡ t.
Proof.
  intros t.
  apply conv_eq. reflexivity.
Defined.

Lemma conv_sym :
  forall {t u},
    t ≡ u ->
    u ≡ t.
Proof.
  intros t u h.
  induction h.
  - apply conv_eq. symmetry. assumption.
  - eapply conv_red_r ; eassumption.
  - eapply conv_red_l ; eassumption.
Defined.

Lemma nl_conv :
  forall {t u t' u'},
    t ≡ u ->
    nl t = nl t' ->
    nl u = nl u' ->
    t' ≡ u'.
Proof.
  intros t u t' u' h. revert t' u'.
  induction h.
  - intros t' u' ht hu.
    apply conv_eq.
    transitivity (nl t).
    + symmetry. assumption.
    + transitivity (nl u) ; assumption.
  - intros t' u' ht hu.
    destruct (nl_red1 H ht) as [t'' [? ?]].
    eapply conv_red_l ; try eassumption.
    eapply IHh ; assumption.
  - intros t' u' ht hu.
    destruct (nl_red1 H hu) as [t'' [? ?]].
    eapply conv_red_r ; try eassumption.
    eapply IHh ; assumption.
Defined.

(* WARNING AXIOM
   The only axiom that we take is transitivity of conversion.
   This should rely on confluence of the reduction which we believe is
   orthogonal to the object of the paper / formalisation.

   Note: This doesn't block any computation. We made sure to put
   typing derivations in ITT in Prop, meaning they are necessarilly
   irrelevant to computation.
 *)
Axiom conv_trans_AXIOM :
  forall {t u v},
    t ≡ u ->
    u ≡ v ->
    t ≡ v.

(* We only use the axiom in the cases that we cannot prove directly. *)
Lemma conv_trans :
  forall {t u v},
    t ≡ u ->
    u ≡ v ->
    t ≡ v.
Proof.
  intros t u v h. revert v.
  induction h ; intros w h2.
  - symmetry in H.
    eapply nl_conv ; try eassumption.
    reflexivity.
  - specialize (IHh _ h2). eapply conv_red_l ; eassumption.
  - dependent induction h2.
    + eapply nl_conv ; [ .. | eassumption ].
      * eapply conv_red_r ; eassumption.
      * reflexivity.
    + eapply conv_trans_AXIOM.
      * eapply conv_red_r ; eassumption.
      * eapply conv_red_l ; eassumption.
    + eapply conv_trans_AXIOM.
      * eapply conv_red_r ; eassumption.
      * eapply conv_red_r ; eassumption.
Defined.

End Conversion.

(*! Congruences for conversion *)

Ltac conv_rewrite_l h :=
  let h' := fresh "h" in
  match type of h with
  | ?A ≡ ?B =>
    lazymatch goal with
    | |- ?lctx ≡ ?rctx =>
      lazymatch lctx with
      | context T [A] =>
        let T1 := context T[A] in
        let T2 := context T[B] in
        assert (h' : T1 ≡ T2) ; [
          clear - h ;
          induction h ; [
            apply conv_eq ; simpl nl ; f_equal ; assumption
          | eapply conv_red_l ; [
              econstructor ; eassumption
            | eassumption
            ]
          | eapply conv_red_r ; [
              eassumption
            | econstructor ; eassumption
            ]
          ]
        | apply (conv_trans h') ; clear h'
        ]
      | _ => fail "Equation doesn't contain " A
      end
    | _ => fail "conv rewrite cannot apply to this goal"
    end
  end.

Ltac conv_rewrite h :=
  (conv_rewrite_l h) + (apply conv_sym ; conv_rewrite_l h ; apply conv_sym).

Ltac conv_rewrite_sym h :=
  let h' := fresh "h" in
  pose proof (conv_sym h) as h' ;
  conv_rewrite h' ;
  clear h'.

(* Ltac conv_rewrites hl := *)
(*   match hl with *)
(*   (* | ?h ?l => conv_rewrite h ; conv_rewrites l *) *)
(*   | ?h => conv_rewrite h *)
(*   end. *)

Tactic Notation "conv" "rewrite" hyp(h) := conv_rewrite h.
(* Tactic Notation "conv" "rewrite" hyp_list(hl) := conv_rewrites hl. *)
(* Tactic Notation "conv" "rewrite" ne_hyp_list(hl) := conv_rewrites hl. *)
Tactic Notation "conv" "rewrite" hyp(h1) "," hyp(h2) :=
  conv rewrite h1 ; conv rewrite h2.
Tactic Notation "conv" "rewrite" hyp(h1) "," hyp(h2) "," hyp(h3) :=
  conv rewrite h1 ; conv rewrite h2, h3.
Tactic Notation "conv" "rewrite" hyp(h1) "," hyp(h2) "," hyp(h3) "," hyp(h4) :=
  conv rewrite h1 ; conv rewrite h2, h3, h4.
Tactic Notation "conv" "rewrite" hyp(h1) "," hyp(h2) "," hyp(h3) "," hyp(h4)
       "," hyp(h5) :=
  conv rewrite h1 ; conv rewrite h2, h3, h4, h5.
Tactic Notation "conv" "rewrite" hyp(h1) "," hyp(h2) "," hyp(h3) "," hyp(h4)
       "," hyp(h5) "," hyp(h6) :=
  conv rewrite h1 ; conv rewrite h2, h3, h4, h5, h6.
Tactic Notation "conv" "rewrite" hyp(h1) "," hyp(h2) "," hyp(h3) "," hyp(h4)
       "," hyp(h5) "," hyp(h6) "," hyp(h7) :=
  conv rewrite h1 ; conv rewrite h2, h3, h4, h5, h6, h7.

Tactic Notation "conv" "rewrite" "<-" hyp(h) := conv_rewrite_sym h.
Tactic Notation "conv" "rewrite" "<-" hyp(h1) "," hyp(h2) :=
  conv rewrite <- h1 ; conv rewrite <- h2.
Tactic Notation "conv" "rewrite" "<-" hyp(h1) "," hyp(h2) "," hyp(h3) :=
  conv rewrite <- h1 ; conv rewrite <- h2, h3.
Tactic Notation "conv" "rewrite" "<-" hyp(h1) "," hyp(h2) "," hyp(h3) "," hyp(h4) :=
  conv rewrite <- h1 ; conv rewrite <- h2, h3, h4.
Tactic Notation "conv" "rewrite" "<-" hyp(h1) "," hyp(h2) "," hyp(h3) "," hyp(h4)
       "," hyp(h5) :=
  conv rewrite <- h1 ; conv rewrite <- h2, h3, h4, h5.
Tactic Notation "conv" "rewrite" "<-" hyp(h1) "," hyp(h2) "," hyp(h3) "," hyp(h4)
       "," hyp(h5) "," hyp(h6) :=
  conv rewrite <- h1 ; conv rewrite <- h2, h3, h4, h5, h6.
Tactic Notation "conv" "rewrite" "<-" hyp(h1) "," hyp(h2) "," hyp(h3) "," hyp(h4)
       "," hyp(h5) "," hyp(h6) "," hyp(h7) :=
  conv rewrite <- h1 ; conv rewrite <- h2, h3, h4, h5, h6, h7.

Section Congruence.

Context `{Sort_notion : Sorts.notion}.

Lemma cong_Heq :
  forall {A a B b A' a' B' b'},
    A ≡ A' ->
    a ≡ a' ->
    B ≡ B' ->
    b ≡ b' ->
    sHeq A a B b ≡ sHeq A' a' B' b'.
Proof.
  intros A a B b A' a' B' b' hA ha hB hb.
  conv rewrite hA, ha, hB, hb.
  apply conv_refl.
Defined.

Lemma cong_Eq :
  forall {A u v A' u' v'},
    A ≡ A' ->
    u ≡ u' ->
    v ≡ v' ->
    sEq A u v ≡ sEq A' u' v'.
Proof.
  intros A u v A' u' v' hA hu hv.
  conv rewrite hA, hu, hv.
  apply conv_refl.
Defined.

Lemma cong_Transport :
  forall {A B p t A' B' p' t'},
    A ≡ A' ->
    B ≡ B' ->
    p ≡ p' ->
    t ≡ t' ->
    sTransport A B p t ≡ sTransport A' B' p' t'.
Proof.
  intros A B p t A' B' p' t' hA hB hp ht.
  conv rewrite hA, hB, hp, ht.
  apply conv_refl.
Defined.

Lemma cong_Prod :
  forall {nx A B nx' A' B'},
    A ≡ A' ->
    B ≡ B' ->
    sProd nx A B ≡ sProd nx' A' B'.
Proof.
  intros nx A B nx' A' B' hA hB.
  conv rewrite hB, hA.
  apply conv_eq. cbn. reflexivity.
Defined.

Lemma cong_Lambda :
  forall {nx A B t nx' A' B' t'},
    A ≡ A' ->
    B ≡ B' ->
    t ≡ t' ->
    sLambda nx A B t ≡ sLambda nx' A' B' t'.
Proof.
  intros nx A B t nx' A' B' t' hA hB ht.
  conv rewrite hB, ht, hA.
  apply conv_eq. cbn. reflexivity.
Defined.

Lemma cong_App :
  forall {u A B v u' A' B' v'},
    A ≡ A' ->
    B ≡ B' ->
    u ≡ u' ->
    v ≡ v' ->
    sApp u A B v ≡ sApp u' A' B' v'.
Proof.
  intros u A B v u' A' B' v' hA hB hu hv.
  conv rewrite hB, hu, hv, hA.
  apply conv_eq. cbn. reflexivity.
Defined.

Lemma cong_Sum :
  forall {nx A B nx' A' B'},
    A ≡ A' ->
    B ≡ B' ->
    sSum nx A B ≡ sSum nx' A' B'.
Proof.
  intros nx A B nx' A' B' hA hB.
  conv rewrite hB, hA.
  apply conv_eq. cbn. reflexivity.
Defined.

Lemma cong_Pair :
  forall {A B u v A' B' u' v'},
    A ≡ A' ->
    B ≡ B' ->
    u ≡ u' ->
    v ≡ v' ->
    sPair A B u v ≡ sPair A' B' u' v'.
Proof.
  intros A B u v A' B' u' v' hA hB hu hv.
  conv rewrite hv, hu, hB, hA.
  apply conv_refl.
Defined.

Lemma cong_Pi1 :
  forall {A B p A' B' p'},
    A ≡ A' ->
    B ≡ B' ->
    p ≡ p' ->
    sPi1 A B p ≡ sPi1 A' B' p'.
Proof.
  intros A B p A' B' p' hA hB hp.
  conv rewrite hp, hB, hA.
  apply conv_refl.
Defined.

Lemma cong_Pi2 :
  forall {A B p A' B' p'},
    A ≡ A' ->
    B ≡ B' ->
    p ≡ p' ->
    sPi2 A B p ≡ sPi2 A' B' p'.
Proof.
  intros A B p A' B' p' hA hB hp.
  conv rewrite hp, hB, hA.
  apply conv_refl.
Defined.

Lemma cong_Refl :
  forall {A u A' u'},
    A ≡ A' ->
    u ≡ u' ->
    sRefl A u ≡ sRefl A' u'.
Proof.
  intros A u A' u' hA hu.
  conv rewrite hA, hu. apply conv_refl.
Defined.

Lemma cong_Pack :
  forall {A1 A2 A1' A2'},
    A1 ≡ A1' ->
    A2 ≡ A2' ->
    sPack A1 A2 ≡ sPack A1' A2'.
Proof.
  intros A1 A2 A1' A2' h1 h2.
  conv rewrite h2, h1.
  apply conv_refl.
Defined.

(** Congruence with lift *)

Lemma meta_red_eq :
  forall {t u u'},
    t ▷ u ->
    u = u' ->
    t ▷ u'.
Proof.
  intros t u u' h e. destruct e. assumption.
Defined.

Fixpoint lift_red1 {n k t1 t2} (h : t1 ▷ t2) :
  lift n k t1 ▷ lift n k t2.
Proof.
  destruct h ; cbn ;
    try match goal with
        | h : ?t ▷ _ |- ?tt ▷ _ =>
          match tt with
          | context [t] =>
            econstructor ;
              eapply lift_red1 ; [ exact h | .. ]
          end
        end.
  - eapply meta_red_eq ; [ econstructor |].
    rewrite <- substP1. cbn. reflexivity.
  - eapply meta_red_eq ; [ econstructor |]. reflexivity.
  - eapply meta_red_eq ; [ econstructor |]. reflexivity.
Defined.

Lemma lift_conv :
  forall {n k t1 t2},
    t1 ≡ t2 ->
    lift n k t1 ≡ lift n k t2.
Proof.
  intros n k t1 t2 h.
  induction h.
  - apply conv_eq. apply nl_lift. assumption.
  - eapply conv_red_l.
    + eapply lift_red1. eassumption.
    + assumption.
  - eapply conv_red_r.
    + eassumption.
    + eapply lift_red1. eassumption.
Defined.

Corollary cong_lift01 :
  forall {t1 t2},
    t1 ≡ t2 ->
    lift0 1 t1 ≡ lift0 1 t2.
Proof.
  intros t1 t2 h.
  apply lift_conv. assumption.
Defined.

(** Congruence with substitution *)

Fixpoint subst_red1 {n t1 t2 u}
  (h : t1 ▷ t2) :
  t1{ n := u } ▷ t2{ n := u }.
Proof.
  destruct h ; cbn ;
    try match goal with
        | h : ?t ▷ _ |- ?tt ▷ _ =>
          match tt with
          | context [t] =>
            econstructor ;
              eapply subst_red1 ; [ exact h | .. ]
          end
        end.
  - eapply meta_red_eq ; [ econstructor |].
    rewrite <- substP4. cbn. reflexivity.
  - eapply meta_red_eq ; [ econstructor |]. reflexivity.
  - eapply meta_red_eq ; [ econstructor |]. reflexivity.
Defined.

Lemma subst_conv :
  forall {n u t1 t2},
    t1 ≡ t2 ->
    t1{ n := u } ≡ t2{ n := u }.
Proof.
  intros n u t1 t2 h.
  induction h.
  - apply conv_eq. apply nl_subst ; [ assumption | reflexivity ].
  - eapply conv_red_l.
    + eapply subst_red1. eassumption.
    + assumption.
  - eapply conv_red_r.
    + eassumption.
    + eapply subst_red1. eassumption.
Defined.

(** Congruence of equal substitutions *)

Lemma red_trans :
  forall {t u v},
    t ▷⃰ u ->
    u ▷⃰ v ->
    t ▷⃰ v.
Proof.
  intros t u v h1 h2. revert v h2.
  induction h1.
  - intros v h2. assumption.
  - intros w h2. specialize (IHh1 w h2).
    econstructor ; eassumption.
Defined.

End Congruence.

Ltac red_rewrite h :=
  let h' := fresh "h" in
  match type of h with
  | ?A ▷⃰ ?B =>
    lazymatch goal with
    | |- ?ctx ▷⃰ _ =>
      lazymatch ctx with
      | context T [A] =>
        let T1 := context T[A] in
        let T2 := context T[B] in
        assert (h' : T1 ▷⃰ T2) ; [
          clear - h ;
          induction h ; [
            constructor
          | econstructor ; [
              econstructor ; eassumption
            | eassumption
            ]
          ]
        | eapply (red_trans h') ; clear h'
        ]
      | _ => fail "Lhs doesn't contain " A
      end
    | _ => fail "red rewrite cannot apply to this goal"
    end
  end.

Tactic Notation "red" "rewrite" hyp(h) := red_rewrite h.
Tactic Notation "red" "rewrite" hyp(h1) "," hyp(h2) :=
  red rewrite h1 ; red rewrite h2.
Tactic Notation "red" "rewrite" hyp(h1) "," hyp(h2) "," hyp(h3) :=
  red rewrite h1 ; red rewrite h2, h3.
Tactic Notation "red" "rewrite" hyp(h1) "," hyp(h2) "," hyp(h3) "," hyp(h4) :=
  red rewrite h1 ; red rewrite h2, h3, h4.
Tactic Notation "red" "rewrite" hyp(h1) "," hyp(h2) "," hyp(h3) "," hyp(h4)
       "," hyp(h5) :=
  red rewrite h1 ; red rewrite h2, h3, h4, h5.
Tactic Notation "red" "rewrite" hyp(h1) "," hyp(h2) "," hyp(h3) "," hyp(h4)
       "," hyp(h5) "," hyp(h6) :=
  red rewrite h1 ; red rewrite h2, h3, h4, h5, h6.
Tactic Notation "red" "rewrite" hyp(h1) "," hyp(h2) "," hyp(h3) "," hyp(h4)
       "," hyp(h5) "," hyp(h6) "," hyp(h7) :=
  red rewrite h1 ; red rewrite h2, h3, h4, h5, h6, h7.

Section conv_substs.

  Context `{Sort_notion : Sorts.notion}.

  Ltac sp h n :=
    lazymatch goal with
    | hu : _ ▷ _ |- _ =>
      specialize (h n _ _ hu) ;
      cbn in h
    end.

  Ltac spone :=
    match goal with
    | ih : forall n u1 u2, _ -> ?t{n := u1} ≡ _ |- context [ ?t{ ?m := _ } ] =>
      sp ih m
    end.

  Ltac spall :=
    repeat spone.

  Ltac conv_rewrite_assumption :=
    match goal with
    | ih : _ ≡ _ |- _ => conv rewrite ih
    end.

  Ltac conv_rewrite_assumptions :=
    repeat conv_rewrite_assumption.

  Reserved Notation " t == u " (at level 50, u at next level).

  Inductive convbrs :
    list (nat * sterm) -> list (nat * sterm) -> Prop :=
  | convbrs_nil : [] == []
  | convbrs_cons n u v b c :
      u ≡ v ->
      b == c ->
      ((n,u) :: b) == ((n,v) :: c)

  where " t == u " := (@convbrs t u) : i_scope.

  Fact convbrs_length :
    forall {b1 b2},
      b1 == b2 ->
      #|b1| = #|b2|.
  Proof.
    intros b1 b2 h. induction h ; cbn ; easy.
  Defined.

  Lemma convbrs_nth :
    forall {b1 b2 n h1 h2},
      b1 == b2 ->
      let u := safe_nth b1 (exist _ n h1) in
      let v := safe_nth b2 (exist _ n h2) in
      (fst u = fst v) * (snd u ≡ snd v).
  Proof.
    intros b1 b2 n h1 h2 h.
    simpl in h1, h2.
    induction b1 in b2, n, h1, h2, h |- *.
    - cbn in *. lia.
    - destruct b2. 1: cbn in * ; lia.
      destruct n.
      + cbn in *. split.
        * inversion h. reflexivity.
        * inversion h. assumption.
      + cbn in *.
        lazymatch goal with
        | |- context [ safe_nth b1 (exist _ _ ?h) ] =>
          set (h1' := h)
        end.
        lazymatch goal with
        | |- context [ safe_nth b2 (exist _ _ ?h) ] =>
          set (h2' := h)
        end.
        specialize (IHb1 b2 n h1' h2').
        forward IHb1.
        { inversion h. assumption. }
        intuition auto.
  Defined.

  Lemma substs_red1 (t : sterm) :
    forall n {u1 u2},
      u1 ▷ u2 ->
      t{ n := u1 } ≡ t{ n := u2 }.
  Proof.
    induction t ; intros m u1 u2 h.
    all: cbn ; spall ; conv_rewrite_assumptions.
    all: try (apply conv_refl).
    case_eq (m ?= n) ; intro e ; bprop e.
    + eapply lift_conv.
      eapply conv_red_l ; try eassumption. apply conv_refl.
    + apply conv_refl.
    + apply conv_refl.
  Defined.

End conv_substs.

Section Substitution.

Context `{Sort_notion : Sorts.notion}.

Lemma substs_conv :
  forall {n u1 u2 t},
    u1 ≡ u2 ->
    t{ n := u1 } ≡ t{ n := u2 }.
Proof.
  intros n u1 u2 t h.
  induction h.
  - apply conv_eq. apply nl_subst ; [ reflexivity | assumption ].
  - eapply conv_trans ; try eassumption.
    eapply substs_red1. assumption.
  - eapply conv_trans ; try eassumption.
    eapply conv_sym.
    eapply substs_red1. assumption.
Defined.

Corollary cong_subst :
  forall {n u1 u2 t1 t2},
    u1 ≡ u2 ->
    t1 ≡ t2 ->
    t1{ n := u1 } ≡ t2{ n := u2 }.
Proof.
  intros n u1 u2 t1 t2 hu ht.
  eapply conv_trans.
  - eapply substs_conv. eassumption.
  - eapply subst_conv. assumption.
Defined.

End Substitution.

(*! Inversion results about conversion *)

Lemma sort_conv_inv `{Sort_notion : Sorts.notion} :
  forall {s1 s2},
    sSort s1 ≡ sSort s2 ->
    s1 = s2.
Proof.
  intros s1 s2 h. dependent induction h.
  - cbn in H. now inversion H.
  - inversion H.
  - inversion H.
Defined.

Ltac inversion_eq :=
  match goal with
  | H : _ = _ |- _ => inversion H
  end.

Ltac split_hyp ::=
  lazymatch goal with
  | h : _ /\ _ |- _ => destruct h
  | h : _ * _ |- _ => destruct h
  end.

Ltac invconv h :=
  dependent induction h ; [
    cbn in * ; inversion_eq ;
    repeat split ; apply conv_eq ; assumption
  | dependent destruction H ;
    split_hyps ; repeat split ; try assumption ;
    eapply conv_red_l ; eassumption
  | dependent destruction H ;
    split_hyps ; repeat split ; try assumption ;
    eapply conv_red_r ; eassumption
  ].

Section Inversions.

Context `{Sort_notion : Sorts.notion}.

Lemma heq_conv_inv :
  forall {A a B b A' a' B' b'},
    sHeq A a B b ≡ sHeq A' a' B' b' ->
    (A ≡ A') /\
    (a ≡ a') /\
    (B ≡ B') /\
    (b ≡ b').
Proof.
  intros A a B b A' a' B' b' h.
  invconv h.
Defined.

Lemma eq_conv_inv :
  forall {A u v A' u' v'},
    sEq A u v ≡ sEq A' u' v' ->
    (A ≡ A') /\
    (u ≡ u') /\
    (v ≡ v').
Proof.
  intros A u v A' u' v' h.
  invconv h.
Defined.

Lemma pack_conv_inv :
  forall {A1 A2 A1' A2'},
    sPack A1 A2 ≡ sPack A1' A2' ->
    (A1 ≡ A1') /\ (A2 ≡ A2').
Proof.
  intros A1 A2 A1' A2' h.
  invconv h.
Defined.

Lemma prod_inv :
  forall {nx ny A B A' B'},
    sProd nx A B ≡ sProd ny A' B' ->
    (A ≡ A') /\ (B ≡ B').
Proof.
  intros nx ny A B A' B' h.
  invconv h.
Defined.

End Inversions.


(* $Id$ *)

Section puzzle.

Parameters Scottish RedSocks WearKilt Married GoOutSunday : Prop.

Hypothesis rule1 : ~ Scottish -> RedSocks.
Hypothesis rule2 : WearKilt \/ ~ RedSocks.
Hypothesis rule3 : Married -> ~ GoOutSunday.
Hypothesis rule4 : GoOutSunday <-> Scottish.
Hypothesis rule5 : WearKilt -> Scottish /\ Married.
Hypothesis rule6 : Scottish -> WearKilt.

Lemma NoMember : False.
Proof.
  apply rule3.
  apply rule5.
  elim rule2.
  intro.
  assumption.
  intro.
  elim H.
  apply rule1.
  intro.
  apply rule3.
  apply rule5.
  apply rule6.
  assumption.
  elim rule4.
  intros.
  apply H2.
  assumption.
  elim rule4.
  intros.
  apply H0.
  apply rule5.
  elim rule2.
  intros.
  assumption.
  intro.
  elim H1.
  apply rule1.
  intro.
  apply rule3.
  apply rule5.
  apply rule6.
  assumption.
  elim rule4.
  intros.
  apply H4.
  assumption.
Qed.

End puzzle.


Add LoadPath "somePath".

Require Export sound_and_complete.
Require Import Omega.

Fixpoint b_propForm_solution(f:propForm)(theta:environment):bool:=
match f with
| top => true
| bot => false
| var x => theta x
| f1 /\p f2 => b_propForm_solution f1 theta && b_propForm_solution f2 theta
| f1 \/p f2 => b_propForm_solution f1 theta || b_propForm_solution f2 theta
end.

Notation "[[ f ]]_b theta" := (b_propForm_solution f theta) (at level 50).

Fixpoint unfold_block (bl:list booleanEquation)(theta:environment):environment:=
match bl with
| nil => theta
| bEqn x fx::bl' => redefineEnvironment (unfold_block bl' theta) x ([[fx]]_b theta)
end.

Definition redefine_bound (bl:list booleanEquation)(result_unbound result_bound:environment):environment:=
fun (x:propVar) => if bnd_block_dec bl x then result_bound x else result_unbound x.

Definition w_d_block(bl:list booleanEquation) := forall x:propVar, bnd_block bl x <->bnd_cnt_block bl x=1.

Fixpoint sol_iterator (H:environment -> environment)(theta_b:environment)(i:nat) :=
match i with
| 0 => H theta_b
| S(k) => H (sol_iterator H theta_b k)
end.

Fixpoint genBES_solution (e:list block)(theta:environment){struct e} : environment :=
let F (e'':list block)(B'':block)(theta'' theta_b'':environment) : environment :=
  unfold_block B'' (genBES_solution e'' (redefine_bound B'' theta'' theta_b''))
in
match e with
| nil => theta
| cons bl e' => if (blockType bl)
                then genBES_solution e' (redefine_bound bl theta (sol_iterator (F e' bl theta) full_environment (length bl)))
                else genBES_solution e' (redefine_bound bl theta (sol_iterator (F e' bl theta) empty_environment (length bl)))
end.

Definition BES_solution (E:BES)(Theta:environment) : environment :=
  genBES_solution (the_genBES (bes E)) Theta.

Lemma neq_no_rewrite : forall theta:environment, forall x y:propVar, x<>y ->
  forall b:bool, theta x <-> (redefineEnvironment theta y b) x.
Proof.
unfold redefineEnvironment.
split;intro.
assert (beq_nat y x=false).
  apply beq_nat_false_iff;auto.
rewrite H1;auto.
assert (beq_nat y x=false).
  apply beq_nat_false_iff;auto.
rewrite H1 in H0;auto.
Qed.

Lemma unbound_no_change_block_function : forall bl:list booleanEquation, forall x:propVar,
  ~bnd_block bl x -> forall theta:environment, theta x <-> unfold_block bl theta x.
Proof.
induction bl;simpl in *;auto.
split;intro;auto.

destruct a as [y fy].
split;intro.
assert (~bnd_block bl x).
  intro;apply H;auto.
apply neq_no_rewrite.
intro.
apply H;auto.
apply-> IHbl;auto.
apply neq_no_rewrite in H0.
apply IHbl;auto.
intro;apply H;auto.
Qed.

Lemma rank_bound_split: forall E:BES, forall R:propVar_relation, consistent_consequence E R ->
  forall x y:propVar, R x y -> ((bnd E x /\ bnd E y) \/ (~bnd E x /\ ~bnd E y)).
Proof.
intros.
destruct (H x y);auto.
destruct (eq_rank _ _ _ H1);auto.
destruct (bnd_dec E x);auto.
destruct (bnd_dec E y);auto.
Qed.

Lemma b_propForm_solution_correct : forall f:propForm, forall theta:environment,
  (propForm_solution f theta) <-> [[f]]_b theta.
Proof.
induction f;split;intro;simpl in *;auto.
inversion H.
apply orb_true_iff.
destruct H.
left;apply IHf1;auto.
right;apply IHf2;auto.
apply orb_true_iff in H.
destruct H.
left;apply IHf1;auto.
right;apply IHf2;auto.
apply andb_true_iff.
destruct H.
split.
apply IHf1;auto.
apply IHf2;auto.
apply andb_true_iff in H.
destruct H.
split.
apply IHf1;auto.
apply IHf2;auto.
Qed.

Lemma alt_tl : forall l:list block, forall h:block,
  alternating_list_block (h::l) -> alternating_list_block l.
Proof.
induction l;simpl in *;auto.
intros.
destruct H.
destruct l;simpl in *;auto.
Qed.

Lemma bnd_cnt_block_gt : forall bl:list booleanEquation, forall x :propVar, bnd_block bl x <-> bnd_cnt_block bl x > 0.
Proof.
induction bl.
split;intro.
inversion H.
simpl in H.
inversion H.

destruct a as [z fz].
simpl in *.
split;intro.
destruct H.
rewrite H.
rewrite<- beq_nat_refl.
omega.
destruct (IHbl x).
specialize (H0 H).
destruct (beq_nat x z);omega.

destruct (eq_nat_decide x z).
rewrite (eq_nat_eq _ _ e);auto.
right.
apply IHbl.
assert (beq_nat x z=false).
  apply beq_nat_false_iff.
  intro.
  apply n;apply eq_nat_is_eq;auto.
rewrite H0 in H.
assumption.
Qed.

Lemma bnd_cnt_gt : forall bl:list block, forall x :propVar, bnd bl x <-> bnd_cnt bl x > 0.
Proof.
induction bl.
split;intro.
inversion H.
simpl in H.
inversion H.

destruct a as [b].
simpl in *.
split;intro.
destruct H.
assert (bnd_cnt_block b x>0).
  apply bnd_cnt_block_gt;auto.
omega.
destruct (IHbl x).
specialize (H0 H);omega.
destruct (gt_dec (bnd_cnt bl x) 0).
right;apply IHbl;auto.
assert (bnd_cnt_block b x>0).
  omega.
left;apply bnd_cnt_block_gt;auto.
Qed.

Lemma w_d_w_d_block : forall bl:list booleanEquation,
  forall b:bool, forall exists_bl:exists beqn:booleanEquation, In beqn bl,
    (w_d ((makeBlock bl b exists_bl)::nil)) <-> w_d_block bl.
Proof.
destruct bl.
split;intros;destruct exists_bl;inversion i.

split;intros.
intro.
destruct b as [z fz].
destruct (H x).
simpl in *.
destruct (eq_nat_decide x z).
rewrite (eq_nat_eq _ _ e) in *.
rewrite<- beq_nat_refl in *.
assert (~bnd_block bl z).
  intro.
  assert (S (bnd_cnt_block bl z) > 1).
    apply gt_n_S.
    apply bnd_cnt_block_gt;auto.
  assert (S (bnd_cnt_block bl z) + 0 = 1).
    apply H0;auto.
  omega.
split;intro;auto.
assert (S (bnd_cnt_block bl z) + 0 = 1);auto.
omega.
assert (beq_nat x z=false).
  apply beq_nat_false_iff.
  intro.
  apply n;apply eq_nat_is_eq;auto.
split;intro.
destruct H3.
exfalso.
apply n;apply eq_nat_is_eq;auto.
rewrite H2 in *.
assert (bnd_cnt_block bl x + 0 = 1);auto.
omega.
rewrite H2 in *.
right.
apply bnd_cnt_block_gt;omega.

destruct b as [z fz].
intro;intros.
destruct (H x).
simpl in *.
destruct (eq_nat_decide x z).
rewrite (eq_nat_eq _ _ e) in *;auto.
rewrite<- beq_nat_refl in *.
split;intro;auto.
destruct H2;try contradiction.
assert (S (bnd_cnt_block bl z)=1);auto.
omega.
assert (beq_nat x z=false).
  apply beq_nat_false_iff;intro.
  apply n;apply eq_nat_is_eq;auto.
rewrite H2 in *.
split;intro.
destruct H3;try contradiction.
assert (bnd_cnt_block bl x=1);auto.
omega.
left.
apply H1.
omega.
Qed.

Lemma w_d_block_tl : forall bl:list booleanEquation, forall heqn:booleanEquation,
  w_d_block (heqn::bl) -> w_d_block bl.
Proof.
destruct heqn as [z fz].
intros;intro.
destruct (H x).
simpl in *.
split;intro.
assert (beq_nat x z=false).
  apply beq_nat_false_iff.
  intro.
  rewrite H3 in *.
  rewrite<- beq_nat_refl in *.
  assert (S(bnd_cnt_block bl z)=1);auto.
  assert (S(bnd_cnt_block bl z)>1).
    apply gt_n_S.
    apply bnd_cnt_block_gt;auto.
  omega.
rewrite H3 in *;auto.
assert (beq_nat x z=false).
  apply beq_nat_false_iff.
  intro.
  rewrite H3 in *.
  rewrite<- beq_nat_refl in *.
  assert (S(bnd_cnt_block bl z)=1);auto.
  assert (S(bnd_cnt_block bl z)>1).
    apply gt_n_S.
    rewrite H2;auto.
  omega.
rewrite H3 in *.
destruct (H1 H2);auto.
exfalso.
apply beq_nat_false_iff in H3;auto.
Qed.

Lemma rhs_unfold_block : forall bl:block,
  forall alt_bl: alternating_list_block (bl::nil),
    forall w_d_bl: w_d (make_genBES (bl::nil) alt_bl),
      forall x:propVar, bnd_block bl x ->
        forall theta:environment,
          (unfold_block bl theta) x
        <->
          propForm_solution (rhs (makeBES (make_genBES (bl::nil) alt_bl) w_d_bl) x) theta.
Proof.
destruct bl as [bl type_bl exists_bl].
induction bl;simpl in *;auto.
intros;contradiction.

destruct a as [z fz].
intros.
simpl in *.
destruct (bnd_block_dec (bEqn z fz :: bl) x);try contradiction.
destruct (eq_nat_decide x z).
rewrite (eq_nat_eq _ _ e) in *;auto.
unfold redefineEnvironment.
rewrite<- beq_nat_refl.
split;intro;apply b_propForm_solution_correct;auto.
unfold redefineEnvironment.
assert (beq_nat z x=false).
  apply beq_nat_false_iff.
  intro.
  apply n;apply eq_nat_is_eq;auto.
repeat rewrite H0.
destruct H.
exfalso.
apply n;apply eq_nat_is_eq;auto.
assert (exists beqn : booleanEquation, In beqn bl).
  clear - b n.
  destruct bl;simpl in *.
  exfalso.
  destruct b;auto.
  apply n;apply eq_nat_is_eq;auto.
  exists b0;auto.
assert (type_bl=type_bl /\ True);auto.
assert (w_d ((makeBlock bl type_bl H1)::nil)).
  apply w_d_w_d_block.
  apply (w_d_block_tl bl (bEqn z fz)).
  apply (w_d_w_d_block (bEqn z fz::bl) type_bl exists_bl);auto.
assert (is_true true);auto.
destruct (IHbl H1 H4 H3 x H theta).
destruct (bnd_block_dec bl x);try contradiction.
split;intro;auto.
Qed.

Lemma useful_unfold_block : forall bl:block,
  forall alt_bl: alternating_list_block (bl::nil),
    forall w_d_bl: w_d (make_genBES (bl::nil) alt_bl),
      forall R:propVar_relation,
        consistent_consequence (makeBES (make_genBES (bl::nil) alt_bl) w_d_bl) R ->
forall theta:environment, consistent_environment theta R ->
  consistent_environment (unfold_block bl theta) R.
Proof.
destruct bl as [bl type_bl exists_bl].
induction bl;simpl;auto.

destruct a as [z fz].
intros.
intro;intros.
destruct (H x y);auto.
destruct (rank_bound_split _ _ H _ _ H1).
clear H4.
simpl in H5.
destruct H5.
destruct H4;try contradiction.
destruct H5;try contradiction.

destruct (rhs_unfold_block (makeBlock (bEqn z fz::bl) type_bl exists_bl) alt_bl w_d_bl y H5 theta);simpl in *.
apply H7.
destruct (bnd_block_dec (bEqn z fz :: bl) y);try contradiction.
destruct (H x y);auto.
simpl in H9.
assert ((x = z \/ bnd_block bl x) \/ False);auto.
assert ((y = z \/ bnd_block bl y) \/ False);auto.
specialize (H9 H10 H11 theta H0).
clear H10 H11.
simpl in H9.
destruct (bnd_block_dec (bEqn z fz :: bl) x);try contradiction.
destruct (bnd_block_dec (bEqn z fz :: bl) y);try contradiction.
apply H9.
clear H6 H7 H8 H9 b b0 b1.
destruct (rhs_unfold_block (makeBlock (bEqn z fz::bl) type_bl exists_bl) alt_bl w_d_bl x H4 theta);simpl in *.
specialize (H6 H2).
destruct (bnd_block_dec (bEqn z fz :: bl) x);try contradiction;auto.

destruct H5.
simpl in *.
unfold redefineEnvironment in *.
assert (beq_nat z x=false).
  apply beq_nat_false_iff;intro.
  apply H5;simpl;auto.
assert (beq_nat z y=false).
  apply beq_nat_false_iff;intro.
  apply H6;simpl;auto.
rewrite H8.
rewrite H7 in H2.
assert (~bnd_block bl x).
  intro;apply H5;simpl;auto.
assert (~bnd_block bl y).
  intro;apply H6;simpl;auto.
apply (unbound_no_change_block_function _ _ H10 theta).
apply (unbound_no_change_block_function _ _ H9) in H2.
apply (H0 x);auto.
Qed.

Lemma useful_sol_iterator : forall f:environment -> environment, forall R:propVar_relation,
(forall theta:environment, consistent_environment theta R -> (consistent_environment (f theta) R)) ->
  forall n:nat, forall theta:environment, consistent_environment theta R ->
    consistent_environment (sol_iterator f theta n) R.
Proof.
induction n;simpl in *;auto.
Qed.

Lemma w_d_tl : forall bl:list block, forall bh:block,
  w_d (bh::bl) -> w_d bl.
Proof.
intros;intro.
destruct bh as [bh type_bh exists_bh].
destruct (H x).
simpl in *.
split;intro.
assert (bnd_cnt_block bh x+bnd_cnt bl x=1);auto.
assert (bnd_cnt bl x>0).
  apply bnd_cnt_gt;auto.
  omega.
apply bnd_cnt_gt.
omega.
Qed.

Lemma w_d_hd : forall bl:list block, forall bh:block,
  w_d (bh::bl) -> w_d_block bh.
Proof.
intros;intro.
destruct bh as [bh type_bh exists_bh].
destruct (H x).
simpl in *.
split;intro.
assert (bnd_cnt_block bh x+bnd_cnt bl x=1);auto.
assert (bnd_cnt_block bh x>0).
  apply bnd_cnt_block_gt;auto.
  omega.
apply bnd_cnt_block_gt.
omega.
Qed.

Lemma rank_tl : forall bl:block, forall e:list block, forall w_d_bl_e:w_d (bl::e),
  forall x y:propVar, rank (bl::e) x=rank (bl::e) y -> rank e x = rank e y.
Proof.
destruct bl as [bl type_bl exists_bl].
induction bl;simpl in *.
destruct exists_bl;contradiction.

simpl in *.
intros.
unfold rank in H.
destruct a as [z fz].
simpl in *.
destruct (bnd_block_dec (bEqn z fz :: bl) y).
destruct (bnd_block_dec (bEqn z fz :: bl) x).
clear H.
simpl in *.
assert (~bnd e x).
  clear IHbl.
  intro.
  destruct (w_d_bl_e x).
  simpl in *.
  assert ((x = z \/ bnd_block bl x) \/ bnd e x);auto.
  specialize (H0 H2).
  assert (bnd_cnt e x>0).
    apply bnd_cnt_gt;auto.
  assert (bnd_cnt_block (bEqn z fz::bl) x>0).
    apply bnd_cnt_block_gt;auto.
  simpl in H4.
  destruct (beq_nat x z);omega.
assert (~bnd e y).
  clear IHbl H.
  intro.
  destruct (w_d_bl_e y).
  simpl in *.
  assert ((y = z \/ bnd_block bl y) \/ bnd e y);auto.
  specialize (H0 H2).
  assert (bnd_cnt e y>0).
    apply bnd_cnt_gt;auto.
  assert (bnd_cnt_block (bEqn z fz::bl) y>0).
    apply bnd_cnt_block_gt;auto.
  simpl in H4.
  destruct (beq_nat y z);omega.
clear - H H0.
induction e;simpl in *.
unfold rank.
destruct (bnd_dec nil x);try contradiction.
destruct (bnd_dec nil y);try contradiction;auto.

destruct a as [bl type_bl exists_bl].
simpl in *.
unfold rank.
destruct (bnd_dec
      ({| theBlock := bl; blockType := type_bl; non_empty := exists_bl |}
       :: e) x);try contradiction.
destruct (bnd_dec
      ({| theBlock := bl; blockType := type_bl; non_empty := exists_bl |}
       :: e) y);try contradiction;auto.
destruct (bnd_dec
          ({|
           theBlock := bEqn z fz :: bl;
           blockType := type_bl;
           non_empty := exists_bl |} :: e) x).
destruct (bnd_dec
          ({|
           theBlock := bEqn z fz :: bl;
           blockType := type_bl;
           non_empty := exists_bl |} :: e) y).
destruct type_bl;exfalso;clear - H;omega.
simpl in *.
exfalso.
apply n0.
left;auto.
destruct (bnd_dec
          ({|
           theBlock := bEqn z fz :: bl;
           blockType := type_bl;
           non_empty := exists_bl |} :: e) y).
destruct type_bl;exfalso;clear - H;omega.
simpl in *.
exfalso.
apply n1.
left;auto.
destruct (bnd_block_dec (bEqn z fz :: bl) x).
destruct (bnd_dec
          ({|
           theBlock := bEqn z fz :: bl;
           blockType := type_bl;
           non_empty := exists_bl |} :: e) x).
destruct (bnd_dec
          ({|
           theBlock := bEqn z fz :: bl;
           blockType := type_bl;
           non_empty := exists_bl |} :: e) y).
destruct type_bl;exfalso;clear - H;omega.
destruct type_bl;exfalso;clear - H;omega.
destruct (bnd_dec
          ({|
           theBlock := bEqn z fz :: bl;
           blockType := type_bl;
           non_empty := exists_bl |} :: e) y).
destruct type_bl;exfalso;clear - H;omega.
simpl in *.
exfalso.
apply n0.
left;auto.
destruct (bnd_dec
          ({|
           theBlock := bEqn z fz :: bl;
           blockType := type_bl;
           non_empty := exists_bl |} :: e) x).
destruct (bnd_dec
          ({|
           theBlock := bEqn z fz :: bl;
           blockType := type_bl;
           non_empty := exists_bl |} :: e) y).
simpl in *.
assert (bnd e x).
  destruct b;auto;contradiction.
assert (bnd e y).
  destruct b0;auto;contradiction.
clear - w_d_bl_e H H0 H1.
induction e.
inversion H0.
simpl in *.
destruct (bnd_block_dec a x).
destruct (bnd_block_dec a y).
assert (~bnd e x).
  intro.
  clear - w_d_bl_e b H2.
  destruct (w_d_bl_e x).
  simpl in *.
  assert ((if beq_nat x z then S (bnd_cnt_block bl x) else bnd_cnt_block bl x) +
    (bnd_cnt_block a x + bnd_cnt e x) = 1).
    apply H;auto.
  assert (bnd_cnt_block a x>0).
    apply bnd_cnt_block_gt;auto.
  assert (bnd_cnt e x>0).
    apply bnd_cnt_gt;auto.
  omega.
assert (~bnd e y).
  intro.
  clear - w_d_bl_e b0 H3.
  destruct (w_d_bl_e y).
  simpl in *.
  assert ((if beq_nat y z then S (bnd_cnt_block bl y) else bnd_cnt_block bl y) +
    (bnd_cnt_block a y + bnd_cnt e y) = 1).
    apply H;auto.
  assert (bnd_cnt_block a y>0).
    apply bnd_cnt_block_gt;auto.
  assert (bnd_cnt e y>0).
    apply bnd_cnt_gt;auto.
  omega.
unfold rank.
destruct (bnd_dec (a :: e) x);try contradiction.
destruct (bnd_dec (a :: e) y);try contradiction.
simpl.
destruct H0;try contradiction.
destruct H1;try contradiction.
destruct (bnd_block_dec a x);try contradiction.
destruct (bnd_block_dec a y);try contradiction.
destruct (blockType a);auto.
destruct type_bl;clear - H;exfalso;omega.
destruct (bnd_block_dec a y).
destruct type_bl;clear - H;exfalso;omega.
unfold rank.
destruct (bnd_dec (a :: e) x);try contradiction.
destruct (bnd_dec (a :: e) y);try contradiction.
simpl.
destruct (bnd_block_dec a x);try contradiction.
destruct (bnd_block_dec a y);try contradiction.
assert (bnd_block_number e x=bnd_block_number e y).
  clear - H.
  destruct type_bl;omega.
rewrite H2;auto.
simpl in *.
destruct type_bl;clear - H;exfalso;omega.
destruct (bnd_dec
          ({|
           theBlock := bEqn z fz :: bl;
           blockType := type_bl;
           non_empty := exists_bl |} :: e) y).
destruct type_bl;clear - H;exfalso;omega.
simpl in *.
assert (~bnd e x).
  intro;apply n1;auto.
assert (~bnd e y).
  intro;apply n2;auto.
clear - H0 H1.
unfold rank.
destruct (bnd_dec e x);try contradiction.
destruct (bnd_dec e y);try contradiction;auto.
Qed.

Lemma cc_tl : forall e:list block, forall bl:block,
forall alt_bl_e: alternating_list_block (bl::e), forall w_d_bl_e: w_d (make_genBES (bl::e) alt_bl_e),
  forall R:propVar_relation, consistent_consequence (makeBES (make_genBES (bl::e) alt_bl_e) w_d_bl_e) R ->
    forall alt_e:alternating_list_block e, forall w_d_e:w_d (make_genBES e alt_e),
      consistent_consequence (makeBES (make_genBES e alt_e) w_d_e) R.
Proof.
induction e;simpl in *.
intros;intro;intros.
split.
unfold rank.
simpl.
destruct (bnd_dec nil x);try contradiction.
destruct (bnd_dec nil y);try contradiction;auto.
simpl;intros.
inversion H1.

intros;simpl in *.
intro;intros;simpl in *.
split.
destruct (H x y H0).
simpl in *.

apply (rank_tl bl (a::e));auto.

intros.
intro;intros.
destruct (H x y H0).
simpl in *.
assert (bnd_block bl x \/ bnd_block a x \/ bnd e x);auto.
assert (bnd_block bl y \/ bnd_block a y \/ bnd e y);auto.
specialize (H6 H7 H8 _ H3).
destruct (bnd_block_dec a y);try contradiction.
assert (bnd_block a x).
  clear - H5 b w_d_bl_e w_d_e.
  specialize (rank_tl bl (a::e) w_d_bl_e _ _ H5).
  intro.
  destruct (eq_rank (a::e) x y H).
  simpl in *.
  assert (bnd_block a y \/ bnd e y);auto.
  specialize (H1 H2).
  unfold rank in H.
  destruct (bnd_dec (a :: e) x);try contradiction.
  destruct (bnd_dec (a :: e) y);try contradiction.
  unfold bnd_block_number in H.
  simpl in H.
  destruct (bnd_block_dec a y);try contradiction.
  destruct (bnd_block_dec a x);auto.
  destruct (blockType a);exfalso;clear - H;omega.
simpl in H6.
assert (~bnd_block bl x).
  clear - H9 w_d_bl_e.
  intro.
  destruct (w_d_bl_e x).
  assert (bnd_cnt (bl::a::e)x=1).
    apply H0;simpl;auto.
  simpl in H2.
  assert (bnd_cnt_block bl x>0).
    apply bnd_cnt_block_gt;auto.
  assert (bnd_cnt_block a x>0).
    apply bnd_cnt_block_gt;auto.
  omega.
assert (~bnd_block bl y).
  clear - b w_d_bl_e.
  intro.
  destruct (w_d_bl_e y).
  assert (bnd_cnt (bl::a::e)y=1).
    apply H0;simpl;auto.
  simpl in H2.
  assert (bnd_cnt_block bl y>0).
    apply bnd_cnt_block_gt;auto.
  assert (bnd_cnt_block a y>0).
    apply bnd_cnt_block_gt;auto.
  omega.
assert (~bnd e x).
  clear - H9 w_d_bl_e.
  intro.
  destruct (w_d_bl_e x).
  assert (bnd_cnt (bl::a::e)x=1).
    apply H0;simpl;auto.
  simpl in H2.
  assert (bnd_cnt e x>0).
    apply bnd_cnt_gt;auto.
  assert (bnd_cnt_block a x>0).
    apply bnd_cnt_block_gt;auto.
  omega.
assert (~bnd e y).
  clear - b w_d_bl_e.
  intro.
  destruct (w_d_bl_e y).
  assert (bnd_cnt (bl::a::e)y=1).
    apply H0;simpl;auto.
  simpl in H2.
  assert (bnd_cnt e y>0).
    apply bnd_cnt_gt;auto.
  assert (bnd_cnt_block a y>0).
    apply bnd_cnt_block_gt;auto.
  omega.
destruct (bnd_block_dec bl y);try contradiction.
destruct (bnd_block_dec bl x);try contradiction.
destruct (bnd_block_dec a x);try contradiction.
destruct (bnd_block_dec a y);try contradiction.
apply H6;auto.
destruct H2;try contradiction.
simpl in *.
destruct (bnd_block_dec a y);try contradiction.
assert (~bnd_block bl y).
  clear - H2 w_d_bl_e.
  intro.
  destruct (w_d_bl_e y).
  assert (bnd_cnt_block bl y + (bnd_cnt_block a y + bnd_cnt e y) = 1).
    apply H0;simpl;auto.
  assert (bnd_cnt_block bl y>0).
    apply bnd_cnt_block_gt;auto.
  assert (bnd_cnt e y>0).
    apply bnd_cnt_gt;auto.
  omega.
destruct (bnd_block_dec bl y);try contradiction.
apply H6.
assert (~bnd_block bl x).
  clear - H1 w_d_bl_e.
  intro.
  destruct (w_d_bl_e x).
  assert (bnd_cnt_block bl x + (bnd_cnt_block a x + bnd_cnt e x) = 1).
    apply H0;simpl;auto.
  assert (bnd_cnt_block bl x>0).
    apply bnd_cnt_block_gt;auto.
  destruct H1.
  assert (bnd_cnt_block a x>0).
    apply bnd_cnt_block_gt;auto.
  omega.
  assert (bnd_cnt e x>0).
    apply bnd_cnt_gt;auto.
  omega.
destruct (bnd_block_dec bl x);try contradiction.
assumption.
Qed.

Lemma cc_hd : forall e:list block, forall bl:block,
forall alt_bl_e: alternating_list_block (bl::e), forall w_d_bl_e: w_d (make_genBES (bl::e) alt_bl_e),
  forall R:propVar_relation, consistent_consequence (makeBES (make_genBES (bl::e) alt_bl_e) w_d_bl_e) R ->
    forall alt_bl:alternating_list_block (bl::nil), forall w_d_bl:w_d (make_genBES (bl::nil) alt_bl),
      consistent_consequence (makeBES (make_genBES (bl::nil) alt_bl) w_d_bl) R.
Proof.
intros;intro;intros.
destruct (H x y H0).

simpl in *;auto.
split.
clear - w_d_bl_e H1.
unfold rank in *.
simpl in *.
destruct (bnd_dec (bl :: nil) x).
destruct (bnd_dec (bl :: nil) y).
simpl in *.
destruct (bnd_dec (bl::e) x).
destruct (bnd_dec (bl::e) y).
destruct (blockType bl).
destruct (bnd_block_dec bl x).
destruct (bnd_block_dec bl y);auto.
inversion H1.
exfalso.
destruct b;auto.
destruct (bnd_block_dec bl x);try contradiction.
destruct (bnd_block_dec bl y);try contradiction;auto.
inversion H1.
destruct (bnd_block_dec bl y);try contradiction.
inversion H1.
auto.
destruct (blockType bl);inversion H1.
exfalso.
destruct b;auto;apply n;simpl;auto.
exfalso.
destruct (bnd_dec (bl::e) x).
destruct (bnd_dec (bl::e) y).
destruct (blockType bl).
simpl in *.
destruct b;auto.
destruct (bnd_block_dec bl x);auto.
destruct (bnd_block_dec bl y).
apply n;auto.
inversion H1.
destruct (bnd_block_dec bl x);auto.
destruct (bnd_block_dec bl y).
apply n;simpl;auto.
inversion H1.
destruct (bnd_block_dec bl y).
inversion H1.
destruct b;auto.
destruct (blockType bl);inversion H1.
destruct (bnd_block_dec bl y).
destruct (bnd_dec (bl::e) y).
destruct (blockType bl);inversion H1.
simpl in *.
apply n;auto.
destruct (bnd_dec (bl::e) y).
destruct (blockType bl);inversion H1.
simpl in *.
destruct b;auto.
destruct (bnd_dec (bl::e) x).
destruct (blockType bl).
destruct (bnd_dec (bl::nil) y);auto.
exfalso.
destruct (bnd_dec (bl::e) y).
destruct (bnd_block_dec bl x);simpl in *;try contradiction.
destruct b0;auto.
destruct b0;auto.
destruct (bnd_block_dec bl y);try contradiction;inversion H1.
destruct b0;auto.
apply n0;simpl;auto.
destruct (bnd_block_dec bl x).
destruct (bnd_dec (bl::e) y).
destruct (bnd_block_dec bl y).
destruct (bnd_dec (bl::nil) y);auto.
exfalso.
simpl in *.
apply n;auto.
destruct (bnd_dec (bl::nil) y);auto.
exfalso.
destruct b2;auto.
destruct (bnd_dec (bl::nil) y);auto.
destruct (bnd_block_dec bl y);auto.
exfalso.
destruct b1;auto.
destruct (bnd_dec (bl::nil) y);auto.
exfalso.
destruct (bnd_dec (bl::e) y).
destruct (bnd_block_dec bl y);auto.
inversion H1.
destruct b0;auto.
destruct b0;auto.
apply n1;left;auto.
destruct (bnd_dec (bl::e) y);auto.
destruct (bnd_block_dec bl y);auto.
destruct (bnd_dec (bl::nil) y);auto.
destruct (blockType bl);inversion H1.
destruct (bnd_dec (bl::nil) y);auto.
exfalso.
destruct b;auto.
apply n1;auto.
left;auto.

intros.
destruct H3;try contradiction.
destruct H4;try contradiction.
assert (bnd_block bl x \/ bnd e x);auto.
assert (bnd_block bl y \/ bnd e y);auto.
intro;intros.
specialize (H2 H5 H6 _ H7).
unfold rhs in *.
simpl in *.
destruct (bnd_block_dec bl x);try contradiction.
destruct (bnd_block_dec bl y);try contradiction.
apply H2;auto.
Qed.

Lemma redef_bnd_consistent : forall bl:block,
forall alt_bl:alternating_list_block (bl::nil),
  forall w_d_bl: w_d (make_genBES (bl::nil) alt_bl), forall R:propVar_relation,
    consistent_consequence (makeBES (make_genBES (bl::nil) alt_bl) w_d_bl) R ->
forall theta_bound theta_unbound:environment, consistent_environment theta_bound R ->
  consistent_environment theta_unbound R ->
    consistent_environment (redefine_bound bl theta_bound theta_unbound) R.
Proof.
destruct bl as  [bl type_bl exists_bl].
destruct bl;simpl in *;auto.
intros;intro;intros.
unfold redefine_bound in *.
destruct (bnd_block_dec nil x);try contradiction.
destruct (bnd_block_dec nil y);try contradiction.
apply (H0 x);auto.

intros.
specialize (rank_bound_split _ _ H).
simpl in *;intros.
destruct b as [z fz].
intro;intros.
destruct (H2 _ _ H3).
destruct H5.
destruct H5;try contradiction.
destruct H6;try contradiction.
unfold redefine_bound in *.
destruct (bnd_block_dec (bEqn z fz::bl) x);try contradiction.
destruct (bnd_block_dec (bEqn z fz::bl) y);try contradiction.
apply (H1 x);auto.
destruct H5.
unfold redefine_bound in *.
destruct (bnd_block_dec (bEqn z fz::bl) x).
exfalso.
apply H5;destruct b;auto.
destruct (bnd_block_dec (bEqn z fz::bl) y).
exfalso.
apply H6;destruct b;auto.
apply (H0 x);auto.
Qed.

Lemma useful : forall E:BES, forall R:propVar_relation,
  consistent_consequence E R ->
    forall theta:environment, consistent_environment theta R ->
      consistent_environment (BES_solution E theta) R.
Proof.
destruct E as [e w_d_e].
destruct e as [e alt_e].
induction e.
simpl in *;auto.

simpl;intros.
assert (alternating_list_block e).
  apply (alt_tl _ a);auto.
assert (w_d e).
  apply (w_d_tl e a);auto.
assert (consistent_consequence (makeBES (make_genBES e H1) H2) R).
  apply (cc_tl _ _ _ _ _ H).
assert (consistent_environment (genBES_solution e theta) R).
  apply (IHe H1 H2 R H3 theta);auto.
assert (alternating_list_block (a::nil)).
  simpl;auto.
assert (w_d (make_genBES (a::nil) H5)).
  destruct a as [al].
  apply w_d_w_d_block.
  apply (w_d_hd _ _ w_d_e).
assert (consistent_consequence (makeBES (make_genBES (a::nil) H5) H6) R).
  apply (cc_hd e _ alt_e w_d_e);auto.
destruct a as [bl bl_type bl_exists].
simpl.
destruct bl_type.

(*nu*)
cut (consistent_environment (redefine_bound bl theta
        (sol_iterator
           (fun theta_b'' : environment =>
            unfold_block bl
              (genBES_solution e (redefine_bound bl theta theta_b'')))
           full_environment (length bl))) R).
intro.
apply (IHe H1 H2 R H3);auto.
apply (redef_bnd_consistent _ H5 H6 _ H7 _ _ H0).
apply useful_sol_iterator.
intros.
cut (consistent_environment (genBES_solution e (redefine_bound bl theta theta0)) R).
intro.
apply (useful_unfold_block _ H5 H6 _ H7 _ H9).
apply (IHe H1 H2 R H3);auto.
apply (redef_bnd_consistent _ H5 H6 _ H7);auto.
apply full_environment_consistent.

(*mu*)
cut (consistent_environment (redefine_bound bl theta
        (sol_iterator
           (fun theta_b'' : environment =>
            unfold_block bl
              (genBES_solution e (redefine_bound bl theta theta_b'')))
           empty_environment (length bl))) R).
intro.
apply (IHe H1 H2 R H3);auto.
apply (redef_bnd_consistent _ H5 H6 _ H7 _ _ H0).
apply useful_sol_iterator.
intros.
cut (consistent_environment (genBES_solution e (redefine_bound bl theta theta0)) R).
intro.
apply (useful_unfold_block _ H5 H6 _ H7 _ H9).
apply (IHe H1 H2 R H3);auto.
apply (redef_bnd_consistent _ H5 H6 _ H7);auto.
apply empty_environment_consistent.
Qed.


(** Solutions to "Elements of Set Theory" Chapter 4 **)
(** Coq coding by choukh, May 2020 **)

Require Export ZFC.Elements.EST4_3.

Example ex4_2: ∀ a, trans a → trans a⁺.
Proof with eauto.
  intros a Ht c b Hc Hb. apply BUnionE in Hb as [].
  - apply BUnionI1. eapply Ht...
  - apply BUnionI1. apply SingE in H. subst...
Qed.

Example ex4_3: ∀ a, trans a ↔ trans 𝒫 a.
Proof with eauto.
  split; intros Ht c b Hc Hb.
  - rewrite PowerAx. intros x Hx. eapply Ht...
    rewrite PowerAx in Hb. apply Hb...
  - apply trans_union_sub in Ht. rewrite ex2_6_a in Ht.
    apply Ht in Hb. rewrite PowerAx in Hb. apply Hb...
Qed.

Example ex4_4: ∀ a, trans a → trans ⋃a.
Proof with eauto.
  intros a Ht c b Hc Hb. apply trans_union_sub in Ht.
  apply Ht in Hb. eapply UnionI...
Qed.

Example ex4_5_a: ∀ 𝒜, (∀A ∈ 𝒜, trans A) → trans ⋃𝒜.
Proof with eauto.
  intros * H a A Ha HA. apply UnionAx in HA as [B [H1 H2]].
  apply H in H1 as Htb.  eapply UnionI...
Qed.

Example ex4_5_b: ∀ 𝒜, (∀A ∈ 𝒜, trans A) → trans ⋂𝒜.
Proof with eauto.
  intros * H a A Ha HA. apply InterE in HA as [Hi HA].
  apply InterI... intros B HB. apply H in HB as Htb.
  apply HA in HB. eapply Htb...
Qed.

Example ex4_6: ∀ a, ⋃a⁺ = a → trans a.
Proof. apply trans_union_suc. Qed.

(* ex4_7 see EST4_1.v Theorem ω_recursion_uniqueness *)

Example ex4_8: ∀ f A h c, injective f → f: A ⇒ A →
  c ∈ A - ran f → h: ω ⇒ A →
  h[∅] = c → (∀n ∈ ω, h[n⁺] = f[h[n]]) →
  injective h.
Proof with eauto; try congruence.
  intros * Hinj [Hff [Hdf Hrf]] Hc [Hfh [Hdh Hrh]] Hh0 Hh1.
  split... intros y Hy. rewrite <- unique_existence.
  split. apply ranE in Hy...
  assert (Hnq0: ∀n ∈ ω, h[n⁺] ≠ c). {
    intros n Hn Heq1. apply Hh1 in Hn as Heq2.
    assert (Heq: f[h[n]] = c) by congruence.
    apply CompE in Hc as [_ Hc]. apply Hc. rewrite <- Heq.
    eapply ap_ran. split... apply Hrh.
    eapply ap_ran... split...
  }
  intros k l Hpk. apply domI in Hpk as Hk. rewrite Hdh in Hk.
  generalize Hpk. generalize dependent l.
  clear Hy Hpk. generalize dependent y.
  ω_induction k; intros y l H1 H2; apply domI in H2 as Hdl;
    apply func_ap in H1; eauto; apply func_ap in H2...
  - rewrite Hdh in Hdl. ω_destruct l... exfalso.
    apply Hh1 in Hp as Heq. eapply Hnq0...
  - rewrite Hdh in Hdl. ω_destruct l... exfalso. apply (Hnq0 m)...
    apply Hh1 in Hm as Heq1. apply Hh1 in Hp as Heq2.
    assert (f[h[l]] = f[h[m]]) by congruence.
    cut (m = l)... eapply IH. apply func_correct...
    cut (h[l] = h[m]). intros Heq.
    rewrite <- Heq. apply func_correct...
    eapply injectiveE; eauto; rewrite Hdf; apply Hrh;
      eapply ranI; apply func_correct...
Qed.

Example ex4_9: ∀ f A B h, f: B ⇒ B → A ⊆ B →
  is_function h → dom h = ω →
  h[∅] = A → (∀n ∈ ω, h[n⁺] = h[n] ∪ f⟦h[n]⟧) →
  let C1 := ⋂{X ∊ 𝒫 B | A ⊆ X ∧ X ⊆ B ∧ f⟦X⟧ ⊆ X} in
  let C2 := ⋃{h[i] | i ∊ ω} in
  C1 = C2.
Proof with neauto; try congruence.
  intros * [Hff [Hdf Hrf]] Hsub Hfh Hdh Hh0 Hh1 C1 C2.
  assert (Hrh: ran h ⊆ 𝒫 B). {
    intros y Hy. rewrite PowerAx. apply ranE in Hy as [n Hp].
    apply domI in Hp as Hn. rewrite Hdh in Hn.
    generalize Hp. clear Hp. generalize dependent y.
    ω_induction n; intros y Hy.
    - apply func_ap in Hy... subst...
    - apply func_ap in Hy... subst y. intros x Hx.
      apply Hh1 in Hm as Heq. rewrite Heq in Hx.
      apply BUnionE in Hx as [].
      + rewrite <- Hdh in Hm. apply func_correct in Hm...
        apply IH in Hm. apply Hm...
      + apply imgE in H as [y [_ Hp]].
        apply ranI in Hp. apply Hrf...
  }
  ext c Hc.
  - (* C1 ⊆ C2 *) apply InterE in Hc as [_ H]. apply H.
    assert (Hsub2: C2 ⊆ B). {
      intros y Hy. apply FUnionE in Hy as [n [Hn Hy]].
      rewrite <- Hdh in Hn. apply func_correct in Hn...
      apply ranI in Hn. apply Hrh in Hn.
      rewrite PowerAx in Hn. apply Hn...
    }
    apply SepI. rewrite PowerAx... split; [|split; auto].
    + (* A ⊆ C2 *) intros x Hx.
      rewrite <- Hh0 in Hx. eapply FUnionI; revgoals...
    + (* f⟦C2⟧ ⊆ C2 *) intros y Hy.
      apply imgE in Hy as [x [Hx Hp]]. apply ranI in Hp as Hr.
      apply func_ap in Hp as Hap... subst y.
      apply FUnionE in Hx as [n [Hn Hx]].
      assert (Hn1: n⁺ ∈ ω) by (apply ω_inductive; auto).
      eapply FUnionI. apply Hn1. apply Hh1 in Hn.
      rewrite Hn. apply BUnionI2. eapply imgI...
  - (* C2 ⊆ C1 *)
    apply FUnionE in Hc as [n [Hn Hc]].
    assert (Hi: ⦿ {X ∊ 𝒫 B | A ⊆ X ∧ X ⊆ B ∧ f⟦X⟧ ⊆ X}). {
      exists B. apply SepI. apply PowerAx... split... split...
      intros x Hx. apply imgE in Hx as [w [_ Hx]].
      apply ranI in Hx. apply Hrf...
    }
    generalize dependent c.
    ω_induction n; intros c Hc; apply InterI...
    + intros y Hy. rewrite Hh0 in Hc.
      apply SepE in Hy as [_ [H _]]. apply H...
    + intros y Hy. apply Hh1 in Hm as Heq. rewrite Heq in Hc.
      apply BUnionE in Hc as [].
      * apply IH in H. apply InterE in H as [_ H]. apply H...
      * apply imgE in H as [w [Hw Hc]].
        apply SepE in Hy as [_ [H1 [H2 H3]]].
        apply H3. eapply imgI... apply IH in Hw.
        apply InterE in Hw as [_ Hy]. apply Hy.
        apply SepI. apply PowerAx... split...
Qed.

Example ex4_13: ∀ m n ∈ ω, m ⋅ n = 0 → m = 0 ∨ n = 0.
Proof. exact mul_eq_0. Qed.

Example ex4_14: ∀n ∈ ω,
  (even n ∨ odd n) ∧ ¬ (even n ∧ odd n).
Proof with eauto; try apply mul_ran; repeat apply ω_inductive; auto.
  intros n Hn. split.
  - ω_induction n.
    + left. exists 0. split... rewrite mul_0_r...
    + destruct IH.
      * right. destruct H as [k [Hk Heq]].
        exists k. split... rewrite Heq, suc...
      * left. destruct H as [k [Hk Heq]].
        exists k⁺. split. apply ω_inductive...
        rewrite Heq, (pred 1), add_suc, add_0_r...
        rewrite suc, suc, mul_suc...
        rewrite (add_comm 2)...
        rewrite (add_assoc (2⋅k))...
        cut (1 + 1 = 2); try congruence...
        rewrite pred, add_suc, add_0_r... apply mul_ran...
  - ω_induction n; intros [[k [Hk Hkeq]] [p [Hp Hpeq]]].
    + rewrite <- suc in Hpeq...
      exfalso. eapply suc_neq_0. rewrite Hpeq...
    + apply IH. split.
      * exists p. split...
        rewrite <- suc in Hpeq... apply suc_injective in Hpeq...
      * ω_destruct k.
        rewrite mul_0_r in Hkeq... exfalso. eapply suc_neq_0...
        exists k. split...
        rewrite pred, mul_suc, add_comm, add_suc in Hkeq...
        apply suc_injective in Hkeq... apply add_ran...
Qed.

(* ex4_15 ex4_16 ex4_17 see EST4_2.v *)

Example ex4_19: ∀ m d ∈ ω, d ≠ 0 →
  ∃ q r ∈ ω, m = (d ⋅ q) + r ∧ r ∈ d.
Proof with neauto.
  intros n Hn.
  ω_induction n; intros d Hd Hnq0.
  - exists 0. split... exists 0. split... split.
    rewrite mul_0_r, add_0_r... apply neq_0_gt_0...
  - apply (IH d Hd) in Hnq0 as [q [Hq [r [Hr [Heq Hrd]]]]]...
    apply suc_preserve_lt in Hrd...
    apply le_iff_lt_suc in Hrd as []; try apply ω_inductive...
    + exists q. split... exists r⁺. split.
      apply ω_inductive... split... rewrite add_suc...
      congruence. apply mul_ran...
    + subst d. exists q⁺. split. apply ω_inductive...
      exists 0. split... split; [|apply suc_has_0; auto].
      rewrite add_0_r, mul_suc, add_comm, add_suc; try apply mul_ran...
      congruence. apply ω_inductive...
Qed.

Example ex4_20: ∀ A, A ≠ ∅ → A ⊆ ω → ⋃A = A → A = ω.
Proof with eauto.
  intros A Hnq0 HA HU. apply ω_ind... split.
  - apply EmptyNE in Hnq0 as [a Ha].
    destruct (classic (a = ∅)). subst a...
    rewrite <- HU. apply UnionAx. exists a. split...
    apply HA in Ha. apply neq_0_gt_0...
  - intros a Ha. apply HA in Ha as Haw. rewrite <- HU in Ha.
    apply UnionAx in Ha as [b [Hb Ha]]. apply HA in Hb as Hbw.
    assert (Ha1: a⁺ ∈ ω) by (apply ω_inductive; auto).
    destruct (classic (b = a⁺)). subst...
    apply nat_connected in H as []...
    + exfalso. apply le_iff_lt_suc in H...
      apply (nat_not_le_gt b Hbw a Haw)...
    + rewrite <- HU. apply UnionAx. exists b. split...
Qed.

Example ex4_21: ¬ ∃ n ∈ ω, ∃ m ∈ n, n ⊆ m.
Proof with eauto.
  intros [n [Hn [m [Hm H]]]].
  assert (Hmw: m ∈ ω) by (eapply ω_trans; eauto).
  ω_destruct n. exfalso0. clear Hn Hp.
  apply H in Hm as Hmm. eapply nat_irrefl...
Qed.

Example ex4_22: ∀ m p ∈ ω, m ∈ m + p⁺.
Proof with eauto.
  intros n Hn.
  ω_induction n; intros k Hk.
  - rewrite add_0_l. apply suc_has_0... apply ω_inductive...
  - rewrite add_suc'... apply (suc_preserve_lt m)...
    apply add_ran... apply ω_inductive... apply ω_inductive...
Qed.

Example ex4_23: ∀ m n ∈ ω, m ∈ n → ∃p ∈ ω, m + p⁺ = n.
Proof with eauto.
  intros k Hk.
  ω_induction k; intros n Hn H.
  - apply neq_0_gt_0 in H... apply pred_exists in H as [n' [Hn' Heq]]...
    exists n'. split... rewrite add_0_l... congruence.
  - ω_destruct n. exfalso0.
    apply suc_preserve_lt in H...
    apply IH in H as [p [Hpw Heq]]...
    exists p. split... rewrite add_suc'... congruence.
    apply ω_inductive...
Qed.

Example ex4_24: ∀ m n p q ∈ ω, m + n = p + q →
  m ∈ p ↔ q ∈ n.
Proof with try apply add_ran; try apply ω_inductive; auto.
  intros m Hm n Hn p Hp q Hq Heq. split; intros.
  - apply ex4_23 in H as [k [Hk Hkeq]]... subst p.
    rewrite add_comm in Heq... rewrite (add_assoc m) in Heq...
    rewrite (add_comm m) in Heq...
    apply add_cancel in Heq... subst n.
    rewrite add_comm... apply ex4_22...
  - apply ex4_23 in H as [k [Hk Hkeq]]... subst n.
    rewrite (add_comm q) in Heq...
    rewrite <- add_assoc in Heq...
    apply add_cancel in Heq... subst p. apply ex4_22...
Qed.

Example ex4_25: ∀ m n p q ∈ ω, n ∈ m → q ∈ p →
  m ⋅ q + n ⋅ p ∈ m ⋅ p + n ⋅ q.
Proof with try apply ω_inductive; auto.
  intros m Hm n Hn p Hp q Hq Hnm Hqp.
  apply ex4_23 in Hqp as [s [Hs Hseq]]... subst p.
  rewrite mul_distr... rewrite mul_distr...
  assert (Hmq: m ⋅ q ∈ ω). { apply mul_ran... }
  assert (Hnq: n ⋅ q ∈ ω). { apply mul_ran... }
  assert (Hns: n ⋅ s⁺ ∈ ω). { apply mul_ran... }
  assert (Hms: m ⋅ s⁺ ∈ ω). { apply mul_ran... }
  rewrite add_comm; revgoals... apply add_ran...
  rewrite (add_assoc (m⋅q))...
  rewrite (add_comm (m⋅q)); revgoals... apply add_ran...
  apply add_preserve_lt... apply add_ran... apply add_ran...
  rewrite add_comm... apply add_preserve_lt...
  apply mul_preserve_lt...
Qed.

Example ex4_26: ∀n ∈ ω, ∀ f, f: n⁺ ⇒ ω →
  ∃m ∈ ran f, ∀k ∈ ran f, k ⋸ m.
Proof with eauto.
  intros n Hn.
  ω_induction n; intros f [Hff [Hfd Hfr]].
  - exists (f[0]). split.
    + eapply ap_ran. split... nauto.
    + intros k Hk. apply ranE in Hk as [x Hp].
      apply domI in Hp as Hx. rewrite Hfd in Hx.
      apply BUnionE in Hx as []. exfalso0.
      apply SingE in H. subst x. apply func_ap in Hp...
  - assert (Hres: f ↾ m⁺: m⁺ ⇒ ω). {
      split. apply restr_func...
      split. ext Hx.
      + apply domE in Hx as [y Hp].
        apply restrE2 in Hp as []...
      + eapply domI. apply restrI... apply func_correct...
        rewrite Hfd. apply BUnionI1...
      + intros y Hy. apply ranE in Hy as [x Hp].
        apply restrE2 in Hp as [Hp _]...
        apply ranI in Hp. apply Hfr in Hp...
    }
    assert (Hreq: ran f = f⟦m⁺⟧ ∪ {f[m⁺],}). {
      ext y Hy.
      - apply ranE in Hy as [x Hp].
        apply domI in Hp as Hd. rewrite Hfd in Hd.
        apply BUnionE in Hd as [].
        + apply BUnionI1. eapply imgI...
        + apply BUnionI2. apply SingE in H. subst x.
          apply func_ap in Hp... subst y...
      - apply BUnionE in Hy as [].
        + apply imgE in H as [x [_ Hp]]. eapply ranI...
        + apply SingE in H. subst y. eapply ranI.
          apply func_correct... rewrite Hfd. apply BUnionI2...
    }
    assert (Hm1: m⁺ ∈ dom f). {
      rewrite Hfd. apply BUnionI2...
    }
    assert (Hfm1: f[m⁺] ∈ ω). {
      eapply ap_ran. split... nauto.
    }
    pose proof (IH _ Hres) as [M [HM IHk]].
    destruct Hres as [_ [_ Hresr]].
    assert (HMw: M ∈ ω) by (apply Hresr; auto).
    destruct (classic (f[m⁺] = M)).
    + exists M. split. eapply ranI.
      apply func_correct in Hm1... rewrite H in Hm1. apply Hm1.
      intros k Hk. rewrite Hreq in Hk.
      apply BUnionE in Hk as []. apply IHk...
      apply SingE in H0. subst k. right...
    + apply nat_connected in H as []...
      * exists M. split. rewrite Hreq. apply BUnionI1...
        intros k Hk. rewrite Hreq in Hk.
        apply BUnionE in Hk as []. apply IHk...
        apply SingE in H0. subst k. left...
      * exists (f[m⁺]). split. eapply ap_ran. split... nauto.
        intros k Hk. rewrite Hreq in Hk.
        apply BUnionE in Hk as []. apply IHk in H0 as []; left.
        eapply nat_trans; revgoals... congruence.
        right. apply SingE in H0...
Qed.

Example ex4_27: ∀ A G f₁ f₂, is_function G →
  f₁: ω ⇒ A → f₂: ω ⇒ A →
  (∀n ∈ ω,
    f₁ ↾ n ∈ dom G ∧ f₂ ↾ n ∈ dom G ∧
    f₁[n] = G[f₁ ↾ n] ∧ f₂[n] = G[f₂ ↾ n]
  ) →
  f₁ = f₂.
Proof with eauto; try congruence.
  intros A G f₁ f₂ HG [Hf₁ [Hf₁d Hf₁r]] [Hf₂ [Hf₂d Hf₂r]] H...
  apply func_ext_intro... intros n Hn. rewrite Hf₁d in Hn.
  pose proof (H n) as [_ [_ [Heq1 Heq2]]]...
  cut (f₁ ↾ n = f₂ ↾ n)... clear Heq1 Heq2.
  ω_induction n.
  - ext Hx.
    + apply restrE1 in Hx as [a [_ [Ha _]]]. exfalso0.
    + apply restrE1 in Hx as [a [_ [Ha _]]]. exfalso0.
  - assert (Heq1: f₁ ↾ m⁺ = (f₁ ↾ m) ∪ (f₁ ↾ {m,})) by apply ex3_22_c.
    assert (Heq2: f₂ ↾ m⁺ = (f₂ ↾ m) ∪ (f₂ ↾ {m,})) by apply ex3_22_c.
    cut (f₁ ↾ {m,} = f₂ ↾ {m,})... clear Heq1 Heq2.
    pose proof (H m) as [_ [_ [Heq1 Heq2]]]...
    assert (Heq3: f₁[m] = f₂[m]) by congruence.
    ext Hx.
    + apply restrE1 in Hx as [a [b [Ha [Hq Heq]]]].
      apply SingE in Ha. apply func_ap in Hq... subst a b x.
      apply restrI... rewrite Heq3.
      apply func_correct...
    + apply restrE1 in Hx as [a [b [Ha [Hq Heq]]]].
      apply SingE in Ha. apply func_ap in Hq... subst a b x.
      apply restrI... rewrite <- Heq3.
      apply func_correct...
Qed.

Ltac ω_strong_induction C := cut (C = 0); [
  intros ?H0; eapply EmptyE in H0; apply H0;
  apply SepI; eauto |
  apply ω_ind_strong_0; [
    intros ?c ?Hc; apply SepE in Hc as []; auto |
    intros ?c ?Hc; apply SepE in Hc as [?Hc ?IH]
  ]
].

Example ex4_28: trans ω.
Proof with auto.
  apply trans_sub. intros n Hn.
  contra.
  set {n ∊ ω | n ⊈ ω} as C.
  ω_strong_induction C.
  ω_destruct c.
  - exfalso. apply IH. intros x Hx. exfalso0.
  - exists c. split; revgoals. apply BUnionI2...
    apply SepI... intros Hsub. apply IH.
    intros x Hx. apply BUnionE in Hx as [].
    apply Hsub... apply SingE in H0. subst...
Qed.

Example ex4_32: ∀n ∈ ω, ⋃{n,}⁺ = n⁺.
Proof with nauto.
  intros n Hn.
  ext Hx.
  - apply UnionAx in Hx as [y [Hy Hx]].
    apply BUnionE in Hy as []; apply SingE in H; subst.
    apply BUnionI1... apply BUnionI2...
  - apply BUnionE in Hx as []; apply UnionAx.
    + exists n. split... apply BUnionI1...
    + exists {n,}. split...
Qed.

Definition count : set → set → Prop := λ S n,
  n ∈ ω ∧ ∃ f, f: n ⟺ S.

Lemma ex4_37_0: ∀ x m n ∈ ω, x ∈ m + n⁺ → x ∉ m →
  ∃b ∈ n⁺, x = m + b.
Proof with eauto.
  intros n Hn a Ha b Hb.
  ω_induction n; intros Hnab Hna.
  - ω_destruct a.
    + exists 0. split. apply suc_has_0... rewrite add_0_r...
    + exfalso. apply Hna. apply suc_has_0...
  - destruct (classic (m⁺ = a)).
    exists 0. split. apply suc_has_0... rewrite add_0_r...
    apply nat_connected in H as []; try apply ω_inductive...
    exfalso. apply Hna...
    assert (Hma: m ∉ a). {
      intros Hma. apply BUnionE in H as [].
      eapply nat_not_lt_gt; revgoals...
      apply SingE in H. eapply nat_not_lt_self; revgoals...
    }
    apply IH in Hma as [c [Hc Heq]]; revgoals.
    eapply nat_trans; revgoals. apply Hnab. apply BUnionI2...
    apply add_ran... apply ω_inductive...
    assert (Hcw: c ∈ ω). {
      eapply ω_trans. apply Hc. apply ω_inductive...
    }
    destruct (classic (c = b)). exfalso.
    rewrite <- H0, add_suc in Hnab...
    apply suc_preserve_lt in Hnab; try apply add_ran...
    eapply nat_irrefl. apply Hm. rewrite <- Heq in Hnab...
    apply nat_connected in H0 as []; revgoals... exfalso.
    apply le_iff_lt_suc in Hc... eapply nat_not_le_gt; revgoals...
    exists c⁺. split; revgoals. rewrite add_suc... congruence.
    apply suc_preserve_lt in H0...
Qed.

Example ex4_37_a: ∀ A B m n,
  count A m → count B n → disjoint A B →
  count (A ∪ B) (m + n).
Proof with eauto; try congruence.
  intros * [Hm [f [[Hff Hfs] [Hfd Hfr]]]]
           [Hn [g [[Hgf Hgs] [Hgd Hgr]]]] Hdj.
  split. apply add_ran...
  set (Rel (m + n) (A ∪ B) (λ a y,
    (a ∈ m ∧ y = f[a]) ∨
    (∃b ∈ n, a = m + b ∧ y = g[b])
  )) as h.
  assert (Hhf: is_function h). {
    split. apply rel_is_rel.
    intros x Hx. rewrite <- unique_existence.
    split. apply domE in Hx...
    intros y1 y2 H1 H2.
    apply SepE in H1 as [Hp [[Hxm1 H1]|[b1 [Hb1 [H11 H12]]]]];
    apply SepE in H2 as [_  [[Hxm2 H2]|[b2 [Hb2 [H21 H22]]]]];
    apply CPrdE2 in Hp as [Hxmn _]; zfc_simple.
    - rewrite H21 in Hxm1. exfalso.
      assert (Hbw: b2 ∈ ω) by (eapply ω_trans; eauto).
      eapply (le_iff_not_gt m Hm (m + b2))...
      apply add_ran... eapply add_enlarge_le...
    - rewrite H11 in Hxm2. exfalso.
      assert (Hbw: b1 ∈ ω) by (eapply ω_trans; eauto).
      eapply (le_iff_not_gt m Hm (m + b1))...
      apply add_ran... eapply add_enlarge_le...
    - assert (Hbw1: b1 ∈ ω) by (eapply ω_trans; eauto).
      assert (Hbw2: b2 ∈ ω) by (eapply ω_trans; eauto).
      rewrite add_comm in H11, H21... rewrite H11 in H21.
      apply add_cancel in H21...
  }
  exists h. split; split...
  - (* single_rooted h *)
    intros y Hy. rewrite <- unique_existence.
    split. apply ranE in Hy...
    intros x1 x2 H1 H2.
    apply SepE in H1 as [Hp1 [[Hxm1 H1]|[b1 [Hb1 [H11 H12]]]]];
    apply SepE in H2 as [Hp2 [[Hxm2 H2]|[b2 [Hb2 [H21 H22]]]]];
    apply CPrdE2 in Hp1 as [Hxmn1 _];
    apply CPrdE2 in Hp2 as [Hxmn2 _]; zfc_simple.
    + rewrite <- Hfd in Hxm1, Hxm2.
      eapply injectiveE; revgoals... split...
    + exfalso. rewrite <- Hfd in Hxm1. rewrite <- Hgd in Hb2.
      apply func_correct in Hxm1... apply ranI in Hxm1.
      apply func_correct in Hb2... apply ranI in Hb2.
      rewrite Hfr in Hxm1. rewrite Hgr in Hb2.
      eapply (disjointE A B)...
    + exfalso. rewrite <- Hfd in Hxm2. rewrite <- Hgd in Hb1.
      apply func_correct in Hxm2... apply ranI in Hxm2.
      apply func_correct in Hb1... apply ranI in Hb1.
      rewrite Hfr in Hxm2. rewrite Hgr in Hb1.
      eapply (disjointE A B)...
    + cut (b1 = b2)... rewrite <- Hgd in Hb1, Hb2.
      eapply injectiveE; revgoals... split...
  - ext Hx.
    (* dom h ⊆ m + n *)
    apply domE in Hx as [y Hp]. apply SepE in Hp as [Hp _].
    apply CPrdE2 in Hp as []...
    (* dom h ⊇ m + n *)
    destruct (classic (x ∈ m)) as [Hxm|Hxm].
    + assert (Hxd := Hxm). rewrite <- Hfd in Hxd.
      apply domE in Hxd as [y Hp].
      eapply domI. apply SepI; zfc_simple.
      * apply CPrdI... apply BUnionI1.
        rewrite <- Hfr. eapply ranI. apply Hp.
      * left. split... apply func_ap in Hp...
    + assert (Hxmn := Hx). ω_destruct n.
      rewrite H, add_0_r in Hx...
      rewrite Heq in Hx.
      eapply ex4_37_0 in Hx as [b [Hb Hx]]; revgoals...
      eapply ω_trans... apply add_ran...
      assert (Hbw: b ∈ ω). {
        eapply ω_trans. apply Hb. apply ω_inductive...
      }
      assert (b ∈ n⁺)... rewrite <- Heq in Hb. clear Hp.
      apply domE in Hb as [c Hp].
      eapply domI. apply SepI; zfc_simple.
      * apply CPrdI... apply BUnionI2.
        rewrite <- Hgr. eapply ranI...
      * right. exists b. split... split... apply func_ap in Hp...
  - ext y Hy.
    (* ran h ⊆ A ∪ B *)
    apply ranE in Hy as [x Hp]. apply SepE in Hp as [Hp _].
    apply CPrdE2 in Hp as []...
    (* ran h ⊇ A ∪ B *)
    assert (Hy' := Hy). apply BUnionE in Hy' as [].
    + rewrite <- Hfr in H. apply ranE in H as [x Hp].
      eapply ranI. apply SepI; zfc_simple.
      * apply CPrdI... apply domI in Hp.
        rewrite Hfd in Hp. apply add_enlarge_lt...
      * left. split. apply domI in Hp... apply func_ap in Hp...
    + rewrite <- Hgr in H. apply ranE in H as [b Hp].
      apply domI in Hp as Hd. rewrite Hgd in Hd.
      assert (Hbw: b ∈ ω) by (eapply ω_trans; eauto).
      eapply ranI. apply SepI; zfc_simple.
      * apply CPrdI... rewrite add_comm...
        apply add_preserve_lt; revgoals...
      * right. exists b. split... split.
        rewrite add_comm... apply func_ap in Hp...
Qed.

Lemma mul_enlarge_r_suc_le : ∀ m n ∈ ω, m ⋸ m ⋅ n⁺.
Proof with eauto.
  intros m Hm n Hn. apply le_iff_not_gt...
  apply mul_ran... apply ω_inductive... intros Hc.
  rewrite mul_suc in Hc...
  apply add_shrink_lt in Hc; try apply mul_ran...
  eapply nat_irrefl; revgoals...
Qed.

Lemma ex4_37_1: ∀ m i1 i2 j1 j2 ∈ ω,
  m ⋅ j1 + i1 = m ⋅ j2 + i2 →
  i1 ∈ m → i2 ∈ m → j1 = j2.
Proof with eauto; try congruence.
  intros n Hn i1 Hi1 i2 Hi2 j1 Hj1 j2 Hj2.
  generalize dependent j2.
  ω_induction j1; intros j2 Hj2 Heq Hlt1 Hlt2.
  - ω_destruct j2... exfalso.
    rewrite mul_0_r, add_0_l in Heq... rewrite Heq in Hlt1.
    apply add_shrink_lt in Hlt1; try apply mul_ran...
    eapply nat_not_le_gt; revgoals. apply Hlt1.
    apply mul_enlarge_r_suc_le...
    apply mul_ran... apply Hn.
  - ω_destruct j2.
    + exfalso. rewrite mul_0_r, add_0_l in Heq...
      rewrite <- Heq in Hlt2.
      apply add_shrink_lt in Hlt2;
        try apply mul_ran; try apply ω_inductive...
      eapply nat_not_le_gt; revgoals. apply Hlt2.
      apply mul_enlarge_r_suc_le...
      apply mul_ran... apply ω_inductive... apply Hn.
    + cut (m = j2)... eapply IH...
      do 2 rewrite mul_suc in Heq...
      do 2 rewrite add_assoc in Heq; try apply mul_ran...
      rewrite add_comm, (add_comm n) in Heq;
        try apply add_ran; try apply mul_ran...
      apply add_cancel in Heq;
        try apply add_ran; try apply mul_ran...
Qed.

Lemma ex4_37_2_0 : ∀ a b ∈ ω, ∀x ∈ a + b,
  a ⋸ x → ∃c ∈ b, x = a + c.
Proof with neauto.
  intros a Ha b Hb.
  ω_induction b; intros x Hx Hlt.
  - exfalso. rewrite add_0_r in Hx...
    eapply nat_not_le_gt; revgoals... eapply ω_trans...
  - assert (Hxw: x ∈ ω). {
      eapply ω_trans. apply Hx.
      apply add_ran... apply ω_inductive...
    }
    rewrite add_suc in Hx...
    apply le_iff_lt_suc in Hx as []; try apply add_ran...
    apply IH in Hlt as [c [Hc Heq]]...
    exists c. split... apply BUnionI1...
Qed.

Lemma ex4_37_2: ∀ m n ∈ ω, ∀x ∈ m ⋅ n,
  ∃i ∈ m, ∃j ∈ n, x = m ⋅ j + i.
Proof with eauto.
  intros k Hk n Hn.
  ω_induction n; intros x Hx.
  - rewrite mul_0_r in Hx... exfalso0.
  - assert (Hxw: x ∈ ω). {
      eapply ω_trans... apply mul_ran...
      apply ω_inductive...
    }
    rewrite mul_suc in Hx; try apply mul_ran...
    destruct (classic (x ∈ k)).
    exists x. split... exists 0. split.
    apply suc_has_0... rewrite mul_0_r, add_0_l...
    apply le_iff_not_gt in H...
    apply ex4_37_2_0 in Hx as [c [Hc Hx]]; try apply mul_ran...
    apply IH in Hc as [i [Hi [j [Hj Hc]]]]. subst c.
    assert (Hiw: i ∈ ω) by (eapply ω_trans; eauto).
    assert (Hjw: j ∈ ω) by (eapply ω_trans; eauto).
    rewrite <- add_assoc, <- mul_suc in Hx; try apply mul_ran...
    exists i. split... exists j⁺. split...
    apply suc_preserve_lt in Hj; try apply ω_inductive...
Qed.

Lemma ex4_37_3: ∀ m n ∈ ω, ∀i ∈ m, ∀j ∈ n,
  m ⋅ j + i ∈ m ⋅ n.
Proof with auto.
  intros k Hk n Hn i Hi.
  ω_induction n; intros j Hj. exfalso0.
  assert (Hiw: i ∈ ω) by (eapply ω_trans; eauto).
  assert (Hjw: j ∈ ω). {
    eapply ω_trans; eauto. apply ω_inductive...
  }
  rewrite mul_suc, (add_comm k); revgoals...
  apply mul_ran...
  apply le_iff_lt_suc in Hj as []...
  - apply IH in H. eapply add_enlarge_lt...
    apply mul_ran...
  - subst. rewrite add_comm, (add_comm (k⋅m))...
    apply add_preserve_lt... apply mul_ran...
    apply mul_ran... apply mul_ran...
Qed.

Example ex4_37_b: ∀ A B m n,
  count A m → count B n → disjoint A B →
  count (A × B) (m ⋅ n).
Proof with eauto; try congruence.
intros * [Hm [f [[Hff Hfs] [Hfd Hfr]]]]
         [Hn [g [[Hgf Hgs] [Hgd Hgr]]]] Hdj.
  split. apply mul_ran...
  set (Rel (m ⋅ n) (A × B) (λ x y,
    let u := π1 y in let v := π2 y in
    ∃i ∈ m, ∃j ∈ n, u = f[i] ∧ v = g[j] ∧
    x = m ⋅ j + i
  )) as h.
  assert (Hhf: is_function h). {
    split. apply rel_is_rel.
    intros x Hx. rewrite <- unique_existence.
    split. apply domE in Hx...
    intros y1 y2 H1 H2.
    apply SepE in H1 as
      [Hp1 [i1 [Hi1 [j1 [Hj1 [Hf1 [Hg1 Heq1]]]]]]].
    apply SepE in H2 as
      [Hp2 [i2 [Hi2 [j2 [Hj2 [Hf2 [Hg2 Heq2]]]]]]].
    apply CPrdE2 in Hp1 as [Hxmn Hy1].
    apply CPrdE2 in Hp2 as [_ Hy2].
    apply CPrdE1 in Hy1 as [u1 [Hu1 [v1 [Hv1 Hy1]]]].
    apply CPrdE1 in Hy2 as [u2 [Hu2 [v2 [Hv2 Hy2]]]].
    rewrite Hy1 in Hf1, Hg1. rewrite Hy2 in Hf2, Hg2.
    zfc_simple. rewrite Heq1 in Heq2.
    assert (Hi1w: i1 ∈ ω) by (eapply ω_trans; eauto).
    assert (Hi2w: i2 ∈ ω) by (eapply ω_trans; eauto).
    assert (Hj1w: j1 ∈ ω) by (eapply ω_trans; eauto).
    assert (Hj2w: j2 ∈ ω) by (eapply ω_trans; eauto).
    assert (j1 = j2) by (eapply ex4_37_1; swap 1 6; eauto).
    rewrite H, add_comm, (add_comm (m⋅j2)) in Heq2;
      try apply mul_ran... cut (i1 = i2)...
    eapply add_cancel; revgoals... apply mul_ran...
  }
  exists h. split; split...
  - (* single_rooted h *)
    intros y Hy. rewrite <- unique_existence.
    split. apply ranE in Hy...
    intros x1 x2 H1 H2.
    apply SepE in H1 as
      [Hp1 [i1 [Hi1 [j1 [Hj1 [Hf1 [Hg1 Heq1]]]]]]].
    apply SepE in H2 as
      [Hp2 [i2 [Hi2 [j2 [Hj2 [Hf2 [Hg2 Heq2]]]]]]].
    apply CPrdE2 in Hp1 as [Hxmn1 Hy1].
    apply CPrdE2 in Hp2 as [Hxmn2 Hy2].
    apply CPrdE1 in Hy1 as [u1 [Hu1 [v1 [Hv1 Hy1]]]].
    apply CPrdE1 in Hy2 as [u2 [Hu2 [v2 [Hv2 Hy2]]]].
    rewrite Hy1 in Hf1, Hg1. rewrite Hy2 in Hf2, Hg2.
    zfc_simple. rewrite Hy1 in Hy2.
    apply op_iff in Hy2 as [Hequ Heqv].
    assert (Heqfi: f[i1] = f[i2]) by congruence.
    assert (Heqfj: g[j1] = g[j2]) by congruence.
    apply injectiveE in Heqfi; revgoals... split...
    apply injectiveE in Heqfj; revgoals... split...
  - ext Hx.
    (* dom h ⊆ m ⋅ n *)
    apply domE in Hx as [y Hp]. apply SepE in Hp as [Hp _].
    apply CPrdE2 in Hp as []...
    (* dom h ⊇ m ⋅ n *)
    assert (Hxmn := Hx).
    apply ex4_37_2 in Hx as [i [Hi [j [Hj Heq]]]]...
    assert (Hid := Hi). assert (Hjd := Hj).
    rewrite <- Hfd in Hid. apply domE in Hid as [yf Hpf].
    rewrite <- Hgd in Hjd. apply domE in Hjd as [yg Hpg].
    eapply domI. apply SepI; zfc_simple.
    apply CPrdI... apply CPrdI.
    rewrite <- Hfr. eapply ranI...
    rewrite <- Hgr. eapply ranI... zfc_simple.
    exists i. split... exists j. split...
    apply func_ap in Hpf... apply func_ap in Hpg...
  - ext y Hy.
    (* ran h ⊆ A ∪ B *)
    apply ranE in Hy as [x Hp]. apply SepE in Hp as [Hp _].
    apply CPrdE2 in Hp as []...
    (* ran h ⊇ A ∪ B *)
    assert (Hy' := Hy).
    apply CPrdE1 in Hy' as [u [Hu [v [Hv H]]]]. subst y.
    rewrite <- Hfr in Hu. apply ranE in Hu as [i Hpf].
    rewrite <- Hgr in Hv. apply ranE in Hv as [j Hpg].
    apply domI in Hpf as Hi. rewrite Hfd in Hi.
    apply domI in Hpg as Hj. rewrite Hgd in Hj.
    eapply ranI. apply SepI; zfc_simple.
    apply CPrdI... apply ex4_37_3...
    exists i. split... exists j. split...
    apply func_ap in Hpf... apply func_ap in Hpg...
Qed.