(*
 * © 2019 Massachusetts Institute of Technology.
 * MIT Proprietary, Subject to FAR52.227-11 Patent Rights - Ownership by the Contractor (May 2014)
 * SPDX-License-Identifier: MIT
 *
 *)
From Coq Require Import
     List
     Morphisms
     Eqdep
.

From SPICY Require Import
     MyPrelude
     Maps
     Messages
     Keys
     Tactics
     Automation
     AdversaryUniverse
     RealWorld
     Simulation

     Theory.KeysTheory
.

Set Implicit Arguments.

Lemma cipher_honestly_signed_honest_keyb_iff :
  forall honestk c tf,
    cipher_honestly_signed honestk c = tf <-> honest_keyb honestk (cipher_signing_key c) = tf.
Proof.
  intros.
  unfold cipher_honestly_signed, cipher_signing_key; split; destruct c; trivial.
Qed.

(******************** CIPHER CLEANING *********************
 **********************************************************
 *
 * Function to clean ciphehrs and lemmas about it.
 *)

Section CleanCiphers.
  Import RealWorld.

  Variable honestk : key_perms.

  Lemma honest_cipher_filter_fn_proper :
    Proper (eq  ==>  eq  ==>  eq) (honest_cipher_filter_fn honestk).
  Proof.
    solve_proper.
  Qed.

  Lemma honest_cipher_filter_fn_filter_proper :
    Proper
      ( eq  ==>  eq  ==>  Equal  ==>  Equal)
      (fun (k : NatMap.Map.key) (e : cipher) (m : t cipher) => if honest_cipher_filter_fn honestk k e then m $+ (k, e) else m).
  Proof.
    unfold Proper, respectful;
      unfold Equal; intros; apply map_eq_Equal in H1; subst; auto.
  Qed.

  Lemma honest_cipher_filter_fn_filter_transpose :
    transpose_neqkey Equal
       (fun (k : NatMap.Map.key) (e : cipher) (m : t cipher) => if honest_cipher_filter_fn honestk k e then m $+ (k, e) else m).
  Proof.
    unfold transpose_neqkey, Equal, honest_cipher_filter_fn, cipher_honestly_signed; intros.
    cases e; cases e'; simpl;
      repeat match goal with
             | [ |- context[if ?cond then _ else _] ] => cases cond
             | [ |- context[_ $+ (?k1,_) $? ?k2] ] => cases (k1 ==n k2); subst; clean_map_lookups
             end; eauto.
  Qed.

  Lemma honest_cipher_filter_fn_filter_proper_eq :
    Proper
      ( eq  ==>  eq  ==>  eq  ==>  eq)
      (fun (k : NatMap.Map.key) (e : cipher) (m : t cipher) => if honest_cipher_filter_fn honestk k e then m $+ (k, e) else m).
  Proof.
    solve_proper.
  Qed.

  Lemma honest_cipher_filter_fn_filter_transpose_eq :
    transpose_neqkey eq
       (fun (k : NatMap.Map.key) (e : cipher) (m : t cipher) => if honest_cipher_filter_fn honestk k e then m $+ (k, e) else m).
  Proof.
    unfold transpose_neqkey, honest_cipher_filter_fn, cipher_honestly_signed; intros.
    cases e; cases e'; subst; simpl;
      repeat match goal with
             | [ |- context[if ?cond then _ else _] ] => cases cond
             | [ |- context[_ $+ (?k1,_) $? ?k2] ] => cases (k1 ==n k2); subst; clean_map_lookups
             end; eauto;
        rewrite map_ne_swap; eauto.
  Qed.

  Hint Resolve
       honest_cipher_filter_fn_proper
       honest_cipher_filter_fn_filter_proper
       honest_cipher_filter_fn_filter_transpose
       honest_cipher_filter_fn_filter_proper_eq
       honest_cipher_filter_fn_filter_transpose_eq
  : core.

  Lemma clean_ciphers_mapsto_iff : forall cs c_id c,
      MapsTo c_id c (clean_ciphers honestk cs) <-> MapsTo c_id c cs /\ honest_cipher_filter_fn honestk c_id c = true.
  Proof.
    intros.
    apply filter_iff; eauto.
  Qed.

  Lemma clean_ciphers_inv :
    forall c_id c cs,
      (clean_ciphers honestk cs) $? c_id = Some c
      -> cs $? c_id = Some c.
  Proof.
    intros.
    rewrite <- find_mapsto_iff, clean_ciphers_mapsto_iff, find_mapsto_iff in H;
      split_ands; assumption.
  Qed.

  Lemma clean_ciphers_keeps_honest_cipher :
    forall c_id c cs,
      cs $? c_id = Some c
      -> honest_cipher_filter_fn honestk c_id c = true
      -> clean_ciphers honestk cs $? c_id = Some c.
  Proof.
    intros.
    rewrite <- find_mapsto_iff.
    rewrite <- find_mapsto_iff in H.
    apply clean_ciphers_mapsto_iff; intuition idtac.
  Qed.

  Lemma honest_key_not_cleaned : forall cs c_id c k,
      cs $? c_id = Some c
      -> k = cipher_signing_key c
      -> honest_key honestk k
      -> clean_ciphers honestk cs $? c_id = Some c.
  Proof.
    intros.
    eapply clean_ciphers_keeps_honest_cipher; auto.
    unfold honest_cipher_filter_fn, cipher_honestly_signed.
    destruct c; subst.
    + invert H. rewrite <- honest_key_honest_keyb; eauto.
    + invert H. rewrite <- honest_key_honest_keyb; eauto.
  Qed.

  Hint Constructors
       msg_accepted_by_pattern : core.

  Hint Extern 1 (_ $+ (_,_) $? _ = _) => progress clean_map_lookups : core.

  Lemma clean_ciphers_eliminates_dishonest_cipher :
    forall c_id c cs k,
      cs $? c_id = Some c
      -> honest_keyb honestk k = false
      -> k = cipher_signing_key c
      -> clean_ciphers honestk cs $? c_id = None.
  Proof.
    intros; unfold clean_ciphers, filter.
    apply P.fold_rec_bis; intros; eauto.
    cases (honest_cipher_filter_fn honestk k0 e); eauto.
    cases (c_id ==n k0); subst; eauto.
    exfalso.
    rewrite find_mapsto_iff in H2; rewrite H2 in H; invert H.
    unfold honest_cipher_filter_fn, cipher_honestly_signed, cipher_signing_key in *.
    cases c; rewrite H0 in Heq; invert Heq.
  Qed.

  Hint Resolve clean_ciphers_eliminates_dishonest_cipher clean_ciphers_keeps_honest_cipher : core.

  Lemma clean_ciphers_keeps_added_honest_cipher :
    forall c_id c cs,
      honest_cipher_filter_fn honestk c_id c = true
      -> ~ In c_id cs
      -> clean_ciphers honestk (cs $+ (c_id,c)) = clean_ciphers honestk cs $+ (c_id,c).
  Proof.
    intros.
    apply map_eq_Equal; unfold Equal; intros.
    cases (c_id ==n y); subst; clean_map_lookups; eauto.
    unfold clean_ciphers, filter; rewrite fold_add; eauto.
    rewrite H; auto.
  Qed.

  Lemma clean_ciphers_reduces_or_keeps_same_ciphers :
    forall c_id c cs k,
      cs $? c_id = Some c
      -> cipher_signing_key c = k
      -> ( clean_ciphers  honestk cs $? c_id = Some c
        /\ honest_keyb honestk k = true)
      \/ ( clean_ciphers honestk cs $? c_id = None
        /\ honest_keyb honestk k = false).
  Proof.
    intros.
    case_eq (honest_keyb honestk k); intros; eauto.
    left; intuition idtac.
    eapply clean_ciphers_keeps_honest_cipher; eauto.
    unfold honest_cipher_filter_fn, cipher_signing_key in *.
    cases c; try invert H0; eauto.
  Qed.

  Lemma clean_ciphers_no_new_ciphers :
    forall c_id cs,
      cs $? c_id = None
      -> clean_ciphers honestk cs $? c_id = None.
  Proof.
    intros.
    unfold clean_ciphers, filter.
    apply P.fold_rec_bis; intros; eauto.
    cases (honest_cipher_filter_fn honestk k e); eauto.
    - case (c_id ==n k); intro; subst; unfold honest_cipher_filter_fn.
      + rewrite find_mapsto_iff in H0; rewrite H0 in H; invert H.
      + rewrite add_neq_o; eauto.
  Qed.

  Hint Resolve clean_ciphers_no_new_ciphers : core.

  Lemma clean_ciphers_eliminates_added_dishonest_cipher :
    forall c_id c cs k,
      cs $? c_id = None
      -> honest_keyb honestk k = false
      -> k = cipher_signing_key c
      -> clean_ciphers honestk cs = clean_ciphers honestk (cs $+ (c_id,c)).
  Proof.
    intros.
    apply map_eq_Equal; unfold Equal; intros.
    cases (y ==n c_id); subst.
    - rewrite clean_ciphers_no_new_ciphers; auto.
      symmetry.
      eapply clean_ciphers_eliminates_dishonest_cipher; eauto.
    - unfold clean_ciphers at 2, filter.
      rewrite fold_add; auto. simpl.
      unfold honest_cipher_filter_fn at 1.
      cases c; simpl in *; try invert H1; rewrite H0; trivial.
  Qed.

  Lemma not_in_ciphers_not_in_cleaned_ciphers :
    forall c_id cs,
      ~ In c_id cs
      -> ~ In c_id (clean_ciphers honestk cs).
  Proof.
    intros.
    rewrite not_find_in_iff in H.
    apply not_find_in_iff; eauto.
  Qed.

  Hint Resolve not_in_ciphers_not_in_cleaned_ciphers : core.

  Lemma dishonest_cipher_cleaned :
    forall cs c_id cipherMsg k,
      cipher_signing_key cipherMsg = k
      -> honest_keyb honestk k = false
      -> ~ In c_id cs
      -> clean_ciphers honestk cs = clean_ciphers honestk (cs $+ (c_id, cipherMsg)).
  Proof.
    intros.
    apply map_eq_Equal; unfold Equal; intros.
    case_eq (cs $? y); intros; simpl in *.
    - eapply clean_ciphers_reduces_or_keeps_same_ciphers in H2; eauto.
      split_ors; split_ands;
        unfold clean_ciphers, filter; rewrite fold_add by auto;
          unfold honest_cipher_filter_fn; cases cipherMsg; invert H; simpl in *; rewrite H0; reflexivity.
    - rewrite clean_ciphers_no_new_ciphers; auto. eapply clean_ciphers_no_new_ciphers in H2.
      unfold clean_ciphers, filter. rewrite fold_add by auto.
      unfold honest_cipher_filter_fn; cases cipherMsg; invert H; simpl in *; rewrite H0; eauto.
  Qed.

  Hint Resolve dishonest_cipher_cleaned : core.

  Hint Extern 1 (honest_cipher_filter_fn _ _ ?c = _) => unfold honest_cipher_filter_fn; cases c : core.

  Lemma clean_ciphers_added_honest_cipher_not_cleaned :
    forall cs c_id c k,
        honest_key honestk k
      -> k = cipher_signing_key c
      -> clean_ciphers honestk (cs $+ (c_id,c)) = clean_ciphers honestk cs $+ (c_id,c).
  Proof.
    intros.
    apply map_eq_Equal; unfold Equal; intros.

    case (y ==n c_id); intros; subst; clean_map_lookups.
    - erewrite clean_ciphers_keeps_honest_cipher; auto.
      invert H; unfold honest_cipher_filter_fn; eauto.
      unfold cipher_honestly_signed, honest_keyb;
        cases c; simpl in *; context_map_rewrites; auto; invert H0; rewrite H1; trivial.
    - case_eq (clean_ciphers honestk cs $? y); intros; subst;
        cases (cs $? y); subst; eauto.
        * assert (cs $? y = Some c1) as CSY by assumption;
            eapply clean_ciphers_reduces_or_keeps_same_ciphers in CSY; eauto;
              split_ors; split_ands;
                clean_map_lookups.
          eapply clean_ciphers_keeps_honest_cipher; eauto.
        * exfalso; eapply clean_ciphers_no_new_ciphers in Heq; contra_map_lookup.
        * assert (cs $? y = Some c0) as CSY by assumption;
            eapply clean_ciphers_reduces_or_keeps_same_ciphers in CSY; eauto;
              split_ors; split_ands; contra_map_lookup; eauto.
  Qed.

  Lemma clean_ciphers_idempotent :
    forall cs,
      ciphers_honestly_signed honestk cs
      -> clean_ciphers honestk cs = cs.
  Proof.
    unfold clean_ciphers, filter, ciphers_honestly_signed; intros.
    apply P.fold_rec_bis; intros; Equal_eq; subst; eauto.
    unfold honest_cipher_filter_fn.
    rewrite find_mapsto_iff in H0.
    assert (cipher_honestly_signed honestk e = true).
    eapply Forall_natmap_in_prop with (P := fun c => cipher_honestly_signed honestk c = true); eauto.
    rewrite H2; trivial.
  Qed.

  Lemma clean_ciphers_honestly_signed :
    forall cs,
      ciphers_honestly_signed honestk (clean_ciphers honestk cs).
  Proof.
    unfold ciphers_honestly_signed; intros.
    rewrite Forall_natmap_forall; intros.
    rewrite <- find_mapsto_iff, clean_ciphers_mapsto_iff in H; split_ands.
    unfold honest_cipher_filter_fn in *; assumption.
  Qed.

  Lemma honest_cipher_filter_fn_nochange_pubk :
    forall pubk k v,
      (forall k kp, pubk $? k = Some kp -> honestk $? k = Some true /\ kp = false)
      -> honest_cipher_filter_fn honestk k v =
        honest_cipher_filter_fn (honestk $k++ pubk) k v.
  Proof.
    unfold honest_cipher_filter_fn; intros;
      unfold cipher_honestly_signed;
      cases v; unfold honest_keyb; simpl;
        solve_perm_merges; auto;
          match goal with
          | [ H : (forall _ _, ?pubk $? _ = Some _ -> _), ARG : ?pubk $? _ = Some _ |- _ ] =>
            specialize (H _ _ ARG); split_ands; subst
          end; clean_map_lookups; eauto.
  Qed.

  Lemma clean_ciphers_nochange_pubk :
    forall pubk cs,
      (forall k p, pubk $? k = Some p -> honestk $? k = Some true /\ p = false)
      -> clean_ciphers (honestk $k++ pubk) cs = clean_ciphers honestk cs.
  Proof.
    intros; unfold clean_ciphers, filter.
    apply P.fold_rec_bis; intros; Equal_eq; eauto.
    rewrite fold_add; eauto; simpl.
    erewrite <- honest_cipher_filter_fn_nochange_pubk; eauto.
    subst; trivial.
  Qed.

  Lemma clean_ciphers_nochange_cipher :
    forall cs c_id c,
      clean_ciphers honestk cs $? c_id = Some c
      -> cs $? c_id = Some c.
  Proof.
    intros.
    rewrite <- find_mapsto_iff, clean_ciphers_mapsto_iff, find_mapsto_iff in H
    ; split_ex
    ; trivial.
  Qed.

End CleanCiphers.

Ltac encrypted_ciphers_prop :=
  match goal with
  | [ H  : encrypted_ciphers_ok _ (?cs $+ (?cid,?c)) _ |- _ ] => generalize (Forall_natmap_in_prop_add H); intros
  | [ H1 : ?cs $? _ = Some _, H2 : encrypted_ciphers_ok _ ?cs _ |- _ ] => generalize (Forall_natmap_in_prop _ H2 H1); simpl; intros
  end;
  repeat match goal with
         | [ H : encrypted_cipher_ok _ _ _ _ |- _ ] => invert H
         | [ H : honest_keyb _ _ = true |- _] => apply honest_keyb_true_honestk_has_key in H
         end; try contradiction.

Lemma clean_ciphers_new_honest_key_idempotent :
  forall honestk k_id cs gks,
    encrypted_ciphers_ok honestk cs gks
    -> ~ In k_id gks
    -> clean_ciphers (honestk $+ (k_id, true)) cs = clean_ciphers honestk cs.
Proof.
  intros.
  apply map_eq_Equal; unfold Equal; intros.
  cases (cs $? y).
  - case_eq (honest_cipher_filter_fn honestk y c); intros.
    + assert (honest_cipher_filter_fn honestk y c = true) as HCFF by assumption.
      unfold honest_cipher_filter_fn, cipher_honestly_signed in HCFF; encrypted_ciphers_prop
      ; erewrite !clean_ciphers_keeps_honest_cipher; eauto.

      simpl; unfold honest_keyb
      ; destruct (k ==n k_id)
      ; clean_map_lookups
      ; trivial.
      simpl; unfold honest_keyb
      ; destruct (k__s ==n k_id)
      ; clean_map_lookups
      ; trivial.

    + assert (honest_cipher_filter_fn honestk y c = false) as HCFF by assumption.
      unfold honest_cipher_filter_fn, cipher_honestly_signed, honest_keyb in HCFF.
      encrypted_ciphers_prop;
        try
          match goal with
          | [ H : honestk $? _ = _ |- _ ] => rewrite H in HCFF; discriminate
          end.
      * erewrite !clean_ciphers_eliminates_dishonest_cipher; eauto.
        unfold cipher_signing_key, honest_keyb;
          solve_simple_maps; eauto.
      * erewrite !clean_ciphers_eliminates_dishonest_cipher; eauto.
        unfold cipher_signing_key, honest_keyb;
          solve_simple_maps; eauto.
  - rewrite !clean_ciphers_no_new_ciphers; auto.
Qed.

#[export] Hint Immediate clean_ciphers_nochange_cipher : core.


From iris.program_logic Require Export weakestpre atomic.
From iris.heap_lang Require Export lang proofmode notation.
From iris.heap_lang.lib Require Import spin_lock.
From iris.algebra Require Import agree frac.
From iris_examples.logatom.flat_combiner Require Import sync misc.
From iris.prelude Require Import options.

(** The simple syncer spec in [sync.v] implies a logically atomic spec. *)

Definition syncR := prodR fracR (agreeR valO). (* track the local knowledge of ghost state *)
Class syncG Σ := sync_tokG :> inG Σ syncR.
Definition syncΣ : gFunctors := #[GFunctor (constRF syncR)].

Global Instance subG_syncΣ {Σ} : subG syncΣ Σ → syncG Σ.
Proof. solve_inG. Qed.

Section atomic_sync.
  Context `{EqDecision A, !heapGS Σ, !lockG Σ}.
  Canonical AO := leibnizO A.
  Context `{!inG Σ (prodR fracR (agreeR AO))}.

  (* TODO: Rename and make opaque; the fact that this is a half should not be visible
           to the user. *)
  Definition gHalf (γ: gname) g : iProp Σ := own γ ((1/2)%Qp, to_agree g).

  Definition atomic_seq_spec (ϕ: A → iProp Σ) α β (f x: val) :=
    (∀ g, {{{ ϕ g ∗ α g }}} f x {{{ v, RET v; ∃ g', ϕ g' ∗ β g g' v }}})%I.

  (* TODO: Provide better masks. ∅ as inner mask is pretty weak. *)
  Definition atomic_synced (ϕ: A → iProp Σ) γ (f f': val) :=
    (□ ∀ α β (x: val), atomic_seq_spec ϕ α β f x →
       <<< ∀ g, gHalf γ g ∗ □ α g >>> f' x @ ∅ <<< ∃ v, ∃ g', gHalf γ g' ∗ β g g' v, RET v >>>)%I.

  (* TODO: Use our usual style with a generic post-condition. *)
  (* TODO: We could get rid of the x, and hard-code a unit. That would
     be no loss in expressiveness, but probably more annoying to apply.
     How much more annoying? And how much to we gain in terms of things
     becomign easier to prove? *)
  (* This is really the core of the spec: It says that executing `s` on `f`
     turns the sequential spec with f, α, β into the concurrent triple with f', α, β. *)
  Definition is_atomic_syncer (ϕ: A → iProp Σ) γ (s: val) :=
    (□ ∀ (f: val), WP s f {{ f', atomic_synced ϕ γ f f' }})%I.

  Definition atomic_syncer_spec (mk_syncer: val) :=
    ∀ (g0: A) (ϕ: A → iProp Σ),
      {{{ ϕ g0 }}} mk_syncer #() {{{ γ s, RET s; gHalf γ g0 ∗ is_atomic_syncer ϕ γ s }}}.

  Lemma atomic_spec (mk_syncer: val):
      mk_syncer_spec mk_syncer → atomic_syncer_spec mk_syncer.
  Proof using Type*.
    iIntros (Hsync g0 ϕ ret) "Hϕ Hret".
    iMod (own_alloc (((1 / 2)%Qp, to_agree g0) ⋅ ((1 / 2)%Qp, to_agree g0))) as (γ) "[Hg1 Hg2]".
    { by rewrite -pair_op agree_idemp. }
    iApply (Hsync (∃ g: A, ϕ g ∗ gHalf γ g)%I with "[Hg1 Hϕ]")=>//.
    { iExists g0. by iFrame. }
    iNext. iIntros (s) "#Hsyncer". iApply "Hret".
    iSplitL "Hg2"; first done. iIntros "!#".
    iIntros (f). iApply wp_wand_r. iSplitR; first by iApply "Hsyncer".
    iIntros (f') "#Hsynced {Hsyncer}".
    iModIntro. iIntros (α β x) "#Hseq". change (ofe_car AO) with A.
    iIntros (Φ') "?".
    (* TODO: Why can't I iApply "Hsynced"? *)
    iSpecialize ("Hsynced" $! _ Φ' x).
    iApply ("Hsynced" with "[] [-]"); [|by iAccu|by auto].
    iIntros "!#" (Φ) "[HR HP] HΦ". iDestruct "HR" as (g) "[Hϕ Hg1]".
    (* we should view shift at this point *)
    iApply fupd_wp. iMod "HP" as (?) "[[Hg2 #Hα] [Hvs1 _]]".
    iDestruct (m_frag_agree with "Hg1 Hg2") as %Heq. subst.
    iMod ("Hvs1" with "[Hg2]") as "HP"; first by iFrame.
    iModIntro. iApply wp_fupd. iApply ("Hseq" with "[$Hϕ]"); first done.
    iIntros "!>" (v) "H". iDestruct "H" as (g') "[Hϕ' Hβ]".
    iApply "HΦ".
    iMod ("HP") as (g'') "[[Hg'' _] [_ Hvs2]]".
    iSpecialize ("Hvs2" $! v).
    iDestruct (m_frag_agree' with "Hg'' Hg1") as "[Hg %]". subst.
    rewrite Qp_div_2.
    iAssert (|==> own γ (((1 / 2)%Qp, to_agree g') ⋅ ((1 / 2)%Qp, to_agree g')))%I
      with "[Hg]" as ">[Hg1 Hg2]".
    { iApply own_update; last by iAssumption.
      apply cmra_update_exclusive. by rewrite -pair_op agree_idemp. }
    iMod ("Hvs2" with "[Hg1 Hβ]").
    { iExists g'. iFrame. }
    iModIntro. iSplitL "Hg2 Hϕ'"; last done.
    iExists g'. by iFrame.
  Qed.

End atomic_sync.


Require Import List.
Require Import Omega.

Require Import MachineModel.
Require Import Assembler.
Require Import SameJumpTransitions.

(*==============================================
   Operational Semantics
==============================================*)
Open Scope type_scope.

(* Operational rules *)
Reserved Notation "S '--->' S'" (at level 50, left associativity).

Inductive evalR : State -> State -> Prop :=

| eval_call : forall (p p' : Address) (r r' r'' : RegisterFile) (f : Flags) (m m' m'' : Memory) (rd : Register),
  inst (lookup m p) (call rd) ->
  p' = lookup m (r rd) ->
  entry_jump p p' ->
  set_stack p r m p' r' m' ->
  r'' = updateR r' SP (S (r' SP)) ->
  m'' = update m (r'' SP) (S p) ->
  (p, r, f, m) ---> (p', r'', f, m'')

| eval_ret : forall (p p' : Address) (r r' r'' : RegisterFile) (f : Flags) (m m' : Memory),
  inst (lookup m p)  ret ->
  p' =  lookup m (r SP) ->
  exit_jump p p' ->
  set_stack p r m p' r' m' ->
  r'' = updateR r' SP (minus (r' SP) 1) ->
  (p, r, f, m) ---> (p', r'', f, m')

| eval_callback : forall (p p' : Address) (r r' r'' : RegisterFile) (f : Flags) (m m' m'' : Memory) (rd : Register),
  inst (lookup m p) (call rd) ->
  p' = lookup m (r rd) ->
  exit_jump p p' ->
  r' = updateR r SP (S (r SP)) ->
  m' = update m (r' SP) (S p)->
  set_stack p r m p' r' m' ->
  r'' = updateR r' SP (S (r' SP)) ->
  m'' = (update m' (r'' SP) (address_returnback_entry_point)) ->
  (p, r, f, m) ---> (p', r'', f, m'')

| eval_retback : forall (p p' : Address) (r r' r'' : RegisterFile) (f : Flags) (m m' : Memory),
  inst (lookup m p)  ret ->
  p' =  lookup m (r SP) ->
  p' = address_returnback_entry_point ->
  entry_jump p p' ->
  set_stack p r m p' r' m' ->
  r'' = updateR r' SP (minus (r' SP) 1) ->
  (p, r, f, m) ---> ( p', r'', f, m')

| eval_writeout : forall (p : Address) (r : RegisterFile) (f : Flags) (m m' : Memory) (rd rs : Register),
  inst (lookup m p) (movs rd rs) ->
  int_jump p (S p) ->
  unprotected (r rd) ->
  m' = update m  (r rd) (r rs)->
  (p, r, f, m) ---> (S p, r, f, m')

| eval_int : forall (p p' : Address) (r r' : RegisterFile) (f f' : Flags) (m m' : MemSec) (me : MemExt) ,
  (p, r, f, m) --i--> (p', r', f', m') ->
  (p, r, f, (plug me m)) ---> (p', r', f', (plug me m'))

| eval_ext : forall (p p' : Address) (r r' : RegisterFile) (f f' : Flags) (m : MemSec) (me me' : MemExt) ,
  (p, r, f, me) --e--> (p', r', f', me') ->
  (p, r, f, (plug me m)) ---> (p', r', f', (plug me' m))

  where "S '--->' S'" := (evalR S S') : type_scope.

(* Inspired by some work of Benton *)

Inductive do_n_steps: State -> nat -> State -> Prop :=
| do_0 : forall sta, do_n_steps sta 0 sta
| do_Sn : forall n (p p' p'' : Address) (r r' r'' : RegisterFile) (f f' f'' : Flags) (c c' c'' : MemSec) (ctx ctx' ctx'' : MemExt),
  (p, r, f, plug ctx c) ---> (p', r', f', plug ctx' c') ->
  do_n_steps  (p', r', f', plug ctx' c') n  (p'', r'', f'', plug ctx'' c'') ->
  do_n_steps  (p, r, f, plug ctx c) (S n) (p'', r'', f'', plug ctx'' c'').

Definition anysteps (n : nat) (sta  : State) :=
  exists n' : nat , exists p : Address, exists r : RegisterFile, exists f : Flags, exists ctx : MemExt, exists c : MemSec,
      n' >= n /\ (do_n_steps sta n' (p, r, f, (plug ctx c))).

Definition diverge (sta : State) := forall n, anysteps n sta.

Definition contextual_equivalence (p1 p2 : MemSec) (c : MemExt) :=
    compatible p1 c -> compatible p2 c ->
    ( (diverge (initial p1 c)) <-> (diverge (initial p2 c)) ).


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 O E Eprime A B C Oprime Aprime Bprime Cprime Eprimeprime C2 C3 C0 : Universe, ((wd_ O E /\ (wd_ Oprime Eprime /\ (wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ A E /\ (wd_ Eprimeprime O /\ (wd_ O Oprime /\ (wd_ Bprime Oprime /\ (wd_ Eprimeprime A /\ (wd_ E Eprimeprime /\ (wd_ E Eprime /\ (wd_ O Eprime /\ (wd_ Oprime Eprimeprime /\ (wd_ Eprimeprime C /\ (wd_ Eprimeprime B /\ (wd_ E C /\ (wd_ E B /\ (wd_ C B /\ (wd_ E Oprime /\ (wd_ Bprime C3 /\ (wd_ Eprime C2 /\ (wd_ Aprime C2 /\ (wd_ Oprime Aprime /\ (wd_ A Aprime /\ (wd_ C Cprime /\ (wd_ B Bprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E C /\ (col_ Oprime Eprime Aprime /\ (col_ Oprime Eprime Bprime /\ (col_ Oprime Eprime Cprime /\ (col_ O Eprimeprime C /\ (col_ O Eprimeprime Oprime /\ (col_ O Eprimeprime C2 /\ (col_ O Eprimeprime C3 /\ col_ O A C0))))))))))))))))))))))))))))))))))))) -> col_ E C B)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Export ProofAlgebra.ProofAlgebra.
Require Export ProofAlgebra.Composable.
Require Export ProofAlgebra.SumE.


Add Rec LoadPath "/home/daniel/UniMath/UniMath" as UniMath.

Require Import Foundations.Generalities.uu0.
Require Import Foundations.hlevel1.hProp.
Require Import Foundations.hlevel2.hSet.

Require Import RezkCompletion.precategories.
Require Import RezkCompletion.functors_transformations.
Require Import RezkCompletion.whiskering.

Load terminalCat.

Local Notation "a --> b" := (precategory_morphisms a b) (at level 50).
Local Notation "f ;; g" := (compose f g) (at level 50, format "f  ;;  g").
Local Notation "# F" := (functor_on_morphisms F)(at level 3).

Definition get_hs
  (C : hs_precategory)
    : has_homsets C
:= pr2 (pr2 C).

Definition hs_precat_pair
  (C : precategory) (hs : has_homsets C)
    : hs_precategory.
Proof.
  unfold hs_precategory.
  apply (tpair _ (pr1 C)).
  split.
  apply (pr2 C).
  apply hs.
Defined.

Definition hs_funct_precat
  (C : precategory) (D: hs_precategory)
    : hs_precategory.
Proof.
  apply (hs_precat_pair (functor_precategory C D (pr2 (pr2 D)))).
  apply (functor_category_has_homsets C D (get_hs D)).
Defined.

Local Notation "D ^^ C" := (hs_funct_precat C D) (at level 2).

(* coercion isn't working (??) when I want to apply a functor from D ^^ C
   to an object of C, need something with coercion to funclass? *)
Definition get_funct
  {C : precategory} {D : hs_precategory} (F : D ^^ C)
    : functor C D.
Proof.
  apply F.
Defined.

Definition dget_funct
  {C D : precategory} {E : hs_precategory}
  (F : (E^^D)^^C )
  (c : C)
    : functor D E.
Proof.
  apply (get_funct F c).
Defined.

Definition tget_funct
  {B C D : precategory} {E : hs_precategory}
  (F : ((E^^D)^^C)^^B )
  (b : B) (c : C)
    : functor D E.
Proof.
  apply (dget_funct F b c).
Defined.

Arguments get_funct {C D} / F.
Arguments dget_funct {C D E} / F c.
Arguments tget_funct {B C D E} / F b c.

Definition get_nat
  {C : precategory} {D : hs_precategory} {F G : D^^C}
  (u : F --> G)
    : nat_trans (get_funct F) (get_funct G).
Proof.
  apply u.
Defined.

Definition dget_nat
  {C D : precategory} {E : hs_precategory} {F G : (E^^D)^^C}
  (v : F --> G) (c : C)
    : nat_trans (dget_funct F c) (dget_funct G c).
Proof.
  apply (get_nat v c).
Defined.

Definition funct_cat
  (C : precategory) (D : category)
    : category.
Proof.
  apply (tpair _ (functor_precategory C D (pr2 (pr2 D)))).
  apply (is_category_functor_category C D).
Defined.

Local Notation "[ C , D ]'" := (funct_cat C D) (at level 2).

(* If 2categories.v still compiles, delete this
Definition function_from_functor_cat
  {C : precategory} {D : category}
    : [C, D]' -> C -> D.
Proof.
  intro f.
  apply f.
Defined.
*)

(* function from terminal cate defines a functor *)
Definition terminal_cat_functors
  {C : hs_precategory}
    : (terminal_cat -> C) ->  C ^^ terminal_cat.
Proof.
  intro x.
  apply (tpair _ (terminal_cat_functors_data x)).
  split.
  - intro a.
    destruct a.
    simpl.
    apply idpath.
  - intros a b c f g.
    destruct a, b, c.
    simpl.
    apply (pathsinv0 (id_left _ _ _ (identity (x tt)))).
Defined.

(* precomposition *)
Definition funct_precomp_data
  {C : precategory} {D : hs_precategory}
  (F : D^^C) (E : hs_precategory)
    : functor_data E^^D E^^C.
Proof.
  apply (tpair _ (functor_composite _ _ _ F)).
  intros G G' u.
  apply (pre_whisker (get_funct F) u).
Defined.

Definition funct_precomp
  {C : precategory} {D : hs_precategory}
  (F : D^^C) (E : hs_precategory)
    : functor E^^D E^^C.
Proof.
  apply (tpair _ (funct_precomp_data F E)).
  split.
  - intro G.
    apply pre_whisker_identity.
    apply get_hs.
  - intros G G' G'' u v.
    apply pre_whisker_composition.
    apply get_hs.
Defined.

(* postcomposition *)
Definition funct_postcomp_data
  {C : hs_precategory} {D : hs_precategory}
  (E : precategory) (F : D^^C)
    : functor_data C^^E D^^E.
Proof.
  apply (tpair _ (fun G' : C^^E =>  functor_composite _ _ _ G' F)).
  intros G G' u.
  apply (post_whisker u (get_funct F)).
Defined.

Definition funct_postcomp
  {C : hs_precategory} {D : hs_precategory}
  (E : precategory) (F : D^^C)
    : functor C^^E D^^E.
Proof.
  apply (tpair _ (funct_postcomp_data E F)).
  split.
  - intro G.
    apply nat_trans_eq.
    apply get_hs.
    intro a.
    apply (functor_id (get_funct F)).
  - intros G G' G'' u v.
    apply nat_trans_eq.
    apply get_hs.
    intro a.
    apply (functor_comp (get_funct F)).
Defined.

(* argument swaping functor (E^^D)^^C ^^ (E^^C)^^D

   The general pattern is to define the object function, then functor
   data, then the actual functor. This is done several times. *)
Definition funct_arg_swap_ob_to_ob_to_data
  {C D : precategory} {E : hs_precategory}
    : (E^^D)^^C -> (D -> (functor_data C E)).
Proof.
  intros F d.
  apply (tpair _ (fun c : C => dget_funct F c d)).
  intros a b f.
  (* re-figure out the args thing so it unfolds get_funct automatically *)
  unfold dget_funct; unfold get_funct.
  apply (# (get_funct F) f).
Defined.

Definition funct_arg_swap_ob_to_ob_to_funct
  {C D : precategory} {E : hs_precategory}
    : (E^^D)^^C -> (D -> (E^^C)).
Proof.
  intros F d.
  apply (tpair _ ((funct_arg_swap_ob_to_ob_to_data F) d)).
  split.
  - intro a; simpl.
    rewrite (functor_id (get_funct F)).
    apply idpath.
  - intros a b c f g; simpl.
    rewrite (functor_comp (get_funct F)).
    apply idpath.
Defined.

Definition funct_arg_swap_on_mor
  {C D : precategory} {E : hs_precategory}
  (F : (E^^D)^^C) {a b : D} (f : a --> b)
    : forall c : C, (dget_funct F c) a --> (dget_funct F c) b.
Proof.
  intro c.
  apply (#(dget_funct F c) f).
Defined.

Definition funct_arg_swap_ob_to_funct_data
  {C D : precategory} {E : hs_precategory}
    : (E^^D)^^C -> (functor_data D E^^C).
Proof.
  intro F.
  apply (tpair _ (funct_arg_swap_ob_to_ob_to_funct F)).
  intros a b f; simpl.
  apply (tpair _ (funct_arg_swap_on_mor F f)).
  intros x y g.
  (* get the natural transformation data from (# F g) *)
  set (H := pr2 (#(get_funct F) g)).
  simpl in *.
  apply (pathsinv0 (H a b f)).
Defined.

Definition funct_arg_swap_ob
  (C D : precategory) (E : hs_precategory)
    : (E^^D)^^C -> (E^^C)^^D.
Proof.
  intro F.
  apply (tpair _ (funct_arg_swap_ob_to_funct_data F)).
  split.
  - intro a.
    apply nat_trans_eq.
    apply get_hs.
    intro c.
    apply (functor_id (dget_funct F c)).
  - intros a b c f g.
    apply nat_trans_eq.
    apply get_hs.
    intro d.
    apply (functor_comp (dget_funct F d)).
Defined.

Definition funct_arg_swap_mor_mor
  {C D : precategory} {E : hs_precategory} {F G : (E^^D)^^C}
  (u : F --> G) (d : D)
    : forall c : C,
       get_funct (funct_arg_swap_ob_to_funct_data F d) c -->
       get_funct (funct_arg_swap_ob_to_funct_data G d) c.
Proof.
  intro c.
  apply (dget_nat u c d).
Defined.

Definition funct_arg_swap_mor
  {C D : precategory} {E : hs_precategory} {F G : (E^^D)^^C}
  (u : F --> G)
    : forall d : D, (funct_arg_swap_ob_to_funct_data F) d -->
                    (funct_arg_swap_ob_to_funct_data G) d.
Proof.
  intro d; simpl.
  apply (tpair _ (funct_arg_swap_mor_mor u d)).
  intros a b f; simpl.
  unfold funct_arg_swap_mor_mor.
  unfold dget_nat; unfold get_nat.
  (* There should be a nicer way of doing this, like inverse functional
     extensionality or generalize d or something.*)
  apply (nat_trans_eq_pointwise _ _ _ _ _ _ (pr2 u a b f)).
Defined.

Definition funct_arg_swap_data
  (C D : precategory) (E : hs_precategory)
    : functor_data (E^^D)^^C (E^^C)^^D.
Proof.
  apply (tpair _ (funct_arg_swap_ob C D E)).
  intros F G u.
  simpl.
  apply (tpair _ (funct_arg_swap_mor u)).
  intros a b f.
  apply nat_trans_eq.
  apply get_hs.
  intro c.
  simpl.
  unfold funct_arg_swap_mor_mor.
  apply (pr2 (dget_nat u c)).
Defined.

Definition funct_arg_swap
  {C D : precategory} {E : hs_precategory}
    : functor ((E^^D)^^C) ((E^^C)^^D).
Proof.
  apply (tpair _ (funct_arg_swap_data C D E)).
  split.
  - intro a.
    apply nat_trans_eq.
    apply get_hs.
    intro y.
    apply nat_trans_eq.
    apply get_hs.
    intro x.
    simpl.
    unfold funct_arg_swap_mor_mor.
    unfold dget_funct; unfold get_funct.
    unfold dget_nat; unfold get_nat.
    simpl.
    apply idpath.
  - intros a b c f g.
    apply nat_trans_eq.
    apply get_hs.
    intro y.
    apply nat_trans_eq.
    apply get_hs.
    intro x.
    simpl.
    unfold funct_arg_swap_mor_mor.
    unfold dget_nat; unfold get_nat.
    simpl.
    apply idpath.
    (* I wonder why this takes so long to compute. If I remove the simpls
       right before the idpath, then the idpath takes a long time to check
       *)
Defined.

(* Definition of the comp functor *)
Definition functor_comp_functor_fun
  (C D E : hs_precategory)
    : (D ^^ C) -> ((E ^^ C) ^^ (E ^^ D)).
Proof.
  intro F.
  apply (funct_precomp F E).
Defined.

Definition functor_comp_functor_nat
  {C D E : hs_precategory}
  (F G : D ^^ C) (u : F --> G)
    : forall H : E ^^ D, (funct_precomp F E) H --> (funct_precomp G E) H.
Proof.
  intro H.
  apply post_whisker.
  apply u.
Defined.

Definition functor_comp_functor_data
  (C D E : hs_precategory)
    : functor_data (D ^^ C) ((E ^^ C) ^^ (E ^^ D)).
Proof.
  apply (tpair _ (fun F : D ^^ C => funct_precomp F E)).
  intros F G u.
  apply (tpair _ (functor_comp_functor_nat F G u)).
  intros H H' r.
  apply nat_trans_eq.
  apply get_hs.
  intro a.
  simpl.
  apply pathsinv0.
  apply (pr2 r (pr1 F a) (pr1 G a) (pr1 u a)).
Defined.

Definition functor_comp_functor
  (C D E : hs_precategory)
    : ((E ^^ C) ^^ (E ^^ D)) ^^ (D ^^ C).
Proof.
  apply (tpair _ (functor_comp_functor_data C D E)).
  split.
  - intro F.
    apply nat_trans_eq. apply get_hs.
    intro G.
    apply nat_trans_eq. apply get_hs.
    intro a.
    simpl.
    apply functor_id.
  - intros F F' F'' u u'.
    apply nat_trans_eq. apply get_hs.
    intro G.
    apply nat_trans_eq. apply get_hs.
    intro a.
    simpl.
    apply functor_comp.
Defined.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal18.

From lfind Require Import LFind.
Lemma lfind_state  (y:lst):@eq lst (rev y) (append (rev y) Nil).
Admitted.
From QuickChick Require Import QuickChick.
QCInclude "/home/yousef/lemmafinder/benchmark/_lfind_clam_lf_goal18_theorem0_43_lem3/".
QCInclude ".".
Extract Constant defNumTests => "50".
Derive Show for lst.

              Derive Arbitrary for lst.

              Instance Dec_Eq_lst : Dec_Eq lst.

              Proof. dec_eq. Qed.

Open Scope string_scope.

Parameter print : lst -> string -> lst.
Extract Constant print => "Extract.print".
Definition collect_data  (y:lst) :=
 let lfind_var := "y:" ++ "(" ++ show y ++ ")"
 in let lfind_v := print y lfind_var
 in lfind_state lfind_v .
QuickChick collect_data.
Success.


Require Import VST.floyd.proofauto.
Local Open Scope logic.
Require Import List. Import ListNotations.
Require Import tweetnacl20140427.Snuffle.
Require Import tweetnacl20140427.Salsa20.
Require Import ZArith.

Require Import tweetnacl20140427.tweetnaclVerifiableC.
Require Import tweetnacl20140427.spec_salsa.
Require Import tweetnacl20140427.verif_salsa_base.
Opaque Snuffle20. Opaque prepare_data. Opaque Snuffle.Snuffle.

Lemma crypto_core_salsa20_ok: semax_body SalsaVarSpecs SalsaFunSpecs
      f_crypto_core_salsa20_tweet crypto_core_salsa20_spec.
Proof. unfold crypto_core_salsa20_spec.
start_function.
abbreviate_semax.
assert_PROP (field_compatible (tarray tuchar 64) [] out /\ isptr out) as HH by entailer!.
destruct HH as [FCout isptrout].
Time forward_call (c, k, Z0, nonce, out, default_val (tarray tuchar 64), data). (*1.8*)
  unfold data_at_, field_at_. rewrite field_at_data_at.
  rewrite field_address_offset by auto with field_compatible.
  rewrite isptr_offset_val_zero; trivial. cancel.
Intros ret.
Time forward. (*1.7*)
unfold fcore_result in H.
  remember (Snuffle20 (prepare_data data)) as d; symmetry in Heqd.
  destruct d. 2: inv H. rewrite Int.eq_true in H.
Exists l.
Time entailer!.
Time Qed. (*4.3*)

Lemma Snuffle_sub_simpl data x:
    Snuffle20 (prepare_data data) = Some x ->
    exists s, Snuffle 20 (prepare_data data) = Some s /\
    forall i (I:0 <= i < 16) v,
      Znth i (prepare_data data) Int.zero = v ->
      littleendian_invert (Int.sub (Znth i x Int.zero) v) =
      littleendian_invert (Znth i s Int.zero).
Proof. intros.
Transparent Snuffle20. unfold Snuffle20 in H. Opaque Snuffle20.
remember (Snuffle 20 (prepare_data data)) as sn.
destruct sn; simpl in H. 2: inv H. clear Heqsn.
exists l; split; trivial.
intros. rewrite (sumlist_char_Znth _ _ _ H).
  rewrite Int.add_commut, Int.sub_add_l, H0, Int.sub_idem, Int.add_zero_l. trivial.
symmetry in H; apply sumlist_length in H.
rewrite Zlength_correct, H, prepare_data_length; trivial.
Qed.

Lemma crypto_core_hsalsa20_ok: semax_body SalsaVarSpecs SalsaFunSpecs
      f_crypto_core_hsalsa20_tweet crypto_core_hsalsa20_spec.
Proof. unfold crypto_core_hsalsa20_spec.
start_function.
Time forward_call (c, k, 1, nonce, out, OUT, data). (*1.4*)
Intros res.
Time forward. (*1.6*)
unfold fcore_result in H.
  remember (Snuffle20 (prepare_data data)) as d; symmetry in Heqd.
  destruct d. 2: inv H. rewrite Int.eq_false in H.
destruct (Snuffle_sub_simpl _ _ Heqd) as [x [X1 X2]].
Exists x.
Time entailer!. (*0.6*)
2: apply Int.one_not_zero.
unfold fcorePOST_SEP; cancel.
  destruct data as[[Nonce C] [K L]].
  destruct C as [[[C1 C2] C3] C4].
  destruct Nonce as [[[N1 N2] N3] N4].
  destruct K as [[[K1 K2] K3] K4].
  destruct L as [[[L1 L2] L3] L4].
apply derives_refl'. f_equal.
  do 8 rewrite X2 in H by (try omega; reflexivity).
  apply H.
Time Qed. (*2.8*)


From Undecidability Require Import MaxList.
From Undecidability Require Import TM.Util.TM_facts TM.Code.CodeTM.

From Undecidability Require Import TM.Util.VectorPrelim.

(* MOVE : this file contains general lemmas from is all over the place... *)

Lemma max_list_rec_eq_foldl (a : nat) (xs : list nat) :
  fold_left max xs a = max_list_rec a xs.
Proof.
  revert a. induction xs as [ | x xs IH]; intros; cbn in *.
  - reflexivity.
  - rewrite IH. rewrite !max_list_rec_max. nia.
Qed.

Lemma sizeOfmTapes_max_list_map (sig : Type) (n : nat) (T : tapes sig n) :
  sizeOfmTapes T = max_list_map (@sizeOfTape _) (vector_to_list T).
Proof.
  unfold sizeOfmTapes.
  rewrite fold_left_vector_to_list.
  rewrite <- vector_to_list_map.
  unfold max_list_map, max_list.
  apply max_list_rec_eq_foldl.
Qed.

Lemma sizeOfmTapes_upperBound (sig : Type) (n : nat) (tps : tapes sig n) :
  forall t, Vector.In t tps -> sizeOfTape t <= sizeOfmTapes tps.
Proof. intros. rewrite sizeOfmTapes_max_list_map. apply max_list_map_ge. now apply vector_to_list_In. Qed.

From Undecidability Require Import L.Prelim.MoreList.

Lemma max_list_sumn l : max_list l <= sumn l.
Proof.
  unfold max_list.
  induction l;cbn. 2:rewrite max_list_rec_max'. all:nia.
Qed.

Lemma right_sizeOfTape sig' (t:tape sig') :
  length (right t) <= sizeOfTape t.
Proof.
  destruct t;cbn. all:autorewrite with list;cbn. all:nia.
Qed.

Lemma length_tape_local_right sig' (t:tape sig') :
  length (tape_local (tape_move_right t)) <= sizeOfTape t.
Proof.
  destruct t;cbn.  1-3:nia. rewrite tape_local_move_right'. autorewrite with list;cbn. all:nia.
Qed.

Lemma size_list X sigX (cX: codable sigX X) (l:list X) :
  size l = sumn (map size l) + length l + 1.
Proof.
  unfold size. cbn. rewrite encode_list_concat.
  rewrite app_length, length_concat, map_map. cbn.
  change S with (fun x => 1 + x). rewrite sumn_map_add,sumn_map_c. setoid_rewrite map_length.
  cbn.  nia.
Qed.

Lemma destruct_vector1 (X : Type) (v : Vector.t X 1) :
  exists x, v = [| x |].
Proof. destruct_vector. eauto. Qed.


Require Import list_examples.

Definition tail_code := Plus1++Load::Ret::nil.

Inductive tail_spec : Spec cfg :=
  tail_claim : forall H x y l, fun_claim tail_spec
  "tail" (Plus1++Load::Ret::nil)
    1 (fun p => asP H (rep_seg (x::nil) y p :* rep_list l y))
    1 (fun p => constraint (p = y) :* litP H).

Lemma tail_proof : sound stack_step tail_spec.
Proof. list_solver. Qed.


(** * Undecidability of the subtyping problem of System Fsub without arrow types *)

Require Import Undecidability.Synthetic.Undecidability.

Require Import Fsub_na FsubN FsubN_undec FsubD FsubF RM CM2.
Require Import Reductions.FsubN_to_Fsub.
Require Import Reductions.FsubD_to_FsubN.
Require Import Reductions.FsubF_to_FsubD.
Require Import Reductions.RM_HALT_to_FsubF.
Require Import Reductions.CM2_Halt_to_RM_Halt.
Require Import Reductions.CM2_HALT_to_CM2_HALT.

From Undecidability.CounterMachines
  Require Import CM2 CM2_undec.

Theorem Fsub'_SUBTYPE_undec : undecidable Fsub'_SUBTYPE.
Proof.
  apply (undecidability_from_reducibility CM2_HALT_undec).
  eapply reduces_transitive. exact CM2_HALT_to_CM2_HALT.reduction.
  eapply reduces_transitive. exact CM2_Halt_to_RM_Halt.reduction.
  eapply reduces_transitive. exact RM_HALT_to_FsubF.reduction.
  eapply reduces_transitive. exact FsubF_to_FsubD.reduction.
  eapply reduces_transitive. exact FsubD_to_FsubN.reduction.
  exact FsubN_to_Fsub.reduction_off.
Qed.

Check Fsub'_SUBTYPE_undec.


Require Import
        Fiat.Narcissus.Common.Specs.

Require Export
        Fiat.Narcissus.Formats.Base.SequenceFormat
        Fiat.Narcissus.Formats.Base.FMapFormat
        Fiat.Narcissus.Formats.Base.StrictTerminalFormat
        Fiat.Narcissus.Formats.Base.LaxTerminalFormat
        Fiat.Narcissus.Formats.Base.FixFormat
        Fiat.Narcissus.Formats.Base.EnqueueFormat
        Fiat.Narcissus.Formats.Base.UnionFormat.

(* Aliases of Correct Decoder for deriving partial views of data. *)
Definition CorrectRefinedDecoder
           {S T : Type}
           {store : Cache}
           {V : Type}
           (monoid : Monoid T)
           (Source_Predicate : S -> Prop)
           (View_Predicate : V -> Prop)
           (view : S -> V -> Prop)
           (format subformat : FormatM S T)
           (decode : T -> CacheDecode -> Hopefully (V * T * CacheDecode))
           (decode_inv : CacheDecode -> Prop)
           (view_format : V -> CacheFormat -> Comp (T * CacheFormat)) :=
  CorrectDecoder monoid Source_Predicate View_Predicate view
                 subformat decode decode_inv
                 (fun v env t =>
                    view_format v env t
                    /\ forall s,
                      Source_Predicate s ->
                        subformat s env ∋ t
                        -> view s v).
Definition Prefix_Format
           {S T : Type}
           {store : Cache}
           (monoid : Monoid T)
           (format subformat : FormatM S T)
  := forall s t env env',
    format s env ∋ (t, env') ->
    exists t1 t2 env'',
      t = mappend t1 t2
      /\ subformat s env ∋ (t1, env'').

(*Lemma  CorrectRefinedDecoder_decode_partial
       {S T : Type}
       {store : Cache}
       {V : Type}
       (monoid' : Monoid T)
       (Source_Predicate : S -> Prop)
       (View_Predicate : V -> Prop)
       (view : S -> V -> Prop)
       (format subformat : FormatM S T)
       (decode : T -> CacheDecode -> Hopefully (V * T * CacheDecode))
       (decode_inv : CacheDecode -> Prop)
       (view_format : V -> CacheFormat -> Comp (T * CacheFormat))
  : CorrectRefinedDecoder monoid' Source_Predicate View_Predicate view
                          format subformat decode decode_inv view_format
    -> forall s t env env',
      format s env ∋ (t, env') ->
      exists t1 t2 env'',
        t = mappend t1 t2 /\
        subformat s env ∋ (t1, env'').
Proof.
  intro.
  eapply H; eauto.
  (* apply proj2 in H. *)
  (* eapply H. *)
  (* eapply H in H0. *)

  (* intros [? [? ?] ] * ?. *)
  (* eapply H0 in H1. *)
  (* unfold sequence_Format, ComposeOpt.compose, Bind2 in H1. *)
  (* computes_to_inv; destruct v; destruct v0; simpl in *; eauto. *)
  (* injections. *)
  (* eexists _, _, _; intuition eauto. *)
Qed. *)

Lemma CorrectRefinedDecoder_decode_impl
       {S T : Type}
       {store : Cache}
       (monoid' : Monoid T)
       (Source_Predicate : S -> Prop)
       (format : FormatM S T)
       (decode : T -> CacheDecode -> Hopefully (S * T * CacheDecode))
       (decode_inv : CacheDecode -> Prop)
  : CorrectRefinedDecoder monoid' Source_Predicate Source_Predicate eq
                          format format decode decode_inv format
    -> CorrectDecoder monoid' Source_Predicate Source_Predicate eq
                      format decode decode_inv format.
Proof.
  intros.
  eapply weaken_view_pred.
  intros; subst; eauto.
  2: apply H.
  intros.
  simpl in H1; intuition eauto.
Qed.

Add Parametric Morphism
    S T V
    (cache : Cache)
    (monoid : Monoid T)
    (Source_Predicate : S -> Prop)
    (View_Predicate : V -> Prop)
    (view : S -> V -> Prop)
    (decode : DecodeM (V * T) T)
    (decode_inv : CacheDecode -> Prop)
    (subformat : FormatM S T)
    (view_format : FormatM V T)
  : (fun format =>
       @CorrectRefinedDecoder S T cache V monoid Source_Predicate View_Predicate
                       view format subformat decode decode_inv view_format)
    with signature (EquivFormat --> impl)
      as format_decode_refined_correct_refineEquiv.
Proof.
  unfold EquivFormat, impl, pointwise_relation; intros.
  - unfold CorrectRefinedDecoder in *.
    apply H0.
Qed.

Add Parametric Morphism
    {S T : Type}
    {cache : Cache}
    (monoid : Monoid T)
  : (fun format subformat =>
       @Prefix_Format S T cache monoid format subformat)
    with signature (EquivFormat --> EquivFormat --> impl)
      as prefix_format_refineEquiv.
Proof.
  unfold EquivFormat, impl, pointwise_relation; unfold Prefix_Format; intros.
  edestruct H1. apply H. eauto. destruct_conjs.
  eexists _, _, _. intuition eauto. apply H0. eauto.
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 A B C D P Q R Z T I Y0 : Universe, ((wd_ A C /\ (wd_ P Q /\ (wd_ C D /\ (wd_ R C /\ (wd_ A B /\ (wd_ P R /\ (wd_ T Z /\ (wd_ C P /\ (wd_ Q C /\ (wd_ A Z /\ (wd_ I Z /\ (wd_ I C /\ (wd_ T A /\ (wd_ Z C /\ (wd_ R I /\ (wd_ Y0 I /\ (wd_ Y0 Z /\ (wd_ Y0 C /\ (col_ P R R /\ (col_ A T Z /\ (col_ P R Q /\ (col_ C R Y0 /\ (col_ C I Y0 /\ col_ C R Z))))))))))))))))))))))) -> col_ I Y0 Z)).
Proof.
  time tac.
Qed.

End FOFProblem.


(* Default settings (from HsToCoq.Coq.Preamble) *)

Generalizable All Variables.

Unset Implicit Arguments.
Set Maximal Implicit Insertion.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Require Coq.Program.Tactics.
Require Coq.Program.Wf.

(* Preamble *)

(* Converted imports: *)

Require GHC.Base.
Require GHC.Prim.
Import GHC.Base.Notations.

(* Converted type declarations: *)

Record Category__Dict (cat : Type -> Type -> Type) := Category__Dict_Build {
  id__ : forall {a}, cat a a ;
  op_z2218U____ : forall {b} {c} {a}, cat b c -> cat a b -> cat a c }.

Definition Category (cat : Type -> Type -> Type) :=
  forall r__, (Category__Dict cat -> r__) -> r__.

Existing Class Category.

Definition id `{g__0__ : Category cat} : forall {a}, cat a a :=
  g__0__ _ (id__ cat).

Definition op_z2218U__ `{g__0__ : Category cat}
   : forall {b} {c} {a}, cat b c -> cat a b -> cat a c :=
  g__0__ _ (op_z2218U____ cat).

Notation "'_∘_'" := (op_z2218U__).

Infix "∘" := (_∘_) (left associativity, at level 40).

(* Converted value declarations: *)

Definition op_zlzlzl__ {cat} {b} {c} {a} `{Category cat}
   : cat b c -> cat a b -> cat a c :=
  _∘_.

Notation "'_<<<_'" := (op_zlzlzl__).

Infix "<<<" := (_<<<_) (at level 99).

Definition op_zgzgzg__ {cat} {a} {b} {c} `{Category cat}
   : cat a b -> cat b c -> cat a c :=
  fun f g => g ∘ f.

Notation "'_>>>_'" := (op_zgzgzg__).

Infix ">>>" := (_>>>_) (at level 99).

(* Skipping instance `Control.Category.Category__Coercion' of class
   `Control.Category.Category' *)

(* Skipping instance `Control.Category.Category__op_ZCz7eUz7eUZC__' of class
   `Control.Category.Category' *)

(* Skipping instance `Control.Category.Category__op_ZCz7eUZC__' of class
   `Control.Category.Category' *)

Local Definition Category__arrow_id : forall {a}, GHC.Prim.arrow a a :=
  fun {a} => GHC.Base.id.

Local Definition Category__arrow_op_z2218U__
   : forall {b} {c} {a},
     GHC.Prim.arrow b c -> GHC.Prim.arrow a b -> GHC.Prim.arrow a c :=
  fun {b} {c} {a} => _GHC.Base.∘_.

Program Instance Category__arrow : Category GHC.Prim.arrow :=
  fun _ k__ =>
    k__ {| id__ := fun {a} => Category__arrow_id ;
           op_z2218U____ := fun {b} {c} {a} => Category__arrow_op_z2218U__ |}.

Module Notations.
Notation "'_Control.Category.∘_'" := (op_z2218U__).
Infix "Control.Category.∘" := (_∘_) (left associativity, at level 40).
Notation "'_Control.Category.<<<_'" := (op_zlzlzl__).
Infix "Control.Category.<<<" := (_<<<_) (at level 99).
Notation "'_Control.Category.>>>_'" := (op_zgzgzg__).
Infix "Control.Category.>>>" := (_>>>_) (at level 99).
End Notations.

(* External variables:
     Type GHC.Base.id GHC.Base.op_z2218U__ GHC.Prim.arrow
*)


Set Warnings "-notation-overridden,-parsing,-deprecated-hint-without-locality".
From Coq Require Import Bool.Bool.
From Coq Require Import Strings.String.
From Coq Require Import Arith.Arith.
From Coq Require Import Arith.EqNat. Import Nat.
From Coq Require Import Arith.PeanoNat.
From Coq Require Import Strings.String.
From Coq Require Import Logic.Eqdep_dec.
From PFPL Require Import PartialMap_Set.
From PFPL Require Import Definitions.

Lemma same_structure_refl :
  forall e, same_structure e e.
Proof.
  induction e; constructor; auto.
Qed.

Lemma same_structure_sym :
  forall e e', same_structure e e' -> same_structure e' e.
Proof.
  intros e e' H. induction H; constructor; auto.
Qed.

Lemma same_structure_trans : forall e e' e'',
  same_structure e e' -> same_structure e' e'' ->
  same_structure e e''.
Proof.
  intros e e' e'' H. generalize dependent e''.
  induction H; intros.
  - inversion H. subst. constructor.
  - inversion H1. subst. constructor; auto.
  - inversion H. subst. constructor.
  - inversion H. subst. constructor.
  - inversion H1. subst. constructor; auto.
  - inversion H1. subst. constructor; auto.
  - inversion H1. subst. constructor; auto.
  - inversion H0. subst. constructor; auto.
Qed.

Lemma same_structure_equal_constructor :
  forall e e', same_structure e e' -> ~ diff_constructor e e'.
Proof.
  intros.
  induction H; subst; intro; simpl in H; contradiction.
Qed.


Require Import Crypto.Compilers.Syntax.
Require Import Crypto.Compilers.Named.Syntax.
Require Import Crypto.Compilers.Named.Context.
Require Import Crypto.Util.PointedProp.
Require Import Crypto.Util.Notations.

Module Export Named.
  Section language.
    Context {base_type_code : Type}
            {op : flat_type base_type_code -> flat_type base_type_code -> Type}
            {Name : Type}
            {interp_base_type : base_type_code -> Type}
            {Context : Context Name interp_base_type}
            (interp_op : forall s d, op s d -> interp_flat_type interp_base_type s -> interp_flat_type interp_base_type d)
            (interped_op_side_conditions : forall s d, op s d -> interp_flat_type interp_base_type s -> pointed_Prop).

    Local Notation exprf := (@exprf base_type_code op Name).
    Local Notation expr := (@expr base_type_code op Name).

    Fixpoint interpf_side_conditions_gen {t} (ctx : Context) (e : exprf t)
      : option (pointed_Prop * interp_flat_type interp_base_type t)
      := match e with
         | TT => Some (trivial, tt)
         | Var t' x => option_map (fun v => (trivial, v)) (lookupb t' ctx x)
         | Op t1 tR opc args
           => match @interpf_side_conditions_gen _ ctx args with
              | Some (args_cond, argsv)
                => Some (args_cond /\ interped_op_side_conditions _ _ opc argsv, interp_op _ _ opc argsv)
              | None => None
              end
         | LetIn _ n ex _ eC
           => match @interpf_side_conditions_gen _ ctx ex with
              | Some (x_cond, x)
                => match @interpf_side_conditions_gen _ (extend ctx n x) eC with
                   | Some (c_cond, cv)
                     => Some (x_cond /\ c_cond, cv)
                   | None => None
                   end
              | None => None
              end
         | Pair _ ex _ ey
           => match @interpf_side_conditions_gen _ ctx ex, @interpf_side_conditions_gen _ ctx ey with
              | Some (x_cond, xv), Some (y_cond, yv) => Some (x_cond /\ y_cond, (xv, yv))
              | None, _ | _, None => None
              end
         end%pointed_prop.
    Definition interpf_side_conditions {t} ctx e : option pointed_Prop
      := option_map (@fst _ _) (@interpf_side_conditions_gen t ctx e).
    Definition interp_side_conditions {t} ctx (e : expr t) : interp_flat_type interp_base_type (domain t) -> option pointed_Prop
      := fun x => interpf_side_conditions (extend ctx (Abs_name e) x) (invert_Abs e).
    Definition InterpSideConditions {t} (e : expr t) : interp_flat_type interp_base_type (domain t) -> option pointed_Prop
      := interp_side_conditions empty e.
  End language.
End Named.


Require Import SpecDeps.
Require Import RData.
Require Import EventReplay.
Require Import MoverTypes.
Require Import Constants.
Require Import CommonLib.
Require Import AbsAccessor.Spec.

Local Open Scope Z_scope.

Section SpecLow.

  Definition rvic_clear_flag_spec0 (intid: Z64) (bitmap: Pointer) (adt: RData) : option RData :=
    match intid, bitmap with
    | VZ64 _intid, (_bitmap_base, _bitmap_ofst) =>
      rely is_int64 _intid;
      when' _idx == interrupt_bitmap_dword_spec (VZ64 _intid) adt;
      rely is_int64 _idx;
      when' _bit == interrupt_bit_spec (VZ64 _intid) adt;
      rely is_int64 _bit;
      when'' _t'3_base, _t'3_ofst == get_bitmap_loc_spec (_bitmap_base, _bitmap_ofst) (VZ64 _idx) adt;
      rely is_int _t'3_ofst;
      rely is_int _bit;
      when adt == atomic_bit_clear_release_64_spec (_t'3_base, _t'3_ofst) _bit adt;
      Some adt
     end
    .

End SpecLow.


Require Export Mtac.Mtac.
Import MtacNotations.

Require Import List.
Import ListNotations.

Inductive pattern A (B : A -> Type) (t : A) : Prop :=
| pbase : forall (x:A) (b : t = x -> Mtac (B x)), Unification -> pattern A B t
| ptele : forall {C}, (forall (x : C), pattern A B t) -> pattern A B t.

Definition NotUnifiableException {A} (x y : A) : Exception. exact exception. Qed.
Definition munify A (x y : A) (P : A -> Type) (f : x = y -> M (P y)) : M (P x)
  := mmatch x with y => [H] f H | _ => raise (NotUnifiableException x y) end.
Arguments munify {A} x y P f.

Definition open_pattern {A} {P:A->Type} {t:A}  :=
  mfix1 op (p : pattern A P t) : M (pattern A P t) :=
    match p return M _ with
    | pbase _ _ _ x f u => ret p : M (pattern _ _ _)
    | @ptele _ _ _ C f =>
      e <- evar C; op (f e)
    end.

Definition NoPatternMatches : Exception. exact exception. Qed.
Definition Anomaly : Exception. exact exception. Qed.

Fixpoint mmatch' {A P} t (ps : list (pattern A P t)) : M (P t) :=
  match ps with
  | [] => raise NoPatternMatches
  | (p :: ps') =>
    p' <- open_pattern p;
    mtry
      match p' with
      | pbase _ _ _ t' f u =>
        munify t t' P f : M (P t)
      | _ => raise Anomaly
      end
    with [? A (x y:A)] NotUnifiableException x y =>
      mmatch' t ps'
    end
  end.

Arguments ptele {A B t C} f.
Arguments pbase {A B t} x b u.

Notation "[? x .. y ] ps" := (ptele (fun x=> .. (ptele (fun y=>ps)).. ))
  (at level 202, x binder, y binder, ps at next level) : mtac_pattern_scope.
Notation "p => b" := (pbase p%core (fun _=>b%core) UniRed)
  (no associativity, at level 201) : mtac_pattern_scope.
Notation "p => [ H ] b" := (pbase p%core (fun H=>b%core) UniRed)
  (no associativity, at level 201, H at next level) : mtac_pattern_scope.
Notation "'_' => b " := (ptele (fun x=> pbase x (fun _=>b%core) UniRed))
  (at level 201, b at next level) : mtac_pattern_scope.

Delimit Scope mtac_pattern_scope with mtac_pattern.

Notation "'with' | p1 | .. | pn 'end'" :=
  ((cons p1%mtac_pattern (.. (cons pn%mtac_pattern nil) ..)))
    (at level 91, p1 at level 210, pn at level 210).
Notation "'with' p1 | .. | pn 'end'" :=
  ((cons p1%mtac_pattern (.. (cons pn%mtac_pattern nil) ..)))
    (at level 91, p1 at level 210, pn at level 210).

Notation "'mmatch' x ls" := (mmatch' x ls).

(* Test *)
  Definition NotFound : Exception.
    exact exception.
  Qed.

Definition inl' A (x : A) : forall l : list A, M (In x l) :=
  mfix1 f (l : list A) : M (In x l) :=
  mmatch l with
  | [? l r] l ++ r =>
      ttry (
        il <- f l;
        ret (in_or_app l r x (or_introl il)) )
      (fun e=>mmatch e with NotFound =>
        ir <- f r;
        ret (in_or_app l r x (or_intror ir))
      end)
  | [? s] (x :: s) => ret (in_eq _ _)
  | [? y s] (y :: s) => r <- f s; ret (in_cons y _ _ r)
  | _ => raise NotFound
  end.

Example testM (
x01 x11 x21 x31 x41 x51 x61 x71 x81 x91
x02 x12 x22 x32 x42 x52 x62 x72 x82 x92
x03 x13 x23 x33 x43 x53 x63 x73 x83 x93
x04 x14 x24 x34 x44 x54 x64 x74 x84 x94
x05 x15 x25 x35 x45 x55 x65 x75 x85 x95
x06 x16 x26 x36 x46 x56 x66 x76 x86 x96
x07 x17 x27 x37 x47 x57 x67 x77 x87 x97
x08 x18 x28 x38 x48 x58 x68 x78 x88 x98
x09 x19 x29 x39 x49 x59 x69 x79 x89 x99
 : nat) : In x99 [
x01;x11;x21;x31;x41;x51;x61;x71;x81;x91;
x02;x12;x22;x32;x42;x52;x62;x72;x82;x92;
x03;x13;x23;x33;x43;x53;x63;x73;x83;x93;
x04;x14;x24;x34;x44;x54;x64;x74;x84;x94;
x05;x15;x25;x35;x45;x55;x65;x75;x85;x95;
x06;x16;x26;x36;x46;x56;x66;x76;x86;x96;
x07;x17;x27;x37;x47;x57;x67;x77;x87;x97;
x08;x18;x28;x38;x48;x58;x68;x78;x88;x98;
x09;x19;x29;x39;x49;x59;x69;x79;x89;x99
].
Proof.
  Time rrun (inl' _ _ _).
Qed.

Require Import Mtac.Mtactics.
Example testo (
x01 x11 x21 x31 x41 x51 x61 x71 x81 x91
x02 x12 x22 x32 x42 x52 x62 x72 x82 x92
x03 x13 x23 x33 x43 x53 x63 x73 x83 x93
x04 x14 x24 x34 x44 x54 x64 x74 x84 x94
x05 x15 x25 x35 x45 x55 x65 x75 x85 x95
x06 x16 x26 x36 x46 x56 x66 x76 x86 x96
x07 x17 x27 x37 x47 x57 x67 x77 x87 x97
x08 x18 x28 x38 x48 x58 x68 x78 x88 x98
x09 x19 x29 x39 x49 x59 x69 x79 x89 x99
 : nat) : In x99 [
x01;x11;x21;x31;x41;x51;x61;x71;x81;x91;
x02;x12;x22;x32;x42;x52;x62;x72;x82;x92;
x03;x13;x23;x33;x43;x53;x63;x73;x83;x93;
x04;x14;x24;x34;x44;x54;x64;x74;x84;x94;
x05;x15;x25;x35;x45;x55;x65;x75;x85;x95;
x06;x16;x26;x36;x46;x56;x66;x76;x86;x96;
x07;x17;x27;x37;x47;x57;x67;x77;x87;x97;
x08;x18;x28;x38;x48;x58;x68;x78;x88;x98;
x09;x19;x29;x39;x49;x59;x69;x79;x89;x99
].
Proof.
  Time rrun (ListMtactics.inlist _ _).
Qed.


Require Export FcEtt.imports.
Require Import ett_ott.
Require Import ett_inf.
Require Import ett_match.

Inductive pattern_renamed : tm -> tm -> available_props ->
                                        available_props -> Prop :=
 | pattern_renamed_Base : forall (F:const) (D:available_props),
     pattern_renamed (a_Fam F) (a_Fam F) D  AtomSetImpl.empty
 | pattern_renamed_AppRel : forall (p1:tm) (R:role) (x:tmvar) (p2:tm)
                                  (y:tmvar) (D D':available_props),
     pattern_renamed p1 p2 D D' -> ~ AtomSetImpl.In  y (D  \u  D') ->
     pattern_renamed (a_App p1 (Role R) (a_Var_f x))
                     (a_App p2 (Role R) (a_Var_f y)) D  (singleton  y  \u  D')
 | pattern_renamed_AppIrrel : forall (p1 p2:tm) (D D':available_props),
     pattern_renamed p1 p2 D D' ->
     pattern_renamed (a_App p1 (Rho Irrel) a_Bullet)
                     (a_App p2 (Rho Irrel) a_Bullet) D D'
 | pattern_renamed_CApp : forall (p1 p2:tm) (D D':available_props),
     pattern_renamed p1 p2 D D' ->
     pattern_renamed (a_CApp p1 g_Triv) (a_CApp p2 g_Triv) D D'.

Hint Constructors pattern_renamed.

Lemma pattern_renamed_extend_support : forall p p' D D' D1,
      pattern_renamed p p' D D' ->
      AtomSetImpl.inter (fv_tm_tm_tm p') D1 [<=] empty ->
      pattern_renamed p p' (D \u D1) D'.
Proof. intros. induction H; simpl in *; eauto.
        - constructor. eapply IHpattern_renamed.
          eapply (Subset_trans _ H0). fsetdec.
        - constructor. eapply IHpattern_renamed.
          eapply (Subset_trans _ H0).
        - constructor. eapply IHpattern_renamed.
          eapply (Subset_trans _ H0).
          Unshelve. all: clear. all:fsetdec.
Qed.

Lemma Rename_narrow : forall p b p' b' D D' S, Rename p b p' b' D D' ->
      S [<=] D -> Rename p b p' b' S D'.
Proof. intros. induction H; eauto.
       econstructor. eauto. fsetdec.
Qed.

Lemma inter_empty : forall S1 S2, (forall x, x `in` S1 -> x `notin` S2) ->
      AtomSetImpl.inter S1 S2 [<=] empty.
Proof. intros. intro. intro. apply inter_iff in H0. apply empty_iff.
       inversion H0. eapply H; eauto.
Qed.

Lemma Rename_inter_sub_empty : forall p b p' b' D D' S1 S2,
      Rename p b p' b' D D' -> S1 [<=] D -> S2 [<=] D' ->
      AtomSetImpl.inter S1 S2 [<=] empty.
Proof. intros. apply inter_empty. intros. eapply subset_notin.
       eapply Rename_inter_empty. eauto. eauto. auto.
Qed.

Fixpoint tm_var_pairs (a p : tm) : list (tm * var) :=
   match (a,p) with
 | (a_Fam F, a_Fam F') => []
 | (a_App a1 (Role R) a2, a_App p1 (Role R') (a_Var_f x)) =>
                                       tm_var_pairs a1 p1 ++ [(a2,x)]
 | (a_App a (Rho Irrel) a', a_App p (Rho Irrel) a_Bullet) =>
                                       tm_var_pairs a p
 | (a_CApp a g_Triv, a_CApp p g_Triv) => tm_var_pairs a p
 | (_,_) => []
   end.

Definition chain_subst a p b := fold_left
       (fun b' a'x' => tm_subst_tm_tm a'x'.1 a'x'.2 b') (tm_var_pairs a p) b.

Lemma chain_subst_lc : forall a p b, tm_pattern_agree a p -> lc_tm b ->
      lc_tm (chain_subst a p b).
Proof. intros. induction H; simpl; auto.
       unfold chain_subst in *. simpl. rewrite fold_left_app. simpl.
       apply tm_subst_tm_tm_lc_tm. auto. auto.
Qed.

Lemma chain_subst_fv : forall a p b, tm_pattern_agree a p ->
      fv_tm_tm_tm (chain_subst a p b) [<=]
        (AtomSetImpl.diff (fv_tm_tm_tm b) (fv_tm_tm_tm p)) \u (fv_tm_tm_tm a).
Proof. intros. induction H; eauto.
        - pose (P := fv_tm_tm_tm_tm_subst_tm_tm_upper (chain_subst a1 p1 b) a2 x).
          unfold chain_subst in *. simpl. rewrite fold_left_app. simpl.
          eapply Subset_trans. eapply P. fsetdec.
        - unfold chain_subst in *. simpl. fsetdec.
        - unfold chain_subst in *. simpl. fsetdec.
Qed.

Lemma Rename_lc_body : forall p p' b b' D D', Rename p b p' b' D D' ->
      lc_tm b.
Proof. intros. induction H; eauto.
Qed.

Lemma Rename_pattern_renamed : forall p b p' b' D D', Rename p b p' b' D D' ->
      pattern_renamed p p' D D'.
Proof. intros. induction H; eauto.
Qed.

Lemma Rename_chain_subst : forall p b p' b' D D', Rename p b p' b' D D' ->
                           b' = chain_subst p' p b.
Proof. intros. induction H; simpl; eauto.
       unfold chain_subst in *. simpl. rewrite fold_left_app. simpl.
       rewrite <- IHRename. auto.
Qed.

Lemma chain_subst_Rename : forall p b p' D D', pattern_renamed p p' D D' ->
      lc_tm b -> Rename p b p' (chain_subst p' p b) D D'.
Proof. intros. induction H; simpl; eauto. unfold chain_subst in *.
       simpl. rewrite fold_left_app. simpl. eauto.
Qed.

Lemma matchsubst_chain_subst : forall a p b, tm_pattern_agree a p ->
                               matchsubst a p b = chain_subst a p b.
Proof. intros. induction H; simpl; eauto. unfold chain_subst in *. simpl.
       rewrite fold_left_app. simpl. rewrite <- IHtm_pattern_agree. auto.
Qed.

Lemma subst_via : forall a y z,
      (forall b, y `notin` fv_tm_tm_tm b ->
      tm_subst_tm_tm a y (tm_subst_tm_tm (a_Var_f y) z b) =
      tm_subst_tm_tm a z b) /\
      (forall brs, y `notin` fv_tm_tm_brs brs ->
      tm_subst_tm_brs a y (tm_subst_tm_brs (a_Var_f y) z brs) =
      tm_subst_tm_brs a z brs) /\
      (forall g, y `notin` fv_tm_tm_co g ->
      tm_subst_tm_co a y (tm_subst_tm_co (a_Var_f y) z g) =
      tm_subst_tm_co a z g) /\
      (forall phi, y `notin` fv_tm_tm_constraint phi ->
      tm_subst_tm_constraint a y (tm_subst_tm_constraint (a_Var_f y) z phi) =
      tm_subst_tm_constraint a z phi).
Proof. intros. apply tm_brs_co_constraint_mutind; intros; simpl;
       try (simpl in H; try simpl in H1; try simpl in H2; f_equal; eauto; fail).
       destruct (eq_var x z). simpl. rewrite eq_dec_refl. auto.
       simpl. destruct (eq_var x y). subst. simpl in H. fsetdec. auto.
Qed.

Lemma subst_via_tm : forall a y z b, y `notin` fv_tm_tm_tm b ->
      tm_subst_tm_tm a y (tm_subst_tm_tm (a_Var_f y) z b) =
      tm_subst_tm_tm a z b.
Proof. intros. eapply subst_via; eauto.
Qed.

Lemma subst_commute : forall a1 a2 x1 x2, x1 `notin` fv_tm_tm_tm a2 ->
      x2 `notin` fv_tm_tm_tm a1 -> x1 <> x2 ->
      (forall b, tm_subst_tm_tm a2 x2 (tm_subst_tm_tm a1 x1 b) =
      tm_subst_tm_tm a1 x1 (tm_subst_tm_tm a2 x2 b)) /\
      (forall brs, tm_subst_tm_brs a2 x2 (tm_subst_tm_brs a1 x1 brs) =
      tm_subst_tm_brs a1 x1 (tm_subst_tm_brs a2 x2 brs)) /\
      (forall g, tm_subst_tm_co a2 x2 (tm_subst_tm_co a1 x1 g) =
      tm_subst_tm_co a1 x1 (tm_subst_tm_co a2 x2 g)) /\
      (forall phi, tm_subst_tm_constraint a2 x2
       (tm_subst_tm_constraint a1 x1 phi) =
        tm_subst_tm_constraint a1 x1 (tm_subst_tm_constraint a2 x2 phi)).
Proof. intros a1 a2 x1 x2 P Q R.
       apply tm_brs_co_constraint_mutind; intros; simpl; eauto;
       try (f_equal; eauto; fail).
       destruct (eq_var x x1). destruct (eq_var x x2). subst. contradiction.
       subst. simpl. rewrite eq_dec_refl. rewrite tm_subst_tm_tm_fresh_eq; auto.
       destruct (eq_var x x2). subst. simpl. rewrite eq_dec_refl.
       rewrite tm_subst_tm_tm_fresh_eq; auto.
       rewrite tm_subst_tm_tm_fresh_eq; auto.
       rewrite tm_subst_tm_tm_fresh_eq; auto.
Qed.

Lemma subst_commute_tm : forall a1 a2 x1 x2 b, x1 `notin` fv_tm_tm_tm a2 ->
      x2 `notin` fv_tm_tm_tm a1 -> x1 <> x2 ->
      tm_subst_tm_tm a2 x2 (tm_subst_tm_tm a1 x1 b) =
      tm_subst_tm_tm a1 x1 (tm_subst_tm_tm a2 x2 b).
Proof. intros. eapply subst_commute; auto.
Qed.

Lemma chain_subst_subst_commute : forall a p x a' b,
      tm_pattern_agree a p ->
      x `notin` fv_tm_tm_tm a -> x `notin` fv_tm_tm_tm p ->
      AtomSetImpl.inter (fv_tm_tm_tm p) (fv_tm_tm_tm a') [<=] empty ->
      chain_subst a p (tm_subst_tm_tm a' x b) =
      tm_subst_tm_tm a' x (chain_subst a p b).
Proof. intros. generalize dependent b. induction H; intros; simpl; eauto.
        - simpl in H0, H1, H2. unfold chain_subst in *. simpl.
          rewrite fold_left_app. rewrite fold_left_app. simpl.
          rewrite subst_commute_tm. fsetdec. fsetdec. fsetdec.
          rewrite IHtm_pattern_agree. fsetdec. fsetdec. fsetdec. auto.
        - simpl in H0, H1, H2. unfold chain_subst in *. simpl.
          rewrite IHtm_pattern_agree. fsetdec. fsetdec. fsetdec. auto.
        - simpl in H0, H1, H2. unfold chain_subst in *. simpl.
          rewrite IHtm_pattern_agree. fsetdec. fsetdec. fsetdec. auto.
Qed.

Theorem MatchSubst_Rename_preserve : forall p b D D' p1 b1 D1 p2 b2 D2 a a1 a2,
   tm_pattern_agree a p -> Rename p b p1 b1 D D1 -> Rename p b p2 b2 D' D2 ->
   (fv_tm_tm_tm a \u fv_tm_tm_tm p \u fv_tm_tm_tm b) [<=] D ->
   (fv_tm_tm_tm a \u fv_tm_tm_tm p \u fv_tm_tm_tm b) [<=] D' ->
   uniq_atoms_pattern p -> MatchSubst a p1 b1 a1 -> MatchSubst a p2 b2 a2 ->
   a1 = a2.
Proof. intros. generalize dependent p1. generalize dependent b1.
       generalize dependent D. generalize dependent D1. generalize dependent a1.
       generalize dependent a2. generalize dependent p2. generalize dependent b2.
       generalize dependent D'. generalize dependent D2. generalize dependent b.
       induction H; intros.
         - inversion H5. inversion H0. inversion H6. inversion H1. subst. auto.
         - unfold uniq_atoms_pattern in *. simpl in *.
           inversion H5; subst. inversion H7; inversion H1; subst.
           inversion H6; subst.
           assert (L0 : lc_tm b). { eapply Rename_lc_body; eauto. }
           assert (L1 : tm_pattern_agree a1 p4).
             { eapply MatchSubst_match; eauto. }
           assert (L2 : tm_pattern_agree a1 p5).
             { eapply MatchSubst_match; eauto. }
           assert (L3 : pattern_renamed p1 p4 D D'0).
             { eapply Rename_pattern_renamed; eauto. }
           assert (L4 : pattern_renamed p1 p5 D' D'1).
             { eapply Rename_pattern_renamed; eauto. }
           assert (L5 : tm_pattern_agree p4 p1).
             { eapply tm_pattern_agree_cong; eauto.
               apply tm_pattern_agree_tm_tm_agree; auto. }
           assert (L6 : tm_pattern_agree p5 p1).
             { eapply tm_pattern_agree_cong. eapply H0.
               apply tm_pattern_agree_tm_tm_agree; auto. }
           pose (P1 := matchsubst_ind_fun H18). clearbody P1.
           move: (matchsubst_ind_fun H20) => P2.
           rewrite <- P1. rewrite <- P2.
           rewrite matchsubst_chain_subst. auto.
           rewrite matchsubst_chain_subst. auto.
           move: (Rename_chain_subst H16) => P3.
           pose (P4 := Rename_chain_subst H27). rewrite P3. rewrite P4.
           pick fresh z.
           assert
           (HYP : chain_subst a1 p4 (chain_subst p4 p1
                      (tm_subst_tm_tm (a_Var_f z) x b)) =
                  chain_subst a1 p5 (chain_subst p5 p1
                      (tm_subst_tm_tm (a_Var_f z) x b))).
           { assert (lc_tm (tm_subst_tm_tm (a_Var_f z) x b)).
             { eapply tm_subst_tm_tm_lc_tm; eauto. }
             apply IHtm_pattern_agree with (b := tm_subst_tm_tm (a_Var_f z) x b)
             (D := D \u singleton z)(D1 := D'0)(p3 := p4)
             (b1 := chain_subst p4 p1 (tm_subst_tm_tm (a_Var_f z) x b))
             (D' := D' \u singleton z)(D2 := D'1)(p2 := p5)
             (b2 := chain_subst p5 p1 (tm_subst_tm_tm (a_Var_f z) x b)).
             -- rewrite <- app_nil_r. eapply NoDup_remove_1. eauto.
             -- rewrite (fv_tm_tm_tm_tm_subst_tm_tm_upper b (a_Var_f z) x).
                simpl.
                assert (h0 : singleton z [<=] singleton z). auto.
                apply (Subset_union H3) in h0.
                eapply (Subset_trans _ h0).
             -- apply chain_subst_Rename.
                eapply pattern_renamed_extend_support; eauto.
                clear - Fr. assert (z `notin` fv_tm_tm_tm p5).
                fsetdec. clear - H. fsetdec. auto.
             -- apply matchsubst_fun_ind. eauto.
                eapply chain_subst_lc; eauto. auto.
                apply matchsubst_chain_subst; auto.
             -- rewrite (fv_tm_tm_tm_tm_subst_tm_tm_upper b (a_Var_f z) x).
                simpl.
                assert (h0 : singleton z [<=] singleton z). auto.
                apply (Subset_union H2) in h0.
                eapply (Subset_trans _ h0).
             -- apply chain_subst_Rename.
                eapply pattern_renamed_extend_support; eauto.
                clear - Fr. assert (z `notin` fv_tm_tm_tm p4).
                fsetdec. clear - H. fsetdec. auto.
             -- apply matchsubst_fun_ind. eauto.
                eapply chain_subst_lc; eauto. auto.
                apply matchsubst_chain_subst; auto.
                Unshelve. all: clear. all: fsetdec.
           }
           rewrite <- tm_subst_tm_tm_back_forth with (x := y) (y := z)
          (b := tm_subst_tm_tm (a_Var_f y) x (chain_subst p4 p1 b)).
           rewrite -> subst_via_tm with (y := y) (b := chain_subst p4 p1 b).
           rewrite -> chain_subst_subst_commute with (a' := a_Var_f y) (x := z).
           rewrite -> subst_via_tm with (y := y).
           rewrite <- chain_subst_subst_commute with (a' := a_Var_f z).
           rewrite HYP.
           rewrite <- subst_via_tm with (y := y0)(z := z).
           rewrite <- chain_subst_subst_commute with (a' := a_Var_f y0) (x := z).
           rewrite -> chain_subst_subst_commute with (a' := a_Var_f z) (x := x).
           rewrite -> subst_via_tm with (y := z)(z := x). auto.
           -- rewrite chain_subst_fv. clear - Fr.
              rewrite AtomSetProperties.diff_subset. fsetdec. auto.
           -- auto.
           -- move: (Rename_fv_new_pattern H27) => M1. rewrite M1.
              move: (Rename_inter_empty H27) => M2. apply M2.
              clear - H3. fsetdec.
           -- move: (tm_pattern_agree_pattern H0) => M1.
              intro. move: (pattern_fv M1 H8) => M2.
              clear - H4 M2. apply NoDup_remove in H4.
              inversion H4. rewrite app_nil_r in H0. contradiction.
           -- clear - Fr. simpl. assert (z `notin` fv_tm_tm_tm p1).
              fsetdec. clear - H. fsetdec.
           -- auto.
           -- clear - Fr. simpl. assert (z `notin` fv_tm_tm_tm a1).
              fsetdec. clear - H. fsetdec.
           -- clear - Fr. simpl. assert (z `notin` fv_tm_tm_tm p5).
              fsetdec. clear - H. fsetdec.
           -- simpl. move: (Rename_fv_new_pattern H27) => M1.
              clear - H28 M1. fsetdec.
           -- repeat rewrite chain_subst_fv.
              rewrite fv_tm_tm_tm_tm_subst_tm_tm_upper. simpl.
              apply AtomSetProperties.not_in_union.
              repeat rewrite AtomSetProperties.diff_subset.
              apply AtomSetProperties.not_in_union.
              apply AtomSetProperties.not_in_union.
              clear - Fr. fsetdec. clear - H3 H28. fsetdec.
              move: (Rename_fv_new_pattern H27) => M1. clear - M1 H28.
              fsetdec. clear - H3 H28. fsetdec. auto. auto.
           -- auto.
           -- move: (Rename_fv_new_pattern H16) => M1. rewrite M1.
              move: (Rename_inter_empty H16) => M2. apply M2.
              clear - H2. fsetdec.
           -- move: (tm_pattern_agree_pattern H0) => M1.
              intro. move: (pattern_fv M1 H8) => M2.
              clear - H4 M2. apply NoDup_remove in H4.
              inversion H4. rewrite app_nil_r in H0. contradiction.
           -- clear - Fr. simpl. assert (z `notin` fv_tm_tm_tm p1).
              fsetdec. clear - H. fsetdec.
           -- rewrite chain_subst_fv.
              rewrite fv_tm_tm_tm_tm_subst_tm_tm_upper. simpl.
              apply AtomSetProperties.not_in_union.
              rewrite AtomSetProperties.diff_subset.
              apply AtomSetProperties.not_in_union.
              clear - Fr. fsetdec. rewrite chain_subst_fv.
              rewrite AtomSetProperties.diff_subset.
              move: (Rename_fv_new_pattern H16) => M1. clear - H2 H17 M1.
              fsetdec. auto. clear - H2 H17. fsetdec. auto.
           -- auto.
           -- clear - Fr. fsetdec.
           -- clear - Fr. fsetdec.
           -- move: (Rename_fv_new_pattern H16) => M1. clear - H17 M1.
              simpl. fsetdec.
           -- rewrite chain_subst_fv. rewrite AtomSetProperties.diff_subset.
              apply AtomSetProperties.not_in_union. clear - H2 H17. fsetdec.
              move: (Rename_fv_new_pattern H16) => M1. rewrite M1. clear - H17.
              fsetdec. auto.
           -- rewrite fv_tm_tm_tm_tm_subst_tm_tm_upper. simpl.
              apply AtomSetProperties.not_in_union. clear - Fr.
              do 6 apply notin_union_2 in Fr. apply notin_union_1 in Fr. auto.
              rewrite chain_subst_fv. rewrite AtomSetProperties.diff_subset.
              clear - Fr. fsetdec. auto.
         - unfold uniq_atoms_pattern in *. simpl in *.
           inversion H5; subst. inversion H7; inversion H1; subst.
           inversion H6; subst.
           eapply IHtm_pattern_agree with (b := b)(D' := D') (D := D). auto.
           fsetdec. eapply H17. auto. fsetdec. eapply H9. auto.
         - unfold uniq_atoms_pattern in *. simpl in *.
           inversion H0; subst. inversion H5; inversion H1; subst.
           inversion H6; subst.
           eapply IHtm_pattern_agree with (b := b)(D' := D') (D := D). auto.
           fsetdec. eapply H14. auto. fsetdec. eapply H8. auto.
Qed.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import omega.Omega.
Require Import Setoid.
Require Import ZArith.

Require Import FinProof.Common.
Require Import FinProof.CommonInstances.
Require Import FinProof.StateMonad2.
Require Import FinProof.StateMonadInstances.
Require Import FinProof.ProgrammingWith.

Local Open Scope struct_scope.

Require Import FinProof.CommonProofs.
Require Import depoolContract.ProofEnvironment.
Require Import depoolContract.DePoolClass.
Require Import depoolContract.SolidityNotations.

Require Import depoolContract.DePoolFunc.
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

(* Import SolidityNotations. *)
Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100.
(*Set Typeclasses Strict Resolution. *)
(* Set Typeclasses Debug.  *)
(* Set Typeclasses Unique Instances.
Unset Typeclasses Unique Solutions. *)

(* Existing Instance monadStateT.
Existing Instance monadStateStateT. *)
(* Module MultiSigWalletSpecSig := MultiSigWalletSpecSig XTypesSig StateMonadSig. *)

Require Import depoolContract.Lib.CommonModelProofs.
Module CommonModelProofs := CommonModelProofs StateMonadSig.
Import CommonModelProofs.
Require Import depoolContract.Lib.Tactics.
Require Import depoolContract.Lib.ErrorValueProofs.
Require Import depoolContract.Lib.CommonCommon.

(* Require Import MultiSigWallet.Proofs.tvmFunctionsProofs. *)

Import DePoolSpec.LedgerClass.SolidityNotations.

Local Open Scope solidity_scope.

Local Open Scope struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

 (* constructor() public {
        bool ok = false;
        for (uint8 i = 0; i < 2; ++i) {
            TvmBuilder b;
            b.store(address(msg.sender), i);
            uint256 publicKey = tvm.hash(b.toCell());
            ok = ok || tvm.pubkey() == publicKey;
        }
        require(ok, ERROR_IS_NOT_DEPOOL);
        m_dePool = msg.sender;
    }
*)

Opaque Z.eqb.
Lemma DePoolProxyContract_Ф_Constructor5_exec : forall (l: Ledger) ,
                                      (*LedgerT ( XErrorValue True XInteger )*)
let b := default in
              (* bool ok = false; *)
let ok := false in
(*first time, i = 0*)
            (* TvmBuilder b;
               b.store(address(msg.sender), i); *)
let b' := builder_store b ( eval_state ( msg_sender ) l )  0 in
            (* uint256 publicKey = tvm.hash(b.toCell()) *)
let publicKey := tvm_hash ( toCell b' ) in
            (* ok = ok || tvm.pubkey() == publicKey; *)
let ok' := ( ok || ( ( eval_state ( tvm_pubkey ) l ) =? publicKey ) )%bool in

(*second time, i = 1*)
            (* TvmBuilder b;
               b.store(address(msg.sender), i); *)
let b'' := default in
let b''' := builder_store b'' ( eval_state ( msg_sender ) l ) 1 in
            (* uint256 publicKey = tvm.hash(b.toCell()) *)
let publicKey' := tvm_hash ( toCell b''' )  in
            (* ok = ok || tvm.pubkey() == publicKey; *)
let ok'' := ( ok' || ( ( eval_state ( tvm_pubkey ) l ) =? publicKey' ) )%bool in
            (* require(ok, ERROR_IS_NOT_DEPOOL); *)
let req : bool := ( ok'' ) in

         exec_state ( ↓ DePoolProxyContract_Ф_constructor5 ) l =
                 if req then
          {$ l With DePoolProxyContract_ι_m_dePool := ( eval_state ( msg_sender ) l ) $}
                 else l.
Proof.
   intros.
   destruct l.
   destruct Ledger_ι_VMState.
   compute. destructIf; auto.
Qed.

Lemma DePoolProxyContract_Ф_Constructor5_eval : forall (l: Ledger) ,
                                      (*LedgerT ( XErrorValue True XInteger )*)
let b := default in
              (* bool ok = false; *)
let ok := false in
(*first time, i = 0*)
            (* TvmBuilder b;
               b.store(address(msg.sender), i); *)
let b' := builder_store b ( eval_state ( msg_sender ) l )  0 in
            (* uint256 publicKey = tvm.hash(b.toCell()) *)
let publicKey := tvm_hash ( toCell b' ) in
            (* ok = ok || tvm.pubkey() == publicKey; *)
let ok' := ( ok || ( ( eval_state ( tvm_pubkey ) l ) =? publicKey ) )%bool in

(*second time, i = 1*)
            (* TvmBuilder b;
               b.store(address(msg.sender), i); *)
let b'' := default in
let b''' := builder_store b'' ( eval_state ( msg_sender ) l ) 1 in
            (* uint256 publicKey = tvm.hash(b.toCell()) *)
let publicKey' := tvm_hash ( toCell b''' )  in
            (* ok = ok || tvm.pubkey() == publicKey; *)
let ok'' := ( ok' || ( ( eval_state ( tvm_pubkey ) l ) =? publicKey' ) )%bool in
            (* require(ok, ERROR_IS_NOT_DEPOOL); *)
let req : bool := ( ok'' ) in

    eval_state (↓ DePoolProxyContract_Ф_constructor5 ) l =
    if req then Value I
           else Error (eval_state ( ↑10 ε DePoolProxyContract_ι_ERROR_IS_NOT_DEPOOL ) l ).
Proof.
  intros.
  destruct l.  (* destruct Ledger_ι_VMState. *)
  compute. destructIf; auto.
Qed.

(*
 (* function process_new_stake(
        uint64 queryId,
        uint256 validatorKey,
        uint32 stakeAt,
        uint32 maxFactor,
        uint256 adnlAddr,
        bytes signature,
        address elector
    ) external override  {
        require(msg.sender == m_dePool, ERROR_IS_NOT_DEPOOL);
        uint carry = msg.value - DePoolLib.PROXY_FEE;
        require(address(this).balance >= carry + DePoolLib.MIN_PROXY_BALANCE, ERROR_BAD_BALANCE);
        IElector(elector).process_new_stake{value: msg.value - DePoolLib.PROXY_FEE}(
            queryId, validatorKey, stakeAt, maxFactor, adnlAddr, signature
        );
    } *)
Definition DePoolProxyContract_Ф_process_new_stake  ( Л_queryId : XInteger64 )
                                                    ( Л_validatorKey : XInteger256 )
                                                    ( Л_stakeAt : XInteger32 )
                                                    ( Л_maxFactor : XInteger32 )
                                                    ( Л_adnlAddr : XInteger256 )
                                                    ( Л_signature : XList XInteger8 )
                                                    ( Л_elector : XAddress )
                                                : LedgerT ( XErrorValue True XInteger ) :=
 Require2 {{ msg_sender () ?== ↑ε10 DePoolProxyContract_ι_m_dePool , ↑ε10 DePoolProxyContract_ι_ERROR_IS_NOT_DEPOOL }} ;
 U0! Л_carry :=  msg_value () !- ↑ε9 DePoolLib_ι_PROXY_FEE ;
 Require {{ tvm_balance () ?>=  $Л_carry !+ (↑ε9 DePoolLib_ι_MIN_PROXY_BALANCE) , ↑ε10 DePoolProxyContract_ι_ERROR_BAD_BALANCE }} ;
 sendMessage {| contractAddress := Л_elector;
				contractFunction := IElector_И_process_new_stakeF Л_queryId Л_validatorKey Л_stakeAt Л_maxFactor Л_adnlAddr  Л_signature;
				contractMessage := {$ default with  messageValue := Л_carry $} |}*)
Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

Lemma DePoolProxyContract_Ф_process_new_stake_exec : forall ( Л_queryId : XInteger64 )
                                                             ( Л_validatorKey : XInteger256 )
                                                             ( Л_stakeAt : XInteger32 )
                                                             ( Л_maxFactor : XInteger32 )
                                                             ( Л_adnlAddr : XInteger256 )
                                                             ( Л_signature :  XList XInteger8 )
                                                             ( Л_elector : XAddress )
                                                             (l: Ledger) ,
    exec_state ( ↓ DePoolProxyContract_Ф_process_new_stake Л_queryId Л_validatorKey Л_stakeAt Л_maxFactor Л_adnlAddr Л_signature Л_elector ) l =

   let msgSender := eval_state msg_sender l in
   let dePoolAddress := eval_state (↑10 ε DePoolProxyContract_ι_m_dePool) l in
   let msgValue := eval_state msg_value l in
   let proxyFee := eval_state (↑9 ε DePoolLib_ι_PROXY_FEE) l in
   let carry := msgValue - proxyFee in
   let oldMessages := eval_state (↑16 ε VMState_ι_messages) l in
   let newMessage :ContractsFunctionWithMessage  := {| contractAddress :=  Л_elector;
                         contractFunction := IElector_И_process_new_stakeF Л_queryId Л_validatorKey Л_stakeAt Л_maxFactor Л_adnlAddr  Л_signature ;
                         contractMessage :=  {| messageValue := carry;
                                               messageFlag := 0 ;
                                               messageBounce := false |} |} in
    let balance := eval_state ( tvm_balance ) l in
    let minBalance := eval_state ( ↑9 ε DePoolLib_ι_MIN_PROXY_BALANCE ) l in
    let req2 : bool := balance >=? carry + minBalance in
    if ( msgSender =? dePoolAddress) then
      if req2 then
          {$ l With VMState_ι_messages := newMessage :: oldMessages $}
      else l
    else l.
 Proof.
   intros.
   destruct l. destruct Ledger_ι_VMState , Ledger_ι_DePoolProxyContract, Ledger_ι_DePoolLib.
   compute.
   repeat destructIf; auto.
 Qed.

Lemma DePoolProxyContract_Ф_process_new_stake_eval : forall ( Л_queryId : XInteger64 )
                                                             ( Л_validatorKey : XInteger256 )
                                                             ( Л_stakeAt : XInteger32 )
                                                             ( Л_maxFactor : XInteger32 )
                                                             ( Л_adnlAddr : XInteger256 )
                                                             ( Л_signature : XList XInteger8 )
                                                             ( Л_elector : XAddress )
                                                             (l: Ledger) ,
    let msgSender := eval_state msg_sender l in
    let dePoolAddress := eval_state (↑10 D2! DePoolProxyContract_ι_m_dePool) l in
    let error1 := eval_state (↑10 D2! DePoolProxyContract_ι_ERROR_IS_NOT_DEPOOL) l in
    let error2 := eval_state (↑10 D2! DePoolProxyContract_ι_ERROR_BAD_BALANCE) l in
   let msgValue := eval_state msg_value l in
   let proxyFee := eval_state (↑9 ε DePoolLib_ι_PROXY_FEE) l in
   let carry := msgValue - proxyFee in
    let balance := eval_state ( tvm_balance ) l in
    let minBalance := eval_state ( ↑9 ε DePoolLib_ι_MIN_PROXY_BALANCE ) l in
    let req2 : bool := balance >=? carry + minBalance in

    eval_state (DePoolProxyContract_Ф_process_new_stake Л_queryId Л_validatorKey Л_stakeAt Л_maxFactor Л_adnlAddr Л_signature Л_elector ) l =
    if (msgSender =? dePoolAddress)
    then if req2 then Value I
                 else Error error2
    else Error error1 .
 Proof.
  intros.
   destruct l. destruct Ledger_ι_VMState , Ledger_ι_DePoolProxyContract, Ledger_ι_DePoolLib.
   compute.
   repeat destructIf; auto.
 Qed.

 (* (* function onStakeAccept ( uint64 queryId , uint32 comment )
 	 	 public functionID ( 0xF374484C ) { IDePool ( m_dePool ) . onStakeAccept
 	 	 { value : msg_value - DePoolLib . PROXY_FEE } ( queryId , comment
       , msg_sender ) ; } *)

Definition DePoolProxyContract_Ф_onStakeAccept ( Л_queryId : XInteger64 )( Л_comment : XInteger32 ) : LedgerT True :=
	U0! Л_dePool := ↑ε10 DePoolProxyContract_ι_m_dePool ;
	U0! Л_value := msg_value () !- ↑ε9 DePoolLib_ι_PROXY_FEE ;
	U0! Л_sender := msg_sender ()  ;
    sendMessage {| contractAddress := Л_dePool;
				   contractFunction := DePoolContract_Ф_onStakeAcceptF Л_queryId Л_comment Л_sender ;
           contractMessage := {$ default with  messageValue := Л_value $} |} .
           *)
 Lemma DePoolProxyContract_Ф_onStakeAccept_exec : forall ( Л_queryId : XInteger64 ) ( Л_comment : XInteger32 ) (l: Ledger) ,
 let dePoolAddress := eval_state (↑10 D2! DePoolProxyContract_ι_m_dePool) l in
 let msgValue := eval_state msg_value l in
 let proxyFee := eval_state (↑9 D2! DePoolLib_ι_PROXY_FEE) l in
 let value := msgValue - proxyFee in
 let msgSender := eval_state msg_sender l in
 let oldMessages := eval_state (↑16 D2! VMState_ι_messages) l in
 let newMessage  := {| contractAddress  := dePoolAddress;
                       contractFunction := DePoolContract_Ф_onStakeAcceptF Л_queryId Л_comment msgSender ;
                       contractMessage  := {$ default with messageValue := value $} |} in

    exec_state (DePoolProxyContract_Ф_onStakeAccept Л_queryId Л_comment ) l =
    {$ l With VMState_ι_messages := newMessage :: oldMessages $}.
 Proof.
   intros. auto.
 Qed.

 Lemma DePoolProxyContract_Ф_onStakeAccept_eval : forall ( Л_queryId : XInteger64 ) ( Л_comment : XInteger32 ) (l: Ledger) ,
 	 eval_state (DePoolProxyContract_Ф_onStakeAccept Л_queryId Л_comment ) l = I .
 Proof.
   intros. auto.
 Qed.

 (* (* function onStakeReject ( uint64 queryId , uint32 comment )
 	 	 public functionID ( 0xEE6F454C ) { IDePool ( m_dePool ) . onStakeReject
 	 	 { value : msg_value - DePoolLib . PROXY_FEE } ( queryId , comment
       , msg_sender ) ; } *)

Definition DePoolProxyContract_Ф_onStakeReject ( Л_queryId : XInteger64 )( Л_comment : XInteger32 ) : LedgerT True :=
	U0! Л_dePool := ↑ε10 DePoolProxyContract_ι_m_dePool ;
	U0! Л_value := msg_value () !- ↑ε9 DePoolLib_ι_PROXY_FEE ;
	U0! Л_sender := msg_sender ()  ;
    sendMessage {| contractAddress := Л_dePool;
				   contractFunction := DePoolContract_Ф_onStakeRejectF Л_queryId Л_comment Л_sender ;
           contractMessage := {$ default with  messageValue := Л_value $} |} .
           *)
 Lemma DePoolProxyContract_Ф_onStakeReject_exec : forall ( Л_queryId : XInteger64 ) ( Л_comment : XInteger32 ) (l: Ledger) ,
 let dePoolAddress := eval_state (↑10 D2! DePoolProxyContract_ι_m_dePool) l in
 let msgValue := eval_state msg_value l in
 let proxyFee := eval_state (↑9 D2! DePoolLib_ι_PROXY_FEE) l in
 let value := msgValue - proxyFee in
 let msgSender := eval_state msg_sender l in
 let oldMessages := eval_state (↑16 D2! VMState_ι_messages) l in
 let newMessage  := {| contractAddress  := dePoolAddress;
                       contractFunction := DePoolContract_Ф_onStakeRejectF Л_queryId Л_comment msgSender ;
                       contractMessage  := {$ default with messageValue := value $} |} in

    exec_state (  DePoolProxyContract_Ф_onStakeReject Л_queryId Л_comment ) l =
    {$ l With VMState_ι_messages := newMessage :: oldMessages $}.
 Proof.
   intros. auto.
 Qed.

 Lemma DePoolProxyContract_Ф_onStakeReject_eval : forall ( Л_queryId : XInteger64 )
                                                         ( Л_comment : XInteger32 )
                                                         (l: Ledger) ,
 	 eval_state (  DePoolProxyContract_Ф_onStakeReject Л_queryId Л_comment ) l = I .
 Proof.
   intros. auto.
 Qed.

 (* function recover_stake(uint64 queryId, address elector) public override {
        require(msg.sender == m_dePool, ERROR_IS_NOT_DEPOOL);
        uint carry = msg.value - DePoolLib.PROXY_FEE;
        require(address(this).balance >= carry + DePoolLib.MIN_PROXY_BALANCE, ERROR_BAD_BALANCE);
        IElector(elector).recover_stake{value: msg.value - DePoolLib.PROXY_FEE}(queryId);
    } *)
(*
Definition DePoolProxyContract_Ф_recover_stake  ( Л_queryId : XInteger64 )
                                                ( Л_elector : XAddress )
                                           : LedgerT ( XErrorValue True XInteger ) :=
 Require2 {{ msg_sender () ?== ↑ε10 DePoolProxyContract_ι_m_dePool , ↑ε10 DePoolProxyContract_ι_ERROR_IS_NOT_DEPOOL }} ;
 U0! Л_carry := msg_value () !- ↑ε9 DePoolLib_ι_PROXY_FEE ;
 Require {{ tvm_balance () ?>=  $Л_carry !+ (↑ε9 DePoolLib_ι_MIN_PROXY_BALANCE) , ↑ε10 DePoolProxyContract_ι_ERROR_BAD_BALANCE }} ;
 sendMessage {| contractAddress := Л_elector;
				contractFunction := IElector_И_recover_stakeF Л_queryId ;
				contractMessage := {$ default with  messageValue := Л_carry $} |} . *)

 Lemma DePoolProxyContract_Ф_recover_stake_exec : forall ( Л_queryId : XInteger64 ) ( Л_elector : XAddress ) (l: Ledger) ,
 let dePoolAddress := eval_state (↑10 ε DePoolProxyContract_ι_m_dePool) l in
 let msgValue := eval_state msg_value l in
 let proxyFee := eval_state (↑9 ε DePoolLib_ι_PROXY_FEE) l in
 let value := msgValue - proxyFee in
 let msgSender := eval_state msg_sender l in
 let oldMessages := eval_state (↑16 ε VMState_ι_messages) l in
 let newMessage  := {| contractAddress  := Л_elector;
                       contractFunction := IElector_И_recover_stakeF Л_queryId ;
                       contractMessage  := {$ default with messageValue := value $} |} in
   let carry := msgValue - proxyFee in
   let balance := eval_state ( tvm_balance ) l in
   let minBalance := eval_state ( ↑9 ε DePoolLib_ι_MIN_PROXY_BALANCE ) l in
   let req2 : bool := balance >=? carry + minBalance in

exec_state ( ↓ DePoolProxyContract_Ф_recover_stake Л_queryId Л_elector ) l =
    if (msgSender =? dePoolAddress)
    then if req2
         then {$ l With VMState_ι_messages := newMessage :: oldMessages $}
         else l
    else l.
 Proof.
  intros.
  destruct l.
  compute; repeat destructIf; auto.
 Qed.

 Lemma DePoolProxyContract_Ф_recover_stake_eval : forall ( Л_queryId : XInteger64 ) ( Л_elector : XAddress ) (l: Ledger) ,
 let msgSender := eval_state msg_sender l in
 let dePoolAddress := eval_state (↑10 D2! DePoolProxyContract_ι_m_dePool) l in
 let error1 := eval_state (↑10 ε DePoolProxyContract_ι_ERROR_IS_NOT_DEPOOL) l in
 let error2 := eval_state (↑10 ε DePoolProxyContract_ι_ERROR_BAD_BALANCE) l in
   let proxyFee := eval_state (↑9 ε DePoolLib_ι_PROXY_FEE) l in
   let msgValue := eval_state msg_value l in
   let carry := msgValue - proxyFee in
   let balance := eval_state ( tvm_balance ) l in
   let minBalance := eval_state ( ↑9 ε DePoolLib_ι_MIN_PROXY_BALANCE ) l in
   let req2 : bool := balance >=? carry + minBalance in

    eval_state (DePoolProxyContract_Ф_recover_stake Л_queryId Л_elector ) l =
    if (msgSender =? dePoolAddress) then
       if req2 then xValue I
               else xError error2
    else xError error1 .
 Proof.
  intros.
  destruct l.
  compute; repeat destructIf; auto.
 Qed.

 (* (* function onSuccessToRecoverStake ( uint64 queryId ) public
 	 	 functionID ( 0xF96F7324 ) { IDePool ( m_dePool ) . onSuccessToRecoverStake
 	 	 { value : msg_value - DePoolLib . PROXY_FEE } ( queryId , msg_sender
       ) ; } *)

Definition DePoolProxyContract_Ф_onSuccessToRecoverStake ( Л_queryId : XInteger64 ) : LedgerT True :=
	U0! Л_dePool := ↑ε10 DePoolProxyContract_ι_m_dePool ;
	U0! Л_value := msg_value () !- ↑ε9 DePoolLib_ι_PROXY_FEE ;
	U0! Л_sender := msg_sender ()  ;
	sendMessage {| contractAddress := Л_dePool;
				   contractFunction := DePoolContract_Ф_onSuccessToRecoverStakeF Л_queryId Л_sender ;
           contractMessage := {$ default with  messageValue := Л_value $} |} .
            *)

 Lemma DePoolProxyContract_Ф_onSuccessToRecoverStake_exec : forall ( Л_queryId : XInteger64 ) (l: Ledger) ,
 let dePoolAddress := eval_state (↑10 D2! DePoolProxyContract_ι_m_dePool) l in
 let msgValue := eval_state msg_value l in
 let proxyFee := eval_state (↑9 D2! DePoolLib_ι_PROXY_FEE) l in
 let value := msgValue - proxyFee in
 let msgSender := eval_state msg_sender l in
 let oldMessages := eval_state (↑16 D2! VMState_ι_messages) l in
 let newMessage  := {| contractAddress  := dePoolAddress;
                       contractFunction := DePoolContract_Ф_onSuccessToRecoverStakeF Л_queryId msgSender ;
                       contractMessage  := {$ default with messageValue := value $} |} in
    exec_state (DePoolProxyContract_Ф_onSuccessToRecoverStake Л_queryId) l =
               {$ l With VMState_ι_messages := newMessage :: oldMessages $}.
 Proof.
  intros.  auto.
 Qed.

 Lemma DePoolProxyContract_Ф_onSuccessToRecoverStake_eval : forall ( Л_queryId : XInteger64 ) (l: Ledger) ,
 	 eval_state (DePoolProxyContract_Ф_onSuccessToRecoverStake Л_queryId ) l = I .
 Proof.
   intros. auto.
 Qed.

 (*
      function getProxyInfo() public view returns (address depool, uint64 minBalance) {
        depool = m_dePool;
        minBalance = DePoolLib.MIN_PROXY_BALANCE;
    }
Definition DePoolProxyContract_Ф_getProxyInfo : LedgerT ( XAddress # XInteger64 ) :=
 U0! Л_depool := ↑ε10 DePoolProxyContract_ι_m_dePool ;
 U0! Л_minBalance := ↑ε9 DePoolLib_ι_MIN_PROXY_BALANCE ;
	 return# ($ Л_depool, $ Л_minBalance) .
 *)

 Lemma DePoolProxyContract_Ф_getProxyInfo_exec : forall (l: Ledger) ,
 	 exec_state ( ↓ DePoolProxyContract_Ф_getProxyInfo ) l = l .
 Proof.
    intros. destruct l; compute; auto.
 Qed.

 Lemma DePoolProxyContract_Ф_getProxyInfo_eval : forall (l: Ledger) ,
                           (*  LedgerT ( XAddress # XInteger64 ) *)
    let dePool := eval_state (↑10 ε DePoolProxyContract_ι_m_dePool) l in
    let minBalance := eval_state (↑9 ε DePoolLib_ι_MIN_PROXY_BALANCE) l in
    eval_state ( ↓ DePoolProxyContract_Ф_getProxyInfo ) l = (dePool, minBalance).
 Proof.
   intros. destruct l ; compute ; auto.
 Qed.