From Coq Require Import Arith ZArith.
From mathcomp Require Import ssreflect ssrbool ssrnat seq eqtype div.
From Common Require Import Tactics Arch Types SsrOrdered Bits Lists FSets Bools Nats ZAriths Var Store.
From mQhasm Require Import QFBV zSSA bvSSA.

Set Implicit Arguments.
Unset Strict Implicit.
Import Prenex Implicits.

Notation wordsize := AMD64.wordsize.

Opaque wordsize.

Import zSSA.
Import bv64SSA.

Definition svar_notin v vs : Prop := forall i, ~~ SSAVS.mem (v, i) vs.

Lemma svar_notin_singleton1 v x :
  svar_notin v (SSAVS.singleton x) -> v != svar x.
Proof.
  destruct x as [x i]. move=> /= H; move: (VSLemmas.not_mem_singleton1 (H i)).
  move=> Hne; apply/negP => Heq; apply: Hne. rewrite (eqP Heq).
  exact: SSAVS.E.eq_refl.
Qed.

Lemma svar_notin_singleton2 v x :
  v != svar x -> svar_notin v (SSAVS.singleton x).
Proof.
  move/negP=> Hne i. apply/negP => Heq; apply: Hne.
  move: (VSLemmas.mem_singleton1 Heq) => {Heq}. destruct x as [x j] => /=.
  move/eqP => [Hv Hi]. by rewrite Hv.
Qed.

Lemma svar_notin_union1 v vs1 vs2 :
  svar_notin v (SSAVS.union vs1 vs2) -> svar_notin v vs1.
Proof.
  move=> H i. move: (H i) => {H} H. exact: (proj1 (VSLemmas.not_mem_union1 H)).
Qed.

Lemma svar_notin_union2 v vs1 vs2 :
  svar_notin v (SSAVS.union vs1 vs2) -> svar_notin v vs2.
Proof.
  move=> H i. move: (H i) => {H} H. exact: (proj2 (VSLemmas.not_mem_union1 H)).
Qed.

Lemma svar_notin_union3 v vs1 vs2 :
  svar_notin v vs1 -> svar_notin v vs2 ->
  svar_notin v (SSAVS.union vs1 vs2).
Proof.
  move=> H1 H2 i. move: (H1 i) (H2 i) => {H1 H2} H1 H2.
  exact: (VSLemmas.not_mem_union2 H1 H2).
Qed.

Lemma svar_notin_add1 v x vs :
  svar_notin v (SSAVS.add x vs) -> v != svar x.
Proof.
  destruct x as [x i] => /= H. move: (H i) => {H} H.
  move: (VSLemmas.not_mem_add1 H) => {H}. move=> [H _]; apply/negP => Heq.
  apply: H. rewrite (eqP Heq); exact: eqxx.
Qed.

Lemma svar_notin_add2 v x vs :
  svar_notin v (SSAVS.add x vs) -> svar_notin v vs.
Proof.
  move=> H i. move: (H i) => {H} H. move: (VSLemmas.not_mem_add1 H) => {H}.
  move=> [_ H]; exact: H.
Qed.

Lemma svar_notin_replace v vs1 vs2 :
  SSAVS.Equal vs1 vs2 -> svar_notin v vs1 -> svar_notin v vs2.
Proof.
  move=> H H1 x. rewrite -H. exact: H1.
Qed.

Lemma svar_notin_subset v vs1 vs2 :
  SSAVS.subset vs1 vs2 -> svar_notin v vs2 -> svar_notin v vs1.
Proof.
  move=> H H2 x. apply/negP => H1. move: (VSLemmas.mem_subset H1 H) => Hmem.
  move/negP: (H2 x). apply. exact: Hmem.
Qed.

(** Generate new SSA variables *)

Definition max_svar (vs : SSAVS.t) : VarOrder.t :=
  match SSAVS.max_elt vs with
  | Some v => svar v
  | None => 0%num
  end.

Definition new_svar (vs : SSAVS.t) : VarOrder.t :=
  N.succ (max_svar vs).

Definition new_svar_program (p : program) : VarOrder.t :=
  N.succ (max_svar (vars_program p)).

Lemma N_ltb_succ v : (v <? N.succ v)%num.
Proof.
  apply: (proj2 (N.ltb_lt v (N.succ v))). exact: N.lt_succ_diag_r.
Qed.

Lemma V_ltb_succ v i j : SSAVarOrder.ltb (v, j) ((N.succ v), i).
Proof.
  rewrite /SSAVarOrder.ltb /SSAVarOrder.M.lt /VarOrder.ltb /NOrderMinimal.lt /=.
  rewrite N_ltb_succ. exact: is_true_true.
Qed.

Lemma new_svar_notin vs : svar_notin (new_svar vs) vs.
Proof.
  rewrite /new_svar /max_svar. set x := SSAVS.max_elt vs.
  have: SSAVS.max_elt vs = x by reflexivity. case x.
  - move=> v Hmax i. apply/negP => Hmem. apply: (VSLemmas.max_elt2 Hmax Hmem).
    exact: V_ltb_succ.
  - move=> Hnone i. apply: VSLemmas.is_empty_mem.
    exact: (VSLemmas.max_elt3 Hnone).
Qed.

Lemma new_svar_notin_program p :
  svar_notin (new_svar_program p) (vars_program p).
Proof.
  exact: new_svar_notin.
Qed.

(** Convert instructions and programs. *)

Definition bv2z_atomic (a : atomic) : zSSA.exp :=
  match a with
  | bvVar v => zVar v
  | bvConst c => zConst (toPosZ c)
  end.

Definition bv2z_instr (tmp : N) (idx : N) (i : instr) : (N * seq zSSA.instr) :=
  match i with
  | bvAssign v a => (idx, [:: zAssign v (bv2z_atomic a)])
(*  | bvNeg v a => [:: zAssign v (zUnop zNeg (bv2z_atomic a))] *)
  | bvAdd v a1 a2 => (idx,
                      [:: zAssign v (zadd (bv2z_atomic a1) (bv2z_atomic a2))])
  | bvAddC c v a1 a2 =>
    (idx,
     [:: zSplit c v (zadd (bv2z_atomic a1) (bv2z_atomic a2)) wordsize])
  | bvAdc v a1 a2 y =>
    (idx,
     [:: zAssign v (zadd (zadd (bv2z_atomic a1) (bv2z_atomic a2)) (zVar y))])
  | bvAdcC c v a1 a2 y =>
    (idx,
     [:: zSplit c v
         (zadd (zadd (bv2z_atomic a1) (bv2z_atomic a2)) (zVar y)) wordsize])
  | bvSub v a1 a2 => (idx,
                      [:: zAssign v (zsub (bv2z_atomic a1) (bv2z_atomic a2))])
  | bvSubC c v a1 a2 =>
    (N.succ idx,
     [:: zSplit (tmp, idx) v
         (zsub (bv2z_atomic a1) (bv2z_atomic a2)) wordsize;
        zAssign c (zneg (zVar (tmp, idx)))])
  | bvSbb v a1 a2 y =>
    (idx,
     [:: zAssign v (zsub (zsub (bv2z_atomic a1) (bv2z_atomic a2)) (zVar y))])
  | bvSbbC c v a1 a2 y =>
    (N.succ idx,
     [:: zSplit (tmp, idx) v
         (zsub (zsub (bv2z_atomic a1) (bv2z_atomic a2)) (zVar y)) wordsize;
        zAssign c (zneg (zVar (tmp, idx)))])
  | bvMul v a1 a2 => (idx,
                      [:: zAssign v (zmul (bv2z_atomic a1) (bv2z_atomic a2))])
  | bvMulf vh vl a1 a2 =>
    (idx,
     [:: zSplit vh vl (zmul (bv2z_atomic a1) (bv2z_atomic a2)) wordsize])
  | bvShl v a n => (idx,
                    [:: zAssign v (zmul2p (bv2z_atomic a) (toNat n))])
  | bvSplit vh vl a n => (idx, [:: zSplit vh vl (bv2z_atomic a) (toNat n)])
  | bvConcatShl vh vl a1 a2 n =>
    (idx,
     [:: zSplit vh vl
         (zadd (zmul2p (bv2z_atomic a1) wordsize) (bv2z_atomic a2))
         (wordsize - (toNat n))])
  end.

Fixpoint bv2z_program (tmp : N) (idx : N) (p : program) : (N * zSSA.program) :=
  match p with
  | [::] => (idx, [::])
  | hd::tl =>
    let (idx, hd) := (bv2z_instr tmp idx hd) in
    let (idx, tl) := (bv2z_program tmp idx tl) in
    (idx, hd ++ tl)
  end.

Definition addB_safe w (bv1 bv2 : BITS w) : bool :=
  ~~ carry_addB bv1 bv2.

Definition adcB_safe w (bv1 bv2 c : BITS w) : bool :=
  ~~ carry_addB bv1 bv2 && ~~ carry_addB (addB bv1 bv2) c.

Definition subB_safe w (bv1 bv2 : BITS w) : bool :=
  ~~ carry_subB bv1 bv2.

Definition sbbB_safe w (bv1 bv2 c : BITS w) : bool :=
  ~~ carry_subB bv1 bv2 && ~~ carry_subB (subB bv1 bv2) c.

Definition mulB_safe w (bv1 bv2 : BITS w) : bool :=
  high w (fullmulB bv1 bv2) == fromNat 0.

Definition shlBn_safe w (bv : BITS w) n : bool :=
  ltB bv (shlBn (@fromNat w 1) (w - n)).

Definition concatshl_safe w (bv1 bv2 : BITS w) n : bool :=
  (n <= w) && shlBn_safe bv1 n.

Definition bv2z_instr_safe_at (i : instr) (s : bv64SSA.State.t) : bool :=
  match i with
  | bvAssign _ _ => true
(*  | bvNeg _ _ => true *)
  | bvAdd _ a1 a2 => addB_safe (eval_atomic a1 s) (eval_atomic a2 s)
  | bvAddC _ _ _ _ => true
  | bvAdc _ a1 a2 y => adcB_safe (eval_atomic a1 s) (eval_atomic a2 s)
                                 (bv64SSA.State.acc y s)
  | bvAdcC _ _ _ _ _ => true
  | bvSub _ a1 a2 => subB_safe (eval_atomic a1 s) (eval_atomic a2 s)
  | bvSubC _ _ _ _ => true
  | bvSbb _ a1 a2 y => sbbB_safe (eval_atomic a1 s) (eval_atomic a2 s)
                                 (bv64SSA.State.acc y s)
  | bvSbbC _ _ _ _ _ => true
  | bvMul _ a1 a2 => mulB_safe (eval_atomic a1 s) (eval_atomic a2 s)
  | bvMulf _ _ _ _ => true
  | bvShl _ a n => shlBn_safe (eval_atomic a s) (toNat n)
  | bvSplit _ _ _ _ => true
  | bvConcatShl _ _ a1 a2 n =>
    concatshl_safe (eval_atomic a1 s) (eval_atomic a2 s) (toNat n)
  end.

Fixpoint bv2z_program_safe_at p s : bool :=
  match p with
  | [::] => true
  | hd::tl => bv2z_instr_safe_at hd s && bv2z_program_safe_at tl (eval_instr s hd)
  end.

Definition bv2z_program_safe p : Prop :=
  forall s, bv2z_program_safe_at p s.

Lemma bv2z_program_cons tmp idx1 idx2 i p zip :
  (idx2, zip) = bv2z_program tmp idx1 (i::p) ->
  exists idx3, exists zi, exists zp,
        (idx3, zi) = bv2z_instr tmp idx1 i /\
        (idx2, zp) = bv2z_program tmp idx3 p /\
        zip = zi ++ zp.
Proof.
  rewrite /=. sethave temp (bv2z_instr tmp idx1 i). destruct temp as [idx3 zi].
  sethave temp (bv2z_program tmp idx3 p). destruct temp as [idx zp].
  move=> Hp Hi [] -> ->. exists idx3; exists zi; exists zp. done.
Qed.

Lemma bv2z_instr_idx_inc tmp idx1 idx2 i zi :
  (idx2, zi) = bv2z_instr tmp idx1 i ->
  (idx1 <= idx2)%num.
Proof.
  case: i => /=; intros;
  (let rec tac :=
       match goal with
       | H : (_, _) = (_, _) |- _ => case: H => -> _; tac
       | |- (?x <= ?x)%num => exact: N.le_refl
       | |- (?x <= N.succ ?x)%num => exact: N.le_succ_diag_r
       | |- _ => idtac
       end in
   tac).
Qed.

Lemma bv2z_program_idx_inc tmp idx1 idx2 p zp :
  (idx2, zp) = bv2z_program tmp idx1 p ->
  (idx1 <= idx2)%num.
Proof.
  elim: p idx1 idx2 zp.
  - move=> idx1 idx2 zp [] -> _. exact: N.le_refl.
  - move=> i p IH idx1 idx2 zip H. move: (bv2z_program_cons H) => {H}.
    move=> [idx3 [zi [zp [Hzi [Hzp Hzip]]]]].
    move: (bv2z_instr_idx_inc Hzi) (IH _ _ _ Hzp) => Hle1 Hle2.
    exact: (N.le_trans _ _ _ Hle1 Hle2).
Qed.

Lemma bv2z_instr_lvs_case tmp idx1 idx2 i zi v :
  (idx2, zi) = bv2z_instr tmp idx1 i ->
  SSAVS.mem v (zSSA.lvs_program zi) ->
  SSAVS.mem v (lvs_instr i) \/
  tmp = svar v /\ (idx1 <= sidx v)%num /\ (sidx v < idx2)%num.
Proof.
  case: i => /=; intros;
  (let rec tac :=
       match goal with
       | H1 : (_, ?zi) = (_, _),
         H2 : is_true (SSAVS.mem _ (zSSA.lvs_program ?zi)) |- _ =>
         let H := fresh in case: H1 => -> H; rewrite H /= in H2 => {H}; tac
       | H : is_true (SSAVS.mem _ (SSAVS.singleton _)) |- _ =>
         move: (zSSA.VSLemmas.mem_singleton1 H) => {H} H; tac
       | H : is_true (SSAVS.mem _ (SSAVS.add _ _)) |- _ =>
         case: (zSSA.VSLemmas.mem_add1 H) => {H} H; tac
       | H : is_true (SSAVS.mem _ (SSAVS.union _ _)) |- _ =>
         case: (zSSA.VSLemmas.mem_union1 H) => {H} H; tac
       | H : SSAVS.E.eq ?v ?t |-
         is_true (SSAVS.mem ?v (SSAVS.singleton ?t)) \/ _ =>
         left; apply: VSLemmas.mem_singleton2; exact: H
       | H : SSAVS.E.eq ?v ?t |-
         is_true (SSAVS.mem ?v (SSAVS.add ?t _)) \/ _ =>
         left; apply: VSLemmas.mem_add2; exact: H
       | H : SSAVS.E.eq ?v ?t |-
         is_true (SSAVS.mem ?v (SSAVS.add _ (SSAVS.singleton ?t))) \/ _ =>
         left; apply: VSLemmas.mem_add3; apply: VSLemmas.mem_singleton2; exact: H
       | H : is_true (SSAVS.mem _ SSAVS.empty) |- _ =>
         apply: False_ind; rewrite zSSA.VSLemmas.mem_empty in H;
         exact: (not_false_is_true H)
       | H : SSAVS.E.eq ?v (?tmp, _) |- _ \/ (?tmp = svar ?v /\ _ /\ _) =>
         right; repeat split; [by rewrite (eqP H) | tac | tac]
       | H : SSAVS.E.eq ?v (_, ?i) |- (?i <= sidx ?v)%num =>
         rewrite (eqP H) /=; exact: N.le_refl
       | H : SSAVS.E.eq ?v (_, ?i) |- (sidx ?v < N.succ ?i)%num =>
         rewrite (eqP H0) /=; exact: N.lt_succ_diag_r
       | |- _ => idtac
       end in
      tac).
Qed.

Lemma bv2z_program_lvs_case tmp idx1 idx2 p zp v :
  (idx2, zp) = bv2z_program tmp idx1 p ->
  SSAVS.mem v (zSSA.lvs_program zp) ->
  SSAVS.mem v (lvs_program p) \/
  tmp = svar v /\ (idx1 <= sidx v)%num /\ (sidx v < idx2)%num.
Proof.
  elim: p tmp idx1 idx2 zp v => /=.
  - move=> tmp idx1 idx2 zp v [] -> -> H. apply: False_ind.
    apply: not_false_is_true. rewrite zSSA.VSLemmas.mem_empty in H.
    exact: H.
  - move=> i p IH tmp idx1 idx2 zip v Hzip.
    move: (bv2z_program_cons Hzip) => {Hzip} [idx3 [zi [zp [Hzi [Hzp ->]]]]].
    rewrite zSSA.lvs_program_concat => Hmem.
    case: (zSSA.VSLemmas.mem_union1 Hmem) => {Hmem} Hmem.
    + case: (bv2z_instr_lvs_case Hzi Hmem).
      * move=> {Hmem} Hmem; left; apply: VSLemmas.mem_union2; exact: Hmem.
      * move=> [H1 [H2 H3]]. right; repeat split; [exact: H1 | exact: H2 | idtac].
        exact: (N.lt_le_trans _ _ _ H3 (bv2z_program_idx_inc Hzp)).
    + case: (IH _ _ _ _ _ Hzp Hmem).
      * move=> {Hmem} Hmem; left; apply: VSLemmas.mem_union3; exact: Hmem.
      * move=> [H1 [H2 H3]]. right; repeat split; [exact: H1 | idtac | exact: H3].
        exact: (N.le_trans _ _ _ (bv2z_instr_idx_inc Hzi) H2).
Qed.

(** State equivalence. *)

Definition bvz_eq (sb : State.t) (sz : zSSA.State.t) : Prop :=
  forall x, toPosZ (State.acc x sb) = zSSA.State.acc x sz.

Lemma bvz_eq_upd v bv zv sb sz :
  bvz_eq sb sz ->
  toPosZ bv = zv ->
  bvz_eq (State.upd v bv sb) (zSSA.State.upd v zv sz).
Proof.
  move=> Heq Hbv x. case Hxv: (x == v).
  - rewrite (State.acc_upd_eq _ _ Hxv) (zSSA.State.acc_upd_eq _ _ Hxv).
    exact: Hbv.
  - move/idP/negP: Hxv => Hxv.
    rewrite (State.acc_upd_neq _ _ Hxv) (zSSA.State.acc_upd_neq _ _ Hxv).
    exact: Heq.
Qed.

Lemma bvz_eq_upd2 vh vl bvh bvl zvh zvl sb sz :
  bvz_eq sb sz ->
  toPosZ bvh = zvh ->
  toPosZ bvl = zvl ->
  bvz_eq (State.upd2 vh bvh vl bvl sb) (zSSA.State.upd2 vh zvh vl zvl sz).
Proof.
  move=> Heq Hbvh Hbvl x. case Hxvl: (x == vl).
  - rewrite (State.acc_upd_eq _ _ Hxvl) (zSSA.State.acc_upd_eq _ _ Hxvl).
    exact: Hbvl.
  - move/idP/negP: Hxvl => Hxvl.
    rewrite (State.acc_upd_neq _ _ Hxvl) (zSSA.State.acc_upd_neq _ _ Hxvl).
    case Hxvh: (x == vh).
    + rewrite (State.acc_upd_eq _ _ Hxvh) (zSSA.State.acc_upd_eq _ _ Hxvh).
      exact: Hbvh.
    + move/idP/negP: Hxvh => Hxvh.
      rewrite (State.acc_upd_neq _ _ Hxvh) (zSSA.State.acc_upd_neq _ _ Hxvh).
      exact: Heq.
Qed.

(** State equivalence except a set of variables. *)

Definition bvz_eqm (tmp : VarOrder.t) (sb : State.t) (sz : zSSA.State.t) : Prop :=
  forall x, tmp != svar x ->
            (toPosZ (State.acc x sb) = zSSA.State.acc x sz).

Lemma bvz_eq_eqm tmp sb sz : bvz_eq sb sz -> bvz_eqm tmp sb sz.
Proof.
  move=> H x _. exact: H.
Qed.

Lemma bvz_eqm_upd v bv zv tmp sb sz :
  bvz_eqm tmp sb sz ->
  toPosZ bv = zv ->
  bvz_eqm tmp (State.upd v bv sb) (zSSA.State.upd v zv sz).
Proof.
  move=> Heq Hbv x Hne. case Hxv: (x == v).
  - rewrite (State.acc_upd_eq _ _ Hxv) (zSSA.State.acc_upd_eq _ _ Hxv).
    exact: Hbv.
  - move/idP/negP: Hxv => Hxv.
    rewrite (State.acc_upd_neq _ _ Hxv) (zSSA.State.acc_upd_neq _ _ Hxv).
    exact: (Heq _ Hne).
Qed.

Lemma bvz_eqm_upd2 vh vl bvh bvl zvh zvl tmp sb sz :
  bvz_eqm tmp sb sz ->
  toPosZ bvh = zvh ->
  toPosZ bvl = zvl ->
  bvz_eqm tmp (State.upd2 vh bvh vl bvl sb) (zSSA.State.upd2 vh zvh vl zvl sz).
Proof.
  move=> Heq Hbvh Hbvl x Hne. case Hxvl: (x == vl).
  - rewrite (State.acc_upd_eq _ _ Hxvl) (zSSA.State.acc_upd_eq _ _ Hxvl).
    exact: Hbvl.
  - move/idP/negP: Hxvl => Hxvl.
    rewrite (State.acc_upd_neq _ _ Hxvl) (zSSA.State.acc_upd_neq _ _ Hxvl).
    case Hxvh: (x == vh).
    + rewrite (State.acc_upd_eq _ _ Hxvh) (zSSA.State.acc_upd_eq _ _ Hxvh).
      exact: Hbvh.
    + move/idP/negP: Hxvh => Hxvh.
      rewrite (State.acc_upd_neq _ _ Hxvh) (zSSA.State.acc_upd_neq _ _ Hxvh).
      exact: (Heq _ Hne).
Qed.

Lemma bvz_eqm_upd2_aux c v bvc bvv zvc zvv zvt tmp idx sb sz :
  bvz_eqm tmp sb sz ->
  toPosZ bvc = zvc ->
  toPosZ bvv = zvv ->
  tmp != svar c ->
  tmp != svar v ->
  bvz_eqm tmp
          (State.upd2 v bvv c bvc sb)
          (zSSA.State.upd c
                          zvc
                          (zSSA.State.upd2 v zvv (tmp, idx) zvt sz)).
Proof.
  move=> Heqm Hc Hv Hnec Hnev x Hnex.
  case Hxc: (x == c).
  - rewrite (zSSA.State.acc_upd_eq _ _ Hxc) (State.acc_upd2_eq2 _ _ _ _ Hxc).
    exact: Hc.
  - move/idP/negP: Hxc => Hxc. rewrite (zSSA.State.acc_upd_neq _ _ Hxc).
    have Hxtmp: x != (tmp, idx).
    { apply/negP => Heq. move/negP: Hnex; apply. by rewrite (eqP Heq). }
    case Hxv: (x == v).
    + rewrite (State.acc_upd2_eq1 _ _ _ Hxv Hxc).
      rewrite (zSSA.State.acc_upd2_eq1 _ _ _ Hxv Hxtmp). exact: Hv.
    + move/idP/negP: Hxv => Hxv.
      rewrite (State.acc_upd2_neq _ _ _ Hxv Hxc).
      rewrite (zSSA.State.acc_upd2_neq _ _ _ Hxv Hxtmp).
      exact: (Heqm _ Hnex).
Qed.

(** Properties of program conversion. *)

Lemma bvz_eqm_eval_atomic tmp a sb sz :
  bvz_eqm tmp sb sz ->
  svar_notin tmp (vars_atomic a) ->
  toPosZ (eval_atomic a sb) = (zSSA.eval_exp (bv2z_atomic a) sz).
Proof.
  move=> Heqm; case: a => /=.
  - move=> x Hnotin. exact: (Heqm _ (svar_notin_singleton1 Hnotin)).
  - reflexivity.
Qed.

Lemma bvz_eqm_eval_instr tmp idx1 idx2 i zi sb sz :
  bvz_eqm tmp sb sz ->
  svar_notin tmp (vars_instr i) ->
  bv2z_instr_safe_at i sb ->
  (idx2, zi) = bv2z_instr tmp idx1 i ->
  bvz_eqm tmp (eval_instr sb i) (zSSA.eval_program sz zi).
Proof.
  move=> Heqm; case: i.
  - (* bvAssign *)
    move=> v a Hnotin _ [] _ -> /=. apply: (bvz_eqm_upd _ Heqm).
    exact: (bvz_eqm_eval_atomic Heqm (svar_notin_add2 Hnotin)).
  - (* bvAdd *)
    move=> v a1 a2 Hnotin Hsafe [] _ -> /=.
    move: (svar_notin_add2 Hnotin) => {Hnotin} Hnotin.
    apply: (bvz_eqm_upd _ Heqm).
    rewrite -(bvz_eqm_eval_atomic Heqm (svar_notin_union1 Hnotin))
            -(bvz_eqm_eval_atomic Heqm (svar_notin_union2 Hnotin)).
    exact: toPosZ_addB_bounded.
  - (* bvAddC *)
    move=> c v a1 a2 Hnotin _ [] _ -> /=.
    move: (svar_notin_add2 (svar_notin_add2 Hnotin)) => {Hnotin} Hnotin.
    rewrite -(bvz_eqm_eval_atomic Heqm (svar_notin_union1 Hnotin))
            -(bvz_eqm_eval_atomic Heqm (svar_notin_union2 Hnotin)).
    sethave temp
            (Z.div_eucl (toPosZ (eval_atomic a1 sb) + toPosZ (eval_atomic a2 sb))
                        (2 ^ Z.of_nat wordsize)).
    destruct temp as [q r] => Hqr. apply: (bvz_eqm_upd2 _ _ Heqm).
    + exact: (toPosZ_addB_zeroExtend_low Hqr).
    + exact: (toPosZ_addB_zeroExtend_high Hqr).
  - (* bvAdc *)
    move=> v a1 a2 y Hnotin Hsafe [] _ -> /=.
    move: (svar_notin_add1 Hnotin) => Hne.
    move: (svar_notin_add2 (svar_notin_add2 Hnotin)) => {Hnotin} Hnotin.
    apply: (bvz_eqm_upd _ Heqm).
    rewrite -(bvz_eqm_eval_atomic Heqm (svar_notin_union1 Hnotin))
            -(bvz_eqm_eval_atomic Heqm (svar_notin_union2 Hnotin))
            -(Heqm _ Hne).
    move: Hsafe => /andP [Hsafe1 Hsafe2].
    exact: toPosZ_addB3_bounded.
  - (* bvAdcC *)
    move=> c v a1 a2 y Hnotin _ [] _ -> /=.
    move: (svar_notin_add1 Hnotin) => Hne.
    move: (svar_notin_add2 (svar_notin_add2 (svar_notin_add2 Hnotin)))
          => {Hnotin} Hnotin.
    rewrite -(bvz_eqm_eval_atomic Heqm (svar_notin_union1 Hnotin))
            -(bvz_eqm_eval_atomic Heqm (svar_notin_union2 Hnotin))
            -(Heqm _ Hne).
    sethave temp
            (Z.div_eucl
               (toPosZ (eval_atomic a1 sb) + toPosZ (eval_atomic a2 sb) +
                toPosZ (State.acc y sb)) (2 ^ Z.of_nat wordsize)).
    destruct temp as [q r] => Hqr.
    apply: (bvz_eqm_upd2 _ _ Heqm).
    + exact: (toPosZ_addB3_zeroExtend_low Hqr).
    + exact: (toPosZ_addB3_zeroExtend_high Hqr).
  - (* bvSub *)
    move=> v a1 a2 Hnotin Hsafe [] _ -> /=.
    move: (svar_notin_add2 Hnotin) => {Hnotin} Hnotin.
    apply: (bvz_eqm_upd _ Heqm).
    rewrite -(bvz_eqm_eval_atomic Heqm (svar_notin_union1 Hnotin))
            -(bvz_eqm_eval_atomic Heqm (svar_notin_union2 Hnotin)).
    exact: toPosZ_subB_bounded.
  - (* bvSubC *)
    move=> c v a1 a2 Hnotin _ [] _ -> /=.
    move: (svar_notin_add1 Hnotin) => Hnec.
    move: (svar_notin_add1 (svar_notin_add2 Hnotin)) => Hnev.
    move: (svar_notin_add2 (svar_notin_add2 Hnotin)) => {Hnotin} Hnotin.
    rewrite -(bvz_eqm_eval_atomic Heqm (svar_notin_union1 Hnotin))
            -(bvz_eqm_eval_atomic Heqm (svar_notin_union2 Hnotin)).
    sethave temp (Z.div_eucl
                    (toPosZ (eval_atomic a1 sb) - toPosZ (eval_atomic a2 sb))
                    (2 ^ Z.of_nat wordsize)).
    destruct temp as [q r] => Hqr.
    apply: (bvz_eqm_upd2_aux _ _ Heqm _ _ Hnec Hnev).
    + rewrite (zSSA.State.acc_upd2_eq2 _ _ _ _ (eqxx (tmp, idx1))).
      exact: (toPosZ_subB_zeroExtend_high Hqr).
    + exact: (toPosZ_subB_zeroExtend_low Hqr).
  - (* bvSbb *)
    move=> v a1 a2 y Hnotin Hsafe [] _ -> /=.
    move: (svar_notin_add1 Hnotin) => Hne.
    move: (svar_notin_add2 (svar_notin_add2 Hnotin)) => {Hnotin} Hnotin.
    apply: (bvz_eqm_upd _ Heqm).
    rewrite -(bvz_eqm_eval_atomic Heqm (svar_notin_union1 Hnotin))
            -(bvz_eqm_eval_atomic Heqm (svar_notin_union2 Hnotin))
            -(Heqm _ Hne).
    move: Hsafe => /andP [Hsafe1 Hsafe2].
    exact: toPosZ_subB3_bounded.
  - (* bvSbbC *)
    move=> c v a1 a2 y Hnotin _ [] _ -> /=.
    move: (svar_notin_add1 Hnotin) => Hney.
    move: (svar_notin_add1 (svar_notin_add2 Hnotin)) => Hnec.
    move: (svar_notin_add1 (svar_notin_add2 ((svar_notin_add2 Hnotin)))) => Hnev.
    move: (svar_notin_add2 (svar_notin_add2 ((svar_notin_add2 Hnotin))))
    => {Hnotin} Hnotin.
    rewrite -(bvz_eqm_eval_atomic Heqm (svar_notin_union1 Hnotin))
            -(bvz_eqm_eval_atomic Heqm (svar_notin_union2 Hnotin))
            -(Heqm _ Hney).
    sethave temp (Z.div_eucl
                    (toPosZ (eval_atomic a1 sb) - toPosZ (eval_atomic a2 sb) -
                     toPosZ (State.acc y sb)) (2 ^ Z.of_nat wordsize)).
    destruct temp as [q r] => Hqr.
    apply: (bvz_eqm_upd2_aux _ _ Heqm _ _ Hnec Hnev).
    + rewrite (zSSA.State.acc_upd2_eq2 _ _ _ _ (eqxx (tmp, idx1))).
      exact: (toPosZ_subB3_zeroExtend_high Hqr).
    + exact: (toPosZ_subB3_zeroExtend_low Hqr).
  - (* bvMul *)
    move=> v a1 a2 Hnotin Hsafe [] _ -> /=. apply: (bvz_eqm_upd _ Heqm).
    move: (svar_notin_add2 Hnotin) => {Hnotin} Hnotin.
    rewrite -(bvz_eqm_eval_atomic Heqm (svar_notin_union1 Hnotin))
            -(bvz_eqm_eval_atomic Heqm (svar_notin_union2 Hnotin)).
    apply: toPosZ_mulB_bounded. rewrite -fromNat0. apply/eqP.
    exact: Hsafe.
  - (* bvMulf *)
    move=> vh vl a1 a2 Hnotin _ [] _ -> /=.
    move: (svar_notin_add2 (svar_notin_add2 Hnotin)) => {Hnotin} Hnotin.
    rewrite -(bvz_eqm_eval_atomic Heqm (svar_notin_union1 Hnotin))
            -(bvz_eqm_eval_atomic Heqm (svar_notin_union2 Hnotin)).
    sethave temp
            (Z.div_eucl (toPosZ (eval_atomic a1 sb) * toPosZ (eval_atomic a2 sb))
                        (2 ^ Z.of_nat wordsize)).
    destruct temp as [q r] => Hqr. apply: (bvz_eqm_upd2 _ _ Heqm).
    + exact: (toPosZ_fullmulB_low Hqr).
    + exact: (toPosZ_fullmulB_high Hqr).
  - (* bvShl *)
    move=> v a n Hnotin Hsafe [] _ -> /=.
    move: (svar_notin_add2 Hnotin) => {Hnotin} Hnotin.
    apply: (bvz_eqm_upd _ Heqm). rewrite -(bvz_eqm_eval_atomic Heqm Hnotin).
    exact: toPosZ_shlBn_bounded.
  - (* bvSplit *)
    move=> vh vl a n Hnotin _ [] _ -> /=.
    move: (svar_notin_add2 (svar_notin_add2 Hnotin)) => {Hnotin} Hnotin.
    rewrite -(bvz_eqm_eval_atomic Heqm Hnotin).
    set temp := Z.div_eucl (toPosZ (eval_atomic a sb)) (2 ^ Z.of_nat (toNat n)).
    have: temp = Z.div_eucl (toPosZ (eval_atomic a sb)) (2 ^ Z.of_nat (toNat n))
      by reflexivity.
    destruct temp as [q r] => Hqr.
    apply: (bvz_eqm_upd2 _ _ Heqm).
    + exact: (toPosZ_shrBn_low Hqr).
    + exact: (toPosZ_shrBn_high Hqr).
  - (* bvConcatShl *)
    move=> vh vl a1 a2 n Hnotin Hsafe [] _ -> /=.
    move: (svar_notin_add2 (svar_notin_add2 Hnotin)) => {Hnotin} Hnotin.
    rewrite -(bvz_eqm_eval_atomic Heqm (svar_notin_union1 Hnotin))
            -(bvz_eqm_eval_atomic Heqm (svar_notin_union2 Hnotin)).
    sethave temp
            (Z.div_eucl
               (toPosZ (eval_atomic a1 sb) *
                2 ^ Z.of_nat wordsize +
                    toPosZ (eval_atomic a2 sb))
               (2 ^ Z.of_nat (wordsize - (toNat n)))).
    destruct temp as [q r] => Hqr. move/andP: Hsafe => [Hle Hsafe].
    apply: (bvz_eqm_upd2 _ _ Heqm).
    + exact: (toPosZ_catB_shlBn_low_shrBn Hle Hsafe Hqr).
    + exact: (toPosZ_catB_shlBn_high Hle Hsafe Hqr).
Qed.

Lemma bvz_eqm_eval_program tmp idx1 idx2 p zp sb sz :
  bvz_eqm tmp sb sz ->
  svar_notin tmp (vars_program p) ->
  bv2z_program_safe_at p sb ->
  (idx2, zp) = bv2z_program tmp idx1 p ->
  bvz_eqm tmp (eval_program sb p) (zSSA.eval_program sz zp).
Proof.
  elim: p tmp idx1 idx2 zp sb sz.
  - move=> tmp idx1 idx2 zp sb sz Heqm Hnotin _ /= [] _ ->. exact: Heqm.
  - move=> hd tl IH tmp idx1 idx2 zip sb sz Heqm Hnotin /andP [Hhd Htl] Hzip.
    move: (bv2z_program_cons Hzip) => {Hzip} [idx3 [zi [zp [Hzi [Hzp ->]]]]].
    rewrite zSSA.eval_program_concat_step.
    move: (svar_notin_union1 Hnotin) (svar_notin_union2 Hnotin) =>
    {Hnotin} Hnotinhd Hnotintl. apply: (IH _ _ _ _ _ _ _ _ _ Hzp).
    + apply: (bvz_eqm_eval_instr Heqm Hnotinhd Hhd Hzi).
    + exact: Hnotintl.
    + exact: Htl.
Qed.

(** Convert specifications. *)

Definition bv2z_unop (op : unop) : zSSA.unop :=
  match op with
  | bvNegOp => zSSA.zNeg
  end.

Definition bv2z_binop (op : binop) : zSSA.binop :=
  match op with
  | bvAddOp => zSSA.zAdd
  | bvSubOp => zSSA.zSub
  | bvMulOp => zSSA.zMul
  end.

Fixpoint bv2z_eexp (e : eexp) : zSSA.exp :=
  match e with
  | bveVar v => zVar v
  | bveConst c => zConst c
  | bveUnop op e => zUnop (bv2z_unop op) (bv2z_eexp e)
  | bveBinop op e1 e2 => zBinop (bv2z_binop op) (bv2z_eexp e1) (bv2z_eexp e2)
  end.

Fixpoint bv2z_ebexp e : zSSA.bexp :=
  match e with
  | bveTrue => zSSA.zTrue
  | bveEq e1 e2 => zSSA.zEq (bv2z_eexp e1) (bv2z_eexp e2)
  | bveEqMod e1 e2 p => zSSA.zEqMod (bv2z_eexp e1) (bv2z_eexp e2) (bv2z_eexp p)
  | bveAnd e1 e2 => zSSA.zAnd (bv2z_ebexp e1) (bv2z_ebexp e2)
  end.

Definition bv2z_spec_rng s : rspec :=
  {| rspre := rng_bexp (spre s);
     rsprog := sprog s;
     rspost := rng_bexp (spost s) |}.

Definition initial_tmp_sidx : N := 1.

Definition new_svar_spec_eqn vs s : VarOrder.t :=
  new_svar (SSAVS.union vs
                     (SSAVS.union
                        (vars_bexp (spre s))
                        (SSAVS.union (vars_program (sprog s))
                                  (vars_bexp (spost s))))).

(* vs: input variables
   s: specification *)
Definition bv2z_spec_eqn vs s : zSSA.spec :=
  let (idx, zp) := bv2z_program (new_svar_spec_eqn vs s)
                                initial_tmp_sidx (sprog s) in
  {| zSSA.spre := bv2z_ebexp (eqn_bexp (spre s));
     zSSA.sprog := zp;
     zSSA.spost := bv2z_ebexp (eqn_bexp (spost s)) |}.

Definition bv2z_spec_safe sp :=
  forall s, eval_rbexp (rng_bexp (spre sp)) s ->
            bv2z_program_safe_at (sprog sp) s.

Lemma svar_notin_inputs vs s :
  svar_notin (new_svar_spec_eqn vs s) vs.
Proof.
  rewrite /new_svar_spec_eqn.
  set ss := (SSAVS.union vs
                     (SSAVS.union (vars_bexp (spre s))
                               (SSAVS.union (vars_program (sprog s))
                                         (vars_bexp (spost s))))).
  move: (new_svar_notin ss) => H. exact: (svar_notin_union1 H).
Qed.

Lemma svar_notin_spre vs s :
  svar_notin (new_svar_spec_eqn vs s) (vars_bexp (spre s)).
Proof.
  rewrite /new_svar_spec_eqn.
  set ss := (SSAVS.union vs
                     (SSAVS.union (vars_bexp (spre s))
                               (SSAVS.union (vars_program (sprog s))
                                         (vars_bexp (spost s))))).
  move: (new_svar_notin ss) => H.
  exact: (svar_notin_union1 (svar_notin_union2 H)).
Qed.

Lemma svar_notin_sprog vs s :
  svar_notin (new_svar_spec_eqn vs s) (vars_program (sprog s)).
Proof.
  rewrite /new_svar_spec_eqn.
  set ss := (SSAVS.union vs
                     (SSAVS.union (vars_bexp (spre s))
                               (SSAVS.union (vars_program (sprog s))
                                         (vars_bexp (spost s))))).
  move: (new_svar_notin ss) => H.
  exact: (svar_notin_union1 (svar_notin_union2 (svar_notin_union2 H))).
Qed.

Lemma svar_notin_spost vs s :
  svar_notin (new_svar_spec_eqn vs s) (vars_bexp (spost s)).
Proof.
  rewrite /new_svar_spec_eqn.
  set ss := (SSAVS.union vs
                     (SSAVS.union (vars_bexp (spre s))
                               (SSAVS.union (vars_program (sprog s))
                                         (vars_bexp (spost s))))).
  move: (new_svar_notin ss) => H.
  exact: (svar_notin_union2 (svar_notin_union2 (svar_notin_union2 H))).
Qed.

(** Properties of specification conversion. *)

Lemma bvz_eq_eval_eunop op (v : Z) :
  eval_eunop op v =
  zSSA.eval_unop (bv2z_unop op) v.
Proof.
  case: op; reflexivity.
Qed.

Lemma bvz_eq_eval_ebinop op (v1 v2 : Z) :
  eval_ebinop op v1 v2 =
  zSSA.eval_binop (bv2z_binop op) v1 v2.
Proof.
  case: op; reflexivity.
Qed.

Lemma bvz_eq_eval_eexp (e : eexp) bs zs :
  bvz_eq bs zs ->
  eval_eexp e bs = zSSA.eval_exp (bv2z_eexp e) zs.
Proof.
  elim: e => /=.
  - move=> a Heq. exact: Heq.
  - reflexivity.
  - move=> op e IH Heq. rewrite -(IH Heq). exact: bvz_eq_eval_eunop.
  - move=> op e1 IH1 e2 IH2 Heq. rewrite -(IH1 Heq) -(IH2 Heq).
    exact: bvz_eq_eval_ebinop.
Qed.

Lemma bvz_eq_eval_ebexp1 e bs zs :
  bvz_eq bs zs ->
  eval_ebexp e bs ->
  zSSA.eval_bexp (bv2z_ebexp e) zs.
Proof.
  elim: e => /=.
  - done.
  - move=> e1 e2 Heq Heval.
    rewrite -(bvz_eq_eval_eexp e1 Heq) -(bvz_eq_eval_eexp e2 Heq). exact: Heval.
  - move=> e1 e2 p Heq Heval.
    rewrite -(bvz_eq_eval_eexp e1 Heq) -(bvz_eq_eval_eexp e2 Heq)
            -(bvz_eq_eval_eexp p Heq). exact: Heval.
  - move=> e1 IH1 e2 IH2 Heq [Heval1 Heval2].
    split; [exact: (IH1 Heq Heval1) | exact: (IH2 Heq Heval2)].
Qed.

Lemma bvz_eq_eval_ebexp2 e bs zs :
  bvz_eq bs zs ->
  zSSA.eval_bexp (bv2z_ebexp e) zs ->
  eval_ebexp e bs.
Proof.
  elim: e => /=.
  - done.
  - move=> e1 e2 Heq Heval.
    rewrite (bvz_eq_eval_eexp e1 Heq) (bvz_eq_eval_eexp e2 Heq). exact: Heval.
  - move=> e1 e2 p Heq Heval.
    rewrite (bvz_eq_eval_eexp e1 Heq) (bvz_eq_eval_eexp e2 Heq)
            (bvz_eq_eval_eexp p Heq). exact: Heval.
  - move=> e1 IH1 e2 IH2 Heq [Heval1 Heval2].
    split; [exact: (IH1 Heq Heval1) | exact: (IH2 Heq Heval2)].
Qed.

Lemma eval_bexp_combine e bs zs :
  bvz_eq bs zs ->
  eval_rbexp (rng_bexp e) bs ->
  zSSA.eval_bexp (bv2z_ebexp (eqn_bexp e)) zs ->
  eval_bexp e bs.
Proof.
  move=> Heq Her Hee. split.
  - exact: (bvz_eq_eval_ebexp2 Heq Hee).
  - exact: Her.
Qed.

Lemma bvz_eqm_eval_eexp tmp (e : eexp) bs zs :
  bvz_eqm tmp bs zs ->
  svar_notin tmp (vars_eexp e) ->
  eval_eexp e bs = zSSA.eval_exp (bv2z_eexp e) zs.
Proof.
  elim: e => /=.
  - move=> a Heqm Hnotin. exact: (Heqm _ (svar_notin_singleton1 Hnotin)).
  - reflexivity.
  - move=> op e IH Heqm Hnotin. rewrite -(IH Heqm Hnotin).
    exact: bvz_eq_eval_eunop.
  - move=> op e1 IH1 e2 IH2 Heqm Hnotin.
    rewrite -(IH1 Heqm (svar_notin_union1 Hnotin))
            -(IH2 Heqm (svar_notin_union2 Hnotin)).
    exact: bvz_eq_eval_ebinop.
Qed.

Lemma bvz_eqm_eval_ebexp1 tmp e bs zs :
  bvz_eqm tmp bs zs ->
  svar_notin tmp (vars_ebexp e) ->
  eval_ebexp e bs ->
  zSSA.eval_bexp (bv2z_ebexp e) zs.
Proof.
  elim: e => /=.
  - done.
  - move=> e1 e2 Heqm Hnotin Heval.
    rewrite -(bvz_eqm_eval_eexp Heqm (svar_notin_union1 Hnotin))
            -(bvz_eqm_eval_eexp Heqm (svar_notin_union2 Hnotin)). exact: Heval.
  - move=> e1 e2 p Heqm Hnotin Heval.
    move: (svar_notin_union1 Hnotin)
          (svar_notin_union1 (svar_notin_union2 Hnotin))
          (svar_notin_union2 (svar_notin_union2 Hnotin)) =>
    {Hnotin} He1 He2 Hp.
    rewrite -(bvz_eqm_eval_eexp Heqm He1) -(bvz_eqm_eval_eexp Heqm He2)
            -(bvz_eqm_eval_eexp Heqm Hp). exact: Heval.
  - move=> e1 IH1 e2 IH2 Heqm Hnotin [Heval1 Heval2].
    split; [exact: (IH1 Heqm (svar_notin_union1 Hnotin) Heval1) |
            exact: (IH2 Heqm (svar_notin_union2 Hnotin) Heval2)].
Qed.

Lemma bvz_eqm_eval_ebexp2 tmp e bs zs :
  bvz_eqm tmp bs zs ->
  svar_notin tmp (vars_ebexp e) ->
  zSSA.eval_bexp (bv2z_ebexp e) zs ->
  eval_ebexp e bs.
Proof.
  elim: e => /=.
  - done.
  - move=> e1 e2 Heqm Hnotin Heval.
    rewrite (bvz_eqm_eval_eexp Heqm (svar_notin_union1 Hnotin))
            (bvz_eqm_eval_eexp Heqm (svar_notin_union2 Hnotin)). exact: Heval.
  - move=> e1 e2 p Heqm Hnotin Heval.
    move: (svar_notin_union1 Hnotin)
          (svar_notin_union1 (svar_notin_union2 Hnotin))
          (svar_notin_union2 (svar_notin_union2 Hnotin)) =>
    {Hnotin} He1 He2 Hp.
    rewrite (bvz_eqm_eval_eexp Heqm He1) (bvz_eqm_eval_eexp Heqm He2)
            (bvz_eqm_eval_eexp Heqm Hp). exact: Heval.
  - move=> e1 IH1 e2 IH2 Heqm Hnotin [Heval1 Heval2].
    split; [exact: (IH1 Heqm (svar_notin_union1 Hnotin) Heval1) |
            exact: (IH2 Heqm (svar_notin_union2 Hnotin) Heval2)].
Qed.

Lemma eval_bexp_combine_eqm tmp e bs zs :
  bvz_eqm tmp bs zs ->
  svar_notin tmp (vars_bexp e) ->
  eval_rbexp (rng_bexp e) bs ->
  zSSA.eval_bexp (bv2z_ebexp (eqn_bexp e)) zs ->
  eval_bexp e bs.
Proof.
  move=> Heqm Hnotin Her Hee. split.
  - exact: (bvz_eqm_eval_ebexp2 Heqm (svar_notin_union1 Hnotin) Hee).
  - exact: Her.
Qed.

(** Convert bvState to zState. *)

Definition bv2z_state bs : zSSA.State.t :=
  fun v => toPosZ (State.acc v bs).

Lemma bv2z_state_eq bs :
  bvz_eq bs (bv2z_state bs).
Proof.
  move=> x; reflexivity.
Qed.

(** Well-formedness *)

Lemma bv2z_atomic_vars a :
  SSAVS.Equal (zSSA.vars_exp (bv2z_atomic a)) (bv64SSA.vars_atomic a).
Proof.
  case: a => /=; reflexivity.
Qed.

Lemma bv2z_eexp_vars (e : eexp) :
  SSAVS.Equal (zSSA.vars_exp (bv2z_eexp e)) (vars_eexp e).
Proof.
  elim: e => /=.
  - reflexivity.
  - reflexivity.
  - move=> _ e IH. exact: IH.
  - move=> _ e1 IH1 e2 IH2. rewrite IH1 IH2. reflexivity.
Qed.

(* Convert (vars_* (bv2z_* _)) to (vars_* _). *)
Ltac vars_to_bvssa :=
  match goal with
  | |- context f [SSAVS.union _ SSAVS.empty] =>
    rewrite zSSA.VSLemmas.union_emptyr; vars_to_bvssa
  | |- context f [vars_exp (bv2z_atomic _)] =>
    rewrite !bv2z_atomic_vars; vars_to_bvssa
  | |- context f [vars_exp (bv2z_eexp _)] =>
    rewrite !bv2z_eexp_vars; vars_to_bvssa
  | |- _ => idtac
  end.

Lemma bv2z_instr_lvs_subset tmp idx1 idx2 i zi :
  (idx2, zi) = bv2z_instr tmp idx1 i ->
  SSAVS.subset (lvs_instr i) (zSSA.lvs_program zi).
Proof.
  case: i => /=; intros;
  (let rec tac :=
       match goal with
       | H : (_, _) = (_, _) |- _ => case: H => _ -> /=; tac
       | |- _ => zSSA.VSLemmas.dp_subset
       end in
   tac).
Qed.

Lemma bv2z_program_lvs_subset tmp idx1 idx2 p zp :
  (idx2, zp) = bv2z_program tmp idx1 p ->
  SSAVS.subset (lvs_program p) (zSSA.lvs_program zp).
Proof.
  elim: p tmp idx1 idx2 zp => /=.
  - move=> _ idx1 idx2 zp [] _ ->. done.
  - move=> i p IH tmp idx1 idx2 zip Hzip.
    move: (bv2z_program_cons Hzip) => {Hzip} [idx3 [zi [zp [Hzi [Hzp ->]]]]].
    rewrite zSSA.lvs_program_concat. apply: zSSA.VSLemmas.union_subsets.
    + exact: (bv2z_instr_lvs_subset Hzi).
    + exact: (IH _ _ _ _ Hzp).
Qed.

Lemma bv2z_instr_vars_subset tmp idx1 idx2 i zi :
  (idx2, zi) = bv2z_instr tmp idx1 i ->
  SSAVS.subset (vars_instr i) (zSSA.vars_program zi).
Proof.
  case: i => /=; intros;
  (let rec tac :=
       match goal with
       | H : (_, _) = (_, _) |- _ => case: H => _ -> /=; tac
       | |- is_true (SSAVS.mem _ _) => zSSA.VSLemmas.dp_mem
       | |- is_true (SSAVS.subset _ _) => vars_to_bvssa; zSSA.VSLemmas.dp_subset
       | |- _ => idtac
       end in
   tac).
Qed.

Lemma bv2z_program_vars_subset tmp idx1 idx2 p zp :
  (idx2, zp) = bv2z_program tmp idx1 p ->
  SSAVS.subset (vars_program p) (zSSA.vars_program zp).
Proof.
  elim: p tmp idx1 idx2 zp => /=.
  - move=> _ idx1 idx2 zp [] _ ->. done.
  - move=> i p IH tmp idx1 idx2 zip Hzip.
    move: (bv2z_program_cons Hzip) => {Hzip} [idx3 [zi [zp [Hzi [Hzp ->]]]]].
    rewrite zSSA.vars_program_concat. apply: zSSA.VSLemmas.union_subsets.
    + exact: (bv2z_instr_vars_subset Hzi).
    + exact: (IH _ _ _ _ Hzp).
Qed.

Lemma bv2z_ebexp_vars_subset f :
  SSAVS.subset (zSSA.vars_bexp (bv2z_ebexp (eqn_bexp f))) (vars_bexp f).
Proof.
  case: f => e r /=. apply: zSSA.VSLemmas.subset_union1 => /= {r}.
  elim: e => /=; intros; vars_to_bvssa; zSSA.VSLemmas.dp_subset.
Qed.

Ltac split_svar_notin_hyp :=
  match goal with
  | H : svar_notin _ (SSAVS.add _ _) |- _ =>
    let H1 := fresh in let H2 := fresh in
    move: (svar_notin_add1 H) (svar_notin_add2 H) => {H} H1 H2;
    split_svar_notin_hyp
  | H : svar_notin _ (SSAVS.union _ _) |- _ =>
    let H1 := fresh in let H2 := fresh in
    move: (svar_notin_union1 H) (svar_notin_union2 H) => {H} H1 H2;
    split_svar_notin_hyp
  | |- _ => idtac
  end.

Lemma bv2z_instr_well_formed tmp idx1 idx2 vs i zi :
  svar_notin tmp (vars_instr i) ->
  well_formed_instr vs i ->
  (idx2, zi) = bv2z_instr tmp idx1 i ->
  zSSA.well_formed_program vs zi.
Proof.
  case: i => /=; intros; split_svar_notin_hyp;
  (let rec tac :=
       match goal with
       | |- is_true true => done
       | H : ?p |- ?p => exact: H
       | H : is_true (?x != svar ?y) |- is_true ((?x, _) != ?y) =>
         apply: svar_ne; exact: H
       (* *)
       | H : (_, _) = (_, _) |- _ => case: H => _ -> /=; tac
       | |- is_true (_ && _) => apply/andP; split; tac
       | H : is_true (_ && _) |- _ =>
         let H1 := fresh in let H2 := fresh in
         move/andP: H => [H1 H2]; tac
       (* *)
       | |- is_true (SSAVS.subset _ _) => vars_to_bvssa; VSLemmas.dp_subset
       | |- _ => idtac
       end in
   tac).
Qed.

Lemma bv2z_program_well_formed tmp idx1 idx2 vs p zp :
  svar_notin tmp (vars_program p) ->
  well_formed_program vs p ->
  (idx2, zp) = bv2z_program tmp idx1 p ->
  zSSA.well_formed_program vs zp.
Proof.
  elim: p tmp idx1 idx2 vs zp => /=.
  - move=> tmp idx1 idx2 vs zp _ _ [] _ ->; done.
  - move=> hd tl IH tmp idx1 idx2 vs zip Hnotin /andP [Hwellhd Hwelltl] Hzip.
    move: (bv2z_program_cons Hzip) => {Hzip} [idx3 [zi [zp [Hzi [Hzp ->]]]]].
    rewrite zSSA.well_formed_program_concat.
    rewrite (bv2z_instr_well_formed (svar_notin_union1 Hnotin) Hwellhd Hzi) /=.
    apply: (@zSSA.well_formed_program_subset (SSAVS.union vs (lvs_instr hd))).
    + exact: (IH _ _ _ _ _ (svar_notin_union2 Hnotin) Hwelltl Hzp).
    + move: (bv2z_instr_lvs_subset Hzi) => Hsubset. zSSA.VSLemmas.dp_subset.
Qed.

Lemma bv2z_var_unchanged_instr tmp idx1 idx2 vs v i zi :
  svar_notin tmp vs ->
  ssa_vars_unchanged_instr vs i ->
  SSAVS.mem v vs ->
  (idx2, zi) = bv2z_instr tmp idx1 i ->
  zSSA.ssa_var_unchanged_program v zi.
Proof.
  case: i => /=; intros; split_svar_notin_hyp;
  (let rec tac :=
       match goal with
       | H : (_, _) = (_, _) |- _ => case: H => _ -> /=; tac
       | |- is_true (_ && _) => apply/andP; split; tac
       | |- is_true (zSSA.ssa_var_unchanged_instr _ _) =>
         rewrite /zSSA.ssa_var_unchanged_instr /=; tac
       | H1 : is_true (ssa_vars_unchanged_instr ?vs _),
         H2 : is_true (SSAVS.mem ?v ?vs) |- _ =>
         move: (ssa_unchanged_instr_mem H1 H2);
         rewrite /ssa_var_unchanged_instr /= => {H1} H1; tac
       | H : is_true (~~ SSAVS.mem _ (SSAVS.singleton _)) |- _ =>
         move: (VSLemmas.not_mem_singleton1 H) => {H} H; tac
       | H : is_true (~~ SSAVS.mem _ (SSAVS.add _ _)) |- _ =>
         let H1 := fresh in let H2 := fresh in
         move: (VSLemmas.not_mem_add1 H) => {H} [H1 H2]; tac
       | |- is_true (~~ SSAVS.mem _ (SSAVS.singleton _)) =>
         apply: zSSA.VSLemmas.not_mem_singleton2; tac
       | |- is_true (~~ SSAVS.mem _ (SSAVS.add _ _)) =>
         apply: zSSA.VSLemmas.not_mem_add2; split; tac
       | |- is_true true => done
       | H : ?p |- ?p => exact: H
       | H1 : svar_notin ?tmp ?vs, H2 : is_true (SSAVS.mem ?v ?vs) |-
         ~ (SSAVS.E.eq v (?tmp, ?i)) =>
         let H := fresh in
         move=> H; rewrite (eqP H) in H2; move: (H1 i); rewrite H2; done
       | |- _ => idtac
       end in
      tac).
Qed.

Lemma bv2z_var_unchanged_program tmp idx1 idx2 vs v p zp :
  svar_notin tmp vs ->
  ssa_vars_unchanged_program vs p ->
  SSAVS.mem v vs ->
  (idx2, zp) = bv2z_program tmp idx1 p ->
  zSSA.ssa_var_unchanged_program v zp.
Proof.
  elim: p idx1 idx2 vs v zp => /=.
  - move=> idx1 idx2 vs v zp _ _ _ [] _ ->.
    exact: zSSA.ssa_var_unchanged_program_empty.
  - move=> i p IH idx1 idx2 vs v zip Hnotin Hunch Hmem Hzip.
    move: (ssa_unchanged_program_cons1 Hunch) => {Hunch} [Hi Hp].
    move: (bv2z_program_cons Hzip) => {Hzip} [idx3 [zi [zp [Hzi [Hzp ->]]]]].
    rewrite zSSA.ssa_var_unchanged_program_concat2.
    + done.
    + exact: (bv2z_var_unchanged_instr Hnotin Hi Hmem Hzi).
    + apply: (IH _ _ _ _ _ Hnotin Hp Hmem Hzp).
Qed.

Lemma bv2z_vars_unchanged_instr tmp idx1 idx2 vs i zi :
  svar_notin tmp vs ->
  ssa_vars_unchanged_instr vs i ->
  (idx2, zi) = bv2z_instr tmp idx1 i ->
  zSSA.ssa_vars_unchanged_program vs zi.
Proof.
  case: i => /=; intros; split_svar_notin_hyp;
  (let rec tac :=
       match goal with
       | H : (_, _) = (_, _) |- _ => case: H => _ -> /=; tac
       | |- is_true (zSSA.ssa_vars_unchanged_program _ _) =>
         let x := fresh in let Hx := fresh in
         apply: zSSA.ssa_unchanged_program_global => x Hx /=; tac
       | H1 : is_true (ssa_vars_unchanged_instr ?vs _),
         H2 : is_true (SSAVS.mem ?x ?vs) |- _ =>
         let H := fresh in
         move: (ssa_unchanged_instr_local H1 H2) => {H1} H; tac
       | H : is_true (ssa_var_unchanged_instr _ _) |- _ =>
         rewrite /ssa_var_unchanged_instr /= in H; tac
       | |- context f [zSSA.ssa_var_unchanged_instr _ _] =>
         rewrite /zSSA.ssa_var_unchanged_instr /=; tac
       | H : is_true (~~ SSAVS.mem _ (SSAVS.singleton _)) |- _ =>
         move: (VSLemmas.not_mem_singleton1 H) => {H} H; tac
       | |- is_true (~~ SSAVS.mem _ (SSAVS.singleton _)) =>
         apply: zSSA.VSLemmas.not_mem_singleton2; tac
       | H : is_true (~~ SSAVS.mem _ (SSAVS.add _ _)) |- _ =>
         let H1 := fresh in let H2 := fresh in
         move: (VSLemmas.not_mem_add1 H) => {H} [H1 H2]; tac
       | |- is_true (~~ SSAVS.mem _ (SSAVS.add _ _)) =>
         apply: zSSA.VSLemmas.not_mem_add2; split; tac
       | |- is_true (_ && _) => apply/andP; split; tac
       | |- is_true true => done
       | H : ?p |- ?p => exact: H
       | H1 : svar_notin ?tmp ?vs,
         H2 : is_true (SSAVS.mem ?v ?vs) |-
         ~ (SSAVS.E.eq ?v (?tmp, ?idx)) =>
         let H := fresh in
         move=> H; move/negP: (H1 idx); apply;
         rewrite -(eqP H); exact: H2
       | |- _ => idtac
       end in
      tac).
Qed.

Lemma bv2z_vars_unchanged_program tmp idx1 idx2 vs p zp :
  svar_notin tmp vs ->
  ssa_vars_unchanged_program vs p ->
  (idx2, zp) = bv2z_program tmp idx1 p ->
  zSSA.ssa_vars_unchanged_program vs zp.
Proof.
  elim: p tmp idx1 idx2 vs zp => /=.
  - move=> tmp idx1 idx2 vs zp _ _ [] _ ->.
    exact: zSSA.ssa_unchanged_program_empty.
  - move=> i p IH tmp idx1 idx2 vs zip Hnotin Hun Hzip.
    move: (bv2z_program_cons Hzip) => {Hzip} [idx3 [zi [zp [Hzi [Hzp ->]]]]].
    move: (ssa_unchanged_program_cons1 Hun) => {Hun} [Hi Hp].
    apply: zSSA.ssa_unchanged_program_concat2.
    + exact: (bv2z_vars_unchanged_instr Hnotin Hi Hzi).
    + exact: (IH _ _ _ _ _ Hnotin Hp Hzp).
Qed.

Lemma bv2z_instr_idx_lt_unchanged tmp idx1 idx2 idx3 i zi :
  svar_notin tmp (vars_instr i) ->
  (idx2, zi) = bv2z_instr tmp idx1 i ->
  (idx3 < idx1)%num ->
  zSSA.ssa_var_unchanged_program (tmp, idx3) zi.
Proof.
  case: i => /=; intros; split_svar_notin_hyp;
  (let rec tac :=
       match goal with
       | H : (_, _) = (_, _) |- _ =>
         let Hidx := fresh H in case: H => Hidx -> /=; tac
       | |- context f [zSSA.ssa_var_unchanged_instr _ _] =>
         rewrite /zSSA.ssa_var_unchanged_instr /=; tac
       | |- is_true (_ && _) => apply/andP; split; tac
       | |- is_true (~~ SSAVS.mem _ (SSAVS.singleton _)) =>
         apply: zSSA.VSLemmas.not_mem_singleton2; tac
       | |- is_true (~~ SSAVS.mem _ (SSAVS.add _ _)) =>
         apply: zSSA.VSLemmas.not_mem_add2; split; tac
       | |- ~ (SSAVS.E.eq _ _) => apply/negP; tac
       | |- is_true true => done
       | H : is_true (?tmp != svar ?v) |- is_true ((?tmp, _) != ?v) =>
         apply: svar_ne; exact: H
       | H : (?i1 < ?i2)%num |- is_true ((?tmp, ?i1) != (?tmp, ?i2)) =>
         let Heq := fresh in
         apply: sidx_ne => /=; apply/negP => Heq; rewrite (eqP Heq) in H;
         exact: (N.lt_irrefl _ H)
       | |- _ => idtac
       end in
    tac).
Qed.

Lemma bv2z_instr_idx_ge_unchanged tmp idx1 idx2 idx3 i zi :
  svar_notin tmp (vars_instr i) ->
  (idx2, zi) = bv2z_instr tmp idx1 i ->
  (idx2 <= idx3)%num ->
  zSSA.ssa_var_unchanged_program (tmp, idx3) zi.
Proof.
  case: i => /=; intros; split_svar_notin_hyp;
  (let rec tac :=
       match goal with
       | H : (_, _) = (_, _) |- _ =>
         let Hidx := fresh H in case: H => Hidx -> /=; tac
       | |- context f [zSSA.ssa_var_unchanged_instr _ _] =>
         rewrite /zSSA.ssa_var_unchanged_instr /=; tac
       | |- is_true (_ && _) => apply/andP; split; tac
       | |- is_true (~~ SSAVS.mem _ (SSAVS.singleton _)) =>
         apply: zSSA.VSLemmas.not_mem_singleton2; tac
       | |- is_true (~~ SSAVS.mem _ (SSAVS.add _ _)) =>
         apply: zSSA.VSLemmas.not_mem_add2; split; tac
       | |- ~ (SSAVS.E.eq _ _) => apply/negP; tac
       | |- is_true true => done
       | H : is_true (?tmp != svar ?v) |- is_true ((?tmp, _) != ?v) =>
         apply: svar_ne; exact: H
       | H1 : (?i3 <= ?i1)%num, H2 : ?i3 = N.succ ?i2
         |- is_true ((?tmp, ?i1) != (?tmp, ?i2)) =>
         let Heq := fresh in let H := fresh in
         apply: sidx_ne => /=; apply/negP => Heq; rewrite (eqP Heq) in H1;
         rewrite H2 in H1;
         move: (N.le_lt_trans _ _ _ H1 (N.lt_succ_diag_r i2)) => H;
         exact: (N.lt_irrefl _ H)
       | |- _ => idtac
       end in
   tac).
Qed.

Lemma bv2z_program_idx_lt_unchanged tmp idx1 idx2 idx3 p zp :
  svar_notin tmp (vars_program p) ->
  (idx2, zp) = bv2z_program tmp idx1 p ->
  (idx3 < idx1)%num ->
  zSSA.ssa_var_unchanged_program (tmp, idx3) zp.
Proof.
  elim: p tmp idx1 idx2 idx3 zp => /=.
  - move=> tmp idx1 idx2 idx3 zp _ [] _ -> _ /=. done.
  - move=> i p IH tmp idx1 idx2 idx3 zip Hnotin Hzip Hidx31.
    move: (bv2z_program_cons Hzip) => {Hzip} [idx4 [zi [zp [Hzi [Hzp ->]]]]].
    apply: zSSA.ssa_var_unchanged_program_concat2.
    + exact: (bv2z_instr_idx_lt_unchanged (svar_notin_union1 Hnotin) Hzi Hidx31).
    + apply: (IH _ _ _ _ _ (svar_notin_union2 Hnotin) Hzp).
      exact: (N.lt_le_trans _ _ _ Hidx31 (bv2z_instr_idx_inc Hzi)).
Qed.

Lemma bv2z_program_idx_ge_unchanged tmp idx1 idx2 idx3 p zp :
  svar_notin tmp (vars_program p) ->
  (idx2, zp) = bv2z_program tmp idx1 p ->
  (idx2 <= idx3)%num ->
  zSSA.ssa_var_unchanged_program (tmp, idx3) zp.
Proof.
  elim: p tmp idx1 idx2 idx3 zp => /=.
  - move=> tmp idx1 idx2 idx3 zp _ [] _ -> _ /=. done.
  - move=> i p IH tmp idx1 idx2 idx3 zip Hnotin Hzip Hidx23.
    move: (bv2z_program_cons Hzip) => {Hzip} [idx4 [zi [zp [Hzi [Hzp ->]]]]].
    apply: zSSA.ssa_var_unchanged_program_concat2.
    + apply: (bv2z_instr_idx_ge_unchanged (svar_notin_union1 Hnotin) Hzi).
      exact: (N.le_trans _ _ _ (bv2z_program_idx_inc Hzp) Hidx23).
    + exact: (IH _ _ _ _ _ (svar_notin_union2 Hnotin) Hzp Hidx23).
Qed.

Lemma bv2z_succ_lvs_unchanged tmp idx1 idx2 idx3 i p zi zp :
  svar_notin tmp (vars_instr i) ->
  svar_notin tmp (vars_program p) ->
  ssa_vars_unchanged_program (lvs_instr i) p ->
  (idx2, zi) = bv2z_instr tmp idx1 i ->
  (idx3, zp) = bv2z_program tmp idx2 p ->
  zSSA.ssa_vars_unchanged_program (zSSA.lvs_program zi) zp.
Proof.
  move=> Hni Hnp Hun Hzi Hzp. apply: zSSA.ssa_unchanged_program_global => x Hmem.
  case: (bv2z_instr_lvs_case Hzi Hmem) => {Hmem}.
  - move=> Hmem. move: (svar_notin_subset (lvs_instr_subset i) Hni).
    move=> {Hni} Hni. exact: (bv2z_var_unchanged_program Hni Hun Hmem Hzp).
  - destruct x as [x idx] => /=. move=> [<- [Hle Hlt]].
    exact: (bv2z_program_idx_lt_unchanged Hnp Hzp Hlt).
Qed.

Lemma bv2z_instr_single_assignment tmp idx1 idx2 vs i zi :
  svar_notin tmp (vars_instr i) ->
  well_formed_instr vs i ->
  (idx2, zi) = bv2z_instr tmp idx1 i ->
  zSSA.ssa_single_assignment zi.
Proof.
  case: i => /=; intros; hyps_splitb; split_svar_notin_hyp;
  (let rec tac :=
       match goal with
       | H : (_, _) = (_, _) |- _ => case: H => _ -> /=; tac
       | |- is_true (_ && _) => splitb; tac
       | |- is_true (zSSA.ssa_vars_unchanged_program (SSAVS.add _ _) _) =>
         apply: zSSA.ssa_unchanged_program_add2; rewrite /=; split; tac
       | |- is_true (zSSA.ssa_vars_unchanged_program (SSAVS.singleton _) _) =>
         apply: zSSA.ssa_unchanged_program_singleton2; rewrite /=; tac
       | |- context f [zSSA.ssa_var_unchanged_instr _ _] =>
         rewrite /zSSA.ssa_var_unchanged_instr /=; tac
       | |- is_true (~~ SSAVS.mem _ (SSAVS.singleton _)) =>
         apply: zSSA.VSLemmas.not_mem_singleton2; apply/negP; tac
       | |- is_true true => done
       | |- is_true (zSSA.ssa_vars_unchanged_program _ [::]) =>
         exact: zSSA.ssa_unchanged_program_empty
       | H : is_true (?x != ?y) |- is_true (?y != ?x) =>
         rewrite eq_sym; exact: H
       | H : is_true (?tmp != svar ?v) |- is_true((?tmp, _) != ?v) =>
         apply: svar_ne; exact: H
       | |- _ => idtac
       end in
   tac).
Qed.

Lemma bv2z_program_single_assignment tmp idx1 idx2 vs p zp :
  svar_notin tmp (vars_program p) ->
  well_formed_program vs p ->
  ssa_single_assignment p ->
  (idx2, zp) = bv2z_program tmp idx1 p ->
  zSSA.ssa_single_assignment zp.
Proof.
  elim: p tmp idx1 idx2 vs zp => /=.
  - move=> tmp idx1 idx2 _ zp _ _ _ [] _ ->; done.
  - move=> i p IH tmp idx1 idx2 vs zip Hnotin /andP [Hwelli Hwellp]
             /andP [Hi Hp] Hzip.
    move: (bv2z_program_cons Hzip) => {Hzip} [idx3 [zi [zp [Hzi [Hzp ->]]]]].
    apply: zSSA.ssa_single_assignment_concat2.
    + exact: (bv2z_instr_single_assignment (svar_notin_union1 Hnotin) Hwelli Hzi).
    + exact: (IH _ _ _ _ _ (svar_notin_union2 Hnotin) Hwellp Hp Hzp).
    + exact: (bv2z_succ_lvs_unchanged (svar_notin_union1 Hnotin)
                                      (svar_notin_union2 Hnotin)
                                      Hi Hzi Hzp).
Qed.

Lemma bv2z_program_well_formed_ssa tmp idx1 idx2 vs p zp :
  svar_notin tmp vs ->
  svar_notin tmp (vars_program p) ->
  well_formed_ssa_program vs p ->
  (idx2, zp) = bv2z_program tmp idx1 p ->
  zSSA.well_formed_ssa_program vs zp.
Proof.
  move=> Hnvs Hnp /andP [/andP [Hwf Hun] Hssa] Hzp.
  apply/andP; split; first (apply/andP; split).
  - exact: (bv2z_program_well_formed Hnp Hwf Hzp).
  - exact: (bv2z_vars_unchanged_program Hnvs Hun Hzp).
  - exact: (bv2z_program_single_assignment Hnp Hwf Hssa Hzp).
Qed.

Lemma bv2z_spec_rng_well_formed vs sp :
  well_formed_spec vs sp ->
  well_formed_spec vs (bv2z_spec_rng sp).
Proof.
  destruct sp as [f p g]. move=> /andP /= [/andP [Hf Hp] Hg].
  rewrite /well_formed_spec /=. rewrite /vars_bexp /=.
  rewrite 2!VSLemmas.union_emptyl Hp.
  rewrite (VSLemmas.subset_trans (vars_rbexp_subset f) Hf).
  rewrite (VSLemmas.subset_trans (vars_rbexp_subset g) Hg).
  done.
Qed.

Lemma bv2z_spec_eqn_well_formed vs sp :
  well_formed_spec vs sp ->
  zSSA.well_formed_spec vs (bv2z_spec_eqn vs sp).
Proof.
  destruct sp as [f p g]. move=> /andP /= [/andP [Hf Hp] Hg].
  rewrite /bv2z_spec_eqn. set tmp := new_svar_spec_eqn vs ({{f}} p {{g}})%bvssa.
  set idx1 := initial_tmp_sidx.
  sethave temp (bv2z_program tmp idx1 (sprog ({{f}} p {{g}})%bvssa)).
  destruct temp as [idx2 zp]. move=> Hzp /=.
  apply/andP => /=; split; first (apply/andP; split).
  - apply: (@zSSA.VSLemmas.subset_trans _ (vars_bexp f)).
    + apply: bv2z_ebexp_vars_subset.
    + assumption.
  - exact: (bv2z_program_well_formed (svar_notin_sprog vs ({{f}} p {{g}})%bvssa)
                                     Hp Hzp).
  - apply: (zSSA.VSLemmas.subset_trans (bv2z_ebexp_vars_subset g)).
    apply: (@zSSA.VSLemmas.subset_trans _ (SSAVS.union vs (vars_program p))).
    + exact: Hg.
    + move: (bv2z_program_vars_subset Hzp) => /= Hsubset.
      zSSA.VSLemmas.dp_subset.
Qed.

Theorem bv2z_spec_eqn_well_formed_ssa vs sp :
  well_formed_ssa_spec vs sp ->
  zSSA.well_formed_ssa_spec vs (bv2z_spec_eqn vs sp).
Proof.
  destruct sp as [f p g]. move=> /andP /= [/andP [Hwf Hun] Hssa].
  move: (bv2z_spec_eqn_well_formed Hwf).
  rewrite /bv2z_spec_eqn. set tmp := new_svar_spec_eqn vs ({{f}} p {{g}})%bvssa.
  set idx1 := initial_tmp_sidx.
  sethave temp (bv2z_program tmp idx1 (sprog ({{f}} p {{g}})%bvssa)).
  destruct temp as [idx2 zp]. move=> Hzp /= Hzwf.
  apply/andP => /=; split; first (apply/andP; split).
  - exact: Hzwf.
  - apply: (bv2z_vars_unchanged_program _ Hun Hzp).
    exact: (svar_notin_inputs vs).
  - move: Hwf => /andP [/andP [_ Hwfp] _].
    apply: (bv2z_program_single_assignment _ Hwfp Hssa Hzp).
    exact: (svar_notin_sprog vs).
Qed.

(** Soundness *)

(* vs: inputs *)
Theorem bv2z_spec_sound vs sp :
  bv2z_spec_safe sp ->
  valid_rspec (bv2z_spec_rng sp) ->
  zSSA.valid_spec (bv2z_spec_eqn vs sp) ->
  valid_spec sp.
Proof.
  destruct sp as [f p g] => /=. rewrite /bv2z_spec_eqn /=.
  sethave tmp (new_svar_spec_eqn vs ({{f}} p {{g}})%bvssa).
  set idx1 := initial_tmp_sidx.
  sethave temp (bv2z_program tmp idx1 (sprog ({{f}} p {{g}})%bvssa)).
  destruct temp as [idx2 zp]. move=> Hzp Htmp Hsafe Hrng Heqn bs1 bs2 /= Hbf Hbp.
  move: (Hrng bs1 bs2 (eval_bexp_rng Hbf) Hbp) => {Hrng} /= Hrng.
  set zs1 := bv2z_state bs1. set zs2 := zSSA.eval_program zs1 zp.
  move: (@bvz_eq_eqm tmp _ _ (bv2z_state_eq bs1)) => Heqm.
  move: (svar_notin_spre vs ({{f}}p{{g}})%bvssa); rewrite -Htmp => Hnf.
  move: (svar_notin_sprog vs ({{f}}p{{g}})%bvssa); rewrite -Htmp => Hnp.
  move: (svar_notin_spost vs ({{f}}p{{g}})%bvssa); rewrite -Htmp => Hng.
  move: (bvz_eqm_eval_ebexp1 Heqm (svar_notin_union1 Hnf)
                             (eval_bexp_eqn Hbf)) => Heqnf.
  move: (Heqn zs1 zs2 Heqnf (Logic.eq_refl zs2)) => {Heqn} /= Heqn.
  apply: (eval_bexp_combine_eqm _ Hng Hrng Heqn). rewrite -Hbp.
  exact: (bvz_eqm_eval_program Heqm Hnp (Hsafe _ (eval_bexp_rng Hbf)) Hzp).
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 cvterm.
Require Export substitution3.

Require Export continuity_axiom2_v2.
Require Export continuity_type_aux_v2.

Require Export cequiv_tacs.
Require Export subst_tacs.

Require Export continuity_per.

Require Export list. (* why? *)

(*
Definition of_type_int {o} lib (t : @NTerm o) :=
  {z : Z & reduces_to lib t (mk_integer z)}.

Definition of_type_int_to_val {o} lib (f : @NTerm o) :=
  forall a,
    of_type_int lib a
    -> {v : NTerm
        & reduces_to lib (mk_apply f a) v
        # isvalue_like v}.

Definition of_type_int_to_val_TO_int {o} lib (F : @NTerm o) :=
  forall f,
    of_type_int_to_val lib f
    -> {z : Z & reduces_to lib (mk_apply F f) (mk_integer z)}.
*)

Definition value_like_type {o} lib (T : @CTerm o) :=
  forall t, member lib t T -> isvaluec_like t.

Definition agree_upto_b_c {o} lib (b f g : @CTerm o) :=
  forall (t : CTerm),
    member lib (absolute_value_c t) (mkc_natk b) (* take t's absolute value *)
    -> equality lib (mkc_apply f t) (mkc_apply g t) mkc_int.

Definition continuous2 {o} lib (F : @CTerm o) :=
  forall f,
    member lib f (mkc_fun mkc_int mkc_int)
    -> {b : CTerm
        & member lib b mkc_tnat
        # forall g : CTerm,
            member lib g (mkc_fun mkc_int mkc_int)
            -> agree_upto_b_c lib b f g
            -> equality lib (mkc_apply F f) (mkc_apply F g) mkc_int}.

Definition agree_upto_b_type_c {o} (b f g : @CTerm o) : CTerm :=
  mkc_isect
    (mkc_set
       mkc_int
       nvarx
       (mkcv_member
          [nvarx]
          (absolute_value_cv [nvarx] (mkc_var nvarx))
          (mkcv_natk [nvarx] (mk_cv [nvarx] b))))
    nvarx
    (mkcv_equality
       [nvarx]
       (mkcv_apply [nvarx] (mk_cv [nvarx] f) (mkc_var nvarx))
       (mkcv_apply [nvarx] (mk_cv [nvarx] f) (mkc_var nvarx))
       (mkcv_int [nvarx])).

Definition agree_upto_b_type_cv_v2 {o} vs (b f g T : @CVTerm o vs) : CVTerm vs :=
  mkcv_isect
    vs
    (mkcv_set
       vs
       (mkcv_int vs)
       nvarx
       (mkcv_member
          (nvarx :: vs)
          (absolute_value_cv (nvarx :: vs) (mk_cv_app_r vs [nvarx] (mkc_var nvarx)))
          (mkcv_natk (nvarx :: vs) (mk_cv_app_l [nvarx] vs b))))
    nvarx
    (mkcv_equality
       (nvarx :: vs)
       (mkcv_apply (nvarx :: vs) (mk_cv_app_l [nvarx] vs f) (mk_cv_app_r vs [nvarx] (mkc_var nvarx)))
       (mkcv_apply (nvarx :: vs) (mk_cv_app_l [nvarx] vs g) (mk_cv_app_r vs [nvarx] (mkc_var nvarx)))
       (mk_cv_app_l [nvarx] vs T)).

Definition continuous_type_c_v2 {o} (F f T : @CTerm o) :=
  mkc_product
    mkc_tnat
    nvarb
    (mkcv_isect
       [nvarb]
       (mkcv_fun [nvarb] (mkcv_int [nvarb]) (mk_cv [nvarb] T))
       nvarg
       (mkcv_ufun
          [nvarg, nvarb]
          (agree_upto_b_type_cv_v2
             [nvarg,nvarb]
             (mk_cv_app_l [nvarg] [nvarb] (mkc_var nvarb))
             (mk_cv [nvarg,nvarb] f)
             (mk_cv_app_r [nvarb] [nvarg] (mkc_var nvarg))
             (mk_cv [nvarg,nvarb] T))
          (mkcv_equality
             [nvarg,nvarb]
             (mkcv_apply [nvarg,nvarb] (mk_cv [nvarg,nvarb] F) (mk_cv [nvarg,nvarb] f))
             (mkcv_apply [nvarg,nvarb] (mk_cv [nvarg,nvarb] F) (mk_cv_app_r [nvarb] [nvarg] (mkc_var nvarg)))
             (mkcv_int [nvarg,nvarb])))).

Definition continuous_type_aux_v2 {o} vb vg vi (F f T : @NTerm o) :=
  mk_product
    mk_tnat
    vb
    (mk_isect
       (mk_fun mk_int T)
       vg
       (mk_ufun
          (agree_upto_b_type_v2
             vi
             (mk_var vb)
             f
             (mk_var vg)
             T)
          (mk_equality
             (mk_apply F f)
             (mk_apply F (mk_var vg))
             mk_int))).

Definition continuous_type_v2 {o} (F f T : @NTerm o) :=
  match newvars3 [F,f,T] with
    | (vb,vg,vi) => continuous_type_aux_v2 vb vg vi F f T
  end.

Lemma lsubstc_continuous_type_v2 {o} :
  forall (F f T : @NTerm o)
         (w : wf_term (continuous_type_v2 F f T))
         (s : CSub)
         (c : cover_vars (continuous_type_v2 F f T) s),
    {wF : wf_term F
     & {wf : wf_term f
     & {wT : wf_term T
     & {cF : cover_vars F s
     & {cf : cover_vars f s
     & {cT : cover_vars T s
     & alphaeqc
         (lsubstc (continuous_type_v2 F f T) w s c)
         (continuous_type_c_v2
            (lsubstc F wF s cF)
            (lsubstc f wf s cf)
            (lsubstc T wT s cT)) }}}}}}.
Proof.
  introv.

  assert (wf_term F # wf_term f # wf_term T) as wf.
  { unfold continuous_type_v2 in w.
    remember (newvars3 [F,f]) as p.
    destruct p as [p vi].
    destruct p as [vb vg].
    apply newvars3_prop in Heqp.
    allsimpl; allrw app_nil_r; allrw in_app_iff; allrw not_over_or; repnd.
    apply wf_product_iff in w; repnd.
    apply wf_isect_iff in w; repnd.
    apply wf_ufun in w; repnd.
    apply wf_fun in w1; repnd.
    apply wf_equality_iff in w; repnd.
    apply wf_apply_iff in w4; repnd; auto. }

  destruct wf as [wF wf].
  destruct wf as [wf wT].
  exists wF wf wT.

  assert (cover_vars F s # cover_vars f s # cover_vars T s) as cov.
  { unfold continuous_type_v2 in c.
    remember (newvars3 [F,f, T]) as p.
    destruct p as [p vi].
    destruct p as [vb vg].
    apply newvars3_prop in Heqp.
    allsimpl; allrw app_nil_r; allrw in_app_iff; allrw not_over_or; repnd.
    apply cover_vars_product in c; repnd.
    apply cover_vars_upto_isect in c; repnd.
    apply cover_vars_upto_ufun in c; repnd.
    apply cover_vars_upto_equality in c; repnd.
    apply cover_vars_upto_apply in c3; repnd.
    allrw <- @csub_filter_app_r; allsimpl.
    apply cover_vars_upto_csub_filter_disjoint in c5;
      [|rw eqvars_prop; simpl; sp; split; complete sp
       |allrw disjoint_cons_r; sp].
    apply cover_vars_upto_csub_filter_disjoint in c3;
      [|rw eqvars_prop; simpl; sp; split; sp
       |allrw disjoint_cons_r; sp].
    apply cover_vars_upto_csub_filter_disjoint in c1;
      [|rw eqvars_prop; simpl; sp; split; sp
       |allsimpl; rw disjoint_singleton_r; rw app_nil_r;
        rw in_remove_nvars; simpl; sp].
    allrw @cover_vars_fun; repnd.
    sp. }

  destruct cov as [cF cf].
  destruct cf as [cf cT].
  exists cF cf cT.

  unfold alphaeqc; simpl.
  unfold csubst, lsubst.
  allrw <- @sub_free_vars_is_flat_map_free_vars_range.
  allrw @sub_free_vars_csub2sub; boolvar; tcsp;
  try (complete (destruct n; tcsp)).

  simpl.
  allrw @sub_filter_nil_r.
  allrw <- @sub_filter_app_r; simpl.
  allrw @sub_find_sub_filter; simpl; tcsp.
  repeat gen_newvar.
  fold_terms.

  allrw @lsubst_aux_sub_filter;
    try (complete (repeat get_newvar_prop; allsimpl;
                   allrw remove_nvars_nil_l; allrw app_nil_r;
                   allrw in_app_iff; allrw not_over_or; repnd;
                   allrw disjoint_cons_r; sp)).

  fold_terms.
  unfold mk_natk.
  fold (@mk_natk_aux o n1 (mk_var n)).
  allfold (@mk_tnat o).
  allfold (@int2int o).
  pose proof (newvar_not_in_free_vars (@mk_var o nvarb)) as nve; simpl in nve.
  autodimp nve hyp;[intro k; repndors; tcsp; ginv|rw nve; clear nve].
  fold (agree_upto_b_type_v2 n1 (mk_var n) (lsubst_aux f (csub2sub s)) (mk_var n0) (lsubst_aux T (csub2sub s))).
  fold (agree_upto_b_type_v2 nvarx (mk_var nvarb) (lsubst_aux f (csub2sub s)) (mk_var nvarg) (lsubst_aux T (csub2sub s))).
  fold (continuous_type_aux_aux_v2 n n0 n1 n5 (lsubst_aux F (csub2sub s)) (lsubst_aux f (csub2sub s)) (lsubst_aux T (csub2sub s))).
  unfold mk_ufun.
  gen_newvar.
  fold (continuous_type_aux_aux nvarb nvarg nvarx n6 (lsubst_aux F (csub2sub s)) (lsubst_aux f (csub2sub s))).
  clear dependent n2.
  clear dependent n3.
  clear dependent n4.

  apply alphaeq_eq.
  repeat get_newvar_prop.
  allsimpl; allrw remove_nvars_nil_l; allrw app_nil_r.
  allrw in_app_iff; allsimpl; allrw not_over_or; repnd; GC.
  apply alphaeq_continuous_type_aux_aux; tcsp;
  try (complete (apply cover_vars_iff_closed_lsubst_aux; auto));
  try (complete (intro k; inversion k)).
Qed.

Tactic Notation "one_lift_lsubst_cont" constr(T) ident(name) tactic(tac) :=
  match T with
    | context [lsubstc (continuous_type ?a ?b) ?w ?s ?c] =>
      let w1 := fresh "w1" in
      let w2 := fresh "w2" in
      let c1 := fresh "c1" in
      let c2 := fresh "c2" in
      pose proof (lsubstc_continuous_type a b w s c) as name;
        destruct name as [w1 name];
        destruct name as [w2 name];
        destruct name as [c1 name];
        destruct name as [c2 name];
        clear_irr; tac
  end.

Ltac one_lift_lsubst_cont_concl :=
  match goal with
    | [ |- ?T ] =>
      let name := fresh "eq" in
      one_lift_lsubst_cont
        T
        name
        (first [ rewrite name
               | progress (apply alphaeqc_sym in name; rwal_c name)
               ]);
        clear name
  end.

Ltac one_lift_lsubst_cont_hyp H :=
  let T := type of H in
  let name := fresh "eq" in
  one_lift_lsubst_cont
    T name
    (first [ rewrite name in H
           | progress (rwal_h name H)
           ]); clear name.

Ltac lift_lsubsts_cont :=
  repeat (match goal with
            | [ H : context [lsubstc _ _ _ _ ] |- _ ] => one_lift_lsubst_cont_hyp H
            | [ |- context [lsubstc _ _ _ _ ] ] => one_lift_lsubst_cont_concl
          end).

(*
*** Local Variables:
*** coq-load-path: ("." "./close/")
*** End:
*)


Set Warnings "-notation-overridden,-parsing".
From Coq Require Export String.
From LF Require Import ProofObjects.
Parameter MISSING: Type.

Module Check.

Ltac check_type A B :=
match type of A with
| context[MISSING] => idtac "Missing:" A
| ?T => first [unify T B; idtac "Type: ok" | idtac "Type: wrong - should be (" B ")"]
end.

Ltac print_manual_grade A :=
match eval compute in A with
| Some (pair ?S ?C) =>
idtac "Score:"  S;
match eval compute in C with
| ""%string => idtac "Comment: None"
| _ => idtac "Comment:" C
end
| None =>
idtac "Score: Ungraded";
idtac "Comment: None"
end.

End Check.

From LF Require Import ProofObjects.
Import Check.

Goal True.

idtac "-------------------  eight_is_even  --------------------".
idtac " ".

idtac "#> ev_8".
idtac "Possible points: 1".
check_type @ev_8 ((ev 8)).
idtac "Assumptions:".
Abort.
Print Assumptions ev_8.
Goal True.
idtac " ".

idtac "#> ev_8'".
idtac "Possible points: 1".
check_type @ev_8' ((ev 8)).
idtac "Assumptions:".
Abort.
Print Assumptions ev_8'.
Goal True.
idtac " ".

idtac "-------------------  equality__leibniz_equality  --------------------".
idtac " ".

idtac "#> equality__leibniz_equality".
idtac "Possible points: 2".
check_type @equality__leibniz_equality (
(forall (X : Type) (x y : X), x = y -> forall P : X -> Prop, P x -> P y)).
idtac "Assumptions:".
Abort.
Print Assumptions equality__leibniz_equality.
Goal True.
idtac " ".

idtac " ".

idtac "Max points - standard: 4".
idtac "Max points - advanced: 4".
Abort.


Require Import Coq.Lists.List.
Import ListNotations.
Require Import Tactics.
Require Import Sequence.
Require Import Syntax.
Require Import Subst.
Require Import SimpSub.
Require Import Promote.
Require Import Hygiene.
Require Import Rules.
Require Import DerivedRules.
Require Defs.
Require Import Obligations.
Require Import Morphism.
Require Import DefsEquiv.
Require Import Equivalence.
Require Import Dots.

Require Import ValidationUtil.

Hint Rewrite def_istp : prepare.

Lemma istpForm_valid : istpForm_obligation.
Proof.
prepare.
intros G a ext0 H.
apply tr_eqtype_formation; auto.
Qed.

Lemma istpEq_valid : istpEq_obligation.
Proof.
prepare.
intros G a b ext0 H.
apply tr_eqtype_formation; auto.
Qed.

Lemma istpFormUniv_valid : istpFormUniv_obligation.
Proof.
prepare.
intros G a i ext0 H.
apply tr_eqtype_formation_univ; auto.
Qed.

Lemma istpEqUniv_valid : istpEqUniv_obligation.
Proof.
prepare.
intros G a b i ext0 H.
apply tr_eqtype_formation_univ; auto.
Qed.

Lemma istpIntro_valid : istpIntro_obligation.
Proof.
prepare.
intros G a ext0 H.
auto.
Qed.

Lemma istpElim_valid : istpElim_obligation.
Proof.
prepare.
intros G a p ext0 H.
auto.
Qed.

Lemma istpExt_valid : istpExt_obligation.
Proof.
unfoldtop.
intros G a p q ext1 ext0 Hp Hq.
unfold Defs.dof, Defs.triv in * |- *.
rewrite -> def_of in * |- *.
rewrite -> def_istp in * |- *.
rewrite -> def_eq in * |- *.
apply tr_equal_intro.
apply (tr_transitivity _ _ triv).
  {
  apply tr_eqtype_eta; auto.
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }

  {
  apply tr_symmetry.
  apply tr_eqtype_eta; auto.
  apply tr_equal_elim.
  eapply tr_equal_eta2; eauto.
  }
Qed.

Lemma istpLeft_valid : istpLeft_obligation.
Proof.
prepare.
intros G1 G2 a b m H.
unfold Defs.triv in H.
apply tr_eqtype_eta_hyp; auto.
Qed.

Lemma inhabitedForm_valid : inhabitedForm_obligation.
Proof.
prepare.
intros G a ext0 H.
eapply tr_inhabitation_formation; eauto.
Qed.


From Hammer Require Import Hammer.

From Coq Require Import omega.Omega.
From Coq Require Import Arith.Arith.
From LF Require Import Imp Maps.

Open Scope imp_scope.
Fixpoint ceval_step1 (st : state) (c : com) : state :=
match c with
| SKIP =>
st
| l ::= a1 =>
(l !-> aeval st a1 ; st)
| c1 ;; c2 =>
let st' := ceval_step1 st c1 in
ceval_step1 st' c2
| TEST b THEN c1 ELSE c2 FI =>
if (beval st b)
then ceval_step1 st c1
else ceval_step1 st c2
| WHILE b1 DO c1 END =>
st
end.
Close Scope imp_scope.

Open Scope imp_scope.
Fixpoint ceval_step2 (st : state) (c : com) (i : nat) : state :=
match i with
| O => empty_st
| S i' =>
match c with
| SKIP =>
st
| l ::= a1 =>
(l !-> aeval st a1 ; st)
| c1 ;; c2 =>
let st' := ceval_step2 st c1 i' in
ceval_step2 st' c2 i'
| TEST b THEN c1 ELSE c2 FI =>
if (beval st b)
then ceval_step2 st c1 i'
else ceval_step2 st c2 i'
| WHILE b1 DO c1 END =>
if (beval st b1)
then let st' := ceval_step2 st c1 i' in
ceval_step2 st' c i'
else st
end
end.
Close Scope imp_scope.

Open Scope imp_scope.
Fixpoint ceval_step3 (st : state) (c : com) (i : nat)
: option state :=
match i with
| O => None
| S i' =>
match c with
| SKIP =>
Some st
| l ::= a1 =>
Some (l !-> aeval st a1 ; st)
| c1 ;; c2 =>
match (ceval_step3 st c1 i') with
| Some st' => ceval_step3 st' c2 i'
| None => None
end
| TEST b THEN c1 ELSE c2 FI =>
if (beval st b)
then ceval_step3 st c1 i'
else ceval_step3 st c2 i'
| WHILE b1 DO c1 END =>
if (beval st b1)
then match (ceval_step3 st c1 i') with
| Some st' => ceval_step3 st' c i'
| None => None
end
else Some st
end
end.
Close Scope imp_scope.

Notation "'LETOPT' x <== e1 'IN' e2"
:= (match e1 with
| Some x => e2
| None => None
end)
(right associativity, at level 60).

Open Scope imp_scope.
Fixpoint ceval_step (st : state) (c : com) (i : nat)
: option state :=
match i with
| O => None
| S i' =>
match c with
| SKIP =>
Some st
| l ::= a1 =>
Some (l !-> aeval st a1 ; st)
| c1 ;; c2 =>
LETOPT st' <== ceval_step st c1 i' IN
ceval_step st' c2 i'
| TEST b THEN c1 ELSE c2 FI =>
if (beval st b)
then ceval_step st c1 i'
else ceval_step st c2 i'
| WHILE b1 DO c1 END =>
if (beval st b1)
then LETOPT st' <== ceval_step st c1 i' IN
ceval_step st' c i'
else Some st
end
end.
Close Scope imp_scope.

Definition test_ceval (st:state) (c:com) :=
match ceval_step st c 500 with
| None    => None
| Some st => Some (st X, st Y, st Z)
end.

Definition pup_to_n : com
. Admitted.

Theorem ceval_step__ceval: forall c st st',
(exists i, ceval_step st c i = Some st') ->
st =[ c ]=> st'.
Proof. hammer_hook "ImpCEvalFun" "ImpCEvalFun.ceval_step__ceval".
intros c st st' H.
inversion H as [i E].
clear H.
generalize dependent st'.
generalize dependent st.
generalize dependent c.
induction i as [| i' ].

-
intros c st st' H. discriminate H.

-
intros c st st' H.
destruct c;
simpl in H; inversion H; subst; clear H.
+  apply E_Skip.
+  apply E_Ass. reflexivity.

+
destruct (ceval_step st c1 i') eqn:Heqr1.
*
apply E_Seq with s.
apply IHi'. rewrite Heqr1. reflexivity.
apply IHi'. simpl in H1. assumption.
*
discriminate H1.

+
destruct (beval st b) eqn:Heqr.
*
apply E_IfTrue. rewrite Heqr. reflexivity.
apply IHi'. assumption.
*
apply E_IfFalse. rewrite Heqr. reflexivity.
apply IHi'. assumption.

+  destruct (beval st b) eqn :Heqr.
*
destruct (ceval_step st c i') eqn:Heqr1.
{
apply E_WhileTrue with s. rewrite Heqr.
reflexivity.
apply IHi'. rewrite Heqr1. reflexivity.
apply IHi'. simpl in H1. assumption. }
{  discriminate H1. }
*
injection H1. intros H2. rewrite <- H2.
apply E_WhileFalse. apply Heqr. Qed.

Definition manual_grade_for_ceval_step__ceval_inf : option (nat*string) := None.

Theorem ceval_step_more: forall i1 i2 st st' c,
i1 <= i2 ->
ceval_step st c i1 = Some st' ->
ceval_step st c i2 = Some st'.
Proof. hammer_hook "ImpCEvalFun" "ImpCEvalFun.ceval_step_more".
induction i1 as [|i1']; intros i2 st st' c Hle Hceval.
-
simpl in Hceval. discriminate Hceval.
-
destruct i2 as [|i2']. inversion Hle.
assert (Hle': i1' <= i2') by omega.
destruct c.
+
simpl in Hceval. inversion Hceval.
reflexivity.
+
simpl in Hceval. inversion Hceval.
reflexivity.
+
simpl in Hceval. simpl.
destruct (ceval_step st c1 i1') eqn:Heqst1'o.
*
apply (IHi1' i2') in Heqst1'o; try assumption.
rewrite Heqst1'o. simpl. simpl in Hceval.
apply (IHi1' i2') in Hceval; try assumption.
*
discriminate Hceval.

+
simpl in Hceval. simpl.
destruct (beval st b); apply (IHi1' i2') in Hceval;
assumption.

+
simpl in Hceval. simpl.
destruct (beval st b); try assumption.
destruct (ceval_step st c i1') eqn: Heqst1'o.
*
apply (IHi1' i2') in Heqst1'o; try assumption.
rewrite -> Heqst1'o. simpl. simpl in Hceval.
apply (IHi1' i2') in Hceval; try assumption.
*
simpl in Hceval. discriminate Hceval.  Qed.

Theorem ceval__ceval_step: forall c st st',
st =[ c ]=> st' ->
exists i, ceval_step st c i = Some st'.
Proof. hammer_hook "ImpCEvalFun" "ImpCEvalFun.ceval__ceval_step".
intros c st st' Hce.
induction Hce.
Admitted.

Theorem ceval_and_ceval_step_coincide: forall c st st',
st =[ c ]=> st'
<-> exists i, ceval_step st c i = Some st'.
Proof. hammer_hook "ImpCEvalFun" "ImpCEvalFun.ceval_and_ceval_step_coincide".
intros c st st'.
split. apply ceval__ceval_step. apply ceval_step__ceval.
Qed.

Theorem ceval_deterministic' : forall c st st1 st2,
st =[ c ]=> st1 ->
st =[ c ]=> st2 ->
st1 = st2.
Proof. hammer_hook "ImpCEvalFun" "ImpCEvalFun.ceval_deterministic'".
intros c st st1 st2 He1 He2.
apply ceval__ceval_step in He1.
apply ceval__ceval_step in He2.
inversion He1 as [i1 E1].
inversion He2 as [i2 E2].
apply ceval_step_more with (i2 := i1 + i2) in E1.
apply ceval_step_more with (i2 := i1 + i2) in E2.
rewrite E1 in E2. inversion E2. reflexivity.
omega. omega.  Qed.


(** * Propositions with a distinguished point representing true *)
(** This allows for something between [bool] and [Prop], where we can
    computationally reduce things like [True /\ True], but can still
    express equality of types. *)
Require Import Coq.Setoids.Setoid.
Require Import Crypto.Util.Notations.

Delimit Scope pointed_prop_scope with pointed_prop.
Delimit Scope option_pointed_prop_scope with option_pointed_prop.
Inductive pointed_Prop := trivial | inject (_ : Prop).
Bind Scope pointed_prop_scope with pointed_Prop.

Definition to_prop (x : pointed_Prop) : Prop
  := match x with
     | trivial => True
     | inject p => p
     end.

Coercion option_pointed_Prop_of_bool (x : bool) : option pointed_Prop
  := if x then Some trivial else None.
Coercion option_pointed_Prop_of_pointed_Prop (x : pointed_Prop) : option pointed_Prop
  := Some x.

Definition prop_of_option (x : option pointed_Prop) : Prop
  := match x with
     | Some p => to_prop p
     | None => False
     end.

Definition and_pointed_Prop (x y : pointed_Prop) : pointed_Prop
  := match x, y with
     | trivial, y => y
     | x, trivial => x
     | inject p, inject q => inject (p /\ q)
     end.

Definition or_pointed_Prop (x y : pointed_Prop) : pointed_Prop
  := match x, y with
     | trivial, _ => trivial
     | _, trivial => trivial
     | inject p, inject q => inject (p \/ q)
     end.

Definition impl_pointed_Prop (x y : pointed_Prop) : pointed_Prop
  := match x, y with
     | trivial, y => y
     | _, trivial => trivial
     | inject p, inject q => inject (p -> q)
     end.

Definition not_option_pointed_Prop (x : option pointed_Prop) : option pointed_Prop
  := match x with
     | Some trivial => None
     | None => Some trivial
     | Some (inject p) => Some (inject (~p))
     end.
Arguments not_option_pointed_Prop _%option_pointed_prop.

Definition and_option_pointed_Prop (x y : option pointed_Prop) : option pointed_Prop
  := match x, y with
     | Some x, Some y => Some (and_pointed_Prop x y)
     | _, _ => None
     end.
Arguments and_option_pointed_Prop (_ _)%option_pointed_prop.

Definition or_option_pointed_Prop (x y : option pointed_Prop) : option pointed_Prop
  := match x, y with
     | Some x, Some y => Some (or_pointed_Prop x y)
     | Some x, None => Some x
     | None, Some y => Some y
     | None, None => None
     end.
Arguments or_option_pointed_Prop (_ _)%option_pointed_prop.

Definition impl_option_pointed_Prop (x y : option pointed_Prop) : option pointed_Prop
  := match x, y with
     | None, _ => Some trivial
     | Some x, Some y => Some (impl_pointed_Prop x y)
     | Some p, None => not_option_pointed_Prop p
     end.
Arguments impl_option_pointed_Prop (_ _)%option_pointed_prop.

Infix "/\" := and_pointed_Prop : pointed_prop_scope.
Infix "\/" := or_pointed_Prop : pointed_prop_scope.
Infix "->" := impl_pointed_Prop : pointed_prop_scope.
Infix "/\" := and_option_pointed_Prop : option_pointed_prop_scope.
Infix "\/" := or_option_pointed_Prop : option_pointed_prop_scope.
Infix "->" := impl_option_pointed_Prop : option_pointed_prop_scope.
Notation "~ P" := (not_option_pointed_Prop P) : option_pointed_prop_scope.

Ltac inversion_pointed_Prop_step :=
  match goal with
  | [ H : inject _ = inject _ |- _ ] => progress (inversion H; clear H)
  end.
Ltac inversion_pointed_Prop := repeat inversion_pointed_Prop_step.

Create HintDb push_prop_of_option discriminated.
Create HintDb push_to_prop discriminated.
Hint Extern 1 => progress autorewrite with push_prop_of_option in * : push_prop_of_option.
Hint Extern 1 => progress autorewrite with push_to_prop in * : push_to_prop.

Lemma to_prop_and P Q : to_prop (P /\ Q)%pointed_prop
                        <-> (to_prop P /\ to_prop Q).
Proof. destruct P, Q; simpl; tauto. Qed.
Hint Rewrite to_prop_and : push_to_prop.

Lemma to_prop_or P Q : to_prop (P \/ Q)%pointed_prop
                       <-> (to_prop P \/ to_prop Q).
Proof. destruct P, Q; simpl; tauto. Qed.
Hint Rewrite to_prop_or : push_to_prop.

Lemma to_prop_impl P Q : to_prop (impl_pointed_Prop P Q)%pointed_prop
                         <-> (to_prop P -> to_prop Q).
Proof. destruct P, Q; simpl; tauto. Qed.
Hint Rewrite to_prop_impl : push_to_prop.

Lemma prop_of_option_and P Q : prop_of_option (P /\ Q)%option_pointed_prop
                               <-> (prop_of_option P /\ prop_of_option Q).
Proof. destruct P, Q; simpl; autorewrite with push_to_prop; tauto. Qed.
Hint Rewrite prop_of_option_and : push_prop_of_option.

Lemma prop_of_option_or P Q : prop_of_option (P \/ Q)%option_pointed_prop
                               <-> (prop_of_option P \/ prop_of_option Q).
Proof. destruct P, Q; simpl; autorewrite with push_to_prop; tauto. Qed.
Hint Rewrite prop_of_option_or : push_prop_of_option.

Lemma prop_of_option_impl P Q : prop_of_option (impl_option_pointed_Prop P Q)%option_pointed_prop
                               <-> (prop_of_option P -> prop_of_option Q).
Proof. destruct P as [ [|P] |], Q as [ [|Q] |]; simpl; tauto. Qed.
Hint Rewrite prop_of_option_impl : push_prop_of_option.

Lemma prop_of_option_not P : prop_of_option (~P)%option_pointed_prop
                               <-> (~prop_of_option P).
Proof. destruct P as [ [|] | ]; simpl; tauto. Qed.
Hint Rewrite prop_of_option_not : push_prop_of_option.


(** * Autosubst Header for Scoped Syntax
    Our development utilises well-scoped de Bruijn syntax. This means that the de Bruijn indices are taken from finite types. As a consequence, any kind of substitution or environment used in conjunction with well-scoped syntax takes the form of a mapping from some finite type _I^n_. In particular, _renamings_ are mappings _I^n -> I^m_. Here we develop the theory of how these parts interact.

Version: December 11, 2019.
*)
From ASUB Require Import core.
Require Import Setoid Morphisms Relation_Definitions.

(* TODO remove to make more predictable *)
Set Implicit Arguments.
Unset Strict Implicit.

(** ** Primitives of the Sigma Calculus
    We implement the finite type with _n_ elements, _I^n_, as the _n_-fold iteration of the Option Type. _I^0_ is implemented as the empty type.
*)

Fixpoint fin (n : nat) : Type :=
  match n with
  | 0 => False
  | S m => option (fin m)
  end.

(** Renamings and Injective Renamings
     _Renamings_ are mappings between finite types.
*)
Definition ren (m n : nat) : Type := fin m -> fin n.

Definition id {X} := @Datatypes.id X.

Definition idren {k: nat} : ren k k := @Datatypes.id (fin k).

(** We give a special name, to the newest element in a non-empty finite type, as it usually corresponds to a freshly bound variable. *)
Definition var_zero {n : nat} : fin (S n) := None.

Definition null {T} (i : fin 0) : T := match i with end.

Definition shift {n : nat} : ren n (S n) :=
  Some.

(** Extension of Finite Mappings
    Assume we are given a mapping _f_ from _I^n_ to some type _X_, then we can _extend_ this mapping with a new value from _x : X_ to a mapping from _I^n+1_ to _X_. We denote this operation by _x . f_ and define it as follows:
*)
Definition scons {X : Type} {n : nat} (x : X) (f : fin n -> X) (m : fin (S n)) : X :=
  match m with
  | None => x
  | Some i => f i
  end.

Hint Opaque scons : rewrite.

(** ** Type Class Instances for Notation *)

(** *** Type classes for renamings. *)

Class Ren1 (X1  : Type) (Y Z : Type) :=
  ren1 : X1 -> Y -> Z.

Class Ren2 (X1 X2 : Type) (Y Z : Type) :=
  ren2 : X1 -> X2 -> Y -> Z.

Class Ren3 (X1 X2 X3 : Type) (Y Z : Type) :=
  ren3 : X1 -> X2 -> X3 -> Y -> Z.

Class Ren4 (X1 X2 X3 X4 : Type) (Y Z : Type) :=
  ren4 : X1 -> X2 -> X3 -> X4 -> Y -> Z.

Class Ren5 (X1 X2 X3 X4 X5 : Type) (Y Z : Type) :=
  ren5 : X1 -> X2 -> X3 -> X4 -> X5 -> Y -> Z.

Module RenNotations.
  Notation "s ⟨ xi1 ⟩" := (ren1  xi1 s) (at level 7, left associativity, format "s  ⟨ xi1 ⟩") : subst_scope.

  Notation "s ⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ⟩") : subst_scope.

  Notation "s ⟨ xi1 ; xi2 ; xi3 ⟩" := (ren3 xi1 xi2 xi3 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ⟩") : subst_scope.

  Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩" := (ren4  xi1 xi2 xi3 xi4 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ⟩") : subst_scope.

  Notation "s ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩" := (ren5  xi1 xi2 xi3 xi4 xi5 s) (at level 7, left associativity, format "s  ⟨ xi1 ; xi2 ; xi3 ; xi4 ; xi5 ⟩") : subst_scope.

  Notation "⟨ xi ⟩" := (ren1 xi) (at level 1, left associativity, format "⟨ xi ⟩") : fscope.

  Notation "⟨ xi1 ; xi2 ⟩" := (ren2 xi1 xi2) (at level 1, left associativity, format "⟨ xi1 ; xi2 ⟩") : fscope.
End RenNotations.

(** *** Type Classes for Substiution *)

Class Subst1 (X1 : Type) (Y Z: Type) :=
  subst1 : X1 -> Y -> Z.

Class Subst2 (X1 X2 : Type) (Y Z: Type) :=
  subst2 : X1 -> X2 -> Y  -> Z.

Class Subst3 (X1 X2 X3 : Type) (Y Z: Type) :=
  subst3 : X1 -> X2 -> X3 ->  Y  -> Z.

Class Subst4 (X1 X2 X3 X4: Type) (Y Z: Type) :=
  subst4 : X1 -> X2 -> X3 -> X4 -> Y  -> Z.

Class Subst5 (X1 X2 X3 X4 X5 : Type) (Y Z: Type) :=
  subst5 : X1 -> X2 -> X3 -> X4 -> X5  -> Y  -> Z.

Module SubstNotations.
  Notation "s [ sigma ]" := (subst1 sigma s) (at level 7, left associativity, format "s '/' [ sigma ]") : subst_scope.

  Notation "s [ sigma ; tau ]" := (subst2 sigma tau s) (at level 7, left associativity, format "s '/' [ sigma ; '/'  tau ]") : subst_scope.
End SubstNotations.

(** ** Type Class for Variables *)
Class Var X Y :=
  ids : X -> Y.

(** ** Proofs for substitution primitives *)

(** Forward Function Composition
    Substitutions represented as functions are ubiquitious in this development and we often have to compose them, without talking about their pointwise behaviour.
    That is, we are interested in the forward compostion of functions, _f o g_, for which we introduce a convenient notation, "f >> g". The direction of the arrow serves as a reminder of the _forward_ nature of this composition, that is first apply _f_, then _g_. *)

Arguments funcomp {X Y Z} (g)%fscope (f)%fscope.

Module CombineNotations.
  Notation "f >> g" := (funcomp g f) (at level 50) : fscope.

  Notation "s .: sigma" := (scons s sigma) (at level 55, sigma at next level, right associativity) : subst_scope.

  #[ global ]
  Open Scope fscope.
  #[ global ]
  Open Scope subst_scope.
End CombineNotations.

Import CombineNotations.

(** Generic lifting operation for renamings *)
Definition up_ren {m n} (xi : ren m n) : ren (S m) (S n) :=
  var_zero .: xi >> shift.

(** Generic proof that lifting of renamings composes. *)
Lemma up_ren_ren k l m (xi: ren k l) (zeta : ren l m) (rho: ren k m) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (up_ren xi >> up_ren zeta) x = up_ren rho x.
Proof.
  intros [x|].
  - cbn. unfold funcomp. now rewrite <- E.
  - reflexivity.
Qed.

Arguments up_ren_ren {k l m} xi zeta rho E.

Lemma fin_eta {X} (f g : fin 0 -> X) :
  pointwise_relation _ eq f g.
Proof. intros []. Qed.

(** Eta laws *)
Lemma scons_eta' {T} {n : nat} (f : fin (S n) -> T) :
  pointwise_relation _ eq (f var_zero .: (funcomp f shift)) f.
Proof. intros x. destruct x; reflexivity. Qed.

Lemma scons_eta_id' {n : nat} :
  pointwise_relation (fin (S n)) eq (var_zero .: shift) id.
Proof. intros x. destruct x; reflexivity. Qed.

Lemma scons_comp' {T:Type} {U} {m} (s: T) (sigma: fin m -> T) (tau: T -> U) :
  pointwise_relation _ eq (funcomp tau (s .: sigma)) ((tau s) .: (funcomp tau sigma)).
Proof. intros x. destruct x; reflexivity. Qed.

(* Lemma scons_tail'_pointwise {X} {n} (s : X) (f : fin n -> X) : *)
(*   pointwise_relation _ eq (funcomp (scons s f) shift) f. *)
(* Proof. *)
(*   reflexivity. *)
(* Qed. *)

(* Lemma scons_tail' {X} {n} (s : X) (f : fin n -> X) x : *)
(*   (scons s f (shift x)) = f x. *)
(* Proof. *)
(*   reflexivity. *)
(* Qed. *)

(* Morphism for Setoid Rewriting. The only morphism that can be defined statically. *)
Instance scons_morphism {X: Type} {n:nat} :
  Proper (eq ==> pointwise_relation _ eq ==> pointwise_relation _ eq) (@scons X n).
Proof.
  intros t t' -> sigma tau H.
  intros [x|].
  cbn. apply H.
  reflexivity.
Qed.

Instance scons_morphism2 {X: Type} {n: nat} :
  Proper (eq ==> pointwise_relation _ eq ==> eq ==> eq) (@scons X n).
Proof.
  intros ? t -> sigma tau H ? x ->.
  destruct x as [x|].
  cbn. apply H.
  reflexivity.
Qed.

(** ** Variadic Substitution Primitives *)

Fixpoint shift_p (p : nat) {n} : ren n (p + n) :=
  fun n => match p with
        | 0 => n
        | S p => Some (shift_p p n)
        end.

Fixpoint scons_p {X: Type} {m : nat} : forall {n} (f : fin m -> X) (g : fin n -> X), fin (m + n)  -> X.
Proof.
  destruct m.
  - intros n f g. exact g.
  - intros n f g. cbn. apply scons.
    + exact (f var_zero).
    + apply scons_p.
      * intros z. exact (f (Some z)).
      * exact g.
Defined.

Hint Opaque scons_p : rewrite.

Instance scons_p_morphism {X: Type} {m n:nat} :
  Proper (pointwise_relation _ eq ==> pointwise_relation _ eq ==> pointwise_relation _ eq) (@scons_p X m n).
Proof.
  intros sigma sigma' Hsigma tau tau' Htau.
  intros x.
  induction m.
  - cbn. apply Htau.
  - cbn. change (fin (S m + n)) with (fin (S (m + n))) in x.
    destruct x as [x|].
    + cbn. apply IHm.
      intros ?. apply Hsigma.
    + cbn. apply Hsigma.
Qed.

Instance scons_p_morphism2 {X: Type} {m n:nat} :
  Proper (pointwise_relation _ eq ==> pointwise_relation _ eq ==> eq ==> eq) (@scons_p X m n).
Proof.
  intros sigma sigma' Hsigma tau tau' Htau ? x ->.
  induction m.
  - cbn. apply Htau.
  - cbn. change (fin (S m + n)) with (fin (S (m + n))) in x.
    destruct x as [x|].
    + cbn. apply IHm.
      intros ?. apply Hsigma.
    + cbn. apply Hsigma.
Qed.

Definition zero_p {m : nat} {n} : fin m -> fin (m + n).
Proof.
  induction m.
  - intros [].
  - intros [x|].
    + exact (shift_p 1 (IHm x)).
    + exact var_zero.
Defined.

Lemma scons_p_head' {X} {m n} (f : fin m -> X) (g : fin n -> X) z:
  (scons_p  f g) (zero_p  z) = f z.
Proof.
 induction m.
  - inversion z.
  - destruct z.
    + simpl. simpl. now rewrite IHm.
    + reflexivity.
Qed.

Lemma scons_p_head_pointwise {X} {m n} (f : fin m -> X) (g : fin n -> X) :
  pointwise_relation _ eq (funcomp (scons_p f g) zero_p) f.
Proof.
  intros z.
  unfold funcomp.
  induction m.
  - inversion z.
  - destruct z.
    + simpl. now rewrite IHm.
    + reflexivity.
Qed.

Lemma scons_p_tail' X  m n (f : fin m -> X) (g : fin n -> X) z :
  scons_p  f g (shift_p m z) = g z.
Proof. induction m; cbn; eauto. Qed.

Lemma scons_p_tail_pointwise X  m n (f : fin m -> X) (g : fin n -> X) :
  pointwise_relation _ eq (funcomp (scons_p f g) (shift_p m)) g.
Proof. intros z. induction m; cbn; eauto. Qed.

Lemma destruct_fin {m n} (x : fin (m + n)):
  (exists x', x = zero_p  x') \/ exists x', x = shift_p m x'.
Proof.
  induction m; simpl in *.
  - right. eauto.
  - destruct x as [x|].
    + destruct (IHm x) as [[x' ->] |[x' ->]].
      * left. now exists (Some x').
      * right. eauto.
    + left. exists None. eauto.
Qed.

Lemma scons_p_comp' X Y m n (f : fin m -> X) (g : fin n -> X) (h : X -> Y) :
  pointwise_relation _ eq (funcomp h (scons_p f g)) (scons_p (f >> h) (g >> h)).
Proof.
  intros x.
  destruct (destruct_fin x) as [[x' ->]|[x' ->]].
  (* TODO better way to solve this? *)
  - revert x'.
    apply pointwise_forall.
    change (fun x => (scons_p f g >> h) (zero_p x)) with (zero_p >> scons_p f g >> h).
    now setoid_rewrite scons_p_head_pointwise.
  - revert x'.
    apply pointwise_forall.
    change (fun x => (scons_p f g >> h) (shift_p m x)) with (shift_p m >> scons_p f g >> h).
    change (fun x => scons_p (f >> h) (g >> h) (shift_p m x)) with (shift_p m >> scons_p (f >> h) (g >> h)).
    now rewrite !scons_p_tail_pointwise.
Qed.

Lemma scons_p_congr {X} {m n} (f f' : fin m -> X) (g g': fin n -> X) z:
  (forall x, f x = f' x) -> (forall x, g x = g' x) -> scons_p f g z = scons_p f' g' z.
Proof. intros H1 H2. induction m; eauto. cbn. destruct z; eauto. Qed.

(** Generic n-ary lifting operation. *)
Definition upRen_p p { m : nat } { n : nat } (xi : (fin) (m) -> (fin) (n)) : fin (p + m) -> fin (p + n)  :=
   scons_p  (zero_p ) (xi >> shift_p _).

Arguments upRen_p p {m n} xi.

(** Generic proof for composition of n-ary lifting. *)
Lemma up_ren_ren_p p k l m (xi: ren k l) (zeta : ren l m) (rho: ren k m) (E: forall x, (xi >> zeta) x = rho x) :
  forall x, (upRen_p p xi >> upRen_p p zeta) x = upRen_p p rho x.
Proof.
  intros x. destruct (destruct_fin x) as [[? ->]|[? ->]].
  - unfold upRen_p. unfold funcomp. now repeat rewrite scons_p_head'.
  - unfold upRen_p. unfold funcomp. repeat rewrite scons_p_tail'.
    now rewrite <- E.
Qed.

Arguments zero_p m {n}.
Arguments scons_p  {X} m {n} f g.

Lemma scons_p_eta {X} {m n} {f : fin m -> X}
      {g : fin n -> X} (h: fin (m + n) -> X) {z: fin (m + n)}:
  (forall x, g x = h (shift_p m x)) -> (forall x, f x = h (zero_p m x)) -> scons_p m f g z = h z.
Proof.
  intros H1 H2. destruct (destruct_fin z) as [[? ->] |[? ->]].
  - rewrite scons_p_head'. eauto.
  - rewrite scons_p_tail'. eauto.
Qed.

Arguments scons_p_eta {X} {m n} {f g} h {z}.
Arguments scons_p_congr {X} {m n} {f f'} {g g'} {z}.

(** ** Notations for Scoped Syntax *)

Module ScopedNotations.
  Include RenNotations.
  Include SubstNotations.
  Include CombineNotations.

(* Notation "s , sigma" := (scons s sigma) (at level 60, format "s ,  sigma", right associativity) : subst_scope. *)

  Notation "s '..'" := (scons s ids) (at level 1, format "s ..") : subst_scope.

  Notation "↑" := (shift) : subst_scope.

  #[ global ]
  Open Scope fscope.
  #[ global ]
  Open Scope subst_scope.
End ScopedNotations.

(** ** Tactics for Scoped Syntax *)

Tactic Notation "auto_case" tactic(t) :=  (match goal with
                                           | [|- forall (i : fin 0), _] => intros []; t
                                           | [|- forall (i : fin (S (S (S (S _))))), _] => intros [[[[|]|]|]|]; t
                                           | [|- forall (i : fin (S (S (S _)))), _] => intros [[[|]|]|]; t
                                           | [|- forall (i : fin (S (S _))), _] => intros [[?|]|]; t
                                           | [|- forall (i : fin (S _)), _] =>  intros [?|]; t
                                           end).

Hint Rewrite @scons_p_head' @scons_p_tail' : FunctorInstances.

(** Generic fsimpl tactic: simplifies the above primitives in a goal. *)
Ltac fsimpl :=
  repeat match goal with
         | [|- context[id >> ?f]] => change (id >> f) with f (* AsimplCompIdL *)
         | [|- context[?f >> id]] => change (f >> id) with f (* AsimplCompIdR *)
         | [|- context [id ?s]] => change (id s) with s
         | [|- context[(?f >> ?g) >> ?h]] => change ((f >> g) >> h) with (f >> (g >> h)) (* AsimplComp *)
         (* | [|- zero_p >> scons_p ?f ?g] => rewrite scons_p_head *)
         | [|- context[(?s .: ?sigma) var_zero]] => change ((s.:sigma) var_zero) with s
         | [|- context[(?s .: ?sigma) (shift ?m)]] => change ((s.:sigma) (shift m)) with (sigma m)
           (* first [progress setoid_rewrite scons_tail' | progress setoid_rewrite scons_tail'_pointwise ] *)
         | [|- context[idren >> ?f]] => change (idren >> f) with f
         | [|- context[?f >> idren]] => change (f >> idren) with f
         | [|- context[?f >> (?x .: ?g)]] => change (f >> (x .: g)) with g (* f should evaluate to shift *)
         | [|- context[?x2 .: (funcomp ?f shift)]] => change (scons x2 (funcomp f shift)) with (scons (f var_zero) (funcomp f shift)); setoid_rewrite (@scons_eta' _ _ f); eta_reduce
         | [|- context[?f var_zero .: ?g]] => change (scons (f var_zero) g) with (scons (f var_zero) (funcomp f shift)); setoid_rewrite scons_eta'; eta_reduce
         | [|- _ =  ?h (?f ?s)] => change (h (f s)) with ((f >> h) s)
         | [|-  ?h (?f ?s) = _] => change (h (f s)) with ((f >> h) s)
         | [|- context[funcomp _ (scons _ _)]] => setoid_rewrite scons_comp'; eta_reduce
         | [|- context[funcomp _ (scons_p _ _ _)]] => setoid_rewrite scons_p_comp'; eta_reduce
         | [|- context[scons (@var_zero _) shift]] => setoid_rewrite scons_eta_id'; eta_reduce
         (* | _ => progress autorewrite with FunctorInstances *)
         | [|- context[funcomp (scons_p _ _ _) (zero_p _)]] =>
           first [progress setoid_rewrite scons_p_head_pointwise | progress setoid_rewrite scons_p_head' ]
         | [|- context[scons_p _ _ _ (zero_p _ _)]] => setoid_rewrite scons_p_head'
         | [|- context[funcomp (scons_p _ _ _) (shift_p _)]] =>
           first [progress setoid_rewrite scons_p_tail_pointwise | progress setoid_rewrite scons_p_tail' ]
         | [|- context[scons_p _ _ _ (shift_p _ _)]] => setoid_rewrite scons_p_tail'
         | _ => first [progress minimize | progress cbn [shift scons scons_p] ]
         end.

(** Generic fsimpl tactic: simplifies the above primitives in the context *)
(* Ltac fsimplc := *)
(*   repeat match goal with *)
(*          | [H: context[id >> ?f] |- _] => change (id >> f) with f in H(* AsimplCompIdL *) *)
(*          | [H: context[?f >> id]|- _] => change (f >> id) with f in H(* AsimplCompIdR *) *)
(*          | [H: context [id ?s]|- _] => change (id s) with s in H *)
(*          (* | [H: context[comp ?f ?g]|- _] => change (comp f g) with (g >> f) in H (* AsimplCompIdL *) *) *)
(*          | [H: context[(?f >> ?g) >> ?h]|- _] => *)
(*            change ((f >> g) >> h) with (f >> (g >> h)) in H (* AsimplComp *) *)
(*          | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H *)
(*          | [H: context[(?s.:?sigma) var_zero]|- _] => change ((s.:sigma) var_zero) with s in H *)
(*          | [H: context[(?s.:?sigma) (shift ?m)]|- _] => change ((s.:sigma) (shift m)) with (sigma m) in H *)
(*                                                                                |[H : context[ _ =  ?h (?f ?s)]|- _] => change (h (f s)) with ((f >> h) s) in H *)
(*          (* |[H: context[?h (?f ?s) = _]|- _] => change (h (f s)) with ((f >> h) s) in H *) *)
(*          | [H: context[idren >> ?f]|- _] => change (idren >> f) with f in H *)
(*          | [H: context[?f >> idren]|- _] => change (f >> idren) with f in H *)
(*          | [H: context[?f >> (?x .: ?g)]|- _] => *)
(*            change (f >> (x .: g)) with g in H *)
(*          (* | [H: context[?x2 .: shift >> ?f]|- _] => *) *)
(*          (*   change x2 with (f var_zero) in H; rewrite (@scons_eta _ _ f) in H *) *)
(*          (* | [H: context[?f var_zero .: ?g]|- _] => *) *)
(*            (* change g with (shift >> f) in H; rewrite scons_eta in H *) *)
(*          (* | _ => first [progress (rewrite scons_comp in * ) | progress (rewrite scons_eta_id in * ) | progress (autorewrite with FunctorInstances in * )] *) *)
(*          end. *)

(** Simplification in both the goal and the context *)
(* Tactic Notation "fsimpl" "in" "*" := *)
(*   fsimpl; fsimplc. *)


(************************************************************************)
(*         *   The Coq Proof Assistant / The Coq Development Team       *)
(*  v      *   INRIA, CNRS and contributors - Copyright 1999-2018       *)
(* <O___,, *       (see CREDITS file for the list of authors)           *)
(*   \VV/  **************************************************************)
(*    //   *    This file is distributed under the terms of the         *)
(*         *     GNU Lesser General Public License Version 2.1          *)
(*         *     (see LICENSE file for the text of the license)         *)
(************************************************************************)

(************************************************************************)

Lemma essai : forall x : nat, x = x.
 refine
 ((fun x0 : nat => match x0 with
                   | O => _
                   | S p => _
                   end)).

Restart.

 refine
 (fun x0 : nat => match x0 as n return (n = n) with
                  | O => _
                  | S p => _
                  end). (* OK *)

Restart.

 refine
 (fun x0 : nat => match x0 as n return (n = n) with
                  | O => _
                  | S p => _
                  end). (* OK *)

Restart.

(**
Refine [x0:nat]Cases x0 of O => ? | (S p) => ? end. (* cannot be executed *)
**)

Abort.

(************************************************************************)

Lemma T : nat.

 refine (S _).

Abort.

(************************************************************************)

Lemma essai2 : forall x : nat, x = x.

refine (fix f (x : nat) : x = x := _).

Restart.

 refine
 (fix f (x : nat) : x = x :=
    match x as n return (n = n :>nat) with
    | O => _
    | S p => _
    end).

Restart.

 refine
 (fix f (x : nat) : x = x :=
    match x as n return (n = n) with
    | O => _
    | S p => _
    end).

Restart.

 refine
 (fix f (x : nat) : x = x :=
    match x as n return (n = n :>nat) with
    | O => _
    | S p => f_equal S _
    end).

Restart.

 refine
 (fix f (x : nat) : x = x :=
    match x as n return (n = n :>nat) with
    | O => _
    | S p => f_equal S _
    end).

Abort.

(************************************************************************)
Parameter f : nat * nat -> nat -> nat.

Lemma essai : nat.

 refine (f _ ((fun x : nat => _:nat) 0)).

Restart.

 refine (f _ 0).

Abort.

(************************************************************************)

Parameter P : nat -> Prop.

Lemma essai : {x : nat | x = 1}.

 refine (exist _ 1 _).  (* ECHEC *)

Restart.

(* mais si on contraint par le but alors ca marche : *)
(* Remarque : on peut toujours faire ça *)
 refine (exist _ 1 _:{x : nat | x = 1}).

Restart.

 refine (exist (fun x : nat => x = 1) 1 _).

Abort.

(************************************************************************)

Lemma essai : forall n : nat, {x : nat | x = S n}.

 refine
 (fun n : nat =>
  match n return {x : nat | x = S n} with
  | O => _
  | S p => _
  end).

Restart.

 refine
   (fun n : nat => match n with
                  | O => _
                  | S p => _
                  end).

Restart.

 refine
 (fun n : nat =>
  match n return {x : nat | x = S n} with
  | O => _
  | S p => _
  end).

Restart.

 refine
 (fix f (n : nat) : {x : nat | x = S n} :=
    match n return {x : nat | x = S n} with
    | O => _
    | S p => _
    end).

Restart.

 refine
 (fix f (n : nat) : {x : nat | x = S n} :=
    match n return {x : nat | x = S n} with
    | O => _
    | S p => _
    end).

exists 1. trivial.
elim (f p).
 refine
 (fun (x : nat) (h : x = S p) => exist (fun x : nat => x = S (S p)) (S x) _).
 rewrite h. auto.
Qed.

(* Quelques essais de recurrence bien fondée *)

Require Import Wf.
Require Import Wf_nat.

Lemma essai_wf : nat -> nat.

 refine
 (fun x : nat =>
  well_founded_induction _ (fun _ : nat => nat -> nat)
    (fun (phi0 : nat) (w : forall phi : nat, phi < phi0 -> nat -> nat) =>
     w x _) x x).
exact lt_wf.

Abort.

Require Import Compare_dec.
Require Import Lt.

Lemma fibo : nat -> nat.
 refine
 (well_founded_induction _ (fun _ : nat => nat)
    (fun (x0 : nat) (fib : forall x : nat, x < x0 -> nat) =>
     match zerop x0 with
     | left _ => 1
     | right h1 =>
         match zerop (pred x0) with
         | left _ => 1
         | right h2 => fib (pred x0) _ + fib (pred (pred x0)) _
         end
     end)).
exact lt_wf.
auto with arith.
apply lt_trans with (m := pred x0); auto with arith.
Qed.