From Coq Require Import Arith ZArith OrderedType.
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat eqtype seq.
From nbits Require Import NBits.
From ssrlib Require Import Types SsrOrder Var Nats ZAriths Tactics.
From BitBlasting Require Import Typ TypEnv State QFBV CNF BBExport.
From BBCache Require Import CompCache.

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

(* ==== bit-blasting with complete cache information ==== *)

Definition bit_blast_eunop (op : QFBV.eunop) :=
  match op with
  | QFBV.Unot => bit_blast_not
  | QFBV.Uneg => bit_blast_neg
  | QFBV.Uextr i j => (fun g ls => bit_blast_extract g i j ls)
  | QFBV.Uhigh n => (fun g ls => bit_blast_high g n ls)
  | QFBV.Ulow n => (fun g ls => bit_blast_low g n ls)
  | QFBV.Uzext n => bit_blast_zeroextend n
  | QFBV.Usext n => bit_blast_signextend n
  | QFBV.Urepeat n => (fun g ls => bit_blast_repeat g n ls)
  | QFBV.Urotl n => (fun g ls => bit_blast_rotateleft g n ls)
  | QFBV.Urotr n => (fun g ls => bit_blast_rotateright g n ls)
  end .

Definition bit_blast_ebinop (op : QFBV.ebinop) :=
  match op with
  | QFBV.Band => bit_blast_and
  | QFBV.Bor => bit_blast_or
  | QFBV.Bxor => bit_blast_xor
  | QFBV.Badd => bit_blast_add
  | QFBV.Bsub => bit_blast_sub
  | QFBV.Bmul => bit_blast_mul
  | QFBV.Bdiv => bit_blast_udiv'
  | QFBV.Bmod => bit_blast_umod
  | QFBV.Bsdiv => bit_blast_sdiv
  | QFBV.Bsrem => bit_blast_srem
  | QFBV.Bsmod => bit_blast_smod
  | QFBV.Bshl => bit_blast_shl
  | QFBV.Blshr => bit_blast_lshr
  | QFBV.Bashr => bit_blast_ashr
  | QFBV.Bconcat => bit_blast_concat
  | QFBV.Bcomp => bit_blast_comp
  end .

Definition bit_blast_bbinop (op : QFBV.bbinop) :=
  match op with
  | QFBV.Beq => bit_blast_eq
  | QFBV.Bult => bit_blast_ult
  | QFBV.Bule => bit_blast_ule
  | QFBV.Bugt => bit_blast_ugt
  | QFBV.Buge => bit_blast_uge
  | QFBV.Bslt => bit_blast_slt
  | QFBV.Bsle => bit_blast_sle
  | QFBV.Bsgt => bit_blast_sgt
  | QFBV.Bsge => bit_blast_sge
  | QFBV.Buaddo => bit_blast_uaddo
  | QFBV.Busubo => bit_blast_usubo
  | QFBV.Bumulo => bit_blast_umulo
  | QFBV.Bsaddo => bit_blast_saddo
  | QFBV.Bssubo => bit_blast_ssubo
  | QFBV.Bsmulo => bit_blast_smulo
  end .

Fixpoint bit_blast_exp_ccache te m cc g e :
  vm * compcache * generator * cnf * word :=
  (* = bit_blast_exp_nocet = *)
  let bit_blast_exp_nocet te m cc g e :
        vm * compcache * generator * cnf * word * cnf :=
      match e with
      | QFBV.Evar v =>
        match find_het e cc with
        | Some (cs, ls) => (m, cc, g, cs, ls, cs)
        | None => match SSAVM.find v m with
                  | None => let '(g', cs, rs) := bit_blast_var te g v in
                            (SSAVM.add v rs m, add_het e cs rs cc, g', cs, rs, cs)
                  | Some rs => (m, add_het e [::] rs cc, g, [::], rs, [::])
                  end
        end
      | QFBV.Econst bs =>
        match find_het e cc with
        | Some (cs, ls) => (m, cc, g, cs, ls, cs)
        | None => let '(g', cs, rs) := bit_blast_const g bs in
                  (m, add_het e cs rs cc, g', cs, rs, cs)
        end
      | QFBV.Eunop op e1 =>
        let '(m1, cc1, g1, cs1, ls1) := bit_blast_exp_ccache te m cc g e1 in
        match find_het e cc1 with
        | Some (csop, lsop) => (m1, cc1, g1, catrev cs1 csop, lsop, csop)
        | None =>
          let '(gop, csop, lsop) := bit_blast_eunop op g1 ls1 in
          (m1, add_het e csop lsop cc1, gop, catrev cs1 csop, lsop, csop)
        end
      | QFBV.Ebinop op e1 e2 =>
        let '(m1, cc1, g1, cs1, ls1) := bit_blast_exp_ccache te m cc g e1 in
        let '(m2, cc2, g2, cs2, ls2) := bit_blast_exp_ccache te m1 cc1 g1 e2 in
        match find_het e cc2 with
        | Some (csop, lsop) => (m2, cc2, g2, catrev cs1 (catrev cs2 csop), lsop, csop)
        | None =>
          let '(gop, csop, lsop) := bit_blast_ebinop op g2 ls1 ls2 in
          (m2, add_het e csop lsop cc2, gop, catrev cs1 (catrev cs2 csop), lsop, csop)
        end
      | QFBV.Eite c e1 e2 =>
        let '(mc, ccc, gc, csc, lc) := bit_blast_bexp_ccache te m cc g c in
        let '(m1, cc1, g1, cs1, ls1) := bit_blast_exp_ccache te mc ccc gc e1 in
        let '(m2, cc2, g2, cs2, ls2) := bit_blast_exp_ccache te m1 cc1 g1 e2 in
        match find_het e cc2 with
        | Some (csop, lsop) =>
          (m2, cc2, g2, catrev csc (catrev cs1 (catrev cs2 csop)), lsop, csop)
        | None =>
          let '(gop, csop, lsop) := bit_blast_ite g2 lc ls1 ls2 in
          (m2, add_het e csop lsop cc2, gop,
           catrev csc (catrev cs1 (catrev cs2 csop)), lsop, csop)
        end
      end
  (* = = *)
  in
  match CompCache.find_cet e cc with
  | Some (cs, ls) => (m, cc, g, [::], ls)
  | None => let '(m', cc', g', cs, lrs, csop) := bit_blast_exp_nocet te m cc g e in
            (m', CompCache.add_cet e csop lrs cc', g', cs, lrs)
  end
with
bit_blast_bexp_ccache te m cc g e : vm * compcache * generator * cnf * literal :=
  (* = bit_blast_bexp_nocbt = *)
  let bit_blast_bexp_nocbt te m cc g e :
        vm * compcache * generator * cnf * literal * cnf :=
      match e with
      | QFBV.Bfalse =>
        match find_hbt e cc with
        | Some (cs, l) => (m, cc, g, cs, l, cs)
        | None => (m, add_hbt e [::] lit_ff cc, g, [::], lit_ff, [::])
        end
      | QFBV.Btrue =>
        match find_hbt e cc with
        | Some (cs, l) => (m, cc, g, cs, l, cs)
        | None => (m, add_hbt e [::] lit_tt cc, g, [::], lit_tt, [::])
        end
      | QFBV.Bbinop op e1 e2 =>
        let '(m1, cc1, g1, cs1, ls1) := bit_blast_exp_ccache te m cc g e1 in
        let '(m2, cc2, g2, cs2, ls2) := bit_blast_exp_ccache te m1 cc1 g1 e2 in
        match find_hbt e cc2 with
        | Some (csop, lop) => (m2, cc2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None =>
          let '(gop, csop, lop) := bit_blast_bbinop op g2 ls1 ls2 in
          (m2, add_hbt e csop lop cc2, gop, catrev cs1 (catrev cs2 csop), lop, csop)
        end
      | QFBV.Blneg e1 =>
        let '(m1, cc1, g1, cs1, l1) := bit_blast_bexp_ccache te m cc g e1 in
        match find_hbt e cc1 with
        | Some (csop, lop) => (m1, cc1, g1, catrev cs1 csop, lop, csop)
        | None => let '(gop, csop, lop) := bit_blast_lneg g1 l1 in
                  (m1, add_hbt e csop lop cc1, gop, catrev cs1 csop, lop, csop)
        end
      | QFBV.Bconj e1 e2 =>
        let '(m1, cc1, g1, cs1, l1) := bit_blast_bexp_ccache te m cc g e1 in
        let '(m2, cc2, g2, cs2, l2) := bit_blast_bexp_ccache te m1 cc1 g1 e2 in
        match find_hbt e cc2 with
        | Some (csop, lop) => (m2, cc2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None => let '(gop, csop, lop) := bit_blast_conj g2 l1 l2 in
                  (m2, add_hbt e csop lop cc2, gop,
                   catrev cs1 (catrev cs2 csop), lop, csop)
        end
      | QFBV.Bdisj e1 e2 =>
        let '(m1, cc1, g1, cs1, l1) := bit_blast_bexp_ccache te m cc g e1 in
        let '(m2, cc2, g2, cs2, l2) := bit_blast_bexp_ccache te m1 cc1 g1 e2 in
        match find_hbt e cc2 with
        | Some (csop, lop) => (m2, cc2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None => let '(gop, csop, lop) := bit_blast_disj g2 l1 l2 in
                  (m2, add_hbt e csop lop cc2, gop,
                   catrev cs1 (catrev cs2 csop), lop, csop)
        end
      end
  (* = = *)
  in
  match CompCache.find_cbt e cc with
  | Some (cs, l) => (m, cc, g, [::], l)
  | None => let '(m', cc', g', cs, lr, csop) := bit_blast_bexp_nocbt te m cc g e in
            (m', CompCache.add_cbt e csop lr cc', g', cs, lr)
  end.

Lemma bit_blast_exp_ccache_equation :
  forall te m cc g e,
    bit_blast_exp_ccache te m cc g e =
  (* = bit_blast_exp_nocet = *)
  let bit_blast_exp_nocet te m cc g e :
        vm * compcache * generator * cnf * word * cnf :=
      match e with
      | QFBV.Evar v =>
        match find_het e cc with
        | Some (cs, ls) => (m, cc, g, cs, ls, cs)
        | None => match SSAVM.find v m with
                  | None => let '(g', cs, rs) := bit_blast_var te g v in
                            (SSAVM.add v rs m, add_het e cs rs cc, g', cs, rs, cs)
                  | Some rs => (m, add_het e [::] rs cc, g, [::], rs, [::])
                  end
        end
      | QFBV.Econst bs =>
        match find_het e cc with
        | Some (cs, ls) => (m, cc, g, cs, ls, cs)
        | None => let '(g', cs, rs) := bit_blast_const g bs in
                  (m, add_het e cs rs cc, g', cs, rs, cs)
        end
      | QFBV.Eunop op e1 =>
        let '(m1, cc1, g1, cs1, ls1) := bit_blast_exp_ccache te m cc g e1 in
        match find_het e cc1 with
        | Some (csop, lsop) => (m1, cc1, g1, catrev cs1 csop, lsop, csop)
        | None =>
          let '(gop, csop, lsop) := bit_blast_eunop op g1 ls1 in
          (m1, add_het e csop lsop cc1, gop, catrev cs1 csop, lsop, csop)
        end
      | QFBV.Ebinop op e1 e2 =>
        let '(m1, cc1, g1, cs1, ls1) := bit_blast_exp_ccache te m cc g e1 in
        let '(m2, cc2, g2, cs2, ls2) := bit_blast_exp_ccache te m1 cc1 g1 e2 in
        match find_het e cc2 with
        | Some (csop, lsop) => (m2, cc2, g2, catrev cs1 (catrev cs2 csop), lsop, csop)
        | None =>
          let '(gop, csop, lsop) := bit_blast_ebinop op g2 ls1 ls2 in
          (m2, add_het e csop lsop cc2, gop, catrev cs1 (catrev cs2 csop), lsop, csop)
        end
      | QFBV.Eite c e1 e2 =>
        let '(mc, ccc, gc, csc, lc) := bit_blast_bexp_ccache te m cc g c in
        let '(m1, cc1, g1, cs1, ls1) := bit_blast_exp_ccache te mc ccc gc e1 in
        let '(m2, cc2, g2, cs2, ls2) := bit_blast_exp_ccache te m1 cc1 g1 e2 in
        match find_het e cc2 with
        | Some (csop, lsop) =>
          (m2, cc2, g2, catrev csc (catrev cs1 (catrev cs2 csop)), lsop, csop)
        | None =>
          let '(gop, csop, lsop) := bit_blast_ite g2 lc ls1 ls2 in
          (m2, add_het e csop lsop cc2, gop,
           catrev csc (catrev cs1 (catrev cs2 csop)), lsop, csop)
        end
      end
  (* = = *)
  in
  match CompCache.find_cet e cc with
  | Some (cs, ls) => (m, cc, g, [::], ls)
  | None => let '(m', cc', g', cs, lrs, csop) := bit_blast_exp_nocet te m cc g e in
            (m', CompCache.add_cet e csop lrs cc', g', cs, lrs)
  end.
Proof. move=> te m cc g e. elim e; done. Qed.

Lemma bit_blast_bexp_ccache_equation :
  forall te m cc g e,
    bit_blast_bexp_ccache te m cc g e =
  (* = bit_blast_bexp_nocbt = *)
  let bit_blast_bexp_nocbt te m cc g e :
        vm * compcache * generator * cnf * literal * cnf :=
      match e with
      | QFBV.Bfalse =>
        match find_hbt e cc with
        | Some (cs, l) => (m, cc, g, cs, l, cs)
        | None => (m, add_hbt e [::] lit_ff cc, g, [::], lit_ff, [::])
        end
      | QFBV.Btrue =>
        match find_hbt e cc with
        | Some (cs, l) => (m, cc, g, cs, l, cs)
        | None => (m, add_hbt e [::] lit_tt cc, g, [::], lit_tt, [::])
        end
      | QFBV.Bbinop op e1 e2 =>
        let '(m1, cc1, g1, cs1, ls1) := bit_blast_exp_ccache te m cc g e1 in
        let '(m2, cc2, g2, cs2, ls2) := bit_blast_exp_ccache te m1 cc1 g1 e2 in
        match find_hbt e cc2 with
        | Some (csop, lop) => (m2, cc2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None =>
          let '(gop, csop, lop) := bit_blast_bbinop op g2 ls1 ls2 in
          (m2, add_hbt e csop lop cc2, gop, catrev cs1 (catrev cs2 csop), lop, csop)
        end
      | QFBV.Blneg e1 =>
        let '(m1, cc1, g1, cs1, l1) := bit_blast_bexp_ccache te m cc g e1 in
        match find_hbt e cc1 with
        | Some (csop, lop) => (m1, cc1, g1, catrev cs1 csop, lop, csop)
        | None => let '(gop, csop, lop) := bit_blast_lneg g1 l1 in
                  (m1, add_hbt e csop lop cc1, gop, catrev cs1 csop, lop, csop)
        end
      | QFBV.Bconj e1 e2 =>
        let '(m1, cc1, g1, cs1, l1) := bit_blast_bexp_ccache te m cc g e1 in
        let '(m2, cc2, g2, cs2, l2) := bit_blast_bexp_ccache te m1 cc1 g1 e2 in
        match find_hbt e cc2 with
        | Some (csop, lop) => (m2, cc2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None => let '(gop, csop, lop) := bit_blast_conj g2 l1 l2 in
                  (m2, add_hbt e csop lop cc2, gop,
                   catrev cs1 (catrev cs2 csop), lop, csop)
        end
      | QFBV.Bdisj e1 e2 =>
        let '(m1, cc1, g1, cs1, l1) := bit_blast_bexp_ccache te m cc g e1 in
        let '(m2, cc2, g2, cs2, l2) := bit_blast_bexp_ccache te m1 cc1 g1 e2 in
        match find_hbt e cc2 with
        | Some (csop, lop) => (m2, cc2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None => let '(gop, csop, lop) := bit_blast_disj g2 l1 l2 in
                  (m2, add_hbt e csop lop cc2, gop,
                   catrev cs1 (catrev cs2 csop), lop, csop)
        end
      end
  (* = = *)
  in
  match CompCache.find_cbt e cc with
  | Some (cs, l) => (m, cc, g, [::], l)
  | None => let '(m', cc', g', cs, lr, csop) := bit_blast_bexp_nocbt te m cc g e in
            (m', CompCache.add_cbt e csop lr cc', g', cs, lr)
  end.
Proof. move=> te m cc g e. elim e; done. Qed.

(* === mk_env_exp_ccache and mk_env_bexp_ccache === *)

Definition mk_env_eunop (op : QFBV.eunop) :=
  match op with
  | QFBV.Unot => mk_env_not
  | QFBV.Uneg => mk_env_neg
  | QFBV.Uextr i j => (fun E g ls => mk_env_extract E g i j ls)
  | QFBV.Uhigh n => (fun E g ls => mk_env_high E g n ls)
  | QFBV.Ulow n => (fun E g ls => mk_env_low E g n ls)
  | QFBV.Uzext n => mk_env_zeroextend n
  | QFBV.Usext n => mk_env_signextend n
  | QFBV.Urepeat n => (fun E g ls => mk_env_repeat E g n ls)
  | QFBV.Urotl n => (fun E g ls => mk_env_rotateleft E g n ls)
  | QFBV.Urotr n => (fun E g ls => mk_env_rotateright E g n ls)
  end .

Definition mk_env_ebinop (op : QFBV.ebinop) :=
  match op with
  | QFBV.Band => mk_env_and
  | QFBV.Bor => mk_env_or
  | QFBV.Bxor => mk_env_xor
  | QFBV.Badd => mk_env_add
  | QFBV.Bsub => mk_env_sub
  | QFBV.Bmul => mk_env_mul
  | QFBV.Bdiv => mk_env_udiv'
  | QFBV.Bmod => mk_env_umod
  | QFBV.Bsdiv => mk_env_sdiv
  | QFBV.Bsrem => mk_env_srem
  | QFBV.Bsmod => mk_env_smod
  | QFBV.Bshl => mk_env_shl
  | QFBV.Blshr => mk_env_lshr
  | QFBV.Bashr => mk_env_ashr
  | QFBV.Bconcat => mk_env_concat
  | QFBV.Bcomp => mk_env_comp
  end .

Definition mk_env_bbinop (op : QFBV.bbinop) :=
  match op with
  | QFBV.Beq => mk_env_eq
  | QFBV.Bult => mk_env_ult
  | QFBV.Bule => mk_env_ule
  | QFBV.Bugt => mk_env_ugt
  | QFBV.Buge => mk_env_uge
  | QFBV.Bslt => mk_env_slt
  | QFBV.Bsle => mk_env_sle
  | QFBV.Bsgt => mk_env_sgt
  | QFBV.Bsge => mk_env_sge
  | QFBV.Buaddo => mk_env_uaddo
  | QFBV.Busubo => mk_env_usubo
  | QFBV.Bumulo => mk_env_umulo
  | QFBV.Bsaddo => mk_env_saddo
  | QFBV.Bssubo => mk_env_ssubo
  | QFBV.Bsmulo => mk_env_smulo
  end .

Lemma mk_env_eunop_env_equal op E1 E2 g ls E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_eunop op E1 g ls = (E1', g1', cs1, lrs1) ->
  mk_env_eunop op E2 g ls = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  case: op => /=.
  - exact: mk_env_not_env_equal.
  - exact: mk_env_neg_env_equal.
  - move=> ? ?; exact: mk_env_extract_env_equal.
  - move=> ?; exact: mk_env_high_env_equal.
  - move=> ?; exact: mk_env_low_env_equal.
  - move=> ?; exact: mk_env_zeroextend_env_equal.
  - move=> ?; exact: mk_env_signextend_env_equal.
  - move=> ?; exact: mk_env_repeat_env_equal.
  - move=> ?; exact: mk_env_rotateleft_env_equal.
  - move=> ?; exact: mk_env_rotateright_env_equal.
Qed.

Lemma mk_env_ebinop_env_equal op E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lrs1 lrs2 :
  env_equal E1 E2 ->
  mk_env_ebinop op E1 g ls1 ls2 = (E1', g1', cs1, lrs1) ->
  mk_env_ebinop op E2 g ls1 ls2 = (E2', g2', cs2, lrs2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lrs1 = lrs2.
Proof.
  case: op => /=.
  - exact: mk_env_and_env_equal.
  - exact: mk_env_or_env_equal.
  - exact: mk_env_xor_env_equal.
  - exact: mk_env_add_env_equal.
  - exact: mk_env_sub_env_equal.
  - exact: mk_env_mul_env_equal.
  - exact: mk_env_udiv'_env_equal.
  - exact: mk_env_umod_env_equal.
  - exact: mk_env_sdiv_env_equal.
  - exact: mk_env_srem_env_equal.
  - exact: mk_env_smod_env_equal.
  - exact: mk_env_shl_env_equal.
  - exact: mk_env_lshr_env_equal.
  - exact: mk_env_ashr_env_equal.
  - exact: mk_env_concat_env_equal.
  - exact: mk_env_comp_env_equal.
Qed.

Lemma mk_env_bbinop_env_equal op E1 E2 g ls1 ls2 E1' E2' g1' g2' cs1 cs2 lr1 lr2 :
  env_equal E1 E2 ->
  mk_env_bbinop op E1 g ls1 ls2 = (E1', g1', cs1, lr1) ->
  mk_env_bbinop op E2 g ls1 ls2 = (E2', g2', cs2, lr2) ->
  env_equal E1' E2' /\ g1' = g2' /\ cs1 = cs2 /\ lr1 = lr2.
Proof.
  case: op => /=.
  - exact: mk_env_eq_env_equal.
  - exact: mk_env_ult_env_equal.
  - exact: mk_env_ule_env_equal.
  - exact: mk_env_ugt_env_equal.
  - exact: mk_env_uge_env_equal.
  - exact: mk_env_slt_env_equal.
  - exact: mk_env_sle_env_equal.
  - exact: mk_env_sgt_env_equal.
  - exact: mk_env_sge_env_equal.
  - exact: mk_env_uaddo_env_equal.
  - exact: mk_env_usubo_env_equal.
  - exact: mk_env_umulo_env_equal.
  - exact: mk_env_saddo_env_equal.
  - exact: mk_env_ssubo_env_equal.
  - exact: mk_env_smulo_env_equal.
Qed.

Fixpoint mk_env_exp_ccache m cc s E g e :
  vm * compcache * env * generator * cnf * word :=
  (* = mk_env_exp_nocet = *)
  let mk_env_exp_nocet m cc s E g e :
        vm * compcache * env * generator * cnf * word * cnf :=
      match e with
      | QFBV.Evar v =>
        match find_het e cc with
        | Some (cs, ls) => (m, cc, E, g, cs, ls, cs)
        | None => match SSAVM.find v m with
                  | None =>
                    let '(E', g', cs, rs) := mk_env_var E g (SSAStore.acc v s) v in
                    (SSAVM.add v rs m, add_het e cs rs cc, E', g', cs, rs, cs)
                  | Some rs => (m, add_het e [::] rs cc, E, g, [::], rs, [::])
                  end
        end
      | QFBV.Econst bs =>
        match find_het e cc with
        | Some (cs, ls) => (m, cc, E, g, cs, ls, cs)
        | None => let '(E', g', cs, rs) := mk_env_const E g bs in
                  (m, add_het e cs rs cc, E', g', cs, rs, cs)
        end
      | QFBV.Eunop op e1 =>
        let '(m1, cc1, E1, g1, cs1, ls1) := mk_env_exp_ccache m cc s E g e1 in
        match find_het e cc1 with
        | Some (csop, lsop) => (m1, cc1, E1, g1, catrev cs1 csop, lsop, csop)
        | None =>
          let '(Eop, gop, csop, lsop) := mk_env_eunop op E1 g1 ls1 in
          (m1, add_het e csop lsop cc1, Eop, gop, catrev cs1 csop, lsop, csop)
        end
      | QFBV.Ebinop op e1 e2 =>
        let '(m1, cc1, E1, g1, cs1, ls1) := mk_env_exp_ccache m cc s E g e1 in
        let '(m2, cc2, E2, g2, cs2, ls2) := mk_env_exp_ccache m1 cc1 s E1 g1 e2 in
        match find_het e cc2 with
        | Some (csop, lsop) => (m2, cc2, E2, g2, catrev cs1 (catrev cs2 csop), lsop, csop)
        | None =>
          let '(Eop, gop, csop, lsop) := mk_env_ebinop op E2 g2 ls1 ls2 in
          (m2, add_het e csop lsop cc2, Eop, gop, catrev cs1 (catrev cs2 csop), lsop, csop)
        end
      | QFBV.Eite c e1 e2 =>
        let '(mc, ccc, Ec, gc, csc, lc) := mk_env_bexp_ccache m cc s E g c in
        let '(m1, cc1, E1, g1, cs1, ls1) := mk_env_exp_ccache mc ccc s Ec gc e1 in
        let '(m2, cc2, E2, g2, cs2, ls2) := mk_env_exp_ccache m1 cc1 s E1 g1 e2 in
        match find_het e cc2 with
        | Some (csop, lsop) =>
          (m2, cc2, E2, g2, catrev csc (catrev cs1 (catrev cs2 csop)), lsop, csop)
        | None =>
          let '(Eop, gop, csop, lsop) := mk_env_ite E2 g2 lc ls1 ls2 in
          (m2, add_het e csop lsop cc2, Eop, gop,
           catrev csc (catrev cs1 (catrev cs2 csop)), lsop, csop)
        end
      end
  (* = = *)
  in
  match CompCache.find_cet e cc with
  | Some (cs, ls) => (m, cc, E, g, [::], ls)
  | None => let '(m', cc', E', g', cs, lrs, csop) := mk_env_exp_nocet m cc s E g e in
            (m', CompCache.add_cet e csop lrs cc', E', g', cs, lrs)
  end
with
mk_env_bexp_ccache m cc s E g e : vm * compcache * env * generator * cnf * literal :=
  (* = mk_env_bexp_nocbt = *)
  let mk_env_bexp_nocbt m cc s E g e :
        vm * compcache * env * generator * cnf * literal * cnf :=
      match e with
      | QFBV.Bfalse =>
        match find_hbt e cc with
        | Some (cs, l) => (m, cc, E, g, cs, l, cs)
        | None => (m, add_hbt e [::] lit_ff cc, E, g, [::], lit_ff, [::])
        end
      | QFBV.Btrue =>
        match find_hbt e cc with
        | Some (cs, l) => (m, cc, E, g, cs, l, cs)
        | None => (m, add_hbt e [::] lit_tt cc, E, g, [::], lit_tt, [::])
        end
      | QFBV.Bbinop op e1 e2 =>
        let '(m1, cc1, E1, g1, cs1, ls1) := mk_env_exp_ccache m cc s E g e1 in
        let '(m2, cc2, E2, g2, cs2, ls2) := mk_env_exp_ccache m1 cc1 s E1 g1 e2 in
        match find_hbt e cc2 with
        | Some (csop, lop) => (m2, cc2, E2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None =>
          let '(Eop, gop, csop, lop) := mk_env_bbinop op E2 g2 ls1 ls2 in
          (m2, add_hbt e csop lop cc2, Eop, gop, catrev cs1 (catrev cs2 csop), lop, csop)
        end
      | QFBV.Blneg e1 =>
        let '(m1, cc1, E1, g1, cs1, l1) := mk_env_bexp_ccache m cc s E g e1 in
        match find_hbt e cc1 with
        | Some (csop, lop) => (m1, cc1, E1, g1, catrev cs1 csop, lop, csop)
        | None => let '(Eop, gop, csop, lop) := mk_env_lneg E1 g1 l1 in
                  (m1, add_hbt e csop lop cc1, Eop, gop, catrev cs1 csop, lop, csop)
        end
      | QFBV.Bconj e1 e2 =>
        let '(m1, cc1, E1, g1, cs1, l1) := mk_env_bexp_ccache m cc s E g e1 in
        let '(m2, cc2, E2, g2, cs2, l2) := mk_env_bexp_ccache m1 cc1 s E1 g1 e2 in
        match find_hbt e cc2 with
        | Some (csop, lop) => (m2, cc2, E2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None => let '(Eop, gop, csop, lop) := mk_env_conj E2 g2 l1 l2 in
                  (m2, add_hbt e csop lop cc2, Eop, gop,
                   catrev cs1 (catrev cs2 csop), lop, csop)
        end
      | QFBV.Bdisj e1 e2 =>
        let '(m1, cc1, E1, g1, cs1, l1) := mk_env_bexp_ccache m cc s E g e1 in
        let '(m2, cc2, E2, g2, cs2, l2) := mk_env_bexp_ccache m1 cc1 s E1 g1 e2 in
        match find_hbt e cc2 with
        | Some (csop, lop) => (m2, cc2, E2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None => let '(Eop, gop, csop, lop) := mk_env_disj E2 g2 l1 l2 in
                  (m2, add_hbt e csop lop cc2, Eop, gop,
                   catrev cs1 (catrev cs2 csop), lop, csop)
        end
      end
  (* = = *)
  in
  match CompCache.find_cbt e cc with
  | Some (cs, l) => (m, cc, E, g, [::], l)
  | None => let '(m', cc', E', g', cs, lr, csop) := mk_env_bexp_nocbt m cc s E g e in
            (m', CompCache.add_cbt e csop lr cc', E', g', cs, lr)
  end.

Lemma mk_env_exp_ccache_equation :
  forall m cc s E g e,  mk_env_exp_ccache m cc s E g e =
  (* = mk_env_exp_nocet = *)
  let mk_env_exp_nocet m cc s E g e :
        vm * compcache * env * generator * cnf * word * cnf :=
      match e with
      | QFBV.Evar v =>
        match find_het e cc with
        | Some (cs, ls) => (m, cc, E, g, cs, ls, cs)
        | None => match SSAVM.find v m with
                  | None =>
                    let '(E', g', cs, rs) := mk_env_var E g (SSAStore.acc v s) v in
                    (SSAVM.add v rs m, add_het e cs rs cc, E', g', cs, rs, cs)
                  | Some rs => (m, add_het e [::] rs cc, E, g, [::], rs, [::])
                  end
        end
      | QFBV.Econst bs =>
        match find_het e cc with
        | Some (cs, ls) => (m, cc, E, g, cs, ls, cs)
        | None => let '(E', g', cs, rs) := mk_env_const E g bs in
                  (m, add_het e cs rs cc, E', g', cs, rs, cs)
        end
      | QFBV.Eunop op e1 =>
        let '(m1, cc1, E1, g1, cs1, ls1) := mk_env_exp_ccache m cc s E g e1 in
        match find_het e cc1 with
        | Some (csop, lsop) => (m1, cc1, E1, g1, catrev cs1 csop, lsop, csop)
        | None =>
          let '(Eop, gop, csop, lsop) := mk_env_eunop op E1 g1 ls1 in
          (m1, add_het e csop lsop cc1, Eop, gop, catrev cs1 csop, lsop, csop)
        end
      | QFBV.Ebinop op e1 e2 =>
        let '(m1, cc1, E1, g1, cs1, ls1) := mk_env_exp_ccache m cc s E g e1 in
        let '(m2, cc2, E2, g2, cs2, ls2) := mk_env_exp_ccache m1 cc1 s E1 g1 e2 in
        match find_het e cc2 with
        | Some (csop, lsop) => (m2, cc2, E2, g2, catrev cs1 (catrev cs2 csop), lsop, csop)
        | None =>
          let '(Eop, gop, csop, lsop) := mk_env_ebinop op E2 g2 ls1 ls2 in
          (m2, add_het e csop lsop cc2, Eop, gop, catrev cs1 (catrev cs2 csop), lsop, csop)
        end
      | QFBV.Eite c e1 e2 =>
        let '(mc, ccc, Ec, gc, csc, lc) := mk_env_bexp_ccache m cc s E g c in
        let '(m1, cc1, E1, g1, cs1, ls1) := mk_env_exp_ccache mc ccc s Ec gc e1 in
        let '(m2, cc2, E2, g2, cs2, ls2) := mk_env_exp_ccache m1 cc1 s E1 g1 e2 in
        match find_het e cc2 with
        | Some (csop, lsop) =>
          (m2, cc2, E2, g2, catrev csc (catrev cs1 (catrev cs2 csop)), lsop, csop)
        | None =>
          let '(Eop, gop, csop, lsop) := mk_env_ite E2 g2 lc ls1 ls2 in
          (m2, add_het e csop lsop cc2, Eop, gop,
           catrev csc (catrev cs1 (catrev cs2 csop)), lsop, csop)
        end
      end
  (* = = *)
  in
  match CompCache.find_cet e cc with
  | Some (cs, ls) => (m, cc, E, g, [::], ls)
  | None => let '(m', cc', E', g', cs, lrs, csop) := mk_env_exp_nocet m cc s E g e in
            (m', CompCache.add_cet e csop lrs cc', E', g', cs, lrs)
  end .
Proof. move=> m cc s E g e. elim e; done. Qed.

Lemma mk_env_bexp_ccache_equation :
  forall m cc s E g e,
    mk_env_bexp_ccache m cc s E g e =
  (* = mk_env_bexp_nocbt = *)
  let mk_env_bexp_nocbt m cc s E g e :
        vm * compcache * env * generator * cnf * literal * cnf :=
      match e with
      | QFBV.Bfalse =>
        match find_hbt e cc with
        | Some (cs, l) => (m, cc, E, g, cs, l, cs)
        | None => (m, add_hbt e [::] lit_ff cc, E, g, [::], lit_ff, [::])
        end
      | QFBV.Btrue =>
        match find_hbt e cc with
        | Some (cs, l) => (m, cc, E, g, cs, l, cs)
        | None => (m, add_hbt e [::] lit_tt cc, E, g, [::], lit_tt, [::])
        end
      | QFBV.Bbinop op e1 e2 =>
        let '(m1, cc1, E1, g1, cs1, ls1) := mk_env_exp_ccache m cc s E g e1 in
        let '(m2, cc2, E2, g2, cs2, ls2) := mk_env_exp_ccache m1 cc1 s E1 g1 e2 in
        match find_hbt e cc2 with
        | Some (csop, lop) => (m2, cc2, E2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None =>
          let '(Eop, gop, csop, lop) := mk_env_bbinop op E2 g2 ls1 ls2 in
          (m2, add_hbt e csop lop cc2, Eop, gop, catrev cs1 (catrev cs2 csop), lop, csop)
        end
      | QFBV.Blneg e1 =>
        let '(m1, cc1, E1, g1, cs1, l1) := mk_env_bexp_ccache m cc s E g e1 in
        match find_hbt e cc1 with
        | Some (csop, lop) => (m1, cc1, E1, g1, catrev cs1 csop, lop, csop)
        | None => let '(Eop, gop, csop, lop) := mk_env_lneg E1 g1 l1 in
                  (m1, add_hbt e csop lop cc1, Eop, gop, catrev cs1 csop, lop, csop)
        end
      | QFBV.Bconj e1 e2 =>
        let '(m1, cc1, E1, g1, cs1, l1) := mk_env_bexp_ccache m cc s E g e1 in
        let '(m2, cc2, E2, g2, cs2, l2) := mk_env_bexp_ccache m1 cc1 s E1 g1 e2 in
        match find_hbt e cc2 with
        | Some (csop, lop) => (m2, cc2, E2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None => let '(Eop, gop, csop, lop) := mk_env_conj E2 g2 l1 l2 in
                  (m2, add_hbt e csop lop cc2, Eop, gop,
                   catrev cs1 (catrev cs2 csop), lop, csop)
        end
      | QFBV.Bdisj e1 e2 =>
        let '(m1, cc1, E1, g1, cs1, l1) := mk_env_bexp_ccache m cc s E g e1 in
        let '(m2, cc2, E2, g2, cs2, l2) := mk_env_bexp_ccache m1 cc1 s E1 g1 e2 in
        match find_hbt e cc2 with
        | Some (csop, lop) => (m2, cc2, E2, g2, catrev cs1 (catrev cs2 csop), lop, csop)
        | None => let '(Eop, gop, csop, lop) := mk_env_disj E2 g2 l1 l2 in
                  (m2, add_hbt e csop lop cc2, Eop, gop,
                   catrev cs1 (catrev cs2 csop), lop, csop)
        end
      end
  (* = = *)
  in
  match CompCache.find_cbt e cc with
  | Some (cs, l) => (m, cc, E, g, [::], l)
  | None => let '(m', cc', E', g', cs, lr, csop) := mk_env_bexp_nocbt m cc s E g e in
            (m', CompCache.add_cbt e csop lr cc', E', g', cs, lr)
  end.
Proof. move=> m cc s E g e. elim e; done. Qed.


Require Import List.
Require Import Coq.Lists.ListSet.
Require Import Omega.

Require Import Stream.
Require Import Unify.
Require Import MiniKanrenSyntax.
Require Import OperationalSem.
Require Import DenotationalSem.

Module OperationalSemCompletenessAbstr (CS : ConstraintStoreSig).

Import CS.

Module OperationalSemCS := OperationalSemAbstr CS.

Import OperationalSemCS.

Lemma search_completeness_generalized
      (l    : nat)
      (g    : goal)
      (CG   : consistent_goal g)
      (s    : subst)
      (cs   : constraint_store s)
      (n    : nat)
      (WF   : well_formed_state' (Leaf g s cs n))
      (t    : trace)
      (OP   : op_sem (State (Leaf g s cs n)) t)
      (f    : repr_fun)
      (DSG  : [| l | g , f |])
      (DSS  : [ s , f ])
      (DSCS : [| s , cs , f |]) :
      exists (f' : repr_fun), {| t , f' |} /\
                            forall (x : name), x < n -> gt_eq (f x) (f' x).
Proof.
  revert OP. revert t. revert CG DSG DSS DSCS WF. revert cs. revert g f s n. induction l.
  { intros. apply in_denotational_sem_zero_lev in DSG. contradiction. }
  { induction g; intros; good_inversion CG.
    { good_inversion DSG. }
    { exists f. split.
      { econstructor. eexists. eexists. split; eauto.
        good_inversion OP. good_inversion EV. simpl_existT_cs_same. constructor. }
      { intros; red; auto. } }
    { exists f. split.
      2: intros; red; auto.
      good_inversion OP. good_inversion EV; good_inversion DSG; simpl_existT_cs_same.
      { destruct DSS as [fs COMP_s_fs]. red in UNI.
        rewrite <- (repr_fun_eq_apply _ _ t COMP_s_fs) in UNI.
        rewrite <- (repr_fun_eq_apply _ _ t0 COMP_s_fs) in UNI.
        rewrite (repr_fun_apply_compose s fs t) in UNI.
        rewrite (repr_fun_apply_compose s fs t0) in UNI.
        apply unfier_from_gt_unifier in UNI.
        destruct UNI as [sc [SC_UNIFIES _]]. specialize (mgu_non_unifiable _ _ MGU sc).
        contradiction. }
      { specialize (upd_cs_fail_condition _ _ _ UPD_CS f).
        intros C. exfalso. apply C. split; auto.
        apply (denotational_sem_uni _ _ _ _ MGU); auto. }
      { red. exists (compose s d). exists cs'. exists n. split.
        { constructor. }
        { apply and_comm. specialize (upd_cs_success_condition _ _ _ _ UPD_CS f).
          intro EQUI. apply EQUI. split; auto. apply (denotational_sem_uni _ _ _ _ MGU); auto. } } }
    { exists f. split.
      2: intros; red; auto.
      good_inversion DSG. good_inversion OP.
      good_inversion EV; simpl_existT_cs_same.
      { exfalso. eapply add_constraint_fail_condition in ADD_C. eauto. }
      { red. exists s. exists cs'. exists n. split.
        { constructor. }
        { apply and_comm. eapply add_constraint_success_condition in ADD_C.
          apply ADD_C. auto. } } }
    { good_inversion OP. inversion EV; subst.
      apply well_formedness_preservation in EV; auto. good_inversion EV. simpl_existT_cs_same.
      good_inversion wfState.
      specialize (op_sem_exists (State (Leaf g1 s cs n))). intro p1. destruct p1 as [t1 OP1].
      specialize (op_sem_exists (State (Leaf g2 s cs n))). intro p2. destruct p2 as [t2 OP2].
      specialize (sum_op_sem _ _ _ _ _ OP1 OP2 OP0). intro Hinter.
      good_inversion DSG.
      { specialize (IHg1 f s n cs CG_G1 DSG0 DSS DSCS WF_L t1 OP1).
        destruct IHg1 as [f' [HinDA ff'_eq]]. exists f'. split; auto.
        red in HinDA. destruct HinDA as [sr [csr [nr [Hin [DSSr DSCSr]]]]].
        red. exists sr. exists csr. exists nr. split; auto. constructor.
        apply (interleave_in _ _ _ Hinter (Answer sr csr nr)). auto. }
      { specialize (IHg2 f s n cs CG_G2 DSG0 DSS DSCS WF_R t2 OP2).
        destruct IHg2 as [f' [HinDA ff'_eq]]. exists f'. split; auto.
        red in HinDA. destruct HinDA as [sr [csr [nr [Hin [DSSr DSCSr]]]]].
        red. exists sr. exists csr. exists nr. split; auto. constructor.
        apply (interleave_in _ _ _ Hinter (Answer sr csr nr)). auto. } }
    { good_inversion DSG. good_inversion OP. inversion EV; simpl_existT_cs_same; subst.
      specialize (op_sem_exists (State (Leaf g1 s cs n))). intro p1. destruct p1 as [t1 OP1].
      assert (wfst'1 : well_formed_state' (Leaf g1 s cs n)).
      { constructor; good_inversion WF; simpl_existT_cs_same; auto. }
      specialize (IHg1 f s n cs CG_G1 DSG_L DSS DSCS wfst'1 t1 OP1).
      destruct IHg1 as [f' [HinDA ff'_eq]]. red in HinDA.
      destruct HinDA as [s' [cs' [n' [Hinstr' [HDAS' HDACS']]]]].
      specialize (op_sem_exists (State (Leaf g2 s' cs' n'))). intro p2. destruct p2 as [t2 OP2].
      specialize (counter_in_trace _ _ _ _ _ _ _ _ OP1 Hinstr'). intro n_le_n'.
      assert (wfst'2 : well_formed_state' (Leaf g2 s' cs' n')).
      { good_inversion WF. simpl_existT_cs_same.
        destruct (well_formed_subst_in_trace _ (wfNonEmpty _ wfst'1)  _ OP1 _ _ _ Hinstr').
        specialize (well_formed_ds_in_trace _ (wfNonEmpty _ wfst'1)  _ OP1 _ _ _ Hinstr').
        intros. constructor; auto. intros.
        apply lt_le_trans with n; auto. }
      assert (Hg2' : in_denotational_sem_lev_goal (S l) g2 f').
      { apply completeness_condition_lev with f; auto. intros. apply ff'_eq.
        good_inversion WF. auto. }
      specialize (IHg2 f' s' n' cs' CG_G2 Hg2' HDAS' HDACS' wfst'2 t2 OP2).
      destruct IHg2 as [f'' [HinDA f'f''_eq]]. red in HinDA.
      destruct HinDA as [s'' [cs'' [n'' [Hinstr'' [HDAS'' HDACS'']]]]].
      exists f''. split.
      { red. exists s''. exists cs''. exists n''. split; auto.
        constructor. eapply prod_op_sem_in; eauto. }
      { intros. red. apply eq_trans with (proj1_sig (f' x)).
        { apply ff'_eq. auto. }
        { apply f'f''_eq. omega. } } }
    { good_inversion DSG. good_inversion OP. inversion EV; simpl_existT_cs_same; subst.
      apply well_formedness_preservation in EV; auto. good_inversion EV.
      rename fn into fa.
      remember (fun x => if name_eq_dec x n
                         then fa a
                         else f x) as fn.
      assert (Hgn : [| S l | g n , fn |]).
      { good_inversion WF. apply den_sem_another_fresh_var with n a fa; auto.
        { intro C. apply FV_LT_COUNTER in C. omega. }
        {  destruct (name_eq_dec n n); try contradiction. reflexivity. }
        { intros. destruct (name_eq_dec x n); try contradiction. auto. } }
      assert (DSSn_AND_DSCSn : [ s , fn ] /\ [| s , cs , fn |]).
      { good_inversion WF. simpl_existT_cs_same. apply (DS_LT_COUNTER f); auto.
        intros. destruct (name_eq_dec x n); try omega. reflexivity. }
      destruct DSSn_AND_DSCSn as [DSSn DSCSn].
      specialize (H n fn s (S n) cs (CG_BODY n) Hgn DSSn DSCSn wfState t0 OP0).
      destruct H as [f' [HinDA ff'_eq]]. exists f'. split.
      { red. red in HinDA. destruct HinDA as [s' [cs' [n' [Hinstr [HDAS HDACS]]]]].
        exists s'. exists cs'. exists n'. split; auto. constructor; auto. }
      { intros. assert (x < S n). { omega. }
        specialize (ff'_eq x H0). red in ff'_eq. red. rewrite <- ff'_eq.
        rewrite Heqfn. destruct (name_eq_dec x n); try omega. reflexivity. } }
    { good_inversion DSG. good_inversion OP. inversion EV; subst.
      apply well_formedness_preservation in EV; auto. good_inversion EV. simpl_existT_cs_same.
      assert (cg_body : consistent_goal (proj1_sig (MiniKanrenSyntax.Prog n) t)).
      { remember (MiniKanrenSyntax.Prog n) as d. destruct d as [rel [Hcl Hco]].
        red in Hco. destruct (Hco t) as [Hcog Hcof]. auto. }
      specialize (IHl (proj1_sig (MiniKanrenSyntax.Prog n) t) f s n0 cs cg_body DSG0 DSS DSCS wfState t1 OP0).
      destruct IHl as [f' [HinDA ff'_eq]]. exists f'. split; auto.
      red. red in HinDA. destruct HinDA as [s' [cs' [n' [Hinstr [HDAS HDACS]]]]].
      exists s'. exists cs'. exists n'. split; auto. constructor; auto. } }
Qed.

Lemma search_completeness
      (g   : goal)
      (CG  : consistent_goal g)
      (k   : nat)
      (HC  : closed_goal_in_context (first_nats k) g)
      (f   : repr_fun)
      (t   : trace)
      (OP : op_sem (State (Leaf g empty_subst init_cs k)) t)
      (HDS : [| g , f |]) :
      exists (f' : repr_fun), {| t , f' |} /\
                            forall (x : name), In x (first_nats k) -> gt_eq (f x) (f' x).
Proof.
  apply in_denotational_sem_some_lev in HDS. destruct HDS as [l HDS].
  assert (WF : well_formed_state' (Leaf g empty_subst init_cs k)).
  { apply well_formed_initial_state; auto. }
  specialize (search_completeness_generalized l g CG empty_subst init_cs k WF t OP f HDS (empty_subst_ds f) (init_condition f)).
  intro. destruct H as [f' [HinDA ff'eq]]. exists f'. split; auto.
  intros. apply ff'eq. apply first_nats_less; auto.
Qed.

End OperationalSemCompletenessAbstr.


(**  Mathematical model of the causal memory implementation
     from "Causal memory: definitions, implementation, and programming"
     (https://link.springer.com/article/10.1007/BF01784241).*)

From aneris.aneris_lang Require Import lang resources.
From stdpp Require Import gmap.
From aneris.prelude Require Import misc.
From aneris.examples.ccddb.spec Require Import base.
From aneris.examples.ccddb.model Require Export events model_spec model_lhst.

(** Global state validity implementation. *)
Section Global_state_valid.
  Context `{!anerisG Mdl Σ, !DB_params}.

  (* The following two definitions capture the fact that the
       union of erasure of s_i (for i = 1 to n) is in M *)

  Definition DBM_lhst_in_gmem (M : gmap Key (gset write_event))
             (s: gset apply_event) :=
    ∀ e, e ∈ s → ∃ h, M !! e.(ae_key) = Some h ∧ erase e ∈ h.

  Definition DBM_gs_hst_in_gs_mem (gs : Gst) : Prop :=
    ∀ s, s ∈ gs.(Gst_hst) → DBM_lhst_in_gmem gs.(Gst_mem) s.

  (* The following definition captures that the write events in the global
       memory come from the sections s_ii (for i = 1 to n) *)
  Definition DBM_gs_mem_in_gs_hst (gs : Gst) :=
    ∀ a h, gs.(Gst_mem) !! a.(we_key) = Some h → a ∈ h →
           ∃ s si e, gs.(Gst_hst) !! a.(we_orig) = Some s ∧
                     DBM_lsec a.(we_orig) s = si ∧
                     e ∈ si ∧ erase e = a.

  Definition DBM_gs_hst_valid (gs : Gst) :=
    ∀ i s, gs.(Gst_hst) !! i = Some s → DBM_lhst_valid i s.

  Definition DBM_dom (gs : Gst) :=
    dom gs.(Gst_mem) = DB_keys.

  Definition DBM_gs_hst_size (gs : Gst) :=
    length gs.(Gst_hst) = length DB_addresses.

  Definition DBM_gs_gmem_elements_key (gs : Gst) :=
    ∀ k h a, gs.(Gst_mem) !! k = Some h → a ∈ h → k = a.(we_key).

  (** Valid Global states *)
  Record DBM_Gst_valid (gs: Gst) : Prop :=
    {
    DBM_GV_dom : DBM_dom gs;
    DBM_GV_hst_size : DBM_gs_hst_size gs;
    DBM_GV_hst_lst_valid : DBM_gs_hst_valid gs ;
    DBM_GV_hst_in_mem : DBM_gs_hst_in_gs_mem gs;
    DBM_GV_mem_in_hst : DBM_gs_mem_in_gs_hst gs;
    DBM_GV_mem_elements_key : DBM_gs_gmem_elements_key gs;
    }.

  Global Arguments DBM_GV_dom {_} _.
  Global Arguments DBM_GV_hst_size {_} _.
  Global Arguments DBM_GV_hst_lst_valid {_} _.
  Global Arguments DBM_GV_hst_in_mem {_} _.
  Global Arguments DBM_GV_mem_in_hst {_} _.
  Global Arguments DBM_GV_mem_elements_key {_} _.

  Lemma DBM_gs_mem_in_gs_hst_aux (gs : Gst) :
    DBM_Gst_valid gs →
    ∀ a h k, gs.(Gst_mem) !! k = Some h → a ∈ h →
             ∃ s si e, gs.(Gst_hst) !! a.(we_orig) = Some s ∧
                       DBM_lsec a.(we_orig) s = si ∧
                       e ∈ si ∧ erase e = a .
  Proof.
    intros Hvg a h k Hkh Hah.
    pose proof (DBM_GV_mem_elements_key Hvg k h a Hkh Hah) as ->.
      by eapply DBM_GV_mem_in_hst.
  Qed.

  Global Arguments DBM_gs_mem_in_gs_hst_aux {_} _.

  Lemma DBM_Gst_valid_hst_ith gs i s :
    DBM_Gst_valid gs →
    gs.(Gst_hst) !! i = Some s →
    i < length DB_addresses.
  Proof.
    intros Hvg His.
    apply lookup_lt_Some in His.
      by pose proof (DBM_GV_hst_size Hvg) as <- .
  Qed.

  Lemma we_in_valid_gs_orig gs k a h :
    DBM_Gst_valid gs →
    gs.(Gst_mem) !! k = Some h → a ∈ h →
    a.(we_orig) < length DB_addresses.
  Proof.
    intros Hvg Hkh Hak.
    pose proof (DBM_gs_mem_in_gs_hst_aux Hvg a h k Hkh Hak)
      as (s & sr & e & Hs & <- & Her & Hea).
    pose proof (DBM_GV_hst_lst_valid Hvg  (we_orig a) s Hs).
      by eapply DBM_LHV_bound_at.
  Qed.

  Lemma we_in_valid_gs_time gs k a h :
    DBM_Gst_valid gs →
    gs.(Gst_mem) !! k = Some h → a ∈ h →
    ∃ p, 0 < p ∧ a.(we_time) !! a.(we_orig) = Some p.
  Proof.
    intros Hvg Hkh Hak.
    pose proof (DBM_gs_mem_in_gs_hst_aux Hvg a h k Hkh Hak)
      as (s & sr & e & Hs & <- & Her & Hea); subst.
    pose proof (DBM_GV_hst_lst_valid Hvg (we_orig (erase e)) s Hs) as Hsv.
    assert ((erase e).(we_orig) < length DB_addresses) as Hao.
    { by eapply we_in_valid_gs_orig. }
    pose proof (DBM_LHV_secs_valid Hsv (we_orig (erase e)) Hao) as Hsrv.
    assert (is_Some (ae_time e !! (we_orig (erase e)))) as [q Hq].
    eapply in_lhs_time_component;
      eauto using in_lsec_in_lhst.
    rewrite erase_time.
    exists q; split; try done.
    eapply DBM_LSV_strongly_complete; [|done|by eauto|by eauto].
    eapply DBM_LHV_times; eauto.
  Qed.

  Lemma DBM_Gst_valid_empty : DBM_Gst_valid empty_Gst.
  Proof.
    split; [| | | | |];
      rewrite /empty_Gst /empty_gmem /empty_lhsts
              /DBM_dom /DBM_gs_hst_size /DBM_gs_hst_valid
              /DBM_gs_hst_in_gs_mem /DBM_gs_mem_in_gs_hst
              / DBM_gs_gmem_elements_key //=.
    - eauto using dom_gset_to_gmap.
    - by rewrite fmap_length.
    - intros ? ?; rewrite list_lookup_fmap.
      pose proof (lookup_lt_is_Some_1 DB_addresses i).
      destruct (_ !! _); simpl; last done.
      intros ?; simplify_eq.
      apply empty_lhst_valid; eauto.
    - intros s.
      rewrite elem_of_list_fmap.
        by intros (?&->&?) ? ?.
    - intros a ?; rewrite lookup_gset_to_gmap.
      destruct (decide (we_key a ∈ DB_keys));
        last by rewrite option_guard_False.
        by rewrite option_guard_True //; intros ?; simplify_eq.
    - intros k ? ?; rewrite lookup_gset_to_gmap.
      destruct (decide (k ∈ DB_keys));
        last by rewrite option_guard_False.
        by rewrite option_guard_True //; intros ?; simplify_eq.
  Qed.

  Lemma DBM_Gst_valid_gmem_ext_internal
        (gs : Gst) (k k' : Key) (h h' : gset write_event) (a a' : write_event) :
    DBM_Gst_valid gs →
    gs.(Gst_mem) !! k = Some h → gs.(Gst_mem) !! k' = Some h' →
    a ∈ h → a' ∈ h' →
    a.(we_orig) = a'.(we_orig) →
    a.(we_time) !! a.(we_orig) = a'.(we_time) !! a.(we_orig) →
    a = a'.
  Proof.
    intros Hvg Hkh Hkh' Hak Hak' Horg Htime.
    pose proof (DBM_gs_mem_in_gs_hst_aux Hvg a h k Hkh Hak)
      as (s & sr & e & Hs & <- & Her & Hea); subst.
    pose proof (DBM_gs_mem_in_gs_hst_aux Hvg a' h' k' Hkh' Hak')
      as (s' & sr' & e' & Hs' & <- & Her' & Hea'); subst.
    rewrite -Horg in Hs', Her'.
    assert (s' = s) as -> by naive_solver; clear Hs'.
    pose proof (DBM_GV_hst_lst_valid Hvg  (we_orig (erase e)) s Hs) as Hsv.
    assert ((erase e).(we_orig) < length DB_addresses) as Hao.
    { by eapply (we_in_valid_gs_orig gs _ (erase e) h). }
    pose proof (DBM_LHV_secs_valid Hsv (we_orig (erase e)) Hao) as Hsrv.
    pose proof (DBM_LSV_ext (DBM_LHV_times Hsv) Hao Hsrv) as Hext.
    f_equal.
      by apply Hext; auto; rewrite -!erase_time.
  Qed.

  Lemma DBM_Gst_valid_gmem_ext_internal_2
        (gs : Gst) (k k' : Key) (h h' : gset write_event) (a1 a2 : write_event):
    DBM_Gst_valid gs →
    gs.(Gst_mem) !! k = Some h → gs.(Gst_mem) !! k' = Some h' →
    a1 ∈ h → a2 ∈ h' → (we_time a1) = (we_time a2) → a1 = a2.
  Proof.
    intros Hvg Hkh Hkh' Hah Hah' Heq.
    destruct (decide (a1.(we_orig) = a2.(we_orig))) as [Horg | Horg ].
    - eapply (DBM_Gst_valid_gmem_ext_internal gs k k' h h'); auto.
      rewrite Heq; done.
    - pose proof (DBM_gs_mem_in_gs_hst_aux Hvg a1 h k Hkh Hah)
        as (s & sr & e1 & Hs & <- & Her & Hea); subst.
      pose proof (DBM_GV_hst_lst_valid Hvg _ _ Hs) as Hoe1s.
      pose proof (DBM_gs_mem_in_gs_hst_aux Hvg a2 h' k' Hkh' Hah')
        as (s' & sr' & e2 & Hs' & <- & Her' & Hea'); subst.
      pose proof (DBM_GV_hst_lst_valid Hvg _ _ Hs') as Hoe2s'.
      assert (we_orig (erase e2) < length DB_addresses) as He2dba
          by eauto using we_in_valid_gs_orig.
      assert (∃ q, (erase e1).(we_time) !! (we_orig (erase e2)) = Some q)
        as [q Hq].
      { rewrite erase_time.
        destruct (in_lhs_time_component e1 (we_orig (erase e2))
                                        (we_orig (erase e1)) s);
          eauto using in_lsec_in_lhst, we_in_valid_gs_orig. }
      destruct (DBM_lsec_causality_lemma (we_orig (erase e1)) s e1 q q
                                         (we_orig (erase e2)))
        as (e12&He2s&He2tm); eauto using we_in_valid_gs_orig, in_lsec_in_lhst.
      { eapply (DBM_LSV_strongly_complete
                  (DBM_LHV_times Hoe2s') He2dba
                  (DBM_LHV_secs_valid Hoe2s' (we_orig (erase e2)) He2dba)).
        eexists; split; eauto.
        rewrite -erase_time.
        rewrite -Heq; done. }
      { by rewrite -erase_time. }
      assert (e12 = e1) as He121.
      { eapply DBM_LHV_ext; first apply Hoe1s; eauto using in_lsec_in_lhst.
        pose proof (DBM_GV_hst_in_mem Hvg) as Hgh.
        assert (s ∈ Gst_hst gs) as Hsgs by by apply elem_of_list_lookup; eauto.
        destruct (Hgh _ Hsgs e12) as (h'' & Hh''1 & He12);
          first by eauto using in_lsec_in_lhst.
        rewrite -!erase_time.
        rewrite Heq.
        f_equal.
        symmetry.
        eapply (DBM_Gst_valid_gmem_ext_internal _ _ _ h' h''); eauto.
        - rewrite !erase_orig; erewrite !orig_in_lsec; eauto.
        - rewrite !erase_time He2tm.
          rewrite -erase_time.
          rewrite -Heq; done. }
      exfalso; apply Horg.
      rewrite -He121 erase_orig.
      erewrite orig_in_lsec; eauto.
  Qed.

  Lemma DBM_Gst_valid_gmem_ext
        (gs : Gst) (k k' : Key) (h h' : gset write_event) (a a' : write_event):
    DBM_Gst_valid gs →
    gs.(Gst_mem) !! k = Some h → gs.(Gst_mem) !! k' = Some h' →
    a ∈ h → a' ∈ h' → we_time a = we_time a' → a = a'.
  Proof.
    intros Hvg Hkh Hkh' Hah Hah' Heq.
    apply (DBM_Gst_valid_gmem_ext_internal_2 gs k k' h h'); eauto.
  Qed.

  Lemma DBM_Gst_valid_lhst_ext
        (gs : Gst) (i i' : nat) (s s' : gset apply_event) (e e' : apply_event):
    DBM_Gst_valid gs →
    gs.(Gst_hst) !! i = Some s →  gs.(Gst_hst) !! i' = Some s' →
    e ∈ s → e' ∈ s' → ae_time e = ae_time e' →
    e.(ae_key) = e'.(ae_key) ∧ e.(ae_val) = e'.(ae_val).
  Proof.
    intros Hgv ? ? He He' ?.
    rewrite -!erase_key -!erase_val.
    assert (erase e = erase e') as ->; last done.
    edestruct (DBM_GV_hst_in_mem Hgv s) as (h & Hh & Hea);
      eauto using elem_of_list_lookup_2.
    edestruct (DBM_GV_hst_in_mem Hgv s') as (h' & Hh' & Hea');
      eauto using elem_of_list_lookup_2.
    eapply (DBM_Gst_valid_gmem_ext_internal_2 _ _ _ h h'); eauto.
    rewrite -> !erase_time; done.
  Qed.

Lemma DBM_Gst_valid_lhst_strong_ext
        (gs : Gst) (i : nat) (s : gset apply_event) (e e' : apply_event):
    DBM_Gst_valid gs →
    gs.(Gst_hst) !! i = Some s →
    e ∈ s → e' ∈ s → ae_time e = ae_time e' → e = e'.
  Proof.
    intros Hgv ? He He' ?.
    eapply DBM_LHV_ext; eauto.
    eapply DBM_GV_hst_lst_valid; eauto.
  Qed.

  Lemma DBM_Gst_valid_ae_provenance (gs : Gst) (i : nat) (s : gset apply_event)
        (e : apply_event) :
    DBM_Gst_valid gs → gs.(Gst_hst) !! i = Some s → e ∈ s →
    ∃ (h : gset write_event), gs.(Gst_mem) !! e.(ae_key) = Some h ∧ erase e ∈ h.
  Proof.
    intros; eapply DBM_GV_hst_in_mem; eauto using elem_of_list_lookup_2.
  Qed.

  Lemma DBM_Gst_valid_causality
        (gs : Gst) (i : nat) (s : gset apply_event) (k : Key)
        (h: gset write_event) (e : apply_event) (a : write_event) :
    DBM_Gst_valid gs →
    gs.(Gst_mem) !! k = Some h → gs.(Gst_hst) !! i = Some s →
    a ∈ h → e ∈ s → vector_clock_lt (we_time a) (ae_time e) →
    ∃ e', e' ∈ (restrict_key k s) ∧ erase e' = a.
  Proof.
    intros Hvg Hkh His Hah Hes Hae.
    pose proof (DBM_GV_mem_elements_key Hvg k h a Hkh Hah) as ->.
    assert (∃ p,  0 < p ∧ a.(we_time) !! a.(we_orig) = Some p)
      as (p & H0p & Harp).
    { by eapply we_in_valid_gs_time. }
    assert (∃ q, p <= q ∧ e.(ae_time) !! a.(we_orig) = Some q)
      as (q & Hpq & Herq).
    { pose proof (vector_clock_lt_le a.(we_time) e.(ae_time) Hae) as Hle.
      eapply Forall2_lookup_l in Hle as (q & Her & Hpq); eauto. }
    edestruct (DBM_lsec_causality_lemma i s e p q) as (e' & He'rs & He'rp);
      eauto using we_in_valid_gs_orig.
    { by eapply DBM_GV_hst_lst_valid. }
    assert (ae_orig e' = we_orig a) as He'_orig.
    { by apply elem_of_filter in He'rs as (Horig&_). }
    assert (∃ h', gs.(Gst_mem) !! e'.(ae_key) = Some h' ∧ erase e' ∈ h')
      as (h' & Hh' & He'h').
    { eapply DBM_GV_hst_in_mem; last eapply in_lsec_in_lhst; eauto.
      eapply elem_of_list_lookup_2; eauto. }
    assert (erase e' = a) as He'a.
    { eapply (DBM_Gst_valid_gmem_ext_internal
                gs (ae_key e') (we_key a) h' h (erase e') a); try done.
      - rewrite -He'_orig. by apply erase_orig.
      - rewrite !erase_time !erase_orig.
          by rewrite !He'_orig Harp He'rp. }
    exists e'; split; last done.
    rewrite elem_of_filter; split; last by eapply in_lsec_in_lhst.
      by rewrite /= -erase_key He'a.
  Qed.

  Global Instance db_states : DB_global_state_valid :=
    {|
    DBM_GstValid gs := DBM_Gst_valid gs;
    DBM_GstValid_empty := DBM_Gst_valid_empty;
    DBM_GstValid_dom gs Hvg := Hvg.(DBM_GV_dom);
    DBM_GstValid_lhst_size gs Hvg:= Hvg.(DBM_GV_hst_size);
    DBM_GstValid_gmem_ext := DBM_Gst_valid_gmem_ext;
    DBM_GstValid_lhst_ext := DBM_Gst_valid_lhst_ext;
    DBM_GstValid_lhst_strong_ext := DBM_Gst_valid_lhst_strong_ext;
    DBM_GstValid_ae_provenance := DBM_Gst_valid_ae_provenance;
    DBM_GstValid_causality := DBM_Gst_valid_causality  |}.

End Global_state_valid.


(**
 * Copyright (C) 2022 BedRock Systems, Inc.
 * All rights reserved.
 *
 * SPDX-License-Identifier: LGPL-2.1 WITH BedRock Exception for use over network, see repository root for details.
 *)

Require Import iris.proofmode.proofmode.
Require Import bedrock.lang.algebra.dfrac_agree.
Require Import bedrock.lang.bi.spec.frac_splittable.
Require Import bedrock.lang.bi.spec.knowledge.
Require Import bedrock.lang.cpp.logic.
Require Import bedrock.lang.cpp.logic.own_instances.

Set Printing Coercions.

(**
Ghost reference cell:

- [dfrac_agree.own (g : dfrac_agree.gname A) (q : Qp) (x : A) : mpred]
represents fractional ownership of ghost cell [g] currently containing
[x]

- [dfrac_agree.know (g : dfrac_agree.gname A) (x : A) : mpred]
represents knowledge that ghost cell contains [x]

*)

Module Type DFRAC_AGREE.

  (** CMRA *)

  Parameter G : ∀ (A : Type) (Σ : gFunctors), Set.
  Existing Class G.
  Parameter Σ : ∀ (A : Type), gFunctors.
  #[global] Declare Instance subG {A Σ} : subG (DFRAC_AGREE.Σ A) Σ -> G A Σ.

  (** Ghosts *)

  Parameter gname : ∀ (A : Type), Set.

  #[global] Declare Instance gname_inhabited A : Inhabited (gname A).
  #[global] Declare Instance gname_eq_dec A : EqDecision (gname A).
  #[global] Declare Instance gname_countable A : Countable (gname A).

  (** Predicates *)

  Parameter own : ∀ {A} `{Σ : cpp_logic, !DFRAC_AGREE.G A Σ}
    (g : gname A) (q : Qp) (x : A), mpred.
  Parameter know : ∀ {A} `{Σ : cpp_logic, !DFRAC_AGREE.G A Σ}
    (g : gname A) (x : A), mpred.

  Section properties.
    Context {A} `{Σ : cpp_logic, !DFRAC_AGREE.G A Σ}.

    (** Structure *)

    #[global] Declare Instance own_objective : Objective3 own.
    #[global] Declare Instance own_frac g : FracSplittable_1 (own g).
    #[global] Declare Instance own_agree g : AgreeF1 (own g).

    #[global] Declare Instance know_objective : Objective2 know.
    #[global] Declare Instance know_timeless : Timeless2 know.
    #[global] Declare Instance know_knowledge : Knowledge2 know.
    #[global] Declare Instance know_agree g : Agree1 (know g).

    #[global] Declare Instance know_own_agree g q x1 x2 :
      Observe2 [| x1 = x2 |] (know g x1) (own g q x2).

    (** Allocation *)

    Axiom alloc_strong_dep : ∀ (f : gname A -> A) (P : gname A -> Prop),
      pred_infinite P ->
      |-- |==> Exists g, [| P g |] ** own g 1 (f g).

    Axiom alloc_cofinite_dep : ∀ (f : gname A -> A) (G : gset (gname A)),
      |-- |==> Exists g, [| g ∉ G |] ** own g 1 (f g).

    Axiom alloc_dep : ∀ (f : gname A -> A),
      |-- |==> Exists g, own g 1 (f g).

    Axiom alloc_strong : ∀ (P : gname A -> Prop) x,
      pred_infinite P ->
      |-- |==> Exists g, [| P g |] ** own g 1 x.

    Axiom alloc_cofinite : ∀ (G : gset (gname A)) x,
      |-- |==> Exists g, [| g ∉ G |] ** own g 1 x.

    Axiom alloc : ∀ x, |-- |==> Exists g, own g 1 x.

    (** Updates *)

    Axiom update : ∀ x g y, own g 1 y |-- |==> own g 1 x.

    Axiom discard : ∀ g q x, own g q x |-- |==> know g x.

  End properties.

End DFRAC_AGREE.

Module dfrac_agree : DFRAC_AGREE.

  (** CMRA *)

  #[local] Notation RA A := (dfrac_agreeR (leibnizO A)).
  Class G (A : Type) (Σ : gFunctors) : Set := G_inG :> inG Σ (RA A).
  Definition Σ (A : Type) : gFunctors := #[ GFunctor (RA A) ].
  Lemma subG {A Σ} : subG (dfrac_agree.Σ A) Σ -> G A Σ.
  Proof. solve_inG. Qed.

  (** Ghosts *)

  Definition gname (A : Type) : Set := iprop.gname.
  Definition gname_inhabited A : Inhabited (gname A) := _.
  Definition gname_eq_dec A : EqDecision (gname A) := _.
  Definition gname_countable A : Countable (gname A) := _.

  (** Predicates *)

  Section defs.
    Context {A} `{Σ : cpp_logic, !dfrac_agree.G A Σ}.

    Definition know (g : gname A) (x : A) : mpred :=
      own g (to_dfrac_agree (A:=leibnizO A) DfracDiscarded x).
    Definition own (g : gname A) (q : Qp) (x : A) : mpred :=
      own g (to_dfrac_agree (A:=leibnizO A) (DfracOwn q) x).

    Definition own_objective : Objective3 own := _.
    Lemma own_frac g : FracSplittable_1 (own g).
    Proof.
      split.
      - intros x q1 q2. by rewrite -own_op -dfrac_agree_op.
      - apply _.
      - intros. iIntros "O".
        iDestruct (own_valid with "O") as %?%to_dfrac_agree_valid.
        auto.
    Qed.

    #[local] Ltac solve_agree :=
      intros; iIntros "O1 O2";
      iDestruct (own_valid_2 with "O1 O2") as %[_ ?]%dfrac_agree_op_valid_L;
      solve [ auto ].

    Lemma own_agree g : AgreeF1 (own g).
    Proof. solve_agree. Qed.

    Definition know_objective : Objective2 know := _.
    Definition know_timeless : Timeless2 know := _.
    Definition know_knowledge : Knowledge2 know.
    Proof. solve_knowledge. Qed.
    Lemma know_agree g : Agree1 (know g).
    Proof. solve_agree. Qed.

    Lemma know_own_agree g q x1 x2 :
      Observe2 [| x1 = x2 |] (know g x1) (own g q x2).
    Proof. solve_agree. Qed.

    Lemma alloc_strong_dep : ∀ (f : gname A -> A) (P : gname A -> Prop),
      pred_infinite P ->
      |-- |==> Exists g, [| P g |] ** own g 1 (f g).
    Proof. intros. by apply : own_alloc_strong_dep. Qed.

    Lemma alloc_cofinite_dep : ∀ (f : gname A -> A) (G : gset (gname A)),
      |-- |==> Exists g, [| g ∉ G |] ** own g 1 (f g).
    Proof. intros. by apply : own_alloc_cofinite_dep. Qed.

    Lemma alloc_dep : ∀ (f : gname A -> A),
      |-- |==> Exists g, own g 1 (f g).
    Proof. intros. by apply : own_alloc_dep. Qed.

    Lemma alloc_strong : ∀ (P : gname A -> Prop) x,
      pred_infinite P ->
      |-- |==> Exists g, [| P g |] ** own g 1 x.
    Proof. intros. by apply : own_alloc_strong. Qed.

    Lemma alloc_cofinite : ∀ (G : gset (gname A)) x,
      |-- |==> Exists g, [| g ∉ G |] ** own g 1 x.
    Proof. intros. by apply : own_alloc_cofinite. Qed.

    Lemma alloc x : |-- |==> Exists g, own g 1 x.
    Proof. by apply own_alloc. Qed.

    Lemma update x g y : own g 1 y |-- |==> own g 1 x.
    Proof. by apply own_update, cmra_update_exclusive. Qed.

    Lemma discard g q x : own g q x |-- |==> know g x.
    Proof. apply own_update, dfrac_agree_persist. Qed.
  End defs.

End dfrac_agree.


(* ------------------------------------------------------- *)
(** #

#
        The double time redundancy (DTR) transformation
#
#
--   Properties of mem block sub-part called rhsPar with stepg

          Dmitry Burlyaev - Pascal Fradet - 2015
#
#                                           *)
(* ------------------------------------------------------- *)
(*Add LoadPath "..\..\Common\".
        Require Import CirReflect .
Add LoadPath "..\..\TMRProof\".
Add LoadPath "..\". *)

Add LoadPath "..\..\Common\".
Add LoadPath "..\..\TMRProof\".
Add LoadPath "..\Transf\".

Require Import dtrTransform.

Set Implicit Arguments.

(* ###################################################################### *)
(** Properties of sub-circuit of Memory Block called rhsPar with Glitches *)
(* ###################################################################### *)

(* Type of rhsPar (IO interface):
  ((si1 # ({save#rollBack} # failF)) # (r_O # save)) ->
  ( [((save # rollBack) # failF) # s1 ]# rNew)
*)

(* State before/after for both cycles with a glitch (stepg) inside the circuit *)
(*by reflexion*)
Lemma stepg_rhs_R : forall p t c, ((fun p => pure_bset p) p)
                  -> stepg ((fun p =>
                                     let si_I :=   (fstS(fstS(fstS(fstS(fstS p))))) in
                                     let sav_I :=   (sndS(fstS(fstS(fstS(fstS p))))) in
                                     let sav2_I :=  (sndS(fstS(fstS(fstS p)))) in
                                     let fai_I :=  (sndS(fstS(fstS p))) in
                                     let rol_I :=   (sndS(fstS p)) in
                                     let rO_I :=   (sndS p) in

                                     rhsPar) p)
                           ((fun p =>
                                     let si_I :=   (fstS(fstS(fstS(fstS(fstS p))))) in
                                     let sav_I :=   (sndS(fstS(fstS(fstS(fstS p))))) in
                                     let sav2_I :=  (sndS(fstS(fstS(fstS p)))) in
                                     let fai_I :=  (sndS(fstS(fstS p))) in
                                     let rol_I :=   (sndS(fstS p)) in
                                     let rO_I :=   (sndS p) in

                                   {si_I,{{{ sav_I, rol_I},fai_I},{rO_I,sav2_I}}}) p) t c

                  -> (fun e => let p := fst(fst e) in
                               let t := snd(fst e) in
                               let c := snd e in

                               let si_I :=   (fstS(fstS(fstS(fstS(fstS p))))) in
                               let sav_I :=   (sndS(fstS(fstS(fstS(fstS p))))) in
                               let sav2_I :=  (sndS(fstS(fstS(fstS p)))) in
                               let fai_I :=  (sndS(fstS(fstS p))) in
                               let rol_I :=   (sndS(fstS p)) in
                               let rO_I :=   (sndS p) in

                               let rI_I:=  if (beq_buset_t sav2_I (~1)) then si_I
                                           else rO_I in

((c=rhsPar)/\ ( t= {{ {{sav_I,rol_I}, fai_I}, si_I}, rI_I}
\/ t= {{ {{sav_I,rol_I}, fai_I}, si_I},~?}))) (p,t,c).
Proof. introv. Reflo_step_g; Simpl. Qed.

(** The aforementioned property in a more useable form  *)
Lemma stepg_rhs: forall (si sav sav2 fai rol r :bool) si_I sav_I  sav2_I fai_I rol_I rO_I t c,
si_I =  bool2bset si -> sav_I  = bool2bset sav -> sav2_I =  bool2bset sav2 ->
fai_I  = bool2bset fai -> rol_I =  bool2bset rol ->  rO_I  = bool2bset r ->
stepg rhsPar  {si_I,{{{ sav_I, rol_I},fai_I},{rO_I,sav2_I}}} t c
->
let rI_I:=  if (beq_buset_t sav2_I (~1)) then si_I else rO_I in
((c=rhsPar)/\ ( t= {{ {{sav_I,rol_I}, fai_I}, si_I}, rI_I}
\/ t= {{ {{sav_I,rol_I}, fai_I}, si_I},~?})).
Proof.
introv G1 G2 G3 G4 G5 G6 H.
set (p := {bool2bset si, bool2bset sav, bool2bset sav2, bool2bset fai, bool2bset rol, bool2bset r}).
assert (X1:   si_I =   (fstS(fstS(fstS(fstS(fstS p)))))) by
(replace p with  {bool2bset si, bool2bset sav, bool2bset sav2, bool2bset fai, bool2bset rol, bool2bset r}; destruct si ; easy).
assert (X2:    sav_I =   (sndS(fstS(fstS(fstS(fstS p)))))) by
(replace p with  {bool2bset si, bool2bset sav, bool2bset sav2, bool2bset fai, bool2bset rol, bool2bset r}; destruct sav; easy).
assert (X3:    sav2_I =  (sndS(fstS(fstS(fstS p))))) by
(replace p with  {bool2bset si, bool2bset sav, bool2bset sav2, bool2bset fai, bool2bset rol, bool2bset r}; destruct sav2 ; easy).
assert (X4:    fai_I =  (sndS(fstS(fstS p)))) by
(replace p with  {bool2bset si, bool2bset sav, bool2bset sav2, bool2bset fai, bool2bset rol, bool2bset r}; destruct fai ; easy).
assert (X5:    rol_I =   (sndS(fstS p))) by
(replace p with  {bool2bset si, bool2bset sav, bool2bset sav2, bool2bset fai, bool2bset rol, bool2bset r}; destruct rol ; easy).
assert (X6:   rO_I =   (sndS p)) by
(replace p with  {bool2bset si, bool2bset sav, bool2bset sav2, bool2bset fai, bool2bset rol, bool2bset r}; destruct r ; easy).
intros. rewrite X1 in H. rewrite  X2 in H. rewrite  X3 in H.  rewrite X5 in H. rewrite  X6 in H.
rewrite X4 in H. Apply stepg_rhs_R in H. simpl fst in H. simpl snd in H.
rewrite <- X1 in H. rewrite <- X2 in H. rewrite <- X3 in H.
rewrite <- X5 in H. rewrite <- X6 in H.  rewrite <- X4 in H. apply H.
Qed.


(* ***************************************************************** *)
(* Progress.v                                                        *)
(*                                                                   *)
(* 2019 Xuan Huang                                                   *)
(* ***************************************************************** *)

(* ################################################################# *)
(** * Progress *)

From Wasm Require Export Validation.
From Wasm Require Export Execution.
From Wasm Require Export ExtendedTyping.
From Wasm Require Export ProofAux.

(* Coercions are too confusing during proofs. *)
Set Printing Coercions.

(* Sometimes. *)
(* Unset Printing Notations. *)

(**************************************************************)
(** ** Implicit Types - Copied from ExtendedTyping *)

(* Primary *)
Implicit Type b : bool.
Implicit Type n m : nat.

(* Value *)
Implicit Type val : val.
Implicit Type vals : list val.

(* Structure *)
Implicit Type M : module.
Implicit Type l : labelidx.

Implicit Type instr : instr.
Implicit Type instrs : list instr.
Implicit Type f func : func.
Implicit Type fs funcs : list func.
Implicit Type tab table: table.
Implicit Type tabs tables: list table.

(* Type *)
Implicit Type t : valtype.
Implicit Type ts : list valtype.
Implicit Type rt : resulttype.
Implicit Type bt : blocktype.
Implicit Type ft functype: functype.
Implicit Type fts functypes: list functype.
Implicit Type tt tabletype: tabletype.
Implicit Type tts tabletypes: list tabletype.

(* Validation *)
Implicit Type C : context.

(* Execution *)
Implicit Type cfg : config.
Implicit Type res : result.
Implicit Type S : store.
Implicit Type F : frame.
Implicit Type T : thread.
Implicit Type E : eval_context.

Implicit Type ainstr : admin_instr.
Implicit Type ainstrs : list admin_instr.

Implicit Type fa: funcaddr.
Implicit Type fas : list funcaddr.
Implicit Type ta: tableaddr.
Implicit Type tas : list tableaddr.

Implicit Type fi funcinst: funcinst.
Implicit Type fis funcinsts: list funcinst.
Implicit Type ti tableinst: tableinst.
Implicit Type tis tableinsts: list tableinst.

Implicit Type Mi mi moduleinst: moduleinst.

(* ================================================================= *)
(** ** Termination State *)
(** Terminal thread/config was not explicit defined. Should be straightforward.

    Q1:
      How to construct a result during step relation?
    A:
      we need to extract [list val] or [Trap] from [list admin_instr]
      to be able to construct [result] then construct [valid_result].

    Q2:
      [Inductive result] looks redundant,
      like [val], it's coincident with [instr]/[admin_instr].
      It's not used in other places besides of [valid_result]
    A:
      one important fact about [Inductive result] is that,
      like [val], it contains more information than [instr].\
      It's equiv to a proof-carrying form of [instr].
 *)

(* Transform between [result] and [admin_instr] *)

Definition result_to_ainstr (res: result) : list admin_instr :=
  match res with
  | R_vals vals => ⇈vals  (* lost information *)
  | R_trap => [Trap]
  end.

Notation "! res" := (result_to_ainstr res) (at level 9).

Example ex : list admin_instr := !R_trap.

(* extended from [valid_result] *)
Reserved Notation " '⊢R' T '∈' rt" (at level 70).
Inductive result_thread : thread -> resulttype -> Prop :=

  | RT : forall res rt F,
      ⊢r res ∈ rt ->
      ⊢R (F, !res) ∈ rt

where " '⊢R' T '∈' rt" := (result_thread T rt).
Hint Constructors result_thread.

Lemma R_vals_ϵ :
    !(R_vals []) = @nil admin_instr.
Proof.
  auto.
Qed.

Lemma R_vals_vals : forall vals,
    !(R_vals vals) = ⇈vals.
Proof.
  auto.
Qed.

Lemma F_vals_R: forall F vals rt,
    Forall2 (fun (val : val) (t : valtype) => ⊢v val ∈ t) vals rt ->
    ⊢R (F, ⇈vals) ∈ rt.
Proof with eauto.
  introv HForall2.
  rewrite <- R_vals_vals...
Qed.

Lemma F_ϵ_R: forall F,
    ⊢R (F, []) ∈ [].
Proof with eauto.
  intros.
  rewrite <- R_vals_ϵ...
Qed.

Lemma F_Trap_R: forall F rt,
    ⊢R (F, [Trap]) ∈ rt.
Proof with eauto.
  intros.
  asserts_rewrite ([Trap] = !R_trap)...
Qed.

(* ================================================================= *)
(** ** Lemma Forall2 *)

(* A specialized version of [Forall2_app_inv_r] *)
Lemma Forall2_snoc_app_r: forall {X Y : Type} {R: X -> Y -> Prop} (xs: list X) (ys': list Y) (y: Y),
     Forall2 R xs (ys' ++ [y]) ->
     exists xs' x, Forall2 R xs' ys' /\ R x y /\ xs = xs' ++ [x].
Proof.
  introv HForall2.
  apply Forall2_app_inv_r in HForall2.
  destruct HForall2 as (xs' & unit & Hxs' & Hunit & Heq).
  inverts Hunit as HRxy Hnil.
  inverts Hnil.
  exists xs' x.
  splits; auto.
Qed.

Lemma Forall2_snoc_app_r2: forall {X Y : Type} {R: X -> Y -> Prop} (xs: list X) (ys': list Y) (y1 y2: Y),
     Forall2 R xs (ys' ++ [y1; y2]) ->
     exists xs' x1 x2, Forall2 R xs' ys' /\ R x1 y1 /\ R x2 y2 /\ xs = xs' ++ [x1; x2].
Proof with eauto.
  introv HForall2.
  apply Forall2_app_inv_r in HForall2.
  destruct HForall2 as (l & r & Hl & Hr & Heq).
  inverts Hr as Hr1 Hr'.
  inverts Hr' as Hr2 Hr''.
  inverts Hr''.
  exists l x x0. splits...
Qed.

Lemma Forall2_snoc_app_r3: forall {X Y : Type} {R: X -> Y -> Prop} (xs: list X) (ys': list Y) (y1 y2 y3: Y),
     Forall2 R xs (ys' ++ [y1; y2; y3]) ->
     exists xs' x1 x2 x3, Forall2 R xs' ys' /\ R x1 y1 /\ R x2 y2 /\ R x3 y3 /\ xs = xs' ++ [x1; x2; x3].
Proof with eauto.
  introv HForall2.
  apply Forall2_app_inv_r in HForall2.
  destruct HForall2 as (l & r & Hl & Hr & Heq).
  inverts Hr as Hr1 Hr'.
  inverts Hr' as Hr2 Hr''.
  inverts Hr'' as Hr3 Hr'''.
  inverts Hr'''.
  exists l x x0 x1. splits...
Qed.

Ltac invert_Forall2_app_r1 HForall2 l r Hl Hr:=
  apply Forall2_snoc_app_r in HForall2;
  destruct HForall2 as (l & r & Hl & Hr & _Heq);
  rewrite _Heq.

Ltac invert_Forall2_app_r2 HForall2 xs' x1 x2 Hxs' Hx1 Hx2:=
  apply Forall2_snoc_app_r2 in HForall2;
  destruct HForall2 as (xs' & x1 & x2 & Hxs' & Hx1 & Hx2 & _Heq);
  rewrite _Heq.

Ltac invert_Forall2_app_r3 HForall2 xs' x1 x2 x3 Hxs' Hx1 Hx2 Hx3:=
  apply Forall2_snoc_app_r3 in HForall2;
  destruct HForall2 as (xs' & x1 & x2 & x3 & Hxs' & Hx1 & Hx2 & Hx3 & _Heq);
  rewrite _Heq.

(* ================================================================= *)
(** ** Build/Extract/Decompose Execution Context *)

(* Decompose on left, which has to be value *)
Lemma decompose_vals_as_E_seq: forall vals ainstrs,
    ⇈vals ++ ainstrs = plug__E (E_seq vals E_hole []) ainstrs.
Proof.
  intros.
  simpl in *.
  rewrite app_nil_r.
  auto.
Qed.

Ltac decompose_vals_as_E_seq_E vals :=
  rewrite decompose_vals_as_E_seq;
  remember (E_seq vals E_hole []) as E.

(* Decompose on right, which has to be rest of the ainstrs *)
Lemma decompose_rest_as_E_seq: forall ainstrs ainstrs',
    ainstrs ++ ainstrs' = plug__E (E_seq [] E_hole ainstrs') ainstrs.
Proof with auto.
  intros.
  simpl in *...
Qed.

Ltac decompose_rest_as_E_seq_E rest :=
  rewrite decompose_rest_as_E_seq;
  remember (E_seq [] E_hole rest) as E.

(* ================================================================= *)
(** ** Progress - VAIS_snoc -> SC_simple*)

Ltac step_VR_trap S F list car :=
  right;
  asserts_rewrite (
    list = [Trap] ++ car
  ); try reflexivity;
  rewrite decompose_rest_as_E_seq;
  exists S F [Trap]; apply SC_trap__E.

Ltac step_snoc_app_cdr S F HSC rest :=
  right;
  decompose_rest_as_E_seq_E rest;
  destruct HSC as (S' & F' & ainstrs' & HSC);
  exists S' F'; eexists;
  eapply SC_E;
  apply HSC.

(* ================================================================= *)
(** ** Main Theorem *)

Theorem progress : forall S T rt,
    ⊢c (S, T) ∈ rt ->
    ⊢R T ∈ rt \/ exists S' F' ainstrs', $(S, T) ↪ (S', F', ainstrs').   (* TODO: [exists T'] *)
Proof with eauto.
  introv HVC.

  (* valid_config *)
  inverts HVC as HSok HVT.
    (* valid_store *)
    (* valid_thread *)
    inverts HVT as HVA HVAIS.
      (* valid_frame *)
      inverts HVA as HVMI HVV.
        (* valid_moduleinst *)
        (* valid_value *)
      (* valid_admin_instrs *)

  dependent induction HVAIS.

  - (* VAIS_empty *)
    left.
    apply F_ϵ_R.

  - remember {| A_locals := vals; A_module := mi |} as F.
    remember (C0 with_locals = ts with_return = None) as C.
    rename H into HVAI__N.
    (* VAIS_snoc:
       we could not extract this case as a lemma since we need IH.

      [IHHVAIS : ... ->
      [          ⊢R (F, ainstrs) ∈ rt
      [          \/ exists S' T', (S0, F, ainstrs) ↪ $(S', T')

      [HVAIS : (S,C) ⊢a* ainstrs ∈ ϵ --> (ts0 ++ ts2)]
      [HVAI__N : (S,C) ⊢a  ainstr__N ∈ ts2 --> ts3]             (* H *)
     --------------------------------------------------------------
       ⊢R (F, ainstrs ++ [ainstr__N])
      [  \/ exists S' T', (S, F, ainstrs ++ [ainstr__N]) ↪ $(S', T') ]
    *)
    inverts HVAI__N as.

    + (* VAI_instr *)
      intros HVI__N.
      inverts keep HVI__N.

      ++ (* VI_const *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            left.
            asserts_rewrite ([Plain (Const val)] = ⇈[val]). reflexivity.
            rewrite <- upup_app.
            eapply F_vals_R.
            apply Forall2_app.
            +++++ rewrite app_nil_r in HForall2...
            +++++ constructor; try constructor...
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain (Const val)] [Plain (Const val)].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain (Const val)].

      ++ (* VI_unop *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            invert_Forall2_app_r1 HForall2 vals' val0 Hval' Hval0.
            rewrite upup_app; rewrite <- app_assoc; simpl.
            decompose_vals_as_E_seq_E vals'.
            exists S F.
            destruct (eval_unop op val0) as [val__opt | ] eqn:Heval.
            +++++ (* Ok *)
              destruct val__opt;
              eexists;
                eapply SC_E;
                eapply SC_simple.
              ++++++ (* Ok Some *) eapply SS_unop__some...
              ++++++ (* Ok None *) eapply SS_unop__none...
            +++++ (* Err *)
              inverts Hval0 as Heqtype_of.
              destruct (eval_unop_no_runtime_err op val0 Heqtype_of Heval).
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain (Unop op)] [Plain (Unop op)].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain (Unop op)].

      ++ (* VI_binop *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            invert_Forall2_app_r2 HForall2 vals' val1 val2 Hval' Hval1 Hval2.
            rewrite upup_app; rewrite <- app_assoc; simpl.
            decompose_vals_as_E_seq_E vals'.
            exists S F.
            destruct (eval_binop op val1 val2) as [val__opt | ] eqn:Heval.
            +++++ (* Ok *)
              destruct val__opt;
              eexists;
                eapply SC_E;
                eapply SC_simple.
              ++++++ (* Ok Some *) eapply SS_binop__some...
              ++++++ (* Ok None *) eapply SS_binop__none...
            +++++ (* Err *)
              inverts Hval1 as Heqtype_of1.
              inverts Hval2 as Heqtype_of2.
              destruct (eval_binop_no_runtime_err op val1 val2 Heqtype_of1 Heqtype_of2 Heval).
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain (Binop op)] [Plain (Binop op)].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain (Binop op)].

      ++ (* VI_testop *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            invert_Forall2_app_r1 HForall2 vals' val0 Hvals' Hval0.
            rewrite upup_app; rewrite <- app_assoc; simpl.
            decompose_vals_as_E_seq_E vals'.
            exists S F.
            destruct (eval_testop op val0) as [ bval | ] eqn:Heval.
            +++++ (* Ok *)
              eexists;
                eapply SC_E;
                eapply SC_simple;
                eapply SS_testop...
            +++++ (* Err *)
              inverts Hval0 as Heqtype_of.
              destruct (eval_testop_no_runtime_err op val0 Heqtype_of Heval).
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain (Testop op)] [Plain (Testop op)].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain (Testop op)].

      ++ (* VI_relop *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            invert_Forall2_app_r2 HForall2 vals' val1 val2 Hvals' Hval1 Hval2.
            rewrite upup_app; rewrite <- app_assoc; simpl.
            decompose_vals_as_E_seq_E vals'.
            exists S F.
            destruct (eval_relop op val1 val2) as [ bval | ] eqn:Heval.
            +++++ (* Ok *)
              eexists;
                eapply SC_E;
                eapply SC_simple;
                eapply SS_relop...
            +++++ (* Err *)
              inverts Hval1 as Heqtype_of1.
              inverts Hval2 as Heqtype_of2.
              destruct (eval_relop_no_runtime_err op val1 val2 Heqtype_of1 Heqtype_of2 Heval).
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain (Relop op)] [Plain (Relop op)].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain (Relop op)].

      ++ (* VI_drop *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            invert_Forall2_app_r1 HForall2 vals' val0 Hvals' Hval0.
            rewrite upup_app; rewrite <- app_assoc; simpl.
            decompose_vals_as_E_seq_E vals'.
            exists S F. eexists;
                eapply SC_E;
                eapply SC_simple;
                eapply SS_drop...
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain Drop] [Plain Drop].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain Drop].

      ++ (* VI_select *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            invert_Forall2_app_r3 HForall2 vals' val1 val2 valc Hvals' Hval1 Hval2 Hvalc.
            rewrite upup_app; rewrite <- app_assoc; simpl.
            inverts Hvalc as Htypeof.
            destruct valc as [c | | | ] ; inverts Htypeof. (* inverts our the underlying [I32.t] *)
            decompose_vals_as_E_seq_E vals'.
            exists S F.
            destruct (I32.eqz c) eqn:Heqz;
              eexists;
              eapply SC_E;
              eapply SC_simple.
            +++++ eapply SS_select2...
            +++++ eapply SS_select1...
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain Select] [Plain Select].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain Select].

      ++ (* VI_nop *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            decompose_vals_as_E_seq_E vals0.
            exists S F. eexists;
              eapply SC_E;
              eapply SC_simple;
              eapply SS_nop.
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain Nop] [Plain Nop].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain Nop].

      ++ (* VI_unreachable *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            decompose_vals_as_E_seq_E vals0.
            exists S F. eexists;
              eapply SC_E;
              eapply SC_simple;
              eapply SS_unreachable.
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain Unreachable] [Plain Unreachable].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain Unreachable].

      ++ (* VI_block *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            decompose_vals_as_E_seq_E vals0.
            exists S F. eexists;
              eapply SC_E;
              (* eapply SC_block *)
              admit.
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain (Block bt instrs)] [Plain (Block bt instrs)].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain (Block bt instrs)].

      ++ (* VI_loop *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            decompose_vals_as_E_seq_E vals0.
            exists S F. eexists;
              eapply SC_E;
              (* eapply SC_loop *)
              admit.
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain (Loop bt instrs)] [Plain (Loop bt instrs)].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain (Loop bt instrs)].

      ++ (* VI_if *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            decompose_vals_as_E_seq_E vals0.
            exists S F. eexists;
              eapply SC_E;
              (* eapply SC_if two cases *)
              admit.
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain (If bt instrs1 instrs2)] [Plain (If bt instrs1 instrs2)].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain (If bt instrs1 instrs2)].

      ++ (* VI_br *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            (* We are not inside a label...how to step?
               SS_br require a label to br.
               This would be vacuously true.
             *)
            admit.
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain (Br l0)] [Plain (Br l0)].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain (Br l0)].

      ++ (* VI_br_if *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            rewrite app_assoc in HForall2.
            invert_Forall2_app_r1 HForall2 vals' val0 Hvals' Hval0.
            rewrite upup_app; rewrite <- app_assoc; simpl.
            decompose_vals_as_E_seq_E vals'.
            exists S F.
            inverts Hval0 as Htypeof.
            destruct val0 as [ c | | | ]; inverts Htypeof.
            destruct (I32.eqz c) eqn:Heqz;
              eexists;
              eapply SC_E;
              eapply SC_simple.
            +++++ (* I32.eqz c = true  *) eapply SS_br_if2...
            +++++ (* I32.eqz c = false *) eapply SS_br_if1...
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain (Br_if l0)] [Plain (Br_if l0)].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain (Br_if l0)].

      ++ (* VI_br_table *)
        edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
        +++ (* ⊢R *)
          inverts HRT as HVR.
          inverts HVR as HForall2; simpl.
          ++++ (* VR_vals *)
            right.
            rewrite app_assoc in HForall2. rewrite app_assoc in HForall2.
            invert_Forall2_app_r1 HForall2 vals' val0 Hvals' Hval0.
            rewrite upup_app; rewrite <- app_assoc; simpl.
            decompose_vals_as_E_seq_E vals'.
            exists S F.
            inverts Hval0 as Htypeof.
            destruct val0 as [ i | | | ]; inverts Htypeof.
            destruct (leb (length ls) (I32.to_nat i)) eqn:Hleb;
              eexists;
              eapply SC_E;
              eapply SC_simple.
            +++++ (* out of bound [SS_br_table__N] *)
              (* Need to make two numbers consistent *)
              admit.
            +++++ (* in bound [SS_br_table__i] *)
              admit.
          ++++ (* VR_trap *)
            step_VR_trap S F [Trap; Plain (Br_table ls l__N)] [Plain (Br_table ls l__N)].
        +++ (* ↪ *)
          step_snoc_app_cdr S' F' HSC [Plain (Br_table ls l__N)].

    + (* VAI_trap *)
      edestruct IHHVAIS as [HRT | HSC]; try solve [subst; eauto].
      ++ (* ⊢R *)
        inverts HRT as HVR.
        inverts HVR as HForall2; simpl.
        +++ (* VR_vals *)
          right.
          decompose_vals_as_E_seq_E vals0.
          exists S F [Trap]. apply SC_trap__E.
        +++ (* VR_trap *)
            (* need to execute the first trap... though I doubt this case could happen? *)
          step_VR_trap S F [Trap; Trap] [Trap].
      ++ (* ↪ *)
        step_snoc_app_cdr S' F' HSC [Trap].

    + (* VAIS_label *)
      introv HVAIS__cont HVAIS__rest.
      inverts HVAIS__rest.
      ++ (* [] *) skip.
         (* TODO: need to generailize the context, i.e., the entire theorem *)

Admitted.

(** Archive - How I found it need to be a induction. *)

(* For SC_Simple, we don't care S and F *)
Lemma progress_SC_simple : forall S C F ainstrs ainstr__N ts0 ts2 ts3,
      (S,C) ⊢a* ainstrs ∈ [] --> (ts0 ++ ts2) ->  (* [HVAIS] *)
      (S,C) ⊢a  ainstr__N ∈ ts2 --> ts3 ->          (* [HVAI__N] *)
(* -------------------------------------------------------------- *)
      ⊢R (F, ainstrs ++ [ainstr__N]) ∈ ts0 ++ ts3
      \/ exists S' T', (S, F, ainstrs ++ [ainstr__N]) ↪ $(S', T').
Proof with eauto.
  introv HVAIS HVAI__N.
  inverts HVAI__N as.

  - (* VAI_instr *)
    intros HVI__N.
    inverts keep HVI__N.

    + (* VI_const *)
      left.
      (* we have shown [ainstrs ++ ⇈[val]] is a normal form
         but how do we show it's a result of vals?
         i.e. all ainstrs here should be some [vals] as well? *)
      admit.

    + (* VI_unop *)
      right.
      (*

  HVAIS : (S, C) ⊢a* ainstrs ∈ [] --> (ts0 ++ [type_of op])
--------------------------------------------------------------
 [exists S' T', (S, F, ainstrs ++ [Plain (Unop op)]) ↪ $ (S', T')]

The problem here is that,
the substructure [ainstrs] could take a step...
when it's not, it would be a result
- either it's trap, then we trap
- or it's a value, then we can possibly take a step

meaning we need a induction hypothesis on HVAIS here.
       *)
Abort.


Require Import Coqlib.
Require Import Asm.
Require Import PeekTactics.
Require Import PeepsLib.
Require Import PregTactics.
Require Import StepIn.
Require Import AsmBits.
Require Import Values.
Require Import ValEq.
Require Import Integers.
Require Import PeepsTactics.
Require Import StepEquiv.
Require Import Globalenvs.
Require Import Memory.
Require Import MemEq.
Require Import MemoryAxioms.
Require Import UseBasic.

(*TODO: Replace with newer version*)
Ltac prep_r :=
  T0 _destruct state_bits;
    NP0 app_new step_fwd_exec step_fwd; eauto;
  repeat break_and;
  P0 _clear step_through;
  P0 _clear step_fwd;
  P0 _clear current_fn;
  NP app_new mem_eq_match_metadata_r MemEq.mem_eq.

Ltac step_l :=
    NP1 app_new step_through_current_instr step_through;
    NP1 app_new step_through_current_fn step_through; [ | simpl; eauto ];
    (step_l_str || step_l_jmp);
    break_and; compute_skipz; P1 _simpl step_through; try break_and;
    NP1 app_new step_fwd_transf_block step_fwd.

Definition aiken_3_example :=
            Ptest_rr ECX ECX ::
            Pjcc Cond_e xH ::
            Pmov_rr ECX EDX ::
            Plabel xH ::
            Pnop ::
            nil.

Section AIKEN_3.

  Variable concrete : code.
  Variable r2 : ireg.
  Variable r3 : ireg.
  Variable r4 : ireg.
  Variable l : label.
  Hypothesis r2_r3_neq : r2 <> r3.
  Hypothesis r2_r4_neq : r2 <> r4.
  Hypothesis r3_r4_neq : r3 <> r4.

  Definition aiken_3_defs : rewrite_defs :=
    {|
      fnd :=
        (* test %ecx, %ecx *)
        (* je .l *)
        (* mov %edx, %ebx *)
        (* .l:         *)
                Ptest_rr r3 r3 ::
                Pjcc Cond_e l ::
                Pmov_rr r2 r4 ::
                Plabel l ::
                Pnop ::
                nil
      ; rpl :=
          (* test %ecx, %ecx *)
          (* cmovne %edx, %ebx           *)
                  Ptest_rr r3 r3 ::
                  Pcmov Cond_ne r2 r4 ::
                  Pnop ::
                  Pnop ::
                  Pnop ::
                  nil
      ; lv_in := PC :: IR r2 :: IR r3 :: IR r4 :: nil
      ; lv_out := PC :: IR r4 :: IR r2 :: nil
      ; clobbered := flags
    |}.

  Lemma aiken_3_selr:
    StepEquiv.step_through_equiv_live (fnd aiken_3_defs) (rpl aiken_3_defs) (lv_in aiken_3_defs) (lv_out aiken_3_defs).
  Proof.
    prep_l.
    step_l.
    step_l.
    {
      step_l.
      prep_r.
      step_r.
      prep_exec_instr.
      simpl.
      repeat break_match; eauto.
      repeat break_exists.
      step_r.
      step_r.
      step_r.
      step_r.
      assert (x6 = md').
      {
        specialize (H23 x3).
        simpl_and_clear.
      }
      subst x6.
      finish_r.

      P0 _clear step_through;
        P0 _clear at_code;
        P0 _clear at_code_end;
        P0 _clear not_after_label_in_code;
        P0 _clear st_rs;
        inv_state;
        P0 bump val_eq;
        P0 bump exec_instr_bits.
      specialize (H24 x5).
      repeat clear_dup.
      unfold exec_instr_bits in *.
      remember r1 as cond_l_rs.
      remember (eval_testcond Cond_e cond_l_rs) as cond_l.
      remember ((nextinstr
               (compare_ints (Val.and (rsr r3) (rsr r3)) Vzero rsr mr))) as cond_r_rs.
      remember (eval_testcond Cond_ne cond_r_rs) as cond_r.
      Ltac gentle_inv_next :=
        match goal with
          | [H: Nxt _ _ _ = Nxt _ _ _ |- _] => inversion H; clear H
        end.
      repeat gentle_inv_next.
      subst m0. subst m1.
      exploit (eval_testcond_match cond_l_rs cond_r_rs Cond_e);
        try solve [
              subst;
              subst r1;
              try eapply val_eq_nextinstr;
              try eapply val_eq_compare_ints;
              try eapply val_eq_and;
              simpl;
              try assumption;
              try reflexivity;
              eauto 8 ].
      intro.
      unfold jumps_to_label in *.
      rewrite H28 in H31.
      break_match_lem H31.
      break_if.
      2: inv_false.
      2: inv_false.
      clear_taut.
      subst cond_l.
      break_or'.
      congruence.
      symmetry in H11.
      eapply eval_testcond_e_neg in H11.
      Focus 2.
      subst.
      clear -H11.
      unfold eval_testcond in *.
      simpl_match_hyp.
      inv_some.
      left.
      apply PtrEquiv.int_eq_true in H0.
      subst. unfold Vtrue.
      reflexivity.

      subst cond_r.
      collapse_match_hyp.
      P1 _simpl negb.
      gentle_inv_next.
      subst x4.
      unfold goto_label_bits in *.
      simpl_match_hyp.
      gentle_inv_next.
      subst m.
      P0 _clear current_instr.
      subst b0.
      subst a1.
      subst a0.

      split.
      2: eq_mem_tac.
      intros.
      repeat break_or_reg.
      + subst.
        preg_simpl.
        repeat find_rewrite_goal.
        simpl.
        preg_simpl_hyp H41.
        preg_simpl_hyp H42.
        P0 _clear current_block.
        P0 _clear no_ptr_regs.
        simpl in *.
        rewrite H40 in H41.
        inv_vint.
        rewrite H2 in H41.
        simpl in H41.
        inv_vint.
        f_equal.
        ring.
      + subst.
        subst r1.
        preg_simpl.
        assumption.
      + subst.
        subst r1.
        preg_simpl.
        assumption.
    }
    {
      step_l.
      step_l.
      step_l.
      prep_r.
      step_r.
      prep_exec_instr.
      simpl.
      repeat break_match; eauto.
      repeat break_exists.
      step_r.
      step_r.
      step_r.
      step_r.
      assert (x6 = md').
      {
        specialize (H23 x3).
        simpl_and_clear.
      }
      subst x6.
      finish_r.

      P0 _clear step_through;
        P0 _clear at_code;
        P0 _clear at_code_end;
        P0 _clear not_after_label_in_code;
        P0 _clear st_rs;
        P0 _clear current_block;
        P0 _clear no_ptr_regs;
        P0 _clear no_ptr_mem;
        P0 _clear match_metadata;
        P0 _clear global_perms;
        inv_state;
        P0 bump val_eq;
        P0 bump exec_instr_bits.
      specialize (H14 x5).
      repeat clear_dup.
      unfold exec_instr_bits in *.
      remember r6 as cond_l_rs.
      remember (eval_testcond Cond_e cond_l_rs) as cond_l.
      remember ((nextinstr
               (compare_ints (Val.and (rsr r3) (rsr r3)) Vzero rsr mr))) as cond_r_rs.
      remember (eval_testcond Cond_ne cond_r_rs) as cond_r.
      repeat gentle_inv_next.
      subst m2. subst m3. subst m0. subst m1.
      subst a3 a0 a1 a2.
      exploit (eval_testcond_match cond_l_rs cond_r_rs Cond_e);
        try solve [
              subst;
              subst r6;
              try eapply val_eq_nextinstr;
              try eapply val_eq_compare_ints;
              try eapply val_eq_and;
              simpl;
              try assumption;
              try reflexivity;
              eauto 8 ].
      intro.

      unfold jumps_to_label in *.
      rewrite H28 in H31.
      assert (cond_l = Some false \/ cond_l = None).
      {
        break_match_lem H31.
        break_if.
        congruence.
        left.
        congruence.
        right.
        congruence.
      }
      clear H31.

      break_or'.
      - subst cond_l.
        rewrite H21 in H5.
        gentle_inv_next.
        subst m.
        clear H10.
        break_or'.
        congruence.
        symmetry in H5.
        rewrite H21 in H5.
        eapply eval_testcond_e_neg in H5.
        Focus 2.
        subst.
        clear -H5 H0 H1 H6.
        unfold compare_ints.
        preg_simpl.
        unfold Val.cmpu.
        unfold Val.of_optbool.
        unfold eval_testcond in *.

        simpl_match_hyp.
        inv_some.
        preg_simpl_hyp Heqv.
        unfold Val.cmpu in *.
        unfold Val.of_optbool in *.
        break_match.
        break_if; auto.
        congruence.

        subst cond_r.
        collapse_match_hyp.
        P1 _simpl negb.
        gentle_inv_next.
        subst x4.
        P0 _clear current_instr.

        split.
        2: eq_mem_tac.
        intros.
        repeat break_or_reg.
        + subst.
          preg_simpl.
          repeat find_rewrite_goal.
          simpl.
          reflexivity.
        + subst.
          subst r6.
          preg_simpl.
          assumption.
        + subst.
          subst r6.
          preg_simpl.
          assumption.
      - subst cond_l.
        rewrite H21 in H5.
        congruence.
    }
  Qed.

  Definition aiken_3_proofs : rewrite_proofs :=
    {|
      defs := aiken_3_defs
      ; selr := aiken_3_selr
    |}.

  Definition peep_aiken_3 :
    concrete = fnd aiken_3_defs ->
    StepEquiv.rewrite.
  Proof.
    intros.
    peep_tac_mk_rewrite aiken_3_defs aiken_3_proofs.
  Qed.

End AIKEN_3.

Definition aiken_3_rewrite (c : code) : option StepEquiv.rewrite.
  name peep_aiken_3 p.
  unfold aiken_3_defs in p.
  simpl in p.
  specialize (p c).
  do 5 set_code_cons c.
  set_code_nil c.
  set_instr_eq i 0%nat aiken_3_example.
  set_instr_eq i0 1%nat aiken_3_example.
  set_instr_eq i1 2%nat aiken_3_example.
  set_instr_eq i2 3%nat aiken_3_example.
  set_instr_eq i3 4%nat aiken_3_example.
  rename_all label lb.
  rename_all ireg a.
  set_testcond_eq c Cond_e.
  set_label_eq lb0 lb.
  set_ireg_eq a2 a1.
  set_ireg_neq a0 a.
  specialize (p a0 a1 a lb n eq_refl).
  exact (Some p).
Defined.

Definition aiken_3 (c : code) : list StepEquiv.rewrite :=
  collect (map aiken_3_rewrite (ParamSplit.matched_pat aiken_3_example c)).