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 *)