(*

  Copyright 2014 Cornell University

  This file is part of VPrl (the Verified Nuprl project).

  VPrl is free software: you can redistribute it and/or modify
  it under the terms of the GNU General Public License as published by
  the Free Software Foundation, either version 3 of the License, or
  (at your option) any later version.

  VPrl is distributed in the hope that it will be useful,
  but WITHOUT ANY WARRANTY; without even the implied warranty of
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  GNU General Public License for more details.

  You should have received a copy of the GNU General Public License
  along with VPrl.  If not, see <http://www.gnu.org/licenses/>.

  Website: http://nuprl.org/html/verification/
  Authors: Abhishek Anand & Vincent Rahli

*)

Require Export sequents_tacs.
Require Export sequents_useful.
Require Export per_props_equality.
Require Export sequents_equality.
Require Export list. (* why *)
(** printing |- $\vdash$ *)
(** printing ->  $\rightarrow$ *)
(* begin hide *)

(* end hide *)

(**

  We now prove the truth of several rules about the PER type.

*)

(* [14] ============ PERTYPE MEMBER EQUALITY ============ *)

(**

  The following rule is called the ``pertype member equality'' rule.
  It allows one to prove that terms are well-formed partial
  equivalence relations, i.e., members of a ``pertype'' type.
<<
   H |- t1 = t2 in pertype(R)

     By pertypeMemberEquality i

     H |- pertype(R) in Type(i)
     H |- R t1 t2
     H |- t1 in Base
>>
 *)

Definition rule_pertype_member_equality {o}
           (t1 t2 R e : NTerm)
           (i : nat)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality t1 t2 (mk_pertype R))))
    [ mk_baresequent H (mk_conclax (mk_member (mk_pertype R) (mk_uni i))),
      mk_baresequent H (mk_concl (mk_apply2 R t1 t2) e),
      mk_baresequent H (mk_conclax (mk_member t1 mk_base))
    ]
    [].

Lemma rule_pertype_member_equality_true {o} :
  forall lib (t1 t2 R e : NTerm),
  forall i : nat,
  forall H : @barehypotheses o,
    rule_true lib (rule_pertype_member_equality
                 t1 t2 R e
                 i
                 H).
Proof.
  unfold rule_pertype_member_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  rename Hyp2 into hyp3.
  destseq; allsimpl; proof_irr; GC.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  (* xxx *)
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lift_lsubst.
  rw @member_eq.
  rw <- @member_equality_iff.

  vr_seq_true in hyp1.
  generalize (hyp1 s1 s2); intro h.
  repeat (autodimp h hyp); exrepnd.
  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_member_iff.
  allapply @member_in_uni.
  apply tequality_in_uni_implies_tequality in h0; auto.

  generalize (teq_and_eq_if_equality lib
                (mk_pertype R) t1 t2 s1 s2 H wT w1 w2 c1 c3 c2 c4 cT cT0
                eqh sim); intro k; lsubst_tac; apply k; clear k; auto.

  clear dependent s1.
  clear dependent s2.
  introv hf sim.
  lsubst_tac.

  generalize (hyp1 s1 s2 hf sim); clear hyp1; intro hyp1; exrepnd.

  vr_seq_true in hyp2.
  generalize (hyp2 s1 s2 hf sim); clear hyp2; intro hyp2; exrepnd.

  vr_seq_true in hyp3.
  generalize (hyp3 s1 s2 hf sim); clear hyp3; intro hyp3; exrepnd.

  lsubst_tac.
  allrw @member_eq.
  allrw <- @member_member_iff.
  allrw @tequality_mkc_member_base.
  allapply @member_in_uni.
  apply tequality_in_uni_implies_tequality in hyp0; auto.
  allapply @inhabited_type_if_equality.
  rw @tequality_mkc_pertype in hyp0; repnd.
  spcast.

  rw @equality_in_mkc_pertype2; dands; auto.
  apply hyp8.
  apply @inhabited_type_cequivc with (a := mkc_apply2 (lsubstc R w0 s2 c0)
                                                     (lsubstc t1 w1 s2 ct2)
                                                     (lsubstc t2 w2 s2 cb2)); auto.
  apply implies_cequivc_apply2; sp.
  apply cequivc_sym; auto.
  apply @inhabited_type_tequality in hyp4; auto.
Qed.

(* begin hide *)

(* end hide *)

(* [15] ============ PERTYPE ELIMINATION ============ *)

(**

  We can state the pertype elimination rule as follows:
<<
   H, x : t1 = t2 in pertype(R), J |- C ext e

     By pertypeElimination i z

     H, x : t1 = t2 in pertype(R), [z : R t1 t2], J |- C ext e
     H |- R t1 t2 in Type(i)
>>
 *)

Definition rule_pertype_elimination {o}
           (R t1 t2 C e : NTerm)
           (x z : NVar)
           (i : nat)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))))
              (mk_hhyp z (mk_apply2 R t1 t2))
              ++ J)
        (mk_concl C e),
      mk_baresequent
        H
        (mk_conclax (mk_member (mk_apply2 R t1 t2) (mk_uni i)))
    ]
    [sarg_var z].

Lemma rule_pertype_elimination_true {o} :
  forall lib (R t1 t2 C e : NTerm),
  forall x z : NVar,
  forall i : nat,
  forall H J : @barehypotheses o,
    rule_true lib (rule_pertype_elimination
                 R t1 t2 C e
                 x z
                 i
                 H J).
Proof.
  unfold rule_pertype_elimination, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent
                      (snoc (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))))
                            (mk_hhyp z (mk_apply2 R t1 t2)) ++ J)
                      (mk_concl C e))
                   (inl eq_refl))
             (hyps (mk_baresequent
                      H
                      (mk_conclax (mk_member (mk_apply2 R t1 t2) (mk_uni i))))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.
  clear hyps.

  assert (covered e
                  (nh_vars_hyps
                     (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (free_vars t1)
           # !LIn x (free_vars t2)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; allrw in_snoc; sp));
    try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
    try (complete (generalize (wfh7 z); allrw in_snoc; sp));
    try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixt1 vhyps ].
  destruct vhyps as [ nixt2 vhyps ].
  destruct vhyps as [ nizc  vhyps ].
  destruct vhyps as [ nize  vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  rw @equality_in_mkc_equality in sim2; repnd.
  rw @equality_in_mkc_pertype in sim0; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim7; exrepnd.
  generalize (hyp1 ((snoc (snoc s1a0 (x, t0)) (z, t)) ++ s1b)
                   ((snoc (snoc s2a0 (x, t3)) (z, t)) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim7; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim14; simpl in sim14; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t0)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim10; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t6)) (z, t4))
         s1b
         (snoc (snoc s2a1 (x, t7)) (z, t5))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s2a1 (x, t7)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t6)) (snoc s2a1 (x, t7)) t4 t5 w3 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 s1a s2a1); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.
  generalize (hyps_functionality_init_seg_snoc lib
                s1a t6 t7 H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) w4 p1);
    simpl; intro k.
  apply k; sp.

  apply hyps_functionality_init_seg with (s3 := s2b1) in eqh; sp.
  rw @substitute_hyps_snoc_sub_weak in sim10; sp.

  rw @similarity_snoc in sim15; simpl in sim15; exrepnd; cpx.
  lsubst_tac; sp.

  rw @similarity_snoc in sim15; simpl in sim15; exrepnd; cpx.
  lsubst_tac.
  rw @tequality_mkc_member in hyp0; repnd.
  repdors.
  apply equality_in_uni in hyp4; sp.
  spcast; apply type_respects_cequivc_right; sp.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t0)) (z, t))
         s1b
         (snoc (snoc s2a0 (x, t3)) (z, t))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R t1 t2))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s1a0 (x, t0)))
         as cvap
         by (apply cover_vars_snoc_weak; rw @cover_vars_apply2; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t0)) (snoc s2a0 (x, t3)) t t wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t0) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t3) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t0) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t3) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

(* begin hide *)

Lemma rule_pertype_elimination_true_ex {o} :
  forall lib i z R t1 t2 C e x H J,
    @rule_true_if
      o lib
      (rule_pertype_elimination
         R t1 t2 C e
         x z
         i
         H J).
Proof.
  intros.
  generalize (rule_pertype_elimination_true lib R t1 t2 C e x z i H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(**

  This is a variant of [rule_pertype_elimination] but where the
  well-formedness goal is stated using a ``type'' sequent.  Also it
  allows one to use all the hypotheses:
<<
   H, x : t1 = t2 in pertype(R), J |- C ext e

     By pertypeElimination i z

     H, x : t1 = t2 in pertype(R), [z : R t1 t2], J |- C ext e
     H, x : t1 = t2 in pertype(R), J |- R t1 t2 is a type
>>
 *)

Definition rule_pertype_elimination_t {o}
           (R t1 t2 C e : NTerm)
           (x z : NVar)
           (i : nat)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))))
              (mk_hhyp z (mk_apply2 R t1 t2))
              ++ J)
        (mk_concl C e),
      mk_baresequent
        (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J)
        (mk_concl_t (mk_apply2 R t1 t2))
    ]
    [sarg_var z].

Lemma rule_pertype_elimination_t_true {o} :
  forall lib (R t1 t2 C e : NTerm),
  forall x z : NVar,
  forall i : nat,
  forall H J : @barehypotheses o,
    rule_true lib (rule_pertype_elimination_t
                 R t1 t2 C e
                 x z
                 i
                 H J).
Proof.
  unfold rule_pertype_elimination_t, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered e
                  (nh_vars_hyps
                     (snoc H (mk_hyp x (mk_equality t1 t2 (mk_pertype R))) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (free_vars t1)
           # !LIn x (free_vars t2)
           # disjoint (free_vars R) (vars_hyps J)
           # disjoint (free_vars t1) (vars_hyps J)
           # disjoint (free_vars t2) (vars_hyps J)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; repeat (first [ progress (allrw in_app_iff) | progress (allrw in_snoc) ]); sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp));
    try (complete (unfold disjoint; unfold disjoint in wfh13; introv k l; discover;
                   repeat (first [ progress (allrw in_app_iff) | progress (allrw in_snoc) ]); sp));
    try (complete (allunfold @disjoint; introv k;
                   discover; allrw in_app_iff; allrw in_snoc; sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixt1 vhyps ].
  destruct vhyps as [ nixt2 vhyps ].
  destruct vhyps as [ nizc  vhyps ].
  destruct vhyps as [ nize  vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  rw @equality_in_mkc_equality in sim2; repnd.
  rw @equality_in_mkc_pertype in sim0; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim7; exrepnd.
  generalize (hyp1 ((snoc (snoc s1a0 (x, t0)) (z, t)) ++ s1b)
                   ((snoc (snoc s2a0 (x, t3)) (z, t)) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim7; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim14; simpl in sim14; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t0)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim10; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t6)) (z, t4))
         s1b
         (snoc (snoc s2a1 (x, t7)) (z, t5))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s2a1 (x, t7)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t6)) (snoc s2a1 (x, t7)) t4 t5 wfct0 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a  (x, t6) ++ s1b)
                   (snoc s2a1 (x, t7) ++ s2b));
    clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  rw @similarity_app; simpl.
  exists (snoc s1a (x,t6)) s1b (snoc s2a1 (x,t7)) s2b; repeat (rw length_snoc); sp.
  lsubst_tac.
  auto.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t0)) (z, t))
         s1b
         (snoc (snoc s2a0 (x, t3)) (z, t))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R t1 t2))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R t1 t2) (snoc s1a0 (x, t0)))
         as cvap
         by (apply cover_vars_snoc_weak;rw @cover_vars_apply2; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t0)) (snoc s2a0 (x, t3)) t t wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t0) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t3) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t0)) (z, t) ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t0) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t3)) (z, t) ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t3) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

(* begin hide *)

Lemma rule_pertype_elimination_t_true_ex {o} :
  forall lib i z R t1 t2 C e x H J,
    rule_true_if lib (@rule_pertype_elimination_t
                    o
                    R t1 t2 C e
                    x z
                    i
                    H J).
Proof.
  intros.
  generalize (rule_pertype_elimination_t_true lib R t1 t2 C e x z i H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(* [16] ============ PERTYPE EQUALITY ============ *)

(**

  We can state the pertype equality rule as follows:
<<
   H |- pertype(R1) = pertype(R2) in Type(i)

     By pertypeMemberEquality x y z u v

     H, x : Base, y : Base |- R1 x y in Type(i)
     H, x : Base, y : Base |- R2 x y in Type(i)
     H, x : Base, y : Base, z : R1 x y |- R2 x y
     H, x : Base, y : Base, z : R2 x y |- R1 x y
     H, x : Base, y : Base, z : R1 x y |- R1 y x
     H, x : Base, y : Base, z : Base, u : R1 z y, v : R1 y z |- R1 x z
>>
 *)

Definition rule_pertype_equality {o}
           (R1 R2 e1 e2 e3 e4 : NTerm)
           (x y z u v : NVar)
           (i : nat)
           (H : @barehypotheses o) :=
  mk_rule
    (mk_baresequent H (mk_conclax (mk_equality (mk_pertype R1) (mk_pertype R2) (mk_uni i))))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x mk_base)) (mk_hyp y mk_base))
        (mk_conclax (mk_member
                       (mk_apply2 R1 (mk_var x) (mk_var y))
                       (mk_uni i))),
      mk_baresequent
        (snoc (snoc H (mk_hyp x mk_base)) (mk_hyp y mk_base))
        (mk_conclax (mk_member
                       (mk_apply2 R2 (mk_var x) (mk_var y))
                       (mk_uni i))),
      mk_baresequent
        (snoc (snoc (snoc H (mk_hyp x mk_base))
                    (mk_hyp y mk_base))
              (mk_hyp z (mk_apply2 R1 (mk_var x) (mk_var y))))
        (mk_concl (mk_apply2 R2 (mk_var x) (mk_var y)) e1),
      mk_baresequent
        (snoc (snoc (snoc H (mk_hyp x mk_base))
                    (mk_hyp y mk_base))
              (mk_hyp z (mk_apply2 R2 (mk_var x) (mk_var y))))
        (mk_concl (mk_apply2 R1 (mk_var x) (mk_var y)) e2),
      mk_baresequent
        (snoc (snoc (snoc H (mk_hyp x mk_base))
                    (mk_hyp y mk_base))
              (mk_hyp z (mk_apply2 R1 (mk_var x) (mk_var y))))
        (mk_concl (mk_apply2 R1 (mk_var y) (mk_var x)) e3),
      mk_baresequent
        (snoc (snoc (snoc (snoc (snoc H (mk_hyp x mk_base))
                                (mk_hyp y mk_base))
                          (mk_hyp z mk_base))
                    (mk_hyp u (mk_apply2 R1 (mk_var x) (mk_var y))))
              (mk_hyp v (mk_apply2 R1 (mk_var y) (mk_var z))))
        (mk_concl (mk_apply2 R1 (mk_var x) (mk_var z)) e4)
    ]
    [].

Lemma rule_pertype_equality_true {o} :
  forall lib (R1 R2 e1 e2 e3 e4 : NTerm),
  forall x y z u v : NVar,
  forall i : nat,
  forall H : @barehypotheses o,
    rule_true lib (rule_pertype_equality
                 R1 R2 e1 e2 e3 e4
                 x y z u v
                 i
                 H).
Proof.
  unfold rule_pertype_equality, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1; rename Hyp1 into hyp2; rename Hyp2 into hyp3;
  rename Hyp3 into hyp4; rename Hyp4 into hyp5; rename Hyp5 into hyp6.
  destseq; allsimpl; proof_irr; GC.

  allunfold @closed_type; allunfold @closed_extract; allsimpl.

  exists (@covered_axiom o (nh_vars_hyps H)).

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R1)
           # !LIn y (free_vars R1)
           # !LIn z (free_vars R1)
           # !LIn u (free_vars R1)
           # !LIn v (free_vars R1)
           # !LIn x (free_vars R2)
           # !LIn y (free_vars R2)
           # !LIn z (free_vars R2)
           # !LIn u (free_vars R2)
           # !LIn v (free_vars R2)
           # !LIn x (vars_hyps H)
           # !LIn y (vars_hyps H)
           # !LIn z (vars_hyps H)
           # !x = y
           # !x = z
           # !y = z) as vhyps.

  clear hyp1 hyp2 hyp3 hyp4 hyp5 hyp6.
  dwfseq.
  sp.

  destruct vhyps as [ nixr1 vhyps ].
  destruct vhyps as [ niyr1 vhyps ].
  destruct vhyps as [ nizr1 vhyps ].
  destruct vhyps as [ niur1 vhyps ].
  destruct vhyps as [ nivr1 vhyps ].
  destruct vhyps as [ nixr2 vhyps ].
  destruct vhyps as [ niyr2 vhyps ].
  destruct vhyps as [ nizr2 vhyps ].
  destruct vhyps as [ niur2 vhyps ].
  destruct vhyps as [ nivr2 vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ niyh vhyps ].
  destruct vhyps as [ nizh vhyps ].
  destruct vhyps as [ nxy vhyps ].
  destruct vhyps as [ nxz nyz ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.
  lift_lsubst.
  rw @member_eq.
  rw <- @member_equality_iff.

  generalize (teq_and_eq_if_equality
                lib (mk_uni i) (mk_pertype R1) (mk_pertype R2) s1 s2 H
                wT w1 w2 c1 c4 c2 c5 cT cT0
                eqh sim);
    intro k; repeat (autodimp k hyp); lsubst_tac; auto; try (apply tequality_mkc_uni).

  clear dependent s1; clear dependent s2.
  introv hf sim; lsubst_tac.

  assert (cover_vars R1 s2)
    as cvr12
      by (apply cover_vars_change_sub with (sub1 := s1); auto;
          allapply @similarity_dom; repnd; allrw; sp).

  assert (cover_vars R2 s1)
    as cvr21
      by (apply cover_vars_change_sub with (sub1 := s2); auto;
          allapply @similarity_dom; repnd; allrw; sp).

  assert (hyps_functionality lib s2 H)
    as hf2 by (apply @similarity_hyps_functionality_trans with (s1 := s1); auto).

  assert (similarity lib s2 s1 H) as sim2 by (apply @similarity_sym; auto).

  generalize (membership_apply2
                lib H R1 x y i s1 s2 w0 c1 cvr12
                (wfh5, (wfct5, wfce), (ct4, ce4))
                hyp1 hf sim);
    introv fty1.
  repeat (autodimp fty1 hyp).

  generalize (membership_apply2
                lib H R2 x y i s2 s1 w3 c0 cvr21
                (wfh5, (wfct4, wfce), (ct3, ce4))
                hyp2 hf2 sim2);
    introv fty2.
  repeat (autodimp fty2 hyp).

  rw @mkc_pertype_equality_in_uni; dands; auto.

  introv.
  generalize (fty1 x0 y0); intro k; repnd; auto.

  introv.
  generalize (fty2 x0 y0); intro k; repnd; auto.

  introv; split; intro inh.

  generalize (implies_inhabited_apply2
                lib H x y z x0 y0 R1 R2 i e1 s2 s2 w0 w3 cvr12 c0
                (wfh5, (wfct5, wfce), (ct4, ce4))
                (wfh3, (wfct3, wfce3), (ct2, ce2)));
    intro impinh; repeat (autodimp impinh hyp).
  apply @similarity_refl in sim2; auto.
  generalize (fty1 x0 y0); intro k; repnd.
  apply iff_inhabited_type_if_tequality_mem in k0; rw <- k0; auto.

  generalize (implies_inhabited_apply2
                lib H x y z x0 y0 R2 R1 i e2 s2 s2 w3 w0 c0 cvr12
                (wfh5, (wfct4, wfce), (ct3, ce4))
                 (wfh2, (wfct2, wfce2), (ct1, ce1)));
    intro impinh; repeat (autodimp impinh hyp).
  apply @similarity_refl in sim2; auto.
  generalize (fty1 x0 y0); intro k; repnd.
  apply iff_inhabited_type_if_tequality_mem in k0; rw k0; auto.

  unfold is_per_type; repnd; dands.

  generalize (is_sym_type
                lib R1 H i x y z e3 s1 s2 w0 c1
                (wfh5, (wfct5, wfce), (ct4, ce4))
                (wfh3, (wfct1, wfce1), (ct0, ce0))).
  intro j; repeat (autodimp j hyp).

  generalize (is_trans_type
                lib R1 H i x y z u v e4 s1 s2 w0 c1
                (wfh5, (wfct5, wfce), (ct4, ce4))
                (wfh0, (wfct0, wfce0), (ct, ce))).
  intro j; repeat (autodimp j hyp).
Qed.

(* begin hide *)

(* end hide *)

(* [20] ============ PERTYPE ELIMINATION 2 ============ *)

(**

  Let us now provide another pertype elimination rule.  This version
  is stated in terms of a pertype hypothesis and not an equality in a
  pertype:

<<
   H, x : pertype(R), J |- C ext e

     By pertypeElimination i z

     H, x : pertype(R), [z : R x x], J |- C ext e
     H, x : pertype(R) |- R x x in Type(i)
>>
 *)

Definition rule_pertype_elimination2 {o}
           (R C e : NTerm)
           (x z : NVar)
           (i : nat)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent
       (snoc H (mk_hyp x (mk_pertype R)) ++ J)
       (mk_concl C e))
    [ mk_baresequent
        (snoc (snoc H (mk_hyp x (mk_pertype R)))
              (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x)))
              ++ J)
        (mk_concl C e),
      mk_baresequent
        (snoc H (mk_hyp x (mk_pertype R)))
        (mk_conclax (mk_member
                       (mk_apply2 R (mk_var x) (mk_var x))
                       (mk_uni i)))
    ]
    [sarg_var z].

Lemma rule_pertype_elimination2_true {o} :
  forall lib (R C e : NTerm),
  forall x z : NVar,
  forall i : nat,
  forall H J : @barehypotheses o,
    rule_true lib (rule_pertype_elimination2
                 R C e
                 x z
                 i
                 H J).
Proof.
  unfold rule_pertype_elimination2, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent
                      (snoc (snoc H (mk_hyp x (mk_pertype R)))
                            (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x))) ++ J)
                      (mk_concl C e))
                   (inl eq_refl))
             (hyps (mk_baresequent
                      (snoc H (mk_hyp x (mk_pertype R)))
                      (mk_conclax (mk_member (mk_apply2 R (mk_var x) (mk_var x)) (mk_uni i))))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_pertype R)) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (vars_hyps H)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; allrw in_snoc; sp));
    try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
    try (complete (generalize (wfh6 z); allrw in_snoc; sp));
    try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ nizc vhyps ].
  destruct vhyps as [ nize vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  applydup @equality_refl in sim2 as simt1.
  rw @equality_in_mkc_pertype in sim2; repnd.
  rw @equality_in_mkc_pertype in simt1; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim0; exrepnd.
  unfold inhabited_type in simt0; destruct simt0 as [t' simt0].
  generalize (hyp1 ((snoc (snoc s1a0 (x, t1)) (z, t')) ++ s1b)
                   ((snoc (snoc s2a0 (x, t2)) (z, t')) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim12; simpl in sim12; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim8; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t4)) (z, t0))
         s1b
         (snoc (snoc s2a1 (x, t5)) (z, t3))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s2a1 (x, t5)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply @cover_vars_var);
             repeat (apply @cover_vars_snoc_weak); sp;
             repeat (rw @dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t4)) (snoc s2a1 (x, t5)) t0 t3 w0 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a (x,t4)) (snoc s2a1 (x,t5))); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.

  lsubst_tac.
  apply @tequality_in_uni_implies_tequality with (i := i); sp.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t1)) (z, t'))
         s1b
         (snoc (snoc s2a0 (x, t2)) (z, t'))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R (mk_var x) (mk_var x)))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s1a0 (x, t1)))
         as cvap
         by (rw @cover_vars_apply2; sp;
             try (complete (apply cover_vars_snoc_weak; sp));
             apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t1)) (snoc s2a0 (x, t2)) t' t' wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t1) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t2) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t1) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t2) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

(* begin hide *)

Lemma rule_pertype_elimination2_true_ex {o} :
  forall lib i z R C e x H J,
    rule_true_if lib (@rule_pertype_elimination2 o
                 R C e
                 x z
                 i
                 H J).
Proof.
  intros.
  generalize (rule_pertype_elimination2_true lib R C e x z i H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(* [21] ============ PERTYPE ELIMINATION 3 ============ *)

(**

  We state yet another pertype elimination rule.  This one is similar
  to the second one presented above but does not require us to provide
  a level for [R x x]:

<<
   H, x : pertype(R), J |- C ext e

     By pertypeElimination i z

     H, x : pertype(R), [z : R x x], J |- C ext e
     H, x : pertype(R) |- (R x x) is a type
>>
 *)

Definition rule_pertype_elimination3 {o}
           (R C e : NTerm)
           (x z : NVar)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent (snoc H (mk_hyp x (mk_pertype R)) ++ J)
                   (mk_concl C e))
    [ mk_baresequent (snoc (snoc H (mk_hyp x (mk_pertype R)))
                          (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x)))
                          ++ J)
                   (mk_concl C e),
      mk_baresequent (snoc H (mk_hyp x (mk_pertype R)))
                    (mk_concl_t (mk_apply2 R (mk_var x) (mk_var x)))
    ]
    [sarg_var z].

Lemma rule_pertype_elimination3_true {o} :
  forall lib (R C e : NTerm),
  forall x z : NVar,
  forall H J : @barehypotheses o,
    rule_true lib (rule_pertype_elimination3
                 R C e
                 x z
                 H J).
Proof.
  unfold rule_pertype_elimination3, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  generalize (hyps (mk_baresequent
                      (snoc (snoc H (mk_hyp x (mk_pertype R)))
                            (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x))) ++ J)
                      (mk_concl C e))
                   (inl eq_refl))
             (hyps (mk_baresequent
                      (snoc H (mk_hyp x (mk_pertype R)))
                      (mk_concl_t (mk_apply2 R (mk_var x) (mk_var x))))
                   (inr (inl eq_refl)));
    simpl; intros hyp1 hyp2.
  destruct hyp1 as [ ws1 hyp1 ].
  destruct hyp2 as [ ws2 hyp2 ].
  destseq; allsimpl; proof_irr; GC.

  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_pertype R)) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # !LIn x (vars_hyps H)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; allrw in_snoc; sp));
    try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
    try (complete (generalize (wfh6 z); allrw in_snoc; sp));
    try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ nizc vhyps ].
  destruct vhyps as [ nize vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  applydup @equality_refl in sim2 as simt1.
  rw @equality_in_mkc_pertype in sim2; repnd.
  rw @equality_in_mkc_pertype in simt1; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim0; exrepnd.
  unfold inhabited_type in simt0; destruct simt0 as [t' simt0].
  generalize (hyp1 ((snoc (snoc s1a0 (x, t1)) (z, t')) ++ s1b)
                   ((snoc (snoc s2a0 (x, t2)) (z, t')) ++ s2b));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_app in sim; simpl in sim; exrepnd; subst; cpx.
  apply app_split in sim0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  rw @similarity_snoc in sim12; simpl in sim12; exrepnd; subst; cpx.
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.
  rewrite substitute_hyps_snoc_sub_weak in sim8; sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  rw @eq_hyps_app; simpl.
  exists (snoc (snoc s1a (x, t4)) (z, t0))
         s1b
         (snoc (snoc s2a1 (x, t5)) (z, t3))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s2a1 (x, t5)))
         as cv
         by (apply cover_vars_apply2; sp;
             try (apply cover_vars_var);
             repeat (apply cover_vars_snoc_weak); sp;
             repeat (rw @dom_csub_snoc); simpl; repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x, t4)) (snoc s2a1 (x, t5)) t0 t3 wfct0 p0 cv;
    dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a (x,t4)) (snoc s2a1 (x,t5))); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.

  lsubst_tac; sp.

  apply sub_eq_hyps_snoc_weak; sp.

  (* similarity *)
  rw @similarity_app; simpl.
  exists (snoc (snoc s1a0 (x, t1)) (z, t'))
         s1b
         (snoc (snoc s2a0 (x, t2)) (z, t'))
         s2b; repeat (rw length_snoc); sp.

  assert (wf_term (mk_apply2 R (mk_var x) (mk_var x)))
         as wfap by (apply wf_apply2; sp).

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s1a0 (x, t1)))
         as cvap
         by (rw @cover_vars_apply2; sp;
             try (complete (apply cover_vars_snoc_weak; sp));
             apply cover_vars_var; rw @dom_csub_snoc; simpl; rw in_snoc; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x, t1)) (snoc s2a0 (x, t2)) t' t' wfap cvap; sp.

  lsubst_tac.
  rw @member_eq; sp.

  rewrite substitute_hyps_snoc_sub_weak; sp.
  (* similarity proved *)

  assert (lsubstc C wfct (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pC0
          = lsubstc C wfct (snoc s1a0 (x, t1) ++ s1b) pC1)
         as eq1
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc C wfct (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pC3
          = lsubstc C wfct (snoc s2a0 (x, t2) ++ s2b) pC2)
         as eq2
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s1a0 (x, t1)) (z, t') ++ s1b) pt0
          = lsubstc e wfce (snoc s1a0 (x, t1) ++ s1b) pt1)
         as eq3
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  assert (lsubstc e wfce (snoc (snoc s2a0 (x, t2)) (z, t') ++ s2b) pt3
          = lsubstc e wfce (snoc s2a0 (x, t2) ++ s2b) pt2)
         as eq4
         by (apply lsubstc_eq_if_csubst; apply subset_free_vars_csub_snoc_app; sp).

  rw eq1 in hyp0.
  rw eq1 in hyp1.
  rw eq2 in hyp0.
  rw eq3 in hyp1.
  rw eq4 in hyp1.
  sp.
Qed.

(* begin hide *)

Lemma rule_pertype_elimination3_true_ex {o} :
  forall lib z R C e x H J,
    rule_true_if lib (@rule_pertype_elimination3 o
                 R C e
                 x z
                 H J).
Proof.
  intros.
  generalize (rule_pertype_elimination3_true lib R C e x z H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)

(* [21] ============ PERTYPE ELIMINATION 4 ============ *)

(**

  We state yet another pertype elimination rule.  This one is similar
  to the third one presented above but [R x x] is now the last hypothesis
  in the first subgoal:

<<
   H, x : pertype(R), J |- C ext e

     By pertypeElimination i z

     H, x : pertype(R), [z : R x x], J |- C ext e
     H, x : pertype(R) |- (R x x) is a type
>>
 *)

Definition rule_pertype_elimination4 {o}
           (R C e : NTerm)
           (x z : NVar)
           (H J : @barehypotheses o) :=
  mk_rule
    (mk_baresequent (snoc H (mk_hyp x (mk_pertype R)) ++ J)
                   (mk_concl C e))
    [ mk_baresequent (snoc ((snoc H (mk_hyp x (mk_pertype R))) ++ J)
                           (mk_hhyp z (mk_apply2 R (mk_var x) (mk_var x))))
                   (mk_concl C e),
      mk_baresequent (snoc H (mk_hyp x (mk_pertype R)))
                    (mk_concl_t (mk_apply2 R (mk_var x) (mk_var x)))
    ]
    [sarg_var z].

Lemma rule_pertype_elimination4_true {o} :
  forall lib (R C e : NTerm),
  forall x z : NVar,
  forall H J : @barehypotheses o,
    rule_true lib (rule_pertype_elimination4
                 R C e
                 x z
                 H J).
Proof.
  unfold rule_pertype_elimination4, rule_true, closed_type_baresequent, closed_extract_baresequent; simpl.
  intros.
  clear cargs.

  (* We prove the well-formedness of things *)
  destseq; allsimpl.
  dLin_hyp; exrepnd.
  rename Hyp0 into hyp1.
  rename Hyp1 into hyp2.
  destseq; allsimpl; proof_irr; GC.

  assert (covered e (nh_vars_hyps (snoc H (mk_hyp x (mk_pertype R)) ++ J))) as cs.
  clear hyp1 hyp2.
  dwfseq; prove_seq; unfold covered; allrw subvars_prop; sp.

  exists cs.

  (* We prove some simple facts on our sequents *)
  assert (!LIn x (free_vars R)
           # disjoint (free_vars R) (vars_hyps J)
           # !LIn x (vars_hyps H)
           # !LIn x (vars_hyps J)
           # !LIn z (free_vars C)
           # !LIn z (free_vars e)
           # !LIn z (hyps_free_vars J)
           # !LIn z (free_vars_hyps J)
           # !LIn z (vars_hyps J)) as vhyps.

  clear hyp1 hyp2.
  dwfseq.
  sp;
    try (complete (discover; allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wg9 x); allrw remove_nvars_nil_l; allrw app_nil_r; sp));
    try (complete (generalize (wfh3 z); allrw in_snoc; sp));
    try (complete (generalize (wfh6 z); allrw in_snoc; sp));
    try (complete (generalize (cg z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (wfh z); allrw in_app_iff; allrw in_snoc; sp));
    try (complete (generalize (ce0 z); allrw @nh_vars_hyps_app; allrw @nh_vars_hyps_snoc;
                   allsimpl; allrw in_app_iff; allrw in_snoc; sp;
                   generalize (subvars_hs_vars_hyps H); intros;
                   generalize (subvars_hs_vars_hyps J); intros;
                   allrw subvars_prop; apply_in_hyp p; sp));
    try (complete (unfold disjoint; unfold disjoint in wfh11; introv k;
                   discover; auto)).

  destruct vhyps as [ nixr vhyps ].
  destruct vhyps as [ disjRJ vhyps ].
  destruct vhyps as [ nixh vhyps ].
  destruct vhyps as [ nixj vhyps ].
  destruct vhyps as [ nizc vhyps ].
  destruct vhyps as [ nize vhyps ].
  destruct vhyps as [ nizj1 vhyps ].
  destruct vhyps as [ nizj2 nizj3 ].
  (* done with proving these simple facts *)

  (* we now start proving the sequent *)
  vr_seq_true.

  rw @similarity_app in sim; exrepnd; allsimpl; subst; cpx.
  duplicate sim5 as dup_sim_snoc.
  rw @similarity_snoc in sim5; exrepnd; allsimpl; subst; cpx.
  lsubst_tac.

  applydup @equality_refl in sim2 as simt1.
  rw @equality_in_mkc_pertype in sim2; repnd.
  rw @equality_in_mkc_pertype in simt1; repnd.

  vr_seq_true in hyp1.
  unfold inhabited_type in sim0; exrepnd.
  unfold inhabited_type in simt0; destruct simt0 as [t' simt0].
  generalize (hyp1 (snoc (snoc s1a0 (x, t1) ++ s1b) (z, t'))
                   (snoc (snoc s2a0 (x, t2) ++ s2b) (z, t')));
    clear hyp1; intro hyp1.
  repeat (autodimp hyp1 hyp); exrepnd.

  (* hyps_functionality *)
  introv sim.
  rw @similarity_snoc in sim; simpl in sim; exrepnd; subst; cpx.
  rw @similarity_app in sim10; simpl in sim10; exrepnd; subst; cpx.
  apply app_split in sim0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  lsubst_tac.
  generalize (eqh (s2a1 ++ s2b0)); intro j.
  autodimp j hyp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1)) s1b0 s2a1 s2b0; repeat (rw length_snoc); sp.

  rw @eq_hyps_app in j; simpl in j; exrepnd; allrw length_snoc.
  apply app_split in j0; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).
  apply app_split in j2; repnd; subst; repeat (rw length_snoc);
  try (complete (allrw; sp)).

  duplicate j5 as dup_eqhyps_snoc.
  rw @eq_hyps_snoc in j5; simpl in j5; exrepnd; subst; cpx.
  lsubst_tac.

  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x))
                     (snoc s2a1 (x,t5) ++ s2b1))
    as cv
      by (apply cover_vars_apply2; sp;
          try (apply cover_vars_var);
          try (apply cover_vars_app_weak);
          repeat (apply cover_vars_snoc_weak); sp;
          repeat (rw @dom_csub_app); simpl;
          repeat (rw @dom_csub_snoc); simpl;
          repeat (rw in_app_iff);
          repeat (rw in_snoc); sp).

  rw @eq_hyps_snoc; simpl.
  exists (snoc s1a (x,t4) ++ s1b) (snoc s2a1 (x,t5) ++ s2b1) t0 t3
         wfct0 p0 cv; repeat (rw length_snoc); dands; try (complete sp).

  rw @eq_hyps_app; simpl.
  exists (snoc s1a (x, t4))
         s1b
         (snoc s2a1 (x, t5))
         s2b1; repeat (rw length_snoc); dands; try (complete sp).

  lsubst_tac.

  vr_seq_true in hyp2.
  generalize (hyp2 (snoc s1a (x,t4)) (snoc s2a1 (x,t5))); clear hyp2; intro hyp2.
  repeat (autodimp hyp2 hyp); exrepnd.

  apply hyps_functionality_init_seg with (s3 := s2b) in eqh; sp.

  lsubst_tac; sp.

  (* similarity *)
  assert (cover_vars (mk_apply2 R (mk_var x) (mk_var x)) (snoc s1a0 (x,t1) ++s1b))
         as cvap
           by (rw @cover_vars_apply2; sp;
               try (complete (apply cover_vars_app_weak; apply cover_vars_snoc_weak; sp));
               apply cover_vars_var; rw @dom_csub_app; rw @dom_csub_snoc; simpl; rw in_app_iff; rw in_snoc; sp).

  rw @similarity_snoc; simpl.
  exists (snoc s1a0 (x,t1) ++ s1b) (snoc s2a0 (x,t2) ++ s2b) t' t'
         wfct0 cvap; sp.

  rw @similarity_app; simpl.
  exists (snoc s1a0 (x, t1))
         s1b
         (snoc s2a0 (x, t2))
         s2b; repeat (rw length_snoc); sp.

  lsubst_tac.
  rw @member_eq; sp.
  (* similarity proved *)

  lsubst_tac.
  sp.
Qed.

(* begin hide *)

Lemma rule_pertype_elimination4_true_ex {o} :
  forall lib z R C e x H J,
    rule_true_if lib (@rule_pertype_elimination4 o
                 R C e
                 x z
                 H J).
Proof.
  intros.
  generalize (rule_pertype_elimination4_true lib R C e x z H J); intro rt.
  rw <- @rule_true_eq_ex in rt.
  unfold rule_true_ex in rt; sp.
Qed.

(* end hide *)


Require Export GeoCoq.Elements.OriginalProofs.proposition_31short.
Require Export GeoCoq.Elements.OriginalProofs.lemma_triangletoparallelogram.
Require Export GeoCoq.Elements.OriginalProofs.lemma_equaltorightisright.
Require Export GeoCoq.Elements.OriginalProofs.lemma_samenotopposite.
Require Export GeoCoq.Elements.OriginalProofs.proposition_34.
Require Export GeoCoq.Elements.OriginalProofs.lemma_PGsymmetric.
Require Export GeoCoq.Elements.OriginalProofs.lemma_PGflip.

Section Euclid.

Context `{Ax:euclidean_euclidean}.

Lemma proposition_46 :
   forall A B R,
   neq A B -> nCol A B R ->
   exists X Y, SQ A B X Y /\ TS Y A B R /\ PG A B X Y.
Proof.
intros.
assert (neq B A) by (conclude lemma_inequalitysymmetric).
let Tf:=fresh in
assert (Tf:exists F, (BetS B A F /\ Cong A F A B)) by (conclude lemma_extension);destruct Tf as [F];spliter.
assert (nCol B A R) by (forward_using lemma_NCorder).
assert (Col B A F) by (conclude_def Col ).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (Col B A B) by (conclude_def Col ).
assert (neq B F) by (forward_using lemma_betweennotequal).
assert (nCol B F R) by (conclude lemma_NChelper).
let Tf:=fresh in
assert (Tf:exists C, (Per B A C /\ TS C B F R)) by (conclude proposition_11B);destruct Tf as [C];spliter.
assert (nCol B F C) by (conclude_def TS ).
assert (Col B F A) by (forward_using lemma_collinearorder).
assert (Col B F B) by (conclude_def Col ).
assert (nCol B A C) by (conclude lemma_NChelper).
assert (neq A C) by (forward_using lemma_NCdistinct).
let Tf:=fresh in
assert (Tf:exists D, (Out A C D /\ Cong A D A B)) by (conclude lemma_layoff);destruct Tf as [D];spliter.
assert (Out A D C) by (conclude lemma_ray5).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (Col A B A) by (conclude_def Col ).
let Tf:=fresh in
assert (Tf:exists q, (BetS C q R /\ Col B F q /\ nCol B F C)) by (conclude_def TS );destruct Tf as [q];spliter.
assert (Col F B q) by (forward_using lemma_collinearorder).
assert (eq B B) by (conclude cn_equalityreflexive).
assert (nCol A B C) by (conclude lemma_NChelper).
assert (Col A B F) by (forward_using lemma_collinearorder).
assert (Col F B A) by (forward_using lemma_collinearorder).
assert (neq B F) by (forward_using lemma_betweennotequal).
assert (neq F B) by (conclude lemma_inequalitysymmetric).
assert (Col B A q) by (conclude lemma_collinear4).
assert (Col A B q) by (forward_using lemma_collinearorder).
assert (TS C A B R) by (conclude_def TS ).
assert (TS D A B R) by (conclude lemma_9_5).
assert (nCol C A B) by (forward_using lemma_NCorder).
assert (eq A A) by (conclude cn_equalityreflexive).
assert (Col C A A) by (conclude_def Col ).
assert (Col A C D) by (conclude lemma_rayimpliescollinear).
assert (Col C A D) by (forward_using lemma_collinearorder).
assert (neq A D) by (conclude lemma_ray2).
assert (nCol C A B) by (forward_using lemma_NCorder).
assert (nCol A D B) by (conclude lemma_NChelper).
assert (nCol A B D) by (forward_using lemma_NCorder).
assert (BetS F A B) by (conclude axiom_betweennesssymmetry).
assert (Col A B B) by (conclude_def Col ).
assert (nCol F B D) by (conclude lemma_NChelper).
let Tf:=fresh in
assert (Tf:exists G e M, (BetS G D e /\ CongA G D A D A B /\ Par G e F B /\ BetS G M B /\ BetS D M A)) by (conclude proposition_31short);destruct Tf as [G[e[M]]];spliter.
assert (Par G e A B) by (conclude lemma_collinearparallel).
assert (Par A B G e) by (conclude lemma_parallelsymmetric).
assert (Col G D e) by (conclude_def Col ).
assert (Col G e D) by (forward_using lemma_collinearorder).
let Tf:=fresh in
assert (Tf:exists E, (PG D E B A /\ Col G e E)) by (conclude lemma_triangletoparallelogram);destruct Tf as [E];spliter.
assert (Per C A B) by (conclude lemma_8_2).
assert (neq D A) by (conclude lemma_inequalitysymmetric).
assert (Per D A B) by (conclude lemma_collinearright).
assert (Per B A D) by (conclude lemma_8_2).
assert (Per G D A) by (conclude lemma_equaltorightisright).
let Tf:=fresh in
assert (Tf:exists p, (BetS G D p /\ Cong G D p D /\ Cong G A p A /\ neq D A)) by (conclude_def Per );destruct Tf as [p];spliter.
assert (BetS p D G) by (conclude axiom_betweennesssymmetry).
assert (Cong p D G D) by (conclude lemma_congruencesymmetric).
assert (Cong p A G A) by (conclude lemma_congruencesymmetric).
assert (Per p D A) by (conclude_def Per ).
assert (Par D A E B) by (conclude_def PG ).
assert (TP D A E B) by (conclude lemma_paralleldef2B).
assert (OS E B D A) by (conclude_def TP ).
assert (eq D D) by (conclude cn_equalityreflexive).
assert (Col D A D) by (conclude_def Col ).
assert (nCol D A B) by (forward_using lemma_NCorder).
assert (BetS B M G) by (conclude axiom_betweennesssymmetry).
assert (Col D M A) by (conclude_def Col ).
assert (Col D A M) by (forward_using lemma_collinearorder).
assert (TS B D A G) by (conclude_def TS ).
assert (TS E D A G) by (conclude lemma_planeseparation).
assert (nCol D A E) by (conclude_def TS ).
assert (TS G D A E) by (conclude lemma_oppositesidesymmetric).
assert (nCol D A G) by (conclude_def TS ).
let Tf:=fresh in
assert (Tf:exists d, (BetS E d G /\ Col D A d /\ nCol D A E)) by (conclude_def TS );destruct Tf as [d];spliter.
assert (neq E G) by (forward_using lemma_betweennotequal).
assert (neq G E) by (conclude lemma_inequalitysymmetric).
assert (neq G D) by (forward_using lemma_NCdistinct).
assert (neq D E) by (forward_using lemma_NCdistinct).
assert (~ OS E G D A).
 {
 intro.
 assert (~ TS E D A G) by (conclude lemma_samenotopposite).
 contradict.
 }
assert (~ BetS D G E).
 {
 intro.
 assert (BetS E G D) by (conclude axiom_betweennesssymmetry).
 assert (BetS E D e) by (conclude lemma_3_7a).
 assert (OS E G D A) by (conclude_def OS ).
 contradict.
 }
assert (~ BetS G E D).
 {
 intro.
 assert (BetS E D e) by (conclude lemma_3_6a).
 assert (OS E G D A) by (conclude_def OS ).
 contradict.
 }
assert (Col e G D) by (forward_using lemma_collinearorder).
assert (Col e G E) by (forward_using lemma_collinearorder).
assert (nCol G e F) by (forward_using lemma_parallelNC).
assert (neq G e) by (forward_using lemma_NCdistinct).
assert (neq e G) by (conclude lemma_inequalitysymmetric).
assert (Col G D E) by (conclude lemma_collinear4).
assert ((eq G D \/ eq G E \/ eq D E \/ BetS D G E \/ BetS G D E \/ BetS G E D)) by (conclude_def Col ).
assert (BetS G D E).
by cases on (eq G D \/ eq G E \/ eq D E \/ BetS D G E \/ BetS G D E \/ BetS G E D).
{
 assert (~ ~ BetS G D E).
  {
  intro.
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS G D E).
  {
  intro.
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS G D E).
  {
  intro.
  contradict.
  }
 close.
 }
{
 assert (~ ~ BetS G D E).
  {
  intro.
  contradict.
  }
 close.
 }
{
 close.
 }
{
 assert (~ ~ BetS G D E).
  {
  intro.
  contradict.
  }
 close.
 }
(** cases *)
assert (Col G D E) by (conclude_def Col ).
assert (neq E D) by (conclude lemma_inequalitysymmetric).
assert (Per E D A) by (conclude lemma_collinearright).
assert ((Cong D A E B /\ Cong D E A B /\ CongA E D A A B E /\ CongA D A B B E D /\ Cong_3 E D A A B E)) by (conclude proposition_34).
assert (Cong A B D E) by (conclude lemma_congruencesymmetric).
assert (Cong A B E D) by (forward_using lemma_congruenceflip).
assert (Cong A B A D) by (conclude lemma_congruencesymmetric).
assert (Cong A D E B) by (forward_using lemma_congruenceflip).
assert (Cong A B E B) by (conclude lemma_congruencetransitive).
assert (Cong A B B E) by (forward_using lemma_congruenceflip).
assert (Cong A B D A) by (forward_using lemma_congruenceflip).
assert (CongA B E D D A B) by (conclude lemma_equalanglessymmetric).
assert (CongA A B E E D A) by (conclude lemma_equalanglessymmetric).
assert (Per B E D) by (conclude lemma_equaltorightisright).
assert (Per A B E) by (conclude lemma_equaltorightisright).
assert (SQ A B E D) by (conclude_def SQ ).
assert (PG B A D E) by (conclude lemma_PGsymmetric).
assert (PG A B E D) by (conclude lemma_PGflip).
close.
Qed.

End Euclid.


(*|
=========================================
Strong and Weak Bisimulations over ctrees
=========================================
The [equ] relation provides [ctree]s with a suitable notion of equality.
It is however much too fine to properly capture any notion of behavioral
equivalence that we could want to capture over computations modelled as
[ctree]s.
If we draw a parallel with [itree]s, [equ] maps directly to [eq_itree],
while [eutt] was introduced to characterize computations that exhibit the
same external observations, but may disagree finitely on the amount of
internal steps occuring between any two observations.
While the only consideration over [itree]s was to be insensitive to the
amount of fuel needed to run, things are richer over [ctree]s.
We essentially want to capture three intuitive things:
- to be insensitive to the particular branches chosen at non-deterministic
nodes -- in particular, we want [br t u ~~ br u t];
- to always be insensitive to how many _invisible_ br nodes are crawled
through -- they really are a generalization of [Tau] in [itree]s;
- to have the flexibility to be sensible or not to the amount of _visible_
br nodes encountered -- they really are a generalization of CCS's tau
steps. This last fact, whether we observe or not these nodes, will constrain
the distinction between the weak and strong bisimulations we define.

In contrast with [equ], as well as the relations in [itree]s, we do not
define the functions generating the relations directly structurally on
the trees. Instead, we follow a definition closely following the style
developed for process calculi, essentially stating that diagrams of this
shape can be closed.
t  R  u
|     |
l     l
v     v
t' R  u'
The transition relations that we use to this end are defined in the [Trans]
module:
- strong bisimulation is defined as a symmetric games over [trans];
- weak bisimulation is defined as an asymmetric game in which [trans] get
answered by [wtrans].

.. coq::none
|*)
From Coinduction Require Import
     coinduction rel tactics.

From ITree Require Import Core.Subevent.

From CTree Require Import
     CTree
     Eq.Equ
     Eq.Shallow
     Eq.Trans
     Eq.SSim
     Eq.SBisim.

From RelationAlgebra Require Export
     rel srel monoid kat kat_tac rewriting normalisation.

Import CTree.
Import CTreeNotations.
Import EquNotations.
Import SBisimNotations.

(*|
Weak Bisimulation
-------------------
Relation relaxing [equ] to become insensible to:
- the amount of (any kind of) brs taken;
- the particular branches taken during (any kind of) brs.
|*)

Section WeakBisim.

  Context {E C : Type -> Type} {X : Type} `{HasTau : B0 -< C}.
  Notation S := (ctree E C X).

  (*|
  The function defining weak simulations: [trans] plays must be answered
  using [wtrans].
  The [ws] definition stands for [weak simulation]. The bisimulation [wb]
  is once again obtained by expliciting the symmetric aspect of the definition.
  |*)
  Program Definition ws: mon (rel S S) :=
    {| body R p q :=
      forall l p', trans l p p' -> exists2 q', wtrans l q q' & R p' q' |}.
  Next Obligation. destruct (H0 _ _ H1). eauto. Qed.

  (*| Heterogenous version TODO: make ws |*)
  Program Definition hws {E F C D: Type -> Type} {X Y: Type} `{Stuck: B0 -< C} `{Stuck': B0 -< D}
          (L: rel (@label E) (@label F)) : mon (rel (ctree E C X) (ctree F D Y)) :=
    {| body R p q :=
      forall l p', trans l p p' -> exists q' l', wtrans l' q q' /\ R p' q' /\ L l l' |}.
  Next Obligation.
    destruct (H0 _ _ H1) as (? & ? & ? & ? & ?).
    do 2 eexists; intuition; eauto.
  Qed.

  (*|
    The bisimulation is obtained by intersecting [ws] with its symmetrized version.
    |*)
  Definition wb := (Coinduction.lattice.cap ws (comp converse (comp ws converse))).

  (*| Heterogenous version TODO: make wb |*)
  Program Definition hwb {E F C D: Type -> Type} {X Y: Type} `{Stuck: B0 -< C} `{Stuck': B0 -< D}
          (L: rel (@label E) (@label F)) : mon (rel (ctree E C X) (ctree F D Y)) :=
    {| body R p q :=
      hws L R p q /\ hws (flip L) (flip R) q p
    |}.
  Next Obligation.
    split; intros.
    - destruct (H0 _ _ H2) as (? & ? & ? & ? & ?).
      do 2 eexists; intuition; eauto.
    - destruct (H1 _ _ H2) as (? & ? & ? & ? & ?).
      do 2 eexists; intuition; eauto.
  Qed.

  (*|
    The function defining one-sided expansion (standard notion in process algebra).
    This relation echoes [euttge] over [itrees]: the amount of fuel required on either
    side of the computation can only decrease from left to right, not the other way around.
    We are not interested in this relation by itself, but it is an important proof intermediate.
    |*)

  Program Definition es: mon (rel S S) :=
    {| body R p q :=
      forall l p', trans l p p' -> exists2 q', etrans l q q' & R p' q' |}.
  Next Obligation. destruct (H0 _ _ H1). eauto. Qed.

  (*| Heterogenous version TODO: make es |*)
  Program Definition hes {E F C D: Type -> Type} {X Y: Type} `{Stuck: B0 -< C} `{Stuck': B0 -< D}
          (L: rel (@label E) (@label F)) : mon (rel (ctree E C X) (ctree F D Y)) :=
    {| body R p q :=
      forall l p', trans l p p' -> exists q' l', etrans l' q q' /\ R p' q' /\ L l l' |}.
  Next Obligation.
    destruct (H0 _ _ H1) as (? & ? & ? & ? & ?).
    do 2 eexists; intuition; eauto.
  Qed.

End WeakBisim.

(*|
The relation itself
|*)
Definition wbisim {E C X} `{HasStuck : B0 -< C} := (gfp (@wb E C X _): hrel _ _).

Module WBisimNotations.

  Notation "p ≈ q" := (wbisim p q) (at level 70).
  Notation wt := (coinduction.t wb).
  Notation wT := (coinduction.T wb).
  Notation wbt := (coinduction.bt wb).
  (*|
    Notations  for easing readability in proofs by enhanced coinduction
    |*)
  Notation "x [≈] y" := (wt _ x y) (at level 80).
  Notation "x {≈} y" := (wbt _ x y) (at level 80).
  Notation "t {{≈}} u" := (wb _ t u) (at level 79).

End WBisimNotations.

Import WBisimNotations.

Ltac fold_wbisim :=
  repeat
    match goal with
    | h: context[@wb ?E ?C ?X ?HS ] |- _ => fold (@wbisim E C X HS) in h
    | |- context[@wb ?E ?C ?X ?HS ]      => fold (@wbisim E C X HS)
    end.

Ltac __coinduction_wbisim R H :=
  unfold wbisim; apply_coinduction; fold_wbisim; intros R H.

Tactic Notation "__step_wbisim" :=
  match goal with
  | |- context[@wbisim ?E ?C ?X ?HasStuck ] =>
      unfold wbisim;
      step;
      fold (@wbisim E C X HasStuck)
  | |- _ => step
  end.

#[local] Tactic Notation "step" := __step_wbisim.

#[local] Tactic Notation "coinduction" simple_intropattern(R) simple_intropattern(H) :=
  __coinduction_wbisim R H.

Ltac __step_in_wbisim H :=
  match type of H with
  | context [@wbisim ?E ?C ?X ?HasStuck ] =>
      unfold wbisim in H;
      step in H;
      fold (@wbisim E C X HasStuck) in H
  end.

#[local] Tactic Notation "step" "in" ident(H) := __step_in_wbisim H.

Ltac twplayL_ tac :=
  match goal with
  | h : @wbisim ?E ?C ?X _ _ _ |- _ =>
      step in h;
      let Hf := fresh "Hf" in
      destruct h as [Hf _];
      cbn in Hf; edestruct Hf as [? ?TR ?EQ];
      [tac | clear Hf]
  end.

Tactic Notation "twplayL" tactic(t) := twplayL_ t.
Ltac wplayL H := twplayL ltac:(apply @H).
Ltac ewplayL := twplayL etrans.

Ltac twplayR_ tac :=
  match goal with
  | h : @wbisim ?E ?F ?C ?D ?X ?Y _ _ ?L |- _ =>
      step in h;
      let Hb := fresh "Hb" in
      destruct h as [_ Hb];
      cbn in Hb; edestruct Hb as [? ?TR ?EQ];
      [tac | clear Hb]
  end.

Tactic Notation "twplayR" tactic(t) := twplayR_ t.
Ltac wplayR H := twplayR ltac:(apply @H).
Ltac ewplayR := twplayR etrans.

Section wbisim_theory.

  Context {E C : Type -> Type} {X : Type} `{HasStuck : B0 -< C}.
  Notation ws := (@ws E C X HasStuck).
  Notation wb := (@wb E C X HasStuck).
  Notation wbisim  := (@wbisim E C X HasStuck).
  Notation wt  := (coinduction.t wb).
  Notation wbt := (coinduction.bt wb).
  Notation wT  := (coinduction.T wb).

(*|
Elementary properties of [wbisim]
----------------------------------------------
We have in short:
- [ss ≤ es ≤ ws] (direct consequence of transition relations' properties)
- [sbisim] ⊆ [wbisim]
- [equ] ⊆ [wbisim]
- [wbisim] is closed under [equ]
- [wbisim] is closed under [bisim]
- up-to reflexivity
- up-to symmetry
- transitivity (but NOT up-to transitivity)

We naturally also have [equ] ⊆ [sbisim], and hence [equ] ⊆  [wbisim], but we need
to work a bit more to establish it.
It is a consequence more generally of [sbisim] and [wbisim] being closed under [equ]
on both arguments.
We also get [wbisim] closed under [sbism] on both arguments, but need first to
establish [wbisim]'s transitivity for that.
|*)
  Lemma s_e: @ss E E C C X X _ _ eq  <= es.
  Proof.
    intros R p q H l p' pp'. destruct (H _ _ pp').
    destruct H0 as (? & ? & ? & <-).
    eexists; intuition; eauto using trans_etrans_.
  Qed.

  Lemma e_w: es <= ws.
  Proof. intros R p q H l p' pp'. destruct (H _ _ pp'). eauto using etrans_wtrans_. Qed.

  Lemma s_w: ss eq <= ws.
  Proof. rewrite s_e. apply e_w. Qed.

  Corollary sbisim_wbisim: sbisim eq <= wbisim.
  Proof.
    apply gfp_leq.
    (* apply Coinduction.lattice.cap_leq. apply s_w.
    intros R p q. apply (@s_w (R°) q p).
     *)
  Admitted.

  #[global] Instance sbisim_wbisim_subrelation : subrelation (sbisim eq) wbisim.
  Proof.
    apply sbisim_wbisim.
  Qed.

(*|
Since [wt R] contains [wbisim] that contains [sbisim] which is known to be reflexive,
it is reflexive as well
|*)
    #[global] Instance Reflexive_wt R: Reflexive (wt R).
    Proof. intro. apply (gfp_t wb). now apply sbisim_wbisim. Qed.

(*|
[converse] is compatible
|*)
    Lemma converse_wt: converse <= wt.
    Proof. apply invol_t. Qed.

(*|
Hence [wt R] is always symmetric
|*)
    #[global] Instance Symmetric_wt R: Symmetric (wt R).
    Proof. intros ??. apply (ft_t converse_wt). Qed.

(*|
[wbism] is closed under [equ]
|*)
    #[global] Instance equ_wbisim_compat_goal : Proper (equ eq ==> equ eq ==> flip impl) wbisim.
    Proof.
      intros t t' eqt u u' equ; cbn.
      revert t t' u u' eqt equ.
      unfold wbisim; coinduction ? CIH; fold wbisim in *.
      intros * eqt equ eqtu.
      step in eqtu.
      destruct eqtu as [ftu btu].
      split.
      + intros ? ? ?.
        rewrite eqt in H.
        apply ftu in H as [?u' T eq].
        eexists. rewrite equ. apply T.
        eapply CIH; try reflexivity; auto.
      + intros ? ? ?.
        rewrite equ in H.
        apply btu in H as [?t' T eq].
        eexists. rewrite eqt. apply T.
        eapply CIH; try reflexivity; auto.
    Qed.

    #[global] Instance equ_wbisim_compat_ctx : Proper (equ eq ==> equ eq ==> impl) wbisim.
    Proof.
      intros t t' eqt u u' equ; cbn.
      revert t t' u u' eqt equ.
      unfold wbisim; coinduction ? CIH; fold wbisim in *.
      intros * eqt equ eqtu.
      step in eqtu.
      destruct eqtu as [ftu btu].
      split.
      + intros ? ? ?.
        rewrite <- eqt in H.
        apply ftu in H as [?u' T eq].
        eexists. rewrite <- equ. apply T.
        eapply CIH; try reflexivity; auto.
      + intros ? ? ?.
        rewrite <- equ in H.
        apply btu in H as [?t' T eq].
        eexists. rewrite <- eqt. apply T.
        eapply CIH; try reflexivity; auto.
    Qed.

(*|
Hence [equ eq] is a included in [wbisim]
|*)
    #[global] Instance equ_wbisim_subrelation : subrelation (equ eq) wbisim.
    Proof.
      red; intros.
      rewrite H; reflexivity.
    Qed.

(*|
Transitivity
~~~~~~~~~~~~
As for weak bisimulation on process algebra, [square] is not a valid
enhancing function (an explicit counter example is provided below,
see [not_square_wt]).
Weak bisimilariy is however transitive nonetheless. We can actually
reproduce directly Pous' proof for CCS, the relation between [trans] and [wtrans]
being exactly the same in both cases, even if the underlying objects
and transitions are completely different.
|*)

(*|
Moving to the [srel] world once again to establish algebaric laws based
on operators from the relation algebra library.
|*)
    #[local] Instance equ_wbisim_compat : Proper (equ eq ==> equ eq ==> iff) wbisim.
    Proof.
      split; intros.
      now rewrite <- H, <- H0.
      now rewrite H, H0.
    Qed.

    Definition wbisimT : srel SS SS :=
      {| hrel_of := wbisim : hrel SS SS |}.

(*|
Algebraic reformulation of the right-to-left part of the game

Note: We can express these laws in the setoid world or not.
Unclear if there's a benefit to either at this point, we do everything
on the setoid side.
|*)
    Lemma wbisim_trans_back l: wbisimT ⋅ trans l ≦ wtrans l ⋅ wbisimT.
    Proof.
      intros p q' [q pq qq']. apply (gfp_pfp wb) in pq as [_ pq]. now apply pq.
    Qed.
    Lemma wbisim_trans_back' l: wbisim ⋅ transR l ≦ (wtrans l : hrel _ _) ⋅ wbisim.
    Proof.
      intros p q' [q pq qq']. (*apply (gfp_pfp wb) in pq as [_ pq]. now apply pq.
    Qed.*) Admitted. (* FIXME *)
    Lemma wbisim_etrans_back l: wbisimT ⋅ etrans l ≦ wtrans l ⋅ wbisimT.
    Proof.
      unfold etrans; destruct l.
      2,3: apply @wbisim_trans_back.
      ra_normalise. rewrite wbisim_trans_back.
      unfold wtrans, etrans. ka.
    Qed.
    Lemma wbisim_taus_back: wbisimT ⋅ (trans tau)^* ≦ (trans tau)^* ⋅ wbisimT.
    Proof.
      rewrite <-str_invol at 2.
      apply str_move_l. rewrite wbisim_trans_back. unfold wtrans, etrans. ka.
    Qed.
    Lemma wbisim_wtrans_back l: wbisimT ⋅ wtrans l ≦ wtrans l ⋅ wbisimT.
    Proof.
      unfold wtrans.
      mrewrite wbisim_taus_back.
      mrewrite wbisim_etrans_back.
      mrewrite wbisim_taus_back.
      unfold wtrans, etrans. ka.
    Qed.

    Lemma cnv_wt R: (wt R: hrel _ _)° ≡ wt R.
    Proof. apply RelationAlgebra.lattice.antisym; intros ???; now apply Symmetric_wt. Qed.
    Lemma cnv_gfp: RelationAlgebra.lattice.weq ((gfp wb: hrel _ _)°) (gfp wb).
    Proof. apply cnv_wt. Qed.
    Lemma cnv_wbisim: wbisimT° ≡ wbisimT.
    Proof. apply cnv_wt. Qed.
    Lemma cnv_wbisim': wbisim° ≡ wbisim.
    Proof. apply cnv_wt. Qed.

(*|
By symmetry, similar results for left-to-right game
|*)
    Lemma wbisim_trans_front l: (trans l)° ⋅ wbisimT ≦ wbisimT ⋅ (wtrans l)°.
    Proof. cnv_switch. rewrite 2cnvdot, cnv_invol, cnv_wbisim. apply wbisim_trans_back. Qed.
    Lemma wbisim_etrans_front l: (etrans l)° ⋅ wbisimT ≦ wbisimT ⋅ (wtrans l)°.
    Proof. cnv_switch. rewrite 2cnvdot, cnv_invol, cnv_wbisim. apply wbisim_etrans_back. Qed.
    Lemma wbisim_wtrans_front l: (wtrans l)° ⋅ wbisimT ≦ wbisimT ⋅ (wtrans l)°.
    Proof. cnv_switch. rewrite 2cnvdot, cnv_invol, cnv_wbisim. apply wbisim_wtrans_back. Qed.

(*|
Explicit, non-algebraic version
|*)
    Lemma wbisim_wtrans_front_ p q l p': wtrans l p p' -> p ≈ q -> exists2 q', p' ≈ q' & @wtrans E C X _ l q q'.
    Proof. intros pp' pq. apply wbisim_wtrans_front. now exists p. Qed.

(*|
Finally, the proof of transitivity
|*)
    #[global] Instance Transitive_wbisim: Transitive wbisim.
    Proof.
      assert (square wbisim <= wbisim) as H.
      apply leq_gfp. apply symmetric_pfp.
      rewrite converse_square.
      apply square. simpl. apply cnv_gfp.
      intros x z [y xy yz] l x' xx'.
      (*apply (gfp_pfp wb) in xy as [xy _].
      destruct (xy _ _ xx') as [y' yy' x'y'].
      destruct (wbisim_wtrans_front_ _ _ _ _ yy' yz) as [z' y'z' zz'].
      exists z'. assumption. now exists y'.
      intros x y z xy yz. apply H. now exists y.
    Qed.*) Admitted.

    #[global] Instance Equivalence_wbisim: Equivalence wbisim.
    Proof.
      split; typeclasses eauto.
    Qed.

(*|
We can now easily derive that [wbisim] is closed under [sbisim]
|*)
    #[global] Instance sbisim_wbisim_closed_goal :
      Proper (sbisim eq ==> sbisim eq ==> flip impl) wbisim.
    Proof.
      repeat intro.
      now rewrite H, H0.
    Qed.

    #[global] Instance sbisim_wbisim_closed_ctx :
      Proper (sbisim eq ==> sbisim eq ==> impl) wbisim.
    Proof.
      repeat intro.
      now rewrite <- H, <- H0.
    Qed.

#[global] Opaque wtrans.

(*|
Weak bisimulation up-to [equ] is valid
|*)
    Lemma equ_clos_wt : @equ_clos E E C C X X <= wt.
    Proof.
      apply Coinduction, by_Symmetry; [apply equ_clos_sym |].
      intros R t u EQ l t1 TR; inv EQ.
      destruct HR as [F _]; cbn in *.
      rewrite Equt in TR.
      apply F in TR.
      destruct TR as [? ? ?].
      eexists.
      rewrite <- Equu; eauto.
      apply (f_Tf wb).
      econstructor; intuition.
      auto.
    Qed.

(*|
We can therefore rewrite [equ] in the middle of bisimulation proofs
|*)
    #[global] Instance equ_clos_wt_proper_goal RR :
      Proper (equ eq ==> equ eq ==> flip impl) (wt RR).
    Proof.
      cbn; unfold Proper, respectful; intros.
      apply (ft_t equ_clos_wt).
      econstructor; [eauto | | symmetry; eauto]; auto.
    Qed.

    #[global] Instance equ_clos_wt_proper_ctx RR :
      Proper (equ eq ==> equ eq ==> impl) (wt RR).
    Proof.
      cbn; unfold Proper, respectful; intros.
      apply (ft_t equ_clos_wt).
      econstructor; [symmetry; eauto | | eauto]; auto.
    Qed.

(*|
Contrary to what happens with [sbisim], weak bisimulation ignores both kinds of taus
|*)
    Lemma guard_wb `{B1 -< C} : forall (t : ctree E C X),
        Guard t ≈ t.
    Proof.
      intros. now rewrite sb_guard.
    Qed.

    Lemma step_wb `{HasTau : B1 -< C} : forall (t : ctree E C X),
        Step t ≈ t.
    Proof.
      intros t; step; split.
      - intros l t' H.
        apply trans_step_inv in H as [EQ ->].
        exists t'.
        rewrite EQ. apply wnil.
        reflexivity.
      - intros l t' H. exists t'.
        apply wtrans_step.
        apply trans_wtrans; auto.
        cbn; reflexivity.
    Qed.

(*|
Disproving the transitivity of [wt R]
-------------------------------------
|*)

    Lemma not_Transitive_wt `{HasTau : B1 -< C} Z: X -> Z -> E Z -> ~ forall R, Transitive (wt R).
    Proof.
      intros x z e H.
      cut (Vis e (fun _ => Ret x) ≈ (Ret x : ctree E C X)).
      - intros abs. step in abs; destruct abs as [abs _].
        destruct (abs (obs e z) (Ret x)) as [? step EQ].
        constructor; reflexivity.
        apply wtrans_ret_inv in step as [[abs' ?] | [abs' ?]]; inv abs'.
      - rewrite <- step_wb.
        rewrite <- (step_wb (Ret x)).
        unfold wbisim; coinduction ? CIH; fold wbisim in *.
        split.
        + intros l t' tt'.
          apply trans_step_inv in tt' as [EQ ->].
          exists (Ret x); auto.
          apply trans_wtrans; constructor; [exact tt | reflexivity].
          apply equ_wbisim_subrelation in EQ.
          rewrite EQ.
          rewrite <- (subrelation_gfp_t _ (step_wb _)).
          rewrite <- (subrelation_gfp_t _ (step_wb (Ret x))).
          assumption.  (* Here clearly some instances are missing, the rewrite do not work in the other order, and should not require such an explicit low level call *)
        + intros ? ? ?.
          apply trans_step_inv in H0 as [EQ ->].
          eexists.
          apply trans_wtrans; constructor; [exact tt | reflexivity].
          cbn.
          apply equ_wbisim_subrelation in EQ.
          rewrite <- (subrelation_gfp_t _ (step_wb _)).
          symmetry.
          rewrite EQ.
          rewrite <- (subrelation_gfp_t _ (step_wb _)).
          symmetry.
          assumption.
    Qed.

    Lemma not_square_wt `{HasTau : B1 -< C} Z: X -> Z -> E Z -> ~ square <= wt.
    Proof.
      intros x z e H. elim (not_Transitive_wt _ x z e). intro R.
      intros ? y ???. apply (ft_t H). now exists y.
    Qed.

End wbisim_theory.

Section bind.

  Obligation Tactic := idtac.
  Context {E C : Type -> Type} {X Y: Type} `{HasStuck : B0 -< C}.

(*|
Specialization of [bind_ctx] to a function acting with [sbisim] on the bound value,
and with the argument (pointwise) on the continuation.
|*)
  Program Definition bind_ctx_wbisim :  mon (rel (ctree E C Y) (ctree E C Y)) :=
    {|body := fun R => @bind_ctx E E C C X X Y Y wbisim (pointwise eq R) |}.
  Next Obligation.
    intros ???? H. apply leq_bind_ctx. intros ?? H' ?? H''.
    apply in_bind_ctx. apply H'. intros t t' HS. apply H0, H'', HS.
  Qed.

(*|
Sufficient condition to exploit symmetry
|*)
    Lemma bind_ctx_wbisim_sym: compat converse bind_ctx_wbisim.
    Proof.
      intro R. simpl. apply leq_bind_ctx. intros. apply in_bind_ctx.
      symmetry; auto.
      intros ? ? ->.
      apply H0; auto.
    Qed.

(*|
The resulting enhancing function gives a valid up-to technique
|*)
    Lemma bind_ctx_wbisim_t : bind_ctx_wbisim <= wt.
    Proof.
      apply Coinduction, by_Symmetry.
      apply bind_ctx_wbisim_sym.
      intros R. apply (leq_bind_ctx _).
      intros t1 t2 tt k1 k2 kk.
      step in tt; destruct tt as (F & B); cbn in *.
      cbn in *; intros l u STEP.
      apply trans_bind_inv in STEP as [(H & t' & STEP & EQ) | (v & STEPres & STEP)]; cbn in *.
      - apply F in STEP as [u' STEP EQ'].
        eexists.
        apply wtrans_bind_l; eauto.
        apply (fT_T equ_clos_wt).
        econstructor; [exact EQ | | reflexivity].
        apply (fTf_Tf wb).
        apply in_bind_ctx; auto.
        intros ? ? ->.
        apply (b_T wb).
        apply kk; auto.
      - clear B.
        (* Things are tricky, the bind inversion rule is messy *)
        specialize (kk v v eq_refl).
        destruct kk as [F' _].
        apply F  in STEPres as [x STEPres EQ].
        apply F' in STEP    as [u' STEP HR].
        pose proof (wtrans_val_inv' STEPres) as (? & wtr & ? & EQ').
        rewrite EQ' in STEPres.
        pose proof wtrans_bind_r _ STEPres STEP as [EQ'' | ?].
        + rewrite EQ'' in STEP.
          assert (l = tau) by admit.
          subst.
          exists (k2 v).
          admit.
          admit.
        + admit.

    Admitted.

End bind.

(*|
Expliciting the reasoning rule provided by the up-to principles.
|*)
Lemma wbisim_clo_bind (E C: Type -> Type) (X Y : Type) `(HasStuck : B0 -< C) :
	forall (t1 t2 : ctree E C X) (k1 k2 : X -> ctree E C Y) RR,
		t1 ≈ t2 ->
    (forall x, (wt RR) (k1 x) (k2 x)) ->
    wt RR (t1 >>= k1) (t2 >>= k2)
.
Proof.
  intros.
  apply (ft_t (@bind_ctx_wbisim_t E C X Y _)).
  apply in_bind_ctx; auto.
  intros ? ? <-; auto.
Qed.

(*|
And in particular, we get the proper instance justifying rewriting [~]
and [≈] to the left of a [bind].
|*)
#[global] Instance bind_wbisim_cong :
 forall (E C : Type -> Type) (X Y : Type) `{B0 -< C} (R : rel Y Y) RR,
   Proper (wbisim ==> pointwise_relation X (wt RR) ==> wt RR) (@bind E C X Y).
Proof.
  repeat red; intros; eapply wbisim_clo_bind; eauto.
Qed.

Lemma wbisim_ret_inv {E C R} `{B0 -< C} : forall (x y : R),
    Ret x ≈ (Ret y : ctree E C R) ->
    x = y.
Proof.
  intros * EQ.
   ewplayL.
  apply wtrans_case' in TR as [(?v & TR & WTR)|(?v & TR & WTR)].
  inv_trans; auto.
  inv_trans; auto.
Qed.

(*|
Note: with brD2, these relations hold up-to strong bisimulation.
With brS2 however they don't even hold up-to weak bisimulation.
|*)
(*
Lemma spinS_nary_0 : forall {E R}, @spinS_nary E R 0 ≈ spinS_nary 0.
Proof.
  intros E R.
  reflexivity.
Qed.*)

Ltac wcase :=
  match goal with
    [ h   : hrel_of (wtrans ?l) _ _,
      bis : wbisim _ _
      |- _] =>
      let EQ := fresh "EQ" in
      match l with
      | tau => apply wtrans_case' in h as [EQ|(? & ?TR & ?WTR)];
              [rewrite <- EQ in bis; clear EQ |]
      | _   => apply wtrans_case' in h as [(? & ?TR & ?WTR)|(? & ?TR & ?WTR)]
      end
  end.

#[local] Arguments trans_brS21 [_ _].
#[local] Arguments trans_brS22 [_ _].
#[local] Arguments trans_ret [_ _] _.

(*|
With brS2 however they don't even hold up-to weak bisimulation.
The proof is not interesting, but it would be good to have a
light way to automate it, so it's a decent case study.
|*)
(*
Lemma brS2_not_assoc :
	~ (brS2 (brS2 (Ret 0 : ctree Sum.void1 nat) (Ret 1)) (Ret 2) ≈ brS2 (Ret 0) (brS2 (Ret 1) (Ret 2)))%nat.
Proof.
  intros abs.

  (* init: 012 || 012 *)
  wplayL trans_brS21.

  (* PL  : 01  || 012 *)
  wcase.
  - (* AR:  01  || 012 *)
    wplayR trans_brS22.
    (* PR:  01  ||  12 *)
    wcase.
    + (* AL:  01  ||  12 *)
      wplayR trans_brS22.
      (* PR:  01  ||   2 *)
      wcase.
      * (* AL: 01  ||   2 *)
        wplayR trans_ret.
        (* PR: 01  |2?|   ∅ *)
        wcase.
        (* AL: steps with 2, abs *)
        inv_trans.
        inv_trans.
        (* PR: 0   ||   ∅ *)
        wcase; inv_trans.
        (* PR: 1   ||   ∅ *)
        wcase; inv_trans.
      * inv_trans.
        (* AL: 0  ||   2 *)
        wcase.
        apply wbisim_ret_inv in EQ; inv EQ.
        inv_trans.
        (* AL: 1  ||   2 *)
        wcase.
        apply wbisim_ret_inv in EQ; inv EQ.
        inv_trans.
    + inv_trans.
      * (* AL:  0  ||  12 *)
        wcase.
        wplayL trans_ret.
        wcase; inv_trans.
        wcase; inv_trans.
        wcase; inv_trans.
        inv_trans.
      * (* AL:  1  ||  12 *)
        wcase.
        wplayR trans_brS22.
        wcase.
        apply wbisim_ret_inv in EQ; inv EQ.
        inv_trans.
        inv_trans.
  - inv_trans.
    + wcase.
      * wplayL trans_brS22.
        wcase.
        apply wbisim_ret_inv in EQ; inv EQ.
        inv_trans.
      * inv_trans.
    + wcase.
      wplayL trans_brS21.
      wcase.
      wplayL trans_ret.
      wcase.
      inv_trans.
      inv_trans.
      wcase; inv_trans.
      wcase; inv_trans.
      inv_trans.
      wcase.
      apply wbisim_ret_inv in EQ; inv EQ.
      inv_trans.
      wcase.
      apply wbisim_ret_inv in EQ; inv EQ.
      inv_trans.
      inv_trans.
      wcase.
      wplayL trans_brS21.
      wcase.
      apply wbisim_ret_inv in EQ; inv EQ.
      inv_trans.
      inv_trans.
      wcase.
      wplayL trans_brS21.
      wcase.
      apply wbisim_ret_inv in EQ; inv EQ.
      inv_trans.
      inv_trans.
Qed.*)


Require Import Events.
Require Import TraceModel.
Require Import Properties.
Require Import CommonST.
Require Import Robustdef.
Require Import Setoid.
Require Import ClassicalExtras.
Require Import Logic.ClassicalFacts.
Require Import ZArith.
Require Import List.

Axiom L : language.

Definition ϕ_par := par L.
Definition ϕ_prg := prod nat (prg L).
Definition ϕ_ctx  := prod nat (ctx L).
Definition ϕ_plug : ϕ_par -> ϕ_ctx -> ϕ_prg :=
  fun P C =>  (fst C , plug L P (snd C)).

Lemma omega_fact : forall n m, n <= m -> (S n) <= (S m).
Proof. intros n m h. omega. Qed.

Fixpoint take_n_of_stream {A: Type} (s : stream) (n : nat) : list A :=
  match n, s with
  | 0, _  => nil
  | S m, scons a s' => cons a (take_n_of_stream s' m)
  end.

Lemma take_n_of_stream_prefix {A : Type} (s : stream) (n: nat) :
  @list_stream_prefix A (take_n_of_stream s n) s.
Proof.
  generalize dependent s. induction n; try now auto.
  intros []; simpl. now auto.
Qed.

Lemma take_n_of_stream_length {A : Type} (s: stream) (n: nat) :
  @length A (take_n_of_stream s n) <= n.
Proof.
  generalize dependent s. induction n; try now auto.
  intros []; simpl; auto. apply omega_fact. now apply IHn.
Qed.

Fixpoint take_n_of_list {A : Type} (l : list A) (n : nat) : list A :=
  match n, l with
  | 0, _ | _, nil => nil
  | S m, cons x xs => cons x (take_n_of_list xs m)
  end.

Lemma take_n_of_list_prefix {A : Type} (l : list A) (n : nat) :
  list_list_prefix (take_n_of_list l n) l.
Proof.
  generalize dependent l. induction n; try now auto;
  intros []; simpl; try now auto.
Qed.

Lemma take_n_of_list_length {A : Type} (l : list A) (n : nat) :
  length (take_n_of_list l n) <= n.
Proof.
  generalize dependent l. induction n; try now auto.
  intros []; simpl; auto.
  intros []; simpl; auto.
  omega. apply omega_fact. now apply IHn.
Qed.

Definition take_n (t : trace) (n : nat) : list event :=
  match t with
  | tstop l _ | tsilent l => take_n_of_list l n
  | tstream s             => take_n_of_stream s n
  end.

Lemma take_n_prefix (t : trace) (n: nat) :
  prefix (ftbd (take_n t n)) t.
Proof.
  destruct t;
    [ now apply take_n_of_list_prefix
    | now apply take_n_of_list_prefix
    | now apply take_n_of_stream_prefix].
Qed.

Lemma take_n_lenght (t : trace) (n : nat): length (take_n t n) <= n.
Proof.
  destruct t;
    [ now apply take_n_of_list_length
    | now apply take_n_of_list_length
    | now apply take_n_of_stream_length].
Qed.

Lemma list_list_prefix_shorter {A : Type} : forall l1 l2 : list A,
  list_list_prefix l1 l2 -> length l1 <= length l2.
Proof.
  induction l1; intros l2 Hpref.
  + simpl. omega.
  + destruct l2; inversion Hpref; subst. simpl.
    apply omega_fact. now apply IHl1.
Qed.

Definition ϕ_sem : ϕ_prg -> prop :=
  fun P =>
  (fun t : trace =>
     exists l es, t = tstop l es  /\ psem (snd P) (ftbd l) /\ length l <= (fst P)).

Lemma non_empty_ϕ : forall P, exists t, ϕ_sem P t.
Proof.
  intros [n Pl].
  destruct (non_empty_sem L Pl) as [t HsemL].
  exists (tstop (take_n t n) an_endstate). unfold ϕ_sem.
  exists (take_n t n), an_endstate. simpl. repeat (split; try now auto).
  exists t. split; try now auto.
  + now apply take_n_prefix.
  + now apply take_n_lenght.
Qed.

Lemma leq_trans : forall n1 n2 n3, n1 <= n2 -> n2 <= n3 -> n1 <= n3.
Proof. intros n1 n2 n3 h1 h2. omega. Qed.

(* intuition there in t in sem longer than m *)
Lemma psem_consequence : forall C P t l,
    ϕ_sem (ϕ_plug P C) t ->
    prefix (ftbd l) t ->
    length l <= fst C.
Proof.
  intros [n C] P t m [mm [es [hem [h1 h2]]]] hpref. subst.
  simpl in *. apply (leq_trans (length m) (length mm) n); auto.
  now apply list_list_prefix_shorter.
Qed.

Definition ϕ := Build_language ϕ_plug
                            ϕ_sem
                            non_empty_ϕ.

(**********************************************************)
(* RSP =/=> RTP                                           *)
(**********************************************************)

Definition c : par ϕ -> par L :=
  fun P => P.

Definition c_RPP (P : par ϕ) (π : prop) : Prop :=
  rsat P π -> rsat (c P) π.

Lemma C_robustly_safety : forall P S, Safety S -> c_RPP P S.
Proof.
  intros P S Hsafety. unfold c_RPP. rewrite contra.
  unfold rsat. repeat rewrite not_forall_ex_not.
  intros [C hC]. unfold sat in *. rewrite not_forall_ex_not in *.
  destruct hC as [t hh]. rewrite not_imp in hh.
  destruct hh as [h1 h2]. destruct (Hsafety t h2) as [m [hpref hwit]].
  destruct m.
  + exists (length l, C). intros ff. simpl in ff.
    destruct t; inversion hpref; subst.
    apply (hwit (tstop l0 e)); auto.
    apply ff. unfold ϕ_sem, ϕ_plug; simpl.
    exists l0, e. repeat (split; try now auto).
    exists (tstop l0 e). split; auto. simpl. now apply list_list_prefix_ref.
  + exists (length l, C). intros ff. simpl in ff.
    apply (hwit (tstop l an_endstate)); auto.
    simpl. now apply list_list_prefix_ref.
    apply ff. unfold ϕ_sem, ϕ_plug; simpl.
    exists l, an_endstate. repeat (split; try now auto).
    now exists t.
Qed.

(*
  WHILE true
   an_envet;
  END.
 *)
Definition an_omega := constant_stream (an_event).
Definition another_omega := constant_stream (another_event).

Hypothesis an_omega_produced : exists P, forall C, sem L (plug L P C) (tstream an_omega).
Hypothesis another_omega_produced : exists P, forall C, sem L (plug L P C) (tstream another_omega).

Lemma not_equal: ~ stream_eq an_omega another_omega.
Proof.
  rewrite stream_eq_finetely_refutable.
  exists nil, an_event, another_event.
  repeat (split; try now auto).
  now apply different_events.
Qed.

Definition my_pi :=
  fun t =>
    match t with
    | tstream s  => stream_eq s an_omega
    | _ => True
    end.

Lemma my_pi_dense : Dense my_pi.
Proof.
  intros t Hfin. destruct t; now inversion Hfin.
Qed.

Lemma another_omega_not_in_my_pi : ~ my_pi (tstream another_omega).
Proof.
 simpl. intros H.  apply stream_eq_sym in H. now apply not_equal.
Qed.

Lemma cut_lemma : forall C P t, sem ϕ (plug ϕ P C) t -> fin t.
Proof.
  intros C P t H. simpl in*.
  unfold ϕ_sem, ϕ_plug in *. destruct H as [m [es [hp H]]].
  now rewrite hp.
Qed.

Axiom some_ctx_L : ctx L.

Theorem separation_RSP_RDP :
  (forall P π, Safety π -> c_RPP P π) /\
  ~  (forall P π, Dense π -> c_RPP P π).
Proof.
  split.
  + now apply C_robustly_safety.
  + intros ff. destruct another_omega_produced as [P H].
    specialize (ff P my_pi). unfold c_RPP, rsat, sat in ff.
    simpl in ff.
    assert (hh :  (forall (C : ctx ϕ) (t : trace), sem ϕ (ϕ_plug P C) t -> my_pi t)).
    { intros C t H0. simpl in H0. unfold ϕ_sem, ϕ_plug in H0.
      destruct H0 as [m [e [hm H0]]]. now rewrite hm. }
    specialize (ff my_pi_dense hh).  specialize (ff some_ctx_L (tstream another_omega)).
    assert (sem L (some_ctx_L [P]) (tstream another_omega)) by now apply (H some_ctx_L).
    specialize (ff H0). now apply another_omega_not_in_my_pi.
Qed.

Theorem separation_RSP_RTP : (forall P π, Safety π -> c_RPP P π) /\ ~  (forall P π, c_RPP P π).
Proof.
  split.
  + now apply C_robustly_safety.
  + intros ff. destruct another_omega_produced as [P H].
    destruct separation_RSP_RDP as [K1 K2].
    now apply K2.
Qed.

(**********************************************************)
(* RDP =/=> RTP                                           *)
(**********************************************************)

Hypothesis only_an_omega_produced : exists P, forall C,
      (sem L (plug L P C) (tstream an_omega) /\
       (forall t, sem L (plug L P C) t ->
         (exists s, t = tstream s /\ stream_eq s an_omega))).

Definition c2 : par L -> par ϕ :=
  fun P => P.

Definition c2_RPP (P : par L) (π : prop) : Prop :=
  rsat P π -> rsat (c2 P) π.

Lemma c2_robustly_dense: forall P π, Dense π -> c2_RPP P π.
Proof.
  intros P π hl. unfold c2_RPP, rsat, sat.
  intros h0 [n C] t hsem.
  simpl in hsem.
  unfold ϕ_sem, ϕ_plug in hsem.
  destruct hsem as [l [es [hembed [hpsem hlen]]]].
  subst. now apply hl.
Qed.

Definition my_pi2 : prop :=
  fun t =>
    match t with
    | tstream s => stream_eq s an_omega
    | _ => False
    end.

Theorem separation_RDP_RTP :
  (forall P π, Dense π -> c2_RPP P π) /\
  ~  (forall P π, c2_RPP P π).
Proof.
  split.
  + now apply c2_robustly_dense.
  + intros ff. destruct only_an_omega_produced as [P h].
    specialize (ff P my_pi2).
    unfold c2_RPP, rsat, sat in ff.
    assert (H : forall (C : ctx L) (t : trace), sem L (C [P]) t -> my_pi2 t).
    { intros C t hsem. specialize (h C). destruct h as [h1 h2].
      destruct (h2 t hsem) as [s [H1 H2]]; now subst. }
    specialize (ff H (0, some_ctx_L) (tstop nil an_endstate)).
    assert  (sem ϕ ((0, some_ctx_L) [c2 P]) (tstop nil an_endstate)).
    { simpl. unfold ϕ_sem, ϕ_plug. exists nil, an_endstate.
      repeat (split; try now auto). simpl.
      exists (tstream an_omega).
      split; try now auto. now apply (h some_ctx_L). }
    specialize (ff H0). inversion ff.
Qed.

Require Import TopologyTrace.

Lemma RDP_plus_RSP_RTP :
  (forall P π, Dense π -> c2_RPP P π) ->
  (forall P π, Safety π -> c2_RPP P π) ->
  (forall P π, c2_RPP P π).
Proof.
  intros h1 h2 P π. destruct (decomposition_safety_dense π) as
      [s [l [hs [hl h]]]]. unfold c2_RPP, rsat, sat in *.
  intros hh C t hsem. rewrite (h t).
  assert (hhs : forall C t, sem L (C [P]) t -> s t) by now firstorder.
  assert (hhl : forall C t, sem L (C [P]) t -> l t) by now firstorder.
  split.
  + now apply (h2 P s hs hhs C t hsem).
  + now apply (h1 P l hl hhl C t hsem).
Qed.

Corollary separation_RLP_RSP :
   (forall P π, Dense π -> c2_RPP P π) /\
   ~  (forall P π, Safety π ->  c2_RPP P π).
Proof.
  split.
  + now apply c2_robustly_dense.
  + intros ff.
    assert (forall P π, c2_RPP P π).
    { apply RDP_plus_RSP_RTP. now apply c2_robustly_dense. auto. }
    destruct separation_RDP_RTP as [K1 K2]. now auto.
Qed.