(**************************************************************************)
(*           *                                                            *)
(*     _     *   The Coccinelle Library / Evelyne Contejean               *)
(*    <o>    *          CNRS-LRI-Universite Paris Sud                     *)
(*  -/@|@\-  *                   A3PAT Project                            *)
(*  -@ | @-  *                                                            *)
(*  -\@|@/-  *      This file is distributed under the terms of the       *)
(*    -v-    *      CeCILL-C licence                                      *)
(*           *                                                            *)
(**************************************************************************)

(** * Termination of rewriting *)

From Coq Require Import List Relations Wellfounded Arith Recdef Setoid.
From CoLoR Require Import closure more_list weaved_relation term_spec
     equational_theory_spec dp.

(** ** Module Type Termin, for termination of rewriting systems. *)

Module MakeSubDP (E : EqTh).

  Module Dp := dp.MakeDP (E).
  Import Dp.
  Import E.
  Import T.

Section Subterm.

Variable R : relation term.
Variable R_reg : forall s t, R s t -> forall x, In x (var_list s) -> In x (var_list t) .
Variable R_var : forall v t, ~ R t (Var v).
Variable CD : forall f, {constructor R f} + {defined R f}.
Variable R_red : term -> list term.
Variable FB : forall t s, one_step R s t <-> In s (R_red t).
Variable inject : nat -> variable.
Variable inject_inv : variable -> nat.
Variable Hinject1 : forall v, inject (inject_inv v) = v.
Variable Hinject2 : forall n, inject_inv (inject n) = n.

Variable cdp : term -> term -> Prop.
Variable cdp_in_dpR : forall u v, cdp v u -> ddp R v u.

Variable P : F.Symb.A -> nat.
Variable u0 : term.
Variable v0 : term.
Variable u0_diff_v0 : u0 <> v0.
Variable cdp_uv0 : cdp v0 u0.

Variable P_ok : match v0 with
                      | Var _ => True
                      | Term f _ => match F.arity f with Free n => P f < n | _ => P f < 2 end
                      end.

Definition projection (t : term) : term :=
  match t with
  | Var _ => t
  | Term f l =>
      match nth_error l (P f)  with
      | Some tf => tf
      | None => t
      end
   end.

Variable  uv0_strict : trans_clos (union _ (one_step R) direct_subterm) (projection v0) (projection u0).

Inductive dp' : term -> term -> Prop :=
  Dp' : forall v u, cdp v u -> (u,v) <> (u0,v0) -> dp' v u.

Inductive dp0 : term -> term -> Prop :=
  Dp0 : dp0 v0 u0.

Definition Rdp' := rdp_step (axiom dp') R.
Definition Rdp0 := rdp_step (axiom dp0) R.
Definition Rcdp := rdp_step (axiom cdp) R.
Definition R1 := compose_rel (refl_trans_clos Rdp') Rdp0.
Definition R1' := compose_rel Rdp0 (refl_trans_clos Rdp').

Lemma subst_projection :
  forall sigma f l, projection (apply_subst sigma (Term f l)) = apply_subst sigma (projection (Term f l)).
Proof.
unfold projection; intros sigma f l; simpl.
generalize (nth_error_map (apply_subst sigma) l (P f)).
case (nth_error (map (apply_subst sigma) l) (P f)).
intros ti_sigma.
case (nth_error l (P f)).
intros ti H; assumption.
contradiction.
case (nth_error l (P f)).
contradiction.
intros; apply eq_refl.
Qed.

Lemma projection_is_subterm :
   forall t f l,
   Rdp0 (Term f l) t ->
   (match F.arity f with
        | AC => length l = 2
        | C => length l = 2
        | Free n => length l = n
   end) ->
   direct_subterm (projection (Term f l))  (Term f l).
Proof.
intros s f l K L.
inversion K as [g l1 l2 t3 H1 H2]; subst.
inversion H2 as [t1 t2 sigma K1 K2 K3]; subst.
destruct t1 as [x | g1 k1].
inversion K1 as [J1 J2]; clear K K1 H2; subst.
assert (K4 := cdp_in_dpR _ _ cdp_uv0).
destruct K4 as [K4 _]; inversion K4.
inversion K1 as [J1 J2].
rewrite J1 in P_ok; injection K2; clear K2; do 2 intro; subst.
destruct (F.arity f) as [ | | n].

destruct k1 as [ | u1 [ | u2 [ | u3 l]]]; try discriminate.
simpl; destruct (P f) as [ | [ | p]]; simpl.
left; reflexivity.
right; left; reflexivity.
assert (Abs := le_S_n _ _ (le_S_n _ _ P_ok)); inversion Abs.

destruct k1 as [ | u1 [ | u2 [ | u3 l]]]; try discriminate.
simpl; destruct (P f) as [ | [ | p]]; simpl.
left; reflexivity.
right; left; reflexivity.
assert (Abs := le_S_n _ _ (le_S_n _ _ P_ok)); inversion Abs.
rewrite <- L in P_ok; generalize P_ok.
simpl; set (k := map (apply_subst sigma) k1); clearbody k; set (p := P f); clearbody p.
revert p k; fix projection_is_subterm 1.
intro p; case p; clear p.
intro l; case l; clear l.
intro Abs; inversion Abs.
intros t l _; simpl; left; reflexivity.
intros p l; case l; clear l.
intro Abs; inversion Abs.
intros t l LL; simpl; right; generalize (projection_is_subterm p l (lt_S_n _ _ LL)).
case (nth_error l p).
intros s s_in_l; exact s_in_l.
intros Abs; apply False_rect; apply (lt_irrefl (size (Term f l))).
apply size_direct_subterm; assumption.
Qed.

Lemma split_dps :
  forall t1 t2, Rcdp t1 t2 <-> union _ Rdp' Rdp0 t1 t2.
Proof.
intros u1 u2; split; intro H.
inversion H as [f' l1 l2 H1 H2 H']; clear H; subst.
inversion H' as [t1 t2 sigma H'' H3 H''']; clear H'; subst.
generalize (T.eq_bool_ok t2 u0); case (T.eq_bool t2 u0); [intro t2_eq_u0 | intro t2_diff_u0].
generalize (T.eq_bool_ok t1 v0); case (T.eq_bool t1 v0); [intro t1_eq_v0 | intro t1_diff_v0].
subst t1 t2; right.
apply Rdp_step with l2; trivial.
rewrite <- H'''; apply instance; apply Dp0.
left; apply Rdp_step with l2; trivial.
rewrite <- H'''; apply instance; apply Dp'; trivial.
intro H; apply t1_diff_v0; injection H; intros; assumption.
left; apply Rdp_step with l2; trivial.
rewrite <- H'''; apply instance; apply Dp'; trivial.
intro H; apply t2_diff_u0; injection H; intros; assumption.

destruct H as [H | H].
inversion H as [f' l1 l2 H1 H2 H']; clear H; subst.
inversion H' as [t1 t2 sigma H'' H3 H''']; clear H'; subst.
inversion H'' as [v u]; clear H''; subst t1 t2.
apply Rdp_step with l2; trivial.
rewrite <- H'''; apply instance; assumption.
inversion H as [f' l1 l2 H1 H2 H']; clear H; subst.
inversion H' as [t1 t2 sigma H'' H3 H''']; clear H'; subst.
inversion H'' as [v u]; clear H''; subst t1 t2.
apply Rdp_step with l2; trivial.
rewrite <- H'''; apply instance; assumption.
Qed.

Lemma dp0_is_dp : forall t1 t2, Rdp0 t2 t1 -> Rcdp t2 t1.
Proof.
intros t1 t2 H; inversion H; subst.
apply Rdp_step with l2; trivial.
inversion H1; subst.
apply instance.
inversion H4; subst; trivial.
Qed.

Lemma dp'_is_dp : forall t1 t2, Rdp' t2 t1 -> Rcdp t2 t1.
Proof.
intros t1 t2 H; inversion H; subst.
apply Rdp_step with l2; trivial.
inversion H1; subst.
apply instance.
inversion H4; subst; trivial.
Qed.

Definition extract_dp u v s t :=
   cdp v u /\
   exists f, exists l1, exists l2, exists sigma,
   s = apply_subst sigma v /\
   Term f l2 = apply_subst sigma u /\
   refl_trans_clos (one_step_list (one_step R)) l2 l1 /\
   Term f l1 = t.

Lemma connect_extract_dp_aux :
  forall u1 v1 s1 t1 un vn sn,
  Rcdp s1 t1 ->
  Rcdp sn s1 ->
  extract_dp u1 v1 s1 t1 -> extract_dp un vn sn s1 ->
  are_connected cdp R (un,vn) (u1,v1).
Proof.
intros u1 v1 s1 t1 un vn sn H1 Hn.
unfold extract_dp.
intros [D1 [f [l1 [l2 [sigma [K1 [J1 [L1 E1]]]]]]]] [Dn [g [k1 [k2 [tau [K2 [J2 [L2 E2]]]]]]]].
exists sigma; exists tau; subst; repeat split; trivial.
rewrite <- J2.
rewrite <- E2; split; trivial.
Qed.

Lemma connect_extract_dp :
  forall u1 v1 s1 t1 un vn sn tn,
  Rcdp s1 t1 ->
  refl_trans_clos Rcdp tn s1 ->
  Rcdp sn tn ->
  extract_dp u1 v1 s1 t1 -> extract_dp un vn sn tn ->
  trans_clos (are_connected cdp R) (un,vn) (u1,v1).
Proof.
intros u1 v1 s1 t1 un vn sn tn H1 H; revert u1 v1 t1 un vn sn H1.
inversion H as [u | tn' s1' H']; clear H.
subst u tn.
intros u1 v1 t1 un vn sn H1 Hn E1 En;
left; apply connect_extract_dp_aux with s1 t1 sn; trivial.
subst s1' tn'.
induction H' as [tn s1 H | tn t s1 H1 H2].
assert (H_save := H).
inversion H as [f l1 l2 tn' H21 H'].
inversion H' as [v2 u2 sigma2].
intros u1 v1 t1 un vn sn Dp1 Dpn E1 En.
assert (E2 : extract_dp u2 v2 tn (Term f l1)).
split.
trivial.
exists f; exists l1; exists l2; exists sigma2; repeat split; trivial.
apply sym_eq; assumption.
apply sym_eq; assumption.
rewrite H3 in En, Dpn.
rewrite H1 in E1, Dp1.
apply trans_clos_is_trans with (u2,v2); left.
subst; refine (connect_extract_dp_aux _ _ _ _ _ _ _ _ _ E2 En); trivial.
subst; refine (connect_extract_dp_aux _ _ _ _ _ _ _ _ _ E1 E2); trivial.
intros u1 v1 t1 un vn sn Dp1 Dpn E1 En.
assert (H1_save := H1).
inversion H1 as [f l1 l2 tn' K1 K2]; subst tn' t.
inversion K2 as [v u sigma].
assert (E : extract_dp u v tn (Term f l1)).
split; trivial.
exists f; exists l1; exists l2; exists sigma; repeat split; trivial.
apply sym_eq; assumption.
apply sym_eq; assumption.
apply trans_clos_is_trans with (u,v).
left; refine (connect_extract_dp_aux _ _ _ _ _ _ _ _ _ E En); trivial.
apply (IHH2 u1 v1 t1 u v tn Dp1 H1_save E1 E).
Qed.

Variable comp : term * term -> nat -> Prop.
Variable comp_def : forall u v, cdp v u -> exists n, comp (u,v) n.
Variable comp_fonc : forall uv n n', comp uv n -> comp uv n' -> n = n'.
Variable comp_ok : forall uv uv', are_connected cdp R uv uv' -> forall n n', comp uv n -> comp uv' n' -> n <= n'.
Definition strong_connect_approx n uv uv' := comp uv n /\ comp uv' n.

Lemma trans_comp_ok :
  forall uv uv', trans_clos (are_connected cdp R) uv uv' -> forall n n', comp uv n -> comp uv' n' -> n <= n'.
Proof.
intros x y H; induction H as [x y H1 | x y z H1 Hn].
apply comp_ok; assumption.
intros nx nz Hx Hz.
destruct x as [ux vx]; destruct y as [uy vy]; destruct H1 as [sigma [sigma' [H1 [H2 H3]]]].
destruct (comp_def _ _ H1) as [ny Hy].
apply le_trans with ny.
apply comp_ok with (ux,vx) (uy,vy).
exists sigma; exists sigma'; split; [ | split]; assumption.
assumption.
assumption.
apply IHHn; assumption.
Qed.

Lemma between_dp0_aux1 :
  forall t1 t2 t3 t4 t5 t6,
  Rdp0 t2 t1 ->
  refl_trans_clos Rdp' t3 t2 ->
  rdp_step (axiom dp') R t4 t3 ->
  refl_trans_clos Rdp' t5 t4 ->
  Rdp0 t6 t5 ->
  forall u v, extract_dp u v t4 t3 ->
      refl_trans_clos (are_connected cdp R) (u0,v0) (u,v) /\
      refl_trans_clos (are_connected cdp R) (u,v) (u0,v0).
Proof.
intros t1 t2 t3 t4 t5 t6 H21 H32 H43 H54 H65 u v E.
assert (E1 : extract_dp u0 v0 t2 t1).
split; trivial.
inversion H21 as [f l1 l2 v1 Hl21 Hdp2]; subst.
inversion Hdp2 as [v2 u2 sigma2 Hdp2' K2 J2]; clear Hdp2.
inversion Hdp2'; subst v2 u2.
exists f; exists l1; exists l2; exists sigma2; repeat split; trivial.
apply sym_eq; assumption.
assert (E6 : extract_dp u0 v0 t6 t5).
split; trivial.
inversion H65 as [f l1 l2 v1 Hl21 Hdp2]; subst.
inversion Hdp2 as [v2 u2 sigma2 Hdp2' K2 J2]; clear Hdp2.
inversion Hdp2'; subst v2 u2.
exists f; exists l1; exists l2; exists sigma2; repeat split; trivial.
apply sym_eq; assumption.

split.
right; apply (connect_extract_dp u v t4 t3 u0 v0 t6 t5); trivial.
apply dp'_is_dp; trivial.
apply refl_trans_incl with (rdp_step (axiom dp') R); trivial.
intros u1 u2 H; apply dp'_is_dp; trivial.
apply dp0_is_dp; trivial.
right; apply (connect_extract_dp u0 v0 t2 t1 u v t4 t3); trivial.
apply dp0_is_dp; trivial.
apply refl_trans_incl with (rdp_step (axiom dp') R); trivial.
intros u1 u2 H; apply dp'_is_dp; trivial.
apply dp'_is_dp; trivial.
Qed.

Lemma projection_one_step_list :
forall f l1 l2, refl_trans_clos (one_step_list (one_step R)) l2 l1 ->
                   refl_trans_clos (one_step R) (projection (Term f l2)) (projection (Term f l1)).
Proof.
intros h l3 l4 H; simpl.
generalize (nth_error_ok_in (P h) l4).
case_eq (nth_error l4 (P h)).
intros s4 H4 K; destruct (K _ (eq_refl _)) as [l41 [l42 [L4 H4']]]; clear K H4.
generalize (nth_error_ok_in (P h) l3).
case_eq (nth_error l3 (P h)).
intros s3 H3 K; destruct (K _ (eq_refl _)) as [l31 [l32 [L3 H3']]]; clear K H3.
rewrite <- L4 in L3.
subst l3 l4.
apply (refl_trans_clos_one_step_list_refl_trans_clos_one_step _ _ _ _ _ _ (sym_eq L3) H).
intros H3 _.
absurd (length l41 < length l41).
apply lt_irrefl.
assert (L : length l4 = length l3).
inversion H.
trivial.
apply rwr_list_length_eq with (one_step R); assumption.
assert (L' := nth_error_none _ _ H3).
rewrite <- L4 in L'; rewrite <- L in L'; subst l4.
apply lt_le_trans with (length (l41 ++ s4 :: l42)); trivial.
rewrite length_app; rewrite plus_comm; simpl.
apply le_n_S; apply le_plus_r.
intros H4 _.
generalize (nth_error_ok_in (P h) l3).
case_eq (nth_error l3 (P h)).
intros s3 H3 K; destruct (K _ (eq_refl _)) as [l31 [l32 [L3 H3']]]; clear K H3.
absurd (length l31 < length l31).
apply lt_irrefl.
assert (L : length l4 = length l3).
inversion H.
trivial.
apply rwr_list_length_eq with (one_step R); assumption.
assert (L' := nth_error_none _ _ H4).
rewrite <- L3 in L'; rewrite L in L'; subst l3.
apply lt_le_trans with (length (l31 ++ s3 :: l32)); trivial.
rewrite length_app; rewrite plus_comm; simpl.
apply le_n_S; apply le_plus_r.
intros H3 _.
inversion H.
left.
right.
apply general_context; assumption.
Qed.

Lemma between_dp0_aux2 :
  (forall n u v, strong_connect_approx n (u0,v0) (u,v) ->
  refl_trans_clos (union _ (one_step R) direct_subterm) (projection v) (projection u)) ->
  forall t1 t2 t3 t4 t5 t6,
  Rdp0 t2 t1 ->
  refl_trans_clos Rdp' t3 t2 ->
  Rdp' t4 t3 ->
  refl_trans_clos Rdp' t5 t4 ->
  Rdp0 t6 t5 ->
  refl_trans_clos (union _ (one_step R) direct_subterm) (projection t4) (projection t3).
Proof.
intros Hdp t1 t2 t3 t4 t5 t6 H21 H32 H43 H54 H65.
inversion H43 as [h l3 l4 v3 Hl43 Hdp4]; subst.
inversion Hdp4 as [v4 u4 sigma4 Hdp4' K4 J4]; clear Hdp4.
inversion Hdp4' as [v4' u4' Hdp4'']; subst u4' v4'.
assert (E4 : extract_dp u4 v4 t4 (Term h l3)).
unfold extract_dp; split; trivial.
exists h; exists l3; exists l4; exists sigma4; repeat split; trivial.
apply sym_eq; assumption.
apply sym_eq; assumption.
destruct (between_dp0_aux1 t1 t2 (Term h l3) t4 t5 t6 H21 H32 H43 H54 H65 _ _ E4) as [K1 K2].
apply refl_trans_clos_is_trans with (projection (Term h l4)).
rewrite <- J4.
assert (Hdp4''' := cdp_in_dpR _ _ Hdp4'').
destruct Hdp4''' as [Hdp4''' Sub4].
inversion Hdp4''' as [u4' r4 p4 g4 k4 R4 Sub4' D4]; subst.
destruct u4 as [x4 | f4 ll4].
apply False_rect; apply (R_var _ _ R4).
do 2 rewrite subst_projection.
apply one_step_subterm_subst.
clear Hdp4' H65 H54 H32 H43 H21.
inversion K1 as [[u v] | uv0 uv4 K1'].
subst u v u0 v0.
right; assumption.
subst uv0 uv4.
inversion K2 as [[u v] | uv4 uv0 K2'].
subst u v u0 v0.
right; assumption.
subst uv0 uv4.
destruct (comp_def _ _ Hdp4'') as [n4 K4].
apply Hdp with n4; split; [ | assumption].
destruct (comp_def _ _ cdp_uv0) as [n0 K0].
replace n4 with n0.
assumption.
apply le_antisym.
apply (trans_comp_ok _ _ K1'); assumption.
apply (trans_comp_ok _ _ K2'); assumption.
apply refl_trans_incl with (one_step R).
intros u1 u2 K; left; assumption.
apply projection_one_step_list; trivial.
Qed.

Lemma between_dp0_aux3 :
  (forall n u v, strong_connect_approx n (u0,v0) (u,v) ->
  refl_trans_clos (union _ (one_step R) direct_subterm) (projection v) (projection u)) ->
  forall t1 t2 t3 t4 t5 t6,
  Rdp0 t2 t1 ->
  refl_trans_clos Rdp' t3 t2 ->
  refl_trans_clos Rdp' t4 t3 ->
  refl_trans_clos Rdp' t5 t4 ->
  Rdp0 t6 t5 ->
  refl_trans_clos (union _ (one_step R) direct_subterm) (projection t4) (projection t3).
Proof.
intros Hdp t1 t2 t3 t4 t5 t6 H21 H32 H43.
inversion H43 as [u | u4 u3 H43']; clear H43.
intros _ _; left.
subst u3 u4; revert t1 t2 t5 t6 H21 H32;
induction H43' as [t4 t3 H43 | t4 t t3 H4 H3]; intros t1 t2 t5 t6 H21 H32 H54 H65.
apply between_dp0_aux2 with t1 t2 t5 t6; trivial.
apply refl_trans_clos_is_trans with (projection t).
apply between_dp0_aux2 with t1 t2 t5 t6; trivial.
apply refl_trans_clos_is_trans with t3; trivial.
right; assumption.
apply IHH3 with t1 t2 t5 t6; trivial.
apply refl_trans_clos_is_trans with t4; trivial.
right; left; assumption.
Qed.

Lemma between_dp0 :
  (forall n u v, strong_connect_approx n (u0,v0) (u,v) ->
  refl_trans_clos (union _ (one_step R) direct_subterm) (projection v) (projection u)) ->
  forall t1 t2 t3 t4,
  Rdp0 t2 t1 ->
  refl_trans_clos Rdp' t3 t2 ->
  Rdp0 t4 t3 ->
  refl_trans_clos (union _ (one_step R) direct_subterm) (projection t3) (projection t2).
Proof.
intros Hdp t1 t2 t3 t4 H21 H32 H43; apply between_dp0_aux3 with t1 t2 t3 t4; trivial.
left.
left.
Qed.

Lemma dp0_decreases :
   forall t1 t2, Rdp0 t2 t1 ->
  trans_clos (union _ (one_step R) direct_subterm) (projection t2) (projection t1).
Proof.
intros t1 t2 H21.
inversion H21 as [f l1 l2 v1 Hl21 Hdp2]; subst.
inversion Hdp2 as [v2 u2 sigma2 Hdp2' K2 J2]; clear Hdp2.
inversion Hdp2'; subst v2 u2.
assert (dp_uv0 := cdp_in_dpR _ _ cdp_uv0).
destruct dp_uv0 as [dp_uv0 H2].
inversion dp_uv0 as [u0' r0 p0 g0 k0 H1 H3]; clear Hdp2' H21; subst.
destruct u0 as [x0 | f0 l0].
apply False_rect; apply (R_var _ _ H1).
assert (Sub := projection_one_step_list f _ _ Hl21).
assert (Sub' : trans_clos (union term (one_step R) direct_subterm)
  (projection (apply_subst sigma2 (Term g0 k0))) (projection (Term f l2))).
rewrite <- J2.
do 2 rewrite subst_projection.
revert uv0_strict; apply trans_incl2.
intros a1 a2 [Sub'' | Sub''].
left; apply one_step_apply_subst; assumption.
right; destruct a2 as [x2 | g2 k2].
contradiction.
simpl; rewrite in_map_iff; exists a1; split; trivial.
inversion Sub as [u H0 H5 | u1 u2 K1 K2].
subst u; simpl; rewrite <- H5; assumption.
subst u1 u2; apply trans_clos_is_trans with (projection (Term f l2)); trivial.
apply trans_incl with (one_step R); trivial.
intros u1 u2 K; left; trivial.
Qed.

Lemma sub_projection :
  (forall n u v, strong_connect_approx n (u0,v0) (u,v) ->
  refl_trans_clos (union _ (one_step R) direct_subterm) (projection v) (projection u)) ->
   forall t1 t2 t3, R1 t3 t2 -> R1 t2 t1 ->
      trans_clos (union term (one_step R) direct_subterm) (projection t2) (projection t1).
Proof.
intros Hdp t1 t3 t5 H53 H31.
inversion H31 as [t3' t2 t1' H32 H21]; subst t1' t3'.
inversion H53 as [t5' t4 t3' H54 H43]; subst t3' t5'.
assert (B21 := dp0_decreases _ _ H21).
assert (B32 := between_dp0 Hdp t1 t2 t3 t4 H21 H32 H43).
inversion B32 as [t | t4' t3' B32'].
rewrite H0; assumption.
apply trans_clos_is_trans with (projection t2); assumption.
Qed.

Lemma acc_R_acc_dp :
forall t, Acc (one_step R) t -> Acc Rcdp t.
Proof.
intros t Acc_t.
apply Acc_incl with (rdp_step (axiom (ddp R)) R).
intros t1 t2 K; inversion K; clear K; subst.
apply Rdp_step with l2; trivial.
inversion H0; clear H0; subst; apply instance; apply cdp_in_dpR; trivial.
apply acc_one_step_acc_ddp; trivial.
Qed.

Lemma acc_R_acc_dp_sub :
forall t, Acc (one_step R) t -> Acc (union _ Rcdp (trans_clos direct_subterm)) t.
Proof.
intros t Acc_t; apply Acc_incl with (trans_clos (union _ (one_step R) direct_subterm)).
clear t Acc_t; intros s t [H1 | H2].
inversion H1; clear H1; subst.
inversion H0; clear H0; subst.
assert (H4 := cdp_in_dpR _ _ H3); clear H3.
destruct H4 as [H4 Sub].
inversion H4; clear H4; subst.
destruct (subterm_subterm _ _ H2) as [H4 | H4]; subst; inversion H; clear H; subst.
do 3 left; rewrite <- H1; apply instance; assumption.
apply trans_clos_is_trans with (Term f l2).
apply trans_incl with (one_step R).
do 3 intro; left; assumption.
do 2 left; rewrite <- H1; apply instance; assumption.
apply trans_incl with (one_step R).
do 3 intro; left; assumption.
apply general_context; assumption.
apply trans_clos_is_trans with (apply_subst sigma t3).
apply trans_incl with direct_subterm.
do 3 intro; right; assumption.
apply instantiated_subterm; assumption.
do 3 left; rewrite <- H1; apply instance; assumption.
apply trans_clos_is_trans with (apply_subst sigma t3).
apply trans_incl with direct_subterm.
do 3 intro; right; assumption.
apply instantiated_subterm; assumption.
apply trans_clos_is_trans with (Term f l2).
do 3 left; rewrite <- H1; apply instance; assumption.
apply trans_incl with (one_step R).
do 3 intro; left; assumption.
apply general_context; assumption.
apply trans_incl with direct_subterm; trivial.
do 3 intro; right; assumption.
apply acc_trans; rewrite <- acc_with_subterm; assumption.
Qed.

Definition Rcdp_min := rest (acc_sub R) Rcdp.
Definition Rdp_min' := rest (acc_sub R) Rdp'.
Definition Rdp0_min := rest (acc_sub R) Rdp0.

Lemma dp_subterm_criterion:
   (match v0 with
      | Var _  => True
      | Term f l =>
        match F.arity f with
        | AC => length l = 2
        | C => length l = 2
        | Free n => length l = n
        end
   end) ->
  (forall n u v, strong_connect_approx n (u0,v0) (u,v) ->
  refl_trans_clos (union _ (one_step R) direct_subterm) (projection v) (projection u)) ->
  well_founded Rdp_min' -> well_founded Rcdp_min.
Proof.
intros L Hdp W' t; apply (well_founded_ind W'); clear t.
intros t IH; apply Acc_intro; intros s [H [Ms Mt]].
rewrite split_dps in H; destruct H as [H | H].
apply IH.
split; [ | split ]; assumption.
apply Acc_incl with (union _ Rdp_min' Rdp0_min).
do 2 intro; intros [K [MW1 MW2]]; rewrite split_dps in K; destruct K as [K | K]; [left | right]; split; trivial.
split; assumption.
split; assumption.
apply acc_union_weak.
apply acc_inv_im2 with term (trans_clos (union term (one_step R) direct_subterm)) projection.
intros a1 a2 a3 H32 H21 H10.
assert (B := between_dp0 Hdp).
(*  a2  <- DP0 DP'* - a2 <- DP0 DP'* - a1<- (DP0 DP'* )* - g1h1sig1 <- DP0 f1k1sig1 *)
assert (H0 : exists a0, Rdp0 a1 a0).
inversion H10 as [a | a1' b1 K10]; clear H10; subst.
exists t; assumption.
inversion K10 as [a1' b1' H10 | a1' b1 c1' J10 K0]; clear K10.
subst a1' b1'.
inversion H10 as [a1' b1 c1' K1 K10]; clear H10.
subst a1' c1'.
exists b1; destruct K1; assumption.
subst a1' c1'.
inversion J10 as [a1' b1' c1 J1 J0]; clear J10.
subst a1' c1.
exists b1'; destruct J1; assumption.
destruct H0 as [a0 H0].
inversion H21 as [a2' b2 c2' K2 K1]; clear H21.
subst a2' c2'.
assert (K1' : refl_trans_clos Rdp' b2 a1).
apply refl_trans_incl with Rdp_min'; trivial.
do 2 intro; intros [K _]; assumption.
assert (K2' := proj1 K2).
assert (B' := B _ _ _ _ H0 K1' K2').
inversion B' as [p J1 J2 | pb2 pa1 B''].
apply dp0_decreases; assumption.
subst pb2 pa1.
apply trans_clos_is_trans with (projection b2); trivial.
apply dp0_decreases; assumption.
apply acc_trans; rewrite <- acc_with_subterm.
destruct s as [v | f l].
simpl; apply Acc_var; trivial.
apply Ms; apply (projection_is_subterm t).
assumption.
inversion H as [g l1 l2 t3 H1 H2]; clear H; subst.
inversion H2 as [t1 t2 sigma]; clear H2; subst.
inversion H; clear H; subst t1 t2.
assert (H4 := cdp_in_dpR _ _ cdp_uv0).
destruct H4 as [H4 _].
inversion H4; clear IH W'; subst.
injection H0; intros; subst f2 l; rewrite length_map.
assumption.
intros b _; apply W'.
Qed.

End Subterm.

Lemma dp_subterm_criterion_gen :
      forall R : relation term,
       (forall (v : variable) (t : term), ~ R t (Var v)) ->
       forall (l0 : list (term * term))
       (cdp cdp': term -> term -> Prop),
       (forall u v : term, cdp v u -> ddp R v u) ->
       forall (P : symbol -> nat),
       (forall u v, cdp v u <-> (cdp' v u \/ In (u,v) l0)) ->
       (forall u0 v0, In (u0,v0) l0 -> u0 <> v0) ->
       (forall u0 v0, In (u0,v0) l0 -> cdp v0 u0) ->
       (forall u0 v0, In (u0,v0) l0 -> match v0 with
       | Var _ => True
       | Term f _ =>
           match F.arity f with
           | AC => P f < 2
           | C => P f < 2
           | Free n => P f < n
           end
       end) ->
       (forall u0 v0, In (u0,v0) l0 -> trans_clos (union term (one_step R) direct_subterm) (projection P v0)
         (projection P u0)) ->
       forall comp : term * term -> nat -> Prop,
      (forall u v : term, cdp v u -> exists n : nat, comp (u, v) n) ->
     (forall uv n n', comp uv n -> comp uv n' -> n = n') ->
       (forall uv uv' : term * term,
        are_connected cdp R uv uv' ->
        forall n n' : nat, comp uv n -> comp uv' n' -> n <= n') ->
       forall n0, (forall uv0, In uv0 l0 -> comp uv0 n0) ->
       (forall u0 v0, In (u0,v0) l0 -> match v0 with
       | Var _ => True
       | Term f l =>
           match F.arity f with
           | AC => length l = 2
           | C => length l = 2
           | Free n => length l = n
           end
       end) ->
       (forall u v : term, comp (u, v) n0 ->
        refl_trans_clos (union term (one_step R) direct_subterm)
          (projection P v) (projection P u)) ->
       well_founded (rest (acc_sub R) (rdp_step (axiom cdp') R)) ->
       well_founded (rest (acc_sub R) (rdp_step (axiom cdp) R)).
Proof.
intros R R_var l0; induction l0 as [ | [u0 v0] l0];
intros cdp cdp' cdp_in_dpR P split_cdp l0_diff l0_in_dpR P_ok l0_decr
comp comp_def comp_fonc comp_ok n0 l0_in_comp_n0 Wl0 cdp_decr W'.

apply wf_incl with (rest (acc_sub R) (rdp_step (axiom cdp') R)); [ | assumption].
intros x y [H Hmin]; split; [ | assumption].
inversion H as [f l1 l2 t3 H1 H2]; clear H; subst.
constructor 1 with l2.
assumption.
inversion H2 as [t1 t2 sigma H3 H4]; clear H2; subst.
constructor 1.
rewrite split_cdp in H3; destruct H3 as [H3 | H3]; [assumption | contradiction].

apply (dp_subterm_criterion R R_var _ cdp_in_dpR P u0 v0) with comp.
apply l0_diff; left; apply eq_refl.
rewrite split_cdp; right; left; apply eq_refl.
apply P_ok with u0; left; apply eq_refl.
apply l0_decr; left; apply eq_refl.
assumption.
assumption.
apply Wl0 with u0; left; apply eq_refl.
unfold strong_connect_approx;  intros n u v [H1 H2]; apply cdp_decr.
replace n0 with n.
assumption.
apply comp_fonc with (u0,v0).
assumption.
apply l0_in_comp_n0; left; apply eq_refl.

apply wf_incl with (rest (acc_sub R) (rdp_step (axiom (fun v u => cdp' v u \/ In (u, v) l0)) R)).
intros x y [H Hmin]; split; [ | assumption].
inversion H as [f l1 l2 t3 H1 H2]; clear H; subst.
constructor 1 with l2.
assumption.
inversion H2 as [t1 t2 sigma H3 H4]; clear H2; subst.
constructor 1.
inversion H3 as [u v K1 K2]; clear H3; subst.
rewrite split_cdp in K1; simpl in K1; destruct K1 as [K1 | [K1 | K1]].
left; assumption.
apply False_rect; apply K2; apply sym_eq; assumption.
right; assumption.

apply IHl0 with cdp' P comp n0.
intros u v [H | H]; apply cdp_in_dpR; rewrite split_cdp; [left | do 2 right]; assumption.
intros u v; split; intro H; assumption.
intros; apply l0_diff; right; assumption.
intros; right; assumption.
intros u1 v1 uv1_in_l0; apply P_ok with u1; right; assumption.
intros u1 v1 uv1_in_l0; apply l0_decr; right; assumption.
intros u v [H | H]; apply comp_def.
rewrite split_cdp; left; assumption.
rewrite split_cdp; do 2 right; assumption.
assumption.
intros [u v] [u' v'] H; apply comp_ok.
destruct H as [sigma [sigma' [H1 [H2 H3]]]].
exists sigma; exists sigma'; split; [ | split].
rewrite split_cdp; destruct H1 as [H1 | H1]; [left | do 2 right]; assumption.
rewrite split_cdp; destruct H2 as [H2 | H2]; [left | do 2 right]; assumption.
assumption.
intros; apply l0_in_comp_n0; right; assumption.
intros u1 v1 uv1_in_l0; apply Wl0 with u1; right; assumption.
apply cdp_decr.
assumption.
Qed.

End MakeSubDP.


Require Import Coq.Lists.List.
Require Import Coq.Strings.String.
Require Import Coq.Reals.Rdefinitions.
Require Import ChargeTactics.Lemmas.
Require Import TLA.TLA.
Require Import TLA.DifferentialInduction.
Require Import TLA.ProofRules.
Require Import Examples.System2.
Require Import Examples.SecondDerivShimCtrlToMiddle4.

Local Open Scope string_scope.

Set Implicit Arguments.
Set Strict Implicit.

Module Type UpperLowerSecondParams.
  Parameter ub : R.

  Parameter d : R.
  Axiom d_gt_0 : (d > 0)%R.

  Parameter amin : R.
  Axiom amin_lt_0 : (amin < 0)%R.

  Parameter ubv : R.
  Parameter ub_ubv : (ubv*d + ubv*ubv*(0-/2)*(/amin) <= ub)%R.

End UpperLowerSecondParams.

Module UpperLowerSecond (Import P : UpperLowerSecondParams).

  Module Params <: SecondDerivShimParams.
    Definition ub := P.ub.
    Definition d := P.d.
    Definition d_gt_0 := P.d_gt_0.
    Definition amin := P.amin.
    Definition amin_lt_0 := P.amin_lt_0.
    Definition ubv := P.ubv.
    Definition ub_ubv := P.ub_ubv.
  End Params.

  Module Monitor := SecondDerivShimCtrl Params.

  Let mirror : RenameList :=
    {{ "y" ~> --"y" & "v" ~> --"v" & "a" ~> --"a" }}%rn.

  Definition mirrored : ActionFormula :=
    SysRename mirror (deriv_term_RenameList mirror)
              Monitor.Next.

  Definition Next : ActionFormula :=
    SysCompose mirrored Monitor.Next.

  Definition IndInv : StateFormula :=
    Rename mirror Monitor.IndInv //\\ Monitor.IndInv.

  Definition Next_Assumption : StateFormula :=
    Rename mirror Monitor.Next_Assumption //\\ Monitor.Next_Assumption.

  Lemma TimedPreserves_Next :
    Next_Assumption |-- TimedPreserves d IndInv Next.
  Proof with (refine _).
    unfold IndInv, Next. unfold SysCompose.
    rewrite SysCompose_simpl.
    rewrite <- TimedPreserves_And_simple...
    unfold Next_Assumption.
    charge_split.
    { rewrite Sys_rename_formula by eauto with rw_rename.
      rewrite SysRename_rule by eauto with rw_rename.
      rewrite TimedPreserves_Rename by eauto with rw_rename.
      rewrite <- Monitor.TimedPreserves_Next.
      charge_tauto. }
    { rewrite <- Monitor.TimedPreserves_Next.
      charge_tauto. }
  Qed.

  Theorem SysNeverStuck_Next : |-- SysNeverStuck d IndInv Next.
  Proof.
    eapply SysNeverStuck_Sys'; [ refine _ | pose proof d_gt_0 ; solve_linear | | ].
    { enable_ex_st.
      pose proof P.amin_lt_0. pose proof P.d_gt_0.
      destruct (RIneq.Rge_dec (st "y") R0).
      { do 3 eexists; exists d; solve_linear. }
      { do 3 eexists; exists d.
        repeat split.
        { solve_linear. }
        { solve_linear. }
        { right. instantiate (1:=(-Params.amin)%R).
          solve_linear. }
        { right. intros. apply RIneq.Rgt_ge in H3.
          contradiction. } } }
    { admit. (** Provable, but we won't worry about it *) }
  Qed.

  Definition Safe : StateFormula :=
    Rename mirror Monitor.Safe //\\ Monitor.Safe.

  Lemma IndInv_impl_Safe : Next_Assumption //\\ IndInv //\\ TimeBound d |-- Safe.
  Proof with (eauto with rw_rename).
    charge_split.
    { rewrite <- Monitor.IndInv_impl_Safe.
      unfold IndInv, Next_Assumption.
      Rename_rewrite.
      do 2 (charge_split; try charge_assumption).
      repeat rewrite <- Rename_ok...
      simpl rename_formula. charge_tauto. }
    { rewrite <- Monitor.IndInv_impl_Safe.
      charge_tauto. }
  Qed.

  Local Open Scope HP_scope.

  Lemma UpperLower_safe :
    []Next_Assumption |-- (IndInv //\\ TimeBound d) //\\ []Next -->> []Safe.
  Proof.
    rewrite <- IndInv_impl_Safe.
    rewrite <- Always_and.
    charge_intros; charge_split; try charge_assumption.
    charge_revert.
    eapply Inductively.Preserves_Inv.
    - compute; tauto.
    - reflexivity.
    - eapply TimedPreserves_Next.
  Qed.

End UpperLowerSecond.


Require Import String List.
Require Import CoqCompile.CpsK.
Require Import CoqCompile.CpsKUtil.
Require Import ExtLib.ExtLib.
Require Import ExtLib.Structures.Monads.
Require Import ExtLib.Structures.Sets.
Require Import ExtLib.Structures.Maps.
Require Import ExtLib.Structures.Reducible.
Require Import ExtLib.Structures.Monoid.
Require Import ExtLib.Data.Set.ListSet.
Require Import ExtLib.Data.Map.FMapAList.

Set Implicit Arguments.
Set Strict Implicit.

Section map_monoid.
  Variable M : Type -> Type.
  Variable K : Type.
  Variable E : Type.
  Variable Monoid_e : Monoid E.
  Context {DMap_M : DMap K M}.
  Context {Foldable_M : Foldable (M E) (K * E)}.

  Definition Monoid_map : Monoid (M E) :=
  {| monoid_unit := Maps.empty
   ; monoid_plus := Maps.combine (K := K) (fun _ => monoid_plus Monoid_e)
  |}.
End map_monoid.

Module Contify.

  Import CpsK.CPSK.

  (** A function [f] can be made into a continuation [k] if all execution
   ** paths in [f] return to the same continuation.
   **
   ** Further: The function must be in the scope of the continuation (can I move it?).
   ** In particular, this means that I can not contify a function inside a function
   ** if I know that it refers to the outer continuation.
   ** - My analysis should never say that I can do this because we always do return
   **   to a passed-in continuation
   **)

  Definition map_monoid : Monoid (alist var (lset (@eq (list cont)))) :=
      @Monoid_map (alist var) _ _ (@Monoid_set_union _ _ _ _) _ _.

  Definition set_monoid := @Monoid_set_union (lset (@eq var)) _ _ _.

  Section monadic.
    Variable m : Type -> Type.
    Context {Monad_m : Monad m}.
    Context {Contexts_m : MonadWriter map_monoid m}.
    Context {Escapes_m : MonadWriter set_monoid m}.
    Context {MonadExc_m : MonadExc string m}.
    Context {ContSubst_m : MonadReader (alist cont cont) m}.

    Definition call (f : op) (ks : list cont) : m unit :=
      match f with
        | Var_o f =>
          tell (Maps.singleton f (Sets.singleton ks))
        | _ => raise "Calling non-variable"%string
      end.

    Definition escapes (o : op) : m unit :=
      match o with
        | Var_o v => tell (Sets.singleton v)
        | _ => ret tt
      end.

    Import MonadNotation.
    Local Open Scope monad_scope.

    Definition isSingleton {A} (ls : lset (@eq A)) : option A :=
      match ls with
        | x :: nil => Some x
        | _ => None
      end.

    Fixpoint replaceCalls (f : op) (k : cont) (e : exp) : exp :=
      match e with
        | App_e f' ks xs => if eq_dec f f' then AppK_e k xs else e
        | AppK_e _ _ => e
        | Halt_e _ _ => e
        | Let_e d e => Let_e d (replaceCalls f k e)
        | LetK_e ks e =>
          let ks' := map (fun kxse => let '(k,xs,e) := kxse in
            (k, xs, replaceCalls f k e)) ks
          in
          LetK_e ks' (replaceCalls f k e)
        | Letrec_e ds e =>
          Letrec_e ds (replaceCalls f k e)
        | Switch_e o arms def =>
          let arms' := map (fun x => (fst x, replaceCalls f k (snd x))) arms in
          let def' := map (replaceCalls f k) def in
          Switch_e o arms' def'
      end.

    Definition replaceAllCalls (cs : list (op * cont)) (e : exp) : exp :=
      List.fold_left (fun acc e_c => let '(f,c) := e_c in
        replaceCalls f c acc) cs e.

    Definition var_to_cont (v : var) : m cont :=
      ret match v with
            | Anon_v p => K "" p
            | Named_v s None => K s 1
            | Named_v s (Some p) => K s p
          end.

    Definition contify_k (k : cont) : m cont :=
      k' <- asks (Maps.lookup k) ;;
      match k' with
        | None => ret k
        | Some k => ret k
      end.

    Fixpoint withConts {T} (ks ks' : list cont) (c : m T) : m T :=
      match ks , ks' with
        | nil , nil => c
        | k :: ks , k' :: ks' => local (Maps.add k k') (withConts ks ks' c)
        | _ , _ => raise "inconsistent continutations "%string
      end.

    Definition mark_escapes (rec : bool) (d : decl) : m unit :=
      let fvars : lset (@eq (var + cont)) := free_vars_decl rec d in
      iterM (fun x => match x with
                        | inl v => escapes (Var_o v)
                        | _ => ret tt
                      end) fvars.

    Definition remove_escapes {T} (ls : list var) (c : m T) : m T :=
      censor (List.fold_left (fun acc v => Sets.remove v acc) ls) c.

    Definition remove_calls {T} (ls : list var) (c : m T) : m T :=
      censor (List.fold_left (fun acc v => Maps.remove v acc) ls) c.

    Definition contifiable (f : var) (escapes : lset (@eq var)) (calls : alist var (lset (@eq (list cont)))) : option (list cont) :=
      if Sets.contains f escapes then None
      else match Maps.lookup f calls with
             | None => Some nil (** it isn't used and it doesn't escape, it is dead code **)
             | Some calls => isSingleton calls
           end.

    Fixpoint contify_exp (e : exp) : m exp.
    refine (
      match e with
        | AppK_e k xs =>
          iterM escapes xs ;;
          k <- contify_k k ;;
          ret (AppK_e k xs)
        | App_e f ks xs =>
          iterM escapes xs ;;
          ks <- mapM contify_k ks ;;
          call f ks ;;
          ret (App_e f ks xs)
        | Halt_e x w =>
          ret (Halt_e x w)
        | Switch_e o arms def =>
          arms' <- mapM (fun pe => let '(p,e) := pe in
            e' <- contify_exp e ;;
            ret (p, e')) arms ;;
          def' <- mapM contify_exp def ;;
          ret (Switch_e o arms' def')
        | Let_e (Fn_d f ks xs e_body) e =>
          e'_conts <- remove_escapes xs (censor (Maps.remove f) (listen (MonadWriter := Escapes_m) (listen (MonadWriter := Contexts_m) (contify_exp e)))) ;;
          let '(e',calls,escape_vars) := e'_conts in
          let contifiable := contifiable f escape_vars calls in
          match contifiable with
            | None =>
              e_body' <- contify_exp e_body ;;
              mark_escapes false (Fn_d f ks xs e_body') ;;
              ret (Let_e (Fn_d f ks xs e_body') e')
            | Some args =>
              (** We can contify f **)
              k <- var_to_cont f ;;
              let e' := replaceCalls (Var_o f) k e' in
              e_body' <- withConts ks args (contify_exp e_body) ;;
              ret (LetK_e ((k, xs, e_body') :: nil) e')
          end
        | Let_e d e =>
          mark_escapes false d ;;
          e' <- contify_exp e ;;
          ret (Let_e d e')
        | Letrec_e ds e =>
          e' <- contify_exp e ;;
          let names := List.map (fun d => match d with
                                            | Fn_d v _ _ _
                                            | Prim_d v _ _
                                            | Op_d v _
                                            | Bind_d v _ _ _ => v
                                         end) ds in
          (** Only consider for contification if it contains only functions **)
          let has_non_func := List.fold_left (fun acc d => match d with
                                                             | Fn_d _ _ _ _ => acc
                                                             | _ => true
                                                           end) ds false in
          if has_non_func then
            (** mark the escapes and return **)
            iterM (mark_escapes true) ds ;;
            ret (Letrec_e ds e')
          else
            func_names <- mapM (fun d => match d with
                                           | Fn_d v _ _ _ => ret v
                                           | _ => raise "unreachable"%string
                                         end) ds ;;
            e'_conts <- remove_escapes func_names (remove_calls func_names (listen (listen (
              ds <- mapM (fun d =>
                match d with
                  | Fn_d v ks xs e =>
                    e' <- remove_escapes xs (contify_exp e) ;;
                    ret (Fn_d v ks xs e)
                  | _ => raise "unreachable"%string
                end) ds ;;
              e' <- contify_exp e ;;
              ret (ds, e')
            )))) ;;
            let '((ds',e'),conts,escape_vars) := e'_conts in
            (** we can contify if all ds are contifiable **)
            (fix continue (ds : list decl) (ks' : list (var * list var * exp)) :=
              match ds with
                | nil =>
                  (** We can contify the let rec **)
                  ks'' <- mapM (fun f => let '(f,_,_) := f in
                                 k' <- var_to_cont f ;;
                                 ret (Var_o f, k')) ks' ;;
                  let _ : alist op cont := ks'' in
                  ks' <-
                    mapM (fun kxse => let '(f,xs,e) := kxse in
                      match Maps.lookup (Var_o f) ks'' with
                        | None => raise "unreachable"%string
                        | Some k => ret (k, xs, replaceAllCalls ks'' e)
                      end) ks' ;;
                  ret (LetK_e ks' (replaceAllCalls ks'' e'))
                | Fn_d v ks xs e :: ds =>
                  match contifiable v conts escape_vars with
                    | None =>
                      (** can't contify **)
                      ret (Letrec_e ds' e')
                    | Some args =>
                      continue ds ((v, xs, e) :: ks')
                  end
                | _ => raise "unreachable"%string
              end) ds' nil
        | LetK_e ks e =>
          ks' <- mapM (fun kxse => let '(k,xs,e) := kxse in
            e' <- contify_exp e ;;
            ret (k, xs, e')) ks ;;
          e' <- contify_exp e ;;
          ret (LetK_e ks' e')
      end).
    Defined.
  End monadic.

  Require Import ExtLib.Data.Monads.WriterMonad.
  Require Import ExtLib.Data.Monads.ReaderMonad.

  Definition contify (e : exp) : string + exp :=
    runReaderT (evalWriterT (Monoid_S := set_monoid) (evalWriterT (Monoid_S := map_monoid) (contify_exp e))) (Maps.empty : alist cont cont).

(*
  Module TESTS.
    Require Import ExtLib.Programming.Show.
    Require Import CoqCompile.CpsKConvert.
    Require Import CoqCompile.Parse.

(*
    Fixpoint even (x : nat) :=
      match x with
        | 0 => true
        | S n => odd n
      end
    with odd (x : nat) :=
      match x with
        | 0 => false
        | S n => even n
      end.
    Definition main := even 1.

    Extraction Language Scheme.
    Recursive Extraction main.
*)

    Definition even :=
      "(define even (lambda (x)
  (match x
     ((O) `(True))
     ((S n) (odd n)))))

(define odd (lambda (x)
  (match x
     ((O) `(False))
     ((S n) (even n)))))

(define main (even `(S ,`(O))))"%string.

    Definition simple :=
      "(define f (lambda (x) `(S ,x)))

       (define main (f `(S ,`(O))))"%string.

    Definition simple_no :=
      "(define f (lambda (x) `(S ,x)))

       (define main `(Pair ,f ,(f `(S ,`(O)))))"%string.

    Definition simple_lam :=
      Eval vm_compute in
      Parse.parse_topdecls simple.

    Definition simple_cps : CPSK.exp :=
      Eval vm_compute in
      match simple_lam as parsed return match parsed with
                                      | inl _ => unit
                                      | inr _ => CPSK.exp
                                    end
        with
        | inl _ => tt
        | inr x =>
          let res := CpsKConvert.CPS_pure x in res (*
          match res with
            | Letrec_e (d :: nil) e => Let_e d e
            | _ => res
          end *)
      end.

    Eval vm_compute in to_string simple_cps.
    Eval vm_compute in to_string (contify simple_cps).

    Definition simple_no_lam :=
      Eval vm_compute in
      Parse.parse_topdecls simple_no.

    Definition simple_no_cps : CPSK.exp :=
      Eval vm_compute in
      match simple_no_lam as parsed return match parsed with
                                      | inl _ => unit
                                      | inr _ => CPSK.exp
                                    end
        with
        | inl _ => tt
        | inr x =>
          let res := CpsKConvert.CPS_pure x in
          match res with
            | Letrec_e (d :: nil) e => Let_e d e
            | _ => res
          end
      end.

    Eval vm_compute in to_string simple_no_cps.
    Eval vm_compute in to_string (contify simple_no_cps).

    Definition even_lam :=
      Eval vm_compute in
      Parse.parse_topdecls even.

    Definition even_cps : CPSK.exp :=
      Eval vm_compute in
      match even_lam as parsed return match parsed with
                                      | inl _ => unit
                                      | inr _ => CPSK.exp
                                    end
        with
        | inl _ => tt
        | inr x =>
          let res := CpsKConvert.CPS_pure x in res (*
          match res with
            | Letrec_e (d :: nil) e => Let_e d e
            | _ => res
          end *)
      end.

    Eval vm_compute in to_string even_cps.
    Eval vm_compute in to_string (contify even_cps).

  End TESTS.
*)

End Contify.


(** We define high-level Pseudo-SPARCv8 language in this File *)
Require Import Coqlib.
Require Import Maps.

Require Import Classical_Prop.

Require Import Integers.
Require Import LibTactics.
Open Scope Z_scope.
Import ListNotations.

Require Import state.
Require Import language.
Require Import highlang.
Require Import lowlang.
Require Import logic.
Require Import reg_lemma.
Require Import soundness.
Require Import refinement.

Set Asymmetric Patterns.

Set Implicit Arguments.
Unset Strict Implicit.

Open Scope code_scope.
Open Scope mem_scope.

(*+ Relational Assertion Language +*)
(** High-level Primitive Command *)
Inductive primcom :=
| Pm : ap -> list Val -> primcom | Pdone : primcom.

(** Syntax of relational assertion language *)
Inductive relasrt : Type :=
| RAreg : HRegName -> Val -> relasrt
| RAmapsto : Address -> Val -> relasrt
| RAEmp : relasrt
| RAcur : Tid -> tlocst -> relasrt
| RArdy : Tid -> tlocst -> relasrt
| RAlst : asrt -> relasrt
| RAprim : primcom -> relasrt
| RAtoken : nat -> relasrt
| RATimeReduce : relasrt -> relasrt
| RAtrue : relasrt
| RAfalse : relasrt
| RAconj : relasrt -> relasrt -> relasrt
| RAdisj : relasrt -> relasrt -> relasrt
| RAstar : relasrt -> relasrt -> relasrt
| RAforall (ty : Type) (P : ty -> relasrt)
| RAexists (ty : Type) (P : ty -> relasrt).

Notation "t ⇝c K" := (RAcur t K) (at level 20).
Notation "t ⇝r K" := (RArdy t K) (at level 20).
Notation "P ⤈" := (RATimeReduce P) (at level 20).
Infix "⋆" := RAstar (at level 31, right associativity).

(** relational state *)
Definition RelState : Type := State * HState * primcom * nat.

Definition hstate_union (hs1 hs2 hs : HState) :=
  match hs1, hs2 with
  | (T1, t1, K1, M1), (T2, t2, K2, M2) =>
    disjoint T1 T2 /\ disjoint M1 M2 /\ hs = (T1 ⊎ T2, t1, K1, M1 ⊎ M2) /\ t1 = t2 /\ K1 = K2
  end.

(** high-level primcom transition *)
Inductive exec_prim : primcom * HState -> primcom * HState -> Prop :=
| PrimExec : forall (prim : ap) lv hs hs',
    prim lv hs hs' -> exec_prim (Pm prim lv, hs) (Pdone, hs').

(* get register file from current thread's local state *)
Definition getHR_K (K : tlocst) :=
  match K with
  | (Q, pc, npc) => match Q with
                   | (HR, b, HF) => HR
                   end
  end.

(* get register file from high-level state *)
Definition getHR (hs : HState) :=
  match hs with
  | (T, t, K, M) => getHR_K K
  end.

(* get memory from high-level state *)
Definition getHM (hs : HState) :=
  match hs with
  | (T, t, K, M) => M
  end.

(* get ThreadPool from high-level state *)
Definition getHThrdPool (hs : HState) :=
  match hs with
  | (T, t, K, M) => T
  end.

(* get HRstate from high-level state *)
Definition getHQ (hs : HState) :=
  match hs with
  | (T, t, K, M) => match K with
                   | (HQ, pc, npc) => HQ
                   end
  end.

(* get low state from relational state *)
Definition get_ls_rls (rls : RelState) :=
  match rls with
  | (s, hs, A, w) => s
  end.

Definition relsatEmp (rls : RelState) :=
  match rls with
  | (s, hs, A, w) =>
    match hs with
    | (T, t, K, M) => M = empM /\ T = EmpThrdPool /\ sat s Aemp
    end
  end.

Definition relsatCurSt (rls : RelState) (t' : Tid) (K' : tlocst) :=
  match rls with
  | (s, hs, A, w) =>
    match hs with
    | (T, t, K, M) => t = t' /\ K = K' /\ relsatEmp (s, hs, A, w)
    end
  end.

Definition relsatRdySt (rls : RelState) (t' : Tid) (K' : tlocst) :=
  match rls with
  | (s, hs, A, w) =>
    match hs with
    | (T, t, K, M) => T = ThrdMap.set t' (Some K') EmpThrdPool /\ M = empM /\ sat s Aemp
    end
  end.

(** Semantics of relational assertion language *)
Fixpoint relsat (rls : RelState) (P : relasrt) {struct P} : Prop :=
  match rls with
  | (s, hs, A, w) =>
    match P with
    | RAreg hrn v => exists t K, relsatCurSt (s, hs, A, w) t K /\ (getHR_K K) hrn = Some v
    | RAmapsto l v => getHM hs = MemMap.set l (Some v) empM /\
                     getHThrdPool hs = EmpThrdPool /\ sat s Aemp
    | RAEmp => relsatEmp (s, hs, A, w)
    | RAcur t K => relsatCurSt (s, hs, A, w) t K
    | RArdy t K => relsatRdySt (s, hs, A, w) t K
    | RAlst p => sat s p /\ getHM hs = empM /\ getHThrdPool hs = EmpThrdPool
    | RAprim A' => A = A' /\ relsatEmp (s, hs, A, w)
    | RAtoken num => (num <= w)%nat /\ relsatEmp (s, hs, A, w)
    | RATimeReduce P' => exists R D, exe_delay R D = (getregs s, getdlyls s) /\
                               relsat ((upddlyls (updregs s R) D), hs, A, w) P'
    | RAtrue => True
    | RAfalse => False
    | RAconj P1 P2 => relsat (s, hs, A, w) P1 /\ relsat (s, hs, A, w) P2
    | RAdisj P1 P2 => relsat (s, hs, A, w) P1 \/ relsat (s, hs, A, w) P2
    | RAstar P1 P2 => exists hs1 hs2 s1 s2 w1 w2, hstate_union hs1 hs2 hs /\ state_union s1 s2 s /\ (w = w1 + w2)%nat /\
                                            relsat (s1, hs1, A, w1) P1 /\ relsat (s2, hs2, A, w2) P2
    | RAforall ty P' => forall (x : ty), relsat (s, hs, A, w) (P' x)
    | RAexists ty P' => exists (x : ty), relsat (s, hs, A, w) (P' x)
    end
  end.

Notation "rls '||=' P" := (relsat rls P) (at level 34, no associativity).
Notation "P ⇒ Q" :=
  (forall rls, rls ||= P -> rls ||= Q)
    (at level 34, right associativity).
Notation "P ⇔ Q" :=
  (forall rls, rls ||= P <-> rls ||= Q)
    (at level 34, right associativity).

(*+ Inference Rules for Refinement Verification +*)
Inductive Logic_var : Type :=
| logic_llvar : logicvar -> Logic_var
| logic_hreg : HRegName -> Logic_var
| logic_hfmls : HFrameList -> Logic_var.

Definition Fpre := list Logic_var -> relasrt.
Definition Fpost := list Logic_var -> relasrt.
Definition Fspec : Type := Fpre * Fpost.
Definition Funspec := Word -> option Fspec.

Definition ImplyPrim (P P' : relasrt) :=
  forall s hs A w, (s, hs, A, w) ||= P ->
              (exists hs' A' w', exec_prim (A, hs) (A', hs') /\ (s, hs', A', w') ||= P') \/ (s, hs, A, w) ||= P'.
Notation "P ⭆ P'" := (ImplyPrim P P') (at level 34, right associativity).

(** Sta of frame asrt *)
Inductive Sta : primcom -> relasrt -> Prop :=
| consSta : forall A Pr,
    (
      forall hprim lv, A = Pm hprim lv ->
                  (
                    forall HSc HSc' HSr w S HS,
                      exec_prim (Pm hprim lv, HSc) (Pdone, HSc') ->
                      hstate_union HSc HSr HS ->
                      (S, HSr, Pm hprim lv, w) ||= Pr ->
                      (
                        exists HS' HSr', exec_prim (Pm hprim lv, HS) (Pdone, HS') /\
                                    hstate_union HSc' HSr' HS' /\
                                    (S, HSr', Pdone, w) ||= Pr
                      )
                  )
    ) \/ A = Pdone ->
    Sta A Pr.

Fixpoint GoodFrm (Pr : relasrt) :=
  match Pr with
  | RAreg hrn v => False
  | RAcur t K => False
  | RAprim A => False
  | RATimeReduce Pr' => GoodFrm Pr'
  | RAconj P1 P2 => GoodFrm P1 /\ GoodFrm P2
  | RAdisj P1 P2 => GoodFrm P1 /\ GoodFrm P2
  | RAstar P1 P2 => GoodFrm P1 /\ GoodFrm P2
  | RAforall ty P => forall x : ty, GoodFrm (P x)
  | RAexists ty P => exists x : ty, GoodFrm (P x)
  | _ => True
  end.

Definition ImplyPrim' (P P' : relasrt) :=
  forall s hs A w, (s, hs, A, w) ||= P -> (forall Pr, GoodFrm Pr -> Sta A Pr) ->
              (exists hs' A' w', exec_prim (A, hs) (A', hs') /\ (s, hs', A', w') ||= P') \/ (s, hs, A, w) ||= P'.

Definition FretSta (P1 P2 : relasrt) :=
  forall rls rls', rls ||= P1 -> rls' ||= P2 ->
          (exists f, (getregs (get_ls_rls rls)) r15 = Some (W f) /\
                (getregs (get_ls_rls rls')) r15 = Some (W f)).

(** well-formed instruction *)
Inductive rel_wf_ins : relasrt -> ins -> relasrt -> Prop :=
| Rel_wf_ins : forall P P' Pr p p' i,
    P ⇒ (RAlst p) ⋆ Pr -> wf_ins p i p' -> RAlst p' ⋆ Pr ⇒ P' ->
    rel_wf_ins P i P'.

Notation " '⊩' '{{' P '}}' i '{{' Q '}}' " := (rel_wf_ins P i Q) (at level 50).

(** well-formed instruction sequence *)
Inductive rel_wf_seq : Funspec -> relasrt -> Label -> InsSeq -> relasrt -> Prop :=
| rel_seq_rule : forall f i I P P' Q Spec,
    ⊩ {{ P ⤈ }} i {{ P' }} -> rel_wf_seq Spec P' (f +ᵢ ($ 4)) I Q ->
    rel_wf_seq Spec P f (i ;; I) Q

| rel_call_rule : forall f f' i I P P1 P2 P' Q Pr Fp Fq (L : list Logic_var) v (Spec : Funspec),
    Spec f' = Some (Fp, Fq) ->
    (P ⤈) ⇒ (RAlst (r15 |=> v)) ⋆ P1 ->
    ⊩ {{ ((RAlst (r15 |=> W f)) ⋆ P1) ⤈ }} i {{ P2 ⋆ RAtoken (1%nat) }} ->
    P2 ⇒ Fp L ⋆ Pr -> Fq L ⋆ Pr ⇒ P'-> Fq L ⇒ RAlst ((Or r15) ==ₑ W f) -> GoodFrm Pr ->
    rel_wf_seq Spec P' (f +ᵢ ($ 8)) I Q ->
    rel_wf_seq Spec P f (call f' # i # I) Q

| rel_retl_rule : forall P P' Q f i Spec,
    ⊩ {{ (P ⤈) ⤈ }} i {{ P' }} -> P' ⇒ Q -> FretSta ((P ⤈) ⤈) P' ->
    rel_wf_seq Spec P f (retl ;; i) Q

| rel_J_rule : forall P P1 P' Q (r1 : GenReg) f f' aexp Spec Fp Fq L v Pr i,
    (P ⤈) ⇒ RAlst (aexp ==ₓ W f') -> Spec f' = Some (Fp, Fq) ->
    (P ⤈) ⇒ RAlst (r1 |=> v) ⋆ P1 -> ⊩ {{ (RAlst (r1 |=> W f) ⋆ P1) ⤈ }} i {{ P' ⋆ RAtoken (1%nat) }} ->
    P' ⇒ Fp L ⋆ Pr -> Fq L ⋆ Pr ⇒ Q -> GoodFrm Pr ->
    rel_wf_seq Spec P f (consJ aexp r1 i) Q

| rel_Be_rule : forall P P' Q bv Spec L f f' Pr i I Fp Fq,
    Spec f' = Some (Fp, Fq) ->
    P ⇒ RAlst (z |=> W bv) ⋆ RAtrue -> ⊩ {{ P ⤈⤈ }} i {{ P' ⋆ RAtoken (1%nat) }} ->
    (bv =ᵢ ($ 0) = true -> rel_wf_seq Spec (P' ⋆ RAtoken (1%nat)) (f +ᵢ ($ 8)) I Q) ->
    ((bv =ᵢ ($ 0) = false) -> ((P' ⇒ Fp L ⋆ Pr) /\ (Fq L ⋆ Pr ⇒ Q) /\ GoodFrm Pr)) ->
    rel_wf_seq Spec P f (be f' # i # I) Q

| rel_ABSCSQ_rule : forall P P' Q Q' f I Spec,
    P ⭆ P' -> rel_wf_seq Spec P' f I Q' -> Q' ⭆ Q ->
    rel_wf_seq Spec P f I Q.

Notation " Spec '⊩' '{{' P '}}' f '#' I '{{' Q '}}' " :=
  (rel_wf_seq Spec P f I Q) (at level 55).

(* basic ext code block constructor *)
Inductive LookupXC : XCodeHeap -> Label -> InsSeq -> Prop :=
| XlookupNoTransIns :
    forall C f I i,
      C f = Some (c (cntrans i)) -> LookupXC C (f +ᵢ ($ 4)) I ->
      LookupXC C f (i ;; I)
| XlookupJmp :
    forall C f i aexp rr,
      C f = Some (c (cjumpl aexp rr)) ->
      C (f +ᵢ ($ 4)) = Some (c (cntrans i)) ->
      LookupXC C f (consJ aexp rr i)
| XlookupRetl :
    forall C f i,
      C f = Some (c (cretl)) -> C (f +ᵢ ($ 4)) = Some (c (cntrans i)) ->
      LookupXC C f (retl ;; i)
| XlookupCall :
    forall C f f' i I,
      C f = Some (c (ccall f')) -> C (f +ᵢ ($ 4)) = Some (c (cntrans i)) ->
      LookupXC C (f +ᵢ ($ 8)) I ->
      LookupXC C f (call f' # i # I)
| XlookupBe :
    forall C f f' i I,
      C f = Some (c (cbe f')) -> C (f +ᵢ ($ 4)) = Some (c (cntrans i)) ->
      LookupXC C (f +ᵢ ($ 8)) I ->
      LookupXC C f (be f' # i # I).

(** Well-formed Code Heap *)
Definition rel_wf_cdhp (Spec : Funspec) (C : XCodeHeap) :=
  forall f L fp fq,
    Spec f = Some (fp, fq) ->
    exists I, LookupXC C f I /\ rel_wf_seq Spec (fp L) f I (fq L).

(** Invariant *)
Definition INV (A : primcom) (lv : list Val) (rls : RelState)
           (restoreQ : Memory -> RState -> Prop) :=
  match rls with
  | (s, hs, A, w) =>
    wp_stateRel restoreQ s hs /\
    ((exists hs', exec_prim (A, hs) (Pdone, hs') /\ A <> Pdone) \/ A = Pdone)
                         /\ args (getHQ hs) (getHM hs) lv
  end.

Definition upd_rls_token (rls : RelState) (w' : nat) :=
  match rls with
  | (s, hs, A, w) => (s, hs, A, w')
  end.

(** Well-formed Spec *)
Inductive wdSpec (restoreQ : Memory -> RState -> Prop) : Fpre -> Fpost -> ap -> Prop :=
| consWdSpec : forall Fp Fq (hprim : ap),
    (
      (forall lv hs hs' (f : Word), hprim lv hs hs' -> (getHR hs' r15 = Some (W f)) ->
                               get_Hs_pcont hs' = (f +ᵢ ($ 8), f +ᵢ ($ 12)))
      /\ (forall Pr lv, GoodFrm Pr -> Sta (Pm hprim lv) Pr)
    ) ->
    (
      forall L, exists vl, Fp L ⇒ RAprim (Pm hprim vl) ⋆ RAtrue /\ Fq L ⇒ RAprim Pdone ⋆ RAtrue
    ) ->
    (
      forall lv rls, INV (Pm hprim lv) lv rls restoreQ ->
                     exists num Pr L,
                       upd_rls_token rls num ||= (Fp L) ⋆ Pr /\
                       (forall rls', rls' ||= (Fq L) ⋆ Pr -> exists lv', INV Pdone lv' rls' restoreQ) /\
                       Sta (Pm hprim lv) Pr
    ) ->
    wdSpec restoreQ Fp Fq hprim.

(** Well-formed Primitive *)
Definition rel_wf_prim (Spec : Funspec) (C : XCodeHeap) (PrimSet : apSet)
           (restoreQ : Memory -> RState -> Prop) :=
  exists Speci, rel_wf_cdhp Speci C /\
           (forall f L hprim, PrimSet f = Some hprim ->
                              (exists Fp Fq I, Spec f = Some (Fp, Fq) /\ LookupXC C f I /\
                                                  (* Fp L ⇒ RAprim (Pm hprim vl) ⋆ RAtrue /\ *)
                                               wdSpec restoreQ Fp Fq hprim
                                               /\ rel_wf_seq Speci (Fp L) f I (Fq L))).

(*+ Logic Soundness +*)
(** index *)
Definition Index : Type := nat * (nat * nat).

(** Index lt *)
Definition LtIndex := lex_ord Nat.lt (lex_ord Nat.lt Nat.lt).
Notation "i ⩹ j" := (LtIndex i j) (at level 34, right associativity).

Lemma well_founded_LtIndex : well_founded LtIndex.
Proof.
  eapply wf_lex_ord.
  eapply Nat.lt_wf_0.
  eapply wf_lex_ord; eapply Nat.lt_wf_0.
Qed.

(** soundness of instruction rule *)
Definition rel_ins_sound P Q i :=
  forall s sh A w,
    (s, sh, A, w) ||= P -> (exists s', (Q__ s (cntrans i) s') /\ (s', sh, A, w) ||= Q).

(** soundness of instruction sequence rule *)
CoInductive rel_safety_insSeq :
  Funspec -> nat -> (XCodeHeap * State * Word * Word) -> (primcom * HState) -> relasrt -> Prop :=
| Rsafety_insSeq : forall C (S : State) (pc npc : Word) A (HS : HState) Q Spec w,
    (* i_seq *)
    (
      forall i,
        C pc = Some (c (cntrans i)) ->
        (
          (* progress *)
          exists S' pc' npc',
            LP__ (C, (S, pc, npc)) tau (C, (S', pc', npc'))
        ) /\
        (
          (* preservation *)
          forall S' pc' npc',
            LP__ (C, (S, pc, npc)) tau (C, (S', pc', npc')) ->
            (
              (
                rel_safety_insSeq Spec w (C, S', pc', npc') (A, HS) Q
              )
              \/
              (
                exists HS' w', exec_prim (A, HS) (Pdone, HS')
                       /\ rel_safety_insSeq Spec w' (C, S', pc', npc') (Pdone, HS') Q
              )
            )
        )
    ) ->
    (* call seq *)
    (
      forall f,
        C pc = Some (c (ccall f)) ->
        (
          (* progress *)
          exists S1 S2 pc1 npc1 pc2 npc2,
            LP__ (C, (S, pc, npc)) tau (C, (S1, pc1, npc1)) /\
            LP__ (C, (S1, pc1, npc1)) tau (C, (S2, pc2, npc2))
        ) /\
        (
          (* preservation *)
          forall S1 S2 pc1 npc1 pc2 npc2,
            LP__ (C, (S, pc, npc)) tau (C, (S1, pc1, npc1)) ->
            LP__ (C, (S1, pc1, npc1)) tau (C, (S2, pc2, npc2)) ->
            (
              exists Fp Fq L r A' HS' w'',
                pc2 = f /\ npc2 = f +ᵢ ($ 4) /\
                Spec f = Some (Fp, Fq) /\ (w'' > 0)%nat /\
                ((A' = A /\ HS = HS' /\ w'' = w) \/ (exec_prim (A, HS) (A', HS'))) /\
                (S2, HS', A', Nat.pred w'') ||= (Fp L) ⋆ r /\ GoodFrm r /\
                (forall S' HS' A' w', (S', HS', A', w') ||= (Fq L) ⋆ r -> (forall Pr, GoodFrm Pr -> Sta A' Pr) ->
                                 rel_safety_insSeq Spec w' (C, S', (pc +ᵢ ($ 8)), (pc +ᵢ ($ 12))) (A', HS') Q) /\
                (forall S' HS' A' w', (S', HS', A', w') ||= Fq L ->
                                 get_R (getregs S') r15 = Some (W pc))
            )
        )
    ) ->
    (* jmpl *)
    (
      forall aexp rd,
        C pc = Some (c (cjumpl aexp rd)) ->
        (
          (* progress *)
          exists S1 S2 pc1 npc1 pc2 npc2,
            LP__ (C, (S, pc, npc)) tau (C, (S1, pc1, npc1)) /\
            LP__ (C, (S1, pc1, npc1)) tau (C, (S2, pc2, npc2))
        ) /\
        (
          forall S1 S2 pc1 npc1 pc2 npc2,
            LP__ (C, (S, pc, npc)) tau (C, (S1, pc1, npc1)) ->
            LP__ (C, (S1, pc1, npc1)) tau (C, (S2, pc2, npc2)) ->
            (
              exists Fp Fq L r A' HS' w',
                ((A' = A /\ HS = HS' /\ w = w') \/ (exec_prim (A, HS) (A', HS'))) /\
                Spec pc2 = Some (Fp, Fq) /\ (S2, HS', A', Nat.pred w') ||= (Fp L) ⋆ r /\ GoodFrm r /\
                ImplyPrim' (Fq L ⋆ r) Q /\ (w' > 0)%nat /\ npc2 = pc2 +ᵢ ($ 4)
            )
        )
    ) ->
    (* be f *)
    (
      forall f,
        C pc = Some (c (cbe f)) ->
        (
          exists S1 S2 pc1 npc1 pc2 npc2,
            LP__ (C, (S, pc, npc)) tau (C, (S1, pc1, npc1)) /\
            LP__ (C, (S1, pc1, npc1)) tau (C, (S2, pc2, npc2))
        ) /\
        (
          forall S1 S2 pc1 npc1 pc2 npc2,
            LP__ (C, (S, pc, npc)) tau (C, (S1, pc1, npc1)) ->
            LP__ (C, (S1, pc1, npc1)) tau (C, (S2, pc2, npc2)) ->
            (
              exists v A' HS' w',
                ((A' = A /\ HS = HS' /\ w = w') \/ (exec_prim (A, HS) (A', HS'))) /\
                get_R (getregs S) z = Some (W v) /\
                (
                  v <> ($ 0) ->
                  (
                    exists Fp Fq L r,
                      Spec pc2 = Some (Fp, Fq) /\ (S2, HS', A', Nat.pred w') ||= (Fp L) ⋆ r /\
                      ImplyPrim' (Fq L ⋆ r) Q /\ GoodFrm r /\ (w' > 0)%nat /\ npc2 = pc2 +ᵢ ($ 4)
                  )
                ) /\
                (
                  v = ($ 0) ->
                  rel_safety_insSeq Spec w' (C, S2, pc2, npc2) (A', HS') Q
                )
            )
        )
    ) ->
    (* retl *)
    (
      C pc = Some (c (cretl)) ->
      (
        exists S1 S2 pc1 npc1 pc2 npc2,
          LP__ (C, (S, pc, npc)) tau (C, (S1, pc1, npc1)) /\
          LP__ (C, (S1, pc1, npc1)) tau (C, (S2, pc2, npc2))
      ) /\
      (
        forall S1 S2 pc1 npc1 pc2 npc2,
          LP__ (C, (S, pc, npc)) tau (C, (S1, pc1, npc1)) ->
          LP__ (C, (S1, pc1, npc1)) tau (C, (S2, pc2, npc2)) ->
          (forall Pr, GoodFrm Pr -> Sta A Pr) ->
          (
            exists A' HS' w',
              ((A' = A /\ HS = HS' /\ w' = w) \/ (exec_prim (A, HS) (A', HS')))
              /\ (S2, HS', A', w') ||= Q /\
              (exists f,
                  get_R (getregs S2) r15 = Some (W f) /\
                  pc2 = f +ᵢ ($ 8) /\ npc2 = f +ᵢ ($ 12)
              )
          )
      )
    ) ->
    rel_safety_insSeq Spec w (C, S, pc, npc) (A, HS) Q.

Definition insSeq_rel_sound Spec P f I Q :=
  forall C S HS A w,
    LookupXC C f I -> (S, HS, A, w) ||= P ->
    rel_safety_insSeq Spec w (C, S, f, f +ᵢ ($ 4)) (A, HS) Q.

Definition cdhp_rel_sound Spec C :=
  forall f Fp Fq L,
    Spec f = Some (Fp, Fq) ->
    exists I : InsSeq, LookupXC C f I /\ insSeq_rel_sound Spec (Fp L) f I (Fq L).

Definition legal_com (oc : option Command) :=
  match oc with
  | Some cc => match cc with
              | c cc' => match cc' with
                        | cntrans i => True
                        | cjumpl aexp rr => True
                        | cbe f => True
                        | ccall f => True
                        | cretl => True
                        | _ => False
                        end
              | _ => False
              end
  | _ => False
  end.

(** soundness of code heap rule *)
CoInductive rel_safety : nat -> Index -> (XCodeHeap * State * Word * Word) -> (primcom * HState) -> relasrt -> Prop :=
| cons_safety : forall k idx C S pc npc A HS Q,
    legal_com (C pc) -> legal_com (C npc) ->
    (* not call ret *)
    (
      forall f aexp rd i,
        (C pc = Some (c (cntrans i)) \/ C pc = Some (c (cjumpl aexp rd)) \/ C pc = Some (c (cbe f))) ->
        (
          (* progress *)
          exists S' pc' npc',
            LP__ (C, (S, pc, npc)) tau (C, (S', pc', npc'))
        ) /\
        (
          (* preservation *)
          forall S' pc' npc',
            LP__ (C, (S, pc, npc)) tau (C, (S', pc', npc')) ->
            (
              (
                exists idx1, (idx1 ⩹ idx) /\ rel_safety k idx1 (C, S', pc', npc') (A, HS) Q
              )
              \/
              (
                exists HS' idx1, exec_prim (A, HS) (Pdone, HS')
                            /\ rel_safety k idx1 (C, S', pc', npc') (Pdone, HS') Q
              )
            )
        )
    ) ->
    (* call *)
    (
      forall f,
        C pc = Some (c (ccall f)) ->
        (
          (* progress *)
          exists S1 S2 pc1 pc2 npc1 npc2,
            LP__ (C, (S, pc, npc)) tau (C, (S1, pc1, npc1)) /\
            LP__ (C, (S1, pc1, npc1)) tau (C, (S2, pc2, npc2))
        ) /\
        (
          (* preservation *)
          forall S1 S2 pc1 pc2 npc1 npc2,
            LP__ (C, (S, pc, npc)) tau (C, (S1, pc1, npc1)) ->
            LP__ (C, (S1, pc1, npc1)) tau (C, (S2, pc2, npc2)) ->
            exists idx1 idx2 A' HS',
              ((idx1 ⩹ idx2 /\ idx2 ⩹ idx /\  A' = A /\ HS = HS') \/ (exec_prim (A, HS) (A', HS'))) /\
              rel_safety (Nat.succ k) idx1 (C, S2, pc2, npc2) (A', HS') Q
        )
    ) ->
    (* retl *)
    (
      C pc = Some (c cretl) ->
      (
          (* progress *)
          exists S1 S2 pc1 pc2 npc1 npc2,
            LP__ (C, (S, pc, npc)) tau (C, (S1, pc1, npc1)) /\
            LP__ (C, (S1, pc1, npc1)) tau (C, (S2, pc2, npc2))
      ) /\
      (
          (* preservation *)
          forall S1 S2 pc1 pc2 npc1 npc2,
            LP__ (C, (S, pc, npc)) tau (C, (S1, pc1, npc1)) ->
            LP__ (C, (S1, pc1, npc1)) tau (C, (S2, pc2, npc2)) ->
            exists idx1 idx2 A' HS' w ,
              ((idx1 ⩹ idx2 /\ idx2 ⩹ idx /\ A' = A /\ HS = HS') \/ (exec_prim (A, HS) (A', HS'))) /\
              (
                (Nat.eqb k 0 = true /\ (S2, HS', A', w) ||= Q /\ A' = Pdone /\ (0%nat, (0%nat, 0%nat)) ⩹ idx1 /\
                (exists f', getregs S2 r15 = Some (W f') /\ pc2 = f' +ᵢ ($ 8) /\ npc2 = f' +ᵢ ($ 12))) \/
                (Nat.eqb k 0 = false /\ rel_safety (Nat.pred k) idx1 (C, S2, pc2, npc2) (A', HS') Q)
              )
      )
    ) ->
    rel_safety k idx (C, S, pc, npc) (A, HS) Q.

(** Simulation for Implementation and Primitive *)
Definition simImpPrim (Cas : XCodeHeap) (f : Word) (P Q : relasrt) (A : primcom) :=
  forall S HS w, (S, HS, A, w) ||= P ->
            exists i, rel_safety 0%nat i (Cas, S, f, f +ᵢ ($ 4)) (A, HS) Q.

(** Well-defined Primitive Set Semantics *)
Definition simImpsPrimSet (Spec : Funspec) (Cas : XCodeHeap) (PrimSet : apSet)
           (restoreQ : Memory -> RState -> Prop) :=
  forall f L hprim, PrimSet f = Some hprim ->
                    exists lv Fp Fq, Spec f = Some (Fp, Fq) /\ PrimSet f = Some hprim
                                     /\ (Fp L ⇒ (RAprim (Pm hprim lv)) ⋆ RAtrue)
                                     /\ wdSpec restoreQ Fp Fq hprim
                                     /\ simImpPrim Cas f (Fp L) (Fq L) (Pm hprim lv).

Inductive n_tau_step {prog : Type} (step : prog -> msg -> prog -> Prop) :
  nat -> prog -> prog -> Prop :=
| tau_step0 : forall p, n_tau_step step 0%nat p p
| tau_step_Sn : forall (p p' p'' : prog) n, n_tau_step step n p p' -> step p' tau p'' ->
                                       n_tau_step step (S n) p p''.

(*+ Whole Program Simulation +*)
CoInductive wp_sim : Index -> LProg -> HProg -> Prop :=
| cons_wp_sim : forall idx LP HP,
    (* tau step *)
    (
      forall LP', LP__ LP tau LP' ->
             (
               (exists idx1, idx1 ⩹ idx /\ wp_sim idx1 LP' HP)
               \/
               (exists idx1 HP' HP'', star_tau_step HP__ HP HP' /\ HP__ HP' tau HP'' /\ wp_sim idx1 LP' HP'')
             )
    ) ->
    (* event step *)
    (
      forall LP' v, LP__ LP (out v) LP' ->
               (exists idx1 HP' HP'', star_tau_step HP__ HP HP' /\ HP__ HP' (out v) HP'' /\ wp_sim idx1 LP' HP'')
    ) ->
    (* abort step *)
    (
      ~ (exists LP' m, LP__ LP m LP') ->
           (exists HP', star_tau_step HP__ HP HP' /\ ~ (exists HP'' m', HP__ HP' m' HP''))
    ) ->
    wp_sim idx LP HP.


Require Import Crypto.Compilers.SmartMap.
Require Import Crypto.Compilers.ExprInversion.
Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Z.Syntax.
Require Import Crypto.Compilers.ZExtended.Syntax.

Definition unextend_base_type (t : ZExtended.Syntax.base_type) : Z.Syntax.base_type
  := match t with
     | TZ => Z.Syntax.TZ
     | TBool => Z.Syntax.TZ
     end.

Definition invert_Const s d (opc : op s d) : option (interp_flat_type interp_base_type d)
  := match opc with
     | ConstZ v => Some v
     | ConstBool v => Some v
     | AddWithGetCarry
     | SubWithGetBorrow
     | MulSplitAtBitwidth
     | AddWithGetCarryZ _
     | SubWithGetBorrowZ _
     | MulSplitAtBitwidthZ _
     | IdWithAlt _
     | Zselect
     | Zmul
     | Zadd
     | Zsub
     | Zopp
     | Zshiftr
     | Zshiftl
     | Zland
     | Zlor
     | Zmodulo
     | Zdiv
     | Zlog2
     | Zpow
     | Zones
     | Zeqb
     | BoolCase _
       => None
     end.

Definition unextend_op {s d} (opc : ZExtended.Syntax.op s d)
  : option (Z.Syntax.op (lift_flat_type unextend_base_type s)
                        (lift_flat_type unextend_base_type d))
  := match opc in ZExtended.Syntax.op s d
           return option (Z.Syntax.op (lift_flat_type unextend_base_type s)
                                      (lift_flat_type unextend_base_type d))
     with
     | AddWithGetCarry => None
     | AddWithGetCarryZ bitwidth
       => Some (Z.Syntax.AddWithGetCarry bitwidth _ _ _ _ _)
     | SubWithGetBorrow => None
     | SubWithGetBorrowZ bitwidth
       => Some (Z.Syntax.SubWithGetBorrow bitwidth _ _ _ _ _)
     | MulSplitAtBitwidth => None
     | MulSplitAtBitwidthZ bitwidth
       => Some (Z.Syntax.MulSplit bitwidth _ _ _ _)
     | IdWithAlt (Tbase _)
       => Some (Z.Syntax.IdWithAlt _ _ _)
     | IdWithAlt _
       => None
     | Zselect => Some (Z.Syntax.Zselect _ _ _ _)
     | Zmul => Some (Z.Syntax.Mul _ _ _)
     | Zadd => Some (Z.Syntax.Add _ _ _)
     | Zsub => Some (Z.Syntax.Sub _ _ _)
     | Zopp => Some (Z.Syntax.Opp _ _)
     | Zshiftr => Some (Z.Syntax.Shr _ _ _)
     | Zshiftl => Some (Z.Syntax.Shl _ _ _)
     | Zland => Some (Z.Syntax.Land _ _ _)
     | Zlor => Some (Z.Syntax.Lor _ _ _)
     | Zmodulo => None
     | Zdiv => None
     | Zlog2 => None
     | Zpow => None
     | Zones => None
     | Zeqb => None
     | ConstZ v => Some (OpConst v)
     | ConstBool v => None
     | BoolCase T => None
     end.