(* 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                               *)
(*                                                                          *)
(****************************************************************************)
(*                              resoudPC_SL.v                               *)
(****************************************************************************)

      (* confluence locale de sigma_lift: resolution des paires critiques *)

Require Import TS.
Require Import sur_les_relations.
Require Import sigma_lift.
Require Import determinePC_SL.

(*** app ***)

Goal
forall a b : terms,
exists u : terms,
  e_relSLstar _ (app (env a id) (env b id)) u /\ e_relSLstar _ (app a b) u.
intros; exists (app a b); split; red in |- *.
apply star_trans1 with (app a (env b id)); auto.
auto.
Save PC_app_id.
Hint Resolve PC_app_id.

Goal
forall (a a' b : terms) (s : sub_explicits),
e_relSL _ a a' ->
exists u : terms,
  e_relSLstar _ (app (env a s) (env b s)) u /\
  e_relSLstar _ (env (app a' b) s) u.
intros; exists (app (env a' s) (env b s)); auto 6.
Save PC1_app_ctxt_l.
Hint Resolve PC1_app_ctxt_l.

Goal
forall (a b b' : terms) (s : sub_explicits),
e_relSL _ b b' ->
exists u : terms,
  e_relSLstar _ (app (env a s) (env b s)) u /\
  e_relSLstar _ (env (app a b') s) u.
intros; exists (app (env a s) (env b' s)); auto 6.
Save PC2_app_ctxt_l.
Hint Resolve PC2_app_ctxt_l.

Goal
forall (a b : terms) (s s' : sub_explicits),
e_relSL _ s s' ->
exists u : terms,
  e_relSLstar _ (app (env a s) (env b s)) u /\
  e_relSLstar _ (env (app a b) s') u.
intros; exists (app (env a s') (env b s')); split; red in |- *.
apply star_trans1 with (app (env a s') (env b s)); auto.
auto.
Save PC_app_ctxt_r.
Hint Resolve PC_app_ctxt_r.

Goal
forall (a b x' : terms) (s : sub_explicits),
e_relSL _ (app a b) x' ->
exists u : terms,
  e_relSLstar _ (app (env a s) (env b s)) u /\ e_relSLstar _ (env x' s) u.
intros a b x' s H; pattern x' in |- *; apply case_SLapp with a b; auto.
Save PC_app_ctxt_l.
Hint Resolve PC_app_ctxt_l.

(*** lambda ***)

Goal
forall a : terms,
exists u : terms,
  e_relSLstar _ (lambda (env a (lift id))) u /\ e_relSLstar _ (lambda a) u.
intro; exists (lambda a); split; red in |- *.
apply star_trans1 with (lambda (env a id)); auto.
auto.
Save PC_lambda_id.
Hint Resolve PC_lambda_id.

Goal
forall (a x' : terms) (s : sub_explicits),
e_relSL _ (lambda a) x' ->
exists u : terms,
  e_relSLstar _ (lambda (env a (lift s))) u /\ e_relSLstar _ (env x' s) u.
intros a x' s H; pattern x' in |- *; apply case_SLlambda with a; intros.
2: assumption.
exists (lambda (env a' (lift s))); auto 6.
Save PC_lambda_ctxt_l.
Hint Resolve PC_lambda_ctxt_l.

Goal
forall (a : terms) (s s' : sub_explicits),
e_relSL _ s s' ->
exists u : terms,
  e_relSLstar _ (lambda (env a (lift s))) u /\
  e_relSLstar _ (env (lambda a) s') u.
intros; exists (lambda (env a (lift s'))); auto 8.
Save PC_lambda_ctxt_r.
Hint Resolve PC_lambda_ctxt_r.

(*** Clos ***)

Goal
forall (a : terms) (s : sub_explicits),
exists u : terms,
  e_relSLstar _ (env a (comp s id)) u /\ e_relSLstar _ (env a s) u.
intros; exists (env a s); split; red in |- *; auto.
Save PC1_clos_id.
Hint Resolve PC1_clos_id.

Goal
forall (a b : terms) (s t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (app a b) (comp s t)) u /\
  e_relSLstar _ (env (app (env a s) (env b s)) t) u.
intros; exists (app (env a (comp s t)) (env b (comp s t))); split;
 red in |- *.
auto.
apply star_trans1 with (app (env (env a s) t) (env (env b s) t)).
auto.
apply star_trans1 with (app (env a (comp s t)) (env (env b s) t)); auto.
Save PC_clos_app.
Hint Resolve PC_clos_app.

Goal
forall (a : terms) (s t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (lambda a) (comp s t)) u /\
  e_relSLstar _ (env (lambda (env a (lift s))) t) u.
intros; exists (lambda (env a (lift (comp s t)))); split; red in |- *.
auto.
apply star_trans1 with (lambda (env (env a (lift s)) (lift t))).
auto.
apply star_trans1 with (lambda (env a (comp (lift s) (lift t)))); auto 6.
Save PC_clos_lambda.
Hint Resolve PC_clos_lambda.

Goal
forall (a : terms) (s s1 t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (env a s1) (comp s t)) u /\
  e_relSLstar _ (env (env a (comp s1 s)) t) u.
intros; exists (env a (comp s1 (comp s t))); split; red in |- *.
auto.
apply star_trans1 with (env a (comp (comp s1 s) t)); auto.
Save PC_clos_clos.
Hint Resolve PC_clos_clos.

Goal
forall (n : nat) (t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var n) (comp shift t)) u /\
  e_relSLstar _ (env (var (S n)) t) u.
intros; exists (env (var (S n)) t); auto 6.
Save PC_clos_varshift1.
Hint Resolve PC_clos_varshift1.

Goal
forall (n : nat) (s t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var n) (comp (comp shift s) t)) u /\
  e_relSLstar _ (env (env (var (S n)) s) t) u.
intros; exists (env (var (S n)) (comp s t)); split; red in |- *.
apply star_trans1 with (env (var n) (comp shift (comp s t))); auto.
auto.
Save PC_clos_varshift2.
Hint Resolve PC_clos_varshift2.

Goal
forall (a : terms) (s t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var 0) (comp (cons a s) t)) u /\
  e_relSLstar _ (env a t) u.
intros; exists (env a t); split; red in |- *.
apply star_trans1 with (env (var 0) (cons (env a t) (comp s t))); auto.
auto.
Save PC_clos_fvarcons.
Hint Resolve PC_clos_fvarcons.

Goal
forall s t : sub_explicits,
exists u : terms,
  e_relSLstar _ (env (var 0) (comp (lift s) t)) u /\
  e_relSLstar _ (env (var 0) t) u.
intros; exists (env (var 0) t); auto 6.
Save PC_clos_fvarlift1.
Hint Resolve PC_clos_fvarlift1.

Goal
forall s1 s2 t : sub_explicits,
exists u : terms,
  e_relSLstar _ (env (var 0) (comp (comp (lift s1) s2) t)) u /\
  e_relSLstar _ (env (env (var 0) s2) t) u.
intros; exists (env (var 0) (comp s2 t)); split; red in |- *.
apply star_trans1 with (env (var 0) (comp (lift s1) (comp s2 t))); auto.
auto.
Save PC_clos_fvarlift2.
Hint Resolve PC_clos_fvarlift2.

Goal
forall (n : nat) (a : terms) (s t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var (S n)) (comp (cons a s) t)) u /\
  e_relSLstar _ (env (env (var n) s) t) u.
intros; exists (env (var n) (comp s t)); split; red in |- *.
apply star_trans1 with (env (var (S n)) (cons (env a t) (comp s t))); auto.
auto.
Save PC_clos_rvarcons.
Hint Resolve PC_clos_rvarcons.

Goal
forall (n : nat) (s t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var (S n)) (comp (lift s) t)) u /\
  e_relSLstar _ (env (env (var n) (comp s shift)) t) u.
intros; exists (env (var n) (comp s (comp shift t))); split; red in |- *.
auto.
apply star_trans1 with (env (var n) (comp (comp s shift) t)); auto.
Save PC_clos_rvarlift1.
Hint Resolve PC_clos_rvarlift1.

Goal
forall (n : nat) (s1 s2 t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var (S n)) (comp (comp (lift s1) s2) t)) u /\
  e_relSLstar _ (env (env (var n) (comp s1 (comp shift s2))) t) u.
intros; exists (env (var n) (comp s1 (comp shift (comp s2 t)))); split;
 red in |- *.
apply star_trans1 with (env (var (S n)) (comp (lift s1) (comp s2 t))); auto.
apply star_trans1 with (env (var n) (comp (comp s1 (comp shift s2)) t)).
auto.
apply star_trans1 with (env (var n) (comp s1 (comp (comp shift s2) t)));
 auto 6.
Save PC_clos_rvarlift2.
Hint Resolve PC_clos_rvarlift2.

Goal
forall (a : terms) (t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env a (comp id t)) u /\ e_relSLstar _ (env a t) u.
intros; exists (env a t); auto 8.
Save PC2_clos_id.
Hint Resolve PC2_clos_id.

Goal
forall (a a' : terms) (s t : sub_explicits),
e_relSL _ a a' ->
exists u : terms,
  e_relSLstar _ (env a (comp s t)) u /\ e_relSLstar _ (env (env a' s) t) u.
intros; exists (env a' (comp s t)); auto 8.
Save PC1_clos_ctxt_l.
Hint Resolve PC1_clos_ctxt_l.

Goal
forall (a : terms) (s s' t : sub_explicits),
e_relSL _ s s' ->
exists u : terms,
  e_relSLstar _ (env a (comp s t)) u /\ e_relSLstar _ (env (env a s') t) u.
intros; exists (env a (comp s' t)); auto 6.
Save PC2_clos_ctxt_l.
Hint Resolve PC2_clos_ctxt_l.

Goal
forall (a : terms) (s t t' : sub_explicits),
e_relSL _ t t' ->
exists u : terms,
  e_relSLstar _ (env a (comp s t)) u /\ e_relSLstar _ (env (env a s) t') u.
intros; exists (env a (comp s t')); auto 6.
Save PC_clos_ctxt_r.
Hint Resolve PC_clos_ctxt_r.

Goal
forall (a x' : terms) (s t : sub_explicits),
e_relSL _ (env a s) x' ->
exists u : terms,
  e_relSLstar _ (env a (comp s t)) u /\ e_relSLstar _ (env x' t) u.
intros a x' s t H; pattern a, s, x' in |- *; apply case_SLenv; auto.
Save PC_clos_ctxt_l.
Hint Resolve PC_clos_ctxt_l.

(*** varshift1 ***)

 (* aucune PC *)

(*** varshift2 ***)

Goal
forall (n : nat) (a : terms) (s : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var (S n)) (cons a s)) u /\
  e_relSLstar _ (env (var n) s) u.
intros; exists (env (var n) s); auto 6.
Save PC_varshift2_shiftcons.
Hint Resolve PC_varshift2_shiftcons.

Goal
forall (n : nat) (s : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var (S n)) (lift s)) u /\
  e_relSLstar _ (env (var n) (comp s shift)) u.
intros; exists (env (var n) (comp s shift)); auto 6.
Save PC_varshift2_shiftlift1.
Hint Resolve PC_varshift2_shiftlift1.

Goal
forall (n : nat) (s t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var (S n)) (comp (lift s) t)) u /\
  e_relSLstar _ (env (var n) (comp s (comp shift t))) u.
intros; exists (env (var n) (comp s (comp shift t))); auto 6.
Save PC_varshift2_shiftlift2.
Hint Resolve PC_varshift2_shiftlift2.

Goal
forall n : nat,
exists u : terms,
  e_relSLstar _ (env (var (S n)) id) u /\ e_relSLstar _ (env (var n) shift) u.
intros; exists (var (S n)); auto 6.
Save PC_varshift2_idr.
Hint Resolve PC_varshift2_idr.

Goal
forall (n : nat) (s s' : sub_explicits),
e_relSL _ s s' ->
exists u : terms,
  e_relSLstar _ (env (var (S n)) s) u /\
  e_relSLstar _ (env (var n) (comp shift s')) u.
intros; exists (env (var (S n)) s'); auto 6.
Save PC_varshift2_ctxt_r.
Hint Resolve PC_varshift2_ctxt_r.

Goal
forall (n : nat) (s x' : sub_explicits),
e_relSL _ (comp shift s) x' ->
exists u : terms,
  e_relSLstar _ (env (var (S n)) s) u /\ e_relSLstar _ (env (var n) x') u.
intros n s x' H; pattern s, x' in |- *; apply case_SLcomp1; auto.
Save PC_varshift2_ctxt_r'.
Hint Resolve PC_varshift2_ctxt_r'.

(*** fvarcons ***)

Goal
forall (a a' : terms) (s : sub_explicits),
e_relSL _ a a' ->
exists u : terms,
  e_relSLstar _ a u /\ e_relSLstar _ (env (var 0) (cons a' s)) u.
intros; exists a'; auto 6.
Save PC1_fvarcons_ctxt_r.
Hint Resolve PC1_fvarcons_ctxt_r.

Goal
forall (a : terms) (s' : sub_explicits),
exists u : terms,
  e_relSLstar _ a u /\ e_relSLstar _ (env (var 0) (cons a s')) u.
intros; exists a; auto 6.
Save PC2_fvarcons_ctxt_r.
Hint Resolve PC2_fvarcons_ctxt_r.

Goal
forall (a : terms) (s x' : sub_explicits),
e_relSL _ (cons a s) x' ->
exists u : terms, e_relSLstar _ a u /\ e_relSLstar _ (env (var 0) x') u.
intros a s x' H; pattern x' in |- *; apply case_SLcons with a s; auto.
Save PC_fvarcons_ctxt_r.

(*** fvarlift1 ***)

Goal
exists u : terms, e_relSLstar _ (var 0) u /\ e_relSLstar _ (env (var 0) id) u.
intros; exists (var 0); auto 6.
Save PC_fvarlift1_liftid.
Hint Resolve PC_fvarlift1_liftid.

Goal
forall s' : sub_explicits,
exists u : terms,
  e_relSLstar _ (var 0) u /\ e_relSLstar _ (env (var 0) (lift s')) u.
intros; exists (var 0); auto 6.
Save PC_fvarlift1_ctxt_r.
Hint Resolve PC_fvarlift1_ctxt_r.

Goal
forall s x' : sub_explicits,
e_relSL _ (lift s) x' ->
exists u : terms, e_relSLstar _ (var 0) u /\ e_relSLstar _ (env (var 0) x') u.
intros s x' H; pattern s, x' in |- *; apply case_SLlift; auto.
Save PC_fvarlift1_ctxt_r'.

(*** fvarlift2 ***)

Goal
forall s t : sub_explicits,
exists u : terms,
  e_relSLstar _ (env (var 0) (lift t)) u /\
  e_relSLstar _ (env (var 0) (lift (comp s t))) u.
intros; exists (var 0); auto 6.
Save PC_fvarlift2_lift1.
Hint Resolve PC_fvarlift2_lift1.

Goal
forall s t v : sub_explicits,
exists u : terms,
  e_relSLstar _ (env (var 0) (comp (lift t) v)) u /\
  e_relSLstar _ (env (var 0) (comp (lift (comp s t)) v)) u.
intros; exists (env (var 0) v); auto 6.
Save PC_fvarlift2_lift2.
Hint Resolve PC_fvarlift2_lift2.

Goal
forall (a : terms) (s t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var 0) (cons a t)) u /\
  e_relSLstar _ (env (var 0) (cons a (comp s t))) u.
intros; exists a; auto 6.
Save PC_fvarlift2_liftenv.
Hint Resolve PC_fvarlift2_liftenv.

Goal
forall s : sub_explicits,
exists u : terms,
  e_relSLstar _ (env (var 0) id) u /\ e_relSLstar _ (env (var 0) (lift s)) u.
exists (var 0); auto 6.
Save PC_fvarlift2_idr.
Hint Resolve PC_fvarlift2_idr.

Goal
forall t : sub_explicits,
exists u : terms,
  e_relSLstar _ (env (var 0) t) u /\
  e_relSLstar _ (env (var 0) (comp id t)) u.
intros; exists (env (var 0) t); auto 7.
Save PC_fvarlift2_liftid.
Hint Resolve PC_fvarlift2_liftid.

Goal
forall s' t : sub_explicits,
exists u : terms,
  e_relSLstar _ (env (var 0) t) u /\
  e_relSLstar _ (env (var 0) (comp (lift s') t)) u.
intros; exists (env (var 0) t); auto 6.
Save PC1_fvarlift2_ctxt_r.
Hint Resolve PC1_fvarlift2_ctxt_r.

Goal
forall s t t' : sub_explicits,
e_relSL _ t t' ->
exists u : terms,
  e_relSLstar _ (env (var 0) t) u /\
  e_relSLstar _ (env (var 0) (comp (lift s) t')) u.
intros; exists (env (var 0) t'); auto 6.
Save PC2_fvarlift2_ctxt_r.
Hint Resolve PC2_fvarlift2_ctxt_r.

Goal
forall s t x' : sub_explicits,
e_relSL _ (comp (lift s) t) x' ->
exists u : terms,
  e_relSLstar _ (env (var 0) t) u /\ e_relSLstar _ (env (var 0) x') u.
intros s t x' H; pattern t, x' in |- *; apply case_SLcomp2 with s; auto.
intros; pattern s, x'0 in |- *; apply case_SLlift; auto.
Save PC_fvarlift2_ctxt_r.

(*** rvarcons ***)

Goal
forall (n : nat) (a' : terms) (s : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var n) s) u /\
  e_relSLstar _ (env (var (S n)) (cons a' s)) u.
intros; exists (env (var n) s); auto 6.
Save PC1_rvarcons_ctxt_r.
Hint Resolve PC1_rvarcons_ctxt_r.

Goal
forall (n : nat) (a : terms) (s s' : sub_explicits),
e_relSL _ s s' ->
exists u : terms,
  e_relSLstar _ (env (var n) s) u /\
  e_relSLstar _ (env (var (S n)) (cons a s')) u.
intros; exists (env (var n) s'); auto 6.
Save PC2_rvarcons_ctxt_r.
Hint Resolve PC2_rvarcons_ctxt_r.

Goal
forall (n : nat) (a : terms) (s x' : sub_explicits),
e_relSL _ (cons a s) x' ->
exists u : terms,
  e_relSLstar _ (env (var n) s) u /\ e_relSLstar _ (env (var (S n)) x') u.
intros n a s x' H; pattern x' in |- *; apply case_SLcons with a s; auto.
Save PC_rvarcons_ctxt_r.

(*** rvarlift1 ***)

Goal
forall n : nat,
exists u : terms,
  e_relSLstar _ (env (var n) (comp id shift)) u /\
  e_relSLstar _ (env (var (S n)) id) u.
intros; exists (var (S n)); split; red in |- *.
apply star_trans1 with (env (var n) shift); auto.
auto.
Save PC_rvarlift1_id.
Hint Resolve PC_rvarlift1_id.

Goal
forall (n : nat) (s s' : sub_explicits),
e_relSL _ s s' ->
exists u : terms,
  e_relSLstar _ (env (var n) (comp s shift)) u /\
  e_relSLstar _ (env (var (S n)) (lift s')) u.
intros; exists (env (var n) (comp s' shift)); auto 6.
Save PC_rvarlift1_ctxt_r.
Hint Resolve PC_rvarlift1_ctxt_r.

Goal
forall (n : nat) (s x' : sub_explicits),
e_relSL _ (lift s) x' ->
exists u : terms,
  e_relSLstar _ (env (var n) (comp s shift)) u /\
  e_relSLstar _ (env (var (S n)) x') u.
intros n s x' H; pattern s, x' in |- *; apply case_SLlift; auto.
Save PC_rvarlift1_ctxt_r'.
Hint Resolve PC_rvarlift1_ctxt_r'.

(*** rvarlift2 ***)

Goal
forall (n : nat) (s t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var n) (comp s (comp shift (lift t)))) u /\
  e_relSLstar _ (env (var (S n)) (lift (comp s t))) u.
intros; exists (env (var n) (comp s (comp t shift))); split; red in |- *.
auto 6.
apply star_trans1 with (env (var n) (comp (comp s t) shift)); auto.
Save PC_rvarlift2_lift1.
Hint Resolve PC_rvarlift2_lift1.

Goal
forall (n : nat) (s t v : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var n) (comp s (comp shift (comp (lift t) v)))) u /\
  e_relSLstar _ (env (var (S n)) (comp (lift (comp s t)) v)) u.
intros; exists (env (var n) (comp s (comp t (comp shift v)))); split;
 red in |- *.
auto 6.
apply star_trans1 with (env (var n) (comp (comp s t) (comp shift v))); auto.
Save PC_rvarlift2_lift2.
Hint Resolve PC_rvarlift2_lift2.

Goal
forall (n : nat) (a : terms) (s t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var n) (comp s (comp shift (cons a t)))) u /\
  e_relSLstar _ (env (var (S n)) (cons a (comp s t))) u.
intros; exists (env (var n) (comp s t)); auto 8.
Save PC_rvarlift2_liftenv.
Hint Resolve PC_rvarlift2_liftenv.

Goal
forall (n : nat) (s : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var n) (comp s (comp shift id))) u /\
  e_relSLstar _ (env (var (S n)) (lift s)) u.
intros; exists (env (var n) (comp s shift)); auto 8.
Save PC_rvarlift2_idr.
Hint Resolve PC_rvarlift2_idr.

Goal
forall (n : nat) (t : sub_explicits),
exists u : terms,
  e_relSLstar _ (env (var n) (comp id (comp shift t))) u /\
  e_relSLstar _ (env (var (S n)) (comp id t)) u.
intros; exists (env (var (S n)) t); split; red in |- *.
apply star_trans1 with (env (var n) (comp shift t)); auto.
auto.
Save PC_rvarlift2_liftid.
Hint Resolve PC_rvarlift2_liftid.

Goal
forall (n : nat) (s s' t : sub_explicits),
e_relSL _ s s' ->
exists u : terms,
  e_relSLstar _ (env (var n) (comp s (comp shift t))) u /\
  e_relSLstar _ (env (var (S n)) (comp (lift s') t)) u.
intros; exists (env (var n) (comp s' (comp shift t))); auto 6.
Save PC1_rvarlift2_ctxt_r.
Hint Resolve PC1_rvarlift2_ctxt_r.

Goal
forall (n : nat) (s t t' : sub_explicits),
e_relSL _ t t' ->
exists u : terms,
  e_relSLstar _ (env (var n) (comp s (comp shift t))) u /\
  e_relSLstar _ (env (var (S n)) (comp (lift s) t')) u.
intros; exists (env (var n) (comp s (comp shift t'))); auto 7.
Save PC2_rvarlift2_ctxt_r.
Hint Resolve PC2_rvarlift2_ctxt_r.

Goal
forall (n : nat) (s t x' : sub_explicits),
e_relSL _ (comp (lift s) t) x' ->
exists u : terms,
  e_relSLstar _ (env (var n) (comp s (comp shift t))) u /\
  e_relSLstar _ (env (var (S n)) x') u.
intros n s t x' H; pattern t, x' in |- *; apply case_SLcomp2 with s; auto.
intros; pattern s, x'0 in |- *; apply case_SLlift; auto.
Save PC_rvarlift2_ctxt_r.
Hint Resolve PC_rvarlift2_ctxt_r.

(*** assenv ***)

Goal
forall s1 s2 t v : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp (comp s1 s2) (comp t v)) u /\
  e_relSLstar _ (comp (comp s1 (comp s2 t)) v) u.
intros; exists (comp s1 (comp s2 (comp t v))); split; red in |- *.
auto.
apply star_trans1 with (comp s1 (comp (comp s2 t) v)); auto.
Save PC_assenv_assenv.
Hint Resolve PC_assenv_assenv.

Goal
forall (a : terms) (s t v : sub_explicits),
exists u : sub_explicits,
  e_relSLstar _ (comp (cons a s) (comp t v)) u /\
  e_relSLstar _ (comp (cons (env a t) (comp s t)) v) u.
intros; exists (cons (env a (comp t v)) (comp s (comp t v))); split;
 red in |- *.
auto.
apply star_trans1 with (cons (env (env a t) v) (comp (comp s t) v)).
auto.
apply star_trans1 with (cons (env a (comp t v)) (comp (comp s t) v)); auto.
Save PC_assenv_mapenv.
Hint Resolve PC_assenv_mapenv.

Goal
forall (a : terms) (s v : sub_explicits),
exists u : sub_explicits,
  e_relSLstar _ (comp shift (comp (cons a s) v)) u /\
  e_relSLstar _ (comp s v) u.
intros; exists (comp s v); split; red in |- *.
apply star_trans1 with (comp shift (cons (env a v) (comp s v))); auto.
auto.
Save PC_assenv_shiftcons.
Hint Resolve PC_assenv_shiftcons.

Goal
forall s v : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp shift (comp (lift s) v)) u /\
  e_relSLstar _ (comp (comp s shift) v) u.
intros; exists (comp s (comp shift v)); auto 6.
Save PC_assenv_shiftlift1.
Hint Resolve PC_assenv_shiftlift1.

Goal
forall s t v : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp shift (comp (comp (lift s) t) v)) u /\
  e_relSLstar _ (comp (comp s (comp shift t)) v) u.
intros; exists (comp s (comp shift (comp t v))); split; red in |- *.
apply star_trans1 with (comp shift (comp (lift s) (comp t v))); auto.
apply star_trans1 with (comp s (comp (comp shift t) v)); auto.
Save PC_assenv_shiftlift2.
Hint Resolve PC_assenv_shiftlift2.

Goal
forall s t v : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp (lift s) (comp (lift t) v)) u /\
  e_relSLstar _ (comp (lift (comp s t)) v) u.
intros; exists (comp (lift (comp s t)) v); auto 6.
Save PC_assenv_lift1.
Hint Resolve PC_assenv_lift1.

Goal
forall s t1 t2 v : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp (lift s) (comp (comp (lift t1) t2) v)) u /\
  e_relSLstar _ (comp (comp (lift (comp s t1)) t2) v) u.
intros; exists (comp (lift (comp s t1)) (comp t2 v)); split; red in |- *.
apply star_trans1 with (comp (lift s) (comp (lift t1) (comp t2 v))); auto.
auto.
Save PC_assenv_lift2.
Hint Resolve PC_assenv_lift2.

Goal
forall (a : terms) (s t v : sub_explicits),
exists u : sub_explicits,
  e_relSLstar _ (comp (lift s) (comp (cons a t) v)) u /\
  e_relSLstar _ (comp (cons a (comp s t)) v) u.
intros; exists (cons (env a v) (comp s (comp t v))); split; red in |- *.
apply star_trans1 with (comp (lift s) (cons (env a v) (comp t v))); auto.
apply star_trans1 with (cons (env a v) (comp (comp s t) v)); auto.
Save PC_assenv_liftenv.
Hint Resolve PC_assenv_liftenv.

Goal
forall t v : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp id (comp t v)) u /\ e_relSLstar _ (comp t v) u.
intros; exists (comp t v); auto 6.
Save PC_assenv_idl.
Hint Resolve PC_assenv_idl.

Goal
forall s v : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp id v)) u /\ e_relSLstar _ (comp s v) u.
intros; exists (comp s v); auto 7.
Save PC1_assenv_idr.
Hint Resolve PC1_assenv_idr.

Goal
forall s t : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp t id)) u /\ e_relSLstar _ (comp s t) u.
intros; exists (comp s t); auto 7.
Save PC2_assenv_idr.
Hint Resolve PC2_assenv_idr.

Goal
forall s s' t v : sub_explicits,
e_relSL _ s s' ->
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp t v)) u /\ e_relSLstar _ (comp (comp s' t) v) u.
intros; exists (comp s' (comp t v)); auto 6.
Save PC_assenv_ctxt_l.
Hint Resolve PC_assenv_ctxt_l.

Goal
forall s t t' v : sub_explicits,
e_relSL _ t t' ->
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp t v)) u /\ e_relSLstar _ (comp (comp s t') v) u.
intros; exists (comp s (comp t' v)); auto 6.
Save PC1_assenv_ctxt_r.
Hint Resolve PC1_assenv_ctxt_r.

Goal
forall s t v v' : sub_explicits,
e_relSL _ v v' ->
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp t v)) u /\ e_relSLstar _ (comp (comp s t) v') u.
intros; exists (comp s (comp t v')); auto 6.
Save PC2_assenv_ctxt_r.
Hint Resolve PC2_assenv_ctxt_r.

Goal
forall s t v x' : sub_explicits,
e_relSL _ (comp s t) x' ->
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp t v)) u /\ e_relSLstar _ (comp x' v) u.
intros s t v x' H; pattern s, t, x' in |- *; apply case_SLcomp; auto.
Save PC_assenv_ctxt_r.
Hint Resolve PC_assenv_ctxt_r.

(*** mapenv ***)

Goal
forall (a : terms) (s : sub_explicits),
exists u : sub_explicits,
  e_relSLstar _ (cons (env a id) (comp s id)) u /\ e_relSLstar _ (cons a s) u.
intros; exists (cons a s); split; red in |- *.
apply star_trans1 with (cons a (comp s id)); auto.
auto.
Save PC_mapenv_idr.
Hint Resolve PC_mapenv_idr.

Goal
forall (a a' : terms) (s t : sub_explicits),
e_relSL _ a a' ->
exists u : sub_explicits,
  e_relSLstar _ (cons (env a t) (comp s t)) u /\
  e_relSLstar _ (comp (cons a' s) t) u.
intros; exists (cons (env a' t) (comp s t)); auto 6.
Save PC1_mapenv_ctxt_l.
Hint Resolve PC1_mapenv_ctxt_l.

Goal
forall (a : terms) (s s' t : sub_explicits),
e_relSL _ s s' ->
exists u : sub_explicits,
  e_relSLstar _ (cons (env a t) (comp s t)) u /\
  e_relSLstar _ (comp (cons a s') t) u.
intros; exists (cons (env a t) (comp s' t)); auto 6.
Save PC2_mapenv_ctxt_l.
Hint Resolve PC2_mapenv_ctxt_l.

Goal
forall (a : terms) (s t t' : sub_explicits),
e_relSL _ t t' ->
exists u : sub_explicits,
  e_relSLstar _ (cons (env a t) (comp s t)) u /\
  e_relSLstar _ (comp (cons a s) t') u.
intros; exists (cons (env a t') (comp s t')); split; red in |- *.
apply star_trans1 with (cons (env a t') (comp s t)); auto.
auto.
Save PC_mapenv_ctxt_r.
Hint Resolve PC_mapenv_ctxt_r.

Goal
forall (a : terms) (s t x' : sub_explicits),
e_relSL _ (cons a s) x' ->
exists u : sub_explicits,
  e_relSLstar _ (cons (env a t) (comp s t)) u /\ e_relSLstar _ (comp x' t) u.
intros a s t x' H; pattern x' in |- *; apply case_SLcons with a s; auto.
Save PC_mapenv_ctxt_l.
Hint Resolve PC_mapenv_ctxt_l.

(*** shiftcons ***)

Goal
forall (a' : terms) (s : sub_explicits),
exists u : sub_explicits,
  e_relSLstar _ s u /\ e_relSLstar _ (comp shift (cons a' s)) u.
intros; exists s; auto 6.
Save PC1_shiftcons_ctxt_r.
Hint Resolve PC1_shiftcons_ctxt_r.

Goal
forall (a : terms) (s s' : sub_explicits),
e_relSL _ s s' ->
exists u : sub_explicits,
  e_relSLstar _ s u /\ e_relSLstar _ (comp shift (cons a s')) u.
intros; exists s'; auto 6.
Save PC2_shiftcons_ctxt_r.
Hint Resolve PC2_shiftcons_ctxt_r.

Goal
forall (a : terms) (s x' : sub_explicits),
e_relSL _ (cons a s) x' ->
exists u : sub_explicits,
  e_relSLstar _ s u /\ e_relSLstar _ (comp shift x') u.
intros a s x' H; pattern x' in |- *; apply case_SLcons with a s; auto.
Save PC_shiftcons_ctxt_r.

(*** shiftlift1 ***)

Goal
exists u : sub_explicits,
  e_relSLstar _ (comp id shift) u /\ e_relSLstar _ (comp shift id) u.
intros; exists shift; auto 6.
Save PC_shiftlift1_liftid.
Hint Resolve PC_shiftlift1_liftid.

Goal
forall s s' : sub_explicits,
e_relSL _ s s' ->
exists u : sub_explicits,
  e_relSLstar _ (comp s shift) u /\ e_relSLstar _ (comp shift (lift s')) u.
intros; exists (comp s' shift); auto 6.
Save PC_shiftlift1_ctxt_r.
Hint Resolve PC_shiftlift1_ctxt_r.

Goal
forall s x' : sub_explicits,
e_relSL _ (lift s) x' ->
exists u : sub_explicits,
  e_relSLstar _ (comp s shift) u /\ e_relSLstar _ (comp shift x') u.
intros s x' H; pattern s, x' in |- *; apply case_SLlift; auto.
Save PC_shiftlift1_ctxt_r'.
Hint Resolve PC_shiftlift1_ctxt_r'.

(*** shiftlift2 ***)

Goal
forall s t : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp shift (lift t))) u /\
  e_relSLstar _ (comp shift (lift (comp s t))) u.
intros; exists (comp s (comp t shift)); split; red in |- *.
auto.
apply star_trans1 with (comp (comp s t) shift); auto.
Save PC_shiftlift2_lift1.
Hint Resolve PC_shiftlift2_lift1.

Goal
forall s t v : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp shift (comp (lift t) v))) u /\
  e_relSLstar _ (comp shift (comp (lift (comp s t)) v)) u.
intros; exists (comp s (comp t (comp shift v))); split; red in |- *.
auto.
apply star_trans1 with (comp (comp s t) (comp shift v)); auto.
Save PC_shiftlift2_lift2.
Hint Resolve PC_shiftlift2_lift2.

Goal
forall (a : terms) (s t : sub_explicits),
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp shift (cons a t))) u /\
  e_relSLstar _ (comp shift (cons a (comp s t))) u.
intros; exists (comp s t); auto 7.
Save PC_shiftlift2_liftenv.
Hint Resolve PC_shiftlift2_liftenv.

Goal
forall t : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp id (comp shift t)) u /\
  e_relSLstar _ (comp shift (comp id t)) u.
intros; exists (comp shift t); auto 7.
Save PC_shiftlift2_liftid.
Hint Resolve PC_shiftlift2_liftid.

Goal
forall s : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp shift id)) u /\
  e_relSLstar _ (comp shift (lift s)) u.
intros; exists (comp s shift); auto 7.
Save PC_shiftlift2_idr.
Hint Resolve PC_shiftlift2_idr.

Goal
forall s s' t : sub_explicits,
e_relSL _ s s' ->
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp shift t)) u /\
  e_relSLstar _ (comp shift (comp (lift s') t)) u.
intros; exists (comp s' (comp shift t)); auto 6.
Save PC1_shiftlift2_ctxt_r.
Hint Resolve PC1_shiftlift2_ctxt_r.

Goal
forall s t t' : sub_explicits,
e_relSL _ t t' ->
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp shift t)) u /\
  e_relSLstar _ (comp shift (comp (lift s) t')) u.
intros; exists (comp s (comp shift t')); auto 6.
Save PC2_shiftlift2_ctxt_r.
Hint Resolve PC2_shiftlift2_ctxt_r.

Goal
forall s t x' : sub_explicits,
e_relSL _ (comp (lift s) t) x' ->
exists u : sub_explicits,
  e_relSLstar _ (comp s (comp shift t)) u /\ e_relSLstar _ (comp shift x') u.
intros s t x' H; pattern t, x' in |- *; apply case_SLcomp2 with s; auto.
intros; pattern s, x'0 in |- *; apply case_SLlift; auto.
Save PC_shiftlift2_ctxt_r.
Hint Resolve PC_shiftlift2_ctxt_r.

(*** lift1 ***)

Goal
forall t : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (lift (comp id t)) u /\ e_relSLstar _ (comp id (lift t)) u.
intros; exists (lift t); auto 7.
Save PC1_lift1_liftid.
Hint Resolve PC1_lift1_liftid.

Goal
forall s : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (lift (comp s id)) u /\ e_relSLstar _ (comp (lift s) id) u.
intros; exists (lift s); auto 7.
Save PC2_lift1_liftid.
Hint Resolve PC2_lift1_liftid.

Goal
forall s s' t : sub_explicits,
e_relSL _ s s' ->
exists u : sub_explicits,
  e_relSLstar _ (lift (comp s t)) u /\
  e_relSLstar _ (comp (lift s') (lift t)) u.
intros; exists (lift (comp s' t)); auto 6.
Save PC_lift1_ctxt_l.
Hint Resolve PC_lift1_ctxt_l.

Goal
forall s t t' : sub_explicits,
e_relSL _ t t' ->
exists u : sub_explicits,
  e_relSLstar _ (lift (comp s t)) u /\
  e_relSLstar _ (comp (lift s) (lift t')) u.
intros; exists (lift (comp s t')); auto 6.
Save PC_lift1_ctxt_r.
Hint Resolve PC_lift1_ctxt_r.

Goal
forall s t x' : sub_explicits,
e_relSL _ (lift s) x' ->
exists u : sub_explicits,
  e_relSLstar _ (lift (comp s t)) u /\ e_relSLstar _ (comp x' (lift t)) u.
intros s t x' H; pattern s, x' in |- *; apply case_SLlift; auto.
Save PC_lift1_ctxt_l'.
Hint Resolve PC_lift1_ctxt_l'.

Goal
forall s t x' : sub_explicits,
e_relSL _ (lift t) x' ->
exists u : sub_explicits,
  e_relSLstar _ (lift (comp s t)) u /\ e_relSLstar _ (comp (lift s) x') u.
intros a t x' H; pattern t, x' in |- *; apply case_SLlift; auto.
Save PC_lift1_ctxt_r'.
Hint Resolve PC_lift1_ctxt_r'.

(*** lift2 ***)

Goal
forall s t v : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp (lift (comp s t)) (lift v)) u /\
  e_relSLstar _ (comp (lift s) (lift (comp t v))) u.
intros; exists (lift (comp s (comp t v))); split; red in |- *.
apply star_trans1 with (lift (comp (comp s t) v)); auto.
auto.
Save PC_lift2_lift1.
Hint Resolve PC_lift2_lift1.

Goal
forall s t1 t2 v : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp (lift (comp s t1)) (comp (lift t2) v)) u /\
  e_relSLstar _ (comp (lift s) (comp (lift (comp t1 t2)) v)) u.
intros; exists (comp (lift (comp s (comp t1 t2))) v); split; red in |- *.
apply star_trans1 with (comp (lift (comp (comp s t1) t2)) v); auto 6.
auto.
Save PC_lift2_lift2.
Hint Resolve PC_lift2_lift2.

Goal
forall (a : terms) (s t v : sub_explicits),
exists u : sub_explicits,
  e_relSLstar _ (comp (lift (comp s t)) (cons a v)) u /\
  e_relSLstar _ (comp (lift s) (cons a (comp t v))) u.
intros; exists (cons a (comp s (comp t v))); split; red in |- *.
apply star_trans1 with (cons a (comp (comp s t) v)); auto.
auto.
Save PC_lift2_liftenv.
Hint Resolve PC_lift2_liftenv.

Goal
forall t v : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp (lift (comp id t)) v) u /\
  e_relSLstar _ (comp id (comp (lift t) v)) u.
intros; exists (comp (lift t) v); auto 8.
Save PC1_lift2_liftid.
Hint Resolve PC1_lift2_liftid.

Goal
forall s v : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp (lift (comp s id)) v) u /\
  e_relSLstar _ (comp (lift s) (comp id v)) u.
intros; exists (comp (lift s) v); auto 8.
Save PC2_lift2_liftid.
Hint Resolve PC2_lift2_liftid.

Goal
forall s t : sub_explicits,
exists u : sub_explicits,
  e_relSLstar _ (comp (lift (comp s t)) id) u /\
  e_relSLstar _ (comp (lift s) (lift t)) u.
intros; exists (lift (comp s t)); auto 6.
Save PC_lift2_idr.
Hint Resolve PC_lift2_idr.

Goal
forall s s' t v : sub_explicits,
e_relSL _ s s' ->
exists u : sub_explicits,
  e_relSLstar _ (comp (lift (comp s t)) v) u /\
  e_relSLstar _ (comp (lift s') (comp (lift t) v)) u.
intros; exists (comp (lift (comp s' t)) v); auto 7.
Save PC_lift2_ctxt_l.
Hint Resolve PC_lift2_ctxt_l.

Goal
forall s t t' v : sub_explicits,
e_relSL _ t t' ->
exists u : sub_explicits,
  e_relSLstar _ (comp (lift (comp s t)) v) u /\
  e_relSLstar _ (comp (lift s) (comp (lift t') v)) u.
intros; exists (comp (lift (comp s t')) v); auto 7.
Save PC1_lift2_ctxt_r.
Hint Resolve PC1_lift2_ctxt_r.

Goal
forall s t v v' : sub_explicits,
e_relSL _ v v' ->
exists u : sub_explicits,
  e_relSLstar _ (comp (lift (comp s t)) v) u /\
  e_relSLstar _ (comp (lift s) (comp (lift t) v')) u.
intros; exists (comp (lift (comp s t)) v'); auto 6.
Save PC2_lift2_ctxt_r.
Hint Resolve PC2_lift2_ctxt_r.

Goal
forall s t v x' : sub_explicits,
e_relSL _ (lift s) x' ->
exists u : sub_explicits,
  e_relSLstar _ (comp (lift (comp s t)) v) u /\
  e_relSLstar _ (comp x' (comp (lift t) v)) u.
intros s t v x' H; pattern s, x' in |- *; apply case_SLlift; auto.
Save PC_lift2_ctxt_l'.
Hint Resolve PC_lift2_ctxt_l'.

Goal
forall s t v x' : sub_explicits,
e_relSL _ (comp (lift t) v) x' ->
exists u : sub_explicits,
  e_relSLstar _ (comp (lift (comp s t)) v) u /\
  e_relSLstar _ (comp (lift s) x') u.
intros s t v x' H; pattern v, x' in |- *; apply case_SLcomp2 with t; auto.
intros; pattern t, x'0 in |- *; apply case_SLlift; auto.
Save PC_lift2_ctxt_r.
Hint Resolve PC_lift2_ctxt_r.

(*** liftenv ***)

Goal
forall (a : terms) (t : sub_explicits),
exists u : sub_explicits,
  e_relSLstar _ (cons a (comp id t)) u /\
  e_relSLstar _ (comp id (cons a t)) u.
intros; exists (cons a t); auto 7.
Save PC_liftenv_liftid.
Hint Resolve PC_liftenv_liftid.

Goal
forall (a : terms) (s s' t : sub_explicits),
e_relSL _ s s' ->
exists u : sub_explicits,
  e_relSLstar _ (cons a (comp s t)) u /\
  e_relSLstar _ (comp (lift s') (cons a t)) u.
intros; exists (cons a (comp s' t)); auto 6.
Save PC_liftenv_ctxt_l.
Hint Resolve PC_liftenv_ctxt_l.

Goal
forall (a a' : terms) (s t : sub_explicits),
e_relSL _ a a' ->
exists u : sub_explicits,
  e_relSLstar _ (cons a (comp s t)) u /\
  e_relSLstar _ (comp (lift s) (cons a' t)) u.
intros; exists (cons a' (comp s t)); auto 6.
Save PC1_liftenv_ctxt_r.
Hint Resolve PC1_liftenv_ctxt_r.

Goal
forall (a : terms) (s t t' : sub_explicits),
e_relSL _ t t' ->
exists u : sub_explicits,
  e_relSLstar _ (cons a (comp s t)) u /\
  e_relSLstar _ (comp (lift s) (cons a t')) u.
intros; exists (cons a (comp s t')); auto 6.
Save PC2_liftenv_ctxt_r.
Hint Resolve PC2_liftenv_ctxt_r.

Goal
forall (a : terms) (s t x' : sub_explicits),
e_relSL _ (lift s) x' ->
exists u : sub_explicits,
  e_relSLstar _ (cons a (comp s t)) u /\ e_relSLstar _ (comp x' (cons a t)) u.
intros a s t x' H; pattern s, x' in |- *; apply case_SLlift; auto.
Save PC_liftenv_ctxt_l'.
Hint Resolve PC_liftenv_ctxt_l'.

Goal
forall (a : terms) (s t x' : sub_explicits),
e_relSL _ (cons a t) x' ->
exists u : sub_explicits,
  e_relSLstar _ (cons a (comp s t)) u /\ e_relSLstar _ (comp (lift s) x') u.
intros a s t x' H; pattern x' in |- *; apply case_SLcons with a t; auto.
Save PC_liftenv_ctxt_r.
Hint Resolve PC_liftenv_ctxt_r.

(*** idl ***)

Goal exists u : sub_explicits, e_relSLstar _ id u /\ e_relSLstar _ id u.
intros; exists id; auto.
Save PC_idl_idr.
Hint Resolve PC_idl_idr.

Goal
forall s s' : sub_explicits,
e_relSL _ s s' ->
exists u : sub_explicits, e_relSLstar _ s u /\ e_relSLstar _ (comp id s') u.
intros; exists s'; auto 6.
Save PC_idl_ctxt_r.
Hint Resolve PC_idl_ctxt_r.

(*** idr ***)

Goal
forall s s' : sub_explicits,
e_relSL _ s s' ->
exists u : sub_explicits, e_relSLstar _ s u /\ e_relSLstar _ (comp s' id) u.
intros; exists s'; auto 6.
Save PC_idr_ctxt_l.
Hint Resolve PC_idr_ctxt_l.

(*** liftid ***)

 (* aucune PC *)

(*** id ***)

Goal
forall a a' : terms,
e_relSL _ a a' ->
exists u : terms, e_relSLstar _ a u /\ e_relSLstar _ (env a' id) u.
intros; exists a'; auto 6.
Save PC_id_ctxt_l.
Hint Resolve PC_id_ctxt_l.


Require Import LibTactics.

Require Import Definitions.
Require Import Infrastructure.
Require Import Lemmas.
Require Import Determinism.
Require Import Soundness.
Require Import Lia.

(** * STATIC *)

Inductive dexp : Set :=
  | de_bvar   : nat -> dexp
  | de_fvar   : var -> dexp
  | de_lit    : nat -> dexp
  | de_unit   : dexp
  | de_anno   : dexp -> typ -> dexp
  | de_app    : dexp -> dexp -> dexp
  | de_abs    : typ -> dexp  -> dexp
  | de_tabs   : dexp -> dexp
  | de_tapp   : dexp -> typ -> dexp
  | de_loc    : nat -> dexp
  | de_ref    : dexp -> dexp
  | de_get    : dexp -> dexp
  | de_set    : dexp -> dexp -> dexp
.

Fixpoint dopen_te_rec (k : nat) (f : typ) (e : dexp) {struct e} : dexp :=
  match e with
  | de_bvar i       => de_bvar i
  | de_fvar x       => de_fvar x
  | de_lit i        => de_lit i
  | de_unit        => de_unit
  | de_loc x      => de_loc x
  | de_app e1 e2    => de_app (dopen_te_rec k f e1) (dopen_te_rec k f e2)
  | de_abs A e1   => de_abs (open_tt_rec k f A) (dopen_te_rec k f e1)
  | de_anno e1 A    => de_anno (dopen_te_rec k f e1) (open_tt_rec k f A)
  | de_tabs e1     => de_tabs (dopen_te_rec (S k) f e1)
  | de_tapp e1 A     => de_tapp (dopen_te_rec k f e1) (open_tt_rec k f A)
  | de_ref e1     => de_ref (dopen_te_rec k f e1)
  | de_get e1     => de_get (dopen_te_rec k f e1)
  | de_set e1 e2     => de_set (dopen_te_rec k f e1) (dopen_te_rec k f e2)
  end.

Fixpoint dopen_ee_rec (k : nat) (f : dexp) (e : dexp) {struct e} : dexp :=
  match e with
  | de_bvar i       => if k == i then f else (de_bvar i)
  | de_fvar x       => de_fvar x
  | de_loc x      => de_loc x
  | de_lit i        => de_lit i
  | de_unit        => de_unit
  | de_app e1 e2    => de_app (dopen_ee_rec k f e1) (dopen_ee_rec k f e2)
  | de_abs A e1   => de_abs A (dopen_ee_rec (S k) f e1)
  | de_anno e1 A    => de_anno (dopen_ee_rec k f e1) A
  | de_tabs e1     => de_tabs (dopen_ee_rec k f e1)
  | de_tapp e1 A     => de_tapp (dopen_ee_rec k f e1) A
  | de_ref e1     => de_ref (dopen_ee_rec k f e1)
  | de_get e1     => de_get (dopen_ee_rec k f e1)
  | de_set e1 e2     => de_set (dopen_ee_rec k f e1) (dopen_ee_rec k f e2)
  end.

Definition dopen_te e T := dopen_te_rec 0 T e.
Definition dopen_ee e1 e2 := dopen_ee_rec 0 e2 e1.

  Notation "t 'dopen_ee_var' x" := (dopen_ee t (de_fvar x)) (at level 67).

  Notation "t 'dopen_te_var' a" := (dopen_te t (t_fvar a)) (at level 67).

Inductive dtyp_static : typ -> Prop :=
  | dtyp_static_nat:
      dtyp_static t_int
  | dtyp_static_fvar: forall i,
      dtyp_static (t_fvar i)
  | dtyp_static_arrow: forall A B,
      dtyp_static A ->
      dtyp_static B ->
      dtyp_static (t_arrow A B)
  | dtyp_static_all: forall L A,
      (forall x, x \notin L -> dtyp_static (A open_tt_var x)) ->
      dtyp_static (t_all A)
  | dtyp_ref: forall A,
      dtyp_static A ->
      dtyp_static (t_ref A)
   | dtyp_static_unit:
      dtyp_static t_unit
.

Inductive dterm_static : exp -> Prop :=
  | dterm_static_var: forall x,
      dterm_static (e_fvar x)
  | dterm_static_nat : forall i,
      dterm_static (e_lit i)
  | dterm_static_unit :
      dterm_static e_unit
  | dterm_static_tabs : forall L V e1,
      (forall x, x \notin L -> dterm_static (e1 open_te_var x)) ->
      (forall X, X \notin L -> dtyp_static (V open_tt_var X)) ->
      dterm_static (e_tabs e1 V)
  | dterm_static_abs : forall L e1 A B,
     dtyp_static A ->
     dtyp_static B ->
      (forall x, x \notin L -> dterm_static (e1 open_ee_var x)) ->
      dterm_static (e_abs A e1 B)
  | dterm_static_app : forall e1 e2,
      dterm_static e1 ->
      dterm_static e2 ->
      dterm_static (e_app e1 e2)
  | dterm_static_tapp : forall e A,
      dterm_static e ->
      dtyp_static A ->
      dterm_static (e_tapp e A)
  | dterm_static_ref : forall e,
      dterm_static e ->
      dterm_static (e_ref e)
  | dterm_static_get : forall e,
      dterm_static e ->
      dterm_static (e_get e)
  | dterm_static_set : forall e1 e2,
      dterm_static e1 ->
      dterm_static e2 ->
      dterm_static (e_set e1 e2)
  | dterm_static_loc : forall i,
      dterm_static (e_loc i)
  | dterm_static_anno : forall e A,
      dterm_static e ->
      dtyp_static A ->
      dterm_static (e_anno e A)
.

Inductive denv_static : env -> Prop :=
  | denv_static_empty : denv_static empty
  | denv_static_typ : forall E x T,
      denv_static E ->
      dtyp_static T ->
      wf_typ E T ->
      x \notin dom E ->
      denv_static ( x ~: T ++ E)
  | denv_static_tvar : forall E x,
      denv_static E ->
      x \notin dom E ->
      denv_static (x ~tvar ++ E)
.

Inductive phi_static : phi -> Prop :=
  | phi_static_typ : forall E,
      (forall l,  l < length (E) ->
      dtyp_static (store_Tlookup l E)) ->
      phi_static (E).

Inductive eq: env -> typ -> typ -> Prop :=
  | eq_int : forall E,
      wf_env E ->
      eq E t_int t_int
  | eq_unit : forall E,
      wf_env E ->
      eq E t_unit t_unit
  | eq_var : forall E x,
      wf_env E ->
      wf_typ E (t_fvar x) ->
      eq E (t_fvar x) (t_fvar x)
  | eq_fun : forall E A1 A2 B1 B2,
      eq E B1 A1 ->
      eq E A2 B2 ->
      eq E (t_arrow A1 A2) (t_arrow B1 B2)
  | eq_all: forall L E A B ,
      (forall x, x \notin L ->
      eq (x ~tvar ++ E) (A open_tt_var x) (B open_tt_var x)) ->
      eq E (t_all A) (t_all B)
  | eq_ref : forall E A B,
      eq E A B ->
      eq E (t_ref A) (t_ref B)
.

Inductive styping : env -> phi -> exp -> dirflag -> typ -> Prop :=
  | styp_var : forall E P x T,
      wf_env E ->
      binds x (bind_typ T) E ->
      styping E P (e_fvar x) Inf T
  | styp_nat : forall E P i,
      wf_env E ->
      styping E P (e_lit i) Inf (t_int)
  | styp_unit : forall E P,
      wf_env E ->
      styping E P e_unit Inf t_unit
  | styp_loc : forall E P l,
       wf_env E ->
      l < length P ->
      wf_typ E (store_Tlookup l P) ->
      styping E P (e_loc l) Inf (t_ref (store_Tlookup l P))
  | styp_app : forall E P e1 e2 A B,
      styping E P e1 Inf (t_arrow A B) ->
      styping E P e2 Chk A ->
      styping E P (e_app e1 e2) Inf B
  | styp_abs : forall L E P A B e,
      (forall x, x \notin L ->
            styping (x ~: A ++ E) P (e open_ee_var x) Chk B) ->
      styping E P (e_abs A e B) Inf (t_arrow A B)
  | styp_anno : forall E P e A,
     styping E P e Chk A ->
     styping E P (e_anno e A) Inf A
  | styp_tabs : forall E P e A L,
      ( forall a , a \notin  L  ->
      styping  ( a ~tvar ++ E) P ( e open_te_var a )  Chk  ( A open_tt_var a )  )  ->
     styping E P (e_tabs e A) Inf (t_all A)
  | styp_tapp : forall E P e A B,
      wf_typ E A ->
     styping E P e Inf (t_all B) ->
     styping E P (e_tapp e A) Inf  (open_tt B A )
  | styp_eq : forall E P e B A,
     eq E A B ->
     styping E P e Inf A ->
     styping E P e Chk B
  | styp_ref : forall E P e A,
     styping E P e Inf A ->
     styping E P (e_ref e) Inf (t_ref A)
  | styp_get : forall E P e A1,
     styping E P e Inf (t_ref A1) ->
     styping E P (e_get e) Inf A1
  | styp_set : forall E P e1 e2 A1,
     styping E P e1 Inf (t_ref A1) ->
     styping E P e2 Chk A1->
     styping E P (e_set e1 e2) Inf t_unit
.

Inductive sstyping : env -> phi -> exp -> dirflag -> typ -> dexp -> Prop :=
  | sstyp_var : forall E P x T,
      wf_env E ->
      binds x (bind_typ T) E ->
      sstyping E P (e_fvar x) Inf T (de_fvar x)
  | sstyp_nat : forall E P i,
      wf_env E ->
      sstyping E P (e_lit i) Inf (t_int) (de_lit i)
  | sstyp_unit : forall E P,
      wf_env E ->
      sstyping E P e_unit Inf t_unit de_unit
  | sstyp_loc : forall E P l,
       wf_env E ->
      l < length P ->
      wf_typ E (store_Tlookup l P) ->
      sstyping E P (e_loc l) Inf (t_ref (store_Tlookup l P)) (de_loc l)
  | sstyp_app : forall E P e1 e2 A B t1 t2,
      sstyping E P e1 Inf (t_arrow A B) t1 ->
      sstyping E P e2 Chk A t2 ->
      sstyping E P (e_app e1 e2) Inf B (de_app t1 t2)
  | sstyp_abs : forall L E P A B e t,
      (forall x, x \notin L ->
            sstyping (x ~: A ++ E) P (e open_ee_var x) Chk B (t dopen_ee_var x)) ->
      sstyping E P (e_abs A e B) Inf (t_arrow A B) (de_abs A t)
  | sstyp_anno : forall E P e A t,
     sstyping E P e Chk A t ->
     sstyping E P (e_anno e A) Inf A (de_anno t A)
  | sstyp_tabs : forall E P e A L t,
      ( forall a , a \notin  L  ->
      sstyping  ( a ~tvar ++ E) P ( e open_te_var a )  Chk  ( A open_tt_var a )   ( t dopen_te_var a ))  ->
     sstyping E P (e_tabs e A) Inf (t_all A) (de_tabs t)
  | sstyp_tapp : forall E P e A B t,
      wf_typ E A ->
     sstyping E P e Inf (t_all B) t ->
     sstyping E P (e_tapp e A) Inf  (open_tt B A ) (de_tapp t A)
  | sstyp_eq : forall E P e B A t,
     eq E A B ->
     sstyping E P e Inf A t ->
     sstyping E P e Chk B t
  | sstyp_ref : forall E P e A t,
     sstyping E P e Inf A t ->
     sstyping E P (e_ref e) Inf (t_ref A) (de_ref t)
  | sstyp_get : forall E P e A1 t,
     sstyping E P e Inf (t_ref A1) t ->
     sstyping E P (e_get e) Inf A1 (de_get t)
  | sstyp_set : forall E P e1 e2 A1 t1 t2,
     sstyping E P e1 Inf (t_ref A1) t1 ->
     sstyping E P e2 Chk A1 t2 ->
     sstyping E P (e_set e1 e2) Inf t_unit (de_set t1 t2)
.

Inductive atyping : env -> phi -> dexp -> dirflag -> typ -> Prop :=
| atyp_var : forall E P x T,
    wf_env E ->
    binds x (bind_typ T) E ->
    atyping E P (de_fvar x) Inf T
| atyp_nat : forall E P i,
    wf_env E ->
    atyping E P (de_lit i)  Inf (t_int)
| atyp_unit : forall E P,
    wf_env E ->
    atyping E P de_unit  Inf t_unit
| atyp_loc : forall E P l,
    wf_env E ->
    l < length P ->
    wf_typ E (store_Tlookup l P) ->
    atyping E P (de_loc l)  Inf  (t_ref (store_Tlookup l P))
| atyp_app : forall E P e1 e2 A B,
    atyping E P e1 Inf (t_arrow A B) ->
    atyping E P e2 Chk  A ->
    atyping E P (de_app e1 e2)  Inf  B
| atyp_abs : forall L E P A B e,
    (forall x, x \notin L ->
            atyping (x ~: A ++ E) P (e dopen_ee_var x) Chk  B) ->
    atyping E P (de_abs A e)  Inf  (t_arrow A B)
| atyp_anno : forall E P e A,
    atyping E P e Chk A ->
    atyping E P (de_anno e A)  Inf  A
| atyp_tabs : forall E P e A L,
    ( forall a , a \notin  L  ->
    atyping  ( a ~tvar ++ E) P ( e dopen_te_var a )  Chk  ( A open_tt_var a )  )  ->
    atyping E P (de_tabs e) Inf (t_all A)
| atyp_tapp : forall E P e A B,
    wf_typ E A ->
    atyping E P e  Inf  (t_all B) ->
    atyping E P (de_tapp e A)  Inf  (open_tt B A )
| atyp_ref : forall E P e A,
    atyping E P e Inf  A ->
    atyping E P (de_ref e) Inf (t_ref A)
| atyp_get : forall E P e A1,
    atyping E P e  Inf (t_ref A1) ->
    atyping E P (de_get e) Inf A1
| atyp_set : forall E P e1 e2 A1,
    atyping E P e1  Inf (t_ref A1) ->
    atyping E P e2 Chk A1->
    atyping E P (de_set e1 e2) Inf t_unit
| atyp_eq : forall E P e A B,
    atyping E P e Inf A ->
    eq E A B ->
    atyping E P e Chk B
.

Inductive aatyping : env -> phi -> dexp -> dirflag -> typ -> exp -> Prop :=
| aatyp_var : forall E P x T,
    wf_env E ->
    binds x (bind_typ T) E ->
    aatyping E P (de_fvar x) Inf T (e_fvar x)
| aatyp_nat : forall E P i,
    wf_env E ->
    aatyping E P (de_lit i)  Inf (t_int) (e_lit i)
| aatyp_unit : forall E P,
    wf_env E ->
    aatyping E P de_unit  Inf  t_unit e_unit
| aatyp_loc : forall E P l,
    wf_env E ->
    l < length P ->
    wf_typ E (store_Tlookup l P) ->
    aatyping E P (de_loc l) Inf (t_ref (store_Tlookup l P)) (e_loc l)
| aatyp_app : forall E P e1 e2 A B t1 t2,
    aatyping E P e1 Inf (t_arrow A B) t1 ->
    aatyping E P e2  Chk A t2 ->
    aatyping E P (de_app e1 e2) Inf B (e_app t1 t2)
| aatyp_abs : forall L E P A B e t,
    (forall x, x \notin L ->
            aatyping (x ~: A ++ E) P (e dopen_ee_var x)  Chk B (t open_ee_var x) ) ->
    aatyping E P (de_abs A e) Inf (t_arrow A B) (e_abs A t B)
| aatyp_anno : forall E P e A t,
    aatyping E P e  Chk A t ->
    aatyping E P (de_anno e A) Inf A (e_anno t A)
| aatyp_tabs : forall E P e A L t,
    ( forall a , a \notin  L  ->
    aatyping  ( a ~tvar ++ E) P ( e dopen_te_var a )   Chk ( A open_tt_var a ) ( t open_te_var a ) )  ->
    aatyping E P (de_tabs e) Inf (t_all A) (e_tabs t A)
| aatyp_tapp : forall E P e A B t,
    wf_typ E A ->
    aatyping E P e Inf (t_all B) t ->
    aatyping E P (de_tapp e A)  Inf (open_tt B A ) (e_tapp t A)
| aatyp_ref : forall E P e A t,
    aatyping E P e Inf A t ->
    aatyping E P (de_ref e) Inf (t_ref A) (e_ref t)
| aatyp_get : forall E P e A1 t,
    aatyping E P e Inf (t_ref A1) t ->
    aatyping E P (de_get e) Inf A1 (e_get t)
| aatyp_set : forall E P e1 e2 A1 t1 t2,
    aatyping E P e1 Inf (t_ref A1) t1 ->
    aatyping E P e2 Chk A1 t2 ->
    aatyping E P (de_set e1 e2) Inf t_unit (e_set t1 t2)
| aatyp_eq : forall E P e A t B,
    aatyping E P e Inf A t ->
    eq E A B ->
    aatyping E P e Chk B t
.

Inductive dstep : conf -> conf -> Prop :=    (* defn step *)
 | dstep_eval : forall mu mu' F e1 e2,
     wellformed F ->
     dstep (e1, mu) ((e2), mu') ->
     dstep ((fill F e1), mu) (( (fill F e2)), mu')
  | dstep_beta : forall (A1:typ) (e:exp) (B1 A2 B2:typ) u t mu,
     sto_ok mu ->
     pvalue u ->
     expr (e_abs A1 e B1) ->
     dstep ((e_app  ( (e_anno  ( (e_abs A1 e B1) )  (t_arrow A2 B2)) )  (e_anno u t)), mu) (((e_anno (e_anno  (open_ee  e (e_anno u A1) )  B1) B2)), mu)
 | dstep_u : forall (u:exp) (A:typ) mu,
     sto_ok mu ->
     pvalue u ->
     ptype mu u A ->
     dstep (u, mu) (( (e_anno u A)), mu)
 | dstep_anno : forall (e:exp) (A:typ) (e':exp) mu mu',
     not(value (e_anno e A)) ->
     dstep (e, mu) (( e'), mu') ->
     dstep ((e_anno e A), mu) (((e_anno e' A)), mu')
 | dstep_annov : forall (A:typ) B u mu,
     sto_ok mu ->
     pvalue u ->
     dstep ((e_anno (e_anno u B) A), mu) ((e_anno u A), mu)
 | dstep_tap : forall (e:exp) (A B C:typ) mu,
     expr (e_anno  (e_tabs e A) (t_all B)) ->
     dstep ((e_tapp (e_anno  (e_tabs e A) (t_all B)) C),mu) (((e_anno (e_anno (open_te e C ) (open_tt  A C )) (open_tt  B C ))),mu)
 | dstep_set : forall l A B u t mu,
     sto_ok mu ->
     pvalue u ->
     principle_type (store_lookup l mu) = B ->
     dstep ((e_set (e_anno (e_loc l)  (t_ref A)) (e_anno u t)), mu) ((e_unit), (replace l (e_anno u B) mu))
 | dstep_new : forall (v:exp) mu,
     sto_ok mu ->
     value v ->
     dstep ((e_ref v), mu) (( (e_loc (length mu))), (mu ++ v::nil))
 | dstep_get : forall (A:typ) l mu,
     sto_ok mu ->
     dstep ((e_get (e_anno (e_loc l) (t_ref A))), mu) (((e_anno (store_lookup l mu) A)), mu)
.

(** Properties for static *)

Hint Constructors aatyping atyping sstyping denv_static dterm_static dtyp_static styping eq dstep: core.

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* eq0;
  unfold open_tt in *; inverts* H0.
  destruct(n0 == n); try solve[inverts* e];
  try solve[inverts* H1].
  -
  inductions B; simpl in *; inverts* eq0;
  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* eq0;
  unfold open_tt in *; inverts* H0;
  destruct(n0 == n); try solve[inverts* e];
  try solve[inverts* H1].
  -
  inductions B; simpl in *; inverts* eq0;
  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* eq0;
  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* eq0;
  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* eq0;
  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* eq0;
  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,
dtyp_static A ->
 wf_typ E A ->
 wf_env E ->
 eq E A A.
Proof.
  introv sta ty ev.
  inductions ty; eauto; try solve[inverts sta].
  -
  inverts* sta.
  -
  inverts sta.
  pick fresh x.
  apply eq_all with (L := union L
  (union L0
     (union (fv_tt A)
        (union (dom E) (fv_tt_env E)))));intros.
  forwards: H2 x0; auto.
  -
  inverts* sta.
Qed.

Lemma eq_right: forall A B E,
dtyp_static A ->
 wf_env E ->
 wf_typ E A ->
 wf_typ E B ->
 A = B ->
 eq E A B.
Proof.
  introv sta ev wf1 wf2 eq.
  inverts* eq.
  apply eq_rel; auto.
Qed.

Lemma sstyping_atyping: forall e1 e2 G P dir A,
  sstyping G P e1 dir A e2 ->
  atyping G P e2 dir A.
Proof.
  introv typ.
  inductions typ; eauto.
Qed.

Lemma aatyping_styping: forall dir e1 e2 G P A,
 aatyping G P e1 dir A e2 ->
 styping G P e2 dir A.
Proof.
  introv typ.
  inductions typ; eauto.
Qed.

Lemma dtyp_static_eq: forall E A B,
    dtyp_static A ->
    dtyp_static B ->
    consist E A B ->
    eq E A B.
Proof.
  introv ta tb con.
  inductions con; eauto; try solve[inverts ta];
  try solve[inverts tb];
  try solve[inverts ta;inverts tb].
  -
  inverts ta; inverts* tb.
  -
  inversions tb. inverts ta.
  pick fresh y and apply eq_all.
  forwards ~ : H3 y.
  -
  inverts ta. inverts* tb.
Qed.

Lemma eq_consist: forall E A B,
    eq E A B ->
    consist E A B.
Proof.
  introv con.
  inductions con; eauto.
Qed.

Lemma dtyp_static_dtype : forall A,
    dtyp_static A ->
    type A.
Proof.
  introv ty. inductions ty; simpls~.
  pick fresh x and apply type_all;eauto.
Qed.

Hint Resolve dtyp_static_dtype : core.

Lemma dterm_static_dterm: forall e,
    dterm_static e ->
    expr e.
Proof.
  introv dm. inductions dm; eauto.
Qed.

Lemma styping_typing : forall E P e dir A,
  styping E P e dir A ->
  typing E P e dir A.
Proof.
    introv typ.
    inductions typ;eauto.
    forwards*: eq_consist H.
Qed.

Lemma dmatch_static_ref : forall A A1,
    pattern_ref A A1 ->
    dtyp_static A ->
    dtyp_static A1 .
Proof.
  introv mat st. inductions mat; simpls~.
Qed.

Lemma dmatch_static_abs : forall A A1,
    pattern_abs A A1 ->
    dtyp_static A ->
    dtyp_static A1 .
Proof.
  introv mat st. inductions mat; simpls~.
Qed.

Lemma dmatch_static_all : forall A A1,
    pattern_all A A1 ->
    dtyp_static A ->
    dtyp_static A1 .
Proof.
  introv mat st. inductions mat; simpls~.
  inverts st.
Qed.

Lemma denv_static_dtyp: forall e x T,
    denv_static e ->
    binds x (bind_typ T) e ->
    dtyp_static T.
Proof.
  introv dm bd. inductions dm; try solve[inverts bd].
  -
  analyze_binds bd.
  inverts* BindsTacVal.
  -
  analyze_binds bd.
Qed.

Lemma static_open: forall e1 u1  x,
 dtyp_static e1 ->
 dtyp_static u1 ->
 type u1 ->
 dtyp_static (subst_tt x u1 e1).
Proof.
  introv ts1 ts2 typ1. gen u1 x.
  inductions ts1; intros;
  simpl; eauto.
  -
  destruct (i == x); eauto.
  -
  pick fresh y and apply dtyp_static_all.
  rewrite subst_tt_open_tt_var; eauto.
Qed.

Definition Dtyping_static_preserve dir T :=
  match dir with
  | Inf => dtyp_static T
  | Chk  => True
  end.

Lemma dtyping_static_preserve : forall E e P dir T,
    typing E P e dir T ->
    denv_static E ->
    dterm_static e ->
    phi_static P ->
    Dtyping_static_preserve dir T.
Proof.
  introv Hty Hen Htm Hpi.
  inductions Hty; auto; unfold Dtyping_static_preserve in *;simpl; auto.
  -
  forwards*: denv_static_dtyp H0.
  -
  inverts Hpi.
  forwards*: H2 l.
  -
  inverts Htm.
  forwards* h1: IHHty1 H2.
  forwards* h3: dmatch_static_abs H. inverts* h3.
  -
  inverts* Htm.
  -
  inverts* Htm.
  -
  inverts* Htm.
  -
  inverts* Htm.
  forwards* h1: IHHty.
  inverts H0; try solve[inverts h1].
  inverts h1.
    pick fresh y.
    rewrite (subst_tt_intro y); eauto.
    forwards*: H1 y.
    forwards*: static_open H0 H4.
  -
  inverts* Htm.
  -
  inverts* Htm.
  forwards* h1: IHHty.
  forwards* h2: dmatch_static_ref h1.
  inverts* h2.
Qed.

Lemma typing_styping : forall E P e dir A,
  dterm_static e ->
  denv_static E ->
  phi_static P ->
  dtyp_static A ->
  typing E P e dir A ->
   styping E P e dir A.
Proof.
  introv es vs ps ts typ.
  lets typ': typ.
  inductions typ;eauto; try solve[inverts es].
  -
    inverts es.
    forwards* h1: dtyping_static_preserve typ1.
    forwards* h2: dmatch_static_abs H.
    inverts* h2.
    forwards*: IHtyp1.
    forwards* h3: dtyping_static_preserve typ2.
    inverts* H; try solve[inverts h1].
  -
    inverts es.
    forwards h1: typing_regular typ'.
    destructs~ h1. inverts H3.
    pick fresh x and apply styp_abs.
    forwards*: H0.
  -
    inverts* es.
  -
    inverts es.
    pick fresh x.
    apply styp_tabs with (L := union L
    (union L0
       (union (fv_te e)
          (union (fv_ee e)
             (union (fv_tt A) (union (dom E) (fv_tt_env E)))))));intros.
    forwards*: H0.
  -
    inverts es.
    forwards* h1: dtyping_static_preserve typ.
    forwards* h2: dmatch_static_all H0.
    inverts* h2.
    forwards*: IHtyp.
    inverts* H0; try solve[inverts h1].
  -
    forwards* h1: dtyping_static_preserve typ.
    forwards*: dtyp_static_eq H.
  -
    inverts* es.
    inverts* ts.
  -
    inverts es.
    forwards* h1: dtyping_static_preserve typ.
    forwards* h2: dmatch_static_ref H.
    inverts* h2.
    forwards*: IHtyp.
    inverts* H; try solve[inverts h1].
  -
    inverts es.
    forwards* h1: dtyping_static_preserve typ1.
    forwards* h2: dmatch_static_ref H.
    inverts* h2.
    forwards*: IHtyp1.
    forwards* h3: dtyping_static_preserve typ2.
    inverts* H; try solve[inverts h1].
Qed.

Lemma  eq_sym: forall E t1 t2,
 eq E t1 t2 ->
 eq E t2 t1.
Proof.
  introv eq.
  inductions eq;intros; try solve[inductions eq0;eauto];eauto.
Qed.

Lemma  eq_static: forall E t1 t2,
 eq E t1 t2 ->
 dtyp_static t1 ->
 dtyp_static t2 .
Proof.
  introv eq sta. gen E t2.
  inductions sta;intros; try solve[inductions eq0;eauto];eauto.
  -
  inverts eq0.
  forwards*:  eq_sym H2.
  -
  inverts eq0.
  pick fresh x and apply dtyp_static_all;eauto.
Qed.

Lemma eq_refl: forall t e,
 wf_env e ->
 wf_typ e t ->
 dtyp_static t ->
 eq e t t.
Proof.
  introv we ev dt. gen e.
  inductions dt;intros;auto; try solve[inverts ev].
  -
    inverts* ev.
  -
  inverts ev.
  pick fresh y and apply eq_all;eauto.
  -
  inverts* ev.
Qed.

Lemma styping_chk: forall E e P A,
denv_static E ->
phi_static P ->
 dterm_static e ->
 styping E P e Inf A ->
 styping E P e Chk A.
Proof.
  introv es ps se typ.
  eapply styp_eq; eauto.
  forwards h2: styping_typing typ.
    forwards h1: dtyping_static_preserve h2; auto.
    unfold Dtyping_static_preserve in *.
    forwards*: eq_refl h1.
Qed.

Lemma fill_chk_chk: forall G e E P B,
 denv_static G ->
 phi_static P ->
 dterm_static e ->
 styping G P (fill E e) Chk B ->
 dtyp_static B ->
 exists A, styping G P e Chk A.
Proof.
  introv es ps te typ st.
  destruct E; unfold fill in *; inverts* typ;
  try solve[inverts* H0].
  - inverts H0.
    forwards h2: styping_typing H5.
    forwards h1: dtyping_static_preserve h2; auto.
    unfold Dtyping_static_preserve in *.
    inverts h1.
    forwards*: styping_chk H5.
  -
    inverts H0.
    forwards*: styping_chk H6.
  -
    inverts H0.
    forwards*: styping_chk H4.
  -
    inverts H0.
    forwards*: styping_chk H5.
Qed.

Lemma fill_static: forall F e,
  dterm_static (fill F e) ->
  dterm_static e.
Proof.
 introv dt.
  destruct F; unfold fill in *; auto;
  try solve[inverts dt; auto].
Qed.

Lemma eq_trans_size: forall E A B C n,
 size_typ A + size_typ B + size_typ C < n ->
 eq E A B ->
 eq E B C ->
 eq E A C.
Proof.
  introv sz eq1 eq2. gen E A B C.
  induction n;intros;
  try solve[lia].
  inductions eq1;eauto.
  -
  inductions eq2;simpl in *;auto.
  forwards: IHn eq2_1 eq1_1. lia.
  forwards: IHn eq1_2 eq2_2. lia.
  auto.
  -
  inductions eq2;simpl in *;auto.
  pick fresh x and apply eq_all.
  forwards h1: H x; auto.
  forwards h2: H1 x; auto.
  forwards: IHn h1 h2.
  rewrite size_open_tt.
  rewrite size_open_tt.
  rewrite size_open_tt.
  lia.
  auto.
  -
  inductions eq2;simpl in *;auto.
  forwards: IHn eq1 eq2. lia.
  auto.
Qed.

Lemma eq_trans: forall E A B C,
 eq E A B ->
 eq E B C ->
 eq E A C.
Proof.
  introv eq1 eq2.
  eapply eq_trans_size ;eauto.
Qed.

Lemma sptype_inf: forall G mu P u A,
 P |== mu ->
 pvalue u ->
 styping G P u Inf A ->
 ptype mu u A.
Proof.
  introv sto pval typ.
  inverts* typ; try solve[inverts* pval].
  inverts sto. inverts H3.
  rewrite H4 in H0.
  forwards*: H5 H0.
  forwards*: sto_ok_value H0 H2.
  forwards*: principle_typ_inf H3.
Qed.

Lemma sprinciple_typ_inf: forall G P u A,
 value u ->
 styping G P u Inf A ->
 principle_type u = A.
Proof.
  introv val typ.
  inverts* val; try solve[inverts* typ].
Qed.

Theorem static_ddstep_dyn_chk : forall e e' B P mu mu',
  P |== mu ->
  phi_static P ->
 dterm_static e ->
 dtyp_static B ->
 styping nil P e Chk B ->
 dstep ( e, mu) ( e', mu') ->
 step (e, mu) ((r_e e'), mu').
Proof.
 introv wel ps ts tys typ red. gen B P.
 inductions red; intros; eauto;
 try solve[forwards*:eq_consist  H1];
 try solve[forwards*: eq_consist H0].
 - forwards h0 :  fill_static ts.
   forwards hh0: fill_chk_chk typ; auto.
   inverts hh0.
   inverts H0.
   forwards h2: styping_typing H2.
   forwards h1: dtyping_static_preserve h2; auto.
   unfold Dtyping_static_preserve in *.
   forwards : eq_static H1; auto.
   eauto.
  -
    inverts typ. inverts H3.
    inverts H9.
    forwards* h1: styping_typing H4.
    inverts H8. inverts H11. inverts H6. inverts H5.
    inverts H4. inverts H8.
    forwards* h2: eq_consist H4.
    forwards* h3: eq_trans H4 H3.
    forwards* h4:eq_consist h3.
    assert(styping empty P (e_anno u A0) Inf A0); eauto.
    forwards* h5: styping_typing H6.
    forwards* h6: eq_trans h3 H10.
    forwards* h7:eq_consist h6.
    forwards*: TypedReduce_progress A0 h1.
    inverts* H7.
    lets red1: H8.
    inverts* H8.
    +
    forwards* h8: sptype_inf H5.
    forwards*: ptype_uniq H17 h8. inverts* H7.
    forwards*: TypedReduce_progress A1 h5.
    inverts* H7.
    lets red2: H8.
    inverts* H8.
    forwards*: ptype_uniq H17 H20. inverts* H7.
    +
    forwards* h8: sptype_inf H5.
    forwards*: ptype_uniq H17 h8. inverts* H7.
  -
    inverts ts.
    inverts typ. inverts* H1.
  - inverts typ. inverts* H2.
    lets typ':H6.
    inverts* H6. inverts* H3.
    inverts* H7.
    forwards*:  sptype_inf H4.
    forwards*: eq_trans H3 H2.
    forwards*: eq_trans H6 H1.
    forwards*: eq_consist H6.
    forwards*: styping_typing typ'.
    inverts H9.
    forwards*: TypedReduce_progress A0 H11.
    forwards* h1: eq_consist H3.
    inverts* H9.
    lets H12': H12.
    inverts* H12.
    forwards*: ptype_uniq H5 H18. inverts* H9.
    forwards*: eq_consist H3.
    forwards*: ptype_uniq H5 H18. inverts* H9.
    -
    inverts typ. inverts* H2.
    forwards* typ': styping_typing H8.
    inverts H7. inverts H9. inverts* H3.
    inverts* H2.
    inverts* H8. inverts* H3. inverts* H11.
    forwards* h1:  sptype_inf H4.
    forwards* h2: eq_trans H3 H2.
    forwards* h3: eq_sym H9.
    forwards*: eq_trans h2 h3.
    forwards*: eq_consist H2.
    forwards* h4: eq_consist H7.
    forwards* h5: eq_consist h2.
    inverts* typ'.
    forwards*: TypedReduce_progress A1 H12.
    inverts* H13.
    lets red1: H14.
    inverts* H14.
    +
    forwards*: ptype_uniq h1 H20. inverts* H13.
    forwards*: eq_consist H3.
    inverts H12. inverts* H17.
    assert(styping empty P (e_anno u A1) Inf A1);eauto.
    forwards* h6: styping_typing H15.
    forwards* h7:  TypedReduce_progress (store_Tlookup l P) h6.
    inverts* h7.
    lets h9: H16. inverts H16.
    forwards* h8: ptype_uniq H26 H20. inverts* h8.
    inverts wel.
    inverts H17.
    rewrite H18 in *.
    forwards h10: H22 l. auto.
    forwards h11: principle_typ_inf h10.
    forwards*: sto_ok_value H16.
    rewrite h11 in *.
    eapply  step_set; eauto.
    forwards* h8: ptype_uniq H26 H20. inverts* h8.
    +
    forwards* h8: ptype_uniq H20 h1. inverts* h8.
Qed.

Theorem static_stepd_dyn_chk : forall G e e' B P mu mu',
P |== mu ->
  phi_static P ->
  denv_static G ->
  dterm_static e ->
 dtyp_static B ->
 styping G P e Chk B ->
 step (e, mu) ((r_e e'), mu') ->
 dstep ( e, mu) ( e', mu').
Proof.
 introv wel ps envs es ts typ red.
 gen G B P.
 inductions red; intros; eauto;
 try solve[forwards*:dtyp_static_eq  H1];
 try solve[forwards*: dtyp_static_eq H0].
 -
   forwards h0: fill_static es.
   forwards hh1: fill_chk_chk typ; auto.
   inverts hh1.
   inverts H0.
   forwards h2: styping_typing H2.
   forwards h1: dtyping_static_preserve h2; auto.
   unfold Dtyping_static_preserve in *.
   forwards h3: eq_static H1; auto.
   eauto.
  -
    inverts es.
    inverts typ. inverts* H5.
    inverts* H12. inverts* H2.
    inverts H3. inverts H14. inverts* H15.
    inverts H0.
    inverts H13. inverts H5.
    inverts H14.
    forwards* h1: sptype_inf H11.
    forwards*:eq_trans H5 H0.
    forwards*:eq_consist H12.
    inverts H9.
    inverts H10. inverts H14. inverts H9.
    forwards*:eq_trans H12 H17.
    forwards*:eq_consist H9.
    inverts* H8.
  -
    inverts es.
    inverts typ. inverts* H1.
  -
    inverts es.
    inverts typ. inverts* H3.
    inverts* H9. inverts* H1.
  -
    inverts es.
    inverts typ. inverts* H2.
    inverts* H10. inverts* H3.
    inverts* H0.
  -
    inverts es.
    inverts typ. inverts* H4.
    inverts* H11. inverts* H3.
    inverts* H9. inverts* H4.
    inverts* H2. inverts* H16.
    inverts H12.
    inverts H0. inverts H4.
    inverts* H16.
    forwards* h1:  sptype_inf  H4.
    forwards* h2: eq_trans H0 H2.
    forwards* h3: eq_consist h2.
    inverts H3.
    forwards*: eq_sym H18.
    forwards* h4: eq_trans h2 H3.
    forwards* h5: eq_consist h4.
    inverts H11.
    inverts wel.
    inverts H14.
    rewrite H15 in *.
    forwards*: H16.
    forwards*: sto_ok_value H11.
    forwards* h6:  principle_typ_inf  H14.
    rewrite <- h6 in *.
    inverts* H10.
    inverts* H17.
  -
    inverts es.
    inverts typ. inverts* H3.
    inverts* H7. inverts* H0.
Qed.


Require Import floyd.proofauto.
Require Import aes.spec_AES256_HL.

Require Import Coqlib.
Require Import msl.Coqlib2.
Require Import floyd.coqlib3.
Require Import Integers.
Require Import List.
Require Import zlist.sublist.
Require Import sha.SHA256.
Require Import sha.general_lemmas.

Local Open Scope logic.

(* utility functions for convertin the funcational spec's data structures
 * into C data structures *)
Definition word_to_int (w : word) : int :=
  match w with (b0, b1, b2, b3) => little_endian_integer [b0; b1; b2; b3] end.

Definition words_to_ints (words : list word) : list int := map word_to_int words.

Definition block_to_ints (b : block) : list int :=
  match b with (w0, w1, w2, w3) => [word_to_int w0; word_to_int w1; word_to_int w2; word_to_int w3] end.

Definition blocks_to_ints (blocks : list block) : list int := flat_map block_to_ints blocks.

(* stipulate that the different ints used to represent bytes are indeed in range *)
Definition word_in_bounds (w : word) :=
  match w with
      (b0, b1, b2, b3) => (Int.unsigned b0 < 256 /\ Int.unsigned b1 < 256 /\ Int.unsigned b2 < 256 /\ Int.unsigned b3 < 256)
  end.
Definition block_in_bounds (b : block) :=
   match b with (w0, w1, w2, w3) => (word_in_bounds w0 /\ word_in_bounds w1 /\ word_in_bounds w2 /\ word_in_bounds w3) end.
Definition words_in_bounds (words : list word) := forall w : word, In w words -> word_in_bounds w.
Definition blocks_in_bounds (blocks : list block) := forall b : block, In b blocks -> block_in_bounds b.

(* Coq implementations of functions in the mbed TLS implementation, which we will
 * have to prove correspond to the spec *)

(* Implemenation's RCON table includes two constants not used in AES256 *)
Definition full_rcons := RCon ++ [
  (Int.repr 27 (* 0x1b *), Int.zero, Int.zero, Int.zero);
  (Int.repr 54 (* 0x36 *), Int.zero, Int.zero, Int.zero)
].

(* similar to grow_key in the functional specification, but always applies both an even
 * and an odd round instead of having a special case for the last round. This is not
 * called for in the functional specification, but this is what the program does, thus
 * producing an extra block *)
Fixpoint grow_key_extra (b1 b2: block) (rcs: list word) : list block :=
  match rcs with
  | hd :: tl =>
    let b3 := odd_round b1 b2 hd in
    let b4 := even_round b2 b3 in
    b3 :: b4 :: grow_key_extra b3 b4 tl
  | [] => []
  end.
Definition extra_key_expansion (k : list word) : list block :=
  match k with
  | [w1; w2; w3; w4; w5; w6; w7; w8] =>
    let b1 := (w1, w2, w3, w4) in
    let b2 := (w5, w6, w7, w8) in
    b1 :: b2 :: (grow_key_extra b1 b2 RCon)
  | l => [] (* should not happen *)
  end.

(* The implementation generates GF(256) exponentiation and logarithm tables,
 * both base 3. It uses these for multiplication *)
Fixpoint gen_exp_table (n : nat) (base : int) : list int :=
  match n with
  | O => []
    (* b XOR (xtime b) = 3*b in GF(256) *)
  | S n' => base :: gen_exp_table n' (Int.xor base (xtime base))
  end.

Fixpoint mapi_aux {A B : Type} (f : Z -> A -> B) (pos : Z) (l : list A) : list B :=
  match l with
  | [] => []
  | hd :: tl => f pos hd :: mapi_aux f (pos+1) tl
  end.

Definition mapi {A B : Type} (f : Z -> A -> B) (l : list A) : list B := mapi_aux f 0 l.

Fixpoint insert_idx {A : Type} (l : list (Z * A)) (p : (Z * A)) : list (Z * A) :=
  match p with (i, a) =>
    match l with
    | [] => p :: []
    | ((i', b) as hd) :: tl =>
      if i =? i' then p :: tl (* replace equal entries *)
      else if i <? i' then p :: hd :: tl
      else hd :: insert_idx tl p
    end
  end.

Definition sort_idx {A : Type} (l : list (Z * A)) : list (Z * A) :=
  fold_left insert_idx l [].

(* the implemenation generates the log table by actually computing
 * x = 3^i, then setting log[x] = i. This is not easy to do in Coq,
 * so instead we generate the power table, pair each entry with its
 * index, sort by entry, and return the indices *)
Definition gen_log_table (n : nat) (base : int) : list int :=
  let exp := gen_exp_table n base in
  let indexed := mapi (fun i e => (Int.unsigned e, Int.repr i)) exp in
  let sorted := sort_idx indexed in
  (* zero is an arbitrary entry at the beginning because log 0 is undefined *)
  Int.zero :: map snd sorted.

(* ith element is 3^i in GF(256) *)
Definition ff_exp_table := gen_exp_table 256 Int.one.
(* ith element is log base 3 of i in GF(256). Zeroth entry is arbitrarily 0 *)
Definition ff_log_table := gen_log_table 256 Int.one.

(* We will show that GF(256) arithmetic done by peasant multiplication
 * is equivalent to the method used by the implementation, namely using
 * log and exponentiation tables. The implementation takes log of a and b,
 * adds them mod 255 (not mod 256) and returns exp of that,
 * returning 0 if a or b is 0 *)
Definition table_ff_mult (a b: int) : int :=
  if Int.eq a Int.zero then Int.zero
  else if Int.eq b Int.zero then Int.zero
  else
    let log_a := Znth (Int.unsigned a) ff_log_table Int.zero in
    let log_b := Znth (Int.unsigned b) ff_log_table Int.zero in
    let idx := Int.modu (Int.add log_a log_b) (Int.repr 255) in
    Znth (Int.unsigned idx) ff_exp_table Int.zero.

Fixpoint repeat_op (op : int -> int) (times : nat) (arg : int) : int :=
  match times with
  | O => arg
  | S n => op (repeat_op op n arg)
  end.

(* implement exponentiation by repeated multiplication, which we will use
 * to verify correctness of our exp and log tables *)
Definition ff_exp (a b : int) := repeat_op (ff_mult a) (Z.to_nat (Int.unsigned b)) Int.one.

(* Forward and reverse table generation *)

(* The forward and reverse tables are used by the implementation to perform the
 * MixColumns and SubBytes step simply by XORing entries from a lookup table. *)
Fixpoint generate_forward_table (table : list int) : list word :=
  match table with
  | hd :: tl =>
    let x := hd in
    let y := xtime hd in
    let z := Int.xor y x in
    (y, x, x, z) :: generate_forward_table tl
  | [] => []
  end.

Definition ft_words := generate_forward_table (map Int.repr sbox).

(* opposite direction of RotWord, brings last byte to front. Applies
 * rotation n times *)
Fixpoint rotate (n : nat) (w : word) : word :=
  match n with
  | O => w
  | S n' => match w with (w0, w1, w2, w3) => (rotate n' (w3, w0, w1, w2)) end
  end.

Definition FT0 := words_to_ints ft_words.
Definition FT1 := words_to_ints (map (rotate 1%nat) ft_words).
Definition FT2 := words_to_ints (map (rotate 2%nat) ft_words).
Definition FT3 := words_to_ints (map (rotate 3%nat) ft_words).

Fixpoint generate_reverse_table (table : list int) : list word :=
  let c_e := Int.repr 14 in (* 0x0e *)
  let c_b := Int.repr 11 in (* 0x0b *)
  let c_d := Int.repr 13 in (* 0x0d *)
  let c_9 := Int.repr 9 in (* 0x09 *)
  match table with
  | hd :: tl =>
    (ff_mult c_e hd, ff_mult c_9 hd, ff_mult c_d hd, ff_mult c_b hd) :: generate_reverse_table tl
  | [] => []
  end.

Definition rt_words := generate_reverse_table (map Int.repr inv_sbox).

Definition RT0 := words_to_ints rt_words.
Definition RT1 := words_to_ints (map (rotate 1%nat) rt_words).
Definition RT2 := words_to_ints (map (rotate 2%nat) rt_words).
Definition RT3 := words_to_ints (map (rotate 3%nat) rt_words).

(* Using the forward and reverse tables to implement the AES round
 * and reverse round *)

Definition zlist_to_col (c : int) : (Z * Z * Z * Z) :=
  let bytes := intlist_to_Zlist [c] in
  match bytes with
  | b3 :: b2 :: b1 :: b0 :: [] => (b0, b1, b2, b3)
  | _ => (0, 0, 0, 0) (* should not happen *)
  end.

Definition mbed_tls_fround_col (b0 b1 b2 b3 : Z) (rk : int) : int :=
  let f0 := Znth b0 FT0 Int.zero in
  let f1 := Znth b1 FT1 Int.zero in
  let f2 := Znth b2 FT2 Int.zero in
  let f3 := Znth b3 FT3 Int.zero in
  fold_left Int.xor [f0; f1; f2; f3] rk.

(* we want to represent a round using the mbed TLS implementation's representation of the data structures
 * and show that this maps back to our functional specification. Corresponds to
 * the AES_FROUND macro *)
Definition mbed_tls_fround (cols : list int) (rk : list int) : list int :=
  match (cols, rk) with
  | (c3 :: c2 :: c1 :: c0 :: [], k3 :: k2 :: k1 :: k0 :: []) =>
      match (zlist_to_col c0, zlist_to_col c1, zlist_to_col c2, zlist_to_col c3) with
            ((c00, c01, c02, c03), (c10, c11, c12, c13),
             (c20, c21, c22, c23), (c30, c31, c32, c33)) =>
       [mbed_tls_fround_col c00 c11 c22 c33 k0;
        mbed_tls_fround_col c10 c21 c32 c03 k1;
        mbed_tls_fround_col c20 c31 c02 c13 k2;
        mbed_tls_fround_col c30 c01 c12 c23 k3]
      end
  | _ => [] (* should not happen *)
  end.

Definition mbed_tls_rround_col (b0 b1 b2 b3 : Z) (rk : int) : int :=
  let r0 := Znth b0 RT0 Int.zero in
  let r1 := Znth b1 RT1 Int.zero in
  let r2 := Znth b2 RT2 Int.zero in
  let r3 := Znth b3 RT3 Int.zero in
  fold_left Int.xor [r0; r1; r2; r3] rk.

(* Corresponds to the AES_RROUND macro *)
Definition mbed_tls_rround (cols : list int) (rk : list int) : list int :=
  match (cols, rk) with
  | (c3 :: c2 :: c1 :: c0 :: [], k3 :: k2 :: k1 :: k0 :: []) =>
      match (zlist_to_col c0, zlist_to_col c1, zlist_to_col c2, zlist_to_col c3) with
            ((c00, c01, c02, c03), (c10, c11, c12, c13),
             (c20, c21, c22, c23), (c30, c31, c32, c33)) =>
      (* note that column positions differ from the forward round *)
       [mbed_tls_rround_col c00 c31 c22 c13 k0;
        mbed_tls_rround_col c10 c01 c32 c23 k1;
        mbed_tls_rround_col c20 c11 c02 c33 k2;
        mbed_tls_rround_col c30 c21 c12 c03 k3]
      end
  | _ => [] (* should not happen *)
  end.


(******************************************************************************)
(** * Events of the Power memory model *)
(******************************************************************************)
Require Import Hahn.
Require Import Basic Events.
Require Export Events.

Set Implicit Arguments.
Remove Hints plus_n_O.

Inductive label :=
  | Aload (l: location) (v: value)
  | Astore (l: location) (v: value)
  | Afence_lwsync
  | Afence_sync.

Definition init_label l :=  (Astore l 0).

Section Labels.

Variable lab : event -> label.

Definition loc a :=
  match lab a with
  | Aload l _
  | Astore l _ => Some l
  | _ => None
  end.

Definition val a :=
  match lab a with
  | Aload  _ v
  | Astore _ v => Some v
  | _ => None
  end.

Definition is_r a :=
  match lab a with
  | Aload  _ _ => True
  | _ => False
  end.

Definition is_w a :=
  match lab a with
  | Astore _ _ => True
  | _ => False
  end.

Definition is_f_sync a :=
  match lab a with
  | Afence_sync => True
  | _ => False
  end.

Definition is_f_lwsync a :=
  match lab a with
  | Afence_lwsync => True
  | _ => False
  end.

End Labels.

Lemma eq_dec_labels :
  forall x y : label, {x = y} + {x <> y}.
Proof.
repeat decide equality.
Qed.


Require Import Rupicola.Lib.Api.
Require Import Rupicola.Lib.Arrays.
Require Import Rupicola.Lib.Loops.
Require Import Rupicola.Lib.WordNotations.
Require Import coqutil.Word.LittleEndianList.

Section with_parameters.
  Context {width: Z} {BW: Bitwidth width} {word: word.word width} {mem: map.map word Byte.byte}.
  Context {locals: map.map String.string word}.
  Context {env: map.map String.string (list String.string * list String.string * Syntax.cmd)}.
  Context {ext_spec: bedrock2.Semantics.ExtSpec}.
  Context {word_ok : word.ok word} {mem_ok : map.ok mem}.
  Context {locals_ok : map.ok locals}.
  Context {env_ok : map.ok env}.
  Context {ext_spec_ok : Semantics.ext_spec.ok ext_spec}.

  Section GetPut.
    Definition packet :=
      Vector.t word 2. (* field1, ttl *)

    Definition __lt {a b: nat} : if lt_dec a b return Prop then Nat.lt a b else True :=
      match lt_dec a b as c return (if c return Prop then Nat.lt a b else True) with
      | left pr => pr
      | _ => I
      end.

    Notation _lt :=
      ltac:(lazymatch goal with
            | [  |- (?a < ?b)%nat ] => exact (@__lt a b)
            end) (only parsing).

    Notation ttl_idx := 1%nat.
    Definition field1 (p: packet) := (VectorArray.get p 0%nat _lt).
    Definition ttl (p: packet) := (VectorArray.get p ttl_idx _lt).

    Definition Packet (addr: word) (p: packet) : mem -> Prop :=
      vectorarray_value AccessWord addr p.

    Definition decr_gallina (p: packet) :=
      let/n ttl := (ttl p) in
      let/n ttl := word.add ttl (word.of_Z (-1)) in
      let/n p := VectorArray.put p ttl_idx _lt ttl in
      p.

    Hint Unfold Packet : compiler_cleanup.

    Instance spec_of_decr : spec_of "decr" :=
      fnspec! "decr" ptr / p R,
      { requires tr mem :=
          (Packet ptr p ⋆ R) mem;
        ensures tr' mem' :=
          tr' = tr /\ (Packet ptr (decr_gallina p) ⋆ R) mem' }.

    Import VectorArrayCompiler.
    Hint Unfold ttl : compiler_cleanup.

    Derive decr_br2fn SuchThat
           (defn! "decr"("p") { decr_br2fn },
            implements decr_gallina)
      As decr_br2fn_ok.
    Proof.
      compile.
    Qed.
  End GetPut.

  Section Loops.
    Definition mask_bytes (bs: ListArray.t byte) mask :=
      let/n bs := ListArray.map (byte.and mask) bs in bs.

    Definition xor_bytes (bs: ListArray.t byte) :=
      let/n r := Byte.x00 in
      let/n r := ListArray.fold_left byte.xor bs Byte.x00 in
      r.

    Definition incr_words (ws: ListArray.t word) :=
      let/n ws := ListArray.map (word.add (word.of_Z 1)) ws in ws.

    Definition sum_words (ws: ListArray.t word) :=
      let/n r := word.of_Z 0 in
      let/n r := ListArray.fold_left word.add ws r in
      r.

    Import LoopCompiler.
    Import SizedListArrayCompiler.
    Hint Extern 10 => lia : compiler_side_conditions.

    Notation bytes := (sizedlistarray_value access_size.one).
    Notation words := (sizedlistarray_value access_size.word).

    Instance spec_of_mask_bytes : spec_of "mask_bytes" :=
      fnspec! "mask_bytes" ptr wlen wmask / (bs : ListArray.t byte) mask R,
        { requires tr mem :=
            wmask = word.of_Z (byte.unsigned mask) /\
            wlen = word.of_Z (Z.of_nat (length bs)) /\
            Z.of_nat (length bs) < 2 ^ width /\
            (bytes (length bs) ptr bs ⋆ R) mem;
          ensures tr' mem' :=
            tr' = tr /\
            (bytes (length bs) ptr (mask_bytes bs mask) ⋆ R) mem' }.

    Derive mask_bytes_br2fn SuchThat
           (defn! "mask_bytes" ("bs", "len", "mask") { mask_bytes_br2fn },
            implements mask_bytes)
           As mask_bytes_br2fn_ok.
    Proof.
      Time compile.
    Qed.

    Instance spec_of_xor_bytes : spec_of "xor_bytes" :=
      fnspec! "xor_bytes" ptr wlen / (bs : ListArray.t byte) R ~> r,
        { requires tr mem :=
            wlen = word.of_Z (Z.of_nat (length bs)) /\
            Z.of_nat (length bs) < 2 ^ width /\
            (bytes (length bs) ptr bs ⋆ R) mem;
          ensures tr' mem' :=
            tr' = tr /\ r = word.of_Z (byte.unsigned (xor_bytes bs)) /\
            (bytes (length bs) ptr bs ⋆ R) mem' }.

    Derive xor_bytes_br2fn SuchThat
           (defn! "xor_bytes" ("bs", "len") ~> "r" { xor_bytes_br2fn },
            implements xor_bytes)
           As xor_bytes_br2fn_ok.
    Proof.
      Time compile.
    Qed.

    Instance spec_of_incr_words : spec_of "incr_words" :=
      fnspec! "incr_words" ptr wlen / (ws : ListArray.t word) R,
        { requires tr mem :=
            wlen = word.of_Z (Z.of_nat (length ws)) /\
            Z.of_nat (length ws) < 2 ^ width /\
            (words (length ws) ptr ws ⋆ R) mem;
          ensures tr' mem' :=
            tr' = tr /\
            (words (length ws) ptr (incr_words ws) ⋆ R) mem' }.

    Derive incr_words_br2fn SuchThat
           (defn! "incr_words" ("ws", "len") { incr_words_br2fn },
            implements incr_words)
           As incr_words_br2fn_ok.
    Proof.
      Time compile.
    Qed.

    Instance spec_of_sum_words : spec_of "sum_words" :=
      fnspec! "sum_words" ptr wlen / (ws : ListArray.t word) R ~> r,
        { requires tr mem :=
            wlen = word.of_Z (Z.of_nat (length ws)) /\
            Z.of_nat (length ws) < 2 ^ width /\
            (words (length ws) ptr ws ⋆ R) mem;
          ensures tr' mem' :=
            tr' = tr /\ r = word.of_Z (word.unsigned (sum_words ws)) /\
            (words (length ws) ptr ws ⋆ R) mem' }.

    Derive sum_words_br2fn SuchThat
           (defn! "sum_words" ("ws", "len") ~> "r" { sum_words_br2fn },
            implements sum_words)
           As sum_words_br2fn_ok.
    Proof.
      Time compile.
    Qed.
  End Loops.

  Section Casts.
    Notation bytes := (listarray_value (memT := mem) (word := word) access_size.one).
    Notation words := (listarray_value (memT := mem) (word := word) access_size.word).

    Notation of_nat n := (word.of_Z (Z.of_nat n)).
    Notation of_Z := word.of_Z.
    Notation unsigned := word.unsigned.

    Notation bs2ws := (bs2ws (word := word) (Memory.bytes_per (width := width) access_size.word)).
    Notation ws2bs := (ws2bs (word := word) (Memory.bytes_per (width := width) access_size.word)).
    Notation bytes_per_word := (Memory.bytes_per (width := width) access_size.word).

(*|
A simple program that takes as input an array of bytes, reinterprets it as an array of little-endian machine words, and counts the number of matches for a given search term in the resulting array.
|*)

    Definition count_ws (data: ListArray.t byte) (needle: word) :=
      let/n r := 0 in
      let/n data := bs2ws data in
      let/n r := ListArray.fold_left (fun r w64 =>
           let/n hit := word.eqb w64 needle in
           let/n r := r + Z.b2z hit in
           r)
        data 0 in
      let/n data := ws2bs data in
      r.

(*|
Instead of applying the mask byte by byte, the program starts by casting its input into a list of 64-bit words, processes these words, and finally casts the result back to a lists of bytes.  Without loading appropriate libraries, Rupicola will not recognize these patterns:
|*)

    Instance spec_of_count_ws : spec_of "count_ws" :=
      fnspec! "count_ws" ptr wlen needle / (bs: list byte) R ~> r, {
        requires tr mem :=
          wlen = of_nat (length bs) /\
          Z.of_nat (length bs) < 2 ^ width /\
          (Datatypes.length bs mod bytes_per_word = 0)%nat /\
          (bytes ptr bs ⋆ R) mem;
        ensures tr' mem' :=
          tr' = tr /\ r = of_Z (count_ws bs needle) /\
          (bytes ptr bs ⋆ R) mem'
      }.

    Lemma bytes_as_words ptr bs:
      (length bs mod bytes_per_word = 0)%nat ->
      Lift1Prop.iff1 (bytes ptr bs) (words ptr (bs2ws bs)).
    Proof. apply words_of_bytes. Qed.

    Lemma words_as_bytes ptr bs:
      (length bs mod bytes_per_word = 0)%nat ->
      Lift1Prop.iff1 (words ptr (bs2ws bs)) (bytes ptr bs).
    Proof. symmetry; apply words_of_bytes; assumption. Qed.

    Lemma compile_bs2ws [t m l σ] (bs: list byte):
      let v := bs2ws bs in
      forall {P} {pred: P v -> _} {k: nlet_eq_k P v} K r bs_var ptr,
        (bytes ptr bs ⋆ r) m ->
        (length bs mod bytes_per_word = 0)%nat ->
        (forall m' : mem,
          (words ptr v ⋆ r) m' ->
          <{ Trace := t; Memory := m'; Locals := l; Functions := σ }> K <{ pred (k v eq_refl) }>) ->
        <{ Trace := t; Memory := m; Locals := l; Functions := σ }>
          K
        <{ pred (let/n x as bs_var eq:Heq := v in k x Heq) }>.
    Proof. intros; seprewrite_in bytes_as_words H; eauto. Qed.

    Lemma compile_bs2ws_rev [t m l σ] (bs: list byte):
      let v := ws2bs (bs2ws bs) in
      forall {P} {pred: P v -> _} {k: nlet_eq_k P v} K r bs_var ptr,

        (words ptr (bs2ws bs) ⋆ r) m ->
        (length bs mod bytes_per_word = 0)%nat ->

        (forall m' : mem,
            (bytes ptr bs ⋆ r) m' ->
            <{ Trace := t; Memory := m'; Locals := l; Functions := σ }>
              K
            <{ pred (k v eq_refl) }>) ->

        <{ Trace := t; Memory := m; Locals := l; Functions := σ }>
          K
        <{ pred (let/n x as bs_var eq:Heq := v in k x Heq) }>.
    Proof. intros; seprewrite_in (words_as_bytes) H; eauto. Qed.

    Import UnsizedListArrayCompiler.

    Hint Extern 1 => simple eapply compile_bs2ws; shelve : compiler.
    Hint Extern 1 => simple eapply compile_bs2ws_rev; shelve : compiler.
    Hint Extern 1 => (pose proof bytes_per_range access_size.word) : nia.
    Hint Rewrite @bs2ws_length using solve[eauto with nia] : compiler_side_conditions.
    Hint Rewrite Nat2Z.inj_div : compiler_side_conditions.
    Hint Extern 10 => eauto with nia : compiler_side_conditions.

    Derive count_ws_br2fn SuchThat
      (defn! "count_ws"("data", "len", "needle") ~> "r" { count_ws_br2fn },
       implements count_ws) As count_ws_br2fn_ok.
    Proof.
      compile.
    Qed.
  End Casts.
End with_parameters.

From bedrock2 Require Import BasicC64Semantics NotationsCustomEntry.
Compute decr_br2fn (word := word).
Compute mask_bytes_br2fn (width := 64).
Compute xor_bytes_br2fn (word := word).
Compute incr_words_br2fn (word := word).
Compute sum_words_br2fn (word := word).
Compute count_ws_br2fn (word := word).