From Cyclic_PA.Maths Require Import naturals.
From Cyclic_PA.Maths Require Import ordinals.

From Cyclic_PA.Logic Require Import definitions.
From Cyclic_PA.Logic Require Import fol.
From Cyclic_PA.Logic Require Import PA_omega.
From Cyclic_PA.Logic Require Import proof_trees.
From Cyclic_PA.Logic Require Import substitute.
Require Import Lia.

Definition w_rule_sub_formula
  (A E : formula) (n : nat) (c : c_term) (S : subst_ind) : formula :=
  formula_sub_ind A (univ n E) (substitution E n (projT1 c)) S.

Lemma w_rule_sub_formula_closed :
    forall (A : formula),
        closed A = true ->
            forall (E : formula) (n : nat) (c : c_term) (S : subst_ind),
                closed (w_rule_sub_formula A E n c S) = true.
Proof.
intros A CA E n c S.
unfold w_rule_sub_formula.
apply (formula_sub_ind_closed _ _ _ CA).
intros CuE.
apply (closed_univ_sub E n CuE (projT1 c)).
destruct c as [t Ct].
apply Ct.
Qed.

Fixpoint w_rule_sub_ptree_fit
  (P : ptree) (E : formula) (n : nat) (c : c_term) (S : subst_ind) : ptree :=
match P, S with
| deg_up d P', _ => deg_up d (w_rule_sub_ptree_fit P' E n c S)

| ord_up alpha P', _ => ord_up alpha (w_rule_sub_ptree_fit P' E n c S)

| node A, _ => P

| exchange_ab A B d alpha P', lor_ind S_B S_A =>
    exchange_ab
      (w_rule_sub_formula A E n c S_A)
      (w_rule_sub_formula B E n c S_B)
      d alpha
      (w_rule_sub_ptree_fit P' E n c (lor_ind S_A S_B))

| exchange_cab C A B d alpha P', lor_ind (lor_ind S_C S_B) S_A =>
    exchange_cab
      (w_rule_sub_formula C E n c S_C)
      (w_rule_sub_formula A E n c S_A)
      (w_rule_sub_formula B E n c S_B)
      d alpha
      (w_rule_sub_ptree_fit P' E n c (lor_ind (lor_ind S_C S_A) S_B))

| exchange_abd A B D d alpha P', lor_ind (lor_ind S_B S_A) S_D =>
    exchange_abd
      (w_rule_sub_formula A E n c S_A)
      (w_rule_sub_formula B E n c S_B)
      (w_rule_sub_formula D E n c S_D)
      d alpha
      (w_rule_sub_ptree_fit P' E n c (lor_ind (lor_ind S_A S_B) S_D))

| exchange_cabd C A B D d alpha P', lor_ind (lor_ind (lor_ind S_C S_B) S_A) S_D =>
    exchange_cabd
      (w_rule_sub_formula C E n c S_C)
      (w_rule_sub_formula A E n c S_A)
      (w_rule_sub_formula B E n c S_B)
      (w_rule_sub_formula D E n c S_D)
      d alpha
      (w_rule_sub_ptree_fit
        P' E n c
        (lor_ind (lor_ind (lor_ind S_C S_A) S_B) S_D))

| contraction_a A d alpha P', _ =>
    contraction_a
      (w_rule_sub_formula A E n c S)
      d alpha
      (w_rule_sub_ptree_fit P' E n c (lor_ind S S))

| contraction_ad A D d alpha P', lor_ind S_A S_D =>
    contraction_ad
      (w_rule_sub_formula A E n c S_A)
      (w_rule_sub_formula D E n c S_D)
      d alpha
      (w_rule_sub_ptree_fit P' E n c (lor_ind (lor_ind S_A S_A) S_D))

| weakening_ad A D d alpha P', lor_ind S_A S_D =>
    weakening_ad
      (w_rule_sub_formula A E n c S_A)
      (w_rule_sub_formula D E n c S_D)
      d alpha
      (w_rule_sub_ptree_fit P' E n c S_D)

| demorgan_ab A B d1 d2 alpha1 alpha2 P1 P2, _ => P

| demorgan_abd A B D d1 d2 alpha1 alpha2 P1 P2, lor_ind S_AB S_D =>
    demorgan_abd
      A B
      (w_rule_sub_formula D E n c S_D)
      d1 d2 alpha1 alpha2
      (w_rule_sub_ptree_fit P1 E n c (lor_ind (0) S_D))
      (w_rule_sub_ptree_fit P2 E n c (lor_ind (0) S_D))

| negation_a A d alpha P', _ => P

| negation_ad A D d alpha P', lor_ind S_A S_D =>
    negation_ad
      A
      (w_rule_sub_formula D E n c S_D)
      d alpha
      (w_rule_sub_ptree_fit P' E n c (lor_ind (non_target A) S_D))

| quantification_a A k t d alpha P', _ => P

| quantification_ad A D k t d alpha P', lor_ind S_A S_D =>
    quantification_ad
      A
      (w_rule_sub_formula D E n c S_D)
      k t d alpha
      (w_rule_sub_ptree_fit P' E n c (lor_ind (0) S_D))

| w_rule_a A k d alpha g, _ =>
    (match form_eqb A E, nat_eqb d (ptree_deg (g c)), nat_eqb k n, S with
    | true, true, true, (1) => ord_up (ord_succ alpha) (g c)
    | true, false, true, (1) => deg_up d (ord_up (ord_succ alpha) (g c))
    | _, _, _, _ => P
    end)

| w_rule_ad A D k d alpha g, lor_ind S_A S_D =>
    (match form_eqb A E, nat_eqb d (ptree_deg (g c)), nat_eqb k n, S_A with
    | true, true, true, (1) =>
        ord_up (ord_succ alpha) (w_rule_sub_ptree_fit (g c) E n c (lor_ind (non_target A) S_D))
    | true, false, true, (1) =>
        deg_up d (ord_up (ord_succ alpha) (w_rule_sub_ptree_fit (g c) E n c (lor_ind (non_target A) S_D)))

    | _, _, _, _ =>
        w_rule_ad
          A
          (w_rule_sub_formula D E n c S_D)
          k d alpha
          (fun (t : c_term) =>
            w_rule_sub_ptree_fit (g t) E n c (lor_ind (non_target A) S_D))
    end)

| cut_ca C A d1 d2 alpha1 alpha2 P1 P2, _ =>
    cut_ca
      (w_rule_sub_formula C E n c S)
      A d1 d2 alpha1 alpha2
      (w_rule_sub_ptree_fit P1 E n c (lor_ind S (non_target A)))
      P2

| cut_ad A D d1 d2 alpha1 alpha2 P1 P2, _ =>
    cut_ad
      A
      (w_rule_sub_formula D E n c S)
      d1 d2 alpha1 alpha2
      P1
      (w_rule_sub_ptree_fit P2 E n c (lor_ind (0) S))

| cut_cad C A D d1 d2 alpha1 alpha2 P1 P2, lor_ind S_C S_D =>
    cut_cad
      (w_rule_sub_formula C E n c S_C)
      A
      (w_rule_sub_formula D E n c S_D)
      d1 d2 alpha1 alpha2
      (w_rule_sub_ptree_fit P1 E n c (lor_ind S_C (non_target A)))
      (w_rule_sub_ptree_fit P2 E n c (lor_ind (0) S_D))

| _, _ => P
end.

Definition w_rule_sub_ptree
  (P : ptree) (E : formula) (n : nat) (c : c_term) (S : subst_ind) : ptree :=
match subst_ind_fit (ptree_formula P) S with
| false => P
| true => w_rule_sub_ptree_fit P E n c S
end.

Lemma w_rule_ptree_formula_true :
    forall (P : ptree) (E : formula) (n : nat) (c : c_term) (S : subst_ind),
        subst_ind_fit (ptree_formula P) S = true ->
            w_rule_sub_ptree_fit P E n c S = w_rule_sub_ptree P E n c S.
Proof.
intros P E n c S FS.
unfold w_rule_sub_ptree.
rewrite FS.
reflexivity.
Qed.

Lemma w_rule_ptree_formula' :
    forall (P : ptree) (E : formula) (n : nat) (c : c_term),
        valid P ->
            forall (S : subst_ind),
                subst_ind_fit (ptree_formula P) S = true ->
                    ptree_formula (w_rule_sub_ptree P E n c S) =
                        w_rule_sub_formula (ptree_formula P) E n c S.
Proof.
intros P E n c.
induction P; try intros PV S FS;
unfold w_rule_sub_ptree;
rewrite FS;
unfold ptree_formula in *; fold ptree_formula in *;
unfold w_rule_sub_ptree_fit; fold w_rule_sub_ptree_fit.

1 : destruct PV as [ID PV].
2 : destruct PV as [[IO PV] NO].

1-2 : rewrite (w_rule_ptree_formula_true _ _ _ _ _ FS);
      unfold ptree_formula; fold ptree_formula;
      apply (IHP PV _ FS).

1 : { inversion PV as [PX].
      unfold w_rule_sub_ptree, w_rule_sub_formula, formula_sub_ind.
      rewrite FS.
      unfold ptree_formula; fold ptree_formula.
      destruct (axiom_atomic _ PX) as [[a fa] | [a fa]];
      rewrite fa;
      unfold formula_sub_ind_fit; fold formula_sub_ind_fit;
      unfold form_eqb;
      reflexivity. }

all : destruct S; inversion FS as [FS'];
      try reflexivity.

1,5,6,13 :  apply and_bool_prop in FS';
            destruct FS' as [FS1 FS2];
            unfold ptree_formula, w_rule_sub_formula, formula_sub_ind, formula_sub_ind_fit;
            fold formula_sub_ind_fit;
            rewrite FS,FS1,FS2;
            reflexivity.

9 : destruct (PV c) as [[[PF PCV ] PD] PO];
    assert (subst_ind_fit (ptree_formula (p c)) (lor_ind (non_target f) S2) = true) as FSP.
9 : { rewrite PF.
      unfold subst_ind_fit; fold subst_ind_fit.
      rewrite non_target_sub_fit.
      unfold "&&".
      destruct S1;
      try inversion FS' as [FS''];
      reflexivity. }

8 : { destruct (PV c) as [[[PF PCV ] PD] PO].
      case (form_eqb f E) eqn:EQ1;
      case (nat_eqb n0 n) eqn:EQ2;
      case (nat_eqb n1 (ptree_deg (p c))) eqn:E3;
      unfold ptree_formula, w_rule_sub_formula;
      fold ptree_formula;
      try rewrite PF;
      try apply form_eqb_eq in EQ1;
      try rewrite EQ1;
      try apply nat_eqb_eq in EQ2;
      try rewrite EQ2;
      try rewrite (formula_sub_ind_1 _ _ FS);
      unfold formula_sub_ind, subst_ind_fit, formula_sub_ind_fit, form_eqb;
      fold form_eqb;
      try rewrite nat_eqb_refl;
      try rewrite form_eqb_refl;
      try rewrite EQ1;
      try rewrite EQ2;
      unfold "&&";
      try reflexivity. }

7 : { case (form_eqb f E) eqn:EQ1;
      case (nat_eqb n0 n) eqn:EQ2;
      case (nat_eqb n1 (ptree_deg (p c))) eqn:E3;
      unfold ptree_formula, w_rule_sub_formula;
      fold ptree_formula;
      try rewrite formula_sub_ind_0;
      try reflexivity. }

all : destruct S1; inversion FS' as [FS''].

1-3 : apply and_bool_prop in FS';
      destruct FS' as [FS1 FS2];
      apply and_bool_prop in FS1;
      destruct FS1 as [FS1_1 FS1_2].

3 : destruct S1_1; inversion FS'' as [FS'''];
    apply and_bool_prop in FS1_1;
    destruct FS1_1 as [FS1_1_1 FS1_1_2].

10,11 : case (form_eqb f E) eqn:EQ1;
        case (nat_eqb n0 n) eqn:EQ2;
        case (nat_eqb n1 (ptree_deg (p c))) eqn:E3.

all : unfold ptree_formula, w_rule_sub_formula, formula_sub_ind, formula_sub_ind_fit, form_eqb;
      fold ptree_formula form_eqb formula_sub_ind_fit;
      try rewrite FS;
      try rewrite FS'';
      try rewrite EQ1;
      try rewrite EQ2;
      try rewrite FS1_1,FS1_2,FS2;
      try rewrite FS1_1_1,FS1_1_2,FS1_2,FS2;
      unfold "&&";
      try reflexivity.

all : apply form_eqb_eq in EQ1;
      destruct EQ1;
      apply nat_eqb_eq in EQ2;
      destruct EQ2;
      rewrite (w_rule_ptree_formula_true _ _ _ _ _ FSP);
      rewrite (H _ PCV _ FSP);
      rewrite PF in *;
      unfold w_rule_sub_formula, formula_sub_ind, formula_sub_ind_fit;
      fold formula_sub_ind_fit;
      rewrite FSP;
      rewrite (non_target_term_sub _ n0 (projT1 c));
      rewrite non_target_sub';
      reflexivity.
Qed.

Lemma w_rule_ptree_formula :
    forall (P : ptree) (E : formula) (n : nat) (c : c_term),
        valid P ->
            forall (S : subst_ind),
                ptree_formula (w_rule_sub_ptree P E n c S) =
                    w_rule_sub_formula (ptree_formula P) E n c S.
Proof.
intros P E n c VP S.
destruct (subst_ind_fit (ptree_formula P) S) eqn:FS.
- apply (w_rule_ptree_formula' _ _ _ _ VP _ FS).
- unfold w_rule_sub_ptree, w_rule_sub_formula, formula_sub_ind.
  rewrite FS.
  reflexivity.
Qed.

Lemma w_rule_ptree_deg :
    forall (P : ptree) (E : formula) (n : nat) (c : c_term),
        valid P ->
            forall (S : subst_ind),
                ptree_deg (w_rule_sub_ptree P E n c S) = ptree_deg P.
Proof.
intros P E n c PV.
unfold w_rule_sub_ptree.
pose (ptree_formula P) as A.
induction P; intros S;
case (subst_ind_fit A S) eqn:FS;
unfold A in FS;
try rewrite FS;
unfold w_rule_sub_ptree_fit; fold w_rule_sub_ptree_fit;
unfold ptree_deg in *; fold ptree_deg in *;
try reflexivity.

1 : destruct PV as [[IO PV] NO].

11,12 : destruct (PV c) as [[[PF PCV] PD] PO].

1 : unfold ptree_formula in FS; fold ptree_formula in FS.
    pose proof (IHP PV S) as IHPS.
    rewrite FS in IHPS.
    apply IHPS.

all : destruct S; inversion FS as [FS'];
      try reflexivity.

4-6 : case (form_eqb f E) eqn:EQ1;
      case (nat_eqb n0 n) eqn:EQ2;
      case (nat_eqb n1 (ptree_deg (p c))) eqn:EQ3;
      unfold ptree_deg; fold ptree_deg;
      try apply form_eqb_eq in EQ1;
      try destruct EQ1;
      try apply nat_eqb_eq in EQ2,EQ3;
      try rewrite EQ3;
      try reflexivity.

all : destruct S1; inversion FS' as [FS''].

3 : destruct S1_1; inversion FS'' as [FS'''].

all : unfold ptree_deg; fold ptree_deg;
      try reflexivity.

- assert (subst_ind_fit (ptree_formula (p c)) (lor_ind (non_target f) S2) = true) as FSP.
  { rewrite PF.
    unfold subst_ind_fit; fold subst_ind_fit.
    rewrite non_target_sub_fit.
    unfold "&&".
    apply FS''. }
  pose proof (H _ PCV (lor_ind (non_target f) S2)) as IHPS.
  rewrite FSP in IHPS.
  apply IHPS.
Qed.

Lemma w_rule_ptree_ord :
    forall (P : ptree) (E : formula) (n : nat) (c : c_term),
        valid P ->
            forall (S : subst_ind),
                ptree_ord (w_rule_sub_ptree P E n c S) = ptree_ord P.
Proof.
intros P E n c PV.
unfold w_rule_sub_ptree.
pose (ptree_formula P) as A.
induction P; intros S;
case (subst_ind_fit A S) eqn:FS;
unfold A in FS;
try rewrite FS;
unfold w_rule_sub_ptree_fit; fold w_rule_sub_ptree_fit;
unfold ptree_ord in *; fold ptree_ord in *;
try reflexivity.

1 : destruct PV as [ID PV].

11,12 : destruct (PV c) as [[[PF PCV] PD] PO].

1 : unfold ptree_formula in FS; fold ptree_formula in FS.
    pose proof (IHP PV S) as IHPS.
    rewrite FS in IHPS.
    apply IHPS.

all : destruct S; inversion FS as [FS'];
      try reflexivity.

4-6 : case (form_eqb f E) eqn:EQ1;
      case (nat_eqb n0 n) eqn:EQ2;
      case (nat_eqb n1 (ptree_deg (p c))) eqn:EQ3;
      unfold ptree_deg; fold ptree_deg;
      try apply form_eqb_eq in EQ1;
      try destruct EQ1;
      try apply nat_eqb_eq in EQ2,EQ3;
      try apply EQ3;
      try reflexivity.

all : destruct S1; inversion FS' as [FS''].

3 : destruct S1_1; inversion FS'' as [FS'''].

all : unfold ptree_deg; fold ptree_deg;
      try reflexivity.
Qed.

Lemma w_rule_valid :
    forall (P : ptree) (E : formula) (n : nat) (c : c_term),
        valid P ->
            forall (S : subst_ind),
                subst_ind_fit (ptree_formula P) S = true ->
                    valid (w_rule_sub_ptree P E n c S).
Proof.
intros P E n c PV.
induction P; try intros S FS;
unfold w_rule_sub_ptree;
rewrite FS;
unfold ptree_formula in *; fold ptree_formula in *;
unfold w_rule_sub_ptree_fit; fold w_rule_sub_ptree_fit.

all : try apply PV.

1 : destruct PV as [ID PV].
2 : destruct PV as [[IO PV] NO].
3-8 : destruct PV as [[[PF PV] PD] PO].
9 : destruct PV as [[[[PF FC] PV] PD] PO].
11-12 : destruct PV as [[[PF PV] PD] PO].
10,15,16,17: destruct PV as [[[[[[[P1F P1V] P2F] P2V] P1D] P2D] P1O] P2O].

3,4,5,6,8,9,10,13,14,15,16,17 : destruct S; inversion FS as [FS'];
                                try destruct (and_bool_prop _ _ FS') as [FS1 FS2].

15 :  assert (valid (w_rule_ad f (w_rule_sub_formula f0 E n c S2) n0 n1 o (fun t : c_term => w_rule_sub_ptree_fit (p t) E n c (lor_ind (non_target f) S2)))) as VSC.
15 :  { assert (forall t, subst_ind_fit (ptree_formula (p t)) (lor_ind (non_target f) S2) = true) as FSt.
        { intros t.
          destruct (PV t) as [[[PF PTV] PD] PO].
          rewrite PF.
          unfold subst_ind_fit; fold subst_ind_fit.
          rewrite non_target_sub_fit.
          unfold "&&".
          apply FS2. }
        repeat split;
        destruct (PV t) as [[[PF PTV] PD] PO];
        rewrite (w_rule_ptree_formula_true _ _ _ _ _ (FSt t)).
        - rewrite (w_rule_ptree_formula _ _ _ _ PTV).
          rewrite PF.
          unfold w_rule_sub_formula.
          rewrite (non_target_term_sub _ n0 (projT1 t)).
          rewrite non_target_sub_lor.
          reflexivity.
        - apply (X _ PTV _ (FSt t)).
        - rewrite (w_rule_ptree_deg _ _ _ _ PTV).
          apply PD.
        - rewrite (w_rule_ptree_ord _ _ _ _ PTV).
          apply PO. }

4,5,6,15 :  destruct S1; inversion FS' as [FS''];
            try destruct (and_bool_prop _ _ FS1) as [FS1_1 FS1_2].

6 : destruct S1_1; inversion FS'' as [FS'''];
    destruct (and_bool_prop _ _ FS1_1) as [FS1_1_1 FS1_1_2].

10 :  assert (closed (univ n E) = true -> closed (substitution E n (projT1 c)) = true) as CIMP.
10 :  { intros CE.
        apply (closed_univ_sub _ _ CE).
        destruct c as [t Ct].
        apply Ct. }

7,8,15,16 : destruct (PV c) as [[[PF PCV] PD] PO].

9,10 :  case (form_eqb f E) eqn:EQ1;
        case (nat_eqb n0 n) eqn:EQ2;
        case (nat_eqb n1 (ptree_deg (p c))) eqn:EQ3;
        try apply PV;
        repeat split;
        try rewrite PO;
        unfold ptree_deg;fold ptree_deg;
        try apply ord_succ_monot;
        try apply ord_succ_nf;
        try apply ptree_ord_nf;
        try apply PCV;
        inversion PD as [EQ4 | ];
        try destruct EQ4;
        try rewrite nat_eqb_refl in EQ3;
        inversion EQ3;
        try lia.

7,8 : case (form_eqb f E) eqn:EQ1;
      case (nat_eqb n0 n) eqn:EQ2;
      case (nat_eqb n1 (ptree_deg (p c))) eqn:EQ3;
      try apply VSC.

all : try apply form_eqb_eq in EQ1;
      try destruct EQ1;
      repeat rewrite w_rule_ptree_formula_true;
      repeat split;
      try apply IHP;
      try apply IHP1;
      try apply IHP2;
      unfold ptree_deg; fold ptree_deg;
      try rewrite w_rule_ptree_deg;
      try rewrite w_rule_ptree_ord;
      try rewrite w_rule_ptree_formula;
      try rewrite PF;
      try rewrite P1F;
      try rewrite P2F;
      unfold w_rule_sub_formula, formula_sub_ind;
      try apply PV;
      try rewrite PD;
      try rewrite PO;
      try apply P1V;
      try rewrite P1D;
      try rewrite P1O;
      try apply P2V;
      try rewrite P2D;
      try rewrite P2O;
      try apply ID;
      try apply IO;
      try apply NO;
      try apply (X _ PCV);
      try rewrite PF;
      unfold subst_ind_fit; fold subst_ind_fit;
      try rewrite non_target_fit;
      try rewrite non_target_sub_fit;
      try rewrite FS;
      try rewrite FS';
      try rewrite FS'';
      try rewrite FS1;
      try rewrite FS1_1;
      try rewrite FS1_2;
      try rewrite FS1_1_1;
      try rewrite FS1_1_2;
      try rewrite FS2;
      unfold "&&";
      unfold formula_sub_ind_fit; fold formula_sub_ind_fit;
      unfold form_eqb; fold form_eqb;
      try rewrite non_target_sub';
      try rewrite <- (sub_fit_true _ _ _ _ FS1);
      try apply (formula_sub_ind_closed _ _ _ FC CIMP);
      try apply ord_succ_monot;
      try apply nf_nf_succ;
      try apply ptree_ord_nf;
      try apply PCV;
      unfold subst_ind_fit; fold subst_ind_fit;
      try reflexivity.
      inversion PD as [EQ4 | ];
      try destruct EQ4;
      try rewrite nat_eqb_refl in EQ3;
      try lia.
Qed.


Set Implicit Arguments.

Require Import DecidableTypeEx.

(**************************************************)
(** * Abstract Definition of Variables *)
(**************************************************)

Module Type GenericVarSig := UsualDecidableType.

(** Decidable sets are the basis for variables used for the abstraction
   or quantification *)

Module Type QuantificationVarSig := MiniDecidableType.

Module GVar_to_Quant (M:GenericVarSig) <: QuantificationVarSig := M.

(** Disjoint union of two usually decidable sets is usually decidable.
   This kind of decidable sets will be used when two kinds of variables
   are used for the formalization. *)

Module DisjUnionUsualDecidableType(D1 D2:GenericVarSig) <: GenericVarSig.

  Definition t := sum D1.t D2.t.

  Definition eq := @eq t.

  Definition eq_refl := @refl_equal t.

  Definition eq_sym := @sym_eq t.

  Definition eq_trans := @trans_eq t.

  Definition eq_dec : forall x y : t, {x = y}+{x <> y}.
  Proof.
    decide equality; [apply D1.eq_dec | apply D2.eq_dec].
  Qed.

End DisjUnionUsualDecidableType.


Set Implicit Arguments.
Require Import LibLN Main_ott Main_Infra Main_Proofs.
Implicit Types x : var.
Implicit Types G : env.

Inductive _typing : env -> trm -> trm -> Prop :=
  | _typing_star : forall G,
      _wf G -> _typing G trm_star trm_star
  | _typing_var : forall e G x A,
      _wf G -> binds x (bind_sub e A) G -> _typing G (trm_var_f x) A
  | _typing_top : forall G A,
      _typing G A trm_star -> _typing G trm_top A
  | _typing_lam : forall L G e1 e2 A B,
      _typing G e1 A ->
      _typing G A trm_star ->
      (forall x, x \notin L ->
                 _typing (G & x ~ bind_sub e1 A) (B ^ x) trm_star) ->
      (forall x, x \notin L ->
                 _typing (G & x ~ bind_sub e1 A) (e2 ^ x) (B ^ x)) ->
      _typing G (trm_abs e1 A e2) (trm_prod e1 A B)
  | _typing_app : forall e3 G e A B C,
      _typing G A B ->
      _sub G A e3 ->
      _typing G e (trm_prod e3 B C) ->
      _typing G (trm_app e A) (C ^^ A)
  | _typing_pi : forall L G e A B,
      _typing G e A ->
      _typing G A trm_star ->
      (forall x, x \notin L ->
        _typing (G & x ~ bind_sub e A) (B ^ x) trm_star) ->
      _typing G (trm_prod e A B) trm_star
  | _typing_castup : forall G e A B,
      _typing G B trm_star ->
      _typing G e A ->
      reduct B A ->
      _typing G (trm_castup B e) B
  | _typing_castdn : forall G e A B,
      _typing G B trm_star ->
      _typing G e A ->
      reduct A B ->
      _typing G (trm_castdn e) B
  | _typing_sub : forall A G e B,
      _typing G e A ->
      _sub G A B ->
      _typing G B trm_star ->
      _typing G e B

with _wf : env -> Prop :=
  | _wf_nil : _wf empty
  | _wf_cons : forall G x e A,
      x # G ->
      _typing G e A ->
      _typing G A trm_star ->
      _wf (G & x ~ bind_sub e A)

with _sub : env -> trm -> trm -> Prop :=
  | _sub_star : forall G, _wf G -> _sub G trm_star trm_star
  | _sub_var_refl : forall G x e A,
      _wf G -> binds x (bind_sub e A) G -> _sub G (trm_var_f x) (trm_var_f x)
  | _sub_var_trans : forall e1 A G x e2,
      binds x (bind_sub e1 A) G -> _sub G e1 e2 ->
      _sub G (trm_var_f x) e2
  | _sub_top : forall G e,
      _wf G -> lc_trm e -> _sub G e trm_top
  | _sub_top_refl : forall G,
      _wf G -> _sub G trm_top trm_top
  | _sub_lam : forall L G e1 e2 e3 A,
      _typing G e3 A ->
      _typing G A trm_star ->
      (forall x, x \notin L -> _sub (G & x ~ bind_sub e3 A) (e1 ^ x) (e2 ^ x)) ->
      _sub G (trm_abs e3 A e1) (trm_abs e3 A e2)
  | _sub_app : forall G e1 e2 A,
      lc_trm A ->
      _sub G e1 e2 -> _sub G (trm_app e1 A) (trm_app e2 A)
  | _sub_pi : forall L G e A B C D,
      _typing G e C ->
      _typing G C trm_star ->
      _sub G C A ->
      (forall x, x \notin L -> _sub (G & x ~ bind_sub e C) (B ^ x) (D ^ x)) ->
      _sub G (trm_prod e A B) (trm_prod e C D)
  | _sub_castup : forall G A e1 e2,
      lc_trm A -> _sub G e1 e2 -> _sub G (trm_castup A e1) (trm_castup A e2)
  | _sub_castdn : forall G e1 e2,
      _sub G e1 e2 -> _sub G (trm_castdn e1) (trm_castdn e2).

Hint Constructors _typing _sub _wf.

Scheme typing_induct := Induction for _typing Sort Prop
  with twf_induct := Induction for _wf Sort Prop
  with tsub_induct := Induction for _sub Sort Prop.

Lemma regular_typing : forall E t T, _typing E t T ->
  (_wf E /\ ok E /\ contains_terms E /\ lc_trm t /\ lc_trm T).
Proof.
  apply typing_induct with
  (P0 := fun E (_ : _wf E) => ok E /\ contains_terms E)
  (P1 := fun E t1 t2 (_: _sub E t1 t2) => _wf E /\ ok E /\ contains_terms E /\ lc_trm t2);
    unfolds contains_terms; intros; splits*.
  destructs H. lets: H0 b. jauto.
  intros. false* (binds_empty_inv).
  intros. destruct (binds_push_inv H1) as [[? P]|[? ?]]; try (inversions P); subst*.
  destructs H. apply* H5.
Qed.

Lemma regular_tsub : forall E t T, _sub E t T ->
  (_wf E /\ ok E /\ contains_terms E /\ lc_trm t /\ lc_trm T).
Proof.
  apply tsub_induct with
  (P0 := fun E (_ : _wf E) => ok E /\ contains_terms E)
  (P := fun E t1 t2 (_: _typing E t1 t2) => _wf E /\ ok E /\ contains_terms E /\ lc_trm t1 /\lc_trm t2);
   unfolds contains_terms; intros; splits*.
  destructs H. lets: H0 b. jauto.
  intros. false* (binds_empty_inv).
  intros. destruct (binds_push_inv H1) as [[? P]|[? ?]]; try (inversions P); subst*.
  destructs H. apply* H5.
Qed.

Hint Extern 1 (lc_trm ?t) => match goal with
  | H: _typing _ t _ |- _ => apply (proj32 (proj33 (regular_typing H)))
  | H: _typing _ _ t |- _ => apply (proj33 (proj33 (regular_typing H)))
  | H: _sub _ t _ |- _ => apply (proj32 (proj33 (regular_tsub H)))
  | H: _sub _ _ t |- _ => apply (proj33 (proj33 (regular_tsub H)))
  end.

Lemma ok_from_twf : forall E, _wf E -> ok E.
Proof.
  induction 1. auto. autos* (regular_typing H0).
Qed.

Hint Extern 1 (ok ?E) => match goal with
  | H: _wf E |- _ => apply (ok_from_twf H)
  end.

Hint Extern 1 (_wf ?E) => match goal with
  | H: _typing E _ _ |- _ => apply (proj1 (regular_typing H))
  | H: _sub E _ _ |- _ => apply (proj1 (regular_tsub H))
  end.

Lemma twf_push_inv : forall E x T U,
  _wf (E & x ~ bind_sub T U) -> _wf E /\ lc_trm T /\ lc_trm U.
Proof.
  introv W. inversions W.
  false (empty_push_inv H0).
  destruct (eq_push_inv H) as [? [? ?]]. inversions H4. subst~.
Qed.

Lemma term_from_binds_in_twf : forall x E T U,
  _wf E -> binds x (bind_sub T U) E -> lc_trm T /\ lc_trm U.
Proof.
  introv W Has. gen E. induction E using env_ind; intros.
  false* binds_empty_inv.
  induction v.
  destruct (twf_push_inv W).
  destruct (binds_push_inv Has) as [[? ?] | [? ?]].
  inversion H2. subst*.
  apply* IHE.
Qed.

Lemma term_from_binds_in_twf_left : forall x E T U,
  _wf E -> binds x (bind_sub T U) E -> lc_trm T.
Proof.
  intros. destruct~ (term_from_binds_in_twf H H0).
Qed.

Lemma term_from_binds_in_twf_right : forall x E T U,
  _wf E -> binds x (bind_sub T U) E -> lc_trm U.
Proof.
  intros. destruct~ (term_from_binds_in_twf H H0).
Qed.

Hint Extern 1 (lc_trm ?t) => match goal with
  | H: binds ?x (bind_sub t ?t2) ?E |- _ => apply (@term_from_binds_in_twf_left x E)
  | H: binds ?x (bind_sub ?t2 t) ?E |- _ => apply (@term_from_binds_in_twf_right x E)
  end.

Lemma twf_left : forall E F : env,
  _wf (E & F) -> _wf E.
Proof.
  intros. induction F using env_ind.
  rewrite~ concat_empty_r in H.
  rewrite concat_assoc in H.
   inversions H. false (empty_push_inv H1).
   destruct (eq_push_inv H0) as [? [? ?]]. subst~.
Qed.

Implicit Arguments twf_left [E F].

Lemma typing_fresh : forall E T U x,
  _typing E T U -> x # E -> x \notin fv T.
Proof.
  introv Typ.
  induction Typ; simpls; intros; try solve [eauto 4].
  rewrite notin_singleton. intro. subst. applys binds_fresh_inv H0 H1.
  pick_fresh y. notin_simpl; auto. apply* (@fv_open_var y).
  pick_fresh y. notin_simpl; auto. apply* (@fv_open_var y).
Qed.

Lemma notin_fv_from_twf : forall E F x U V,
  _wf (E & x ~ bind_sub U V & F) -> x \notin fv U /\ x \notin fv V.
Proof.
  intros.
  lets W: (twf_left H). inversions W.
  false (empty_push_inv H1).
  destruct (eq_push_inv H0) as [? [P ?]]. inversions P.
  split; apply* typing_fresh.
Qed.

Hint Extern 1 (?x \notin fv ?U) =>
  match goal with H: _wf (?E & x ~ (bind_sub U ?V) & ?F) |- _ =>
    apply (proj1 (notin_fv_from_twf H)) end.

Hint Extern 1 (?x \notin fv ?V) =>
  match goal with H: _wf (?E & x ~ (bind_sub ?U V) & ?F) |- _ =>
    apply (proj2 (notin_fv_from_twf H)) end.

Lemma notin_fv_from_tbinds : forall x y T U E,
  _wf E -> binds y (bind_sub T U) E -> x # E -> x \notin fv T /\ x \notin fv U.
Proof.
  induction E using env_ind; intros.
  false* binds_empty_inv.
  induction v.
  destruct (twf_push_inv H).
    destruct (binds_push_inv H0) as [[? ?] | [? ?]].
    inversion H5. subst. inversions H. false* (empty_push_inv H6).
     destruct (eq_push_inv H4) as [? [? ?]].  inversion H9. subst~.
     split; apply* typing_fresh.
    autos*.
Qed.

Lemma notin_fv_from_tbinds_left : forall x y T U E,
  _wf E -> binds y (bind_sub T U) E -> x # E -> x \notin fv T.
Proof.
  introv A B C. destructs~ (notin_fv_from_tbinds A B C).
Qed.

Lemma notin_fv_from_tbinds_right : forall x y T U E,
  _wf E -> binds y (bind_sub T U) E -> x # E -> x \notin fv U.
Proof.
  introv A B C. destructs~ (notin_fv_from_tbinds A B C).
Qed.

Lemma notin_fv_from_tbinds' : forall E F x V y U1 U2,
  _wf (E & x ~ V & F) ->
  binds y (bind_sub U1 U2) E ->
  x \notin fv U1 /\ x \notin fv U2.
Proof.
  intros. lets W: (twf_left H). inversions keep W.
  false (empty_push_inv H2).
  induction V.
  destruct (eq_push_inv H1) as [? [P ?]]. inversion P. subst~.
  lets W': (twf_left W). apply* notin_fv_from_tbinds.
Qed.

Hint Extern 1 (?x \notin fv ?U1) =>
  match goal with H: _wf (?E & x ~ ?V & ?F), B: binds ?y (bind_sub U1 ?U2) ?E |- _ =>
    apply (proj1 (notin_fv_from_tbinds' H B)) end.

Hint Extern 1 (?x \notin fv ?U2) =>
  match goal with H: _wf (?E & x ~ ?V & ?F), B: binds ?y (bind_sub ?U1 U2) ?E |- _ =>
    apply (proj2 (notin_fv_from_tbinds' H B)) end.

Lemma tsub_fresh : forall E A B x,
  _sub E A B -> x # E -> x \notin fv A -> x \notin fv B.
Proof.
  introv S. induction S; simpls; intros; try solve [eauto 3].
  apply* IHS. rewrite notin_singleton in *. apply* notin_fv_from_tbinds_left.
  notin_simpl; auto; try solve [apply* typing_fresh].
    pick_fresh y. apply~ (@fv_open_var y). apply* H2.
    apply* fv_close_var.
  notin_simpl; auto; try solve [apply* typing_fresh].
    pick_fresh y. apply~ (@fv_open_var y). apply* H2.
    apply* fv_close_var.
Qed.

Lemma typing_fresh_all : forall E T U x,
  _typing E T U -> x # E -> x \notin fv T /\ x \notin fv U.
Proof.
  introv Typ.
  induction Typ; simpls; intros; try solve [splits*].
  splits. rewrite notin_singleton. intro. subst. applys binds_fresh_inv H0 H1.
    apply* notin_fv_from_tbinds_right.
  destructs~ IHTyp1. destructs~ IHTyp2.
    pick_fresh y. split; notin_simpl; auto.
    apply* (@fv_open_var y). apply* H2.
    apply* (@fv_open_var y). apply* H2.
  destructs~ IHTyp1. destructs~ IHTyp2.
    split; notin_simpl; auto. apply* fv_open_term.
  destructs~ IHTyp1. destructs~ IHTyp2.
    pick_fresh y. split; notin_simpl; auto.
    apply* (@fv_open_var y). apply* H0.
  (* splits*. apply* tsub_fresh. *)
Qed.

Lemma typing_fresh_typ : forall E T U x,
  _typing E T U -> x # E -> x \notin fv U.
Proof.
  introv P Q. destructs~ (typing_fresh_all P Q).
Qed.

Lemma tsub_weaken : forall G E F t T,
  _sub (E & G) t T ->
  _wf (E & F & G) ->
  _sub (E & F & G) t T
with typing_weaken : forall G E F t T,
  _typing (E & G) t T ->
  _wf (E & F & G) ->
  _typing (E & F & G) t T.
Proof.
  clear tsub_weaken.
  introv Typ. gen_eq Env: (E & G). gen G.
  induction Typ; introv EQ W; subst; eauto.
  (* case: var *)
  apply* _sub_var_refl. apply* binds_weaken.
  (* case: trans *)
  apply* (@_sub_var_trans e1 A). apply* binds_weaken.
  (* case: trm_abs *)
  apply_fresh* (@_sub_lam) as y.
  apply_ih_bind* H2.
  (* case: trm_prod *)
  apply_fresh* (@_sub_pi) as y. apply_ih_bind* H2.

  clear typing_weaken.
  introv Typ. gen_eq Env: (E & G). gen G.
  induction Typ; introv EQ W; subst; eauto.
  (* case: var *)
  apply* _typing_var. apply* binds_weaken.
  (* case: trm_abs *)
  apply_fresh* (@_typing_lam) as y.
  forwards TypP: (IHTyp1 G0); auto.
  apply_ih_bind* H0. apply_ih_bind* H2.
  (* case: trm_prod *)
  apply_fresh* (@_typing_pi) as y. apply_ih_bind* H0.
Qed.

Lemma tsub_refl : forall G t T,
  _typing G t T -> _sub G t t.
Proof.
  intros. inductions H; eauto.
Qed.

Lemma typing_wf_from_context : forall x T U (E:env),
  binds x (bind_sub T U) E ->
  _wf E ->
  _typing E T U /\
  _typing E U trm_star.
Proof.
  introv B W. induction E using env_ind.
  false* binds_empty_inv.
  destruct (binds_push_inv B) as [[? ?]|[? ?]].
    subst. inversions W. false (empty_push_inv H0).
     destruct (eq_push_inv H) as [? [P ?]]. inversions P. subst.
     split; apply_empty* typing_weaken.
    induction v.
    destruct (twf_push_inv W).
     split; apply_empty* typing_weaken.
Qed.

Lemma typing_wf_from_twf : forall G x e A,
  _wf (G & x ~ bind_sub e A) -> _typing G e A /\ _typing G A (trm_star).
Proof.
  intros. inversions H.
  false. apply* empty_push_inv.
  destruct (eq_push_inv H0) as [? [? ?]]. inversion H4. subst*.
Qed.

Lemma typing_narrowing_typ : forall Q B A F x E C e,
  _typing (E & x ~ bind_sub Q B & F) e C ->
  _sub E A B ->
  _wf (E & x ~ bind_sub Q A & F) ->
  _typing (E & x ~ bind_sub Q A & F) e C
with tsub_narrowing_typ : forall Q B A F x E e1 e2,
  _sub (E & x ~ bind_sub Q B & F) e1 e2 ->
  _sub E A B ->
  _wf (E & x ~ bind_sub Q A & F) ->
  _sub (E & x ~ bind_sub Q A & F) e1 e2.
Proof.
  clear typing_narrowing_typ.
  intros. gen_eq G: (E & x ~ bind_sub Q B & F). gen E F.
  induction H; intros; subst; eauto.
  (* case var *)
  asserts W: (_wf (E & x ~ bind_sub Q A)). apply* twf_left.
  destruct (binds_concat_inv H0).
  apply* _typing_var.
  destruct H3.
  destruct (binds_push_inv H4). destructs H5.
  inversions H6. apply* (@_typing_sub A).
  apply_empty* tsub_weaken. apply_empty* tsub_weaken.
  destructs (typing_wf_from_twf (twf_left H)).
  apply_empty* typing_weaken.
  apply_empty* typing_weaken.
  apply_empty* typing_weaken.
  (* case lam *)
  apply_fresh* (@_typing_lam) as y.
  apply_ih_bind* H2. apply_ih_bind* H4.
  (* case pi *)
  apply_fresh* (@_typing_pi) as y.
  apply_ih_bind* H2.

  clear tsub_narrowing_typ.
  intros. gen_eq G: (E & x ~ bind_sub Q B & F). gen E F.
  induction H; intros; subst; eauto.
  (* case var *)
  asserts W1: (_wf (E & x ~ bind_sub Q A)). apply* twf_left.
  destruct (binds_concat_inv H0).
  apply* _sub_var_refl.
  destruct H3.
  destruct (binds_push_inv H4). destructs H5.
  inversions H6. apply_empty* tsub_weaken.
  apply_empty* tsub_weaken.
  (* case trans *)
  asserts W1: (_wf (E & x ~ bind_sub Q A)). apply* twf_left.
  destruct (binds_concat_inv H).
  apply* _sub_var_trans.
  destruct H3. destruct (binds_push_inv H4). destructs H5. inversions H6.
  apply* _sub_var_trans.
  apply* _sub_var_trans.
  (* case lam *)
  apply_fresh* (@_sub_lam) as y.
  apply_ih_bind* H2.
  (* case pi *)
  apply_fresh* (@_sub_pi) as y.
  apply_ih_bind* H3.
Qed.

Lemma tsub_trans : forall B G A C,
  _sub G A B -> _sub G B C -> _sub G A C.
Proof.
  introv S1. asserts* W: (lc_trm B).
  gen G A C. set_eq B' eq: B. gen B' eq.
  induction W; intros B' eq G AA S1;
    induction S1; try discriminate; inversions eq;
      intros C' S2; inversions keep S2;
        try solve [eauto 3].
  apply~ _sub_top.
  apply_fresh _sub_lam as y.
    auto. auto. lets P1: H0 y __. auto.
    lets P2: (P1 _ eq_refl).
    lets Q1: H3 y __. auto. lets Q2: H12 y __. auto.
    lets: P2 Q1 Q2. auto.
  apply~ _sub_top.
  apply_fresh _sub_pi as y.
    auto. auto. apply* IHW2.
    lets P1: H0 y __. auto. lets P2: (P1 _ eq_refl).
    lets Q1: H3 y __. auto. lets Q2: H13 y __. auto.
    apply~ P2. apply_empty* (@tsub_narrowing_typ e A C).
Qed.

Hint Resolve tsub_trans.

Lemma typing_prod_inv : forall E e U T P,
  _typing E (trm_prod e U T) P ->
     _sub E trm_star P
  /\ _typing E e U
  /\ _typing E U trm_star
  /\ exists L, forall x, x \notin L -> _typing (E & x ~ bind_sub e U) (T ^ x) trm_star.
Proof.
  introv Typ. gen_eq P1: (trm_prod e U T).
  induction Typ; intros; subst; tryfalse.
  inversions EQP1. splits*.
  destructs~ (IHTyp1 eq_refl).
  splits*.
Qed.

Definition substenv (x:var) (v:trm) (p:binding) :=
  match p with
  | bind_sub e A => bind_sub (subst x v e) (subst x v A)
  end.

Lemma substenv_eq : forall x v e1 e2,
  bind_sub ([x ~> v] e1) ([x ~> v] e2) = substenv x v (bind_sub e1 e2).
Proof.
  intros. simpls*.
Qed.

Lemma substenv_fresh : forall x t1 t2 u,
  x \notin fv t1 -> x \notin fv t2 ->
  substenv x u (bind_sub t1 t2) = bind_sub t1 t2.
Proof.
  intros. unfolds substenv.
  rewrite* subst_fresh.
  rewrite* subst_fresh.
Qed.

Lemma typing_substitution : forall V e (F:env) v (E:env) x t T,
  _typing E v V ->
  _sub E v e ->
  _typing (E & x ~ bind_sub e V & F) t T ->
  _typing (E & (map (substenv x v) F)) (subst x v t) (subst x v T).
Proof.
  introv Typv Sub Typt.
  gen_eq G: (E & x ~ bind_sub e V & F). gen F.
  apply typing_induct with
   (P := fun (G:env) t T (Typt : _typing G t T) =>
      forall (F:env), G = E & x ~ bind_sub e V & F ->
      _typing (E & map (substenv x v) F) ([x ~> v]t) ([x ~> v]T))
   (P0 := fun (G:env) (W: _wf G) =>
      forall F, G = E & x ~ bind_sub e V & F ->
      _wf (E & (map (substenv x v) F)))
   (P1 := fun (G:env) t T (Subt : _sub G t T) =>
      forall (F:env), G = E & x ~ bind_sub e V & F ->
      _sub (E & map (substenv x v) F) ([x ~> v]t) ([x ~> v]T));
   intros; subst; simpls subst; try solve [eauto 4].
  (* case: trm_star *)
  autos*.
  (* case: var *)
  case_var.
    binds_mid~. inversions TEMP. rewrite* subst_fresh. apply_empty* typing_weaken.
    apply~ (@_typing_var ([x~>v]e0)). rewrite substenv_eq.
    destruct~ (binds_not_middle_inv b) as [K|[Fr K]]. rewrite* substenv_fresh.
  (* case: trm_abs *)
  apply_fresh* (@_typing_lam) as y; rewrite* substenv_eq.
   cross; auto. apply_ih_map_bind* H1.
   cross; auto. apply_ih_map_bind* H2.
  (* case: trm_app *)
  rewrite* subst_open.
  (* case: trm_prod *)
  apply_fresh* (@_typing_pi) as y; rewrite* substenv_eq.
   cross; auto. apply_ih_map_bind* H1.
  (* case: castup *)
  apply* _typing_castup. apply* reduct_red_out.
  (* case: castdn *)
  apply* _typing_castdn. apply* reduct_red_out.
  (* case: sub *)
  apply* (@_typing_sub ([x ~> v] A)).
  (* case: wf nil *)
  false (empty_middle_inv H).
  (* case: wf cons *)
  change LibEnv.env with LibEnv.env in *.
  induction F using env_ind.
    rewrite concat_empty_r in H1.
     destruct (eq_push_inv H1) as [? [? ?]]. subst.
     rewrite map_empty. rewrite~ concat_empty_r.
    clear IHF. rewrite concat_assoc in H1.
     destruct (eq_push_inv H1) as [? [? ?]]. subst.
     rewrite map_push. rewrite concat_assoc. apply* (@_wf_cons).
  (* case sub_var *)
  case_var.
    binds_mid~. apply_empty* tsub_weaken. apply* tsub_refl.
    apply _sub_var_refl with (A := [x ~> v] A) (e := [x ~> v] e0). auto.
    rewrite substenv_eq.
    destruct~ (binds_not_middle_inv b) as [K|[Fr K]]. rewrite* substenv_fresh.
  (* case sub_var trans *)
  asserts* W: (_wf (E & x ~ bind_sub e V & F)).
  case_var.
    binds_mid~. inversions TEMP.
    lets: (H _ eq_refl).
    apply~ (@tsub_trans ([x ~> v] e)).
    rewrite* subst_fresh.
    apply_empty* tsub_weaken.
    apply* (@_sub_var_trans ([x~>v]e1) ([x~>v]A)).
    rewrite substenv_eq.
    destruct~ (binds_not_middle_inv b) as [K|[Fr K]]. rewrite* substenv_fresh.
  (* case: sub_abs *)
  apply_fresh* (@_sub_lam) as y; rewrite* substenv_eq.
   cross; auto. apply_ih_map_bind* H1.
  (* case: sub_app *)
  autos*.
  (* case: sub_prod *)
  apply_fresh* (@_sub_pi) as y; rewrite* substenv_eq.
   cross; auto. apply_ih_map_bind* H2.
Qed.

Lemma typing_abs_inv : forall E e V t P,
  _typing E (trm_abs e V t) P -> exists T L,
     _typing E V trm_star
  /\ _typing E e V
  /\ (forall x, x \notin L -> _typing (E & x ~ bind_sub e V) (T ^ x) trm_star)
  /\ (_sub E (trm_prod e V T) P)
  /\ (forall x, x \notin L -> _typing (E & x ~ bind_sub e V) (t ^ x) (T ^ x)).
Proof.
  introv Typ. gen_eq u: (trm_abs e V t).
  induction Typ; intros; subst; tryfalse.
  inversions EQu. exists B L. splits*. apply* tsub_refl.
  destruct (IHTyp1 eq_refl) as [T0 [L ?]]. destructs H0.
  exists T0 L. splits*.
Qed.

Lemma typing_var_inv : forall G x A,
  _typing G (trm_var_f x) A ->
  exists e A', binds x (bind_sub e A') G /\ _sub G A' A.
Proof.
  intros.
  inductions H; tryfalse.
  destructs~ (typing_wf_from_context H0).
  exists* e A. splits*. apply* tsub_refl.
  destruct (IH_typing1 x eq_refl) as [e [A' [? ?]]].
  exists e A'. splits*.
Qed.

Lemma typing_wf_from_typing : forall E t T,
  _typing E t T ->
  _typing E T trm_star.
Proof.
  intros. inductions H; try solve [eauto 3].
  destruct* (typing_wf_from_context H0).
  destructs (typing_prod_inv IH_typing2).
  destruct H5 as [L ?].
  pick_fresh x. rewrite~ (@subst_intro x).
  unsimpl ([x ~> A](trm_star)).
  apply_empty* (@typing_substitution B e3).
Qed.

Lemma typing_wf_from_sub : forall G e1 e2 A,
  _typing G e1 A ->
  _sub G e1 e2 ->
  _typing G e2 A.
Proof.
  introv Ty Su. gen A. inductions Su; intros; try solve [eauto 3].
  inductions Ty.
    lets: binds_func H0 H. inversions H2.
    lets: (typing_wf_from_context H H1). apply* IHSu.
    destructs~ (typing_wf_from_context H).
    apply~ (@_typing_sub A0). apply* IHTy1.
  apply* _typing_top. apply* typing_wf_from_typing.
  destruct (typing_abs_inv Ty) as [T0 [L1 ?]].
  destructs H3.
  apply~ (@_typing_sub (trm_prod e3 A T0)).
  apply_fresh* _typing_lam as y.
  apply* typing_wf_from_typing.
  inductions Ty.
    apply* (@_typing_app e3).
    apply* (@_typing_sub A0).
  destructs (typing_prod_inv Ty).
  destruct H6 as [L' ?].
  apply~ (@_typing_sub trm_star).
  apply_fresh _typing_pi as y.
    auto. auto.
    lets P1: H2 y __. auto. apply P1.
    apply_empty* (@typing_narrowing_typ e A C).
    apply* typing_wf_from_typing.
  inductions Ty; eauto 4.
  inductions Ty; eauto 4.
Qed.

Lemma _typing_sub' : forall A G e B,
  _typing G e A ->
  _sub G A B ->
  _typing G e B.
Proof.
  intros. apply* (@_typing_sub A).
  apply typing_wf_from_sub with (e1 := A).
  apply* typing_wf_from_typing.
  auto.
Qed.

Hint Resolve _typing_sub'.

Lemma typing_app_inv : forall G e A D,
  _typing G (trm_app e A) D ->
  exists e3 B C, _typing G A B /\
                 _sub G A e3 /\
                 _typing G e (trm_prod e3 B C) /\
                 _sub G (C ^^ A) D.
Proof.
  intros. gen_eq Q: (trm_app e A).
  induction H; intros; subst; tryfalse.
  inversions EQQ. exists* e3 B C. splits*.
  asserts* Typ2: (_typing G (trm_prod e3 B C) trm_star).
  apply* typing_wf_from_typing.
  destruct (typing_prod_inv Typ2) as [? [? [? [L P]]]].
  assert (_typing G (C ^^ A) trm_star).
  pick_fresh y. rewrite* (@subst_intro y).
  unsimpl([y ~> A] trm_star).
  asserts* Eq: (trm_star = trm_star ^ y).
  rewrite Eq.
  apply_empty* (@typing_substitution B e3).
  apply* tsub_refl.
  destruct~ IH_typing1 as [e3' [B' [C' [? [? ?]]]]].
  exists* e3' B' C'.
Qed.

Lemma sub_to' : forall G e1 e2 A,
  sub G e1 e2 A ->
  _typing G e1 A /\
  _sub G e1 e2.
Proof.
  apply sub_induct with
   (P0 := fun (G:env) (W:wf G) => _wf G);
   intros; subst; simpls subst.
  splits; autos*.
  splits; autos*.
  splits; autos*.
  splits; autos*.
  splits; autos*.
  (* lam *)
  splits.
  apply_fresh* _typing_lam as y.
  destructs~ (H2 y).
  destructs~ (H1 y).
  apply_fresh* _sub_lam as y.
  destructs~ (H1 y).
  (* app *)
  splits; autos*.
  (* pi *)
  splits.
  apply_fresh* _typing_pi as y.
  destructs~ (H2 y).
  apply_fresh* _sub_pi as y.
  destructs~ (H3 y).
  splits; autos*.
  splits; autos*.
  splits; autos*.
  autos*.
  autos*.
Qed.

Lemma sub_to : forall G e1 e2 A,
  sub G e1 e2 A ->
  _typing G e1 A /\ _typing G e2 A /\ _sub G e1 e2.
Proof.
  intros.
  destructs (sub_to' H).
  splits*.
  apply* typing_wf_from_sub.
Qed.

Lemma sub_wf_to : forall G,
  wf G -> _wf G.
Proof.
  intros. inductions H.
  auto. destruct (sub_to H0) as [? [? ?]].
  apply* _wf_cons.
  apply* sub_to'.
Qed.

Lemma sub_app_app_inv : forall E e1 e2 A A' T,
  sub E (trm_app e1 A) (trm_app e2 A') T ->
  exists e3 B C, A = A' /\ sub E A e3 B /\
                 sub E e1 e2 (trm_prod e3 B C) /\
                 sub E (C ^^ A) T trm_star.
Proof.
  intros. inductions H; autos*.
  exists e3 B C. splits*.
  lets: sub_wf_from_sub H.
  destruct (sub_prod_prod_inv H1) as [L T'].
  pick_fresh x. rewrite~ (@subst_intro x).
  unsimpl ([x ~> A'](trm_star)).
  apply_empty* (@sub_substitution B e3).
  destruct (IHsub1 _ _ _ _ eq_refl eq_refl) as [e3' [B' [C' ?]]].
  destructs H1.
  exists* e3' B' C'. splits*.
  apply* (@sub_trans A0).
Qed.

Lemma sub_from_aux : forall G e1 e2 A,
  sub G e1 e1 A ->
  _sub G e1 e2 ->
  sub G e1 e2 A.
Proof.
  intros. gen A.
  apply tsub_induct with
   (P := fun (G:env) e A (Typ: _typing G e A) => sub G e e A)
   (P0 := fun (G:env) (W:_wf G) => wf G)
   (P1 := fun (G:env) e1 e2 (W:_sub G e1 e2) =>
            forall A (S1: sub G e1 e1 A),
            sub G e1 e2 A);
    intros; eauto 4.

  (* case: typing sub *)
  apply* (@sub_sub' A).
  apply* H1. apply* sub_wf_from_sub.
  (* case: sub var *)
  destructs~ (sub_wf_from_context b).
  asserts* W: (sub G0 (trm_var_f x) (trm_var_f x) A).
  asserts* W2: (sub G0 (trm_var_f x) e3 A).
  apply* sub_typekeep.
  (* case: sub abs *)
  destruct (sub_abs_abs_inv S1) as [C' ?]. destructs H3.
  apply~ (@sub_sub' (trm_prod e4 A C')).
  destruct H6 as [L' ?].
  apply_fresh* sub_abs as y.
  apply* sub_wf_from_sub.
  (* case: sub app *)
  destruct (sub_app_app_inv S1) as [e3' [B' [C' ?]]].
  destructs H1.
  apply* (@sub_sub' (C' ^^ A)).
  (* case: sub prod *)
  destructs (sub_prod_prod_inv2 S1).
  destruct H8 as [L' ?].
  asserts*: (sub G0 trm_star A0 trm_star).
  destruct H4; subst; auto.
  apply~ (@sub_sub' trm_star).
  apply_fresh* sub_prod as y.
  lets P1: H8 y __. auto.
  lets P2: H3 y __. auto.
  apply~ P2. apply_empty* (@sub_narrowing_typ e C A).
  (* case: sub castup *)
  destruct (sub_castup_inv S1) as [A' ?].
  destructs H1.
  apply* (@sub_sub' A).
  (* case: sub castdn *)
  destruct (sub_castdn_inv S1) as [A' [B' ?]].
  destructs H1.
  apply* (@sub_sub' B').
Qed.

Lemma typing_to_sub_refl : forall G e A,
  _typing G e A ->
  sub G e e A.
Proof.
  intros.
  apply typing_induct with
   (P := fun (G:env) e A (Typ: _typing G e A) => sub G e e A)
   (P0 := fun (G:env) (W:_wf G) => wf G)
   (P1 := fun (G:env) e1 e2 (W:_sub G e1 e2) =>
            forall A (S1: sub G e1 e1 A),
            sub G e1 e2 A);
    intros; try solve [eauto 4 | apply* sub_from_aux].
  apply* (@sub_sub' A0).
  apply* H1. apply* sub_wf_from_sub.
Qed.

Lemma sub_from : forall G e1 e2 A,
  _typing G e1 A ->
  _sub G e1 e2 ->
  sub G e1 e2 A.
Proof.
  intros.
  apply* sub_from_aux.
  apply* typing_to_sub_refl.
Qed.


Require Import UniMath.Foundations.All.
Require Import UniMath.MoreFoundations.All.

Require Import UniMath.CategoryTheory.Core.Prelude.
(* a few libraries need to be reloaded after “All”,
   to claim precedence on overloaded names *)
Require Import UniMath.CategoryTheory.limits.pullbacks.

Require Import TypeTheory.Auxiliary.Auxiliary.
Require Import TypeTheory.Auxiliary.CategoryTheory.

(** * Basic pullback utility functions *)

Section Pullback_Basics.

Definition map_into_Pb
    {C : category} {a b c d : C}
    {f : a --> b} {g : a --> c} {k : b --> d} {h : c --> d}
    {sqr_comm : f ;; k = g ;; h}
    (Pb : isPullback sqr_comm)
    {e : C} (x : e --> b) (y : e --> c) (H : x ;; k = y ;; h)
  :  e --> a.
Proof.
  eapply (PullbackArrow (make_Pullback _ Pb)).
  apply H.
Defined.

Definition Pb_map_commutes_1
    {C : category} {a b c d : C}
    {f : a --> b} {g : a --> c} {k : b --> d} {h : c --> d}
    {sqr_comm : f ;; k = g ;; h}
    (Pb : isPullback sqr_comm)
    {e : C} (x : e --> b) (y : e --> c) H
  : map_into_Pb Pb x y H ;; f = x.
Proof.
  apply (PullbackArrow_PullbackPr1 (make_Pullback _ _)).
Qed.

Definition Pb_map_commutes_2
    {C : category} {a b c d : C}
    {f : a --> b} {g : a --> c} {k : b --> d} {h : c --> d}
    {sqr_comm : f ;; k = g ;; h}
    (Pb : isPullback sqr_comm)
    {e : C} (x : e --> b) (y : e --> c) H
  : map_into_Pb Pb x y H ;; g = y.
Proof.
  apply (PullbackArrow_PullbackPr2 (make_Pullback _ _)).
Qed.

Lemma map_into_Pb_unique
    {C : category} {a b c d : C}
    {f : a --> b} {g : a --> c} {k : b --> d} {h : c --> d}
    {sqr_comm : f ;; k = g ;; h}
    (Pb : isPullback sqr_comm)
    {e : C} {x y : e --> a}
    (e_f : x ;; f = y ;; f) (e_g : x ;; g = y ;; g)
  : x = y.
Proof.
  etrans.
  { use (PullbackArrowUnique _ Pb); try eassumption.
    repeat rewrite <- assoc. apply maponpaths; assumption. }
  apply pathsinv0, (PullbackArrowUnique _ Pb); apply idpath.
Qed.

(* In fact this is trivial, since the equality doesn’t appear in the type of the pullback. However, it’s convenient for proof scripts. *)
Lemma isPullback_indepdent_of_path
    {C : category} {a b c d : C}
    {f : a --> b} {g : a --> c} {k : b --> d} {h : c --> d}
    {sqr_comm : f ;; k = g ;; h}
    (Pb : isPullback sqr_comm)
    (sqr_comm' :  f ;; k = g ;; h)
  : isPullback (sqr_comm').
Proof.
  exact Pb.
Defined.

(* Duplicate of [is_symmetric_isPullback] from UniMath, but without the un-needed [has_homsets]/[category] assumption *)
Lemma is_symmetric_isPullback
    {C : category}
    {a b c d : C} {f : b --> a} {g : c --> a}
    {p1 : d --> b} {p2 : d --> c} {H : p1 · f = p2 · g}
    (pb : isPullback H)
  : isPullback (! H).
Proof.
  use make_isPullback.
  intros e h k H'.
  use (iscontrweqf _ (pb e k h (! H'))).
  use (weqtotal2 (idweq _)).
  intros ?. apply weqdirprodcomm.
Defined.

(* Variant of [is_symmetric_isPullback], more convenient for applying when reasoning bottom-up. *)
Lemma is_symmetric'_isPullback
    {C : category}
    {a b c d : C} {f : b --> a} {g : c --> a}
    {p1 : d --> b} {p2 : d --> c} {H : p1 · f = p2 · g}
    (pb : isPullback (! H))
  : isPullback H.
Proof.
  eapply transportf. 2: { eapply is_symmetric_isPullback, pb. }
  apply pathsinv0inv0.
Defined.

End Pullback_Basics.

(** * Pullback transfer lemmas *)

Section Pullback_transfers.
(* Various results, generally showing that perturbing a pullback squares by equalities and/or isos is still a pullback. *)

Lemma square_morphism_equal
    {C : category} {a b c d : C}
    {f : a --> b} {g : a --> c} {k : b --> d} {h : c --> d}
    (sqr_comm : f ;; k = g ;; h)
    {k'} (e : k' = k)
  : f ;; k' = g ;; h.
Proof.
  rewrite e. assumption.
Defined.

Lemma isPb_morphism_equal
    {C : category} {a b c d : C}
    {f : a --> b} {g : a --> c} {k : b --> d} {h : c --> d}
    (sqr_comm : f ;; k = g ;; h)
    (Pb : isPullback sqr_comm)
    {k'} (e : k' = k)
  : isPullback (square_morphism_equal sqr_comm e).
Proof.
  match goal with |[|- isPullback ?HH] => generalize HH end.
  rewrite e.
  intro.
  apply Pb.
Defined.

Definition commutes_and_is_pullback {C : category} {a b c d : C}
    (f : b --> a) (g : c --> a) (p1 : d --> b) (p2 : d --> c)
  : UU
:= ∑ (H : p1 ;; f = p2 ;; g), isPullback H.

(* Note: should have a dual version where [i_a], instead of [i_d], is assumed iso (and using [post_comp_with_iso_is_inj] in the proof). *)
Lemma commuting_square_transfer_z_iso {C : precategory}
      {a b c d : C}
      {f : b --> a} {g : c --> a} {p1 : d --> b} {p2 : d --> c}
      {a' b' c' d' : C}
      {f' : b' --> a'} {g' : c' --> a'} {p1' : d' --> b'} {p2' : d' --> c'}
      {i_a : a --> a'} {i_b : b --> b'} {i_c : c --> c'} {i_d : z_iso d d'}
      (i_f : f ;; i_a = i_b ;; f') (i_g : g ;; i_a = i_c ;; g')
      (i_p1 : p1 ;; i_b = i_d ;; p1') (i_p2 : p2 ;; i_c = i_d ;; p2')
   : p1 ;; f = p2;; g
   -> p1' ;; f' = p2' ;; g'.
Proof.
  intro H.
  refine (pre_comp_with_z_iso_is_inj i_d _ _ _).
  rewrite 2 assoc.
  rewrite <- i_p1, <- i_p2.
  rewrite <- 2 assoc.
  rewrite <- i_f, <- i_g.
  rewrite 2 assoc.
  apply maponpaths_2, H.
Qed.

(* Generalisation of [isPulback_iso_of_morphisms].
TODO: This probably should work in an arbitrary precategory, i.e. not requiring the hom-sets assumption.  Try upgrading proof to show that? *)
Lemma isPullback_transfer_z_iso {C : category}
      {a b c d : C}
      {f : b --> a} {g : c --> a} {p1 : d --> b} {p2 : d --> c}
      (H : p1 ;; f = p2;; g)
      {a' b' c' d' : C}
      {f' : b' --> a'} {g' : c' --> a'} {p1' : d' --> b'} {p2' : d' --> c'}
      (H' : p1' ;; f' = p2' ;; g')
      {i_a : z_iso a a'} {i_b : z_iso b b'} {i_c : z_iso c c'} {i_d : z_iso d d'}
      (i_f : f ;; i_a = i_b ;; f') (i_g : g ;; i_a = i_c ;; g')
      (i_p1 : p1 ;; i_b = i_d ;; p1') (i_p2 : p2 ;; i_c = i_d ;; p2')
   : isPullback H
   -> isPullback H'.
Proof.
  intros Hpb.
  apply (make_isPullback _ ).
  intros X h k H''.
  simple refine (tpair _ _ _ ).
  - simple refine (tpair _ _ _ ).
    { refine ( _ ;; i_d ).
      simple refine (PullbackArrow (make_Pullback _ Hpb) _ _ _ _).
      + exact (h ;; z_iso_inv_from_z_iso i_b).
      + exact (k ;; z_iso_inv_from_z_iso i_c).
      + abstract (
          apply (post_comp_with_z_iso_is_inj i_a _);
          repeat rewrite <- assoc;
          rewrite i_f, i_g;
          eapply @pathscomp0;
          [ apply maponpaths; rewrite assoc;
            apply maponpaths_2, z_iso_after_z_iso_inv
          | eapply @pathsinv0, @pathscomp0;
          [ apply maponpaths; rewrite assoc;
            apply maponpaths_2, z_iso_after_z_iso_inv
          | rewrite 2 id_left; apply @pathsinv0, H''
          ]]
        ).
    }
    cbn; split;
    abstract (
      rewrite <- assoc;
      eapply @pathscomp0;
      [ apply maponpaths, @pathsinv0;
        try apply i_p2; try apply i_p1
      | rewrite assoc;
      eapply @pathscomp0;
      [ apply maponpaths_2;
        try apply (PullbackArrow_PullbackPr2 (make_Pullback _ _));
        try apply (PullbackArrow_PullbackPr1 (make_Pullback _ _))
      | rewrite <- assoc, z_iso_after_z_iso_inv; apply id_right]] ).
  - intros hk'.
    apply subtypePath.
      intro; apply isapropdirprod; apply homset_property.
    cbn.
    apply (post_comp_with_z_iso_is_inj (z_iso_inv_from_z_iso i_d)).
    eapply @pathscomp0.
    2: { rewrite <- assoc. cbn. rewrite z_iso_inv_after_z_iso.
         eapply pathsinv0, id_right. }
    apply PullbackArrowUnique; cbn.
    + apply (post_comp_with_z_iso_is_inj i_b).
      repeat rewrite <- assoc.
      rewrite i_p1, z_iso_after_z_iso_inv, id_right.
      eapply @pathscomp0.
        apply maponpaths. rewrite assoc, z_iso_after_z_iso_inv. apply id_left.
      apply (pr1 (pr2 hk')).
    + apply (post_comp_with_z_iso_is_inj i_c).
      repeat rewrite <- assoc.
      rewrite i_p2, z_iso_after_z_iso_inv, id_right.
      eapply @pathscomp0.
        apply maponpaths. rewrite assoc, z_iso_after_z_iso_inv. apply id_left.
      apply (pr2 (pr2 hk')).
  Qed.

(* Generalisation of [isPulback_iso_of_morphisms]. *)
Lemma commutes_and_is_pullback_transfer_z_iso {C : category}
      {a b c d : C}
      {f : b --> a} {g : c --> a} {p1 : d --> b} {p2 : d --> c}
      {a' b' c' d' : C}
      {f' : b' --> a'} {g' : c' --> a'} {p1' : d' --> b'} {p2' : d' --> c'}
      {i_a : z_iso a a'} {i_b : z_iso b b'} {i_c : z_iso c c'} {i_d : z_iso d d'}
      (i_f : f ;; i_a = i_b ;; f') (i_g : g ;; i_a = i_c ;; g')
      (i_p1 : p1 ;; i_b = i_d ;; p1') (i_p2 : p2 ;; i_c = i_d ;; p2')
      (H : p1 ;; f = p2 ;; g) (P : isPullback H)
   : commutes_and_is_pullback f' g' p1' p2'.
Proof.
  exists (commuting_square_transfer_z_iso i_f i_g i_p1 i_p2 H).
  exact (isPullback_transfer_z_iso _ _ i_f i_g i_p1 i_p2 P).
Qed.

Lemma postcomp_commutes_and_is_pb_with_z_iso
    {C : category} {a b c d : C}
    {f : a --> b} {g : a --> c} {k : b --> d} {h : c --> d}
    (sqr_comm : f ;; k = g ;; h)
    (Pb : isPullback sqr_comm)
    {y : C} (r : y --> d) (i : z_iso b y) (Hi : i ;; r = k)
  : ∑ H : f ;; i ;; r = g ;; h, isPullback H.
Proof.
  simple refine (commutes_and_is_pullback_transfer_z_iso _ _ _ _ _ Pb);
    try apply identity_z_iso;
    try rewrite id_left;
    try rewrite id_right;
    try apply idpath.
  apply pathsinv0, Hi.
Qed.

Definition postcomp_pb_with_z_iso
    {C : category} {a b c d : C}
    {f : a --> b} {g : a --> c} {k : b --> d} {h : c --> d}
    (sqr_comm : f ;; k = g ;; h)
    (Pb : isPullback sqr_comm)
    {y : C} (r : y --> d) (i : z_iso b y) (Hi : i ;; r = k)
  : isPullback _
:= pr2 (postcomp_commutes_and_is_pb_with_z_iso _ Pb _ i Hi).

End Pullback_transfers.

(** * Uniqueness of pullbacks *)

Definition isaprop_Pullback (C : category) (H : is_univalent C)
           (a b c : C) (f : b --> a) (g : c --> a)
: isaprop (Pullback f g).
Proof.
  unfold Pullback.
  apply invproofirrelevance.
  unfold Pullback.
  intros Pb Pb'.
  apply subtypePath.
  - intro; apply isofhleveltotal2.
    + apply homset_property.
    + intros; apply isaprop_isPullback.
  - apply (total2_paths_f (isotoid _ H (z_iso_from_Pullback_to_Pullback _ _))).
    rewrite transportf_dirprod, transportf_isotoid.
    rewrite inv_from_z_iso_z_iso_from_Pullback.
    rewrite transportf_isotoid.
    rewrite inv_from_z_iso_z_iso_from_Pullback.
    destruct Pb as [Cone bla];
    destruct Pb' as [Cone' bla'];
    simpl in *.
    destruct Cone as [p [h k]];
    destruct Cone' as [p' [h' k']];
    simpl in *.
    unfold from_Pullback_to_Pullback;
    rewrite PullbackArrow_PullbackPr2, PullbackArrow_PullbackPr1.
    apply idpath.
Qed.

(* TODO: check for results of the following section upstream *)
Section Pullback_Unique_Up_To_Iso.

(*   a'   b'
      f  /h
   a----b  b'
   |    |
 g |    | k
   |    |
   c----d
     j

   and pb square a' b' c d, and h iso

   task: construct iso from a to a'

 *)

  Variable CC : category.
  Variables A B C D A' B' : CC.
  Variables (f : A --> B) (g : A --> C) (k : B --> D) (j : C --> D)
            (H : f ;; k = g ;; j) (pb : isPullback H).
  Variables (f' : A' --> B') (g' : A' --> C) (r : B' --> D) (h : z_iso B B').
  Variable (H' : f' ;; r = g' ;; j).
  Variable (pb' : isPullback H').
  Variable (T : h ;; r = k).

  Definition map_to_2nd_pb : A --> A'.
  Proof.
    use (map_into_Pb pb').
    - exact (f ;; h).
    - exact g.
    - eapply pathscomp0. 2: { apply H. }
      eapply pathscomp0. apply (!assoc _ _ _ ).
      apply maponpaths. apply T.
  Defined.

  Definition map_to_1st_pb : A' --> A.
  Proof.
    use (map_into_Pb pb).
    - exact (f';; inv_from_z_iso h).
    - exact g'.
    - eapply pathscomp0; [| apply H'].
      eapply pathscomp0; [ apply (!assoc _ _ _ ) |].
      apply maponpaths. apply z_iso_inv_on_right.
      apply (!T).
  Defined.

  Lemma inv1 : map_to_2nd_pb ;; map_to_1st_pb = identity _ .
  Proof.
    apply (map_into_Pb_unique pb).
    - rewrite id_left.
      rewrite <- assoc.
      unfold map_to_1st_pb.
      rewrite Pb_map_commutes_1.
      rewrite assoc.
      apply pathsinv0.
      apply z_iso_inv_on_left.
      unfold map_to_2nd_pb.
      use Pb_map_commutes_1.
    - rewrite id_left.
      rewrite <- assoc.
      unfold map_to_1st_pb.
      rewrite Pb_map_commutes_2.
      unfold map_to_2nd_pb.
      apply Pb_map_commutes_2.
  Qed.

  Lemma inv2 : map_to_1st_pb ;; map_to_2nd_pb = identity _ .
  Proof.
    apply (map_into_Pb_unique pb').
    - rewrite id_left.
      rewrite <- assoc.
      unfold map_to_2nd_pb.
      rewrite Pb_map_commutes_1.
      rewrite assoc.
      unfold map_to_1st_pb.
      rewrite Pb_map_commutes_1.
      rewrite <- assoc.
      rewrite z_iso_after_z_iso_inv.
      apply id_right.
    - rewrite id_left.
      rewrite <- assoc.
      unfold map_to_2nd_pb.
      rewrite Pb_map_commutes_2.
      unfold map_to_1st_pb.
      apply Pb_map_commutes_2.
  Qed.

  Definition z_iso_to_second_pb : z_iso A A'.
  Proof.
    exists map_to_2nd_pb.
    exists map_to_1st_pb.
    split.
    - apply inv1.
    - apply inv2.
  Defined.

End Pullback_Unique_Up_To_Iso.


Require Import Setoid ssrbool ssreflect.
(*Require Import perm.*)

Lemma ab_bool_lr : forall a b, a && b -> a /\ b.
Proof.
  intros a b; case a; case b; intros H; inversion H; split; assumption.
Qed.

Lemma ab_bool : forall a b, a && b <-> a /\ b.
Proof.
  intros a b; split.
  apply ab_bool_lr.
  case a;case b; intros (ha,hb); solve [inversion ha | inversion hb | reflexivity].
Qed.

Lemma wrapperAB : forall S:Type, forall A B:S,forall le:S->S->bool, forall le_total:(forall x y:S, le x y || le y x), forall P:S-> S -> Type, forall Pwlog:(forall x y:S, le x y -> P x y), forall Psym:(forall x y:S,  P y x -> P x y),  P A B.
  Proof.
    intros S A B le le_total P Pwlog Psym;
      destruct (Bool.orb_true_elim _ _ (le_total A B)) as [i | i];
    [exact (Pwlog _ _ i) | exact  (Psym _ _ (Pwlog _ _ i))].
  Defined.

(*Ltac revert_all_except1 x :=
  repeat match goal with
           [ H : _ |- _ ]  =>
           match H with x => fail 1 | _ => revert H end end.

Ltac revert_all_except2 x y :=
  repeat match goal with
           [ H : _ |- _ ]  =>
           match H with x => fail 1 | y=> fail 1 | _ => revert H end end.

Ltac revert_all_except3 x y  z:=
  repeat match goal with
           [ H : _ |- _ ]  =>
           match H with x => fail 1 | y => fail 1 | z => fail 1 | _ => revert H end end.
*)

Ltac wlog2 vA vB vle vle_total tac_sym tac_wlog:=
  let X:= fresh "X" in
  let Y:= fresh "Y" in
  let Xsym := fresh "Xsym" in
  let Xle := fresh "Xle" in
  pattern vA,vB;
  match goal with vA:?ty |- (?P vA vB) =>
                  cbv beta;
                  revert vA vB;
                  assert (Xle:forall x y:ty, vle x y -> P x y);
                  [first [tac_wlog | idtac "You have to prove " Xle "."] |
                   assert (Xsym:forall x y:ty, P y x -> P x y);
                   [first [tac_sym |  idtac "You have to prove " Xsym "."] |
                    intros X Y; apply (wrapperAB  _ X Y vle vle_total _ Xle Xsym)
                  ]]
  end.

Lemma wrapABC : forall S:Type, forall A B C:S,
      forall le:S->S->bool, forall le_total:(forall x y:S, le x y || le y x),
          forall P:S->S->S->Type,
            forall Pwlog: (forall x y z : S, le x y && le y z -> P x y z),
      (forall x y z : S, P x z y -> P x y z) ->
      (forall x y z : S, P y x z -> P x y z) ->
      (forall x y z : S, P y z x -> P x y z) ->
      (forall x y z : S, P z x y -> P x y z) ->
      (forall x y z : S, P z y x -> P x y z) ->
      P A B C.
Proof.
  intros S A B C le le_total P Pwlog Psym1 Psym2 Psym3 Psym4 Psym5;
    destruct (Bool.orb_true_elim _ _ (le_total A B)) as [i | i];
    destruct (Bool.orb_true_elim _ _ (le_total A C)) as [j | j];
    destruct (Bool.orb_true_elim _ _ (le_total B C)) as [k | k];
    [
      apply Pwlog; try rewrite i; try rewrite j; try rewrite k; reflexivity
    | apply Psym1; apply Pwlog; try rewrite i; try rewrite j; try rewrite k; reflexivity
    | apply Pwlog; try rewrite i; try rewrite j; try rewrite k; reflexivity
    | apply Psym4; apply Pwlog; try rewrite i; try rewrite j; try rewrite k; reflexivity
    | apply Psym2; apply Pwlog; try rewrite i; try rewrite j; try rewrite k; reflexivity
    | apply Psym2; apply Pwlog; try rewrite i; try rewrite j; try rewrite k; reflexivity
    | apply Psym3; apply Pwlog; try rewrite i; try rewrite j; try rewrite k; reflexivity
    | apply Psym5; apply Pwlog; try rewrite i; try rewrite j; try rewrite k; reflexivity
    ].
Qed.

Ltac wlog3 vA vB vC vle vle_total tac_sym tac_wlog :=
  let X:= fresh "A" in
  let Y:= fresh "B" in
  let Z:= fresh "C" in
  let Xsym := fresh "Xsym" in
  let Xsym1 := fresh "Xsym1" in
  let Xsym2 := fresh "Xsym2" in
  let Xle := fresh "Xle" in
  pattern vA,vB,vC;
  match goal with vA:?ty |- (?P vA vB vC) =>
                  cbv beta;
                  revert vA vB vC;
                  assert (Xle:forall A B C:ty, vle A B && vle B C -> P A B C) ;
                  [ tac_wlog |
                    intros X Y Z; apply (wrapABC _ X Y Z vle vle_total _ Xle);clear Xle; tac_sym]
  end.
(*
Lemma l03 : 0<3.
Proof.
  auto.
Qed.

Lemma l13 : 1<3.
Proof.
  auto.
Qed.

Lemma l23 : 2<3.
Proof.
  auto.
Qed.
Inductive Point :=
| P0 | P1 | P2 | P3 | P4 | P5 | P6 | P7 | P8 | P9 | P10 | P11 | P12 | P13 | P14 .

Inductive Line :=
| L0 | L1 | L2 | L3 | L4 | L5 | L6 | L7 | L8 | L9 | L10 | L11 | L12 | L13 | L14 | L15 | L16 | L17 | L18 | L19 | L20 | L21 | L22 | L23 | L24 | L25 | L26 | L27 | L28 | L29 | L30 | L31 | L32 | L33 | L34 .

Parameter incid_lp : Point -> Line -> bool.
Parameter P:Line -> Line -> Line -> Prop.
Parameter leL:Line -> Line -> bool.
Parameter eqL:Line -> Line -> bool.
Parameter leL_total:(forall x y:Line, leL x y || leL y x).

(*  Definition f2, f4, f5 and so on... *)
Definition f3 (A:Type) (i:'I_3)  (x y z:A) : A.
case i.
intros m; case m; clear m.
intros; exact x.
intros m; case m; clear m.
intros; exact y.
intros m; case m; clear m.
intros; exact z.
intros; by [].
Defined.
Definition f3' := f3 Line.

Definition dist_3l (A B C :Line) : bool :=
    (negb (eqL A B)) && (negb (eqL A C)) && (negb (eqL B C)).

Parameter eqL_sym : forall x y, eqL x y = eqL y x.

Ltac d_tac H := revert H; repeat rewrite ab_bool; firstorder; rewrite eqL_sym; assumption.

Lemma dist_3l_ok_simple : forall x y z, dist_3l x y z -> dist_3l y z x.
Proof.
  (*unfold dist_3l;*) intros x y z H; d_tac H.
Qed.

(*Lemma dist_3l_ok_simple' : forall x y z, dist_3l x y z ->> dist_3l y z x.
Proof.
  (*unfold dist_3l;*) intros x y z; unfold dist_3l; repeat rewrite ab_bool; firstorder. d_tac H.
Qed.
*)
Lemma dist_3l_ok : forall s:'S_3, forall x y z,  dist_3l x y z ->

                        dist_3l (f3' (s (Ordinal l03)) x y z) (f3' (s (Ordinal l13)) x y z) (f3' (s (Ordinal l23)) x y z).
Proof.
  intros s; pattern s; case s.
  intros pval; case pval.

  Check apermE.
case pval. intros.

  admit.

Admitted.

(*  Definition is_inv (P:A->A->A->bool) : bool :=
  forall x y z dist_3l x y z <-> *)
Definition Intersect_In (l1 l2 :Line) (P:Point) := incid_lp P l1 && incid_lp P l2.

Definition exists_Point (f:Point -> bool) : bool :=
  f P0 || f P1 || f P2 || f P3 || f P4 || f P5 || f P6 || f P7 || f P8 || f P9 || f P10 || f P11 || f P12 || f P13 || f P14.

Definition exists_Line (f:Line -> bool) : bool :=
  f L0 || f L1 || f L2 || f L3 || f L4 || f L5 (*|| f P6 || f P7 || f P8 || f P9 || f P10 || f P11 || f P12 || f P13 || f P14*).

Lemma foo : forall a b:bool, a -> b -> a && b.
Proof.
  intros a b; case a; case b; solve [reflexivity | discriminate].
Qed.

Lemma exists_exists_Point : forall P:Point->bool, (exists p:Point, P p) -> exists_Point P.
Proof.
unfold exists_Point; intros P x.
elim x; intros t; case t.
Admitted.
Lemma exists_exists_Line : forall P:Line->bool, (exists p:Line, P p) -> exists_Line P.
Proof.
Admitted.
Lemma exists_exists_Line2 : forall P:Line->bool,  exists_Line P -> (exists p:Line, P p).
Proof.
Admitted.

Definition forall_Line (f:Line-> bool) : bool := f L0 && f L1 && f L2 && f L3 && f L4 && f L5 && f L6 && f L7 && f L8 && f L9 && f L10 && f L11 && f L12 && f L13 && f L14 &&
f L15 && f L16 && f L17 && f L18 && f L19 && f L20 && f L21 && f L22 && f L23 && f L24 && f L25 && f L26 && f L27 && f L28 && f L29 && f L30 && f L31 && f L32 && f L33 && f L34.

Lemma a3_3 : forall v1 v2 v3:Line,
      dist_3l v1 v2 v3 -> exists v4 :Line, ( exists T1:Point, exists T2:Point, exists T3:Point,
             (Intersect_In v1 v4 T1) && (Intersect_In v2 v4 T2) && (Intersect_In v3 v4 T3)).
  Proof.
    idtac "-> proving a3_3".
    intros v1 v2 v3.
    wlog3 v1 v2 v3 leL leL_total idtac idtac.
admit.
intros.
lapply H.
(*Ltac first_order' := let H:= fresh in intros H; repeat match goal with H':exists t:_,_ |- _ => destruct H' end; revert H; repeat rewrite ab_bool.
first_order'.
firstorder. intros.
repeat match goal with H:exists t:_,_ |- _ => destruct H end.
match goal with HT:exists t:?A, ?P t |- _ => idtac "coucou" end.*)
admit.
d_tac H0.
intros; lapply H.
admit.
d_tac H0.
intros; lapply H.
admit.
d_tac H0.
intros; lapply H.
admit.
d_tac H0.
intros; lapply H.
admit.
d_tac H0.
Admitted.
(* comprendre exists et ex dans bool *)
Lemma ff : forall Q:Line->Point->bool, False -> exists p:Line, exists x:Point, Q p x.
Proof.
  intros.
Print ex.
Check is_true.
(*apply exists_exists_Line2.
Lemma xx (a b:bool) : is_true (andb a b) <-> a/\b.
Admitted.*)
(*
Definition exists_Point (f:Point -> bool) : bool :=
  f P0 || f P1 || f P2 || f P3 || f P4 || f P5 || f P6 || f P7 || f P8 || f P9 || f P10 || f P11 || f P12 || f P13 || f P14.

*)
Check ab_bool.
Lemma ttt : forall A B C:Line->Point->Point->Point->bool, exists x:Line, exists T1 T2 T3, A x T1 T2 T3 && B x T1 T2 T3 && C x T1 T2 T3 <-> exists x:Line,exists T1 T2 T3, A x T1 T2 T3 /\ B x T1 T2 T3/\ C x T1 T2 T3.
Proof.
Admitted.
(*rewrite ttt.
rewrite (ab_bool  (andb (Intersect_In x v4 T1) (Intersect_In y v4 T2))).
intros (v4, (T1, (T2, (T3 ,H')))).
exists v4; exists T1; exists T3; exists T2.
Set Printing All.
Check ab_bool.

repeat rewrite ab_bool in H'.
revert H'; repeat rewrite ab_bool; firstorder.*)
(*Lemma t : forall a b, a && b -> b && a.
  intros.
rewrite ab_bool in H.
rewrite ab_bool in H'.
apply ab_bool.
assumption.*)

(*

match goal with |- @ex Line (fun v4 : Line => ?P v4) => idtac "coucou" end.
Set Printing All.
match goal with
    |- @ex Line
    (fun v4 : Line =>
     @ex Point
       (fun T1 : Point =>
        @ex Point
          (fun T2 : Point =>
           @ex Point
             (fun T3 : Point => ?P v4 T1 T2 T3)))) => idtac "coucou" end. exists (v4:Line)(T1 T2 T3:Point), Intersect_In x v4 T1 && Intersect_In y v4 T2 && Intersect_In z v4 T3 => idtac "coucou" end.
Ltac exchange_2last :=
  match goal with
    H:_ |- exists (P:?X), ?Y P => idtac "coucou" end.
exchange_2last.

applymodulo
assert (dist_3l x z y).
admit.
apply H.*)
Lemma t : forall x y z:Line, P x y z.
Proof.
  intros.
  wlog3 x y z leL leL_total idtac idtac.
  admit.
  Definition w := 'I_3.
  Locate "'S_".
  Print  perm_of.
  Locate "'I_".
  Locate ordinal.
Admitted.

  Lemma  u:  forall s:'S_3, s (Ordinal l03) = s (Ordinal l23).
  Admitted.

Eval compute in (f3' (Ordinal l03)).
Eval compute in (f3' (Ordinal l13)).
Eval compute in (f3' (Ordinal l23)).

Lemma vt: forall s:'S_3,
      forall x y z:Line, P x y z ->

                        P (f3' (s (Ordinal l03)) x y z) (f3' (s (Ordinal l13)) x y z) (f3' (s (Ordinal l23)) x y z).
Proof.
intros.
case s; intros; simpl.
rewrite PermDef.fun_of_permE.
simpl.
case pval.
intros t0; case t0.
intros tval; case tval.
intros; simpl.
Admitted. (*simpl.
Search _ Finfun.

unfold f3',f3; simpl.
Print Finfun.
simpl.
Search _ pval.

rewrite pvalE.
reunfold f3',f3; simpl.
Check pvalE.

(* rewrite pvalE. *)
Search _ pval.
unfold f3.

Search _ pval.
Search _ aperm.
Admitted.
*)
Admitted.
  Admitted.
 *)

(* Local Variables: *)
(* coq-prog-name: "/Users/magaud/.opam/4.07.0/bin/coqtop" *)
(* coq-load-path: (("/Users/magaud/containers/theories" "Containers") ("/Users/magaud/galapagos/dev/trunk/ProjectiveGeometry/Dev" "ProjectiveGeometry.Dev")) *)
(* suffixes: .v *)
(* End: *)


(* Authors: Anders Kaseorg, Chelsea Voss. *)

Axiom Bird : Type.
Axiom Call : Bird -> Bird -> Bird.

Notation "A $ B" := (Call A B) (at level 50).

Definition composes A B C : Prop :=
  forall x, C $ x = A $ (B $ x).
Definition is_compose compose := forall A B, composes A B (compose A B).

Definition mockingbird M : Prop :=
  forall x, M $ x = x $ x.

Definition fond A B : Prop := A $ B = B.

Theorem Problem_1 :
  forall compose,
    is_compose compose ->
    forall M,
      mockingbird M ->
      forall A, exists B, fond A B.
Proof.
  intros.
  exists (M $ compose A M).
  congruence.
Qed.
(*YA*)

Definition egocentric x : Prop := x $ x = x.

Theorem Problem_2 :
  forall compose,
    is_compose compose ->
    forall M,
      mockingbird M ->
      exists e, egocentric e.
Proof.
  intros.
  exists (M $ compose M M).
  congruence.
Qed.

Definition agree A B x : Prop := A $ x = B $ x.

Definition agreeable A : Prop := forall B, exists x, agree A B x.

Theorem Problem_3 :
  forall compose,
    is_compose compose ->
    forall A,
      agreeable A ->
      forall B, exists C, fond B C.
Proof.
  intros.
  destruct H0 with (compose B A) as [D].
  exists (A $ D).
  congruence.
Qed.

Theorem Problem_4 :
  forall compose,
    is_compose compose ->
    forall A B C,
      composes A B C ->
      agreeable C ->
      agreeable A.
Proof.
  intros.
  intro D.
  destruct H1 with (compose D B) as [x].
  exists (B $ x).
  congruence.
Qed.

Theorem Problem_5 :
  forall compose,
    is_compose compose ->
    forall A B C,
    exists D,
      forall x,
        D $ x = A $ (B $ (C $ x)).
Proof.
  intros.
  exists (compose A (compose B C)).
  congruence.
Qed.

Definition compatible A B : Prop := exists x y, A $ x = y /\ B $ y = x.

Theorem Problem_6 :
  forall compose,
    is_compose compose ->
    forall M,
      mockingbird M ->
      forall A B, compatible A B.
Proof.
  intros.
  exists (M $ compose (compose B A) M).
  exists (A $ (M $ compose (compose B A) M)).
  split; congruence.
Qed.

Definition happy A : Prop := compatible A A.

Theorem Problem_7 :
  forall A B, fond A B -> happy A.
Proof.
  intros.
  exists B, B.
  split; congruence.
Qed.

Definition normal A := exists B, fond A B.

Theorem Problem_8 :
  forall compose,
    is_compose compose ->
    forall Ha,
      happy Ha ->
      exists N, normal N.
Proof.
  intros.
  exists (compose Ha Ha).
  destruct H0.
  exists x.
  destruct H0.
  destruct H0.
  congruence.
Qed.

Definition fixated A B := forall y, A $ y = B.

Definition hopelessly_egocentric B := fixated B B.

Definition kestrel K := forall x, fixated (K $ x) x.

Theorem Problem_9 :
  forall compose,
    is_compose compose ->
    forall M,
      mockingbird M ->
      forall K,
        kestrel K ->
        exists B, hopelessly_egocentric B.
Proof.
  intros.
  exists (M $ compose K M).
  congruence.
Qed.

Theorem Problem_10 :
  forall x y, fixated x y -> fond x y.
Proof.
  congruence.
Qed.

Theorem Problem_11 :
  forall K, kestrel K -> egocentric K -> hopelessly_egocentric K.
Proof.
  congruence.
Qed.

Theorem Problem_12 :
  forall K, kestrel K -> forall x, egocentric (K $ x) -> fond K x.
Proof.
  congruence.
Qed.

Theorem Problem_13 :
  forall A, hopelessly_egocentric A -> forall x y, A $ x = A $ y.
Proof.
  congruence.
Qed.

Theorem Problem_14 :
  forall A, hopelessly_egocentric A -> forall x y, A $ x $ y = A.
Proof.
  congruence.
Qed.

Theorem Problem_15 :
  forall A, hopelessly_egocentric A -> forall x, hopelessly_egocentric (A $ x).
Proof.
  congruence.
Qed.

Theorem Problem_16 :
  forall K, kestrel K -> forall x y, K $ x = K $ y -> x = y.
Proof.
  intros.
  replace x with (K $ x $ K); congruence.
Qed.

Theorem Problem_17 :
  forall B x y, fixated B x -> fixated B y -> x = y.
Proof.
  intros.
  replace x with (B $ B); congruence.
Qed.

Theorem Problem_18 :
  forall K, kestrel K -> forall x, fond K (K $ x) -> fond K x.
Proof.
  intros.
  apply Problem_16 with K; congruence.
Qed.

Definition lonely (B : Bird) : Prop := forall x, B = x.

Theorem Problem_19 :
  forall K, kestrel K -> egocentric K -> lonely K.
Proof.
  intros.
  intro.
  apply Problem_16 with K; congruence.
Qed.

Definition identity I := forall x, I $ x = x.

Theorem Problem_20 :
  forall I, identity I -> agreeable I -> forall B, exists x, fond B x.
Proof.
  intros.
  destruct H0 with B.
  exists x.
  congruence.
Qed.

Theorem Problem_21 :
  forall I, identity I -> (forall B, exists x, fond B x) -> agreeable I.
Proof.
  intros.
  intro.
  destruct H0 with B.
  exists x.
  congruence.
Qed.

Theorem Problem_22 :
  forall I, identity I ->
            (forall A B, compatible A B) ->
            (forall C, normal C) /\ agreeable I.
Proof.
  split.
  - intros.
    destruct H0 with C I.
    exists x.
    destruct H1.
    destruct H1.
    congruence.
  - intro B.
    destruct H0 with B I.
    exists x.
    destruct H1.
    destruct H1.
    congruence.
Qed.

Theorem Problem_23 :
  forall I, identity I -> hopelessly_egocentric I -> lonely I.
Proof.
  congruence.
Qed.

Definition lark L := forall x y, (L $ x) $ y = x $ (y $ y).

Theorem Problem_24 :
  forall L, lark L -> forall I, identity I -> exists M, mockingbird M.
Proof.
  intros.
  exists (L $ I).
  congruence.
Qed.

Theorem Problem_25 :
  forall L, lark L -> forall A, exists B, fond A B.
Proof.
  intros.
  exists (L $ A $ (L $ A)).
  congruence.
Qed.

Definition attractive A := forall B, fond B A.

Theorem Problem_26 :
  forall L, lark L -> hopelessly_egocentric L -> attractive L.
Proof.
  intros.
  intro.
  transitivity (L $ L); congruence.
Qed.

Theorem Problem_27 :
  forall L, lark L -> forall K, kestrel K -> fond L K -> exists B, lark B /\ kestrel B.
Proof.
  intros.
  replace L with K in H.
  - exists K; tauto.
  - apply Problem_19; congruence.
Qed.

Theorem Problem_28 :
  forall K, kestrel K -> forall L, lark L -> fond K L -> forall B, fond B L.
Proof.
  intros.
  apply Problem_26; congruence.
Qed.

Theorem Problem_29 :
  forall L, lark L -> exists B, egocentric B.
Proof.
  intros.
  exists (L $ L $ L $ (L $ L $ L) $ (L $ L $ L $ (L $ L $ L))).
  congruence.
Qed.

(*End*)


Require Import LogicalRelations.
Require Import Coq.Lists.List.
Require Import OptionRel.
Local Open Scope rel_scope.

(** * Testing Delay.v *)

Goal
  forall P Q : Prop, P -> P /\ Q.
Proof.
  Fail delay.
  delayed (intros; split; auto; delay); [idtac].
  (* this should leave us with the subgoal Q, which hit [delay] above. *)
Abort.

(** * Tests *)

(** ** Reflexivity *)

Goal
  forall A (a: A), a = a.
Proof.
  intros.
  rauto.
Qed.

Goal
  forall A (a: A), exists b, b = a.
Proof.
  intros; eexists.
  monotonicity.
Qed.

(** ** Setoid rewriting *)

Goal
  forall A (a b: A) `(HR: Equivalence A) (H: R a b),
    sum_rel R R (inl a) (inl b).
Proof.
  intros.
  rewrite H.
  rewrite <- H.
  reflexivity.
Qed.

(** There is an issue with the following. *)

Goal
  forall A (a b: A) (R: rel A A) (f: A -> A) (p: A -> Prop),
    Monotonic f (R ++> R) ->
    Monotonic p (R --> impl) ->
    R a b ->
    p (f b) ->
    p (f a).
Proof.
  intros A a b R f p Hf Hp Hab H.
  rewrite <- Hab in H.
  assumption.
Qed.

(** ** Monotonicity tactics *)

(** Basic sanity check. This has actually failed in the past due to
  [context_candidate] being too liberal and selecting the [RB]
  property instead of [RA], then going nowhere with that with no
  backtracking implemented yet. *)

Goal
  forall A B (RA: rel A A) (x y: A) (RB: rel B B) (z t: B),
    RA x y ->
    RB z t ->
    RA x y.
Proof.
  intros.
  rauto.
Qed.

Goal
  forall A (a b: A) (R: rel A A) (H: R a b),
    let f (x y: A * A) := (@pair (A+A) (A+A) (inr (fst x)) (inl (snd y))) in
    Monotonic f (R * ⊤ ++> ⊤ * R ++> (⊥ + R) * (R + ⊥))%rel.
Proof.
  intros; unfold f.
  rauto.
Qed.

Goal
  forall {A1 A2 B1 B2} (R1 R1': rel A1 A2) (R2 R2': rel B1 B2),
    subrel R1' R1 ->
    subrel R2 R2' ->
    subrel (R1 ++> R2) (R1' ++> R2').
Proof.
  do 10 intro.
  rauto.
Qed.

(** Check that we can use relational hypotheses from the context as
  well as [Monotonic]/[Related] instances. *)

Goal
  forall
    {A B} (R: rel A A)
    (op: A -> B) (Hop: (R ++> eq) op op)
    (x y: A) (Hxy: R x y),
    op x = op y.
Proof.
  intros.
  rauto.
Qed.

(** Bug with relational parametricity: you can't [RElim] a relation
  you don't know yet. *)

Goal
  forall {A B} (RA: rel A A) (RB: rel B B) (m n: (A -> B) * B) (x: A),
    ((- ==> RB) * RB)%rel m n ->
    RB (fst m x) (fst n x).
Proof.
  intros A B RA RB m n x Hmn.
  try monotonicity.
  try rauto.
Abort.

(** Pattern matching *)

Goal
  forall {A B} (RA: rel A A) (RB: rel B B) (x y: A) (f: A -> A + B),
    RA x y ->
    (RA ++> RA + RB) f f ->
    RA (match f x with inl a => a | inr b => x end)
       (match f y with inl a => a | inr b => y end).
Proof.
  intros.
  rauto.
Qed.

Goal
  forall {A B} (RA: rel A A) (RB: rel B B) (x y: A * B) (z: A),
    RA z z ->
    prod_rel RA RB x y ->
    RA (let (a, b) := x in z)
       (let (a, b) := y in z).
Proof.
  intros.
  rauto.
Qed.

Goal
  forall {A} (R: rel A A),
    Monotonic
      (fun (b: bool) x y => if b then x else y)
      (- ==> R ++> R ++> R).
Proof.
  intros.
  rauto.
Qed.

Goal
  forall {A} (R : rel A A) (b : bool) (x y : A),
    b = b ->
    R x x ->
    R y y ->
    R (if b then x else y)
      (if b then x else y).
Proof.
  intros.
  rauto.
Qed.

(** [rel_curry] *)

Goal
  forall {A B C} R R' S (f: A -> B -> B -> C) (x1 y1: A) (x2 y2: B),
    Monotonic f (rel_curry (R ++> R' ++> S)) ->
    S (f x1 x2 x2) (f y1 y2 y2).
Proof.
  intros A B C R R' S f x1 y1 x2 y2 Hf.
  monotonicity.
Abort.

(** If we can deduce some terms are equal, we should be able to
  rewrite them under any context. However right now this can only be
  done by declaring the [f_equal_relim] hint.

  Maybe a good solution for this might even go further: abstract the
  common context and use [eq_rect] if it's possible to prove equality
  between the variant parts. *)

Goal
  forall {A} (R: rel A A) (f: A -> A) (C: A -> Prop) x y,
    Monotonic f (R ++> eq) ->
    R x y ->
    C (f x) ->
    C (f y).
Proof.
  intros A R f C x y Hf Hxy.
  Fail rauto.
  pose proof @f_equal_relim.
  rauto.
Qed.

(** *** Hypotheses from the context *)

(* This used to fail because [Hyy] would
  shadow [Hxy] (the hypothesis we want). *)

Goal
  forall {A} (R: rel A A) (x y: A),
    R x y -> eq y y -> R x y.
Proof.
  intros A R x y Hxy Hyy.
  monotonicity.
Qed.

(* This still fail with Coq 8.5, but Coq 8.6 is able to backtrack and
  try hypothesis from the context beyond the first one it finds. *)

Goal
  forall {A} (R: rel A A) (x y: A),
    R x y -> eq x y -> R x y.
Proof.
  intros A R x y Hxy Hyy.
  try monotonicity.
Abort.

(** This used to fail because the flipped hypothesis would not be
  identified as a candidate. This is important because the constraints
  generated by the setoid rewriting system often have this form. *)

Goal
  forall {A} (R: rel A A) (f : A -> A),
    Monotonic f (R ++> R) ->
    (flip R ++> flip R) f f.
Proof.
  intros A R f Hf.
  rauto.
Qed.

(** Then *this* used to fail because the [flip] was hidden until after
  we exploit the [subrel] property. This is important in particular
  when using the equivalences for a given partial order, as in [eqrel]
  vs. [subrel], where we want to be able to use equivalences in both
  directions. *)

Goal
  forall {A} (R R': rel A A) (f: A -> A),
    Monotonic f (R ++> R) ->
    Related R' (flip R) subrel ->
    (R' ++> flip R) f f.
Proof.
  intros A R R' f Hf HR.
  rauto.
Qed.

(** As an example where proper handling of [flip] is important,
  this is a goal generated by [setoid_rewrite] when we try to rewrite
  using [eqrel] under [option_le]. Here, both [R1] and [R2] have to be
  instantiated as [flip eq] (so that the associated hypotheses can be
  used to solve goals of the form [yi = xi]), and similarly we need to
  use the super-relation [flip subrel] of [eqrel]. *)

Goal
  forall A, exists R1 R2: relation (option A),
    (eqrel ==> R1 ==> R2 ==> flip impl)%signature option_le option_le.
Proof.
  intros A. eexists. eexists.
  rauto.
Qed.

(** *** [impl] vs. [subrel] *)

(** This checks that a relational property written in terms of
  [subrel] can be used to solve a goal stated in terms of [impl].
  This is made possible by [subrel_impl_relim]. *)

Goal
  forall A B C (R: rel A A) (f: A -> rel B C) a1 a2 b c,
    Monotonic f (R ++> subrel) ->
    R a1 a2 ->
    impl (f a1 b c) (f a2 b c).
Proof.
  intros A B C R f a1 a2 b c Hf Ha.
  monotonicity; rauto.
Qed.

Goal
  forall A1 A2 B1 B2 (R1 R2: rel A1 A2) (R: rel B1 B2),
    subrel R1 R2 ->
    forall x y,
      (R2 ++> R) x y ->
      (R1 ++> R) x y.
Proof.
  intros A1 A2 B1 B2 R1 R2 R HR12 x y.
  rauto.
Qed.

(** *** Generic rules *)

(** The [coreflexivity] of [rel_prod] and [eq] makes it possible for
  [pair_rel] to behave in the same way as [f_equal] below, since they
  allow us to deduce that [eq * eq] is a [subrel] of [eq]. *)

Goal
  forall A B (x1 x2 : A) (y1 y2 : B),
    x1 = x2 -> y1 = y2 -> (x1, y1) = (x2, y2).
Proof.
  intros.
  rauto.
Qed.

(** ** Using [foo_subrel] instances *)

(** Still broken because of the interaction between [subrel] and
  [- ==> - ==> impl] (or lack thereof) *)

Goal
  forall A1 A2 B1 B2 C1 C2 (R1 R2: rel A1 A2) (R1': rel B1 B2) (R: rel C1 C2),
    subrel R1 R2 ->
    forall x y,
      (R2 ++> R) x y ->
      (R1 ++> R) x y.
Proof.
  intros A1 A2 B1 B2 C1 C2 R1 R2 R1' R HR12 x y H.
  rewrite HR12.
  assumption.
Qed.

Goal
  forall A B (xa1 xa2 ya1 ya2 : A) (xb1 xb2 yb1 yb2 : B)
         (opA: A -> A -> A) (opB: B -> B -> B)
         (RA: rel A A) (RB: rel B B)
         (HopA: Monotonic opA (RA ++> RA ++> RA))
         (HopB: Monotonic opB (RB ++> RB ++> RB))
         (Hxa: RA xa1 xa2)
         (Hxb: RB xb1 xb2)
         (Hya: RA ya1 ya2)
         (Hyb: RB yb1 yb2),
    (RA * RB)%rel
      (opA xa1 ya1, opB xb1 yb1)
      (opA xa2 ya2, opB xb2 yb2).
Proof.
  intros.
  rauto.
Qed.

Goal
  forall A1 A2 B1 B2 C1 C2 (R1 R2: rel A1 A2) (R1': rel B1 B2) (R: rel C1 C2),
    subrel R1 R2 ->
    forall x y,
      (R2 * R1' ++> R) x y ->
      (R1 * R1' ++> R) x y.
Proof.
  intros A1 A2 B1 B2 C1 C2 R1 R2 R1' R HR12 x y H.
  rewrite HR12.
  assumption.
Qed.

(** ** The [rgraph] tactic *)

Goal
  forall {A} (R S T: rel A A),
    subrel R S ->
    subrel S R ->
    subrel S T ->
    subrel R T.
Proof.
  intros.
  rstep.
Qed.

Goal
  forall `(PER) (x y z t : A),
    R x y ->
    R z y ->
    R z t ->
    R t x.
Proof.
  intros.
  rstep.
Qed.

(** ** General issues *)

(** Assumptions can be used by [Monotonicity] to solve the goal.
  However, consider the goal [?R f g |- (- ==> S) f g].
  [Monotonicity] can solve this by instantiating [R] and using the
  hypothesis, however [RIntro] will take precedence in this case.
  This means we will end up with a goal [?R f g, x |- S (f x) (g x)]
  that cannot be solved anymore.

  When [?R] is already [- ==> S] or some equivalent relation, this is
  not a problem, because the work done by [RIntro] can essentially be
  undone later by [Monotonicity]. However when [?R] is an existential
  variable this is not true and we would prefer an earlier
  instantiation.

  This is a possible workaround:
<<<
Lemma assumption_rstep {P : Prop} :
  P -> RStep True P.
Proof.
  firstorder.
Qed.

Global Hint Extern 1 (RStep _ (_ ?x ?y)) =>
  lazymatch goal with
    H : ?R x y |- _ => is_evar R; eexact (assumption_rstep H)
  end : typeclass_instances.
>>>
  *)

Goal
  forall A B (R : relation B) (f g : A -> B), exists X : relation (A -> B),
    X f g ->
    (- ==> R) f g.
Proof.
  intros. eexists. intros.
  Fail rauto.
  monotonicity.
Abort.

(** ** The [transport] tactic *)

Goal
  forall W acc A B C (R1: W -> rel A A) (R2: W -> rel B B) (R3: W -> rel C C),
  forall f g a b x w,
    Monotonic f (rforall w, R1 w ++> R2 w) ->
    Monotonic g (rforall w, R2 w ++> option_rel (rel_incr acc R3 w)) ->
    R1 w a b ->
    g (f a) = Some x ->
    exists y, rel_incr acc R3 w x y.
Proof.
  intros.
  transport H2.
  eexists.
  rauto.
Qed.

(** ** Tests for specific relators *)

(** *** [list_rel] *)

(** [list_subrel] use to not work because of a missing [Params] declaration. *)

Goal
  forall A B (R R': rel A B) l1 l2 x y,
    subrel R R' ->
    list_rel R l1 l2 ->
    R' x y ->
    list_rel R' (x :: l1) (y :: l2).
Proof.
  intros.
  rauto.
Qed.

(** *** [rel_pull] *)

(** The [RIntro] instance for [rel_pull] used to be less general. *)

Goal
  forall A B (f: A -> B) (R: rel B B) x y,
    R (f x) (f y) ->
    (R @@ f) x y.
Proof.
  intros.
  rauto.
Qed.

(** We don't want the introduction rule for [rel_pull] to shadow
  relational properties. *)

Lemma rel_pull_2:
  forall A B (f: A -> B) (R: rel B B) (g: A -> A) x y,
    Monotonic g (⊤ ==> R @@ f) ->
    (R @@ f) (g x) (g y).
Proof.
  intros.
  rauto.
Qed.

(** *** [rel_all] *)

Lemma rel_all_1:
  forall {A} (x: A),
    (rforall a, req a) x x -> forall a, req a x x.
Proof.
  intros.
  rauto.
Qed.

(** *** [rel_ex] *)

Lemma rel_ex_1:
  forall {A} (x: A),
    (rexists a, req a) x x.
Proof.
  intros.
  rauto.
Qed.

(** *** [rel_top] *)

(** We used to only have an [RIntro] instance for [⊤%rel], which is
  enough for proving all goals of the form [⊤%rel x y] but not enough
  to derive properties of relations in which [⊤%rel] is a component. *)

Lemma rel_top_component_refl:
  forall {A} (x: list A),
    list_rel ⊤ x x.
Proof.
  intros.
  rauto.
Qed.

Lemma rel_top_component_trsym:
  forall {A} (x y z: list A),
    list_rel ⊤ x y -> list_rel ⊤ z y -> list_rel ⊤ x z.
Proof.
  intros.
  rauto.
Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

(* Contribution to the Coq Library   V6.3 (July 1999)                    *)

(****************************************************************)
(*           The Calculus of Inductive Constructions            *)
(*                       COQ v5.10                              *)
(*                                                              *)
(* Laurent Arditi.  Laboratoire I3S. CNRS ura 1376.             *)
(* Universite de Nice - Sophia Antipolis                        *)
(* arditi@unice.fr, http://wwwi3s.unice.fr/~arditi/lolo.html    *)
(*                                                              *)
(* date: may 1995                                               *)
(* file: Arith_compl.v                                          *)
(* contents: additionnal lemmas on plus,mult,minus,le...        *)
(* definitions of 2^ and factorial, lemmas about them           *)
(****************************************************************)

Require Export Plus.
Require Export Mult.
Require Import Minus.
Require Export Lt.
Require Export Le.
Require Export Gt.

(****************************************************************)
(* Complements sur plus et mult *)

Lemma plus_n_SO : forall x : nat, x + 1 = S x.
intros; rewrite plus_comm; auto with arith.
Qed. Hint Resolve plus_n_SO.

Lemma plus_permute2 : forall x y z : nat, x + y + z = x + z + y.
intros.
rewrite (plus_comm x y).
rewrite (plus_comm x z).
rewrite plus_comm.
symmetry  in |- *.
rewrite plus_comm.
rewrite plus_permute.
auto with arith.
Qed. Hint Resolve plus_permute2.

Lemma mult_sym : forall a b : nat, a * b = b * a.
intros a b; elim a; simpl in |- *; auto with arith.
intros y H.
replace (y * b) with (b * y).
elim (mult_n_Sm b y).
apply plus_comm.
Qed. Hint Resolve mult_sym.

Lemma mult_permute : forall a b c : nat, a * b * c = a * c * b.
intros.
rewrite mult_assoc_reverse.
rewrite mult_assoc_reverse.
replace (c * b) with (b * c); auto with arith.
Qed. Hint Resolve mult_permute.

(*
Lemma plus_n_n : (n:nat)((plus n n)=(mult n (S (S O)))).
Intro.
Rewrite -> mult_sym.
Simpl.
Replace (plus n O) with (plus O n);Auto with arith.
Qed. Hints Resolve plus_n_n.
*)

Lemma plus_O_O : forall n m : nat, n + m = 0 -> n = 0.
simple induction n. intros. trivial with arith.
intros. inversion H0.
Qed.

Lemma mult_plus_distr2 : forall n m p : nat, n * (m + p) = n * m + n * p.
intros. rewrite mult_sym. rewrite mult_plus_distr_r. rewrite mult_sym.
replace (p * n) with (n * p). trivial with arith. apply mult_sym.
Qed.

(****************************************************************)
(* La fonction puissance de 2 *)

Fixpoint power2 (n : nat) : nat :=
  match n with
  | O => 1
  | S x => power2 x + power2 x
  end.

Lemma power2_eq2 : forall x : nat, power2 (S x) = power2 x + power2 x.
Proof.
 auto with arith.
Qed.

(*
Lemma power2_SO : ((S (S O))=(power2 (S O))).
Auto with arith. Qed. Hints Resolve power2_SO.

Lemma mult_power2 : (x,y:nat)
		((mult (power2 x) (power2 y))=(power2 (plus x y))).
*)
Lemma power2_plus : forall x y : nat, power2 (x + y) = power2 x * power2 y.
simple induction x. intros. simpl in |- *. elim plus_n_O; auto with arith.
intros. simpl in |- *. rewrite H. rewrite mult_plus_distr_r. trivial with arith.
Qed.

(****************************************************************)
(* Complements sur Lt Le Gt... *)

Theorem le_plus_n_m : forall n m : nat, n <= m -> n + n <= m + m.
simple induction n. auto with arith.
intros. inversion H0. auto with arith.
simpl in |- *. elim plus_n_Sm. elim plus_n_Sm.
apply le_n_S. apply le_n_S. apply H. apply le_Sn_le. exact H1.
Qed. Hint Resolve le_plus_n_m.

Theorem lt_plus_n_m : forall n m : nat, n < m -> S (n + n) < m + m.
simple induction n.
simpl in |- *. simple induction m. simpl in |- *. intros. absurd (0 < 0). apply le_not_lt. auto with arith.
exact H.
intros. simpl in |- *. elim plus_n_Sm. apply lt_n_S. auto with arith.
intros. inversion H0. simpl in |- *. repeat elim plus_n_Sm. auto with arith.
simpl in |- *.
repeat elim plus_n_Sm. apply lt_n_S. apply lt_n_S. apply H. inversion H1. auto with arith.
apply le_lt_n_Sm. apply le_Sn_le. apply le_Sn_le. exact H3.
Qed.

Lemma le_plus_lem1 : forall a b c : nat, a <= b -> c + a <= c + b.
intros. inversion H. auto with arith.
elim plus_n_Sm. apply le_S. auto with arith.
Qed. Hint Resolve le_plus_lem1.

Lemma le_plus_lem2 : forall a b c : nat, c + a <= c + b -> a <= b.
simple induction c. auto with arith.
simpl in |- *. intros. apply H. apply le_S_n. exact H0.
Qed.

Lemma gt_double : forall a b : nat, a + a > b + b -> a > b.
simple induction a. simpl in |- *. intros. absurd (0 > b + b). auto with arith.
auto with arith. simple induction b. simpl in |- *. auto with arith.
intros. apply gt_n_S.
apply H. generalize H1. simpl in |- *. elim plus_n_Sm. elim plus_n_Sm. intro.
cut (S (n + n) > S (n0 + n0)). intro. apply gt_S_n. exact H3.
apply gt_S_n. exact H2.
Qed.

Lemma gt_double_inv : forall a b : nat, a > b -> a + a > b + b.
simple induction a. intros. absurd (0 > b). auto with arith. exact H.
simple induction b. intros. simpl in |- *. auto with arith.
intros. simpl in |- *. elim plus_n_Sm.
elim plus_n_Sm. apply gt_n_S. apply gt_n_S. apply H. apply gt_S_n. exact H1.
Qed.

Lemma gt_double_n_S : forall a b : nat, a > b -> a + a > S (b + b).
simple induction a. intros. absurd (0 > b). auto with arith.
exact H.
simple induction b. simpl in |- *. intro.
apply gt_n_S. unfold gt in |- *. unfold lt in |- *. elim plus_n_Sm. auto with arith.
intros. simpl in |- *. apply gt_n_S.
elim plus_n_Sm. apply gt_n_S. elim plus_n_Sm. apply H. apply gt_S_n. exact H1.
Qed.

Lemma gt_double_S_n : forall a b : nat, a > b -> S (a + a) > b + b.
intros. apply gt_trans with (a + a). auto with arith. apply gt_double_inv. exact H.
Qed.

(****************************************************************)
(* Complements sur minus *)

Lemma minus_le_O : forall a b : nat, a <= b -> a - b = 0.
intros. pattern a, b in |- *. apply le_elim_rel. auto with arith.
intros. simpl in |- *. exact H1.
exact H.
Qed.

Lemma minus_n_SO : forall n : nat, n - 1 = pred n.
simple induction n. auto with arith. intros. simpl in |- *. auto with arith.
Qed.

Lemma minus_le_lem2c : forall a b : nat, a - S b <= a - b.
intros. pattern a, b in |- *. apply nat_double_ind. auto with arith.
intro. elim minus_n_O. rewrite minus_n_SO. simpl in |- *. auto with arith.
intros. simpl in |- *. exact H.
Qed.

Lemma minus_le_lem2 : forall a b : nat, a - b <= a.
simple induction b. elim minus_n_O. auto with arith.
intros. apply le_trans with (a - n). apply minus_le_lem2c.
exact H.
Qed. Hint Resolve minus_le_lem2.

Lemma minus_minus_lem1 : forall a b : nat, a - b - a = 0.
intros. apply minus_le_O. apply minus_le_lem2.
Qed. Hint Resolve minus_minus_lem1.

Lemma minus_minus_lem2 : forall a b : nat, b <= a -> a - (a - b) = b.
simple induction b. intros. elim minus_n_O. elim minus_n_n. trivial with arith. intros.
replace (a - (a - S n)) with (S a - S (a - S n)).
rewrite <- (minus_Sn_m a (S (a - S n))). rewrite (minus_Sn_m a (S n)).
simpl in |- *. rewrite <- H. rewrite H. rewrite H. trivial with arith.
apply le_Sn_le. exact H0.
apply le_Sn_le. exact H0. apply le_Sn_le. exact H0. exact H0.
rewrite minus_Sn_m. simpl in |- *. apply minus_le_lem2. exact H0. simpl in |- *. trivial with arith.
Qed.

Lemma le_minus_minus : forall a b c : nat, c <= b -> a - b <= a - c.
simple induction a. simpl in |- *. auto with arith.
intros. generalize H0. elim c. elim minus_n_O. intro. apply minus_le_lem2.
elim b. intros. absurd (S n0 <= 0). auto with arith.
exact H2.
intros. simpl in |- *. apply H. apply le_S_n. exact H3.
Qed.