(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Correctness proof for constant propagation (processor-dependent part). *)

Require Import Coqlib.
Require Import Compopts.
Require Import AST.
Require Import Integers.
Require Import Floats.
Require Import Values.
Require Import Memory.
Require Import Globalenvs.
Require Import Events.
Require Import Op.
Require Import Registers.
Require Import RTL.
Require Import ValueDomain.
Require Import ConstpropOp.

(** * Correctness of strength reduction *)

(** We now show that strength reduction over operators and addressing
  modes preserve semantics: the strength-reduced operations and
  addressings evaluate to the same values as the original ones if the
  actual arguments match the static approximations used for strength
  reduction. *)

Section STRENGTH_REDUCTION.

Variable bc: block_classification.
Variable ge: genv.
Hypothesis GENV: genv_match bc ge.
Variable sp: block.
Hypothesis STACK: bc sp = BCstack.
Variable ae: AE.t.
Variable rs: regset.
Variable m: mem.
Hypothesis MATCH: ematch bc rs ae.

Lemma match_G:
  forall r id ofs,
  AE.get r ae = Ptr(Gl id ofs) -> Val.lessdef rs#r (symbol_address ge id ofs).
Proof.
  intros. apply vmatch_ptr_gl with bc; auto. rewrite <- H. apply MATCH.
Qed.

Lemma match_S:
  forall r ofs,
  AE.get r ae = Ptr(Stk ofs) -> Val.lessdef rs#r (Vptr sp ofs).
Proof.
  intros. apply vmatch_ptr_stk with bc; auto. rewrite <- H. apply MATCH.
Qed.

Ltac InvApproxRegs :=
  match goal with
  | [ H: _ :: _ = _ :: _ |- _ ] =>
        injection H; clear H; intros; InvApproxRegs
  | [ H: ?v = AE.get ?r ae |- _ ] =>
        generalize (MATCH r); rewrite <- H; clear H; intro; InvApproxRegs
  | _ => idtac
  end.

Ltac SimplVM :=
  match goal with
  | [ H: vmatch _ ?v (I ?n) |- _ ] =>
      let E := fresh in
      assert (E: v = Vint n) by (inversion H; auto);
      rewrite E in *; clear H; SimplVM
  | [ H: vmatch _ ?v (F ?n) |- _ ] =>
      let E := fresh in
      assert (E: v = Vfloat n) by (inversion H; auto);
      rewrite E in *; clear H; SimplVM
  | [ H: vmatch _ ?v (Ptr(Gl ?id ?ofs)) |- _ ] =>
      let E := fresh in
      assert (E: Val.lessdef v (Op.symbol_address ge id ofs)) by (eapply vmatch_ptr_gl; eauto);
      clear H; SimplVM
  | [ H: vmatch _ ?v (Ptr(Stk ?ofs)) |- _ ] =>
      let E := fresh in
      assert (E: Val.lessdef v (Vptr sp ofs)) by (eapply vmatch_ptr_stk; eauto);
      clear H; SimplVM
  | _ => idtac
  end.

Lemma eval_static_shift_correct:
  forall s n, eval_shift s (Vint n) = Vint (eval_static_shift s n).
Proof.
  intros. destruct s; simpl; rewrite s_range; auto.
Qed.

Lemma cond_strength_reduction_correct:
  forall cond args vl,
  vl = map (fun r => AE.get r ae) args ->
  let (cond', args') := cond_strength_reduction cond args vl in
  eval_condition cond' rs##args' m = eval_condition cond rs##args m.
Proof.
  intros until vl. unfold cond_strength_reduction.
  case (cond_strength_reduction_match cond args vl); simpl; intros; InvApproxRegs; SimplVM.
- apply Val.swap_cmp_bool.
- auto.
- apply Val.swap_cmpu_bool.
- auto.
- rewrite eval_static_shift_correct. auto.
- rewrite eval_static_shift_correct. auto.
- destruct (Float.eq_dec n1 Float.zero).
  subst n1. simpl. destruct (rs#r2); simpl; auto. rewrite Float.cmp_swap. auto.
  simpl. rewrite H1; auto.
- destruct (Float.eq_dec n2 Float.zero).
  subst n2. simpl. auto.
  simpl. rewrite H1; auto.
- destruct (Float.eq_dec n1 Float.zero).
  subst n1. simpl. destruct (rs#r2); simpl; auto. rewrite Float.cmp_swap. auto.
  simpl. rewrite H1; auto.
- destruct (Float.eq_dec n2 Float.zero); simpl; auto.
  subst n2; auto.
  rewrite H1; auto.
- auto.
Qed.

Lemma make_cmp_base_correct:
  forall c args vl,
  vl = map (fun r => AE.get r ae) args ->
  let (op', args') := make_cmp_base c args vl in
  exists v, eval_operation ge (Vptr sp Int.zero) op' rs##args' m = Some v
         /\ Val.lessdef (Val.of_optbool (eval_condition c rs##args m)) v.
Proof.
  intros. unfold make_cmp_base.
  generalize (cond_strength_reduction_correct c args vl H).
  destruct (cond_strength_reduction c args vl) as [c' args']. intros EQ.
  econstructor; split. simpl; eauto. rewrite EQ. auto.
Qed.

Lemma make_cmp_correct:
  forall c args vl,
  vl = map (fun r => AE.get r ae) args ->
  let (op', args') := make_cmp c args vl in
  exists v, eval_operation ge (Vptr sp Int.zero) op' rs##args' m = Some v
         /\ Val.lessdef (Val.of_optbool (eval_condition c rs##args m)) v.
Proof.
  intros c args vl.
  assert (Y: forall r, vincl (AE.get r ae) (Uns 1) = true ->
             rs#r = Vundef \/ rs#r = Vint Int.zero \/ rs#r = Vint Int.one).
  { intros. apply vmatch_Uns_1 with bc. eapply vmatch_ge. eapply vincl_ge; eauto. apply MATCH. }
  unfold make_cmp. case (make_cmp_match c args vl); intros.
- destruct (Int.eq_dec n Int.one && vincl v1 (Uns 1)) eqn:E1.
  simpl in H; inv H. InvBooleans. subst n.
  exists (rs#r1); split; auto. simpl.
  exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
  destruct (Int.eq_dec n Int.zero && vincl v1 (Uns 1)) eqn:E0.
  simpl in H; inv H. InvBooleans. subst n.
  exists (Val.xor rs#r1 (Vint Int.one)); split; auto. simpl.
  exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
  apply make_cmp_base_correct; auto.
- destruct (Int.eq_dec n Int.zero && vincl v1 (Uns 1)) eqn:E0.
  simpl in H; inv H. InvBooleans. subst n.
  exists (rs#r1); split; auto. simpl.
  exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
  destruct (Int.eq_dec n Int.one && vincl v1 (Uns 1)) eqn:E1.
  simpl in H; inv H. InvBooleans. subst n.
  exists (Val.xor rs#r1 (Vint Int.one)); split; auto. simpl.
  exploit Y; eauto. intros [A | [A | A]]; rewrite A; simpl; auto.
  apply make_cmp_base_correct; auto.
- apply make_cmp_base_correct; auto.
Qed.

Lemma make_addimm_correct:
  forall n r,
  let (op, args) := make_addimm n r in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.add rs#r (Vint n)) v.
Proof.
  intros. unfold make_addimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst. exists (rs#r); split; auto. destruct (rs#r); simpl; auto; rewrite Int.add_zero; auto.
  exists (Val.add rs#r (Vint n)); auto.
Qed.

Lemma make_shlimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_shlimm n r1 r2 in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.shl rs#r1 (Vint n)) v.
Proof.
  Opaque mk_shift_amount.
  intros; unfold make_shlimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shl_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:?; intros.
  econstructor; split. simpl; eauto.  rewrite mk_shift_amount_eq; auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_shrimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_shrimm n r1 r2 in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.shr rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shrimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shr_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:?; intros.
  econstructor; split. simpl; eauto.  rewrite mk_shift_amount_eq; auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_shruimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_shruimm n r1 r2 in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.shru rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_shruimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.shru_zero. auto.
  destruct (Int.ltu n Int.iwordsize) eqn:?; intros.
  econstructor; split. simpl; eauto.  rewrite mk_shift_amount_eq; auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_mulimm_correct:
  forall n r1 r2,
  rs#r2 = Vint n ->
  let (op, args) := make_mulimm n r1 r2 in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mul rs#r1 (Vint n)) v.
Proof.
  intros; unfold make_mulimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros. subst.
  exists (Vint Int.zero); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.one; intros. subst.
  exists (rs#r1); split; auto. destruct (rs#r1); simpl; auto. rewrite Int.mul_one; auto.
  destruct (Int.is_power2 n) eqn:?; intros.
  exploit Int.is_power2_range; eauto. intros R.
  econstructor; split. simpl; eauto. rewrite mk_shift_amount_eq; auto.
  rewrite (Val.mul_pow2 rs#r1 _ _ Heqo). auto.
  econstructor; split; eauto. simpl. congruence.
Qed.

Lemma make_divimm_correct:
  forall n r1 r2 v,
  Val.divs rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divimm n r1 r2 in
  exists w, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divimm.
  destruct (Int.is_power2 n) eqn:?.
  destruct (Int.ltu i (Int.repr 31)) eqn:?.
  exists v; split; auto. simpl. eapply Val.divs_pow2; eauto. congruence.
  exists v; auto.
  exists v; auto.
Qed.

Lemma make_divuimm_correct:
  forall n r1 r2 v,
  Val.divu rs#r1 rs#r2 = Some v ->
  rs#r2 = Vint n ->
  let (op, args) := make_divuimm n r1 r2 in
  exists w, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some w /\ Val.lessdef v w.
Proof.
  intros; unfold make_divuimm.
  destruct (Int.is_power2 n) eqn:?.
  replace v with (Val.shru rs#r1 (Vint i)).
  econstructor; split. simpl. rewrite mk_shift_amount_eq. eauto.
  eapply Int.is_power2_range; eauto. auto.
  eapply Val.divu_pow2; eauto. congruence.
  exists v; auto.
Qed.

Lemma make_andimm_correct:
  forall n r x,
  vmatch bc rs#r x ->
  let (op, args) := make_andimm n r x in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.and rs#r (Vint n)) v.
Proof.
  intros; unfold make_andimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (Vint Int.zero); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.and_mone; auto.
  destruct (match x with Uns k => Int.eq (Int.zero_ext k (Int.not n)) Int.zero
                       | _ => false end) eqn:UNS.
  destruct x; try congruence.
  exists (rs#r); split; auto.
  inv H; auto. simpl. replace (Int.and i n) with i; auto.
  generalize (Int.eq_spec (Int.zero_ext n0 (Int.not n)) Int.zero); rewrite UNS; intro EQ.
  Int.bit_solve. destruct (zlt i0 n0).
  replace (Int.testbit n i0) with (negb (Int.testbit Int.zero i0)).
  rewrite Int.bits_zero. simpl. rewrite andb_true_r. auto.
  rewrite <- EQ. rewrite Int.bits_zero_ext by omega. rewrite zlt_true by auto.
  rewrite Int.bits_not by auto. apply negb_involutive.
  rewrite H5 by auto. auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_orimm_correct:
  forall n r,
  let (op, args) := make_orimm n r in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.or rs#r (Vint n)) v.
Proof.
  intros; unfold make_orimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (Vint Int.mone); split; auto. destruct (rs#r); simpl; auto. rewrite Int.or_mone; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_xorimm_correct:
  forall n r,
  let (op, args) := make_xorimm n r in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.xor rs#r (Vint n)) v.
Proof.
  intros; unfold make_xorimm.
  predSpec Int.eq Int.eq_spec n Int.zero; intros.
  subst n. exists (rs#r); split; auto. destruct (rs#r); simpl; auto. rewrite Int.xor_zero; auto.
  predSpec Int.eq Int.eq_spec n Int.mone; intros.
  subst n. exists (Val.notint (rs#r)); split. auto.
  destruct (rs#r); simpl; auto.
  econstructor; split; eauto. auto.
Qed.

Lemma make_mulfimm_correct:
  forall n r1 r2,
  rs#r2 = Vfloat n ->
  let (op, args) := make_mulfimm n r1 r1 r2 in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
Proof.
  intros; unfold make_mulfimm.
  destruct (Float.eq_dec n (Float.floatofint (Int.repr 2))); intros.
  simpl. econstructor; split. eauto. rewrite H; subst n.
  destruct (rs#r1); simpl; auto. rewrite Float.mul2_add; auto.
  simpl. econstructor; split; eauto.
Qed.

Lemma make_mulfimm_correct_2:
  forall n r1 r2,
  rs#r1 = Vfloat n ->
  let (op, args) := make_mulfimm n r2 r1 r2 in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.mulf rs#r1 rs#r2) v.
Proof.
  intros; unfold make_mulfimm.
  destruct (Float.eq_dec n (Float.floatofint (Int.repr 2))); intros.
  simpl. econstructor; split. eauto. rewrite H; subst n.
  destruct (rs#r2); simpl; auto. rewrite Float.mul2_add; auto.
  rewrite Float.mul_commut; auto.
  simpl. econstructor; split; eauto.
Qed.

Lemma make_cast8signed_correct:
  forall r x,
  vmatch bc rs#r x ->
  let (op, args) := make_cast8signed r x in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.sign_ext 8 rs#r) v.
Proof.
  intros; unfold make_cast8signed. destruct (vincl x (Sgn 8)) eqn:INCL.
  exists rs#r; split; auto.
  assert (V: vmatch bc rs#r (Sgn 8)).
  { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
  inv V; simpl; auto. rewrite is_sgn_sign_ext in H3 by auto. rewrite H3; auto.
  econstructor; split; simpl; eauto.
Qed.

Lemma make_cast16signed_correct:
  forall r x,
  vmatch bc rs#r x ->
  let (op, args) := make_cast16signed r x in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.sign_ext 16 rs#r) v.
Proof.
  intros; unfold make_cast16signed. destruct (vincl x (Sgn 16)) eqn:INCL.
  exists rs#r; split; auto.
  assert (V: vmatch bc rs#r (Sgn 16)).
  { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
  inv V; simpl; auto. rewrite is_sgn_sign_ext in H3 by auto. rewrite H3; auto.
  econstructor; split; simpl; eauto.
Qed.

Lemma make_singleoffloat_correct:
  forall r x,
  vmatch bc rs#r x ->
  let (op, args) := make_singleoffloat r x in
  exists v, eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v /\ Val.lessdef (Val.singleoffloat rs#r) v.
Proof.
  intros; unfold make_singleoffloat.
  destruct (vincl x Fsingle && generate_float_constants tt) eqn:INCL.
  InvBooleans. exists rs#r; split; auto.
  assert (V: vmatch bc rs#r Fsingle).
  { eapply vmatch_ge; eauto. apply vincl_ge; auto. }
  inv V; simpl; auto. rewrite Float.singleoffloat_of_single by auto. auto.
  econstructor; split; simpl; eauto.
Qed.

Lemma op_strength_reduction_correct:
  forall op args vl v,
  vl = map (fun r => AE.get r ae) args ->
  eval_operation ge (Vptr sp Int.zero) op rs##args m = Some v ->
  let (op', args') := op_strength_reduction op args vl in
  exists w, eval_operation ge (Vptr sp Int.zero) op' rs##args' m = Some w /\ Val.lessdef v w.
Proof.
  intros until v; unfold op_strength_reduction;
  case (op_strength_reduction_match op args vl); simpl; intros.
(* cast8signed *)
  InvApproxRegs; SimplVM; inv H0. apply make_cast8signed_correct; auto.
(* cast8signed *)
  InvApproxRegs; SimplVM; inv H0. apply make_cast16signed_correct; auto.
(* add *)
  InvApproxRegs; SimplVM. inv H0.
  fold (Val.add (Vint n1) rs#r2). rewrite Val.add_commut. apply make_addimm_correct.
  InvApproxRegs; SimplVM. inv H0. apply make_addimm_correct.
(* addshift *)
  InvApproxRegs; SimplVM. inv H0. rewrite eval_static_shift_correct. apply make_addimm_correct.
(* sub *)
  InvApproxRegs; SimplVM. inv H0. econstructor; split; eauto.
  InvApproxRegs; SimplVM. inv H0. rewrite Val.sub_add_opp. apply make_addimm_correct.
(* subshift *)
  InvApproxRegs; SimplVM. inv H0. rewrite eval_static_shift_correct. rewrite Val.sub_add_opp. apply make_addimm_correct.
(* rsubshift *)
  InvApproxRegs; SimplVM. inv H0. rewrite eval_static_shift_correct. econstructor; split; eauto.
(* mul *)
  InvApproxRegs; SimplVM. inv H0. fold (Val.mul (Vint n1) rs#r2).
  rewrite Val.mul_commut. apply make_mulimm_correct; auto.
  InvApproxRegs; SimplVM. inv H0. apply make_mulimm_correct; auto.
(* divs *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
  apply make_divimm_correct; auto.
(* divu *)
  assert (rs#r2 = Vint n2). clear H0. InvApproxRegs; SimplVM; auto.
  apply make_divuimm_correct; auto.
(* and *)
  InvApproxRegs; SimplVM. inv H0. fold (Val.and (Vint n1) rs#r2). rewrite Val.and_commut. apply make_andimm_correct; auto.
  InvApproxRegs; SimplVM. inv H0. apply make_andimm_correct; auto.
(* andshift *)
  InvApproxRegs; SimplVM. inv H0. rewrite eval_static_shift_correct. apply make_andimm_correct; auto.
(* or *)
  InvApproxRegs; SimplVM. inv H0. fold (Val.or (Vint n1) rs#r2). rewrite Val.or_commut. apply make_orimm_correct.
  InvApproxRegs; SimplVM. inv H0. apply make_orimm_correct.
(* orshift *)
  InvApproxRegs; SimplVM. inv H0. rewrite eval_static_shift_correct. apply make_orimm_correct.
(* xor *)
  InvApproxRegs; SimplVM. inv H0. fold (Val.xor (Vint n1) rs#r2). rewrite Val.xor_commut. apply make_xorimm_correct.
  InvApproxRegs; SimplVM. inv H0. apply make_xorimm_correct.
(* xorshift *)
  InvApproxRegs; SimplVM. inv H0. rewrite eval_static_shift_correct. apply make_xorimm_correct.
(* bic *)
  InvApproxRegs; SimplVM. inv H0. apply make_andimm_correct; auto.
(* bicshift *)
  InvApproxRegs; SimplVM. inv H0. rewrite eval_static_shift_correct. apply make_andimm_correct; auto.
(* shl *)
  InvApproxRegs; SimplVM. inv H0. apply make_shlimm_correct; auto.
(* shr *)
  InvApproxRegs; SimplVM. inv H0. apply make_shrimm_correct; auto.
(* shru *)
  InvApproxRegs; SimplVM. inv H0. apply make_shruimm_correct; auto.
(* singleoffloat *)
  InvApproxRegs; SimplVM; inv H0. apply make_singleoffloat_correct; auto.
(* cmp *)
  inv H0. apply make_cmp_correct; auto.
(* mulf *)
  InvApproxRegs; SimplVM; inv H0. rewrite <- H2. apply make_mulfimm_correct; auto.
  InvApproxRegs; SimplVM; inv H0. fold (Val.mulf (Vfloat n1) rs#r2).
  rewrite <- H2. apply make_mulfimm_correct_2; auto.
(* default *)
  exists v; auto.
Qed.

Lemma addr_strength_reduction_correct:
  forall addr args vl res,
  vl = map (fun r => AE.get r ae) args ->
  eval_addressing ge (Vptr sp Int.zero) addr rs##args = Some res ->
  let (addr', args') := addr_strength_reduction addr args vl in
  exists res', eval_addressing ge (Vptr sp Int.zero) addr' rs##args' = Some res' /\ Val.lessdef res res'.
Proof.
  intros until res. unfold addr_strength_reduction.
  destruct (addr_strength_reduction_match addr args vl); simpl;
  intros VL EA; InvApproxRegs; SimplVM; try (inv EA).
- rewrite Int.add_zero_l.
  change (Vptr sp (Int.add n1 n2)) with (Val.add (Vptr sp n1) (Vint n2)).
  econstructor; split; eauto. apply Val.add_lessdef; auto.
- fold (Val.add (Vint n1) rs#r2).  rewrite Int.add_zero_l. rewrite Int.add_commut.
  change (Vptr sp (Int.add n2 n1)) with (Val.add (Vptr sp n2) (Vint n1)).
  rewrite Val.add_commut. econstructor; split; eauto. apply Val.add_lessdef; auto.
- fold (Val.add (Vint n1) rs#r2).
  rewrite Val.add_commut. econstructor; split; eauto.
- econstructor; split; eauto.
- rewrite eval_static_shift_correct. rewrite Int.add_zero_l.
  change (Vptr sp (Int.add n1 (eval_static_shift s n2)))
    with (Val.add (Vptr sp n1) (Vint (eval_static_shift s n2))).
  econstructor; split; eauto. apply Val.add_lessdef; auto.
- rewrite eval_static_shift_correct. econstructor; split; eauto.
- rewrite Int.add_zero_l. change (Vptr sp (Int.add n1 n)) with (Val.add (Vptr sp n1) (Vint n)).
  econstructor; split; eauto. apply Val.add_lessdef; auto.
- exists res; auto.
Qed.

End STRENGTH_REDUCTION.


(* This file contains the formalisation of lemma 19 and corollary 20 *)

Require Import general.
Require Import lterms.
Require Import erase_facts.
Require Import svars.
Require Import subterms.
Require Import standard.
Require Import sred.
Require Import ared.
Require Import sexpand_std.

Lemma lem_a_root_commute :
  forall x y z, RootContr_clc_a x y -> RootContr_clc_s x z -> Standard y ->
                exists u, (RootContr_clc_a z u \/ z = u) /\ Red_clc_s y u.
Proof.
  intros.
  invert_rcontr_clc_a.
  yintuition; yintuition; try yelles 1.
  invert_rcontr_clc_s.
  yintuition; yintuition; yelles 1.
Qed.

Lemma lem_standard_implies_glue_iterms_l :
  forall y, Standard y -> forall z, In z (tuple_of_lterm y) -> R_glue_iterms_l Contr_clc_s z.
Proof.
  unfold R_glue_iterms_l.
  intros.
  assert (HStd_z: Std z).
  unfold Standard in *; pose_subterm; ydestruct y; simpl in *; ycrush.
  assert (HH: is_iterm z = true \/ Sterm z).
  assert (is_ltup z = false).
  assert (Std y).
  apply lem_standard_implies_std; ycrush.
  ydestruct y; simpl in *; yisolve.
  ydestruct z; simpl in *; yisolve.
  destruct HH.
  destruct z, x', y0; pose lem_contr_s_basic; pose_contr_s; ycrush.
  assert (Sterm x').
  unfold Std in *; pose_red_s; ycrush.
  destruct z, x'; pose_contr_s; ycrush.
Qed.

Lemma lem_standard_implies_glue_iterms_r :
  forall y, Standard y -> forall z, In z (tuple_of_lterm y) -> R_glue_iterms_r Contr_clc_s z.
Proof.
  unfold R_glue_iterms_r.
  intros.
  assert (HStd_z: Std z).
  unfold Standard in *; pose_subterm; ydestruct y; simpl in *; ycrush.
  assert (HH: is_iterm z = true \/ Sterm z).
  assert (is_ltup z = false).
  assert (Std y).
  apply lem_standard_implies_std; ycrush.
  ydestruct y; simpl in *; yisolve.
  ydestruct z; simpl in *; yisolve.
  destruct HH.
  destruct z, y', x; pose lem_contr_s_basic; pose_contr_s; ycrush.
  assert (Sterm y').
  unfold Std in *; pose_red_s; ycrush.
  destruct z, y', x; pose_contr_s; ycrush.
Qed.

Lemma lem_standard_red_s_preserves_not_ltup :
  forall x y, Standard x -> Red_clc_s x y -> is_ltup x = false -> is_ltup y = false.
Proof.
  intros.
  assert (Std x).
  unfold Standard in *; pose_subterm; ycrush.
  assert (HH: is_iterm x = true \/ Sterm x).
  ydestruct x; unfold Std in *; yisolve.
  destruct HH.
  assert (is_iterm y = true).
  assert (lterm_basic x).
  ydestruct x; ycrush.
  assert (x = y).
  pose lem_red_s_basic; ycrush.
  ycrush.
  ydestruct y; ycrush.
  assert (Sterm y).
  unfold Std in *; ycrush.
  ydestruct y; ycrush.
Qed.

Lemma lem_standard_contr_s_preserves_no_nested_tuple :
  forall y y', Standard y -> Contr_clc_s y y' ->
               (forall x, In x (tuple_of_lterm y) -> is_ltup x = false) ->
               forall x, In x (tuple_of_lterm y') -> is_ltup x = false.
Proof.
  intros.
  assert (is_ltup y' = true \/ is_ltup y' = false) by ycrush.
  yintuition.
  ydestruct y'; yisolve; simpl in *.
  yinversion H0; fold Contr_clc_s in *; simpl in *.
  ydestruct y; yisolve; simpl in *.
  ydestruct y1; yisolve; simpl in *.
  assert (Red_clc_s (I1 @l y2) y2).
  apply lem_rcontr_s_to_red_s; ycrush.
  assert (is_ltup y2 = false).
  eapply lem_standard_red_s_preserves_not_ltup; ycrush.
  ycrush.
  ydestruct y1_1; yisolve; simpl in *.
  assert (Red_clc_s (K1 @l y1_2 @l y2) y1_2).
  apply lem_rcontr_s_to_red_s; ycrush.
  assert (is_ltup y1_2 = false).
  eapply lem_standard_red_s_preserves_not_ltup; ycrush.
  ycrush.
  ydestruct y1_1_1; yisolve; simpl in *.
  ydestruct y1_1_2; yisolve; simpl in *.
  assert (Red_clc_s (C1 @l T1 @l y1_2 @l y2) y1_2).
  apply lem_rcontr_s_to_red_s; ycrush.
  assert (is_ltup y1_2 = false).
  eapply lem_standard_red_s_preserves_not_ltup; ycrush.
  ycrush.
  assert (Red_clc_s (C1 @l F1 @l y1_2 @l y2) y2).
  apply lem_rcontr_s_to_red_s; ycrush.
  assert (is_ltup y2 = false).
  eapply lem_standard_red_s_preserves_not_ltup; ycrush.
  ycrush.
  simp_hyps.
  destruct H0.
  assert (Red_clc_s (C2 @l y1_1_2 @l y1_2 @l y2) y1_2).
  apply lem_rcontr_s_to_red_s; ycrush.
  assert (is_ltup y1_2 = false).
  eapply lem_standard_red_s_preserves_not_ltup; ycrush.
  ycrush.
  assert (Red_clc_s (C2 @l y1_1_2 @l y1_2 @l y2) y2).
  apply lem_rcontr_s_to_red_s; ycrush.
  assert (is_ltup y2 = false).
  eapply lem_standard_red_s_preserves_not_ltup; ycrush.
  ycrush.
  simp_hyps.
  unfold build_s_result in *.
  assert (exists a b s, split_in_groups l0 (tuple_of_lterm y2) = a :: b :: s).
  ydestruct l0.
  generalize (lem_tuple_len_nonzero y1_2); simpl in *; omega.
  pose lem_split_result; ycrush.
  ycrush.
  destruct H2; subst.
  assert (Standard x0).
  pose lem_subterm_standard; pose_subterm; ycrush.
  eapply lem_standard_red_s_preserves_not_ltup; pose_red_s; ycrush.
  ycrush.
  destruct H2; subst.
  ycrush.
  destruct H0; subst.
  assert (Standard y0).
  pose lem_subterm_standard; pose_subterm; ycrush.
  eapply lem_standard_red_s_preserves_not_ltup; pose_red_s; ycrush.
  ycrush.
  destruct H2; subst.
  ycrush.
  destruct H0; subst.
  ycrush.
  induction l0; simpl in *.
  destruct H0; subst.
  assert (Standard z).
  assert (HH: z :: l' = nil ++ z :: l') by ycrush.
  rewrite HH in *; clear HH.
  pose lem_subterm_standard; pose_subterm; ycrush.
  eapply lem_standard_red_s_preserves_not_ltup; pose_red_s; ycrush.
  ycrush.
  destruct H0; subst.
  ycrush.
  assert (Standard (ltup y'1 y'2 (l0 ++ z :: l'))).
  eapply lem_standard_ltup; ycrush.
  apply IHl0; ycrush.
  assert (HH: tuple_of_lterm y' = y' :: nil).
  ydestruct y'; ycrush.
  rewrite HH in *; clear HH; simpl in *.
  ycrush.
Qed.

Lemma lem_a_commute_0 :
  forall x y z, RootContr_clc_a x y -> Contr_clc_s x z -> Standard y ->
                exists u, (RootContr_clc_a z u \/ z = u) /\ Red_clc_s y u.
Proof.
  intros.
  yinversion H0; fold Contr_clc_s in *; try yelles 1.

  pose lem_a_root_commute; ycrush.

  invert_rcontr_clc_a; yintuition; yintuition.
  yinversion H; repeat invert_contr_clc_s; [ yelles 2 | yelles 2 | racrush ].
  yinversion H; repeat invert_contr_clc_s; [ yelles 2 | yelles 2 |
                                             ydestruct x; yisolve; yelles 2 ].
  yinversion H; repeat invert_contr_clc_s.
  yelles 2.
  ydestruct x2; yisolve; yelles 2.
  assert (ErasedEqv y' x1) by
      (eauto 8 using lem_red_s_implies_erased_eqv, lem_erased_eqv_trans,
       lem_erased_eqv_sym, lem_contr_s_to_red_s).
  racrush.
  yinversion H3; yinversion H2; yinversion H.
  yinversion H; repeat invert_contr_clc_s; [ yelles 2 | racrush ].
  ydestruct x0; yisolve.
  ydestruct x0_1; yisolve.
  ydestruct x0_1_1; yisolve; simp_hyps.
  repeat invert_contr_clc_s.
  clear -H12; yelles 2.
  assert (is_nonempty l).
  ydestruct l; ycrush.
  assert (Red_clc_s (build_s_result l x0_1_2 (tuple_of_lterm x0_2) (tuple_of_lterm y0))
                      (build_s_result l y' (tuple_of_lterm x0_2) (tuple_of_lterm y0))).
  pose lem_contr_s_s_result_1; pose_red_s; ycrush.
  assert (RootContr_clc_a (S1 l @l y' @l x0_2 @l y0)
                          (build_s_result l y' (tuple_of_lterm x0_2) (tuple_of_lterm y0))).
  racrush.
  ycrush.
  assert (is_nonempty l).
  ydestruct l; ycrush.
  assert (forall z, In z (tuple_of_lterm x0_2) -> R_glue_iterms_l Contr_clc_s z).
  assert (Standard x0_2).
  assert (RootContr_S (S1 l @l x0_1_2 @l x0_2 @l y0)
                      (build_s_result l x0_1_2 (tuple_of_lterm x0_2) (tuple_of_lterm y0))) by ycrush.
  eapply lem_standard_expand_below_S_redex; pose_subterm; ycrush.
  apply lem_standard_implies_glue_iterms_l; ycrush.
  assert (Red_clc_s (build_s_result l x0_1_2 (tuple_of_lterm x0_2) (tuple_of_lterm y0))
                      (build_s_result l x0_1_2 (tuple_of_lterm y') (tuple_of_lterm y0))).
  pose lem_contr_s_s_result_2; pose_red_s; ycrush.
  assert (is_ltup y' = true).
  pose lem_contr_s_preserves_is_ltup; ycrush.
  assert (length (tuple_of_lterm y') = length l).
  rewrite <- lem_contr_s_length with (x := x0_2); ycrush.
  assert (All_pairs (tuple_of_lterm y') ErasedEqv).
  pose lem_contr_s_all_pairs_erased_eqv; ycrush.
  assert (RootContr_clc_a (S1 l @l x0_1_2 @l y' @l y0)
                          (build_s_result l x0_1_2 (tuple_of_lterm y') (tuple_of_lterm y0))).
  racrush.
  ycrush.
  repeat invert_contr_clc_s.
  clear -H10; yelles 2.
  exists (y' @l lterm_of_tuple (firstn n (tuple_of_lterm y0)) @l
             (glue_iterms x0_2 (lterm_of_tuple (skipn n (tuple_of_lterm y0))))).
  racrush.
  exists (x0_1_2 @l lterm_of_tuple (firstn n (tuple_of_lterm y0)) @l
                 (glue_iterms y' (lterm_of_tuple (skipn n (tuple_of_lterm y0))))).
  assert (Standard x0_2).
  apply lem_standard_expand_below_S_redex with
  (r1 := S2 n @l x0_1_2 @l x0_2 @l y0)
    (r2 := x0_1_2 @l lterm_of_tuple (firstn n (tuple_of_lterm y0)) @l
                  (glue_iterms x0_2 (lterm_of_tuple (skipn n (tuple_of_lterm y0)))));
    pose lem_s2_discriminate_y; pose_subterm; ycrush.
  assert (Red_clc_s
            (x0_1_2 @l lterm_of_tuple (firstn n (tuple_of_lterm y0)) @l
                    (glue_iterms x0_2 (lterm_of_tuple (skipn n (tuple_of_lterm y0)))))
            (x0_1_2 @l lterm_of_tuple (firstn n (tuple_of_lterm y0)) @l
                    (glue_iterms y' (lterm_of_tuple (skipn n (tuple_of_lterm y0)))))).
  assert (RootContr_S
            (S2 n @l x0_1_2 @l x0_2 @l y0)
            (x0_1_2 @l lterm_of_tuple (firstn n (tuple_of_lterm y0)) @l
                    (glue_iterms x0_2 (lterm_of_tuple (skipn n (tuple_of_lterm y0)))))).
  ycrush.
  pose lem_standard_implies_glue_iterms_l.
  unfold R_glue_iterms_l in *.
  assert (Contr_clc_s (glue_iterms x0_2 (lterm_of_tuple (skipn n (tuple_of_lterm y0))))
                      (glue_iterms y' (lterm_of_tuple (skipn n (tuple_of_lterm y0))))).
  assert (tuple_of_lterm x0_2 = x0_2 :: nil) by ycrush.
  eapply r; ycrush.
  pose_red_s; ycrush.
  assert (is_ltup y' = false).
  pose lem_standard_not_reduces_to_tuple; pose_red_s; ycrush.
  assert (RootContr_clc_a (S2 n @l x0_1_2 @l y' @l y0)
                          (x0_1_2 @l lterm_of_tuple (firstn n (tuple_of_lterm y0)) @l
                                  (glue_iterms y' (lterm_of_tuple (skipn n (tuple_of_lterm y0)))))).
  racrush.
  ycrush.

  invert_rcontr_clc_a; yintuition; yintuition.
  yinversion H; repeat invert_contr_clc_s; ydestruct x1; yisolve; yelles 2.
  yinversion H; repeat invert_contr_clc_s; racrush.
  yinversion H; repeat invert_contr_clc_s.
  assert (ErasedEqv x y') by
      (eauto 8 using lem_red_s_implies_erased_eqv, lem_erased_eqv_trans,
       lem_erased_eqv_sym, lem_contr_s_to_red_s).
  racrush.
  yinversion H3; racrush.
  yinversion H; repeat invert_contr_clc_s; ydestruct x1; yisolve; yelles 2.
  ydestruct x0; yisolve.
  ydestruct x0_1; yisolve.
  ydestruct x0_1_1; yisolve; simp_hyps.
  assert (is_nonempty l).
  ydestruct l; ycrush.
  assert (Standard y0).
  assert (RootContr_S (S1 l @l x0_1_2 @l x0_2 @l y0)
                      (build_s_result l x0_1_2 (tuple_of_lterm x0_2) (tuple_of_lterm y0))) by ycrush.
  eapply lem_standard_expand_below_S_redex; pose_subterm; ycrush.
  assert (forall z, In z (tuple_of_lterm y0) -> R_glue_iterms_r Contr_clc_s z).
  apply lem_standard_implies_glue_iterms_r; ycrush.
  assert (Red_clc_s (build_s_result l x0_1_2 (tuple_of_lterm x0_2) (tuple_of_lterm y0))
                      (build_s_result l x0_1_2 (tuple_of_lterm x0_2) (tuple_of_lterm y'))).
  pose lem_contr_s_s_result_3; pose_red_s; ycrush.
  assert (is_ltup y' = true).
  pose lem_contr_s_preserves_is_ltup; ycrush.
  assert (lst_sum l < length (tuple_of_lterm y')).
  rewrite <- lem_contr_s_length with (x := y0); ycrush.
  assert (All_pairs (tuple_of_lterm y') ErasedEqv).
  pose lem_contr_s_all_pairs_erased_eqv; ycrush.
  assert (forall x : lterm, In x (tuple_of_lterm y') -> is_ltup x = false).
  pose lem_standard_contr_s_preserves_no_nested_tuple; ycrush.
  assert (RootContr_clc_a (S1 l @l x0_1_2 @l x0_2 @l y')
                          (build_s_result l x0_1_2 (tuple_of_lterm x0_2) (tuple_of_lterm y'))).
  racrush.
  ycrush.
  assert (Standard y0).
  assert (RootContr_S (S2 n @l x0_1_2 @l x0_2 @l y0)
                      (x0_1_2 @l lterm_of_tuple (firstn n (tuple_of_lterm y0)) @l
                              glue_iterms x0_2 (lterm_of_tuple (skipn n (tuple_of_lterm y0))))).
  ycrush.
  eapply lem_standard_expand_below_S_redex; pose_subterm; ycrush.
  assert (forall z, In z (tuple_of_lterm y0) -> R_glue_iterms_r Contr_clc_s z).
  apply lem_standard_implies_glue_iterms_r; ycrush.
  assert (Red_clc_s (x0_1_2 @l lterm_of_tuple (firstn n (tuple_of_lterm y0)) @l
                            (glue_iterms x0_2 (lterm_of_tuple (skipn n (tuple_of_lterm y0)))))
                    (x0_1_2 @l lterm_of_tuple (firstn n (tuple_of_lterm y')) @l
                            (glue_iterms x0_2 (lterm_of_tuple (skipn n (tuple_of_lterm y')))))).
  pose lem_contr_s_s2_result; pose_red_s; ycrush.
  assert (is_ltup y' = true).
  pose lem_contr_s_preserves_is_ltup; ycrush.
  assert (n < length (tuple_of_lterm y')).
  rewrite <- lem_contr_s_length with (x := y0); ycrush.
  assert (All_pairs (tuple_of_lterm y') ErasedEqv).
  pose lem_contr_s_all_pairs_erased_eqv; ycrush.
  assert (forall x : lterm, In x (tuple_of_lterm y') -> is_ltup x = false).
  pose lem_standard_contr_s_preserves_no_nested_tuple; ycrush.
  assert (RootContr_clc_a (S2 n @l x0_1_2 @l x0_2 @l y')
                          (x0_1_2 @l lterm_of_tuple (firstn n (tuple_of_lterm y')) @l
                                  (glue_iterms x0_2 (lterm_of_tuple (skipn n (tuple_of_lterm y')))))).
  racrush.
  ycrush.
Qed.

Lemma lem_a_commute_1 :
  forall x y z, Contr_clc_a x y -> RootContr_clc_s x z -> Standard y ->
                exists u, (Contr_clc_a z u \/ z = u) /\ Red_clc_s y u.
Proof.
  intros.
  yinversion H; fold Contr_clc_a in *; try yelles 1.

  pose lem_a_root_commute; pose_contr_a; ycrush.

  invert_rcontr_clc_s; yintuition; yintuition.
  yinversion H; repeat invert_contr_clc_a.
  racrush.
  racrush.
  yinversion H3; racrush.
  yinversion H3; racrush.
  exists y'; pose_red_s; ycrush.
  yinversion H; repeat invert_contr_clc_a.
  racrush.
  racrush.
  yinversion H3; racrush.
  yinversion H3; racrush.
  exists x1; pose_red_s; ycrush.
  yinversion H; repeat invert_contr_clc_a.
  racrush.
  racrush.
  yinversion H4; racrush.
  exists x; intuition; apply lem_rcontr_s_to_red_s; ycrush.
  assert (ErasedEqv y' x1) by
      (eauto 8 using lem_contr_a_to_erased_eqv, lem_erased_eqv_trans,
       lem_erased_eqv_sym, lem_contr_s_to_red_s).
  exists y'; intuition; apply lem_rcontr_s_to_red_s; ycrush.
  yinversion H; repeat invert_contr_clc_a.
  racrush.
  racrush.
  yinversion H4; racrush.
  exists x1; intuition; apply lem_rcontr_s_to_red_s; ycrush.
  assert (ErasedEqv y' x1) by
      (eauto 8 using lem_contr_a_to_erased_eqv, lem_erased_eqv_trans,
       lem_erased_eqv_sym, lem_contr_s_to_red_s).
  exists x1; intuition; apply lem_rcontr_s_to_red_s; ycrush.
  yinversion H; repeat invert_contr_clc_a.
  yinversion H2; racrush.
  yinversion H; repeat invert_contr_clc_a.
  racrush.
  yinversion H4; racrush.
  exists y'; intuition; apply lem_rcontr_s_to_red_s; ycrush.
  rename x into l.
  yinversion H; repeat invert_contr_clc_a.
  racrush.
  racrush.
  yinversion H11; racrush.
  assert (is_nonempty l).
  ydestruct l; ycrush.
  assert (Contr_clc_a (build_s_result l x1 (tuple_of_lterm x2) (tuple_of_lterm x3))
                      (build_s_result l y' (tuple_of_lterm x2) (tuple_of_lterm x3))).
  pose lem_contr_a_s_result_1; ycrush.
  assert (Red_clc_s (S1 l @l y' @l x2 @l x3)
                    (build_s_result l y' (tuple_of_lterm x2) (tuple_of_lterm x3))).
  apply lem_rcontr_s_to_red_s; ycrush.
  ycrush.
  assert (is_nonempty l).
  ydestruct l; ycrush.
  assert (Contr_clc_a (build_s_result l x1 (tuple_of_lterm x2) (tuple_of_lterm x3))
                      (build_s_result l x1 (tuple_of_lterm y') (tuple_of_lterm x3))).
  pose lem_contr_a_s_result_2; ycrush.
  assert (is_ltup y' = true).
  pose lem_contr_a_preserves_is_ltup; ycrush.
  assert (length (tuple_of_lterm y') = length l).
  rewrite <- lem_contr_a_length with (x := x2); ycrush.
  assert (All_pairs (tuple_of_lterm y') ErasedEqv).
  pose lem_contr_a_all_pairs_erased_eqv; ycrush.
  assert (Red_clc_s (S1 l @l x1 @l y' @l x3)
                    (build_s_result l x1 (tuple_of_lterm y') (tuple_of_lterm x3))).
  apply lem_rcontr_s_to_red_s; ycrush.
  assert (Sterm (build_s_result l x1 (tuple_of_lterm y') (tuple_of_lterm x3))).
  pose lem_standard_sterm; pose_sterm; ycrush.
  ycrush.
  rename x into n.
  yinversion H; repeat invert_contr_clc_a.
  racrush.
  racrush.
  yinversion H9; racrush.
  exists (y' @l lterm_of_tuple (firstn n (tuple_of_lterm x3)) @l
             (glue_iterms x2 (lterm_of_tuple (skipn n (tuple_of_lterm x3))))).
  split; [ pose_contr_a; ycrush | apply lem_rcontr_s_to_red_s; ycrush ].
  exists (x1 @l lterm_of_tuple (firstn n (tuple_of_lterm x3)) @l
             (glue_iterms y' (lterm_of_tuple (skipn n (tuple_of_lterm x3))))).
  assert (Contr_clc_a
            (x1 @l lterm_of_tuple (firstn n (tuple_of_lterm x3)) @l
                (glue_iterms x2 (lterm_of_tuple (skipn n (tuple_of_lterm x3)))))
            (x1 @l lterm_of_tuple (firstn n (tuple_of_lterm x3)) @l
                (glue_iterms y' (lterm_of_tuple (skipn n (tuple_of_lterm x3)))))).
  pose lem_contr_a_glue_l.
  unfold R_glue_iterms_l in *.
  pose_contr_a; ycrush.
  assert (is_ltup y' = false).
  yinversion H10; try yelles 1.
  assert (HH: Sterm y') by racrush.
  yinversion HH; ycrush.
  assert (Red_clc_s (S2 n @l x1 @l y' @l x3)
                    (x1 @l lterm_of_tuple (firstn n (tuple_of_lterm x3)) @l
                        (glue_iterms y' (lterm_of_tuple (skipn n (tuple_of_lterm x3)))))).
  apply lem_rcontr_s_to_red_s; ycrush.
  ycrush.

  invert_rcontr_clc_s; yintuition; yintuition.
  yinversion H; repeat invert_contr_clc_a; exists x; pose_red_s; ycrush.
  yinversion H; repeat invert_contr_clc_a; exists y'; pose_red_s; ycrush.
  yinversion H; repeat invert_contr_clc_a.
  assert (ErasedEqv x y') by
      (eauto 8 using lem_contr_a_to_erased_eqv, lem_erased_eqv_trans,
       lem_erased_eqv_sym, lem_contr_s_to_red_s).
  exists x; intuition; apply lem_rcontr_s_to_red_s; ycrush.
  yinversion H; repeat invert_contr_clc_a.
  assert (ErasedEqv x y') by
      (eauto 8 using lem_contr_a_to_erased_eqv, lem_erased_eqv_trans,
       lem_erased_eqv_sym, lem_contr_s_to_red_s).
  exists y'; intuition; apply lem_rcontr_s_to_red_s; ycrush.
  yinversion H.
  exists y'; pose_red_s; ycrush.
  yinversion H; repeat invert_contr_clc_a; exists x; pose_red_s; ycrush.
  rename x into l.
  yinversion H; repeat invert_contr_clc_a.
  assert (is_nonempty l).
  ydestruct l; ycrush.
  assert (Contr_clc_a (build_s_result l x1 (tuple_of_lterm x2) (tuple_of_lterm x3))
                      (build_s_result l x1 (tuple_of_lterm x2) (tuple_of_lterm y'))).
  pose lem_contr_a_s_result_3; ycrush.
  assert (is_ltup y' = true).
  pose lem_contr_a_preserves_is_ltup; ycrush.
  assert (lst_sum l < length (tuple_of_lterm y')).
  rewrite <- lem_contr_a_length with (x := x3); ycrush.
  assert (All_pairs (tuple_of_lterm y') ErasedEqv).
  pose lem_contr_a_all_pairs_erased_eqv; ycrush.
  assert (forall x : lterm, In x (tuple_of_lterm y') -> is_ltup x = false).
  assert (Standard y').
  pose lem_subterm_standard; pose_subterm; ycrush.
  Reconstr.hobvious (@H14)
	            (@standard.lem_standard_no_nested_tuple)
		    Reconstr.Empty.
  assert (Red_clc_s (S1 l @l x1 @l x2 @l y')
                    (build_s_result l x1 (tuple_of_lterm x2) (tuple_of_lterm y'))).
  apply lem_rcontr_s_to_red_s; ycrush.
  ycrush.
  rename x into n.
  yinversion H; repeat invert_contr_clc_a.
  assert (Contr_clc_a (x1 @l lterm_of_tuple (firstn n (tuple_of_lterm x3)) @l
                          (glue_iterms x2 (lterm_of_tuple (skipn n (tuple_of_lterm x3)))))
                      (x1 @l lterm_of_tuple (firstn n (tuple_of_lterm y')) @l
                          (glue_iterms x2 (lterm_of_tuple (skipn n (tuple_of_lterm y')))))).
  pose lem_contr_a_s2_result; ycrush.
  assert (is_ltup y' = true).
  pose lem_contr_a_preserves_is_ltup; ycrush.
  assert (n < length (tuple_of_lterm y')).
  rewrite <- lem_contr_a_length with (x := x3); ycrush.
  assert (All_pairs (tuple_of_lterm y') ErasedEqv).
  pose lem_contr_a_all_pairs_erased_eqv; ycrush.
  assert (forall x : lterm, In x (tuple_of_lterm y') -> is_ltup x = false).
  assert (Standard y').
  pose lem_subterm_standard; pose_subterm; ycrush.
  Reconstr.hobvious (@H11)
	            (@standard.lem_standard_no_nested_tuple)
		    Reconstr.Empty.
  assert (Red_clc_s (S2 n @l x1 @l x2 @l y')
                    (x1 @l lterm_of_tuple (firstn n (tuple_of_lterm y')) @l
                        (glue_iterms x2 (lterm_of_tuple (skipn n (tuple_of_lterm y')))))).
  apply lem_rcontr_s_to_red_s; ycrush.
  ycrush.
Qed.

(* lemma 19 *)
Lemma lem_a_commute :
  forall x y z, Contr_clc_a x y -> Contr_clc_s x z -> Standard y ->
                exists u, (Contr_clc_a z u \/ z = u) /\ Red_clc_s y u.
Proof.
  assert (forall x z, Contr_clc_s x z ->
                      forall y, Contr_clc_a x y -> Standard y ->
                                exists u, (Contr_clc_a z u \/ z = u) /\ Red_clc_s y u).
  intros x z H.
  induction H; fold Contr_clc_s in *; yintros.

  pose lem_a_commute_1; ycrush.

  invert_contr_clc_a.
  assert (Contr_clc_s (x @l y) (x' @l y)).
  pose_contr_s; ycrush.
  pose lem_a_commute_0; pose_contr_a; ycrush.
  assert (Standard x'0).
  pose lem_subterm_standard; pose_subterm; ycrush.
  pose_contr_a; pose_red_s; ycrush.
  assert (Standard y').
  pose lem_subterm_standard; pose_subterm; ycrush.
  pose_contr_a; pose_red_s; ycrush.

  invert_contr_clc_a.
  assert (Contr_clc_s (x @l y) (x @l y')).
  pose_contr_s; ycrush.
  pose lem_a_commute_0; pose_contr_a; ycrush.
  assert (Standard x').
  pose lem_subterm_standard; pose_subterm; ycrush.
  pose_contr_a; pose_red_s; ycrush.
  assert (Standard y'0).
  pose lem_subterm_standard; pose_subterm; ycrush.
  pose_contr_a; pose_red_s; ycrush.

  yinversion H0; fold Contr_clc_a in *; yisolve.
  racrush.
  assert (Standard x'0).
  pose lem_subterm_standard; pose_subterm; ycrush.
  pose_contr_a; pose_red_s; ycrush.
  pose_contr_a; pose_red_s; ycrush.
  pose_contr_a; pose_red_s; ycrush.

  yinversion H0; fold Contr_clc_a in *; yisolve.
  racrush.
  pose_contr_a; pose_red_s; ycrush.
  assert (Standard y'0).
  pose lem_subterm_standard; pose_subterm; ycrush.
  pose_contr_a; pose_red_s; ycrush.
  pose_contr_a; pose_red_s; ycrush.

  yinversion H0; fold Contr_clc_a in *; yisolve.
  racrush.
  pose_contr_a; pose_red_s; ycrush.
  pose_contr_a; pose_red_s; ycrush.
  assert (Standard z'0).
  pose lem_subterm_standard; pose_subterm; ycrush.
  generalize l0 l'0 H5.
  clear l0 l'0 H1 H5.
  induction l; intros.
  ydestruct l0.
  simpl in *.
  yinversion H5.
  assert (exists u : lterm, (Contr_clc_a z' u \/ z' = u) /\ Red_clc_s z'0 u).
  pose_contr_a; pose_red_s; ycrush.
  assert (exists u : lterm,
             (Contr_clc_a (ltup x y (nil ++ z' :: l')) u \/ ltup x y (nil ++ z' :: l') = u) /\
             Red_clc_s (ltup x y (nil ++ z'0 :: l')) u).
  pose_contr_a; pose_red_s; ycrush.
  ycrush.
  assert (l = z).
  yinversion H5; trivial.
  assert (l' = (l0 ++ z0 :: l'0)).
  yinversion H5; trivial.
  subst; simpl; clear H5.
  assert (Contr_clc_a (ltup x y ((z' :: l0) ++ z0 :: l'0)) (ltup x y ((z' :: l0) ++ z'0 :: l'0))).
  pose_contr_a; ycrush.
  assert (Red_clc_s (ltup x y (nil ++ z :: l0 ++ z'0 :: l'0)) (ltup x y (nil ++ z' :: l0 ++ z'0 :: l'0))).
  clear -H; pose_red_s; ycrush.
  ycrush.
  ydestruct l0; simpl in *.
  assert (a = z0).
  yinversion H5; trivial.
  assert (l'0 = l ++ z :: l').
  yinversion H5; trivial.
  subst; simpl in *.
  assert (Contr_clc_a (ltup x y (nil ++ z0 :: l ++ z' :: l'))
                      (ltup x y (nil ++ z'0 :: l ++ z' :: l'))).
  pose_contr_a; ycrush.
  assert (Red_clc_s (ltup x y ((z'0 :: l) ++ z :: l')) (ltup x y ((z'0 :: l) ++ z' :: l'))).
  pose_red_s; ycrush.
  ycrush.
  yinversion H5.
  yforwarding.
  assert (is_ltup (ltup x y (l1 ++ z'0 :: l'0)) = true) by ycrush.
  assert (is_ltup x0 = true).
  pose lem_red_s_preserves_is_ltup; ycrush.
  ydestruct x0; yisolve.
  yintuition.
  pose lem_contr_a_ltup_extend; pose lem_red_s_ltup_extend; ycrush.
  yinversion H4.
  pose lem_red_s_ltup_extend; ycrush.
  ycrush.
Qed.

(* corollary 20 *)
Lemma lem_a_commute_red :
  forall x y z, Contr_clc_a x y -> Red_clc_s x z -> StronglyStandard y ->
                exists u, (Contr_clc_a z u \/ z = u) /\ Red_clc_s y u.
Proof.
  assert (forall x z, Red_clc_s x z ->
                      forall y, Contr_clc_a x y -> StronglyStandard y ->
                                exists u, (Contr_clc_a z u \/ z = u) /\ Red_clc_s y u).
  intros x z H.
  induction H; fold Red_clc_s in *; yintros.
  pose lem_a_commute; pose_red_s; ycrush.
  ycrush.
  assert (exists u : lterm, (Contr_clc_a y u \/ y = u) /\ Red_clc_s y0 u) by ycrush.
  yintuition.
  assert (exists u : lterm, (Contr_clc_a z u \/ z = u) /\ Red_clc_s x0 u).
  assert (StronglyStandard x0).
  pose lem_reduce_subterm_strongly_standard; pose_subterm; ycrush.
  ycrush.
  pose_red_s; ycrush.
  pose_red_s; ycrush.
  ycrush.
Qed.


(*

  Copyright 2014 Cornell University

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

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

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

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

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

*)

Require Export computation5.
Require Export atom_ren.

Lemma computes_to_val_like_in_max_k_steps_preserves_program {p} :
  forall lib k (t1 t2 : @NTerm p),
    computes_to_val_like_in_max_k_steps lib t1 t2 k
    -> isprogram t1
    -> isprogram t2.
Proof.
  unfold computes_to_val_like_in_max_k_steps, reduces_in_atmost_k_steps;
  introv comp isp; repnd.
  apply computek_preserves_program in comp0; sp.
Qed.

Lemma isprogram_subst_if_bt {p} :
  forall t v a,
    @isprogram p a
    -> isprogram_bt (bterm [v] t)
    -> isprogram (subst t v a).
Proof.
  introv ispa ispt.
  apply subst_preserves_program; auto.
  destruct ispt as [c w].
  inversion w; sp.
  introv i.
  destruct ispt as [c w].
  unfold closed_bt in c; allsimpl.
  rw <- null_iff_nil in c; rw null_remove_nvars in c.
  discover; allsimpl; sp.
Qed.

Lemma wf_atom_eq_iff {p} :
  forall a b c d : @NTerm p,
    (wf_term a # wf_term b # wf_term c # wf_term d) <=> wf_term (mk_atom_eq a b c d).
Proof.
  introv; split; intro i.
  apply wf_atom_eq; sp.
  allrw @wf_term_eq.
  inversion i as [|?| o lnt k e]; subst; allsimpl.
  generalize (k (nobnd a)) (k (nobnd b)) (k (nobnd c)) (k (nobnd d)); intros k1 k2 k3 k4.
  repeat (dest_imp k1 hyp).
  repeat (dest_imp k2 hyp).
  repeat (dest_imp k3 hyp).
  repeat (dest_imp k4 hyp).
  inversion k1; subst.
  inversion k2; subst.
  inversion k3; subst.
  inversion k4; subst; sp.
Qed.

Lemma isprog_vars_mk_atom_eq {p} :
  forall (a b c d : @NTerm p) vs,
    isprog_vars vs (mk_atom_eq a b c d)
    <=> (isprog_vars vs a
         # isprog_vars vs b
         # isprog_vars vs c
         # isprog_vars vs d).
Proof.
  introv.
  repeat (rw @isprog_vars_eq; simpl).
  repeat (rw remove_nvars_nil_l).
  repeat (rw app_nil_r).
  repeat (rw subvars_app_l).
  repeat (rw <- @wf_term_eq).
  allrw <- @wf_atom_eq_iff; split; sp.
Qed.

Lemma isprogram_mk_atom_eq {p} :
  forall (a b c d : @NTerm p),
    isprogram (mk_atom_eq a b c d)
    <=> (isprogram a
         # isprogram b
         # isprogram c
         # isprogram d).
Proof.
  introv.
  pose proof (isprog_vars_mk_atom_eq a b c d []) as h.
  allrw <- @isprog_vars_nil_iff_isprog.
  allrw @isprogram_eq; auto.
Qed.

Lemma computes_to_val_like_in_max_k_steps_can_iff {p} :
  forall lib c bterms a k,
    computes_to_val_like_in_max_k_steps lib (oterm (@Can p c) bterms) a k
    <=> a = oterm (Can c) bterms.
Proof.
  introv; split; intro comp; subst.
  apply computes_to_val_like_in_max_k_steps_can in comp; auto.
  unfold computes_to_val_like_in_max_k_steps, reduces_in_atmost_k_steps.
  dands; try (complete (left; sp)).
  induction k; simpl; sp.
  rw IHk; simpl; sp.
Qed.

Lemma computes_to_val_like_in_max_k_steps_sleep_implies {p} :
  forall lib k t v,
    computes_to_val_like_in_max_k_steps lib (mk_sleep t) v k
    -> {x : NTerm
        & {m : nat
           & k = S m
           # computes_to_val_like_in_max_k_steps lib t x m
           # ({z : Z & v = mk_axiom # x = @mk_integer p z}
              [+]
              (isexc x # x = v))}}.
Proof.
  induction k; introv comp; simpl.

  - allunfold @computes_to_val_like_in_max_k_steps.
    rw @reduces_in_atmost_k_steps_0 in comp; repnd; subst.
    unfold isvalue_like in comp; allsimpl; sp.

  - rw @computes_to_val_like_in_max_k_steps_S in comp; exrepnd.
    destruct t; ginv.
    dopid o as [can|ncan|exc|abs] Case; try (complete (inversion comp1)).

    + Case "Can".
      destruct l; try (complete (inversion comp1)).
      destruct can; inversion comp1; subst.
      apply computes_to_val_like_in_max_k_steps_can_iff in comp0; subst.
      exists (@mk_integer p z) k; dands; auto.
      apply computes_to_val_like_in_max_k_steps_can_iff; sp.
      left; exists z; sp.

    + Case "NCan".
      rw @computes_step_sleep_ncan in comp1.
      remember (compute_step lib (oterm (NCan ncan) l)); destruct c; inversion comp1; subst; GC.
      apply IHk in comp0; clear IHk; exrepnd; subst.
      exists x (S m); dands; auto.
      rw @computes_to_val_like_in_max_k_steps_S.
      exists n; auto.

    + Case "Exc".
      inversion comp1; subst; GC.
      apply computes_to_val_like_in_max_k_steps_exc in comp0; subst.
      exists (oterm Exc l) k; dands; auto.
      apply computes_to_val_like_in_max_k_steps_exc_iff; sp.

    + Case "Abs".
      rw @computes_step_sleep_abs in comp1.
      remember (compute_step lib (oterm (Abs abs) l)); destruct c; inversion comp1; subst; GC.
      apply IHk in comp0; clear IHk; exrepnd; subst.
      exists x (S m); dands; auto.
      rw @computes_to_val_like_in_max_k_steps_S.
      exists n; auto.
Qed.

Lemma computes_to_val_like_in_max_k_steps_tuni_implies {p} :
  forall lib k t v,
    computes_to_val_like_in_max_k_steps lib (mk_tuni t) v k
    -> {x : NTerm
        & {m : nat
           & k = S m
           # computes_to_val_like_in_max_k_steps lib t x m
           # ({n : nat & v = mk_uni n # x = @mk_integer p (Z.of_nat n)}
              [+]
              (isexc x # x = v))}}.
Proof.
  induction k; introv comp; simpl.

  - allunfold @computes_to_val_like_in_max_k_steps.
    rw @reduces_in_atmost_k_steps_0 in comp; repnd; subst.
    unfold isvalue_like in comp; allsimpl; sp.

  - rw @computes_to_val_like_in_max_k_steps_S in comp; exrepnd.
    destruct t; ginv.
    dopid o as [can|ncan|exc|abs] Case; try (complete (inversion comp1)).

    + Case "Can".
      destruct l; try (complete (inversion comp1)).
      csunf comp1; simpl in comp1.
      unfold compute_step_tuni in comp1; simpl in comp1.
      destruct can; allsimpl; try (complete (inversion comp1)).
      destruct (Z_le_gt_dec 0 z); inversion comp1; subst; GC.
      apply computes_to_val_like_in_max_k_steps_can_iff in comp0; subst.
      exists (@mk_integer p z) k; dands; auto.
      apply computes_to_val_like_in_max_k_steps_can_iff; sp.
      left; exists (Z.to_nat z); sp.
      rw Znat.Z2Nat.id; sp.

    + Case "NCan".
      rw @computes_step_tuni_ncan in comp1.
      remember (compute_step lib (oterm (NCan ncan) l)); destruct c; inversion comp1; subst; GC.
      apply IHk in comp0; clear IHk; exrepnd; subst.
      exists x (S m); dands; auto.
      rw @computes_to_val_like_in_max_k_steps_S.
      exists n; auto.

    + Case "Exc".
      inversion comp1; subst; GC.
      apply computes_to_val_like_in_max_k_steps_exc in comp0; subst.
      exists (oterm Exc l) k; dands; auto.
      apply computes_to_val_like_in_max_k_steps_exc_iff; sp.

    + rw @computes_step_tuni_abs in comp1.
      remember (compute_step lib (oterm (Abs abs) l)); destruct c; inversion comp1; subst; GC.
      apply IHk in comp0; clear IHk; exrepnd; subst.
      exists x (S m); dands; auto.
      rw @computes_to_val_like_in_max_k_steps_S.
      exists n; auto.
Qed.

Lemma alphaeqbt_nilv_r {o}:
  forall (b : @BTerm o) t,
    alpha_eq_bterm b (bterm [] t)
    -> {t' : NTerm $ b = bterm [] t' # alpha_eq t' t}.
Proof.
  introv aeq.
  apply alpha_eq_bterm_sym in aeq.
  apply alphaeqbt_nilv in aeq; exrepnd; subst.
  exists nt2; dands; eauto with slow.
Qed.

Lemma computes_step_minus_ncan {p} :
  forall lib n l,
    compute_step lib (mk_minus (oterm (@NCan p n) l))
    = match compute_step lib (oterm (NCan n) l) with
        | csuccess t => csuccess (mk_minus t)
        | cfailure m t => cfailure m t
      end.
Proof.
  introv; csunf; simpl; auto.
Qed.

Lemma computes_step_minus_abs {p} :
  forall lib o l,
    compute_step lib (mk_minus (oterm (@Abs p o) l))
    = match compute_step lib (oterm (Abs o) l) with
        | csuccess t => csuccess (mk_minus t)
        | cfailure m t => cfailure m t
      end.
Proof. sp. Qed.

Lemma computes_to_val_like_in_max_k_steps_minus_implies {p} :
  forall lib k t v,
    computes_to_val_like_in_max_k_steps lib (mk_minus t) v k
    -> {x : NTerm
        & {m : nat
           & k = S m
           # computes_to_val_like_in_max_k_steps lib t x m
           # ({z : Z & v = mk_integer (- z) # x = @mk_integer p z}
              [+]
              (isexc x # x = v))}}.
Proof.
  induction k; introv comp; simpl.

  - allunfold @computes_to_val_like_in_max_k_steps.
    rw @reduces_in_atmost_k_steps_0 in comp; repnd; subst.
    unfold isvalue_like in comp; allsimpl; sp.

  - rw @computes_to_val_like_in_max_k_steps_S in comp; exrepnd.
    destruct t; ginv.
    dopid o as [can|ncan|exc|abs] Case; try (complete (inversion comp1)).

    + Case "Can".
      destruct l; try (complete (inversion comp1)).
      csunf comp1; simpl in comp1.
      unfold compute_step_minus in comp1; simpl in comp1.
      destruct can; allsimpl; ginv.
      apply computes_to_val_like_in_max_k_steps_can_iff in comp0; subst.
      exists (@mk_integer p z) k; dands; auto.
      * apply computes_to_val_like_in_max_k_steps_can_iff; sp.
      * left; exists z; sp.

    + Case "NCan".
      rw @computes_step_minus_ncan in comp1.
      remember (compute_step lib (oterm (NCan ncan) l)); destruct c; inversion comp1; subst; GC.
      apply IHk in comp0; clear IHk; exrepnd; subst.
      exists x (S m); dands; auto.
      rw @computes_to_val_like_in_max_k_steps_S.
      exists n; auto.

    + Case "Exc".
      inversion comp1; subst; GC.
      apply computes_to_val_like_in_max_k_steps_exc in comp0; subst.
      exists (oterm Exc l) k; dands; auto.
      apply computes_to_val_like_in_max_k_steps_exc_iff; sp.

    + rw @computes_step_minus_abs in comp1.
      remember (compute_step lib (oterm (Abs abs) l)); destruct c; inversion comp1; subst; GC.
      apply IHk in comp0; clear IHk; exrepnd; subst.
      exists x (S m); dands; auto.
      rw @computes_to_val_like_in_max_k_steps_S.
      exists n; auto.
Qed.

Lemma computes_to_val_like_in_max_k_steps_parallel_implies {o} :
  forall lib k (bs : list (@BTerm o)) v,
    computes_to_val_like_in_max_k_steps lib (oterm (NCan NParallel) bs) v k
    -> {x : NTerm
        & {u : NTerm
        & {bs' : list BTerm
        & {m : nat
        & k = S m
        # bs = nobnd u :: bs'
        # computes_to_val_like_in_max_k_steps lib u x m
        # (iscan x # v = mk_axiom)
          [+]
          (isexc x # x = v)}}}}.
Proof.
  induction k; introv comp; simpl.

  - allunfold @computes_to_val_like_in_max_k_steps.
    rw @reduces_in_atmost_k_steps_0 in comp; repnd; subst.
    unfold isvalue_like in comp; allsimpl; sp.

  - rw @computes_to_val_like_in_max_k_steps_S in comp; exrepnd.
    csunf comp1; allsimpl.
    destruct bs as [|b bs]; ginv.
    destruct b as [l t].
    destruct l; ginv.
    destruct t as [z|f|op bts]; ginv;[].
    dopid op as [can|ncan|exc|abs] Case; ginv.

    + Case "Can".
      apply compute_step_parallel_success in comp1; subst.
      apply computes_to_val_like_in_max_k_steps_can_iff in comp0; subst.
      exists (oterm (Can can) bts) (oterm (Can can) bts) bs k; dands; auto.
      apply computes_to_val_like_in_max_k_steps_can_iff; sp.

    + Case "NCan".
      remember (compute_step lib (oterm (NCan ncan) bts)) as comp'; destruct comp'; ginv.
      apply IHk in comp0; clear IHk; exrepnd; subst; allunfold @nobnd; ginv.
      exists x (oterm (NCan ncan) bts) bs' (S m); dands; auto.
      rw @computes_to_val_like_in_max_k_steps_S.
      exists u; auto.

    + Case "Exc".
      apply computes_to_val_like_in_max_k_steps_exc in comp0; subst.
      exists (oterm Exc bts) (oterm Exc bts) bs k; dands; auto.
      apply computes_to_val_like_in_max_k_steps_exc_iff; sp.

    + Case "Abs".
      remember (compute_step lib (oterm (Abs abs) bts)) as comp'; destruct comp'; ginv.
      apply IHk in comp0; clear IHk; exrepnd; subst.
      allunfold @nobnd; ginv.
      exists x (oterm (Abs abs) bts) bs' (S m); dands; auto.
      rw @computes_to_val_like_in_max_k_steps_S.
      exists u; auto.
Qed.

Lemma isvalue_vterm {o} : forall v, !@isvalue o (vterm v).
Proof.
  introv h.
  inversion h; subst; allsimpl; tcsp.
Qed.

Lemma computes_to_value_implies_val_like {p} :
  forall lib (a b : @NTerm p),
    computes_to_value lib a b
    -> computes_to_val_like lib a b.
Proof.
  introv comp.
  unfold computes_to_val_like, computes_to_val_like_in_max_k_steps.
  unfold computes_to_value, reduces_to in comp.
  exrepnd.
  exists k; dands; auto.
  left.
  destruct b as [v|f|op bs]; allsimpl; tcsp;[allapply @isvalue_vterm;tcsp|].
  allapply @isvalue_implies; repnd; auto.
Qed.

Lemma computes_to_exception_implies_val_like {p} :
  forall lib en (a b : @NTerm p),
    computes_to_exception lib en a b
    -> computes_to_val_like lib a (mk_exception en b).
Proof.
  introv comp.
  unfold computes_to_val_like, computes_to_val_like_in_max_k_steps.
  unfold computes_to_exception, reduces_to in comp.
  exrepnd.
  exists k; dands; auto.
  right.
  constructor.
Qed.

Lemma computes_to_val_like_in_max_k_steps_0 {p} :
  forall lib (t u : @NTerm p),
    computes_to_val_like_in_max_k_steps lib t u 0 <=> (t = u # isvalue_like u).
Proof.
  introv; unfold computes_to_val_like_in_max_k_steps.
  rw @reduces_in_atmost_k_steps_0; sp.
Qed.

Definition has_value_like_k {p} lib k (t : @NTerm p) :=
  {u : NTerm & computes_to_val_like_in_max_k_steps lib t u k}.

Lemma has_value_like_0 {o} :
  forall lib (t : @NTerm o),
    has_value_like_k lib 0 t <=> isvalue_like t.
Proof.
  introv; unfold has_value_like_k; split; intro k; exrepnd.
  - allrw @computes_to_val_like_in_max_k_steps_0; repnd; subst; auto.
  - exists t; allrw @computes_to_val_like_in_max_k_steps_0; auto.
Qed.

Lemma has_value_like_S {o} :
  forall lib k (t : @NTerm o),
    has_value_like_k lib (S k) t
    <=> {u : NTerm
         & compute_step lib t = csuccess u
         # has_value_like_k lib k u}.
Proof.
  introv; unfold has_value_like_k; split; intro h; exrepnd.
  - allrw @computes_to_val_like_in_max_k_steps_S; exrepnd.
    eexists; eauto.
  - exists u0; dands; auto.
    allrw @computes_to_val_like_in_max_k_steps_S.
    eexists; eauto.
Qed.

Lemma if_has_value_like_k_ncompop_can1 {o} :
  forall lib c can bs k (t : @NTerm o) l,
    has_value_like_k
      lib k
      (oterm (NCan (NCompOp c))
             (bterm [] (oterm (Can can) bs)
                    :: bterm [] t
                    :: l))
    -> {j : nat & j < k # has_value_like_k lib j t}.
Proof.
  induction k; introv r.
  - allrw @has_value_like_0; repnd.
    unfold isvalue_like in r; allsimpl; sp.
  - allrw @has_value_like_S; exrepnd.
    destruct t as [v|f|op bs1]; try (complete (csunf r1; allsimpl; dcwf h)).
    dopid op as [can2|ncan2|exc2|abs2] Case.
    + exists 0; dands; try omega.
      rw @has_value_like_0; dands; eauto 3 with slow.
    + rw @compute_step_ncompop_ncan2 in r1.
      dcwf h.
      remember (compute_step lib (oterm (NCan ncan2) bs1)) as comp1.
      symmetry in Heqcomp1.
      destruct comp1; ginv.
      apply IHk in r0; exrepnd.
      exists (S j); dands; try omega.
      rw @has_value_like_S.
      exists n; tcsp.
    + csunf r1; simpl in r1; ginv.
      dcwf h; ginv.
      exists k; sp.
    + csunf r1; simpl in r1; csunf r1; allsimpl.
      dcwf h.
      unfold on_success in r1.
      remember (compute_step_lib lib abs2 bs1) as comp1.
      symmetry in Heqcomp1.
      destruct comp1; ginv.
      apply IHk in r0; exrepnd.
      exists (S j); dands; try omega.
      rw @has_value_like_S.
      exists n; tcsp.
Qed.

Lemma if_has_value_like_k_narithop_can1 {o} :
  forall lib c can bs k (t : @NTerm o) l,
    has_value_like_k
      lib k
      (oterm (NCan (NArithOp c))
             (bterm [] (oterm (Can can) bs)
                    :: bterm [] t
                    :: l))
    -> {j : nat & j < k # has_value_like_k lib j t}.
Proof.
  induction k; introv r.
  - allrw @has_value_like_0; repnd.
    unfold isvalue_like in r; allsimpl; sp.
  - allrw @has_value_like_S; exrepnd.
    destruct t as [v|f|op bs1]; try (complete (csunf r1; allsimpl; dcwf h)).
    dopid op as [can2|ncan2|exc2|abs2] Case.
    + exists 0; dands; try omega.
      rw @has_value_like_0; dands; eauto 3 with slow.
    + rw @compute_step_narithop_ncan2 in r1.
      dcwf h.
      remember (compute_step lib (oterm (NCan ncan2) bs1)) as comp1.
      symmetry in Heqcomp1.
      destruct comp1; ginv.
      apply IHk in r0; exrepnd.
      exists (S j); dands; try omega.
      rw @has_value_like_S.
      exists n; tcsp.
    + csunf r1; simpl in r1; ginv.
      dcwf h; ginv.
      exists k; sp.
    + csunf r1; simpl in r1; csunf r1; allsimpl.
      dcwf h.
      unfold on_success in r1.
      remember (compute_step_lib lib abs2 bs1) as comp1.
      symmetry in Heqcomp1.
      destruct comp1; ginv.
      apply IHk in r0; exrepnd.
      exists (S j); dands; try omega.
      rw @has_value_like_S.
      exists n; tcsp.
Qed.

Lemma has_value_like_k_lt {o} :
  forall lib k1 k2 (t : @NTerm o),
    has_value_like_k lib k1 t
    -> k1 < k2
    -> has_value_like_k lib k2 t.
Proof.
  unfold has_value_like_k; introv r l; exrepnd.
  exists u; dands; auto.
  pose proof (no_change_after_value_like lib t k1 u) as h.
  allunfold @computes_to_val_like_in_max_k_steps; repnd; dands; auto.
  repeat (autodimp h hyp); tcsp.
  pose proof (h (k2 - k1)) as hh.
  assert (k2 - k1 + k1 = k2) as e by omega.
  rw e in hh; auto.
Qed.

Lemma computes_to_val_like_in_max_k_steps_if_isvalue_like {o} :
  forall lib (t u : @NTerm o) k,
    computes_to_val_like_in_max_k_steps lib t u k
    -> isvalue_like t
    -> t = u.
Proof.
  introv comp isv.
  unfold computes_to_val_like_in_max_k_steps in comp; repnd.
  apply reduces_in_atmost_k_steps_if_isvalue_like in comp0; auto.
Qed.

Lemma if_has_value_like_k_cbv_primarg {o} :
  forall lib k (t : @NTerm o) bs,
    has_value_like_k lib k (oterm (NCan NCbv) (bterm [] t :: bs))
    -> {j : nat & j < k # has_value_like_k lib j t}.
Proof.
  induction k; introv r.

  - allrw @has_value_like_0; repnd.
    unfold isvalue_like in r; allsimpl; sp.

  - allrw @has_value_like_S; exrepnd.
    destruct t as [v|f|op l].

    { simpl in r1; ginv. }

    { exists 0; dands; try omega.
      rw @has_value_like_0; dands; eauto 3 with slow; simpl; sp. }

    dopid op as [can1|ncan1|exc1|abs1] Case.

    + Case "Can".
      exists 0; dands; try omega.
      rw @has_value_like_0; dands; eauto 3 with slow; simpl; sp.

    + Case "NCan".
      rw @compute_step_ncan_ncan in r1.
      remember (compute_step lib (oterm (NCan ncan1) l)) as comp.
      symmetry in Heqcomp; destruct comp; ginv.
      apply IHk in r0; exrepnd.
      exists (S j); dands; try omega.
      rw @has_value_like_S; exists n; sp.

    + Case "Exc".
      csunf r1; allsimpl; ginv.
      unfold has_value_like_k in r0; exrepnd.
      apply computes_to_val_like_in_max_k_steps_if_isvalue_like in r1; subst; tcsp.
      exists 0; dands; try omega.
      rw @has_value_like_0; dands; eauto 3 with slow.

    + Case "Abs".
      csunf r1; allsimpl; csunf r1; allsimpl.
      unfold on_success in r1.
      remember (compute_step_lib lib abs1 l) as comp.
      symmetry in Heqcomp; destruct comp; ginv.
      apply IHk in r0; exrepnd.
      exists (S j); dands; try omega.
      rw @has_value_like_S; exists n; sp.
Qed.

Lemma isvalue_like_integer {o} :
  forall z, @isvalue_like o (mk_integer z).
Proof.
  introv; unfold isvalue_like; simpl; sp.
Qed.
Hint Resolve isvalue_like_integer : slow.

Lemma isvalue_like_uni {o} :
  forall n, @isvalue_like o (mk_uni n).
Proof.
  introv; unfold isvalue_like; simpl; sp.
Qed.
Hint Resolve isvalue_like_uni : slow.

Lemma if_has_value_like_k_ncan_primarg {o} :
  forall lib ncan k (t : @NTerm o) bs,
    has_value_like_k lib k (oterm (NCan ncan) (bterm [] t :: bs))
    -> {j : nat & j < k # has_value_like_k lib j t}.
Proof.
  induction k; introv r.

  - allrw @has_value_like_0.
    unfold isvalue_like in r; allsimpl; sp.

  - allrw @has_value_like_S; exrepnd.
    destruct t as [v|f|op l].

    { simpl in r1; ginv. }

    { exists 0; dands; try omega.
      rw @has_value_like_0; eauto 3 with slow. }

    dopid op as [can1|ncan1|exc1|abs1] Case.

    + Case "Can".
      exists 0; dands; try omega.
      rw @has_value_like_0; eauto 3 with slow.

    + Case "NCan".
      rw @compute_step_ncan_ncan in r1.
      remember (compute_step lib (oterm (NCan ncan1) l)) as comp.
      symmetry in Heqcomp; destruct comp; ginv.
      apply IHk in r0; exrepnd; auto.
      exists (S j); dands; try omega.
      rw @has_value_like_S.
      exists n; sp.

    + Case "Exc".
      csunf r1; allsimpl.
      apply compute_step_catch_success in r1.
      dorn r1; exrepnd; subst; allsimpl.

      * exists 0; dands; try omega.
        rw @has_value_like_0; eauto 3 with slow.

      * exists 0; dands; try omega.
        unfold has_value_like_k in r0; exrepnd.
        apply computes_to_val_like_in_max_k_steps_if_isvalue_like in r1; eauto 3 with slow; subst.
        rw @has_value_like_0; eauto 3 with slow.

    + Case "Abs".
      csunf r1; allsimpl; csunf r1; allsimpl.
      unfold on_success in r1.
      remember (compute_step_lib lib abs1 l) as comp.
      symmetry in Heqcomp; destruct comp; ginv.
      apply IHk in r0; exrepnd; auto.
      exists (S j); dands; try omega.
      rw @has_value_like_S.
      exists n; sp.
Qed.

Lemma closed_mk_vbot {o} :
  forall v, @closed o (mk_vbot v).
Proof.
  introv.
  unfold closed, mk_vbot; simpl.
  rw remove_nvars_eq; simpl; auto.
Qed.
Hint Resolve closed_mk_vbot : slow.

Lemma alphaeq_preserves_computes_to_val_like_in_max_k_steps {o} :
  forall lib k (t1 t2 : @NTerm o) u,
    nt_wf t1
    -> alpha_eq t1 t2
    -> computes_to_val_like_in_max_k_steps lib t1 u k
    -> {v : NTerm & computes_to_val_like_in_max_k_steps lib t2 v k # alpha_eq u v}.
Proof.
  introv wf aeq hv.
  allunfold @computes_to_val_like_in_max_k_steps; repnd.
  pose proof (reduces_in_atmost_k_steps_alpha lib t1 t2) as h; repeat (autodimp h hyp).
  applydup h in hv0; exrepnd.
  exists t2'; dands; auto.
  eapply alpha_eq_preserves_isvalue_like; eauto.
Qed.

Lemma alphaeq_preserves_has_value_like_k {o} :
  forall lib k (t1 t2 : @NTerm o),
    nt_wf t1
    -> alpha_eq t1 t2
    -> has_value_like_k lib k t1
    -> has_value_like_k lib k t2.
Proof.
  introv wf aeq hv.
  allunfold @has_value_like_k; exrepnd.
  eapply alphaeq_preserves_computes_to_val_like_in_max_k_steps in hv0; eauto.
  exrepnd.
  exists v; auto.
Qed.

Lemma has_value_like_k_ren_utokens {o} :
  forall lib k (t : @NTerm o) ren,
    nt_wf t
    -> no_repeats (range_utok_ren ren)
    -> disjoint (range_utok_ren ren) (diff (get_patom_deq o) (dom_utok_ren ren) (get_utokens t))
    -> has_value_like_k lib k t
    -> has_value_like_k lib k (ren_utokens ren t).
Proof.
  introv wf norep disj hvl.
  allunfold @has_value_like_k; exrepnd.
  allunfold @computes_to_val_like_in_max_k_steps; repnd.
  apply (reduces_in_atmost_k_steps_ren_utokens _ _ _ _ ren) in hvl1; auto.
  exists (ren_utokens ren u); dands; eauto with slow.
Qed.

Lemma reduces_in_atmost_k_steps_refl {o} :
  forall (lib : library) (k : nat) (t : @NTerm o),
    isvalue_like t
    -> reduces_in_atmost_k_steps lib t t k.
Proof.
  induction k; introv isvl.
  - rw @reduces_in_atmost_k_steps_0; auto.
  - rw @reduces_in_atmost_k_steps_S.
    exists t; dands; tcsp.
    apply compute_step_value_like; auto.
Qed.

Lemma eqset_free_vars_disjoint {o} :
  forall (t : @NTerm o) (sub : Substitution),
  eqset (free_vars (lsubst t sub))
        (remove_nvars (dom_sub sub) (free_vars t)
                      ++ sub_free_vars (sub_keep_first sub (free_vars t))).
Proof.
  introv; pose proof (eqvars_free_vars_disjoint t sub) as h; rw eqvars_prop in h; auto.
Qed.

Lemma has_value_like_k_fresh_implies {o} :
  forall lib k a v (t : @NTerm o),
    wf_term t
    -> !LIn a (get_utokens t)
    -> has_value_like_k lib k (mk_fresh v t)
    -> has_value_like_k lib k (subst t v (mk_utoken a)).
Proof.
  introv wt nia hvl.
  allunfold @has_value_like_k; exrepnd.
  allunfold @computes_to_val_like_in_max_k_steps; exrepnd.
  revert dependent u.
  revert dependent t.
  revert dependent a.
  induction k; introv wt nia r isvl.

  - allrw @reduces_in_atmost_k_steps_0; subst.
    unfold isvalue_like in isvl; repndors; inversion isvl.

  - allrw @reduces_in_atmost_k_steps_S; exrepnd.
    apply compute_step_ncan_bterm_cons_success in r1; repnd; subst; GC.
    repndors; exrepnd; subst; allsimpl; GC.
    + apply reduces_in_atmost_k_steps_implies_reduces_to in r0.
      apply reduces_in_atmost_k_step_fresh_id in r0; tcsp.
    + apply computation3.reduces_in_atmost_k_steps_if_isvalue_like in r0; eauto 3 with slow; subst.
      exists (subst t v (mk_utoken a)); dands; eauto 4 with slow.
      apply reduces_in_atmost_k_steps_refl; eauto with slow.
    + repnd; subst.
      pose proof (compute_step_subst_utoken lib t x [(v,mk_utoken (get_fresh_atom t))]) as h.
      allrw @get_utokens_sub_cons; allrw @get_utokens_sub_nil; allsimpl.
      allrw disjoint_singleton_l.
      repeat (autodimp h hyp); try (apply get_fresh_atom_prop); eauto 3 with slow.
      { apply nr_ut_sub_cons; eauto 3 with slow.
        intro i; apply get_fresh_atom_prop. }
      exrepnd.
      pose proof (h0 [(v,mk_utoken a)]) as q; clear h0; allsimpl.
      allrw @get_utokens_sub_cons; allrw @get_utokens_sub_nil; allsimpl.
      allrw disjoint_singleton_l.
      repeat (autodimp q hyp); exrepnd.
      allrw @fold_subst.

      assert (wf_term x) as wfx.
      { eapply compute_step_preserves_wf;[exact r3|].
        apply wf_term_subst; eauto with slow. }

      assert (!LIn v (free_vars x)) as nivx.
      { intro j; apply compute_step_preserves in r3; repnd; eauto 3 with slow.
        rw subvars_prop in r2; apply r2 in j; clear r2.
        apply eqset_free_vars_disjoint in j; allsimpl.
        allrw in_app_iff; allrw in_remove_nvars; allsimpl; boolvar; allsimpl; tcsp. }

      pose proof (IHk a (subst_utokens x [(get_fresh_atom t, mk_var v)])) as q; clear IHk.
      repeat (autodimp q hyp).
      { apply wf_subst_utokens; eauto 3 with slow. }
      { intro j; apply get_utokens_subst_utokens_subset in j; allsimpl.
        unfold get_utokens_utok_ren in j; allsimpl; allrw app_nil_r.
        rw in_remove in j; repnd.
        apply alphaeq_preserves_utokens in h1; rw h1 in j.
        apply get_utokens_subst in j; boolvar; allsimpl; allrw in_app_iff; tcsp; allsimpl.
        repndors; tcsp. }

      pose proof (q u) as ih; clear q.
      repeat (autodimp ih hyp); exrepnd.

      pose proof (simple_subst_subst_utokens_aeq x (get_fresh_atom t) v) as aeq1.
      repeat (autodimp aeq1 hyp).

      pose proof (alpha_eq_ren_utokens
                    (subst (subst_utokens x [(get_fresh_atom t, mk_var v)]) v
                           (mk_utoken (get_fresh_atom t)))
                    x [(get_fresh_atom t, a)] aeq1) as aeq2.
      rw @subst_ren_utokens in aeq2; allsimpl; fold_terms.
      unfold ren_atom in aeq2; allsimpl; boolvar; tcsp.
      rw @ren_utokens_trivial in aeq2;
        [|simpl; apply disjoint_singleton_l; intro i;
          apply get_utokens_subst_utokens_subset in i; allsimpl;
          unfold get_utokens_utok_ren in i; allsimpl; rw app_nil_r in i;
          rw in_remove in i; repnd; GC;
          apply alphaeq_preserves_utokens in h1; rw h1 in i;
          apply get_utokens_subst in i; allsimpl; boolvar; allrw app_nil_r;
          allrw in_app_iff; repndors; tcsp].

      clear aeq1.

      pose proof (alpha_eq_ren_utokens
                    x (subst w v (mk_utoken (get_fresh_atom t)))
                    [(get_fresh_atom t, a)] h1) as aeq3.
      rw @subst_ren_utokens in aeq3; allsimpl; fold_terms.
      unfold ren_atom in aeq3; allsimpl; boolvar; tcsp.
      rw (ren_utokens_trivial [(get_fresh_atom t, a)] w) in aeq3;
        [|simpl; apply disjoint_singleton_l; intro i; apply h4 in i;
          apply get_fresh_atom_prop in i; sp]; GC.

      eapply alpha_eq_trans in aeq3;[|exact aeq2]; clear aeq2.
      apply alpha_eq_sym in aeq3.
      eapply alpha_eq_trans in aeq3;[|exact q0]; clear q0.

      dup ih1 as ih2.
      eapply reduces_in_atmost_k_steps_alpha in ih2;
        [|apply nt_wf_subst; eauto 3 with slow;
          apply nt_wf_eq; apply wf_subst_utokens;
          eauto 3 with slow
         |apply alpha_eq_sym in aeq3; apply aeq3];[];exrepnd.
      rename t2' into s'.

      exists s'; dands; eauto 2 with slow.
      rw @reduces_in_atmost_k_steps_S.
      eexists; dands; eauto.
Qed.

Lemma has_value_like_k_vbot {o} :
  forall (lib : @library o) k v,
    !has_value_like_k lib k (mk_vbot v).
Proof.
  introv hv.
  unfold has_value_like_k, computes_to_val_like_in_max_k_steps in hv; exrepnd.
  apply reduces_in_atmost_k_steps_vbot in hv1; tcsp.
Qed.

Lemma has_value_like_k_fresh_id {o} :
  forall (lib : @library o) k v,
    !has_value_like_k lib k (mk_fresh v (mk_var v)).
Proof.
  introv hv.
  unfold has_value_like_k, computes_to_val_like_in_max_k_steps in hv; exrepnd.
  pose proof (reduces_in_atmost_k_step_fresh_id lib v u) as h.
  autodimp h hyp.
  eauto 3 with slow.
Qed.

Definition computes_to_can {p} lib (t1 t2 : @NTerm p) :=
  reduces_to lib t1 t2
  # iscan t2.

Lemma computes_to_exception_mk_less {o} :
  forall lib (a b c d : @NTerm o) n e,
    wf_term a
    -> wf_term b
    -> wf_term c
    -> wf_term d
    -> computes_to_exception lib n (mk_less a b c d) e
    -> {k1 : Z
        & {k2 : Z
        & reduces_to lib a (mk_integer k1)
        # reduces_to lib b (mk_integer k2)
        # (((k1 < k2)%Z # computes_to_exception lib n c e)
           [+]
           ((k2 <= k1)%Z # computes_to_exception lib n d e)
          )}}
       [+] computes_to_exception lib n a e
       [+] {z : Z
            & reduces_to lib a (mk_integer z)
            # computes_to_exception lib n b e}.
Proof.
  introv wfa wfb wfc wfd comp.
  unfold computes_to_exception, reduces_to in comp; exrepnd.
  pose proof (computes_to_val_like_in_max_k_steps_comp_implies
                lib k CompOpLess a b c d (mk_exception n e)) as h.
  repeat (autodimp h hyp).
  { unfold computes_to_val_like_in_max_k_steps; dands; eauto 3 with slow. }

  repndors; exrepnd; repndors; exrepnd; ginv.

  - left.
    allunfold @computes_to_can_in_max_k_steps; repnd.
    allunfold @spcan; fold_terms.
    exists i1 i2; dands; eauto with slow.
    boolvar;[left|right]; dands; auto;
    allunfold @computes_to_val_like_in_max_k_steps; repnd;
    exists (k - (k1 + k2 + 1)); auto.

  - right; left.
    exists k1; auto.

  - right; right; allsimpl.
    exists i; dands; auto.
    + allunfold @computes_to_can_in_max_k_steps; repnd.
      unfold computes_to_can; dands; eauto with slow.
    + exists k2; auto.
Qed.

Lemma computes_to_can_in_max_k_steps_implies_reduces_in_atmost_k_steps {o} :
  forall lib k (t : @NTerm o) u,
    computes_to_can_in_max_k_steps lib k t u
    -> reduces_in_atmost_k_steps lib t u k.
Proof.
  introv comp.
  unfold computes_to_can_in_max_k_steps in comp; sp.
Qed.
Hint Resolve computes_to_can_in_max_k_steps_implies_reduces_in_atmost_k_steps : slow.

Lemma computes_to_val_like_in_max_k_steps_implies_has_value_like_k {o} :
  forall lib (t u : @NTerm o) k,
    computes_to_val_like_in_max_k_steps lib t u k
    -> has_value_like_k lib k t.
Proof.
  introv comp.
  unfold has_value_like_k.
  exists u; sp.
Qed.
Hint Resolve computes_to_val_like_in_max_k_steps_implies_has_value_like_k : slow.

Lemma has_value_like_k_mk_less {o} :
  forall lib k (a b c d : @NTerm o),
    wf_term a
    -> wf_term b
    -> wf_term c
    -> wf_term d
    -> has_value_like_k lib k (mk_less a b c d)
    -> ({k1 : nat
         & {u : NTerm
         & {e : NTerm
         & k1 + 1 <= k
         # computes_to_exception_in_max_k_steps lib u a e k1
         # reduces_in_atmost_k_steps
             lib
             (mk_less a b c d)
             (mk_less (mk_exception u e) b c d) k1 }}}
        [+]
        {k1 : nat
         & {k2 : nat
         & {z : Z
         & {u : NTerm
         & {e : NTerm
         & k1 + k2 + 1 <= k
         # reduces_in_atmost_k_steps lib a (mk_integer z) k1
         # computes_to_exception_in_max_k_steps lib u b e k2
         # reduces_in_atmost_k_steps
             lib
             (mk_less a b c d)
             (mk_less (mk_integer z) (mk_exception u e) c d)
             (k1 + k2)}}}}}
        [+]
        {k1 : nat
         & {k2 : nat
         & {i1 : Z
         & {i2 : Z
         & k1 + k2 + 1 <= k
         # reduces_in_atmost_k_steps lib a (mk_integer i1) k1
         # reduces_in_atmost_k_steps lib b (mk_integer i2) k2
         # has_value_like_k
             lib
             (k - (k1 + k2 + 1))
             (if Z_lt_le_dec i1 i2 then c else d)
         # reduces_in_atmost_k_steps
             lib
             (mk_less a b c d)
             (mk_less (mk_integer i1) (mk_integer i2) c d)
             (k1 + k2) }}}}).
Proof.
  introv wa wb wc wd hv.
  unfold has_value_like_k in hv; exrepnd.
  apply computes_to_val_like_in_max_k_steps_comp_implies in hv0;
    repndors; exrepnd; auto;[|idtac|].

  - repndors; exrepnd; tcsp;ginv;[].
    allunfold @spcan; fold_terms.
    right; right.
    exists k1 k2 i1 i2.
    dands; eauto 3 with slow.
    boolvar; eauto 3 with slow.

  - subst; fold_terms.
    left.
    exists k1 en e; sp.

  - subst; fold_terms.
    right; left.
    repndors; exrepnd; ginv; allsimpl.
    exists k1 k2 i en e; dands; eauto 3 with slow.
Qed.


From stdpp Require Import prelude.
From VLSM.Lib Require Import Preamble.
From VLSM.Core Require Import VLSM VLSMProjections Composition Equivocation.

(** * VLSM No Equivocation Composition Constraints *)

Section sec_no_equivocations.

Context
  {message : Type}
  (vlsm : VLSM message)
  .

(**
  An equivocating transition can be prevented by checking that the message
  to be received [has_been_sent] previously in the state about to receive it.

  However, since we might allow certain other messages, such as initial
  messages, we give a slightly more general definition, that of
  [no_equivocation_except_from] those specified by a given predicate.
*)

Definition no_equivocations_except_from
  `{HasBeenSentCapability message vlsm}
  (exception : message -> Prop)
  (l : vlabel vlsm)
  (som : state * option message)
  :=
  let (s, om) := som in
  from_option (fun m => has_been_sent vlsm s m \/ exception m) True om.

(**
  The [no_equivocations] constraint does not allow any exceptions
  (messages being received must have been previously sent).
*)
Definition no_equivocations
  `{HasBeenSentCapability message vlsm}
  (l : vlabel vlsm)
  (som : state * option message)
  : Prop
  :=
  no_equivocations_except_from (fun m => False) l som.

End sec_no_equivocations.

(** ** No-Equivocation Invariants

  In this section we show that under [no_equivocations] assumptions:

  - for any valid state all messages [directly_observed_were_sent].
  - the [pre_loaded_with_all_messages_vlsm] is equal to the [no_equivocations] VLSM.
*)

Section sec_no_equivocation_invariants.

Context
  message
  (X : VLSM message)
  `{HasBeenSentCapability message X}
  `{HasBeenDirectlyObservedCapability message X}
  (Henforced : forall l s om, input_valid (pre_loaded_with_all_messages_vlsm X) l (s, om) ->
    no_equivocations X l (s, om))
  .

(**
  A VLSM that enforces the [no_equivocations] constraint and also supports
  [has_been_directly_observed] obeys the [directly_observed_were_sent] invariant which states that
  any message that [has_been_directly_observed] in a state, [has_been_sent] in
  the same state, too.
*)

Definition directly_observed_were_sent (s : state) : Prop :=
  forall msg, has_been_directly_observed X s msg -> has_been_sent X s msg.

Lemma directly_observed_were_sent_initial s :
  vinitial_state_prop X s ->
  directly_observed_were_sent s.
Proof.
  intros Hinitial msg Hsend.
  by apply has_been_directly_observed_no_inits in Hsend.
Qed.

Lemma directly_observed_were_sent_preserved l s im s' om :
  input_valid_transition X l (s, im) (s', om) ->
  directly_observed_were_sent s ->
  directly_observed_were_sent s'.
Proof.
  intros Hptrans Hprev msg Hobs.
  specialize (Hprev msg).
  apply preloaded_weaken_input_valid_transition in Hptrans.
  eapply (oracle_step_update (has_been_directly_observed_stepwise_props X) _ _ _ _ _ Hptrans)
    in Hobs; simpl in Hobs.
  specialize (Henforced l s (Some msg)).
  rewrite (has_been_sent_step_update Hptrans).
  destruct Hptrans as [Hv _].
  destruct Hobs as [[Hin | Hout] | Hobs]; subst.
  - (* by [no_equivocations], the incoming message [im] was previously sent *)
    specialize (Henforced Hv).
    by destruct Henforced; [right |].
  - by left.
  - by right; apply Hprev.
Qed.

(* TODO(wkolowski): make notation uniform accross the file. *)
Lemma directly_observed_were_sent_invariant s:
  valid_state_prop X s ->
  directly_observed_were_sent s.
Proof.
  intro Hproto.
  induction Hproto using valid_state_prop_ind.
  - by apply directly_observed_were_sent_initial.
  - by eapply directly_observed_were_sent_preserved.
Qed.

(**
  If the [valid]ity function satisfies the [no_equivocations] constraint then
  it doesn't matter if we preload the composition with some initial messages,
  since all messages must be sent before being received, which means that
  one cannot use the new messages to create additional traces.
*)
Lemma no_equivocations_preloaded_traces
  (is : state)
  (tr : list transition_item)
  : finite_valid_trace (pre_loaded_with_all_messages_vlsm X) is tr -> finite_valid_trace X is tr.
Proof.
  intro Htr.
  induction Htr using finite_valid_trace_rev_ind.
  - split; [| done].
    rapply @finite_valid_trace_from_empty.
    by apply initial_state_is_valid.
  - destruct IHHtr as [IHtr His].
    split; [| done].
    rapply extend_right_finite_trace_from; [done |].
    apply finite_valid_trace_last_pstate in IHtr as Hs.
    cut (option_valid_message_prop X iom); [by firstorder |].
    destruct iom as [m |]; [| by apply option_valid_message_None].
    destruct Hx as [Hv _].
    apply Henforced in Hv.
    destruct Hv as [Hbsm | []].
    by eapply sent_valid.
Qed.

Lemma preloaded_incl_no_equivocations
  : VLSM_incl (pre_loaded_with_all_messages_vlsm X) X.
Proof.
  specialize no_equivocations_preloaded_traces.
  clear -X. destruct X as [T [S M]].
  by apply VLSM_incl_finite_traces_characterization.
Qed.

Lemma preloaded_eq_no_equivocations
  : VLSM_eq (pre_loaded_with_all_messages_vlsm X) X.
Proof.
  split.
  - by apply preloaded_incl_no_equivocations.
  - by apply (vlsm_incl_pre_loaded_with_all_messages_vlsm X).
Qed.

End sec_no_equivocation_invariants.

Section sec_composite_no_equivocation.

Context
  {message : Type}
  `{finite.Finite index}
  (IM : index -> VLSM message)
  `{forall i, HasBeenSentCapability (IM i)}
  (constraint : composite_label IM -> composite_state IM * option message -> Prop)
  .

Definition sent_except_from exception es iom : Prop :=
  from_option (fun im => composite_has_been_sent IM es im \/ exception im) True iom.

Definition composite_no_equivocations_except_from
  (exception : message -> Prop)
  (l : composite_label IM)
  (som : composite_state IM * option message)
  :=
  sent_except_from exception som.1 som.2.

(**
  The [composite_no_equivocations] constraint requires that
  messages being received must have been previously sent by a
  machine in the composition.
*)
Definition composite_no_equivocations
  (l : composite_label IM)
  (som : composite_state IM * option message)
  : Prop
  :=
  composite_no_equivocations_except_from (fun m => False) l som.

(** ** Composite No-Equivocation Invariants

  A VLSM composition whose constraint subsumes the [no_equivocations] constraint
  and also supports [has_been_received] (or [has_been_directly_observed]) obeys an
  invariant that any message that tests as [has_been_received]
  (resp. [has_been_directly_observed]) in a state also tests as [has_been_sent]
  in the same state.
*)

Section sec_composite_no_equivocation_invariants.

Context
  `{forall i, HasBeenReceivedCapability (IM i)}
  (X := composite_vlsm IM constraint)
  (Hsubsumed : preloaded_constraint_subsumption IM constraint composite_no_equivocations)
  .

Definition composite_directly_observed_were_sent (s : state) : Prop :=
  forall msg, composite_has_been_directly_observed IM s msg -> composite_has_been_sent IM s msg.

Lemma composite_directly_observed_were_sent_invariant s :
  valid_state_prop X s ->
  composite_directly_observed_were_sent s.
Proof.
  intros Hs m.
  rewrite composite_has_been_directly_observed_sent_received_iff.
  intros Hobs.
  cut (has_been_sent X s m); [done |].
  apply (directly_observed_were_sent_invariant message X); [| done ..].
  by intros l s0 om; apply Hsubsumed.
Qed.

End sec_composite_no_equivocation_invariants.

Section sec_seeded_composite_vlsm_no_equivocation.

(** ** Pre-loading a VLSM composition with no equivocations constraint

  When adding initial messages to a VLSM composition with a no equivocation
  constraint, we cannot simply use the [pre_loaded_vlsm] construct
  because the no-equivocation constraint must also be altered to reflect that
  the newly added initial messages are safe to be received at all times.
*)

Context
  (X := free_composite_vlsm IM)
  .

Section sec_seeded_composite_vlsm_no_equivocation_definition.

Context
  (seed : message -> Prop)
  .

(** Constraint is updated to also allow seeded messages. *)

Definition no_equivocations_additional_constraint_with_pre_loaded
  (l : composite_label IM)
  (som : composite_state IM * option message)
  :=
  composite_no_equivocations_except_from seed l som
  /\ constraint l som.

Definition composite_no_equivocation_vlsm_with_pre_loaded
  : VLSM message
  :=
  pre_loaded_vlsm (composite_vlsm IM no_equivocations_additional_constraint_with_pre_loaded) seed.

Lemma seeded_no_equivocation_incl_preloaded :
  VLSM_incl composite_no_equivocation_vlsm_with_pre_loaded
    (pre_loaded_with_all_messages_vlsm (free_composite_vlsm IM)).
Proof.
  unfold composite_no_equivocation_vlsm_with_pre_loaded.
  match goal with
  |- VLSM_incl (pre_loaded_vlsm ?v _) _ =>
    specialize (pre_loaded_with_all_messages_vlsm_is_pre_loaded_with_True v) as Hprev
  end.
  destruct Hprev as [_ Hprev].
  match type of Hprev with
  | VLSM_incl (mk_vlsm ?m) _ => apply VLSM_incl_trans with m
  end.
  - cbn; clear Hprev.
    by apply (@pre_loaded_vlsm_incl message
      (composite_vlsm IM no_equivocations_additional_constraint_with_pre_loaded)).
  - match type of Hprev with
    | VLSM_incl _ (mk_vlsm ?m) => apply VLSM_incl_trans with m
    end
    ; [done |].
    unfold free_composite_vlsm; cbn.
    by apply preloaded_constraint_subsumption_incl.
Qed.

End sec_seeded_composite_vlsm_no_equivocation_definition.

(** Adds a no-equivocations condition on top of an existing constraint. *)
Definition no_equivocations_additional_constraint
  (l : composite_label IM)
  (som : composite_state IM * option message)
  :=
  composite_no_equivocations l som
  /\ constraint l som.

Context
  (SeededNoeqvFalse := composite_no_equivocation_vlsm_with_pre_loaded (fun m => False))
  (Noeqv := composite_vlsm IM no_equivocations_additional_constraint)
  (SeededNoeqvTrue := composite_no_equivocation_vlsm_with_pre_loaded (fun m => True))
  (PreFree := pre_loaded_with_all_messages_vlsm (free_composite_vlsm IM))
  .

Lemma false_composite_no_equivocation_vlsm_with_pre_loaded
  : VLSM_eq SeededNoeqvFalse Noeqv.
Proof.
  unfold SeededNoeqvFalse.
  unfold composite_no_equivocation_vlsm_with_pre_loaded.
  match goal with
  |- VLSM_eq (pre_loaded_vlsm ?m _) _ => specialize (vlsm_is_pre_loaded_with_False m) as Heq
  end.
  apply VLSM_eq_sym in Heq.
  match type of Heq with
  | VLSM_eq _ ?v => apply VLSM_eq_trans with (machine v)
  end
  ; [done |].
  specialize (constraint_subsumption_incl IM) as Hincl.
  unfold no_equivocations_additional_constraint_with_pre_loaded.
  by split; apply Hincl; intros l [s [m |]] Hpv; apply Hpv.
Qed.

End sec_seeded_composite_vlsm_no_equivocation.

End sec_composite_no_equivocation.