From stdpp Require Import finite vector.
From trillium.prelude Require Import finitary classical quantifiers.
From trillium.program_logic Require Import traces.
From aneris.prelude Require Import misc.
From aneris.prelude Require Import time.
From aneris.aneris_lang Require Import state_interp adequacy.
From aneris.aneris_lang Require Import tactics proofmode.
From aneris.examples.gcounter_convergence Require Import
     crdt_model crdt_resources crdt_runner vc.
From trillium.traces Require Import trace_properties.

Import InfListNotations.

Local Instance: ∀ gcdata st st', ProofIrrel (GCounterM gcdata st st').
Proof. intros ?????; apply ProofIrrelevance. Qed.

Lemma GcounterM_rel_finitary gcdata : aneris_model_rel_finitary (GCounterM gcdata).
Proof.
  intros st.
  apply finite_smaller_card_nat.
  apply (@in_list_finite
            _ _ (λ st', GCounterM gcdata st st') _
            (all_crdt_states_smaller (GClen gcdata) (vmap S (max_vc st)))).
  intros ? ?.
  apply elem_of_all_crdt_states_smaller.
  intros ?.
  apply crdt_next_bounded; done.
Qed.

Definition oloc_less_defined (ol ol' : option loc) : Prop :=
  match ol with
  | Some l =>
    match ol' with
    | Some l' => l' = l
    | None => False
    end
  | None => True
  end.

Global Instance oloc_less_defined_PO : PartialOrder oloc_less_defined.
Proof.
  constructor; first constructor.
  - intros []; split; auto.
  - intros [] [] [] [] []; split; intros; simplify_eq/=; eauto.
  - intros [] [] [] []; auto.
Qed.

Definition locs_less_defined (locs locs' : list (option loc)) : Prop :=
  Forall2 oloc_less_defined locs locs'.

Lemma locs_less_defined_lookup locs locs' i :
  locs_less_defined locs locs' → oloc_less_defined (locs !!! i) (locs' !!! i).
Proof.
  rewrite /locs_less_defined Forall2_lookup.
  intros Hlocs.
  specialize (Hlocs i).
  rewrite !list_lookup_total_alt.
  destruct (locs !! i); destruct (locs' !! i); inversion Hlocs; simplify_eq; done.
Qed.

Global Instance locs_less_defined_PO : PartialOrder locs_less_defined.
Proof.
  constructor; first constructor.
  - intros l; apply (_ : Reflexive (Forall2 _)).
  - intros l1 l2 l3; apply (_ : Transitive (Forall2 _)).
  - intros l1 l2; apply (_ : AntiSymm _ (Forall2 _)).
Qed.

Lemma locs_all_defined locs locs' :
  locs_less_defined (Some <$> locs) locs' → locs' = (Some <$> locs).
  intros Hld.
  apply list_eq; intros i.
  destruct (decide (i < length locs)) as [Hlt|Hnlt].
  - destruct (lookup_lt_is_Some_2 locs i) as [l Hl]; first done.
    destruct (lookup_lt_is_Some_2 locs' i) as [ol Hol].
    { erewrite <- (Forall2_length); last apply Hld.
      rewrite fmap_length; done. }
    apply (locs_less_defined_lookup _ _ i) in Hld.
    revert Hld.
    rewrite list_lookup_fmap list_lookup_total_fmap //.
    erewrite !list_lookup_total_correct; eauto.
    intros Hld.
    rewrite Hl Hol; simpl.
    destruct ol; simplify_eq/=; done.
  - rewrite list_lookup_fmap (lookup_ge_None_2 locs); last lia.
    rewrite lookup_ge_None_2; first done.
    erewrite <- (Forall2_length); last apply Hld.
    rewrite fmap_length; lia.
Qed.

Section crdt_main_rel.
  Context (gcdata : GCData).

  Implicit Types ex : execution_trace aneris_lang.
  Implicit Types iex : inf_execution_trace aneris_lang.
  Implicit Types atr : finite_trace (GCounterM gcdata) ().
  Implicit Types iatr : inflist (() * GCounterM gcdata).

  Notation ith_sa i := (gcd_addr_list gcdata !!! i).

  Definition loc_of_trace_i (i : nat) (evs : event_obs aneris_lang) : option loc :=
    match evs with
    | [] => None
    | ev :: evs' =>
      match expr_e ev.(post_expr) with
      | Val #(LitLoc l) => Some l
      | _ => None
      end
    end.

  Definition locs_of_trace_now (ex : execution_trace aneris_lang) : list (option loc) :=
    (λ i, loc_of_trace_i i (events_of_trace (allocEV (StringOfZ i)) ex) ) <$> seq 0 (GClen gcdata).

  Fixpoint locs_of_trace (ex : execution_trace aneris_lang) : finite_trace (list (option loc)) () :=
    match ex with
    | trace_singleton _ => {tr[replicate (GClen gcdata) None]}
    | trace_extend ex' _ c => (locs_of_trace ex') :tr[()]: (locs_of_trace_now ex)
    end.

  Lemma locs_of_trace_last ex :
    trace_last (locs_of_trace ex) = locs_of_trace_now ex.
  Proof.
    destruct ex; last done.
    rewrite /locs_of_trace_now.
    rewrite (const_fmap _ _ None); first by rewrite seq_length.
    intros ?; rewrite events_of_singleton_trace; done.
  Qed.

  Lemma locs_of_trace_now_length ex : length (locs_of_trace_now ex) = GClen gcdata.
  Proof. rewrite /locs_of_trace fmap_length seq_length; done. Qed.

  Lemma locs_of_trace_length ex : trace_forall (λ tr, length tr = GClen gcdata) (locs_of_trace ex).
  Proof.
    induction ex as [|ex IHex c]; simpl in *.
    - constructor. rewrite replicate_length //.
    - constructor; first done. apply locs_of_trace_now_length.
  Qed.

  Lemma locs_of_trace_now_extend_less_defined ex c oζ:
    valid_exec (ex :tr[oζ]: c) →
    locs_less_defined (locs_of_trace_now ex) (locs_of_trace_now (ex :tr[oζ]: c)).
  Proof.
    intros Hvl.
    apply Forall2_lookup; intros i.
    destruct (decide (i < GClen gcdata)); last first.
    { rewrite !lookup_ge_None_2; first by constructor.
      - rewrite locs_of_trace_now_length; lia.
      - rewrite locs_of_trace_now_length; lia. }
    rewrite !list_lookup_fmap !lookup_seq_lt //=; [].
    constructor.
    destruct (events_of_trace_extend_app (allocEV (StringOfZ i)) ex c oζ) as (evs & _ & Heq & _);
      first done.
    rewrite Heq.
    destruct (events_of_trace (allocEV (StringOfZ i)) ex); reflexivity.
  Qed.

  Lemma locs_of_trace_less_defined ex :
    valid_exec ex → trace_steps (λ x _ y, locs_less_defined x y) (locs_of_trace ex).
  Proof.
    induction ex as [|ex IHex c]; simpl; first by constructor.
    intros Hvl.
    econstructor; [done| |by apply IHex; eapply valid_exec_exec_extend_inv; eauto].
    rewrite locs_of_trace_last.
    apply locs_of_trace_now_extend_less_defined; done.
  Qed.

  Lemma locs_of_trace_now_lookup_singleton i ex ip lbl l v σ h :
    i < GClen gcdata →
    events_of_trace (allocEV (StringOfZ i)) ex = [allocObs ip lbl l v σ h] →
    locs_of_trace_now ex !! i = Some (Some l).
  Proof.
    intros Hi Hevs.
    rewrite /locs_of_trace list_lookup_fmap lookup_seq_lt /=; last done.
    rewrite /loc_of_trace_i Hevs; done.
  Qed.

  Lemma locs_of_trace_now_lookup_nil i ex :
    i < GClen gcdata →
    events_of_trace (allocEV (StringOfZ i)) ex = [] →
    locs_of_trace_now ex !! i = Some None.
  Proof.
    intros Hi Hevs.
    rewrite /locs_of_trace list_lookup_fmap lookup_seq_lt /=; last done.
    rewrite /loc_of_trace_i Hevs; done.
  Qed.

  Definition valid_model_fin_trace (mtr : finite_trace (GCounterM gcdata) ()) : Prop :=
    trace_forall valid_crdt_state mtr ∧ trace_steps (λ st _ st', st = st' ∨ CrdtNext st tt st') mtr.

  Definition gcounter_values_related_now (lcs : (list (option loc)))
             (c : cfg aneris_lang) (δ : GCounterM gcdata) : Prop :=
    ∀ i : fin (GClen gcdata),
       match lcs !!! (fin_to_nat i) with
       | Some l =>
         ∃ h, c.2.(state_heaps) !! (ip_of_address (ith_sa (fin_to_nat i))) = Some h ∧
              h !! l = Some (vector_clock_to_val (vec_to_list (δ !!! i)))
       | None => δ !!! i = vreplicate (GClen gcdata) 0
       end.

  Definition gcounter_values_related (locs : finite_trace (list (option loc)) ())
             (ex : execution_trace aneris_lang) (mtr : finite_trace (GCounterM gcdata) ()) : Prop :=
    trace_forall3 gcounter_values_related_now locs ex mtr.

  Definition gcounter_values_related_now_locs_resolved (lcs : (list loc))
             (c : cfg aneris_lang) (δ : GCounterM gcdata) : Prop :=
    ∀ i : fin (GClen gcdata),
      ∃ h, c.2.(state_heaps) !! (ip_of_address (ith_sa (fin_to_nat i))) = Some h ∧
           h !! (lcs !!! (fin_to_nat i)) = Some (vector_clock_to_val (vec_to_list (δ !!! i))).

  Lemma gcounter_values_related_now_resolve_locs locs c δ :
    length locs = GClen gcdata →
    gcounter_values_related_now (Some <$> locs) c δ →
    gcounter_values_related_now_locs_resolved locs c δ.
  Proof.
    intros Hlen Hvrel i.
    specialize (Hvrel i).
    rewrite list_lookup_total_fmap in Hvrel; [done|by rewrite Hlen; apply fin_to_nat_lt].
  Qed.

  Definition gcounter_monotone (locs : finite_trace (list (option loc)) ())
             (ex : execution_trace aneris_lang) : Prop :=
    trace_steps2
       (λ lcs c _ _ lcs' c',
          ∀ i, i < GClen gcdata →
               match lcs !!! i with
               | Some l =>
                 match lcs' !!! i with
                 | Some l' =>
                   l' = l ∧
                   ∃ h h' (vc vc' : vector_clock (GClen gcdata)),
                      c.2.(state_heaps) !! (ip_of_address (ith_sa i)) = Some h ∧
                      c'.2.(state_heaps) !! (ip_of_address (ith_sa i)) = Some h' ∧
                      h !! l = Some (vector_clock_to_val vc) ∧
                      h' !! l = Some (vector_clock_to_val vc') ∧
                      vc_le vc vc'
                 | None => False
                 end
               | None => True
               end) locs ex.

  Definition gcounter_monotone_configs (lcs : list loc) (c c' : cfg aneris_lang) : Prop :=
    c = c' ∨
    ∀ i, i < GClen gcdata →
         ∃ h h' (vc vc' : vector_clock (GClen gcdata)),
            c.2.(state_heaps) !! (ip_of_address (ith_sa i)) = Some h ∧
            c'.2.(state_heaps) !! (ip_of_address (ith_sa i)) = Some h' ∧
            h !! (lcs !!! i) = Some (vector_clock_to_val vc) ∧
                 h' !! (lcs !!! i) = Some (vector_clock_to_val vc') ∧
                 vc_le vc vc'.

  Lemma gcounter_monotone_configs_vc_le lcs i c c' h h' (vc vc' : vector_clock (GClen gcdata)) :
    i < GClen gcdata →
    gcounter_monotone_configs lcs c c' →
    c.2.(state_heaps) !! (ip_of_address (ith_sa i)) = Some h →
    c'.2.(state_heaps) !! (ip_of_address (ith_sa i)) = Some h' →
    h !! (lcs !!! i) = Some (vector_clock_to_val (vec_to_list vc)) →
    h' !! (lcs !!! i) = Some (vector_clock_to_val (vec_to_list vc')) →
    vc_le vc vc'.
  Proof.
    intros Hi Hgmc Hh Hh' Hvc Hvc'.
    destruct Hgmc as [<-|Hgmc].
    { simplify_eq.
      match goal with
      | Heq :  _ =  _ |- _ =>
        apply vec_to_list_inj2 in Heq; simplify_eq; done
      end. }
    specialize (Hgmc i Hi) as (?&?&?&?&?&?&?&?&?); simplify_eq.
    repeat
       match goal with
       | Heq :  _ =  _ |- _ =>
         apply vec_to_list_inj2 in Heq; simplify_eq
       end; done.
  Qed.

  Global Instance gcounter_monotone_configs_PreOrder lcs : PreOrder (gcounter_monotone_configs lcs).
  Proof.
    split.
    - by left.
    - intros c1 c2 c3 Hc12 Hc23.
      destruct Hc12 as [->|Hc12]; first done.
      destruct Hc23 as [<-|Hc23]; first by right.
      right.
      intros i Hi.
      destruct (Hc12 i Hi) as (h1&h2&vc1&vc2&?&?&?&?&?).
      destruct (Hc23 i Hi) as (h2'&h3&vc2'&vc3&?&?&?&?&?).
      simplify_eq/=.
      match goal with
       | Heq : _ =  _ |- _ =>
         apply vec_to_list_inj2 in Heq; simplify_eq
      end.
      eexists h1, h3, vc1, vc3; split_and!; [by eauto|by eauto|done|done|etrans; eauto].
  Qed.

  Definition gcounter_monotone_locs_resolved_simple
             (lcs : list loc) (l : list (cfg aneris_lang)) : Prop :=
    ∀ i c1 c2, l !! i = Some c1 → l !! (S i) = Some c2 → gcounter_monotone_configs lcs c1 c2.

  Definition gcounter_monotone_locs_resolved (lcs : list loc) (l : list (cfg aneris_lang)) : Prop :=
    ∀ i j c1 c2, i ≤ j → l !! i = Some c1 → l !! j = Some c2 → gcounter_monotone_configs lcs c1 c2.

  Lemma gcounter_monotone_locs_resolved_if_simple lcs l :
    gcounter_monotone_locs_resolved_simple lcs l → gcounter_monotone_locs_resolved lcs l.
  Proof.
    intros Hgms i j c1 c2 Hij Hi Hj.
    apply Nat.le_sum in Hij as [k Hk].
    revert i j Hk c1 c2 Hi Hj.
    induction k as [|k IHk]; intros i j Hk c1 c2 Hi Hj.
    { assert (j = i) by lia; clear Hk; simplify_eq; reflexivity. }
    destruct (lookup_lt_is_Some_2 l (i + k)) as [c Hc].
    { apply lookup_lt_Some in Hj; lia. }
    etrans; first by apply (IHk i (i + k) eq_refl c1 c); auto.
    replace j with (S (i + k)) in Hj by lia.
    eapply Hgms; eauto.
  Qed.

  Lemma gcounter_monotone_resolve_locs lcs ex il l :
    length il = length l →
    length lcs = GClen gcdata →
    valid_exec (ex +trl+ l) →
    trace_last (locs_of_trace ex) = (Some <$> lcs) →
    trace_steps (λ x _ y, locs_less_defined x y) (locs_of_trace ex +trl+ il) →
    gcounter_monotone (locs_of_trace ex +trl+ il) (ex +trl+ l) →
    gcounter_monotone_locs_resolved lcs (trace_last ex :: map snd l).
  Proof.
    intros Hlen Hlcs Hvl Hld Hldl Hgms.
    apply gcounter_monotone_locs_resolved_if_simple.
    revert il Hlen Hvl Hld Hldl Hgms; induction l as [|[oζ c] l IHl] using rev_ind;
      intros il Hlen Hvl Hld Hldl Hgms.
    { intros i j c1 c2; rewrite list_lookup_singleton; done. }
    intros i c1 c2 Hi HSi.
    destruct il as [|[[] locs] il _] using rev_ind.
    { rewrite app_length /= in Hlen; lia. }
    rewrite -!trace_append_list_assoc /= in Hvl, Hgms, Hldl.
    assert (i < S (length l)).
    { cut (S i < length (trace_last ex :: map snd l ++ [c])).
      - rewrite /= app_length map_length /=; lia.
      - apply lookup_lt_is_Some_1; eauto.
        rewrite map_app in HSi. rewrite HSi; eauto. }
    rewrite map_app (lookup_app_l (_ :: _)) in Hi; last first.
    { list_simplifier. rewrite map_length //. }
    destruct (decide (i < length l)) as [Hlt|Hnlt].
    - rewrite /= map_app lookup_app_l in HSi; last by rewrite map_length.
      eapply (IHl il); [rewrite !app_length /= in Hlen| |done| | |by eauto|by eauto].
      + rewrite !Nat.add_1_r in Hlen. by injection Hlen.
      + eapply valid_exec_exec_extend_inv; eauto.
      + eapply trace_steps_step_inv in Hldl as [? ?]; done.
      + eapply trace_steps2_step_inv in Hgms as [? ?]; done.
    - assert (i = length l) as HSieq by lia.
      rewrite HSieq in HSi.
      rewrite map_app (lookup_app_r (_ :: _)) in HSi; last by rewrite /= map_length.
      rewrite /= map_length Nat.sub_diag in HSi; simplify_eq/=.
      apply trace_steps2_step_inv in Hgms as [_ Hgms].
      destruct Hgms as (? & ? & ?%last_eq_trace_ends_in & ?%last_eq_trace_ends_in & Hgms).
      simplify_eq.
      destruct l as [|[? c'] l _] using rev_ind.
      + assert (length il = 0) by by rewrite app_length /= in Hlen; lia.
        destruct il; last done.
        simplify_eq/=.
        rewrite Hld in Hgms.
        right; intros i Hi.
        specialize (Hgms i Hi).
        rewrite list_lookup_total_fmap in Hgms; last lia.
        destruct (locs !!! i); last done.
        destruct Hgms as [-> Hgms]; done.
      + rewrite -!trace_append_list_assoc /= in Hgms.
        rewrite app_length /= in Hi.
        rewrite map_app (lookup_app_r (_ ::_)) in Hi; last by rewrite /= map_length; lia.
        rewrite /= in Hi.
        replace (length l + 1 - S (length l)) with 0 in Hi by lia.
        simplify_eq/=.
        apply valid_exec_exec_extend_inv in Hvl as [Hvl _].
        apply locs_of_trace_less_defined in Hvl.
        apply trace_steps_step_inv in Hldl as [Hldl _].
        eapply trace_append_list_steps_rtc_nl in Hldl;
          [|apply trace_ends_in_last|apply trace_ends_in_last].
        revert Hldl; rewrite rt_rtc_same Hld; intros Hldl.
        right. intros i Hilen.
        apply (locs_less_defined_lookup _ _ i) in Hldl.
        rewrite list_lookup_total_fmap in Hldl; last lia.
        specialize (Hgms i Hilen).
        destruct (trace_last (locs_of_trace ex +trl+ il) !!! i) as [ol'|]; last done.
        simplify_eq/=.
        destruct (locs !!! i); last done.
        destruct Hgms as (-> & Hgms).
        by list_simplifier.
  Qed.

  Definition send_evs_rel (locs : list (option loc)) (ex : execution_trace aneris_lang) : Prop :=
    ∃ sevss,
       length sevss = GClen gcdata ∧
       ∀ i, i < GClen gcdata →
            ∃ sevs,
               sevss !! i = Some sevs ∧
               sendevs_valid sevs ∧
               match locs !!! i with
               | Some l =>
                 Forall2
                    (@send_events_correspond gcdata (ith_sa i) l)
                    (events_of_trace (sendonEV (ith_sa i)) ex)
                    sevs
               | None => events_of_trace (sendonEV (ith_sa i)) ex = [] ∧ sevs = []
               end.

  Definition send_evs_rel_locs_resolved
             (locs : list loc) (ex : execution_trace aneris_lang) : Prop :=
    ∃ sevss,
       length sevss = GClen gcdata ∧
       ∀ i, i < GClen gcdata →
            ∃ sevs,
               sevss !! i = Some sevs ∧
               sendevs_valid sevs ∧
               Forall2
                  (@send_events_correspond gcdata (ith_sa i) (locs !!! i))
                  (events_of_trace (sendonEV (ith_sa i)) ex)
                  sevs.

  Lemma send_evs_rel_resolve_locs locs ex :
    length locs = GClen gcdata →
    send_evs_rel (Some <$> locs) ex →
    send_evs_rel_locs_resolved locs ex.
  Proof.
    intros Hlen [sevss [? Hsevs]].
    exists sevss; split; first done.
    intros i Hi.
    specialize (Hsevs i Hi).
    setoid_rewrite list_lookup_total_fmap in Hsevs; [eauto|lia].
  Qed.

  Definition receive_evs_rel (locs : list (option loc)) (ex : execution_trace aneris_lang) : Prop :=
    ∃ revss,
       length revss = GClen gcdata ∧
       ∀ i, i < GClen gcdata →
            ∃ revs,
               revss !! i = Some revs ∧
               match locs !!! i with
               | Some l =>
                 Forall2 (rec_events_correspond (ith_sa i))
                         (events_of_trace (receiveonEV (ith_sa i)) ex) revs ∧
                 ∃ h (vc : vector_clock (GClen gcdata)),
                    (trace_last ex).2.(state_heaps) !! (ip_of_address (ith_sa i)) = Some h ∧
                    h !! l = Some (vector_clock_to_val vc) ∧
                 forall j rev, S j < length revs → revs !! j = Some rev → vc_le rev vc
               | None => events_of_trace (receiveonEV (ith_sa i)) ex = [] ∧ revs = []
               end.

  Definition receive_evs_rel_locs_resolved
             (locs : list loc) (ex : execution_trace aneris_lang) : Prop :=
    ∃ revss,
       length revss = GClen gcdata ∧
       ∀ i, i < GClen gcdata →
            ∃ revs,
               revss !! i = Some revs ∧
               Forall2 (rec_events_correspond (ith_sa i))
                         (events_of_trace (receiveonEV (ith_sa i)) ex) revs ∧
               ∃ h (vc : vector_clock (GClen gcdata)),
                  (trace_last ex).2.(state_heaps) !! (ip_of_address (ith_sa i)) = Some h ∧
                  h !! (locs !!! i) = Some (vector_clock_to_val vc) ∧
                  forall j rev, S j < length revs → revs !! j = Some rev → vc_le rev vc.

  Lemma receive_evs_rel_resolve_locs locs ex :
    length locs = GClen gcdata →
    receive_evs_rel (Some <$> locs) ex →
    receive_evs_rel_locs_resolved locs ex.
  Proof.
    intros Hlen [revss [? Hrevs]].
    exists revss; split; first done.
    intros i Hi.
    specialize (Hrevs i Hi).
    setoid_rewrite list_lookup_total_fmap in Hrevs; [eauto|lia].
  Qed.

  Definition crdt_main_rel (ex: execution_trace aneris_lang)
             (mtr : auxiliary_trace (aneris_to_trace_model (GCounterM gcdata))) : Prop :=
    valid_system_trace ex mtr ∧
    valid_model_fin_trace mtr ∧
    gcounter_values_related (locs_of_trace ex) ex mtr ∧
    send_evs_rel (trace_last (locs_of_trace ex)) ex ∧
    receive_evs_rel (trace_last (locs_of_trace ex)) ex.

  Lemma crdt_main_rel_monotone ex mtr :
    crdt_main_rel ex mtr → gcounter_monotone (locs_of_trace ex) ex.
  Proof.
    intros (Hvl & Hmvl & Hvrel & _).
    revert mtr Hvl Hmvl Hvrel.
    induction ex as [|ex IHex c]; simpl;
      intros mtr Hvl Hmvl Hvrel; first by apply trace_steps2_singleton.
    econstructor; [done|done| |]; last first.
    { apply trace_forall3_extend_inv_l in Hvrel as (? & ? & ? & mtr' & ? & [] & ? & ? & ? & ?); simplify_eq.
      inversion Hvl; simplify_eq.
      eapply IHex.
      - done.
      - destruct Hmvl as [[? ?]%trace_forall_extend_inv [? [??]]%trace_steps_step_inv]; done.
      - by eauto. }
    apply trace_forall3_extend_inv_l in Hvrel as (c' & ex' & st & mtr' & oζ & ? & ? & ? & Hrel1 & Hrel2);
      simplify_eq/=.
    apply trace_forall3_last in Hrel1.
    intros i Hi.
    specialize (Hrel1 (nat_to_fin Hi)).
    specialize (Hrel2 (nat_to_fin Hi)).
    rewrite locs_of_trace_last in Hrel1.
    rewrite locs_of_trace_last.
    rewrite !fin_to_nat_to_fin in Hrel1, Hrel2.
    eapply valid_system_trace_valid_exec_trace in Hvl.
    destruct (locs_of_trace_now (ex' :tr[ oζ ]: c') !!! i) eqn:Heq; last first.
    { pose proof (locs_of_trace_now_extend_less_defined ex' c' _ Hvl) as Hld.
      apply (locs_less_defined_lookup _ _ i) in Hld.
      rewrite Heq in Hld.
      destruct (locs_of_trace_now ex' !!! i); done. }
    pose proof (locs_of_trace_now_extend_less_defined ex' c' _ Hvl) as Hld.
    apply (locs_less_defined_lookup _ _ i) in Hld.
    rewrite Heq in Hld.
    destruct (locs_of_trace_now ex' !!! i); simplify_eq/=; last done.
    split; first done.
    destruct Hrel1 as (h & Hh1 & Hh2).
    destruct Hrel2 as (h' & Hh'1 & Hh'2).
    eexists _, _, _, _; split_and!; [by eauto|by eauto|by eauto|by eauto|].
    destruct Hmvl as [_ Hmvl].
    apply trace_steps_step_inv in Hmvl as [_ (st' & -> & [->|Hmvl])]; first done.
    apply crdt_next_vc_le; done.
  Qed.

  Lemma crdt_main_rel_initially (ps : programs_using_gcounters gcdata) v :
    crdt_main_rel
       {tr[ ([{| expr_n := "system"; expr_e := runner gcdata 0 (progs ps) v |}],
             init_state) ]}
       {tr[ initial_crdt_state (GClen gcdata) ]}.
  Proof.
    rewrite /crdt_main_rel /=; split_and!.
    - constructor.
    - repeat constructor. apply valid_initial_crdt_state.
    - constructor; intros i.
      rewrite lookup_total_replicate_2; last by apply fin_to_nat_lt.
      rewrite vlookup_replicate; done.
    - exists (replicate (length (gcd_addr_list gcdata)) []).
      split; first by rewrite replicate_length.
      intros i Hi.
      exists []; split; first by rewrite lookup_replicate_2.
      split.
      { intros ????; rewrite lookup_nil; done. }
      rewrite lookup_total_replicate_2; last done.
      rewrite events_of_singleton_trace; done.
    - exists (replicate (length (gcd_addr_list gcdata)) []).
      split; first by rewrite replicate_length.
      intros i Hi.
      exists []; split; first by rewrite lookup_replicate_2.
      rewrite lookup_total_replicate_2; last done.
      rewrite events_of_singleton_trace; done.
  Qed.

  Lemma crdt_main_rel_step (ps : programs_using_gcounters gcdata) v ex
        (atr atr': auxiliary_trace (aneris_to_trace_model (GCounterM gcdata))) ex' oζ ℓ:
    valid_system_trace ex atr →
    trace_contract ex oζ ex' →
    trace_contract atr ℓ atr' →
    crdt_main_rel ex' atr' →
    trace_starts_in ex
      ([{| expr_n := "system"; expr_e := runner gcdata 0 (progs ps) v |}], init_state) →
    trace_starts_in atr (initial_crdt_state (GClen gcdata)) →
    valid_state_evolution (ex' :tr[oζ]: trace_last ex) (atr' :tr[ℓ]: trace_last atr) →
    (∀ i : fin (length (gcd_addr_list gcdata)),
      match locs_of_trace_now ex !!! (fin_to_nat i) with
      | Some l =>
        ∃ h : heap,
          (trace_last ex).2.(state_heaps) !! ip_of_address (ith_sa (fin_to_nat i)) = Some h ∧
          h !! l = Some (vector_clock_to_val (vec_to_list ((trace_last atr) !!! i)))
      | None => (trace_last atr) !!! i = vreplicate (length (gcd_addr_list gcdata)) 0
     end) →
    send_evs_rel (locs_of_trace_now ex) ex →
    receive_evs_rel (locs_of_trace_now ex) ex →
    crdt_main_rel ex atr.
  Proof.
    intros Hvls [c ->] [δ ->] Hmrel Hex's Hatr's Hvse Hstrel Hsevsrel Hrevsrel; simpl in *.
    rewrite /crdt_main_rel /=; split_and!.
    - done.
    - split.
      + constructor; first by apply Hmrel.
        destruct Hmrel as (_ & [Hvst _] & _).
        apply trace_forall_last in Hvst.
        destruct Hvse as [<-|]; first done.
        eapply CrdtNext_preserves_validity; done.
      + destruct Hmrel as (_ & [_ Hststep] & _).
        econstructor; [done | | done].
        destruct Hvse as [<-|]; by auto.
    - constructor; [by apply Hmrel|done].
    - done.
    - done.
  Qed.

  CoFixpoint locs_of_inf_trace
             (ex : execution_trace aneris_lang)
             (iex: inf_execution_trace aneris_lang) : inflist (() * list (option loc)) :=
    match iex with
    | []%inflist => []
    | ((oζ, c) :: iex')%inflist =>
      (tt, (locs_of_trace_now (ex :tr[oζ]: c))) :: locs_of_inf_trace (ex :tr[oζ]: c) iex'
    end.

  Lemma locs_of_inf_trace_take ex iex n :
    ((locs_of_trace ex) +trl+ (inflist_take n (locs_of_inf_trace ex iex))) =
    locs_of_trace (ex +trl+ (inflist_take n iex)).
  Proof.
    revert ex iex; induction n as [|n IHn]; intros ex iex; simpl; first done.
    destruct iex as [|[??]?]; simpl; first done.
    rewrite -IHn; done.
  Qed.

  Lemma locs_of_inf_trace_length ex iex : inflist_same_length (locs_of_inf_trace ex iex) iex.
  Proof.
    intros n.
    revert ex iex.
    induction n; simpl; intros ex iex.
    - rewrite (inflist_unfold_fold (locs_of_inf_trace ex iex)).
      destruct iex as [|[??]?]; simpl; done.
    - destruct iex as [|[??]?]; done.
  Qed.

  Lemma locs_of_inf_trace_cons_inv ex iex lcs ilocs:
    locs_of_inf_trace ex iex = (lcs :: ilocs)%inflist →
    ∃ oζ c iex',
       iex = ((oζ, c):: iex')%inflist ∧
       lcs = (tt, locs_of_trace_now (ex :tr[oζ]: c)) ∧
       ilocs = locs_of_inf_trace (ex :tr[oζ]: c) iex'.
  Proof.
    rewrite (inflist_unfold_fold (locs_of_inf_trace ex iex)).
    destruct iex as [|[??]?]; simpl; first done.
    intros; simplify_eq; eauto 10.
  Qed.

  Lemma locs_of_inf_trace_less_defined ex iex :
    valid_inf_exec ex iex →
    always
       (λ locs ilocs, trace_steps (λ x _ y, locs_less_defined x y) locs)
       (locs_of_trace ex) (locs_of_inf_trace ex iex).
  Proof.
    intros Hvex.
    apply always_take_drop; intros n.
    rewrite locs_of_inf_trace_take.
    apply locs_of_trace_less_defined.
    eapply valid_inf_exe_valid_exec.
    apply valid_inf_exe_take_drop; done.
  Qed.

  Definition crdt_main_rel_ternary
             (locs : finite_trace (list (option loc)) ()) (ex: execution_trace aneris_lang)
             (mtr : auxiliary_trace (aneris_to_trace_model (GCounterM gcdata)))
             (ilocs : inflist (() * list (option loc))) (iex: inf_execution_trace aneris_lang)
             (imtr : inflist (() * GCounterM gcdata)) : Prop :=
    valid_system_trace ex mtr ∧
    valid_model_fin_trace mtr ∧
    gcounter_values_related locs ex mtr ∧
    send_evs_rel (trace_last locs) ex ∧
    receive_evs_rel (trace_last locs) ex.

  Lemma crdt_main_rel_ternary_crdt_main_rel ex mtr ilocs iex imtr :
    crdt_main_rel_ternary (locs_of_trace ex) ex mtr ilocs iex imtr → crdt_main_rel ex mtr.
  Proof. intros (?&?&?&?&?); split_and!; done. Qed.

  (* move *)
  Lemma valid_inf_system_trace_take_drop n
        {Λ : language} {M} (φ : execution_trace Λ → auxiliary_trace M → Prop)
        (ex : execution_trace Λ) (atr : auxiliary_trace M)
        (iex : inf_execution_trace Λ) (iatr : inf_auxiliary_trace M) :
    valid_inf_system_trace φ ex atr iex iatr →
    valid_inf_system_trace φ
      (ex +trl+ inflist_take n iex) (atr +trl+ inflist_take n iatr)
      (inflist_drop n iex) (inflist_drop n iatr).
  Proof.
    revert ex atr iex iatr.
    induction n as [|n IHn]; first done.
    intros ex atr iex iatr Hvisf.
    inversion Hvisf; simplify_eq/=; first done.
    apply IHn; done.
  Qed.
  Lemma valid_inf_system_trace_length
        {Λ : language} {M} (φ : execution_trace Λ → auxiliary_trace M → Prop)
        (ex : execution_trace Λ) (atr : auxiliary_trace M)
        (iex : inf_execution_trace Λ) (iatr : inf_auxiliary_trace M) :
    valid_inf_system_trace φ ex atr iex iatr → inflist_same_length iex iatr.
  Proof.
    intros Hvisf n.
    apply (valid_inf_system_trace_take_drop n) in Hvisf.
    inversion Hvisf; simplify_eq/=; done.
  Qed.
  Lemma valid_inf_system_trace_mono
        {Λ : language} {M} (φ ψ : execution_trace Λ → auxiliary_trace M → Prop)
        (ex : execution_trace Λ) (atr : auxiliary_trace M)
        (iex : inf_execution_trace Λ) (iatr : inf_auxiliary_trace M) :
    (∀ (ex' : execution_trace Λ) (atr' : auxiliary_trace M), φ ex' atr' → ψ ex' atr') →
    valid_inf_system_trace φ ex atr iex iatr → valid_inf_system_trace ψ ex atr iex iatr.
  Proof.
    revert ex atr iex iatr; cofix IH; intros ex atr iex iatr Hφψ Hφ.
    inversion Hφ; simplify_eq.
    - constructor; apply Hφψ; done.
    - econstructor; eauto.
  Qed.
  Lemma valid_inf_system_trace_rel
        {Λ : language} {M} (φ : execution_trace Λ → auxiliary_trace M → Prop)
        (ex : execution_trace Λ) (atr : auxiliary_trace M)
        (iex : inf_execution_trace Λ) (iatr : inf_auxiliary_trace M) :
    valid_inf_system_trace φ ex atr iex iatr → φ ex atr.
  Proof. inversion 1; done. Qed.

  Lemma crdt_main_rel_always_ternary
        (ex : execution_trace aneris_lang) (iex : inf_execution_trace aneris_lang)
        (atr : auxiliary_trace (aneris_to_trace_model (GCounterM gcdata))) :
    valid_inf_exec ex iex →
    continued_simulation crdt_main_rel ex atr →
    ∃ imtr,
       always3
          crdt_main_rel_ternary
          (locs_of_trace ex) ex atr (locs_of_inf_trace ex iex) iex imtr.
  Proof.
    intros Hvl Hcs.
    specialize (continued_simulation_rel _ _ _ Hcs) as (Hst & _ & _ & _).
    pose proof (produced_inf_aux_trace_valid_inf _ _  _ Hst Hcs iex Hvl) as Hvisf.
    clear Hst.
    exists (produce_inf_aux_trace _ ex atr Hcs iex Hvl).
    pose proof (valid_inf_system_trace_length _ _ _ _ _ Hvisf) as Hlen.
    apply (valid_inf_system_trace_mono _ crdt_main_rel) in Hvisf; last first.
    { apply continued_simulation_rel. }
    revert Hlen Hvisf.
    generalize (produce_inf_aux_trace _ ex atr Hcs iex Hvl); intros iatr.
    clear Hcs.
    revert ex iex atr iatr Hvl.
    cofix IH; intros ex iex atr iatr Hvl Hlen Hvisf.
    constructor; [| | |].
    - apply valid_inf_system_trace_rel in Hvisf; done.
    - apply locs_of_inf_trace_length.
    - eapply inflist_same_length_trans; done.
    - simpl.
      intros ?????????
             (?&?&?&?&?&?)%locs_of_inf_trace_cons_inv
             -> ->; simplify_eq.
      apply (IH (_ :tr[_]: _)).
      + apply traces.valid_inf_exec_adjust; done.
      + rewrite -inflist_same_length_cons; done.
      + apply (valid_inf_system_trace_take_drop 1) in Hvisf; done.
  Qed.

  Lemma eventually_sent_eventually_exists_loc_one i ex iex mtr imtr :
    i < GClen gcdata →
    valid_inf_exec ex iex →
    eventually (λ ex' _, events_of_trace (sendonEV (ith_sa i)) ex' ≠ []) ex iex →
    always3 crdt_main_rel_ternary (locs_of_trace ex) ex mtr (locs_of_inf_trace ex iex) iex imtr →
    eventually3
       (always3 (λ locs _ _ _ _ _, ∃ l, (trace_last locs) !! i = Some (Some l)))
       (locs_of_trace ex) ex mtr (locs_of_inf_trace ex iex) iex imtr.
  Proof.
    intros Hi Hvex Hev Hal.
    apply eventually_take_drop in Hev as [n Hev].
    assert ((always (λ ex' _, events_of_trace (sendonEV (ith_sa i)) ex' ≠ []))
               (ex +trl+ inflist_take n iex) (inflist_drop n iex)) as Hev'.
    { apply always_take_drop; intros k.
      destruct (events_of_trace_app
                   (sendonEV (ith_sa i))
                   (ex +trl+ inflist_take n iex)
                   (inflist_take k (inflist_drop n iex))) as (evs & ? & -> & _).
      { rewrite trace_append_list_assoc -inflist_take_add.
        eapply valid_inf_exe_valid_exec; eapply valid_inf_exe_take_drop; done. }
      intros []%app_eq_nil; simplify_eq. }
    clear Hev.
    apply eventually3_take_drop; exists n.
    split; last by eapply always3_inflist_same_length; eauto.
    apply (always3_unroll_n _ n) in Hal.
    apply always3_take_drop; intros k.
    split; last by eapply always3_inflist_same_length; eauto.
    apply (always3_unroll_n _ k), always3_holds in Hal.
    apply (always_unroll_n _ k), always_holds in Hev'.
    revert Hal Hev'.
    rewrite !trace_append_list_assoc -!inflist_take_add.
    intros Hal Hev.
    destruct Hal as (_&_&_& (sevss & Hlen & Hsevs) &_).
    specialize (Hsevs i Hi) as (sevs & ? & ? & Hlocs).
    rewrite list_lookup_total_alt in Hlocs.
    revert Hlocs.
    rewrite locs_of_inf_trace_take locs_of_trace_last.
    destruct (lookup_lt_is_Some_2 (locs_of_trace_now (ex +trl+ inflist_take (n + k) iex)) i)
      as [ol Hol].
    { rewrite locs_of_trace_now_length; done. }
    rewrite Hol; simpl.
    destruct ol; first by eauto.
    intros [? ?]; simplify_eq.
  Qed.

  Lemma eventually_sent_eventually_exists_loc_all ex iex mtr imtr :
    (∀ i, i < GClen gcdata →
          eventually (λ ex' _, events_of_trace (sendonEV (ith_sa i)) ex' ≠ []) ex iex) →
    valid_inf_exec ex iex →
    always3 crdt_main_rel_ternary (locs_of_trace ex) ex mtr (locs_of_inf_trace ex iex) iex imtr →
    eventually3
       (λ locs ex' mtr' ilocs' iex' imtr',
          ∀ (j : fin (S (GClen gcdata))),
             always3 (λ locs' ex'' mtr'' ilocs'' iex'' imtr'',
                      match fin_to_nat j with
                      | 0 => crdt_main_rel_ternary locs' ex'' mtr'' ilocs'' iex'' imtr''
                      | S k => ∃ l, (trace_last locs') !! k = Some (Some l)
                      end) locs ex' mtr' ilocs' iex' imtr')
       (locs_of_trace ex) ex mtr (locs_of_inf_trace ex iex) iex imtr.
  Proof.
    intros Hev Hvex Hal.
    apply eventually3_forall_combine.
    intros j.
    destruct (fin_to_nat j) as [|j'] eqn:Hj'.
    - pose proof (always3_inflist_same_length _ _ _ _ _ _ _ Hal) as [? ?].
      apply holds_eventually3; done.
    - assert (j' < GClen gcdata).
      { assert (S j' < S (GClen gcdata)) by by rewrite -Hj'; apply fin_to_nat_lt. lia. }
      apply eventually_sent_eventually_exists_loc_one; auto.
  Qed.

  Lemma eventually_sent_eventually_allocated_helper len locs ex mtr ilocs iex imtr :
  (∀ j : fin (S len),
     always3
       (λ locs' ex'' mtr'' ilocs'' iex'' imtr'',
          match fin_to_nat j with
          | 0 => crdt_main_rel_ternary locs' ex'' mtr'' ilocs'' iex'' imtr''
          | S k => ∃ l : loc, trace_last locs' !! k = Some (Some l)
        end) locs ex mtr ilocs iex imtr) →
  ∃ lcssg : {lcs : list loc | length lcs = len},
     take len (trace_last locs) = Some <$> `lcssg ∧
     always3 crdt_main_rel_ternary locs ex mtr ilocs iex imtr.
  Proof.
    intros Hex.
    induction len as [|n IHn].
    - exists (exist (λ l, length l = 0) (@nil loc) eq_refl).
      rewrite take_0 /=.
      split; first done.
      specialize (Hex 0%fin); done.
    - destruct IHn as [[lcs Hlcslen] [Hlcs1 Hlcs2]].
      { intros j.
        assert (fin_to_nat j < S (S n)) as Hlt.
        { etrans; first apply fin_to_nat_lt; lia. }
        specialize (Hex (nat_to_fin Hlt)).
        eapply always3_mono; last apply Hex.
        clear.
        rewrite fin_to_nat_to_fin; done. }
      assert (S n < S (S n)) as Hlt by lia.
      specialize (Hex (nat_to_fin Hlt)).
      apply always3_holds in Hex.
      rewrite fin_to_nat_to_fin in Hex.
      destruct Hex as [l Hl].
      assert (length (lcs ++ [l]) = S n) as Hlcslen'.
      { rewrite app_length Hlcslen; simpl; lia. }
      exists (exist _ (lcs ++ [l]) Hlcslen').
      split; last done.
      erewrite take_S_r; last by eauto.
      rewrite Hlcs1 fmap_app; simpl; done.
  Qed.

  Lemma eventually_sent_eventually_allocated_helper' locs ex mtr ilocs iex imtr :
    length (trace_last locs) = GClen gcdata →
  (∀ j : fin (S (GClen gcdata)),
     always3
       (λ locs' ex'' mtr'' ilocs'' iex'' imtr'',
          match fin_to_nat j with
          | 0 => crdt_main_rel_ternary locs' ex'' mtr'' ilocs'' iex'' imtr''
          | S k => ∃ l : loc, trace_last locs' !! k = Some (Some l)
        end) locs ex mtr ilocs iex imtr) →
  ∃ lcssg : {lcs : list loc | length lcs = GClen gcdata},
     trace_last locs = Some <$> `lcssg ∧
     always3 crdt_main_rel_ternary locs ex mtr ilocs iex imtr.
  Proof.
    intros Hlen Hex.
    rewrite -(firstn_all (trace_last locs)) Hlen.
    apply eventually_sent_eventually_allocated_helper; done.
  Qed.

  Lemma eventually_sent_eventually_allocated ex iex mtr imtr :
    (∀ i, i < GClen gcdata →
          eventually (λ ex' _, events_of_trace (sendonEV (ith_sa i)) ex' ≠ []) ex iex) →
    valid_inf_exec ex iex →
    always3 crdt_main_rel_ternary (locs_of_trace ex) ex mtr (locs_of_inf_trace ex iex) iex imtr →
    ∃ lcs : list loc,
       length lcs = GClen gcdata ∧
       eventually3
          (λ locs ex' mtr' ilocs' iex' imtr',
           (trace_last locs = Some <$> lcs) ∧
           always3 crdt_main_rel_ternary locs ex' mtr' ilocs' iex' imtr')
          (locs_of_trace ex) ex mtr (locs_of_inf_trace ex iex) iex imtr.
  Proof.
    intros Hev Hvex Hal.
    cut (∃ lcssg : {lcs : list loc | length lcs = GClen gcdata},
             eventually3
                (λ locs ex' mtr' ilocs' iex' imtr',
                 (trace_last locs = Some <$> `lcssg) ∧
                 always3 crdt_main_rel_ternary locs ex' mtr' ilocs' iex' imtr')
                (locs_of_trace ex) ex mtr (locs_of_inf_trace ex iex) iex imtr).
    { intros [[? ?] ?]; eauto. }
    apply eventually3_exists.
    epose proof (eventually_sent_eventually_exists_loc_all _ _ _ _ Hev Hvex Hal) as Hex.
    apply eventually3_take_drop in Hex as [n [Hex [Hilen1 Hilen2]]].
    apply eventually3_take_drop.
    exists n; split; last done.
    apply eventually_sent_eventually_allocated_helper'; last done.
    rewrite locs_of_inf_trace_take locs_of_trace_last locs_of_trace_now_length; done.
  Qed.

  Definition crdt_main_rel_locs_resolved (locs : list loc) (ex: execution_trace aneris_lang)
             (mtr : finite_trace (GCounterM gcdata) ())
             (iex: inf_execution_trace aneris_lang)
             (imtr : inflist (() * GCounterM gcdata))  : Prop :=
    valid_model_fin_trace mtr ∧
    gcounter_values_related_now_locs_resolved locs (trace_last ex) (trace_last mtr) ∧
    send_evs_rel_locs_resolved locs ex ∧
    receive_evs_rel_locs_resolved locs ex.

  Definition monotone_from_now_on locs ex iex :=
    (always (λ ex' _,
             ∃ l, ex' = ex +trl+ l ∧
                  gcounter_monotone_locs_resolved locs (trace_last ex :: map snd l)) ex iex).

  (* TODO: put in aneris *)

  Lemma monotone_from_now_on_unroll_n n locs ex iex :
    monotone_from_now_on locs ex iex →
    monotone_from_now_on locs (ex +trl+ inflist_take n iex) (inflist_drop n iex).
  Proof.
    intros Hfno.
    apply always_take_drop; intros m.
    apply (always_unroll_n _ n) in Hfno.
    apply (always_unroll_n _ m) in Hfno.
    apply always_holds in Hfno.
    destruct Hfno as [l [Hl Hgms]].
    rewrite Hl.
    rewrite !trace_append_list_assoc -!inflist_take_add in Hl.
    apply trace_append_list_inj2 in Hl.
    rewrite inflist_take_add in Hl.
    simplify_eq.
    eexists _; split.
    { rewrite !trace_append_list_assoc; done. }
    intros i j ?????.
    apply (Hgms (length (inflist_take n iex) + i) (length (inflist_take n iex) + j)).
    - lia.
    - destruct i as [|i]; simpl in *.
      + rewrite map_app (lookup_app_l (_ :: _)) /=; last by rewrite map_length /=; lia.
        rewrite Nat.add_0_r.
        rewrite trace_last_of_append_list_map //.
      + rewrite Nat.add_comm /= Nat.add_comm.
        rewrite map_app lookup_app_r; last by rewrite map_length; lia.
        rewrite map_length minus_plus; done.
    - destruct j as [|j]; simpl in *.
      + rewrite map_app (lookup_app_l (_ :: _)); last by rewrite /= map_length /=; lia.
        rewrite Nat.add_0_r.
        rewrite trace_last_of_append_list_map; done.
      + rewrite Nat.add_comm /= Nat.add_comm.
        rewrite map_app lookup_app_r; last by rewrite map_length; lia.
        rewrite map_length minus_plus; done.
  Qed.

  Definition closed_model_relation locs ex mtr iex imtr :=
    (monotone_from_now_on locs ex iex) ∧
    always2 (crdt_main_rel_locs_resolved locs) ex mtr iex imtr.

  Lemma eventually_sent_eventually_locs_resolved ex iex mtr imtr :
    (∀ i, i < GClen gcdata →
          eventually (λ ex' _, events_of_trace (sendonEV (ith_sa i)) ex' ≠ []) ex iex) →
    valid_inf_exec ex iex →
    always3 crdt_main_rel_ternary (locs_of_trace ex) ex mtr (locs_of_inf_trace ex iex) iex imtr →
    ∃ locs, length locs = GClen gcdata ∧ eventually2 (closed_model_relation locs) ex mtr iex imtr.
  Proof.
    intros Hev Hvl Hal3.
    edestruct (eventually_sent_eventually_allocated ex iex mtr imtr) as (locs & Hlocslen & Hal);
      [done|done|done|].
    exists locs; split; first done.
    apply eventually3_take_drop in Hal as [n [[Hex1 Hex2] [Hilen1 Hilen2]]].
    apply eventually2_take_drop.
    exists n; split; last done.
    split.
    - apply always_take_drop; intros k.
      apply (always3_unroll_n _ n), (always3_unroll_n _ k), always3_holds in Hal3.
      rewrite !trace_append_list_assoc -!inflist_take_add in Hal3.
      rewrite !locs_of_inf_trace_take in Hal3.
      apply crdt_main_rel_ternary_crdt_main_rel in Hal3.
      apply crdt_main_rel_monotone in Hal3.
      rewrite !inflist_take_add -!trace_append_list_assoc in Hal3.
      pose proof (locs_of_inf_trace_less_defined _ _ Hvl) as Hld.
      apply (always_unroll_n _ n), (always_unroll_n _ k), always_holds in Hld.
      eexists _; split; first reflexivity.
      eapply (gcounter_monotone_resolve_locs
                 locs
                 (ex +trl+ inflist_take n iex)
                 (inflist_take
                     k
                     (locs_of_inf_trace (ex +trl+ inflist_take n iex) (inflist_drop n iex)))).
      + apply inflist_take_of_same_length, locs_of_inf_trace_length.
      + done.
      + eapply valid_inf_exe_valid_exec.
        do 2 apply valid_inf_exe_take_drop; done.
      + rewrite -locs_of_inf_trace_take; done.
      + rewrite !locs_of_inf_trace_take.
        rewrite trace_append_list_assoc -inflist_take_add.
        rewrite trace_append_list_assoc in Hld.
        rewrite -inflist_take_add in Hld.
        rewrite !locs_of_inf_trace_take in Hld.
        done.
      + rewrite !locs_of_inf_trace_take. done.
    - apply always2_take_drop; intros k; split; last by apply inflist_same_length_drop.
      apply (always3_unroll_n _ k), always3_holds in Hex2.
      pose proof (locs_of_inf_trace_less_defined _ _ Hvl) as Hld.
      apply (always_unroll_n _ n), (always_unroll_n _ k), always_holds in Hld.
      eapply trace_append_list_steps_rtc_nl in Hld; [|done|done].
      revert Hld; rewrite rt_rtc_same.
      rewrite !trace_append_list_assoc -!inflist_take_add.
      rewrite !trace_append_list_assoc -!inflist_take_add in Hex2.
      intros Hld.
      apply locs_all_defined in Hld.
      destruct Hex2 as (_ & vmf & Hvrel%trace_forall3_last & Hsevs & Hrevs).
      rewrite Hld in Hvrel, Hrevs, Hsevs.
      split_and!.
      + done.
      + apply gcounter_values_related_now_resolve_locs; auto.
      + apply send_evs_rel_resolve_locs; auto.
      + apply receive_evs_rel_resolve_locs; auto.
  Qed.

End crdt_main_rel.


Require Import Bool.
Require Import List.

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

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

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

Require Import ReorderStep.
Require Import ProgressStep.

Require Import Syntax.
Require Import Semantics.

Set Implicit Arguments.

Inductive reorder_store l1 v1 o1: forall (i2:Instr.t), Prop :=
| reorder_store_load
    r2 l2 o2
    (ORD1: Ordering.le o1 Ordering.relaxed)
    (ORD2: Ordering.le o2 Ordering.relaxed)
    (LOC: l1 <> l2)
    (REGS: RegSet.disjoint (Instr.regs_of (Instr.store l1 v1 o1))
                           (Instr.regs_of (Instr.load r2 l2 o2))):
    reorder_store l1 v1 o1 (Instr.load r2 l2 o2)
| reorder_store_store
    l2 v2 o2
    (ORD1: Ordering.le o1 Ordering.relaxed)
    (LOC: l1 <> l2):
    reorder_store l1 v1 o1 (Instr.store l2 v2 o2)
| reorder_store_update
    r2 l2 rmw2 or2 ow2
    (ORD1: Ordering.le o1 Ordering.relaxed)
    (ORDR2: Ordering.le or2 Ordering.relaxed)
    (LOC: l1 <> l2)
    (REGS: RegSet.disjoint (Instr.regs_of (Instr.store l1 v1 o1)) (RegSet.singleton r2)):
    reorder_store l1 v1 o1 (Instr.update r2 l2 rmw2 or2 ow2)
.

Inductive sim_store: forall (st_src:lang.(Language.state)) (lc_src:Local.t) (sc1_src:TimeMap.t) (mem1_src:Memory.t)
                       (st_tgt:lang.(Language.state)) (lc_tgt:Local.t) (sc1_tgt:TimeMap.t) (mem1_tgt:Memory.t), Prop :=
| sim_store_intro
    l1 f1 t1 v1 released1 o1 i2 rs
    lc1_src sc1_src mem1_src
    lc1_tgt sc1_tgt mem1_tgt
    lc2_src sc2_src
    (REORDER: reorder_store l1 v1 o1 i2)
    (FULFILL: fulfill_step lc1_src sc1_src l1 f1 t1 (RegFile.eval_value rs v1) None released1 o1 lc2_src sc2_src)
    (LOCAL: sim_local lc2_src lc1_tgt)
    (SC: TimeMap.le sc2_src sc1_tgt)
    (MEMORY: sim_memory mem1_src mem1_tgt)
    (WF_SRC: Local.wf lc1_src mem1_src)
    (WF_TGT: Local.wf lc1_tgt mem1_tgt)
    (SC_SRC: Memory.closed_timemap sc1_src mem1_src)
    (SC_TGT: Memory.closed_timemap sc1_tgt mem1_tgt)
    (MEM_SRC: Memory.closed mem1_src)
    (MEM_TGT: Memory.closed mem1_tgt):
    sim_store
      (State.mk rs [Stmt.instr i2; Stmt.instr (Instr.store l1 v1 o1)]) lc1_src sc1_src mem1_src
      (State.mk rs [Stmt.instr i2]) lc1_tgt sc1_tgt mem1_tgt
.

Lemma sim_store_mon
      st_src lc_src sc1_src mem1_src
      st_tgt lc_tgt sc1_tgt mem1_tgt
      sc2_src mem2_src
      sc2_tgt mem2_tgt
      (SIM1: sim_store st_src lc_src sc1_src mem1_src
                       st_tgt lc_tgt sc1_tgt mem1_tgt)
      (SC_FUTURE_SRC: TimeMap.le sc1_src sc2_src)
      (SC_FUTURE_TGT: TimeMap.le sc1_tgt sc2_tgt)
      (MEM_FUTURE_SRC: Memory.future mem1_src mem2_src)
      (MEM_FUTURE_TGT: Memory.future mem1_tgt mem2_tgt)
      (SC1: TimeMap.le sc2_src sc2_tgt)
      (MEM1: sim_memory mem2_src mem2_tgt)
      (WF_SRC: Local.wf lc_src mem2_src)
      (WF_TGT: Local.wf lc_tgt mem2_tgt)
      (SC_SRC: Memory.closed_timemap sc2_src mem2_src)
      (SC_TGT: Memory.closed_timemap sc2_tgt mem2_tgt)
      (MEM_SRC: Memory.closed mem2_src)
      (MEM_TGT: Memory.closed mem2_tgt):
  sim_store st_src lc_src sc2_src mem2_src
            st_tgt lc_tgt sc2_tgt mem2_tgt.
Proof.
  inv SIM1. exploit future_fulfill_step; try exact FULFILL; eauto; try refl.
  { by inv REORDER. }
  i. des. econs; eauto.
Qed.

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

Lemma sim_store_step
      st1_src lc1_src sc1_src mem1_src
      st1_tgt lc1_tgt sc1_tgt mem1_tgt
      (SIM: sim_store st1_src lc1_src sc1_src mem1_src
                      st1_tgt lc1_tgt sc1_tgt mem1_tgt):
    _sim_thread_step lang lang ((sim_thread (sim_terminal eq)) \8/ sim_store)
                     st1_src lc1_src sc1_src mem1_src
                     st1_tgt lc1_tgt sc1_tgt mem1_tgt.
Proof.
  inv SIM. ii.
  exploit fulfill_step_future; eauto; try viewtac. i. des.
  inv STEP_TGT; [inv STEP|inv STEP; inv LOCAL0];
    try (inv STATE; inv INSTR; inv REORDER); ss.
  - (* promise *)
    exploit Local.promise_step_future; eauto. i. des.
    exploit sim_local_promise; try exact LOCAL0; (try by etrans; eauto); eauto. i. des.
    exploit reorder_fulfill_promise; try exact FULFILL; try exact STEP_SRC; eauto. i. des.
    exploit Local.promise_step_future; eauto. i. des.
    esplits.
    + eauto.
    + econs 2. econs 1. econs; eauto.
    + auto.
    + etrans; eauto.
    + auto.
    + right. econs; eauto.
      eapply Memory.future_closed_timemap; eauto.
  - (* load *)
    exploit sim_local_read; try exact LOCAL0; (try by etrans; eauto); eauto; try refl. i. des.
    exploit reorder_fulfill_read; try exact FULFILL; try exact STEP_SRC; eauto. i. des.
    exploit Local.read_step_future; try exact STEP1; eauto. i. des.
    exploit fulfill_write; eauto; try by viewtac. i. des.
    esplits.
    + econs 2; eauto. econs.
      * econs. econs 2. econs; [|econs 2]; eauto. econs. econs.
      * auto.
    + econs 2. econs 2. econs; [|econs 3]; eauto. econs.
      erewrite <- RegFile.eq_except_value; eauto.
      * econs.
      * symmetry. eauto.
      * apply RegFile.eq_except_singleton.
    + auto.
    + auto.
    + etrans; eauto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
  - (* update-load *)
    exploit sim_local_read; try exact LOCAL0; (try by etrans; eauto); eauto; try refl. i. des.
    exploit reorder_fulfill_read; try exact FULFILL; try exact STEP_SRC; eauto. i. des.
    exploit Local.read_step_future; try exact STEP1; eauto. i. des.
    exploit fulfill_write; eauto; try by viewtac. i. des.
    esplits.
    + econs 2; eauto. econs.
      * econs. econs 2. econs; [|econs 2]; eauto. econs. econs. eauto.
      * auto.
    + econs 2. econs 2. econs; [|econs 3]; eauto. econs.
      erewrite <- RegFile.eq_except_value; eauto.
      * econs.
      * symmetry. eauto.
      * apply RegFile.eq_except_singleton.
    + auto.
    + auto.
    + etrans; eauto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
  - (* store *)
    hexploit sim_local_write; try exact LOCAL1; eauto; try refl; try by viewtac. i. des.
    exploit reorder_fulfill_write; try exact FULFILL; try exact STEP_SRC; eauto; try by viewtac. i. des.
    exploit Local.write_step_future; try exact STEP1; eauto; try by viewtac. i. des.
    exploit fulfill_write; eauto; try by viewtac. i. des.
    esplits.
    + econs 2; eauto. econs.
      * econs. econs 2. econs; [|econs 3]; eauto. econs. econs.
      * auto.
    + econs 2. econs 2. econs; [|econs 3]; eauto. econs. econs.
    + auto.
    + etrans; eauto.
    + etrans; eauto. etrans; eauto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
      etrans; eauto.
  - (* update *)
    exploit fulfill_step_future; try exact FULFILL; eauto; try by viewtac. i. des.
    exploit Local.read_step_future; try exact LOCAL1; eauto; try by viewtac. i. des.
    exploit sim_local_read; try exact LOCAL1; (try by etrans; eauto); eauto; try refl. i. des.
    exploit Local.read_step_future; try exact STEP_SRC; eauto. i. des.
    hexploit sim_local_write; try exact LOCAL2; eauto; try refl; try by viewtac. i. des.
    hexploit reorder_fulfill_update; try exact FULFILL; try exact STEP_SRC; try exact STEP_SRC0; eauto; try by viewtac. i. des.
    exploit Local.read_step_future; try apply STEP1; eauto. i. des.
    exploit Local.write_step_future; try apply STEP2; eauto. i. des.
    exploit fulfill_write; eauto; try exact STEP3; try by viewtac. i. des.
    esplits.
    + econs 2; eauto. econs.
      * econs. econs 2. econs; [|econs 4]; eauto. econs. econs. eauto.
      * auto.
    + econs 2. econs 2. econs; [|econs 3]; eauto. econs.
      erewrite <- RegFile.eq_except_value; eauto.
      * econs.
      * symmetry. eauto.
      * apply RegFile.eq_except_singleton.
    + auto.
    + etrans; eauto.
    + etrans; eauto. etrans; eauto.
    + left. eapply paco9_mon; [apply sim_stmts_nil|]; ss.
      etrans; eauto.
Qed.

Lemma sim_store_sim_thread:
  sim_store <8= (sim_thread (sim_terminal eq)).
Proof.
  pcofix CIH. i. pfold. ii. ss. splits; ss; ii.
  - inv TERMINAL_TGT. inv PR; ss.
  - exploit sim_store_mon; eauto. i.
    exploit sim_store_future; try apply x0; eauto. i. des.
    esplits; eauto.
  - exploit sim_store_mon; eauto. i.
    inversion x0. subst. i.
    exploit (progress_program_step rs i2 nil); eauto. i. des.
    destruct th2. exploit sim_store_step; eauto.
    { econs 2. eauto. }
    i. des.
    + exploit program_step_promise; eauto. i.
      exploit Thread.rtc_tau_step_future; eauto. s. i. des.
      exploit Thread.opt_step_future; eauto. s. i. des.
      exploit Thread.program_step_future; eauto. s. i. des.
      punfold SIM. exploit SIM; try apply SC3; eauto; try refl. s. i. des.
      exploit PROMISES; eauto. i. des.
      esplits; [|eauto].
	    etrans; eauto. etrans; [|eauto].
      inv STEP_SRC; eauto. econs 2; eauto. econs; eauto.
      * econs. eauto.
      * etrans; eauto.
        destruct e; by inv STEP; inv STATE; inv INSTR; inv REORDER.
    + inv SIM. inv STEP; inv STATE.
  - exploit sim_store_mon; eauto. i. des.
    exploit sim_store_step; eauto. i. des.
    + esplits; eauto.
      left. eapply paco9_mon; eauto. ss.
    + esplits; eauto.
Qed.


Require Import CertiGraph.unionfind.env_unionfind.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.graph_relation.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.msl_application.Graph.
Require Import CertiGraph.msl_application.UnionFindGraph.
Require Import CertiGraph.msl_application.GList.
Require Import CertiGraph.msl_application.GList_UnionFind.
Require Import CertiGraph.floyd_ext.share.
Require Import CertiGraph.unionfind.spatial_graph_glist.

Local Coercion UFGraph_LGraph: UFGraph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion ULGraph_LGraph: LGraph >-> UnionFindGraph.LGraph.
Local Identity Coercion LGraph_LabeledGraph: UnionFindGraph.LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Notation vertices_at sh P g:= (@vertices_at _ _ _ _ _ mpred (@SGP pSGG_VST nat unit (sSGG_VST sh)) (SGA_VST sh) P g).
Notation whole_graph sh g := (vertices_at sh (vvalid g) g).
Notation graph sh x g := (@reachable_vertices_at _ _ _ _ _ _ _ _ _ _ (@SGP pSGG_VST nat unit (sSGG_VST sh)) _ x g).
Notation UFGraph := (@UFGraph pSGG_VST).
Notation uf_under_bound g := (uf_under_bound id g).
Existing Instances maGraph finGraph liGraph RGF.

Definition vlabel_in_bound (g: UFGraph) := forall x, vvalid g x -> Z.of_nat (vlabel g x) <= Int.max_unsigned.

Lemma rank_unchanged_in_bound: forall (g g': UFGraph), uf_equiv g g' -> rank_unchanged g g' -> vlabel_in_bound g -> vlabel_in_bound g'.
Proof. unfold uf_equiv, rank_unchanged, vlabel_in_bound. intros. destruct H as [? _]. pose proof H2. rewrite <- H in H2. rewrite <- H0; auto. Qed.

Definition mallocN_spec :=
 DECLARE _mallocN
  WITH sh: wshare, n:Z
  PRE [tint]
     PROP (0 <= n <= Int.max_signed)
     PARAMS (Vint (Int.repr n))
     GLOBALS ()
     SEP ()
  POST [ tptr tvoid ]
     EX v: addr,
     PROP ()
     LOCAL (temp ret_temp (pointer_val_val v))
     SEP (data_at sh node_type (pointer_val_val null, (Vint (Int.repr 0)))
              (pointer_val_val v)).

Definition find_spec :=
 DECLARE _find
  WITH sh: wshare, g: UFGraph, x: pointer_val
  PRE [tptr (Tstruct _Node noattr)]
          PROP  (vvalid g x ; uf_under_bound g)
          PARAMS (pointer_val_val x)
          GLOBALS ()
          SEP   (whole_graph sh g)
  POST [ tptr (Tstruct _Node noattr) ]
        EX g': UFGraph, EX rt : pointer_val,
        PROP (uf_equiv g g'; uf_root g' x rt ; uf_under_bound g' ; rank_unchanged g g')
        LOCAL (temp ret_temp (pointer_val_val rt))
        SEP (whole_graph sh g').

Definition unionS_spec :=
 DECLARE _unionS
  WITH sh: wshare, g: UFGraph, x: pointer_val, y: pointer_val
  PRE [tptr (Tstruct _Node noattr), tptr (Tstruct _Node noattr)]
          PROP  (vvalid g x; vvalid g y ; uf_under_bound g ; vlabel_in_bound g)
          PARAMS (pointer_val_val x; pointer_val_val y)
          GLOBALS ()
          SEP   (whole_graph sh g)
  POST [ Tvoid ]
        EX g': UFGraph,
        PROP (uf_union g x y g' ; uf_under_bound g')
        LOCAL()
        SEP (whole_graph sh g').

Definition makeSet_spec :=
  DECLARE _makeSet
  WITH sh: wshare, g: UFGraph
    PRE []
      PROP (uf_under_bound g)
      PARAMS ()
      GLOBALS ()
      SEP (whole_graph sh g)
    POST [tptr (Tstruct _Node noattr)]
      EX g': UFGraph, EX rt: pointer_val,
      PROP (~ vvalid g rt ; vvalid g' rt ; is_partial_graph g g' ; uf_under_bound g')
      LOCAL (temp ret_temp (pointer_val_val rt))
      SEP (whole_graph sh g').

Definition Gprog : funspecs := ltac:(with_library prog [mallocN_spec; makeSet_spec; find_spec; unionS_spec]).

Lemma body_makeSet: semax_body Vprog Gprog f_makeSet makeSet_spec.
Proof.
  start_function.
  forward_call (sh, 8).
  - rep_lia.
  - Intros x.
    assert_PROP (x <> null) as x_not_null by (entailer !; destruct H1 as [? _]; apply H1).
    assert_PROP (~ vvalid g x) by (entailer; apply (@vertices_at_sepcon_unique_1x _ _ _ _ SGBA_VST _ _ (SGA_VST sh) (SGAvs_VST sh) g x (vvalid g) (O, null))).
    forward. forward. forward.
    Exists (make_set_Graph O tt tt x g x_not_null H0) x. entailer !.
    + split; [|split]; simpl; [right | apply is_partial_make_set_pregraph | apply uf_under_bound_make_set_graph]; auto.
    + assert (Coqlib.Prop_join (vvalid g) (eq x) (vvalid (make_set_Graph 0%nat tt tt x g x_not_null H0))). {
        simpl; hnf; split; intros; [unfold graph_gen.addValidFunc | subst a]; intuition.
      } assert (vgamma (make_set_Graph O tt tt x g x_not_null H0) x = (O, x)). {
        unfold vgamma, UnionFindGraph.vgamma. simpl. f_equal.
        - destruct (SGBA_VE x x); [| hnf in c; unfold Equivalence.equiv in c; exfalso]; auto.
        - unfold graph_gen.updateEdgeFunc. destruct (EquivDec.equiv_dec (x, tt) (x, tt)). 2: compute in c; exfalso; auto. destruct (SGBA_VE null null); auto.
          hnf in c. unfold Equivalence.equiv in c. exfalso; auto.
      } rewrite <- (vertices_at_sepcon_1x (make_set_Graph 0%nat tt tt x g x_not_null H0) x (vvalid g) _ (O, x)); auto. apply sepcon_derives. 1: apply derives_refl.
      assert (vertices_at sh (vvalid g) g = vertices_at sh (vvalid g) (make_set_Graph O tt tt x g x_not_null H0)). {
        apply vertices_at_vertices_identical. simpl. hnf. intros. destruct a as [y ?]. unfold Morphisms_ext.app_sig. simpl.
        unfold UnionFindGraph.vgamma. simpl. unfold graph_gen.updateEdgeFunc. f_equal.
        - destruct (SGBA_VE y x); [hnf in e; subst y; exfalso |]; auto.
        - destruct (EquivDec.equiv_dec (x, tt) (y, tt)); auto. hnf in e. inversion e. subst y. exfalso; auto.
      } rewrite <- H6. apply derives_refl.
Qed.

Lemma false_Cne_eq: forall x y, typed_false tint (force_val (sem_cmp_pp Cne (pointer_val_val x) (pointer_val_val y))) -> x = y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; auto. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. subst; auto.
    + simpl in H. inversion H.
  - simpl in H. inversion H.
Qed.

Lemma true_Cne_neq: forall x y, typed_true tint (force_val (sem_cmp_pp Cne (pointer_val_val x) (pointer_val_val y))) -> x <> y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; [|intro; inversion H0..]. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + simpl in H. inversion H.
    + subst b0. pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. intro; apply H0. inversion H1. reflexivity.
  - intro. inversion H0. auto.
Qed.

Lemma graph_local_facts: forall sh x (g: UFGraph), vvalid g x -> whole_graph sh g |-- valid_pointer (pointer_val_val x).
Proof.
  intros. eapply derives_trans; [apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) x (vgamma g x)); auto |].
  simpl vertex_at at 1. unfold binode. entailer!.
Qed.

Lemma body_find: semax_body Vprog Gprog f_find find_spec.
Proof.
  start_function.
  remember (vgamma g x) as rpa eqn:?H. destruct rpa as [r pa].
  (* p = x -> parent; *)
  localize [data_at sh node_type (vgamma2cdata (vgamma g x)) (pointer_val_val x)]. rewrite <- H1. simpl vgamma2cdata.
  forward. 1: entailer!; destruct pa; simpl; auto.
  unlocalize [whole_graph sh g].
  1: rewrite <- H1; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g (vvalid g) x (r, pa)); auto.
  assert (H_PARENT_Valid: vvalid g pa) by (eapply valid_parent; eauto).
  (* if (p != x) { *)
  forward_if
    (EX g': UFGraph, EX rt : pointer_val,
     PROP (uf_equiv g g' /\ uf_root g' x rt /\ uf_under_bound g' /\ rank_unchanged g g')
     LOCAL (temp _p (pointer_val_val rt); temp _x (pointer_val_val x))
     SEP (whole_graph sh g')).
  - apply denote_tc_test_eq_split; apply graph_local_facts; auto.
  - (* p0 = find(p); *)
    forward_call (sh, g, pa). Intros vret. destruct vret as [g' root]. simpl fst in *. simpl snd in *.
    Opaque pointer_val_val. forward. Transparent pointer_val_val.
    pose proof (true_Cne_neq _ _ H2).
    assert (weak_valid g' root) by (right; destruct H4; apply reachable_foot_valid in H4; auto).
    assert (vvalid g' x) by (destruct H3 as [? _]; rewrite <- H3; apply H).
    assert (~ reachable g' root x) by (apply (uf_equiv_not_reachable g g' x r pa root); auto).
    assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g' x root H8 H9 H10)) (Graph_gen_redirect_parent g' x root H8 H9 H10) =
            vertices_at sh (vvalid g') (Graph_gen_redirect_parent g' x root H8 H9 H10)). {
      apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
    remember (vgamma g' x) as rpa eqn:?H. destruct rpa as [r' pa']. symmetry in H12.
    localize [data_at sh node_type (Vint (Int.repr (Z.of_nat r')), pointer_val_val pa') (pointer_val_val x)].
    forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g' x root H8 H9 H10)].
    + rewrite H11. apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto. destruct H4.
      apply reachable_foot_valid in H4. intro. subst root. apply (valid_not_null g' null H4). simpl. auto.
    + Exists (Graph_gen_redirect_parent g' x root H8 H9 H10) root. rewrite H11. entailer!.
      assert (uf_root g' x root). {
        rewrite <- (uf_equiv_root_the_same g g' x root); auto.
        apply (uf_root_edge _ (liGraph g) _ pa); [| apply (vgamma_not_dst g x r pa) | rewrite (uf_equiv_root_the_same g g')]; auto.
      } split; [|split].
      * apply (graph_gen_redirect_parent_equiv g g' x r pa); auto.
      * simpl. apply (uf_root_gen_dst_same g' (liGraph g') x x root); auto. apply reachable_refl; auto.
      * apply uf_under_bound_redirect_parent; auto.
  - forward. Exists g x. entailer!. apply false_Cne_eq in H2. subst pa. split; [|split; [split |]]; auto.
    + apply (uf_equiv_refl _  (liGraph g)).
    + apply uf_root_vgamma with (n := r); auto.
    + repeat intro; auto.
  - Intros g' rt. forward. Exists g' rt. entailer!.
Qed. (* Original: 56.251 secs; VST 2.*: 2.084 secs*)

(* Print Assumptions body_find. *)

Lemma true_Ceq_eq: forall x y, typed_true tint (force_val (sem_cmp_pp Ceq (pointer_val_val x) (pointer_val_val y))) -> x = y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; auto. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. subst. reflexivity.
    + simpl in H. inversion H.
  - simpl in H. inversion H.
Qed.

Lemma false_Ceq_neq: forall x y, typed_false tint (force_val (sem_cmp_pp Ceq (pointer_val_val x) (pointer_val_val y))) -> x <> y.
Proof.
  intros. hnf in H. destruct x, y; inversion H; [|intro; inversion H0..]. simpl in H. clear H1. unfold sem_cmp_pp in H. simpl in H. destruct (eq_block b b0).
  - destruct (Ptrofs.eq i i0) eqn:? .
    + simpl in H. inversion H.
    + pose proof (Ptrofs.eq_spec i i0). rewrite Heqb1 in H0. intro. apply H0. inversion H1. reflexivity.
  - intro. apply n. inversion H0; reflexivity.
Qed.

Lemma body_unionS: semax_body Vprog Gprog f_unionS unionS_spec.
Proof.
  start_function.
  forward_call (sh, g, x). Intros vret. destruct vret as [g1 x_root]. simpl fst in *. simpl snd in *. apply rank_unchanged_in_bound in H6; auto.
  assert (vvalid g1 y) by (destruct H3 as [? _]; rewrite <- H3; apply H0).
  forward_call (sh, g1, y). Intros vret. destruct vret as [g2 y_root]. simpl fst in *. simpl snd in *. apply rank_unchanged_in_bound in H11; auto.
  assert (H_VALID_XROOT: vvalid g2 x_root) by (destruct H8 as [? _]; rewrite <- H8; destruct H4; apply reachable_foot_valid in H4; apply H4).
  assert (H_VALID_YROOT: vvalid g2 y_root) by (destruct H9; apply reachable_foot_valid in H9; apply H9).
  assert (H_XROOT_NOT_NULL: x_root <> null) by (intro; subst x_root; apply (valid_not_null g2 null H_VALID_XROOT); simpl; auto).
  assert (H_YROOT_NOT_NULL: y_root <> null) by (intro; subst y_root; apply (valid_not_null g2 null H_VALID_YROOT); simpl; auto).
  forward_if_tac
    (PROP (x_root <> y_root)
     LOCAL (temp _yRoot (pointer_val_val y_root); temp _xRoot (pointer_val_val x_root);
     temp _x (pointer_val_val x); temp _y (pointer_val_val y))
     SEP (vertices_at sh (vvalid g2) g2)).
  - apply denote_tc_test_eq_split; apply graph_local_facts; auto.
  - forward. apply true_Ceq_eq in H12. Exists g2. subst y_root. entailer!. apply (the_same_root_union g g1 g2 x y x_root); auto.
  - forward. apply false_Ceq_neq in H12. entailer!.
  - Intros. (* xRank = xRoot -> rank; *)
    remember (vgamma g2 x_root) as rpa eqn:?H. destruct rpa as [rankXRoot paXRoot]. symmetry in H13.
    localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
    rewrite H13. simpl vgamma2cdata. forward.
    unlocalize [whole_graph sh g2].
    1: rewrite H13; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g2 (vvalid g2) x_root (rankXRoot, paXRoot)); auto.
    (* yRank = yRoot -> rank; *)
    remember (vgamma g2 y_root) as rpa eqn:?H. destruct rpa as [rankYRoot paYRoot]. symmetry in H14.
    localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
    rewrite H14. simpl vgamma2cdata. forward.
    unlocalize [whole_graph sh g2].
    1: rewrite H14; simpl; apply (@vertices_at_ramif_1_stable _ _ _ _ SGBA_VST _ _ (SGA_VST sh) g2 (vvalid g2) y_root (rankYRoot, paYRoot)); auto.
    rename H_VALID_XROOT into H15. clear H1 H2 H5 H6.
    assert (Int.unsigned (Int.repr (Z.of_nat rankXRoot)) = Z.of_nat (vlabel g2 x_root)). {
      simpl vgamma in H13. inversion H13. apply Int.unsigned_repr. split; [apply Zle_0_nat | specialize (H11 x_root H15); auto].
    } assert (Int.unsigned (Int.repr (Z.of_nat rankYRoot)) = Z.of_nat (vlabel g2 y_root)). {
      simpl vgamma in H14. inversion H14. apply Int.unsigned_repr. split; [apply Zle_0_nat | specialize (H11 y_root H_VALID_YROOT); auto].
    } clear H11.
    forward_if
      (EX g': UFGraph,
       PROP (uf_union g x y g' /\ uf_under_bound g')
       LOCAL (temp _xRank (Vint (Int.repr (Z.of_nat rankXRoot))); temp _yRank (Vint (Int.repr (Z.of_nat rankYRoot)));
              temp _xRoot (pointer_val_val x_root); temp _yRoot (pointer_val_val y_root);
              temp _x (pointer_val_val x); temp _y (pointer_val_val y))
       SEP (whole_graph sh g')).
    + assert (weak_valid g2 y_root) by (right; auto).
      assert (~ reachable g2 y_root x_root) by (intro; destruct H9; specialize (H16 _ H11); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g2 x_root y_root H6 H15 H11)) (Graph_gen_redirect_parent g2 x_root y_root H6 H15 H11) =
              vertices_at sh (vvalid g2) (Graph_gen_redirect_parent g2 x_root y_root H6 H15 H11)). {
        apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
      (* xRoot -> parent = yRoot; *)
      localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
      rewrite H13. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 x_root y_root H6 H15 H11)].
      1: rewrite H13; simpl vgamma2cdata; rewrite H16; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
      Exists (Graph_gen_redirect_parent g2 x_root y_root H6 H15 H11). entailer !. split.
      * apply (diff_root_union_1 g g1 g2 x y x_root y_root); auto.
      * rewrite H1 in *. rewrite H2 in *. rewrite <- Nat2Z.inj_lt in H5. destruct H9. apply uf_under_bound_redirect_parent_lt; auto.
    + assert (weak_valid g2 x_root) by (right; auto). rename H_VALID_YROOT into H11.
      assert (~ reachable g2 x_root y_root) by (intro; rewrite (uf_equiv_root_the_same g1 g2) in H4; auto; destruct H4; specialize (H17 _ H16); auto).
      assert (vertices_at sh (vvalid (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16)) (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16) =
              vertices_at sh (vvalid g2) (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16)). {
        apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition. }
      forward_if
      (EX g': UFGraph,
       PROP (uf_union g x y g' /\ uf_under_bound g')
       LOCAL (temp _xRank (Vint (Int.repr (Z.of_nat rankXRoot))); temp _yRank (Vint (Int.repr (Z.of_nat rankYRoot)));
              temp _xRoot (pointer_val_val x_root); temp _yRoot (pointer_val_val y_root);
              temp _x (pointer_val_val x); temp _y (pointer_val_val y))
       SEP (whole_graph sh g')).
      * (* yRoot -> parent = xRoot; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
        rewrite H14. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16)].
        1: rewrite H14; simpl vgamma2cdata; rewrite H17; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
        Exists (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16). entailer!. split.
        -- apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto.
        -- rewrite H1 in *. rewrite H2 in *. rewrite <- Nat2Z.inj_lt in H18. apply uf_under_bound_redirect_parent_lt; auto.
           rewrite (uf_equiv_root_the_same g1 g2) in H4; auto. destruct H4. auto.
      * (* yRoot -> parent = xRoot; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 y_root)) (pointer_val_val y_root)].
        rewrite H14. simpl vgamma2cdata. forward. unlocalize [whole_graph sh (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16)].
        1: rewrite H14; simpl vgamma2cdata; rewrite H17; apply (@graph_gen_redirect_parent_ramify _ (sSGG_VST sh)); auto.
        set (g3 := Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16).
        assert (uf_union g x y g3) by (subst g3; simpl; apply (diff_root_union_2 g g1 g2 x y x_root y_root); auto).
        (* xRoot -> rank = xRank + 1; *)
        localize [data_at sh node_type (vgamma2cdata (vgamma g2 x_root)) (pointer_val_val x_root)].
        rewrite H13. simpl vgamma2cdata. forward.
        rewrite add_repr. replace (Z.of_nat rankXRoot + 1) with (Z.of_nat (rankXRoot + 1)). 2: rewrite Nat2Z.inj_add; simpl; auto.
        unlocalize [whole_graph sh (Graph_vgen g3 x_root (rankXRoot + 1)%nat)].
        -- assert (vertices_at sh (vvalid (Graph_vgen g3 x_root (rankXRoot + 1)%nat)) (Graph_vgen g3 x_root (rankXRoot + 1)%nat) =
                   vertices_at sh (vvalid g3) (Graph_vgen g3 x_root (rankXRoot + 1)%nat)). {
             apply vertices_at_Same_set. unfold Ensembles.Same_set, Ensembles.Included, Ensembles.In. simpl. intuition.
           } rewrite H20. clear H20. rewrite H13. simpl vgamma2cdata. apply (@graph_vgen_ramify _ (sSGG_VST sh)).
           ++ subst g3. simpl. destruct H8 as [? _]. rewrite <- H8. destruct H4; apply reachable_foot_valid in H4; apply H4.
           ++ subst g3. remember (Graph_gen_redirect_parent g2 y_root x_root H6 H11 H16) as g3.
              apply (graph_gen_redirect_parent_vgamma _ _ _ rankXRoot paXRoot) in Heqg3; auto. intros. inversion H20; auto.
        -- Exists (Graph_vgen g3 x_root (rankXRoot + 1)%nat). entailer!. rewrite H1 in *; rewrite H2 in *.
           assert (Z.of_nat (vlabel g2 x_root) = Z.of_nat (vlabel g2 y_root)) by (clear -H5 H18; intuition). apply Nat2Z.inj in H24.
           simpl in H13. inversion H13. apply uf_under_bound_redirect_parent_eq; auto. rewrite (uf_equiv_root_the_same g1 g2) in H4; auto. destruct H4. auto.
    + Intros g'. Exists g'. entailer!.
Qed. (* Original: 192.772 secs; VST 2.*: 4.786 secs *)