From NP Require Export equality.Context equality.Bisimulation equality.WeakBisimulation.

Definition obscongruent (R:LTS) (s t : states R) := forall (a:action),
           prod
               (forall s':states R, istrans R s a s' -> {t':states R & prod (isatrans R t a t') (weakbisimilar R s' t') })
               (forall t':states R, istrans R t a t' -> {s':states R & prod (isatrans R s a s') (weakbisimilar R s' t') }).

Section Comparsion.

Lemma bisim_obscong (R:LTS) (s t : states R) : bisimilar R s t -> obscongruent R s t.
Proof.
intros [p [pst bp]]. intros a. destruct (bp s t a pst) as [HL HR]. split.
* intros s' ss'. destruct (HL s' ss') as [t' [tt' ps't']]. exists t'. split. apply weakena. easy. exists p. split. easy. apply bsm_weakbsm. easy.
* intros t' tt'. destruct (HR t' tt') as [s' [ss' ps't']]. exists s'. split. apply weakena. easy. exists p. split. easy. apply bsm_weakbsm. easy.
Defined.

Definition bisimType (R:LTS) (s t k l :states R) (o:obscongruent R s t): Type.
Proof.
refine (sum _ _).
* refine {r1 : states R & {a:action & {kar1 : istrans R s a r1 & _ }}}.
  destruct (o a) as [HHL HHR]. destruct (HHL r1 kar1) as [r1' [tr1' [p pt]]]. exact (p k l).
* refine {r1 : states R & {a:action & {kar1 : istrans R t a r1 & _ }}}.
  destruct (o a) as [HHL HHR]. destruct (HHR r1 kar1) as [r1' [tr1' [p pt]]]. exact (p k l).
Defined.

Lemma obscong_weakbisim (R:LTS) (s t : states R) : obscongruent R s t -> weakbisimilar R s t.
Proof.
intros H. exists (fun k l => sum (prod (k=s) (l=t)) (bisimType R s t k l H)). split.
* left. now split.
* apply weakbisim_strongattacker. intros k l a [[sk tl]|kl]; destruct (H a) as [HL HR]; split.
  - intros s' ss'. destruct (H a) as [HHL HHR] eqn:HH. rewrite sk in ss'. destruct (HHL s' ss') as [r1' [kq [p1 [wp1l wp1r]]]] eqn:HHLe. exists r1'. split. apply aweaken. congruence. right. unfold bisimType. left. exists s', a. rewrite HH. exists ss'. rewrite HHLe. easy.
  - intros t' tt'. destruct (H a) as [HHL HHR] eqn:HH. rewrite tl in tt'. destruct (HHR t' tt') as [r1' [kq [p1 [wp1l wp1r]]]] eqn:HHRe. exists r1'. split. apply aweaken. congruence. right. right. exists t', a, tt'. rewrite HH. cbn. rewrite HHRe. easy.
  - intros s' ks'. destruct kl as [[rl [al [trl pl]]]|[rl [al [trl pl]]]].
    + destruct (H al) as [HHL HHR] eqn:HH. cbn in pl. destruct (HHL rl trl) as [r1' [p0l [p [prlk1 wbp]]]] eqn:HHLe. destruct (wbp k l a) as [HbL HbR]. easy. destruct (HbL s') as [t' [lt' ps't']]. now apply weaken. exists t'. split. easy. right. left. exists rl, al, trl. rewrite HH. cbn. rewrite HHLe. easy.
    + destruct (H al) as [HHL HHR] eqn:HH. cbn in pl. destruct (HHR rl trl) as [r1' [p0l [p [prlk1 wbp]]]] eqn:HHLe. destruct (wbp k l a) as [HbL HbR]. easy. destruct (HbL s') as [t' [lt' ps't']]. now apply weaken. exists t'. split. easy. right. right. exists rl, al, trl. rewrite HH. cbn. rewrite HHLe. easy.
  - intros s' ks'. destruct kl as [[rl [al [trl pl]]]|[rl [al [trl pl]]]].
    + destruct (H al) as [HHL HHR] eqn:HH. cbn in pl. destruct (HHL rl trl) as [r1' [p0l [p [prlk1 wbp]]]] eqn:HHLe. destruct (wbp k l a) as [HbL HbR]. easy. destruct (HbR s') as [t' [lt' ps't']]. now apply weaken. exists t'. split. easy. right. left. exists rl, al, trl. rewrite HH. cbn. rewrite HHLe. easy.
    + destruct (H al) as [HHL HHR] eqn:HH. cbn in pl. destruct (HHR rl trl) as [r1' [p0l [p [prlk1 wbp]]]] eqn:HHLe. destruct (wbp k l a) as [HbL HbR]. easy. destruct (HbR s') as [t' [lt' ps't']]. now apply weaken. exists t'. split. easy. right. right. exists rl, al, trl. rewrite HH. cbn. rewrite HHLe. easy.
Defined.

End Comparsion.

Section Equivalence.

Lemma obscong_refl (R:LTS) (s:states R) : obscongruent R s s.
Proof.
intros a. split.
* intros s' ss'%weakena. exists s'. split. easy. apply wbisim_refl.
* intros t' tt'%weakena. exists t'. split. easy. apply wbisim_refl.
Defined.

Lemma obscong_symm (R:LTS) (s t : states R) : obscongruent R s t -> obscongruent R t s.
Proof.
intros op a. destruct (op a) as [oL oR]. split.
* intros s' ts'. destruct (oR s' ts') as [t' [st' s't']]. exists t'. split. easy. now apply wbisim_symm.
* intros t' st'. destruct (oL t' st') as [s' [ts' s't']]. exists s'. split. easy. now apply wbisim_symm.
Defined.

Lemma watrans_obscong_replay (R:LTS) (s t u : states R) (a:action) : obscongruent R s t -> isatrans R s a u -> {v:states R & prod (isatrans R t a v) (weakbisimilar R u v)}.
Proof.
intros H r1r2a. destruct (H a) as [HL HR]. destruct a.
* destruct r1r2a as [r1 [r2 [[[n pn] r1r2] r2u]]]. destruct n as [|n].
  - rewrite <- pn in r1r2. destruct (HL r2 r1r2) as [v [tv [p [pr2v bp]]]]. destruct (bp r2 v Tau pr2v) as [HpL HpR]. destruct (HpL u r2u) as [vv [vvv uvv]]. exists vv. split. apply at_lengthen with t v. now exists 0. easy. easy. exists p. now split.
  - destruct pn as [r [sr pn]]. destruct (HL r sr) as [r' [tr' [p [prr' wbp]]]]. destruct (wbp r r' Tau prr') as [HpL HpR]. destruct (HpL u) as [v [r'v puv]]. apply tt_merge with r2. apply tt_merge with r1. exists n. easy. exists 1. exists r2. split. easy. easy. easy. exists v. split. apply at_lengthen with t r'. now exists 0. easy. easy. exists p. split. easy. easy.
* apply obscong_weakbisim in H. apply aweaken in r1r2a. destruct H as [p [pst wbp]]. destruct (wbp s t (Snd n) pst) as [HLL HRR]. destruct (HLL u r1r2a) as [v [tv uv]]. exists v. split. easy. exists p. now split.
* apply obscong_weakbisim in H. apply aweaken in r1r2a. destruct H as [p [pst wbp]]. destruct (wbp s t (Rcv n) pst) as [HLL HRR]. destruct (HLL u r1r2a) as [v [tv uv]]. exists v. split. easy. exists p. now split.
Defined.

Lemma obscong_trans (R:LTS) (s t r : states R) : obscongruent R s t -> obscongruent R t r -> obscongruent R s r.
Proof.
intros H1 H2 a. destruct (H1 a) as [H1L H1R]. destruct (H2 a) as [H2L H2R]. split.
* intros s' ss'. destruct (H1L s' ss') as [t' [tt' s't']]. destruct (watrans_obscong_replay R t r t' a) as [r' [rr' bsr]]. easy. easy. exists r'. split. easy. apply wbisim_trans with t'. easy. easy.
* intros r' rr'. destruct (H2R r' rr') as [t' [tt' t'r']]. destruct (watrans_obscong_replay R t s t' a) as [s' [ss' bss]]. apply obscong_symm. easy. easy. exists s'. split. easy. apply wbisim_trans with t'. apply wbisim_symm. easy. easy.
Defined.

End Equivalence.

Section Congruence.

Variable G : nat -> CCS.
Variable s0 : CCS.

Lemma obscong_prefix (r r' :CCS) (a:action) : obscongruent (CCSLTS G s0) r r' -> obscongruent (CCSLTS G s0) (Prefix a r) (Prefix a r').
Proof.
intros oc b. split.
* intros k' H. cbn in H. inversion H. exists r'. split. apply weakena, tPrefix. apply obscong_weakbisim. rewrite <- H3. easy.
* intros l' H. cbn in H. inversion H. exists r.  split. apply weakena, tPrefix. apply obscong_weakbisim. rewrite <- H3. easy.
Defined.

Lemma obscong_choice_l (r s r': CCS) : obscongruent (CCSLTS G s0) r r' -> obscongruent (CCSLTS G s0) (Choice r s) (Choice r' s).
Proof.
intros oc a. split.
* intros k' H. cbn in H. inversion H.
  + destruct (oc a) as [HL _]. destruct (HL k' X) as [l' [r'l' k'l']]. exists l'. split.
    - destruct r'l' as [s1 [s2 [[[[|n] HH] s1s2] s2l']]].
      ++ exists (Choice r' s), s2. split. split. now exists 0. apply tChoiceL. rewrite <- HH in s1s2. exact s1s2. easy.
      ++ destruct HH as [s1' [HHL HHR]]. exists s1, s2. split. split. exists (S n). exists s1'. split. apply tChoiceL. easy. easy. easy. easy.
    - easy.
  + exists k'. split. apply weakena, tChoiceR. easy. apply wbisim_refl.
* intros l' H. cbn in H. inversion H.
  + destruct (oc a) as [_ HR]. destruct (HR l' X) as [k' [rk' k'l']]. exists k'. split.
    - destruct rk' as [s1 [s2 [[[[|n] HH] s1s2] s2k']]].
      ++ exists (Choice r s), s2. split. split. now exists 0. apply tChoiceL. rewrite <- HH in s1s2. exact s1s2. easy.
      ++ destruct HH as [s1' [HHL HHR]]. exists s1, s2. split. split. exists (S n). exists s1'. split. apply tChoiceL. easy. easy. easy. easy.
    - easy.
  + exists l'. split. apply weakena, tChoiceR. easy. apply wbisim_refl.
Defined.

Lemma obscong_choice_r (r s s': CCS) : obscongruent (CCSLTS G s0) s s' -> obscongruent (CCSLTS G s0) (Choice r s) (Choice r s').
Proof.
intros oc a. split.
* intros k' H. cbn in H. inversion H.
  + exists k'. split. apply weakena, tChoiceL. easy. apply wbisim_refl.
  + destruct (oc a) as [HL _]. destruct (HL k' X) as [l' [s'l' k'l']]. exists l'. split.
    - destruct s'l' as [s1 [s2 [[[[|n] HH] s1s2] s2l']]].
      ++ exists (Choice r s'), s2. split. split. now exists 0. apply tChoiceR. rewrite <- HH in s1s2. exact s1s2. easy.
      ++ destruct HH as [s1' [HHL HHR]]. exists s1, s2. split. split. exists (S n). exists s1'. split. apply tChoiceR. easy. easy. easy. easy.
    - easy.
* intros l' H. cbn in H. inversion H.
  + exists l'. split. apply weakena, tChoiceL. easy. apply wbisim_refl.
  + destruct (oc a) as [_ HR]. destruct (HR l' X) as [k' [sk' k'l']]. exists k'. split.
    - destruct sk' as [s1 [s2 [[[[|n] HH] s1s2] s2k']]].
      ++ exists (Choice r s), s2. split. split. now exists 0. apply tChoiceR. rewrite <- HH in s1s2. exact s1s2. easy.
      ++ destruct HH as [s1' [HHL HHR]]. exists s1, s2. split. split. exists (S n). exists s1'. split. apply tChoiceR. easy. easy. easy. easy.
    - easy.
Defined.

Lemma obscong_par_l (r s r': CCS) : obscongruent (CCSLTS G s0) r r' -> obscongruent (CCSLTS G s0) (Par r s) (Par r' s).
Proof.
intros oc a. split.
* intros k' H. cbn in H. inversion H.
  + destruct (oc a) as [HL _]. destruct (HL P' X) as [l' [r'l' P'l']]. exists (Par l' s). split.
    - destruct r'l' as [s1 [s2 [[s's1 s1s2] s2l']]]. exists (Par s1 s), (Par s2 s). split. split. now apply ttrans_par_l_transport. now apply tParL. now apply ttrans_par_l_transport.
    - now apply wbisim_cong_par_l.
  + exists (Par r' Q'). split. apply weakena, tParR. easy. apply wbisim_cong_par_l. apply obscong_weakbisim. easy.
  + destruct (oc a0) as [HL _]. destruct (HL P' X) as [l' [r'l' P'l']]. exists (Par l' Q'). split. apply wtrans_par_syncl_transport with a0. apply aweaken. easy. easy. easy. now apply wbisim_cong_par_l.
* intros l' H. cbn in H. inversion H.
  + destruct (oc a) as [_ HR]. destruct (HR P' X) as [rr' [rr'l' P'rr']]. exists (Par rr' s). split.
    - destruct rr'l' as [s1 [s2 [[rr's1 s1s2] s2l']]]. exists (Par s1 s), (Par s2 s). split. split. now apply ttrans_par_l_transport. now apply tParL. now apply ttrans_par_l_transport.
    - now apply wbisim_cong_par_l.
  + exists (Par r Q'). split. apply weakena, tParR. easy. apply wbisim_cong_par_l. apply obscong_weakbisim. easy.
  + destruct (oc a0) as [_ HR]. destruct (HR P' X) as [rr' [rr'l' P'rr']]. exists (Par rr' Q'). split. apply wtrans_par_syncl_transport with a0. apply aweaken. easy. easy. easy. now apply wbisim_cong_par_l.
Defined.

Lemma obscong_par_r (r s r': CCS) : obscongruent (CCSLTS G s0) r r' -> obscongruent (CCSLTS G s0) (Par s r) (Par s r').
Proof.
intros oc a. split.
* intros k' H. cbn in H. inversion H.
  + exists (Par P' r'). split. apply weakena, tParL. easy. apply wbisim_cong_par_r. apply obscong_weakbisim. easy.
  + destruct (oc a) as [HL _]. destruct (HL Q' X) as [l' [r'l' P'l']]. exists (Par s l'). split.
    - destruct r'l' as [s1 [s2 [[s's1 s1s2] s2l']]]. exists (Par s s1), (Par s s2). split. split. now apply ttrans_par_r_transport. now apply tParR. now apply ttrans_par_r_transport.
    - now apply wbisim_cong_par_r.
  + destruct (oc (invAction a0)) as [HL _]. destruct (HL Q' X0) as [l' [r'l' P'l']]. exists (Par P' l'). split. apply wtrans_par_syncr_transport with a0. easy. easy. apply aweaken. easy. now apply wbisim_cong_par_r.
* intros l' H. cbn in H. inversion H.
  + exists (Par P' r). split. apply weakena, tParL. easy. apply wbisim_cong_par_r. apply obscong_weakbisim. easy.
  + destruct (oc a) as [_ HR]. destruct (HR Q' X) as [rr' [rr'l' P'rr']]. exists (Par s rr'). split.
    - destruct rr'l' as [s1 [s2 [[rr's1 s1s2] s2l']]]. exists (Par s s1), (Par s s2). split. split. now apply ttrans_par_r_transport. now apply tParR. now apply ttrans_par_r_transport.
    - now apply wbisim_cong_par_r.
  + destruct (oc (invAction a0)) as [_ HR]. destruct (HR Q' X0) as [rr' [rr'l' P'rr']]. exists (Par P' rr'). split. apply wtrans_par_syncr_transport with a0. easy. easy. apply aweaken. easy. now apply wbisim_cong_par_r.
Defined.

Lemma atrans_restrict_transport (s s': CCS) (a:action) (H:actionFilter) : admits H a -> isatrans (CCSLTS G s0) s a s' -> isatrans (CCSLTS G s0) (Restrict s H) a (Restrict s' H).
Proof.
intros aH [s1 [s2 [[ss1 s1s2] s2s']]]. exists (Restrict s1 H), (Restrict s2 H). split. split. 1, 3: now apply ttrans_restrict_transport. now apply tRes.
Defined.

Lemma obscong_restrict (r r': CCS) (H:actionFilter) : obscongruent (CCSLTS G s0) r r' -> obscongruent (CCSLTS G s0) (Restrict r H) (Restrict r' H).
Proof.
intros oc a. split.
* intros k' HH. cbn in HH. inversion HH.
  + destruct (oc a) as [HL _]. destruct (HL P' X0) as [l' [r'l' P'l']]. exists (Restrict l' H). split.
    - apply atrans_restrict_transport. easy. easy.
    - now apply wbisim_cong_restrict.
* intros l' HH. cbn in HH. inversion HH.
  + destruct (oc a) as [_ HR]. destruct (HR P' X0) as [rr' [rr'l' P'rr']]. exists (Restrict rr' H). split.
    - apply atrans_restrict_transport. easy. easy.
    - now apply wbisim_cong_restrict.
Defined.

Lemma obscong_cong : congruence (obscongruent (CCSLTS G s0)).
Proof.
intros p q c b. induction c as [|a c IH|c IH r|l c IH|c IH r|l c IH|c IH H].
* easy.
* now apply obscong_prefix.
* now apply obscong_choice_l.
* now apply obscong_choice_r.
* now apply obscong_par_l.
* now apply obscong_par_r.
* now apply obscong_restrict.
Defined.

Section ContextualWeakBisimilarity.

Definition cwb (k l : CCS) := forall c : Context, weakbisimilar (CCSLTS G s0) (emplaceC c k) (emplaceC c l).

Lemma cwb_wbisim (k l : CCS) : cwb k l -> weakbisimilar (CCSLTS G s0) k l.
Proof.
intros H. pose proof (H CTrivial) as HH. cbn in HH. easy.
Defined.

Lemma cwb_cong : congruence cwb.
Proof.
intros k l c H c'. rewrite ! emplace_eq. apply H.
Defined.

Lemma cwb_coarsest (R' : CCS -> CCS -> Type) : congruence R' -> (forall k l, R' k l -> weakbisimilar (CCSLTS G s0) k l) -> (forall k l, R' k l -> cwb k l).
Proof.
intros cR' R'wb k l Rkl c. apply R'wb, (cR' k l c Rkl).
Defined.

Lemma obscong_cwb (k l : CCS) : obscongruent (CCSLTS G s0) k l -> cwb k l.
Proof.
apply cwb_coarsest. apply obscong_cong. intros k1 s1. apply obscong_weakbisim.
Defined.

Section ChoiceCongruence. (*It's not actually provable that this is a congruence *)
Definition ccg (k l : CCS) := forall R:CCS, weakbisimilar (CCSLTS G s0) (Choice k R) (Choice l R).

Lemma ccg_weakbisim (k l : CCS) : ccg k l -> weakbisimilar (CCSLTS G s0) k l.
Proof.
intros cc. specialize (cc Stop).
apply wbisim_trans with (Choice k Stop).
apply bisim_wbisim, bisim_symm, bisim_choice_stop.
apply wbisim_trans with (Choice l Stop).
easy.
apply bisim_wbisim, bisim_choice_stop.
Defined.

Lemma ccg_cong_prefix (k l : CCS) z : ccg k l -> ccg (Prefix z k) (Prefix z l).
Proof.
intros cc Q. destruct (ccg_weakbisim k l cc) as [R [Rkl wbR%weakbisim_strongattacker]].
exists (fun a b => sum (sum (R a b) (a=b)) (prod (a = Choice (Prefix z k) Q) (b = Choice (Prefix z l) Q))). split.
* now right.
* apply weakbisim_strongattacker. intros a b y [[ab|aa]|[ac bc]]; split.
  + intros a' aa'. destruct (wbR a b y ab) as [HL _]. destruct (HL a' aa') as [b' [bb' a'b']]. exists b'. split. easy. auto.
  + intros b' bb'. destruct (wbR a b y ab) as [_ HR]. destruct (HR b' bb') as [a' [aa' a'b']]. exists a'. split. easy. auto.
  + subst. intros a' aa'. exists a'. split. now apply weaken. auto.
  + subst. intros a' aa'. exists a'. split. now apply weaken. auto.
  + subst a b. intros a' aa'. inversion aa'; subst.
    - inversion X; subst. exists l. split. apply weaken, tChoiceL, tPrefix. auto.
    - exists a'. split. now apply weaken, tChoiceR. auto.
  + subst a b. intros b' bb'. inversion bb'; subst.
    - inversion X; subst. exists k. split. apply weaken, tChoiceL, tPrefix. auto.
    - exists b'. split. now apply weaken, tChoiceR. auto.
Defined.

Lemma ccg_choice_left (k l : CCS) z : ccg k l -> ccg (Choice k z) (Choice l z).
Proof.
intros cc Q. pose proof (cc (Choice z Q)) as HzQ.
apply wbisim_trans with (Choice k (Choice z Q)).
apply wbisim_choice_assoc.
apply wbisim_trans with (Choice l (Choice z Q)).
easy.
apply wbisim_symm, wbisim_choice_assoc.
Defined.

End ChoiceCongruence.

(*
Lemma cwb_obscong (k l : CCS) : cwb k l -> obscongruent (CCSLTS G s0) k l.
Proof.
intros ckl a. cbn. destruct a as [|c|c].
* admit.

* destruct (ckl CTrivial) as [R [Rkl wbR%weakbisim_strongattacker]]. destruct (wbR k l (Snd c)) as [HL HR]. easy. split.
  - intros k' kk'. destruct (HL k' kk') as [l' [ll' k'l']]. exists l'. split. easy. exists R. split. easy. apply weakbisim_strongattacker. easy.
  - intros l' ll'. destruct (HR l' ll') as [k' [kk' k'l']]. exists k'. split. easy. exists R. split. easy. apply weakbisim_strongattacker. easy.
* destruct (ckl CTrivial) as [R [Rkl wbR%weakbisim_strongattacker]]. destruct (wbR k l (Rcv c)) as [HL HR]. easy. split.
  - intros k' kk'. destruct (HL k' kk') as [l' [ll' k'l']]. exists l'. split. easy. exists R. split. easy. apply weakbisim_strongattacker. easy.
  - intros l' ll'. destruct (HR l' ll') as [k' [kk' k'l']]. exists k'. split. easy. exists R. split. easy. apply weakbisim_strongattacker. easy.
Admitted.

Lemma obscong_coarsest (R' : CCS -> CCS -> Type) : congruence R' -> (forall k l, R' k l -> weakbisimilar (CCSLTS G s0) k l) -> (forall k l, R' k l -> obscongruent (CCSLTS G s0) k l).
Proof.
intros H1 H2 k l Rkl. apply cwb_obscong. eapply cwb_coarsest. apply H1. easy. easy.
Defined.

In our model of CCS, this is actually false.
The problem is that we allow only countably many CCS terms and infinte bindings, which means we can construct universal CCS terms that subsumes every other CCS term.
If C is this term, then C+R for any R is weakly bisimilar to C since C expands to the big choice of all CCS terms, and that already contains R.
The proof in Coq seems long and complicated so I haven't yet gotten around to doing it.

*)
(*
Section CounterExample.
(* Assume a bijection between CCS and nat *)
Variable f : CCS -> nat.
Variable g : nat -> CCS.
Variable fg_inv : forall n:nat, f(g n) = n.
Variable gf_inv : forall x:CCS, g(f x) = x.

Definition rfG (n:nat) := Choice (g n) (Var (S n)).
Definition rfCCS := Var 0.
Definition rfCCS' := Prefix Tau (rfCCS).

Lemma rfTransactionFinder (C C':CCS) z : trans rfG C z C' -> trans rfG rfCCS z C'.
intros H. unfold rfCCS. enough {n|g n = C} as [n gnC].
* subst C. enough (trans rfG (Choice (g n) (Var (S n))) z C') as HH.
  + clear H. induction n as [|n IH].
    - eapply tRec. unfold rfG. easy. easy.
    - apply IH. apply tChoiceR. eapply tRec. unfold rfG. easy. easy.
  + now apply tChoiceL.
* exists (f C). apply gf_inv.
Defined.

Lemma contraCWB : forall c : Context, weakbisimilar (CCSLTS rfG s0) (emplaceC c rfCCS) (emplaceC c rfCCS').
intros c. induction c. (* Note: needs stronger induction hypothesis that ensures we directly follow transitions "normally" (even internal ones) until we reach rfCCS through the context*)
* cbn. exists (fun k l => sum (k=l) (prod (k=rfCCS) (l=rfCCS'))). split.
  - auto.
  - apply weakbisim_strongattacker. intros a b z [ab|[ar br]]; split.
    + subst b. intros a' aa'. exists a'. split. now apply weaken. auto.
    + subst b. intros a' aa'. exists a'. split. now apply weaken. auto.
    + subst a b. intros a' aa'. exists a'. split. unfold rfCCS'. apply aweaken. exists rfCCS, a'. repeat split. exists 1, rfCCS. split. apply tPrefix. easy. easy. now exists 0. now left.
    + subst a b. unfold rfCCS'. intros a' aa'. inversion aa'. subst. exists rfCCS. split. now exists 0. now left.
* cbn. now apply wbisim_cong_prefix.
* cbn. generalise
* admit.
* now apply wbisim_cong_par_l.
* now apply wbisim_cong_par_r.
* now apply wbisim_cong_restrict.
Admitted.

Lemma contraNotObsCong : (obscongruent (CCSLTS contraGamma s0) contraCCS contraCCS') -> False.

End CounterExample.
*)
End ContextualWeakBisimilarity.
End Congruence.

Section Laws.

Variable G : nat -> CCS.
Variable s0 : CCS.

Lemma obscong_choice_comm (P Q : CCS) : obscongruent (CCSLTS G s0) (Choice P Q) (Choice Q P).
Proof.
apply bisim_obscong, bisim_choice_comm.
Defined.

Lemma obscong_choice_assoc (P Q R : CCS) : obscongruent (CCSLTS G s0) (Choice (Choice P Q) R) (Choice P (Choice Q R)).
Proof.
apply bisim_obscong, bisim_choice_assoc.
Defined.

Lemma obscong_choice_stop (P:CCS) : obscongruent (CCSLTS G s0) (Choice P Stop) P.
Proof.
apply bisim_obscong, bisim_choice_stop.
Defined.

Lemma obscong_choice_idem (P:CCS) : obscongruent (CCSLTS G s0) (Choice P P) P.
Proof.
apply bisim_obscong, bisim_choice_idem.
Defined.

Lemma obscong_subsidiary_tau (P:CCS) (a:action) : obscongruent (CCSLTS G s0) (Prefix a (Prefix Tau P)) (Prefix a P).
Proof.
intros z. split.
* intros s' atPs'. exists P. inversion atPs'; subst. split.
  - apply weakena, tPrefix.
  - apply wbisim_initial_tau.
* intros s' aPs'. exists P. inversion aPs'; subst. split.
  - exists (Prefix z (Prefix Tau s')), (Prefix Tau s'). repeat split.
    + now exists 0.
    + apply tPrefix.
    + exists 1. eexists. split. now apply tPrefix. easy.
  - apply wbisim_refl.
Defined.

Lemma obscong_choice_idem_tau (P:CCS): obscongruent (CCSLTS G s0) (Choice P (Prefix Tau P)) (Prefix Tau P).
Proof.
intros z. split.
* intros s' PtPs'. inversion PtPs'; subst.
  - exists s'. split. exists P, s'. repeat split. exists 1, P. split. apply tPrefix. easy. easy. now exists 0. apply wbisim_refl.
  - exists s'. split. now apply weakena. apply wbisim_refl.
* intros t' st'. exists t'. split. now apply weakena, tChoiceR. apply wbisim_refl.
Defined.

Lemma obscong_choice_tau_distr (P Q:CCS) (a:action) : obscongruent (CCSLTS G s0) (Prefix a (Choice P (Prefix Tau Q)))
                                                                         (Choice (Prefix a (Choice P (Prefix Tau Q))) (Prefix a Q)).
Proof.
intros z. split.
* intros s' rs'. exists s'. split. now apply weakena, tChoiceL. apply wbisim_refl.
* intros t' rt'. inversion rt'; subst.
  + exists t'. split. now apply weakena. apply wbisim_refl.
  + inversion X. subst a0 P0 t' a. exists Q. split.
    - eexists _, _. repeat split. now exists 0. apply tPrefix. exists 1, Q. split. now apply tChoiceR, tPrefix. easy.
    - apply wbisim_refl.
Defined.

End Laws.


(* Quick and simple "spike" specification of PowerPlay *)

(* Bring in an exponential function *)
Require Import NPeano.

(* Problems and Solutions are parameters, so we put them in a Class *)
Class Domain := {
  Problem  : Type;
  Solution : Problem -> Type
}.

(* Solvers might solve Problems within a timeout *)
Definition Solver {D : Domain} := forall p,
                                         nat ->
                                         option (Solution p).

(* If a Solver does not return None, it can solve a Problem *)
Definition Solves {D : Domain} (s : Solver) p n: Prop
        := s p n <> None.

(* One Solver Dominates another if it Solves all the same Problems and more *)
Definition Dominates {D : Domain} (s1 s2 : Solver) : Prop
        := (forall p n, Solves s2 p n -> Solves s1 p n) /\
          ~(forall p n, Solves s1 p n -> Solves s2 p n).

(* Solvers are opaque, but we need a transparent representation *)
Class Lang {D : Domain} : Type := {
  AST       : Type;
  interpret : AST -> Solver
}.

(* Searchers look for a Solver AST which Dominates another *)
Definition Searcher {D : Domain} {L : Lang}
        := forall ast1 (n : nat),
                  option {ast2 | Dominates (interpret ast2)
                                           (interpret ast1)}.

(* Our Searcher is a parameter, so we wrap it in a Class *)
Class GivenSearcher {D : Domain} {L : Lang} := {
  searcher : Searcher
}.

(* We can relax the Dominates condition to only prevent regressions *)
Definition NoWorse {D : Domain} s1 s2 : Prop
        := Dominates s1 s2 \/ s1 = s2.

(* By returning our input Solver instead of None, a Searcher becomes NoWorse *)
Definition searcher' {D : Domain} {L : Lang} {G : GivenSearcher}
                     ast1 (n : nat)
        :  {ast2 | NoWorse (interpret ast2)
                           (interpret ast1)}.
  (* Propose a value for ast2 *)
  refine (exist  _
                 (match searcher ast1 n with
                      | None    => ast1
                      | Some s' => proj1_sig s'
                  end)
                 _).

  (* Prove by case-analysis on 'searcher ast1 n' that ast2 is NoWorse *)
  destruct (searcher ast1 n).

  (* searcher ast1 n = Some s. Solve by extracting the proof from s *)
  exact (or_introl (proj2_sig s)).

  (* searcher ast1 n = None. Solve trivially *)
  exact (or_intror eq_refl).
Defined.

(* Define an infinite stream of Solvers, each NoWorse than the last *)
CoInductive NoWorseStream {D : Domain} s1 : Type :=
  nwsCons : forall s2,
                   NoWorse s2 s1    ->
                   NoWorseStream s2 ->
                   NoWorseStream s1.

(* Projection function to extract a Solver from a NoWorseStream *)
Fixpoint get_solver {D : Domain} {s1} (n : nat)
                    (nws : NoWorseStream s1) : Solver :=
  match n with
      | 0 => s1
      | S n' => match nws with
                    | nwsCons _ _ _ nws' => get_solver n' nws'
                end
  end.

(* PowerPlay makes a NoWorseStream by searching with increasing timeouts *)
CoFixpoint powerplay' {D : Domain} {L :Lang} {G : GivenSearcher}
                      ast n : NoWorseStream (interpret ast)
        := let found := searcher' ast (S n) in
           let ast'  := proj1_sig found  in
           let proof := proj2_sig found  in
               nwsCons  (interpret ast)
                        (interpret ast')
                        proof
                       (powerplay' ast' (S n)).

(* Set initial values *)
Definition powerplay (D : Domain) (L : Lang) (G : GivenSearcher) ast
        :  NoWorseStream (interpret ast)
        := powerplay' ast 0.


Require Export Metalib.Metatheory.
Require Import LibTactics.
Require Import Definitions.
Require Import String.
Require Import Lia.

Require Import Infrastructure.

(* ********************************************************************** *)
(**  Properties of [wf_typ] *)

Lemma type_from_wf_typ : forall E T,
  wf_typ E T -> type T.
Proof.
  introv H; induction H; eauto.
Qed.

Hint Resolve type_from_wf_typ:core.

Lemma wf_typ_weakening : forall T E F G,
  wf_typ (G ++ E) T ->
  uniq (G ++ F ++ E) ->
  wf_typ (G ++ F ++ E) T.
Proof with simpl_env; eauto.
  intros T E F G Hwf_typ Hk.
  remember (G ++ E) as F'.
  generalize dependent G.
  induction Hwf_typ; intros G Hok Heq; subst...
  Case "type_all".
    pick fresh Y and apply wf_typ_all...
    rewrite <- app_assoc.
    apply H0...
Qed.

Lemma wf_typ_weaken_head : forall T E F,
  wf_typ E T ->
  uniq (F ++ E) ->
  wf_typ (F ++ E) T.
Proof.
  intros.
  rewrite_env (empty ++ F++ E).
  auto using wf_typ_weakening.
Qed.

Lemma wf_typ_strengthening : forall E F x U T,
 wf_typ (F ++ x ~ bind_typ U ++ E) T ->
 wf_typ (F ++ E) T.
Proof with simpl_env; eauto.
  intros E F x U T H.
  remember (F ++ x ~ bind_typ U ++ E) as G.
  generalize dependent F.
  induction H; intros F Heq; subst...
  Case "wf_typ_var".
    analyze_binds H...
  Case "wf_typ_all".
    pick fresh Y and apply wf_typ_all...
    rewrite <- app_assoc.
    apply H0...
Qed.

Lemma notin_fv_tt_open_inv : forall X T U k,
  X `notin` fv_tt T ->
  X `notin` fv_tt U ->
  X `notin` fv_tt (open_tt_rec k U T).
Proof.
  introv notint notinu. gen k.
  inductions T; intros; simpl in *; eauto.
  destruct(k == n);eauto.
Qed.

Lemma wf_typ_strengthening_1 : forall E F x v T,
 wf_typ (F ++ x ~ v ++ E) T ->
 x `notin` fv_tt T ->
 wf_typ (F ++ E) T.
Proof.
  introv wf1 notin.
  inductions wf1; try(constructor~); simpls~.
  -
    apply binds_remove_mid in H; auto.
  -
     apply~ IHwf1_1.
  -
     apply~ IHwf1_2.
  -
    pick fresh Y and apply wf_typ_all...
    rewrite <- app_assoc.
    apply* H0;eauto.
    apply* notin_fv_tt_open_inv.
  -  apply~ IHwf1.
Qed.

Lemma wf_typ_subst_tb : forall F E Z P T,
  wf_typ (F ++ Z ~tvar  ++ E) T ->
  wf_typ E P ->
  uniq (map (subst_tb Z P) F ++ E) ->
  wf_typ (map (subst_tb Z P) F ++ E) (subst_tt Z P T).
Proof with simpl_env; eauto using wf_typ_weaken_head, type_from_wf_typ.
  introv WT WP.
  remember (F ++ Z ~tvar ++ E) as G.
  generalize dependent F.
  induction WT; intros F EQ Ok; subst; simpl subst_tt...
  -
    destruct (x == Z); subst...
    analyze_binds H.
    apply* wf_typ_var.
    assert (bind_tvar = subst_tb Z P bind_tvar).
    reflexivity. rewrite H.
    assert(binds x (subst_tb Z P bind_tvar) (map (subst_tb Z P) F)).
    forwards: binds_map_2 BindsTac.
    apply H0.
    forwards: binds_app_2 H0.
    apply H1.
  -
    pick fresh Y and apply wf_typ_all...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Z P) (Y ~tvar ++ F) ++ E).
    apply H0 ...
Qed.

Lemma wf_typ_open : forall E U T2,
  uniq E ->
  wf_typ E (t_all T2) ->
  wf_typ E U ->
  wf_typ E (open_tt T2 U).
Proof with simpl_env; eauto.
  introv Ok WA WU.
  inverts* WA.
  pick fresh X.
  rewrite (subst_tt_intro X)...
  rewrite_env (map (subst_tb X U) empty ++ E).
  eapply wf_typ_subst_tb...
Qed.

(* ********************************************************************** *)
(** Properties of [wf_env] and [wf_typ] *)

Lemma uniq_from_wf_env : forall E,
  wf_env E ->
  uniq E.
Proof.
  intros E H; induction H; auto.
Qed.

Hint Resolve uniq_from_wf_env : core.

Lemma wf_typ_from_binds_typ : forall x U E,
  wf_env E ->
  binds x (bind_typ U) E ->
  wf_typ E U.
Proof with auto using wf_typ_weaken_head.
  induction 1; intros J; analyze_binds J...
  injection BindsTacVal; intros; subst...
Qed.

Lemma wf_typ_from_wf_env_typ : forall x T E,
  wf_env (x ~ bind_typ T ++ E) ->
  wf_typ E T.
Proof.
  intros x T E H. inversion H; auto.
Qed.

(* ********************************************************************** *)
(** Properties of [wf_env] *)

Lemma wf_env_inv : forall E x T,
  wf_env (x ~ T ++ E) -> wf_env E /\  x `notin` dom E.
Proof.
  introv O. inverts* O.
Qed.

Lemma wf_env_strengthening : forall x T E F,
  wf_env (F ++ x ~ bind_typ T ++ E) ->
  wf_env (F ++ E).
Proof with eauto using wf_typ_strengthening.
  induction F; intros Wf_env; inversion Wf_env; subst; simpl_env in *...
Qed.

Lemma wf_env_subst_tb : forall x T E F,
  wf_env (F ++ x ~tvar ++ E) ->
  wf_typ E T ->
  wf_env (map (subst_tb x T) F ++ E).
Proof with eauto using wf_typ_subst_tb.
inductions F; intros Wf_env WP; simpl_env;
    inversion Wf_env; simpl_env in *; simpl subst_tb...
  rewrite <- H in Wf_env.
  applys~ wf_env_typ.
  applys* wf_typ_subst_tb.
Qed.

Lemma notin_fv_tt_open : forall (Y X : atom) T,
  X `notin` fv_tt (open_tt T Y) ->
  X `notin` fv_tt T.
Proof.
 intros Y X T. unfold open_tt.
 generalize 0.
 induction T; simpl; intros k Fr; eauto.
Qed.

Lemma notin_fv_wf : forall E (X : atom) T,
  wf_typ E T ->
  X `notin` dom E ->
  X `notin` fv_tt T.
Proof with auto.
  intros E X T Wf_typ.
  induction Wf_typ; intros Fr; simpl...
  Case "wf_typ_var".
    assert (x `in` (dom E))...
    eapply binds_In; eauto.
    assert (X <> x) by fsetdec. fsetdec.
  Case "wf_typ_all".
    pick fresh Y.
    apply (notin_fv_tt_open Y)...
Qed.

Lemma map_subst_tb_id : forall G Z P,
  wf_env G ->
  Z `notin` dom G ->
  G = map (subst_tb Z P) G.
Proof with auto.
  intros G Z P H.
  induction H; simpl; intros Fr; simpl_env...
  -
  rewrite <- IHwf_env...
  -
  rewrite <- IHwf_env...
  rewrite <- subst_tt_fresh... eapply notin_fv_wf; eauto.
Qed.

Lemma wf_env_concat_left_inv: forall E F,
    wf_env (F ++ E) -> wf_env E.
Proof.
  induction F; introv okt; auto.
  apply* IHF.
  destruct~ a.
  inverts* okt.
Qed.

(* ********************************************************************** *)
(** ** eqent *)

Lemma eq_weakening : forall E F G S T,
  eq (G ++ E) S T ->
  wf_env (G ++ F ++ E) ->
  eq (G ++ F ++ E) S T.
Proof with simpl_env; auto using wf_typ_weakening.
  intros E F G S T Sub Ok.
  remember (G ++ E) as H.
  generalize dependent G.
  induction Sub; intros G Ok EQ; subst...
  -
    pick fresh Y and apply eq_all...
    rewrite <- app_assoc.
    apply H0...
Qed.

Lemma notin_decidable: forall a E,
 wf_env E ->
 a `notin` dom E \/ not(a `notin` dom E).
Proof.
  introv wf.
  inductions E; eauto.
  inverts* wf.
  -
  forwards*: IHE H1. inverts* H.
  destruct(a == x); try solve[left*].
  + inverts e.
    right.
    simpl.
    unfold not; intros nt.
    apply nt; eauto.
  -
  forwards*: IHE H1. inverts* H.
  destruct(a == x); try solve[left*].
  + inverts e.
    right.
    simpl.
    unfold not; intros nt.
    apply nt; eauto.
Qed.

Lemma eq_refl: forall E A,
 wf_env E ->
 wf_typ E A ->
 eq E A A.
Proof.
 introv ok wft.
 inductions wft; eauto.
 pick fresh y and apply eq_all; eauto.
Qed.

Lemma eq_through_subst_tt : forall E F Y S T A,
  eq (F ++ Y ~tvar ++ E) S T ->
  wf_typ E A ->
  eq (map (subst_tb Y A) F ++ E) (subst_tt Y A S) (subst_tt Y A T).
Proof with simpl_env;
     eauto 4 using wf_typ_subst_tb, wf_env_subst_tb, wf_typ_weaken_head.
  introv SsubT PsubQ.
  remember (F ++ Y ~tvar ++ E) as G.
  generalize dependent F.
  induction SsubT; intros G EQ; subst; simpl subst_tt...
  -
    destruct (x == Y); subst.
    apply eq_refl...
    apply eq_refl...
    inverts* H0.
    analyze_binds H3...
    apply* wf_typ_var.
    assert (bind_tvar = subst_tb Y A bind_tvar).
    reflexivity. rewrite H0.
    assert(binds x (subst_tb Y A bind_tvar) (map (subst_tb Y A) G)).
    forwards: binds_map_2 BindsTac.
    apply H1.
    forwards: binds_app_2 H1.
    apply H2.
  -
    pick fresh X and apply eq_all...
    rewrite subst_tt_open_tt_var...
    rewrite subst_tt_open_tt_var...
    rewrite_env (map (subst_tb Y A) (X ~tvar ++ G) ++ E).
    apply H0...
Qed.

Lemma eq_subst_simpl : forall E Y S T A,
  eq (Y ~tvar ++ E) S T ->
  wf_typ E A ->
  eq (E) (subst_tt Y A S) (subst_tt Y A T).
Proof.
  introv con type.
  rewrite_env (map (subst_tb Y A) empty ++E).
  apply* eq_through_subst_tt.
Qed.

Lemma wf_typ_rename : forall E F z u A,
    wf_typ (E ++ z ~tvar ++ F) A ->
    wf_env (E ++ u ~tvar ++ F) ->
    wf_typ (E ++ u ~tvar ++ F) (subst_tt z (t_fvar u) A).
Proof.
  introv wf okt.
  inductions wf; simpls; auto.
  -
    destruct(x == z); try solve[inverts* e].
    forwards*: binds_remove_mid H.
    apply wf_typ_var.
    forwards*: binds_weaken H0.
    simpl_env.
    apply H1.
  -
    pick fresh x and apply wf_typ_all.
    forwards ~ : H0 x (x ~tvar ++ E) F z.
    simpl_env in *.
    apply wf_env_tvar; eauto.
    rewrite <- subst_tt_open_tt_var in H1; auto.
Qed.

Lemma eq_subst : forall F E A B z u,
    eq (E ++ z ~tvar ++ F) A B ->
    wf_env (E ++ u ~tvar ++ F) ->
    eq (E ++ u ~tvar ++ F) (subst_tt z (t_fvar u) A)
                           (subst_tt z (t_fvar u) B)
.
Proof.
  introv typt. inductions typt; introv okt; simpl; f_equal~.
  -
    destruct(x == z);eauto.
    apply eq_var;eauto.
    forwards*: uniq_from_wf_env H.
    forwards*: wf_typ_strengthening_1 H0.
    forwards*: uniq_from_wf_env okt.
    forwards*: wf_typ_weakening H2 H3.
  -
    forwards*: IHtypt1 okt.
    forwards*: IHtypt2 okt.
  -
    pick fresh x and apply eq_all.
    forwards ~ : H0 x F (x ~tvar ++ E) z.
    simpl.
    apply wf_env_tvar;eauto.
    simpl in H1.
    rewrite_env((x, bind_tvar) :: E ++ (u, bind_tvar) :: F).
    rewrite~ subst_tt_open_tt_var.
    assert((subst_tt z u B open_tt_var x) =
    (subst_tt z u (B open_tt_var x))).
    rewrite~ subst_tt_open_tt_var.
    rewrite H2;eauto.
  -
    forwards*: IHtypt okt.
Qed.

Lemma eq_regular : forall E A B,
  eq E A B -> wf_env E /\ wf_typ E A /\ wf_typ E B.
Proof with simpl_env; try solve [auto | intuition auto].
  introv H.
  induction H...
  -
  repeat split...
  +
    pick fresh x.
    forwards*: H0 x.
    destructs~ H1.
    forwards*: wf_env_inv H1.
  +
      pick fresh Y and apply wf_typ_all...
      destruct (H0 Y)...
  +
      pick fresh Y and apply wf_typ_all...
      destruct (H0 Y)...
Qed.

Lemma eq_rename : forall E x y A B,
  eq (x ~tvar ++ E) (A open_tt_var x) (B open_tt_var x) ->
  x \notin dom E \u fv_tt A \u fv_tt B ->
  y \notin dom E \u fv_tt A \u fv_tt B ->
  eq (y ~tvar ++ E) (A open_tt_var y) (B open_tt_var y)
.
Proof.
  introv Typx Frx Fry.
  destruct(x == y). substs*.
  rewrite~ (@subst_tt_intro x).
  assert
  ((B open_tt_var y) =
  subst_tt x y (B open_tt_var x)).
  rewrite~ (@subst_tt_intro x).
  rewrite H.
  rewrite_env (empty ++ x ~tvar ++ E) in Typx.
  rewrite_env (empty ++ y ~tvar ++ E).
  assert(wf_env (empty ++ y ~tvar ++ E)).
  simpl.
  forwards*: eq_regular Typx.
  destruct H0. inverts* H0.
  apply wf_env_tvar;eauto.
  forwards*: eq_subst Typx H0.
Qed.

(*
Lemma eq_decidable : forall E A B,
  wf_env E ->
  wf_typ E A ->
  wf_typ E B ->
  (eq E A B \/ not(eq E A B)) /\ (eq E B A \/ not(eq E B A)).
Proof.
  introv wf wt1 wt2. gen B.
  inductions wt1; intros;eauto;
  try solve[split*].
  -
    inductions wt2; try solve[
      split; right; unfold not;intros nt;
      inverts* nt
    ];
    try solve[split*;left*].
  -
     inductions wt2; try solve[
      split; right; unfold not;intros nt;
      inverts* nt
    ];
    try solve[split*;left*].
  -
    inductions wt2; try solve[
      split; right; unfold not;intros nt;
      inverts* nt
    ];
    try solve[split*;left*].
    destruct(x == x0);try solve[inverts* e; split*].
    try solve[
      split; right; unfold not;intros nt;
      inverts* nt
    ].
  -
    inductions wt2; try solve[
     split; right; unfold not;intros nt;
     inverts* nt
   ];
   try solve[split*;left*].
   clear IHwt2_1 IHwt2_2.
   forwards*: IHwt1_1 wt2_1.
   forwards*: IHwt1_2 wt2_2.
   inverts H. inverts H0.
   split.
   inverts* H2; try solve[
    right; unfold not;intros nt;
    inverts* nt
    ];
    try solve[split*;left*].
    inverts* H; try solve[
    right; unfold not;intros nt;
    inverts* nt
    ];
    try solve[split*;left*].
    inverts* H1; try solve[
    right; unfold not;intros nt;
    inverts* nt
    ];
    try solve[split*;left*].
    inverts* H3; try solve[
    right; unfold not;intros nt;
    inverts* nt
    ];
    try solve[split*;left*].
  -
   inductions wt2; try solve[
     split; right; unfold not;intros nt;
     inverts* nt
   ];
   try solve[split*;left*].
   pick fresh x.
   forwards*: H0 H1. inverts* H3.
   split.
   +
   inverts H4.
   *
   left.
   pick fresh y and apply eq_all.
   forwards*: eq_rename y H3.
   *
   right.
   unfold not; intros nt.
   apply H3; eauto.
   inverts nt.
   pick fresh y.
   forwards*: H8 y.
   forwards*: eq_rename y H4.
   +
   inverts H5.
   *
   left.
   pick fresh y and apply eq_all.
   forwards*: eq_rename y H3.
   *
   right.
   unfold not; intros nt.
   apply H3; eauto.
   inverts nt.
   pick fresh y.
   forwards*: H8 y.
   forwards*: eq_rename y H5.
  -
    inductions wt2; try solve[
     split; right; unfold not;intros nt;
     inverts* nt
   ];
   try solve[split*;left*].
   forwards*: IHwt1 wt2.
   inverts H.
   split.
   inverts* H0; try solve[
    right; unfold not;intros nt;
    inverts* nt
    ];
    try solve[split*;left*].
    inverts* H0; try solve[
    right; unfold not;intros nt;
    inverts* nt
    ];
    try solve[split*;left*].
    inverts* H1; try solve[
    right; unfold not;intros nt;
    inverts* nt
    ];
    try solve[split*;left*].
    inverts* H1; try solve[
    right; unfold not;intros nt;
    inverts* nt
    ];
    try solve[split*;left*].
Qed.
 *)

Lemma eq_strengthening : forall x U E F S T,
  eq (F ++ x ~ bind_typ U ++ E) S T ->
  eq (F ++ E) S T.
Proof with eauto using wf_typ_strengthening, wf_env_strengthening.
  intros x U E F S T SsubT.
  remember (F ++ x ~ bind_typ U ++ E) as E'.
  generalize dependent F.
  induction SsubT; intros F EQ; subst...
  Case "eq_all".
    pick fresh X and apply eq_all...
    rewrite <- app_assoc.
    apply H0...
Qed.

Hint Resolve eq_refl:core.

(* ********************************************************************** *)
(** * Regularity of relations *)

Lemma typing_regular : forall E P e dir T,
  typing E P e dir T -> wf_env E /\ expr e /\ wf_typ E T.
Proof with simpl_env; try solve [auto | intuition auto].
  introv H.
  inductions H ...
  -
    repeat split...
    eauto using wf_typ_from_binds_typ.
  -
     destructs IHtyping1;
     destructs IHtyping2.
     splits~; try solve[inverts* H3].
  -
    pick fresh y.
    destruct (H0 y) as [Hok [J K]]...
    repeat split.
    + inversion Hok...
    +
    pick fresh x and apply expr_abs;
    eauto using type_from_wf_typ, wf_typ_from_wf_env_typ.
    destruct (H0 x)...
    +
    apply wf_typ_arrow; eauto using wf_typ_from_wf_env_typ.
    rewrite_env (empty ++ E).
    eapply wf_typ_strengthening; simpl_env; eauto.
  -
    destructs IHtyping;
    splits~.
    apply* expr_anno.
  -
    pick fresh Y.
    destruct (H0 Y) as [Hok [J K]]...
    inversion Hok; subst.
    repeat split...
    + pick fresh X and apply expr_tabs.
        destruct (H0 X)...
    +
      pick fresh Z and apply wf_typ_all...
      destruct (H0 Z)...
  -
    repeat split...
    + apply expr_tapp...
      eauto using type_from_wf_typ.
    +
      destruct IHtyping as [R1' [R2' R3']].
      eapply wf_typ_open; eauto.
  -
    destructs~ IHtyping; splits~.
    inverts* H2.
Qed.

(** Automation *)

Hint Extern 1 (wf_env ?E) =>
  match goal with
  | H: typing _ _ _ _ _ |- _ => apply (proj1 (typing_regular _ _ _ _ _ H))
  | H: eq _ _ _ |- _ => apply (proj1 (eq_regular _ _ _ _ H))
  end : core.

Hint Extern 1 (wf_typ ?E ?t) =>
  match goal with
  | H: typing _ _ _ _ _ |- _ => apply (proj2 (proj2 (typing_regular _ _ _ _ _ H)))
  | H: eq _ _ _ |- _ => apply (proj1 (proj2 (eq_regular _ _ _ H)))
  | H: eq _ _ _ |- _ => apply (proj2 (proj2 (eq_regular _ _ _ H)))
  end : core.

Hint Extern 1 (type ?T) =>
  let go E := apply (type_from_wf_typ E); auto in
  match goal with
  | H: typing ?E _ _ _ _ |- _ => go E
  | H: eq ?E _ _ |- _ => go E
  | H: eq ?E _ _ |- _ => go E
  end : core.

Hint Extern 1 (expr ?e) =>
 match goal with
 | H: typing _ _ _ _ _|- _ => apply (proj1 (proj2 (typing_regular _ _ _ _ _ H)))
 end : core.

Lemma typing_atyping : forall E P e dir T,
  typing E P e dir T -> atyping E P e T.
Proof.
  introv typ.
  inductions typ; eauto.
Qed.

Lemma atyping_typing : forall E P e T,
  atyping E P e T -> typing E P e Inf T.
Proof.
  introv typ.
  inductions typ; eauto.
Qed.

Lemma eq_type: forall A B x n,
 x `notin` (fv_tt A) ->
 x `notin` (fv_tt B) ->
 open_tt_rec n x A = open_tt_rec n x B ->
 A = B.
Proof.
  introv nt1 nt2 eq. gen B n x.
  inductions A; intros;try solve[].
  -
  inductions B; simpl in *; inverts* eq;
  unfold open_tt in *; inverts* H0.
  destruct(n0 == n); try solve[inverts* e];
  try solve[inverts* H1].
  -
  inductions B; simpl in *; inverts* eq;
  unfold open_tt in *; inverts* H0.
  +
  forwards* h1: IHA1 H2.
  forwards* h2: IHA2 H1.
  inverts h1. inverts* h2.
  +
  destruct(n0 == n); try solve[inverts* e];
  try solve[inverts* H1].
  -
  inductions B; simpl in *; inverts* eq;
  unfold open_tt in *; inverts* H0;
  destruct(n0 == n); try solve[inverts* e];
  try solve[inverts* H1].
  destruct(n1 == n); try solve[inverts* e];
  try solve[inverts* H1].
  destruct(n1 == n0); try solve[inverts* e];
  try solve[inverts* H1].
  destruct(n1 == n0); try solve[inverts* e];
  try solve[inverts* H1].
  inverts* H1. inverts* e.
  exfalso. apply nt2. eauto.
  -
  inductions B; simpl in *; inverts* eq;
  unfold open_tt in *; inverts* H0.
  destruct(n0 == n); try solve[inverts* e];
  try solve[inverts* H1].
  inverts* H1. inverts* e.
  exfalso. apply nt1. eauto.
  -
  inductions B; simpl in *; inverts* eq;
  unfold open_tt in *; inverts* H0.
  destruct(n0 == n); try solve[inverts* e];
  try solve[inverts* H1].
  forwards*: IHA H1.
  inverts* H.
  -
  inductions B; simpl in *; inverts* eq;
  unfold open_tt in *; inverts* H0.
  destruct(n0 == n); try solve[inverts* e];
  try solve[inverts* H1].
  forwards*: IHA H1.
  inverts* H.
  -
  inductions B; simpl in *; inverts* eq;
  unfold open_tt in *; inverts* H0.
  destruct(n0 == n); try solve[inverts* e];
  try solve[inverts* H1].
Qed.

Lemma eq_left: forall A B E,
 eq E A B ->
 A = B.
Proof.
  introv eq.
  inductions eq; eauto.
  - inverts* IHeq1.  inverts* IHeq2.
  - pick fresh x.
    forwards* h1: H0 x.
    forwards*: eq_type h1.
    inverts* H1.
  - inverts* IHeq.
Qed.

Lemma eq_rel: forall E A,
 wf_typ E A ->
 wf_env E ->
 eq E A A.
Proof.
  introv ty ev.
  inductions ty; eauto.
Qed.

Lemma eq_right: forall A B E,
 wf_env E ->
 wf_typ E A ->
 wf_typ E B ->
 A = B ->
 eq E A B.
Proof.
  introv ev wf1 wf2 eq.
  inverts* eq.
Qed.


Require Import List.

Inductive emptiness := NonEmpty : emptiness | MaybeEmpty : emptiness.

Inductive char : Set := mk_char : nat -> char.
Definition string := list char.

Definition parser_guts (a : Set) := string -> list (a * nat).

Definition non_empty {a} (p : parser_guts a) : Prop :=
  p nil = nil.

Definition satisfies_emptiness e {a} (p : parser_guts a) :=
  match e with
  | MaybeEmpty => True
  | NonEmpty => non_empty p
  end.

Definition parser (e : emptiness) (a : Set) : Set :=
  { p : parser_guts a | satisfies_emptiness e p }.

SearchAbout sig.

Definition returnP {a : Set} (x : a) : parser MaybeEmpty a.
refine (exist _ (fun _ => cons (x, 0) nil) _).
simpl; auto.
Defined.

Definition append_emptiness e1 e2 :=
  match e1, e2 with
  | MaybeEmpty, MaybeEmpty => MaybeEmpty
  | _, _ => NonEmpty
  end.

Definition bind_list {a b} (xs : list a) (k : a -> list b) : list b := concat (map k xs).

Definition bindP_guts {a b : Set} (p : parser_guts a) (k : a -> parser_guts b) : parser_guts b :=
  fun input =>
    bind_list (p input) (fun result =>
      let (x, n) := result in
      k x (skipn n input)).

Theorem bind_nonempty_nonempty : forall {a b} (p : parser_guts a) (k : a -> parser_guts b),
  non_empty p ->
  non_empty (bindP_guts p k).
Proof.
  unfold non_empty in *. intros a b p k Hp.
  unfold bindP_guts. rewrite Hp.
  unfold bind_list. unfold map. reflexivity.
Qed.

Lemma skipn_nil_nil : forall {A} n, skipn n (@nil A) = (@nil A).
Proof.
  intros.
  destruct n; auto.
Qed.

Lemma bind_nil_nil : forall {a b} (l : list a) (k : a -> list b), (forall x, k x = nil) -> bind_list l k = nil.
Proof.
  intros.
  unfold bind_list.
  induction l.
  - auto.
  - simpl. rewrite H. simpl. assumption.
Qed.

Theorem bind_nonempty_nonempty_2 : forall {a b} (p : parser_guts a) (k : a -> parser_guts b),
  (forall x, non_empty (k x)) ->
  non_empty (bindP_guts p k).
Proof.
  unfold non_empty in *. intros a b p k Hk.
  unfold bindP_guts.
  destruct (p nil).
  - auto.
  - apply bind_nil_nil.
    intros. destruct x. rewrite skipn_nil_nil. apply Hk.
Qed.

Definition bindP {a b : Set} {e1 e2} (p : parser e1 a) (k : a -> parser e2 b) : parser (append_emptiness e1 e2) b.
destruct p as [p_guts Hp].
exists (bindP_guts p_guts (fun x => proj1_sig (k x))).

unfold append_emptiness in *. unfold satisfies_emptiness in *.
destruct e1; destruct e2; try auto.

- apply bind_nonempty_nonempty. assumption.
- apply bind_nonempty_nonempty. assumption.
- apply bind_nonempty_nonempty_2.
  intros.
  destruct (k x). simpl.
  apply s.
Qed.

Definition type_of {a} (x : a) := a.

Definition satisfy (p : char -> bool) : parser NonEmpty char.
exists (fun input =>
  match input with
  | nil => nil
  | x :: xs =>
     if p x
       then (x, 1) :: nil
       else nil
  end).

reflexivity.
Defined.

Definition non_empty_str : Set := char * string.

Scheme Equality for char.

Definition mapP {a b : Set} {e} (f : a -> b) (p : parser e a) : parser e b.
destruct p as [p_guts Hp].
exists (fun input => map (fun result => match result with (x, n) => (f x, n) end) (p_guts input)).
unfold satisfies_emptiness in *.
destruct e; auto.
unfold non_empty in *.
rewrite Hp.
reflexivity.
Defined.

Fixpoint stringP' c s : parser NonEmpty unit :=
  match s with
  | c' :: s'' =>
    bindP
      (satisfy (char_beq c))
      (fun _ => stringP' c' s'')
  | nil =>
    mapP (fun _ => tt) (satisfy (char_beq c))
  end.

Definition stringP (s : non_empty_str) : parser NonEmpty unit :=
  let (c, s') := s in stringP' c s'.

Definition alt_emptiness e1 e2 :=
  match e1, e2 with
  | NonEmpty, NonEmpty => NonEmpty
  | _, _ => MaybeEmpty
  end.

Definition fail {a} : parser NonEmpty a.
exists (fun _ => nil). reflexivity.
Defined.

Definition altP {e1 e2 a} (p1 : parser e1 a) (p2 : parser e2 a) : parser (alt_emptiness e1 e2) a.
Admitted.

Fixpoint manyP {a} (p : parser NonEmpty a) : parser MaybeEmpty (list a) :=
 altP
   (bindP p (fun x =>
     bindP (manyP p) (fun xs =>
     returnP (cons x xs))))
   (returnP nil).


Require Export Qual.geq.
Require Export Qual.defeq.
Require Export Qual.par.
Require Export Qual.confluence.

Set Implicit Arguments.

(* These lemmas talk about what MultiPar does for ValueTypes. Once Par has revealed the head form
   of a type, it never changes. *)

Lemma MultiPar_Type_inv : forall S A psi B s, MultiPar S psi A B -> A = a_Type s -> B = a_Type s.
Proof.
  intros S A psi B s H. induction H. auto.
  inversion H; intro K; auto; try inversion K.
Qed.

Lemma MultiPar_TyUnit_inv : forall S A psi B, MultiPar S psi A B -> A = a_TyUnit -> B = a_TyUnit.
Proof.
  intros S A psi B H. induction H. auto.
  inversion H; intro K; auto; try inversion K.
Qed.

Lemma MultiPar_Pi_inv : forall S D rho A B,
    MultiPar S D A B ->
    forall A1 A2, A = a_Pi rho A1 A2 ->
             exists B1 B2, B = (a_Pi rho B1 B2) /\
                      MultiPar S D A1 B1 /\
                      exists L, forall x, x \notin L ->
                                MultiPar ([(x,D)] ++ S) D (open_tm_wrt_tm A2 (a_Var_f x))
                                         (open_tm_wrt_tm B2 (a_Var_f x)).
Proof.
  intros S D rho A B H.
  induction H; intros; subst; try invert_Grade; subst.
  + eexists. eexists. split; try reflexivity. repeat split; eauto.
  + inversion H; subst;
    destruct (IHMultiPar _ _ ltac:(auto)) as [B01 [B02 EQ]];
    auto; split_hyp; subst.
    exists B01, B02; repeat split; auto.
    eapply MP_Step; eauto.
    move: H3 => [L0 h].
    exists (L \u L0). move=> x Fr. repeat spec x.
    eapply MP_Step; eauto.
Qed.

Lemma MultiPar_WSigma_inv : forall S D rho A B, MultiPar S D A B -> forall A1 A2,
      A = a_WSigma rho A1 A2 ->
      exists B1 B2, B = (a_WSigma rho B1 B2)
               /\ MultiPar S D A1 B1 /\
               exists L, forall x, x \notin L ->
                         MultiPar ([(x,D)] ++ S) D (open_tm_wrt_tm A2 (a_Var_f x))
                                  (open_tm_wrt_tm B2 (a_Var_f x)).
Proof.
  intros S D rho A B H.
  induction H; intros; subst; try invert_Grade; subst.
  + eexists. eexists. split; try reflexivity. repeat split; eauto.
  + inversion H; subst;
    destruct (IHMultiPar _ _ ltac:(auto)) as [B01 [B02 EQ]];
    auto; split_hyp; subst.
    exists B01, B02; repeat split; auto.
    eapply MP_Step; eauto.
    move: H3 => [L0 h].
    exists (L \u L0). move=> x Fr. repeat spec x.
    eapply MP_Step; eauto.
Qed.

Lemma MultiPar_SSigma_inv : forall S D rho A B, MultiPar S D A B -> forall A1 A2,
      A = a_SSigma rho A1 A2 ->
      exists B1 B2, B = (a_SSigma rho B1 B2)
               /\ MultiPar S D A1 B1 /\
               exists L, forall x, x \notin L ->
                         MultiPar ([(x,D)] ++ S) D (open_tm_wrt_tm A2 (a_Var_f x))
                                  (open_tm_wrt_tm B2 (a_Var_f x)).
Proof.
  intros S D rho A B H.
  induction H; intros; subst; try invert_Grade; subst.
  + eexists. eexists. split; try reflexivity. repeat split; eauto.
  + inversion H; subst;
    destruct (IHMultiPar _ _ ltac:(auto)) as [B01 [B02 EQ]];
    auto; split_hyp; subst.
    exists B01, B02; repeat split; auto.
    eapply MP_Step; eauto.
    move: H3 => [L0 h].
    exists (L \u L0). move=> x Fr. repeat spec x.
    eapply MP_Step; eauto.
Qed.

Lemma MultiPar_Sum_inv : forall S D A B, MultiPar S D A B -> forall A1 A2,
      A = a_Sum A1 A2 -> exists B1 B2, B = (a_Sum B1 B2)   /\ MultiPar S D A1 B1 /\ MultiPar S D A2 B2.
Proof.
  intros S D A B H.
  induction H; intros; subst; try invert_Grade; subst.
  + eexists. eexists. split; try reflexivity. repeat split; eauto.
  + inversion H; subst;
    destruct (IHMultiPar _ _ ltac:(auto)) as [B01 [B02 EQ]]; auto; split_hyp; subst.
      exists B01, B02; eauto.
Qed.

(* ------------------------------------------------------------------------ *)

(* Proof that joinability implies consistency. *)

Ltac step_left := apply Consistent_a_Step_R; [auto |intro N; inversion N; inversion H0]; fail.
Ltac step_right := apply Consistent_a_Step_L; [auto | intro N; inversion N; inversion H0]; fail.

(* look for a multipar involvong a head form and apply the appropriate lemma for that
   head form. Note: for paths, the lemma has already been applied so we only need
   to look for a hypothesis about path consistency. *)
Ltac MultiPar_step EQ :=
  let b1' := fresh "b" in
  let b2' := fresh "b" in
  match goal with
  | [ SIDE : MultiPar _  _ ( a_Type _ ) _ |- _ ] =>
    eapply MultiPar_Type_inv in SIDE; eauto; rename SIDE into EQ
  | [ SIDE : MultiPar _  _ a_TyUnit _ |- _ ] =>
    apply MultiPar_TyUnit_inv in SIDE; auto; rename SIDE into EQ
  | [ SIDE : MultiPar _  _ (a_Pi _ _ _ ) _ |- _ ] =>
    destruct (MultiPar_Pi_inv SIDE ltac:(auto)) as [b1' [b2' [EQ _]]]; clear SIDE
  | [ SIDE : MultiPar _ _ (a_WSigma _ _ _)  _ |- _ ] =>
    destruct (MultiPar_WSigma_inv SIDE ltac:(auto)) as [b1' [b2' [EQ _]]]; clear SIDE
  | [ SIDE : MultiPar _ _ (a_SSigma _ _ _)  _ |- _ ] =>
    destruct (MultiPar_SSigma_inv SIDE ltac:(auto)) as [b1' [b2' [EQ _]]]; clear SIDE
  | [ SIDE : MultiPar _ _ (a_Sum _ _)  _ |- _ ] =>
    destruct (MultiPar_Sum_inv SIDE ltac:(auto)) as [b1' [b2' [EQ _]]]; clear SIDE
  end.

Lemma Joins_Consistent : forall S a psi b, Joins S psi a b -> Consistent a b.
Proof.
  intros.
  all: destruct H as [P psi a1 a2 b1 b2 MSL MSR].
  move: (MultiPar_lc1 MSL) => lc1.
  move: (MultiPar_lc1 MSR) => lc2.
  move: (MultiPar_lc2 MSL) => lc3.
  destruct a1; try step_left; destruct a2; try step_right; auto.
  (* 34 subgoals. At this point all cases have a value type form on both left and right. *)
  (* Resolve the MP of these type forms. *)
  all: try MultiPar_step EQ1.
  all: try MultiPar_step EQ2.

  all: subst; match goal with [H : GEq _ _ _ _ |- _ ] => inversion H; subst end.

  (* 4 cases that actually are consistent. *)
  all: repeat match goal with [H : lc_tm (_ _) |- _ ] => inversion H; subst; clear H end.
  all: eauto.

Qed.

(*
a  -> b -->* c      d - by confluence
|     |      |      e - by induction
v     v      v
a2 -> d -->* e
*)

Lemma MultiPar_confluence_helper : forall S D a a1, MultiPar S D a a1
-> forall a2, Par S D a a2 -> exists e, Par S D a1 e /\ MultiPar S D a2 e.
Proof.
  intros S D a a1 H. induction H.
  - intros. move: (Par_lc2 H0) => cl1. exists a2. split; eauto.
    eapply MP_Refl; eauto using Par_Grade2.
  - intros. destruct (confluence H H1) as [d [L R]].
      destruct (IHMultiPar _ L) as [e [LL RR]]; auto.
      exists e. split; eauto.
Qed.

(*
a -->  b -->* c    d - by prior lemma
|      |      |    e - by induction.
v      v      v
*      *      *
a2 --> d -->* e
*)

Lemma MultiPar_confluence : forall S D a a1, MultiPar S D a a1
-> forall a2, MultiPar S D a a2 -> exists b1, exists b2,  MultiPar S D a1 b1 /\ MultiPar S D a2 b2 /\ GEq S D b1 b2.
Proof.
  intros S D a a1 MP. induction MP.
  intros.
 - exists a2. exists a2.
   repeat split; eauto using MultiPar_lc2, MultiPar_Grade2, GEq_refl.
 - intros.
   destruct (MultiPar_confluence_helper H0 H) as [d [L R]].
   destruct (IHMP d) as [e [f ?]]; auto. split_hyp.
   exists e. exists f. split; eauto.
Qed.

Lemma MultiPar_refl : forall S D a, Grade S D a -> MultiPar S D a a.
Proof.
  intros. eapply MP_Refl. auto.
Qed.

Lemma MultiPar_trans : forall S D a b c, MultiPar S D a b -> MultiPar S D b c -> MultiPar S D a c.
Proof.
  intros.
  induction H. auto.
  eauto.
Qed.

Lemma MultiPar_respects_GEq : forall W a psi b, MultiPar W psi a b -> forall a', GEq W psi a a'
                                                                  -> exists b', MultiPar W psi a' b'
                                                                          /\ GEq W psi b b'.
Proof.
  induction 1; intros.
  - exists a'. split. eapply MP_Refl. eauto using GEq_lc2, GEq_Grade2. auto.
  - move: (Par_respects_GEq H H1) => [b1 [PP GE]].
    edestruct IHMultiPar as [b' [MP GE']]. eauto.
    eauto.
Qed.

(*
    a   b   c        a         b         c
     \ / \ /          \      /  \       /
      ab  bc          ab = ab'   bc = bc'
      .\ ./            |    |    |    |
        d             d1 =  d  = e =  e1
 *)

Lemma Joins_transitive : forall S D a b, Joins S D a b -> forall c, Joins S D b c -> Joins S D a c.
Proof.
  intros S D a b h. destruct h as [P psi a b ab ab' MSL MSR].
  intros c h2. destruct h2 as [? ? b c bc bc' MSL' MSR'].
  destruct (MultiPar_confluence MSR MSL') as [d [e [MSL'' [MSR'' GE]]]].
  move: (GEq_symmetry H) => hsym.
  destruct (MultiPar_respects_GEq MSL'' hsym) as [d1 [h1 h2]].
  destruct (MultiPar_respects_GEq MSR'' H0) as [e1 [h3 h4]].
  apply join with (b1:= d1)(b2:=e1).
  eapply MultiPar_trans; eauto.
  eapply MultiPar_trans; eauto.
  eapply GEq_trans with (b:=d); eauto using GEq_symmetry.
  eapply GEq_trans with (b:=e); eauto using GEq_symmetry.
Qed.

Lemma Joins_symmetry: forall S D a b, Joins S D a b -> Joins S D b a.
Proof.
  intros S D a b H.
  destruct H.
  apply join with (b1:= b2)(b2:=b1); eauto using GEq_symmetry.
Qed.

Lemma Joins_refl : forall S D a, Grade S D a -> Joins S D a a.
Proof.
  intros.
  econstructor. eapply MP_Refl; auto. eapply MP_Refl; auto.
  eapply GEq_refl. eauto.
Qed.

(* --------------------------------------------- *)

Lemma MultiPar_Pi :  forall (L : atoms) (P : econtext) (psi psi1 : grade) (A1 B1 A2 B2 : tm),
    MultiPar P psi A1 A2 ->
    (forall x : atom,
        x `notin` L -> MultiPar ([(x, psi)] ++ P) psi
                               (open_tm_wrt_tm B1 (a_Var_f x)) (open_tm_wrt_tm B2 (a_Var_f x))) ->
    MultiPar P psi (a_Pi psi1 A1 B1) (a_Pi psi1 A2 B2).
Proof.
  intros.
  eapply MultiPar_trans with (b := (_ psi1 A2 B1)).
  + induction H; auto.
    ++ eapply MP_Refl; eauto.
       fresh_apply_Grade x; auto; repeat spec x.
       eauto using MultiPar_Grade1.
    ++ eapply MP_Step with (b := _ psi1 b B1); eauto.
       fresh_apply_Par x; eauto; repeat spec x.
       eapply Par_Refl; eauto using MultiPar_Grade1.
  + pick fresh x. repeat spec x.
    dependent induction H1.
    ++ apply open_tm_wrt_tm_inj in x; auto. subst.
       eapply MP_Refl; eauto.
       fresh_apply_Grade y; eauto 2 using MultiPar_Grade2.
       eapply (@Grade_renaming x0); auto.
    ++ eapply MP_Step with (b := a_Pi psi1 A2 (close_tm_wrt_tm x b)).
       fresh_apply_Par y. eapply Par_Refl; eauto using MultiPar_Grade2.
       rewrite <- (open_tm_wrt_tm_close_tm_wrt_tm b x) in H0.
       eapply (@Par_renaming x); try rewrite fv_tm_tm_close_tm_wrt_tm; auto.
       eapply IHMultiPar;  try rewrite fv_tm_tm_close_tm_wrt_tm; eauto 3.
       rewrite (open_tm_wrt_tm_close_tm_wrt_tm b x).
       auto.
Qed.

Lemma MultiPar_WSigma
     : forall (L : atoms) (P : econtext) (psi psi1 : grade) (A1 B1 A2 B2 : tm),
       MultiPar P psi A1 A2 ->
       (forall x : atom,
        x `notin` L -> MultiPar ([(x,psi)] ++ P) psi (open_tm_wrt_tm B1 (a_Var_f x)) (open_tm_wrt_tm B2 (a_Var_f x))) ->
       MultiPar P psi (a_WSigma psi1 A1 B1) (a_WSigma psi1 A2 B2).
Proof.
  intros.
  eapply MultiPar_trans with (b := (_ psi1 A2 B1)).
  + induction H; auto.
    ++ eapply MP_Refl; eauto.
       fresh_apply_Grade x; auto; repeat spec x.
       eauto using MultiPar_Grade1.
    ++ eapply MP_Step with (b := _ psi1 b B1); eauto.
       fresh_apply_Par x; eauto; repeat spec x.
       eapply Par_Refl; eauto using MultiPar_Grade1.
  + pick fresh x. repeat spec x.
    dependent induction H1.
    ++ apply open_tm_wrt_tm_inj in x; auto. subst.
       eapply MP_Refl; eauto.
       fresh_apply_Grade y; eauto 2 using MultiPar_Grade2.
       eapply (@Grade_renaming x0); auto.
    ++ eapply MP_Step with (b := a_WSigma psi1 A2 (close_tm_wrt_tm x b)).
       fresh_apply_Par y. eapply Par_Refl; eauto using MultiPar_Grade2.
       rewrite <- (open_tm_wrt_tm_close_tm_wrt_tm b x) in H0.
       eapply (@Par_renaming x); try rewrite fv_tm_tm_close_tm_wrt_tm; auto.
       eapply IHMultiPar;  try rewrite fv_tm_tm_close_tm_wrt_tm; eauto 3.
       rewrite (open_tm_wrt_tm_close_tm_wrt_tm b x).
       auto.
Qed.

Lemma MultiPar_SSigma
     : forall (L : atoms) (P : econtext) (psi psi1 : grade) (A1 B1 A2 B2 : tm),
       MultiPar P psi A1 A2 ->
       (forall x : atom,
        x `notin` L -> MultiPar ([(x, psi)] ++ P) psi (open_tm_wrt_tm B1 (a_Var_f x)) (open_tm_wrt_tm B2 (a_Var_f x))) ->
       MultiPar P psi (a_SSigma psi1 A1 B1) (a_SSigma psi1 A2 B2).
Proof.
  intros.
  eapply MultiPar_trans with (b := (_ psi1 A2 B1)).
  + induction H; auto.
    ++ eapply MP_Refl; eauto.
       fresh_apply_Grade x; auto; repeat spec x.
       eauto using MultiPar_Grade1.
    ++ eapply MP_Step with (b := _ psi1 b B1); eauto.
       fresh_apply_Par x; eauto; repeat spec x.
       eapply Par_Refl; eauto using MultiPar_Grade1.
  + pick fresh x. repeat spec x.
    dependent induction H1.
    ++ apply open_tm_wrt_tm_inj in x; auto. subst.
       eapply MP_Refl; eauto.
       fresh_apply_Grade y; eauto 2 using MultiPar_Grade2.
       eapply (@Grade_renaming x0); auto.
    ++ eapply MP_Step with (b := a_SSigma psi1 A2 (close_tm_wrt_tm x b)).
       fresh_apply_Par y. eapply Par_Refl; eauto using MultiPar_Grade2.
       rewrite <- (open_tm_wrt_tm_close_tm_wrt_tm b x) in H0.
       eapply (@Par_renaming x); try rewrite fv_tm_tm_close_tm_wrt_tm; auto.
       eapply IHMultiPar;  try rewrite fv_tm_tm_close_tm_wrt_tm; eauto 3.
       rewrite (open_tm_wrt_tm_close_tm_wrt_tm b x).
       auto.
Qed.

Lemma MultiPar_Abs1 : forall (L : atoms) (P : econtext) (psi psi0 : grade) (A1 b1 b2 : tm),
       (forall x : atom,
        x `notin` L -> MultiPar ([(x, psi0)] ++ P) psi (open_tm_wrt_tm b1 (a_Var_f x)) (open_tm_wrt_tm b2 (a_Var_f x))) ->
       CGrade P psi q_Top A1 ->
       MultiPar P psi (a_Abs psi0 A1 b1) (a_Abs psi0 A1 b2).
Proof.
  intros.
  pick fresh x. repeat spec x.
  dependent induction H1.
    ++ apply open_tm_wrt_tm_inj in x; auto. subst.
       eapply MP_Refl; eauto.
       fresh_apply_Grade y; eauto 2 using MultiPar_Grade2.
       eapply (@Grade_renaming x0); auto.
    ++ eapply MP_Step with (b := a_Abs psi0 A1 (close_tm_wrt_tm x b)).
       fresh_apply_Par y.
       rewrite <- (open_tm_wrt_tm_close_tm_wrt_tm b x) in H.
       eapply (@Par_renaming x); try rewrite fv_tm_tm_close_tm_wrt_tm; auto.
       inversion H0; eauto.
       eapply IHMultiPar;  try rewrite fv_tm_tm_close_tm_wrt_tm; eauto 3.
       rewrite (open_tm_wrt_tm_close_tm_wrt_tm b x).
       auto.
Qed.

Inductive CMultiPar : econtext -> grade -> grade -> tm -> tm -> Prop :=
    CMultiPar_Leq : forall (P : econtext) (psi psi0 : grade) (a1 a2 : tm),
               psi0 <= psi -> MultiPar P psi a1 a2 -> CMultiPar P psi psi0 a1 a2
  | CMultiPar_Nleq : forall (P : econtext) (psi psi0 : grade) (a1 a2 : tm),
                lc_tm a1 ->
                lc_tm a2 -> ~ psi0 <= psi -> uniq P -> CMultiPar P psi psi0 a1 a2.

#[export] Hint Constructors CMultiPar : core.

Lemma MultiPar_Abs : forall (L : atoms) (P : econtext) (psi psi0 : grade) (A1 A2 b1 b2 : tm),
       (forall x : atom,
        x `notin` L -> MultiPar ([(x, psi0)] ++ P) psi (open_tm_wrt_tm b1 (a_Var_f x)) (open_tm_wrt_tm b2 (a_Var_f x))) ->
       (CMultiPar P psi q_Top A1 A2) ->
       MultiPar P psi (a_Abs psi0 A1 b1) (a_Abs psi0 A2 b2).
Proof.
  intros.
  inversion H0; subst; clear H0.
  + induction H2; eauto. eapply MultiPar_Abs1; eauto.
    eapply MP_Step with (b := a_Abs psi0 b b1).
    fresh_apply_Par y; auto. spec y. eapply Par_Refl. eapply MultiPar_Grade1; eauto.
    eapply IHMultiPar; eauto.
  + eapply MP_Step with (b := a_Abs psi0 A2 b1).
    fresh_apply_Par y; auto. spec y. eapply Par_Refl. eapply MultiPar_Grade1; eauto.
    eapply MultiPar_Abs1; eauto.
Qed.

Lemma MultiPar_WPairBeta
     : forall (L : atoms) (P : econtext) (psi psi0 phi : grade) (a1 b1 b2 a1' a2' : tm),
       MultiPar P psi a1 (a_WPair a1' psi0 a2') ->
       (forall x : atom,
        x `notin` L -> MultiPar ([(x, psi0)] ++ P) psi (open_tm_wrt_tm b1 (a_Var_f x)) (open_tm_wrt_tm b2 (a_Var_f x))) ->
       MultiPar P psi (a_LetPair psi0 a1 b1) (a_App (open_tm_wrt_tm b2 a1') q_Bot a2').
Proof.
  intros.
  eapply MultiPar_trans with (b := a_LetPair psi0 a1 b2).
  + pick fresh x. repeat spec x.
    dependent induction H1.
    ++ apply open_tm_wrt_tm_inj in x; auto. subst.
       eapply MP_Refl; eauto.
       fresh_apply_Grade y; eauto 2 using MultiPar_Grade1.
       eapply (@Grade_renaming x0); auto.
    ++ eapply MP_Step with (b := a_LetPair psi0 a1 (close_tm_wrt_tm x b)).
       fresh_apply_Par y. eapply Par_Refl; eauto using MultiPar_Grade1.
       rewrite <- (open_tm_wrt_tm_close_tm_wrt_tm b x) in H0.
       eapply (@Par_renaming x); try rewrite fv_tm_tm_close_tm_wrt_tm; auto.
       eapply IHMultiPar;  try rewrite fv_tm_tm_close_tm_wrt_tm; eauto 3.
       rewrite (open_tm_wrt_tm_close_tm_wrt_tm b x).
       auto.
  + dependent induction H; auto.
    ++ eapply MP_Step with (b :=  (a_App (open_tm_wrt_tm b2 a1') q_Bot a2')).
       fresh_apply_Par x; auto. spec x.
       eapply Par_Refl.
       eapply MultiPar_Grade2; eauto.
       eapply MP_Refl; eauto.
       have GA: (Grade P psi (open_tm_wrt_tm b2 a1')).
       {
         pick fresh x. spec x.
         invert_Grade; subst. invert_CGrade a1'; subst.
         eapply Grade_open; eauto using MultiPar_Grade2.
         eapply Grade_open_irrel; eauto using MultiPar_Grade2.
       }
       invert_Grade; subst.
       eapply G_App; eauto using leq_Bot.
    ++ eapply MP_Step with (b := a_LetPair psi0 b b2).
       fresh_apply_Par x; eauto; repeat spec x.
       eapply Par_Refl; eauto using MultiPar_Grade2.
       eapply IHMultiPar; eauto.
Qed.

Lemma MultiPar_LetPair
     : forall (L : atoms) (P : econtext) (psi psi0 phi : grade) (a1 b1 a2 b2 : tm),
       MultiPar P psi a1 a2 ->
       (forall x : atom,
        x `notin` L -> MultiPar ([(x, psi0)] ++ P) psi (open_tm_wrt_tm b1 (a_Var_f x)) (open_tm_wrt_tm b2 (a_Var_f x))) ->
       MultiPar P psi (a_LetPair psi0 a1 b1) (a_LetPair psi0 a2 b2).
Proof.
  intros.
  eapply MultiPar_trans with (b := a_LetPair psi0 a1 b2).
  + pick fresh x. repeat spec x.
    dependent induction H1.
    ++ apply open_tm_wrt_tm_inj in x; auto. subst.
       eapply MP_Refl; eauto.
       fresh_apply_Grade y; eauto 2 using MultiPar_Grade1.
       eapply (@Grade_renaming x0); auto.
    ++ eapply MP_Step with (b := a_LetPair psi0 a1 (close_tm_wrt_tm x b)).
       fresh_apply_Par y. eapply Par_Refl; eauto using MultiPar_Grade1.
       rewrite <- (open_tm_wrt_tm_close_tm_wrt_tm b x) in H0.
       eapply (@Par_renaming x); try rewrite fv_tm_tm_close_tm_wrt_tm; auto.
       eapply IHMultiPar;  try rewrite fv_tm_tm_close_tm_wrt_tm; eauto 3.
       rewrite (open_tm_wrt_tm_close_tm_wrt_tm b x).
       auto.
  + induction H.
    ++ eapply MP_Refl.
       fresh_apply_Grade x; eauto 3 using MultiPar_Grade2.
    ++ eapply MP_Step with (b := a_LetPair psi0 b b2).
       fresh_apply_Par x; eauto 4 using MultiPar_Grade2.
       eapply IHMultiPar; eauto.
Qed.

Ltac fresh_apply_MultiPar x :=
  match goal with
      | [ |- MultiPar ?P ?psi (a_Pi ?psi2 ?a ?b) (a_Pi ?psi3 ?a2 ?b2) ] => pick fresh x and apply MultiPar_Pi
      | [ |- MultiPar ?P ?psi (a_WSigma ?psi2 ?a ?b) (a_WSigma ?psi3 ?a3 ?b3) ] => pick fresh x and apply MultiPar_WSigma
      | [ |- MultiPar ?P ?psi (a_SSigma ?psi2 ?a ?b) (a_SSigma ?psi3 ?a2 ?b2) ] => pick fresh x and apply MultiPar_SSigma
      | [ |- MultiPar ?P ?psi (a_Abs ?psi2 ?A1 ?b) (a_Abs ?psi3 ?A2 ?b3) ] => pick fresh x and apply MultiPar_Abs
      | [ |- MultiPar ?P ?psi (a_LetPair ?psi2 ?a ?b) (a_App ?a1 ?phi2 ?a2)  ] => pick fresh x and apply MultiPar_WPairBeta
      | [ |- MultiPar ?P ?psi (a_LetPair ?psi2 ?a ?b) (a_LetPair ?psi3 ?a2 ?b2)  ] => pick fresh x and apply MultiPar_LetPair
    end.

Ltac exists_apply_MultiPar x :=
  let y := fresh in
  fresh_apply_MultiPar y; eauto;
  eapply (@MultiPar_renaming x); try rewrite fv_tm_tm_close_tm_wrt_tm; auto;
  rewrite open_tm_wrt_tm_close_tm_wrt_tm; auto.

(*
Lemma MultiPar_Pi_exists :  forall x (P : econtext) (psi psi1 : grade) (A1 B1 A2 B' : tm),
    x `notin` fv_tm_tm B1 \u dom P ->
    MultiPar P psi A1 A2 ->
    MultiPar ([(x, q_C)] ++ P) psi (open_tm_wrt_tm B1 (a_Var_f x)) B' ->
    MultiPar P psi (a_Pi psi1 A1 B1) (a_Pi psi1 A2 (close_tm_wrt_tm x B')).
Proof.
  intros x P psi psi1 A1 B1 A2 B' Fr MPA MPB.
  exists_apply_MultiPar x.
Qed.*)

Lemma MultiPar_PiFst : forall W rho (A B A' B' : tm) psi,
    MultiPar W psi (a_Pi rho A B) (a_Pi rho A' B') ->
    MultiPar W psi A A'.
Proof.
  intros W rho A B A' B' R' h1.
  dependent induction h1.
  - inversion H. subst. constructor. auto.
  - inversion H. subst. eapply IHh1; eauto.
    apply MP_Step with (b := A2). auto.
    eapply IHh1; eauto.
Qed.

(*
Lemma MultiPar_PiSnd : forall W rho (A B A' B' : tm) psi,
    MultiPar W psi (a_Pi rho A B) (a_Pi rho A' B') ->
    exists L, forall x, x `notin` L ->
              MultiPar ([(x,psi)] ++ W) psi (open_tm_wrt_tm B (a_Var_f x)) (open_tm_wrt_tm B' (a_Var_f x)).
Proof.
  intros W rho A B A' B' R' h1.
  dependent induction h1; eauto.
  - inversion H. subst. exists L. intros.
    constructor. eauto.
  - inversion H; subst.
    eapply IHh1; eauto.
    destruct (IHh1 rho A2 B2 A' B') as [L0 h0]; auto.
    exists (L \u L0 \u dom P);  eauto.
Qed. *)

Lemma MultiPar_App : forall a a' c c' S psi psi0,
    MultiPar S psi a c
    -> CMultiPar S psi psi0 a' c'
    -> MultiPar S psi (a_App a psi0 a') (a_App c psi0 c').
Proof.
  intros.
  eapply MultiPar_trans with (b:= a_App c psi0 a').
  + induction H. eapply MP_Refl; eauto.
    eapply G_App; eauto. inversion H0; subst; eauto using MultiPar_Grade1.
    eapply MP_Step with (b:= a_App b psi0 a'); eauto using MultiPar_Grade1.
    eapply Par_App; eauto. inversion H0; subst; eauto using MultiPar_Grade1.
  + inversion H0; subst; clear H0.
    induction H2; eauto using MultiPar_Grade2.
    eapply MP_Step with (b:= a_App c psi0 b); eauto using MultiPar_Grade2.
    induction H; eauto using MultiPar_Grade2.
    eapply MP_Step with (b:= a_App a psi0 c'); eauto using MultiPar_Grade2.

Qed.

Lemma Joins_App : forall a a' b b' S psi psi0,
      Joins S psi a b
    -> CJoins S psi psi0 a' b'
    -> Joins S psi (a_App a psi0 a') (a_App b psi0 b').
Proof.
  intros a a' b b' S psi psi0 H H0.
  inversion H.
  inversion H0. inversion H9; subst.
  + apply join with (b1:= (a_App b1 psi0 b0)) (b2:= a_App b2 psi0 b3).
    eapply MultiPar_App; eauto.
    eapply MultiPar_App; auto.
    apply GEq_App; eauto.
  +  apply join with (b1:= (a_App b1 psi0 a')) (b2:= a_App b2 psi0 b').
     eapply MultiPar_App; eauto.
     eapply MultiPar_App; auto.
     apply GEq_App; eauto using GEq_uniq.
Qed.

Lemma Joins_AppRel: forall a a' b b' S psi psi0,
      Joins S psi a b
    -> Joins S psi a' b'
    -> psi0 <= psi
    -> Joins S psi (a_App a psi0 a') (a_App b psi0 b').
Proof.
  intros a a' b b' S psi psi0 H H0 LE.
  inversion H.
  inversion H0.
  subst.
  apply join with (b1:= (a_App b1 psi0 b0)) (b2:= a_App b2 psi0 b3).
  eapply MultiPar_App; eauto.
  eapply MultiPar_App; auto.
  apply GEq_App; eauto.
Qed.

Lemma Joins_AppIrrel : forall a a' c c' S psi psi0,
      Joins S psi a c
    -> lc_tm a'
    -> lc_tm c'
    -> not (psi0 <= psi)
    -> Joins S psi (a_App a psi0 a') (a_App c psi0 c').
Proof.
  intros a a' b b' S psi psi0 H LC1 LC2 NLE.
  inversion H.
  subst.
  apply join with (b1:= (a_App b1 psi0 a')) (b2:= a_App b2 psi0 b').
  eapply MultiPar_App; eauto using GEq_uniq.
  eapply MultiPar_App; eauto using GEq_uniq.
  apply GEq_App; eauto using GEq_uniq.
Qed.

Lemma MultiPar_WPairRel : forall a a' b b' S psi psi0,
      MultiPar S psi a b
    -> psi0 <= psi
    -> MultiPar S psi a' b'
    -> MultiPar S psi (a_WPair a psi0 a') (a_WPair b psi0 b').
Proof.
  intros a a' b b' S psi psi0 MP LE MP2.
  + eapply MultiPar_trans with (b:= a_WPair b psi0 a').
    ++ induction MP; eauto using MultiPar_Grade1.
       eapply MP_Step with (b:= a_WPair b psi0 a'); eauto using MultiPar_Grade1.
    ++ induction MP2; eauto using MultiPar_Grade1.
       eapply MP_Step with (b:= a_WPair b psi0 a0); eauto using MultiPar_Grade2.
       eapply MP_Step with (b:= a_WPair b psi0 b0); eauto using MultiPar_Grade2.
Qed.

Lemma MultiPar_WPairIrrel : forall a a' b b' S psi psi0,
      lc_tm a
    -> lc_tm b
    -> not (psi0 <= psi)
    -> MultiPar S psi a' b'
    -> MultiPar S psi (a_WPair a psi0 a') (a_WPair b psi0 b').
Proof.
  intros a a' b b' S psi psi0 LC1 LC2 NLE MP2.
  + eapply MultiPar_trans with (b:= a_WPair b psi0 a').
    ++ eapply MP_Step with (b:= a_WPair b psi0 a').
       eapply Par_WPair; eauto using MultiPar_Grade1, MultiPar_uniq.
       eapply MP_Refl; eauto using MultiPar_Grade1, MultiPar_uniq.
    ++ induction MP2.
       eapply MP_Refl; eauto using MultiPar_Grade1, MultiPar_uniq.
       eapply MP_Step with (b:= a_WPair b psi0 b0); eauto.
       eapply Par_WPair; eauto using MultiPar_Grade1, MultiPar_uniq.
Qed.

Lemma Joins_WPair : forall a a' b b' S psi psi0,
      CJoins S psi psi0 a b
    -> Joins S psi a' b'
    -> Joins S psi (a_WPair a psi0 a') (a_WPair b psi0 b').
Proof.
  intros a a' b b' S psi psi0 H H0.
  inversion H; inversion H0; subst.
  + inversion H2; subst.
    apply join with (b1:= (a_WPair b0 psi0 b1)) (b2:= a_WPair b3 psi0 b2).
    eapply MultiPar_WPairRel; eauto.
    eapply MultiPar_WPairRel; eauto.
    apply GEq_WPair; eauto.
  + eapply join with (b1 := (a_WPair a psi0 b1)) (b2:= a_WPair b psi0 b2).
    eapply MultiPar_WPairIrrel; eauto.
    eapply MultiPar_WPairIrrel; eauto.
    apply GEq_WPair; eauto.
Qed.

Lemma MultiPar_SPairRel : forall a a' b b' S psi psi0,
      MultiPar S psi a b
    -> psi0 <= psi
    -> MultiPar S psi a' b'
    -> MultiPar S psi (a_SPair a psi0 a') (a_SPair b psi0 b').
Proof.
  intros a a' b b' S psi psi0 MP LE MP2.
  + eapply MultiPar_trans with (b:= a_SPair b psi0 a').
    ++ induction MP; eauto using MultiPar_Grade1.
       eapply MP_Step with (b:= a_SPair b psi0 a'); eauto using MultiPar_Grade1.
    ++ induction MP2; eauto using MultiPar_Grade1.
       eapply MP_Step with (b:= a_SPair b psi0 a0); eauto using MultiPar_Grade2.
       eapply MP_Step with (b:= a_SPair b psi0 b0); eauto using MultiPar_Grade2.
Qed.

Lemma MultiPar_SPairIrrel : forall a a' b b' S psi psi0,
      lc_tm a
    -> lc_tm b
    -> not (psi0 <= psi)
    -> MultiPar S psi a' b'
    -> MultiPar S psi (a_SPair a psi0 a') (a_SPair b psi0 b').
Proof.
  intros a a' b b' S psi psi0 LC1 LC2 NLE MP2.
  + eapply MultiPar_trans with (b:= a_SPair b psi0 a').
    ++ eapply MP_Step with (b:= a_SPair b psi0 a').
       eapply Par_SPair; eauto using MultiPar_Grade1, MultiPar_uniq.
       eapply MP_Refl; eauto using MultiPar_Grade1, MultiPar_uniq.
    ++ induction MP2.
       eapply MP_Refl; eauto using MultiPar_Grade1, MultiPar_uniq.
       eapply MP_Step with (b:= a_SPair b psi0 b0); eauto.
       eapply Par_SPair; eauto using MultiPar_Grade1, MultiPar_uniq.
Qed.

Lemma Joins_SPair : forall a a' b b' S psi psi0,
      CJoins S psi psi0 a b
    -> Joins S psi a' b'
    -> Joins S psi (a_SPair a psi0 a') (a_SPair b psi0 b').
Proof.
  intros a a' b b' S psi psi0 H H0.
  inversion H; inversion H0; subst.
  + inversion H2; subst.
    apply join with (b1:= (a_SPair b0 psi0 b1)) (b2:= a_SPair b3 psi0 b2).
    eapply MultiPar_SPairRel; eauto.
    eapply MultiPar_SPairRel; eauto.
    apply GEq_SPair; eauto.
  + eapply join with (b1 := (a_SPair a psi0 b1)) (b2:= a_SPair b psi0 b2).
    eapply MultiPar_SPairIrrel; eauto.
    eapply MultiPar_SPairIrrel; eauto.
    apply GEq_SPair; eauto.
Qed.

Lemma MultiPar_Proj1 : forall P a1 a2 psi0 psi,
    MultiPar P psi a1 a2 ->
    psi0 <= psi ->
    MultiPar P psi (a_Proj1 psi0 a1) (a_Proj1 psi0 a2).
Proof.
  induction 1; intros.
  eapply MP_Refl; eauto.
  eapply MP_Step. 2: { eauto. }
  eapply Par_Proj1; eauto.
Qed.

Lemma Joins_Proj1 : forall P a1 a2 psi0 psi,
    Joins P psi a1 a2 ->
    psi0 <= psi ->
    Joins P psi (a_Proj1 psi0 a1) (a_Proj1 psi0 a2).
Proof.
  intros.
  inversion H. subst.
  eapply join.
  eapply MultiPar_Proj1; eauto.
  eapply MultiPar_Proj1; eauto.
  eapply GEq_Proj1; eauto.
Qed.

Lemma MultiPar_Proj2 : forall P a1 a2 psi0 psi,
    MultiPar P psi a1 a2 ->
    MultiPar P psi (a_Proj2 psi0 a1) (a_Proj2 psi0 a2).
Proof.
  induction 1; intros.
  eapply MP_Refl; eauto.
  eapply MP_Step. 2: { eauto. }
  eapply Par_Proj2; eauto.
Qed.

Lemma Joins_Proj2 : forall P a1 a2 psi0 psi,
    Joins P psi a1 a2 ->
    Joins P psi (a_Proj2 psi0 a1) (a_Proj2 psi0 a2).
Proof.
  intros.
  inversion H. subst.
  eapply join.
  eapply MultiPar_Proj2; eauto.
  eapply MultiPar_Proj2; eauto.
  eapply GEq_Proj2; eauto.
Qed.

Lemma MultiPar_Sum : forall P psi A1 A1' A2 A2',  MultiPar P psi A1 A1' ->
  MultiPar P psi A2 A2' ->
  MultiPar P psi (a_Sum A1 A2) (a_Sum A1' A2').
Proof.
  intros.
  eapply MultiPar_trans with (b := a_Sum A1' A2).
  + induction H; eauto using MultiPar_Grade1.
    eapply MP_Step with (b:= a_Sum b A2); eauto using MultiPar_Grade1.
  + induction H0; eauto using MultiPar_Grade2.
    eapply MP_Step with (b:= a_Sum A1' b); eauto using MultiPar_Grade2.
Qed.

Lemma Joins_Sum : forall P psi A1 A1' A2 A2',  Joins P psi A1 A1' ->
  Joins P psi A2 A2' ->
  Joins P psi (a_Sum A1 A2) (a_Sum A1' A2').
Proof.
  intros.
  inversion H. inversion H0. subst.
  eapply join; eauto using MultiPar_Sum.
Qed.

Lemma MultiPar_Inj1 : forall P a1 a2 psi,
    MultiPar P psi a1 a2 ->
    MultiPar P psi (a_Inj1 a1) (a_Inj1 a2).
Proof.
  induction 1; intros.
  eapply MP_Refl; eauto.
  eapply MP_Step. 2: { eauto. }
  eapply Par_Inj1; eauto.
Qed.

Lemma Joins_Inj1 : forall P a1 a2 psi,
    Joins P psi a1 a2 ->
    Joins P psi (a_Inj1 a1) (a_Inj1 a2).
Proof.
  intros.
  inversion H. subst.
  eapply join.
  eapply MultiPar_Inj1; eauto.
  eapply MultiPar_Inj1; eauto.
  eapply GEq_Inj1; eauto.
Qed.

Lemma MultiPar_Inj2 : forall P a1 a2 psi,
    MultiPar P psi a1 a2 ->
    MultiPar P psi (a_Inj2 a1) (a_Inj2 a2).
Proof.
  induction 1; intros.
  eapply MP_Refl; eauto.
  eapply MP_Step. 2: { eauto. }
  eapply Par_Inj2; eauto.
Qed.

Lemma Joins_Inj2 : forall P a1 a2 psi,
    Joins P psi a1 a2 ->
    Joins P psi (a_Inj2 a1) (a_Inj2 a2).
Proof.
  intros.
  inversion H. subst.
  eapply join.
  eapply MultiPar_Inj2; eauto.
  eapply MultiPar_Inj2; eauto.
  eapply GEq_Inj2; eauto.
Qed.

Lemma Joins_Case : forall P a a' b1 b1' b2 b2' psi0 psi,
    psi0 <= psi ->
    Joins P psi a a' ->
    Joins P psi b1 b1' ->
    Joins P psi b2 b2' ->
    Joins P psi (a_Case psi0 a b1 b2) (a_Case psi0 a' b1' b2').
Proof.
  intros.
  inversion H0. inversion H1. inversion H2. subst.
  have MultiPar_Case : forall a b0 b1 b4 b2 b6,
    MultiPar P psi a b0 ->
    MultiPar P psi b1 b4 ->
    MultiPar P psi b2 b6 ->
    psi0 <= psi ->
    MultiPar P psi (a_Case psi0 a b1 b2) (a_Case psi0 b0 b4 b6).
  { clear. intros.
    move: (MultiPar_Grade1 H) => G1.
    move: (MultiPar_Grade1 H) => G2.
    move: (MultiPar_Grade1 H0) => G10.
    move: (MultiPar_Grade2 H0) => G20.
    move: (MultiPar_Grade1 H1) => G11.
    move: (MultiPar_Grade2 H1) => G21.
    eapply MultiPar_trans with (b:= a_Case psi0 b0 b1 b2).
    2: eapply MultiPar_trans with (b := a_Case psi0 b0 b4 b2).
    + induction H; eauto.
      eapply MP_Step. eapply Par_Case; eauto using Par_Grade2.
      eapply IHMultiPar; eauto using Par_Grade2.
    + induction H0; eauto using MultiPar_Grade2.
      eapply MP_Step. 2:  eapply IHMultiPar; eauto using Par_Grade2.
      eapply Par_Case; eauto using MultiPar_Grade2.
    + induction H1; eauto using MultiPar_Grade2.
      eapply MP_Step. 2:  eapply IHMultiPar; eauto using Par_Grade2.
      eapply Par_Case; eauto using MultiPar_Grade2.
  }
  eapply join.
  eapply MultiPar_Case; eauto.
  eapply MultiPar_Case; eauto.
  eapply GEq_Case; eauto.
Qed.

(* This is the key lemma for consistency. If we can prove two types equal, then they are joinable. *)
(* Basically, we need to prove a joins version of every DefEq rule. *)

Ltac invert_Joins :=
    match goal with [H : Joins _ _ _ _ |- _ ] => inversion H; clear H; subst
                 |  [H : CJoins _ _ _ _ _ |- _ ] => inversion H; clear H; subst end.

Ltac invert_CJoins :=
    match goal with
                 |  [H : CJoins _ _ _ _ _ |- _ ] => inversion H; clear H; subst end.

Ltac exists_apply_GEq x :=
  let y := fresh in
  fresh_apply_GEq y; eauto;
  eapply (@GEq_renaming x); repeat rewrite fv_tm_tm_close_tm_wrt_tm; eauto;
  rewrite open_tm_wrt_tm_close_tm_wrt_tm;
  rewrite open_tm_wrt_tm_close_tm_wrt_tm;
  auto.

Lemma DefEq_Joins :
(forall S D phi A B, CDefEq S D phi A B -> CJoins S D phi A B) /\
forall S D A B, DefEq S D A B -> Joins S D A B.
Proof.
  apply CDefEq_DefEq_mutual.
  all: intros; eauto.
  - eapply Joins_refl; eauto.
  - eapply Joins_transitive; eauto.
  - eapply Joins_symmetry; eauto.
  - have MPb: MultiPar P psi b b.
    { eapply MP_Refl; eauto using Step_lc2, Step_Grade. }
    have MP: MultiPar P psi a b.
    { eapply MP_Step. eapply Step_Par; eauto. auto. }
    eapply join; eauto.
    eapply GEq_refl.
    eapply Step_Grade; eauto.
  - (* Pi cong *)
    pick fresh x. repeat spec x.
    repeat invert_Joins.
    eapply join with (b1 := a_Pi psi0 b0 (close_tm_wrt_tm x b1))
                     (b2 := a_Pi psi0 b3 (close_tm_wrt_tm x b2)).
    exists_apply_MultiPar x.
    exists_apply_MultiPar x.
    exists_apply_GEq x.
  - (* Abs cong *)
    pick fresh x. repeat spec x.
    repeat invert_Joins.
    + eapply join with (b1 := a_Abs psi0 b4 (close_tm_wrt_tm x b0))
                     (b2 := a_Abs psi0 b5 (close_tm_wrt_tm x b3)).
      exists_apply_MultiPar x.
      exists_apply_MultiPar x.
      exists_apply_GEq x.
    + eapply join with (b1 := a_Abs psi0 A1 (close_tm_wrt_tm x b0))
                     (b2 := a_Abs psi0 A2 (close_tm_wrt_tm x b3)).
      exists_apply_MultiPar x.
      exists_apply_MultiPar x.
      exists_apply_GEq x.
  - (* app cong *)
    invert_CJoins.
    eapply Joins_AppRel; eauto.
    eapply Joins_AppIrrel; eauto.
  - (* PiFst *)
    invert_Joins.
    eapply MultiPar_Pi_inv in H0; try reflexivity.
    move: H0 => [A1' [B1' [? hh]]]. split_hyp. subst.
    eapply MultiPar_Pi_inv in H1; try reflexivity.
    move: H1 => [A2' [B2' [? hh]]]. split_hyp. subst.
    match goal with [H:GEq _ _ _ _ |- _ ] => inversion H end. subst.
    eapply join; eauto.
  - (* PiSnd *)
    repeat invert_Joins.
    match goal with [H0 : MultiPar _ _ (a_Pi _ _ _) _ |- _ ] =>
        eapply MultiPar_Pi_inv in H0; try reflexivity;
        move: H0 => [A1' [B1' [? [? hh]]]]; subst; move: hh => [L1 h1] end.
    match goal with [H0 : MultiPar _ _ (a_Pi _ _ _) _ |- _ ] =>
        eapply MultiPar_Pi_inv in H0; try reflexivity;
        move: H0 => [A2' [B2' [? [? hh]]]]; subst; move: hh => [L2 h2] end.
    invert_GEq. subst.
    pick fresh x. repeat spec x.
    rewrite (subst_tm_tm_intro x B1); eauto.
    rewrite (subst_tm_tm_intro x B2); eauto.
    eapply join.
    eapply MultiPar_subst3; try eassumption.
    eapply MultiPar_subst3; try eassumption.
    move: CEq_GEq_equality_substitution => [_ sub].
    eapply sub with (P2 := nil); simpl_env; eauto.
    eapply CEq_Leq; eauto using MultiPar_lc2. reflexivity.
  - (* WSigma cong *)
    pick fresh x. repeat spec x.
    repeat invert_Joins.
    eapply join with (b1 := a_WSigma psi0 b0 (close_tm_wrt_tm x b1))
                     (b2 := a_WSigma psi0 b3 (close_tm_wrt_tm x b2)).
    exists_apply_MultiPar x.
    exists_apply_MultiPar x.
    exists_apply_GEq x.
  - (* WSigma Fst *)
    repeat invert_Joins.
    match goal with [H0 : MultiPar _ _ (a_WSigma _ _ _) _ |- _ ] =>
        eapply MultiPar_WSigma_inv in H0; try reflexivity;
        move: H0 => [A1' [B1' [? [? hh]]]]; subst; move: hh => [L1 h1] end.
    match goal with [H0 : MultiPar _ _ (a_WSigma _ _ _) _ |- _ ] =>
        eapply MultiPar_WSigma_inv in H0; try reflexivity;
        move: H0 => [A2' [B2' [? [? hh]]]]; subst; move: hh => [L2 h2] end.
    match goal with [H:GEq _ _ _ _ |- _ ] => inversion H end. subst.
    eapply join; eauto.
  - (* WSigma Snd *)
    repeat invert_Joins.
    match goal with [H0 : MultiPar _ _ (a_WSigma _ _ _) _ |- _ ] =>
        eapply MultiPar_WSigma_inv in H0; try reflexivity;
        move: H0 => [A1' [B1' [? [? hh]]]]; subst; move: hh => [L1 h1] end.
    match goal with [H0 : MultiPar _ _ (a_WSigma _ _ _) _ |- _ ] =>
        eapply MultiPar_WSigma_inv in H0; try reflexivity;
        move: H0 => [A2' [B2' [? [? hh]]]]; subst; move: hh => [L2 h2] end.
    match goal with [H:GEq _ _ _ _ |- _ ] => inversion H; clear H end. subst.
    pick fresh x. repeat spec x.
    rewrite (subst_tm_tm_intro x B1); eauto.
    rewrite (subst_tm_tm_intro x B2); eauto.
    eapply join.
    eapply MultiPar_subst3; try eassumption.
    eapply MP_Refl; eauto.
    eapply MultiPar_subst3; try eassumption.
    eapply MP_Refl; eauto.
    eapply GEq_substitution_same with (P2 := nil); eauto.
  - (* WPair *)
    eapply Joins_WPair; eauto.
  - (* LetPair cong *)
    pick fresh x. repeat spec x.
    repeat invert_Joins.
    eapply join with (b1 := a_LetPair psi0 b4 (close_tm_wrt_tm x b0))
                     (b2 := a_LetPair psi0 b5 (close_tm_wrt_tm x b3)).
    exists_apply_MultiPar x.
    exists_apply_MultiPar x.
    exists_apply_GEq x.
  - (* SSigma cong *)
    pick fresh x. repeat spec x.
    repeat invert_Joins.
    eapply join with (b1 := a_SSigma psi0 b0 (close_tm_wrt_tm x b1))
                     (b2 := a_SSigma psi0 b3 (close_tm_wrt_tm x b2)).
    exists_apply_MultiPar x.
    exists_apply_MultiPar x.
    exists_apply_GEq x.
  - (* SSigma Fst *)
    repeat invert_Joins.
    match goal with [H0 : MultiPar _ _ (a_SSigma _ _ _) _ |- _ ] =>
        eapply MultiPar_SSigma_inv in H0; try reflexivity;
        move: H0 => [A1' [B1' [? [? hh]]]]; subst; move: hh => [L1 h1] end.
    match goal with [H0 : MultiPar _ _ (a_SSigma _ _ _) _ |- _ ] =>
        eapply MultiPar_SSigma_inv in H0; try reflexivity;
        move: H0 => [A2' [B2' [? [? hh]]]]; subst; move: hh => [L2 h2] end.
    match goal with [H:GEq _ _ _ _ |- _ ] => inversion H end. subst.
    eapply join; eauto.
  - (* SSigma Snd *)
    repeat invert_Joins.
    match goal with [H0 : MultiPar _ _ (a_SSigma _ _ _) _ |- _ ] =>
        eapply MultiPar_SSigma_inv in H0; try reflexivity;
        move: H0 => [A1' [B1' [? [? hh]]]]; subst; move: hh => [L1 h1] end.
    match goal with [H0 : MultiPar _ _ (a_SSigma _ _ _) _ |- _ ] =>
        eapply MultiPar_SSigma_inv in H0; try reflexivity;
        move: H0 => [A2' [B2' [? [? hh]]]]; subst; move: hh => [L2 h2] end.
    match goal with [H:GEq _ _ _ _ |- _ ] => inversion H end. subst.
    pick fresh x. repeat spec x.
    rewrite (subst_tm_tm_intro x B1); eauto.
    rewrite (subst_tm_tm_intro x B2); eauto.
    eapply join.
    eapply MultiPar_subst3; try eassumption.
    eapply MultiPar_subst3; try eassumption.
    move: CEq_GEq_equality_substitution => [_ sub].
    eapply sub with (P2 := nil); simpl_env; eauto.
    eapply CEq_Leq; eauto. reflexivity.
  - (* SPair *)
    eapply Joins_SPair; eauto.
  - (* Proj1 *)
    eapply Joins_Proj1; eauto.
  - (* Proj2 *)
    eapply Joins_Proj2; eauto.
  - (* Sum Cong *)
    eapply Joins_Sum; eauto.
  - (* Sum Fst *)
    invert_Joins.
    eapply MultiPar_Sum_inv in H0; try reflexivity.
    move: H0 => [A1'1 [A2'1 hh]]. split_hyp. subst.
    eapply MultiPar_Sum_inv in H1; try reflexivity.
    move: H1 => [A1'2 [A2'2 hh]]. split_hyp. subst.
    match goal with [H:GEq _ _ _ _ |- _ ] => inversion H end. subst.
    eapply join; eauto.
  - (* Sum Snd *)
    invert_Joins.
    eapply MultiPar_Sum_inv in H0; try reflexivity.
    move: H0 => [A1'1 [A2'1 hh]]. split_hyp. subst.
    eapply MultiPar_Sum_inv in H1; try reflexivity.
    move: H1 => [A1'2 [A2'2 hh]]. split_hyp. subst.
    match goal with [H:GEq _ _ _ _ |- _ ] => inversion H end. subst.
    eapply join; eauto.
  - (* Inj1 *)
    eapply Joins_Inj1; eauto.
  - (* Inj2 *)
    eapply Joins_Inj2; eauto.
  - (* Case *)
    eapply Joins_Case; eauto.
  - eapply join; eauto.
  - eapply join; eauto.
  - (* SubstIrrel *)
    pick fresh x. repeat spec x.
    invert_Joins.
    move: (GEq_uniq H3) => u. destruct_uniq.
    rewrite (subst_tm_tm_intro x); auto.
    rewrite (subst_tm_tm_intro x b2); auto.
    eapply join.
    instantiate (1 := (subst_tm_tm a1 x b0)).
    eapply MultiPar_subst3_CMultiPar; try eassumption.
    eapply CMP_Nleq; auto.
    instantiate (1 := (subst_tm_tm a1 x b3)).
    eapply MultiPar_subst3_CMultiPar; try eassumption.
    eapply CMP_Nleq; auto.
    eapply GEq_substitution_irrel with (P2 := nil); eauto.
Qed.

Lemma DefEq_Consistent : forall S D A B, DefEq S D A B -> Consistent A B.
Proof.
  intros.
  eapply Joins_Consistent.
  eapply DefEq_Joins.
  eauto.
Qed.

(* Inverse of DefEq_Joins *)

Lemma CDefEq_Refl : forall G psi phi b, CGrade G psi phi b -> CDefEq G psi phi b b.
Proof.
  intros.
  inversion H; subst; eauto.
Qed.

Lemma Par_DefEq :
  (forall W psi phi a b, CPar W psi phi a b -> CDefEq W psi phi a b) /\
  (forall W psi a b, Par W psi a b -> DefEq W psi a b).
Proof.
  apply CPar_Par_mutual.
  all: intros; auto.
  all: try fresh_apply_DefEq x; auto.
  - move: (Par_lc2 p) => LC. inversion LC. subst.
    move: (CPar_lc1 c) => LC1.
    move: CPar_Par_Grade => [h0 h2].
    apply h0 in c. split_hyp.
    apply h2 in p. split_hyp. clear h0 h2.
    eapply Eq_Trans with (b := open_tm_wrt_tm a' b).
    eapply Eq_Trans with (b := a_App (a_Abs psi0 A a') psi0 b).
    eapply Eq_App; eauto.
    + eapply CDefEq_Refl; auto.
    + eapply Eq_Beta; eauto.
      invert_Grade.
      pick fresh x.
      inversion H1. subst.
      ++ eapply Grade_open with (y:=x); auto.
      ++ eapply Grade_open_irrel; eauto.
    + inversion H0; subst.
    ++ invert_Grade.
       pick fresh x. rewrite (subst_tm_tm_intro x a' b). auto. rewrite (subst_tm_tm_intro x a' b'). auto.
       eapply DefEq_equality_substitution with (P:= [(x, psi0)] ++ P); auto.
    ++ invert_Grade.
       pick fresh x and apply Eq_SubstIrrel; auto.
  - move: (Par_lc2 p) => LC. inversion LC. subst.
    move: CPar_Par_Grade => [h0 h2].
    apply h2 in p. split_hyp.
    pick fresh y. move: (p0 y ltac:(auto)) => p1.
    apply h2 in p1. split_hyp.
    eapply Eq_Trans with (b := a_App (open_tm_wrt_tm b1 a1') q_Bot a2').
    eapply Eq_Trans with (b := a_LetPair psi0 (a_WPair a1' psi0 a2') b1).
    + pick fresh x and apply Eq_LetPair; auto.
      eapply Eq_Refl; auto.
      move: (p0 x ltac:(auto)) => Pb.
      move: CPar_Par_Grade => [ _ h3].
      apply h2 in Pb. split_hyp. auto.
    + eapply Eq_Beta; eauto.
      pick fresh x and apply G_LetPair; auto.
      move: (p0 x ltac:(auto)) => Pb.
      move: CPar_Par_Grade => [ _ h3].
      apply h2 in Pb. split_hyp. auto.
      eapply S_LetPairBeta; auto.
      eapply lc_a_LetPair_exists with (x1:=y); auto.
      eapply Grade_lc; eauto.
      invert_Grade. subst.
      eapply G_App; auto.
      inversion H11; subst.
      ++ eapply Grade_open with (y:=y); eauto.
      ++ eapply Grade_open_irrel; eauto.
      ++ eapply CG_Leq; auto using leq_Bot.
    + invert_Grade. subst.
      eapply Eq_App; auto.
      pick fresh x.
      rewrite (subst_tm_tm_intro x b1); auto.
      rewrite (subst_tm_tm_intro x b2); auto.
      repeat spec x.
      eapply DefEq_substitution_CGrade with (P2:=nil); simpl_env; eauto.
      eapply CDefEq_Refl. eapply CG_Leq; eauto using leq_Bot.

  - move: (Par_Grade1 p) => p1.
    move: (Par_Grade2 p) => p2.
    move: (DefEq_lc2 H) => lc. inversion lc. subst.
    eapply Eq_Trans with (b := (a_Proj1 psi0 (a_SPair a1' psi0 a2))).
    eapply Eq_Proj1; auto.
    eapply Eq_Beta; auto.
    invert_Grade. subst. inversion H6. auto. done.

  - move: (Par_Grade p) => [p1 p2].
    invert_Grade. subst.
    move: (DefEq_lc2 H) => lc. inversion lc. subst.

    eapply Eq_Trans with (b := (a_Proj2 psi0 (a_SPair a1' psi0 a2))).
    eapply Eq_Proj2; auto.
    eapply Eq_Beta; auto.

  - move: (Par_Grade p) => [G1 G2].
    invert_Grade. subst.
    move: (DefEq_lc2 H) => lc. inversion lc. subst.
    eapply Eq_Trans with (b := a_Case psi0 (a_Inj1 a') b1' b2).
    eapply Eq_Case; auto.
    eapply Eq_Refl; eauto using DefEq_Grade1.
    eapply Eq_Beta; eauto.
    eapply G_Case; eauto using DefEq_Grade2.
    eapply S_Case1Beta; eauto using DefEq_lc2.
    constructor; eauto using DefEq_Grade2.
  - move: (Par_Grade p) => [G1 G2].
    invert_Grade. subst.
    move: (DefEq_lc2 H) => lc. inversion lc. subst.
    eapply Eq_Trans with (b := a_Case psi0 (a_Inj2 a') b1 b2').
    eapply Eq_Case; auto.
    eapply Eq_Refl; eauto using DefEq_Grade1.
    eapply Eq_Beta; eauto.
    eapply G_Case; eauto using DefEq_Grade2.
    eapply S_Case2Beta; eauto using DefEq_lc2.
    constructor; eauto using DefEq_Grade2.
Qed.

Lemma MultiPar_DefEq :
  forall S D A B, MultiPar S D A B -> DefEq S D A B.
Proof.
  intros.
  induction H.
  eapply Eq_Refl; auto.
  eapply Eq_Trans with (b := b).
  eapply Par_DefEq; auto.
  auto.
Qed.

Lemma Joins_DefEq :
  forall S D A B, Joins S D A B -> DefEq S D A B.
Proof.
  intros.
  inversion H. subst.
  move: CEqGEq_DefEq => [_ h].
  move: MultiPar_DefEq => h1.
  eapply Eq_Trans with (b:= b1); auto.
  eapply Eq_Trans with (b := b2); auto.
Qed.