(* Following http://adam.chlipala.net/theses/andreser.pdf chapter 3 *)
Require Import Coq.ZArith.ZArith Coq.micromega.Lia.
Require Import Coq.Structures.Orders.
Require Import Coq.Lists.List.
Require Import Crypto.Algebra.Nsatz.
Require Import Crypto.Arithmetic.ModularArithmeticTheorems.
Require Import Crypto.Util.Decidable.
Require Import Crypto.Util.LetIn.
Require Import Crypto.Util.ListUtil.
Require Import Crypto.Util.NatUtil.
Require Import Crypto.Util.Prod.
Require Import Crypto.Util.Decidable.Bool2Prop.
Require Import Crypto.Util.Tactics.SpecializeBy.
Require Import Crypto.Util.Tactics.UniquePose.
Require Import Crypto.Util.CPSUtil.
Require Import Crypto.Util.CPSNotations.
Require Import Crypto.Util.ZUtil.Definitions.
Require Import Crypto.Util.ZUtil.EquivModulo.
Require Import Crypto.Util.ZUtil.Modulo Crypto.Util.ZUtil.Div.
Require Import Crypto.Util.ZUtil.Zselect.
Require Import Crypto.Util.ZUtil.Hints.Core.
Require Import Crypto.Util.ZUtil.Modulo.PullPush.
Require Import Crypto.Util.ZUtil.Tactics.LtbToLt.
Require Import Crypto.Util.ZUtil.Tactics.DivModToQuotRem.
Require Import Crypto.Util.ZUtil.Tactics.RewriteModSmall.
Require Import Crypto.Util.ZUtil.Tactics.PullPush.Modulo.
Require Import Crypto.Util.Notations.
Import ListNotations. Local Open Scope Z_scope.

Reserved Notation "'dlet_list_pair_only_snd' x := v 'in' f"
         (at level 200, f at level 200, format "'dlet_list_pair_only_snd'  x  :=  v  'in' '//' f").
Reserved Notation "'dlet_list_pair' x := v 'in' f"
         (at level 200, f at level 200, format "'dlet_list_pair'  x  :=  v  'in' '//' f").
Reserved Notation "'dlet_list' x := v 'in' f"
         (at level 200, f at level 200, format "'dlet_list'  x  :=  v  'in' '//' f").
Declare Scope runtime_scope.
Delimit Scope runtime_scope with RT.
Import CPSBindNotations.
Local Open Scope cps_scope.

Module Type Runtime.
  Parameter Let_In : forall {A P} (x : A) (f : forall a : A, P a), P x.
  Parameter runtime_nth_default : forall {A}, A -> list A -> nat -> A.
  Parameter runtime_add : Z -> Z -> Z.
  Parameter runtime_sub : Z -> Z -> Z.
  Parameter runtime_mul : Z -> Z -> Z.
  Parameter runtime_div : Z -> Z -> Z.
  Parameter runtime_modulo : Z -> Z -> Z.
  Parameter runtime_opp : Z -> Z.
  Arguments runtime_add (_ _)%RT.
  Arguments runtime_sub (_ _)%RT.
  Arguments runtime_mul (_ _)%RT.
  Arguments runtime_div _%RT _%Z.
  Arguments runtime_modulo _%RT _%Z.
  Arguments runtime_opp _%RT.
  Infix "*" := runtime_mul : runtime_scope.
  Infix "+" := runtime_add : runtime_scope.
  Infix "-" := runtime_sub : runtime_scope.
  Infix "/" := runtime_div : runtime_scope.
  Notation "x 'mod' y" := (runtime_modulo x y) : runtime_scope.
  Notation "- x" := (runtime_opp x) : runtime_scope.
  Notation "'dlet_nd' x .. y := v 'in' f" := (Let_In (P:=fun _ => _) v (fun x => .. (fun y => f) .. )) (only parsing).
  Notation "'dlet' x .. y := v 'in' f" := (Let_In v (fun x => .. (fun y => f) .. )).

  Module RT_Z.
    Parameter zselect : Z -> Z -> Z -> Z.
    Parameter add_get_carry_full : Z -> Z -> Z -> Z * Z.
    Parameter add_with_get_carry_full : Z -> Z -> Z -> Z -> Z * Z.
    Parameter mul_split : Z -> Z -> Z -> Z * Z.
    Parameter land : Z -> Z -> Z.
  End RT_Z.
End Runtime.

Module RuntimeDefinitions <: Runtime.
  Definition Let_In := @LetIn.Let_In.
  Definition runtime_nth_default := List.nth_default.
  Definition runtime_add := Z.add.
  Definition runtime_sub := Z.sub.
  Definition runtime_mul := Z.mul.
  Definition runtime_opp := Z.opp.
  Definition runtime_div := Z.div.
  Definition runtime_modulo := Z.modulo.
  Module RT_Z.
    Definition zselect := Z.zselect.
    Definition add_get_carry_full := Z.add_get_carry_full.
    Definition add_with_get_carry_full := Z.add_with_get_carry_full.
    Definition mul_split := Z.mul_split.
    Definition land := Z.land.
  End RT_Z.
End RuntimeDefinitions.

Module RuntimeAxioms : Runtime.
  Include RuntimeDefinitions.
End RuntimeAxioms.

Module Export RuntimeDefinitionsCbv.
  Import RuntimeDefinitions.
  Declare Reduction cbv_no_rt
    := cbv -[Let_In
               runtime_nth_default
               runtime_add
               runtime_sub
               runtime_mul
               runtime_opp
               runtime_div
               runtime_modulo
               RT_Z.add_get_carry_full
               RT_Z.add_with_get_carry_full
               RT_Z.mul_split].
  Declare Reduction lazy_no_rt
    := lazy -[Let_In
                runtime_nth_default
                runtime_add
                runtime_sub
                runtime_mul
                runtime_opp
                runtime_div
                runtime_modulo
                RT_Z.add_get_carry_full
                RT_Z.add_with_get_carry_full
                RT_Z.mul_split].
  Declare Reduction pattern_rt
    := pattern Let_In,
       runtime_nth_default,
       runtime_add,
       runtime_sub,
       runtime_mul,
       runtime_opp,
       runtime_div,
       runtime_modulo,
       RT_Z.add_get_carry_full,
       RT_Z.add_with_get_carry_full,
       RT_Z.mul_split.

  Import RuntimeAxioms.
  Declare Reduction pattern_ax_rt
    := pattern (@Let_In),
       (@runtime_nth_default),
       runtime_add,
       runtime_sub,
       runtime_mul,
       runtime_opp,
       runtime_div,
       runtime_modulo,
       RT_Z.add_get_carry_full,
       RT_Z.add_with_get_carry_full,
       RT_Z.mul_split.
End RuntimeDefinitionsCbv.

Module RT_Extra (Import RT : Runtime).
  Fixpoint dlet_nd_list_pair {A B} (ls : list (A * B)) {T} (f : list (A * B) -> T) : T
    := match ls with
       | nil => f nil
       | cons x xs
         => dlet_nd x1 := fst x in dlet_nd x2 := snd x in @dlet_nd_list_pair A B xs T (fun xs => f ((x1, x2) :: xs))
       end.

  Fixpoint dlet_nd_list {A} (ls : list A) {T} (f : list A -> T) : T
    := match ls with
       | nil => f nil
       | cons x xs
         => dlet_nd x := x in @dlet_nd_list A xs T (fun xs => f (x :: xs))
       end.

  Fixpoint dlet_nd_list_pair_only_snd {A B} (ls : list (A * B)) {T} (f : list (A * B) -> T) : T
    := match ls with
       | nil => f nil
       | cons x xs
         => dlet_nd x2 := snd x in @dlet_nd_list_pair_only_snd A B xs T (fun xs => f ((fst x, x2) :: xs))
       end.

  Notation "'dlet_list_pair_only_snd' x := v 'in' f" := (dlet_nd_list_pair_only_snd v (fun x => f)).
  Notation "'dlet_list_pair' x := v 'in' f" := (dlet_nd_list_pair v (fun x => f)).
  Notation "'dlet_list' x := v 'in' f" := (dlet_nd_list v (fun x => f)).

  Definition expand_list_helper {A} (default : A) (ls : list A) (n : nat) (idx : nat) : list A
  := nat_rect
       (fun _ => nat -> list A)
       (fun _ => nil)
       (fun n' rec_call idx
        => cons (runtime_nth_default default ls idx) (rec_call (S idx)))
       n
       idx.
  Definition expand_list {A} (default : A) (ls : list A) (n : nat) : list A
    := expand_list_helper default ls n 0.
End RT_Extra.

Module Associational (Import RT : Runtime).
  Module Import Deps.
    Module Export RT_Extra := RT_Extra RT.
  End Deps.
  Definition eval (p:list (Z*Z)) : Z :=
    fold_right (fun x y => x + y) 0%Z (map (fun t => fst t * snd t) p).

  Definition mul (p q:list (Z*Z)) : list (Z*Z) :=
    flat_map (fun t =>
      map (fun t' =>
        (fst t * fst t', (snd t * snd t')%RT))
    q) p.

  Definition square_cps (p:list (Z*Z)) : ~> list (Z*Z) :=
    list_rect
      _
      (return nil)
      (fun t ts acc T k
       => (dlet two_t2 := (2 * snd t)%RT in
               acc
                 _
                 (fun acc
                  => k (((fst t * fst t, (snd t * snd t)%RT)
                           :: (map (fun t'
                                    => (fst t * fst t', (two_t2 * snd t')%RT))
                                   ts))
                          ++ acc))))
      p.

  Definition negate_snd (p:list (Z*Z)) : list (Z*Z) :=
    map (fun cx => (fst cx, (-snd cx)%RT)) p.

  Definition split (s:Z) (p:list (Z*Z)) : list (Z*Z) * list (Z*Z)
    := let hi_lo := partition (fun t => fst t mod s =? 0) p in
       (snd hi_lo, map (fun t => (fst t / s, snd t)) (fst hi_lo)).

  Definition reduce (s:Z) (c:list _) (p:list _) : list (Z*Z) :=
    let lo_hi := split s p in fst lo_hi ++ mul c (snd lo_hi).

  (* reduce at most [n] times, stopping early if the high list is nil at any point *)
  Definition repeat_reduce (n : nat) (s:Z) (c:list _) (p:list _) : list (Z * Z)
    := nat_rect
         _
         (fun p => p)
         (fun n' repeat_reduce_n' p
          => let lo_hi := split s p in
             if (length (snd lo_hi) =? 0)%nat
             then p
             else let p := fst lo_hi ++ mul c (snd lo_hi) in
                  repeat_reduce_n' p)
         n
         p.

  (* rough template (we actually have to do things a bit differently to account for duplicate weights):
[ dlet fi_c := c * fi in
   let (fj_high, fj_low) := split fj at s/fi.weight in
   dlet fi_2 := 2 * fi in
    dlet fi_2_c := 2 * fi_c in
    (if fi.weight^2 >= s then fi_c * fi else fi * fi)
       ++ fi_2_c * fj_high
       ++ fi_2 * fj_low
 | fi <- f , fj := (f weight less than i) ]
   *)
  (** N.B. We take advantage of dead code elimination to allow us to
      let-bind partial products that we don't end up using *)
  (** [v] -> [(v, v*c, v*c*2, v*2)] *)
  Definition let_bind_for_reduce_square_cps (c:list (Z*Z)) (p:list (Z*Z)) : ~> list ((Z*Z) * list(Z*Z) * list(Z*Z) * list(Z*Z)) :=
    fun T
    => let two := [(1,2)] (* (weight, value) *) in
       map_cps2 (fun t T k => dlet_list_pair_only_snd c_t := mul [t] c in dlet_list_pair_only_snd two_c_t := mul c_t two in dlet_list_pair_only_snd two_t := mul [t] two in k (t, c_t, two_c_t, two_t)) p.
  Definition reduce_square_cps (s:Z) (c:list (Z*Z)) (p:list (Z*Z)) : ~>list (Z*Z) :=
    (p <- let_bind_for_reduce_square_cps c p;
    let div_s := map (fun t => (fst t / s, snd t)) in
    return (list_rect
      _
      nil
      (fun t ts acc
       => (let '(t, c_t, two_c_t, two_t) := t in
           (if ((fst t * fst t) mod s =? 0)
            then div_s (mul [t] c_t)
            else mul [t] [t])
             ++ (flat_map
                   (fun '(t', c_t', two_c_t', two_t')
                    => if ((fst t * fst t') mod s =? 0)
                       then div_s
                              (if fst t' <=? fst t
                               then mul [t'] two_c_t
                               else mul [t] two_c_t')
                       else (if fst t' <=? fst t
                             then mul [t'] two_t
                             else mul [t] two_t'))
                   ts))
            ++ acc)
      p)).

  Definition bind_snd_cps (p : list (Z*Z)) : ~>list (Z * Z) :=
    @dlet_nd_list_pair_only_snd _ _ p.

  Section Carries.
    Definition carryterm_cps (w fw:Z) (t:Z * Z) : ~> list (Z * Z) :=
      fun T k
      => if (Z.eqb (fst t) w)
         then dlet_nd t2 := snd t in
              dlet_nd d2 := (t2 / fw)%RT in
              dlet_nd m2 := (t2 mod fw)%RT in
              k [(w * fw, d2);(w,m2)]
         else k [t].

    Definition carry_cps (w fw:Z) (p:list (Z * Z)) : ~> list (Z * Z):=
      fun T => flat_map_cps (carryterm_cps w fw) p.
  End Carries.
End Associational.

Module Positional (Import RT : Runtime).
  Module Import Deps.
    Module Associational := Associational RT.
  End Deps.
  Section Positional.
  Context (weight : nat -> Z).

  Definition to_associational (n:nat) (xs:list Z) : list (Z*Z)
    := combine (map weight (List.seq 0 n)) xs.
  Definition eval n x := Associational.eval (@to_associational n x).
  Definition zeros n : list Z := repeat 0 n.
  Definition add_to_nth i x (ls : list Z) : list Z
    := ListUtil.update_nth i (fun y => (x + y)%RT) ls.

  Definition place (t:Z*Z) (i:nat) : nat * Z :=
    nat_rect
      (fun _ => unit -> (nat * Z)%type)
      (fun _ => (O, if fst t =? 1 then snd t else (fst t * snd t)%RT))
      (fun i' place_i' _
       => let i := S i' in
          if (fst t mod weight i =? 0)
          then (i, let c := fst t / weight i in if c =? 1 then snd t else (c * snd t)%RT)
          else place_i' tt)
      i
      tt.

  Definition from_associational_cps n (p:list (Z*Z)) : ~> list Z :=
    fun T => fold_right_cps2 (fun t ls T k =>
      let '(p1, p2) := place t (pred n) in
      dlet_nd p2 := p2 in
      k (add_to_nth p1 p2 ls)) (zeros n) p.

  Definition extend_to_length (n_in n_out : nat) (p:list Z) : list Z :=
    p ++ zeros (n_out - n_in).

  Definition drop_high_to_length (n : nat) (p:list Z) : list Z :=
    firstn n p.

  Section mulmod.
    Context (s:Z)
            (c:list (Z*Z)).
    Definition mulmod_cps (n:nat) (a b:list Z) : ~> list Z
      := let a_a := to_associational n a in
         let b_a := to_associational n b in
         let ab_a := Associational.mul a_a b_a in
         let abm_a := Associational.repeat_reduce n s c ab_a in
         from_associational_cps n abm_a.

    Definition squaremod_cps (n:nat) (a:list Z) : ~> list Z
      := (let a_a := to_associational n a in
         aa_a <- Associational.reduce_square_cps s c a_a;
         let aam_a := Associational.repeat_reduce (pred n) s c aa_a in
         from_associational_cps n aam_a).
  End mulmod.

  Definition add_cps (n:nat) (a b:list Z) : ~> list Z
    := let a_a := to_associational n a in
       let b_a := to_associational n b in
       from_associational_cps n (a_a ++ b_a).

  Section Carries.
    Definition carry_cps n m (index:nat) (p:list Z) : ~> list Z :=
      (p <- @Associational.carry_cps (weight index)
         (weight (S index) / weight index)
         (to_associational n p);
       from_associational_cps
           m p).

    Definition carry_reduce_cps n (s:Z) (c:list (Z * Z))
               (index:nat) (p : list Z) : ~> list Z :=
      (p <- @carry_cps n (S n) index p;
         p <- from_associational_cps
           n (Associational.reduce
                s c (to_associational (S n) p));
       return p).

    (* N.B. It is important to reverse [idxs] here, because fold_right is
      written such that the first terms in the list are actually used
      last in the computation. For example, running:

      `Eval cbv - [Z.add] in (fun a b c d => fold_right Z.add d [a;b;c]).`

      will produce [fun a b c d => (a + (b + (c + d)))].*)
    Definition chained_carries_cps n s c p (idxs : list nat) : ~> _ :=
      fun T => fold_right_cps2 (fun a b => carry_reduce_cps n s c a b) p (rev idxs).

    (* carries without modular reduction; useful for converting between bases *)
    Definition chained_carries_no_reduce_cps n p (idxs : list nat) : ~> _ :=
      fun T => fold_right_cps2 (fun a b => carry_cps n n a b) p (rev idxs).

    (* Reverse of [eval]; translate from Z to basesystem by putting
    everything in first digit and then carrying. *)
    Definition encode_cps n s c (x : Z) : ~> list Z :=
      (p <- from_associational_cps n [(1,x)]; chained_carries_cps n s c p (seq 0 n)).

    (* Reverse of [eval]; translate from Z to basesystem by putting
    everything in first digit and then carrying, but without reduction. *)
    Definition encode_no_reduce_cps n (x : Z) : ~> list Z :=
      (p <- from_associational_cps n [(1,x)]; chained_carries_no_reduce_cps n p (seq 0 n)).
  End Carries.

  Section sub.
    Context (n:nat)
            (s:Z)
            (c:list (Z * Z))
            (coef:Z).

    Definition negate_snd_cps (a:list Z) : ~> list Z
      := let A := to_associational n a in
         let negA := Associational.negate_snd A in
         from_associational_cps n negA.

    Definition scmul_cps (x:Z) (a:list Z) : ~> list Z
      := let A := to_associational n a in
         let R := Associational.mul A [(1, x)] in
         from_associational_cps n R.

    Definition balance_cps : ~> list Z
      := (sc <- encode_cps n s c (s - Associational.eval c); v <- scmul_cps coef sc; return v).

    Definition sub_cps (a b:list Z) : ~> list Z
      := (balance <- balance_cps;
            ca <- add_cps n balance a;
            _b <- negate_snd_cps b;
            camb <- add_cps n ca _b;
            return camb).

    Definition opp_cps (a:list Z) : ~> list Z
      := sub_cps (zeros n) a.
  End sub.

  Section select.
    Definition zselect_cps (mask cond:Z) (p:list Z) : ~> _ :=
      fun T k => dlet t := RT_Z.zselect cond 0 mask in k (List.map (RT_Z.land t) p).

    Definition select (cond:Z) (if_zero if_nonzero:list Z) :=
      List.map (fun '(p, q) => RT_Z.zselect cond p q) (List.combine if_zero if_nonzero).
  End select.
End Positional.
End Positional.


(* (c) Copyright Microsoft Corporation and Inria. All rights reserved. *)
Require Import ssreflect.
Require Import ssrnat.
Require Import seq.
Require Import cfmap.
Require Import cfreducible.
Require Import configurations.

Lemma red494to498 : reducible_in_range 494 498 the_configs.
Proof. CheckReducible. Qed.


From stdpp Require Import fin_maps gmap.
From iris.bi.lib Require Import fractional.
From iris.proofmode Require Import tactics.
From iris.base_logic.lib Require Import saved_prop gen_heap.
From aneris.prelude Require Import collect.
From aneris.lib Require Import gen_heap_light.
From aneris.aneris_lang Require Export aneris_lang network resources.

From RecordUpdate Require Import RecordSet.
Set Default Proof Using "Type".

Import uPred.
Import RecordSetNotations.

Definition messages_history := prod message_soup message_soup.

Definition messages_history_map := gmap socket_address messages_history.

Implicit Types mh : messages_history_map.
Implicit Types rt : messages_history.

(* The set of all received messages *)
Definition messages_received mh := collect (λ _ rt, rt.1) mh.

Lemma elem_of_messages_received mh :
  ∀ m, m ∈ messages_received mh ↔
         ∃ sa rt, mh !! sa = Some rt ∧ m ∈ rt.1.
Proof. by apply elem_of_collect; eauto. Qed.

(* The set of all transmitted messages *)
Definition messages_sent mh := collect (λ _ rt, rt.2) mh.

Lemma elem_of_messages_sent mh :
  ∀ m, m ∈ messages_sent mh ↔
         ∃ sa rt, mh !! sa = Some rt ∧ m ∈ rt.2.
Proof. by apply elem_of_collect; eauto. Qed.

(** Definitions for the message history *)
Definition messages_received_sent mh : messages_history :=
  (messages_received mh, messages_sent mh).

(* [m] has been received *)
Definition message_received m mh := m ∈ (messages_received mh).

Lemma gset_to_gmap_singleton (v: message_soup * message_soup)
      (a : socket_address) : gset_to_gmap v {[ a ]} = {[a := v]}.
Proof.
  assert ({[a]} = {[a]} ∪ (∅: gset socket_address)) as -> by by set_solver.
    by rewrite (gset_to_gmap_union_singleton v a ∅) gset_to_gmap_empty.
Qed.

Lemma messages_received_init B :
  messages_received (gset_to_gmap (∅, ∅) B) = ∅.
Proof.
  rewrite /messages_received.
  apply collect_empty_f.
  intros ? [].
  rewrite lookup_gset_to_gmap_Some.
  by intros [? [=]].
Qed.

Lemma messages_sent_init B :
  messages_sent (gset_to_gmap (∅, ∅) B) = ∅.
Proof.
  rewrite /messages_sent.
  apply collect_empty_f.
  intros ? [].
  rewrite lookup_gset_to_gmap_Some.
  by intros [? [=]].
Qed.

Lemma messages_received_sent_init B :
  messages_received_sent (gset_to_gmap (∅, ∅) B) = (∅, ∅).
Proof.
  rewrite /messages_received_sent. f_equal.
  - apply messages_received_init.
  - apply messages_sent_init.
Qed.

Lemma messages_sent_insert a R T mh :
  messages_sent (<[a:=(R, T)]> mh) = T ∪ messages_sent (delete a mh).
Proof.
  rewrite /messages_sent.
  apply collect_insert.
Qed.

Lemma message_received_insert a msg R T mh :
  message_received msg (<[a:=(R, T)]> mh) ↔
                   msg ∈ R ∨ message_received msg (delete a mh).
Proof.
  rewrite /message_received /messages_received.
  rewrite collect_insert //= elem_of_union //.
Qed.

 Lemma messages_received_insert  a R T mh :
   messages_received (<[a:=(R, T)]> mh) = R ∪ messages_received (delete a mh).
 Proof.
   rewrite /messages_received.
   apply collect_insert.
 Qed.

Lemma messages_sent_split a R T mh :
  mh !! a = Some (R, T) →
  messages_sent mh =
  T ∪ messages_sent (delete a mh).
Proof.
  intros.
  assert (mh = <[a := (R,T)]>mh) as Heq by by rewrite insert_id.
  rewrite {1} Heq.
  apply collect_insert.
Qed.

(* The messages in the logical map mh, that tracks received and transmitted
   messages, have coherent addresses. *)
Definition messages_addresses_coh mh :=
  ∀ a R T, mh !! a = Some (R, T) →
    (∀ m, m ∈ R → m_destination m = a) ∧ (∀ m, m ∈ T → m_sender m = a).

Definition messages_received_from_sent_coh mh :=
  messages_received mh ⊆ messages_sent mh.

Definition messages_received_from_sent_coh_aux mh :=
  ∀ rt m,
    mh !! (m_destination m) = Some rt →
    m ∈ rt.1 →
    ∃ rt', mh !! (m_sender m) = Some rt' ∧ m ∈ rt'.2.

Lemma messages_received_from_sent_corrolary_coh mh :
  messages_addresses_coh mh →
  messages_received_from_sent_coh mh →
  messages_received_from_sent_coh_aux mh.
Proof.
  intros Hacoh Hrcoh.
  intros rt m Hrt Hm.
  assert (m ∈ messages_received mh) as Hmr.
  { by apply elem_of_collect; eauto. }
  apply Hrcoh, elem_of_collect in Hmr as (sa & rt' & Hrt' & Hmt).
  assert (mh !! sa = Some (rt'.1, rt'.2)) as Hgas by by destruct rt'.
  specialize (Hacoh sa rt'.1  rt'.2 Hgas) as (Hc1 & Hc2).
  specialize (Hc2 m Hmt). set_solver.
Qed.

Lemma messages_sent_dijsoint a R T mh :
  mh !! a = Some (R, T) →
  messages_addresses_coh mh →
  T ## messages_sent (delete a mh).
Proof.
  intros Ha Hmcoh.
  apply elem_of_disjoint.
  intros m HmT Hms.
  apply elem_of_collect in Hms as (a' & (R',T') & Ha' & Ht).
  simplify_map_eq.
  destruct (Hmcoh a R T Ha) as (_ & HT).
  specialize (HT m HmT).
  rewrite -HT in Ha'.
  destruct (decide (a' = (m_sender m))) as [->|Hneq].
  - by rewrite lookup_delete in Ha'.
  - rewrite lookup_delete_ne in Ha'; last done.
    destruct (Hmcoh a' R' T' Ha') as (_ & HT').
    specialize (HT' m Ht).
    done.
Qed.


Require Import FloydSeq.base2.
Require Import FloydSeq.forward.

Inductive FWD : Type :=
| FWD_end: FWD
| FWD_straight0: FWD -> FWD
| FWD_straight1: forall {A: Type}, (A -> FWD) -> FWD
| FWD_intro: forall {A: Type}, (A -> FWD) -> FWD
| FWD_while0: forall (P: environ->mpred), FWD -> FWD -> FWD
| FWD_while1: forall (P: environ->mpred) {A: Type}, (A -> FWD) -> FWD -> FWD.

Ltac go_FWD f :=
  match f with
  | FWD_end => idtac
  | FWD_straight0 ?f' => forward; [ .. | go_FWD f']
  | FWD_straight1 ?f1 =>
         let x := fresh "x" in forward x; [ .. |
         let y := constr:(f1 x) in let y' := (eval cbv beta in y) in
         go_FWD y']
  | FWD_intro ?f1 =>
         let x := fresh "x" in forward_intro x;
         let y := constr:(f1 x) in let y' := (eval cbv beta in y) in
         go_FWD y'
  | FWD_while0 ?P ?Q ?f1 ?f2 =>
          forward_while P (*Q*); [ | | | go_FWD f1 | go_FWD f2]
  | FWD_while1 ?P ?Q ?f1 ?f2 =>
            let x := fresh "x" in forward_while P (*x*);
             [ | |
             |  let y := constr:(f1 x) in let y' := (eval cbv beta in y) in
                 go_FWD y'
             | go_FWD f2]
  end.


Require Import
  ByteString.Lib.Tactics
  ByteString.Lib.Nomega
  ByteString.Lib.FMapExt
  ByteString.Lib.Fiat
  ByteString.Lib.FromADT
  ByteString.Memory
  ByteString.Heap
  Coq.FSets.FMapFacts
  Coq.Structures.DecidableTypeEx.

Module HeapCanonical (M : WSfun Ptr_as_DT).

Module Import Heap := Heap M.

Import HeapState.
Import FMapExt.

Open Scope N_scope.

(** In order to refine to a computable heap, we have to add the notion of
    "free memory", from which addresses may be allocated. A further
    optimization here would be to add a free list, to which free blocks are
    returned, in order avoid gaps in the heap. A yet further optimization
    would be to better manage the free space to avoid fragmentation. The
    implementation below simply grows the heap with every allocation. *)

Theorem HeapCanonical : FullySharpened HeapSpec.
Proof.
  start sharpening ADT.

  eapply transitivityT.
  eapply annotate_ADT with
    (methDefs' := icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|}
                 (icons {|methBody :=  _|} inil ) ) ) ) ) ) ) ) ) )
    (AbsR := fun or nr =>
       M.Equal (resvs or) (resvs (snd nr)) /\
       M.Equal (bytes or) (bytes (snd nr)) /\
       P.for_all (fun addr sz => plusPtr addr sz <=? fst nr) (resvs (snd nr))).
  simpl; repeat apply Build_prim_prod; simpl;
  intros; try simplify with monad laws; set_evars.

  (* refine constructor emptyS *)
  {
    (*
    instantiate (1 := Build_prim_prod {| consBody := _ |} ());
    simpl; simplify with monad laws; set_refine_evar.
    (* tactic should do all this automatically. *)
    *)

    refine pick val (0%N, newHeapState).
      finish honing.

    intuition; simpl.
    apply for_all_empty; relational; nomega.
  }

  (* refine method allocS. *)
  {
    (*
    instantiate (1 := Build_prim_prod {| methBody := _ |} _); simpl;
    set_refine_evar; simplify with monad laws.
    (* tactic should do all this automatically. *)
   *)

    unfold find_free_block.

    refine pick val (fst r_n).
    {
      simplify with monad laws; simpl.

      refine pick val (plusPtr (A:=Word) (fst r_n) (` d),
                       {| resvs := M.add (fst r_n) (` d) (resvs (snd r_n))
                        ; bytes := bytes (snd r_n) |}).
        simplify with monad laws; simpl.

        finish honing.

      simpl in *; intuition.
      rewrite H2; reflexivity.
      apply for_all_add_true; relational; try nomega.
        rewrite <- H2.
        destruct d.
        eapply allocations_no_overlap_r; eauto.
        rewrite H2.
        eapply for_all_impl; eauto; relational;
        intros; nomega.
      split.
        eapply for_all_impl; eauto; relational;
        intros; nomega.
      nomega.
    }

    repeat breakdown; simpl in *.
    rewrite H0.
    eapply for_all_impl; eauto;
    relational; nomega.
  }
  (* And so on :) ....*)

  (* refine method freeS. *)
  {
    refine pick val (fst r_n,
                     {| resvs := M.remove d (resvs (snd r_n))
                      ; bytes := bytes (snd r_n) |}).
    try simplify with monad laws; simpl.
      finish honing.

    simpl in *; intuition.
    - rewrite H2; reflexivity.
    - apply for_all_remove; relational; nomega.
  }

  (* refine method reallocS. *)
  {
    unfold find_free_block.
    refine pick val (Ifopt M.find d (resvs (snd r_n)) as sz
                     Then If ` d0 <=? sz Then d Else fst r_n
                     Else fst r_n).
    {
      simplify with monad laws.

      refine pick val
        (Ifopt M.find d (resvs (snd r_n)) as sz
         Then If ` d0 <=? sz
              Then
                (fst r_n,
                 {| resvs := M.add d (` d0) (resvs (snd r_n)) (* update *)
                  ; bytes := bytes (snd r_n) |})
              Else
                (plusPtr (A:=Word) (fst r_n) (` d0),
                 {| resvs :=
                      M.add (fst r_n) (` d0) (M.remove d (resvs (snd r_n)))
                  ; bytes :=
                      copy_bytes d (fst r_n) sz (bytes (snd r_n))|})
         Else
           (plusPtr (A:=Word) (fst r_n) (` d0),
            {| resvs := M.add (fst r_n) (` d0) (resvs (snd r_n))
             ; bytes := bytes (snd r_n) |})).
        simplify with monad laws.
        simpl.
        finish honing.

      simpl in *; intuition; rewrite ?H2;
      (destruct (M.find d _) as [sz|] eqn:Heqe;
       [ destruct (` d0 <=? sz) eqn:Heqe1;
         simpl; rewrite ?Heqe1 |]); simpl.
      - rewrite remove_add; reflexivity.
      - reflexivity.
      - apply F.add_m; auto.
        apply F.Equal_mapsto_iff; split; intros.
          simplify_maps.
        simplify_maps; intuition.
        subst.
        apply F.find_mapsto_iff in H1.
        congruence.
      - rewrite copy_bytes_idem; assumption.
      - rewrite N.min_l.
          rewrite H0; reflexivity.
        nomega.
      - assumption.
      - normalize.
        apply_for_all; relational.
        rewrite <- remove_add.
        apply for_all_add_true; relational; try nomega.
          simplify_maps.
        split.
          apply for_all_remove; relational; nomega.
        nomega.
      - normalize.
        apply_for_all; relational.
        rewrite <- remove_add.
        apply for_all_add_true; relational; try nomega.
          simplify_maps.
        split.
          apply for_all_remove; relational; try nomega.
          apply for_all_remove; relational; try nomega.
          eapply for_all_impl; eauto;
          relational; nomega.
        nomega.
      - rewrite <- remove_add.
        apply for_all_add_true; relational; try nomega.
          simplify_maps.
        split.
          apply for_all_remove; relational; try nomega.
          eapply for_all_impl; eauto;
          relational; nomega.
        nomega.
    }

    simpl in *; intuition; rewrite ?H1;
    (destruct (M.find d _) as [sz|] eqn:Heqe;
     [ destruct (` d0 <=? sz) eqn:Heqe1;
       simpl; rewrite ?Heqe1 |]); simpl.
    - normalize.
      rewrite <- H2 in Heqe.
      pose proof (allocations_no_overlap H Heqe) as H2'.
      apply P.for_all_iff; relational; intros; try nomega.
      simplify_maps.
      specialize (H2' _ _ H5 H3).
      nomega.
    - normalize.
      apply_for_all; relational.
      apply for_all_remove; relational; try nomega.
      eapply for_all_impl; eauto;
      relational; try nomega.
      rewrite <- H2 in H4.
      auto.
    - apply for_all_remove; relational.
        nomega.
      remember (fun _ _ => _ <=? _) as P.
      remember (fun _ _ => negb _) as P'.
      apply for_all_impl with (P:=P) (P':=P');
      relational; try nomega.
      rewrite H2.
      assumption.
  }

  (* refine method peekS. *)
  {
    refine pick val (Ifopt M.find (plusPtr d d0) (bytes (snd r_n)) as v
                     Then v
                     Else Zero).
      simplify with monad laws.
      refine pick val r_n.
      simplify with monad laws.
      simpl; finish honing.
      simpl in *; intuition.

    clear H.
    simpl in *; intuition.
    destruct (M.find (plusPtr d d0) _) as [sz|] eqn:Heqe;
    simpl; normalize.
      left.
      rewrite H0.
      assumption.
    right.
    split; intuition.
    destruct H1.
    apply F.find_mapsto_iff in H1.
    rewrite H0 in H1.
    congruence.
  }

  (* refine method pokeS. *)
  {
    refine pick val (fst r_n,
                     {| resvs := resvs (snd r_n)
                      ; bytes := M.add (plusPtr d d0) d1 (bytes (snd r_n)) |}).
    simpl.
    finish honing.

    simpl in *; intuition;
    destruct (d <? fst r_n) eqn:Heqe; simpl; trivial;
    rewrite H0; reflexivity.
  }

  (* refine method memcpyS. *)
  {
    refine pick val (fst r_n,
                     {| resvs := resvs (snd r_n)
                      ; bytes := copy_bytes (plusPtr d d0) (plusPtr d1 d2)
                                            d3 (bytes (snd r_n)) |}).
      finish honing.

    simpl in *; intuition;
    rewrite H0; reflexivity.
  }

  (* refine method memsetS. *)
  {
    refine pick val
       (fst r_n,
        {| resvs := resvs (snd r_n)
         ; bytes :=
             P.update
               (bytes (snd r_n))
               (N.peano_rect
                  (fun _ => M.t Word)
                  (bytes (snd r_n))
                  (fun i => M.add (plusPtr(A:=Word) d (d0 + i))%N d2) d1) |}).
      simpl; finish honing.

    simpl in *; intuition.
    apply P.update_m; trivial.
    induction d1 using N.peano_ind; simpl; trivial.
    rewrite !N.peano_rect_succ.
    apply F.add_m; auto.
  }

  (* refine method readS. *)
  {
    refine pick eq.
    simplify with monad laws; simpl.
    refine pick val r_n.
      simplify with monad laws; simpl.
      destruct H0, H2.
      rewrite Npeano_rect_eq
        with (g := fun (i : N) (xs : list Word) =>
          match M.find (plusPtr d (d0 + i)) (bytes (snd r_n)) with
          | Some w => w
          | None => Zero
          end :: xs).
        finish honing.
      intros.
      f_equal.
      rewrite H2.
      reflexivity.

    simpl in *; intuition.
  }

  (* refine method writeS. *)
  {
    refine pick val
       (fst r_n,
        {| resvs := resvs (snd r_n)
         ; bytes := load_into_map (plusPtr d d0) d1 (bytes (snd r_n)) |}).
      finish honing.

    simpl in *; intuition.
    apply load_into_map_Proper; auto.
    reflexivity.
  }

  constructor.
  finish_SharpeningADT_WithoutDelegation.
Defined.

End HeapCanonical.


Require Import Coq.Reals.Rdefinitions.
Require Import Coq.Reals.Rbasic_fun.
Require Import Coq.Classes.RelationClasses.
Require Import Coq.Classes.Morphisms.
Require Import Coq.Lists.ListSet.
Require Import ChargeCore.Tactics.Lemmas.
Require Import ChargeCore.Tactics.Indexed.
Require Import ExtLib.Tactics.
Require Import Logic.Logic.
Require Import Logic.ProofRules.
Require Import Logic.ArithFacts.
Require Import Logic.Automation.
Require Import Logic.EnabledLemmas.
Require Import Logic.Inductively.

Local Open Scope HP_scope.
Local Open Scope string_scope.

(** TODO: Move this **)
Lemma land_dup : forall A : Formula, A -|- A //\\ A.
Proof. intros; split; charge_tauto. Qed.

(* Adds time derivative to an Evolution.
 * - the global time is stored in [t]
 * - the time until the next discrete step is stored in [T]
 *)
Definition mkEvolution (world : Evolution) : Evolution :=
  fun st' => st' "T" = --1 //\\ world st'.

Definition World (world : Evolution) : Formula :=
  Continuous (mkEvolution world) //\\ 0 < "T" //\\ 0 <= "T"!.

Definition TimeBound (d : R) : Formula :=
  0 <= "T" <= d.

Definition Discr (Prog : ActionFormula) (d : R) : ActionFormula :=
  Prog //\\ "T" = 0 //\\ 0 <= "T"! <= d.

Definition Sys (P : ActionFormula) (w : Evolution) (d : R) : ActionFormula :=
  "T" <= d //\\ (Discr P d \\// World w).

Definition System (P : ActionFormula) (w : Evolution) (d : R) : ActionFormula :=
  Sys P w d \\// (Enabled (Sys P w d) -->> lfalse).

Definition TimedPreserves (delta : R) (P : StateFormula) (A : ActionFormula) : Formula :=
  Preserves (P //\\ 0 <= "T" <= delta) A.

Definition SysNeverStuck (delta : R) (I : StateFormula) (A : ActionFormula) : Formula :=
  0 <= "T" <= delta //\\ I -->> Enabled A.

Global Instance Proper_mkEvolution_lentails
: Proper (lentails ==> lentails) mkEvolution.
Proof.
  unfold mkEvolution. morphism_intro.
  rewrite Evolution_lentails_lentails in H.
  apply Evolution_lentails_lentails.
  simpl in *. restoreAbstraction.
  intros. rewrite H. reflexivity.
Qed.

Global Instance Proper_mkEvolution_lequiv
: Proper (lequiv ==> lequiv) mkEvolution.
Proof.
  unfold mkEvolution. morphism_intro.
  eapply Evolution_lequiv_lequiv.
  intro.
  eapply Evolution_lequiv_lequiv with (x:=x0) in H.
  rewrite H. reflexivity.
Qed.

Global Instance Proper_World_lequiv
: Proper (lequiv ==> lequiv) World.
Proof.
  unfold World; morphism_intro.
  rewrite H. reflexivity.
Qed.

Global Instance Proper_World_lentails
: Proper (lentails ==> lentails) World.
Proof.
  unfold World; morphism_intro.
  rewrite H. reflexivity.
Qed.

Global Instance Proper_Discr
: Proper (lequiv ==> eq ==> lequiv) Discr.
Proof.
  morphism_intro; unfold Discr.
  subst. rewrite H. reflexivity.
Qed.

Global Instance Proper_Sys_lequiv
: Proper (lequiv ==> lequiv ==> eq ==> lequiv) Sys.
Proof.
  unfold Sys, Discr, World. morphism_intro.
  subst. rewrite H; clear H. rewrite H0; clear H0. reflexivity.
Qed.

Global Instance Proper_Sys_lentails
: Proper (lentails ==> lentails ==> eq ==> lentails) Sys.
Proof.
  unfold Sys, Discr, World. morphism_intro.
  subst. rewrite H; clear H. rewrite H0; clear H0. reflexivity.
Qed.

Global Instance Proper_System_lequiv
: Proper (lequiv ==> lequiv ==> eq ==> lequiv) System.
Proof.
  unfold System, Discr, World. morphism_intro.
  subst. rewrite H; clear H. rewrite H0; clear H0. reflexivity.
Qed.

Theorem Preserves_Sys
: forall P Prog IndInv (w : Evolution) (d:R),
  (forall st', is_st_formula (w st')) ->
  P //\\ IndInv //\\ 0 <= "T"! <= "T" //\\ "T" <= d (* This could be "T"! < "T" *)
    //\\ World w |-- next IndInv ->
  P //\\ IndInv //\\ "T" = 0 //\\ 0 <= "T"! <= d
    //\\ Discr Prog d |-- next IndInv ->
  P |-- Preserves IndInv (Sys Prog w d).
Proof.
  intros P Prog IndInv world delta.
  intros Hst_world Hworld Hdiscr.
  unfold Preserves.
  charge_revert.
  charge_intros. unfold Sys.
  decompose_hyps.
  { rewrite <- Hdiscr. unfold Discr.
    charge_tauto. }
  { rewrite <- Hworld.
    simpl. restoreAbstraction.
    unfold World; repeat charge_split; try charge_tauto.
    charge_assert (Exists T : R, "T" = T //\\ ("T") ! <= T).
    { apply Exists_with_st with (t:="T"). intros.
      charge_intros. charge_split; [ charge_assumption | ].
      eapply diff_ind with (G:="T" <= x) (Hyps:=ltrue).
      - compute; tauto.
      - compute; tauto.
      - charge_assumption.
      - unfold mkEvolution.
        intros. simpl. split; auto.
      - simpl next. restoreAbstraction; charge_tauto.
      - solve_linear.
      - charge_tauto.
      - solve_linear. }
    { charge_intros.
      charge_fwd.
      solve_linear. } }
Qed.

Definition SafeAndReactive d (I : StateFormula) (S : ActionFormula)
  : Formula :=
  TimedPreserves d I S //\\ SysNeverStuck d I S.

Lemma SysSystem_TimedPreserves
: forall G I P w d,
  G |-- TimedPreserves d I (Sys P w d) ->
  G |-- SysNeverStuck  d I (Sys P w d) ->
  G |-- TimedPreserves d I (System P w d).
Proof.
  intros. unfold SysNeverStuck, TimedPreserves, Preserves in *.
  rewrite (land_dup G).
  rewrite H at 1.
  rewrite H0.
  charge_revert.
  unfold System.
  charge_intros.
  decompose_hyps.
  - charge_tauto.
  - charge_exfalso. charge_tauto.
Qed.

Theorem SafeAndReactive_TimedPreserves
: forall G I D w d,
  G |-- SafeAndReactive d I (Sys D w d) ->
  G |-- TimedPreserves d I (System D w d).
Proof.
  intros. rewrite H. unfold SafeAndReactive.
  apply SysSystem_TimedPreserves; charge_tauto.
Qed.

Theorem SystemSys
: forall G I P w d,
    G |-- TimedPreserves d I (System P w d) ->
    G |-- TimedPreserves d I (Sys P w d).
Proof.
  unfold TimedPreserves, Preserves. intros.
  rewrite H.
  unfold System. charge_tauto.
Qed.

Definition SysDisjoin_simpl
: forall D1 D2 W d,
    Sys D1 W d \\// Sys D2 W d -|- Sys (D1 \\// D2) W d.
Proof.
  unfold Sys. intros.
  split.
  { decompose_hyps; unfold Discr; charge_tauto. }
  { unfold Discr. decompose_hyps; charge_tauto. }
Qed.

Theorem SysDisjoin_compose
: forall G D1 D2 w d P Q,
    G |-- TimedPreserves d P (Sys D1 w d) ->
    G |-- TimedPreserves d Q (Sys D2 w d) ->
    G |-- TimedPreserves d (P \\// Q) (Sys ((P //\\ D1) \\// (Q //\\ D2)) w d).
Proof.
  intros.
  etransitivity.
  2: eapply Proper_Preserves_lequiv.
  3: symmetry; eapply SysDisjoin_simpl.
  2: reflexivity.
  rewrite land_dup.
  rewrite H at 1; rewrite H0.
  unfold TimedPreserves.
  rewrite Preserves_Or.
  unfold Preserves.
  charge_intros.
  simpl next; restoreAbstraction.
  charge_assert (next P //\\ 0 <= ("T") ! //\\ ("T") ! <= d \\//
                 next Q //\\ 0 <= ("T") ! //\\ ("T") ! <= d).
  { charge_use.
    - charge_revert. charge_revert. charge_clear.
      charge_intros.
      unfold Sys, Discr.
      charge_cases; charge_tauto.
    - charge_revert. charge_clear. charge_intros.
      charge_cases; charge_tauto. }
  { charge_clear. charge_intros; charge_cases; charge_tauto. }
Qed.

Theorem NeverStuck_disjoin
: forall G D1 D2 w d P Q,
    is_st_formula P ->
    is_st_formula Q ->
    G |-- SysNeverStuck d P (Sys D1 w d) ->
    G |-- SysNeverStuck d Q (Sys D2 w d) ->
    G |-- SysNeverStuck d (P \\// Q) (Sys ((P //\\ D1) \\// (Q //\\ D2)) w d).
Proof.
  unfold SysNeverStuck.
  do 7 intro. intros Hst_P Hst_Q.
  intros.
  rewrite land_dup.
  rewrite H at 1; rewrite H0.
  rewrite <- SysDisjoin_simpl.
  rewrite <- Enabled_or.
  charge_intros. charge_cases.
  - charge_left.
    charge_assert (P //\\ Enabled (Sys D1 w d)); [ charge_tauto | ].
    rewrite Enabled_and_push by assumption.
    charge_clear.
    charge_intro. apply Proper_Enabled_lentails.
    unfold Sys, Discr. charge_cases; charge_tauto.
  - charge_right.
    charge_assert (Q //\\ Enabled (Sys D2 w d)); [ charge_tauto | ].
    rewrite Enabled_and_push by assumption.
    apply forget_prem.
    charge_intro. apply Proper_Enabled_lentails.
    unfold Sys, Discr. charge_cases; charge_tauto.
Qed.

(* MOVE *)
Lemma mkEvolution_and
: forall P Q, mkEvolution P //\\ mkEvolution Q -|- mkEvolution (P //\\ Q).
Proof.
  unfold mkEvolution; simpl; intros.
  eapply Evolution_lequiv_lequiv.
  intros. Transparent ChargeCore.Logics.ILInsts.ILFun_Ops.
  simpl. Opaque ChargeCore.Logics.ILInsts.ILFun_Ops.
  restoreAbstraction.
  split; charge_tauto.
Qed.

Definition SysCompose_simpl
: forall D1 D2 W1 W2 d,
    Sys (D1 //\\ D2) (W1 //\\ W2) d |-- Sys D1 W1 d //\\ Sys D2 W2 d.
Proof.
  unfold Sys, Discr, World; intros.
  { repeat charge_cases. charge_tauto.
    charge_right. charge_right.
    rewrite <- mkEvolution_and. rewrite Continuous_and.
    charge_tauto. }
(*
  { repeat charge_cases.
    - charge_tauto.
    - charge_exfalso. solve_linear.
    - charge_exfalso. solve_linear.
    - charge_right. repeat charge_split; try charge_tauto.
      charge_assert (Continuous (mkEvolution W1) //\\
                     Continuous (mkEvolution W2)).
      { charge_tauto. }
      apply forget_prem.
      rewrite Continuous_and_lequiv.
      rewrite mkEvolution_and. charge_tauto. }
*)
Qed.

Lemma Enabled_TimeBound :
  forall d,
    (d > 0)%R ->
    |-- Enabled (next (TimeBound d)).
Proof.
  intros. enable_ex_st. exists d. solve_linear.
Qed.

Definition SysRename_rule
: forall D W d sigma sigma',
    RenameMapOk sigma ->
    sigma "T" = "T" ->
    RenameDerivOk sigma sigma' ->
    Sys (Rename sigma D)
        (fun st' : state =>
           Forall st'' : state,
                         (Forall x : Var, st'' x = sigma' st' x) -->> Rename sigma (W st''))
        d
    |-- Rename sigma (Sys D W d).
Proof.
  intros.
  unfold Sys, Discr, World.
  repeat first [ rewrite Rename_and
               | rewrite Rename_or
               | rewrite Rename_Comp by apply H ].
  simpl; restoreAbstraction. rewrite H0.
  charge_split; [ charge_assumption | ].
  charge_cases; [ charge_left | charge_right ].
  { simpl. restoreAbstraction. charge_tauto. }
  { simpl. restoreAbstraction.
    charge_split; try charge_tauto.
    rewrite <- Rename_Continuous' by eassumption.
    charge_assert (Continuous
     (mkEvolution
        (fun st' : state =>
         Forall st'' : state,
         (Forall x : Var, st'' x = sigma' st' x) -->> Rename sigma (W st'')))).
    { charge_assumption. }
    apply forget_prem.
    charge_intros.
    (** TODO: This is bad. *)
    unfold Continuous.
    repeat (apply lexistsL; intros).
    charge_exists x. charge_exists x0.
    repeat charge_split; try charge_assumption.
    breakAbstraction.
    intros.
    forward_reason.
    unfold is_solution in *.
    destruct H3. exists x1.
    unfold solves_diffeqs in *.
    intros.
    specialize (H3 _ H6).
    revert H3. simpl.
    intros. forward_reason.
    split; eauto.
    rewrite H7; clear H7.
    rewrite <- H3; clear H3.
    red in H1.
    specialize (H1 _ x1).
    destruct H1.
    specialize (H1 "T" z).
    rewrite <- H1.
    unfold deriv_stateF.
    generalize dependent (x3 "T").
    rewrite H0. simpl. intros.
    unfold Ranalysis1.derive.
    eapply Ranalysis1.pr_nu.
    auto. }
Qed.

Definition Sys_rename_formula
: forall D W d sigma sigma',
      RenameMapOk sigma ->
      st_term_renamings D ->
      (forall st', st_term_renamings (W st')) ->
    Sys (rename_formula sigma D)
        (fun st' : state =>
           Forall st'' : state,
                         (Forall x : Var, st'' x = sigma' st' x) -->> rename_formula sigma (W st''))
        d |--
    Sys (Rename sigma D)
        (fun st' : state =>
           Forall st'' : state,
                         (Forall x : Var, st'' x = sigma' st' x) -->> Rename sigma (W st''))
        d.
Proof.
  intros. unfold Sys.
  charge_split.
  { charge_assumption. }
  { charge_revert. charge_clear.
    charge_intros. apply lorL.
    { apply lorR1.
      rewrite Rename_ok; [ reflexivity | assumption | assumption ]. }
    { apply lorR2.
      apply Proper_World_lentails.
      apply Evolution_lentails_lentails.
      intros.
      apply lforall_lentails_m.
      red. intros.
      rewrite Rename_ok; [ reflexivity | auto | assumption ]. } }
Qed.

Ltac sysrename_side_cond :=
  match goal with
  | [ |- forall _ : state, is_st_formula _ ]
    => tlaIntuition; abstract is_st_term_list
  | [ |- NotRenamed _ _ ]
    => reflexivity
  | [ |- _ ] => apply deriv_term_list; reflexivity
  end.

Theorem SysNeverStuck_Sys : forall (d :R) I W D,
    (d >= 0)%R ->
    I //\\ "T" = 0 |-- Enabled (0 <= "T"! <= d //\\ D) ->
    I //\\ 0 < "T" <= d |-- Enabled (World W) ->
    |-- SysNeverStuck d I (Sys D W d).
Proof.
  intros d I W D Hd. intros. unfold SysNeverStuck.
  charge_intros.
  charge_assert ("T" = 0 \\// 0 < "T" <= d).
  { solve_linear. }
  charge_revert.
  charge_clear.
  charge_intros. charge_cases.
  { unfold Sys.
    rewrite <- Enabled_and_push by (compute; tauto).
    charge_split; [ solve_linear | ].
    rewrite <- EnabledLemmas.Enabled_or.
    charge_left. unfold Discr.
    rewrite (landC D). repeat rewrite landA.
    rewrite <- Enabled_and_push by (compute; tauto).
    charge_split; [ charge_assumption | ].
    simpl in *. restoreAbstraction. repeat rewrite <- landA.
    eassumption. }
  { unfold Sys.
    rewrite <- Enabled_and_push by (compute; tauto).
    charge_split;
      [ simpl; restoreAbstraction; charge_assumption | ].
    rewrite <- EnabledLemmas.Enabled_or.
    charge_right. assumption. }
Qed.

Theorem SysNeverStuck_Sys' : forall (d :R) I W D,
    is_st_formula I ->
    (d >= 0)%R ->
    |-- Enabled (I -->> "T" = 0 -->> 0 <= "T"! <= d //\\ D) ->
    |-- Enabled (I -->> 0 < "T" <= d -->> World W) ->
    |-- SysNeverStuck d I (Sys D W d).
Proof.
  intros. eapply SysNeverStuck_Sys; eauto.
  - do 2 charge_revert.
    repeat (rewrite <- Enabled_limpl_st; [ | refine _ ]).
    assumption.
  - do 2 charge_revert.
    repeat (rewrite <- Enabled_limpl_st; [ | refine _ ]).
    assumption.
Qed.

(** TODO: Move Up **)
Lemma TimedPreserves_And_simple
  : forall d I1 I2 A B,
    is_st_formula I1 -> is_st_formula I2 ->
    TimedPreserves d I1 A //\\ TimedPreserves d I2 B
                   |-- TimedPreserves d (I1 //\\ I2) (A //\\ B).
Proof.
  intros. unfold TimedPreserves.
  rewrite Preserves_And_simple.
  eapply Preserves_equiv.
  { simpl; tauto. }
  { simpl; tauto. }
  { split; charge_tauto. }
  { reflexivity. }
Qed.

Lemma TimedPreserves_And
  : forall (d : R) (I1 I2 : StateFormula) (A B : ActionFormula),
   is_st_formula I1 ->
   is_st_formula I2 ->
   TimedPreserves d I1 ((I2 //\\ TimeBound d) //\\ A) //\\
   TimedPreserves d I2 ((I1 //\\ TimeBound d) //\\ B)
   |-- TimedPreserves d (I1 //\\ I2) (A //\\ B).
Proof.
  intros. unfold TimedPreserves, TimeBound.
  rewrite Preserves_And.
  eapply Preserves_equiv.
  { simpl; tauto. }
  { simpl; tauto. }
  { split; charge_tauto. }
  { reflexivity. }
Qed.

Lemma TimedPreserves_intro
  : forall (d : R) (I P G : Formula) (A : ActionFormula),
    G //\\ P |-- TimedPreserves d I A ->
    G |-- TimedPreserves d I (P //\\ A).
Proof.
  unfold TimedPreserves. intros.
  apply Preserves_intro; assumption.
Qed.

Global Instance Proper_TimedPreserves_lentails
  : Proper (eq ==> eq ==> lentails --> lentails) TimedPreserves.
Proof.
  morphism_intro. unfold Basics.flip in *.
  unfold TimedPreserves. subst. rewrite H1. reflexivity.
Qed.

Global Instance Proper_TimedPreserves_lequiv
  : Proper (eq ==> eq ==> lequiv ==> lequiv) TimedPreserves.
Proof.
  morphism_intro. unfold Basics.flip in *.
  unfold TimedPreserves. subst. rewrite H1. reflexivity.
Qed.

Lemma TimedPreserves_Rename
  : forall d (sigma : RenameMap) I A,
    sigma "T" = "T" ->
    RenameMapOk sigma ->
    TimedPreserves d (Rename sigma I) (Rename sigma A) -|- Rename sigma (TimedPreserves d I A).
Proof.
  unfold TimedPreserves, Preserves. intros.
  simpl next. restoreAbstraction.
  autorewrite with rw_rename.
  simpl rename_formula. rewrite H. simpl next_term. restoreAbstraction. reflexivity.
Qed.

(** "Parsing" of [Sys] allows us to recover the benefits of the
 ** deep embedding.
 **)

Inductive SysParse (D : ActionFormula) (w : Evolution) (d : R)
: ActionFormula -> Prop :=
| Parsed : SysParse D w d (Sys D w d).

Existing Class SysParse.
Existing Instance Parsed.

(* Some projection functions. *)
Definition Sys_D (A : ActionFormula)
           {D w d} {SP : SysParse D w d A} : ActionFormula := D.
Arguments Sys_D _ {_ _ _ _} : clear implicits.

Definition Sys_w (A : ActionFormula)
           {D w d} {SP : SysParse D w d A} : Evolution := w.
Arguments Sys_w _ {_ _ _ _} _ : clear implicits.

Definition Sys_d (A : ActionFormula)
           {D w d} {SP : SysParse D w d A} : R := d.
Arguments Sys_d _ {_ _ _ _} : clear implicits.

Definition SysRename (sigma : RenameMap) (sigma' : RenameMapDeriv)
           (A : ActionFormula) {D w d} {SP : SysParse D w d A}
  : ActionFormula :=
    Sys (rename_formula sigma D)
        (fun st' : state =>
           Forall st'' : state,
             (Forall x : Var, st'' x = sigma' st' x) -->>
             rename_formula sigma (w st''))
        d.
Arguments SysRename _ _ _ {_ _ _ _} : clear implicits.

Definition SysCompose (A : ActionFormula) (B : ActionFormula)
           {DA DB wA wB d} {SP_A : SysParse DA wA d A}
           {SP_B : SysParse DB wB d B}
  : ActionFormula :=
  Sys (DA //\\ DB) (wA //\\ wB) d.
Arguments SysCompose _ _ {_ _ _ _ _ _ _} : clear implicits.

Definition SysDisjoin (IA : StateFormula) (A : ActionFormula)
           (IB : StateFormula) (B : ActionFormula)
           {DA DB w d} {SP_A : SysParse DA w d A}
           {SP_B : SysParse DB w d B}
  : ActionFormula :=
  Sys ((IA //\\ DA) \\// (IB //\\ DB)) w d.
Arguments SysDisjoin _ _ _ _ {_ _ _ _ _ _} : clear implicits.

Definition SysSystem (A : ActionFormula)
           {D w d} {SP : SysParse D w d A} : ActionFormula :=
  System D w d.
Arguments SysSystem _ {_ _ _ _} : clear implicits.

Lemma SysCompose_abstract :
  forall A B {DA DB wA wB d} {SP_A : SysParse DA wA d A}
         {SP_B : SysParse DB wB d B},
    SysCompose A B |-- A.
Proof.
  intros. unfold SysCompose. rewrite SysCompose_simpl.
  inversion SP_A. charge_tauto.
Qed.

Theorem SysDisjoin_SafeAndReactive :
  forall DA DB w d IA IB G,
    is_st_formula IA ->
    is_st_formula IB ->
    G |-- SafeAndReactive d IA (Sys DA w d) ->
    G |-- SafeAndReactive d IB (Sys DB w d) ->
    G |-- SafeAndReactive d (IA \\// IB)
                  (SysDisjoin IA (Sys DA w d) IB (Sys DB w d)).
Proof.
  unfold SafeAndReactive. intros. charge_split.
  { apply SysDisjoin_compose; [ rewrite H1 | rewrite H2 ];
    charge_tauto. }
  { apply NeverStuck_disjoin; try assumption;
    [ rewrite H1 | rewrite H2 ];
    charge_tauto. }
Qed.


(** * Functoriality of the construction of adjunctions *)
Require Import Category.Core Functor.Core NaturalTransformation.Core.
Require Import Functor.Identity Functor.Composition.Core.
Require Import NaturalTransformation.Composition.Core NaturalTransformation.Composition.Laws.
Require Import NaturalTransformation.Identity.
Require Import NaturalTransformation.Paths.
Require Import Functor.Dual NaturalTransformation.Dual Category.Dual.
Require Import Adjoint.Core Adjoint.UnitCounit Adjoint.UnitCounitCoercions Adjoint.Dual.
Require Import Adjoint.Composition.Core.
Require Import Adjoint.Functorial.Parts.
Require Import HProp Types.Sigma HoTT.Tactics.

Set Universe Polymorphism.
Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.

Local Open Scope natural_transformation_scope.
Local Open Scope morphism_scope.

Section laws.
  (** Some tactics to handle all the proofs.  The tactics deal with
      the "obvious" commutativity requirements by writing back and
      forth with associativity and respectfulness of composition,
      trying to find applications of the adjunction laws. *)
  Local Ltac try_various_ways tac :=
    progress repeat first [ progress tac
                          | rewrite <- ?Functor.Core.composition_of;
                            progress try_associativity_quick tac
                          | rewrite -> ?Functor.Core.composition_of;
                            progress try_associativity_quick tac ].

  (** This is suboptimal, because we keep rewriting back and forth
      with associativity and [composition_of].  But it only takes 0.74
      seconds total, so it's probably not worth optimizing. *)
  Local Ltac handle_laws' :=
    idtac;
    match goal with
      | _ => reflexivity
      | _ => progress rewrite ?identity_of, ?Category.Core.left_identity, ?Category.Core.right_identity
      | _ => try_various_ways ltac:(f_ap)
      | [ |- context[components_of ?T ?x] ]
        => try_various_ways ltac:(simpl rewrite <- (commutes T))
      | [ |- context[unit ?A] ]
        => try_various_ways ltac:(rewrite (unit_counit_equation_1 A))
      | [ |- context[unit ?A] ]
        => try_various_ways ltac:(rewrite (unit_counit_equation_2 A))
    end.

  Local Ltac t :=
    apply path_natural_transformation; intro;
    cbn;
    repeat handle_laws'.

  Section left.
    Local Arguments unit : simpl never.
    Local Arguments counit : simpl never.

    Section identity_of.
      Context `{Funext}.
      Variables C D : PreCategory.

      Variable G : Functor D C.
      Variable F : Functor C D.
      Variable A : F -| G.

      Definition left_identity_of
      : @left_morphism_of C C 1 D D 1 G F A G F A 1
        = ((left_identity_natural_transformation_2 _)
             o (right_identity_natural_transformation_1 _))%natural_transformation.
      Proof. t. Qed.

      Definition left_identity_of_nondep
      : @left_morphism_of_nondep C D G F A G F A 1 = 1%natural_transformation.
      Proof. t. Qed.
    End identity_of.

    Section composition_of_dep.
      Context `{Funext}.
      Variables C C' C'' : PreCategory.
      Variable CF : Functor C C'.
      Variable CF' : Functor C' C''.
      Variables D D' D'' : PreCategory.
      Variable DF : Functor D D'.
      Variable DF' : Functor D' D''.

      Variable G : Functor D C.
      Variable F : Functor C D.
      Variable A : F -| G.
      Variable G' : Functor D' C'.
      Variable F' : Functor C' D'.
      Variable A' : F' -| G'.
      Variable G'' : Functor D'' C''.
      Variable F'' : Functor C'' D''.
      Variable A'' : F'' -| G''.
      Variable T : NaturalTransformation (CF o G) (G' o DF).
      Variable T' : NaturalTransformation (CF' o G') (G'' o DF').

      Local Open Scope natural_transformation_scope.

      Definition left_composition_of
      : (@left_morphism_of
           _ _ _ _ _ _ _ _
           A _ _ A''
           ((associator_1 _ _ _)
              o (T' oR DF)
              o (associator_2 _ _ _)
              o (CF' oL T)
              o (associator_1 _ _ _)))
        = (associator_2 _ _ _)
            o (DF' oL left_morphism_of A A' T)
            o (associator_1 _ _ _)
            o (left_morphism_of A' A'' T' oR CF)
            o (associator_2 _ _ _).
      Proof. t. Qed.
    End composition_of_dep.

    Section composition_of.
      Context `{Funext}.
      Variables C D : PreCategory.

      Variable G : Functor D C.
      Variable F : Functor C D.
      Variable A : F -| G.
      Variable G' : Functor D C.
      Variable F' : Functor C D.
      Variable A' : F' -| G'.
      Variable G'' : Functor D C.
      Variable F'' : Functor C D.
      Variable A'' : F'' -| G''.
      Variable T : NaturalTransformation G G'.
      Variable T' : NaturalTransformation G' G''.

      Local Open Scope natural_transformation_scope.

      Definition left_composition_of_nondep
      : (@left_morphism_of_nondep _ _ _ _ A _ _ A'' (T' o T))
        = ((left_morphism_of_nondep A A' T)
             o (left_morphism_of_nondep A' A'' T')).
      Proof. t. Qed.
    End composition_of.
  End left.

  Section right.
    Section identity_of.
      Context `{Funext}.
      Variables C D : PreCategory.

      Variable F : Functor C D.
      Variable G : Functor D C.
      Variable A : F -| G.

      Definition right_identity_of
      : @right_morphism_of C C 1 D D 1 F G A F G A 1
        = ((right_identity_natural_transformation_2 _)
             o (left_identity_natural_transformation_1 _))%natural_transformation
        := ap (@NaturalTransformation.Dual.opposite _ _ _ _)
              (@left_identity_of _ _ _ F^op G^op A^op).

      Definition right_identity_of_nondep
      : @right_morphism_of_nondep C D F G A F G A 1 = 1%natural_transformation
        := ap (@NaturalTransformation.Dual.opposite _ _ _ _)
              (@left_identity_of_nondep _ _ _ F^op G^op A^op).
    End identity_of.

    Section composition_of_dep.
      Context `{Funext}.
      Variables C C' C'' : PreCategory.
      Variable CF : Functor C C'.
      Variable CF' : Functor C' C''.
      Variables D D' D'' : PreCategory.
      Variable DF : Functor D D'.
      Variable DF' : Functor D' D''.

      Variable F : Functor C D.
      Variable G : Functor D C.
      Variable A : F -| G.
      Variable F' : Functor C' D'.
      Variable G' : Functor D' C'.
      Variable A' : F' -| G'.
      Variable F'' : Functor C'' D''.
      Variable G'' : Functor D'' C''.
      Variable A'' : F'' -| G''.
      Variable T : NaturalTransformation (F' o CF) (DF o F).
      Variable T' : NaturalTransformation (F'' o CF') (DF' o F').

      Local Open Scope natural_transformation_scope.

      (** This is slow, at about 3.8 s.  It also requires the opposite
          association to unify. *)
      Definition right_composition_of
      : right_morphism_of
          A A''
          ((associator_2 DF' DF F)
             o ((DF' oL T)
                  o ((associator_1 DF' F' CF)
                       o ((T' oR CF)
                            o (associator_2 F'' CF' CF)))))
        = (associator_1 G'' DF' DF)
            o ((right_morphism_of A' A'' T' oR DF)
                 o ((associator_2 CF' G' DF)
                      o ((CF' oL right_morphism_of A A' T)
                           o (associator_1 CF' CF G))))
        := ap (@NaturalTransformation.Dual.opposite _ _ _ _)
              (@left_composition_of
                 _ _ _ _ (DF^op) (DF'^op) _ _ _ (CF^op) (CF'^op)
                 _ _ A^op _ _ A'^op _ _ A''^op T^op T'^op).
    End composition_of_dep.

    Section composition_of.
      Context `{Funext}.
      Variables C D : PreCategory.

      Variable F : Functor C D.
      Variable G : Functor D C.
      Variable A : F -| G.
      Variable F' : Functor C D.
      Variable G' : Functor D C.
      Variable A' : F' -| G'.
      Variable F'' : Functor C D.
      Variable G'' : Functor D C.
      Variable A'' : F'' -| G''.
      Variable T : NaturalTransformation F F'.
      Variable T' : NaturalTransformation F' F''.

      Local Open Scope natural_transformation_scope.

      Definition right_composition_of_nondep
      : (@right_morphism_of_nondep _ _ _ _ A'' _ _ A (T' o T))
        = ((right_morphism_of_nondep A' A T)
             o (right_morphism_of_nondep A'' A' T'))
        := ap (@NaturalTransformation.Dual.opposite _ _ _ _)
              (@left_composition_of_nondep _ _ _ _ _ A''^op _ _ A'^op _ _ A^op T'^op T^op).
    End composition_of.
  End right.
End laws.


Require Import VST.floyd.proofauto.
Require Import sha.sha.
Require Import sha.SHA256.
Require Import sha.sha_lemmas.
Require Import sha.spec_sha.
Local Open Scope nat.
Local Open Scope logic.

Lemma body_SHA256_Init: semax_body Vprog Gtot f_SHA256_Init SHA256_Init_spec.
Proof.
start_function.
name c_ _c.
unfold data_at_.
(* BEGIN: without these lines, the "do 8 forward" takes 40 times as long. *)
unfold field_at_.
unfold_data_at (field_at _ _ _ _ _).
simpl fst; simpl snd.
(* END: without these lines *)
Time do 8 (forward; unfold upd_Znth, sublist; simpl app). (* 21 sec *)
Time repeat forward. (* 14 sec *)
Exists (map Vint init_registers,
      (Vint Int.zero, (Vint Int.zero, (list_repeat (Z.to_nat 64) Vundef, Vint Int.zero)))).
unfold_data_at (data_at _ _ _ _).
Time entailer!. (* 5.2 sec *)
repeat split; auto.
unfold s256_h, fst, s256a_regs.
rewrite hash_blocks_equation. reflexivity.
unfold data_at. apply derives_refl'; f_equal.
f_equal.
simpl.
repeat (apply f_equal2; [f_equal; apply int_eq_e; compute; reflexivity | ]); auto.
Time Qed. (* 33.6 sec *)


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

From PromisingLib Require Import Axioms.
From PromisingLib Require Import Basic.
Require Import Event.
From PromisingLib Require Import Language.
Require Import View.
Require Import Cell.
Require Import Memory.
Require Import TView.
Require Import Local.
Require Import Thread.
Require Import Configuration.

Require Import PromiseConsistent.

Require Import SimMemory.
Require Import SimPromises.
Require Import SimLocal.

Set Implicit Arguments.

Section SimulationThread.
  Variable (lang_src lang_tgt:language).

  Definition SIM_TERMINAL :=
    forall (st_src:(Language.state lang_src)) (st_tgt:(Language.state lang_tgt)), Prop.

  Definition SIM_THREAD :=
    forall (sim_terminal: SIM_TERMINAL)
      (st1_src:(Language.state lang_src)) (lc1_src:Local.t) (sc0_src:TimeMap.t) (mem0_src:Memory.t)
      (st1_tgt:(Language.state lang_tgt)) (lc1_tgt:Local.t) (sc0_tgt:TimeMap.t) (mem0_tgt:Memory.t), Prop.

  Definition _sim_thread_step
             (sim_thread: forall (st1_src:(Language.state lang_src)) (lc1_src:Local.t) (sc0_src:TimeMap.t) (mem0_src:Memory.t)
                            (st1_tgt:(Language.state lang_tgt)) (lc1_tgt:Local.t) (sc0_tgt:TimeMap.t) (mem0_tgt:Memory.t), Prop)
             st1_src lc1_src sc1_src mem1_src
             st1_tgt lc1_tgt sc1_tgt mem1_tgt
    :=
    forall pf_tgt e_tgt st3_tgt lc3_tgt sc3_tgt mem3_tgt
      (STEP_TGT: Thread.step pf_tgt e_tgt
                             (Thread.mk _ st1_tgt lc1_tgt sc1_tgt mem1_tgt)
                             (Thread.mk _ st3_tgt lc3_tgt sc3_tgt mem3_tgt)),
      <<FAILURE: Thread.steps_failure (Thread.mk _ st1_src lc1_src sc1_src mem1_src)>> \/
      exists e_src st2_src lc2_src sc2_src mem2_src st3_src lc3_src sc3_src mem3_src,
        <<FAILURE: e_tgt <> ThreadEvent.failure>> /\
        <<STEPS: rtc (@Thread.tau_step _)
                     (Thread.mk _ st1_src lc1_src sc1_src mem1_src)
                     (Thread.mk _ st2_src lc2_src sc2_src mem2_src)>> /\
        <<STEP_SRC: Thread.opt_step e_src
                                    (Thread.mk _ st2_src lc2_src sc2_src mem2_src)
                                    (Thread.mk _ st3_src lc3_src sc3_src mem3_src)>> /\
        <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
        <<SC3: TimeMap.le sc3_src sc3_tgt>> /\
        <<MEMORY3: sim_memory mem3_src mem3_tgt>> /\
        <<SIM: sim_thread st3_src lc3_src sc3_src mem3_src st3_tgt lc3_tgt sc3_tgt mem3_tgt>>.

  Definition _sim_thread
             (sim_thread: SIM_THREAD)
             (sim_terminal: SIM_TERMINAL)
             (st1_src:(Language.state lang_src)) (lc1_src:Local.t) (sc0_src:TimeMap.t) (mem0_src:Memory.t)
             (st1_tgt:(Language.state lang_tgt)) (lc1_tgt:Local.t) (sc0_tgt:TimeMap.t) (mem0_tgt:Memory.t): Prop :=
    forall sc1_src mem1_src
      sc1_tgt mem1_tgt
      (SC: TimeMap.le sc1_src sc1_tgt)
      (MEMORY: sim_memory mem1_src mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc0_src sc1_src)
      (SC_FUTURE_TGT: TimeMap.le sc0_tgt sc1_tgt)
      (MEM_FUTURE_SRC: Memory.future_weak mem0_src mem1_src)
      (MEM_FUTURE_TGT: Memory.future_weak mem0_tgt mem1_tgt)
      (WF_SRC: Local.wf lc1_src mem1_src)
      (WF_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM_SRC: Memory.closed mem1_src)
      (MEM_TGT: Memory.closed mem1_tgt)
      (CONS_TGT: Local.promise_consistent lc1_tgt),
      <<TERMINAL:
        forall (TERMINAL_TGT: (Language.is_terminal lang_tgt) st1_tgt),
          <<FAILURE: Thread.steps_failure (Thread.mk _ st1_src lc1_src sc1_src mem1_src)>> \/
          exists st2_src lc2_src sc2_src mem2_src,
            <<STEPS: rtc (@Thread.tau_step _)
                         (Thread.mk _ st1_src lc1_src sc1_src mem1_src)
                         (Thread.mk _ st2_src lc2_src sc2_src mem2_src)>> /\
            <<SC: TimeMap.le sc2_src sc1_tgt>> /\
            <<MEMORY: sim_memory mem2_src mem1_tgt>> /\
            <<TERMINAL_SRC: (Language.is_terminal lang_src) st2_src>> /\
            <<LOCAL: sim_local SimPromises.bot lc2_src lc1_tgt>> /\
            <<TERMINAL: sim_terminal st2_src st1_tgt>>>> /\
      <<CAP:
        forall mem2_src
          (CAP_SRC: Memory.cap (Local.promises lc1_src) mem1_src mem2_src),
        exists mem2_tgt,
          <<MEMORY: sim_memory mem2_src mem2_tgt>> /\
          <<CAP_TGT: Memory.cap (Local.promises lc1_tgt) mem1_tgt mem2_tgt>>>> /\
      <<PROMISES:
        forall (PROMISES_TGT: (Local.promises lc1_tgt) = Memory.bot)
          (NORESERVE: Memory.no_reserve mem1_tgt),
          <<FAILURE: Thread.steps_failure (Thread.mk _ st1_src lc1_src sc1_src mem1_src)>> \/
          exists st2_src lc2_src sc2_src mem2_src,
            <<STEPS: rtc (@Thread.tau_step _)
                         (Thread.mk _ st1_src lc1_src sc1_src mem1_src)
                         (Thread.mk _ st2_src lc2_src sc2_src mem2_src)>> /\
            <<PROMISES_SRC: (Local.promises lc2_src) = Memory.bot>>>> /\
      <<STEP: _sim_thread_step (sim_thread sim_terminal)
                               st1_src lc1_src sc1_src mem1_src
                               st1_tgt lc1_tgt sc1_tgt mem1_tgt>>.

  Lemma _sim_thread_mon: monotone9 _sim_thread.
  Proof.
    ii. exploit IN; try apply SC; eauto. i. des.
    splits; eauto. ii.
    exploit STEP; eauto. i. des; eauto.
    right. esplits; eauto.
  Qed.
  #[local]
  Hint Resolve _sim_thread_mon: paco.

  Definition sim_thread: SIM_THREAD := paco9 _sim_thread bot9.

  Lemma sim_thread_mon
        sim_terminal1 sim_terminal2
        (SIM: sim_terminal1 <2= sim_terminal2):
    sim_thread sim_terminal1 <8= sim_thread sim_terminal2.
  Proof.
    pcofix CIH. i. punfold PR. pfold. ii.
    exploit PR; try apply SC; eauto. i. des.
    splits; auto.
    - i. exploit TERMINAL; eauto. i. des; eauto.
      right. esplits; eauto.
    - ii. exploit STEP; eauto. i. des; eauto.
      inv SIM0; [|done].
      right. esplits; eauto.
  Qed.
End SimulationThread.
#[export]
Hint Resolve _sim_thread_mon: paco.

Lemma sim_thread_step
      lang_src lang_tgt
      sim_terminal
      pf_tgt e_tgt
      st1_src lc1_src sc1_src mem1_src
      st1_tgt lc1_tgt sc1_tgt mem1_tgt
      st3_tgt lc3_tgt sc3_tgt mem3_tgt
      (STEP: @Thread.step lang_tgt pf_tgt e_tgt
                          (Thread.mk _ st1_tgt lc1_tgt sc1_tgt mem1_tgt)
                          (Thread.mk _ st3_tgt lc3_tgt sc3_tgt mem3_tgt))
      (SC: TimeMap.le sc1_src sc1_tgt)
      (MEMORY: sim_memory mem1_src mem1_tgt)
      (WF_SRC: Local.wf lc1_src mem1_src)
      (WF_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM_SRC: Memory.closed mem1_src)
      (MEM_TGT: Memory.closed mem1_tgt)
      (CONS_TGT: Local.promise_consistent lc3_tgt)
      (SIM: sim_thread sim_terminal st1_src lc1_src sc1_src mem1_src st1_tgt lc1_tgt sc1_tgt mem1_tgt):
  <<FAILURE: Thread.steps_failure (Thread.mk lang_src st1_src lc1_src sc1_src mem1_src)>> \/
  exists e_src st2_src lc2_src sc2_src mem2_src st3_src lc3_src sc3_src mem3_src,
    <<FAILURE: e_tgt <> ThreadEvent.failure>> /\
    <<STEPS: rtc (@Thread.tau_step lang_src)
                 (Thread.mk _ st1_src lc1_src sc1_src mem1_src)
                 (Thread.mk _ st2_src lc2_src sc2_src mem2_src)>> /\
    <<STEP: Thread.opt_step e_src
                            (Thread.mk _ st2_src lc2_src sc2_src mem2_src)
                            (Thread.mk _ st3_src lc3_src sc3_src mem3_src)>> /\
    <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
    <<SC: TimeMap.le sc3_src sc3_tgt>> /\
    <<MEMORY: sim_memory mem3_src mem3_tgt>> /\
    <<WF_SRC: Local.wf lc3_src mem3_src>> /\
    <<WF_TGT: Local.wf lc3_tgt mem3_tgt>> /\
    <<SC_SRC: Memory.closed_timemap sc3_src mem3_src>> /\
    <<SC_TGT: Memory.closed_timemap sc3_tgt mem3_tgt>> /\
    <<MEM_SRC: Memory.closed mem3_src>> /\
    <<MEM_TGT: Memory.closed mem3_tgt>> /\
    <<SIM: sim_thread sim_terminal st3_src lc3_src sc3_src mem3_src st3_tgt lc3_tgt sc3_tgt mem3_tgt>>.
Proof.
  hexploit step_promise_consistent; eauto. s. i.
  punfold SIM. exploit SIM; eauto; try refl. i. des.
  exploit Thread.step_future; eauto. s. i. des.
  exploit STEP0; eauto. i. des; eauto.
  inv SIM0; [|done]. right.
  exploit Thread.rtc_tau_step_future; eauto. s. i. des.
  exploit Thread.opt_step_future; eauto. s. i. des.
  esplits; eauto.
Qed.

Lemma sim_thread_opt_step
      lang_src lang_tgt
      sim_terminal
      e_tgt
      st1_src lc1_src sc1_src mem1_src
      st1_tgt lc1_tgt sc1_tgt mem1_tgt
      st3_tgt lc3_tgt sc3_tgt mem3_tgt
      (STEP: @Thread.opt_step lang_tgt e_tgt
                              (Thread.mk _ st1_tgt lc1_tgt sc1_tgt mem1_tgt)
                              (Thread.mk _ st3_tgt lc3_tgt sc3_tgt mem3_tgt))
      (SC: TimeMap.le sc1_src sc1_tgt)
      (MEMORY: sim_memory mem1_src mem1_tgt)
      (WF_SRC: Local.wf lc1_src mem1_src)
      (WF_TGT: Local.wf lc1_tgt mem1_tgt)
      (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
      (MEM_SRC: Memory.closed mem1_src)
      (MEM_TGT: Memory.closed mem1_tgt)
      (CONS_TGT: Local.promise_consistent lc3_tgt)
      (SIM: sim_thread sim_terminal st1_src lc1_src sc1_src mem1_src st1_tgt lc1_tgt sc1_tgt mem1_tgt):
  <<FAILURE: Thread.steps_failure (Thread.mk lang_src st1_src lc1_src sc1_src mem1_src)>> \/
  exists e_src st2_src lc2_src sc2_src mem2_src st3_src lc3_src sc3_src mem3_src,
    <<FAILURE: e_tgt <> ThreadEvent.failure>> /\
    <<STEPS: rtc (@Thread.tau_step lang_src)
                 (Thread.mk _ st1_src lc1_src sc1_src mem1_src)
                 (Thread.mk _ st2_src lc2_src sc2_src mem2_src)>> /\
    <<STEP: Thread.opt_step e_src
                            (Thread.mk _ st2_src lc2_src sc2_src mem2_src)
                            (Thread.mk _ st3_src lc3_src sc3_src mem3_src)>> /\
    <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
    <<SC: TimeMap.le sc3_src sc3_tgt>> /\
    <<MEMORY: sim_memory mem3_src mem3_tgt>> /\
    <<WF_SRC: Local.wf lc3_src mem3_src>> /\
    <<WF_TGT: Local.wf lc3_tgt mem3_tgt>> /\
    <<SC_SRC: Memory.closed_timemap sc3_src mem3_src>> /\
    <<SC_TGT: Memory.closed_timemap sc3_tgt mem3_tgt>> /\
    <<MEM_SRC: Memory.closed mem3_src>> /\
    <<MEM_TGT: Memory.closed mem3_tgt>> /\
    <<SIM: sim_thread sim_terminal st3_src lc3_src sc3_src mem3_src st3_tgt lc3_tgt sc3_tgt mem3_tgt>>.
Proof.
  inv STEP.
  - right. esplits; eauto; ss. econs 1.
  - eapply sim_thread_step; eauto.
Qed.

Lemma sim_thread_rtc_step
      lang_src lang_tgt
      sim_terminal
      st1_src lc1_src sc1_src mem1_src
      e1_tgt e2_tgt
      (STEPS: rtc (@Thread.tau_step lang_tgt) e1_tgt e2_tgt)
      (SC: TimeMap.le sc1_src (Thread.sc e1_tgt))
      (MEMORY: sim_memory mem1_src (Thread.memory e1_tgt))
      (WF_SRC: Local.wf lc1_src mem1_src)
      (WF_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
      (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
      (MEM_SRC: Memory.closed mem1_src)
      (MEM_TGT: Memory.closed (Thread.memory e1_tgt))
      (CONS_TGT: Local.promise_consistent (Thread.local e2_tgt))
      (SIM: sim_thread sim_terminal st1_src lc1_src sc1_src mem1_src (Thread.state e1_tgt) (Thread.local e1_tgt) (Thread.sc e1_tgt) (Thread.memory e1_tgt)):
  <<FAILURE: Thread.steps_failure (Thread.mk lang_src st1_src lc1_src sc1_src mem1_src)>> \/
  exists st2_src lc2_src sc2_src mem2_src,
    <<STEPS: rtc (@Thread.tau_step lang_src)
                 (Thread.mk _ st1_src lc1_src sc1_src mem1_src)
                 (Thread.mk _ st2_src lc2_src sc2_src mem2_src)>> /\
    <<SC: TimeMap.le sc2_src (Thread.sc e2_tgt)>> /\
    <<MEMORY: sim_memory mem2_src (Thread.memory e2_tgt)>> /\
    <<WF_SRC: Local.wf lc2_src mem2_src>> /\
    <<WF_TGT: Local.wf (Thread.local e2_tgt) (Thread.memory e2_tgt)>> /\
    <<SC_SRC: Memory.closed_timemap sc2_src mem2_src>> /\
    <<SC_TGT: Memory.closed_timemap (Thread.sc e2_tgt) (Thread.memory e2_tgt)>> /\
    <<MEM_SRC: Memory.closed mem2_src>> /\
    <<MEM_TGT: Memory.closed (Thread.memory e2_tgt)>> /\
    <<SIM: sim_thread sim_terminal st2_src lc2_src sc2_src mem2_src (Thread.state e2_tgt) (Thread.local e2_tgt) (Thread.sc e2_tgt) (Thread.memory e2_tgt)>>.
Proof.
  revert SC MEMORY WF_SRC WF_TGT SC_SRC SC_TGT MEM_SRC MEM_TGT SIM.
  revert st1_src lc1_src sc1_src mem1_src.
  induction STEPS; i.
  { right. esplits; eauto. }
  inv H. inv TSTEP. destruct x, y. ss.
  exploit Thread.step_future; eauto. s. i. des.
  hexploit rtc_tau_step_promise_consistent; eauto. s. i.
  exploit sim_thread_step; eauto. i. des; eauto.
  exploit IHSTEPS; eauto. i. des.
  - left. inv FAILURE0. des.
    unfold Thread.steps_failure. esplits; [|eauto].
    etrans; eauto. etrans; eauto. inv STEP0; eauto.
    econs 2; eauto. econs.
    + econs. eauto.
    + destruct e, e_src; ss.
  - right. destruct z. ss.
    esplits; try apply MEMORY1; eauto.
    etrans; [eauto|]. etrans; [|eauto]. inv STEP0; eauto.
    econs 2; eauto. econs.
    + econs. eauto.
    + destruct e, e_src; ss.
Qed.

Lemma sim_thread_plus_step
      lang_src lang_tgt
      sim_terminal
      pf_tgt e_tgt
      st1_src lc1_src sc1_src mem1_src
      e1_tgt e2_tgt e3_tgt
      (STEPS: rtc (@Thread.tau_step lang_tgt) e1_tgt e2_tgt)
      (STEP: @Thread.step lang_tgt pf_tgt e_tgt e2_tgt e3_tgt)
      (SC: TimeMap.le sc1_src (Thread.sc e1_tgt))
      (MEMORY: sim_memory mem1_src (Thread.memory e1_tgt))
      (WF_SRC: Local.wf lc1_src mem1_src)
      (WF_TGT: Local.wf (Thread.local e1_tgt) (Thread.memory e1_tgt))
      (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
      (SC_TGT: Memory.closed_timemap (Thread.sc e1_tgt) (Thread.memory e1_tgt))
      (MEM_SRC: Memory.closed mem1_src)
      (MEM_TGT: Memory.closed (Thread.memory e1_tgt))
      (CONS_TGT: Local.promise_consistent (Thread.local e3_tgt))
      (SIM: sim_thread sim_terminal st1_src lc1_src sc1_src mem1_src (Thread.state e1_tgt) (Thread.local e1_tgt) (Thread.sc e1_tgt) (Thread.memory e1_tgt)):
  <<FAILURE: Thread.steps_failure (Thread.mk lang_src st1_src lc1_src sc1_src mem1_src)>> \/
  exists e_src st2_src lc2_src sc2_src mem2_src st3_src lc3_src sc3_src mem3_src,
    <<FAILURE: e_tgt <> ThreadEvent.failure>> /\
    <<STEPS: rtc (@Thread.tau_step lang_src)
                 (Thread.mk _ st1_src lc1_src sc1_src mem1_src)
                 (Thread.mk _ st2_src lc2_src sc2_src mem2_src)>> /\
    <<STEP: Thread.opt_step e_src
                            (Thread.mk _ st2_src lc2_src sc2_src mem2_src)
                            (Thread.mk _ st3_src lc3_src sc3_src mem3_src)>> /\
    <<EVENT: ThreadEvent.get_machine_event e_src = ThreadEvent.get_machine_event e_tgt>> /\
    <<SC: TimeMap.le sc3_src (Thread.sc e3_tgt)>> /\
    <<MEMORY: sim_memory mem3_src (Thread.memory e3_tgt)>> /\
    <<WF_SRC: Local.wf lc3_src mem3_src>> /\
    <<WF_TGT: Local.wf (Thread.local e3_tgt) (Thread.memory e3_tgt)>> /\
    <<SC_SRC: Memory.closed_timemap sc3_src mem3_src>> /\
    <<SC_TGT: Memory.closed_timemap (Thread.sc e3_tgt) (Thread.memory e3_tgt)>> /\
    <<MEM_SRC: Memory.closed mem3_src>> /\
    <<MEM_TGT: Memory.closed (Thread.memory e3_tgt)>> /\
    <<SIM: sim_thread sim_terminal st3_src lc3_src sc3_src mem3_src (Thread.state e3_tgt) (Thread.local e3_tgt) (Thread.sc e3_tgt) (Thread.memory e3_tgt)>>.
Proof.
  destruct e1_tgt, e2_tgt, e3_tgt. ss.
  exploit Thread.rtc_tau_step_future; eauto. s. i. des.
  hexploit step_promise_consistent; eauto. s. i.
  exploit sim_thread_rtc_step; eauto. s. i. des; eauto.
  exploit Thread.rtc_tau_step_future; try exact STEPS0; eauto. s. i. des.
  exploit sim_thread_step; try exact STEP; try exact SIM0; eauto. s. i. des.
  - left. inv FAILURE. des.
    unfold Thread.steps_failure. esplits; [|eauto].
    etrans; eauto.
  - right. rewrite STEPS1 in STEPS0.
    esplits; try exact STEPS0; try exact STEP0; eauto.
Qed.

Lemma sim_thread_future
      lang_src lang_tgt
      sim_terminal
      st_src lc_src sc1_src sc2_src mem1_src mem2_src
      st_tgt lc_tgt sc1_tgt sc2_tgt mem1_tgt mem2_tgt
      (SIM: @sim_thread lang_src lang_tgt sim_terminal st_src lc_src sc1_src mem1_src st_tgt lc_tgt sc1_tgt mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc1_src sc2_src)
      (SC_FUTURE_TGT: TimeMap.le sc1_tgt sc2_tgt)
      (MEM_FUTURE_SRC: Memory.future_weak mem1_src mem2_src)
      (MEM_FUTURE_TGT: Memory.future_weak mem1_tgt mem2_tgt):
  sim_thread sim_terminal st_src lc_src sc2_src mem2_src st_tgt lc_tgt sc2_tgt mem2_tgt.
Proof.
  pfold. ii.
  punfold SIM. exploit SIM; (try by etrans; eauto); eauto.
Qed.

Lemma cap_property
      mem1 mem2 lc sc
      (CAP: Memory.cap (Local.promises lc) mem1 mem2)
      (WF: Local.wf lc mem1)
      (SC: Memory.closed_timemap sc mem1)
      (CLOSED: Memory.closed mem1):
  <<FUTURE: Memory.future_weak mem1 mem2>> /\
  <<WF: Local.wf lc mem2>> /\
  <<SC: Memory.closed_timemap sc mem2>> /\
  <<CLOSED: Memory.closed mem2>> /\
  <<NORESERVE: Memory.no_reserve_except (Local.promises lc) mem2>>.
Proof.
  splits.
  - eapply Memory.cap_future_weak; eauto.
  - eapply Local.cap_wf; eauto.
  - eapply Memory.cap_closed_timemap; eauto.
  - eapply Memory.cap_closed; eauto.
  - eapply Memory.cap_no_reserve_except; eauto. apply WF.
Qed.

Lemma sc_property
      sc1 sc2 mem
      (MAX: Memory.max_full_timemap mem sc2)
      (SC1: Memory.closed_timemap sc1 mem)
      (MEM: Memory.closed mem):
  <<SC2: Memory.closed_timemap sc2 mem>> /\
  <<LE: TimeMap.le sc1 sc2>>.
Proof.
  splits.
  - eapply Memory.max_full_timemap_closed; eauto.
  - eapply Memory.max_full_timemap_spec; eauto.
Qed.

Lemma sim_thread_consistent
      lang_src lang_tgt
      sim_terminal
      st_src lc_src sc_src mem_src
      st_tgt lc_tgt sc_tgt mem_tgt
      (SIM: sim_thread sim_terminal st_src lc_src sc_src mem_src st_tgt lc_tgt sc_tgt mem_tgt)
      (SC: TimeMap.le sc_src sc_tgt)
      (MEMORY: sim_memory mem_src mem_tgt)
      (WF_SRC: Local.wf lc_src mem_src)
      (WF_TGT: Local.wf lc_tgt mem_tgt)
      (SC_SRC: Memory.closed_timemap sc_src mem_src)
      (SC_TGT: Memory.closed_timemap sc_tgt mem_tgt)
      (MEM_SRC: Memory.closed mem_src)
      (MEM_TGT: Memory.closed mem_tgt)
      (CONSISTENT: Thread.consistent (Thread.mk lang_tgt st_tgt lc_tgt sc_tgt mem_tgt)):
  Thread.consistent (Thread.mk lang_src st_src lc_src sc_src mem_src).
Proof.
  hexploit consistent_promise_consistent; eauto. s. i.
  generalize SIM. intro X.
  punfold X. exploit X; eauto; try refl. i. des.
  ii. ss.
  exploit CAP; eauto. i. des.
  exploit cap_property; try exact CAP0; eauto. i. des.
  exploit cap_property; try exact CAP_TGT; eauto. i. des.
  exploit Memory.max_full_timemap_exists; try apply CLOSED0. i. des.
  exploit sim_memory_max_full_timemap; try exact MEMORY0; eauto. i. subst.
  exploit sc_property; try exact SC_MAX; eauto. i. des.
  exploit sc_property; try exact x0; eauto. i. des.
  exploit CONSISTENT; eauto. s. i. des.
  - left. inv FAILURE. des.
    exploit sim_thread_future; try exact SIM; try exact LE; try exact LE0; eauto. i.
    exploit sim_thread_plus_step; try exact STEPS; try exact FAILURE; try exact x2; eauto; try refl.
    { inv FAILURE; inv STEP0. inv LOCAL. inv LOCAL0. ss. }
    i. des; auto. ss.
  - hexploit Local.bot_promise_consistent; eauto. i.
    exploit sim_thread_future; try exact SIM; try exact LE; try exact LE0; eauto. i.
    exploit sim_thread_rtc_step; try apply STEPS; try exact x1; eauto; try refl. i. des; eauto.
    destruct e2. ss.
    punfold SIM0. exploit SIM0; eauto; try refl. i. des.
    hexploit Thread.rtc_tau_step_no_reserve_except; try exact STEPS; eauto. i.
    unfold Thread.no_reserve_except in *. ss.
    rewrite PROMISES0 in *.
    hexploit Memory.no_reserve_except_bot_no_reserve; try apply MEM_TGT0; eauto. i.
    exploit PROMISES1; eauto. i. des.
    + left. unfold Thread.steps_failure in *. des.
      esplits; [|eauto]. etrans; eauto.
    + right. eexists (Thread.mk _ _ _ _ _). splits; [|eauto].
      etrans; eauto.
Qed.


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

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

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

Definition POINTER_BOUNDARY : Z := 1024.

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

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

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

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

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

#[export] Hint Resolve treerep_local_facts : saturate_local.

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

Definition int_or_ptr_to_int_spec :=
 DECLARE _int_or_ptr_to_int
 WITH x : val
 PRE [ int_or_ptr_type ]
   PROP(is_int I32 Signed x) PARAMS (x) SEP()
 POST [ tint ]
   PROP() RETURN (x) SEP().

Definition int_or_ptr_to_ptr_spec :=
 DECLARE _int_or_ptr_to_ptr
 WITH x : val
 PRE [ int_or_ptr_type ]
   PROP(isptr x) PARAMS (x) SEP()
 POST [ tptr tvoid ]
   PROP() RETURN (x) SEP().

Definition int_to_int_or_ptr_spec :=
 DECLARE _int_to_int_or_ptr
 WITH x : val
 PRE [ tint ]
   PROP(valid_int_or_ptr x) PARAMS(x) SEP()
 POST [ int_or_ptr_type ]
   PROP() RETURN(x) SEP().

Definition ptr_to_int_or_ptr_spec :=
 DECLARE _ptr_to_int_or_ptr
 WITH x : val
 PRE [ tptr tvoid ]
   PROP(valid_int_or_ptr x) PARAMS(x) SEP()
 POST [ int_or_ptr_type ]
   PROP() RETURN(x) SEP().

Definition makenode_spec :=
 DECLARE _makenode
  WITH p: val, q: val
  PRE [ int_or_ptr_type, int_or_ptr_type ]
    PROP() PARAMS(p; q) SEP()
  POST [ tptr (Tstruct _tree noattr) ]
    EX r:val,
    PROP() RETURN (r)
    SEP (data_at Tsh (Tstruct _tree noattr) (p,q) r).

Definition copytree_spec :=
 DECLARE _copytree
  WITH t: tree, p : val
  PRE  [ int_or_ptr_type ]
    PROP() PARAMS (p) SEP (treerep t p)
  POST [ int_or_ptr_type ]
    EX v:val,
    PROP() RETURN (v)
    SEP (treerep t p; treerep t v).

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

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


(* *********************************************************************)
(*                                                                     *)
(*              The Compcert verified compiler                         *)
(*                                                                     *)
(*          Xavier Leroy, INRIA Paris-Rocquencourt                     *)
(*                                                                     *)
(*  Copyright Institut National de Recherche en Informatique et en     *)
(*  Automatique.  All rights reserved.  This file is distributed       *)
(*  under the terms of the INRIA Non-Commercial License Agreement.     *)
(*                                                                     *)
(* *********************************************************************)

(** Linearization of the control-flow graph:
    translation from LTL to LTLin *)

Require Import Coqlib.
Require Import Maps.
Require Import Ordered.
Require Import FSets.
Require FSetAVL.
Require Import AST.
Require Import Values.
Require Import Globalenvs.
Require Import Errors.
Require Import Op.
Require Import Locations.
Require Import LTL.
Require Import LTLin.
Require Import Kildall.
Require Import Lattice.

Open Scope error_monad_scope.

(** To translate from LTL to LTLin, we must lay out the nodes
  of the LTL control-flow graph in some linear order, and insert
  explicit branches and conditional branches to make sure that
  each node jumps to its successors as prescribed by the
  LTL control-flow graph.  However, branches are not necessary
  if the fall-through behaviour of LTLin instructions already
  implements the desired flow of control.  For instance,
  consider the two LTL instructions
<<
    L1: Lop op args res L2
    L2: ...
>>
  If the instructions [L1] and [L2] are laid out consecutively in the LTLin
  code, we can generate the following LTLin code:
<<
    L1: Lop op args res
    L2: ...
>>
  However, if this is not possible, an explicit [Lgoto] is needed:
<<
    L1: Lop op args res
        Lgoto L2
        ...
    L2: ...
>>
  The main challenge in code linearization is therefore to pick a
  ``good'' order for the nodes that exploits well the
  fall-through behavior.  Many clever trace picking heuristics
  have been developed for this purpose.

  In this file, we present linearization in a way that clearly
  separates the heuristic part (choosing an order for the basic blocks)
  from the actual code transformation parts.  We proceed in two passes:
- Choosing an order for the nodes.  This returns an enumeration of CFG
  nodes stating that they must be laid out in the order shown in the
  list.
- Generate LTLin code where each node branches explicitly to its
  successors, except if one of these successors is the immediately
  following instruction.

  The beauty of this approach is that correct code is generated
  under surprisingly weak hypotheses on the enumeration of
  CFG nodes: it suffices that every reachable instruction occurs
  exactly once in the enumeration.  We therefore follow an approach
  based on validation a posteriori: a piece of untrusted Caml code
  implements the node enumeration heuristics, and the resulting
  enumeration is checked for correctness by Coq functions that are
  proved to be sound.
*)

(** * Determination of the order of basic blocks *)

(** We first compute a mapping from CFG nodes to booleans,
  indicating whether a CFG instruction is reachable or not.
  This computation is a trivial forward dataflow analysis
  where the transfer function is the identity: the successors
  of a reachable instruction are reachable, by the very
  definition of reachability. *)

Module DS := Dataflow_Solver(LBoolean)(NodeSetForward).

Definition reachable_aux (f: LTL.function) : option (PMap.t bool) :=
  DS.fixpoint
    (successors f)
    (fun pc r => r)
    ((f.(fn_entrypoint), true) :: nil).

Definition reachable (f: LTL.function) : PMap.t bool :=
  match reachable_aux f with
  | None => PMap.init true
  | Some rs => rs
  end.

(** We then enumerate the nodes of reachable instructions.
  This task is performed by external, untrusted Caml code. *)

Parameter enumerate_aux: LTL.function -> PMap.t bool -> list node.

(** Now comes the a posteriori validation of a node enumeration. *)

Module Nodeset := FSetAVL.Make(OrderedPositive).

(** Build a [Nodeset.t] from a list of nodes, checking that the list
  contains no duplicates. *)

Fixpoint nodeset_of_list (l: list node) (s: Nodeset.t)
                         {struct l}: res Nodeset.t :=
  match l with
  | nil => OK s
  | hd :: tl =>
      if Nodeset.mem hd s
      then Error (msg "Linearize: duplicates in enumeration")
      else nodeset_of_list tl (Nodeset.add hd s)
  end.

Definition check_reachable_aux
     (reach: PMap.t bool) (s: Nodeset.t)
     (ok: bool) (pc: node) (i: LTL.instruction) : bool :=
  if reach!!pc then ok && Nodeset.mem pc s else ok.

Definition check_reachable
     (f: LTL.function) (reach: PMap.t bool) (s: Nodeset.t) : bool :=
  PTree.fold (check_reachable_aux reach s) f.(LTL.fn_code) true.

Definition enumerate (f: LTL.function) : res (list node) :=
  let reach := reachable f in
  let enum := enumerate_aux f reach in
  do s <- nodeset_of_list enum Nodeset.empty;
  if check_reachable f reach s
  then OK enum
  else Error (msg "Linearize: wrong enumeration").

(** * Translation from LTL to LTLin *)

(** We now flatten the structure of the CFG graph, laying out
  LTL instructions consecutively in the order computed by [enumerate],
  and inserting branches to the labels of sucessors if necessary.
  Whether to insert a branch or not is determined by
  the [starts_with] function below.

  For LTL conditional branches [Lcond cond args s1 s2],
  we have two possible translations:
<<
      Lcond cond args s1;       or     Lcond (not cond) args s2;
      Lgoto s2                         Lgoto s1
>>
  We favour the first translation if [s2] is the label of the
  next instruction, and the second if [s1] is the label of the
  next instruction, thus avoiding the insertion of a redundant [Lgoto]
  instruction. *)

Fixpoint starts_with (lbl: label) (k: code) {struct k} : bool :=
  match k with
  | Llabel lbl' :: k' => if peq lbl lbl' then true else starts_with lbl k'
  | _ => false
  end.

Definition add_branch (s: label) (k: code) : code :=
  if starts_with s k then k else Lgoto s :: k.

Definition linearize_instr (b: LTL.instruction) (k: code) : code :=
  match b with
  | LTL.Lnop s =>
      add_branch s k
  | LTL.Lop op args res s =>
      Lop op args res :: add_branch s k
  | LTL.Lload chunk addr args dst s =>
      Lload chunk addr args dst :: add_branch s k
  | LTL.Lstore chunk addr args src s =>
      Lstore chunk addr args src :: add_branch s k
  | LTL.Lcall sig ros args res s =>
      Lcall sig ros args res :: add_branch s k
  | LTL.Ltailcall sig ros args =>
      Ltailcall sig ros args :: k
  | LTL.Lbuiltin ef args res s =>
      Lbuiltin ef args res :: add_branch s k
  | LTL.Lcond cond args s1 s2 =>
      if starts_with s1 k then
        Lcond (negate_condition cond) args s2 :: add_branch s1 k
      else
        Lcond cond args s1 :: add_branch s2 k
  | LTL.Ljumptable arg tbl =>
      Ljumptable arg tbl :: k
  | LTL.Lreturn or =>
      Lreturn or :: k
  end.

(** Linearize a function body according to an enumeration of its nodes.  *)

Fixpoint linearize_body (f: LTL.function) (enum: list node)
                        {struct enum} : code :=
  match enum with
  | nil => nil
  | pc :: rem =>
      match f.(LTL.fn_code)!pc with
      | None => linearize_body f rem
      | Some b => Llabel pc :: linearize_instr b (linearize_body f rem)
      end
  end.

(** * Entry points for code linearization *)

Definition transf_function (f: LTL.function) : res LTLin.function :=
  do enum <- enumerate f;
  OK (mkfunction
       (LTL.fn_sig f)
       (LTL.fn_params f)
       (LTL.fn_stacksize f)
       (add_branch (LTL.fn_entrypoint f) (linearize_body f enum))).

Definition transf_fundef (f: LTL.fundef) : res LTLin.fundef :=
  AST.transf_partial_fundef transf_function f.

Definition transf_program (p: LTL.program) : res LTLin.program :=
  transform_partial_program transf_fundef p.


(* (c) Copyright 2006-2018 Microsoft Corporation and Inria.                  *)
(* Distributed under the terms of CeCILL-B.                                  *)
From mathcomp Require Import ssreflect ssrfun ssrbool ssrnat seq.
From fourcolor Require Import cfmap cfreducible configurations present.
From fourcolor Require Import task001to214 task215to234 task235to282.
From fourcolor Require Import task283to302 task303to322 task323to485.
From fourcolor Require Import task486to506 task507to541 task542to588.
From fourcolor Require Import task589to633.

(******************************************************************************)
(*   C-reducibility of all the configurations in the_configs, collating the   *)
(* proofs by reflection in all the [job|task]MMMtoMMM.v files.                *)
(******************************************************************************)

Lemma the_reducibility : reducibility.
Proof.
rewrite /reducibility; apply cat_reducible_range with 322.
  CatReducible red000to214 red214to234 red234to282 red282to302 red302to322.
CatReducible red322to485 red485to506 red506to541 red541to588 red588to633.
Qed.