Set Warnings "-notation-overridden,-parsing".
From Coq Require Import Bool.Bool Init.Nat Arith.Arith Arith.EqNat
     Init.Datatypes Strings.String Program Logic.FunctionalExtensionality.
Require Export Coq.Strings.String.
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype seq fintype ssrnat ssrfun.
From TLC Require Import LibTactics LibLogic.
From Coq_intermittent Require Export programs semantics algorithms lemmas_1
     lemmas_0 proofs_0 proofs_n proofs_d.

(*weaker version of all_diff_in_fw where the requireement that
 the program can make it up till a checkpoint or termination is omitted*)
Inductive all_diff_in_fww: nvmem -> vmem -> command -> nvmem -> Prop :=
  Diff_in_FWw: forall{N1 V1 c1 N2 V2 c2 N1c O W} (T: trace_cs (N1, V1, c1) (N2, V2, c2) O W),
    checkpoint \notin O ->
( forall(l: loc ), ((getmap N1) l <> (getmap N1c) l) -> (l \in getfstwt W))
-> all_diff_in_fww N1 V1 c1 N1c.

 Lemma add_skip_ins_w {N1 V l N2}: all_diff_in_fww N1 V (Ins l) N2 ->
                                 all_diff_in_fww N1 V (l;; skip) N2.
   intros Hdiff. inversion Hdiff; subst.
   inversion T; subst.
   -
     econstructor; try eapply CsTrace_Empty; try by [].
     econstructor. eapply CsTrace_Single.
     move: (cceval_skip H1) => eq. subst.
     eapply Seq; try apply H1; try by []; try assumption. intros w contra. subst. inversion H1.
     intros contra. subst. inversion H1. assumption.
     assumption.
     destruct Cmid as [ [nm vm] cm].
     move: (cceval_skip H3) => eq. subst.
     econstructor. eapply CsTrace_Single.
     eapply Seq; try apply H3; try by []; try assumption. intros w contra. subst. inversion H3.
     intros contra. subst. inversion H3.
     rewrite mem_cat in H. move/ norP: H => [Ho1 Ho2].
     assumption.
     suffices: W2 = emptysets. move => eq. subst.
     rewrite append_write_empty in H0.
     assumption.
     move: (trace_skip H1) => Heq. subst.
       by move/empty_trace_cs1: H1 => [one two].
     Qed.

 Lemma agreeonread_ins_w_r: forall{N Nend N2: nvmem} {V Vend: vmem}
                        {l: instruction} {crem c1: command}
                   {O : obseq} {W: the_write_stuff},
  all_diff_in_fww N V (l;;crem) N2 ->
             cceval_w (N2, V, Ins l) O (Nend, Vend, c1) W ->
             ( forall(z: loc), z \in (getrd W) ->
                                (getmap N2) z = (getmap N) z).
      intros. inversion H; subst. apply/ eqP /negPn /negP.
        rename H1 into Hread.
      intros contra.
      move/ eqP: contra => contra. apply not_eq_sym in contra.
      apply (H3 z) in contra.
      destruct (O0 == [::]) eqn: Hbool.
      - move/eqP : Hbool => Heq. subst.
        move: (empty_trace_cs1 T) => [ [one two] three four].
        subst. discriminate contra.
      - move/ negbT /eqP : Hbool => Hneq.
        move: (single_step_alls_rev T Hneq) =>
        [Cmid [W1 [Wrest [O1 [Hcceval [Hsubseq Hw] ] ] ] ] ].
        subst.
        simpl in contra.
        inversion Hcceval; subst.
        destruct Hsubseq as [Orest Hsub].
        rewrite Hsub mem_cat in H2.
        move/norP : H2 => [contra1 H111].
        move/ negP: contra1. by apply.
        inversion H0; subst.
        move: (cceval_agr H0 H12) => Heqrd.
        rewrite Heqrd in Hread.
        move: (fw_nin_r_c z H12 Hread) => Hfw.
        rewrite mem_cat in contra.
        move/orP : contra => [contra1 | contra2].
        rewrite mem_filter in contra1.
        move/ andP : contra1  => [one two].
        move/negP : one. by apply.
        move/negP : Hfw. by apply.
    Qed.

    Lemma agreeonread_ins_w_l: forall{N Nend N2: nvmem} {V Vend: vmem}
                        {l: instruction} {crem c1: command}
                   {O : obseq} {W: the_write_stuff},
  all_diff_in_fww N V (l;;crem) N2 ->
             cceval_w (N, V, Ins l) O (Nend, Vend, c1) W ->
             ( forall(z: loc), z \in (getrd W) ->
                                (getmap N) z = (getmap N2) z).
      intros. inversion H; subst. apply/ eqP /negPn /negP.
        rename H1 into Hread.
      intros contra.
      move/ eqP: contra => contra.
      apply (H3 z) in contra.
      destruct (O0 == [::]) eqn: Hbool.
      - move/eqP : Hbool => Heq. subst.
        move: (empty_trace_cs1 T) => [ [one two] three four].
        subst. discriminate contra.
      - move/ negbT /eqP : Hbool => Hneq.
        assert (cceval_w (N, V, l;; crem) O (Nend, Vend, crem) W) as Hcceval.
        move: (single_step_alls_rev T Hneq). =>
        [Cmid [W1 [Wrest [O1 [Hcceval [Hsubseq Hw] ] ] ] ] ].
        inversion Hcceval; subst.
        destruct Hsubseq as [Orest Hsub].
        rewrite Hsub mem_cat in H2.
        move/norP : H2 => [contra1 H111]. exfalso.
        move/ negP: contra1. by apply.
        inversion H0; subst.
        move: (determinism_c H0 H12) => [one [two three] ].
        inversion one. subst.
        assumption.
        move: (single_step_alls T Hneq Hcceval). =>
        [W1 [O1 [Trem [Hsub Heq] ] ] ].
        rewrite Heq in contra. unfold append_write in contra.
        simpl in contra.
        move: (fw_nin_r_c z Hcceval Hread) => Hfw.
        rewrite mem_cat in contra.
        move/orP : contra => [contra1 | contra2].
        rewrite mem_filter in contra1.
        move/ andP : contra1  => [one two].
        move/negP : one. by apply.
        move/negP : Hfw. by apply.
        Qed.

 Lemma agreeonread_w_r: forall{N Nend N2: nvmem} {V Vend: vmem}
                        {c c1: command}
                   {O : obseq} {W: the_write_stuff},
  all_diff_in_fww N V c N2 ->
             cceval_w (N2, V, c) O (Nend, Vend, c1) W ->
            ( forall(z: loc), z \in (getrd W) ->
                   (getmap N2) z = (getmap N) z).
   intros. move: H H0 H1 => Hdiff Hcc Hr. dependent induction c.
   apply add_skip_ins_w in Hdiff.
   eapply agreeonread_ins_w_r; try apply Hdiff; try apply Hcc; try assumption.
   inversion Hcc; subst; try( rewrite in_nil in Hr; discriminate Hr).
   eapply agreeonread_ins_w_r; try apply Hdiff; try apply H10; try assumption.
   inversion Hdiff; subst.
   apply/eqP /negPn/ negP. intros contra. move/eqP: contra => contra.
   apply not_eq_sym in contra. apply (H0 z) in contra.
      destruct (O0 == [::]) eqn: Hbool; move/eqP : Hbool => Heq; subst.
      -
        move: (empty_trace_cs1 T) => [ [one two] three four].
        subst. discriminate contra.
      -
        move: (single_step_alls_rev T Heq) =>
        [Cmid [W1 [Wrest [O1 [Hcceval [Hsubseq Hw] ] ] ] ] ].
        move: (cceval_agr Hcceval Hcc) => Hww.
        rewrite Hw in contra.
        unfold append_write in contra. simpl in contra. rewrite Hww in contra. rewrite - Hww in Hr.
        move: (fw_nin_r_c z Hcceval Hr) => Hfw.
        rewrite mem_cat in contra.
        move/ orP : contra. => [con1 | con2].
        rewrite mem_filter in con1. move/andP: con1 => [con11 con12]. move/ negP: con11. apply. by rewrite - Hww.
        move/ negP: Hfw. by apply.
    Qed.

 Lemma agreeonread_w_l: forall{N Nend N2: nvmem} {V Vend: vmem}
                        {c c1: command}
                   {O : obseq} {W: the_write_stuff},
  all_diff_in_fww N V c N2 ->
             cceval_w (N, V, c) O (Nend, Vend, c1) W ->
            ( forall(z: loc), z \in (getrd W) ->
                   (getmap N) z = (getmap N2) z).
   intros. move: H H0 H1 => Hdiff Hcc Hr. dependent induction c.
   apply add_skip_ins_w in Hdiff.
   eapply agreeonread_ins_w_l; try apply Hdiff; try apply Hcc; try assumption.
   inversion Hcc; subst; try( rewrite in_nil in Hr; discriminate Hr).
   eapply agreeonread_ins_w_l; try apply Hdiff; try apply H10; try assumption.
   inversion Hdiff; subst.
   apply/eqP /negPn/ negP. intros contra. move/eqP: contra => contra.
   apply (H0 z) in contra.
      destruct (O0 == [::]) eqn: Hbool; move/eqP : Hbool => Heq; subst.
      -
        move: (empty_trace_cs1 T) => [ [one two] three four].
        subst. discriminate contra.
      -
        move: (single_step_alls T Heq Hcc). =>
        [Wrest [Orest [Trest [Hsubseq Hw] ] ] ].
        rewrite Hw in contra.
        unfold append_write in contra. simpl in contra.
        move: (fw_nin_r_c z Hcc Hr) => Hfw.
        rewrite mem_cat in contra.
        move/ orP : contra. => [con1 | con2].
        rewrite mem_filter in con1. move/andP: con1 => [con11 con12]. move/ negP: con11. by apply.
        move/ negP: Hfw. by apply.
    Qed.

 Lemma same_com_hcbc {N N1 Nend1 V V1 l crem O W c1} : all_diff_in_fww N V (l;;crem) N1 ->
                              cceval_w (N1, V, Ins l) O (Nend1, V1, c1) W ->
                              exists(Nend: nvmem), (cceval_w (N, V, Ins l) O (Nend, V1, c1) W) /\
 forall(l: loc), l \in (getwt W) -> ((getmap Nend) l = (getmap Nend1) l).
   intros Hdiff Hcceval1.
move: (agreeonread_ins_w_r Hdiff Hcceval1) => agr.
      dependent induction Hcceval1; simpl in agr.
      - exists (updateNV_sv N x v). split. apply NV_Assign; try assumption.
        eapply agr_imp_age; try apply H; try assumption.
        simpl. intros l Hin. rewrite mem_seq1 in Hin.
        move/ eqP : Hin => Hin. subst.
        destruct N as [Nmap ND].
        destruct N1 as [N1map N1D].
        unfold updateNV_sv. unfold updatemap. simpl.
        destruct (v == error) eqn: Hbool. simpl in agr.
        move/ eqP: Hbool => Heq. subst. inversion H1.
        remember (inl x) as xloc.
        suffices: (if xloc == xloc then v else Nmap xloc) = v /\
                  (if xloc == xloc then v else N1map xloc) = v.
        move => [one two].
          by rewrite one two.
        split; by apply ifT.
     - exists N. split. apply V_Assign; try assumption.
       eapply agr_imp_age; try apply H; try assumption.
       simpl. move => l contra.
        rewrite in_nil in contra. by exfalso.
     - exists (updateNV_arr N element a v). split. eapply Assign_Arr.
       eapply agr_imp_age; try apply H; try assumption.
       intros z Hin.
       suffices: (z \in readobs_wvs (r ++ ri)).
       move => Hin1.
         by apply (agr z).
         rewrite readobs_app_wvs.
         by eapply in_app_r.
       eapply agr_imp_age; try apply H0; try assumption.
       intros z Hin.
       suffices: (z \in readobs_wvs (r ++ ri)).
       move => Hin1.
         by apply (agr z).
         rewrite readobs_app_wvs.
           by eapply in_app_l. assumption. assumption.
           simpl.
           intros l Hin.
        destruct N as [Nmap ND].
        destruct N1 as [N1map N1D].
        unfold updateNV_arr. simpl.
        rewrite mem_seq1 in Hin. move/ eqP : Hin => Hin. subst.
        unfold updatemap.
        suffices:
          ((if inr element == inr element then v else Nmap (inr element)) = v
                                                                              /\
  (if inr element == inr element then v else N1map (inr element)) = v).
        move => annoying.
        move: (annoying loc_eqtype loc_eqtype) => [one two].
        destruct (v == error) eqn: Hbool.
        move/ eqP: Hbool => three. subst. inversion H1.
          by rewrite one two.
          intros. split; by apply ifT.
          Qed.

Lemma trace_converge_minus1w {N V N' Nmid Vmid Nmid'
                            O W} {l: instruction}:
  all_diff_in_fww N V l N' ->
  cceval_w (N, V, Ins l) O (Nmid, Vmid, Ins skip) W ->
  cceval_w (N', V, Ins l) O (Nmid', Vmid, Ins skip) W ->
  Nmid = Nmid'.
  move => Hdiff Hcceval1 Hcceval2.
  inversion Hdiff. subst.
dependent induction T.
-
  suffices: N2 = N'. move => Heq. subst.
  move: (determinism_c Hcceval1 Hcceval2). =>
  [ one two]. inversion one. by subst.
  simpl in H0. apply nvmem_eq. intros z.
  apply/eqP/ negPn /negP. intros contra.
  move/ eqP : contra => contra. apply H0 in contra.
  discriminate contra.
-
  apply nvmem_eq. intros z.
  move: (same_com_hcbc (add_skip_ins_w Hdiff) Hcceval2).
  => [Nend [Hcceval3 Hloc] ].
  move: (determinism_c Hcceval3 Hcceval1) => [one [two three] ]. inversion one. subst.
  destruct (z \in (getwt W)) eqn:Hbool.
  by apply (Hloc z) in Hbool.
  suffices: (getmap N) z = (getmap N') z.
  move => Heq.
  apply (connect_mems Hcceval1 Hcceval2 (negbT Hbool) Heq).
  move: (determinism_c H Hcceval1). => [eq0 [eq1 eq2] ]. inversion eq0. subst.
  apply/eqP /negPn /negP. intros contra.
  move/ eqP / (H1 z) : contra => contra.
  apply (in_subseq (fw_subst_wt_c Hcceval1)) in contra.
  rewrite Hbool in contra. discriminate contra.
  destruct Cmid as [ [nm vm] cm]. move: (cceval_skip H0) => Heq. subst. apply trace_skip in T. exfalso. by apply H.
Qed.

 Lemma same_com_hc {N N1 V c Nend2 V1 c1 O W}:
  all_diff_in_fww N V c N1 ->
  cceval_w (N1, V, c) O (Nend2, V1, c1) W -> (*use that W2 must be a subset of W*)
  checkpoint \notin O ->
  exists (Nend1: nvmem), cceval_w (N, V, c) O (Nend1, V1, c1) W
                             /\ all_diff_in_fww Nend1 V1 c1 Nend2.
    intros Hdiff Hcceval1 Ho.
   induction c.
  - move: (same_com_hcbc (add_skip_ins_w Hdiff) Hcceval1). => [Nend [Hcceval Hloc] ].
    exists Nend. split; try assumption.
    move: (cceval_skip Hcceval1) => Heq. subst.
    pose proof (trace_converge_minus1w Hdiff Hcceval Hcceval1). subst.
    econstructor; try reflexivity.
    apply (CsTrace_Empty (Nend2, V1, Ins skip)).
      by rewrite in_nil.
      move => l0 contra. exfalso. by apply contra.
  - inversion Hcceval1; subst.
    + exfalso. move/negP : Ho. by apply.
    + exists N. split. apply Skip.
      inversion Hdiff; subst.
      destruct (O == [::]) eqn: Hbool.
       - move/ eqP : Hbool => Hbool. subst.
      apply empty_trace_cs1 in T. move: T =>
                                  [ [one two ] three four].
      subst.
      econstructor; try apply CsTrace_Empty; try assumption.
      auto.
       - move/ negbT / eqP : Hbool => Hneq.
         move: (single_step_alls_rev T Hneq). => [
                                                Cmid [W1
                                                [Wrest1 [O1
                                                     [Hcceval
                                                        [Hsubseq1 Hwrite1] ] ] ] ] ].
         inversion Hcceval; subst.
         move: (single_step_alls T Hneq Hcceval). =>
                                                  [Wrest [Orest [Trest [Hsubseq Hwrite] ] ] ].
         rewrite append_write_empty_l in H0.
         repeat rewrite append_write_empty_l in Hwrite. subst.
         econstructor; try apply Trest; try assumption.
       exfalso. by apply H9.
         + move: (same_com_hcbc Hdiff H10). => [Nend [ Hcceval Hloc] ].
           exists Nend. split.
       apply Seq; try assumption.
       inversion Hdiff; subst.
      destruct (O0 == [::]) eqn: Hbool.
       - move/ eqP : Hbool => Hbool. subst.
      apply empty_trace_cs1 in T. move: T =>
                                  [ [one two ] three four].
      subst.
      suffices: (getmap N2) =1 (getmap N1). move/nvmem_eq => H500. subst.
      move: (determinism_c H10 Hcceval) => [ [one two] ]. subst.
      econstructor; try apply CsTrace_Empty; try assumption.
      by [].
      intros l0. apply/ eqP /negPn /negP. intros contra.
      move/ eqPn / (H0 l0) : contra.
      by rewrite in_nil. auto.
       - move/ negbT / eqP : Hbool => Hneq.
         suffices: cceval_w (N, V, l;;c1) O (Nend, V1, c1) W.
         move => Hccevalbig.
move: (single_step_alls T Hneq Hccevalbig). => [Wrest [Orest
                                                     [Trest
                                [Hsubseq Hwrite] ] ] ].
       econstructor; try apply Trest; try assumption.
       apply/negP. intros contra.
       apply/negP / negPn: H.
       rewrite Hsubseq. rewrite/ orP mem_cat. apply/orP. by right.
           intros l0 Hl0. remember Hl0 as Hneql.
           clear HeqHneql.
           suffices: getmap Nend l0 <> getmap Nend2 l0 -> l0 \notin getwt W.
           intros Hlocc. apply Hlocc in Hl0.
           suffices: (l0 \in getfstwt W0).
           intros Hfw.
           subst. move/ fw_split : Hfw => [one | two].
           apply (in_subseq (fw_subst_wt_c Hcceval
                 )) in one.
           exfalso. move/ negP : Hl0. by apply.
             by move: two => [whatever done].
             apply H0.
             move: (update_one_contra l0 Hcceval Hl0) => Heq1.
             move: (update_one_contra l0 Hcceval1 Hl0) => Heq2.
             by rewrite Heq1 Heq2.
             clear Hneq. intros Hneq. apply/negP. intros contra.
             apply Hneq. by apply Hloc.
             apply Seq; try assumption.
         + inversion Hcceval1; subst; exists N; inversion Hdiff; subst;
           destruct (O == [::]) eqn: Hbool.
          -  move/ eqP : Hbool => Hbool. subst.
      apply empty_trace_cs1 in T. move: T =>
                                  [ [one two ] three four].
      subst.
      suffices: (getmap N2) =1 (getmap Nend2). move/nvmem_eq => H500. subst. split; try assumption.
      econstructor; try apply CsTrace_Empty; try assumption.
      intros l0. apply/ eqP /negPn /negP. intros contra.
      move/ eqPn / (H0 l0) : contra.
      by rewrite in_nil. auto.
          - move/ negbT / eqP : Hbool => Hneq.
            move: (agreeonread_w_r Hdiff Hcceval1) => agr.
            move: (agr_imp_age H9 agr) => Heval.
            split.
           apply If_T; try assumption.
         move: (single_step_alls_rev T Hneq). => [
                                                Cmid [W1
                                                [Wrest1 [O1
                                                     [Hcceval
                                                        [Hsubseq1 Hwrite1] ] ] ] ] ].
       move: (single_step_alls T Hneq Hcceval). => [Wrest [Orest
                                                     [Trest
                                                        [Hsubseq Hwrite] ] ] ].
       destruct Cmid as [ [Nmid Vmid] cmid].
       inversion Hcceval; subst.
       econstructor; try apply Trest; try assumption.
         destruct Wrest1 as [ [w1 w2 ] w3].
         destruct Wrest as [ [wr1 wr2] wr3]. inversion Hwrite.

         repeat rewrite cats0 in H2.
         repeat rewrite cats0 in H4.
         intros l Hneql.
         simpl.
         apply H0 in Hneql. subst. simpl in Hneq.
         unfold append_write in Hneql.
         simpl in Hneql. rewrite cats0 in Hneql.
         rewrite H4 in Hneql.
         rewrite mem_filter in Hneql.
           by move/ andP : Hneql => [one two].
           move: (determinism_e H12 Heval) => [one two].
           inversion two.
          -  move/ eqP : Hbool => Hbool. subst.
      apply empty_trace_cs1 in T. move: T =>
                                  [ [one two ] three four].
      subst.
      suffices: (getmap N2) =1 (getmap Nend2). move/nvmem_eq => H500. subst. split; try assumption.
      econstructor; try apply CsTrace_Empty; try assumption.
      intros l0. apply/ eqP /negPn /negP. intros contra.
      move/ eqPn / (H0 l0) : contra.
      by rewrite in_nil. auto.
          - move/ negbT / eqP : Hbool => Hneq.
            move: (agreeonread_w_r Hdiff Hcceval1) => agr.
            move: (agr_imp_age H9 agr) => Heval.
            split.
           apply If_F; try assumption.
         move: (single_step_alls_rev T Hneq). => [
                                                Cmid [W1
                                                [Wrest1 [O1
                                                     [Hcceval
                                                        [Hsubseq1 Hwrite1] ] ] ] ] ].
       move: (single_step_alls T Hneq Hcceval). => [Wrest [Orest
                                                     [Trest
                                                        [Hsubseq Hwrite] ] ] ].
       destruct Cmid as [ [Nmid Vmid] cmid].
       inversion Hcceval; subst.
           move: (determinism_e H12 Heval) => [one two].
           inversion two.
       econstructor; try apply Trest; try assumption.
         destruct Wrest1 as [ [w1 w2 ] w3].
         destruct Wrest as [ [wr1 wr2] wr3]. inversion Hwrite.

         repeat rewrite cats0 in H2.
         repeat rewrite cats0 in H4.
         intros l Hneql.
         simpl.
         apply H0 in Hneql. subst. simpl in Hneq.
         unfold append_write in Hneql.
         simpl in Hneql. rewrite cats0 in Hneql.
         rewrite H4 in Hneql.
         rewrite mem_filter in Hneql.
           by move/ andP : Hneql => [one two].
Qed.

  Lemma same_com_help {N N1 V c Nend2 Vend cend O W}:
  all_diff_in_fww N V c N1 ->
  trace_cs (N1, V, c) (Nend2, Vend, cend) O W ->
  checkpoint \notin O ->
  exists (Nend1: nvmem), trace_cs (N, V, c) (Nend1, Vend, cend) O W
  .
    intros. move: N H.
    dependent induction H0; intros N Hdiff.
    + exists N. apply CsTrace_Empty.
    + move: (same_com_hc Hdiff H H1) => [Nend1 [done blah] ].
      exists Nend1. by apply CsTrace_Single.
    + destruct Cmid as [ [Nmid Vmid] cmid].
      rewrite mem_cat in H2. move/norP : H2 => [Ho1 Ho2].
      move: (same_com_hc Hdiff H1 Ho1) => [Nendm [Tm Hdiffm] ].
      suffices: exists Nend1,
               trace_cs (Nendm, Vmid, cmid)
                        (Nend1, Vend, cend) O2 W2.
      move => [Nend1 Tend].
      exists Nend1. eapply CsTrace_Cons; try apply Tend; try assumption.
      eapply IHtrace_cs; try reflexivity; try assumption.
Qed.

Lemma war_cceval: forall{N0 N Nmid: nvmem} {V Vmid: vmem} {c cmid: command}
                   {l: instruction}
                   {O: obseq} {W: the_write_stuff} {Wstart Rstart W' R': warvars},

        cceval_w (N, V, l;;c) O (Nmid, Vmid, cmid) W ->
        WAR_ins (getdomain N0) Wstart Rstart l W' R' ->
        (subseq ((getwt W) ++ Wstart)  W')
          /\ get_smallvars ((getwt W) ++ Wstart) = (get_smallvars W')
          /\ (R' =  (getrd W) ++ Rstart).
    intros. move: H H0 => Hcceval Hwar.
    dependent induction Hwar.
    -  inversion Hcceval; subst. split; try split; try by []. exfalso. by apply H9.
    - inversion Hcceval; subst. move: (extract_write_svv H13 H0) => Heq.
      rewrite Heq. split; try split; try by [].
      inversion H13; subst; pose proof (read_deterministic H (RD H10));
        subst; split; reflexivity.
    -inversion Hcceval; subst. move: (extract_write_svnv H13 H) => Heq.
    rewrite Heq. split; try split; try by []. inversion H13; subst;
    pose proof (read_deterministic H0 (RD H10));
    subst; split; reflexivity.
 - inversion Hcceval; subst. move: (extract_write_svnv H15 H0) => Heq.
    rewrite Heq. inversion H15; subst;
    move: (read_deterministic H (RD H12)) => Heq1; subst;
    split; try split; try by [].
 - inversion Hcceval; subst. move: (extract_write_svnv H14 H2) => Heq.
    rewrite Heq. inversion H14; subst;
    move: (read_deterministic H (RD H11)) => Heq1; subst;
                                              split; try split; try by [].

 - inversion Hcceval; subst; inversion H13; subst.
   split; try split. simpl.
   rewrite - cat1s. apply cat_subseq.
   rewrite sub1seq.
   destruct element as [a0 index0]. eapply gen_locs_works.
   apply H17. auto. Opaque get_smallvars. simpl.
   rewrite (sv_add_el W0 W0); try auto.
   symmetry. rewrite (sv_add_arr W0 W0 a); try auto.
   simpl.
   rewrite readobs_app_wvs. rewrite catA.
   move: (read_deterministic H (RD H15)) => Heq1.
   move: (read_deterministic H0 (RD H14)) => Heq2.
   by subst.
 - inversion Hcceval; subst; inversion H14; subst.
   split; try split. simpl.
   rewrite - cat1s. apply cat_subseq.
   rewrite sub1seq.
   destruct element as [a0 index0]. eapply gen_locs_works.
   apply H18. auto.
   Opaque get_smallvars. simpl.
   rewrite (sv_add_el W0 W0); try auto.
   symmetry. rewrite (sv_add_arr W0 W0 a); try auto.
   simpl. rewrite readobs_app_wvs. rewrite catA.
   pose proof (read_deterministic H (RD H16)).
   pose proof (read_deterministic H0 (RD H15)).
   by subst.
Qed.

Lemma agsv_war_bc {w W1 W2 R l W' R'}:
             WAR_ins w W1 R l W' R' ->
       (get_smallvars W2) = (get_smallvars W1) ->
       exists(W2': warvars), WAR_ins w W2 R l W2' R' /\
       (get_smallvars W2') = (get_smallvars W').

      intros.
      inversion H; subst.
      - exists W2; split. eapply WAR_Skip. assumption.
      - exists W2. split; try assumption. eapply WAR_Vol; try assumption.
        by apply (agsv_war_h W' W2).
      - exists(inl x :: W2). split.
        eapply WAR_NoRd; try apply H1; try assumption. by apply sv_add_sv.
      - exists(inl x :: W2). split. eapply WAR_Checkpointed; try apply H0; try assumption.
        apply/ negP.
        apply (agsv_war_h W1 W2). assumption. by
            move/negP: H4. by apply sv_add_sv.
      - exists(inl x :: W2). split. eapply WAR_WT; try apply H0; try assumption.
        symmetry in H0.
        apply/ negPn.
        apply (contra (agsv_war_h W2 W1 x H0)).
          by apply/negPn. by apply sv_add_sv.
      - exists(generate_locs a ++ W2). split.
        eapply WAR_NoRd_Arr. apply H1. apply H2. assumption.
        apply sv_add_arr.
        rewrite (sv_add_arr W1 W2 a); try by [].
      -exists(generate_locs a ++ W2). split.
       eapply WAR_Checkpointed_Arr; try apply H0; try apply H1; try assumption.
        apply sv_add_arr.
        rewrite (sv_add_arr W1 W2 a); try by [].
Qed.

 Lemma agsv_war {w W1 W2 R c}:
       WARok w W1 R c ->
       (get_smallvars W2) = (get_smallvars W1) ->
       WARok w W2 R c. intros.
      move: W2 H0.  dependent induction H; intros; simpl.
      - move: (agsv_war_bc H H0) => [W2' Done]. eapply WAR_I. apply Done.
      - eapply WAR_CP; assumption.
      - move: (agsv_war_bc H H1) => [W2' [H21 H22] ].
        eapply WAR_Seq; try assumption.
        apply H21. by apply IHWARok.
     - eapply WAR_If. apply H. by apply IHWARok1. by apply IHWARok2.
Qed.

Lemma warok_partial:  forall{N0 N Nmid: nvmem} {V Vmid: vmem} {c cmid: command} {O: obseq} {W: the_write_stuff} {Wstart Rstart: warvars},
    cceval_w (N, V, c) O (Nmid, Vmid, cmid) W ->
    checkpoint \notin O ->
    WARok (getdomain N0) Wstart Rstart c ->
    WARok (getdomain N0) ((getwt W) ++ Wstart) ((getrd W) ++ Rstart) cmid.
    intros. move: H H0 H1 => Hcceval Ho Hwarok.
    dependent induction Hwarok; simpl.
    - apply cceval_skip in Hcceval. subst. eapply WAR_I. constructor.
    - inversion Hcceval; subst. discriminate Ho.
      exfalso. by apply (H8 w).
   - move: (war_cceval Hcceval H) => [Hsubseq [Hsmallvars Hr] ]. subst. apply cceval_steps in Hcceval. subst.  eapply agsv_war. apply Hwarok. assumption.
 - inversion Hcceval; subst;
    pose proof (read_deterministic H (RD H10));
    subst; assumption.
Qed.

Lemma two_bcw {Ni Ni1 V V1 l c1 crem Nc O W} : all_diff_in_fww Ni V (l;;crem) Nc ->
                              cceval_w (Ni, V, Ins l) O (Ni1, V1, c1) W ->
                              exists(Nc1: nvmem), (cceval_w (Nc, V, Ins l) O (Nc1, V1, c1) W /\
                              forall(l: loc), l \in (getwt W) -> ((getmap Ni1) l = (getmap Nc1) l)).
      intros.
      move: (agreeonread_ins_w_l H H0) => agr.
      dependent induction H0; simpl in agr.
      - exists (updateNV_sv Nc x v). split. apply NV_Assign; try assumption.
        eapply agr_imp_age; try apply H2; try assumption.
        simpl. intros l Hin. rewrite mem_seq1 in Hin.
        move/ eqP : Hin => Hin. subst.
        destruct Ni as [Nimap NiD].
        destruct Nc as [Ncmap NcD].
        unfold updateNV_sv. unfold updatemap. simpl.
        remember (inl x) as xloc.
        suffices: (if xloc == xloc then v else Nimap xloc) = v /\
                  (if xloc == xloc then v else Ncmap xloc) = v.
        move => [one two].
        destruct (v == error) eqn: Hbool.
        move/ eqP : Hbool => Heq. subst. inversion H1.
          by rewrite one two.
        split; by apply ifT.
     - exists Nc. split. apply V_Assign; try assumption.
       eapply agr_imp_age; try apply H2; try assumption.
       simpl. move => l contra.
        rewrite in_nil in contra. by exfalso.
     - exists (updateNV_arr Nc element a v). split. eapply Assign_Arr.
       eapply agr_imp_age; try apply H3; try assumption.
       intros z Hin.
       suffices: (z \in readobs_wvs (r ++ ri)).
       move => Hin1.
         by apply (agr z).
         rewrite readobs_app_wvs.
         by eapply in_app_r.
       eapply agr_imp_age; try apply H0; try assumption.
       intros z Hin.
       suffices: (z \in readobs_wvs (r ++ ri)).
       move => Hin1.
         by apply (agr z).
         rewrite readobs_app_wvs.
           by eapply in_app_l. assumption. assumption.
           simpl.
           intros l Hin.
        destruct Ni as [Nimap NiD].
        destruct Nc as [Ncmap NcD].
        unfold updateNV_arr. simpl.
        rewrite mem_seq1 in Hin.
        move/ eqP : Hin => Hin. subst.
        unfold updatemap.
        suffices:
          ((if inr element == inr element then v else Nimap (inr element)) = v
                                                                              /\
  (if inr element == inr element then v else Ncmap (inr element)) = v).
        move => annoying.
        move: (annoying loc_eqtype loc_eqtype) => [one two].
        destruct (v == error) eqn: Hbool.
        move/ eqP : Hbool => Heq. subst. inversion H1.
          by rewrite one two.
       intros. split; by apply ifT.
Qed.

Lemma war_works_loc_c {N0 N Nend: nvmem} {V Vend: vmem} {c cend: command} {O: obseq} {W: the_write_stuff}
      {Wstart Rstart: warvars}:
    cceval_w (N, V, c) O (Nend, Vend, cend) W ->
    WARok (getdomain N0) Wstart Rstart c ->
    checkpoint \notin O ->
  forall (l: loc),
(l \notin (remove Rstart (getfstwt W)) ->
 l \in (getwt W) ->
       l \in (getdomain N0) \/ l \in Wstart).
  intros Hcceval Hwarok Ho.
  move: Rstart Wstart Hwarok Ho. remember Hcceval as Hcceval1.
  clear HeqHcceval1.
  dependent induction Hcceval1; intros; simpl in H;
    try discriminate H0; try discriminate H1.
  -  remember H3 as Hwt.
    clear HeqHwt.
    simpl in H3. rewrite mem_seq1 in H3.
    move/eqP : H3 => Heq. subst.
   inversion Hwarok; subst; inversion H7;
     subst.
     +  exfalso. apply (negNVandV x H0 H10).
     +
       rewrite mem_cat in H13.
         move / negP / norP : H13 => [Hre Hrs].
         rewrite mem_filter in H2.
         move/nandP: H2. => [contra | H2].
         rewrite Hrs in contra. discriminate contra.
         pose proof (negfwandw_means_r Hcceval H2 Hwt) as Hrd.

         simpl in Hrd.
         move: (read_deterministic H10 (RD H)) => Heq. subst.
         exfalso. move/negP : Hre. by apply.
     +
        by left.
     +
       by right.
     -
       rewrite in_nil in H3.
       discriminate H3.
     -
       remember H4 as Hwt. clear HeqHwt.
       simpl in H4.
       rewrite mem_seq1 in H4. move/ eqP : H4 => Heq. subst.
       inversion Hwarok; subst; inversion H8;
       subst.
       +
           remember (inr element) as l.
           destruct element as [a0 index].
     -
           rewrite mem_filter in H3.
           move/nandP : H3 => [contra | H3].
           unfold intersect in H15. exfalso. apply H15.
            exists l.
           split. subst.
           eapply gen_locs_works. apply H2.
           repeat rewrite mem_cat.
           repeat (apply/ orP; right).
           apply /negPn : contra.
           pose proof (negfwandw_means_r Hcceval H3 Hwt) as Hrd. simpl in Hrd.
       pose proof
            (read_deterministic (RD H0) H11).
       pose proof
            (read_deterministic (RD H) H14).
       subst.
       exfalso.
       apply H15.
       remember (inr (El a0 index)) as l. exists l.
           split. subst.
           eapply gen_locs_works. apply H2.
       rewrite catA.
       rewrite <- readobs_app_wvs.
       rewrite mem_cat.
       apply/ orP. by left.
           +
         destruct element.
             left.
         apply (in_subseq H16 (gen_locs_works H2)).
-
           inversion Hwarok; subst. exfalso. by apply (H w).
           eapply IHHcceval1; try apply Hcceval1;
             try reflexivity;
             try assumption.
           eapply WAR_I; try apply H8; try reflexivity; try assumption. assumption.
           Qed.

Lemma war_works_loc {N0 N Nend: nvmem} {V Vend: vmem} {c cend: command} {O: obseq} {W: the_write_stuff}
      {Wstart Rstart: warvars}:
    trace_cs (N, V, c) (Nend, Vend, cend) O W ->
    WARok (getdomain N0) Wstart Rstart c ->
    checkpoint \notin O ->
  forall (l: loc),
(l \notin (remove Rstart (getfstwt W)) ->
 l \in (getwt W) ->
       l \in (getdomain N0) \/ l \in Wstart).
intros T Hwarok Ho.
move: Wstart Rstart Hwarok.
dependent induction T; intros.
+ rewrite in_nil in H0. discriminate H0.
+ eapply war_works_loc_c; try apply H; try apply Hwarok; try assumption.
+ destruct W1 as [ [wW1 rW1] fwW1].
  destruct W2 as [ [wW2 rW2] fwW2].
  destruct Cmid as [ [Nmid Vmid] cmid].
  simpl in H1. simpl in H2. simpl in IHT.
  remember Ho as Hoo. clear HeqHoo.
  rewrite mem_cat in Hoo. move/ norP : Hoo => [Ho1 Ho2].
  move: (war_works_loc_c H0 Hwarok Ho1) => Hl1.
  move: (warok_partial H0 Ho1 Hwarok) => Hwarok2.
  simpl in Hwarok2.
  suffices:
        (forall l : loc,
        l \notin remove (rW1 ++ Rstart) fwW2 ->
        l \in wW2 -> l \in getdomain N0 \/ l \in (wW1 ++ Wstart)).
  move => Hl2. simpl in Hl1.
  rewrite mem_cat in H2. move/orP: H2 => Happ.
destruct (l \in wW1) eqn: Hbool;
  rewrite mem_filter in H1; move/nandP : H1 => [Hr1 | Hweird].
+ suffices: (l \notin remove Rstart fwW1).
intros H500. apply Hl1; try assumption.
rewrite mem_filter. apply/nandP. by left.
+ rewrite mem_cat in Hweird. move/ norP: Hweird => [Hdone H600].
  apply Hl1. rewrite mem_filter. apply/ nandP. by right.
    by [].
 +suffices: (l \notin remove (rW1 ++ Rstart) fwW2).
  intros H500. destruct Happ as [Hw2 | contra].
  suffices: (l \in getdomain N0 \/ l \in wW1 ++ Wstart).
  move => [one | two]. by left. right. rewrite mem_cat in two.
  move/ orP : two => [contra | done]. rewrite Hbool in contra.
  discriminate contra. assumption.
  eapply Hl2; try assumption.
  rewrite Hbool in contra. discriminate contra.
  rewrite mem_filter. apply/nandP. left. rewrite mem_cat.
  apply/negPn / orP. right. apply/negPn: Hr1.
 +
   suffices: (l \notin remove (rW1 ++ Rstart) fwW2).
  intros H500. destruct Happ as [Hw2 | contra].
  suffices: (l \in getdomain N0 \/ l \in wW1 ++ Wstart).
  move => [one | two]. by left. right. rewrite mem_cat in two.
  move/ orP : two => [contra | done]. rewrite Hbool in contra.
  discriminate contra. assumption.
  eapply Hl2; try assumption.
  rewrite Hbool in contra. discriminate contra.
  rewrite mem_filter. apply/nandP.
  rewrite mem_cat in Hweird. move/ norP: Hweird. => [Hdone H600].
  rewrite mem_filter in Hdone. move/ nandP : Hdone => [Hd1 | Hd2].
  left. rewrite mem_cat. apply/negPn/ orP. left.
  by apply/negPn. by right.
  eapply IHT; try reflexivity; try assumption.
  Qed.

Lemma wts_cped_sv: forall{N0 N Nend: nvmem} {V Vend: vmem} {c cend: command} {O: obseq} {W: the_write_stuff}
                  {Wstart Rstart: warvars} {l: loc},
    trace_cs (N, V, c) (Nend, Vend, cend) O W ->
    WARok (getdomain N0) Wstart Rstart c ->
    checkpoint \notin O ->
    l \notin (getdomain N0) ->
    l \in (getwt W) ->
    l \in (remove Rstart (getfstwt W))
          \/ l \in Wstart.
  intros.
  move: (war_works_loc H H0 H1) => Hl.
  destruct (l \in remove Rstart (getfstwt W)) eqn: Hin.
    by left.
    move/ negbT / (Hl l): Hin => Himp.
    move: (Himp H3) => [one | two].
    exfalso. by move/ negP : H2. by right.
Qed.

Lemma war_works {N0 N Nend: nvmem} {V Vend: vmem} {c cend: command} {O: obseq} {W: the_write_stuff}:
    trace_cs (N, V, c) (Nend, Vend, cend) O W ->
  subset_nvm N0 N ->
    WARok (getdomain N0) [::] [::] c ->
    checkpoint \notin O ->
    all_diff_in_fww N V c (N0 U! Nend).
  intros T Hsub Hwarok Ho.
  econstructor; try apply T; try assumption.
  intros l Hneq.
  destruct N as [Nmap Nd].
  destruct N0 as [N0map N0d].
  destruct Nend as [Nendmap Nendd].
  unfold updatemaps in Hneq. simpl in Hneq.
  assert (l \notin N0d) as Hnin0.
  apply/negP. intros contra.
  rewrite ifT in Hneq. apply Hneq.
  unfold subset_nvm in Hsub. symmetry. by eapply Hsub.
  assumption.
  rewrite ifF in Hneq.
  apply (update T) in Hneq.
  move: (war_works_loc T Hwarok Ho) => Hl.
  rewrite remove_empty in Hl.
  apply/ negPn/ negP. intros contra.
  move/ Hl : contra. => [contra1 | contra2].
  assumption.
  move/negP: Hnin0. by apply.
    by [].
    by apply negbTE.
Qed.

Lemma same_com {N0 N V c Nmid Vmid cmid O1 W1 Nend1 Vend cend O2 W2}:
  WARok (getdomain N0) [::] [::] c ->
  subset_nvm N0 N ->
  trace_cs (N, V, c) (Nmid, Vmid, cmid) O1 W1 ->
  checkpoint \notin O1 ->
  trace_cs (N0 U! Nmid, V, c) (Nend1, Vend, cend) O2 W2 ->
  checkpoint \notin O2 ->
  exists (Nend2: nvmem), trace_cs (N, V, c) (Nend2, Vend, cend) O2 W2.
  intros Hwar Hsub Tmid Ho1 T2 Ho2.
  move: (war_works Tmid Hsub Hwar Ho1) => Hdiff.
  eapply same_com_help; try apply Hdiff; try assumption. apply T2.
Qed.

Lemma same_comi {N0 N V c O1 W1 Nend Vend cend }:
  WARok (getdomain N0) [::] [::] c ->
  subset_nvm N0 N ->
  trace_i1 ((N0, V, c), N, V, c) ((N0, V, c), Nend, Vend, cend) O1 W1 ->
  checkpoint \notin O1 ->
  exists (Nend2: nvmem) (Oc: obseq) (Wc: the_write_stuff), (trace_cs (N, V, c) (Nend2, Vend, cend) Oc Wc /\
checkpoint \notin Oc).
  intros. dependent induction  H1.
  exists Nend O W. split; assumption.
  suffices:(exists Nend2 Oc Wc,
               trace_cs (N0 U! Nmid, V, c)
                 (Nend2, Vend, cend) Oc Wc /\
               checkpoint \notin Oc
           ). move => [Nend2 [Ocend [Wcend [Tend Hocend] ] ] ].
  move: (same_com H H0 H3 H4 Tend Hocend) => [Nend0 Tdone].
  exists Nend0 Ocend Wcend. split; assumption.
  eapply IHtrace_i1; try reflexivity; try assumption.
  apply sub_update.
  repeat rewrite mem_cat in H2. move/norP: H2 => [Hblah H2].
  move/norP: H2 => [contra Hb]. rewrite mem_seq1 in contra.
    by case/eqP : contra.
    Qed.

   Lemma warok_cp {N1 N2 V1 V2 c crem O W Wstart Rstart}
      {w0 w1: warvars}:
  WARok w0 Wstart Rstart c ->
  trace_cs (N1, V1, c) (N2, V2, incheckpoint w1;; crem) O W ->
  WARok w1 [::] [::] crem. intros Hwar T.
   move: N1 V1 N2 V2 O W T.
   dependent induction Hwar; subst; intros.
   2: {
     destruct (O == [::]) eqn: Hbool; move/ eqP: Hbool => Hbool. subst.
     move/empty_trace_cs1: T => [one two]. inversion one.
     subst. assumption.
     move: (single_step_alls_rev T Hbool). =>
 [ [ [nm vm] cm]
     [W1
        [Wrest
           [ O1
               [Hcceval
                  [Hsub Hw]
               ]
           ]
        ]
 ] ].
     move: (cceval_steps Hcceval) => one. subst.
     move: (single_step_alls T Hbool Hcceval). =>
                                               [Wrest0 [Orest [Trest [Hsubr Hwr] ] ] ].
     eapply IHHwar; try by []. apply Trest.
   }
   2: {
     destruct (O == [::]) eqn: Hbool; move/ eqP: Hbool => Hbool. subst.
     move/empty_trace_cs1: T => [one two]. inversion one.
     subst. inversion H.
     move: (single_step_alls_rev T Hbool). =>
 [ [ [nm vm] cm]
     [W1
        [Wrest
           [ O1
               [Hcceval
                  [Hsub Hw]
               ]
           ]
        ]
 ] ].
     move: (cceval_steps Hcceval) => one. subst.
     move: (single_step_alls T Hbool Hcceval). =>
                                               [Wrest0 [Orest [Trest [Hsubr Hwr] ] ] ].
     eapply IHHwar; try by []. apply Trest.
   }
   2: {
suffices: O <> [::]. move => Hneq.
     move: (single_step_alls_rev T Hneq). =>
 [ [ [nm vm] cm]
     [W1
        [Wrest
           [ O1
               [Hcceval
                  [Hsub Hw]
               ]
           ]
        ]
 ] ].
     move: (single_step_alls T Hneq Hcceval). =>
                                              [Wrest0 [Orest [Trest [Hsubr Hwr] ] ] ].
     inversion Hcceval; subst;
       [eapply IHHwar1 | eapply IHHwar2]; try by []; apply Trest.
     intros contra. subst.
     move/ empty_trace_cs1: T => [one two]. inversion one.
   }
   move/ trace_skip1: T => [one | one]; inversion one.
   Qed.


Theorem all_equal : forall x y : Empty_set, x = y.
Proof.
 destruct x.
Qed.

Theorem all_diff : forall x y : Empty_set, x <> y.
Proof.
 destruct x.
Qed.


From Test Require Import tactic.

Section FOFProblem.

Variable Universe : Set.
Variable UniverseElement : Universe.

Variable wd_ : Universe -> Universe -> Prop.
Variable col_ : Universe -> Universe -> Universe -> Prop.

Variable col_swap1_1 : (forall A B C : Universe, (col_ A B C -> col_ B A C)).
Variable col_swap2_2 : (forall A B C : Universe, (col_ A B C -> col_ B C A)).
Variable col_triv_3 : (forall A B : Universe, col_ A B B).
Variable wd_swap_4 : (forall A B : Universe, (wd_ A B -> wd_ B A)).
Variable col_trans_5 : (forall P Q A B C : Universe, ((wd_ P Q /\ (col_ P Q A /\ (col_ P Q B /\ col_ P Q C))) -> col_ A B C)).

Theorem pipo_6 : (forall P Q R S Pprime Qprime Rprime Sprime A B X Y Qprimeprime Sprimeprime : Universe, ((wd_ A B /\ (wd_ X Y /\ (wd_ P Q /\ (wd_ R S /\ (wd_ Pprime Qprime /\ (wd_ Rprime Sprime /\ (wd_ Qprime Qprimeprime /\ (wd_ Sprime Sprimeprime /\ (wd_ Qprime Sprime /\ (wd_ Pprime Rprime /\ (wd_ Pprime Qprimeprime /\ (wd_ B Qprimeprime /\ (wd_ A Qprimeprime /\ (wd_ Qprimeprime Sprimeprime /\ (wd_ Rprime Sprimeprime /\ (col_ A B Pprime /\ (col_ A B Qprime /\ (col_ A B Rprime /\ (col_ A B Sprime /\ (col_ Rprime Pprime Qprimeprime /\ (col_ Rprime Pprime Sprimeprime /\ col_ Pprime Rprime A))))))))))))))))))))) -> col_ Pprime Rprime B)).
Proof.
  time tac.
Qed.

End FOFProblem.


From stdpp Require Import namespaces strings.

Lemma test1 (N1 N2 : namespace) :
  N1 ## N2 → ↑N1 ⊆@{coPset} ⊤ ∖ ↑N2.
Proof. solve_ndisj. Qed.

Lemma test2 (N1 N2 : namespace) :
  N1 ## N2 → ↑N1.@"x" ⊆@{coPset} ⊤ ∖ ↑N1.@"y" ∖ ↑N2.
Proof. solve_ndisj. Qed.

Lemma test3 (N : namespace) :
  ⊤ ∖ ↑N ⊆@{coPset} ⊤ ∖ ↑N.@"x".
Proof. solve_ndisj. Qed.

Lemma test4 (N : namespace) :
  ⊤ ∖ ↑N ⊆@{coPset} ⊤ ∖ ↑N.@"x" ∖ ↑N.@"y".
Proof. solve_ndisj. Qed.

Lemma test5 (N1 N2 : namespace) :
  ⊤ ∖ ↑N1 ∖ ↑N2 ⊆@{coPset} ⊤ ∖ ↑N1.@"x" ∖ ↑N2 ∖ ↑N1.@"y".
Proof. solve_ndisj. Qed.


(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Set Implicit Arguments.
Unset Strict Implicit.
Require Export Fpart2.
Section tiroirs_def.
Variable E F : Setoid.
Variable f : MAP E F.

Lemma diff_add_part2 :
 forall (E : Setoid) (A : part_set E) (x : E),
 in_part x A -> Equal A (add_part (diff A (single x)) x).
intros E0 A x H'; try assumption.
apply in_eq_part.
intros x0 H'0; try assumption.
elim (classic (Equal x x0)); intros.
apply in_part_trans_eq with x; auto with *.
cut (in_part x0 (diff A (single x))).
unfold add_part in |- *; auto with *.
apply in_diff; auto with *.
intros x0 H'0; try assumption.
elim (classic (Equal x x0)); intros.
apply in_part_trans_eq with x; auto with *.
cut (in_part x0 (diff A (single x))).
intros H'1; try assumption.
apply diff_in_l with (single x).
auto with *.
unfold add_part in H'0.
elim (in_part_union H'0); intros.
auto with *.
absurd (Equal x x0); auto with *.
Qed.
Hint Resolve diff_add_part2: algebra.

Lemma cardinal_minus_part :
 forall (B : part_set F) (x : F) (n : nat),
 cardinal B (S n) -> in_part x B -> cardinal (diff B (single x)) n.
intros B x n H' H'0; try assumption.
apply cardinal_S with B x; auto with *.
unfold not in |- *; intros.
cut (~ in_part x (single x)).
unfold not in |- *; auto with *.
apply diff_in_r with B; auto with *.
Qed.
Hint Resolve cardinal_minus_part: algebra.

Lemma tiroirs :
 forall (n : nat) (Chaussettes : part_set E),
 cardinal Chaussettes n ->
 forall (m : nat) (Tiroirs : part_set F),
 cardinal Tiroirs m ->
 m < n ->
 (forall x : E, in_part x Chaussettes -> in_part (f x) Tiroirs) ->
 exists x : E, (exists y : E, ~ Equal x y /\ Equal (f x) (f y)).
simple induction n.
intros Chaussettes H' m Tiroirs H'0 H'1; try assumption.
inversion H'1.
intros n0 H' Chaussettes H'0 m Tiroirs H'1 H'2 H'3; try assumption.
inversion H'0.
elim (classic (ex (fun y : E => ~ Equal x y /\ Equal (Ap f x) (Ap f y))));
 intros.
exists x; try assumption.
cut (exists m0 : nat, m = S m0).
intros H'4; try assumption.
case H'4; clear H'4; intros.
apply H' with (diff Chaussettes (single x)) x0 (diff Tiroirs (single (f x))).
apply cardinal_S with Chaussettes x.
unfold not in |- *; intros.
absurd (~ in_part x (single x)); auto with *.
apply diff_in_r with Chaussettes; auto with *.
auto with *.
apply diff_add_part2.
apply in_part_comp_r with (add_part B x); auto with *.
auto with *.
apply cardinal_minus_part.
rewrite <- H5; auto with *.
apply H'3; auto with *.
apply in_part_comp_r with (add_part B x).
auto with *.
auto with *.
rewrite H5 in H'2; auto with *.
intros x1 H'4; try assumption.
apply in_diff.
apply H'3; auto with *.
apply diff_in_l with (single x); auto with *.
unfold not in |- *; intros.
unfold not in H4.
apply H4.
exists x1; try assumption.
split.
intros H'5; try assumption.
cut (~ in_part x1 (single x)).
intro.
apply H7.
apply in_part_trans_eq with x; auto with *.
apply diff_in_r with Chaussettes; auto with *.
auto with *.
inversion H'1.
cut (in_part (f x) Tiroirs).
intros H'4; try assumption.
absurd (in_part (f x) (empty F)); auto with *.
apply in_part_comp_r with Tiroirs; auto with *.
apply H'3.
apply in_part_comp_r with (add_part B x); auto with *.
exists n2; try assumption.
auto with *.
Qed.
End tiroirs_def.


Require Import SpecCert.x86.Architecture.

Definition lock_smramc_pre
           {Label: Type} :=
  fun (a:Architecture Label) =>
    smramc_is_unlocked (memory_controller a).

Definition lock_smramc_post
           {Label: Type} :=
  fun (a a':Architecture Label) =>
    exists h, let m' := lock_smramc (memory_controller a) h
    in a' = update_memory_controller a m'.


Require Import HoTT.
Require Import UnivalenceAxiom.

Require Import HoTTEx.
Require Import Denotation.
Require Import UnivalentSemantics.
Require Import AutoTactics.

Open Scope type.

Module SubqueryOptimization (T : Types) (S : Schemas T) (R : Relations T S)  (A : Aggregators T S).
  Import T S R A.
  Module SQL_TSRA := SQL T S R A.
  Import SQL_TSRA.
  Module AutoTac := AutoTactics T S R A.
  Import AutoTac.

  Definition InlineCorrelatedSubquery : Type.
    refine (forall (Γ s: Schema) (a : relation s) ty (c : Column ty s), _).
    pose (@variable ty ((Γ ++ s) ++ s) (left⋅right⋅c)) as v0.
    pose (@variable ty ((Γ ++ s) ++ s) (right⋅c)) as v1.
    refine (⟦ Γ ⊢ (SELECT * FROM1 table a WHERE (EXISTS (SELECT * FROM1 table a WHERE (equal v0 v1)))) : s ⟧ =
            ⟦ Γ ⊢ (SELECT * FROM1 table a) : s ⟧); revgoals.
  Defined.
  Arguments InlineCorrelatedSubquery /.

  Lemma inlineCorrelatedSubquery : InlineCorrelatedSubquery.
    solve_summation.

  Defined.

  (*
  Pull up subqueries in FROM clause. Query before:
     SELECT *
     FROM A, (SELECT * FROM B WHERE <p>) as C
     WHERE slct
  Query after:
     SELECT *
     FROM A, B
     WHERE slct AND <p'>
  One thing that needs noticing is that <p> and <p'> are on different context
   *)
  Definition PullUpSubqueryInFrom : Type.
    refine (forall Γ (s1 s2: Schema) (a : SQL Γ s1) (b: SQL Γ s2)
                (slct1: Pred (Γ ++ s1 ++ s2))
                (slct0: Pred (Γ ++ s2)),
        ⟦Γ ⊢ (SELECT * FROM2 a, (SELECT * FROM1 b WHERE slct0 ) WHERE slct1 ): _ ⟧ =
        ⟦Γ ⊢ (SELECT * FROM2 a, b WHERE slct1 AND _ slct0) : _ ⟧).
    refine (castPred (combine left (right⋅right))).
  Defined.

  Arguments PullUpSubqueryInFrom /.

  Lemma pullUpSubqueryInFrom : PullUpSubqueryInFrom.
    hott_ring.
  Qed.
End SubqueryOptimization.


Require Import Util EqDec DecSolve Val CSet Map Envs Option Get SetOperations IL.Events.
Require Export MoreList Isa.Ops.

Set Implicit Arguments.

(** * Extended Expressions *)

Inductive exp :=
| Operation (e:op)
| Call (f:external) (Y:list op).

Definition isCall e :=
  match e with
  | Operation _ => false
  | Call _ _ => true
  end.

Definition externals (e:exp) :=
  match e with
  | Operation _ => {}
  | Call f _ => singleton f
  end.

Instance inst_eq_dec_exp : EqDec exp eq.
Proof.
  hnf; intros. change ({x = y} + {x <> y}).
  decide equality.
  - eapply inst_eq_dec_op.
  - eapply list_eq_dec.
    intros. eapply inst_eq_dec_op.
  - eapply Pos.eq_dec.
Defined.

Definition freeVars (e:exp) :=
  match e with
  | Operation e => Ops.freeVars e
  | Call f Y => list_union (List.map Ops.freeVars Y)
  end.

(** ** Renaming *)

Definition rename_exp (ϱ:env var) (e:exp) :=
  match e with
  | Operation e => Operation (rename_op ϱ e)
  | Call f Y => Call f (List.map (rename_op ϱ) Y)
  end.

Lemma rename_exp_comp e ϱ ϱ'
  : rename_exp ϱ (rename_exp ϱ' e) = rename_exp (ϱ' ∘ ϱ) e.
Proof.
  unfold comp. general induction e; simpl; eauto.
  - f_equal; eauto using rename_op_comp.
  - f_equal; eauto.
    rewrite map_map. setoid_rewrite rename_op_comp; eauto.
Qed.

Lemma rename_exp_ext
  : forall e (ϱ ϱ':env var), feq (R:=eq) ϱ ϱ' -> rename_exp ϱ e = rename_exp ϱ' e.
Proof.
  intros. general induction e; simpl; eauto.
  - f_equal; eauto using rename_op_ext.
  - f_equal; eauto.
    abstract (eapply map_ext; eauto using rename_op_ext) using rename_op_list_ext.
Defined.

Lemma rename_exp_agree ϱ ϱ' e
  : agree_on eq (freeVars e) ϱ ϱ'
    -> rename_exp ϱ e = rename_exp ϱ' e.
Proof.
  intros; general induction e; simpl in *; f_equal;
    eauto 30 using agree_on_incl, incl_left, incl_right, rename_op_agree.
  - clear f.
    abstract (eapply MoreList.map_ext_get_eq; intros; inv_get; eauto with len;
    eapply rename_op_agree;
    eapply agree_on_incl; eauto; eapply incl_list_union; eauto using map_get_1) using
        rename_op_list_agree.
Defined.

Lemma rename_exp_freeVars
  : forall e ϱ `{Proper _ (_eq ==> _eq) ϱ},
    freeVars (rename_exp ϱ e) ⊆ lookup_set ϱ (freeVars e).
Proof.
  intros. general induction e; simpl.
  - eapply rename_op_freeVars; eauto.
  - clear f.
    abstract (eapply list_union_incl; eauto with cset;
      intros; inv_get; rewrite lookup_set_list_union; eauto using lookup_set_empty;
      eapply incl_list_union; eauto using map_get_1, rename_op_freeVars)
             using rename_op_list_freeVars.
Defined.

(** ** Liveness *)

Inductive live_exp_sound : exp -> set var -> Prop :=
| OperationLiveSound e lv
  : live_op_sound e lv -> live_exp_sound (Operation e) lv
| CallLiveSound f Y lv
  : (forall n e, get Y n e -> live_op_sound e lv)
    -> live_exp_sound (Call f Y) lv.

Instance live_exp_sound_Subset e
  : Proper (Subset ==> impl) (live_exp_sound e).
Proof.
  unfold Proper, respectful, impl; intros.
  general induction e.
  - invt live_exp_sound. econstructor. eapply live_op_sound_Subset; eauto.
  - inv H0; econstructor; intros. eapply live_op_sound_Subset; eauto.
Qed.

Instance live_op_sound_Equal e
  : Proper (Equal ==> iff) (live_exp_sound e).
Proof.
  unfold Proper, respectful, impl; split; intros.
  - eapply subset_equal in H. rewrite H in H0; eauto.
  - symmetry in H. eapply subset_equal in H.
    rewrite <- H; eauto.
Qed.

Instance live_op_sound_dec e lv
  : Computable (live_exp_sound e lv).
Proof.
  induction e; try dec_solve.
  - decide (live_op_sound e lv); dec_solve.
  - decide ( forall (n : nat) (e : op), get Y n e -> live_op_sound e lv); try dec_solve.
Qed.

Lemma live_exp_sound_incl
  : forall e lv lv', live_exp_sound e lv' -> lv' ⊆ lv -> live_exp_sound e lv.
Proof.
  intros. rewrite <- H0; eauto.
Qed.

Lemma freeVars_live e lv
  : live_exp_sound e lv -> freeVars e ⊆ lv.
Proof.
  intros. general induction H; simpl; eauto using Ops.freeVars_live, Ops.freeVars_live_list.
Qed.

Lemma freeVars_live_list Y lv
  : (forall (n : nat) (y : exp), get Y n y -> live_exp_sound y lv)
    -> list_union (freeVars ⊝ Y) ⊆ lv.
Proof.
  intros H. eapply list_union_incl; intros; inv_get; eauto using freeVars_live with cset.
Qed.

Lemma live_exp_rename_sound e lv (ϱ:env var)
  : live_exp_sound e lv
    -> live_exp_sound (rename_exp ϱ e) (lookup_set ϱ lv).
Proof.
  intros.
  general induction H; simpl; econstructor; intros; inv_get; eauto using live_op_rename_sound.
Qed.

Lemma live_freeVars
  : forall e, live_exp_sound e (freeVars e).
Proof.
  intros. general induction e; simpl; econstructor;
            eauto using Ops.live_freeVars with cset.
  intros. eapply live_op_sound_incl.
  eapply Ops.live_freeVars.
  eapply incl_list_union; eauto using map_get_1.
Qed.

(** ** Alpha Equivalence *)

Inductive alpha_exp : env var -> env var -> exp -> exp -> Prop :=
| AlphaOperation ϱ ϱ' e e' :
    alpha_op ϱ ϱ' e e'
    -> alpha_exp ϱ ϱ' (Operation e) (Operation e')
| AlphaCall ϱ ϱ' f Y Y' :
    length Y = length Y'
  -> (forall n x y, get Y n x -> get Y' n y -> alpha_op ϱ ϱ' x y)
  -> alpha_exp ϱ ϱ' (Call f Y) (Call f Y').

Lemma alpha_exp_rename_injective
  : forall e ϱ ϱ',
    inverse_on (freeVars e) ϱ ϱ'
    -> alpha_exp ϱ ϱ' e (rename_exp ϱ e).
Proof.
  intros. induction e; simpl; eauto using alpha_exp, alpha_op_rename_injective.
  econstructor; eauto with len.
  intros; inv_get. eapply alpha_op_rename_injective.
  eapply inverse_on_incl; eauto; simpl. eapply incl_list_union; eauto using map_get_1.
Qed.

Lemma alpha_exp_refl : forall e, alpha_exp id id e e.
Proof.
  intros; induction e; eauto 20 using alpha_exp, alpha_op_refl.
  econstructor; eauto. intros. get_functional. eapply alpha_op_refl.
Qed.

Lemma alpha_exp_sym : forall ϱ ϱ' e e', alpha_exp ϱ ϱ' e e' -> alpha_exp ϱ' ϱ e' e.
Proof.
  intros. general induction H; eauto using alpha_exp, alpha_op_sym.
Qed.

Set Regular Subst Tactic.

Lemma alpha_exp_trans
  : forall ϱ1 ϱ1' ϱ2 ϱ2' s s' s'',
    alpha_exp ϱ1 ϱ1' s s'
    -> alpha_exp ϱ2 ϱ2' s' s''
    -> alpha_exp (ϱ1 ∘ ϱ2) (ϱ2' ∘ ϱ1') s s''.
Proof.
  intros. general induction H; invt alpha_exp; eauto using alpha_exp, alpha_op_trans.
  - econstructor; eauto with len.
    intros. inv_get. eapply alpha_op_trans; eauto.
Qed.

Unset Regular Subst Tactic.

Lemma alpha_exp_inverse_on
  : forall ϱ ϱ' s t, alpha_exp ϱ ϱ' s t -> inverse_on (freeVars s) ϱ ϱ'.
Proof.
  intros. general induction H; simpl; eauto using alpha_op_inverse_on.
  + eapply inverse_on_list_union; eauto.
    intros; inv_get. eauto using alpha_op_inverse_on.
Qed.

Lemma alpha_exp_agree_on_morph
  : forall f g ϱ ϱ' s t,
    alpha_exp ϱ ϱ' s t
    -> agree_on _eq (lookup_set ϱ (freeVars s)) g ϱ'
    -> agree_on _eq (freeVars s) f ϱ
    -> alpha_exp f g s t.
Proof.
  intros.
  general induction H; simpl in *;
    eauto using alpha_exp, alpha_op_agree_on_morph.
  - econstructor; eauto. clear H f.
    abstract (intros; eapply alpha_op_agree_on_morph; eauto;
      [ eapply agree_on_incl; eauto;
        rewrite SetOperations.lookup_set_list_union; eauto using lookup_set_empty;
        eapply incl_list_union; eauto using map_get_1
      |  eauto with cset ])
    using alpha_op_list_agree_on_morph.
Defined.

Lemma exp_rename_renamedApart_all_alpha e e' ϱ ϱ'
  : alpha_exp ϱ ϱ' e e'
    -> rename_exp ϱ e = e'.
Proof.
  intros. general induction H; simpl; f_equal; eauto using op_rename_renamedApart_all_alpha.
  eapply map_ext_get_eq; intros; eauto using op_rename_renamedApart_all_alpha.
Qed.

Lemma alpha_exp_morph
  : forall (ϱ1 ϱ1' ϱ2 ϱ2':env var) e e',
    @feq _ _ eq ϱ1  ϱ1'
    -> @feq _ _ eq ϱ2 ϱ2'
    -> alpha_exp ϱ1 ϱ2 e e'
    -> alpha_exp ϱ1' ϱ2' e e'.
Proof.
  intros. general induction H1; eauto using alpha_exp, alpha_op_morph.
Qed.

Lemma freeVars_renameExp ϱ e
  : freeVars (rename_exp ϱ e) [=] lookup_set ϱ (freeVars e).
Proof.
  general induction e; simpl;
    eauto using freeVars_rename_op_list, freeVars_renameOp.
Qed.


(**************************************************************************)
(*  This file is part of CertrBPF,                                        *)
(*  a formally verified rBPF verifier + interpreter + JIT in Coq.         *)
(*                                                                        *)
(*  Copyright (C) 2022 Inria                                              *)
(*                                                                        *)
(*  This program is free software; you can redistribute it and/or modify  *)
(*  it under the terms of the GNU General Public License as published by  *)
(*  the Free Software Foundation; either version 2 of the License, or     *)
(*  (at your option) any later version.                                   *)
(*                                                                        *)
(*  This program is distributed in the hope that it will be useful,       *)
(*  but WITHOUT ANY WARRANTY; without even the implied warranty of        *)
(*  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the         *)
(*  GNU General Public License for more details.                          *)
(*                                                                        *)
(**************************************************************************)

From Coq Require Import ZArith.

From compcert Require Import Integers.

Open Scope nat_scope.

Inductive opcode_alu64: Type := (**r 0xX7 *)
  (** ALU64:13 *)
  | op_BPF_ADD64
  | op_BPF_SUB64
  | op_BPF_MUL64
  | op_BPF_DIV64
  | op_BPF_OR64
  | op_BPF_AND64
  | op_BPF_LSH64
  | op_BPF_RSH64
  | op_BPF_NEG64
  | op_BPF_MOD64
  | op_BPF_XOR64
  | op_BPF_MOV64
  | op_BPF_ARSH64
  | op_BPF_ALU64_ILLEGAL_INS.

(**
#define BPF_INSTRUCTION_ALU_OP_MASK     0xf0

#define BPF_INSTRUCTION_ALU_ADD         0x00
#define BPF_INSTRUCTION_ALU_SUB         0x10
#define BPF_INSTRUCTION_ALU_MUL         0x20
#define BPF_INSTRUCTION_ALU_DIV         0x30
#define BPF_INSTRUCTION_ALU_OR          0x40
#define BPF_INSTRUCTION_ALU_AND         0x50
#define BPF_INSTRUCTION_ALU_LSH         0x60
#define BPF_INSTRUCTION_ALU_RSH         0x70
#define BPF_INSTRUCTION_ALU_NEG         0x80
#define BPF_INSTRUCTION_ALU_MOD         0x90
#define BPF_INSTRUCTION_ALU_XOR         0xA0
#define BPF_INSTRUCTION_ALU_MOV         0xB0
#define BPF_INSTRUCTION_ALU_ARSH        0xC0

*)

Definition byte_to_opcode_alu64 (op: nat): opcode_alu64 :=
  let opcode_alu := Nat.land op 0xf0 in (**r masking operation *)
    match opcode_alu with
    | 0x00 => op_BPF_ADD64
    | 0x10 => op_BPF_SUB64
    | 0x20 => op_BPF_MUL64
    | 0x30 => op_BPF_DIV64
    | 0x40 => op_BPF_OR64
    | 0x50 => op_BPF_AND64
    | 0x60 => op_BPF_LSH64
    | 0x70 => op_BPF_RSH64
    | 0x80 => op_BPF_NEG64 (*if Nat.eqb op 0x87 then op_BPF_NEG64 else op_BPF_ALU64_ILLEGAL_INS*)
    | 0x90 => op_BPF_MOD64
    | 0xa0 => op_BPF_XOR64
    | 0xb0 => op_BPF_MOV64
    | 0xc0 => op_BPF_ARSH64
    | _    => op_BPF_ALU64_ILLEGAL_INS
    end.

Inductive opcode_alu32: Type := (**r 0xX4 *)
  (** ALU32:13 *)
  | op_BPF_ADD32
  | op_BPF_SUB32
  | op_BPF_MUL32
  | op_BPF_DIV32
  | op_BPF_OR32
  | op_BPF_AND32
  | op_BPF_LSH32
  | op_BPF_RSH32
  | op_BPF_NEG32
  | op_BPF_MOD32
  | op_BPF_XOR32
  | op_BPF_MOV32
  | op_BPF_ARSH32
  | op_BPF_ALU32_ILLEGAL_INS.

Definition byte_to_opcode_alu32 (op: nat): opcode_alu32 :=
  let opcode_alu := Nat.land op 0xf0 in (**r masking operation *)
    match opcode_alu with
    | 0x00 => op_BPF_ADD32
    | 0x10 => op_BPF_SUB32
    | 0x20 => op_BPF_MUL32
    | 0x30 => op_BPF_DIV32
    | 0x40 => op_BPF_OR32
    | 0x50 => op_BPF_AND32
    | 0x60 => op_BPF_LSH32
    | 0x70 => op_BPF_RSH32
    | 0x80 => op_BPF_NEG32 (*
    | 0x80 => if Nat.eqb op 0x84 then op_BPF_NEG32 else op_BPF_ALU32_ILLEGAL_INS *)
    | 0x90 => op_BPF_MOD32
    | 0xa0 => op_BPF_XOR32
    | 0xb0 => op_BPF_MOV32
    | 0xc0 => op_BPF_ARSH32
    | _    => op_BPF_ALU32_ILLEGAL_INS
    end.

Inductive opcode_branch: Type := (**r 0xX5 *)
  (**Branch: 13 *)
  | op_BPF_JA
  | op_BPF_JEQ
  | op_BPF_JGT
  | op_BPF_JGE
  | op_BPF_JLT
  | op_BPF_JLE
  | op_BPF_JSET
  | op_BPF_JNE
  | op_BPF_JSGT
  | op_BPF_JSGE
  | op_BPF_JSLT
  | op_BPF_JSLE
  | op_BPF_CALL
  | op_BPF_RET
  | op_BPF_JMP_ILLEGAL_INS.

(**
#define BPF_INSTRUCTION_ALU_OP_MASK     0xf0

#define BPF_INSTRUCTION_BRANCH_JA       0x00
#define BPF_INSTRUCTION_BRANCH_JEQ      0x10
#define BPF_INSTRUCTION_BRANCH_JGT      0x20
#define BPF_INSTRUCTION_BRANCH_JGE      0x30
#define BPF_INSTRUCTION_BRANCH_JLT      0xa0
#define BPF_INSTRUCTION_BRANCH_JLE      0xb0
#define BPF_INSTRUCTION_BRANCH_JSET     0x40
#define BPF_INSTRUCTION_BRANCH_JNE      0x50
#define BPF_INSTRUCTION_BRANCH_JSGT     0x60
#define BPF_INSTRUCTION_BRANCH_JSGE     0x70
#define BPF_INSTRUCTION_BRANCH_JSLT     0xc0
#define BPF_INSTRUCTION_BRANCH_JSLE     0xd0
#define BPF_INSTRUCTION_BRANCH_CALL     0x80
#define BPF_INSTRUCTION_BRANCH_EXIT     0x90
*)

(**r
there is an error:

opcode = 0x0d -> ja

0x0d & 0x07 = 0x05 i.e. op_BPF_Branch

0x0d & 0xf0 = 0x00 i.e. op_BPF_JA

*)
Definition byte_to_opcode_branch (op: nat): opcode_branch :=
  let opcode_jmp := Nat.land op 0xf0 in (**r masking operation *)
    match opcode_jmp with
    | 0x00 => op_BPF_JA (*
    | 0x00 => if Nat.eqb op 0x05 then op_BPF_JA else op_BPF_JMP_ILLEGAL_INS *)
    | 0x10 => op_BPF_JEQ
    | 0x20 => op_BPF_JGT
    | 0x30 => op_BPF_JGE
    | 0xa0 => op_BPF_JLT
    | 0xb0 => op_BPF_JLE
    | 0x40 => op_BPF_JSET
    | 0x50 => op_BPF_JNE
    | 0x60 => op_BPF_JSGT
    | 0x70 => op_BPF_JSGE
    | 0xc0 => op_BPF_JSLT
    | 0xd0 => op_BPF_JSLE
    | 0x80 => op_BPF_CALL
    | 0x90 => op_BPF_RET (*
    | 0x80 => if Nat.eqb op 0x85 then op_BPF_CALL else op_BPF_JMP_ILLEGAL_INS
    | 0x90 => if Nat.eqb op 0x95 then op_BPF_RET else op_BPF_JMP_ILLEGAL_INS *)
    | _    => op_BPF_JMP_ILLEGAL_INS
    end.

Inductive opcode_mem_ld_imm: Type :=  (**r 0xX8 *)
  (** Load/Store: 13 *)
  | op_BPF_LDDW_low
  | op_BPF_LDDW_high
  | op_BPF_LDX_IMM_ILLEGAL_INS.

Definition byte_to_opcode_mem_ld_imm (op: nat): opcode_mem_ld_imm :=
  let opcode_ld := Nat.land op 0xff in (**r masking operation *)
    match opcode_ld with
    | 0x18 => op_BPF_LDDW_low
    | 0x10 => op_BPF_LDDW_high
    | _    => op_BPF_LDX_IMM_ILLEGAL_INS
    end.

Inductive opcode_mem_ld_reg: Type :=  (**r 0xX1/0xX9 *)
  (** Load/Store: 13 *)
  | op_BPF_LDXW
  | op_BPF_LDXH
  | op_BPF_LDXB
  | op_BPF_LDXDW
  | op_BPF_LDX_REG_ILLEGAL_INS.

Definition byte_to_opcode_mem_ld_reg (op: nat): opcode_mem_ld_reg :=
  let opcode_ld := Nat.land op 0xff in (**r masking operation *)
    match opcode_ld with
    | 0x61 => op_BPF_LDXW
    | 0x69 => op_BPF_LDXH
    | 0x71 => op_BPF_LDXB
    | 0x79 => op_BPF_LDXDW
    | _    => op_BPF_LDX_REG_ILLEGAL_INS
    end.

Inductive opcode_mem_st_imm: Type :=  (**r 0xX2/0xXa *)
  | op_BPF_STW
  | op_BPF_STH
  | op_BPF_STB
  | op_BPF_STDW
  | op_BPF_ST_ILLEGAL_INS.

Definition byte_to_opcode_mem_st_imm (op: nat): opcode_mem_st_imm :=
  let opcode_st := Nat.land op 0xff in (**r masking operation *)
    match opcode_st with
    | 0x62 => op_BPF_STW
    | 0x6a => op_BPF_STH
    | 0x72 => op_BPF_STB
    | 0x7a => op_BPF_STDW
    | _    => op_BPF_ST_ILLEGAL_INS
    end.

Inductive opcode_mem_st_reg: Type :=  (**r 0xX3/0xXb *)
  | op_BPF_STXW
  | op_BPF_STXH
  | op_BPF_STXB
  | op_BPF_STXDW
  | op_BPF_STX_ILLEGAL_INS.

Definition byte_to_opcode_mem_st_reg (op: nat): opcode_mem_st_reg :=
  let opcode_st := Nat.land op 0xff in (**r masking operation *)
    match opcode_st with
    | 0x63 => op_BPF_STXW
    | 0x6b => op_BPF_STXH
    | 0x73 => op_BPF_STXB
    | 0x7b => op_BPF_STXDW
    | _    => op_BPF_STX_ILLEGAL_INS
    end.

Inductive opcode: Type :=
  | op_BPF_ALU64   (**r 0xX7 / 0xXf *)
  | op_BPF_ALU32   (**r 0xX4 / 0xXc *)
  | op_BPF_Branch  (**r 0xX5 / 0xXd *)
  | op_BPF_Mem_ld_imm  (**r 0xX8 *)
  | op_BPF_Mem_ld_reg  (**r 0xX1/0xX9 *)
  | op_BPF_Mem_st_imm  (**r 0xX2/0xXa *)
  | op_BPF_Mem_st_reg  (**r 0xX3/0xXb *)

  | op_BPF_ILLEGAL_INS.

(**
#define BPF_INSTRUCTION_CLS_MASK        0x07

#define BPF_INSTRUCTION_CLS_LD          0x00
#define BPF_INSTRUCTION_CLS_LDX         0x01
#define BPF_INSTRUCTION_CLS_ST          0x02
#define BPF_INSTRUCTION_CLS_STX         0x03
#define BPF_INSTRUCTION_CLS_ALU32       0x04
#define BPF_INSTRUCTION_CLS_BRANCH      0x05
#define BPF_INSTRUCTION_CLS_ALU64       0x07
*)
Definition byte_to_opcode (op: nat): opcode :=
  let opc := Nat.land op 0x07 in (**r masking operation *)
    match opc with
    | 0x07 => op_BPF_ALU64
    | 0x04 => op_BPF_ALU32
    | 0x05 => op_BPF_Branch
    | 0x00 => op_BPF_Mem_ld_imm
    | 0x01 => op_BPF_Mem_ld_reg
    | 0x02 => op_BPF_Mem_st_imm
    | 0x03 => op_BPF_Mem_st_reg
    | _    => op_BPF_ILLEGAL_INS
    end.

(*
Definition int64_to_opcode (ins: int64): nat :=
  Z.to_nat (Z.land (Int.unsigned (Int.repr
    (Int64.unsigned (Int64.and ins (Int64.repr 0xff)))
    )) 0xff).
Int64.unsigned (Int64.and ins (Int64.repr 0xff))). *)

(******************** Dx related *******************)

Definition opcode_alu64_eqb  (o o' : opcode_alu64): bool :=
  match o , o' with
  | op_BPF_ADD64, op_BPF_ADD64
  | op_BPF_SUB64, op_BPF_SUB64
  | op_BPF_MUL64, op_BPF_MUL64
  | op_BPF_DIV64, op_BPF_DIV64
  | op_BPF_OR64,  op_BPF_OR64
  | op_BPF_AND64, op_BPF_AND64
  | op_BPF_LSH64, op_BPF_LSH64
  | op_BPF_RSH64, op_BPF_RSH64
  | op_BPF_NEG64,  op_BPF_NEG64
  | op_BPF_MOD64, op_BPF_MOD64
  | op_BPF_XOR64, op_BPF_XOR64
  | op_BPF_MOV64, op_BPF_MOV64
  | op_BPF_ARSH64,op_BPF_ARSH64
  | op_BPF_ALU64_ILLEGAL_INS, op_BPF_ALU64_ILLEGAL_INS => true
  | _, _ => false
  end.

Definition opcode_alu32_eqb  (o o' : opcode_alu32) : bool :=
  match o , o' with
  | op_BPF_ADD32, op_BPF_ADD32
  | op_BPF_SUB32, op_BPF_SUB32
  | op_BPF_MUL32, op_BPF_MUL32
  | op_BPF_DIV32, op_BPF_DIV32
  | op_BPF_OR32,  op_BPF_OR32
  | op_BPF_AND32, op_BPF_AND32
  | op_BPF_LSH32, op_BPF_LSH32
  | op_BPF_RSH32, op_BPF_RSH32
  | op_BPF_NEG32,  op_BPF_NEG32
  | op_BPF_MOD32, op_BPF_MOD32
  | op_BPF_XOR32, op_BPF_XOR32
  | op_BPF_MOV32, op_BPF_MOV32
  | op_BPF_ARSH32,op_BPF_ARSH32
  | op_BPF_ALU32_ILLEGAL_INS, op_BPF_ALU32_ILLEGAL_INS => true
  | _, _ => false
  end.

Definition opcode_branch_eqb (o o' : opcode_branch): bool :=
  match o , o' with
  | op_BPF_JA,    op_BPF_JA
  | op_BPF_JEQ,   op_BPF_JEQ
  | op_BPF_JGT,   op_BPF_JGT
  | op_BPF_JGE,   op_BPF_JGE
  | op_BPF_JLT,   op_BPF_JLT
  | op_BPF_JLE,   op_BPF_JLE
  | op_BPF_JSET,  op_BPF_JSET
  | op_BPF_JNE,   op_BPF_JNE
  | op_BPF_JSGT,  op_BPF_JSGT
  | op_BPF_JSGE,  op_BPF_JSGE
  | op_BPF_JSLT,  op_BPF_JSLT
  | op_BPF_JSLE,  op_BPF_JSLE
  | op_BPF_CALL,  op_BPF_CALL
  | op_BPF_RET,   op_BPF_RET
  | op_BPF_JMP_ILLEGAL_INS, op_BPF_JMP_ILLEGAL_INS => true
  | _, _ => false
  end.

Definition opcode_mem_ld_imm_eqb (o o' : opcode_mem_ld_imm): bool :=
  match o , o' with
  | op_BPF_LDDW_low,   op_BPF_LDDW_low
  | op_BPF_LDDW_high,   op_BPF_LDDW_high
  | op_BPF_LDX_IMM_ILLEGAL_INS, op_BPF_LDX_IMM_ILLEGAL_INS => true
  | _, _ => false
  end.

Definition opcode_mem_ld_reg_eqb (o o' : opcode_mem_ld_reg): bool :=
  match o , o' with
  | op_BPF_LDXW,   op_BPF_LDXW
  | op_BPF_LDXH,   op_BPF_LDXH
  | op_BPF_LDXB,   op_BPF_LDXB
  | op_BPF_LDXDW,  op_BPF_LDXDW
  | op_BPF_LDX_REG_ILLEGAL_INS, op_BPF_LDX_REG_ILLEGAL_INS => true
  | _, _ => false
  end.

Definition opcode_mem_st_imm_eqb (o o' : opcode_mem_st_imm): bool :=
  match o , o' with
  | op_BPF_STW,    op_BPF_STW
  | op_BPF_STH,    op_BPF_STH
  | op_BPF_STB,    op_BPF_STB
  | op_BPF_STDW,   op_BPF_STDW
  | op_BPF_ST_ILLEGAL_INS, op_BPF_ST_ILLEGAL_INS => true
  | _, _ => false
  end.

Definition opcode_mem_st_reg_eqb (o o' : opcode_mem_st_reg): bool :=
  match o , o' with
  | op_BPF_STXW,   op_BPF_STXW
  | op_BPF_STXH,   op_BPF_STXH
  | op_BPF_STXB,   op_BPF_STXB
  | op_BPF_STXDW,  op_BPF_STXDW
  | op_BPF_STX_ILLEGAL_INS, op_BPF_STX_ILLEGAL_INS => true
  | _, _ => false
  end.

Definition opcode_eqb (o o' : opcode) : bool :=
  match o , o' with
  | op_BPF_ALU64,      op_BPF_ALU64
  | op_BPF_ALU32,      op_BPF_ALU32
  | op_BPF_Branch,     op_BPF_Branch
  | op_BPF_Mem_ld_imm, op_BPF_Mem_ld_imm
  | op_BPF_Mem_ld_reg, op_BPF_Mem_ld_reg
  | op_BPF_Mem_st_imm, op_BPF_Mem_st_imm
  | op_BPF_Mem_st_reg, op_BPF_Mem_st_reg

  | op_BPF_ILLEGAL_INS, op_BPF_ILLEGAL_INS => true
  | _, _ => false
  end.


Require Import VST.floyd.proofauto.
Require Import VST.progs.int_or_ptr.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Inductive tree :=
| LEAF: forall i, 0 <= i <= Int.max_signed -> tree
| NODE: tree -> tree -> tree.

Fixpoint treerep (t: tree) (p: val) : mpred :=
  match t with
  | LEAF i _ => !! (p = Vint (Int.repr (i+i+1))) && emp
  | NODE t1 t2 => EX p1:val, EX p2: val,
               data_at Tsh (Tstruct _tree noattr) (p1,p2) p
              * treerep t1 p1 * treerep t2 p2
  end.

Definition POINTER_BOUNDARY : Z := 1024.

Definition valid_int_or_ptr (x: val) :=
 match x with
 | Vint i => Int.testbit i 0 = true
              \/ Int.unsigned i < POINTER_BOUNDARY
 | Vptr b z => Ptrofs.testbit z 0 = false
 | _ => False
 end.

Lemma valid_int_or_ptr_ii1:
 forall i, valid_int_or_ptr (Vint (Int.repr (i + i + 1))).
Proof.
intros.
simpl.
left.
rewrite Int.unsigned_repr_eq.
rewrite Zodd_mod.
apply Zeq_is_eq_bool.
replace (i+i) with (2*i)%Z by omega.
rewrite <- Zmod_div_mod; try omega.
rewrite Z.mul_comm, Z.add_comm.
rewrite Z_mod_plus_full.
reflexivity.
compute; reflexivity.
exists (Z.div Int.modulus 2).
reflexivity.
Qed.

Lemma valid_int_or_ptr_i2:
 forall i, 0 <= i < POINTER_BOUNDARY ->
   valid_int_or_ptr (Vint (Int.repr i)).
Proof.
intros.
simpl.
right.
unfold POINTER_BOUNDARY in *.
rewrite Int.unsigned_repr by rep_omega.
rep_omega.
Qed.

Lemma field_compatible_valid_int_or_ptr:
  forall p,
  field_compatible (Tstruct _tree noattr) [] p ->
  valid_int_or_ptr p.
Proof.
intros.
destruct H as [H1 [_ [_ [H2 _]]]].
destruct p; try contradiction.
clear - H2; simpl in *.
    rewrite Zodd_even_bool.
    apply negb_false_iff.
    apply Zeven_bool_iff.
    inv H2.
    1: inv H.
    inv H1.
    specialize (H4 _left _ _ eq_refl eq_refl).
    inv H4.
    inv H.
    simpl in H0.
    destruct H0 as [j H].
    rewrite Z.add_0_r in H.
    rewrite H; clear.
    replace (j*4)%Z with (2*(2*j))%Z by omega.
    apply Zeven_2p.
Qed.

Lemma treerep_local_facts:
  forall t p,
   treerep t p |--
   !! (valid_int_or_ptr p).
Proof.
intros.
destruct t; simpl.
entailer!.
apply valid_int_or_ptr_ii1.
Intros p1 p2.
entailer!.
apply field_compatible_valid_int_or_ptr; auto.
Qed.

Hint Resolve treerep_local_facts : saturate_local.

Definition test_int_or_ptr_spec :=
 DECLARE _test_int_or_ptr
 WITH x : val
 PRE [ _x OF int_or_ptr_type ]
   PROP(valid_int_or_ptr x) LOCAL(temp _x x) SEP()
 POST [ tint ]
   PROP()
   LOCAL(temp ret_temp
          (Vint (Int.repr (match x with
                    | Vint _ => 1
                    | _ => 0
                    end))))
   SEP().

Definition int_or_ptr_to_int_spec :=
 DECLARE _int_or_ptr_to_int
 WITH x : val
 PRE [ _x OF int_or_ptr_type ]
   PROP(is_int I32 Signed x) LOCAL(temp _x x) SEP()
 POST [ tint ]
   PROP() LOCAL (temp ret_temp x) SEP().

Definition int_or_ptr_to_ptr_spec :=
 DECLARE _int_or_ptr_to_ptr
 WITH x : val
 PRE [ _x OF int_or_ptr_type ]
   PROP(isptr x) LOCAL(temp _x x) SEP()
 POST [ tptr tvoid ]
   PROP() LOCAL (temp ret_temp x) SEP().

Definition int_to_int_or_ptr_spec :=
 DECLARE _int_to_int_or_ptr
 WITH x : val
 PRE [ _x OF tint ]
   PROP(valid_int_or_ptr x)
   LOCAL(temp _x x) SEP()
 POST [ int_or_ptr_type ]
   PROP() LOCAL (temp ret_temp x) SEP().

Definition ptr_to_int_or_ptr_spec :=
 DECLARE _ptr_to_int_or_ptr
 WITH x : val
 PRE [ _x OF tptr tvoid ]
   PROP(valid_int_or_ptr x) LOCAL(temp _x x) SEP()
 POST [ int_or_ptr_type ]
   PROP() LOCAL (temp ret_temp x) SEP().

Definition makenode_spec :=
 DECLARE _makenode
  WITH p: val, q: val
  PRE [ _left OF int_or_ptr_type, _right OF int_or_ptr_type ]
    PROP() LOCAL(temp _left p; temp _right q) SEP()
  POST [ tptr (Tstruct _tree noattr) ]
    EX r:val,
    PROP() LOCAL(temp ret_temp r)
    SEP (data_at Tsh (Tstruct _tree noattr) (p,q) r).

Definition copytree_spec :=
 DECLARE _copytree
  WITH t: tree, p : val
  PRE  [ _t OF int_or_ptr_type ]
    PROP() LOCAL(temp _t p) SEP (treerep t p)
  POST [ int_or_ptr_type ]
    EX v:val,
    PROP() LOCAL(temp ret_temp v)
    SEP (treerep t p; treerep t v).

Definition Gprog : funspecs :=
    ltac:(with_library prog [
    test_int_or_ptr_spec;
    int_or_ptr_to_int_spec;
    int_or_ptr_to_ptr_spec;
    int_to_int_or_ptr_spec;
    ptr_to_int_or_ptr_spec;
    makenode_spec; copytree_spec
  ]).

Lemma body_copytree: semax_body Vprog Gprog f_copytree copytree_spec.
Proof.
  start_function.
  assert_PROP (valid_int_or_ptr p) by entailer!.
  destruct t.
* (* LEAF *)
 unfold treerep.
 Intros. subst p.
 forward_call (Vint (Int.repr (i+i+1))).
 forward_if.
 - (* then clause *)
   forward. simpl.
   Exists (Vint (Int.repr(i+i+1))).
   entailer!.
 - (* else clause *)
  inv H0.
* (* NODE *)
  unfold treerep; fold treerep.
  rename p into t.
  Intros p q.
  forward_call t.
  assert_PROP (isptr t) by entailer!.
  destruct t; try contradiction. clear H0.
  forward_if.
  - (* then clause *)
    contradiction.
  - (* else clause *)
   clear H0. simpl in H.
   forward_call (Vptr b i).
   apply I.
   forward.
     entailer!.
     destruct p; try contradiction; apply I.
   forward_call (t1,p).
   Intros p1.
   deadvars.
   forward.
   forward.
    entailer!.
     destruct q; try contradiction; apply I.
   forward_call (t2,q).
   Intros p2.
   forward.
   deadvars.
   forward_call (p1,p2).
  Intros r.
  assert_PROP (valid_int_or_ptr r). {
    entailer!.
    apply field_compatible_valid_int_or_ptr; auto.
  }
  forward_call r.
  forward. simpl.
  Exists r p q p1 p2.
  entailer!.
Qed.


Require Import aes.aesutils.
Require Import aes.AES256.

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

Local Open Scope logic.

Lemma extra_expansion_sublist : forall k : list word,
  Zlength k = Nk -> sublist 0 (Nb*(Nr+1)) (blocks_to_ints (extra_key_expansion k)) = blocks_to_ints (KeyExpansion k).
Proof.
  intros.
  simpl.
  unfold extra_key_expansion.
  unfold KeyExpansion.
  assert (length k = 8%nat).
    rewrite Zlength_correct in H.
    apply Nat2Z.inj.
    auto.
  do 9 (destruct k as [ | ?w k]; try (inv H0; rename H2 into H0)).
  reflexivity.
Qed.

(* FIPS 197 section 5.3.5 mentions that ShiftRows and SubBytes (or InvShiftRows and
 * InvSubBytes) can commute. Normally, we would stipulate that the blocks are in bounds,
 * but it actually turns out to be unnecessary for the proof. *)

Lemma subbytes_shiftrows_comm : forall b : block,
  ShiftRows (SubBytes b) = SubBytes (ShiftRows b).
Proof.
  intros.
  destruct b as [[[[[[? ?] ?] ?] [[[? ?] ?] ?]] [[[? ?] ?] ?]] [[[? ?] ?] ?]].
  reflexivity.
Qed.

Lemma invsubbytes_invshiftrows_comm : forall b : block,
    InvShiftRows (InvSubBytes b) = InvSubBytes (InvShiftRows b).
Proof.
  intros.
  destruct b as [[[[[[? ?] ?] ?] [[[? ?] ?] ?]] [[[? ?] ?] ?]] [[[? ?] ?] ?]].
  reflexivity.
Qed.

(* FIPS 197 section 5.3.5 mentions that MixColumns and InvMixColumns are linear over
 * XOR (i.e., AddRoundKey) *)

(*
Lemma mixcolumns_xor_linear: forall s : state, rk : block,
    block_in_bounds s -> block_in_bounds rk ->
    MixColumns (AddRoundKey s rk) = AddRoundKey (MixColumns s) (MixColumns rk)
*)

(*
Lemma invmixcolumns_xor_linear : forall s : state, rk : block,
    block_in_bounds s -> block_in_bounds rk ->
    InvMixColumns (AddRoundKey s rk) = AddRoundKey (InvMixColumns s) (InvMixColumns rk).
*)

(* To show correctness of the implementation of the AES ciper round,
 * we will need to take into account that the XOR of C ints also XORs the
 * individual bytes *)
(*
Lemma xor_bytes : forall x y : int,
  let x_bytes := map Int.repr (intlist_to_Zlist [x]) in
  let y_bytes := map Int.repr (intlist_to_Zlist [y]) in
  map Int.repr (intlist_to_Zlist [Int.xor x y]) = map2 Int.xor x_bytes y_bytes.
*)

(* This would show that the mbed TLS implementation of the encryption round is equivalent to
 * the one in the functional spec *)
(*
Lemma round_equiv : forall (s : state) (rk : block),
  block_in_bounds s -> block_in_bounds rk ->
  block_to_ints (transpose (round s rk)) = mbed_tls_fround (block_to_ints (transpose s)) (block_to_ints (transpose rk)).
*)

(* This would show that the reverse encryption round is equivalent to the one in the functional spec *)
(*
Lemma inv_round_equiv : forall (s : state) (rk : block),
  block_in_bounds s -> block_in_bounds rk ->
  block_to_ints (transpose (inv_round s rk)) = mbed_tls_rround (blocks_to_ints (transpose s)) (block_to_ints (transpose rk)).
*)

Lemma sbox_invsbox_inverse : forall a : nat, (a < 256)%nat ->
    let b := Z.to_nat (Int.unsigned (nth a sbox Int.zero)) in
    nth b inv_sbox Int.zero = Int.repr (Z.of_nat a).
Proof.
  intros.
  do 256 (destruct a as [| a]; [reflexivity | ]).
  omega.
Qed.

Lemma invsbox_sbox_inverse : forall a : nat, (a < 256)%nat ->
    let b := Z.to_nat (Int.unsigned (nth a inv_sbox Int.zero)) in
    nth b sbox Int.zero = Int.repr (Z.of_nat a).
Proof.
  intros.
  do 256 (destruct a as [| a]; [reflexivity | ]).
  omega.
Qed.