Require Export L Computable ComputableTime Lproc Lbeta Lrewrite.
Require Import Reflection ListTactics mixedTactics.

Local Ltac wLsimpl' _n := intros;try reflexivity';try standardizeGoal _n ; try reflexivity'.
Local Ltac wLsimpl := wLsimpl' 100.

(* Lsimpl' uses correctnes lemmas and wLsimpl*)
Ltac Lsimpl' :=
  match goal with
  | |- eval ?s _ => (* tryif has_evar s then fail
    else *) assert (lambda s) by Lproc;split;[ (exact (starR _ _);fail 1)|Lproc]
  | |- eval ?s _ => (* tryif has_evar s then fail
    else*) (progress (eapply eval_helper;[Lsimpl';reflexivity|]))

  | _ => try Lrewrite;try wLsimpl' 100
  end.

Ltac Lreduce :=
  repeat progress (try Lrewrite;try Lbeta).

(*Lsimpl that uses correctnes lemmas*)
Ltac Lsimpl :=intros;
  lazymatch goal with
  | |- _ >(<= _ ) _ => Lreduce;try Lreflexivity
  | |- _ ⇓(_ ) _ => repeat progress Lbeta;try Lreflexivity
  | |- _ ⇓(<= _ ) _ => Lreduce;try Lreflexivity
  | |- _ >(_) _ => repeat progress Lbeta;try Lreflexivity
  | |- _ >* _ => Lreduce;try Lreflexivity
  | |- eval _ _ => Lreduce;try Lreflexivity
  | |- _ == _  => repeat Lsimpl';try reflexivity'
  end.

Ltac LsimplHypo := standardizeHypo 100.

Tactic Notation "closedRewrite" :=
  match goal with
    | [ |- context[subst ?s _ _] ] =>
      let cl := fresh "cl" in assert (cl:closed s);[Lproc|rewrite !cl;clear cl]

  end.

Tactic Notation "closedRewrite" "in" hyp(h):=
  match type of h with
    | context[subst ?s _ _] =>
      let cl := fresh "cl" in assert (cl:closed s);[Lproc|rewrite !cl in h;clear cl]
  end.

Tactic Notation "redStep" "at" integer(pos) := rewrite step_Lproc at pos;[simpl;try closedRewrite|Lproc].

Tactic Notation "redStep" "in" hyp(h) "at" integer(pos) := rewrite step_Lproc in h at pos;[simpl in h;try closedRewrite in h|Lproc].

Tactic Notation "redStep" "in" hyp(h) := redStep in h at 1.

(* register needed lemmas:*)

Lemma rho_correct s t : proc s -> lambda t -> rho s t >* s (rho s) t.
Proof.
  intros. unfold rho,r. redStep at 1. apply star_trans_l. Lsimpl.
Qed.

Lemma rho_correctPow s t : proc s -> lambda t -> rho s t >(3) s (rho s) t.
Proof.
  intros. unfold rho,r. change 3 with (1+2). apply pow_add.
  eexists;split. apply (rcomp_1 step). now inv H0.
  cbn. closedRewrite. apply pow_step_congL;[|reflexivity]. now Lbeta.
Qed.

Hint Resolve rho_correct : Lrewrite.

Lemma rho_inj s t: rho s = rho t -> s = t.
Proof.
  unfold rho,r. congruence.
Qed.

Hint Resolve rho_lambda rho_cls : LProc.

Tactic Notation "recStep" constr(P) "at" integer(i):=
  match eval lazy [P] in P with
      | rho ?rP => unfold P;rewrite rho_correct at i;[|Lproc..];fold P;try unfold rP
  end.

Tactic Notation "recStep" constr(P) :=
  intros;recStep P at 1.

Lemma I_proc : proc I.
  fLproc.
Qed.

Lemma K_proc : proc K.
  fLproc.
Qed.

Lemma omega_proc : proc omega.
  fLproc.
Qed.

Lemma Omega_closed : closed Omega.
  fLproc.
Qed.

Hint Resolve I_proc K_proc omega_proc Omega_closed: LProc.

Hint Extern 0 (I >(_) _)=> unfold I;reflexivity : Lrewrite.
Hint Extern 0 (K >(_) _)=> unfold K;reflexivity : Lrewrite.


Require Import FP.Classes.
Require Import FP.CoreData.
Require Import FP.CoreClasses.
Require Import FP.Data.Identity.
Require Import FP.Data.Cont.
Require Import FP.Data.Susp.
Require Import FP.Data.Option.
Require Import FP.Data.Peano.
Require Import FP.Data.N.
Require Import FP.Data.State.

Import CoreDataNotation.
Import CoreClassesNotation.
Import ClassesNotation.
Import SuspNotation.

Section Foldable.
  Context {X T} `{! Foldable X T }.

  Definition fold {A} (f:X -> A -> A) (a:A) : T -> A :=
    cofold (fun (x:X) (aM:identity A) => f x $ run_identity aM) (Identity a).
  Definition mfold {m A} `{! Monad m } (f:X -> A -> m A) (a:A) : T -> m A :=
    fold (fun (x:X) (aM:m A) => a <- aM ;; f x a) (mret a).
  Definition revfold {A} (f:X -> A -> A) : A -> T -> A :=
    run_cont '.:'
      mfold begin fun (x:X) (a:A) =>
        callcc $ fun (k:A -> cont A A) =>
          a <- k a ;;
          mret $ f x a
      end.
  Definition lazyfold {A} (f:forall {C}, X -> (C -> A) -> C -> A) (a:A) : T -> A :=
    cofold (fun (x:X) (aW:susp A) => f x force aW) (delay | a).
End Foldable.

Section Fix.
  Context {T} {F:Foldable T T}.

  Definition fold_fix {A B}
      (ff:(T -> A -> option B) -> T -> A -> option B) (t:T) (a:A) : option B :=
    lazyfold begin fun (C:Type) (t:T) (k:C->T->A->option B) (l:C) =>
      ff $ fun _ (a:A) => k l t a
    end (const2 None) t t a.

  Definition fold_mfix {m A B} `{! Monad m }
      (ff:(T -> A -> m (option B)) -> T -> A -> m (option B)) (t:T) (a:A) : m (option B) :=
    lazyfold begin fun (C:Type) (t:T) (k:C->T->A->m (option B)) (l:C) =>
      ff $ fun _ (a:A) => k l t a
    end (const2 $ mret None) t t a.
End Fix.

Section Iterable.
  Context {X T} `{! Iterable X T }.

  Definition iter {A} (f:A -> X -> A) (a:A) : T -> A :=
    coiter (fun (aM:identity A) (x:X) => f (run_identity aM) x) (Identity a).
  Definition miter {m A} `{! Monad m } (f:A -> X -> m A) (a:A) : T -> m A :=
    iter (fun (aM:m A) (x:X) => a <- aM ;; f a x) (mret a).
  Definition reviter {A} (f:A -> X -> A) : A -> T -> A :=
    run_cont '.:'
      miter begin fun (a:A) (x:X) =>
        callcc $ fun (k:A -> cont A A) =>
          a <- k a ;;
          mret $ f a x
      end.
  Definition lazyiter {A} (f:forall {C}, (C -> A) -> X -> C -> A) (a:A) : T -> A :=
    coiter (fun (aW:susp A) (x:X) => f force x aW) (delay | a).
End Iterable.

Section Buildable.
  Context {X T} `{! Buildable X T }.

  Definition build (f:forall A, (X -> A -> A) -> A -> A) : T :=
    run_identity $ mbuild $
      fun A (f':X -> A -> A) (a:A) =>
        mret $ f A begin fun (x:X) (a:A) =>
          f' x a
        end a.
End Buildable.

Section GeneralizedList.
  Definition map {T A U B} `{! Foldable A T ,! Buildable B U }
      (f:A -> B) (t:T) : U :=
    build $ fun C (cons:B -> C -> C) (nil:C) =>
      fold (fun (a:A) (c:C) => cons (f a) c) nil t.

  Definition foreach {T A U B} `{! Foldable A T ,! Buildable B U }
      : T -> (A -> B) -> U := flip map.

  Definition filter {T A U} `{! Foldable A T ,! Buildable A U }
      (f:A -> bool) (t:T) : U :=
    build $ fun C (cons:A -> C -> C) (nil:C) =>
      fold (fun (a:A) (c:C) => if f a then cons a c else c) nil t.

  Definition select {T A} `{! Foldable A T } (p:A -> bool) : T -> option A :=
    lazyfold begin fun C (a:A) (k:C -> option A) (l:C) =>
      if p a then Some a else k l
    end None.

  Definition lookup {T A B} `{! EqvDec A ,! Foldable (A*B) T } (a:A)
      : T -> option B :=
    mbind_fmap snd '.' select (fun (p:A*B) => fst p ~=! a).

  Definition cat_options {T A U} `{! Foldable (option A) T ,! Buildable A U }
      (t:T) : U :=
    build $ fun C (cons:A -> C -> C) (nil:C) =>
      fold (fun (aM:option A) (c:C) => option_elim aM id cons c) nil t.

  Definition numbered {T A U} `{! Foldable A T ,! Buildable (N*A) U }
      (t:T) : U :=
    eval_state 0 $ mbuild $ fun C (cons:N*A -> C -> C) (nil:C) =>
      mfold begin fun (a:A) (c:C) =>
        n <- pinc ;;
        mret $ cons (n,a) c
      end nil t.

  Definition intersperse {T A U} `{! Foldable A T ,! Buildable A U }
      (i:A) (t:T) : U :=
    eval_state false $ mbuild $ fun C (cons:A -> C -> C) (nil:C) =>
      mfold begin fun (a:A) (c:C) =>
        b <- mget ;;
        mput true ;;
        mret $ if b:bool then
          cons a (cons i c)
        else
          cons a c
      end nil t.

  Definition replicate {T A} `{! Buildable A T } (n:N) (a:A) : T :=
    build $ fun C (cons:A -> C -> C) (nil:C) =>
      loopr (cons a) nil n.

  Definition length {T A P} `{! Foldable A T ,! Peano P } (t:T) : P :=
    exec_state pzero $
      mfold begin fun (_:A) (_:unit) =>
        pinc ;; mret tt
      end tt t.
End GeneralizedList.


From iris.algebra Require Export cmra.
From iris.algebra Require Import updates local_updates.
From stdpp Require Export collections coPset.
Set Default Proof Using "Type".
(** This is pretty much the same as algebra/gset, but I was not able to
generalize the construction without breaking canonical structures. *)

(* The union CMRA *)
Section coPset.
  Implicit Types X Y : coPset.

  Canonical Structure coPsetC := discreteC coPset.

  Instance coPset_valid : Valid coPset := λ _, True.
  Instance coPset_unit : Unit coPset := (∅ : coPset).
  Instance coPset_op : Op coPset := union.
  Instance coPset_pcore : PCore coPset := Some.

  Lemma coPset_op_union X Y : X ⋅ Y = X ∪ Y.
  Proof. done. Qed.
  Lemma coPset_core_self X : core X = X.
  Proof. done. Qed.
  Lemma coPset_included X Y : X ≼ Y ↔ X ⊆ Y.
  Proof.
    split.
    - intros [Z ->]. rewrite coPset_op_union. set_solver.
    - intros (Z&->&?)%subseteq_disjoint_union_L. by exists Z.
  Qed.

  Lemma coPset_ra_mixin : RAMixin coPset.
  Proof.
    apply ra_total_mixin; eauto.
    - solve_proper.
    - solve_proper.
    - solve_proper.
    - intros X1 X2 X3. by rewrite !coPset_op_union assoc_L.
    - intros X1 X2. by rewrite !coPset_op_union comm_L.
    - intros X. by rewrite coPset_core_self idemp_L.
  Qed.
  Canonical Structure coPsetR := discreteR coPset coPset_ra_mixin.

  Global Instance coPset_cmra_discrete : CmraDiscrete coPsetR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma coPset_ucmra_mixin : UcmraMixin coPset.
  Proof. split. done. intros X. by rewrite coPset_op_union left_id_L. done. Qed.
  Canonical Structure coPsetUR := UcmraT coPset coPset_ucmra_mixin.

  Lemma coPset_opM X mY : X ⋅? mY = X ∪ from_option id ∅ mY.
  Proof. destruct mY; by rewrite /= ?right_id_L. Qed.

  Lemma coPset_update X Y : X ~~> Y.
  Proof. done. Qed.

  Lemma coPset_local_update X Y X' : X ⊆ X' → (X,Y) ~l~> (X',X').
  Proof.
    intros (Z&->&?)%subseteq_disjoint_union_L.
    rewrite local_update_unital_discrete=> Z' _ /leibniz_equiv_iff->.
    split. done. rewrite coPset_op_union. set_solver.
  Qed.
End coPset.

(* The disjoiny union CMRA *)
Inductive coPset_disj :=
  | CoPset : coPset → coPset_disj
  | CoPsetBot : coPset_disj.

Section coPset_disj.
  Arguments op _ _ !_ !_ /.
  Canonical Structure coPset_disjC := leibnizC coPset_disj.

  Instance coPset_disj_valid : Valid coPset_disj := λ X,
    match X with CoPset _ => True | CoPsetBot => False end.
  Instance coPset_disj_unit : Unit coPset_disj := CoPset ∅.
  Instance coPset_disj_op : Op coPset_disj := λ X Y,
    match X, Y with
    | CoPset X, CoPset Y => if decide (X ## Y) then CoPset (X ∪ Y) else CoPsetBot
    | _, _ => CoPsetBot
    end.
  Instance coPset_disj_pcore : PCore coPset_disj := λ _, Some ε.

  Ltac coPset_disj_solve :=
    repeat (simpl || case_decide);
    first [apply (f_equal CoPset)|done|exfalso]; set_solver by eauto.

  Lemma coPset_disj_included X Y : CoPset X ≼ CoPset Y ↔ X ⊆ Y.
  Proof.
    split.
    - move=> [[Z|]]; simpl; try case_decide; set_solver.
    - intros (Z&->&?)%subseteq_disjoint_union_L.
      exists (CoPset Z). coPset_disj_solve.
  Qed.
  Lemma coPset_disj_valid_inv_l X Y :
    ✓ (CoPset X ⋅ Y) → ∃ Y', Y = CoPset Y' ∧ X ## Y'.
  Proof. destruct Y; repeat (simpl || case_decide); by eauto. Qed.
  Lemma coPset_disj_union X Y : X ## Y → CoPset X ⋅ CoPset Y = CoPset (X ∪ Y).
  Proof. intros. by rewrite /= decide_True. Qed.
  Lemma coPset_disj_valid_op X Y : ✓ (CoPset X ⋅ CoPset Y) ↔ X ## Y.
  Proof. simpl. case_decide; by split. Qed.

  Lemma coPset_disj_ra_mixin : RAMixin coPset_disj.
  Proof.
    apply ra_total_mixin; eauto.
    - intros [?|]; destruct 1; coPset_disj_solve.
    - by constructor.
    - by destruct 1.
    - intros [X1|] [X2|] [X3|]; coPset_disj_solve.
    - intros [X1|] [X2|]; coPset_disj_solve.
    - intros [X|]; coPset_disj_solve.
    - exists (CoPset ∅); coPset_disj_solve.
    - intros [X1|] [X2|]; coPset_disj_solve.
  Qed.
  Canonical Structure coPset_disjR := discreteR coPset_disj coPset_disj_ra_mixin.

  Global Instance coPset_disj_cmra_discrete : CmraDiscrete coPset_disjR.
  Proof. apply discrete_cmra_discrete. Qed.

  Lemma coPset_disj_ucmra_mixin : UcmraMixin coPset_disj.
  Proof. split; try apply _ || done. intros [X|]; coPset_disj_solve. Qed.
  Canonical Structure coPset_disjUR := UcmraT coPset_disj coPset_disj_ucmra_mixin.
End coPset_disj.


From Coq Require Import Extraction.
From Coq Require Import ZArith.

Extract Inductive nat => "u64" ["0" "__nat_succ"] "__nat_elim!".
Extract Inductive positive => "u64" ["__pos_onebit" "__pos_zerobit" "1"] "__pos_elim!".
Extract Inductive N => "u64" ["0" "__N_frompos"] "__N_elim!".
Extract Inductive Z => "i64" ["0" "__Z_frompos" "__Z_fromneg"] "__Z_elim!".
Extract Inductive comparison =>
  "std::cmp::Ordering"
    ["std::cmp::Ordering::Equal"
     "std::cmp::Ordering::Less"
     "std::cmp::Ordering::Greater"].

Extract Constant BinPosDef.Pos.add => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a + b }".
Extract Constant BinPosDef.Pos.succ => "fn ##name##(&'a self, a: u64) -> u64 { a + 1 }".
Extract Constant BinPosDef.Pos.pred => "fn ##name##(&'a self, a: u64) -> u64 { a - 1 }".
Extract Constant BinPosDef.Pos.sub => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a - b }".
Extract Constant BinPosDef.Pos.mul => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a * b }".
Extract Constant BinPosDef.Pos.min => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { std::cmp::min(a, b) }".
Extract Constant BinPosDef.Pos.max => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { std::cmp::max(a, b) }".
Extract Constant BinPosDef.Pos.eqb => "fn ##name##(&'a self, a: u64, b: u64) -> bool { a == b }".
Extract Constant BinPosDef.Pos.compare =>
"fn ##name##(&'a self, a: u64, b: u64) -> std::cmp::Ordering {
  a.cmp(&b)
}".
Extract Constant BinPosDef.Pos.compare_cont =>
"fn ##name##(&'a self, cont: std::cmp::Ordering, a: u64, b: u64) -> std::cmp::Ordering {
  if a < b then
    std::cmp::Ordering::Less
  else if a == b then
    cont
  else
    std::cmp::Ordering::Greater".

Extract Constant BinNatDef.N.add => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a + b }".
Extract Constant BinNatDef.N.succ => "fn ##name##(&'a self, a: u64) -> u64 { a + 1 }".
Extract Constant BinNatDef.N.pred => "fn ##name##(&'a self, a: u64) -> u64 { a - 1 }".
Extract Constant BinNatDef.N.sub => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a - b }".
Extract Constant BinNatDef.N.mul => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a * b }".
Extract Constant BinNatDef.N.div => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a / b }".
Extract Constant BinNatDef.N.modulo => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { a % b }".
Extract Constant BinNatDef.N.min => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { std::cmp::min(a, b) }".
Extract Constant BinNatDef.N.max => "fn ##name##(&'a self, a: u64, b: u64) -> u64 { std::cmp::max(a, b) }".
Extract Constant BinNatDef.N.eqb => "fn ##name##(&'a self, a: u64, b: u64) -> bool { a == b }".
Extract Constant BinNatDef.N.compare =>
"fn ##name##(&'a self, a: u64, b: u64) -> std::cmp::Ordering { a.cmp(&b) }".

Extract Constant BinIntDef.Z.add => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { a + b }".
Extract Constant BinIntDef.Z.succ => "fn ##name##(&'a self, a: i64) -> i64 { a + 1 }".
Extract Constant BinIntDef.Z.pred => "fn ##name##(&'a self, a: i64) -> i64 { a - 1 }".
Extract Constant BinIntDef.Z.sub => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { a - b }".
Extract Constant BinIntDef.Z.mul => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { a * b }".
Extract Constant BinIntDef.Z.opp => "fn ##name##(&'a self, a: i64) -> i64 { -a }".
Extract Constant BinIntDef.Z.min => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { std::cmp::min(a, b) }".
Extract Constant BinIntDef.Z.max => "fn ##name##(&'a self, a: i64, b: i64) -> i64 { std::cmp::max(a, b) }".
Extract Constant BinIntDef.Z.eqb => "fn ##name##(&'a self, a: i64, b: i64) -> bool { a == b }".
(* TODO: div and modulo are nontrivial since Coq rounds towards negative infinity *)
(*Extract ConstanBinIntDef.t Z.div => "fn ##name##(a: i64, b: i64) -> i64 { a.checked_div(b).unwrap_or(0) }".
Extract Constant BinIntDef.Z.modulo => "fn ##name##(a: i64, b: i64) -> i64 { a.checked_rem(b).unwrap_or(a) }".*)
Extract Constant BinIntDef.Z.compare =>
"fn ##name##(&'a self, a: i64, b: i64) -> std::cmp::Ordering { a.cmp(&b) }".
Extract Constant BinIntDef.Z.of_N =>
"fn ##name##(&'a self, a: u64) -> i64 {
  use std::convert::TryFrom;
  i64::try_from(a).unwrap()
}".
Extract Constant BinIntDef.Z.abs_N => "fn ##name#(&'a self, a: i64) -> u64 { a.unsigned_abs() }".


(*

  Copyright 2014 Cornell University

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

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

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

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

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

*)

Require Export csubst.

Definition bot_exc {o} : @NTerm o := mk_exception mk_bot mk_bot.
Definition bot_excc {o} : @CTerm o := mkc_exception mkc_bot mkc_bot.

Definition mk_isexc {o} (t : @NTerm o) : @NTerm o := mk_approx bot_exc t.

Lemma fold_isexc {p} :
  forall (t : @NTerm p),
    mk_approx bot_exc t = mk_isexc t.
Proof. sp. Qed.

Lemma wf_bot_exc {o} : @wf_term o bot_exc.
Proof.
  unfold bot_exc.
  apply wf_exception; eauto 3 with slow.
Qed.
Hint Resolve wf_bot_exc : slow.

Lemma wf_isexc {p} :
  forall a : @NTerm p, wf_term a -> wf_term (mk_isexc a).
Proof.
  sp; unfold mk_isexc.
  allrw @wf_term_eq.
  constructor; repeat (allsimpl; sp; subst; repeat constructor).
Qed.

Lemma wf_isexc_iff {p} :
  forall a : @NTerm p, wf_term a <=> wf_term (mk_isexc a).
Proof.
  sp; split; intro i.
  apply wf_isexc; sp.
  allrw @wf_term_eq.
  allrw @nt_wf_eq.
  apply wf_approx_iff in i; sp.
Qed.

Lemma isprogram_bot_exc {o} : @isprogram o bot_exc.
Proof.
  introv.
  apply isprogram_exception; eauto 3 with slow.
Qed.
Hint Resolve isprogram_bot_exc : slow.

Lemma isprogram_isexc {p} :
  forall t : @NTerm p,
    isprogram t
    -> isprogram (mk_isexc t).
Proof.
  unfold mk_isexc; introv isp.
  apply isprogram_approx; eauto 3 with slow.
Qed.

Lemma isprog_isexc {p} :
  forall t : @NTerm p,
    isprog t
    -> isprog (mk_isexc t).
Proof.
  sp; allrw @isprog_eq.
  apply isprogram_isexc; sp.
Qed.

Definition mkc_isexc {p} (t : @CTerm p) : CTerm :=
  let (a,x) := t in
    exist isprog (mk_isexc a) (isprog_isexc a x).

Lemma isprog_vars_isexc {p} :
  forall vs (a : @NTerm p), isprog_vars vs (mk_isexc a) <=> isprog_vars vs a.
Proof.
  introv.
  allrw @isprog_vars_eq; simpl.
  allrw remove_nvars_nil_l; allrw app_nil_r.
  allrw @nt_wf_eq.
  allrw <- @wf_isexc_iff; sp.
Qed.

Lemma cover_vars_isexc {p} :
  forall a sub,
    @cover_vars p (mk_isexc a) sub
    <=> cover_vars a sub.
Proof.
  sp; unfold mk_isexc; split; sp; allrw @cover_vars_eq; allsimpl;
  allrw remove_nvars_nil_l; allrw app_nil_r;
  allrw subvars_app_l; sp.
Qed.

Lemma csubst_bot_exc {o} :
  forall (sub : @CSub o), csubst bot_exc sub = bot_exc.
Proof.
  introv.
  apply csubst_trivial.
  simpl; auto.
Qed.

Lemma lsubstc_bot_exc {o} :
  forall (sub : @CSub o)
         (w  : wf_term bot_exc)
         (c  : cover_vars bot_exc sub),
    lsubstc bot_exc w sub c = bot_excc.
Proof.
  introv.
  pose proof (lsubstc_mk_exception_ex mk_bot mk_bot sub w c) as h; exrepnd.
  unfold bot_exc.
  rw h1; clear h1.
  allrw @lsubstc_mk_bot; auto.
Qed.

Lemma lsubstc_vars_bot_exc {o} :
  forall (sub : @CSub o)
         (w  : wf_term bot_exc)
         (vs : list NVar)
         (c  : cover_vars_upto bot_exc sub vs),
    lsubstc_vars bot_exc w sub vs c = mk_cv vs bot_excc.
Proof.
  introv.
  apply cvterm_eq; simpl.
  rw @csubst_bot_exc; auto.
Qed.

Lemma lsubstc_mk_isexc {p} :
  forall t sub,
  forall wt : @wf_term p t,
  forall w  : wf_term (mk_isexc t),
  forall ct : cover_vars t sub,
  forall c  : cover_vars (mk_isexc t) sub,
    lsubstc (mk_isexc t) w sub c
    = mkc_isexc (lsubstc t wt sub ct).
Proof.
  unfold mk_isexc; sp.
  pose proof (lsubstc_mk_approx_ex bot_exc t sub w c) as h.
  exrepnd.
  rw h1; clear h1.
  rw @lsubstc_bot_exc.
  apply cterm_eq; simpl; auto.
Qed.

Lemma lsubstc_mk_isexc_ex {p} :
  forall t sub,
  forall w  : wf_term (@mk_isexc p t),
  forall c  : cover_vars (mk_isexc t) sub,
    {wt : wf_term t
     & {ct : cover_vars t sub
        & lsubstc (mk_isexc t) w sub c
             = mkc_isexc (lsubstc t wt sub ct)}}.
Proof.
  sp.
  duplicate w; duplicate c.
  rw <- @wf_isexc_iff in w.
  rw @cover_vars_isexc in c.
  exists w c.
  apply lsubstc_mk_isexc.
Qed.

Lemma mkc_isexc_eq {o} :
  forall (t : @CTerm o), mkc_isexc t = mkc_approx bot_excc t.
Proof.
  introv.
  destruct_cterms.
  apply cterm_eq; simpl; auto.
Qed.

Definition mk_halts_like {o} (t : @NTerm o) : @NTerm o :=
  mk_approx bot_exc (mk_cbv t nvarx bot_exc).

Lemma fold_halts_like {p} :
  forall (t : @NTerm p),
    mk_approx bot_exc (mk_cbv t nvarx bot_exc) = mk_halts_like t.
Proof. sp. Qed.

Lemma wf_halts_like {p} :
  forall a : @NTerm p, wf_term a -> wf_term (mk_halts_like a).
Proof.
  introv wf; unfold mk_halts_like.
  apply wf_approx; eauto 3 with slow.
  apply wf_cbv; eauto 3 with slow.
Qed.

Lemma wf_halts_like_iff {p} :
  forall a : @NTerm p, wf_term a <=> wf_term (mk_halts_like a).
Proof.
  sp; split; intro i.
  apply wf_halts_like; sp.
  unfold mk_halts_like in i.
  apply wf_approx_iff in i; repnd.
  apply wf_cbv_iff in i; sp.
Qed.

Lemma isprogram_halts_like {p} :
  forall t : @NTerm p,
    isprogram t
    -> isprogram (mk_halts_like t).
Proof.
  unfold mk_halts_like; introv isp.
  apply isprogram_approx; eauto 3 with slow.
  apply isprogram_cbv; eauto 3 with slow.
Qed.

Lemma isprog_halts_like {p} :
  forall t : @NTerm p,
    isprog t
    -> isprog (mk_halts_like t).
Proof.
  sp; allrw @isprog_eq.
  apply isprogram_halts_like; sp.
Qed.

Definition mkc_halts_like {p} (t : @CTerm p) : CTerm :=
  let (a,x) := t in
    exist isprog (mk_halts_like a) (isprog_halts_like a x).

Lemma isprog_vars_halts_like {p} :
  forall vs (a : @NTerm p), isprog_vars vs (mk_halts_like a) <=> isprog_vars vs a.
Proof.
  introv.
  allrw @isprog_vars_eq; simpl.
  allrw remove_nvars_nil_l; allrw app_nil_r.
  allrw @nt_wf_eq.
  allrw <- @wf_halts_like_iff; sp.
Qed.

Lemma cover_vars_halts_like {p} :
  forall a sub,
    @cover_vars p (mk_halts_like a) sub
    <=> cover_vars a sub.
Proof.
  sp; unfold mk_halts_like; split; sp; allrw @cover_vars_eq; allsimpl;
  allrw remove_nvars_nil_l; allrw app_nil_r;
  allrw subvars_app_l; sp.
Qed.

Lemma lsubstc_mk_halts_like {p} :
  forall t sub,
  forall wt : @wf_term p t,
  forall w  : wf_term (mk_halts_like t),
  forall ct : cover_vars t sub,
  forall c  : cover_vars (mk_halts_like t) sub,
    lsubstc (mk_halts_like t) w sub c
    = mkc_halts_like (lsubstc t wt sub ct).
Proof.
  unfold mk_isexc; sp.
  pose proof (lsubstc_mk_approx_ex bot_exc (mk_cbv t nvarx bot_exc) sub w c) as h.
  exrepnd.
  unfold mk_halts_like.
  rw h1; clear h1.
  pose proof (lsubstc_mk_cbv_ex t nvarx bot_exc sub w2 c2) as h; exrepnd.
  rw h1; clear h1.
  rw @lsubstc_bot_exc.
  rw @lsubstc_vars_bot_exc.
  apply cterm_eq; simpl; auto.
Qed.

Lemma lsubstc_mk_halts_like_ex {p} :
  forall t sub,
  forall w  : wf_term (@mk_halts_like p t),
  forall c  : cover_vars (mk_halts_like t) sub,
    {wt : wf_term t
     & {ct : cover_vars t sub
     & lsubstc (mk_halts_like t) w sub c
       = mkc_halts_like (lsubstc t wt sub ct)}}.
Proof.
  sp.
  duplicate w; duplicate c.
  rw <- @wf_halts_like_iff in w.
  rw @cover_vars_halts_like in c.
  exists w c.
  apply lsubstc_mk_halts_like.
Qed.


Require Import TestSuite.admit.
(* -*- mode: coq; coq-prog-args: ("-indices-matter") -*- *)
Set Universe Polymorphism.

Inductive Empty : Prop := .

Inductive paths {A : Type} (a : A) : A -> Type :=
  idpath : paths a a.

Notation "x = y :> A" := (@paths A x y) : type_scope.
Notation "x = y" := (x = y :>_) : type_scope.
Arguments idpath {A a} , [A] a.

Definition idmap {A : Type} : A -> A := fun x => x.

Definition path_sum {A B : Type} (z z' : A + B)
           (pq : match z, z' with
                   | inl z0, inl z'0 => z0 = z'0
                   | inr z0, inr z'0 => z0 = z'0
                   | _, _ => Empty
                 end)
: z = z'.

  admit.
Defined.
Definition ap {A B:Type} (f:A -> B) {x y:A} (p:x = y) : f x = f y
  := match p with idpath => idpath end.

Theorem ex2_8 {A B A' B' : Type} (g : A -> A') (h : B -> B') (x y : A + B)

        (pq : match (x, y) with (inl x', inl y') => x' = y' | (inr x', inr y') => x' = y' | _ => Empty end) :
  let f z := match z with inl z' => inl (g z') | inr z' => inr (h z') end in
  ap f (path_sum x y pq) = path_sum (f x) (f y)
                                    ((match x as x return match (x, y) with
                                                              (inl x', inl y') => x' = y'
                                                            | (inr x', inr y') => x' = y'
                                                            | _ => Empty
                                                          end -> match (f x, f y) with
                                                                   | (inl x', inl y') => x' = y'
                                                                   | (inr x', inr y') => x' = y'
                                                                   | _ => Empty end with
                                        | inl x' => match y with
                                                      | inl y' => ap g
                                                      | inr y' => idmap
                                                    end
                                        | inr x' => match y with
                                                      | inl y' => idmap
                                                      | inr y' => ap h
                                                    end
                                      end) pq).

Admitted.
(* Toplevel input, characters 20-29:
Error: Matching on term "f y" of type "A' + B'" expects 2 branches. *)


Require Import Bool.
Require Import List.

From sflib Require Import sflib.
From Paco Require Import paco.

From PromisingLib Require Import Basic.
From PromisingLib Require Import Loc.

Require Import Event.
From PromisingLib Require Import Language.
Require Import Time.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Thread.
Require Import Configuration.

Require Import FulfillStep.
Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.
Require Import Compatibility.
Require Import SimThread.

Require Import Syntax.
Require Import Semantics.
Require Import SplitAcq.

Set Implicit Arguments.

Definition local_acqrel (lc:Local.t) :=
  (Local.mk (TView.write_fence_tview
               (TView.read_fence_tview lc.(Local.tview) Ordering.acqrel)
               TimeMap.bot
               Ordering.acqrel)
            lc.(Local.promises)).

Lemma sim_local_promise_acqrel
      lc1_src mem1_src
      lc1_tgt mem1_tgt
      lc2_tgt mem2_tgt
      loc from to val released kind
      (STEP_TGT: Local.promise_step lc1_tgt mem1_tgt loc from to val released lc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local lc1_src (local_acqrel lc1_tgt))
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src mem2_src,
    <<STEP_SRC: Local.promise_step lc1_src mem1_src loc from to val released lc2_src mem2_src kind>> /\
    <<LOCAL2: sim_local lc2_src (local_acqrel lc2_tgt)>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  inv LOCAL1. inv STEP_TGT.
  exploit SimPromises.promise_bot; eauto.
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  i. des.
  exploit sim_memory_closed_opt_view; eauto. i.
  exploit Memory.promise_future; try apply PROMISE_SRC; eauto.
  { apply WF1_SRC. }
  { apply WF1_SRC. }
  i. des.
  esplits; eauto.
  - econs; eauto.
  - econs; eauto.
Qed.

Lemma sim_local_fulfill_acqrel
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt
      loc from to val releasedm_src releasedm_tgt released ord_src ord_tgt
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_WF: View.opt_wf releasedm_src)
      (RELM_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT: Time.le (View.rlx (View.unwrap releasedm_tgt) loc) from)
      (WF_RELM_TGT: View.opt_wf releasedm_tgt)
      (ORD: Ordering.le ord_src ord_tgt)
      (ORD_TGT: Ordering.le ord_tgt Ordering.acqrel)
      (STEP_TGT: fulfill_step lc1_tgt sc1_tgt loc from to val releasedm_tgt released ord_tgt lc2_tgt sc2_tgt)
      (LOCAL1: sim_local lc1_src (local_acquired lc1_tgt))
      (ACQUIRED1: View.le lc1_src.(Local.tview).(TView.cur)
                          (View.join lc1_tgt.(Local.tview).(TView.cur) releasedm_tgt.(View.unwrap)))
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists lc2_src sc2_src,
    <<STEP_SRC: fulfill_step lc1_src sc1_src loc from to val releasedm_src released ord_src lc2_src sc2_src>> /\
    <<LOCAL2: sim_local lc2_src (local_acqrel lc2_tgt)>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>>.
Proof.
  inv STEP_TGT.
  assert (RELT_LE:
   View.opt_le
     (TView.write_released lc1_src.(Local.tview) sc1_src loc to releasedm_src ord_src)
     (TView.write_released lc1_tgt.(Local.tview) sc2_tgt loc to releasedm_tgt ord_tgt)).
  { unfold TView.write_released, TView.write_tview. ss. viewtac.
    repeat (condtac; aggrtac;
            try match goal with
                | [|- View.opt_le _ _] => econs
                end);
      try apply WF1_TGT.
    - etrans; eauto. aggrtac.
    - etrans; [apply WF1_SRC|]. etrans; eauto. aggrtac.
    - etrans; [apply LOCAL1|]. aggrtac.
  }
  assert (RELT_WF:
   View.opt_wf (TView.write_released lc1_src.(Local.tview) sc1_src loc to releasedm_src ord_src)).
  { unfold TView.write_released. condtac; econs.
    repeat (try condtac; viewtac; try apply WF1_SRC).
  }
  exploit SimPromises.remove_bot; try exact REMOVE;
    try exact MEM1; try apply LOCAL1; eauto.
  { apply WF1_SRC. }
  { apply WF1_TGT. }
  { apply WF1_TGT. }
  i. des. esplits.
  - econs; eauto.
    + etrans; eauto.
    + inv WRITABLE. econs.
      * eapply TimeFacts.le_lt_lt; [apply ACQUIRED1|]. viewtac.
        eapply TimeFacts.le_lt_lt; eauto.
  - econs; eauto. s.
    unfold TView.write_tview, TView.write_fence_tview, TView.read_fence_tview. ss.
    econs; ss; repeat (condtac; aggrtac).
    all: try by destruct ord_src, ord_tgt.
    all: try by apply WF1_TGT.
    + etrans; [apply LOCAL1|]. repeat (try condtac; aggrtac).
    + etrans; [apply LOCAL1|]. aggrtac.
      etrans; [apply WF1_TGT|]. etrans; [apply WF1_TGT|]. aggrtac.
    + etrans; [apply LOCAL1|]. aggrtac.
      etrans; [apply WF1_TGT|]. etrans; [apply WF1_TGT|]. aggrtac.
    + etrans; [apply LOCAL1|]. repeat (try condtac; aggrtac).
      etrans; [apply WF1_TGT|]. etrans; [apply WF1_TGT|]. aggrtac.
    + etrans; [apply LOCAL1|]. ss. condtac; aggrtac.
    + etrans; [apply LOCAL1|]. aggrtac.
  - ss.
Qed.

Lemma sim_local_write_acqrel
      lc1_src sc1_src mem1_src
      lc1_tgt sc1_tgt mem1_tgt
      lc2_tgt sc2_tgt mem2_tgt
      loc from to val releasedm_src releasedm_tgt released_tgt ord_src ord_tgt kind
      (RELM_LE: View.opt_le releasedm_src releasedm_tgt)
      (RELM_SRC_WF: View.opt_wf releasedm_src)
      (RELM_SRC_CLOSED: Memory.closed_opt_view releasedm_src mem1_src)
      (RELM_TGT_WF: View.opt_wf releasedm_tgt)
      (RELM_TGT_CLOSED: Memory.closed_opt_view releasedm_tgt mem1_tgt)
      (RELM_TGT: Time.le (View.rlx (View.unwrap releasedm_tgt) loc) from)
      (ORD: Ordering.le ord_src ord_tgt)
      (ORD_TGT: Ordering.le ord_tgt Ordering.acqrel)
      (STEP_TGT: Local.write_step lc1_tgt sc1_tgt mem1_tgt loc from to val releasedm_tgt released_tgt ord_tgt lc2_tgt sc2_tgt mem2_tgt kind)
      (LOCAL1: sim_local lc1_src (local_acquired lc1_tgt))
      (ACQUIRED1: View.le lc1_src.(Local.tview).(TView.cur)
                          (View.join lc1_tgt.(Local.tview).(TView.cur) releasedm_tgt.(View.unwrap)))
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (WF1_SRC: Local.wf lc1_src mem1_src)
      (WF1_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC1_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC1_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM1_SRC: Memory.closed mem1_src)
      (MEM1_TGT: Memory.closed mem1_tgt):
  exists released_src lc2_src sc2_src mem2_src,
    <<STEP_SRC: Local.write_step lc1_src sc1_src mem1_src loc from to val releasedm_src released_src ord_src lc2_src sc2_src mem2_src kind>> /\
    <<REL2: View.opt_le released_src released_tgt>> /\
    <<LOCAL2: sim_local lc2_src (local_acqrel lc2_tgt)>> /\
    <<SC2: TimeMap.le sc2_src sc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>>.
Proof.
  exploit write_promise_fulfill; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  exploit sim_local_promise_acquired; eauto. i. des.
  exploit Local.promise_step_future; eauto. i. des.
  hexploit sim_local_fulfill_acqrel; try apply STEP2;
    try apply LOCAL2; try apply MEM2; eauto.
  { eapply Memory.future_closed_opt_view; eauto. }
  { inv STEP_SRC. inv STEP1. ss. }
  i. des.
  exploit promise_fulfill_write; try exact STEP_SRC; try exact STEP_SRC0; eauto.
  { i. exploit ORD0; eauto.
    - etrans; eauto.
    - i. des. splits; auto. eapply sim_local_nonsynch_loc; eauto.
  }
  i. des. esplits; eauto. etrans; eauto.
Qed.

Inductive split_acqrel: forall (i1 i2:Instr.t), Prop :=
| split_acqrel_load
    r l:
    split_acqrel (Instr.load r l Ordering.acqrel) (Instr.load r l Ordering.relaxed)
| split_acqrel_update
    r l rmw ow
    (OW: Ordering.le ow Ordering.acqrel):
    split_acqrel (Instr.update r l rmw Ordering.acqrel ow) (Instr.update r l rmw Ordering.relaxed ow)
.

Inductive sim_acqrel: forall (st_src:lang.(Language.state)) (lc_src:Local.t) (sc1_src:TimeMap.t) (mem1_src:Memory.t)
                        (st_tgt:lang.(Language.state)) (lc_tgt:Local.t) (sc1_tgt:TimeMap.t) (mem1_tgt:Memory.t), Prop :=
| sim_acqrel_intro
    rs
    lc1_src sc1_src mem1_src
    lc1_tgt sc1_tgt mem1_tgt
    (LOCAL: sim_local lc1_src (local_acqrel lc1_tgt))
    (SC: TimeMap.le sc1_src sc1_tgt)
    (MEMORY: sim_memory mem1_src mem1_tgt)
    (WF_SRC: Local.wf lc1_src mem1_src)
    (WF_TGT: Local.wf lc1_tgt mem1_tgt)
    (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
    (SC_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
    (MEM_SRC: Memory.closed mem1_src)
    (MEM_TGT: Memory.closed mem1_tgt):
    sim_acqrel
      (State.mk rs []) lc1_src sc1_src mem1_src
      (State.mk rs [Stmt.instr (Instr.fence Ordering.acqrel Ordering.acqrel)]) lc1_tgt sc1_tgt mem1_tgt
.

Lemma sim_acqrel_mon
      st_src lc_src sc1_src mem1_src
      st_tgt lc_tgt sc1_tgt mem1_tgt
      sc2_src mem2_src
      sc2_tgt mem2_tgt
      (SIM1: sim_acqrel st_src lc_src sc1_src mem1_src
                          st_tgt lc_tgt sc1_tgt mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc1_src sc2_src)
      (SC_FUTURE_TGT: TimeMap.le sc1_tgt sc2_tgt)
      (MEM_FUTURE_SRC: Memory.future mem1_src mem2_src)
      (MEM_FUTURE_TGT: Memory.future mem1_tgt mem2_tgt)
      (SC1: TimeMap.le sc2_src sc2_tgt)
      (MEM1: sim_memory mem2_src mem2_tgt)
      (WF_SRC: Local.wf lc_src mem2_src)
      (WF_TGT: Local.wf lc_tgt mem2_tgt)
      (SC_SRC: Memory.closed_timemap sc2_src mem2_src)
      (SC_TGT: Memory.closed_timemap sc2_tgt mem2_tgt)
      (MEM_SRC: Memory.closed mem2_src)
      (MEM_TGT: Memory.closed mem2_tgt):
  sim_acqrel st_src lc_src sc2_src mem2_src
               st_tgt lc_tgt sc2_tgt mem2_tgt.
Proof.
  inv SIM1. econs; eauto.
Qed.

Lemma sim_acqrel_future
      st_src lc_src sc1_src mem1_src
      st_tgt lc_tgt sc1_tgt mem1_tgt
      sc2_src mem2_src
      (SC1: TimeMap.le sc1_src sc1_tgt)
      (MEM1: sim_memory mem1_src mem1_tgt)
      (SIM1: sim_acqrel st_src lc_src sc1_src mem1_src
                          st_tgt lc_tgt sc1_tgt mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc1_src sc2_src)
      (MEM_FUTURE_SRC: Memory.future mem1_src mem2_src)
      (WF_SRC: Local.wf lc_src mem2_src)
      (SC_SRC: Memory.closed_timemap sc2_src mem2_src)
      (MEM_SRC: Memory.closed mem2_src):
  exists lc'_src sc2_tgt mem2_tgt,
    <<SC2: TimeMap.le sc2_src sc2_tgt>> /\
    <<MEM2: sim_memory mem2_src mem2_tgt>> /\
    <<SC_FUTURE_TGT: TimeMap.le sc1_tgt sc2_tgt>> /\
    <<MEM_FUTURE_TGT: Memory.future mem1_tgt mem2_tgt>> /\
    <<WF_TGT: Local.wf lc_tgt mem2_tgt>> /\
    <<SC_TGT: Memory.closed_timemap sc2_tgt mem2_tgt>> /\
    <<MEM_TGT: Memory.closed mem2_tgt>> /\
    <<SIM2: sim_acqrel st_src lc'_src sc2_src mem2_src
                         st_tgt lc_tgt sc2_tgt mem2_tgt>>.
Proof.
  inv SIM1.
  exploit SimPromises.future; try apply MEM1; eauto.
  { inv LOCAL. ss. eauto. }
  i. des. esplits; eauto.
  - etrans.
    + apply Memory.max_timemap_spec; eauto. viewtac.
    + apply sim_memory_max_timemap; eauto.
  - etrans.
    + apply Memory.max_timemap_spec; eauto. viewtac.
    + apply Memory.future_max_timemap; eauto.
  - apply Memory.max_timemap_closed. viewtac.
  - econs; eauto.
    + etrans.
      * apply Memory.max_timemap_spec; eauto. viewtac.
      * apply sim_memory_max_timemap; eauto.
    + apply Memory.max_timemap_closed. viewtac.
Qed.

Lemma sim_acqrel_step
      st1_src lc1_src sc1_src mem1_src
      st1_tgt lc1_tgt sc1_tgt mem1_tgt
      (SIM: sim_acqrel st1_src lc1_src sc1_src mem1_src
                         st1_tgt lc1_tgt sc1_tgt mem1_tgt):
  _sim_thread_step lang lang ((sim_thread (sim_terminal eq)) \8/ sim_acqrel)
                   st1_src lc1_src sc1_src mem1_src
                   st1_tgt lc1_tgt sc1_tgt mem1_tgt.
Proof.
  inv SIM. ii.
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR; inv SPLIT); ss.
  - (* promise *)
    exploit Local.promise_step_future; eauto. i. des.
    exploit sim_local_promise_acqrel; try exact LOCAL; eauto. i. des.
    exploit Local.promise_step_future; eauto. i. des.
    esplits; try apply SC; eauto.
    + econs 2. econs. econs; eauto.
    + eauto.
    + right. econs; eauto.
  - (* fence *)
    exploit Local.fence_step_future; eauto. i. des.
    inv STATE. inv INSTR. inv LOCAL1. ss.
    esplits; (try by econs 1); eauto.
    left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
Qed.

Lemma sim_acqrel_sim_thread:
  sim_acqrel <8= (sim_thread (sim_terminal eq)).
Proof.
  pcofix CIH. i. pfold. ii. ss. splits; ss; ii.
  - inv TERMINAL_TGT. inv PR; ss.
  - exploit sim_acqrel_mon; eauto. i.
    exploit sim_acqrel_future; try apply x0; eauto. i. des.
    esplits; eauto.
  - esplits; eauto.
    inv PR. eapply sim_local_memory_bot; eauto.
  - exploit sim_acqrel_mon; eauto. i. des.
    exploit sim_acqrel_step; eauto. i. des.
    + esplits; eauto.
      left. eapply paco9_mon; eauto. ss.
    + esplits; eauto.
Qed.

Lemma split_acqrel_sim_stmts
      i_src i_tgt
      (SPLIT: split_acqrel i_src i_tgt):
  sim_stmts eq
            [Stmt.instr i_src]
            [Stmt.instr i_tgt; Stmt.instr (Instr.fence Ordering.acqrel Ordering.acqrel)]
            eq.
Proof.
  pcofix CIH. ii. subst. pfold. ii. splits; ii.
  { inv TERMINAL_TGT. }
  { exploit SimPromises.future; try apply LOCAL; eauto. i. des.
    esplits; eauto.
    - etrans.
      + apply Memory.max_timemap_spec; eauto. viewtac.
      + apply sim_memory_max_timemap; eauto.
    - etrans.
      + apply Memory.max_timemap_spec; eauto. viewtac.
      + apply Memory.future_max_timemap; eauto.
    - apply Memory.max_timemap_closed. viewtac.
  }
  { esplits; eauto.
    inv LOCAL. apply SimPromises.sem_bot_inv in PROMISES; auto. rewrite PROMISES. auto.
  }
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR; inv SPLIT); ss.
  - (* promise *)
    exploit sim_local_promise; eauto. i. des.
    esplits; try apply SC; eauto.
    econs 2. econs 1; eauto. econs; eauto. eauto.
  - (* load *)
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read_acquired; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    esplits; try apply SC; eauto.
    + econs 2. econs 2. econs; cycle 1.
      * econs 2. eauto.
      * econs. econs.
    + auto.
    + left. eapply paco9_mon; [apply sim_acqrel_sim_thread|]; ss.
      econs; ss. inv LOCAL2. econs; ss.
      etrans; eauto. apply TViewFacts.write_fence_tview_incr.
      eapply TViewFacts.read_fence_future; apply WF2.
  - (* update-load *)
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read_acquired; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    esplits; try apply SC; eauto.
    + econs 2. econs 2. econs; cycle 1.
      * econs 2. eauto.
      * econs. econs. eauto.
    + auto.
    + left. eapply paco9_mon; [apply sim_acqrel_sim_thread|]; ss.
      econs; ss. inv LOCAL2. econs; ss.
      etrans; eauto. apply TViewFacts.write_fence_tview_incr.
      eapply TViewFacts.read_fence_future; apply WF2.
  - (* update *)
    exploit Local.read_step_future; eauto. i. des.
    exploit sim_local_read_acquired; eauto. i. des.
    exploit Local.read_step_future; eauto. i. des.
    exploit Local.write_step_future; eauto. i. des.
    hexploit sim_local_write_acqrel; try exact LOCAL2; try exact SC; eauto; try refl.
    { inv LOCAL1. eapply MEM_TGT. eauto. }
    { inv STEP_SRC. inv LOCAL1. ss. repeat (condtac; aggrtac).
      - rewrite <- ? View.join_l. apply LOCAL.
      - apply WF_TGT.
      - unfold TimeMap.join. rewrite <- Time.join_l. rewrite <- Time.join_l. rewrite <- Time.join_r.
        unfold View.singleton_ur_if. condtac; ss. unfold TimeMap.singleton, LocFun.add.
        condtac; ss. refl.
    }
    i. des.
    exploit Local.write_step_future; eauto. i. des.
    esplits; try apply SC; eauto.
    + econs 2. econs 2. econs; cycle 1.
      * econs 4; eauto.
      * econs. econs. eauto.
    + auto.
    + left. eapply paco9_mon; [apply sim_acqrel_sim_thread|]; ss.
Qed.


Require Import Coq.ZArith.ZArith.
Require Import Coq.Strings.String.
Require Import Coq.Lists.List.
Require Import Coq.micromega.Lia.
Require Import bedrock2.Syntax.
Require Import bedrock2.ProgramLogic.
Require Import bedrock2.Map.Separation.
Require Import bedrock2.Map.SeparationLogic.
Require Import bedrock2.WeakestPreconditionProperties.
Require Import coqutil.Word.Interface.
Require Import coqutil.Word.Properties.
Require Import coqutil.Map.Interface.
Require Import coqutil.Map.Properties.
Require Import coqutil.Datatypes.List.
Require Import coqutil.Datatypes.PropSet.
Require Import Crypto.Bedrock.Field.Common.Types.
Require Import Crypto.Bedrock.Field.Common.Tactics.
Require Import Crypto.Bedrock.Field.Common.Util.
Require Import Crypto.Bedrock.Field.Translation.Proofs.Cmd.
Require Import Crypto.Bedrock.Field.Translation.Proofs.Equivalence.
Require Import Crypto.Bedrock.Field.Translation.Proofs.EquivalenceProperties.
Require Import Crypto.Bedrock.Field.Translation.Proofs.Flatten.
Require Import Crypto.Bedrock.Field.Translation.Proofs.UsedVarnames.
Require Import Crypto.Bedrock.Field.Translation.Proofs.VarnameSet.
Require Import Crypto.Bedrock.Field.Translation.Proofs.LoadStoreList.
Require Import Crypto.Bedrock.Field.Translation.Func.
Require Import Crypto.Bedrock.Field.Translation.Flatten.
Require Import Crypto.Bedrock.Field.Translation.LoadStoreList.
Require Import Crypto.Language.API.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.Option.
Import ListNotations. Local Open Scope Z_scope.

Import API.Compilers.
Import Wf.Compilers.expr.
Import Types.Notations.

Section Func.
  Context
    {width BW word mem locals env ext_spec varname_gen error}
   `{parameters_sentinel : @parameters width BW word mem locals env ext_spec varname_gen error}.
  Context {ok : ok}.

  Local Existing Instance rep.Z.

  Inductive valid_func : forall {t}, @API.expr (fun _ => unit) t -> Prop :=
  | validf_Abs :
      forall {s d} f, valid_func (f tt) ->
                      valid_func (expr.Abs (s:=type.base s) (d:=d) f)
  | validf_base :
      forall {b} e, valid_cmd e -> valid_func (t:=type.base b) e
  .

  Lemma translate_func'_correct {t}
        (* three exprs, representing the same Expr with different vars *)
        (e0 : @API.expr (fun _ => unit) t)
        (e1 : @API.expr API.interp_type t)
        (e2 : @API.expr ltype t)
        (* expressions are valid input to translate_func' *)
        (e0_valid : valid_func e0)
        (* context list (consists only of arguments) *)
        (G : list _) :
    (* exprs are all related *)
    wf3 G e0 e1 e2 ->
    forall (argnames : type.for_each_lhs_of_arrow ltype t)
           (args : type.for_each_lhs_of_arrow API.interp_type t)
           (nextn : nat),
      (* ret1 := fiat-crypto interpretation of e1 applied to args1 *)
      let ret1 : base.interp (type.final_codomain t) :=
          type.app_curried (API.interp e1) args in
      (* out := translation output for e2; triple of
         (# varnames used, return values, cmd) *)
      let out := translate_func' e2 nextn argnames in
      let nvars := fst (fst out) in
      let ret2 := base_rtype_of_ltype (snd (fst out)) in
      let body := snd out in
      (* look up variables in argnames *)
      let argvalues :=
          type.map_for_each_lhs_of_arrow rtype_of_ltype argnames in
      (* argnames don't contain variables we could later overwrite *)
      (forall n,
        (nextn <= n)%nat ->
        ~ varname_set_args argnames (varname_gen n)) ->
      (* G doesn't contain variables we could overwrite *)
      (forall n,
        (nextn <= n)%nat ->
        ~ context_varname_set G (varname_gen n)) ->
      forall (tr : Semantics.trace)
             (locals : locals)
             (mem : mem)
             (functions : list (string*func)),
        (* locals doesn't contain variables we could overwrite *)
        (forall n nvars,
            (nextn <= n)%nat ->
            map.undef_on locals (used_varnames (varname_gen:=varname_gen) n nvars)) ->
        (* argument values are equivalent *)
        locally_equivalent_args args argvalues locals ->
        (* contexts are equivalent; for every variable in the context list G,
           the fiat-crypto and bedrock2 results match *)
        context_equiv G locals ->
        (* executing translation output is equivalent to interpreting e *)
        WeakestPrecondition.cmd
          (WeakestPrecondition.call functions)
          body tr mem locals
          (fun tr' mem' locals' =>
             tr = tr' /\
             mem = mem' /\
             subset (varname_set_base (snd (fst out)))
                            (used_varnames (varname_gen:=varname_gen) nextn nvars) /\
             Interface.map.only_differ
               locals (used_varnames (varname_gen:=varname_gen) nextn nvars) locals' /\
             locally_equivalent_base
               (listZ:=rep.listZ_local) ret1 ret2 locals').
  Proof.
    revert G. cbv zeta.
    induction e0_valid; intros *.
    { (* Abs *)
      inversion 1; cleanup_wf.
      cbn [translate_func']; intros.
      match goal with
      | H : context [varname_set_args] |- _ =>
        cbn [varname_set_args] in H;
          setoid_rewrite not_union_iff in H;
          match type of H with
            forall x y, ?P /\ ?Q =>
            assert (forall x y, P) by (apply H);
            assert (forall x y, Q) by (apply H);
            clear H
          end
      end.
      destruct argnames.
      cbv [locally_equivalent_args] in *.
      cbn [fst snd equivalent_args
               type.map_for_each_lhs_of_arrow] in *.
      cleanup. sepsimpl.
      eapply IHe0_valid; eauto; [ | ].
      { destruct args; cbn [fst snd].
        cbn [context_varname_set]; intros.
        apply not_union_iff; eauto with lia. }
      { eapply Forall_cons; eauto. } }
    { (* base case *)
      inversion 1; cleanup_wf;
      cbv [translate_func']; intros.
      all:eapply Proper_cmd;
        [solve [apply Proper_call] | repeat intro
         | eapply (translate_cmd_correct (t:=type.base _));
           solve [eauto] ];
        cbv beta in *; cleanup; subst; tauto. }
  Qed.

  Lemma look_up_return_values {t} :
    forall (ret : base.interp t)
           (retnames : listexcl_base_ltype (listZ:=rep.listZ_mem) t)
           (retsizes : base_access_sizes t)
           (locals : locals)
           (mem : mem)
           (R : _ -> Prop),
      sep (equivalent_listexcl
             ret (map_listexcl (fun t => base_rtype_of_ltype (t:=t)) retnames)
             retsizes locals) R mem ->
      WeakestPrecondition.list_map
        (WeakestPrecondition.get locals)
        (flatten_listexcl_base_ltype retnames)
        (fun flat_rets =>
           sep (equivalent_listexcl_flat_base ret flat_rets retsizes)
               R mem).
  Proof.
    cbv [flatten_retnames].
    induction t;
      cbn [flatten_base_ltype
             flatten_listexcl_base_ltype
             equivalent_listexcl_flat_base
             equivalent_listexcl
             flatten_rets base_rtype_of_ltype rep.rtype_of_ltype
             flatten_base_rtype equivalent_flat_base
             rep.listZ_mem rep.Z equivalent]; break_match;
        repeat match goal with
               | _ => progress (intros; cleanup)
               | _ => progress subst
               | _ => progress sepsimpl
               | _ => progress cbn [rep.equiv rep.listZ_mem rep.Z] in *
               | _ => progress cbn [List.hd
                                      WeakestPrecondition.list_map
                                      WeakestPrecondition.list_map_body
                                      WeakestPrecondition.literal
                                      WeakestPrecondition.dexpr
                                      WeakestPrecondition.dexprs
                                      WeakestPrecondition.expr
                                      WeakestPrecondition.expr_body]
               | _ => rewrite word.of_Z_unsigned
               | H : WeakestPrecondition.dexpr _ _ _ _ |- _ => destruct H
               | |- WeakestPrecondition.get _ _ _ => eexists; split; [ eassumption | ]
               | |- WeakestPrecondition.literal _ _ =>
                 cbv [WeakestPrecondition.literal dlet.dlet]
               | |- Lift1Prop.ex1 _ _ => eexists; sepsimpl; eauto; [ ]
               | H : False |- _ => tauto
               | _ => reflexivity
               | _ => solve [eauto]
               end.
    { apply list_map_app_iff;
        [ split; intros;
          (eapply Proper_get; [|eassumption]); repeat intro;
          match goal with H : _ |- _ => apply H; solve [eauto] end |  ].
      fold (@Language.Compilers.base.interp) in *.
      eapply Proper_list_map; [ solve [apply Proper_get] | repeat intro | ].
      2:{ eapply IHt1;
          (* TODO: why does ecancel_assumption not work here? *)
          use_sep_assumption; rewrite sep_assoc; reflexivity. }
      cbv beta in *.
      eapply Proper_list_map; [ solve [apply Proper_get] | repeat intro | ].
      2:{ eapply IHt2.
          (* TODO: why does ecancel_assumption not work here? *)
          use_sep_assumption; rewrite sep_comm,sep_assoc; reflexivity. }
      cbv beta in *.
      apply sep_ex1_l.
      match goal with |- context[List.firstn _ (?x ++ ?y)] =>
                      exists (length x) end.
      rewrite firstn_app_sharp, skipn_app_sharp by reflexivity.
      ecancel_assumption. }
  Qed.

  Lemma equivalent_flat_base_iff1 {t} :
    forall (names : base_ltype t)
           (values : base.interp t)
           (sizes : base_access_sizes t)
           (flat_values : list word)
           (locals locals' : locals),
      NoDup (flatten_base_ltype names) ->
      map.putmany_of_list_zip
        (flatten_base_ltype names) flat_values locals = Some locals' ->
      Lift1Prop.iff1
        (equivalent_flat_base values flat_values sizes)
        (equivalent_base values (base_rtype_of_ltype names) sizes locals').
  Proof.
    induction t;
      cbn [rep.Z rep.equiv base_rtype_of_ltype
                 equivalent_base equivalent_flat_base
                 flatten_base_ltype];
      break_match; cbn [fst snd]; intros; try reflexivity; [ | | ].
    all:match goal with
          H : _ |- _ =>
          pose proof H;
            eapply map.putmany_of_list_zip_sameLength in H;
            cbn [length] in H
        end.
    { repeat intro. rewrite sep_emp_l.
      destruct flat_values as [| ? [|? ?] ]; cbn [length] in *; try lia.
      cbv [emp List.hd
               WeakestPrecondition.literal dlet.dlet
               WeakestPrecondition.get WeakestPrecondition.dexpr
               WeakestPrecondition.expr WeakestPrecondition.expr_body].
      repeat match goal with
             | _ => progress sepsimpl
             | _ => progress subst
             | _ => progress cbn [map.putmany_of_list_zip] in *
             | H : Some _ = Some _ |- _ => inversion H; clear H; subst
             | _ => rewrite map.get_put_same, word.of_Z_unsigned
             | _ => split; intros; cleanup; subst
             | _ => eexists; sepsimpl; [ reflexivity .. | ]
             | _ => solve [eauto]
             end. }
    { match goal with
      | H : _ |- _ =>
        rewrite putmany_of_list_zip_app_l in H;
          pose proof H;
          rewrite putmany_of_list_zip_bind_comm in H by auto
      end.
      match goal with
        H : NoDup (_ ++ _) |- _ =>
        pose proof H;
        apply NoDup_app_iff in H; cleanup
      end.
      cbv [Option.bind] in *.
      break_match_hyps; try congruence.
      repeat intro; split; intros.
      { match goal with
        | H : Lift1Prop.ex1 _ _ |- _ => destruct H end.
        eapply Proper_sep_iff1;
          [ symmetry; eapply IHt1; eassumption
          | symmetry; eapply IHt2; eassumption | ].
        erewrite <-flatten_base_samelength by ecancel_assumption.
        rewrite firstn_length_firstn, skipn_length_firstn.
        assumption. }
      { eexists.
        eapply Proper_sep_iff1;
          [ eapply IHt1; eassumption
          | eapply IHt2; eassumption | ].
        eapply Proper_sep_iff1; [ | reflexivity | ].
        { eapply (equivalent_only_differ_iff1
                    ltac:(eapply equiv_listZ_only_differ_mem)
                 _ locals');
            eauto using @only_differ_sym, @map.only_differ_putmany with typeclass_instances.
          symmetry.
          eapply disjoint_sameset; eauto using varname_set_flatten.
          apply NoDup_disjoint; eauto using string_dec. }
        { eauto. } } }
    { repeat intro. rewrite sep_emp_l.
      destruct flat_values as [| ? [|? ?] ]; cbn [length] in *; try lia.
      cbv [List.hd
             rep.equiv rep.rtype_of_ltype rep.listZ_mem rep.Z
             WeakestPrecondition.literal dlet.dlet
             WeakestPrecondition.get WeakestPrecondition.dexpr
             WeakestPrecondition.expr WeakestPrecondition.expr_body].
      match goal with
        H : map.putmany_of_list_zip _ _ _ = _ |- _ =>
        cbn [map.putmany_of_list_zip] in H; inversion H; clear H; subst
      end.
      split; intros;
        repeat match goal with
               | _ => progress sepsimpl
               | _ => progress subst
               | H : Some _ = Some _ |- _ =>
                 inversion H; clear H; subst
               | H : _ |- _ => rewrite word.of_Z_unsigned in H
               | H : _ |- _ => rewrite map.get_put_same in H
               | _ => rewrite map.get_put_same
               | _ => rewrite word.of_Z_unsigned
               | |- Lift1Prop.ex1 _ _ => eexists
               | |- exists _, _ => eexists
               | |- _ /\ _ => split
               | _ => solve [eauto]
               | _ => congruence
               end. }
  Qed.

  (* When arguments are loaded into initial locals, the new argument names map
     to the correct values *)
  Lemma equivalent_flat_args_iff1 {t} :
    forall (argnames : type.for_each_lhs_of_arrow ltype t)
           (args : type.for_each_lhs_of_arrow API.interp_type t)
           (argsizes : type.for_each_lhs_of_arrow access_sizes t)
           (flat_args : list word)
           (locals locals' : locals),
      NoDup (flatten_argnames argnames) ->
      map.putmany_of_list_zip
        (flatten_argnames argnames) flat_args locals = Some locals' ->
      let argvalues :=
          type.map_for_each_lhs_of_arrow rtype_of_ltype argnames in
      Lift1Prop.iff1
        (equivalent_flat_args args flat_args argsizes)
        (equivalent_args args argvalues argsizes locals').
  Proof.
    induction t;
      cbn [equivalent_args
             equivalent_flat_args
             flatten_argnames type.map_for_each_lhs_of_arrow];
      break_match; intros; try reflexivity; [ | ].
    all:match goal with
          H : _ |- _ =>
          pose proof H;
            eapply map.putmany_of_list_zip_sameLength in H
        end.
    { destruct flat_args; cbn [length] in *; try lia; [ ].
      repeat intro; cbv [emp]; tauto. }
    { destruct argnames. cbn [fst snd rtype_of_ltype] in *.
      match goal with
      | H : _ |- _ =>
        pose proof H; rewrite putmany_of_list_zip_app_l in H
      end.
      match goal with
      | H : NoDup (_ ++ _) |- _ =>
        pose proof H; apply NoDup_app_iff in H; cleanup
      end.
      cbv [Option.bind] in *. break_match_hyps; try congruence.
      repeat intro; split; intros.
      { repeat match goal with
               | _ => progress cleanup
               | H : Lift1Prop.ex1 _ _ |- _ => destruct H
               | H: _ |- _ =>
                 erewrite <-flatten_base_samelength in H by eauto;
                   rewrite ?firstn_length_firstn, ?skipn_length_firstn in H
               end.
        split; eauto.
        { eexists.
          eapply Proper_sep_iff1;
            [ | reflexivity | eassumption ].
          rewrite equivalent_flat_base_iff1 by eauto.
          eapply equivalent_only_differ_iff1;
            eauto using @only_differ_sym, @map.only_differ_putmany
              with typeclass_instances equiv; [ ].
          rewrite varname_set_flatten; symmetry;
            apply NoDup_disjoint; eauto using string_dec. }
        { eapply IHt2; eassumption. } }
      { cleanup; subst.
        eexists; split; eauto.
        { eexists.
          eapply Proper_sep_iff1;
            [ | reflexivity | eassumption ].
          rewrite equivalent_flat_base_iff1 by eauto.
          eapply equivalent_only_differ_iff1;
            eauto using @only_differ_sym, @map.only_differ_putmany
              with typeclass_instances equiv; [ ].
          rewrite varname_set_flatten; symmetry;
            apply NoDup_disjoint; eauto using string_dec. }
        { eapply IHt2; eassumption. } } }
  Qed.

  Lemma equivalent_listonly_flat_iff1 {t} :
    forall (names : listonly_base_ltype t) (values : list word)
           (sizes : base_access_sizes t)
           (l locals init_locals : locals)
           (vset : set string) (x : base.interp t),
      NoDup (flatten_listonly_base_ltype names) ->
      map.putmany_of_list_zip (flatten_listonly_base_ltype names) values l = Some init_locals ->
      map.only_differ init_locals vset locals ->
      disjoint vset (of_list (flatten_listonly_base_ltype names)) ->
      Lift1Prop.iff1
        (equivalent_listonly
           x (map_listonly base_rtype_of_ltype names) sizes locals)
        (equivalent_listonly_flat_base x values sizes).
  Proof.
    induction t;
      cbn [fst snd equivalent_listonly equivalent_listonly_flat_base
               flatten_listonly_base_ltype
               equivalent_flat_base map_listonly];
      intros; break_match; try reflexivity; [ | | ].
    { cbn [map.putmany_of_list_zip] in *.
      break_match_hyps; try congruence; [ ].
      split; intros; sepsimpl; tauto. }
    { destruct names. cbn [fst snd] in *.
      match goal with
      | H : _ |- _ =>
        pose proof H; rewrite putmany_of_list_zip_app_l in H
      end.
      match goal with
      | H : NoDup (_ ++ _) |- _ =>
        pose proof H; apply NoDup_app_iff in H; cleanup
      end.
      cbv [Option.bind] in *. break_match_hyps; try congruence; [ ].
      match goal with
      | H : _ |- _ => rewrite of_list_app in H;
                        rewrite disjoint_union_r_iff in H
      end.
      cleanup.

      match goal with
      | H : map.putmany_of_list_zip _ (List.firstn _ _) _ = Some _ |- _ =>
        pose proof H; apply map.only_differ_putmany in H
      end.
      match goal with
      | H : map.putmany_of_list_zip _ (List.skipn _ _) _ = Some _ |- _ =>
        pose proof H; apply map.only_differ_putmany in H
      end.

      erewrite IHt1; eauto using only_differ_trans; [ |
        apply disjoint_union_l_iff; intuition trivial;
        symmetry; eapply NoDup_disjoint; eauto ].
      erewrite IHt2 by eauto using only_differ_trans.
      split; intros; [ eexists; eassumption | ].
      sepsimpl.
      erewrite <-flatten_listonly_samelength by ecancel_assumption.
      rewrite firstn_length_firstn, skipn_length_firstn.
      fold (@Language.Compilers.base.interp) in *.
      ecancel_assumption. }
    { cbn [map.putmany_of_list_zip] in *.
      break_match_hyps; try congruence; [ ].
      match goal with H : Some _ = Some _ |- _ =>
                      inversion H; subst; clear H end.
      cbn [rep.Z rep.listZ_mem base_rtype_of_ltype rep.rtype_of_ltype
                 rep.equiv length List.hd].
      cbn [WeakestPrecondition.dexpr
             WeakestPrecondition.expr WeakestPrecondition.expr_body].
      cbv [WeakestPrecondition.literal dlet.dlet].
      repeat match goal with
             | H : _ |- _ => rewrite map.get_put_same in H
             | H : context [of_list [_] ] |- _ =>
               rewrite of_list_singleton in H
             | H : map.only_differ (map.put _ ?k ?v) _ ?m' |- _ =>
               eapply only_differ_notin in H;
                 [ | eapply disjoint_singleton_r_iff; eassumption ]
             end.
      cbv [WeakestPrecondition.get].
      split; intros; sepsimpl; subst; try reflexivity.
      { eexists. sepsimpl; eauto; [ ].
        rewrite !word.of_Z_unsigned in *.
        eexists; sepsimpl; eauto; [ ].
        eexists; sepsimpl; eauto; [ ].
        congruence. }
      { eexists; sepsimpl; eauto; [ ].
        eexists; sepsimpl; eauto; [ ].
        eexists; sepsimpl; eauto; [ ].
        eexists; split; eauto; [ ].
        apply word.of_Z_unsigned. } }
  Qed.

  Lemma translate_func_correct {t}
        (e : API.Expr t)
        (* expressions are valid input to translate_func *)
        (e_valid : valid_func (e _)) :
    Wf e ->
    forall (fname : string)
           (retnames : base_ltype (type.final_codomain t))
           (retsizes : base_access_sizes (type.final_codomain t))
           (argnames : type.for_each_lhs_of_arrow ltype t)
           (arglengths : type.for_each_lhs_of_arrow list_lengths t)
           (argsizes : type.for_each_lhs_of_arrow access_sizes t)
           (args : type.for_each_lhs_of_arrow API.interp_type t),
      (* rets := fiat-crypto interpretation of e1 applied to args *)
      let rets : base.interp (type.final_codomain t) :=
          type.app_curried (API.interp (e _)) args in
      (* extract list lengths from fiat-crypto arguments/return values *)
      arglengths = list_lengths_from_args args ->
      let retlengths := list_lengths_from_value rets in
      (* out := translation output for e2; triple of
         (function arguments, function return variable names, body) *)
      let out := translate_func
                   e argnames arglengths argsizes retnames retsizes in
      let f : string*func := (fname, fst out) in
      let lengths := snd out in
      forall tr
             (mem : mem)
             (flat_args : list word)
             (out_ptrs : list word)
             (argvalues : list word)
             (functions : list (string*func))
             (R : _ -> Prop),
        (* argument values are the concatenation of true argument values
           and output pointer values *)
        argvalues = out_ptrs ++ flat_args ->
        length out_ptrs =
        length (flatten_listonly_base_ltype
                  (fst (extract_listnames retnames))) ->
        (* argnames don't contain variables we could later overwrite *)
        (forall n, ~ varname_set_args argnames (varname_gen n)) ->
        (* argument values are equivalent *)
        equivalent_flat_args args flat_args argsizes mem ->
        (* argnames don't have duplicates *)
        NoDup (flatten_argnames argnames) ->
        (* argument bounds are within allowed integer size *)
        access_sizes_good_args argsizes ->
        (* argument bounds are obeyed *)
        within_access_sizes_args args argsizes ->
        (* retnames don't contain variables we could later overwrite *)
        (forall n, ~ varname_set_base retnames (varname_gen n)) ->
        (* retnames don't have duplicates *)
        NoDup (flatten_base_ltype retnames) ->
        (* return value bounds are within allowed integer size *)
        base_access_sizes_good retsizes ->
        (* return value bounds are obeyed *)
        within_base_access_sizes rets retsizes ->
        (* argnames and retnames are disjoint *)
        disjoint (varname_set_args argnames)
                         (varname_set_base retnames) ->
        (* seplogic frame for return values *)
        sep (lists_reserved_with_initial_context
               retlengths argnames retnames retsizes argvalues) R mem ->
        (* translated function produces equivalent results *)
        WeakestPrecondition.call
          (f :: functions) fname tr mem argvalues
          (fun tr' mem' flat_rets =>
             tr = tr' /\
             (* lengths of output lists match *)
             retlengths = snd out /\
             (* return values are equivalent *)
             sep (sep (equivalent_listexcl_flat_base
                         rets flat_rets retsizes)
                      (equivalent_listonly_flat_base
                         rets out_ptrs retsizes))
                 R mem').
  Proof.
    cbv [translate_func]; intros. subst.
    cbn [fst snd
             WeakestPrecondition.call
             WeakestPrecondition.call_body WeakestPrecondition.func].
    rewrite eqb_refl.
    match goal with
      |- exists l, map.of_list_zip ?ks ?vs = Some l /\ _ =>
      assert (NoDup ks);
        [ | assert (exists m, map.of_list_zip ks vs = Some m);
            [ | cleanup; eexists; split; [ eassumption | ] ] ]
    end.
    { apply disjoint_NoDup; eauto using flatten_listonly_NoDup.
      eapply subset_disjoint_l;
        [ | symmetry; rewrite <-varname_set_args_flatten; solve [eauto] ].
      eapply flatten_listonly_subset. }
    { eapply of_list_zip_app; try lia; [ ].
      erewrite flatten_args_samelength; eauto. }
    match goal with H : _ |- _ =>
                    pose proof H;
                      eapply (of_list_zip_flatten_argnames argnames) in H;
                      cleanup
    end.
    match goal with
    | H : map.of_list_zip _ _ = Some _ |- _ =>
      pose proof H;
      cbv [map.of_list_zip] in H;
        rewrite putmany_of_list_zip_app_l in H;
        rewrite firstn_app_sharp, skipn_app_sharp in H
          by eauto using flatten_args_samelength;
        pose proof H; (* preserve original ordering *)
        erewrite putmany_of_list_zip_bind_comm in H by eauto;
        cbv [Option.bind] in *; repeat break_match_hyps; try congruence; [ ]
    end.
    cbn [WeakestPrecondition.cmd WeakestPrecondition.cmd_body].
    eapply Proper_cmd; [ solve [apply Proper_call] | repeat intro | ].
    2 : { eapply load_arguments_correct; try eassumption; eauto.
          eapply equivalent_flat_args_iff1; eauto. }
    cbv beta in *. cleanup; subst.
    eapply Proper_cmd; [ solve [apply Proper_call] | repeat intro | ].
    2 : { eapply @translate_func'_correct with (args:=args);
          cbv [context_equiv]; intros; try apply Wf3_of_Wf; eauto; [ ].
          eapply only_differ_disjoint_undef_on; eauto;
            [ eapply used_varnames_disjoint; lia | ].
          eapply putmany_of_list_zip_undef_on
            with (ks:=flatten_argnames _); eauto;
            [ rewrite <-varname_set_args_flatten;
              symmetry; eapply disjoint_used_varnames_lt;
              eauto with lia | ].
          eapply putmany_of_list_zip_undef_on;
            eauto using @undef_on_empty with typeclass_instances.
          eapply subset_disjoint_l;
            eauto using flatten_listonly_subset; [ ].
          eapply disjoint_sym.
          eapply disjoint_used_varnames_lt; eauto with lia. }
    cbv beta in *. cleanup; subst.
    eapply Proper_cmd; [ solve [apply Proper_call] | repeat intro | ].
    2 : {
      cbv [lists_reserved_with_initial_context] in *.
      break_match_hyps; try congruence; [ ].
      match goal with H : Some _ = Some _ |- _ =>
                      inversion H; clear H; subst end.
      eapply store_return_values_correct;
        eauto using @only_differ_trans with typeclass_instances.
      { eapply of_list_zip_undef_on; eauto.
        rewrite of_list_app.
        rewrite <-varname_set_args_flatten.
        repeat match goal with
               | |- disjoint (union _ _) _ =>
                 apply disjoint_union_l_iff; split; auto
               | |- disjoint _ (union _ _) =>
                 apply disjoint_union_r_iff; split; auto
               | |- disjoint
                      (of_list
                         (flatten_listonly_base_ltype _))
                      (used_varnames _ _) =>
                 symmetry;
                 eapply subset_disjoint_r;
                   [ solve [apply flatten_listonly_subset] | ]
               end;
          (* solvers *)
          try match goal with
              | |- disjoint _ (varname_set_listexcl _) =>
                eapply subset_disjoint_r;
                  solve [eauto using varname_set_listexcl_subset]
              | |- disjoint (used_varnames _ _) _ =>
                apply disjoint_used_varnames_lt; intros;
                  solve [eauto with lia]
              | |- disjoint _ (used_varnames _ _) =>
                symmetry; apply disjoint_used_varnames_lt; intros;
                  solve [eauto with lia]
              | _ => solve [eauto using flatten_listonly_disjoint]
              | _ => solve [symmetry; eauto using flatten_listonly_disjoint]
              end. }
      { eapply subset_disjoint_l; try eassumption.
        eauto using disjoint_used_varnames_lt. } }

    cbv beta in *. cleanup; subst.
    match goal with H : list_lengths_from_value _ = _ |- _ =>
                    rewrite H end.
    eapply Proper_list_map;
      [ solve [apply Proper_get]
      | | eapply look_up_return_values; eauto;
          apply equivalent_extract_listnames; eauto ].
    repeat intro; cleanup; subst; eauto.
    split; eauto.
    split; eauto.

    use_sep_assumption.
    cancel.

    repeat match goal with H : NoDup (_ ++ _) |- _ =>
                           apply NoDup_app_iff in H end.
    cleanup.

    eapply equivalent_listonly_flat_iff1;
      eauto 10 using @only_differ_sym, @map.only_differ_putmany,
      @only_differ_trans with typeclass_instances; [ ].
    repeat match goal with
             |- disjoint (union _ _) _ =>
             eapply disjoint_union_l_iff; split
           | _ => rewrite <-varname_set_args_flatten
           | _ =>
             solve[eauto using flatten_listonly_disjoint,
                   subset_disjoint_r, flatten_listonly_subset,
                   disjoint_used_varnames_lt]
           | _ =>
             symmetry;
               solve[eauto using flatten_listonly_disjoint,
                     subset_disjoint_r, flatten_listonly_subset,
                     disjoint_used_varnames_lt]
           end.
  Qed.
End Func.


(************************************************************************)
(* Copyright (c) 2017-2018, Ajay Kumar Eeralla <ae266@mail.missouri.edu>*)
(************************************************************************)
 Require Export voting.
 (** proofs **)

Theorem frame4_ind: (phi5 0 1) ~ (phi5 1 0).
Proof. repeat unfold phi5, phi4, phi3, phi2, phi1, t1, t2, t3, t4. repeat unfold t4.
       simpl.
apply IFBRANCH_M5 with (ml1:= phi0) (ml2:=phi0).
simpl.       repeat unfold Avote.
apply IFBRANCH_M4 with (ml1:= phi0 ++ [bol (theta x1 A), msg (tr 0 0 3 5 7 9)]) (ml2:= phi0 ++ [ bol (theta x1 A), msg (tr 0 1 3 5 7 9)]).
simpl.
apply IFBRANCH_M3 with (ml1:= phi0 ++[ bol (theta x1 A), msg (tr 0 0 3 5 7 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 8 10)])(ml2:= phi0 ++[
  bol (theta x1 A), msg (tr 0 1 3 5 7 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 8 10)]).
apply IFBRANCH_M3 with (ml1:= phi0 ++[bol (theta x1 A), msg (tr 0 0 3 5 7 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 8 10), bol (to (x3tt 0 1)) #? A ])(ml2:= phi0 ++[bol (theta x1 A), msg (tr 0 1 3 5 7 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 8 10), bol (to (x3tt 1 0)) #? A]).

apply IFBRANCH_M2 with (ml1:= phi0 ++[bol (theta x1 A), msg (tr 0 0 3 5 7 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 8 10), bol (to (x3tt 0 1)) #? A, bol (acc 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11 2) ])(ml2:= phi0 ++[bol (theta x1 A), msg (tr 0 1 3 5 7 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 8 10), bol (to (x3tt 1 0)) #? A, bol (acc 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11 2)]).
simpl.

apply IFBRANCH_M2 with (ml1:= phi0 ++[bol (theta x1 A), msg (tr 0 0 3 5 7 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 8 10), bol (to (x3tt 0 1)) #? A, bol (acc 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11 2), bol (to (x4ttt 0 1)) #? B ])(ml2:= phi0 ++[bol (theta x1 A), msg (tr 0 1 3 5 7 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 8 10), bol (to (x3tt 1 0)) #? A, bol (acc 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11 2), bol (to (x4ttt 1 0)) #? B]).
simpl.

repeat unfold t5.
simpl.
repeat unfold mchecks, strm.
apply IFBRANCH_M1 with (ml1:= [msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (vk 0), msg (vk 1),
   msg (pke 2), bol (theta x1 A), msg (tr 0 0 3 5 7 9), bol (theta (x2t 0) B), msg (tr 1 1 4 6 8 10),
   bol (to (x3tt 0 1)) #? A, bol (acc 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11 2), bol (to (x4ttt 0 1)) #? B,
   bol (acc 1 4 6 (x4ttt 0 1)), msg (e 1 4 6 (x4ttt 0 1) TWO 12 2)])(ml2:= [msg A, msg B, msg M, msg C1, msg C2, msg C3, msg ONE, msg TWO, msg THREE, msg (vk 0), msg (vk 1), msg (pke 2),
  bol (theta x1 A), msg (tr 0 1 3 5 7 9), bol (theta (x2t 1) B), msg (tr 1 0 4 6 8 10), bol (to (x3tt 1 0)) #? A,
  bol (acc 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11 2), bol (to (x4ttt 1 0)) #? B, bol (acc 0 4 6 (x4ttt 1 0)),
  msg (e 0 4 6 (x4ttt 1 0) TWO 12 2)]).
simpl.
unfold p, d. repeat unfold e.

Theorem frame8_ind: (phi8 0 1) ~ (phi8 1 0).
 Proof. unfold phi8. simpl. repeat unfold t1, t2, t3, t4, t4s, t4ss, t47, t48. repeat unfold tr. repeat unfold Avote, Bvote.
        repeat unfold t5. repeat unfold strm. repeat unfold t61, t62, t61s, t62s, t61ss, t62ss, t71, t72, t71s, t72s. repeat unfold fintrm. repeat unfold strm.
        apply IFBRANCH_M8 with (ml1:= phi0) (ml2:= phi0); simpl.
        apply IFBRANCH_M7 with (ml1:= phi0 ++ [bol (theta x1 A), msg (vk 0, (b 0 3 5, s 0 3 5 7 9))]) (ml2:= (phi0++[ bol (theta x1 A), msg (vk 0, (b 1 3 5, s 1 3 5 7 9))])); simpl.
        apply IFBRANCH_M6 with (ml1:= phi0 ++ [ bol (theta x1 A), msg (vk 0, (b 0 3 5, s 0 3 5 7 9)), bol (theta (x2t 0) B), msg (vk 1, (b 1 4 6, s 1 4 6 8 10))]) (ml2:= phi0++ [  bol (theta x1 A), msg (vk 0, (b 1 3 5, s 1 3 5 7 9)), bol (theta (x2t 1) B), msg (vk 1, (b 0 4 6, s 0 4 6 8 10))]); simpl.

        apply IFBRANCH_M6 with (ml1:= phi0 ++ [ bol (theta x1 A), msg (vk 0, (b 0 3 5, s 0 3 5 7 9)), bol (theta (x2t 0) B), msg (vk 1, (b 1 4 6, s 1 4 6 8 10)),  bol (to (x3tt 0 1)) #? A]) (ml2:= phi0++ [  bol (theta x1 A), msg (vk 0, (b 1 3 5, s 1 3 5 7 9)), bol (theta (x2t 1) B), msg (vk 1, (b 0 4 6, s 0 4 6 8 10)), bol (to (x3tt 1 0)) #? A]); simpl.
        apply IFBRANCH_M5 with (ml1:= phi0 ++ [ bol (theta x1 A), msg (vk 0, (b 0 3 5, s 0 3 5 7 9)), bol (theta (x2t 0) B), msg (vk 1, (b 1 4 6, s 1 4 6 8 10)),  bol (to (x3tt 0 1)) #? A,  bol (acc 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11 2)]) (ml2:= phi0++ [  bol (theta x1 A), msg (vk 0, (b 1 3 5, s 1 3 5 7 9)), bol (theta (x2t 1) B), msg (vk 1, (b 0 4 6, s 0 4 6 8 10)), bol (to (x3tt 1 0)) #? A, bol (acc 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11 2)]); simpl.

        apply IFBRANCH_M5 with (ml1:= phi0 ++ [ bol (theta x1 A), msg (vk 0, (b 0 3 5, s 0 3 5 7 9)), bol (theta (x2t 0) B), msg (vk 1, (b 1 4 6, s 1 4 6 8 10)),  bol (to (x3tt 0 1)) #? A,  bol (acc 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11 2), bol (to (x4ttt 0 1)) #? B]) (ml2:= phi0++ [  bol (theta x1 A), msg (vk 0, (b 1 3 5, s 1 3 5 7 9)), bol (theta (x2t 1) B), msg (vk 1, (b 0 4 6, s 0 4 6 8 10)), bol (to (x3tt 1 0)) #? A, bol (acc 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11 2), bol (to (x4ttt 1 0)) #? B]); simpl.

        apply IFBRANCH_M4 with (ml1:= phi0 ++ [ bol (theta x1 A), msg (vk 0, (b 0 3 5, s 0 3 5 7 9)), bol (theta (x2t 0) B), msg (vk 1, (b 1 4 6, s 1 4 6 8 10)),  bol (to (x3tt 0 1)) #? A,  bol (acc 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11 2), bol (to (x4ttt 0 1)) #? B,  bol (acc 1 4 6 (x4ttt 0 1)), msg (e 1 4 6 (x4ttt 0 1) TWO 12 2)]) (ml2:= phi0++ [  bol (theta x1 A), msg (vk 0, (b 1 3 5, s 1 3 5 7 9)), bol (theta (x2t 1) B), msg (vk 1, (b 0 4 6, s 0 4 6 8 10)), bol (to (x3tt 1 0)) #? A, bol (acc 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11 2), bol (to (x4ttt 1 0)) #? B,  bol (acc 0 4 6 (x4ttt 1 0)), msg (e 0 4 6 (x4ttt 1 0) TWO 12 2)]); simpl.

        apply IFBRANCH_M3 with (ml1:= phi0 ++ [ bol (theta x1 A), msg (vk 0, (b 0 3 5, s 0 3 5 7 9)), bol (theta (x2t 0) B), msg (vk 1, (b 1 4 6, s 1 4 6 8 10)),  bol (to (x3tt 0 1)) #? A,  bol (acc 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11 2), bol (to (x4ttt 0 1)) #? B,  bol (acc 1 4 6 (x4ttt 0 1)), msg (e 1 4 6 (x4ttt 0 1) TWO 12 2),  bol (mchecks x5t 0 1 TWO),
   msg (shufl (p 1 (x5t 0 1)) (p 2 (x5t 0 1)) (p 3 (x5t 0 1)))]) (ml2:= phi0++ [  bol (theta x1 A), msg (vk 0, (b 1 3 5, s 1 3 5 7 9)), bol (theta (x2t 1) B), msg (vk 1, (b 0 4 6, s 0 4 6 8 10)), bol (to (x3tt 1 0)) #? A, bol (acc 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11 2), bol (to (x4ttt 1 0)) #? B,  bol (acc 0 4 6 (x4ttt 1 0)), msg (e 0 4 6 (x4ttt 1 0) TWO 12 2), bol (mchecks x5t 1 0 TWO),
                                                                                msg (shufl (p 1 (x5t 1 0)) (p 2 (x5t 1 0)) (p 3 (x5t 1 0)))]); simpl.

           apply IFBRANCH_M3 with (ml1:= phi0 ++ [ bol (theta x1 A), msg (vk 0, (b 0 3 5, s 0 3 5 7 9)), bol (theta (x2t 0) B), msg (vk 1, (b 1 4 6, s 1 4 6 8 10)),  bol (to (x3tt 0 1)) #? A,  bol (acc 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11 2), bol (to (x4ttt 0 1)) #? B,  bol (acc 1 4 6 (x4ttt 0 1)), msg (e 1 4 6 (x4ttt 0 1) TWO 12 2),  bol (mchecks x5t 0 1 TWO),
   msg (shufl (p 1 (x5t 0 1)) (p 2 (x5t 0 1)) (p 3 (x5t 0 1))),  bol (theta21 x6t A 0 1)]) (ml2:= phi0++ [  bol (theta x1 A), msg (vk 0, (b 1 3 5, s 1 3 5 7 9)), bol (theta (x2t 1) B), msg (vk 1, (b 0 4 6, s 0 4 6 8 10)), bol (to (x3tt 1 0)) #? A, bol (acc 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11 2), bol (to (x4ttt 1 0)) #? B,  bol (acc 0 4 6 (x4ttt 1 0)), msg (e 0 4 6 (x4ttt 1 0) TWO 12 2), bol (mchecks x5t 1 0 TWO),
                                                                                msg (shufl (p 1 (x5t 1 0)) (p 2 (x5t 1 0)) (p 3 (x5t 1 0))), bol (theta21 x6t A 1 0)]); simpl.

            apply IFBRANCH_M2 with (ml1:= phi0 ++ [bol (theta x1 A), msg (vk 0, (b 0 3 5, s 0 3 5 7 9)), bol (theta (x2t 0) B), msg (vk 1, (b 1 4 6, s 1 4 6 8 10)),  bol (to (x3tt 0 1)) #? A,  bol (acc 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11 2), bol (to (x4ttt 0 1)) #? B,  bol (acc 1 4 6 (x4ttt 0 1)), msg (e 1 4 6 (x4ttt 0 1) TWO 12 2),  bol (mchecks x5t 0 1 TWO),
   msg (shufl (p 1 (x5t 0 1)) (p 2 (x5t 0 1)) (p 3 (x5t 0 1))),  bol (theta21 x6t A 0 1),  bol (acc1 0 1 3 5) & (bcheck (c 0 3) (x6t 0 1)), msg (e1 0 3 x6t 1 13)]) (ml2:= phi0++ [bol (theta x1 A), msg (vk 0, (b 1 3 5, s 1 3 5 7 9)), bol (theta (x2t 1) B), msg (vk 1, (b 0 4 6, s 0 4 6 8 10)), bol (to (x3tt 1 0)) #? A, bol (acc 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11 2), bol (to (x4ttt 1 0)) #? B,  bol (acc 0 4 6 (x4ttt 1 0)), msg (e 0 4 6 (x4ttt 1 0) TWO 12 2), bol (mchecks x5t 1 0 TWO),
                                                                                msg (shufl (p 1 (x5t 1 0)) (p 2 (x5t 1 0)) (p 3 (x5t 1 0))), bol (theta21 x6t A 1 0), bol (acc1 1 0 3 5) & (bcheck (c 1 3) (x6t 1 0)), msg (e1 1 3 x6t 0 13)]); simpl.

                 apply IFBRANCH_M2 with (ml1:= phi0 ++ [bol (theta x1 A), msg (vk 0, (b 0 3 5, s 0 3 5 7 9)), bol (theta (x2t 0) B), msg (vk 1, (b 1 4 6, s 1 4 6 8 10)),  bol (to (x3tt 0 1)) #? A,  bol (acc 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11 2), bol (to (x4ttt 0 1)) #? B,  bol (acc 1 4 6 (x4ttt 0 1)), msg (e 1 4 6 (x4ttt 0 1) TWO 12 2),  bol (mchecks x5t 0 1 TWO),
   msg (shufl (p 1 (x5t 0 1)) (p 2 (x5t 0 1)) (p 3 (x5t 0 1))),  bol (theta21 x6t A 0 1),  bol (acc1 0 1 3 5) & (bcheck (c 0 3) (x6t 0 1)), msg (e1 0 3 x6t 1 13),  bol (theta21 x7t B 0 1)]) (ml2:= phi0++ [bol (theta x1 A), msg (vk 0, (b 1 3 5, s 1 3 5 7 9)), bol (theta (x2t 1) B), msg (vk 1, (b 0 4 6, s 0 4 6 8 10)), bol (to (x3tt 1 0)) #? A, bol (acc 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11 2), bol (to (x4ttt 1 0)) #? B,  bol (acc 0 4 6 (x4ttt 1 0)), msg (e 0 4 6 (x4ttt 1 0) TWO 12 2), bol (mchecks x5t 1 0 TWO),
                                                                                msg (shufl (p 1 (x5t 1 0)) (p 2 (x5t 1 0)) (p 3 (x5t 1 0))), bol (theta21 x6t A 1 0), bol (acc1 1 0 3 5) & (bcheck (c 1 3) (x6t 1 0)), msg (e1 1 3 x6t 0 13), bol (theta21 x7t B 1 0)]); simpl.

           apply IFBRANCH_M1 with (ml1:= phi0 ++ [bol (theta x1 A), msg (vk 0, (b 0 3 5, s 0 3 5 7 9)), bol (theta (x2t 0) B), msg (vk 1, (b 1 4 6, s 1 4 6 8 10)),  bol (to (x3tt 0 1)) #? A,  bol (acc 0 3 5 (x3tt 0 1)), msg (e 0 3 5 (x3tt 0 1) TWO 11 2), bol (to (x4ttt 0 1)) #? B,  bol (acc 1 4 6 (x4ttt 0 1)), msg (e 1 4 6 (x4ttt 0 1) TWO 12 2),  bol (mchecks x5t 0 1 TWO),
   msg (shufl (p 1 (x5t 0 1)) (p 2 (x5t 0 1)) (p 3 (x5t 0 1))),  bol (theta21 x6t A 0 1),  bol (acc1 0 1 3 5) & (bcheck (c 0 3) (x6t 0 1)), msg (e1 0 3 x6t 1 13),  bol (theta21 x7t B 0 1), bol (acc1 0 1 4 6) & (bcheck (c 1 4) (x7t 0 1)), msg (e1 0 4 x7t 1 14)]) (ml2:= phi0++ [bol (theta x1 A), msg (vk 0, (b 1 3 5, s 1 3 5 7 9)), bol (theta (x2t 1) B), msg (vk 1, (b 0 4 6, s 0 4 6 8 10)), bol (to (x3tt 1 0)) #? A, bol (acc 1 3 5 (x3tt 1 0)), msg (e 1 3 5 (x3tt 1 0) TWO 11 2), bol (to (x4ttt 1 0)) #? B,  bol (acc 0 4 6 (x4ttt 1 0)), msg (e 0 4 6 (x4ttt 1 0) TWO 12 2), bol (mchecks x5t 1 0 TWO),
                                                                                msg (shufl (p 1 (x5t 1 0)) (p 2 (x5t 1 0)) (p 3 (x5t 1 0))), bol (theta21 x6t A 1 0), bol (acc1 1 0 3 5) & (bcheck (c 1 3) (x6t 1 0)), msg (e1 1 3 x6t 0 13), bol (theta21 x7t B 1 0), bol (acc1 1 0 4 6) & (bcheck (c 0 4) (x7t 1 0)), msg (e1 1 4 x7t 0 14)]); simpl.

       unfold mchecks, theta21. unfold d.


Require Export Fiat.ADT Fiat.ADTNotation Fiat.ADTRefinement Fiat.ADTRefinement.BuildADTRefinements.

Require Export Fiat.Narcissus.Examples.Guard.Core.
Require Export Fiat.Narcissus.Examples.Guard.IPTablesGuard.

Definition GuardSig : ADTSig := ADTsignature {
  Constructor "Init" : rep,
  Method "ProcessPacket" : rep * bytes -> rep * result
}.

Definition GuardSpec : ADT GuardSig := IPGuard {{
    iptables -P FORWARD DROP;
    iptables -A FORWARD --protocol "UDP" --source-port bootps --not --source 192*168*0*1 -j DROP;
    iptables -A FORWARD --protocol "UDP" --source-port bootpc --not --destination 255*255*255*255 -j DROP
}}.

Arguments andb : simpl nomatch.
Arguments Word.NToWord : simpl never.
Arguments Word.wones : simpl never.
Arguments Word.wzero : simpl never.
Arguments Word.zext : simpl never.
Hint Rewrite Bool.andb_true_l : iptables.

Ltac t_ :=
  match goal with
  | _ => progress (subst || cbn)
  | _ => progress (autounfold with iptables || autorewrite with iptables)
  | _ => simplify with monad laws
  | _ => refine pick eq
  end.

Ltac t := repeat t_.

Ltac guardc :=
  start sharpening ADT;
  hone representation using eq; t;
    [ finish honing.. | finish_SharpeningADT_WithoutDelegation ].

Theorem SharpenedGuard :
  FullySharpened GuardSpec.
Proof. guardc. Defined.

Definition GuardImpl :=
  Eval cbn in projT1 SharpenedGuard.