Require Import RelationClasses.
Require Import Bool.
Require Import List.

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

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

Require Import Event.
From PromisingLib Require Import DenseOrder.
Require Import Time.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import MemoryFacts.
Require Import MemoryDomain.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import MemorySplit.
Require Import MemoryMerge.
Require Import Cover.
Require Import SimMemory.

Set Implicit Arguments.

Module SimPromises.
  Include MemoryDomain.

  Definition none_if_released loc ts (pview:t) (released:option View.t): option View.t :=
    if mem loc ts pview
    then None
    else released.

  Definition none_if loc ts (pview:t) (msg:Message.t): Message.t :=
    match msg with
    | Message.full val released =>
      Message.full val (none_if_released loc ts pview released)
    | Message.reserve => Message.reserve
    end.

  Lemma none_if_bot loc ts msg:
    none_if loc ts bot msg = msg.
  Proof.
    destruct msg; ss.
  Qed.

  Ltac none_if_tac :=
    repeat
      (try match goal with
           | [ |- context[none_if _ _ _ (Message.full ?val ?released)]] =>
             unfold none_if; ss
           | [ |- context[none_if _ _ _ ?msg]] =>
             unfold none_if; destruct msg; ss
           | [ |- context[none_if_released _ _ ?msg]] =>
             unfold none_if_released; condtac; ss
           end).

  Definition mem_le_transf (pview:t) (lhs rhs:Memory.t): Prop :=
    forall loc to from msg
      (LHS: Memory.get loc to lhs = Some (from, msg)),
      Memory.get loc to rhs = Some (from, none_if loc to pview msg).

  Definition kind_transf loc ts (pview:t) (kind:Memory.op_kind): Memory.op_kind :=
    match kind with
    | Memory.op_kind_add => Memory.op_kind_add
    | Memory.op_kind_split ts msg => Memory.op_kind_split ts (none_if loc ts pview msg)
    | Memory.op_kind_lower msg => Memory.op_kind_lower (none_if loc ts pview msg)
    | Memory.op_kind_cancel => Memory.op_kind_cancel
    end.

  Lemma kind_transf_bot loc ts kind:
    kind_transf loc ts bot kind = kind.
  Proof.
    destruct kind; ss; rewrite none_if_bot; ss.
  Qed.

  Inductive sem (pview:t) (inv:t) (promises_src promises_tgt:Memory.t): Prop :=
  | sem_intro
      (LE: mem_le_transf pview promises_tgt promises_src)
      (PVIEW: forall l t (MEM: mem l t pview), exists f val released, Memory.get l t promises_tgt = Some (f, Message.full val released))
      (SOUND: forall l t (INV: mem l t inv),
          Memory.get l t promises_tgt = None /\
          exists f m, Memory.get l t promises_src = Some (f, m))
      (COMPLETE: forall l t f m
                   (SRC: Memory.get l t promises_src = Some (f, m))
                   (TGT: Memory.get l t promises_tgt = None),
          mem l t inv)
  .

  Lemma promise
        pview inv
        loc from to msg
        promises1_src mem1_src
        promises1_tgt mem1_tgt promises2_tgt mem2_tgt
        kind_tgt
        (PROMISE_TGT: Memory.promise promises1_tgt mem1_tgt loc from to msg promises2_tgt mem2_tgt kind_tgt)
        (INV1: sem pview inv promises1_src promises1_tgt)
        (SIM1: sim_memory mem1_src mem1_tgt)
        (LE1_SRC: Memory.le promises1_src mem1_src)
        (LE1_TGT: Memory.le promises1_tgt mem1_tgt)
        (MEM1_SRC: Memory.closed mem1_src)
        (MEM1_TGT: Memory.closed mem1_tgt):
    exists promises2_src mem2_src,
      <<PROMISE_SRC: Memory.promise promises1_src mem1_src loc from to (none_if loc to pview msg) promises2_src mem2_src (kind_transf loc to pview kind_tgt)>> /\
      <<INV2: sem pview inv promises2_src promises2_tgt>> /\
      <<SIM2: sim_memory mem2_src mem2_tgt>>.
  Proof.
    inv PROMISE_TGT.
    - exploit (@Memory.add_exists mem1_src loc from to msg);
        try by inv MEM; inv ADD.
      { eapply covered_disjoint.
        - apply SIM1.
        - inv MEM. inv ADD. auto. }
      i. des.
      exploit Memory.add_exists_le; try apply LE1_SRC; eauto. i. des.
      exploit sim_memory_add; try apply SIM1; try refl; eauto. i.
      esplits; eauto.
      + none_if_tac.
        * inv INV1. exploit PVIEW; eauto. intro x. des.
          hexploit Memory.add_get0; try exact PROMISES; eauto. i. des. congr.
        * econs 1; eauto; try congr.
          i. exploit sim_memory_get_inv; try exact GET; eauto.
          { apply MEM1_SRC. }
          { apply MEM1_TGT. }
          i. des. inv FROM; cycle 1.
          { inv H. eauto. }
          exploit Memory.add_get0; try exact MEM. i. des.
          exploit Memory.add_get1; try exact GET_TGT; eauto. i.
          exploit Memory.get_ts; try exact GET1. i. des.
          { subst. inv H. }
          exploit Memory.get_ts; try exact x3. i. des.
          { subst. inv TO; inv H0.
            exploit Memory.get_ts; try exact GET. i. des; timetac. inv x5. }
          exploit Memory.get_disjoint; [exact GET1|exact x3|..]. i. des.
          { subst. congr. }
          apply (x6 to); econs; ss; try refl.
          exploit Memory.get_ts; try exact GET. i. des.
          { subst. eauto. }
          { etrans; eauto. econs. ss. }
        * econs 1; eauto; ss.
          i. exploit RESERVE; eauto. i. des.
          inv SIM1. exploit MSG; eauto. i. des. inv MSG0. eauto.
      + econs.
        * ii. erewrite Memory.add_o; eauto.
          erewrite (@Memory.add_o promises2_tgt) in LHS; try exact PROMISES. revert LHS.
          condtac; ss.
          { i. des. inv LHS. none_if_tac.
            inv INV1. exploit PVIEW; eauto. i. des.
            exploit Memory.add_get0; try exact PROMISES; eauto. i. des. congr. }
          { apply INV1. }
        * i. inv INV1. exploit PVIEW; eauto. i. des.
          erewrite Memory.add_o; eauto. condtac; eauto.
          ss. des. subst. exploit LE; eauto. intro x.
          inv x1. inv ADD. exfalso.
          eapply DISJOINT; eauto; econs; eauto; try refl. ss.
          exploit Memory.get_ts; try eapply x. i. des; ss.
          subst. inv TO.
        * i. inv INV1. exploit SOUND; eauto. i.
          erewrite Memory.add_o; eauto. erewrite (@Memory.add_o promises2); eauto.
          condtac; ss. des. subst.
          exploit Memory.add_get0; eauto. i. des. congr.
        * i. revert SRC TGT.
          erewrite Memory.add_o; eauto. erewrite (@Memory.add_o promises2_tgt); eauto.
          condtac; ss. inv INV1. eapply COMPLETE; eauto.
    - exploit Memory.split_get0; try exact PROMISES; eauto. i. des.
      exploit (@Memory.split_exists promises1_src loc from to ts3 msg (none_if loc ts3 pview msg3));
        try by inv PROMISES; inv SPLIT.
      { apply INV1. eauto. }
      i. des.
      exploit Memory.split_exists_le; try apply LE1_SRC; eauto. i. des.
      exploit sim_memory_split; try apply SIM1; try refl; eauto. i.
      esplits; eauto.
      + unfold none_if. destruct msg; ss.
        unfold none_if_released. condtac; ss.
        * inv INV1. exploit PVIEW; eauto. intro x. des.
          hexploit Memory.split_get0; try exact PROMISES; eauto. congr.
        * econs 2; eauto; congr.
      + econs.
        * ii. revert LHS.
          erewrite Memory.split_o; eauto. erewrite (@Memory.split_o mem2); try exact x0.
          repeat condtac; ss.
          { i. des. inv LHS. none_if_tac.
            inv INV1. exploit PVIEW; eauto. i. des.
            exploit Memory.split_get0; try exact PROMISES; eauto. congr. }
          { guardH o. i. des. inv LHS. ss. }
          { apply INV1. }
        * i. inv INV1. exploit PVIEW; eauto. intro x. des.
          erewrite Memory.split_o; eauto. repeat condtac; eauto.
          des; ss. subst. rewrite GET0 in x. inv x. eauto.
        * i. inv INV1. exploit SOUND; eauto. i.
          erewrite Memory.split_o; eauto. erewrite (@Memory.split_o mem2); eauto.
          exploit Memory.split_get0; try exact x0; eauto. i. des.
          repeat condtac; ss.
          { des. subst. congr. }
          { guardH o. des. subst. congr. }
          esplits; eauto.
        * i. revert SRC TGT.
          erewrite Memory.split_o; eauto. erewrite (@Memory.split_o promises2_tgt); eauto.
          repeat condtac; ss. inv INV1. eapply COMPLETE; eauto.
    - exploit Memory.lower_get0; try exact PROMISES; eauto. i. des.
      exploit (@Memory.lower_exists promises1_src loc from to (none_if loc to pview msg0) (none_if loc to pview msg));
        try by inv MEM; inv LOWER.
      { apply INV1. eauto. }
      { none_if_tac; econs; ss.
        inv MEM. inv LOWER. inv MSG_WF. ss. }
      { none_if_tac; destruct msg0; ss.
        - inv MEM. inv LOWER. inv MSG_LE. econs. refl.
        - inv PROMISES. inv MSG_LE. }
      i. des.
      exploit Memory.lower_exists_le; try apply LE1_SRC; eauto. i. des.
      exploit sim_memory_lower; try exact SIM1; try exact x1; try exact x2; eauto.
      { none_if_tac; try refl. econs. econs. }
      i. esplits; eauto.
      + econs 3; eauto.
        * none_if_tac; viewtac. econs. viewtac.
        * subst. ss. esplits; eauto.
      + econs.
        * ii. revert LHS.
          erewrite Memory.lower_o; eauto. erewrite (@Memory.lower_o mem2); try exact x0.
          condtac; ss.
          { i. des. inv LHS. ss. }
          { apply INV1. }
        * i. inv INV1. exploit PVIEW; eauto. intro x. des.
          erewrite Memory.lower_o; eauto. condtac; eauto.
          des. ss. subst. rewrite GET in x. inv x.
          inv MSG_LE. esplits; eauto.
        * i. inv INV1. exploit SOUND; eauto. i.
          erewrite Memory.lower_o; eauto. erewrite (@Memory.lower_o mem2); eauto.
          exploit Memory.lower_get0; try exact x1; eauto. i. des.
          condtac; ss.
          { des. subst. congr. }
          esplits; eauto.
        * i. revert SRC TGT.
          erewrite Memory.lower_o; eauto. erewrite (@Memory.lower_o promises2_tgt); eauto.
          repeat condtac; ss. inv INV1. eapply COMPLETE; eauto.
    - exploit Memory.remove_get0; try exact PROMISES. i. des.
      exploit (@Memory.remove_exists promises1_src loc from to Message.reserve).
      { inv INV1. exploit LE; eauto. }
      i. des.
      exploit (@Memory.remove_exists mem1_src loc from to Message.reserve).
      { inv INV1. exploit LE; eauto. }
      i. des.
      exploit sim_memory_remove; try exact SIM1; eauto. i.
      esplits; try exact x2; eauto.
      inv INV1. econs; ii.
      + erewrite Memory.remove_o in LHS; eauto.
        erewrite Memory.remove_o; eauto.
        condtac; ss. eauto.
      + exploit PVIEW; eauto. i. des.
        erewrite Memory.remove_o; eauto. condtac; ss; eauto.
        des. subst. congr.
      + exploit SOUND; eauto. i. des. split.
        * erewrite Memory.remove_o; eauto. condtac; ss; eauto.
        * erewrite Memory.remove_o; eauto. condtac; ss; eauto.
          des. subst. congr.
      + erewrite Memory.remove_o in SRC; eauto.
        erewrite Memory.remove_o in TGT; eauto.
        des_ifs. eauto.
  Qed.

  Lemma promise_bot
        inv
        loc from to msg
        promises1_src mem1_src
        promises1_tgt mem1_tgt promises2_tgt mem2_tgt
        kind
        (PROMISE_TGT: Memory.promise promises1_tgt mem1_tgt loc from to msg promises2_tgt mem2_tgt kind)
        (INV1: sem bot inv promises1_src promises1_tgt)
        (SIM1: sim_memory mem1_src mem1_tgt)
        (LE1_SRC: Memory.le promises1_src mem1_src)
        (LE1_TGT: Memory.le promises1_tgt mem1_tgt)
        (MEM1_SRC: Memory.closed mem1_src)
        (MEM1_TGT: Memory.closed mem1_tgt):
    exists promises2_src mem2_src,
      <<PROMISE_SRC: Memory.promise promises1_src mem1_src loc from to msg promises2_src mem2_src kind>> /\
      <<INV2: sem bot inv promises2_src promises2_tgt>> /\
      <<SIM2: sim_memory mem2_src mem2_tgt>>.
  Proof.
    exploit promise; eauto. i. des.
    rewrite none_if_bot in *.
    rewrite kind_transf_bot in *.
    esplits; eauto.
  Qed.

  Lemma remove_tgt
        pview inv
        loc from to msg
        promises1_src mem1_src
        promises1_tgt mem1_tgt promises2_tgt
        (REMOVE_TGT: Memory.remove promises1_tgt loc from to msg promises2_tgt)
        (INV1: sem pview inv promises1_src promises1_tgt)
        (SIM1: sim_memory mem1_src mem1_tgt)
        (LE1_SRC: Memory.le promises1_src mem1_src)
        (LE1_TGT: Memory.le promises1_tgt mem1_tgt)
        (FINITE1_TGT: Memory.finite promises1_tgt):
      <<INV2: sem (unset loc to pview) (set loc to inv) promises1_src promises2_tgt>> /\
      <<INV2': mem loc to inv = false>>.
  Proof.
    hexploit Memory.remove_future; eauto. i. des.
    exploit Memory.remove_get0; [eauto|]. i. des.
    inv INV1. exploit LE0; eauto. i.
    esplits.
    - econs.
      + ii. revert LHS.
        erewrite Memory.remove_o; eauto. condtac; ss. i.
        exploit LE0; eauto.
        unfold none_if, none_if_released. repeat condtac; ss.
        * revert COND1. rewrite unset_o. condtac; ss; [|congr].
          guardH o. des. subst. unguardH o. des; congr.
        * revert COND1. rewrite unset_o. condtac; ss. congr.
      + i. revert MEM. rewrite unset_o. condtac; ss. guardH o. i.
        exploit PVIEW; eauto. i. des.
        erewrite Memory.remove_o; eauto. condtac; ss; eauto.
        des. subst. unguardH o. des; congr.
      + i. erewrite Memory.remove_o; eauto.
        revert INV. rewrite set_o.
        unfold Time.t, DOSet.elt. condtac; ss; i.
        * des. subst. esplits; eauto.
        * exploit SOUND; eauto.
      + i. revert TGT.
        erewrite Memory.remove_o; eauto. rewrite set_o.
        unfold Time.t, DOSet.elt. condtac; ss; i.
        eapply COMPLETE; eauto.
    - destruct (mem loc to inv) eqn:X; auto.
      exploit SOUND; [eauto|]. i. des. congr.
  Qed.

  Lemma remove_src
        pview inv
        loc from to msg
        promises1_src mem1_src
        promises1_tgt mem1_tgt
        (INV1: sem pview inv promises1_src promises1_tgt)
        (INV1': mem loc to inv)
        (SIM1: sim_memory mem1_src mem1_tgt)
        (GET: Memory.get loc to promises1_src = Some (from, msg))
        (LE1_SRC: Memory.le promises1_src mem1_src)
        (LE1_TGT: Memory.le promises1_tgt mem1_tgt):
    exists promises2_src,
      <<REMOVE_SRC: Memory.remove promises1_src loc from to msg promises2_src>> /\
      <<INV2: sem pview (unset loc to inv) promises2_src promises1_tgt>>.
  Proof.
    inv INV1.
    exploit Memory.remove_exists; eauto. i. des.
    esplits; eauto.
    econs.
    - ii. revert LHS.
      erewrite (@Memory.remove_o mem2); eauto. condtac; ss; eauto.
      des. subst. exploit SOUND; eauto. i. des. congr.
    - i. exploit PVIEW; eauto.
    - i. rewrite unset_o in INV. revert INV. condtac; ss.
      guardH o.
      i. exploit SOUND; eauto. i. des. splits; eauto.
      erewrite Memory.remove_o; eauto. condtac; ss; eauto.
      des. subst. unguardH o. des; congr.
    - i. revert SRC.
      erewrite Memory.remove_o; eauto. rewrite unset_o.
      unfold Time.t, DOSet.elt. condtac; ss; i.
      eapply COMPLETE; eauto.
  Qed.

  Lemma remove
        pview inv
        loc from to msg
        promises1_src mem1_src
        promises1_tgt mem1_tgt promises2_tgt
        (MSG_WF: Message.wf msg)
        (TIME: Time.lt from to)
        (REMOVE_TGT: Memory.remove promises1_tgt loc from to msg promises2_tgt)
        (INV1: sem pview inv promises1_src promises1_tgt)
        (SIM1: sim_memory mem1_src mem1_tgt)
        (LE1_SRC: Memory.le promises1_src mem1_src)
        (LE1_TGT: Memory.le promises1_tgt mem1_tgt)
        (FINITE1_TGT: Memory.finite promises1_tgt):
    exists promises2_src,
      <<REMOVE_SRC: Memory.remove promises1_src loc from to (none_if loc to pview msg) promises2_src>> /\
      <<INV2: sem (unset loc to pview) inv promises2_src promises2_tgt>>.
  Proof.
    hexploit Memory.remove_future; try apply REMOVE_TGT; eauto. i. des.
    exploit remove_tgt; eauto. i. des.
    exploit Memory.remove_get0; eauto. i. des.
    inv INV1. exploit LE0; eauto. i.
    exploit remove_src; try apply set_eq; eauto. i. des.
    esplits; eauto.
    rewrite unset_set in INV0; auto.
  Qed.

  Lemma remove_bot
        inv
        loc from to msg
        promises1_src mem1_src
        promises1_tgt mem1_tgt promises2_tgt
        (MSG_WF: Message.wf msg)
        (TIME: Time.lt from to)
        (REMOVE_TGT: Memory.remove promises1_tgt loc from to msg promises2_tgt)
        (INV1: sem bot inv promises1_src promises1_tgt)
        (SIM1: sim_memory mem1_src mem1_tgt)
        (LE1_SRC: Memory.le promises1_src mem1_src)
        (LE1_TGT: Memory.le promises1_tgt mem1_tgt)
        (FINITE1_TGT: Memory.finite promises1_tgt):
    exists promises2_src,
      <<REMOVE_SRC: Memory.remove promises1_src loc from to msg promises2_src>> /\
      <<INV2: sem bot inv promises2_src promises2_tgt>>.
  Proof.
    exploit remove; eauto. i. des.
    rewrite none_if_bot in *.
    esplits; eauto.
    replace bot with (unset loc to bot); ss. apply ext. i.
    rewrite unset_o. condtac; ss.
  Qed.

  Lemma sem_bot promises:
    sem bot bot promises promises.
  Proof.
    econs.
    - ii. rewrite none_if_bot. ss.
    - i. revert MEM. rewrite bot_spec. congr.
    - i. inv INV.
    - i. congr.
  Qed.

  Lemma sem_bot_inv
        promises_src promises_tgt
        (SEM: sem bot bot promises_src promises_tgt):
    promises_src = promises_tgt.
  Proof.
    apply Memory.ext. i.
    destruct (Memory.get loc ts promises_tgt) as [[? []]|] eqn:X.
    - inv SEM. exploit LE; eauto.
    - destruct (Memory.get loc ts promises_src) as [[? []]|] eqn:Y.
      + inv SEM. exploit LE; eauto. s. i. congr.
      + inv SEM. exploit LE; eauto. s. i. congr.
      + inv SEM. exploit LE; eauto. s. i. congr.
    - destruct (Memory.get loc ts promises_src) as [[? []]|] eqn:Y.
      + inv SEM. exploit COMPLETE; eauto. intro x. inv x.
      + inv SEM. exploit COMPLETE; eauto. intro x. inv x.
      + ss.
  Qed.

  Lemma latest_reserve
        pview
        promises_src mem_src
        promises_tgt mem_tgt
        loc
        (INV: sem pview bot promises_src promises_tgt)
        (MEM: sim_memory mem_src mem_tgt)
        (MEM_SRC: Memory.closed mem_src)
        (MEM_TGT: Memory.closed mem_tgt):
    Memory.latest_reserve loc promises_src mem_src <->
    Memory.latest_reserve loc promises_tgt mem_tgt.
  Proof.
    inv INV. unfold Memory.latest_reserve.
    split; i.
    - erewrite <- sim_memory_max_ts; eauto. des_ifs.
      + exploit LE; eauto. i. ss. congr.
      + exploit LE; eauto. i. ss. congr.
    - erewrite sim_memory_max_ts; eauto. des_ifs.
      + exploit LE; eauto. i. ss. congr.
      + exploit COMPLETE; eauto.
  Qed.

  Lemma cap_get_src
        pview
        promises_src mem1_src mem2_src
        promises_tgt mem1_tgt mem2_tgt
        loc from to msg
        (INV1: sem pview bot promises_src promises_tgt)
        (MEM1: sim_memory mem1_src mem1_tgt)
        (CAP_SRC: Memory.cap promises_src mem1_src mem2_src)
        (CAP_TGT: Memory.cap promises_tgt mem1_tgt mem2_tgt)
        (MEM1_SRC: Memory.closed mem1_src)
        (MEM1_TGT: Memory.closed mem1_tgt)
        (GET1_SRC: Memory.get loc to mem1_src = None)
        (GET2_SRC: Memory.get loc to mem2_src = Some (from, msg)):
    <<GET1_TGT: Memory.get loc to mem1_tgt = None>> /\
    <<GET2_TGT: Memory.get loc to mem2_tgt = Some (from, msg)>>.
  Proof.
    exploit Memory.cap_inv; try exact CAP_SRC; eauto. i. des; try congr.
    - subst.
      exploit sim_memory_adjacent_src; try exact x1; eauto. i. des.
      inv CAP_TGT. exploit MIDDLE; eauto. i. splits; auto.
      inv x3. apply EMPTY; eauto. refl.
    - subst.
      erewrite sim_memory_max_ts; eauto.
      rewrite latest_reserve in *; eauto.
      exploit sim_memory_latest_val_src; eauto. i.
      exploit Memory.max_full_view_exists; try apply MEM1_TGT. i. des.
      exploit sim_memory_max_full_view; try exact MEM1; eauto. i. subst.
      inv CAP_TGT. exploit BACK; eauto. i. splits; auto.
      destruct (Memory.get loc (Time.incr (Memory.max_ts loc mem1_tgt)) mem1_tgt) as [[]|] eqn:MAX; ss.
      exploit Memory.max_ts_spec; eauto. i. des.
      specialize (Time.incr_spec (Memory.max_ts loc mem1_tgt)). i. timetac.
  Qed.

  Lemma cap_get_tgt
        pview
        promises_src mem1_src mem2_src
        promises_tgt mem1_tgt mem2_tgt
        loc from to msg
        (INV1: sem pview bot promises_src promises_tgt)
        (MEM1: sim_memory mem1_src mem1_tgt)
        (CAP_SRC: Memory.cap promises_src mem1_src mem2_src)
        (CAP_TGT: Memory.cap promises_tgt mem1_tgt mem2_tgt)
        (MEM1_SRC: Memory.closed mem1_src)
        (MEM1_TGT: Memory.closed mem1_tgt)
        (GET1_TGT: Memory.get loc to mem1_tgt = None)
        (GET2_TGT: Memory.get loc to mem2_tgt = Some (from, msg)):
    <<GET1_SRC: Memory.get loc to mem1_src = None>> /\
    <<GET2_SRC: Memory.get loc to mem2_src = Some (from, msg)>>.
  Proof.
    exploit Memory.cap_inv; try exact CAP_TGT; eauto. i. des; try congr.
    - subst.
      exploit sim_memory_adjacent_tgt; try exact x1; eauto. i. des.
      inv CAP_SRC. exploit MIDDLE; eauto. i. splits; auto.
      inv x3. apply EMPTY; eauto. refl.
    - subst.
      erewrite <- sim_memory_max_ts; eauto.
      rewrite <- latest_reserve in *; eauto.
      exploit sim_memory_latest_val_tgt; eauto. i.
      exploit Memory.max_full_view_exists; try apply MEM1_SRC. i. des.
      exploit sim_memory_max_full_view; try exact MEM1; eauto. i. subst.
      inv CAP_SRC. exploit BACK; eauto. i. splits; auto.
      destruct (Memory.get loc (Time.incr (Memory.max_ts loc mem1_src)) mem1_src) as [[]|] eqn:MAX; ss.
      exploit Memory.max_ts_spec; eauto. i. des.
      specialize (Time.incr_spec (Memory.max_ts loc mem1_src)). i. timetac.
  Qed.

  Lemma cap
        pview
        lc_src mem1_src mem2_src
        lc_tgt mem1_tgt
        (INV1: sem pview bot (Local.promises lc_src) (Local.promises lc_tgt))
        (MEM1: sim_memory mem1_src mem1_tgt)
        (CAP_SRC: Memory.cap (Local.promises lc_src) mem1_src mem2_src)
        (MEM1_SRC: Memory.closed mem1_src)
        (MEM1_TGT: Memory.closed mem1_tgt):
    exists mem2_tgt,
      <<MEM2: sim_memory mem2_src mem2_tgt>> /\
      <<CAP_TGT: Memory.cap (Local.promises lc_tgt) mem1_tgt mem2_tgt>>.
  Proof.
    exploit Memory.cap_exists; try exact MEM1_TGT; eauto. i. des.
    esplits; eauto.
    rename mem2 into mem2_tgt. econs; i; try split; i.
    - inv H.
      destruct (Memory.get loc to mem1_src) as [[]|] eqn:GET1.
      + inv CAP_SRC. exploit SOUND; eauto. intro x.
        rewrite x in GET. inv GET.
        eapply cap_cover; eauto.
        inv MEM1. rewrite <- COVER.
        econs; eauto.
      + exploit cap_get_src; eauto. i. des.
        econs; eauto.
    - inv H.
      destruct (Memory.get loc to mem1_tgt) as [[]|] eqn:GET1.
      + inv CAP. exploit SOUND; eauto. intro x.
        rewrite x in GET. inv GET.
        eapply cap_cover; eauto.
        inv MEM1. rewrite COVER.
        econs; eauto.
      + exploit cap_get_tgt; eauto. i. des.
        econs; eauto.
    - destruct (Memory.get loc to mem1_tgt) as [[]|] eqn:GET1.
      + inv CAP. exploit SOUND; eauto. intro x.
        rewrite x in GET. inv GET.
        inv MEM1. exploit MSG; eauto. i. des.
        inv CAP_SRC. exploit SOUND; eauto. i.
        esplits; eauto.
      + exploit cap_get_tgt; eauto. i. des.
        esplits; eauto. refl.
    - destruct (Memory.get loc to mem1_src) as [[]|] eqn:GET1.
      + inv CAP_SRC. exploit SOUND; eauto. intro x.
        rewrite x in H. inv H.
        inv MEM1. rewrite RESERVE in GET1.
        inv CAP. exploit SOUND0; eauto.
      + exploit cap_get_src; eauto. i. des. auto.
    - destruct (Memory.get loc to mem1_tgt) as [[]|] eqn:GET1.
      + inv CAP. exploit SOUND; eauto. intro x.
        rewrite x in H. inv H.
        inv MEM1. rewrite <- RESERVE in GET1.
        inv CAP_SRC. exploit SOUND0; eauto.
      + exploit cap_get_tgt; eauto. i. des. auto.
  Qed.
End SimPromises.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^511 - 187
Base: 46 + 5/11
***)

Definition curve : CurveParameters :=
  {|
    sz := 11%nat;
    base := 46 + 5/11;
    bitwidth := 64;
    s := 2^511;
    c := [(1, 187)];
    carry_chains := Some [seq 0 (pred 11); [0; 1]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := None;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


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 X1 X2 X3 E F : Universe, ((wd_ A B /\ (wd_ B C /\ (wd_ A C /\ (wd_ A E /\ (wd_ A F /\ (wd_ B E /\ (wd_ B F /\ (wd_ C E /\ (wd_ C E /\ (wd_ A X3 /\ (wd_ B X2 /\ (wd_ C X1 /\ (wd_ E F /\ (col_ E C X1 /\ (col_ E B X2 /\ (col_ E A X3 /\ (col_ E C X1 /\ (col_ F A X3 /\ col_ F B X2)))))))))))))))))) -> col_ B E A)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Common.Definitions.
Require Import Common.Util.
Require Import Common.Memory.
Require Import Common.Blame.
Require Import Common.CompCertExtensions.
Require Import CompCert.Events.
Require Import CompCert.Smallstep.
Require Import CompCert.Behaviors.
Require Import Intermediate.Machine.
Require Import Intermediate.GlobalEnv.
Require Import Intermediate.CS.
Require Import Old.Intermediate.PS.

From mathcomp Require Import ssreflect ssrfun ssrbool.

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

Import Intermediate.

Section Decomposition.
  Variable p c: program.

  Hypothesis wf1 : well_formed_program p.
  Hypothesis wf2 : well_formed_program c.

  Hypothesis linkability: linkable (prog_interface p) (prog_interface c).
  Hypothesis main_linkability: linkable_mains p c.

  Hypothesis closedness_after_linking:
    closed_program (program_link p c).

  Lemma match_initial_states:
    forall ics,
      CS.initial_state (program_link p c) ics ->
    exists ips,
      PS.initial_state p (prog_interface c) ips /\
      PS.partial_state (prog_interface c) ics ips.
  Proof.
    intros ics Hics_init.
    CS.unfold_states.
    (* case analysis on who has control, then build the partial state *)
    destruct (Pointer.component pc \in domm (prog_interface c)) eqn:Htarget;
      exists (PS.partialize (gps, mem, regs, pc) (prog_interface c));
      simpl; rewrite Htarget.
    (* context has control *)
    - split.
      + eapply PS.initial_state_intro with (p':=c).
        * reflexivity.
        * assumption.
        * assumption.
        * assumption.
        * assumption.
        * eapply PS.ContextControl; eauto.
          ** apply Hics_init.
      + eapply PS.ContextControl; eauto.
    (* program has control *)
    - split.
      + eapply PS.initial_state_intro with (p':=c).
        * reflexivity.
        * assumption.
        * assumption.
        * assumption.
        * assumption.
        * eapply PS.ProgramControl; auto.
          ** PS.simplify_turn.
             unfold negb. rewrite Htarget. auto.
          ** apply Hics_init.
      + eapply PS.ProgramControl; auto.
        * PS.simplify_turn.
          unfold negb. rewrite Htarget. auto.
  Qed.

  Lemma match_final_states:
    forall ics ips,
      PS.partial_state (prog_interface c) ics ips ->
      CS.final_state (prepare_global_env (program_link p c)) ics ->
      PS.final_state p (prog_interface c) ips.
  Proof.
    intros ics ips Hpartial Hics_final.
    CS.unfold_states.
    (* case analysis on who has control *)
    destruct (Pointer.component pc \in domm (prog_interface c)) eqn:Htarget.
    (* context has control *)
    - inversion Hpartial; inversion H; subst.
      + PS.simplify_turn.
        rewrite Htarget in H4. discriminate.
      + apply PS.final_state_context.
        PS.simplify_turn. auto.
    (* program has control *)
    - inversion Hpartial; inversion H; subst.
      + eapply PS.final_state_program with (p':=c).
        * reflexivity.
        * assumption.
        * assumption.
        * assumption.
        * assumption.
        * PS.simplify_turn. rewrite Htarget. auto.
        * eauto.
        * assumption.
      + PS.simplify_turn.
        rewrite Htarget in H4. discriminate.
  Qed.

  Lemma lockstep_simulation:
    forall ics t ics',
      CS.step (prepare_global_env (program_link p c)) ics t ics' ->
    forall ips,
      PS.partial_state (prog_interface c) ics ips ->
    exists ips',
      PS.step p (prog_interface c) (prepare_global_env p) ips t ips' /\
      PS.partial_state (prog_interface c) ics' ips'.
  Proof.
    intros ics t ics' Hstep ips Hpartial.

    (* case analysis on who has control and the executed step *)
    inversion linkability; subst.
    inversion Hpartial; subst;
    inversion Hstep; subst.

    (** program has control **)

    (* epsilon steps *)

    - eexists. split.
      + eapply PS.partial_step with (p':=c); eauto.
        * econstructor; eauto.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + econstructor; auto.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); eauto.
        * econstructor; eauto.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + econstructor; auto.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); eauto.
        * econstructor; eauto.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + econstructor; auto.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); eauto.
        * econstructor; eauto.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + econstructor; auto.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); eauto.
        * econstructor; eauto.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + econstructor; auto.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); eauto.
        * econstructor; eauto.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + econstructor; auto.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); eauto.
        * econstructor; eauto.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + econstructor; auto.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); eauto.
        * econstructor; eauto.
          ** PS.simplify_turn.
             erewrite <- find_label_in_component_1; eauto.
      + econstructor; auto.
        ** PS.simplify_turn.
           erewrite <- find_label_in_component_1; eauto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); eauto.
        * econstructor; eauto.
          ** PS.simplify_turn.
             match goal with
             | Hsame_comp: Pointer.component _ = Pointer.component _ |- _ =>
               rewrite Hsame_comp; assumption
             end.
      + econstructor; auto.
        * PS.simplify_turn.
          match goal with
          | Hsame_comp: Pointer.component _ = Pointer.component _ |- _ =>
            rewrite Hsame_comp; assumption
          end.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); eauto.
        * econstructor; eauto.
          ** PS.simplify_turn.
             erewrite <- find_label_in_procedure_1; eauto.
      + econstructor; auto.
        * PS.simplify_turn.
          erewrite <- find_label_in_procedure_1; eauto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); eauto.
        * econstructor; eauto.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + econstructor; auto.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); eauto.
        * econstructor; eauto.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + econstructor; auto.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    (* call *)
    (* case analysis on the target *)
    - destruct (C' \in domm (prog_interface c)) eqn:Htarget.
      (* external call *)
      + eexists. split.
        * eapply PS.partial_step with (p':=c); auto.
          ** eassumption.
          ** eapply PS.ProgramControl; auto.
          ** eapply PS.ContextControl; auto.
        * eapply PS.ContextControl; auto.
      (* internal call *)
      + eexists. split.
        * eapply PS.partial_step with (p':=c); auto.
          ** eassumption.
          ** eapply PS.ProgramControl; auto.
          ** eapply PS.ProgramControl; auto.
             *** PS.simplify_turn.
                 unfold negb. rewrite Htarget. auto.
        * eapply PS.ProgramControl; auto.
          ** PS.simplify_turn.
             unfold negb. rewrite Htarget. auto.

    (* return *)
    (* case analysis on the target *)
    - destruct (Pointer.component pc' \in domm (prog_interface c)) eqn:Htarget.
      (* external return *)
      + eexists. split.
        * eapply PS.partial_step with (p':=c); auto.
          ** eassumption.
          ** eapply PS.ProgramControl; auto.
          ** eapply PS.ContextControl; auto.
        * eapply PS.ContextControl; auto.
      (* internal return *)
      + eexists. split.
        * eapply PS.partial_step with (p':=c); auto.
          ** eassumption.
          ** eapply PS.ProgramControl; auto.
          ** eapply PS.ProgramControl; auto.
             *** PS.simplify_turn.
                 unfold negb. rewrite Htarget. auto.
        * eapply PS.ProgramControl; auto.
          ** PS.simplify_turn.
             unfold negb. rewrite Htarget. auto.

    (** context has control **)

    (* epsilon steps *)

    - eexists. split.
      + eapply PS.partial_step with (p':=c); auto.
        * eassumption.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn. auto.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + eapply PS.ContextControl;
          try reflexivity.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); auto.
        * eassumption.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn. auto.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + eapply PS.ContextControl;
          try reflexivity.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); auto.
        * eassumption.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn. auto.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + eapply PS.ContextControl;
          try reflexivity.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); auto.
        * eassumption.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn. auto.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + eapply PS.ContextControl;
          try reflexivity.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); auto.
        * eassumption.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn. auto.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + eapply PS.ContextControl;
          try reflexivity.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); auto.
        * eassumption.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn. auto.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + eapply PS.ContextControl;
          try reflexivity.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); auto.
        * eassumption.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn. auto.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + eapply PS.ContextControl;
          try reflexivity.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); auto.
        * eassumption.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn. auto.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn.
             erewrite <- find_label_in_component_1; eauto.
      + eapply PS.ContextControl;
          try reflexivity.
        ** PS.simplify_turn.
           erewrite <- find_label_in_component_1; eauto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); auto.
        * eassumption.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn. auto.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn.
             match goal with
             | Heq_comp: Pointer.component ?PC' = Pointer.component ?PC |- _ =>
               rewrite Heq_comp
             end; auto.
      + eapply PS.ContextControl;
          try reflexivity.
        ** PS.simplify_turn.
           match goal with
           | Heq_comp: Pointer.component ?PC' = Pointer.component ?PC |- _ =>
             rewrite Heq_comp
           end; auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); auto.
        * eassumption.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn. auto.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn.
             erewrite <- find_label_in_procedure_1; eauto.
      + eapply PS.ContextControl;
          try reflexivity.
        ** PS.simplify_turn.
           erewrite <- find_label_in_procedure_1; eauto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); auto.
        * eassumption.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn. auto.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + eapply PS.ContextControl;
          try reflexivity.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    - eexists. split.
      + eapply PS.partial_step with (p':=c); auto.
        * eassumption.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn. auto.
        * eapply PS.ContextControl;
            try reflexivity.
          ** PS.simplify_turn.
             rewrite Pointer.inc_preserves_component. auto.
      + eapply PS.ContextControl;
          try reflexivity.
        ** PS.simplify_turn.
           rewrite Pointer.inc_preserves_component. auto.

    (* call *)
    (* case analysis on the target *)
    - destruct (C' \in domm (prog_interface c)) eqn:Htarget.
      (* internal call *)
      + eexists. split.
        * eapply PS.partial_step with (p':=c); auto.
          ** eassumption.
          ** eapply PS.ContextControl; auto.
          ** eapply PS.ContextControl; auto.
        * eapply PS.ContextControl; auto.
      (* external call *)
      + eexists. split.
        * eapply PS.partial_step with (p':=c); auto.
          ** eassumption.
          ** eapply PS.ContextControl; auto.
          ** eapply PS.ProgramControl; auto.
             *** PS.simplify_turn.
                 unfold negb. rewrite Htarget. auto.
        * eapply PS.ProgramControl; auto.
          ** PS.simplify_turn.
             unfold negb. rewrite Htarget. auto.

    (* return *)
    (* case analysis on the target *)
    - destruct (Pointer.component pc' \in domm (prog_interface c)) eqn:Htarget.
      (* internal return *)
      + eexists. split.
        * eapply PS.partial_step with (p':=c); auto.
          ** eassumption.
          ** eapply PS.ContextControl; auto.
          ** eapply PS.ContextControl; auto.
        * eapply PS.ContextControl; auto.
      (* external return *)
      + eexists. split.
        * eapply PS.partial_step with (p':=c); auto.
          ** eassumption.
          ** eapply PS.ContextControl; auto.
          ** eapply PS.ProgramControl; auto.
             *** PS.simplify_turn.
                 unfold negb. rewrite Htarget. auto.
        * eapply PS.ProgramControl; auto.
          ** PS.simplify_turn.
             unfold negb. rewrite Htarget. auto.
  Qed.

  Theorem decomposition:
    forward_simulation (CS.sem (program_link p c))
                       (PS.sem p (prog_interface c)).
  Proof.
    eapply forward_simulation_step.
    - apply match_initial_states.
    - apply match_final_states.
    - apply lockstep_simulation.
  Qed.

  Corollary decomposition_with_refinement:
    forall beh1,
      program_behaves (CS.sem (program_link p c)) beh1 ->
    exists beh2,
      program_behaves (PS.sem p (prog_interface c)) beh2 /\
      behavior_improves beh1 beh2.
  Proof.
    intros beh1 Hbeh1.
    eapply forward_simulation_behavior_improves; eauto.
    apply decomposition.
  Qed.

  Corollary decomposition_with_safe_behavior:
    forall beh,
      program_behaves (CS.sem (program_link p c)) beh ->
      not_wrong beh ->
      program_behaves (PS.sem p (prog_interface c)) beh.
  Proof.
    intros beh.
    eapply forward_simulation_same_safe_behavior; eauto.
    apply decomposition.
  Qed.

  (* CH: Here is a weaker assumption we should try to use in the
         proof below to closer match the paper argument. Here is a proof
         that it's indeed weaker than decomposition_with_refinement, so
         obtaining it for our instance is not an issue. *)
  Lemma decomposition_prefix :
    forall m,
      not_wrong_finpref m ->
      does_prefix (CS.sem (program_link p c)) m ->
      does_prefix (PS.sem p (prog_interface c)) m.
  Proof.
    intros m Hmsafe [b1 [Hb1 Hm]].
    destruct (decomposition_with_refinement Hb1)
      as [b2 [Hb2 H12]].
    exists b2. split. exact Hb2.
    unfold behavior_improves in H12. destruct H12 as [|[t [H1 H2]]]; subst. assumption.
    unfold prefix in Hm. destruct m as [| t' | t']. tauto. simpl in Hmsafe; tauto.
    eapply behavior_prefix_goes_wrong_trans; eassumption.
  Qed.

End Decomposition.


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e384m2e128m2e96p2e32m1_12limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


(* seplog (c) AIST 2005-2013. R. Affeldt, N. Marti, et al. GNU GPLv3. *)
(* seplog (c) AIST 2014-2018. R. Affeldt et al. GNU GPLv3. *)
From mathcomp Require Import ssreflect ssrfun ssrbool eqtype ssrnat seq.
Require Import ssrZ ZArith_ext seq_ext machine_int uniq_tac multi_int.
Import MachineInt.
Require Import mips_seplog mips_contrib mips_frame mips_mint mips_tactics.
Import expr_m.
Import assert_m.
Require Import multi_halve_s_prg multi_is_zero_u_triple multi_zero_s_triple.
Require Import abs_triple multi_halve_u_triple.

Local Open Scope mips_expr_scope.
Local Open Scope mips_assert_scope.
Local Open Scope mips_hoare_scope.
Local Open Scope machine_int_scope.
Local Open Scope zarith_ext_scope.
Local Open Scope uniq_scope.
Local Open Scope multi_int_scope.

(* TODO: clean *)

Lemma auxili nk (slen rk : int 32) :
  Z_of_nat nk < 2 ^^ 31 ->
(* TODO: really useful? *)
  slen != zero32 ->
  s2Z slen = sgZ (s2Z slen) * Z_of_nat nk ->
  s2Z rk = `|s2Z slen| ->
  u2Z rk = Z_of_nat nk.
Proof.
move=> nk_231 slen0 slen_nk rk_nk.
have H1 : 0 <= s2Z rk by rewrite rk_nk; apply normZ_ge0.
have Haux : s2Z slen <> 0.
  rewrite (_ : 0 = s2Z (Z2u 32 0)); last first.
    rewrite s2Z_u2Z_pos' //; by rewrite Z2uK.
    move/eqP in slen0.
    contradict slen0.
    by apply s2Z_inj in slen0.
have H2 : s2Z rk < 2 ^^ 31.
  rewrite rk_nk slen_nk Zabs_Zmult Zabs_Zsgn_1 // mul1Z Z.abs_eq //.
  exact: Zle_0_nat.
rewrite s2Z_u2Z_pos' in rk_nk; last by rewrite -s2Z_u2Z_pos.
rewrite rk_nk slen_nk Zabs_Zmult Zabs_Zsgn_1 // mul1Z Z.abs_eq //.
exact: Zle_0_nat.
Qed.

Lemma multi_halve_s_noneucl_triple rk a a0 i tmp prev next : uniq(rk, a, a0, i, tmp, prev, next, r0) ->
  forall nk va, Z_of_nat nk < 2 ^^ 31 ->
    forall val : Z,
      {{ fun s h => [ a ]_s = va /\ (var_signed nk a val) s h}}
      multi_halve_s_noneucl a a0 i tmp prev next rk
      {{ fun s h => exists val',
        (var_signed nk a val') s h /\ 2 * val' + sgZ val * u2Z ([prev]_s `>> 31) = val}}.
Proof.
move=> Hnodup nk va nk_231 val.
rewrite /multi_halve_s_noneucl.

apply (hoare_prop_m.hoare_stren (fun s h => exists slen ptr A,
  SignMagn slen nk A val /\
  u2Z ptr + 4 * Z_of_nat nk < \B^1 /\
  u2Z va + 4 * 2 < \B^1 /\
  [a ]_ s = va /\
  ((var_e a |--> slen :: ptr :: nil) ** (int_e ptr |--> A)) s h)).

move=> s h [Ha Hmem].
case: Hmem => slen ptr A a_fit encodingA ptr_fit Hmem.
exists slen, ptr, A.
repeat (split; first by done).
split; [congruence | done].

apply pull_out_exists => slen.
apply pull_out_exists => ptr.
apply pull_out_exists => A.
apply (hoare_prop_m.pull_out_conjunction' hoare0_false) => encoding.
apply (hoare_prop_m.pull_out_conjunction' hoare0_false) => ptr_fit.
apply (hoare_prop_m.pull_out_conjunction' hoare0_false) => va_fit.

apply hoare_lw_back_alt'' with (!(fun s => [ rk ]_s = slen) **
  (fun s h => ([a ]_ s) = va /\
    ((var_e a |--> slen :: ptr :: nil) ** (int_e ptr |--> A)) s h)).

move=> s h [Ha Hmem].
exists slen; split.
  move: Hmem.
  rewrite -mapsto2_mapstos conAE.
  apply monotony => // h1.
  apply mapsto_ext => //=.
  by rewrite sext_Z2u // addi0.

rewrite /update_store_lw.
apply store_upd_con.
apply con_and_bang_L; repeat Reg_upd => //.
split; first by assumption.
by Assert_upd.

apply hoare_ifte_bang.

  (* length = 0 *)

  apply hoare_addiu' => s h H.
  apply con_and_bang_inv_R in H.
  case: H => H Hr.
  rewrite /= in Hr.
  move/eqP/u2Z_inj : Hr.
  rewrite store.get_r0 => Hr.
  case: H => h1 [h2 [h1dh2 [h1Uh2 [[Hh1 ?] [a_va Hh2]]]]]; subst h1.
  clear h1dh2.
  rewrite heap.unioneh in h1Uh2; subst h2.
  exists 0.
  case: encoding => H1 H2 H3 H4.
  split.
    apply mkVarSigned with slen ptr A => //.
    Reg_upd.
    congruence.
    rewrite -Hh1 Hr.
    apply mkSignMagn => //.
    rewrite s2Z_u2Z_pos' //; by rewrite Z2uK.
    rewrite s2Z_u2Z_pos' //; by rewrite Z2uK.
    rewrite s2Z_u2Z_pos' //; by rewrite Z2uK.
    by Assert_upd.
  rewrite H4.
  rewrite -Hh1 Hr.
  rewrite s2Z_u2Z_pos' //; by rewrite Z2uK.

(* length <> 0 *)

apply (hoare_prop_m.hoare_stren (!(fun s => slen != zero32) **
  !(fun s => ([rk ]_ s) = slen) **
  (fun s h => ([a ]_ s) = va  /\
    (var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) s h))).

move=> s h H.
apply con_and_bang_inv_R in H.
case: H => H H2.
apply con_and_bang_inv_L in H.
case: H => H3 H.
apply con_and_bang_L => //.
apply con_and_bang_L => //.
rewrite /= in H2.
move: H2.
rewrite H3.
rewrite store.get_r0 Z2uK //.
apply contra.
move/eqP => ->.
by rewrite Z2uK.

apply pull_out_bang => slen0.

apply while.hoare_seq with (!(fun s => s2Z ([rk ]_ s) = `|s2Z slen|) **
  fun s h => ([a ]_ s) = va /\
  (var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A) s h).

have : s2Z slen <> - 2 ^ 31.
  case: encoding => H1 H2 H3 H4.
  rewrite H2 => abs.
  have abs' : Z_of_nat nk = 2 ^ 31.
    destruct (s2Z slen) => //.
    rewrite mul1Z in abs; by destruct nk.
    by rewrite mulN1Z eqZ_opp in abs *.
  by rewrite abs' in nk_231.
have : uniq(rk, a0,r0) by Uniq_uniq r0.
move/abs_triple_bang/(_ slen) => Habs_triple.
move/Habs_triple => {}Habs_triple.
apply frame_rule_R => //.
rewrite [modified_regs _]/=.
by Inde.

apply hoare_lw_back_alt'' with (
  (fun s h => ([a ]_ s) = va /\
    ((var_e a |--> slen :: ptr :: nil ** int_e ptr |--> A)) s h /\
    [a0]_s = ptr /\
    s2Z ([rk ]_ s) = Z.abs (s2Z slen))).

move=> s h H.
exists ptr.
rewrite conCE in H.
rewrite -mapsto2_mapstos /= in H.
case: H => h1 [h2 [h1dh2 [h1Uh2 [Hh1 Hh2]]]].
case: Hh1 => a_va Hh1.
case: Hh2 => ? Hh2; subst h2.
clear h1dh2.
rewrite heap.unionhe in h1Uh2; subst h1.
split.
  rewrite conAE in Hh1.
  rewrite conCE conAE in Hh1.
  move: Hh1.
  apply monotony => // h'.
  apply mapsto_ext => //=.
  by rewrite sext_Z2u.
rewrite /update_store_lw.
repeat Reg_upd.
split; first by [].
split; last by [].
Assert_upd.
by rewrite -mapsto2_mapstos.

eapply while.hoare_seq.

case: encoding. move=> A_nk slen_nk slen_val val_A.

have Hnodup' : uniq(rk,a0,i,tmp,prev,next,r0) by  Uniq_uniq r0.
move: (multi_halve_u_triple _ _ _ _ _ _ Hnodup' nk ptr ptr_fit A A_nk) => Htmp {Hnodup'}.

apply (before_frame
(!(fun s => u2Z ([a ]_ s) + 4 * 2 < \B^1 /\ [a]_s = va) ** (var_e a |--> slen :: ptr :: nil))
(fun s h => [a0 ]_ s = ptr /\
  u2Z [rk ]_ s = Z_of_nat nk /\
  (var_e a0 |--> A) s h)
(fun s h => exists A',
  size A' = nk /\
  ([a0 ]_ s) = ptr /\
  u2Z ([rk ]_ s) = Z_of_nat nk /\
  (var_e a0 |--> A') s h /\
  2 * \S_{ nk } A' + u2Z (([prev ]_ s) `>> 31) = \S_{ nk } A)).
apply frame_rule_R.
exact Htmp.
simpl modified_regs.
Inde.
apply inde_u2Z_fit.
by Uniq_not_In.
done.

move=> s h [a_va [Hmem [Ha0 rk_nk]]].
rewrite conCE.
move: Hmem; apply monotony => // h' Hh'.
apply con_and_bang_L => //.
by rewrite a_va.
split => //.
split.
  by apply (auxili nk slen ([rk]_s)).
move: Hh'; by apply mapstos_ext.

by apply hoare_prop_m.entails_id.

case: encoding. move=> A_nk slen_nk slen_val val_A.

have Hnodup' : uniq(rk,a0,i,tmp,next,r0) by  Uniq_uniq r0.

apply exists_conC_hoare.
apply pull_out_exists => A'.

rewrite con_bangE_R.
rewrite conAE.
apply pull_out_bang => A'_nk.

apply while.hoare_seq with (((fun s h =>
  u2Z ([rk ]_ s) = Z_of_nat nk /\
  ([a0 ]_ s) = ptr /\
  (var_e a0 |--> A') s h /\
  (0 = \S_{ nk } A' -> ([next ]_ s) = one32) /\
  (0 < \S_{ nk } A' -> ([next ]_ s) = zero32)) **
!(fun s0 => 2 * \S_{ nk } A' + u2Z (([prev ]_ s0) `>> 31) = \S_{ nk } A) **
!(fun s0 => u2Z ([a ]_ s0) + 4 * 2 < \B^1 /\ [a]_s0 = va) **
var_e a |--> slen :: ptr :: nil)).

move: (multi_is_zero_u_triple _ _ _ _ _ Hnodup' nk A' ptr A'_nk ptr_fit) => Htmp {Hnodup'}.

apply (before_frame
(!(fun s0 => 2 * \S_{ nk } A' + u2Z (([prev ]_ s0) `>> 31) = \S_{ nk } A) **
 !(fun s0 => u2Z ([a ]_ s0) + 4 * 2 < \B^1 /\ [a]_s0 = va) **
 var_e a |--> slen :: ptr :: nil)
(fun s h => u2Z [rk ]_ s = Z_of_nat nk /\ [a0 ]_ s = ptr /\ (var_e a0 |--> A') s h)
(fun s h =>
   u2Z ([rk ]_ s) = Z_of_nat nk /\
   ([a0 ]_ s) = ptr /\
   (var_e a0 |--> A') s h /\
   (0 = \S_{ nk } A' -> ([next ]_ s) = one32) /\
   (0 < \S_{ nk } A' -> ([next ]_ s) = zero32))).
apply frame_rule_R.
by apply Htmp.
Inde.
apply inde_u2Z_b_get_R with (b := fun x => @shrl x 32).
rewrite [modified_regs _]/=.
by Uniq_not_In.
apply inde_u2Z_get_plus_Zlt.
rewrite [modified_regs _]/=; by Uniq_not_In.
simpl modified_regs; by Uniq_not_In.
simpl modified_regs; by Uniq_not_In.
done.

move=> s h H.
rewrite -conAE in H.
rewrite -2!conAE.
move: H.
apply monotony => // h1 Hh1.
move: Hh1.
apply monotony => // h2 Hh2.
apply con_and_bang_R; tauto.
by apply hoare_prop_m.entails_id.

apply hoare_ifte_bang.

have : uniq(a, r0) by Uniq_uniq r0.
move/multi_zero_s_triple/(_ A' ptr slen) => Htmp.

eapply (before_frame !(fun s0 =>
  [a ]_ s0 = va/\
  u2Z ([rk ]_ s0) = Z_of_nat nk /\
  [a0 ]_ s0 = ptr /\
  0 = \S_{ nk } A' /\
  2 * \S_{ nk } A' + u2Z (([prev ]_ s0) `>> 31) = \S_{ nk } A /\
  u2Z ([a ]_ s0) + 4 * 2 < \B^1)).
apply frame_rule_R.
apply Htmp.
by Inde.
done.

  move=> s h H.
  apply con_and_bang_inv_R in H.
  case: H => H Htest.
  rewrite /= in Htest.
  rewrite conCE 2!conAE in H.
  apply con_and_bang_inv_L in H.
  case: H => A'shift H.
  apply con_and_bang_inv_L in H.
  case: H => [[Ha Ha'] H].
  rewrite !con_bangE_R in H.
  rewrite !con_bangE_L in H.
  rewrite conCE !conAE in H.
  apply con_and_bang_inv_L in H.
  case: H => rk_nk H.
  apply con_and_bang_inv_L in H.
  case: H => a0_ptr H.
  rewrite conCE 1!conAE in H.
  apply con_and_bang_inv_L in H.
  case: H => [[HSum1 HSum2] H].

  apply con_and_bang_R => //.

  move: H.
  apply monotony => // h'.
  by apply mapstos_ext.

  repeat (split; first by done).
  case/leZ_eqVlt : (min_lSum nk A') => // abs.
  apply HSum2 in abs.
  rewrite abs in Htest.
  by rewrite store.get_r0 Z2uK //  in Htest.

move=> s h H.
(*rewrite !con_bangE_R in H.*)
(*rewrite conAE in H.*)
apply con_and_bang_inv_R in H.
case: H => H [a_va [rk_nk [a0_ptr [HSum [Hshift a_fit]]]]].

have [X|X] : u2Z (([prev ]_ s) `>> 31) = 0 \/
  u2Z (([prev ]_ s) `>> 31) = 1.
  move: (shrl_lt ([prev ]_ s) 31) => /= X1.
  move: (min_u2Z (([prev ]_ s) `>> 31)) => ?; lia.
exists 0.
split.
  apply mkVarSigned with zero32 ptr A' => //.
  apply mkSignMagn => //.
  by rewrite s2Z_u2Z_pos' // Z2uK.
  by rewrite s2Z_u2Z_pos' // Z2uK.
  by rewrite s2Z_u2Z_pos' // Z2uK.
rewrite {2}val_A /= X -Hshift -HSum X; ring.

exists 0.
split.
  apply mkVarSigned with zero32 ptr A' => //.
  apply mkSignMagn => //.
  by rewrite s2Z_u2Z_pos' // Z2uK.
  by rewrite s2Z_u2Z_pos' // Z2uK.
  by rewrite s2Z_u2Z_pos' // Z2uK.
rewrite val_A X Zsgn_Zmult ZsgnK -Hshift -HSum /= X /=; ring.

apply hoare_nop'.
move=> s h H.
apply con_and_bang_inv_R in H.
case: H => H Htest.
rewrite /= in Htest.
move/negPn : Htest.
rewrite store.get_r0 Z2uK //.
move/eqP=> Htest.
case: H => h1 [h2 [h1dh2 [h1Uh2 [Hh1 Hh2]]]].

exists (sgZ (s2Z slen) * (\S_{ nk } A')).
apply con_and_bang_inv_L in Hh2.
case: Hh2 => A'shift Hh2.
case: Hh1 => rk_nk [a0_ptr [Hh1 His_zero]].
rewrite val_A.
have A'_not_0 : 0 < \S_{ nk } A'.
  apply ltZ_neqAle; split; last exact: min_lSum.
  move/(proj1 (His_zero)) => abs; move: Htest.
  by rewrite abs Z2uK.
apply con_and_bang_inv_L in Hh2.
split.
  apply mkVarSigned with slen ptr A' => //.
  tauto.
  apply mkSignMagn => //.
  rewrite Zsgn_Zmult ZsgnK (proj2 (Zsgn_pos (\S_{ nk } A')) A'_not_0); ring.
exists h2, h1 => //.
split; first exact: heap.disj_sym.
split.
  rewrite heap.unionC //; exact: heap.disj_sym.
split; first tauto.
by move: Hh1; apply mapstos_ext => //.
rewrite -A'shift mulZDr !mulZA.
f_equal; first ring.
f_equal.
rewrite -mulZA -mulZDr Zsgn_Zmult ZsgnK.
have : 0 < 2 * \S_{ nk } A' + u2Z (([prev ]_ s) `>> 31).
  move: (min_u2Z (([prev ]_ s) `>> 31)) => ?; lia.
move/Zsgn_pos => ->; ring.
Qed.


Require Import Crypto.Specific.Framework.RawCurveParameters.
Require Import Crypto.Util.LetIn.

(***
Modulus : 2^216 - 2^108 - 1
Base: 54
***)

Definition curve : CurveParameters :=
  {|
    sz := 4%nat;
    base := 54;
    bitwidth := 64;
    s := 2^216;
    c := [(1, 1); (2^108, 1)];
    carry_chains := Some [[1; 3]; [2; 0; 3; 1]; [2; 0]]%nat;

    a24 := None;
    coef_div_modulus := Some 2%nat;

    goldilocks := Some true;
    karatsuba := None;
    montgomery := false;
    freeze := Some true;
    ladderstep := false;

    mul_code := None;

    square_code := None;

    upper_bound_of_exponent_loose := None;
    upper_bound_of_exponent_tight := None;
    allowable_bit_widths := None;
    freeze_extra_allowable_bit_widths := None;
    modinv_fuel := None
  |}.

Ltac extra_prove_mul_eq _ := idtac.
Ltac extra_prove_square_eq _ := idtac.


Require Import Coq.Program.Basics.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Program.Combinators.
Require Import Setoid.
Require Import ZArith.
Require Import Psatz.

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.NewProofs.ProofHelpers.
Require Import depoolContract.DePoolFunc.

(* Set Typeclasses Iterative Deepening.
Set Typeclasses Depth 100. *)

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 struct_scope.
Local Open Scope Z_scope.
Local Open Scope solidity_scope.
Require Import Lists.List.
Import ListNotations.
Local Open Scope list_scope.

Require Import depoolContract.DePoolConsts.
Module DePoolContract_Ф_onSuccessToRecoverStake (dc : DePoolConstsTypesSig XTypesSig StateMonadSig).
Module DePoolFuncs := DePoolFuncs XTypesSig StateMonadSig dc.
Module ProofHelpers := ProofHelpers dc.

Import dc.
Import ProofHelpers.
Import DePoolFuncs.
Import DePoolSpec.
Import LedgerClass.

Opaque Z.eqb Z.add Z.sub Z.div Z.mul hmapLookup hmapInsert Z.ltb Z.geb Z.leb Z.gtb Z.modulo deleteListPair.

Opaque DePoolContract_Ф_startRoundCompleting DePoolContract_Ф_acceptRewardAndStartRoundCompleting.

Lemma DePoolContract_Ф_onSuccessToRecoverStake_exec : forall  ( Л_queryId : XInteger64 )
                                                              ( Л_elector : XAddress )
                                                              ( l: Ledger ) ,
let optRound := eval_state ( ↓ ( RoundsBase_Ф_fetchRound Л_queryId ) ) l in
let req1 : bool := isSome optRound in
let round := maybeGet optRound in
let req2 : bool := eval_state msg_sender l =?  round ->> RoundsBase_ι_Round_ι_proxy  in
let req3 : bool := Л_elector =? round ->> RoundsBase_ι_Round_ι_elector in
let value := ( eval_state msg_value l) + DePoolLib_ι_PROXY_FEE in
let if1 : bool := eqb (round ->> RoundsBase_ι_Round_ι_step) RoundsBase_ι_RoundStepP_ι_WaitingIfValidatorWinElections in
let if2 : bool := value <? round ->> RoundsBase_ι_Round_ι_stake in
let if3 : bool := eqb ( round ->> RoundsBase_ι_Round_ι_step ) RoundsBase_ι_RoundStepP_ι_WaitingReward in
let if4 : bool := value >=? ( ( round ->> RoundsBase_ι_Round_ι_stake ) - ( round ->> RoundsBase_ι_Round_ι_unused ) ) in
let la :=  exec_state (↓ tvm_accept) l in

let (round', l') := if if1 then
                        if if2 then ({$ round with ( RoundsBase_ι_Round_ι_step , RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze ) ;
                                                   ( RoundsBase_ι_Round_ι_unused , value ) $}, la) else
                        ({$ round with ( RoundsBase_ι_Round_ι_step , RoundsBase_ι_RoundStepP_ι_WaitingUnfreeze ) ;
                                       ( RoundsBase_ι_Round_ι_completionReason , RoundsBase_ι_CompletionReasonP_ι_ElectionsAreLost ) $}, la)
                           else if if3 then
                                        let r' := {$ round with ( RoundsBase_ι_Round_ι_recoveredStake , value ) $} in
                                        if if4 then
                                             run ( ↓ ( DePoolContract_Ф_acceptRewardAndStartRoundCompleting r'  value ) ) la
                                               else
                                             run ( ↓ ( DePoolContract_Ф_startRoundCompleting r' RoundsBase_ι_CompletionReasonP_ι_ValidatorIsPunished ) ) la
                           else (round, injEmbed (VMState_ι_savedDePoolContracts (Ledger_ι_VMState l)) la) in

exec_state ( ↓ DePoolContract_Ф_onSuccessToRecoverStake Л_queryId Л_elector ) l =
if req1 then
        if req2 then
                if req3 then
                        if if1 then
                                if if2 then exec_state ( ↓ ( RoundsBase_Ф_setRound Л_queryId round' ) ) l'
                                       else exec_state ( ↓ ( RoundsBase_Ф_setRound Л_queryId round' ) ) l'
                               else
                        if if3 then
                                if if4 then exec_state ( ↓ ( RoundsBase_Ф_setRound Л_queryId round' ) ) l'
                                       else exec_state ( ↓ ( RoundsBase_Ф_setRound Л_queryId round' ) ) l'
                                else l'
                         else l
                else l
        else l.
 Proof.

        intros.
        destructLedger l.
        compute.

        Time repeat destructIf_solve. idtac.
        all: try rewrite H0 in H4; try discriminate. idtac.
        all: try destructFunction2 DePoolContract_Ф_acceptRewardAndStartRoundCompleting; auto. idtac.
        all: try rewrite H1 in H5; try discriminate. idtac.
        all: try destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.
Qed.

Lemma DePoolContract_Ф_onSuccessToRecoverStake_eval : forall ( Л_queryId : XInteger64 )
                                                              ( Л_elector : XAddress )
                                                              (l: Ledger) ,
let optRound := eval_state ( ↓ ( RoundsBase_Ф_fetchRound Л_queryId ) ) l in
let req1 : bool := isSome optRound in
let round := maybeGet optRound in
let req2 : bool := eval_state msg_sender l =?  round ->> RoundsBase_ι_Round_ι_proxy  in
let req3 : bool := Л_elector =? round ->> RoundsBase_ι_Round_ι_elector in
let la :=  exec_state (↓ tvm_accept) l in
let value := ( eval_state msg_value l) + DePoolLib_ι_PROXY_FEE in
let if1 : bool := eqb (round ->> RoundsBase_ι_Round_ι_step) RoundsBase_ι_RoundStepP_ι_WaitingIfValidatorWinElections in
let if2 : bool := value <? round ->> RoundsBase_ι_Round_ι_stake in
let if3 : bool := eqb ( round ->> RoundsBase_ι_Round_ι_step ) RoundsBase_ι_RoundStepP_ι_WaitingReward in
let if4 : bool := value >=? ( ( round ->> RoundsBase_ι_Round_ι_stake ) -
                                                           ( round ->> RoundsBase_ι_Round_ι_unused ) ) in
eval_state ( ↓ DePoolContract_Ф_onSuccessToRecoverStake Л_queryId Л_elector ) l =

if req1 then
        if req2 then
                if req3 then
                        if if1 then
                                if if2 then Value I
                                       else Value I
                               else
                        if if3 then
                                if if4 then Value I
                                       else Value I
                                else Error InternalErrors_ι_ERROR521
                         else Error Errors_ι_IS_NOT_ELECTOR
                else Error Errors_ι_IS_NOT_PROXY
        else Error InternalErrors_ι_ERROR513 .

 Proof.
        intros.
        destructLedger l.
        compute.

        Time repeat destructIf_solve. idtac.
        all: try destructFunction2 DePoolContract_Ф_acceptRewardAndStartRoundCompleting; auto. idtac.
        all: try destructFunction2 DePoolContract_Ф_startRoundCompleting; auto.

 Qed.

 End DePoolContract_Ф_onSuccessToRecoverStake.


Require Import List.
Require Import Omega.

Require Import MachineModel.
Require Import Assembler.

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

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

Inductive evalSec : StateSec -> StateSec -> Prop :=
| eval_sec_movl : forall (p : Address) (r r' : RegisterFile) (f : Flags) (m : MemSec) (rd rs : Register),
  inst (lookupMS m p) (movl rd rs) ->
  int_jump p (S p) ->
  read_allowed p  (r rs) ->
  r' = updateR r rd (lookupMS m (r rs)) ->
  (p, r, f, m) --i--> (S p, r', f, m)

| eval_sec_movs : forall (p : Address) (r : RegisterFile) (f : Flags) (m m' : MemSec) (rd rs : Register),
  inst (lookupMS m p) (movs rd rs) ->
  int_jump p (S p) ->
  data_segment (r rd) ->
  write_allowed p  (r rd) ->
  m' = updateMS m  (r rd) (r rs)->
  (p, r, f, m) --i--> (S p, r, f, m')

| eval_sec_movi : forall (p : Address) (i : Value) (r r' : RegisterFile) (f : Flags) (m : MemSec) (rd : Register),
  inst (lookupMS m p) (movi rd i) ->
  int_jump p (S p) ->
  r' = updateR r rd i ->
  (p, r, f, m) --i--> (S p, r', f, m)

| eval_sec_compare : forall (p : Address) (r : RegisterFile) (f f' : Flags) (m : MemSec) (r1 r2 : Register),
  inst (lookupMS m p) (cmp r1 r2) ->
  int_jump p (S p) ->
  f' = updateF (updateF f ZF (beq_nat (r r1) (r r2))) SF (blt_nat (r r1) (r r2)) ->
  (p, r, f, m) --i--> (S p, r, f', m)

| eval_sec_add : forall (p : Address) (r r' : RegisterFile) (f f' : Flags) (v : Value) (m : MemSec) (rd rs : Register),
  inst (lookupMS m p) (add_ rd rs) ->
  int_jump p (S p) ->
  v = plus (r rd) (r rs)  ->
  r' = updateR r rd v ->
  f' = updateF f ZF (beq_nat v 0) ->
  (p, r, f, m) --i--> (S p, r', f', m)

| eval_sec_sub : forall (p : Address) (r r' : RegisterFile) (f f' : Flags) (v : Value) (m : MemSec) (rd rs : Register),
  inst (lookupMS m p) (sub_ rd rs) ->
  int_jump p (S p) ->
  v = minus (r rd) (r rs)  ->
  r' = updateR r rd v ->
  f' = updateF f ZF (beq_nat v 0) ->
  (p, r, f, m) --i--> (S p, r', f', m)

| eval_sec_call : forall (p p' : Address) (r r' r'' : RegisterFile) (f : Flags) (m m' m'' : MemSec) (rd : Register),
  inst (lookupMS m p) (call rd) ->
  p' = lookupMS m (r rd) ->
  int_jump p p' ->
  r'' = updateR r' SP (S (r' SP)) ->
  m'' = updateMS m (r'' SP) (S p) ->
  (p, r, f, m) --i--> (p', r'', f, m'')

| eval_sec_ret : forall (p p' : Address) (r r' r'' : RegisterFile) (f : Flags) (m m' : MemSec),
  inst (lookupMS m p)  ret ->
  p' =  lookupMS m (r SP) ->
  int_jump p p' ->
  r'' = updateR r' SP (minus (r' SP) 1) ->
  (p, r, f, m) --i--> (p', r'', f, m')

| eval_sec_je_true : forall (p p' : Address) (r : RegisterFile) (f : Flags) (m : MemSec) (ri : Register),
  inst (lookupMS m p) (je ri) ->
  f ZF = true ->
  p' = r ri ->
  int_jump p p' ->
  (p, r, f, m) --i--> (p', r, f, m)

| eval_sec_je_false : forall (p p' : Address) (r : RegisterFile) (f : Flags) (m : MemSec) (ri : Register),
  inst (lookupMS m p) (je ri) ->
  f ZF = false ->
  p' = S p ->
  int_jump p p' ->
  (p, r, f, m) --i--> (p', r, f, m)

| eval_sec_jl_true : forall (p p' : Address) (r : RegisterFile) (f : Flags) (m : MemSec) (ri : Register),
  inst (lookupMS m p) (jl ri) ->
  f SF = true ->
  p' = r ri ->
  int_jump p p' ->
  (p, r, f, m) --i--> (p', r, f, m)

| eval_sec_jl_false : forall (p p' : Address) (r : RegisterFile) (f : Flags) (m : MemSec) (ri : Register),
  inst (lookupMS m p) (jl ri) ->
  f SF = false ->
  p' = S p ->
  int_jump p p' ->
  (p, r, f, m) --i--> (p', r, f, m)

| eval_sec_jump : forall (p p' : Address) (r : RegisterFile) (f : Flags) (m : MemSec) (rd : Register),
  inst (lookupMS m p) (jmp rd) ->
  p' = r rd ->
  int_jump p p' ->
  (p, r, f, m) --i--> (p', r, f, m)

| eval_sec_halt : forall (p : Address) (r : RegisterFile) (f : Flags) (m : MemSec),
  inst (lookupMS m p) halt ->
  (p, r, f, m) --i--> (0, r, f, m)

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

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

Inductive evalExt : StateExt -> StateExt -> Prop :=
| eval_ext_movl : forall (p : Address) (r r' : RegisterFile) (f : Flags) (m : MemExt) (rd rs : Register),
  inst (lookupME m p) (movl rd rs) ->
  ext_jump p (S p) ->
  read_allowed p  (r rs) ->
  r' = updateR r rd (lookupME m (r rs)) ->
  (p, r, f, m) --e--> (S p, r', f, m)

| eval_ext_movs : forall (p : Address) (r : RegisterFile) (f : Flags) (m m' : MemExt) (rd rs : Register),
  inst (lookupME m p) (movs rd rs) ->
  ext_jump p (S p) ->
  write_allowed p  (r rd) ->
  m' = updateME m  (r rd) (r rs)->
  (p, r, f, m) --e--> (S p, r, f, m')

| eval_ext_movi : forall (p : Address) (i : Value) (r r' : RegisterFile) (f : Flags) (m : MemExt) (rd : Register),
  inst (lookupME m p) (movi rd i) ->
  ext_jump p (S p) ->
  r' = updateR r rd i ->
  (p, r, f, m) --e--> (S p, r', f, m)

| eval_ext_compare : forall (p : Address) (r : RegisterFile) (f f' : Flags) (m : MemExt) (r1 r2 : Register),
  inst (lookupME m p) (cmp r1 r2) ->
  ext_jump p (S p) ->
  f' = updateF (updateF f ZF (beq_nat (r r1) (r r2))) SF (blt_nat (r r1) (r r2)) ->
  (p, r, f, m) --e--> (S p, r, f', m)

| eval_ext_add : forall (p : Address) (r r' : RegisterFile) (f f' : Flags) (v : Value) (m : MemExt) (rd rs : Register),
  inst (lookupME m p) (add_ rd rs) ->
  ext_jump p (S p) ->
  v = plus (r rd) (r rs)  ->
  r' = updateR r rd v ->
  f' = updateF f ZF (beq_nat v 0) ->
  (p, r, f, m) --e--> (S p, r', f', m)

| eval_ext_sub : forall (p : Address) (r r' : RegisterFile) (f f' : Flags) (v : Value) (m : MemExt) (rd rs : Register),
  inst (lookupME m p) (sub_ rd rs) ->
  ext_jump p (S p) ->
  v = minus (r rd) (r rs)  ->
  r' = updateR r rd v ->
  f' = updateF f ZF (beq_nat v 0) ->
  (p, r, f, m) --e--> (S p, r', f', m)

| eval_ext_call : forall (p p' : Address) (r r' r'' : RegisterFile) (f : Flags) (m m' m'' : MemExt) (rd : Register),
  inst (lookupME m p) (call rd) ->
  p' = lookupME m (r rd) ->
  ext_jump p p' ->
  r'' = updateR r' SP (S (r' SP)) ->
  m'' = updateME m (r'' SP) (S p) ->
  (p, r, f, m) --e--> (p', r'', f, m'')

| eval_ext_ret : forall (p p' : Address) (r r' r'' : RegisterFile) (f : Flags) (m m' : MemExt),
  inst (lookupME m p)  ret ->
  p' =  lookupME m (r SP) ->
  ext_jump p p' ->
  r'' = updateR r' SP (minus (r' SP) 1) ->
  (p, r, f, m) --e--> (p', r'', f, m')

| eval_ext_je_true : forall (p p' : Address) (r : RegisterFile) (f : Flags) (m : MemExt) (ri : Register),
  inst (lookupME m p) (je ri) ->
  f ZF = true ->
  p' = r ri ->
  ext_jump p p' ->
  (p, r, f, m) --e--> (p', r, f, m)

| eval_ext_je_false : forall (p p' : Address) (r : RegisterFile) (f : Flags) (m : MemExt) (ri : Register),
  inst (lookupME m p) (je ri) ->
  f ZF = false ->
  p' = S p ->
  ext_jump p p' ->
  (p, r, f, m) --e--> (p', r, f, m)

| eval_ext_jl_true : forall (p p' : Address) (r : RegisterFile) (f : Flags) (m : MemExt) (ri : Register),
  inst (lookupME m p) (jl ri) ->
  f SF = true ->
  p' = r ri ->
  ext_jump p p' ->
  (p, r, f, m) --e--> (p', r, f, m)

| eval_ext_jl_false : forall (p p' : Address) (r : RegisterFile) (f : Flags) (m : MemExt) (ri : Register),
  inst (lookupME m p) (jl ri) ->
  f SF = false ->
  p' = S p ->
  ext_jump p p' ->
  (p, r, f, m) --e--> (p', r, f, m)

| eval_ext_jump : forall (p p' : Address) (r : RegisterFile) (f : Flags) (m : MemExt) (rd : Register),
  inst (lookupME m p) (jmp rd) ->
  p' = r rd ->
  ext_jump p p' ->
  (p, r, f, m) --e--> (p', r, f, m)

| eval_ext_halt : forall (p : Address) (r : RegisterFile) (f : Flags) (m : MemExt),
  inst (lookupME m p) halt ->
  (p, r, f, m) --e--> (0, r, f, m)

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


Require Import Crypto.Specific.Framework.SynthesisFramework.
Require Import Crypto.Specific.montgomery32_2e206m5_7limbs.CurveParameters.

Module P <: PrePackage.
  Definition package : Tag.Context.
  Proof. make_Synthesis_package curve extra_prove_mul_eq extra_prove_square_eq. Defined.
End P.

Module Export S := PackageSynthesis P.


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 AB BC ABC BCprime Bprime Cprime : Universe, ((wd_ A O /\ (wd_ B O /\ (wd_ C O /\ (wd_ O E /\ (wd_ O Eprime /\ (wd_ E Eprime /\ (wd_ BC O /\ (wd_ Bprime O /\ (wd_ BC BCprime /\ (col_ O E A /\ (col_ O E B /\ (col_ O E AB /\ (col_ O E C /\ (col_ O E BC /\ (col_ O E ABC /\ (col_ O Eprime BCprime /\ (col_ O Eprime Bprime /\ col_ O Eprime Cprime))))))))))))))))) -> col_ O B BC)).
Proof.
  time tac.
Qed.

End FOFProblem.


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 X P Pprime Q Aprime : Universe, ((wd_ A B /\ (wd_ B X /\ (wd_ A X /\ (wd_ P X /\ (wd_ P Pprime /\ (wd_ X Pprime /\ (wd_ A P /\ (wd_ B P /\ (wd_ X Q /\ (wd_ P Q /\ (wd_ A Aprime /\ (wd_ X Aprime /\ (wd_ P Aprime /\ (wd_ Q Aprime /\ (wd_ Q B /\ (wd_ Q A /\ (col_ Aprime B X /\ (col_ A X Aprime /\ col_ P X Pprime)))))))))))))))))) -> col_ A B X)).
Proof.
  time tac.
Qed.

End FOFProblem.


Require Import Coq.Classes.RelationClasses.
Require Import Coq.Relations.Relation_Definitions.
Require Import Logic.lib.Coqlib.
Require Import Logic.lib.Ensembles_ext.
Require Import Logic.GeneralLogic.Base.
Require Import Logic.GeneralLogic.KripkeModel.
Require Import Logic.GeneralLogic.Semantics.Kripke.
Require Import Logic.MinimumLogic.Syntax.
Require Import Logic.MinimumLogic.Semantics.Kripke.
Require Import Logic.PropositionalLogic.Syntax.
Require Import Logic.PropositionalLogic.Semantics.Kripke.
Require Import Logic.SeparationLogic.Syntax.
Require Import Logic.SeparationLogic.Model.SeparationAlgebra.
Require Import Logic.SeparationLogic.Model.OrderedSA.
Require Import Logic.SeparationLogic.Model.DownwardsClosure.
Require Import Logic.SeparationLogic.Semantics.WeakSemantics.
Require Import Logic.SeparationLogic.Semantics.StrongSemantics.
Require Import Logic.SeparationLogic.Semantics.UpwardsSemantics.
Require Import Logic.SeparationLogic.Semantics.FlatSemantics.

Local Open Scope logic_base.
Local Open Scope syntax.
Local Open Scope kripke_model.
Import PropositionalLanguageNotation.
Import SeparationLogicNotation.
Import KripkeModelFamilyNotation.

Module Up2Flat.
Section Up2Flat.

Context {L: Language}
        {minL: MinimumLanguage L}
        {andpL: AndLanguage L}
        {orpL: OrLanguage L}
        {falsepL: FalseLanguage L}
        {negpL: NegLanguage L}
        {iffpL: IffLanguage L}
        {truepL: TrueLanguage L}
        {sepconL: SepconLanguage L}
        {wandL: WandLanguage L}
        {MD: Model}
        {kMD: KripkeModel MD}
        {M: Kmodel}
        {R: Relation (Kworlds M)}
        {po_R: PreOrder Krelation}
        {J: Join (Kworlds M)}
        {SA: SeparationAlgebra (Kworlds M)}
        {uSA: UpwardsClosedSeparationAlgebra (Kworlds M)}
        {SM: Semantics L MD}
        {kiSM: KripkeIntuitionisticSemantics L MD M SM}
        {usepconSM: UpwardsSemantics.SepconSemantics L MD M SM}
        {uwandSM: UpwardsSemantics.WandSemantics L MD M SM}.

Definition fwandSM: @FlatSemantics.WandSemantics L wandL MD kMD M _ (DownwardsClosure_J) SM.
Proof.
  hnf; intros.
  unfold WeakSemantics.wand.
  split; unfold Included, Ensembles.In; intros m ?.
  + rewrite (app_same_set (UpwardsSemantics.denote_wand _ _) m) in H.
    intros.
    destruct H0 as [m' [m1' [? [? ?]]]].
    apply (H  _ _ _ H0 H3).
    eapply sat_mono; eauto.
  + rewrite (app_same_set (UpwardsSemantics.denote_wand _ _) m).
    hnf; intros.
    apply (H m1 m2); auto.
    exists m0, m1.
    split; [| split]; auto.
    reflexivity.
Qed.

Definition fsepconSM: @FlatSemantics.SepconSemantics L sepconL MD kMD M _ (DownwardsClosure_J) SM.
Proof.
  hnf; intros.
  unfold WeakSemantics.sepcon.
  split; unfold Included, Ensembles.In; intros m ?.
  + rewrite (app_same_set (UpwardsSemantics.denote_sepcon _ _) m) in H.
    destruct H as [m1 [m2 [? [? ?]]]].
    exists m1, m2.
    split; [| split]; auto.
    exists m1, m2.
    split; [| split]; auto; reflexivity.
  + rewrite (app_same_set (UpwardsSemantics.denote_sepcon _ _) m).
    destruct H as [m1 [m2 [[n1 [n2 [? [? ?]]]] [? ?]]]].
    exists n1, n2.
    split; [| split]; auto; eapply sat_mono; eauto.
Qed.

Definition feSM {empL: EmpLanguage L} {USA': UnitalSeparationAlgebra' (Kworlds M)} {uempSM: UpwardsSemantics.EmpSemantics L MD M SM}: @FlatSemantics.EmpSemantics L _ MD _ M _ (DownwardsClosure_J) SM.
Proof.
  constructor;
  intros m; simpl; unfold Ensembles.In; unfold WeakSemantics.emp;
  rewrite <- DownwardsClosure_increasing;
  apply UpwardsSemantics.denote_emp.
Qed.

End Up2Flat.
End Up2Flat.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import Bvector.
Require Import EqDec.

Local Open Scope type_scope.

Section HMAC_Message.

  Variable word_size max_size : nat.

  Definition Message := nat * Vector.t (Bvector word_size) max_size.

  Instance Message_EqDec : EqDec Message.

  eapply pair_EqDec;  eauto with typeclass_instances.
  eapply Vector_EqDec.
  eapply Vector_EqDec.
  eauto with typeclass_instances.

  Qed.

End HMAC_Message.


Section domain.
Variable cfg : Set.

(* Because we are showing soundness, it's a stronger result if we don't put any
   restrictions on the syntax or domains of matching logic patterns,
   so we instead allow an arbitrary satisfaction relation.
 *)
Definition formula env : Type := env -> cfg -> Prop.
Definition stateless env : Type := env -> Prop.

(* Rather than explicitly tagging rules as one-path or all-path,
   observe that none of the rules mix quantifiers, so we'll just
   state the proof system without saying whether it's one-path or
   all-path, and prove that soundness for both interpretations.
 *)
Definition system := forall env,
  formula env -> formula env -> Prop.

Definition in_opt_system (S : option system) env (phi phi' : formula env) : Prop :=
  match S with
    | None => False
    | Some sys => sys env phi phi'
  end.

Definition cons_system env (phi phi' : formula env) (S : system) : system :=
  fun env0 X X0 =>
    S env0 X X0 \/
    {H : env = env0 | phi = eq_rect_r _ X H /\ phi' = eq_rect_r _ X0 H}.

Definition cons_opt_system env (phi phi' : formula env) (S : option system) : option system :=
  Some (cons_system env phi phi' (in_opt_system S)).

Definition system_empty (S : option system) : Prop :=
  match S with
    | Some _ => False
    | None => True
  end.

Definition union_system (C : option system) (S : system) : system :=
  match C with
    | None => S
    | Some S1 =>
      fun env0 X X0 => S1 env0 X X0 \/ S env0 X X0
  end.

Section FixTransition.
Variable (S : cfg -> cfg -> Prop).

(* The proof system defined for soundness.
   Because we are only interested in soundness here, including additional
   rules is a stronger result (such as allowing logical framing at any
   point rather than just combined with axiom, including substitution
   as an explicit rule, or including step even during the
   one-path soundness proof)
 *)
Inductive IS (C : option system) (A : system) : forall env,
  formula env -> formula env -> Prop :=
  (* This step is written in terms of a transtion relation, rather
     than a system given as a set of rules.
     Equavalence to the version in the paper is shown
     later in this file. *)
  | is_step : forall env (phi phi' : formula env),
                (forall e c, phi e c ->
                             (exists c2, S c c2) /\
                             (forall c2, S c c2 -> phi' e c2)) ->
                 IS C A env phi phi'
  | is_axiom : forall env phi phi',
                 A env phi phi' -> IS C A env phi phi'
  | is_refl : forall env phi, system_empty C -> IS C A env phi phi
  | is_trans : forall env phi phi' phi'',
       IS C A env phi phi' ->
       IS None (union_system C A) env phi' phi'' ->
       IS C A env phi phi''
  | is_conseq : forall env
       (phi1 phi1' phi2 phi2' : formula env),
       (forall e g, phi1 e g -> phi1' e g) ->
       (forall e g, phi2 e g -> phi2' e g) ->
       IS C A env phi1' phi2 ->
       IS C A env phi1 phi2'
  | is_case : forall env phi phi1 phi',
       IS C A env phi  phi' ->
       IS C A env phi1 phi' ->
       IS C A env (fun e g => phi e g \/ phi1 e g) phi'
(* Abstraction with frehsness made manifest by giving phi a biggern env. *)
  | is_abstr : forall env denx
       (phi : formula (env * denx)) (phi' : formula env),
       IS C A (env * denx) phi (fun rho_and_x g => phi' (fst rho_and_x) g) ->
       IS C A env (fun rho g => exists x, phi (rho , x) g) phi'
(* Abstraction done by replacing the value in the environment,
   with the operation (repx) of replacing that value in the environment left abstract,
   and freeness of phi' taken as an assumption. *)
  | is_abstr' : forall env denx repx
       (phi phi' : formula env),
       (forall rho (x : denx) gamma, phi' rho gamma <-> phi' (repx x rho) gamma) ->
       IS C A env phi phi' ->
       IS C A env (fun rho g => exists x, phi (repx x rho) g) phi'
  | is_circ : forall env phi phi',
       IS (cons_opt_system env phi phi' C) A env phi phi' ->
       IS C A env phi phi'
  | is_subst : forall env env' f phi phi',
       IS C A env' phi phi' ->
       IS C A env (fun e g => phi (f e) g) (fun e g => phi' (f e) g)
  | is_lf : forall env phi phi' psi,
       IS C A env phi phi' ->
       IS C A env (fun e g => phi e g  /\ psi e)
                  (fun e g => phi' e g /\ psi e).

(* Now some lemmas checking adequacy of definitions that
   won't be needed outside this file
 *)

(* For soundness, the weakly-well-defined condition is used mostly
   just to be sure that the transition system induced by a set of
   rules actually makes it's own rules semantically valid.
   Check that here. *)
(* A transition relation where each rule in the system
   induces an immediate step *)
Definition relation_of_system (S : system) : cfg -> cfg -> Prop :=
  fun gamma gamma' =>
    exists env, exists (rho : env), exists phi, exists phi',
       (S env phi phi') /\ phi rho gamma /\ phi' rho gamma'.
(* A system consisting of rules all of whose instances
   hold in exactly one step along some path *)
Definition system_of_relation (R : cfg -> cfg -> Prop) : system :=
  fun env phi phi' =>
    forall (rho : env) gamma gamma',
      phi rho gamma -> phi' rho gamma' -> R gamma gamma'.
(* A weakly well-defined rule *)
Definition weakly_well_defined (env : Set) phi phi' : Prop :=
  forall (gamma : cfg) (rho : env), phi rho gamma -> exists (gamma' : cfg), phi' rho gamma'.
(* Show that the if a rule is weakly-well-defined, then included in the
   system of the transition relation of any system including that rule *)
Lemma weakly_well_defined_rule_valid :
  forall (S : system) (env : Set) (phi phi' : formula env),
    S env phi phi' -> weakly_well_defined env phi phi' ->
    (system_of_relation (relation_of_system S) env phi phi').
unfold system_of_relation, relation_of_system; eauto 40.
Qed.

Section StepGood.
Variable (Ssys : system).
Hypothesis (Ssys_welldef :
              forall env phi phi' e c1,
                (Ssys env phi phi' /\ phi e c1) ->
                exists c2, phi' e c2).
Hypothesis (Ssys_good :
              forall c1 c2, S c1 c2 <->
                            exists env phi phi' e,
              (Ssys env phi phi' /\ phi e c1 /\ phi' e c2)).

(* Check that the step rule is faithful compared to the
   paper proof as long as S is generated from
   a set of sell-defined reachability rules *)

Lemma s_prog :
  forall c,
    (exists c2, S c c2)
      <-> (exists env phi phi' e,
            Ssys env phi phi' /\ phi e c).
split. firstorder eauto.
intros.
destruct H as (env & phi & phi' & e & H).
specialize (@Ssys_welldef env phi phi' e c H).
destruct Ssys_welldef.
exists x.
apply Ssys_good.
firstorder eauto.
Qed.

Lemma s_succs :
  forall env1 (e : env1) c (phi_g : formula env1),
    ((forall c2, S c c2 -> phi_g e c2)
      <->
     (forall env phi phi',
       Ssys env phi phi' ->
       forall e2, phi e2 c ->
                  forall c2, phi' e2 c2 -> phi_g e c2)).
Proof.
intros.
split.
intros.
apply H.
apply Ssys_good.
firstorder eauto.

intros.
apply Ssys_good in H0.
destruct H0 as (env & phi & phi' & e2 & Hssys & Hphi & Hphi').
apply (H env phi phi' Hssys e2 Hphi c2 Hphi').
Qed.
End StepGood.
End FixTransition.

End domain.