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

(****************************************************************************)
(*                 The Calculus of Inductive Constructions                  *)
(*                                                                          *)
(*                                Projet Coq                                *)
(*                                                                          *)
(*                     INRIA                        ENS-CNRS                *)
(*              Rocquencourt                        Lyon                    *)
(*                                                                          *)
(*                                Coq V5.10                                 *)
(*                              Nov 25th 1994                               *)
(*                                                                          *)
(****************************************************************************)
(*                              commutation.v                               *)
(****************************************************************************)

(*****************************************************************************)
(*          Projet Coq  - Calculus of Inductive Constructions V5.8           *)
(*****************************************************************************)
(*                                                                           *)
(*      Meta-theory of the explicit substitution calculus lambda-env         *)
(*      Amokrane Saibi                                                       *)
(*                                                                           *)
(*      September 1993                                                       *)
(*                                                                           *)
(*****************************************************************************)

                 (*  SL commute avec B|| de la maniere suivante:

                                           B||
                                       x ---------> z
                                       |            |
                                    SL |            |SL*
                                       |            |
                                       V            V
                                       y ----------> u
                                         SL*B||SL*              *)
Require Import sur_les_relations.
Require Import TS.
Require Import egaliteTS.
Require Import sigma_lift.
Require Import betapar.
Require Import SLstar_bpar_SLstar.
Require Import determinePC_SL.

Definition e_diag1 (b : wsort) (x y : TS b) :=
  forall z : TS b,
  e_beta_par _ x z ->
  exists u : TS b, e_slstar_bp_slstar _ y u /\ e_relSLstar _ z u.

Notation diag1 := (e_diag1 _) (only parsing).
(* <Warning> : Syntax is discontinued *)

(* les regles du systeme sigma-lift (SL) verifient le diagramme *)

Goal forall x y : terms, reg_app x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros a b0 s z H0.
pattern z in |- *; apply case_benv with (app a b0) s.
2: assumption.
intros x' s' H1 H2; pattern x' in |- *; apply case_bapp with a b0.
3: assumption.
(* 1-regle B||: app *)
intros a' b0' H3 H4; exists (app (env a' s') (env b0' s')); auto 6.
 (* (a[s])(b0[s]) SL*B||SL* (a'[s'])(b0'[s']) *)
 (* (a'b0')[s'] SL* (a'[s'])(b0'[s']) *)
(* 2-regle B||: beta *)
intros a1 a1' b0' H3 H4 H5; rewrite H3.
exists (env a1' (cons (env b0' s') s')); split.
 (* ((L a1)[s])(b0[s]) SL*B||SL* a1'[b0'[s'].s'] *)
red in |- *; apply comp_2rel with (app (lambda (env a1 (lift s))) (env b0 s)).
   (* ((L a1)[s])(b0[s]) SL* (L (a1[||S]))(b0[s]) *)
auto 6.
   (* (L (a1[||S]))(b0[s]) B|| (a1'[||s'])[b0'[s'].id] *)
apply comp_2rel with (env (env a1' (lift s')) (cons (env b0' s') id)).
auto.
   (* (a1'[||s'])[b0'[s'].id] SL* a1'[b0'[s'].s'] *)
red in |- *;
 apply star_trans1 with (env a1' (comp (lift s') (cons (env b0' s') id))).
auto.
apply star_trans1 with (env a1' (cons (env b0' s') (comp s' id))); auto 6.
 (* (a1'[b0'id])[s'] SL* a1'[b0'[s'].s'] *)
red in |- *; apply star_trans1 with (env a1' (comp (cons b0' id) s')).
auto.
apply star_trans1 with (env a1' (cons (env b0' s') (comp id s'))); auto 6.
Save commut_app.
Hint Resolve commut_app.

Goal forall x y : terms, reg_lambda x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros a s z H0.
pattern z in |- *; apply case_benv with (lambda a) s.
2: assumption.
intros x' s' H1 H2; pattern x' in |- *; apply case_blambda with a.
2: assumption.
intros a' H3; exists (lambda (env a' (lift s'))); auto 6.
(* L(a[||s]) SL*B||*SL L(a'[||s']) *)
(* (L a0')[s'] SL* L(a0'[||s']) *)
Save commut_lambda.
Hint Resolve commut_lambda.

Goal forall x y : terms, reg_clos x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros a s t z H0.
pattern z in |- *; apply case_benv with (env a s) t.
2: assumption.
intros x' t' H1 H2; pattern x' in |- *; apply case_benv with a s.
2: assumption.
intros a' s' H3 H4; exists (env a' (comp s' t')); auto 6.
(*  a[sot] SL*B||SL* a'[s'ot'] *)
(* (a'[s'])[t'] SL* a'[s'ot'] *)
Save commut_clos.
Hint Resolve commut_clos.

Goal forall x y : terms, reg_varshift1 x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros n z H0.
pattern z in |- *; apply case_benv with (var n) shift.
2: assumption.
intros x' s' H1 H2; pattern x' in |- *; apply case_bvar with n.
2: assumption.
pattern s' in |- *; apply case_bshift.
2: assumption.
exists (var (S n)); auto 6.
(* n+1 SL*B||SL* n+1 *)
(* n[|] SL* n+1 *)
Save commut_varshift1.
Hint Resolve commut_varshift1.

Goal forall x y : terms, reg_varshift2 x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros n s z H0.
pattern z in |- *; apply case_benv with (var n) (comp shift s).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_bvar with n.
2: assumption.
pattern y' in |- *; apply case_bcomp with shift s.
2: assumption.
intros t' s' H3 H4; pattern t' in |- *; apply case_bshift.
2: assumption.
exists (env (var (S n)) s'); auto 6.
(* n+1[s] SL*B||SL* n+1[s'] *)
(* n[|os'] SL* n+1[s'] *)
Save commut_varshift2.
Hint Resolve commut_varshift2.

Goal forall x y : terms, reg_fvarcons x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros a s z H0.
pattern z in |- *; apply case_benv with (var 0) (cons a s).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_bvar with 0.
2: assumption.
pattern y' in |- *; apply case_bcons with a s.
2: assumption.
intros a' s' H3 H4; exists a'; auto 6.
(* a SL*B||SL* a' *)
(* 0[a'.s'] SL* a' *)
Save commut_fvarcons.
Hint Resolve commut_fvarcons.

Goal forall x y : terms, reg_fvarlift1 x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros s z H0.
pattern z in |- *; apply case_benv with (var 0) (lift s).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_bvar with 0.
2: assumption.
pattern y' in |- *; apply case_blift with s.
2: assumption.
intros s' H3; exists (var 0); auto 6.
(* 0 SL*B||SL* 0 *)
(* 0[||s'] SL* 0 *)
Save commut_fvarlift1.
Hint Resolve commut_fvarlift1.

Goal forall x y : terms, reg_fvarlift2 x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros s t z H0.
pattern z in |- *; apply case_benv with (var 0) (comp (lift s) t).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_bvar with 0.
2: assumption.
pattern y' in |- *; apply case_bcomp with (lift s) t.
2: assumption.
intros z' t' H3 H4; pattern z' in |- *; apply case_blift with s.
2: assumption.
intros s' H5; exists (env (var 0) t'); auto 6.
(* 0[t] SL*B||SL* 0[t'] *)
(* 0[||s'ot'] SL* 0[t'] *)
Save commut_fvarlift2.
Hint Resolve commut_fvarlift2.

Goal forall x y : terms, reg_rvarcons x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros n a s z H0.
pattern z in |- *; apply case_benv with (var (S n)) (cons a s).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_bvar with (S n).
2: assumption.
pattern y' in |- *; apply case_bcons with a s.
2: assumption.
intros a' s' H3 H4; exists (env (var n) s'); auto 6.
(* n[s] SL*B||SL* n[s'] *)
(* n+1[a'.s'] SL* n[s'] *)
Save commut_rvarcons.
Hint Resolve commut_rvarcons.

Goal forall x y : terms, reg_rvarlift1 x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros n s z H0.
pattern z in |- *; apply case_benv with (var (S n)) (lift s).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_bvar with (S n).
2: assumption.
pattern y' in |- *; apply case_blift with s.
2: assumption.
intros s' H3; exists (env (var n) (comp s' shift)); auto 6.
(* n[so|] SL*B||SL* n[s'o|] *)
(* n+1[||s'] SL* n[s'o|] *)
Save commut_rvarlift1.
Hint Resolve commut_rvarlift1.

Goal forall x y : terms, reg_rvarlift2 x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros n s t z H0.
pattern z in |- *; apply case_benv with (var (S n)) (comp (lift s) t).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_bvar with (S n).
2: assumption.
pattern y' in |- *; apply case_bcomp with (lift s) t.
2: assumption.
intros z' t' H3 H4; pattern z' in |- *; apply case_blift with s.
2: assumption.
intros s' H5; exists (env (var n) (comp s' (comp shift t'))); auto 6.
(* n[so(|ot)] SL*B||SL* n[s'o(|ot')] *)
(* n+1[||s'ot'] SL* n[s'o(|ot')] *)
Save commut_rvarlift2.
Hint Resolve commut_rvarlift2.

Goal forall x y : sub_explicits, reg_assenv x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros s t u z H0.
pattern z in |- *; apply case_bcomp with (comp s t) u.
2: assumption.
intros x' u' H1 H2; pattern x' in |- *; apply case_bcomp with s t.
2: assumption.
intros s' t' H3 H4; exists (comp s' (comp t' u')); auto 6.
(* so(tou) SL*B||SL* s'o(t'ou') *)
(*  (s'ot')ou' SL* s'o(t'ou') *)
Save commut_assenv.
Hint Resolve commut_assenv.

Goal forall x y : sub_explicits, reg_mapenv x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros a s t z H0.
pattern z in |- *; apply case_bcomp with (cons a s) t.
2: assumption.
intros x' t' H1 H2; pattern x' in |- *; apply case_bcons with a s.
2: assumption.
intros a' s' H3 H4; exists (cons (env a' t') (comp s' t')); auto 6.
(* a[t].(sot) SL*B||SL a'[t'].(s'ot') *)
(* (a'.s')ot' SL* a'[t'].(s'ot') *)
Save commut_mapenv.
Hint Resolve commut_mapenv.

Goal forall x y : sub_explicits, reg_shiftcons x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros a s z H0.
pattern z in |- *; apply case_bcomp with shift (cons a s).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_bshift.
2: assumption.
pattern y' in |- *; apply case_bcons with a s.
2: assumption.
intros a' s' H3 H4; exists s'; auto 6.
(* s SL*B||SL* s' *)
(* shift o(a'.s') SL* s' *)
Save commut_shiftcons.
Hint Resolve commut_shiftcons.

Goal forall x y : sub_explicits, reg_shiftlift1 x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros s z H0.
pattern z in |- *; apply case_bcomp with shift (lift s).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_bshift.
2: assumption.
pattern y' in |- *; apply case_blift with s.
2: assumption.
intros s' H3; exists (comp s' shift); auto 6.
(* so| SL*B||SL* s'o| *)
(* |o(|| s') SL* s'o| *)
Save commut_shiftlift1.
Hint Resolve commut_shiftlift1.

Goal forall x y : sub_explicits, reg_shiftlift2 x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros s t z H0.
pattern z in |- *; apply case_bcomp with shift (comp (lift s) t).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_bshift.
2: assumption.
pattern y' in |- *; apply case_bcomp with (lift s) t.
2: assumption.
intros z' t' H3 H4; pattern z' in |- *; apply case_blift with s.
2: assumption.
intros s' H5; exists (comp s' (comp shift t')); auto 6.
(* so(|ot) SL*B||SL* s'o(|ot') *)
(* (|| s')ot' SL* s'o(|ot') *)
Save commut_shiftlift2.
Hint Resolve commut_shiftlift2.

Goal forall x y : sub_explicits, reg_lift1 x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros s t z H0.
pattern z in |- *; apply case_bcomp with (lift s) (lift t).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_blift with s.
2: assumption.
intros s' H3; pattern y' in |- *; apply case_blift with t.
2: assumption.
intros t' H4; exists (lift (comp s' t')); auto 6.
(* ||(sot) SL*B||SL* ||(s'ot') *)
(* ||s' o ||t' SL* ||(s'ot') *)
Save commut_lift1.
Hint Resolve commut_lift1.

Goal forall x y : sub_explicits, reg_lift2 x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros s t u z H0.
pattern z in |- *; apply case_bcomp with (lift s) (comp (lift t) u).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_blift with s.
2: assumption.
intros s' H3; pattern y' in |- *; apply case_bcomp with (lift t) u.
2: assumption.
intros z' u' H4 H5; pattern z' in |- *; apply case_blift with t.
2: assumption.
intros t' H6; exists (comp (lift (comp s' t')) u'); auto 6.
(* ||(sot)ou SL*B||SL* ||(s'ot')ou' *)
(* ||s'o(||t'ou') SL* ||(s'ot')ou' *)
Save commut_lift2.
Hint Resolve commut_lift2.

Goal forall x y : sub_explicits, reg_liftenv x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros a s t z H0.
pattern z in |- *; apply case_bcomp with (lift s) (cons a t).
2: assumption.
intros x' y' H1 H2; pattern x' in |- *; apply case_blift with s.
2: assumption.
intros s' H3; pattern y' in |- *; apply case_bcons with a t.
2: assumption.
intros a' t' H4 H5; exists (cons a' (comp s' t')); auto 6.
(* a.(sot) SL*B||SL* a'.(s'ot') *)
(* ||s'o(a'.t') SL* a'.(s'ot') *)
Save commut_liftenv.
Hint Resolve commut_liftenv.

Goal forall x y : sub_explicits, reg_idl x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros s z H0.
pattern z in |- *; apply case_bcomp with id s.
2: assumption.
intros x' s' H1 H2; pattern x' in |- *; apply case_bid.
2: assumption.
exists s'; auto 6.
(* s SL*B||SL* s' *)
(* idos' SL* s' *)
Save commut_idl.
Hint Resolve commut_idl.

Goal forall x y : sub_explicits, reg_idr x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros s z H0.
pattern z in |- *; apply case_bcomp with s id.
2: assumption.
intros s' x' H1 H2; pattern x' in |- *; apply case_bid.
2: assumption.
exists s'; auto 6.
(* s SL*B||SL* s' *)
(* s'oid SL* s' *)
Save commut_idr.
Hint Resolve commut_idr.

Goal forall x y : sub_explicits, reg_liftid x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros z H0.
pattern z in |- *; apply case_blift with id.
2: assumption.
intros x' H1; pattern x' in |- *; apply case_bid.
2: assumption.
exists id; auto 6.
(* id SL*B||SL* id *)
(* ||id SL* id *)
Save commut_liftid.
Hint Resolve commut_liftid.

Goal forall x y : terms, reg_id x y -> e_diag1 _ x y.
simple induction 1; red in |- *; intros a z H0.
pattern z in |- *; apply case_benv with a id.
2: assumption.
intros a' x' H1 H2; pattern x' in |- *; apply case_bid.
2: assumption.
exists a'; auto 6.
(* a SLB||SL* a' *)
(* a'[id] SL* a' *)
Save commut_id.
Hint Resolve commut_id.

Goal forall (b : wsort) (x y : TS b), e_systemSL _ x y -> e_diag1 _ x y.
simple induction 1; intros; auto.
Save commut_systemSL.

(* lemmes techniques *)

Goal
forall (P : terms -> Prop) (a : terms),
(forall a' : terms, e_relSLstar _ a a' -> P (lambda a')) ->
forall M N : terms, e_relSLstar _ N M -> N = lambda a -> P M.
intros P a H M N H0; generalize a H; elim H0.
intros x a0 H1 H2; rewrite H2; apply (H1 a0); red in |- *; apply star_refl.
intros x y z H1 H2 H3 a0 H4 H5; generalize H1; rewrite H5; intro H6.
cut (y = y).
2: trivial.
pattern y at 2 in |- *; apply case_SLlambda with a0.
2: assumption.
intros a0' H7 H8; apply (H3 a0').
intros a' H9; apply H4; red in |- *; apply star_trans1 with a0'; assumption.
assumption.
Save case_SLstar_lambda'.

Goal
forall (P : terms -> Prop) (a : terms),
(forall a' : terms, e_relSLstar _ a a' -> P (lambda a')) ->
forall M : terms, e_relSLstar _ (lambda a) M -> P M.
intros; pattern M in |- *; apply case_SLstar_lambda' with a (lambda a);
 auto 6.
Save case_SLstar_lambda.

Goal
forall (P : terms -> Prop) (a : terms),
(forall a' : terms, e_slstar_bp_slstar _ a a' -> P (lambda a')) ->
forall M : terms, e_slstar_bp_slstar _ (lambda a) M -> P M.
intros P a H M H0.
elim
 (comp_case terms (e_relSLstar wt)
    (explicit_comp_rel _ (e_beta_par wt) (e_relSLstar wt))
    (lambda a) M H0).
intros x H1; elim H1; intros H2.
pattern x in |- *; apply case_SLstar_lambda with a.
2: assumption.
intros a' H3 H4.
elim (comp_case terms (e_beta_par wt) (e_relSLstar wt) (lambda a') M H4).
intros y H5; elim H5; intros H6.
pattern y in |- *; apply case_blambda with a'.
2: assumption.
intros a'' H7 H8.
pattern M in |- *; apply case_SLstar_lambda with a''.
2: assumption.
intros a_ H9; apply H.
red in |- *; apply comp_2rel with a'.
assumption.
apply comp_2rel with a''; assumption.
Save case_slbpsl_lambda.

Goal forall a a' : terms, e_diag1 _ (lambda a) (lambda a') -> e_diag1 _ a a'.
red in |- *; intros a a' H z H0.
elim (H (lambda z)).
2: apply lambda_bpar; assumption.
intros u1 H1; elim H1; intros H2 H3.
cut (u1 = u1).
2: trivial.
pattern u1 at 1 in |- *; apply case_SLstar_lambda with z.
2: assumption.
intros z' H4; pattern u1 in |- *; apply case_slbpsl_lambda with a'.
2: assumption.
intros a'' H5 H6; exists a''; split.
assumption.
elim (proj_lambda z' a'' H6); assumption.
Save diag1_lambda.

Theorem commut :
 forall (b : wsort) (x y : TS b), e_relSL _ x y -> e_diag1 _ x y.
simple induction 1; intros.
(* regles de reecriture *)
apply commut_systemSL; assumption.
(* contexte app droit *)
red in |- *; intros z H2; generalize H0 H1.
pattern z in |- *; apply case_bapp with a b0.
3: assumption.
 (* regle B||: app *)
intros a'' b0'' H3 H4 H5 H6.
elim (H6 a'' H3); intros a_ H7; elim H7; intros H8 H9.
exists (app a_ b0''); auto.
 (* regle B||: beta *)
intros a1 a1'' b0'' H3 H4 H5; rewrite H3.
intro H6; pattern a' in |- *; apply case_SLlambda with a1.
2: assumption.
intros a1' H7 H8.
elim (diag1_lambda a1 a1' H8 a1'' H4); intros a_ H9; elim H9; intros H10 H11.
exists (env a_ (cons b0'' id)); auto.
(* contexte app gauche *)
red in |- *; intros z H2; pattern z in |- *; apply case_bapp with a b0.
3: assumption.
 (* regle B||: app *)
intros a'' b0'' H3 H4.
elim (H1 b0'' H4); intros b0_ H5; elim H5; intros H6 H7.
exists (app a'' b0_); auto.
 (* regle B||: beta *)
intros a1 a1'' b0'' H3 H4 H5; rewrite H3.
elim (H1 b0'' H5); intros b0_ H6; elim H6; intros H7 H8.
exists (env a1'' (cons b0_ id)); auto.
(* contexte lambda *)
red in |- *; intros z H2.
pattern z in |- *; apply case_blambda with a.
2: assumption.
intros a'' H3.
elim (H1 a'' H3); intros a_ H4; elim H4; intros H5 H6.
exists (lambda a_); auto.
(* contexte env droit *)
red in |- *; intros z H2.
pattern z in |- *; apply case_benv with a s.
2: assumption.
intros a'' s'' H3 H4.
elim (H1 a'' H3); intros a_ H5; elim H5; intros H6 H7.
exists (env a_ s''); auto.
(* contexte env gauche *)
red in |- *; intros z H2.
pattern z in |- *; apply case_benv with a s.
2: assumption.
intros a'' s'' H3 H4.
elim (H1 s'' H4); intros s_ H5; elim H5; intros H6 H7.
exists (env a'' s_); auto.
(* contexte cons droit *)
red in |- *; intros z H2.
pattern z in |- *; apply case_bcons with a s.
2: assumption.
intros a'' s'' H3 H4.
elim (H1 a'' H3); intros a_ H5; elim H5; intros H6 H7.
exists (cons a_ s''); auto.
(* contexte cons gauche *)
red in |- *; intros z H2.
pattern z in |- *; apply case_bcons with a s.
2: assumption.
intros a'' s'' H3 H4.
elim (H1 s'' H4); intros s_ H5; elim H5; intros H6 H7.
exists (cons a'' s_); auto.
(* contexte comp droit *)
red in |- *; intros z H2.
pattern z in |- *; apply case_bcomp with s t.
2: assumption.
intros s'' t'' H3 H4.
elim (H1 s'' H3); intros s_ H5; elim H5; intros H6 H7.
exists (comp s_ t''); auto.
(* contexte comp gauche *)
red in |- *; intros z H2.
pattern z in |- *; apply case_bcomp with s t.
2: assumption.
intros s'' t'' H3 H4.
elim (H1 t'' H4); intros t_ H5; elim H5; intros H6 H7.
exists (comp s'' t_); auto.
(* contexte lift *)
red in |- *; intros z H2.
pattern z in |- *; apply case_blift with s.
2: assumption.
intros s'' H3.
elim (H1 s'' H3); intros s_ H4; elim H4; intros H5 H6.
exists (lift s_); auto.
Qed.

(***************************************************)
(*    SL verifie le diagramme ci-dessus            *)
(***************************************************)

Theorem commutation :
 forall (b : wsort) (x y z : TS b),
 e_relSL _ x y ->
 e_beta_par _ x z ->
 exists u : TS b, e_relSLstar _ z u /\ e_slstar_bp_slstar _ y u.
intros b x y z H H0; apply Ex_PQ; generalize z H0.
change (e_diag1 _ x y) in |- *.
apply commut; assumption.
Qed.


(* This file constructs a notion of N-ary parallel composition for IPDL protocols, rather than only binary. We then lift
our reasoning to be about N-ary composition (with prefix 'pars').
*)

From mathcomp Require Import ssreflect ssrbool ssrnat eqtype ssrfun seq tuple fintype.
From mathcomp Require Import choice path bigop.
Require Import FunctionalExtensionality Classes.Equivalence.
Require Import Lib.SeqOps.
Require Import Lib.Base Ipdl.Exp Lib.TupleLems Lib.setoid_bigop.
Require Import Lib.Set Core.

Definition pars_def {C} (r : list (@ipdl C)) : ipdl := foldr Par (prot0) r.

Definition pars {C} r := (nosimpl (@pars_def C r)).

Notation "[pars xs ]" := (pars xs) (format "[pars  xs ]").
Notation "[|| x1 ]" := (pars (x1 :: [::]))
  (at level 0, format "[||  x1 ]") : seq_scope.

Notation "[|| x1 ; x2 ; .. ; xn ]" := (pars (x1 :: x2 :: .. [:: xn] ..))
  (at level 0, format "[||  '[' x1 ; '/' x2 ; '/' .. ; '/' xn ']' ]"
  ) : ipdl_scope.

Arguments pars : simpl never.

Section Pars.
  Context {chan : Type -> Type}.
  Local Notation EqProt := (@EqProt chan).

Lemma pars_cons r rs :
  EqProt (pars (r :: rs)) (r ||| pars rs).
  rewrite //=.
Qed.

Lemma pars_prot0 (rs : seq (ipdl)) :
  EqProt (pars (prot0 :: rs)) (pars rs).
  rewrite pars_cons -eq_0par //=.
Qed.

Lemma pars_cons_cong r1 r2 rs1 rs2 :
  EqProt r1 r2 ->
  EqProt (pars rs1) (pars rs2) ->
  EqProt (pars (r1 :: rs1)) (pars (r2 :: rs2)).
  intros; rewrite !pars_cons.
  apply EqCong; done.
Qed.

Lemma pars_rcons rs r :
  EqProt (pars rs ||| r) (pars (rcons rs r)).
  induction rs.
  rewrite //=.
  rewrite EqCompComm; reflexivity.
  rewrite //= !pars_cons.
  rewrite -IHrs.
  rewrite EqCompAssoc.
  reflexivity.
Qed.

Lemma pars_nil : @pars chan nil = prot0.
  rewrite /pars //=.
Qed.

Lemma pars_cat rs1 rs2 :
  EqProt (pars (rs1 ++ rs2)) (pars rs1 ||| pars rs2).
  move:rs2; induction rs1; rewrite //=; intro.
  rewrite pars_nil -eq_0par //=.
  rewrite !pars_cons.
  rewrite IHrs1 EqCompAssoc; reflexivity.
Qed.

Lemma pars1 r : EqProt (pars [:: r]) r.
  rewrite /pars //= -eq_par0 //=.
Qed.

Lemma pars_pars rs rs' : EqProt (pars (pars rs :: rs')) (pars (rs ++ rs')).
  rewrite pars_cons.
  rewrite pars_cat.
  reflexivity.
Qed.

  Lemma pars2 r1 r2 :
    EqProt (pars [:: r1; r2]) (r1 ||| r2).
    rewrite !pars_cons /pars -eq_par0 //=.
  Qed.

Lemma Perm_pars (xs ys : seq ipdl) :
  Permutation.Permutation xs ys ->
  EqProt (pars xs) (pars ys).
  elim.
  reflexivity.
  intros.
  rewrite !pars_cons //= H0; reflexivity.
  intros.
  rewrite !pars_cons //= EqCompAssoc (EqCompComm y) -EqCompAssoc; reflexivity.
  intros.
  rewrite (H0); done.
Qed.

   Lemma pars_split (n : nat) (ps : seq ipdl) :
     EqProt (pars ps) (pars (take n ps) ||| pars (drop n ps)).
    rewrite -pars_cat.
    rewrite cat_take_drop //=.
   Qed.

   Lemma par_in_pars r1 r2 rs :
     EqProt (pars ((r1 ||| r2) :: rs))
                (pars (r1 :: r2 :: rs)).
     rewrite !pars_cons EqCompAssoc //=.
   Qed.

    Lemma par_in_pars2 r rs r1 r2 :
        EqProt (pars (r :: (r1 ||| r2) :: rs))
                    (pars (r :: r1 :: r2 :: rs)).
        rewrite !pars_cons.
        apply EqCong; rewrite //=.
        rewrite EqCompAssoc; done.
    Qed.

    Lemma par_in_pars3 r r' rs r1 r2 :
        EqProt (pars (r :: r' :: (r1 ||| r2) :: rs))
                    (pars (r :: r' :: r1 :: r2 :: rs)).
        rewrite !pars_cons.
        apply EqCong; rewrite //=.
        apply EqCong; rewrite //=.
        rewrite EqCompAssoc; done.
    Qed.

    Lemma par_in_pars4 r r' r'' rs r1 r2 :
        EqProt (pars (r :: r' :: r'' :: (r1 ||| r2) :: rs))
                    (pars (r :: r' :: r'' :: r1 :: r2 :: rs)).
        rewrite !pars_cons.
        apply EqCong; rewrite //=.
        apply EqCong; rewrite //=.
        apply EqCong; rewrite //=.
        rewrite EqCompAssoc; done.
    Qed.

Lemma cat_nil_nil {A : eqType} (x y : seq A) :
  x = nil ->
  y = nil ->
  (x ++ y = nil).
  move => -> ->; done.
Qed.

Lemma filter_none {A} (xs : seq A) (P : pred A) :
  all (fun x => ~~ (P x)) xs ->
  filter P xs = nil.
  intros; induction xs; rewrite //=.
  simpl in H; destruct (andP H).
  rewrite (negbTE H0) IHxs //=.
Qed.

Lemma New_in_pars t k rs :
  pars [:: New t k & rs] =p @New chan t (fun x => pars [:: k x & rs]).
  rewrite pars_cons.
  rewrite EqCompNew.
  apply EqCongNew; intros.
  rewrite pars_cons //=.
Qed.

(* Rewriting in pars *)

Inductive list_eqprot : list ipdl -> list ipdl -> Prop :=
  | nil_equiv : list_eqprot nil nil
  | cons_equiv x y s t : EqProt x y -> list_eqprot s t -> list_eqprot (x :: s) (y :: t).

Instance list_eqprot_refl : Reflexive list_eqprot.
   intro.
   induction x.
   constructor.
   constructor.
   done.
   done.
Qed.

Instance list_eqprot_tr : Transitive list_eqprot.
   intro; intros.
   move: z H0; induction H; intros.
   done.
   inversion H1; subst.
   constructor.
   rewrite H //=.
   apply IHlist_eqprot.
   done.
Qed.

Instance list_eqprot_sym : Symmetric list_eqprot.
   intro; intros.
   induction H.
   done.
   constructor.
   rewrite H //=.
   done.
Qed.

Lemma swapE  n k rs :
  EqProt (pars rs) (pars (swap n k rs)).
  apply Perm_pars.
  apply Perm_swap.
Qed.

Lemma pars_fold t1 t2 (a : chan t1) (r : rxn t2)
      (k : t2 -> rxn t1) rs :
  EqProt
         (New t2 (fun c => pars [:: Out a (x <-- Read c ;; k x), Out c r & rs]))
         (pars [:: Out a (x <-- r ;; k x) & rs]).
  etransitivity.
  apply EqCongNew => c.
  rewrite !pars_cons.
  rewrite EqCompAssoc.
  apply EqRefl.
  rewrite -EqCompNew.
  setoid_rewrite EqCompComm at 2.
  rewrite EqFold.
  rewrite -pars_cons //=.
Qed.

(* Tactics for basic permutations / editing *)

Lemma pars_edit' r1 r2 rs :
  EqProt r1 r2 ->
  EqProt (pars (r1 :: rs)) (pars (r2 :: rs)).
  intros.
  rewrite //=.
  apply EqCong.
  done.
  reflexivity.
Qed.

Open Scope bool_scope.

Lemma pars_edit n r1 r2 rs :
  EqProt r1 r2 ->
  List.nth_error rs n = Some r1 ->
  EqProt (pars rs) (pars (lset rs n r2)).
  intros.
  destruct (eqVneq n 0); subst.
  destruct rs.
  rewrite //=.
  simpl in H.
  inversion H0; subst.
  erewrite pars_edit'.
  rewrite lset_0_cons.
  reflexivity.
  done.

  etransitivity.
  apply (swapE 0 n).
  destruct rs; simpl in *.
  destruct n; done.
  erewrite swap0E; last first.
  apply H0.
  done.
  done.
  erewrite pars_edit'; last by apply H.
  etransitivity.
  apply (swapE 0 n).
  simpl.
  have -> : swap 0 n (r2 :: lset rs n.-1 i0) =
           lset (i0 :: rs) n (r2).
  apply nth_error_eqP => j.
  rewrite nth_error_swap //=.
  rewrite nth_error_lset.
  destruct (eqVneq n j); subst.
  rewrite size_lset.
  have: List.nth_error (i0 :: rs) j by rewrite H0.
  rewrite nth_error_size_lt => ->.
  rewrite (negbTE i) //=.
  rewrite -nth_error_size_lt.
  destruct j.
  done.
  simpl.
  simpl in H0.
  rewrite H0 //=.
  rewrite size_lset; last first.
  rewrite -nth_error_size_lt.
  destruct n.
  done.
  simpl in *; rewrite H0 //=.
  destruct n.
  done.
  simpl in *.
  have -> : (n.+1 < (size rs).+1) = (n < size rs) by done.
  rewrite -nth_error_size_lt H0 //=.
  destruct j; simpl.
  rewrite nth_error_lset.
  rewrite eq_refl //=.
  rewrite -nth_error_size_lt H0 //=.
  rewrite nth_error_lset.
  rewrite eqE //= in i1.
  have hnj: n != j by done.
  rewrite (negbTE hnj); done.
  rewrite -nth_error_size_lt H0 //=.
  rewrite -nth_error_size_lt H0 //=.
  reflexivity.
Qed.

Lemma pars_edit_out n m (cm : chan m) (r1 r2 : rxn m) (rs : seq (ipdl)) :
  r1 =r r2 ->
  List.nth_error rs n = Some (Out cm r1) ->
  EqProt (pars rs) (pars (lset rs n (Out cm r2))).
  intros.
  eapply pars_edit.
  apply EqCongReact.
  apply H.
  done.
Qed.

   Lemma inline {t} {t'} (b : chan t') (c : chan t) k r :
     isDet _ r ->
     EqProt (Out b (x <-- Read c ;; k x) ||| Out c r)
                      (Out b (x <-- r ;; k x) ||| Out c r).
     intros.
     rewrite EqCompComm.
     rewrite EqSubst //=.
     rewrite EqCompComm.
     done.
   Qed.

   Lemma pars_inline {t} {t'} (b : chan t') (c : chan t) k r rs :
     isDet _ r ->
     EqProt (pars [:: (Out b (x <-- Read c ;; k x)), Out c r & rs])
                      (pars [:: (Out b (x <-- r ;; k x)), Out c r & rs]).
     intros.
     rewrite !pars_cons.
     rewrite !EqCompAssoc.
     rewrite inline.
     done.
     done.
   Qed.

Lemma pars_mkdep {t1 t2} (c : chan t1) (d : chan t2) r1 r2 rs :
  (forall t (c0 : chan t), can_read c0 r2 -> reads_from c0 r1) ->
  pars [::
          c ::= r1, d ::= r2 & rs] =p
  pars [::
          c ::= (_ <-- Read d ;; r1), d ::= r2 & rs].
  intros.
  symmetry.
  rewrite pars_cons.
  rewrite pars_cons.
  rewrite EqCompAssoc.
  rewrite EqCompComm.
  etransitivity.
  apply EqCongComp.
  rewrite EqCompComm.
  apply EqUnused.
  done.
  symmetry; rewrite !pars_cons.
  symmetry.
  rewrite EqCompComm.
  rewrite EqCompAssoc.
  rewrite (EqCompComm (c ::= r1)).
  done.
Qed.

Lemma pars_unused {t1 t2} (c1 : chan t1) (c2 : chan t2) rs r r' :
  (forall (t : Type) (c0 : chan t), can_read c0 r -> reads_from c0 r') ->
  (pars [:: Out c2 (_ <-- Read c1;; r'), Out c1 r & rs]) =p
  (pars [:: Out c2 (r'), Out c1 r & rs]).
  intros.
  rewrite -pars_mkdep.
  done.
  done.
Qed.

Lemma pars_tr {t1 t2 t3} (c : chan t1) (d : chan t3) k1 (e : chan t2) k2 rs :
  pars [::
          c ::= (x <-- Read d ;; k1 x),
          e ::= (x <-- Read c ;; k2 x) & rs]
  =p
  pars [::
          c ::= (x <-- Read d ;; k1 x),
          e ::= (_ <-- Read d ;; x <-- Read c ;; k2 x) & rs].
  intros; rewrite !pars_cons !EqCompAssoc.
  rewrite EqSubsume; last first.
  done.
Qed.

Lemma new_pars_remove {t1} (r : chan t1 -> rxn t1) rs :
  (a <- new t1 ;; pars [:: Out a (r a) & rs]) =p pars rs.
  intros.
  setoid_rewrite pars_cons.
  rewrite RRemove; done.
Qed.

Lemma generalize_pars_eq2_1 r1 r2 r1' r2' :
  (forall rs, pars [:: r1, r2 & rs] =p pars [:: r1', r2' & rs] ) ->
  forall rs1 rs2,
    @pars chan ([:: r1] ++ rs1 ++ [:: r2] ++ rs2) =p pars (r1' :: rs1 ++ [:: r2'] ++ rs2).
  intros.
  induction rs1.
  simpl.
  rewrite H.
  done.
  simpl.
  rewrite (swapE 0 1); rewrite /swap /lset //=.
  rewrite insert_0.
  rewrite (pars_split 1); simpl.
  rewrite IHrs1.
  rewrite -pars_cat; simpl.
  rewrite (swapE 0 1); rewrite /swap /lset //=.
  rewrite insert_0.
  done.
Qed.

End Pars.

Add Parametric Relation {C} : (list (@ipdl C)) (list_eqprot )
                                       reflexivity proved by (list_eqprot_refl )
                                       symmetry proved by (list_eqprot_sym )
                                           transitivity proved by (list_eqprot_tr ) as list_eqprot_rel.

Close Scope bool_scope.
Require Import Setoid Relation_Definitions Morphisms.

Add Parametric Morphism {C} : (@pars C) with signature
    list_eqprot ==> EqProt as pars_mor.
  intros.
  induction H.
  done.
  rewrite !pars_cons.
  rewrite H.
  rewrite IHlist_eqprot.
  done.
Qed.

Add Parametric Morphism {C} : cons with signature
    (@EqProt C) ==> list_eqprot ==> list_eqprot as cons_mor.
  intros.
  constructor; done.
Qed.

Ltac find_in_pars_rec p rs acc :=
  lazymatch eval simpl in rs with
    | nil => acc
    | (?r :: ?rs') =>
      lazymatch r with
        | context[p] => acc
        | _ => find_in_pars_rec p rs' (S acc)
      end
   end.

Ltac find_in_pars p rs := find_in_pars_rec p rs 0.

Ltac get_idx nxx :=
  let t := type of nxx in
  lazymatch eval simpl in t with
    | nat => constr:(nxx)
    | _ =>
      match goal with
      | [ |- EqProt (pars ?rs) _ ] =>
        let j := find_in_pars nxx rs in j
      end
  end.

Ltac swap_tac nxx mxx :=
  let m___ := get_idx mxx in
  setoid_rewrite (swapE nxx m___) at 1; rewrite /swap /lset /=.

Ltac split_tac n :=
    match goal with
      | [ |- @EqProt  _ _ ] => setoid_rewrite (pars_split n _) at 1; rewrite /= end.

Ltac join_tac :=
    match goal with
      | [ |- EqProt  _ ] => setoid_rewrite <- (pars_cat _ _ ) at 1; rewrite /= end.

Lemma nth_errorP {T} (xs : seq T) x n :
  List.nth_error xs n = Some x ->
  exists xs1 xs2,
    (xs = xs1 ++ [:: x] ++ xs2) /\ (size xs1 = n).
  move: xs x; induction n.
  intros.
  destruct xs.
  done.
  simpl in *.
  inversion H; subst.
  exists nil.
  simpl.
  exists xs; split; done.
  intros.
  destruct xs.
  done.
  simpl in *.
  move/IHn: H => [A [B [h1 h2]]].
  subst.
  exists (t :: A).
  exists B.
  simpl.
  split; done.
Qed.


From SSL_Iris Require Import core.
From iris.program_logic Require Export weakestpre.
From iris.proofmode Require Export tactics coq_tactics ltac_tactics reduction.
From iris.heap_lang Require Import lang notation proofmode.
Require Import common.
From iris_string_ident Require Import ltac2_string_ident.
From Hammer Require Import Hammer.
Context `{!heapG Σ}.
Set Default Proof Using "Type".

Definition sll_append : val :=
rec: "sll_append" "x1" "r" :=
let: "x22" := ! ("r") in
#();;
if: "x1" = #null_loc
then (
#()
)
else (
let: "vx12" := ! ("x1") in
#();;
let: "nxtx12" := ! ("x1" +ₗ #1) in
#();;
"sll_append" "nxtx12" "r";;
let: "y12" := ! ("r") in
#();;
("x1" +ₗ #1) <- ("y12");;
("r") <- ("x1");;
#()
).

Lemma sll_append_spec :
∀ (r : loc) (x2 : loc) (s2 : (list Z)) (_alpha_531 : sll_card) (x1 : loc) (s1 : (list Z)) (_alpha_530 : sll_card),
{{{ (sll x1 s1 _alpha_530) ∗ (sll x2 s2 _alpha_531) ∗ r ↦ #x2 }}}
  sll_append #x1 #r
{{{ RET #(); ∃ (y : loc) (_alpha_532 : sll_card) (s : (list Z)), ⌜(s = (s1 ++ s2))⌝ ∗ (sll y s _alpha_532) ∗ r ↦ #y }}}.
Proof.
iIntros (r x2 s2 _alpha_531 x1 s1 _alpha_530 ϕ) "(iH1 & iH2 & iH3) Post".
iRewriteHyp.
iLöb as "sll_append" forall (r x2 s2 _alpha_531 x1 s1 _alpha_530 ϕ).
ssl_begin.
try rename x2 into x22.
ssl_load.
iRename select ((sll x1 s1 _alpha_530))%I into "iH4".
ssl_if Cond_iH4.

iDestruct (sll_card_0_learn with "iH4") as "[iH4 %iH4_eqn]".
rewrite iH4_eqn; last by safeDispatchPure.
tac_except_post ltac:(rewrite sll_card_0_open).
iDestruct "iH4" as  "(%iH5 & %iH6)".
try wp_pures.
iFindApply.
iExists x22.
iExists _alpha_531.
iExists ([] ++ s2).
ssl_finish.

iDestruct (sll_card_1_learn with "iH4") as "[iH4 %iH4_eqn]".

edestruct iH4_eqn as [_alpha_529x1 ->]; first by safeDispatchPure.
tac_except_post ltac:(rewrite sll_card_1_open).
iDestruct "iH4" as (vx1 s1x1 nxtx1) "((%iH7 & %iH8) & (iH9 & iH10 & iH11 & iH12))".
try rename vx1 into vx12.
ssl_load.
try rename nxtx1 into nxtx12.
ssl_load.
wp_apply ("sll_append" $! (r) (x22) (s2) (_alpha_531) (nxtx12) (s1x1) (_alpha_529x1) with "[$] [$] [$]").

iIntros  "iH16".
iDestruct "iH16" as (y1 _alpha_5321 s3) "(%iH13 & (iH14 & iH15))".
try wp_pures.
try rename y1 into y12.
ssl_load.
ssl_store.
ssl_store.
try wp_pures.
iFindApply.
iExists x1.
iExists (sll_card_1 _alpha_5321 : sll_card).
iExists (([vx12] ++ s1x1) ++ s2).
ssl_finish.
ssl_rewrite_first_heap sll_card_1_open.
pull_out_exist.
iExists vx12.
pull_out_exist.
iExists (s1x1 ++ s2).
pull_out_exist.
iExists y12.
ssl_finish.
Qed.


Require Import PeanoNat.

Require Export SystemFR.NormalizationSing.
Require Export SystemFR.SubtypeList.
Require Export SystemFR.InferMatch.
Require Export SystemFR.CloseLemmas.

Opaque reducible_values.

Lemma open_nmatch_3: forall Γ T2 T3 t t',
  is_erased_type T2 ->
  is_erased_type T3 ->
  wf T2 0 ->
  wf T3 2 ->
  subset (fv T2) (support Γ) ->
  subset (fv T3) (support Γ) ->
  [ Γ ⊨ t ⤳* t' ] ->
  [ Γ ⊫ List_Match t T2 T3 = List_Match t' T2 T3 ].
Proof.
  eauto using open_sub_list_match_scrut, delta_beta_obs_equiv.
Qed.

Lemma nmatch_nil: forall ρ T2 T3,
  valid_interpretation ρ ->
  [ ρ ⊨ List_Match tnil T2 T3 = T2 ].
Proof.
  unfold equivalent_types, List_Match;
    repeat step || simp_red_top_level_goal || simp_red_top_level_hyp || open_none;
    eauto using reducible_values_closed.

  - apply_anywhere equivalent_value_left; steps; eauto with closing values.
  - left; repeat step || simp_red || exists uu;
      eauto using reducible_values_closed;
      eauto using equivalent_refl.
Qed.

Opaque List.

Lemma nmatch_cons: forall ρ t ts T2 T3,
  valid_interpretation ρ ->
  wf t 0 ->
  wf ts 0 ->
  is_erased_term t ->
  is_erased_term ts ->
  pfv t term_var = nil ->
  pfv ts term_var = nil ->
  wf T3 2 ->
  pfv T3 term_var = nil ->
  is_erased_type T3 ->
  [ ρ ⊨ t : T_top ] ->
  [ ρ ⊨ ts : List ] ->
  [ ρ ⊨ List_Match (tcons t ts) T2 T3 = open 0 (open 1 T3 t) ts ].
Proof.
  unfold equivalent_types, List_Match;
    repeat step || simp_red_top_level_goal || simp_red_top_level_hyp || open_none;
    eauto using reducible_values_closed;
    eauto 3 using right_left_equivalence with exfalso values.

  - apply_anywhere tright_equiv; eauto with closing values.
    eapply reducibility_open_equivalent2; try eassumption; steps;
      eauto 3 using equivalent_sym, pair_equiv_1, pair_equiv_2 with closing.

  - right; repeat step.
    apply reducible_expr_value; eauto with values.
    apply reducible_exists with t;
      repeat step || list_utils || rewrite open_list || open_none; eauto with fv wf erased.
    apply reducible_exists with ts;
      repeat step || list_utils || open_none; eauto with fv wf erased.
    apply reducible_type_refine with uu; repeat step || open_none || list_utils;
      eauto with fv wf erased;
      eauto using reducible_value_expr.
    apply reducible_value_expr; repeat step || simp_red_goal.
    apply equivalent_refl; repeat step || list_utils.
Qed.

Opaque List_Match.

Lemma open_nmatch_nil: forall Θ Γ T2 T3,
  [ Θ; Γ ⊨ List_Match tnil T2 T3 = T2 ].
Proof.
  unfold open_equivalent_types; repeat step || rewrite substitute_List_Match;
    eauto with wf;
    eauto using nmatch_nil.
Qed.

Lemma open_nmatch_1: forall Γ T2 T2' T3 t,
  is_erased_type T2 ->
  is_erased_type T3 ->
  wf T2 0 ->
  wf T3 2 ->
  subset (fv T2) (support Γ) ->
  subset (fv T3) (support Γ) ->
  [ Γ ⊨ t ⤳* tnil ] ->
  [ Γ ⊫ T2 = T2' ] ->
  [ Γ ⊫ List_Match t T2 T3 = T2' ].
Proof.
  intros.
  eapply open_equivalent_types_trans; try apply open_nmatch_3;
    eauto using open_equivalent_types_trans, open_nmatch_nil.
Qed.

Lemma open_nmatch_cons: forall Θ Γ T2 T3 t1 t2,
  wf t1 0 ->
  wf t2 0 ->
  wf T3 2 ->
  is_erased_term t1 ->
  is_erased_term t2 ->
  is_erased_type T3 ->
  subset (fv t1) (support Γ) ->
  subset (fv t2) (support Γ) ->
  subset (fv T3) (support Γ) ->
  [ Θ; Γ ⊨ t1 : T_top ] ->
  [ Θ; Γ ⊨ t2 : List ] ->
  [ Θ; Γ ⊨ List_Match (tcons t1 t2) T2 T3 = open 0 (open 1 T3 t1) t2 ].
Proof.
  unfold open_equivalent_types, open_reducible;
    repeat step || rewrite substitute_List_Match || t_substitutions ||
           t_instantiate_sat3 || apply nmatch_cons;
    eauto with wf erased fv.
Qed.

Lemma reducibility_subst_equiv:
  forall ρ v T x t1 t2,
    [ ρ ⊨ v : psubstitute T ((x, t1) :: nil) term_var ]v ->
    valid_interpretation ρ ->
    wf T 0 ->
    is_erased_type T ->
    subset (fv T) (x :: nil) ->
    [ t1 ≡ t2 ] ->
    [ ρ ⊨ v : psubstitute T ((x, t2) :: nil) term_var ]v.
Proof.
  intros; repeat rewrite <- (open_close _ _ _ 0) in * by auto.
  rewrite <- (open_close _ _ _ 0) in H by auto.
  eapply reducibility_open_equivalent; eauto; repeat step;
    eauto with erased wf;
    eauto using fv_close_nil2.
Qed.

Lemma reducibility_subst_equiv2:
  forall ρ T x t1 t2,
    valid_interpretation ρ ->
    wf T 0 ->
    is_erased_type T ->
    subset (fv T) (x :: nil) ->
    [ t1 ≡ t2 ] ->
    [ ρ ⊨ psubstitute T ((x, t1) :: nil) term_var = psubstitute T ((x, t2) :: nil) term_var ].
Proof.
  unfold equivalent_types; steps;
    eauto using reducibility_subst_equiv, equivalent_sym.
Qed.

Lemma subset_diff:
  forall s1 x s2,
    subset s1 (x :: s2) ->
    subset (s1 -- (x :: nil)) s2.
Proof.
  unfold subset; repeat step || instantiate_any || rewrite in_remove in *.
Qed.

Opaque diff.

Lemma subset_diff2:
  forall s1 x s2,
    subset s1 (x :: s2) ->
    subset (s1 -- s2) (x :: nil).
Proof.
  unfold subset; repeat step || instantiate_any || rewrite in_diff in *.
Qed.

Lemma closed_mapping_fv2:
  forall l tag,
    pclosed_mapping l tag ->
    pfv_range l tag = nil.
Proof.
  induction l; repeat step || list_utils.
Qed.

Lemma reducibility_subst_equiv3:
  forall ρ T x l t1 t2,
    valid_interpretation ρ ->
    wf T 0 ->
    is_erased_type T ->
    ~ x ∈ support l ->
    wfs l 0 ->
    erased_terms l ->
    pclosed_mapping l term_var ->
    subset (fv T) (x :: support l) ->
    [ t1 ≡ t2 ] ->
    [ ρ ⊨ psubstitute T ((x, t1) :: l) term_var = psubstitute T ((x, t2) :: l) term_var ].
Proof.
  intros.
  repeat rewrite (substitute_cons4 _ T); steps.
  apply reducibility_subst_equiv2; steps; eauto with wf erased fv.
  eapply subset_transitive; eauto using fv_subst2;
    repeat step || sets || rewrite closed_mapping_fv2 by auto;
    eauto using subset_diff2;
    eauto with sets.
Qed.

Lemma in_support_in_context:
  forall P Γ l x,
    x ∈ support l ->
    satisfies P Γ l ->
    x ∈ pfv_context Γ term_var.
Proof.
  intros; apply fv_context_support; erewrite satisfies_same_support; eauto.
Qed.

Lemma open_instantiate:
  forall Θ Γ x t T T1 T2,
    ~ x ∈ fv T ->
    ~ x ∈ fv_context Γ ->
    wf T1 0 ->
    wf T2 0 ->
    is_erased_type T1 ->
    is_erased_type T2 ->
    subset (fv T1) (x :: support Γ) ->
    subset (fv T2) (x :: support Γ) ->
    [ Θ; Γ ⊨ t : T ] ->
    [ Θ; (x, T) :: Γ ⊨ T1 = T2 ] ->
    [ Θ; Γ ⊨ psubstitute T1 ((x, t) :: nil) term_var = psubstitute T2 ((x, t) :: nil) term_var ].
Proof.
  unfold open_equivalent_types, open_reducible; repeat step || t_instantiate_sat3.
  top_level_unfold reduces_to; steps.
  unshelve epose proof (H8 ρ ((x, v) :: l) _ _);
    repeat step || apply SatCons || (rewrite <- substitute_cons3 by steps);
    eauto with fv wf twf erased.

  eapply equivalent_types_trans; try eapply reducibility_subst_equiv3;
    repeat step || erewrite satisfies_same_support in * by eauto;
    try solve [ equivalent_star ];
    eauto using in_support_in_context;
    eauto with wf erased fv.

  eapply equivalent_types_trans; eauto; apply equivalent_types_sym.

  apply reducibility_subst_equiv3;
    repeat step || erewrite satisfies_same_support in * by eauto;
    try solve [ equivalent_star ];
    eauto using in_support_in_context;
    eauto with wf erased fv.
Qed.

Lemma open_reducible_weaken:
  forall Θ Γ x A t B,
    ~ x ∈ fv t ->
    ~ x ∈ fv B ->
    [ Θ; Γ ⊨ t : B ] ->
    [ Θ; (x, A) :: Γ ⊨ t : B ].
Proof.
  unfold open_reducible; repeat step || step_inversion satisfies || t_substitutions.
Qed.

Lemma open_nmatch_2: forall Γ T2 T3 T3' t t1 t2 x y,
  is_erased_term t1 ->
  is_erased_term t2 ->
  is_erased_type T2 ->
  is_erased_type T3 ->
  is_erased_type T3' ->
  wf t1 0 ->
  wf t2 0 ->
  wf T2 0 ->
  wf T3 2 ->
  wf T3' 0 ->
  subset (fv t1) (support Γ) ->
  subset (fv t2) (support Γ) ->
  subset (fv T2) (support Γ) ->
  subset (fv T3) (support Γ) ->
  subset (fv T3') (support Γ) ->
  ~ x ∈ fv t1 ->
  ~ x ∈ fv t2 ->
  ~ x ∈ fv T3 ->
  ~ x ∈ fv T3' ->
  ~ x ∈ fv_context Γ ->
  ~ y ∈ fv t1 ->
  ~ y ∈ fv t2 ->
  ~ y ∈ fv T3 ->
  ~ y ∈ fv T3' ->
  ~ y ∈ fv_context Γ ->
  x <> y ->
  [ Γ ⊫ t1 : T_top ] ->
  [ Γ ⊫ t2 : List ] ->
  [ Γ ⊨ t ⤳* tcons t1 t2 ] ->
  [ (x, T_singleton T_top t1) :: (y, T_singleton List t2) :: Γ ⊫
    open 0 (open 1 T3 (fvar x term_var)) (fvar y term_var) = T3' ] ->
  [ Γ ⊫ List_Match t T2 T3 = T3' ].
Proof.
  intros.
  eapply open_equivalent_types_trans; try apply open_nmatch_3; try eassumption; steps.
  eapply open_equivalent_types_trans; try apply open_nmatch_cons; steps.
  apply (open_instantiate _ _ _ t1) in H28;
    repeat step || list_utils || apply wf_open || apply is_erased_type_open ||
           rewrite pfv_shift2 in *;
    eauto with fv wf erased;
    eauto using subset_add2.
  - apply (open_instantiate _ _ _ t2) in H28;
      repeat step || list_utils || apply wf_open || apply wf_subst || t_substitutions ||
             apply is_erased_type_open || apply subst_erased_type ||
             rewrite pfv_shift2 in *;
      eauto with fv wf erased;
      eauto using subset_add2;
      eauto using open_reducible_singleton.

    + rewrite (substitute_nothing2 T3') in *; repeat step || rewrite substitute_nothing3 in *.
      rewrite (substitute_nothing2 T3') in *; repeat step || rewrite substitute_nothing3 in *.

    + eapply subset_transitive; eauto using fv_open; repeat step || sets.
      eapply subset_transitive; eauto using fv_open; repeat step || sets;
        eauto using subset_add2.

  - eapply subset_transitive; eauto using fv_open; repeat step || sets.
    eapply subset_transitive; eauto using fv_open; repeat step || sets;
      eauto using subset_add2.
  - apply open_reducible_weaken; repeat step || rewrite pfv_shift2 in *;
      eauto using open_reducible_singleton.
Qed.


Add LoadPath "/users/paulkline/Documents/coqs/protosynth".
Add LoadPath "/home/paul/Documents/coqs/protosynth/cpdt/src" as Cpdt.
Require Import MyShortHand.

Inductive Noun : Set:=
  | VirusChecker
  | PCR.
Theorem eq_dec_Noun : equality Noun.
crush_equal.
Defined.
Hint Resolve eq_dec_Noun : eq_dec_db.
(* Now we define what it is we would like to know about these nouns. *)
Inductive Attribute : Set :=
  | Name : Attribute
  | Hash : Attribute
  | Index : nat -> Attribute
  | Version : Attribute.
Theorem eq_dec_Attribute : equality Attribute.
crush_equal. Defined.
Hint Resolve eq_dec_Attribute : eq_dec_db.
(*We only want to disallow nonsensical combinations, like a (PCR, version),
 hence this relation. *)
Inductive DescriptionR : Noun -> Attribute -> Set :=
  | pcrMR : forall n, DescriptionR PCR (Index n)
  | virusCheckerNameR : DescriptionR VirusChecker Name
  | virusCheckerVersionR : DescriptionR VirusChecker Version.
Theorem eq_dec_DescriptionR {n} {a}:  equality (DescriptionR n a).
crush_equal.
Defined.
Hint Resolve eq_dec_DescriptionR : eq_dec_db.
Hint Resolve eq_dec_DescriptionR.

(* This 'extra step' is done simply so that comparison between descriptors
is 'easy.'It is much more involved to be able to compare indexed types. *)
Inductive Description : Set :=
  | descriptor {n : Noun} {a : Attribute} : DescriptionR n a -> Description.
Theorem eq_dec_Description : equality Description.
crush_equal.
Defined.
Hint Resolve eq_dec_Description : eq_dec_db.

(*This defines what the type of measuring these things should be. *)
Definition measurementDenote (d: Description) :=
match d with
 | descriptor r => (match r with
    | pcrMR n => nat
    | virusCheckerNameR => nat
    | virusCheckerVersionR => nat
    end)
end.

(* Here we begin specificiation of requirements. So not only do I want a particular measurment,
   but I want it to be certain values. *)
Inductive Requirement (d : Description) :=
| requirement : ( (measurementDenote d) -> bool) -> Requirement d.
Require Import FunctionalExtensionality.
Theorem eq_dec_f {A} {B} : forall (a b : (A -> B)), a =<> b.
Proof. intros.
specialize functional_extensionality with a b. intros.
 Admitted.
Hint Resolve eq_dec_f : eq_dec_db.
Theorem eq_dec_Requirement : forall d (x y : Requirement d), x =<> y.
Proof. intros.
destruct d.
destruct d;
crush_equal.
Defined.
Hint Resolve eq_dec_Requirement : eq_dec_db.

(* This begins the defining of what a privacy policy is. First we define a rule.
    A rule regulates the release of a measurement. We could decide to release information if
    some counter condition holds; we could release it for free; we could explicitly never release it;
    or some combination of and-ing and or-ing rules.
    Note that at this point we've allowed for nonsensical release rules like, "never release or release for free",
     "release for free and never release".
    NOTE: If we can't request something twice, what if duplicate occurs in rule req?
          todo: keep all received measurements and check those first for the value *)
Inductive Rule (mything : Description) :=
| rule  {your : Description} : (Requirement your) -> Rule mything
| free : Rule mything
| never : Rule mything.
(*| multiReqAnd : Rule mything ->Rule mything -> Rule mything
| multiReqOr : Rule mything -> Rule mything -> Rule mything.
*)
Theorem eq_dec_Rule : forall x, equality (Rule x).
Proof.

intros. intro_equals.
destruct x.
destruct d;
generalize dependent x0;
induction y;
intro_equals;
destruct x0; try first [decidable |
crush_equal].
(* rest is for and and or case included *)
(*
specialize IHy1 with x0_1.
specialize IHy2 with x0_2.
destruct IHy1.  subst.
destruct IHy2.  subst. decidable.
decidable.  decidable.
specialize IHy1 with x0_1.
specialize IHy2 with x0_2.
destruct IHy1.  subst.
destruct IHy2.  subst. decidable.
crush_equal. decidable.
specialize IHy1 with x0_1.
specialize IHy2 with x0_2.
destruct IHy1.  subst.
destruct IHy2.  subst. decidable.
decidable.  decidable.
specialize IHy1 with x0_1.
specialize IHy2 with x0_2.
destruct IHy1.  subst.
destruct IHy2.  subst. decidable.
crush_equal. decidable.

specialize IHy1 with x0_1.
specialize IHy2 with x0_2.
destruct IHy1.  subst.
destruct IHy2.  subst. decidable.
decidable.  decidable.
specialize IHy1 with x0_1.
specialize IHy2 with x0_2.
destruct IHy1.  subst.
destruct IHy2.  subst. decidable.
crush_equal. decidable.
*)
Defined.
Hint Resolve eq_dec_Rule : eq_dec_db.
(* simply a list of rules. *)
Inductive PrivacyPolicy :=
| EmptyPolicy : PrivacyPolicy
| ConsPolicy {d :Description}:
    Rule d ->
    PrivacyPolicy -> PrivacyPolicy.
Theorem eq_dec_PrivacyPolicy : equality PrivacyPolicy.
intro_equals.
generalize dependent x.
induction y; try
crush_equal + decidable.
intros. destruct x; decidable.
intros. destruct x. decidable.
 specialize IHy with x.
 destruct IHy.  subst. crush_equal.
 crush_equal.
Defined.
Hint Resolve eq_dec_PrivacyPolicy : eq_dec_db.
Inductive Action : Set :=
 | ASend : Action
 | AReceive : Action.
Theorem eq_dec_Action : equality Action.
crush_equal.
Defined.
Hint Resolve eq_dec_Action : eq_dec_db.
(*A RequestItem is used to compose a list of the items and requirements upon
those items in an attestation *)
Inductive RequestItem : Set :=
 | requestItem (d : Description) : (Requirement d) -> RequestItem.
Theorem eq_dec_RequestItem : equality RequestItem.
intro_equals.
generalize dependent x.
induction y;  intros. destruct x; try crush_equal.
Defined.
Hint Resolve eq_dec_RequestItem : eq_dec_db.

Inductive RequestLS : Set :=
 | emptyRequestLS : RequestLS
 | ConsRequestLS : RequestItem -> RequestLS -> RequestLS.
Theorem eq_dec_RequestLS : equality RequestLS.
crush_equal.
Defined.
Hint Resolve eq_dec_RequestLS : eq_dec_db.

Inductive Role : Set :=
 | Appraiser
 | Attester.
Theorem eq_dec_Role : equality Role.
crush_equal.
Defined.