Require Import Category.Lib.
Require Import Category.Theory.Category.
Require Import Category.Theory.Isomorphism.
Require Import Category.Theory.Functor.
Require Import Category.Functor.Product.Internal.
Require Import Category.Functor.Hom.Internal.
Require Import Category.Structure.Terminal.
Require Import Category.Structure.Cartesian.
Require Import Category.Structure.Cartesian.Closed.
Require Import Category.Structure.Monoidal.Closed.
Require Import Category.Instance.Sets.

Generalizable All Variables.

Section InternalProduct.

Context {C : Category}.
Context `{@Cartesian C}.
Context `{@Terminal C}.

#[local] Ltac solveit :=
  unfold proj_left, proj_right;
  try split; intros; unfork; cat.

(* Every cartesian category with terminal objects gives rise to a monoidal
   category taking the terminal object as unit, and the tensor as product. *)

Program Definition CC_Monoidal : @Monoidal C := {|
  tensor := InternalProductFunctor C;
  I := 1
|}.
Next Obligation.
  intros.
  simpl.
  rewrite <- !fork_comp.
  apply Cartesian.fork_respects.
  - rewrite id_left.
    rewrite exl_fork.
    cat.
    apply one_unique.
  - rewrite id_left.
    rewrite exr_fork_assoc.
    apply id_right.
Qed.
Next Obligation.
  intros. simpl.
  rewrite <- !fork_comp.
  apply Cartesian.fork_respects.
  - rewrite exl_fork_assoc.
    cat.
  - cat.
    apply one_unique.
Qed.
Next Obligation.
  (* Time Succeed solve [solveit]. *)
  intros. simpl.
  rewrite <- fork_comp.
  symmetry.
  rewrite <- fork_comp.
  rewrite !exl_fork_assoc.
  apply Cartesian.fork_respects.
  { rewrite exl_fork_comp.
    apply comp_assoc_sym.
  }
  rewrite <- fork_comp.
  symmetry.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  apply Cartesian.fork_respects.
  - rewrite exr_fork_assoc.
    rewrite !exl_fork_assoc.
    rewrite !exr_fork_comp.
    apply comp_assoc.
  - rewrite !exr_fork_assoc.
    symmetry.
    apply exr_fork.
Qed.
Next Obligation.
  (* Time Succeed solve [solveit]. *)
  intros. simpl.
  do 5 rewrite <- fork_comp.
  repeat apply Cartesian.fork_respects.
  - rewrite !exl_fork_assoc.
    symmetry.
    apply exl_fork.
  - rewrite !exl_fork_assoc.
    rewrite !exr_fork_assoc.
    rewrite exl_fork_comp.
    apply comp_assoc.
  - rewrite !exr_fork_assoc.
    rewrite !exr_fork_comp.
    apply comp_assoc.
Qed.
Next Obligation.
  (* Time Succeed solve [solveit]. *)
  intros. simpl.
  rewrite <- fork_comp.
  apply Cartesian.fork_respects.
  - rewrite id_left.
    symmetry.
    apply exl_fork.
  - rewrite id_left.
    rewrite exr_fork_assoc.
    symmetry. apply exr_fork.
Qed.
Next Obligation.
  (* Time Succeed solve [solveit]. *)
  intros. simpl.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  symmetry.
  rewrite <- fork_comp.
  apply Cartesian.fork_respects.
  { rewrite id_left.
    rewrite exl_fork_assoc.
    rewrite exl_fork.
    rewrite exl_fork_assoc.
    rewrite exl_fork_comp.
    apply comp_assoc.
  }
  rewrite exr_fork_assoc.
  do 3 rewrite <- fork_comp.
  rewrite exl_fork_assoc.
  rewrite exl_fork_assoc.
  apply Cartesian.fork_respects.
  { symmetry.
    etransitivity.
    { rewrite <- comp_assoc.
      apply compose_respects; [reflexivity|].
      rewrite exl_fork_assoc.
      apply exr_fork_comp.
    }
    rewrite exl_fork_comp.
    apply comp_assoc_sym.
  }
  rewrite exr_fork.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  apply Cartesian.fork_respects.
  { rewrite exl_fork_assoc.
    symmetry.
    etransitivity.
    { rewrite <- comp_assoc.
      apply compose_respects; [reflexivity|].
      rewrite exl_fork_assoc.
      apply exr_fork_comp.
    }
    apply exr_fork_comp.
  }
  symmetry.
  rewrite exr_fork.
  rewrite exr_fork.
  apply id_left.
Qed.

Lemma exl_swap {x y z w} :
  @exl x y z w ∘ swap ≈ exr.
Proof. solveit. Qed.

Lemma exr_swap {x y z w} :
  @exr x y z w ∘ swap ≈ exl.
Proof. solveit. Qed.

Program Definition CC_BraidedMonoidal : @BraidedMonoidal C := {|
  braided_is_monoidal := CC_Monoidal;
  braid := @swap C _
|}.
Next Obligation.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  rewrite swap_fork.
  rewrite <- fork_comp.
  apply Cartesian.fork_respects.
  - rewrite <- comp_assoc.
    rewrite <- comp_assoc.
    rewrite <- comp_assoc.
    apply compose_respects; try reflexivity.
    rewrite exl_fork_comp.
    rewrite exr_fork.
    rewrite !id_left.
    apply exl_swap.
  - rewrite id_left.
    rewrite id_left.
    rewrite id_left.
    rewrite exr_fork.
    rewrite exl_fork.
    rewrite <- comp_assoc.
    apply compose_respects; try reflexivity.
    apply exr_swap.
Qed.
Next Obligation.
  (* Time Succeed solve [solveit]. *)
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  symmetry.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  apply Cartesian.fork_respects.
  { rewrite exl_fork_assoc.
    rewrite id_left.
    rewrite exl_fork_assoc.
    symmetry.
    rewrite <- comp_assoc.
    rewrite swap_fork.
    rewrite exl_fork_assoc.
    rewrite exl_fork.
    unfold swap.
    rewrite exl_fork_comp.
    reflexivity.
  }
  rewrite exr_fork_assoc.
  rewrite swap_fork.
  rewrite <- comp_assoc.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  apply Cartesian.fork_respects.
  - rewrite exr_fork.
    rewrite id_left.
    rewrite swap_fork.
    rewrite exl_fork_assoc.
    rewrite exr_fork.
    reflexivity.
  - rewrite exl_fork_assoc.
    rewrite comp_assoc.
    rewrite exr_swap.
    etransitivity.
    2: {
      apply compose_respects; [reflexivity|].
      symmetry.
      apply swap_fork.
    }
    symmetry.
    apply exr_fork.
Qed.
Next Obligation.
  (* Time Succeed solve [solveit]. *)
  intros. simpl.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  symmetry.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  apply Cartesian.fork_respects.
  { rewrite exl_fork_assoc.
    rewrite id_left.
    rewrite swap_fork.
    rewrite <- comp_assoc.
    rewrite swap_fork.
    symmetry.
    rewrite <- fork_comp.
    rewrite exl_fork.
    rewrite <- comp_assoc.
    rewrite exr_fork.
    rewrite exl_fork.
    rewrite <- fork_comp.
    rewrite <- comp_assoc.
    rewrite exr_fork.
    rewrite exl_fork.
    unfold swap.
    rewrite exl_fork_comp.
    reflexivity.
  }
  rewrite exr_fork_assoc.
  rewrite !id_left.
  rewrite <- comp_assoc.
  rewrite exr_fork.
  unfold swap.
  rewrite comp_assoc.
  rewrite exr_fork.
  rewrite <- !comp_assoc.
  rewrite (comp_assoc exr (exr △ exl)).
  rewrite exr_fork.
  rewrite exl_fork.
  rewrite exr_fork.
  reflexivity.
Qed.

Program Definition CC_BalancedMonoidal : @BalancedMonoidal C := {|
  balanced_is_braided := CC_BraidedMonoidal;
  twist := fun _ =>
    {| to   := id
     ; from := id
     ; iso_to_from := _
     ; iso_from_to := _
    |}
|}.

Definition CC_SymmetricMonoidal : @SymmetricMonoidal C := {|
  symmetric_is_braided := CC_BraidedMonoidal;
  braid_invol := @swap_invol _ _
|}.

Program Definition CC_RelevanceMonoidal : @RelevanceMonoidal C := {|
  relevance_is_symmetric := CC_SymmetricMonoidal;
  diagonal  := fun _ => Cartesian.fork id id
|}.
Next Obligation.
  cat_simpl.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  apply Cartesian.fork_respects.
  - rewrite exl_fork_assoc.
    cat.
  - rewrite exr_fork_assoc.
    cat.
Qed.
Next Obligation.
  cat_simpl. apply Cartesian.fork_respects; try reflexivity.
  apply one_unique.
Qed.
Next Obligation.
  (* Time Succeed solve [solveit]. *)
  simpl. intros.
  rewrite <- fork_comp.
  symmetry.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  rewrite !exl_fork_assoc.
  rewrite !exl_fork_comp.
  apply Cartesian.fork_respects.
  { cat. }
  rewrite exr_fork_assoc.
  rewrite id_right.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  apply Cartesian.fork_respects.
  - rewrite exl_fork_assoc.
    rewrite exr_fork_comp.
    cat_simpl.
  - rewrite exr_fork.
    cat_simpl.
Qed.
Next Obligation.
  intros. simpl.
  rewrite swap_fork.
  reflexivity.
Qed.
Next Obligation.
  intros. simpl.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  rewrite <- fork_comp.
  apply Cartesian.fork_respects.
  - rewrite <- fork_comp.
    rewrite exl_fork.
    rewrite id_left.
    rewrite <- fork_comp.
    rewrite <- fork_comp.
    rewrite exl_fork.
    rewrite exl_fork_assoc.
    rewrite exl_fork_comp.
    rewrite id_left.
    rewrite <- fork_exl_exr.
    apply Cartesian.fork_respects; try reflexivity.
    rewrite exr_fork_assoc.
    rewrite comp_assoc.
    rewrite comp_assoc.
    rewrite comp_assoc.
    rewrite exl_fork.
    rewrite exl_fork_assoc.
    rewrite comp_assoc.
    rewrite exl_swap.
    rewrite exl_fork_assoc.
    rewrite exr_fork.
    rewrite !exr_fork_assoc.
    rewrite exl_fork_comp.
    cat_simpl.
  - rewrite exr_fork_assoc.
    rewrite comp_assoc.
    rewrite comp_assoc.
    rewrite comp_assoc.
    rewrite exr_fork.
    rewrite <- fork_comp.
    rewrite exl_fork_assoc.
    rewrite comp_assoc.
    rewrite exr_swap.
    rewrite <- fork_comp.
    rewrite exl_fork_assoc.
    rewrite exl_fork.
    rewrite <- fork_comp.
    rewrite <- fork_comp.
    rewrite <- fork_comp.
    rewrite <- fork_exl_exr.
    apply Cartesian.fork_respects.
    + rewrite exr_fork_assoc.
      rewrite exl_fork.
      rewrite exl_fork_assoc.
      rewrite exr_fork_comp.
      cat_simpl.
    + rewrite exr_fork.
      rewrite id_left.
      rewrite exr_fork.
      rewrite !exr_fork_assoc.
      rewrite exr_fork_comp.
      cat_simpl.
Qed.

Program Definition CC_SemicartesianMonoidal :
  @SemicartesianMonoidal C CC_Monoidal := {|
  eliminate := fun o => one[o]
|}.
Next Obligation.
  intros.
  apply one_unique.
Qed.

#[local] Obligation Tactic := program_simpl; solveit; auto.

Program Definition CC_CartesianMonoidal : @CartesianMonoidal C := {|
  cartesian_is_relevance     := CC_RelevanceMonoidal;
  cartesian_is_semicartesian := CC_SemicartesianMonoidal;
|}.

Context `{CL : @Closed C _}.

Program Definition CCC_ClosedMonoidal : @ClosedMonoidal C := {|
  closed_is_cartesian := CC_CartesianMonoidal;
  exponent_obj := λ x y, @fobj _ _ (@InternalHomFunctor C _ CL) (x, y);
  exp_iso := @Cartesian.Closed.exp_iso C _ _;
|}.
Next Obligation.
  exists (to (@Cartesian.Closed.exp_iso C _ _ x y z) f).
  - cat.
  - intros.
    rewrite X; clear X.
    rewrite id_left.
    pose proof (@Cartesian.Closed.eval_first C _ _ _ _ _ v).
    cbv in X.
    rewrite X.
    sapply (iso_to_from (@Cartesian.Closed.exp_iso C _ _ x y z)).
Qed.

End InternalProduct.


Require Import AbsTheorySem.
Require Import SN_NAT.

Import GenLemmas.
Import SN_CC_Real.
Import ZF SN CCSN.
Import ZFind_nat Sat SATnat SN_NAT.

(*Instantiate the semantic of First Order Theory with Presburger*)
Module PSemSig <: AbsSemSig.

(*Presburger is the uni-sort theroy*)
Definition sort := Nat.

Lemma sort_not_kind : sort <> kind.
Proof. discriminate. Qed.

Lemma typ_sort : forall e, typ e sort kind.
Proof. apply typ_N. Qed.

Lemma sort_clsd :
  (forall n k, eq_trm (lift_rec n k sort) sort) /\
  (forall t k, eq_trm (subst_rec t k sort) sort).
Proof. split; intros; simpl; split; red; reflexivity. Qed.

Definition wf_clsd_env e := forall i j, val_ok e i j ->
  exists j', val_ok e i j' /\ (forall n, closed_pure_trm (j' n)).

Definition prf_T : trm.
left.
exists (fun _ => lam props (fun x => lam x (fun y => y)))
  (fun _ => Lc.Abs (Lc.Abs (Lc.Ref 0))).
do 2 red; intros. reflexivity.

do 2 red; intros. reflexivity.

red; intros. reflexivity.

red; intros. reflexivity.

Defined.

Lemma Tprf : forall i j,
  [int i prf_T, tm j prf_T] \real prod props (fun x => prod x (fun _ => x)).
intros. simpl int; simpl tm.
apply prod_intro_lam.
 do 2 red; intros. apply lam_ext; [|do 2 red; intros]; trivial.

 do 2 red; intros. apply prod_ext; [|do 2 red; intros]; trivial.

 apply Lc.sn_abs. apply Lc.sn_var.

 intros. unfold Lc.subst. simpl Lc.subst_rec.
 apply prod_intro_lam.
  do 2 red; intros; trivial.

  do 2 red; intros; reflexivity.

  apply Lc.sn_var.

  intros. unfold Lc.subst; simpl Lc.subst_rec.
  rewrite Lc.lift0; trivial.
Qed.

Lemma FprfF : forall i j v,
  (forall n : nat, closed_pure_trm (j n)) ->
  [int i v, tm j v] \real prod props (fun p => p) -> False.
intros i j v Hclsd Hv.
assert (forall S, inSAT (Lc.App (tm j v) (Lc.Abs (Lc.Ref 0))) S) as HF.
 intros.
 assert ([mkProp S, Lc.Abs (Lc.Ref 0)] \real props).
  assert (mkProp S ∈ El props).
   rewrite El_props_def. exists S. reflexivity.
  split; trivial.
   rewrite Real_sort; trivial. apply Lc.sn_abs; apply Lc.sn_var.

 apply SN.prod_elim with (x:=mkProp S) (u:=Lc.Abs (Lc.Ref 0)) in Hv; trivial.
  destruct Hv. rewrite Real_mkProp in H1; trivial.
  unfold inX, mkProp at 2 in H0. rewrite El_def in H0.
  apply singl_elim in H0; trivial.

  do 2 red; intros; trivial.

 destruct (neutral_not_closed _ HF).
 inversion_clear H.
  apply tm_closed in H0. unfold closed_pure_trm in Hclsd.
    apply False_ind. apply H0. intros. apply Hclsd.

    inversion_clear H0. inversion_clear H.
Qed.

Definition P1 := (lam (mkTY NAT cNAT) (fun x =>
    NATREC (prod props (fun p => prod p (fun p1 => p)))
    (fun _ _ => prod props (fun p => p)) x)).

Lemma P1_real : [P1, Lc.K]\real prod (mkTY NAT cNAT) (fun _ : X => props).
assert (forall x, x ∈ NAT ->
  NATREC (prod props (fun p : set => prod p (fun _ : set => p)))
  (fun _ _ : set => prod props (fun p : set => p)) x ∈ El props).
 intros; change (El props) with ((fun _ => El props) x).
  apply NATREC_typ; [do 2 red; reflexivity|do 3 red; reflexivity|trivial| |intros].
   apply impredicative_prod.
    do 2 red; intros; apply prod_ext; [|do 2 red]; trivial.

    intros; apply impredicative_prod; [do 2 red; reflexivity|trivial].

   apply impredicative_prod; [do 2 red |]; trivial.

apply prod_intro_lam.
 do 2 red; intros; apply NATREC_morph; [reflexivity|do 3 red; reflexivity|trivial].

 do 2 red; reflexivity.

 apply Lc.sn_abs; apply Lc.sn_var.

 intros; destruct H0 as (Hx, Hu); unfold inX in Hx; rewrite El_def in Hx; split.
  unfold inX; apply H; trivial.

  unfold Lc.subst; simpl Lc.subst_rec. rewrite Real_sort; [clear H|apply H; trivial].
   apply Lc.sn_abs; apply Lc.sn_lift; apply sat_sn in Hu; trivial.
Qed.

Definition P1t : trm.
left. exists (fun _ => P1) (fun _ => Lc.K).
do 2 red; intros. reflexivity.

do 2 red; intros. reflexivity.

red; intros. reflexivity.

red; intros. reflexivity.
Defined.

Lemma P1_ZERO : app P1 ZERO == prod props (fun p => prod p (fun p1 => p)).
unfold P1. rewrite beta_eq.
 rewrite NATREC_0; reflexivity.

 do 2 red; intros. apply NATREC_morph; [reflexivity|do 3 red; intros; reflexivity|trivial].

 rewrite El_def. apply ZERO_typ.
Qed.

Lemma P1_SUCC : forall n, n ∈ NAT -> app P1 (SUCC n) == prod props (fun p => p).
unfold P1; intros; rewrite beta_eq.
 rewrite NATREC_S; [reflexivity|do 3 red; reflexivity|trivial].

 do 2 red; intros; apply NATREC_morph; [reflexivity|do 3 red; reflexivity|trivial].

 rewrite El_def; apply SUCC_typ; trivial.
Qed.

Definition P2 := (lam (mkTY NAT cNAT) (fun x =>
    NATREC (prod props (fun p => p))
    (fun _ _ => prod props (fun p => prod p (fun p1 => p))) x)).

Lemma P2_real : [P2, Lc.K]\real prod (mkTY NAT cNAT) (fun _ : X => props).
assert (forall x, x ∈ NAT ->
  NATREC (prod props (fun p : set => p))
  (fun _ _ : set => prod props (fun p : set => prod p (fun _ : set => p))) x ∈ El props).
 intros; change (El props) with ((fun _ => El props) x).
  apply NATREC_typ; [do 2 red; reflexivity|do 3 red; reflexivity|trivial| |intros].
   apply impredicative_prod; [do 2 red |]; trivial.

   apply impredicative_prod; [do 2 red|]; intros.
    apply prod_ext; [|do 2 red]; trivial.

    apply impredicative_prod; [do 2 red; reflexivity|trivial].

apply prod_intro_lam.
 do 2 red; intros; apply NATREC_morph; [reflexivity|do 3 red; reflexivity|trivial].

 do 2 red; reflexivity.

 apply Lc.sn_abs; apply Lc.sn_var.

 intros; destruct H0 as (Hx, Hu); unfold inX in Hx; rewrite El_def in Hx; split.
  unfold inX; apply H; trivial.

  unfold Lc.subst; simpl Lc.subst_rec. rewrite Real_sort; [clear H|apply H; trivial].
   apply Lc.sn_abs; apply Lc.sn_lift; apply sat_sn in Hu; trivial.
Qed.

Definition P2t : trm.
left. exists (fun _ => P2) (fun _ => Lc.K).
do 2 red; intros. reflexivity.

do 2 red; intros. reflexivity.

red; intros. reflexivity.

red; intros. reflexivity.
Defined.

Lemma P2_SUCC : forall n, n ∈ NAT ->
  app P2 (SUCC n) == prod props (fun p => prod p (fun p1 => p)).
intros; unfold P2; rewrite beta_eq.
 rewrite NATREC_S; [reflexivity|do 3 red; reflexivity|trivial].

 do 2 red; intros. apply NATREC_morph; [reflexivity|do 3 red; intros; reflexivity|trivial].

 rewrite El_def. apply SUCC_typ; trivial.
Qed.

Lemma P2_ZERO : app P2 ZERO == prod props (fun p => p).
unfold P2; rewrite beta_eq.
 rewrite NATREC_0; reflexivity.

 do 2 red; intros; apply NATREC_morph; [reflexivity|do 3 red; reflexivity|trivial].

 rewrite El_def; apply ZERO_typ.
Qed.

Definition P3 x0 := (lam (mkTY NAT cNAT) (fun x =>
    NATREC (prod props (fun p => p)) (fun n _ => app x0 n) x)).

Lemma P3_morph : forall x y, x == y -> P3 x == P3 y.
intros. unfold P3. apply lam_ext; [reflexivity|do 2 red; intros].
 apply NATREC_morph; [reflexivity| |trivial].
  do 2 red; intros. rewrite H2; rewrite H; reflexivity.
Qed.

Definition P3t : trm -> trm.
intros P. left.
exists (fun i => P3 (int i P)) (fun j => tm j P).
do 3 red; intros. apply P3_morph; rewrite H; reflexivity.

do 2 red; intros. rewrite H. reflexivity.

destruct P. destruct i. simpl. apply itm_lift0.
red; intros. reflexivity.

destruct P. destruct i. simpl. apply itm_subst0.
red; intros. reflexivity.
Defined.

Lemma P3_real : forall x0 u,
  [x0, u]\real prod (mkTY NAT cNAT) (fun _ : set => props) ->
  [P3 x0, u]\real prod (mkTY NAT cNAT) (fun _ : X => props).
intros.
assert (forall x, x ∈ NAT ->
  NATREC (prod props (fun p : set => p))
  (fun n _ : set => app x0 n) x ∈ El props).
 intros; change (El props) with ((fun _ => El props) x).
  apply NATREC_typ; [do 2 red; reflexivity|do 3 red; intros; rewrite H1; reflexivity
    |trivial| |intros].
   apply impredicative_prod; [do 2 red |]; trivial.

   specialize (inSAT_n k H1); intros H3. destruct H3 as (x1, (H3, _)).
   apply SN.prod_elim with (x:=k) (u:=x1) in H; [|do 2 red; intros; reflexivity|].
    destruct H as (H, _); unfold inX in H; trivial.

    split; [unfold inX; rewrite El_def|]; trivial.
     rewrite Real_def; [|apply fam_mrph|]; trivial.

apply prod_intro_sn; [|do 2 red; reflexivity|apply real_sn in H; trivial|].
 do 2 red; intros; apply NATREC_morph; [reflexivity
   |do 3 red; intros; rewrite H3; reflexivity|trivial].

 intros. assert (x ∈ NAT).
  destruct H1 as (H1, _). unfold inX in H1; rewrite El_def in H1; trivial.

 apply SN.prod_elim with (x:=x) (u:=u0) in H; [apply H0 in H2|do 2 red; reflexivity|trivial].
  split; [unfold inX|rewrite Real_sort; [apply real_sn in H|]]; trivial.
Qed.

Lemma P3_SUCC : forall n x0,
  n ∈ NAT ->
  app (P3 x0) (SUCC n) == app x0 n.
intros; unfold P3; rewrite beta_eq.
 rewrite NATREC_S; [reflexivity|do 3 red; intros; rewrite H0; reflexivity|trivial].

 do 2 red; intros. apply NATREC_morph;
 [reflexivity|do 3 red; intros; rewrite H2; reflexivity|trivial].

 rewrite El_def. apply SUCC_typ; trivial.
Qed.

Lemma eq_SUCC_eq : forall m n x y,
  m ∈ NAT ->
  n ∈ NAT ->
  [x, y]\real prod (prod (mkTY NAT cNAT) (fun _ : X => props))
  (fun x0 : X => prod (app x0 (SUCC n)) (fun _ : X => app x0 (SUCC m))) ->
  [x, y]\real prod (prod (mkTY NAT cNAT) (fun _ : X => props))
  (fun x0 : X => prod (app x0 n) (fun _ : X => app x0 m)).
intros m n x y Hm Hn HS.

assert (forall m n, m ∈ NAT -> n ∈ NAT ->
prod (prod (mkTY NAT cNAT) (fun _ : X => props))
     (fun x0 : X => prod (app x0 n) (fun _ : X => app x0 m)) ∈ El props).
intros. apply impredicative_prod.
 do 2 red; intros. apply prod_ext; [|do 2 red; intros]; rewrite H2; reflexivity.

 intros; apply impredicative_prod.
  do 2 red; intros; reflexivity.

  apply prod_elim with (x:=m0) in H1; trivial.
   do 2 red; intros; reflexivity.

   rewrite El_def; trivial.

assert (prod (prod (mkTY NAT cNAT) (fun _ : X => props))
  (fun x0 : X => prod (app x0 (SUCC n)) (fun _ : X => app x0 (SUCC m))) ∈ El props).
apply H; apply SUCC_typ; trivial.

assert (prod (prod (mkTY NAT cNAT) (fun _ : X => props))
  (fun x0 : X => prod (app x0 n) (fun _ : X => app x0 m)) ∈ El props).
apply H; trivial.

rewrite El_props_def in H0, H1. destruct H0, H1.

assert ((lam (prod (mkTY NAT cNAT) (fun _ => props))
(fun x0 => lam (app x0 n) (fun x1 => app (app x (P3 x0)) x1))) ∈
El (prod (prod (mkTY NAT cNAT) (fun _ : X => props))
     (fun x0 : X => prod (app x0 n) (fun _ : X => app x0 m)))).
apply prod_intro.
 do 2 red; intros. apply lam_ext; [rewrite H3; reflexivity|do 2 red; intros; rewrite H5].
  apply app_ext; [|reflexivity].
   apply app_ext; [reflexivity|unfold P3].
    apply lam_ext; [reflexivity|do 2 red; intros].
     apply NATREC_morph;
       [reflexivity|do 2 red; intros; rewrite H3; rewrite H8; reflexivity|trivial].

 do 2 red; intros. apply prod_ext; [|do 2 red; intros]; rewrite H3; reflexivity.

 intros. apply prod_intro.
  do 2 red; intros. rewrite H4; reflexivity.

  do 2 red; intros. reflexivity.

  intros. destruct HS as (HS, _); unfold inX in HS.
  assert (P3 x2 ∈ El (prod (mkTY NAT cNAT) (fun _ : X => props))).
   unfold P3. apply prod_intro.
    do 2 red; intros.
    apply NATREC_morph; [reflexivity|do 3 red; intros; rewrite H6; reflexivity|trivial].

    do 2 red; intros; reflexivity.

    intros. change (El props) with ((fun _ => El props) x4). apply NATREC_typ; intros.
     do 2 red; intros; reflexivity.

     do 3 red; intros. rewrite H5; reflexivity.

     rewrite El_def in H4; trivial.

     apply impredicative_prod; [do 2 red|]; trivial.

     apply prod_elim with (x:=k) in H2;
       [|do 2 red; intros; reflexivity|rewrite El_def]; trivial.

  apply prod_elim with (x:=(P3 x2)) in HS; [|do 2 red; intros|trivial].
  2 : apply prod_ext; [|do 2 red; intros]; rewrite H6; reflexivity.
  assert (El (prod (app (P3 x2) (SUCC n)) (fun _ : X => app (P3 x2) (SUCC m))) ==
   El (prod (app x2 n) (fun _ : X => app x2 m))).
   apply El_morph; apply prod_ext; [|do 2 red; intros]; rewrite P3_SUCC; trivial; reflexivity.

  rewrite H5 in HS; clear H5.
  apply prod_elim with (x:=x3) in HS; trivial.
   do 2 red; intros; reflexivity.

assert (x == (lam (prod (mkTY NAT cNAT) (fun _ => props))
(fun x0 => lam (app x0 n) (fun x1 => app (app x (P3 x0)) x1)))).
 destruct HS as (HS, _); unfold inX in H1.
 rewrite H0 in HS; rewrite H1 in H2. rewrite El_mkProp in HS, H2.
 apply singl_elim in HS; apply singl_elim in H2. rewrite HS, H2; reflexivity.

assert ([lam (prod (mkTY NAT cNAT) (fun _ : set => props))
         (fun x0 : set => lam (app x0 n) (fun  x1 => app (app x (P3 x0)) x1)), y]\real
  prod (prod (mkTY NAT cNAT) (fun _ : X => props))
  (fun x2 : X => prod (app x2 n) (fun _ : X => app x2 m)) ->
  [x, y]\real prod (prod (mkTY NAT cNAT) (fun _ : X => props))
  (fun x2 : X => prod (app x2 n) (fun _ : X => app x2 m))).
apply real_morph; [trivial| |]; reflexivity.

apply H4. clear H0 x0 H x1 H1 H2 H3 H4.
apply prod_intro_sn.
 do 2 red; intros. apply lam_ext; [rewrite H0; reflexivity|do 2 red; intros].
  apply app_ext; trivial.
   apply app_ext; [reflexivity|].
    unfold P3. apply lam_ext; [reflexivity|do 2 red; intros].
     apply NATREC_morph; [reflexivity|do 3 red; intros; rewrite H0, H5; reflexivity|trivial].

 do 2 red; intros. apply prod_ext; [|do 2 red; intros]; rewrite H0; reflexivity.

 apply real_sn in HS; trivial.

 intros. apply prod_intro_sn.
  do 2 red; intros. rewrite H1; reflexivity.

  do 2 red; intros. reflexivity.

  apply SN.prod_elim with (3:=H) in HS.
   apply real_sn in HS; trivial.

   do 2 red; intros. apply prod_ext; [|do 2 red; intros]; rewrite H1; reflexivity.

  intros. apply SN.prod_elim with (x:=P3 x0) (u:=u) in HS; [| |apply P3_real; trivial].
  2 : do 2 red; intros; apply prod_ext; [|do 2 red; intros]; rewrite H2; reflexivity.
   assert ([app x (P3 x0), GenRealSN.Lc.App y u]\real
       prod (app (P3 x0) (SUCC n)) (fun _ : X => app (P3 x0) (SUCC m)) ->
   [app x (P3 x0), GenRealSN.Lc.App y u]\real
       prod (app x0 n) (fun _ : X => app x0 m)).
    apply real_morph; [reflexivity| |reflexivity].
     apply prod_ext; [|do 2 red; intros]; rewrite <- P3_SUCC; trivial; reflexivity.

   apply H1 in HS. clear H1.
   apply SN.prod_elim with (x:=x1) (u:=u0) in HS; [|do 2 red; reflexivity|]; trivial.
Qed.

Lemma PredVary : forall e x y i j,
  wf_clsd_env e ->
  typ e x sort ->
  typ e y sort ->
  val_ok e i j ->
  (exists j', val_ok e i j' /\ (forall n, closed_pure_trm (j' n)) /\
    (exists P, P <> kind /\ [int i P, tm j' P] \real int i (Prod sort prop) /\
      exists u, [int i u, tm j' u] \real (app (int i P) (int i x)) /\
        ((exists v, [int i v, tm j' v] \real (app (int i P) (int i y))) ->
          int i x == int i y))).
intros e x y i j' Hclsd Hx Hy Hok'.
apply Hclsd in Hok'. clear Hclsd j'.
destruct Hok' as (j, (Hok, Hclsd)).
exists j; split; [|split]; trivial.
apply red_typ with (1:=Hok) in Hx; [|discriminate].
destruct Hx as (_, (Hx, _)); unfold inX in Hx; simpl in Hx; rewrite El_def in Hx.
apply red_typ with (1:=Hok) in Hy; [|discriminate].
destruct Hy as (_, (Hy, _)); unfold inX in Hy; simpl in Hy; rewrite El_def in Hy.

set (int_x := int i x) in *. clearbody int_x.
set (int_y := int i y) in *. clearbody int_y.
clear x y e Hok.

revert int_y Hy. pattern int_x; apply NAT_ind; trivial; intros.
 apply H1 in Hy; clear H1. destruct Hy as (P, (HSP, (HP, (u, (Hu, Hv))))).
 exists P; split; [|split]; trivial.
 exists u; split; rewrite <- H0; trivial.

 exists P1t. split; [discriminate|split].
  simpl int; simpl tm. apply P1_real.

  exists prf_T. simpl int; simpl tm.
  rewrite P1_ZERO. split; [apply Tprf with (i:=i) (j:=j)|].
  pattern int_y; apply NAT_ind; [intros|reflexivity|intros|trivial].
   rewrite H0 in H1; apply H1.
   destruct H2 as (v, Hv); exists v; rewrite H0; trivial.

   destruct H1 as (v, HF). rewrite P1_SUCC in HF; trivial.
   apply FprfF in HF; trivial. contradiction.

 pattern int_y; apply NAT_ind; trivial; intros.
  destruct H3 as (P, (HSP, (HP, (u, (Hu, Hv))))).
  exists P; split; [|split]; trivial.
  exists u; split; trivial; intros.
   rewrite <- H2; apply Hv. destruct H3 as (v, H3); exists v; rewrite H2; trivial.

  exists P2t. split; [discriminate|split].
   simpl int; simpl tm; apply P2_real; trivial.

   exists prf_T. simpl int; simpl tm.
   rewrite P2_SUCC; trivial.
   split; [apply Tprf with (i:=i) (j:=j)|].
   intros. destruct H1 as (v, Hv). rewrite P2_ZERO in Hv.
   apply FprfF in Hv; [contradiction|trivial].

  specialize H0 with (1:=H1).
  destruct H0 as (P, (HSP, (HP, (u, (Hu, Hv))))).
  exists (P3t P). split; [discriminate|split].
   simpl int; simpl tm. apply P3_real; trivial.

   exists u; split; [simpl int; rewrite P3_SUCC; trivial|].
    intros. destruct H0 as (v, Hv').
    simpl int in Hv'; rewrite P3_SUCC in Hv'; trivial.
    assert (n == n0).
     apply Hv; exists v; trivial.
    rewrite H0; reflexivity.
Qed.

End PSemSig.

(************************************************************************************)
(*Semantic of axioms*)
(************************************************************************************)
Module PSemAx <: SemanticAx PSemSig.

Include SemLogic PSemSig.

Lemma typ_S1 : forall e n,
  typ e n Nat ->
  typ e (App Succ n) Nat.
intros e n Hn.
setoid_replace Nat with (subst n Nat) using relation eq_trm;
  [|simpl; split; red; reflexivity].
apply typ_app with (V:=Nat); [trivial|apply typ_S|discriminate|discriminate].
Qed.

Lemma int_S : forall n i, int i n ∈ NAT ->
  int i (App Succ n) == SUCC (int i n).
intros; simpl.
rewrite beta_eq; [reflexivity| |rewrite El_def; trivial].
 do 2 red; intros; rewrite H1; reflexivity.
Qed.

Definition Add := Abs Nat (Abs Nat (NatRec (Ref 1) (Abs Nat Succ) (Ref 0))).

Lemma typ_Add : forall e, typ e Add (Prod Nat (Prod Nat (lift 2 Nat))).
intros.
apply typ_abs; [left; apply typ_N| |discriminate].
apply typ_abs; [left; apply typ_N| |discriminate].
assert (forall n e, typ e n Nat ->
  eq_typ e (App (Abs Nat Nat) n) Nat).
 intros. setoid_replace Nat with (subst n Nat) using relation eq_trm at 3;
   [|simpl; split; red; reflexivity].
 apply eq_typ_beta; [apply refl|apply refl|trivial|discriminate].

setoid_replace (lift 2 Nat) with Nat using relation eq_trm;
  [|simpl; split; red; reflexivity].
apply typ_conv with (T := App (Abs Nat Nat) (Ref 0)); [|apply H|discriminate|discriminate].
 apply typ_Nrect.
  setoid_replace Nat with (lift 1 Nat) using relation eq_trm at 3;
    [apply typ_var; trivial|simpl; split; red; reflexivity].

  apply typ_conv with (T:=Nat); [| |discriminate|discriminate].
   setoid_replace Nat with (lift 2 Nat) using relation eq_trm at 3;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

   apply sym. apply H. apply typ_0.

  apply typ_abs; [left; apply typ_N| |discriminate].
   apply typ_conv with (T:=Prod Nat (lift 1 Nat)); [apply typ_S| |discriminate|discriminate].
    apply sym. apply eq_typ_prod; [| |discriminate].
     unfold lift. rewrite red_lift_abs.
     setoid_replace (lift_rec 1 0 Nat) with Nat using relation eq_trm;
       [apply H|simpl; split; red; reflexivity].
      setoid_replace Nat with (lift 1 Nat) using relation eq_trm at 4;
        [apply typ_var; trivial|simpl; split; red; reflexivity].

     unfold lift at 2 3. rewrite red_lift_abs.
     setoid_replace (lift_rec 1 0 Nat) with Nat using relation eq_trm;
       [apply H; apply typ_S1|simpl; split; red; reflexivity].
      setoid_replace Nat with (lift 2 Nat) using relation eq_trm at 6;
        [apply typ_var; trivial|simpl; split; red; reflexivity].

 setoid_replace Nat with (lift 1 Nat) using relation eq_trm at 3;
   [apply typ_var; trivial|simpl; split; red; reflexivity].
Qed.

Lemma typ_Add2 : forall e m n,
  typ e m Nat ->
  typ e n Nat ->
  typ e (App (App Add m) n) Nat.
intros e m n Hm Hn.
setoid_replace Nat with (subst n Nat) using relation eq_trm;
  [|simpl; split; red; reflexivity].
apply typ_app with (V:=Nat); [trivial| |discriminate|discriminate].
setoid_replace (Prod Nat Nat) with (subst m (Prod Nat (lift 2 Nat))) using relation eq_trm;
  [|simpl; split; red; reflexivity].
apply typ_app with (V:=Nat); [trivial|apply typ_Add|discriminate|discriminate].
Qed.

Lemma int_Add : forall n m i M N,
  int i m ∈ NAT ->
  int i n ∈ NAT ->
  int i m == M ->
  int i n == N ->
  int i (App (App Add m) n) == NATREC M (fun _ => SUCC) N.
intros n m i M N Him Hin Hm Hn.
replace (int i (App (App Add m) n)) with
  (app (app (lam (mkTY NAT cNAT) (fun x => lam (mkTY NAT cNAT) (fun y =>
    (NATREC x (fun p q =>
      app (app (lam (mkTY NAT cNAT) (fun _ => lam (mkTY NAT cNAT) SUCC)) p) q) y))))
  (int i m)) (int i n)) by reflexivity.
rewrite beta_eq; [
  |do 2 red; intros; apply lam_ext; [reflexivity|do 2 red; intros; apply NATREC_morph; [|
    do 3 red; intros; rewrite H3, H4; reflexivity|]; trivial]
  |rewrite El_def; trivial].
rewrite beta_eq; [
  |do 2 red; intros; apply NATREC_morph; [reflexivity
    |do 3 red; intros; rewrite H1, H2; reflexivity|trivial]
  |rewrite El_def; trivial].
assert (NATREC (int i m) (fun _ : set => SUCC) (int i n) ==
  NATREC M (fun _ : set => SUCC) N).
 apply NATREC_morph; [|do 3 red; intros; rewrite H0; reflexivity|]; trivial.
rewrite <- H; clear H.

pattern (int i n); apply NAT_ind; [|do 2 rewrite NATREC_0; reflexivity| |trivial]; intros.
 assert (NATREC (int i m) (fun _ : set => SUCC) x ==
   NATREC (int i m) (fun _ : set => SUCC) x').
  apply NATREC_morph; [reflexivity|do 3 red; intros; rewrite H3; reflexivity|trivial].

 rewrite H2 in H1; rewrite <- H1; clear H2.
 apply NATREC_morph; [reflexivity
   |do 3 red; intros; apply app_ext; [apply app_ext; [reflexivity|]|]; trivial
   |rewrite H0; reflexivity].

 rewrite NATREC_S; [|do 3 red; intros; rewrite H1, H2; reflexivity|trivial].
 rewrite NATREC_S; [|do 3 red; intros; rewrite H2; reflexivity|trivial].
 rewrite beta_eq; [rewrite H0|do 2 red; reflexivity|rewrite El_def; trivial].
 rewrite beta_eq; [reflexivity|do 2 red; intros; rewrite H2; reflexivity
   |rewrite El_def; change NAT with ((fun _ => NAT) n0)].
  apply NATREC_typ; [do 2 red; reflexivity|do 3 red; intros; rewrite H2; reflexivity| |
    |intros; apply SUCC_typ]; trivial.
Qed.

(*Axiom1 : ~ S n = 0*)
Definition ax1_aux := Abs Nat (NatRec True_symb (Abs Nat (Abs prop False_symb)) (Ref 0)).

Lemma P_ax1_aux : forall e, typ e ax1_aux (Prod Nat prop).
intros e. unfold ax1_aux.
assert (forall n e, typ e n Nat ->
  eq_typ e (App (Abs Nat prop) n) prop).
 intros.
 setoid_replace prop with (subst n prop) using relation eq_trm at 2;
   [apply eq_typ_beta; [apply refl|apply refl|trivial|discriminate]
     |simpl; split; red; reflexivity].

apply typ_abs; [left; apply typ_N| |discriminate].
apply typ_conv with (T := App (Abs Nat prop) (Ref 0));
  [|apply H; setoid_replace Nat with (lift 1 Nat) using relation eq_trm at 2;
    [apply typ_var; trivial|simpl; split; red; reflexivity]
   |discriminate|discriminate].
apply typ_Nrect.
 setoid_replace Nat with (lift 1 Nat) using relation eq_trm at 2;
   [apply typ_var; trivial|simpl; split; red; reflexivity].

 apply typ_conv with (T:=prop); [apply True_symb_typ|apply sym; apply H; apply typ_0
   |discriminate|discriminate].

 apply typ_abs; [left; apply typ_N| |discriminate].
 apply typ_conv with (T:=Prod prop prop); [| |discriminate|discriminate].
  apply typ_abs; [left; apply typ_prop|apply False_symb_typ|discriminate].

  apply sym; apply eq_typ_prod; [| |discriminate].
   unfold lift; rewrite red_lift_abs.
   setoid_replace (lift_rec 1 0 Nat) with Nat using relation eq_trm;
     [|simpl; split; red; reflexivity].
   setoid_replace (lift_rec 1 1 prop) with prop using relation eq_trm;
     [apply H|simpl; split; red; reflexivity].
   setoid_replace Nat with (lift 1 Nat) using relation eq_trm at 3;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

   unfold lift at 2; rewrite red_lift_abs.
    setoid_replace (lift_rec 2 0 Nat) with Nat using relation eq_trm;
      [|simpl; split; red; reflexivity].
    setoid_replace (lift_rec 2 1 prop) with prop using relation eq_trm;
      [apply H; apply typ_S1|simpl; split; red; reflexivity].
    setoid_replace Nat with (lift 2 Nat) using relation eq_trm at 4;
      [apply typ_var; trivial|simpl; split; red; reflexivity].
Qed.

Lemma ax1_aux_0 : forall e, eq_typ e True_symb (App ax1_aux Zero).
red; intros e i j Hok; simpl.
rewrite beta_eq; [rewrite NATREC_0; reflexivity| |rewrite El_def; apply ZERO_typ].
 do 2 red; intros. apply NATREC_morph; [reflexivity| |trivial].
  do 3 red; intros. apply app_ext; [apply app_ext|]; trivial.
   apply lam_ext; [|do 2 red; intros]; reflexivity.
Qed.

Lemma ax1_aux_S : forall e n, typ e n Nat ->
  eq_typ e False_symb (App ax1_aux (App Succ n)).
red; intros e n Hn i j Hok.
apply red_typ with (1:=Hok) in Hn; [destruct Hn as (_, (Hn, _))|discriminate].
unfold inX in Hn; rewrite ElNat_eq in Hn.
generalize (True_symb_typ e); intros HT.
apply red_typ with (1:=Hok) in HT; [destruct HT as (_, (HT, _))|discriminate].
unfold inX in HT; simpl int in HT.
generalize (False_symb_typ e); intros HF.
apply red_typ with (1:=Hok) in HF; [destruct HF as (_, (HF, _))|discriminate].
unfold inX in HF; simpl int in HF.
replace (int i (App ax1_aux (App Succ n))) with
  (app (lam (mkTY NAT cNAT) (fun x => NATREC (int (V.cons x i) True_symb) (fun p q =>
    app (app (lam (mkTY NAT cNAT) (fun y => lam props (fun z =>
      (int (V.cons z (V.cons y (V.cons x i))) False_symb)))) p) q) x))
  (int i (App Succ n))) by reflexivity.
rewrite int_S; [unfold ax1_aux; simpl int|trivial].
rewrite beta_eq; [
  |do 2 red; intros; apply NATREC_morph; [reflexivity
    |do 3 red; intros; apply app_ext; [apply app_ext; [reflexivity|]|]|]
  |rewrite El_def; apply SUCC_typ]; trivial.
rewrite NATREC_S; [
  |do 3 red; intros; apply app_ext; [apply app_ext; [reflexivity|]|]
  |]; trivial.
rewrite beta_eq;[|do 2 red; reflexivity|rewrite El_def; trivial].
rewrite beta_eq; [reflexivity|do 2 red; reflexivity
  |change (El props) with ((fun _ => El props) (int i n))].
apply NATREC_typ; [do 2 red; reflexivity
  |do 3 red; intros; apply app_ext; [apply app_ext; [reflexivity|]|]; trivial
  | | |intros]; trivial.
rewrite beta_eq; [|do 2 red; reflexivity|rewrite El_def; trivial].
rewrite beta_eq; [|do 2 red; reflexivity|]; trivial.
Qed.

Definition ax1 := forall e, exists t,
  typ e t (Fall (Neg (EQ_trm Zero (App (App Add (Ref 0)) (App Succ Zero))))).

Lemma P_ax_intro1 : ax1.
unfold ax1. intros e.
generalize (True_symb_intro (EQ_trm Zero (App (App Add (Ref 0)) (App Succ Zero))::Nat::e)).
intros Ht; destruct Ht as (t, Ht).
exists (Abs Nat (Abs (EQ_trm Zero (App (App Add (Ref 0)) (App Succ Zero)))
(App (App (Ref 0) ax1_aux) t))).
apply typ_abs; [left; apply typ_N|unfold Neg|discriminate].
apply Impl_intro; [|discriminate|].
 apply EQ_trm_typ; [apply typ_0|apply typ_Add2; [|apply typ_S1; apply typ_0]].
  setoid_replace Nat with (lift 1 Nat) using relation eq_trm at 2;
    [apply typ_var; trivial|simpl; split; red; reflexivity].

 setoid_replace (lift 1 False_symb) with (subst t False_symb) using relation eq_trm by
   (simpl; split; red; reflexivity).
 apply typ_app with (V:=True_symb); [trivial|clear Ht|discriminate|discriminate].
 apply typ_conv with (T:=(subst ax1_aux (Prod (App (Ref 0) (lift 2 Zero))
   (App (Ref 1) (lift 3 (App (App Add (Ref 0)) (App Succ Zero))))))); [
     | |discriminate|discriminate].
  apply typ_app with (V:=(Prod Nat prop)); [apply P_ax1_aux| |discriminate|discriminate].
   setoid_replace ((Prod (Prod Nat prop) (Prod (App (Ref 0) (lift 2 Zero))
     (App (Ref 1) (lift 3 (App (App Add (Ref 0)) (App Succ Zero))))))) with
   (lift 1 ((Prod (Prod Nat prop) (Prod (App (Ref 0) (lift 1 Zero))
     (App (Ref 1) (lift 2 (App (App Add (Ref 0)) (App Succ Zero))))))))
   using relation eq_trm; [apply typ_var; trivial
     |unfold lift; do 3 rewrite red_lift_prod; do 11 rewrite red_lift_app].
   rewrite eq_trm_lift_ref_fv; [simpl plus|omega].
   rewrite eq_trm_lift_ref_bd; [|omega].
   rewrite eq_trm_lift_ref_bd; [|omega].
   rewrite eq_trm_lift_ref_fv; [simpl plus|omega].
   rewrite eq_trm_lift_ref_fv; [simpl plus|omega].
   rewrite lift_rec_acc; [simpl plus|omega].
   rewrite lift_rec_acc; [simpl plus|omega].
   rewrite lift_rec_acc; [simpl plus|omega].
   rewrite lift_rec_acc; [simpl plus|omega].
   fold (lift 3 Add). fold (lift 3 Succ). fold (lift 3 Zero).
   apply Prod_morph; [apply Prod_morph; simpl; split; red|]; reflexivity.

  unfold subst. rewrite red_sigma_prod. do 2 rewrite red_sigma_app.
  rewrite red_sigma_var_eq; [rewrite lift0|discriminate].
  setoid_replace ((subst_rec ax1_aux 0 (lift 2 Zero))) with Zero using relation eq_trm;
    [|simpl; split; red; reflexivity].
  rewrite red_sigma_var_eq; [|discriminate].
  rewrite subst_lift_lt; [|omega].
  apply eq_typ_prod; [rewrite ax1_aux_0; apply refl| |discriminate].
  rewrite ax1_aux_S with (n:=(Ref 2)).
   apply eq_typ_app.
    unfold lift. unfold ax1_aux. rewrite red_lift_abs.
    apply eq_typ_abs; [| |discriminate].
     setoid_replace (lift_rec 1 0 Nat) with Nat using relation eq_trm;
       [apply refl|simpl; split; red; reflexivity].

     red; intros; simpl. apply NATREC_morph; [reflexivity| |reflexivity].
      do 3 red; intros. apply app_ext; [apply app_ext; [reflexivity|]|]; trivial.

     red; intros; unfold lift. red in H.
     assert (nth_error (App ax1_aux Zero :: Prod (Prod Nat prop)
       (Prod (App (Ref 0) (lift 1 Zero)) (App (Ref 1)
         (lift 2 (App (App Add (Ref 0)) (App Succ Zero))))) :: Nat :: e) 2 =
     value Nat) by trivial.
     specialize H with (1:=H0); clear H0.
     apply in_int_not_kind in H; [|discriminate].
     destruct H as (H, _); unfold inX in H; simpl in H. rewrite El_def in H.
     rewrite int_lift_rec_eq.
     assert (int (V.lams 0 (V.shift 2) i) (Ref 0) == i 2) by
       (unfold V.lams, V.shift; simpl; reflexivity).
     assert (int (V.lams 0 (V.shift 2) i) (App Succ Zero) == SUCC ZERO) by
       (rewrite int_S; simpl; [reflexivity|apply ZERO_typ]).
     rewrite int_Add with (3:=H0) (4:=H1);
       [|rewrite H0; trivial|rewrite H1; apply SUCC_typ; apply ZERO_typ].
      rewrite NATREC_S; [rewrite NATREC_0; rewrite int_S; [reflexivity|trivial]
        |do 3 red; intros; rewrite H3; reflexivity|apply ZERO_typ].

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

(*Axiom2 : x + 1 = y + 1 -> x = y*)
Definition ax2 := forall e, exists t, typ e t (Fall (Fall (Impl
  (EQ_trm (App (App Add (Ref 0)) (App Succ Zero)) (App (App Add (Ref 1)) (App Succ Zero)))
  (EQ_trm (Ref 0) (Ref 1))))).

Lemma P_ax_intro2 : ax2.
unfold ax2; intros e.
exists (Abs Nat (Abs Nat (Abs (EQ_trm (App (App Add (Ref 0)) (App Succ Zero))
  (App (App Add (Ref 1)) (App Succ Zero))) (Ref 0)))).
apply typ_abs; [left; apply typ_N| |discriminate].
apply typ_abs; [left; apply typ_N| |discriminate].
apply Impl_intro; [|discriminate|].
 apply EQ_trm_typ.
  apply typ_Add2; [|apply typ_S1; apply typ_0].
   setoid_replace Nat with (lift 1 Nat) using relation eq_trm at 3;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

  apply typ_Add2; [|apply typ_S1; apply typ_0].
   setoid_replace Nat with (lift 2 Nat) using relation eq_trm at 3;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

setoid_replace (lift 1 (EQ_trm (Ref 0) (Ref 1))) with
  (EQ_trm (Ref 1) (Ref 2)) using relation eq_trm; [
    |unfold EQ_trm, lift; repeat rewrite red_lift_prod; repeat rewrite red_lift_app;
      rewrite eq_trm_lift_ref_bd; [|omega]; rewrite lift_rec_acc; [simpl plus|omega];
        rewrite eq_trm_lift_ref_fv; [simpl plus|omega]; rewrite eq_trm_lift_ref_bd; [|omega];
          rewrite lift_rec_acc; [simpl plus|omega];
            repeat (rewrite eq_trm_lift_ref_fv; [simpl plus|omega]);
              apply Prod_morph; [apply Prod_morph; simpl; split; red|]; reflexivity].
red; intros. red in H.
assert (nth_error (EQ_trm (App (App Add (Ref 0)) (App Succ Zero))
  (App (App Add (Ref 1)) (App Succ Zero)) :: Nat :: Nat :: e) 0 = value (
    EQ_trm (App (App Add (Ref 0)) (App Succ Zero))
    (App (App Add (Ref 1)) (App Succ Zero)))) by trivial.
assert (nth_error (EQ_trm (App (App Add (Ref 0)) (App Succ Zero))
  (App (App Add (Ref 1)) (App Succ Zero)) :: Nat :: Nat :: e) 1 = value Nat) by trivial.
assert (nth_error (EQ_trm (App (App Add (Ref 0)) (App Succ Zero))
  (App (App Add (Ref 1)) (App Succ Zero)) :: Nat :: Nat :: e) 2 = value Nat) by trivial.
apply H in H0. apply in_int_not_kind in H0; [|discriminate].
apply H in H1. apply in_int_not_kind in H1; [destruct H1 as (H1, _)|discriminate].
unfold inX in H1; simpl in H1; rewrite El_def in H1.
apply H in H2. apply in_int_not_kind in H2; [destruct H2 as (H2, _)|discriminate].
unfold inX in H2; simpl in H2; rewrite El_def in H2.
apply in_int_intro; [clear e H|discriminate|discriminate].
assert ([i 0, j 0]\real (prod (prod (mkTY NAT cNAT) (fun _ => props)) (fun x =>
  prod (app x (i 1)) (fun y => app x (i 2)))) ->
[int i (Ref 0), tm j (Ref 0)]\real int i (EQ_trm (Ref 1) (Ref 2))).
 apply real_morph; simpl; reflexivity.

apply H; clear H.
assert ([int i (Ref 0), tm j (Ref 0)] \real int i (lift 1
  (EQ_trm (App (App Add (Ref 0)) (App Succ Zero))
    (App (App Add (Ref 1)) (App Succ Zero)))) ->
  ([int i (Ref 0), tm j (Ref 0)] \real int (V.shift 1 i)
    (EQ_trm (App (App Add (Ref 0)) (App Succ Zero))
      (App (App Add (Ref 1)) (App Succ Zero))))).
 unfold lift; rewrite int_lift_rec_eq. rewrite V.lams0; trivial.

specialize H with (1:=H0); clear H0.
replace (int (V.shift 1 i) (Prod (Prod Nat prop)
  (Prod (App (Ref 0) (lift 1 (App (App Add (Ref 0)) (App Succ Zero))))
    (App (Ref 1) (lift 2 (App (App Add (Ref 1)) (App Succ Zero))))))) with
  (prod (prod (mkTY NAT cNAT) (fun _ => props)) (fun x =>
    prod (app x (int (V.cons x (V.shift 1 i))
      (lift 1 (App (App Add (Ref 0)) (App Succ Zero))))) (fun y =>
        app x (int (V.cons y (V.cons x (V.shift 1 i)))
          (lift 2 (App (App Add (Ref 1)) (App Succ Zero))))))) in H by reflexivity.
assert ([int i (Ref 0), tm j (Ref 0)] \real
  prod (prod (mkTY NAT cNAT) (fun _ : set => props)) (fun x : set =>
    prod (app x (int (V.cons x (V.shift 1 i))
      (lift 1 (App (App Add (Ref 0)) (App Succ Zero))))) (fun y : set =>
        app x (int (V.cons y (V.cons x (V.shift 1 i)))
          (lift 2 (App (App Add (Ref 1)) (App Succ Zero)))))) ->
  [i 0, j 0] \real (prod (prod (mkTY NAT cNAT) (fun _ => props)) (fun x =>
    prod (app x (SUCC (i 1))) (fun y => app x (SUCC (i 2)))))).
 apply real_morph; [reflexivity| |reflexivity].
  apply prod_ext; [reflexivity|do 2 red; intros].
   apply prod_ext; [|do 2 red; intros].
    rewrite int_cons_lift_eq.
    assert (int (V.shift 1 i) (Ref 0) == i 1) by reflexivity.
    assert (int (V.shift 1 i) (App Succ Zero) == SUCC ZERO) by (apply int_S; apply ZERO_typ).
    rewrite int_Add with (3:=H4) (4:=H5); [
      |rewrite H4; trivial|rewrite H5; apply SUCC_typ; apply ZERO_typ].
     rewrite NATREC_S; [rewrite NATREC_0, H3; reflexivity
       |do 3 red; intros; rewrite H7; reflexivity|apply ZERO_typ].

    rewrite split_lift. do 2 rewrite int_cons_lift_eq.
    assert (int (V.shift 1 i) (Ref 1) == i 2) by reflexivity.
    assert (int (V.shift 1 i) (App Succ Zero) == SUCC ZERO) by (apply int_S; apply ZERO_typ).
    rewrite int_Add with (3:=H6) (4:=H7); [
      |rewrite H6; trivial|rewrite H7; apply SUCC_typ; apply ZERO_typ].
     rewrite NATREC_S; [rewrite NATREC_0, H3; reflexivity
       |do 3 red; intros; rewrite H9; reflexivity|apply ZERO_typ].

apply H0 in H; clear H0.
apply eq_SUCC_eq; trivial.
Qed.

(*Axiom 3 : x = x + 0*)
Definition ax3 := forall e, exists t,
  typ e t (Fall (EQ_trm (Ref 0) (App (App Add (Ref 0)) Zero))).

Lemma P_ax_intro3 : ax3.
unfold ax3.
exists (Abs Nat (Abs (Prod Nat prop) (Abs (App (Ref 0) (Ref 1)) (Ref 0)))).
unfold EQ_trm. unfold lift at 1.
apply typ_abs; [left; apply typ_N| |discriminate].
apply typ_abs; [left; apply typ_prod;
  [left; trivial|left; apply typ_N|apply typ_prop]| |discriminate].
rewrite (eq_trm_lift_ref_fv 1 0 0); [simpl plus|omega].
apply typ_abs; [right| |discriminate].
 setoid_replace prop with (subst (Ref 1) prop) using relation eq_trm at 2;
   [|simpl; split; red; reflexivity].
  apply typ_app with (V:=Nat); [| |discriminate|discriminate].
   setoid_replace Nat with (lift 2 Nat) using relation eq_trm at 3;
     [apply typ_var; trivial|simpl; split; red; reflexivity].

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

apply typ_conv with (T:=(lift 1 (App (Ref 0) (Ref 1))));
  [apply typ_var; trivial| |discriminate|discriminate].
unfold lift at 1. rewrite red_lift_app.
do 2 (rewrite eq_trm_lift_ref_fv; [simpl plus|omega]).
apply eq_typ_app; [apply refl|do 2 red; intros].
unfold lift; rewrite int_lift_rec_eq. rewrite V.lams0.
red in H.
assert (nth_error (App (Ref 0) (Ref 1)::Prod Nat prop::Nat::e) 2 = value Nat) by trivial.
specialize H with (1:=H0); clear H0.
apply in_int_not_kind in H; [destruct H as (H, _)|discriminate].
unfold inX in H; simpl in H; rewrite El_def in H.
assert (int (V.shift 2 (fun k : nat => i k)) (Ref 0) == i 2) by reflexivity.
assert (int (V.shift 2 (fun k : nat => i k)) Zero == ZERO) by reflexivity.
rewrite int_Add with (3:=H0) (4:=H1); [rewrite NATREC_0; reflexivity
  |rewrite H0; trivial|rewrite H1; apply ZERO_typ].
Qed.

(*Axiom 4 : (x + y) + 1 = x + (y + 1)*)
Definition ax4 := forall e, exists t,
  typ e t (Fall(Fall (EQ_trm (App (App Add (App (App Add (Ref 0)) (Ref 1)))
  (App Succ Zero)) (App (App Add (Ref 0)) (App (App Add (Ref 1)) (App Succ Zero)))))).

Lemma P_ax_intro4 : ax4.
unfold ax4.
exists (Abs Nat (Abs Nat (Abs (Prod Nat prop)
  (Abs (App (Ref 0) (App (App Add (App (App Add (Ref 1)) (Ref 2)))
    (App Succ Zero))) (Ref 0))))).
apply typ_abs; [left; apply typ_N| |discriminate].
apply typ_abs; [left; apply typ_N| |discriminate].
apply typ_abs; [left; apply typ_prod; [left; trivial|left; apply typ_N|apply typ_prop]|
  |discriminate].
unfold lift at 1. repeat rewrite red_lift_app.
assert (eq_trm (lift_rec 1 0 Add) Add) as Hadd_lift.
 unfold Add. repeat rewrite red_lift_abs.
 apply Abs_morph; [simpl; split; red; reflexivity|].
  apply Abs_morph; [simpl; split; red; reflexivity|].
   simpl; split; red; intros.
    apply NATREC_morph; [unfold V.lams, V.shift; simpl; apply H|
      |unfold V.lams, V.shift; simpl; apply H].
     do 3 red; intros. apply app_ext; [apply app_ext; [reflexivity|]|]; trivial.

    unfold I.lams, I.shift; simpl; do 2 rewrite H; trivial.

rewrite Hadd_lift. do 2 (rewrite eq_trm_lift_ref_fv; [simpl plus|omega]).
setoid_replace (lift_rec 1 0 Succ) with Succ using relation eq_trm by
  (simpl; split; red; reflexivity).
setoid_replace (lift_rec 1 0 Zero) with Zero using relation eq_trm by
  (simpl; split; red; reflexivity).
apply typ_abs; [right| |discriminate].
 setoid_replace prop with
   (subst (App (App Add (App (App Add (Ref 1)) (Ref 2))) (App Succ Zero)) prop)
   using relation eq_trm at 2 by (simpl; split; red; reflexivity).
 apply typ_app with (V:=Nat); [| |discriminate|discriminate].
  apply typ_Add2; [|apply typ_S1; apply typ_0].
   apply typ_Add2.
    setoid_replace Nat with (lift 2 Nat) using relation eq_trm at 4;
      [apply typ_var; trivial|simpl; split; red; reflexivity].

    setoid_replace Nat with (lift 3 Nat) using relation eq_trm at 4;
      [apply typ_var; trivial|simpl; split; red; reflexivity].

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

 apply typ_conv with (T:= lift 1 (App (Ref 0) (App (App Add (App (App Add (Ref 1)) (Ref 2)))
   (App Succ Zero)))); [apply typ_var; trivial| |discriminate|discriminate].
  unfold lift. rewrite red_lift_app. rewrite eq_trm_lift_ref_fv; [simpl plus|omega].
  apply eq_typ_app; [apply refl|do 2 red; intros].
   red in H.
   assert (nth_error (App (Ref 0)
     (App (App Add (App (App Add (Ref 1)) (Ref 2))) (App Succ Zero))
     :: Prod Nat prop :: Nat :: Nat :: e) 2 = value Nat) as Hi2 by trivial.
   assert (nth_error (App (Ref 0)
     (App (App Add (App (App Add (Ref 1)) (Ref 2))) (App Succ Zero))
     :: Prod Nat prop :: Nat :: Nat :: e) 3 = value Nat) as Hi3 by trivial.
   apply H in Hi2; apply in_int_not_kind in Hi2; [|discriminate].
   destruct Hi2 as (Hi2, _); unfold inX in Hi2; simpl in Hi2; rewrite El_def in Hi2.
   apply H in Hi3; apply in_int_not_kind in Hi3; [|discriminate].
   destruct Hi3 as (Hi3, _); unfold inX in Hi3; simpl in Hi3; rewrite El_def in Hi3.
   clear H. do 2 rewrite int_lift_rec_eq. do 2 rewrite V.lams0.
   assert (int (V.shift 1 (fun k : nat => i k)) (App (App Add (Ref 1)) (Ref 2)) ==
     NATREC (i 2) (fun _ => SUCC) (i 3)).
    assert (int (V.shift 1 (fun k : nat => i k)) (Ref 1) == (i 2)) by reflexivity.
    assert (int (V.shift 1 (fun k : nat => i k)) (Ref 2) == (i 3)) by reflexivity.
    rewrite int_Add with (3:=H) (4:=H0); [reflexivity|rewrite H|rewrite H0]; trivial.
   assert (forall n, int (V.shift n i) (App Succ Zero) == SUCC ZERO) as Hn1 by
     (intros n; apply int_S; apply ZERO_typ).
   rewrite int_Add with (3:=H) (4:=(Hn1 1)); [clear H
     |rewrite H; change NAT with ((fun _ => NAT) (i 3)); apply NATREC_typ; trivial;
       [do 2 red; intros; reflexivity
       |do 3 red; intros; rewrite H1; reflexivity
       |intros; apply SUCC_typ; trivial]
     |rewrite (Hn1 1); apply SUCC_typ; apply ZERO_typ].
   assert (int (V.shift 2 (fun k : nat => i k)) (Ref 0) == (i 2)) by reflexivity.
   assert (int (V.shift 2 (fun k : nat => i k)) (App (App Add (Ref 1)) (App Succ Zero)) ==
     NATREC (i 3) (fun _ => SUCC) (SUCC ZERO)).
    assert (int (V.shift 2 (fun k : nat => i k)) (Ref 1) == (i 3)) by reflexivity.
    rewrite int_Add with (3:=H0) (4:=(Hn1 2)); [reflexivity|rewrite H0
      |rewrite (Hn1 2); apply SUCC_typ; apply ZERO_typ]; trivial.
   rewrite int_Add with (3:=H) (4:=H0); [|rewrite H; trivial
     |rewrite H0; change NAT with ((fun _ => NAT) (SUCC ZERO)); apply NATREC_typ; trivial;
       [do 2 red; reflexivity
       |do 3 red; intros; rewrite H2; reflexivity
       |apply SUCC_typ; apply ZERO_typ
       |intros; apply SUCC_typ; trivial]].
   rewrite NATREC_S; [rewrite NATREC_0
     |do 3 red; intros; rewrite H2; reflexivity|apply ZERO_typ].
   assert (NATREC (i 2) (fun _ : set => SUCC)
     (NATREC (i 3) (fun _ : set => SUCC) (SUCC ZERO)) ==
     NATREC (i 2) (fun _ : set => SUCC) (SUCC (i 3))).
    apply NATREC_morph; [reflexivity
      |do 3 red; intros; rewrite H2; reflexivity
      |rewrite NATREC_S; [rewrite NATREC_0; reflexivity
        |do 3 red; intros; rewrite H2; reflexivity|apply ZERO_typ]].

   rewrite H1; clear Hn1 H H0 H1.
   rewrite NATREC_S; [reflexivity|do 3 red; intros; rewrite H0; reflexivity|trivial].
Qed.

(*Induction Schema*)
Definition ax5 := forall e P, typ (Nat::e) P (lift 1 prop) -> exists t,
  typ e t (Impl (subst Zero P) (Impl (Fall (Impl P
  (subst (App (App Add (Ref 0)) (App Succ Zero)) (lift_rec 1 1 P)))) (Fall P))).

Lemma P_ax_intro5 : ax5.
unfold ax5; intros e P HP.
exists (Abs (subst Zero P) (Abs (Prod (lift 1 Nat) (Impl (lift_rec 1 1 P)
  ((lift_rec 1 1 (subst (App (App Add (Ref 0)) (App Succ Zero)) (lift_rec 1 1 P))))))
    (Abs (lift 2 Nat) (NatRec (Ref 2) (Ref 1) (Ref 0))))).

red; intros i j Hok.
assert (val_ok (Nat::e) (V.cons ZERO i) (I.cons ZE j)).
 apply vcons_add_var; [trivial| |discriminate].
  split; [unfold inX; rewrite ElNat_eq|rewrite RealNat_eq; [apply cNAT_ZE|]]; apply ZERO_typ.

generalize HP; intros HSP.
apply red_typ with (1:=H) in HSP; [destruct HSP as (HSP, _)|discriminate].
clear H; revert i j Hok.
fold (typ e (Abs (subst Zero P) (Abs (Prod (lift 1 Nat) (Impl (lift_rec 1 1 P)
  ((lift_rec 1 1 (subst (App (App Add (Ref 0)) (App Succ Zero)) (lift_rec 1 1 P))))))
    (Abs (lift 2 Nat) ((NatRec (Ref 2) (Ref 1) (Ref 0))))))
  ((Impl (subst Zero P) (Impl (Fall (Impl P (subst (App (App Add (Ref 0)) (App Succ Zero))
    (lift_rec 1 1 P)))) (Fall P))))).
apply Impl_intro; [|discriminate|].
 apply typ_subst with (A:=Nat); [discriminate|discriminate| |apply typ_0].
  setoid_replace prop with (lift 1 prop) using relation eq_trm in HP; [trivial
    |simpl; split; red; reflexivity].

 assert (typ (subst Zero P :: e) (Abs (Prod (lift 1 Nat) (Prod (lift_rec 1 1 P)
   (lift_rec 1 0 (lift_rec 1 1 (subst (App (App Add (Ref 0)) (App Succ Zero))
     (lift_rec 1 1 P)))))) (Abs (lift 1 (lift 1 Nat)) (NatRec (Ref 2) (Ref 1) (Ref 0))))
 (Prod (Prod (lift 1 Nat) (Prod (lift_rec 1 1 P) (lift_rec 1 0 (lift_rec 1 1
   (subst (App (App Add (Ref 0)) (App Succ Zero))
     (lift_rec 1 1 P)))))) (Prod (lift 1 (lift 1 Nat)) (lift_rec 2 1 P))) ->
 typ (subst Zero P :: e) (Abs (Prod (lift 1 Nat) (Impl (lift_rec 1 1 P) (lift_rec 1 1
   (subst (App (App Add (Ref 0)) (App Succ Zero)) (lift_rec 1 1 P)))))
 (Abs (lift 2 Nat) (NatRec (Ref 2) (Ref 1) (Ref 0)))) (lift 1 (Impl
   (Fall (Impl P (subst (App (App Add (Ref 0)) (App Succ Zero))
     (lift_rec 1 1 P)))) (Fall P)))).
  apply typ_morph.
   apply Abs_morph; [reflexivity|apply Abs_morph; [apply split_lift|reflexivity]].

   unfold Impl, Fall, lift. rewrite red_lift_prod.
   apply Prod_morph; do 2 rewrite red_lift_prod.
    apply Prod_morph; [reflexivity|apply Prod_morph; [reflexivity|]].
     rewrite (lift_rec_comm _ 1 1 0 1); [reflexivity|omega].

    apply Prod_morph; [simpl; split; red; reflexivity|].
     rewrite (lift_rec_acc _ 1 1 2 1); [simpl plus; reflexivity|omega].

 apply H; clear H.
 apply typ_abs; [right| |discriminate].
  apply typ_prod; [right; trivial|left;
    setoid_replace (lift 1 Nat) with Nat using relation eq_trm;
      [apply typ_N|split; red; simpl; reflexivity]|].
  apply typ_prod; [right; trivial|right;
    setoid_replace prop with (lift_rec 1 1 prop) using relation eq_trm;
      [apply weakening_bind; trivial|split; red; simpl; reflexivity]|].
  setoid_replace prop with (lift 1 (lift_rec 1 1 (lift 1 prop))) using relation eq_trm;
    [|simpl; split; red; reflexivity].
  apply weakening.
  apply weakening_bind; trivial.
  apply typ_subst with (A:=(lift 1 Nat)); [discriminate|discriminate| |].
   unfold lift; rewrite lift_rec_comm by omega; apply weakening_bind; trivial.

   apply typ_Add2; [|apply typ_S1; apply typ_0].
    setoid_replace Nat with (lift 1 Nat) using relation eq_trm at 2;
      [apply typ_var; trivial|split; red; simpl; reflexivity].

 apply typ_abs; [left; replace kind with (lift 1 (lift 1 kind)); [|trivial]|
   |destruct P; [discriminate|trivial]].
  do 2 apply weakening; apply typ_N.

  apply typ_conv with (T:=(App (Abs (lift 1 (lift 1 (lift 1 Nat))) (lift_rec 3 1 P)) (Ref 0)));
    [| |discriminate|destruct P; [discriminate|trivial]].
   apply typ_Nrect.
    setoid_replace Nat with (lift 1 (lift 1 (lift 1 Nat))) using relation eq_trm at 3;
       [apply typ_var; trivial|simpl; split; red; reflexivity].

    apply typ_conv with (T:=(lift 3 (subst Zero P))); [apply typ_var; trivial|
      |destruct P; [discriminate|trivial]|discriminate].
     rewrite eq_typ_beta with (N':=Zero) (M':=(lift_rec 3 1 P)); [|apply refl|apply refl
        |apply typ_0|discriminate].
      do 2 red; intros. unfold lift, subst.
      rewrite int_subst_rec_eq; simpl; rewrite V.lams0.
      do 2 rewrite int_lift_rec_eq; rewrite V.lams0.
      rewrite int_subst_rec_eq; simpl; rewrite V.lams0.
      rewrite <- V.cons_lams; [rewrite V.lams0|do 2 red; intros; rewrite H0]; reflexivity.

    apply typ_conv with (T:=(lift 2 (Prod (lift 1 Nat) (Prod (lift_rec 1 1 P)
      (lift_rec 1 0 (lift_rec 1 1 (subst (App (App Add (Ref 0)) (App Succ Zero))
        (lift_rec 1 1 P)))))))); [apply typ_var; trivial| |discriminate|discriminate].
      rewrite split_lift with (n:=1).
      unfold lift. repeat rewrite red_lift_prod.
      repeat rewrite red_lift_abs.
      apply eq_typ_prod; [red; simpl; reflexivity| |discriminate].
       apply eq_typ_prod; [| |destruct P; [discriminate|trivial]].
        rewrite eq_typ_beta with (N':=(Ref 0)) (M':=(lift_rec 1 1 (lift_rec 3 1 P)));
          [|apply refl|apply refl| |discriminate].
         rewrite subst0_lift. do 2 red; intros.
         do 5 rewrite int_lift_rec_eq. unfold V.lams, V.shift.
         apply int_morph; [do 3 red; intros|reflexivity].
          destruct (le_gt_dec 1 a) as [le|gt]; simpl; reflexivity.

         replace ((lift_rec 1 0 (lift_rec 1 0 (lift_rec 1 0 (lift_rec 1 0 Nat))))) with
           (lift 1 (lift_rec 1 0 (lift_rec 1 0 (lift_rec 1 0 Nat)))) by trivial.
         apply typ_var; trivial.

        rewrite eq_typ_beta with (N':=(App Succ (Ref 1)))
          (M':=(lift_rec 2 1 (lift_rec 3 1 P))); [|apply refl|apply refl| |discriminate].
         rewrite (lift_rec_acc _ 1 1 2 2) by omega. simpl plus.
         do 2 red; intros. do 3 rewrite int_lift_rec_eq. rewrite V.lams0.
         unfold subst; do 2 rewrite int_subst_rec_eq. do 2 rewrite V.lams0.
         assert (int (V.shift 0 (V.lams 1 (V.shift 1) (V.shift 1 (fun k : nat =>
           V.lams 2 (V.shift 2) i k)))) (Ref 0) == i 1).
          unfold V.lams, V.shift; simpl; reflexivity.
         assert (int (V.shift 0 (V.lams 1 (V.shift 1) (V.shift 1 (fun k : nat =>
           V.lams 2 (V.shift 2) i k)))) (App Succ Zero) == SUCC ZERO).
          rewrite int_S; [simpl; reflexivity|apply ZERO_typ].
         red in H.
         assert (in_int i j (Ref 1) (lift 2 (lift 1 (lift 1 (lift 1 Nat))))).
          apply H; reflexivity.

         apply in_int_not_kind in H2; [|discriminate].
         destruct H2 as (Hi1, _); unfold inX in Hi1; simpl in Hi1; rewrite El_def in Hi1.
         rewrite int_Add with (3:=H0) (4:=H1); [|rewrite H0; trivial
           |rewrite H1; apply SUCC_typ; apply ZERO_typ].
         do 3 rewrite int_lift_rec_eq.
         rewrite NATREC_S; [rewrite NATREC_0
           |do 3 red; intros; rewrite H3; reflexivity
           |apply ZERO_typ].
         rewrite int_S; [|simpl; unfold V.shift; trivial].
         do 3 (rewrite <- V.cons_lams; [|do 2 red; intros; rewrite H2; reflexivity]).
         do 3 rewrite V.lams0. unfold V.lams, V.shift; simpl.
         apply int_morph; [do 2 red; intros|reflexivity].
          apply V.cons_morph;
            [|do 3 red; intros; replace (a0-0) with a0; [|omega]]; reflexivity.

         apply typ_S1.
         setoid_replace Nat with (lift 2 (lift 1 (lift 1 (lift 1 Nat)))) using relation eq_trm at 4;
           [apply typ_var; trivial|simpl; split; red; reflexivity].

    rewrite eq_typ_beta with (N':=(Ref 0)) (M':=(lift_rec 3 1 P));
      [|apply refl|apply refl| |discriminate].
     do 2 red; intros. unfold subst.
     rewrite int_subst_rec_eq. do 2 rewrite int_lift_rec_eq.
     rewrite V.lams0. rewrite <- V.cons_lams; [|do 2 red; intros; rewrite H0; reflexivity].
     rewrite V.lams0; unfold V.shift at 1; simpl. apply int_morph; [|reflexivity].
      apply V.cons_ext; [unfold V.lams, V.shift; simpl
        |rewrite V.shift_lams; rewrite V.lams0; rewrite V.shift_split]; reflexivity.

    apply typ_var; trivial.
Qed.

Definition ax := ax1 /\ ax2 /\ ax3 /\ ax4 /\ ax5.

Lemma ax_provable : ax.
unfold ax. split; [apply P_ax_intro1|split; [apply P_ax_intro2
|split; [apply P_ax_intro3|split; [apply P_ax_intro4|apply P_ax_intro5]]]].
Qed.

End PSemAx.

(************************************************************************************)
(*Presburger Semantic*)
(************************************************************************************)
Module PresburgerSem <: TheorySem.

Module sig <: AbsSemSig := PSemSig.
Export sig.

Module ax <: SemanticAx PSemSig := PSemAx.
Export ax.

End PresburgerSem.


Require Import RelationClasses.
Require Import List.
Require Import Maps.
Require Import Coqlib.
Require Import LibTactics.
Require Import Basics.

Require Import sflib.

Require Import Basic.
Require Import Loc.
Require Import Axioms.

Require Import Language.
Require Import Event.
Require Import Integers.

Set Implicit Arguments.

(** * Syntax of the CSimpRTL Language *)

(** This file defines the syntax of the concurrent simple RTL language (CSimpRTL),
    which corresponds to the definitions in Figure 7 in our paper *)

Module Reg := Ident.
Module RegSet := IdentSet.
Module RegMap := IdentMap.
Module RegFun := IdentFun.

Module Op2.
    Inductive t :=
    | add
    | sub
    | mul
    .
    Definition eval (op:t): forall (op1 op2:int), int :=
        match op with
        | add => Int.add
        | sub => Int.sub
        | mul => Int.mul
        end.
    Definition eqb (op1 op2: t): bool :=
        match op1, op2 with
        | add, add => true
        | sub, sub => true
        | mul, mul => true
        | _, _ => false
        end.
    Definition eq_dec : forall op1 op2: t, {op1 = op2} + {op1 <> op2}.
        decide equality.
    Defined.
End Op2.

(** ** Instruction *)
Module Inst.
    Inductive expr :=
    | expr_val (val: int)
    | expr_reg (reg: Reg.t)
    | expr_op2 (op: Op2.t) (op1 op2: expr)
    .

    Definition expr_eq_dec: forall e1 e2: expr, {e1 = e2} + {e1 <> e2}.
        decide equality. eapply Int.eq_dec. eapply Loc.eq_dec. eapply Op2.eq_dec.
    Defined.

    Definition beq_expr (e1 e2: expr): bool :=
        expr_eq_dec e1 e2.

    Lemma beq_expr_eq:
        forall e e',
        beq_expr e e' = true <-> e = e'.
    Proof.
        intros.
        split.
        - intro.
          unfolds beq_expr.
          unfolds Coqlib.proj_sumbool.
          des_ifs.
        - intro.
            unfolds beq_expr.
            unfolds Coqlib.proj_sumbool.
            des_ifs.
    Qed.

    Fixpoint regs_of_expr (r:expr): RegSet.t :=
        match r with
        | expr_val val => RegSet.empty
        | expr_reg reg => RegSet.singleton reg
        | expr_op2 _ op1 op2 => RegSet.union (regs_of_expr op1) (regs_of_expr op2)
        end.

    (** Instruction includes:
        - [skip]: skip;
        - [assign]: register assignments;
        - [load]: memory read;
        - [store]: memory store;
        - [print]: system call for output;
        - [cas]: atomic update;
        - [fence_rel], [fence_acq] and [fence_sc]: release, acquire and sc fences. *)
    Inductive t :=
    | skip
    | assign (lhs: Reg.t) (rhs: expr)
    | load (lhs: Reg.t) (loc: Loc.t) (or: Ordering.t)
    | store (lhs: Loc.t) (rhs: expr) (ow: Ordering.t)
    | print (e: expr)
    | cas (lhs: Reg.t) (loc: Loc.t) (er ew: expr) (or ow: Ordering.t)
    | fence_rel
    | fence_acq
    | fence_sc
    .

    Definition regs_of (i:t): RegSet.t :=
        match i with
        | skip => RegSet.empty
        | assign reg rhs => RegSet.add reg (regs_of_expr rhs)
        | load reg loc _ => regs_of_expr (expr_reg reg)
        | store loc rhs _ => regs_of_expr rhs
        | cas r loc er ew _ _ =>
          RegSet.add r (RegSet.union (regs_of_expr er) (regs_of_expr ew))
        | print e => regs_of_expr e
        | _ => RegSet.empty
        end.
End Inst.

(** ** Basic Block *)
(** A list of instructions with a jmp (unconditional branch),
    or call (function call) or be (conditional branch) or ret (function return) instructions as a tail. *)
Module BBlock.
    Inductive t :=
    | jmp (f: Language.fid)
    | call (f fret: Language.fid)
    | be (e: Inst.expr) (f1 f2: Language.fid)
    | ret
    | blk (c: Inst.t) (b: t).

    Fixpoint regs_of_blk (BB: t): RegSet.t :=
      match BB with
      | jmp f => RegSet.empty
      | call f fret => RegSet.empty
      | ret => RegSet.empty
      | be e f1 f2 => Inst.regs_of_expr e
      | blk c BB' => RegSet.union (Inst.regs_of c) (regs_of_blk BB')
      end.

    Fixpoint get_out_fids (bb: t): list(Language.fid) :=
        match bb with
        | blk _ bb' => get_out_fids bb'
        | jmp fid => fid::nil
        | call f fret => fret::nil
        | be _ fid1 fid2  => fid1::(fid2::nil)
        | _ => nil
        end.

    Fixpoint bb_from_i (bb: t) (i: nat) {struct i} : option t :=
        match i with
        | O => Some bb
        | S i' =>
            match bb with
            | blk _ bb' => bb_from_i bb' i'
            | _ => None
            end
        end.

    Fixpoint len (bb: t) :=
        match bb with
        | blk c bb' => len(bb') + 1
        | _ => 1
        end.

    Lemma len_lt_zero:
    forall bb,
        len bb > 0.
    Proof.
        intros.
        unfolds len.
        destruct bb; try lia.
    Qed.

    Lemma len_lt:
    forall i bb bb',
      bb_from_i bb i = Some bb' ->
      i < len bb.
    Proof.
      induction i.
      intros.
      pose proof (len_lt_zero bb). lia.
      intros.
      unfold bb_from_i in H.
      destruct bb; try discriminate; eauto. folds bb_from_i .
      eapply IHi in H.
      unfold len. fold len.
      lia.
    Qed.

    Lemma len_divide:
    forall i bb bb',
      bb_from_i bb i = Some bb' ->
      i + len bb' = len bb.
    Proof.
      induction i.
      intros.
      unfold bb_from_i in H.
      inv H. lia.

      intros.
      unfold bb_from_i in H.
      destruct bb; try discriminate; eauto. folds bb_from_i .
      eapply IHi in H.
      unfold len. fold len.
      lia.
    Qed.

    Lemma len_lt_one:
    forall bb,
      (exists i' bb',
        bb = blk i' bb'
        )
      ->
      len bb > 1.
    Proof.
      intros.
      destruct H as (inst' & bb' & BLK).
      rewrite BLK.
      unfold len; try discriminate. fold len.
      pose proof (len_lt_zero bb'). lia.
    Qed.

    Lemma len_eq_one:
    forall bb,
      (forall i' bb',
        bb <> blk i' bb'
        )
      ->
      len bb = 1.
    Proof.
      intros.
      pose proof (classic (len bb = 1)).
      destruct H0; trivial.
      {
        exfalso.
        pose proof (len_lt_zero bb).
        destruct bb; unfolds len; try lia.
        folds len.
        pose proof (H c bb). contradiction.
      }
    Qed.

    Lemma len_eq:
    forall i bb bb',
      bb_from_i bb i = Some bb' ->
      (forall i' bb'',
        bb' <> blk i' bb''
        )
      ->
      i+1 = len bb.
    Proof.
      induction i.
      -
      intros.
      unfold bb_from_i in H.
      inversion H. simpl.
      eapply eq_sym.
      eapply len_eq_one; eauto.
      -
      intros.
      eapply len_divide in H.
      eapply len_eq_one in H0; eauto.
      rewrite H0 in H. trivial.
    Qed.

    Lemma len_none:
    forall i bb,
      bb_from_i bb i = None <->
      i >= len bb.
    Proof.
      induction i.
      -
        intros.
        split.
        unfolds bb_from_i. discriminate.
        intros.
        pose proof (len_lt_zero bb).
        lia.
      -
        intros.
        split.
        {
          intros.
          unfold bb_from_i in H.
          folds bb_from_i.
          destruct bb; unfolds len; try lia.
          eapply IHi in H.
          lia.
        }
        {
          intros.
          unfold len in H.
          destruct bb;
          unfolds bb_from_i; trivial.
          folds bb_from_i.
          folds len.
          assert (i >= len bb). {
            lia.
          }
          eapply IHi in H0.
          trivial.
        }
    Qed.

    Lemma len_none_plus:
    forall bb i i',
      bb_from_i bb i = None ->
      i' >= i ->
      bb_from_i bb i' = None.
    Proof.
      intros.
      eapply len_none in H.
      assert (i' >= len bb). {lia. }
      eapply len_none in H1.
      trivial.
    Qed.

End BBlock.
Notation "i ## b" := (BBlock.blk i b) (at level 69, right associativity).
Notation "b [ i :]" := (BBlock.bb_from_i b i) (at level 1, right associativity).

(** ** Codeheap *)
(** A partial mapping from block label to basic block. *)
Definition CodeHeap:Type := PTree.t (BBlock.t). (** fid -> bblock *)
(** ** Function *)
(** A pair of codeheap and a label indicating the function entry. *)
(** In our paper (in Figure 4), for simple presentation,
    we assume that the entry of each function equals to its function identifier. *)
Definition Func:Type := (CodeHeap * Language.fid).
(** ** Program *)
(** A partial mapping from function identifier to function. *)
Definition Code:Type := PTree.t Func.

Fixpoint regs_of_cdhp' (BS: list (positive * BBlock.t)) :=
  match BS with
  | nil => RegSet.empty
  | (l, BB) :: BS' => RegSet.union (BBlock.regs_of_blk BB) (regs_of_cdhp' BS')
  end.

Definition regs_of_cdhp (cdhp: CodeHeap) :=
  regs_of_cdhp' (PTree.elements cdhp).

Definition succ (bb: BBlock.t): list(Language.fid) := BBlock.get_out_fids bb.

Inductive pred (cdhp: CodeHeap) (f: Language.fid): forall (f': Language.fid), Prop :=
    | pred_intro
        f' bb
        (VALID: cdhp!f' = Some bb)
        (PRED: In f (succ bb))
        :
        pred cdhp f f'
    .

Theorem subblk_same_succ:
    forall blk inst blk',
        blk = inst ## blk' ->
        succ blk = succ blk'.
Proof.
    intros.
    unfolds succ.
    unfolds BBlock.get_out_fids. rewrite H. trivial.
Qed.

Definition bb_from_i := BBlock.bb_from_i.

Theorem bb_from_zero:
    forall blk,
    blk[0:] = Some blk.
Proof.
    intros.
    unfolds BBlock.bb_from_i.
    induction blk; trivial.
Qed.

Theorem bb_from_i_plus_one:
    forall i blk inst b',
    blk [i:] = Some (inst ## b')
    ->
    blk [i+1:] = Some (b').
Proof.
    induction i.
    -
        intros.
        unfolds BBlock.bb_from_i.
        destruct blk; try inversion H; eauto.
    -
        intros.
        simpls.
        destruct blk; eauto; try discriminate.
Qed.

Theorem bb_from_i_gnone:
    forall i blk inst blk',
    blk = inst ## blk'
    ->
    blk [i:] = None
    ->
    blk' [i:] = None
    .
Proof.
  induction i.
  intros.
  - unfolds BBlock.bb_from_i. discriminate.
  - intros.
    unfolds BBlock.bb_from_i. rewrite H in H0.
    destruct blk' eqn:EqBlk'; trivial.
    (* pose proof H0.  *)
    (* destruct i; try discriminate; eauto. *)
    eapply BBlock.len_none in H0.
    folds BBlock.bb_from_i.
    eapply BBlock.len_none.
    assert (exists i', i = S i'). {
      pose proof (BBlock.len_lt_zero (c ## t)).
      destruct i; try lia.
      exists i. trivial.
    }
    destruct H1 as (i' & H1).
    rewrite H1.
    rewrite H1 in H0.
    folds bb_from_i.
    eapply BBlock.len_none.
    eapply BBlock.len_none in H0.
    rewrite <- EqBlk' in H0.
    eapply IHi in EqBlk'; eauto.
    eapply BBlock.len_none_plus with (i' := S i') in EqBlk'; eauto; try lia.
    rewrite H1; trivial.
Qed.

Theorem bb_from_i_geq:
    forall i blk inst blk' blk'',
    blk = inst ## blk'
    ->
    blk' [i:] = blk''
    ->
    blk [i+1:] = blk''
    .
Proof.
  induction i.
  - intros.
    unfolds BBlock.bb_from_i. simpls.
    rewrite H. trivial.
  - intros.
    unfolds BBlock.bb_from_i. simpls.
    rewrite H.
    replace (i+1) with (S i); try lia.
    trivial.
Qed.

Theorem bb_from_i_plus_one_implies_i:
    forall i blk blk'',
        blk [S i:] = Some blk''
        ->
      exists inst,
        blk [i:] = Some (inst##blk'').
Proof.
  induction i.
  -
  intros.
  unfolds BBlock.bb_from_i.
  destruct blk eqn:EqBlk; try discriminate.
  inv H.
  exists c. econs.
  -
  intros.
  unfolds BBlock.bb_from_i.
  destruct blk eqn:EqBlk; try discriminate.
  folds BBlock.bb_from_i.
  destruct t eqn:EqT; try discriminate; eauto.
Qed.

Theorem bb_from_i_invariant:
    forall i blk blk',
      blk [i:] = Some blk'
      ->
      BBlock.len blk = i + BBlock.len blk'.
Proof.
  induction i.
  -
    intros.
    unfolds BBlock.bb_from_i. inv H. lia.
  -
    intros.
    eapply bb_from_i_plus_one_implies_i in H.
    destruct H as (inst & H).
    eapply IHi in H.
    rewrite H.
    unfold BBlock.len; simpls.
    lia.
Qed.

Theorem blk_partial_i_lt_len:
    forall i blk blk',
        blk[i:] = Some blk'
        ->
        i < BBlock.len blk.
Proof.
    intros.
    eapply bb_from_i_invariant in H.
    pose proof (BBlock.len_lt_zero blk').
    rewrite H.
    eapply Nat.lt_sub_lt_add_l.
    lia.
Qed.

Lemma reg_in_blk_in_cdhp':
  forall m l BB r
    (IN: In (l, BB) m)
    (REG: RegSet.In r (BBlock.regs_of_blk BB)),
    RegSet.In r (regs_of_cdhp' m).
Proof.
  induction m; ii; ss; eauto.
  destruct a. des1.
  - inv IN. eapply RegSet.union_spec. eauto.
  - eapply RegSet.union_spec; eauto.
Qed.

Theorem reg_in_blk_in_cdhp
        r BB l cdhp
        (REG_BLK: RegSet.In r (BBlock.regs_of_blk BB))
        (GET: cdhp ! l = Some BB):
  RegSet.In r (regs_of_cdhp cdhp).
Proof.
  unfold regs_of_cdhp.
  eapply reg_in_blk_in_cdhp'; eauto.
  instantiate (1 := l).
  eapply PTree.elements_correct; eauto.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj23eqsynthconj1 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural), (@eq natural (plus (mult lv0 lv1) lv2) (plus lv2 (mult lv1 (plus lv0 Zero)))).
Admitted.
QuickChick conj23eqsynthconj1.


Require Export RelDefinitions.
Require Import RelClasses.
Require Import Relators.

(** ** Union of relations *)

Definition rel_union {A B} (R1 R2: rel A B): rel A B :=
  fun x y => R1 x y \/ R2 x y.

Arguments rel_union {_ _} R1%rel R2%rel _ _.

Infix "\/" := rel_union : rel_scope.

Global Instance rel_union_subrel {A B}:
  Monotonic (@rel_union A B) (subrel ++> subrel ++> subrel).
Proof.
  clear.
  firstorder.
Qed.

Global Instance rel_union_subrel_params:
  Params (@rel_union) 4.

(** Since we're forced to commit to a branch, we can't use [RIntro],
  but can still provide [RExists] instances. *)

Lemma rel_union_rexists_l {A B} (R1 R2: rel A B) x y:
  RExists (R1 x y) (R1 \/ R2) x y.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ (_ \/ _) _ _) =>
  eapply rel_union_rexists_l : typeclass_instances.

Lemma rel_union_rexists_r {A B} (R1 R2: rel A B) x y:
  RExists (R2 x y) (R1 \/ R2) x y.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ (_ \/ _) _ _) =>
  eapply rel_union_rexists_r : typeclass_instances.

(** More often, we can solve a [rel_union] goal using a monotonicity
  property, and the [subrel] instances below. *)

Lemma rel_union_subrel_rexists_l {A B} (R R1 R2: rel A B):
  RExists (subrel R R1) subrel R (R1 \/ R2)%rel.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ subrel _ (_ \/ _)%rel) =>
  eapply rel_union_subrel_rexists_l : typeclass_instances.

Lemma rel_union_subrel_rexists_r {A B} (R R1 R2: rel A B):
  RExists (subrel R R2) subrel R (R1 \/ R2)%rel.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ subrel _ (_ \/ _)%rel) =>
  eapply rel_union_subrel_rexists_r : typeclass_instances.

Lemma rel_union_lub {A B} (R1 R2 R: rel A B):
  RIntro (subrel R1 R /\ subrel R2 R) subrel (R1 \/ R2)%rel R.
Proof.
  firstorder.
Qed.

Hint Extern 2 (RIntro _ subrel (_ \/ _)%rel _) =>
  eapply rel_union_lub : typeclass_instances.

Lemma rel_union_refl_l {A} (R1 R2: rel A A):
  Reflexive R1 ->
  Reflexive (R1 \/ R2).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Reflexive (_ \/ _)) =>
  eapply rel_union_refl_l : typeclass_instances.

Lemma rel_union_refl_r {A} (R1 R2: rel A A):
  Reflexive R2 ->
  Reflexive (R1 \/ R2).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Reflexive (_ \/ _)) =>
  eapply rel_union_refl_r : typeclass_instances.

Lemma rel_union_corefl {A} (R1 R2: rel A A):
  Coreflexive R1 ->
  Coreflexive R2 ->
  Coreflexive (R1 \/ R2).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Coreflexive (_ \/ _)) =>
  eapply rel_union_corefl : typeclass_instances.

Lemma rel_union_sym {A} (R1 R2: rel A A):
  Symmetric R1 ->
  Symmetric R2 ->
  Symmetric (R1 \/ R2).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Symmetric (_ \/ _)) =>
  eapply rel_union_sym : typeclass_instances.

(** ** Intersection of relations *)

Definition rel_inter {A B} (R1 R2: rel A B): rel A B :=
  fun x y => R1 x y /\ R2 x y.

Arguments rel_inter {_ _} R1%rel R2%rel _ _.

Infix "/\" := rel_inter : rel_scope.

Global Instance rel_inter_subrel {A B}:
  Monotonic (@rel_inter A B) (subrel ++> subrel ++> subrel).
Proof.
  clear.
  firstorder.
Qed.

Global Instance rel_inter_params:
  Params (@rel_inter) 4.

(** In some cases, the relation in the goal will cause existential
  variables to be instantiated accordingly; for instance, [rstep] run
  on [?R x y |- (R1 /\ R2) x y] will instantiate [?R := R1 /\ R2].
  Because of this, splitting a [rel_inter] goal into two subgoals may
  cause a dead-end and we have to use [RExists] for the following
  rule. *)

Lemma rel_inter_rexists {A B} (R1 R2: rel A B) x y:
  RExists (R1 x y /\ R2 x y) (R1 /\ R2) x y.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ (_ /\ _) _ _) =>
  eapply rel_inter_rexists : typeclass_instances.

Lemma rel_inter_subrel_rexists_l {A B} (R1 R2 R: rel A B):
  RExists (subrel R1 R) subrel (R1 /\ R2)%rel R.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ subrel (_ /\ _)%rel _) =>
  eapply rel_inter_subrel_rexists_l : typeclass_instances.

Lemma rel_inter_subrel_rexists_r {A B} (R1 R2 R: rel A B):
  RExists (subrel R2 R) subrel (R1 /\ R2)%rel R.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ subrel (_ /\ _)%rel _) =>
  eapply rel_inter_subrel_rexists_r : typeclass_instances.

Lemma rel_inter_glb {A B} (R R1 R2: rel A B):
  RIntro (subrel R R1 /\ subrel R R2) subrel R (R1 /\ R2)%rel.
Proof.
  firstorder.
Qed.

Hint Extern 2 (RIntro _ subrel _ (_ /\ _)%rel) =>
  eapply rel_inter_glb : typeclass_instances.

Lemma rel_inter_refl {A} (R1 R2: rel A A):
  Reflexive R1 ->
  Reflexive R2 ->
  Reflexive (R1 /\ R2).
Proof.
  intros H1 H2.
  split; reflexivity.
Qed.

Hint Extern 2 (Reflexive (_ /\ _)) =>
  eapply rel_inter_refl : typeclass_instances.

Lemma rel_inter_corefl_l {A} (R1 R2: rel A A):
  Coreflexive R1 ->
  Coreflexive (R1 /\ R2).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Coreflexive (_ /\ _)) =>
  eapply rel_inter_corefl_l : typeclass_instances.

Lemma rel_inter_corefl_r {A} (R1 R2: rel A A):
  Coreflexive R2 ->
  Coreflexive (R1 /\ R2).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Coreflexive (_ /\ _)) =>
  eapply rel_inter_corefl_r : typeclass_instances.

Lemma rel_inter_trans {A} (R1 R2: rel A A):
  Transitive R1 ->
  Transitive R2 ->
  Transitive (R1 /\ R2).
Proof.
  intros H1 H2 x y z [Hxy1 Hxy2] [Hyz1 Hyz2].
  split; etransitivity; eassumption.
Qed.

Hint Extern 2 (Transitive (_ /\ _)) =>
  eapply rel_inter_trans : typeclass_instances.

Lemma rel_inter_sym {A} (R1 R2: rel A A):
  Symmetric R1 ->
  Symmetric R2 ->
  Symmetric (R1 /\ R2).
Proof.
  intros H1 H2 x y [Hxy1 Hxy2].
  split; symmetry; assumption.
Qed.

Hint Extern 2 (Symmetric (_ /\ _)) =>
  eapply rel_inter_sym : typeclass_instances.

Global Instance rel_inter_flip_sym {A} (R: rel A A):
  Symmetric (R /\ flip R).
Proof.
  intros x y [Hxy Hyx].
  split; assumption.
Qed.

(** On a related note, a symmetric subrelation of [R] is also a
  subrelation of its inverse. *)

Lemma subrel_sym_flip {A} (R R': relation A):
  Symmetric R ->
  RStep (subrel R R') (subrel R (flip R')).
Proof.
  intros HR H x y Hxy.
  symmetry in Hxy.
  firstorder.
Qed.

Hint Extern 60 (RStep _ (subrel _ (flip _))) =>
  eapply subrel_sym_flip : typeclass_instances.

(** ** Implication *)

Definition rel_impl {A B} (R1 R2: rel A B): rel A B :=
  fun x y => R1 x y -> R2 x y.

Global Instance rel_impl_subrel {A B}:
  Monotonic (@rel_impl A B) (subrel --> subrel ++> subrel).
Proof.
  firstorder.
Qed.

Global Instance rel_impl_subrel_params:
  Params (@rel_impl) 4.

Lemma rel_impl_rintro {A B} (R1 R2: rel A B) x y:
  RIntro (R1 x y -> R2 x y) (rel_impl R1 R2) x y.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RIntro _ (rel_impl _ _) _ _) =>
  eapply rel_impl_rintro : typeclass_instances.

Lemma rel_impl_relim {A B} (R1 R2: rel A B) x y:
  RElim (rel_impl R1 R2) x y (R1 x y) (R2 x y).
Proof.
  firstorder.
Qed.

Hint Extern 0 (RElim (rel_impl _ _) _ _ _ _) =>
  eapply rel_impl_relim : typeclass_instances.

Lemma rel_impl_subrel_codomain {A B} (R1 R2: rel A B):
  Related R2 (rel_impl R1 R2) subrel.
Proof.
  firstorder.
Qed.

(** ** The bottom and top relations *)

Definition rel_bot {A B}: rel A B :=
  fun x y => False.

Notation "⊥" := rel_bot : rel_scope.

Lemma rel_bot_subrel {A B} (R: rel A B):
  Related ⊥%rel R subrel.
Proof.
  firstorder.
Qed.

Hint Extern 0 (Related ⊥%rel _ _) =>
  eapply rel_bot_subrel : typeclass_instances.

Lemma rel_bot_relim {A B} (x: A) (y: B) P:
  RElim ⊥ x y True P.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RElim ⊥ _ _ _ _) =>
  eapply rel_bot_relim : typeclass_instances.

Definition rel_top {A B}: rel A B :=
  fun x y => True.

Notation "⊤" := rel_top : rel_scope.

Lemma rel_top_rintro {A B} (x: A) (y: B):
  RIntro True ⊤ x y.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RIntro _ ⊤ _ _) =>
  eapply rel_top_rintro : typeclass_instances.

Global Instance rel_top_equiv {A}:
  @Equivalence A ⊤.
Proof.
  repeat constructor.
Qed.

(** ** Relation equivalence *)

Definition eqrel {A B}: rel (rel A B) (rel A B) :=
  (subrel /\ flip subrel)%rel.

Arguments eqrel {_ _} RA%rel RB%rel.

Global Instance eqrel_equivalence A B:
  Equivalence (@eqrel A B).
Proof.
  unfold eqrel.
  split; typeclasses eauto.
Qed.

Global Instance eqrel_subrel A B:
  Related (@eqrel A B) (@subrel A B) subrel.
Proof.
  firstorder.
Qed.

(** ** Relation composition *)

Definition rel_compose {A B C} (RAB: rel A B) (RBC: rel B C): rel A C :=
  fun x z => exists y, RAB x y /\ RBC y z.

Hint Unfold rel_compose.

Global Instance rel_compose_subrel {A B C}:
  Monotonic (@rel_compose A B C) (subrel ++> subrel ++> subrel).
Proof.
  firstorder.
Qed.

Global Instance rel_compose_eqrel {A B C}:
  Monotonic (@rel_compose A B C) (eqrel ==> eqrel ==> eqrel).
Proof.
  firstorder.
Qed.

Global Instance rel_compose_params:
  Params (@rel_compose) 4.

Lemma rel_compose_id_left {A B} (R: rel A B):
  eqrel (rel_compose R eq) R.
Proof.
  unfold rel_compose.
  split; intros x y; firstorder; congruence.
Qed.

Lemma rel_compose_id_right {A B} (R: rel A B):
  eqrel (rel_compose eq R) R.
Proof.
  unfold rel_compose.
  split; intros x y; firstorder; congruence.
Qed.

Lemma rel_compose_assoc {A B C D} (RAB: rel A B) (RBC: rel B C) (RCD: rel C D):
  eqrel
    (rel_compose (rel_compose RAB RBC) RCD)
    (rel_compose RAB (rel_compose RBC RCD)).
Proof.
  unfold rel_compose.
  split; intros x y; firstorder; congruence.
Qed.

(** Transitivity and decomposition can be expressed in terms of
  [rel_compose] in the following way. *)

Global Instance rel_compose_rcompose {A B C} (RAB : rel A B) (RBC : rel B C) :
  RCompose RAB RBC (rel_compose RAB RBC).
Proof.
  firstorder.
Qed.

Global Instance rel_compose_rdecompose {A B C} (RAB : rel A B) (RBC : rel B C) :
  RDecompose RAB RBC (rel_compose RAB RBC).
Proof.
  firstorder.
Qed.

Global Instance rcompose_subrel `(RCompose) :
  Related (rel_compose RAB RBC) RAC subrel.
Proof.
  firstorder.
Qed.

Global Instance rdecompose_subrel `(RDecompose) :
  Related RAC (rel_compose RAB RBC) subrel.
Proof.
  firstorder.
Qed.

(** ** Pulling a relation along functions *)

Definition rel_pull {A B A' B'} f g (R: rel A' B'): rel A B :=
  fun x y => R (f x) (g y).

(** We use the following notation. Left associativity would make more
  sense but we have to match [Coq.Classes.RelationPairs]. *)

Notation "R @@ ( f , g )" := (rel_pull f g R)
  (at level 30, right associativity) : rel_scope.

Notation "R @@ f" := (rel_pull f f R)
  (at level 30, right associativity) : rel_scope.

Notation "R @@ ( f )" := (rel_pull f f R)
  (at level 30, right associativity) : rel_scope.

Global Instance rel_pull_subrel {A B A' B'} (f: A -> A') (g: B -> B'):
  Monotonic (rel_pull f g) (subrel ++> subrel).
Proof.
  firstorder.
Qed.

Global Instance rel_pull_subrel_params:
  Params (@rel_pull) 3.

(** In the restricted case where [f = g], [rel_pull] preserves many
  properties of the underlying relation. *)

Lemma rel_pull_refl {A B} (f: A -> B) (R: rel B B):
  Reflexive R ->
  Reflexive (R @@ f).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Reflexive (rel_pull _ _ _)) =>
  eapply rel_pull_refl : typeclass_instances.

Lemma rel_pull_sym {A B} (f: A -> B) R:
  Symmetric R ->
  Symmetric (R @@ f).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Symmetric (rel_pull _ _ _)) =>
  eapply rel_pull_sym : typeclass_instances.

Lemma rel_pull_trans {A B} (f: A -> B) R:
  Transitive R ->
  Transitive (R @@ f).
Proof.
  firstorder.
Qed.

Hint Extern 1 (Transitive (rel_pull _ _ _)) =>
  eapply rel_pull_trans : typeclass_instances.

(** The introduction rule is straightforward, but changes the head
  terms to the functions used with [rel_pull]. This means that an
  [RIntro] rule would short-circuit any relational property formulated
  for the original terms, even if the codomain is a matching
  [rel_pull] relation and we have an appropriate [RElim] instance.
  To avoid shadowing such properties, we define our introduction rule
  as an [RStep] with a low priority. See test [rel_pull_2]. *)

Lemma rel_pull_rintro {A B A' B'} (f: A -> A') (g: B -> B') R x y:
  RStep (R (f x) (g y)) ((R @@ (f, g))%rel x y).
Proof.
  firstorder.
Qed.

Hint Extern 60 (RStep _ ((_ @@ (_, _))%rel _ _)) =>
  eapply rel_pull_rintro : typeclass_instances.

(** We can reuse an instance of [RElim] for the underlying relation to
  provide corresponding instances for the pulled relation. *)

Lemma rel_pull_relim {A B A' B'} (f: A -> A') (g: B -> B') R x y P Q:
  RElim R (f x) (g y) P Q ->
  RElim (R @@ (f, g)) x y P Q.
Proof.
  firstorder.
Qed.

Hint Extern 1 (RElim (_ @@ (_, _)) _ _ _ _) =>
  eapply rel_pull_relim : typeclass_instances.

(** ** Pushing a relation along functions *)

Inductive rel_push {A1 A2 B1 B2} f g (R: rel A1 A2): rel B1 B2 :=
  rel_push_rintro x y: RIntro (R x y) (rel_push f g R) (f x) (g y).

Hint Extern 1 (RIntro _ (rel_push _ _ _) _ _) =>
  eapply rel_push_rintro : typeclass_instances.

(** The level we choose here is to match the notation used for
  [PTree.get] in Compcert's [Maps] library. *)

Notation "R !! ( f , g )" := (rel_push f g R)
  (at level 1) : rel_scope.

Notation "R !! f" := (rel_push f f R)
  (at level 1) : rel_scope.

Notation "R !! ( f )" := (rel_push f f R)
  (at level 1) : rel_scope.

Global Instance rel_push_subrel {A1 A2 B1 B2} (f: A1 -> B1) (g: A2 -> B2):
  Proper (subrel ++> subrel) (rel_push f g).
Proof.
  intros R1 R2 HR x y Hxy.
  destruct Hxy.
  rintro; eauto.
Qed.

Global Instance rel_push_subrel_params:
  Params (@rel_push) 3.

Lemma rel_push_corefl {A B} (f: A -> B) (R: rel A A):
  Coreflexive R ->
  Coreflexive (R !! f).
Proof.
  intros H _ _ [x y Hxy].
  f_equal.
  eauto using coreflexivity.
Qed.

Hint Extern 1 (Coreflexive (_ !! _)) =>
  eapply rel_push_corefl : typeclass_instances.

(** When using [R !! fst] or [R !! snd], if [rel_push_intro] does not
  apply, we can use the following instances instead. *)

Lemma rel_push_fst_rexists {A1 A2 B1 B2} (x1:A1) (x2:A2) (y1:B1) (y2:B2) R:
  RExists (R (x1, y1) (x2, y2)) (R !! fst) x1 x2.
Proof.
  intros H.
  change x1 with (fst (x1, y1)).
  change x2 with (fst (x2, y2)).
  rintro.
  assumption.
Qed.

Hint Extern 1 (RExists _ (_ !! fst) _ _) =>
  eapply rel_push_fst_rexists : typeclass_instances.

Lemma rel_push_snd_rexists {A1 A2 B1 B2} (x1:A1) (x2:A2) (y1:B1) (y2:B2) R:
  RExists (R (x1, y1) (x2, y2)) (R !! snd) y1 y2.
Proof.
  intros H.
  change y1 with (snd (x1, y1)).
  change y2 with (snd (x2, y2)).
  rintro.
  assumption.
Qed.

Hint Extern 1 (RExists _ (_ !! snd) _ _) =>
  eapply rel_push_snd_rexists : typeclass_instances.

(** ** Relation currying *)

(* An interesting special case of [rel_pull] is [rel_curry], which
  takes a relation over [A * B -> C] and turns it into a relation
  over [A -> B -> C].

  [rel_curry] is particularly useful when two (curried) arguments
  to a given function have to be related in a dependent way. For
  example in Compcert, memory injections relate memory blocks and
  offsets jointly, but many operations have those as two separate
  arguments. To state the relational property of such operations, we
  can uncurry a joint relation on (block, offset) pairs.

  [rel_curry] can be obtained by pulling back the original relation
  along [uncurry]: *)

Definition curry {A B C} (f: A * B -> C): A -> B -> C :=
  fun a b => f (a, b).

Definition uncurry {A B C} (f: A -> B -> C): A * B -> C :=
  fun ab => match ab with (a, b) => f a b end.

Definition rel_curry {A1 B1 C1 A2 B2 C2} (R: rel (A1*B1->C1) (A2*B2->C2)) :=
  (R @@ uncurry)%rel.

Definition rel_uncurry {A1 B1 C1 A2 B2 C2} (R: rel (A1->B1->C1) (A2->B2->C2)) :=
  (R @@ curry)%rel.

(** We use the following notation for [rel_curry], which evokes
  splitting a pair into two separate arguments. Note that we use the
  same priority as for [++>], [-->], and [==>], because we usually
  want [rel_curry] to nest in such a way that for instance,
  [S ++> % R --> % R ++> impl] will be interpreted as
  [S ++> rel_curry (R --> rel_curry (R ++> impl))]. *)

Notation "% R" := (rel_curry R) (at level 55, right associativity) : rel_scope.

(** In order to provide an [RElim] instance for [rel_curry], we will
  rely on the fact that:

      uncurry f (x1, x2) x3 ... xn = f x1 x2 x3 ... xn,

  and that:

      rel_curry R f g <-> R (uncurry f) (uncurry g),

  so that when the instance of [RElim] associated with [R] allows us
  to show:

      Rcod (uncurry f (x1, x2) x3 ... xn) (uncurry g (y1, y2) y3 ... yn)

  we can convert it into an instance for proving:

      Rcod (f x1 x2 x3 ... xn) (g y1 y2 y3 ... yn),

  which is what will be expected for [monotonicity]. To accomplish
  this, we need to [unfold uncurry] in the result provided for [R]
  before we use it to solve the [rel_uncurry] case. This helper class
  does this. *)

Class UnfoldUncurry {A} (before: A) (after: A) :=
  unfold_uncurry_before_after: before = after.

Ltac unfold_uncurry :=
  match goal with
    | |- context C[uncurry ?f ?p] =>
      is_evar p;
      let T := type of p in
      let Av := fresh in evar (Av: Type);
      let A := eval red in Av in clear Av;
      let Bv := fresh in evar (Bv: Type);
      let B := eval red in Bv in clear Bv;
      unify T (prod A B)%type;
      let av := fresh in evar (av : A);
      let a := eval red in av in clear av;
      let bv := fresh in evar (bv : B);
      let b := eval red in bv in clear bv;
      let G := context C[f a b] in
      unify p (a, b);
      change G
  end.

Hint Extern 1 (UnfoldUncurry ?P ?Q) =>
  repeat unfold_uncurry; constructor : typeclass_instances.

(** Now we can provide a somewhat general [RElim] instance for
  [rel_uncurry]. *)

Lemma rel_curry_relim {A1 B1 C1 A2 B2 C2} R f g P Q Q':
  @RElim (A1 * B1 -> C1) (A2 * B2 -> C2) R (uncurry f) (uncurry g) P Q ->
  UnfoldUncurry Q Q' ->
  @RElim (A1 -> B1 -> C1) (A2 -> B2 -> C2) (% R) f g P Q'.
Proof.
  unfold UnfoldUncurry.
  intros; subst.
  assumption.
Qed.

Hint Extern 60 (RStep _ ((% _)%rel _ _)) =>
  eapply rel_pull_rintro : typeclass_instances.

Hint Extern 1 (RElim (% _) _ _ _ _) =>
  eapply rel_curry_relim : typeclass_instances.

(** ** The [req] relation *)

(** The relation [req a] asserts that both elements are equal to [a].
  This comes in handy when expressing the relational properties of
  functions: it can be used to fix the value of an argument, or
  parametrize it using a variable with a broader scope. *)

Inductive req {A} (a: A): rel A A :=
  req_intro: req a a a.

Lemma req_rintro {A} (a: A):
  RIntro True (req a) a a.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RIntro _ (req _) _ _) =>
  eapply req_rintro : typeclass_instances.

Lemma req_corefl {A} (a: A):
  Coreflexive (req a).
Proof.
  destruct 1.
  reflexivity.
Qed.

Hint Extern 0 (Coreflexive (req _)) =>
  eapply req_corefl : typeclass_instances.

(** ** Checking predicates on the left and right elements *)

Definition lsat {A B} (P: A -> Prop): rel A B :=
  fun x y => P x.

Global Instance lsat_subrel A B:
  Monotonic (@lsat A B) ((- ==> impl) ++> subrel).
Proof.
  firstorder.
Qed.

Global Instance lsat_subrel_params:
  Params (@lsat) 3.

Definition rsat {A B} (P: B -> Prop): rel A B :=
  fun x y => P y.

Global Instance rsat_subrel A B:
  Monotonic (@rsat A B) ((- ==> impl) ++> subrel).
Proof.
  firstorder.
Qed.

Global Instance rsat_subrel_params:
  Params (@rsat) 3.

Inductive psat {A} (I: A -> Prop) (x: A): A -> Prop :=
  psat_intro: I x -> psat I x x.

Global Instance psat_subrel A:
  Monotonic (@psat A) ((- ==> impl) ++> subrel).
Proof.
  intros P Q HPQ x _ [Hx].
  constructor. apply HPQ. assumption.
Qed.

Global Instance psat_subrel_params:
  Params (@psat) 3.

Lemma psat_corefl {A} (I: A -> Prop):
  Coreflexive (psat I).
Proof.
  intros x _ [_]. reflexivity.
Qed.

Hint Extern 0 (Coreflexive (psat _)) =>
  eapply psat_corefl : typeclass_instances.

(** ** Relation versions of [ex] and [all] *)

(** Ideally we would overload the [forall] and [exists] notation to
  use the relation version under the [rel] scope. But as long as
  we keep [rel_scope] open globally, we can't really do that
  without breaking everything. So we use our own keyword [rexists] and
  [rforall] instead. *)

Definition rel_all {A B C} (R: C -> rel A B): rel A B :=
  fun x y => forall c, R c x y.

Notation "'rforall' x .. y , p" :=
  (rel_all (fun x => .. (rel_all (fun y => p%rel)) .. ))
  (at level 200, x binder, right associativity)
  : rel_scope.

Lemma rel_all_rintro {A B C} (R: C -> rel A B) m n:
  RIntro (forall c : C, R c m n) (rel_all R) m n.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RIntro _ (rel_all _) _ _) =>
  eapply rel_all_rintro : typeclass_instances.

Lemma rel_all_relim {A B C} (R: C -> rel A B) x y P Q:
  (exists c, RElim (R c) x y P Q) ->
  RElim (rel_all R) x y P Q.
Proof.
  firstorder.
Qed.

Hint Extern 1 (RElim (rel_all _) _ _ _ _) =>
  eapply rel_all_relim; eexists : typeclass_instances.

Definition rel_ex {A B C} (R: C -> rel A B): rel A B :=
  fun x y => exists c, R c x y.

Notation "'rexists' x .. y , p" :=
  (rel_ex (fun x => .. (rel_ex (fun y => p%rel)) ..))
  (at level 200, x binder, right associativity)
  : rel_scope.

Lemma rel_ex_rintro {A B C} (R: C -> rel A B) c m n:
  RExists (R c m n) (rel_ex R) m n.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ (rel_ex _) _ _) =>
  eapply rel_ex_rintro : typeclass_instances.

Lemma rel_ex_relim {A B C} (R: C -> rel A B) x y P Q:
  (forall c, RElim (R c) x y P Q) ->
  RElim (rel_ex R) x y P Q.
Proof.
  firstorder.
Qed.

Hint Extern 1 (RElim (rel_ex _) _ _ _ _) =>
  eapply rel_ex_relim : typeclass_instances.

(** ** The [rel_incr] construction *)

(** XXX: this is on the way out, see KLR.v *)

(** When dealing with Kripke logical relations, we have a family of
  relations indexed by a type of worlds, as well as an accessibility
  relation over this type of worlds. We often want to state that there
  exists a world accessible from a base one in which the relation
  holds. The following construction expresses this. *)

Definition rel_incr {W A B} (acc: rel W W) (R: W -> rel A B): W -> rel A B :=
  fun w a b => exists w', acc w w' /\ R w' a b.

(** While it's possible to define a more general monotonicity property
  for [rel_incr], this one is well-behaved and usually corresponds to
  what we want. *)

Global Instance rel_incr_subrel {W A B} acc:
  Transitive acc ->
  Monotonic (@rel_incr W A B acc) ((- ==> subrel) ++> acc --> subrel).
Proof.
  intros Hacc R1 R2 HR w1 w2 Hw a b (w1' & Hw1' & Hab).
  eexists; split.
  - transitivity w1;
    eassumption.
  - apply HR.
    assumption.
Qed.

Global Instance rel_incr_subrel_params:
  Params (@rel_incr) 4.

(** Note the order of the premises in our intro rule. We want to first
  determine what [w'] should be, then prove [acc w w']. *)

Lemma rel_incr_rintro {W A B} (acc: rel W W) (R: W -> rel A B) w w' m n:
  RExists (R w' m n /\ acc w w') (rel_incr acc R w) m n.
Proof.
  firstorder.
Qed.

Hint Extern 0 (RExists _ (rel_incr _ _ _) _ _) =>
  eapply rel_incr_rintro : typeclass_instances.

Lemma rel_incr_rdestruct {W A B} acc R w T:
  (forall w, exists Tw, RDestruct (R w) Tw /\ Convertible (T w) Tw) ->
  RDestruct
    (@rel_incr W A B acc R w)
    (fun P => forall w', acc w w' -> Delay.unpack (T w' P)).
Proof.
  clear.
  intros HR m n (w' & Hw' & Hmn) P H.
  destruct (HR w') as (Tw & HRw' & HTw).
  eapply rdestruct; eauto.
  destruct HTw.
  eapply H; eauto.
Qed.

Hint Extern 2 (RDestruct (rel_incr _ _ _) _) =>
  eapply rel_incr_rdestruct; intro; eexists; split : typeclass_instances.