Require Import VST.progs.conclib.
Require Import VST.floyd.proofauto.
Require Import VST.floyd.library.
Require Import bst.puretree.
Require Import bst.bst_conc.
Require Import VST.atomics.general_locks.
Require Import bst.verif_bst_conc_atomic.
Require Import Coq.Sets.Ensembles.

Ltac allpr_intros x := apply allp_right; intros x. (* Temporary *)

Lemma gt_ghost_sorted : forall t1 t2 k k0 v0 g g0,
  gt_ghost (T_ghost t1 g k0 v0 t2 g0) k ->
  gt_ghost (V := val) t1 k /\ gt_ghost (V := val) t2 k.
Proof.
  intros. unfold gt_ghost in H.
  split; unfold gt_ghost; intros; apply H.
  * apply InLeft_ghost; auto.
  * apply InRight_ghost; auto.
Qed.

Lemma change_ghost_root: forall tg gl rootl rootr,
  sorted_ghost_tree tg ->
  ghost_tree_rep tg gl (rootl, rootr) |--
  EX o : option ghost_info,
    !! (match o with
        | None => tg = E_ghost
        | Some (x, y, g1, g2) => (exists tg1 tg2, tg = T_ghost tg1 g1 x y tg2 g2)
        end) &&
    (public_half gl (rootl, rootr, Some o)) *
    (ALL rootl2 : number, ALL rootr2 : number, ALL g : gname,
      !! (range_incl (rootl, rootr) (rootl2, rootr2) = true) &&
      public_half g (rootl2, rootr2, Some o) -* |==> ghost_tree_rep tg g (rootl2, rootr2)).
Proof.
  induction tg; intros.
  - simpl. Exists (None: @option ghost_info). entailer!.
    allpr_intros rootl2; allpr_intros rootr2; allpr_intros g.
    rewrite <- wand_sepcon_adjoint. rewrite emp_sepcon. Intros.
    apply ghost_seplog.bupd_intro.
  - simpl. Exists (Some (k, v, g, g0)). entailer!. { eauto. }
    allpr_intros rootl2; allpr_intros rootr2; allpr_intros g'.
    inv H. sep_apply IHtg1. sep_apply IHtg2.
    Intros o1 o2.
    rewrite <- wand_sepcon_adjoint.
    iIntros "((Ha & Hb) & Hc)". logic_to_iris.
    iDestruct "Ha" as "[root_left tree_left]".
    iDestruct "Hb" as "[root_right tree_right]".
    iSpecialize ("tree_left" $! (Finite_Integer k) rootr2  g0).
    iSpecialize ("tree_right" $! rootl2 (Finite_Integer k) g).
    iDestruct "Hc" as "[% Hc]". apply andb_prop in H1. destruct H1.
    assert (range_incl (rootl, Finite_Integer k) (rootl2, Finite_Integer k) = true). {
      apply andb_true_intro. split; try apply less_than_equal_refl. auto.
    }
    assert (range_incl (Finite_Integer k, rootr) (Finite_Integer k, rootr2) = true). {
      apply andb_true_intro. split; try apply less_than_equal_refl. auto.
    }
    iMod (public_half_range_incl with "root_right") as "root_right".
    { eauto. }
    iMod (public_half_range_incl with "root_left") as "root_left".
    { eauto. }
    repeat logic_to_iris.
    iMod ("tree_right" with "[$root_right]"). iPureIntro.
    split; auto.
    iMod ("tree_left" with "[$root_left]"). iPureIntro.
    split; auto. iModIntro. iFrame.
Qed.

Fixpoint pushdown_ghost {V} (c ab: @ghost_tree V) : ghost_tree :=
  match ab with
  | E_ghost => c
  | T_ghost a ga y v' b gb => T_ghost (pushdown_ghost c a) ga y v' b gb
  end.

Fixpoint delete_ghost {V} (x: key) (s: @ghost_tree V) : ghost_tree :=
  match s with
  | E_ghost => E_ghost
  | T_ghost a ga y v' b gb => if x <? y then T_ghost (delete_ghost x a) ga y v' b gb
                              else if y <? x then T_ghost a ga y v' (delete_ghost x b) gb
                              else pushdown_ghost a b
  end.

Arguments range_incl : simpl never.

(* up *)
Lemma Subtract_Union1 : forall {A} S1 S2 (x : A), ~In S2 x -> Subtract (Union S1 S2) x = Union (Subtract S1 x) S2.
Proof.
  intros; apply Extensionality_Ensembles; split; intros ? Hin.
  - inv Hin.
    inv H0.
    + constructor 1; constructor 1; auto.
    + constructor 2; auto.
  - inv Hin.
    + inv H0.
      constructor; auto.
      constructor 1; auto.
    + constructor.
      constructor 2; auto.
      { intros X; inv X; contradiction. }
Qed.

Lemma Subtract_Add : forall {A} S (x : A), ~In S x -> Subtract (Add S x) x = S.
Proof.
  intros; apply Extensionality_Ensembles; split; intros ??.
  - inv H0.
    inv H1; auto; contradiction.
  - constructor.
    + constructor 1; auto.
    + intros X; inv X; contradiction.
Qed.

Lemma In_same_map : forall tg1 tg2 x, tree_to_gmap tg1 = tree_to_gmap tg2 -> In_ghost x tg1 <-> In_ghost x tg2.
Proof.
  intros.
  rewrite !In_tree_to_gmap H; reflexivity.
Qed.

Lemma ghost_tree_delete: forall tg g_root g_in gl gr x v (r_root: range),
 Ensembles.In (find_ghost_set tg g_root) g_in ->
 keys_in_range_ghost tg r_root ->
 sorted_ghost_tree tg -> unique_gname tg ->
 ~Ensembles.In (find_ghost_set' tg) g_root ->
 ghost_tree_rep tg g_root r_root |--
 EX n n0:number, EX o1:option ghost_info,
 !!(range_incl (n,n0) r_root = true) &&
 public_half g_in (n, n0, Some o1) *
 (!!(o1 = Some (x,v,gl,gr)) -->
   EX o3 : option ghost_info,
  public_half gr (Finite_Integer x, n0, Some o3) *
 ((EX o2 : option ghost_info,
        public_half gl (n, Finite_Integer x, Some o2) *
   (!!(o1 = Some (x,v,gl,gr) /\ o3 = None /\ (key_in_range x (n,n0) = true)) &&
      public_half g_in (n, n0, Some (* o1' *) o2) -* |==> (!! (In_ghost x tg
        /\ find_ghost_set (delete_ghost x tg) g_root = (Subtract (Subtract (find_ghost_set tg g_root) gl) gr)
        /\ Ensembles.In (find_ghost_set' tg) gl /\ Ensembles.In (find_ghost_set' tg) gr)
        && ghost_tree_rep (delete_ghost x tg) g_root r_root))%I)

   && (ALL gr1 gr2 : gname, ALL k : key, ALL y : val,
        (!!(o1 = Some (x,v,gl,gr) /\ o3 = Some (k, y, gr1, gr2)
          /\ (key_in_range x (n,n0) = true) /\ less_than (Finite_Integer x) (Finite_Integer k) = true) &&
        (public_half g_in (n, n0, Some (Some (k, y, gr, gr2)))
        * public_half gr (n, Finite_Integer k, Some (Some (x, v, gl, gr1))))
        -* |==> (EX tg',
          !!(tree_to_gmap tg = tree_to_gmap tg' /\
             find_ghost_set' tg = find_ghost_set' tg' /\
             sorted_ghost_tree tg' /\ unique_gname tg') &&
           ghost_tree_rep tg' g_root r_root)))%I)).
Proof.
  induction tg; destruct r_root as (rootl, rootr); simpl; intros Hin Hrange Hsorted Hunique Hroot.
  - inv Hin.
    Exists rootl rootr (None : @option ghost_info).
    rewrite range_incl_refl; entailer!.
    rewrite <- imp_andp_adjoint. Intros; discriminate.
  - apply keys_in_range_ghost_subtrees in Hrange as (Hk & Hl & Hr); auto.
    inv Hsorted; inv Hunique; inv Hin. inv H.
    + eapply IHtg1 in H0; [| eauto | eauto | eauto | eauto].
      simpl in H0; sep_apply H0; clear H0.
      Intros n1 n2 o1; Exists n1 n2 o1; entailer!.
      { eapply range_incl_trans; [eauto|].
        apply (key_in_range_l _ (_, _)); auto. }
      rewrite <- imp_andp_adjoint. Intros; subst.
      rewrite -> prop_imp by reflexivity.
      Intros o3 o2; Exists o3 o2; cancel.
      iIntros "((Hcase & ?) & ?)"; iSplit.
      * iDestruct "Hcase" as "[[$ IH] _]".
        iIntros "[(% & % & %) Hin]"; subst.
        iMod ("IH" with "[$Hin]") as "[(% & % & % & %) Hdel]"; [auto|].
        specialize (Hgtl _ H1).
        destruct (x <? k) eqn:?; [simpl; iFrame | lia].
        iPureIntro; split; auto; split3.
        -- apply InLeft_ghost; auto.
        -- rewrite -> empty_intersection in H8.
            rewrite H3 !Subtract_Union1; auto.
            ** rewrite find_ghost_set_equiv; intros X; inv X.
               unshelve eapply (H8 _ _ H14); eauto.
               inv H14; contradiction.
            ** rewrite find_ghost_set_equiv; intros X; inv X.
               unshelve eapply (H8 _ _ H14); eauto.
               inv H14; contradiction.
            ** intros X; inv X.
               contradiction Hroot; constructor 1.
               rewrite find_ghost_set_equiv; constructor 1; auto.
            ** intros X; inv X.
               contradiction Hroot; constructor 1.
               rewrite find_ghost_set_equiv; constructor 1; auto.
        -- split; rewrite find_ghost_set_equiv; do 2 constructor 1; auto.
      * iIntros (gr1 gr2 k0 y) "[(% & % & % & %) H]".
        iDestruct "Hcase" as "[_ IH]".
        logic_to_iris.
        iMod ("IH" $! gr1 gr2 k0 y with "[$H]") as (tg') "[(% & % & % & %) IH]"; [auto | subst].
        iExists (T_ghost tg' g k v tg2 g0); simpl; iFrame.
        iPureIntro; split; auto; split3.
        -- congruence.
        -- rewrite !find_ghost_set_equiv; congruence.
        -- split; constructor; rewrite <- ?H13; auto.
           intros ??; eapply Hgtl, In_same_map; eassumption.
    + eapply IHtg2 in H0; [| eauto | eauto | eauto | eauto].
      simpl in H0; sep_apply H0; clear H0.
      Intros n1 n2 o1; Exists n1 n2 o1; entailer!.
      { eapply range_incl_trans; [eauto|].
        apply (key_in_range_r _ (_, _)); auto. }
      rewrite <- imp_andp_adjoint; Intros; subst.
      rewrite -> prop_imp by reflexivity.
      Intros o3 o2; Exists o3 o2; cancel.
      iIntros "((Hcase & ?) & ?)"; iSplit.
      * iDestruct "Hcase" as "[[$ IH] _]".
        iIntros "[(% & % & %) Hin]"; subst.
        iMod ("IH" with "[$Hin]") as "[(% & % & % & %) Hdel]"; [auto|].
        specialize (Hltr _ H1).
        destruct (x <? k) eqn:?; [lia|].
        destruct (k <? x) eqn:?; [simpl; iFrame | lia].
        iPureIntro; split; auto; split3.
        -- apply InRight_ghost; auto.
        -- rewrite -> empty_intersection in H8.
            rewrite H3 Subtract_Union1.
            rewrite Subtract_Union1.
            rewrite (Union_comm _ (find_ghost_set _ _)) !Subtract_Union1.
            rewrite (Union_comm _ (find_ghost_set _ _)); auto.
            ** rewrite find_ghost_set_equiv; intros X; inv X.
               eapply (H8 _ H14); eauto.
               inv H14; contradiction.
            ** rewrite find_ghost_set_equiv; intros X; inv X.
               eapply (H8 _ H14); eauto.
               inv H14; contradiction.
            ** intros X; inv X.
               contradiction Hroot; constructor 2.
               rewrite find_ghost_set_equiv; constructor 1; auto.
            ** intros X; inv X.
               contradiction Hroot; constructor 2.
               rewrite find_ghost_set_equiv; constructor 1; auto.
        -- split; rewrite !find_ghost_set_equiv; constructor 2; constructor 1; auto.
      * iIntros (gr1 gr2 k0 y) "[(% & % & % & %) H]".
        iDestruct "Hcase" as "[_ IH]".
        logic_to_iris.
        iMod ("IH" $! gr1 gr2 k0 y with "[$H]") as (tg') "[(% & % & % & %) IH]"; [auto | subst].
        iExists (T_ghost tg1 g k v tg' g0); simpl; iFrame.
        iPureIntro; split; auto; split3.
        -- congruence.
        -- rewrite !find_ghost_set_equiv; congruence.
        -- split; constructor; rewrite <- ?H13; auto.
           intros ??; eapply Hltr, In_same_map; eassumption.
    + clear IHtg1 IHtg2. inv H. (* pushdown case *)
      Exists rootl rootr (Some (k, v, g, g0)); rewrite range_incl_refl; entailer!.
      rewrite <- imp_andp_adjoint; Intros. inv H.
      erewrite change_ghost_root by auto; Intros o2.
      destruct tg2; simpl.
      * Exists (None : @option ghost_info); cancel. apply andp_right.
        Exists o2; cancel. rewrite Z.ltb_irrefl. rewrite <- wand_sepcon_adjoint. entailer!.
        iIntros "(Ha & Hb)". iSpecialize ("Ha" $! rootl rootr g_in with "[$Hb]").
        { iPureIntro; split; auto. apply (key_in_range_l _ (_, _)); auto. }
        logic_to_iris. iMod "Ha" as "$"; iPureIntro.
        split; auto; split3.
        -- constructor 1; auto.
        -- unfold Add; rewrite -> 3Subtract_Union1, (find_ghost_set_equiv _ gl).
            fold (Add (find_ghost_set tg1 gl) gr). rewrite -> Subtract_Add by auto.
            fold (Add (find_ghost_set' tg1) gr). rewrite -> Subtract_Add by auto.
            apply find_ghost_set_equiv.
            { intros X; inv X; contradiction. }
            { intros X; inv X. contradiction Hroot. constructor 2; rewrite find_ghost_set_equiv; constructor 2; constructor. }
            { intros X; inv X. contradiction Hroot. constructor 1; rewrite find_ghost_set_equiv; constructor 2; constructor. }
        -- split; [constructor 1; rewrite find_ghost_set_equiv|]; constructor 2; constructor.
        -- allpr_intros gr1; allpr_intros gr2; allpr_intros k; allpr_intros y.
           rewrite <- wand_sepcon_adjoint; Intros; discriminate.
      * Exists (Some (k, v, g, g0)) o2; cancel. apply andp_right.
        { cancel. rewrite <- wand_sepcon_adjoint; Intros; discriminate. }
        allpr_intros gr1; allpr_intros gr2; allpr_intros k'; allpr_intros y.
        rewrite <- wand_sepcon_adjoint; entailer!.
        iIntros "(((((Ha & Hb) & Hc) & Hd) & He) & Hf)".
        iSpecialize ("Hb" $! rootl (Finite_Integer x) gl with "[$Ha]").
        { rewrite range_incl_refl; auto. }
        inv H0. logic_to_iris. iMod "Hb"; iModIntro.
        iExists (T_ghost (T_ghost tg1 gl x v0 tg2_1 gr1) gr k' y tg2_2 gr2); simpl; iFrame.
        iPureIntro; split; auto; split3; [.. | split].
        -- rewrite <- insert_union_l, <- insert_union_r, insert_commute, map_union_assoc; auto.
           { lia. }
           { destruct (eq_dec (tree_to_gmap tg1 !! k') None); auto. apply In_tree_to_gmap in n. specialize (Hgtl _ n); lia. }
        -- unfold Add; rewrite !Union_assoc.
           rewrite (Union_comm (Singleton _)); auto.
        -- inv Hsortedr. constructor; auto. constructor; auto.
           ++ intros ? Hin; apply Hltr. constructor 2; auto.
           ++ intros ? Hin; inv Hin; auto; try lia.
              specialize (Hgtl _ H3); lia.
        -- inv H6. constructor; auto. constructor; auto.
           ++ intros ?; subst. contradiction H10; simpl.
              constructor 1; rewrite find_ghost_set_equiv; constructor 2; constructor.
           ++ rewrite -> empty_intersection in *.
              intros ???; eapply H8; eauto.
              constructor 1; rewrite find_ghost_set_equiv; constructor 1; auto.
           ++ intros ?; contradiction H10; simpl.
              constructor 1; rewrite find_ghost_set_equiv; constructor 1; auto.
           ++ intros ?; rewrite -> empty_intersection in H8; eapply H8; eauto; simpl.
              constructor 1; rewrite find_ghost_set_equiv; constructor 2; constructor.
           ++ intros ?; subst. contradiction H11; simpl.
              constructor 2; rewrite find_ghost_set_equiv; constructor 2; constructor.
           ++ rewrite -> empty_intersection in *.
              simpl; intros ? Hunion ?; inv Hunion.
              rewrite find_ghost_set_equiv in H3; inv H3.
              { eapply H8; eauto; simpl. constructor 2; rewrite find_ghost_set_equiv; constructor 1; auto. }
              { inv H4; contradiction H10; simpl. constructor 2; rewrite find_ghost_set_equiv; constructor 1; auto. }
              { rewrite find_ghost_set_equiv in H3; inv H3. eapply H19; eauto. inv H4; contradiction. }
           ++ simpl; intros X; inv X.
              { rewrite find_ghost_set_equiv in H0; inv H0; auto. inv H3; contradiction. }
              { contradiction H11; simpl. constructor 1; auto. }
           ++ intros ?; contradiction H11; simpl. constructor 2; rewrite find_ghost_set_equiv; constructor 1; auto.
           ++ simpl; intros X; inv X.
              { rewrite find_ghost_set_equiv in H0; inv H0; auto.
                rewrite -> empty_intersection in H8; eapply H8; eauto; simpl. constructor 2; rewrite find_ghost_set_equiv; constructor 2; constructor.
                inv H3. contradiction H10; simpl. constructor 2; rewrite find_ghost_set_equiv; constructor 2; constructor. }
              { rewrite find_ghost_set_equiv in H0; inv H0; auto. inv H3; contradiction. }
Qed.

Lemma pushdown_tree_to_gmap : forall tg1 tg2,
  (forall x y, In_ghost x tg1 -> In_ghost y tg2 -> x < y) ->
  tree_to_gmap (pushdown_ghost tg1 tg2) = union (tree_to_gmap tg1) (tree_to_gmap tg2).
Proof.
  intros; revert dependent tg1; induction tg2; simpl; intros.
  - rewrite right_id; auto.
  - rewrite IHtg2_1.
    rewrite -map_union_assoc insert_union_r; auto.
    destruct (eq_dec (tree_to_gmap tg1 !! k) None); auto.
    apply In_tree_to_gmap, (H _ k) in n; first lia.
    constructor 1; auto.
    { intros; apply H; auto.
      constructor 2; auto. }
Qed.

Lemma delete_tree_to_gmap : forall tg x, sorted_ghost_tree tg ->
  tree_to_gmap (delete_ghost x tg) = delete x (tree_to_gmap tg).
Proof.
  intros; induction tg; auto; simpl.
  - symmetry; apply delete_empty.
  - inv H. destruct (x <? k) eqn: ?; [|destruct (k <? x) eqn: ?]; simpl.
    + rewrite IHtg1; auto.
      rewrite delete_insert_ne; last lia.
      rewrite delete_union (delete_notin (tree_to_gmap tg2)); auto.
      destruct (eq_dec (tree_to_gmap tg2 !! x) None); auto.
      apply In_tree_to_gmap, Hltr in n; lia.
    + rewrite IHtg2; auto.
      rewrite delete_insert_ne; last lia.
      rewrite delete_union (delete_notin (tree_to_gmap tg1)); auto.
      destruct (eq_dec (tree_to_gmap tg1 !! x) None); auto.
      apply In_tree_to_gmap, Hgtl in n; lia.
    + rewrite pushdown_tree_to_gmap.
      assert (x = k) by lia; subst; rewrite delete_insert; auto.
      rewrite lookup_union.
      destruct (eq_dec (tree_to_gmap tg1 !! k) None).
      * rewrite e; destruct (eq_dec (tree_to_gmap tg2 !! k) None).
        { rewrite e0; auto. }
        apply In_tree_to_gmap, Hltr in n; lia.
      * apply In_tree_to_gmap, Hgtl in n; lia.
      * intros ?? ?%Hgtl ?%Hltr; lia.
Qed.

Lemma In_pushdown_left_ghost: forall (t1 t2: ghost_tree) (x: key),
   In_ghost (V := val) x (pushdown_ghost t1 t2) -> In_ghost x t1 \/ In_ghost x t2.
Proof.
  intros. revert t2 H. induction t2; intros; simpl in *; auto. inv H.
  - right. now apply InRoot_ghost.
  - apply IHt2_1 in H1. destruct H1; [left | right]; auto. now apply InLeft_ghost.
  - right. now apply InRight_ghost.
Qed.

Lemma pushdown_left_ghost_sorted: forall (tg1 tg2: ghost_tree),
   sorted_ghost_tree tg1 -> sorted_ghost_tree tg2 -> (forall x y, In_ghost x tg1 -> In_ghost y tg2 -> x < y) ->
   sorted_ghost_tree (V := val) (pushdown_ghost tg1 tg2).
Proof.
  intros. revert tg2 H0 H1. induction tg2; intros; simpl in H0 |-*; auto.
  inv H0. constructor; auto.
  - apply IHtg2_1; auto. intros. apply H1; auto. now apply InLeft_ghost.
  - intros z ?. apply In_pushdown_left_ghost in H0. destruct H0.
    + apply Z.lt_gt, H1; auto. now apply InRoot_ghost.
    + now specialize (Hgtl _ H0).
Qed.

Lemma In_delete_ghost: forall (x: key) (t: ghost_tree) (y: key), In_ghost (V := val) y (delete_ghost x t) -> In_ghost y t.
Proof.
  intros. revert t H. induction t; intros; simpl in *; auto. destruct (x <? k).
  - inv H; try ((now apply InLeft_ghost) || (now apply InRoot_ghost) || (now apply InRight_ghost)).
    apply IHt1 in H1. now apply InLeft_ghost.
  - destruct (k <? x).
    + inv H; try ((now apply InLeft_ghost) || (now apply InRoot_ghost) || (now apply InRight_ghost)).
      apply IHt2 in H1. now apply InRight_ghost.
    + apply In_pushdown_left_ghost in H. destruct H; [apply InLeft_ghost | apply InRight_ghost]; easy.
Qed.

Lemma delete_ghost_sorted: forall (x: key) (t: ghost_tree),
   sorted_ghost_tree t -> sorted_ghost_tree (V := val) (delete_ghost x t).
Proof.
  intros. revert t H. induction t; intros; simpl; auto. inv H.
  destruct (x <? k) eqn: ?; [|destruct (k <? x) eqn: ?].
  - constructor; auto. intros ??%In_delete_ghost. now apply Hgtl.
  - constructor; auto. intros ??%In_delete_ghost. now apply Hltr.
  - apply pushdown_left_ghost_sorted; auto. intros.
    apply Hgtl in H; apply Hltr in H0; lia.
Qed.

Lemma in_tree_del : forall g s g1,
  in_tree g g1 * ghost_ref g s |-- (|==> ghost_ref g (Subtract s g1))%I.
Proof.
  intros. unfold in_tree at 1. Intros sh1. iIntros "H".
  rewrite ghost_part_ref_join.
  iMod (part_ref_update(P := set_PCM) _ _ _ _ (Subtract (Singleton g1) g1) (Subtract s g1) with "H") as "H".
  { intros. repeat constructor.
    - inversion 1; subst.
      inv H. inv H3. specialize (H x). contradict H.
      inv H1. split; auto.
    - inv H. apply Extensionality_Ensembles.
      split; unfold Included; intros.
      { inv H. inv H1.
        apply Union_introl. split; auto.
        apply Union_intror; auto. }
      { inv H. inv H1. congruence.
        split; auto.
        apply Union_intror; auto.
        inv H0. specialize (H x). contradict H.
        split; auto. } }
  fold (ghost_part_ref(P := set_PCM) sh1 (Subtract (Singleton g1) g1) (Subtract s g1) g).
  rewrite <- ghost_part_ref_join.
  iDestruct "H" as "[H $]". iMod (own_dealloc with "H"). auto.
Qed.

Lemma update_ghost_ref_delete: forall g gl gr s g_in, finite s ->
  (in_tree g g_in * ghost_ref g s * in_tree g gr * in_tree g gl  |-- |==>
    ghost_ref g (Subtract (Subtract s gl) gr) * in_tree g g_in)%I .
Proof.
  intros. iIntros "H". iDestruct "H" as "((Ha & Hc) & Hd)".
  iDestruct "Ha" as "(Ha & Hb)".
  iPoseProof (in_tree_del with "[$Hd $Hb]") as ">Hb".
  iPoseProof (in_tree_del with "[$Hc $Hb]") as ">Hb".
  iModIntro; iFrame.
Qed.

Lemma pushdown_find_ghost : forall t1 t2,
  sorted_ghost_tree t1 -> sorted_ghost_tree t2 ->
  find_ghost_set' (pushdown_ghost t1 t2) = Union (find_ghost_set' t1) (find_ghost_set' t2).
Proof.
  intros. revert dependent t1; induction t2; simpl; intros.
  + now rewrite -> Union_comm, Union_Empty.
  + inv H0. rewrite find_ghost_set_equiv.
    rewrite IHt2_1; auto. rewrite (find_ghost_set_equiv t2_1).
    unfold Add.
    rewrite <- (Union_assoc (find_ghost_set' t1) _ (find_ghost_set t2_2 g0)).
    rewrite -> (Union_assoc (find_ghost_set' t1) _ _). reflexivity.
Qed.

Lemma pushdown_left_ghost_unique: forall tg1 tg2,
  sorted_ghost_tree tg1 -> sorted_ghost_tree tg2 ->
  unique_gname tg1 -> unique_gname tg2 ->
  Intersection (find_ghost_set' tg1) (find_ghost_set' tg2) = @Empty_set gname ->
  (forall x y, In_ghost x tg1 -> In_ghost y tg2 -> x < y) ->
  unique_gname (pushdown_ghost tg1 tg2).
Proof.
  induction tg2; simpl; intros; auto.
  inv H0. inv H2. apply Unique_Tree; auto.
  - apply IHtg2_1; auto.
    rewrite -> empty_intersection in *; intros ???.
    eapply H3; eauto.
    constructor 1. rewrite find_ghost_set_equiv; constructor 1; auto.
    { intros; apply H4; auto. apply InLeft_ghost; auto. }
  - rewrite pushdown_find_ghost; auto.
    rewrite -> empty_intersection in *; intros ? Hin ?.
    inv Hin.
    + eapply H3; eauto.
      constructor 2. rewrite find_ghost_set_equiv; constructor 1; auto.
    + eapply H13; eauto.
  - rewrite pushdown_find_ghost; auto.
    intros Hcontra; inv Hcontra; try contradiction.
    rewrite -> empty_intersection in H3; eapply H3; eauto.
    constructor 1; rewrite find_ghost_set_equiv; constructor 2; constructor.
  - rewrite pushdown_find_ghost; auto.
    intros Hcontra; inv Hcontra; try contradiction.
    rewrite -> empty_intersection in H3; eapply H3; eauto.
    constructor 2; rewrite find_ghost_set_equiv; constructor 2; constructor.
Qed.

Lemma delete_find_ghost_weak: forall x tg k,
  sorted_ghost_tree tg -> In_ghost x tg ->
  In (find_ghost_set' (delete_ghost x tg)) k ->
  In (find_ghost_set' tg) k.
Proof.
  induction tg; simpl; intros.
  - inv H1.
  - inv H. inv H0; simpl in *.
    + rewrite Z.ltb_irrefl in H1.
      rewrite pushdown_find_ghost in H1; auto.
      rewrite -> !find_ghost_set_equiv. inv H1; [constructor 1 | constructor 2]; constructor 1; auto.
    + specialize (Hgtl _ H2). destruct (x <? k) eqn:?; try lia.
      inv H1.
      * rewrite -> !find_ghost_set_equiv in * |-*. (* H |-* does not rewrite the 2nd instance on goal *)
      inv H.
      apply Union_introl, Union_introl. apply IHtg1; auto.
      { inv H0; constructor 1; constructor 2; constructor. }
      * constructor 2; auto.
    + specialize (Hltr _ H2). destruct (x <? k) eqn:?; try lia. destruct (k <? x) eqn:?; try lia.
      inv H1.
      * constructor 1; auto.
      * rewrite -> !find_ghost_set_equiv in * |-*. (* H |-* does not rewrite the 2nd instance on goal *)
      inv H.
      apply Union_intror, Union_introl. apply IHtg2; auto.
      { inv H0; constructor 2; constructor 2; constructor. }
Qed.

Lemma delete_ghost_unique: forall x tg,
  In_ghost x tg -> sorted_ghost_tree tg ->
  unique_gname tg -> unique_gname (delete_ghost x tg).
Proof.
  induction tg; simpl; auto; intros.
  inv H0; inv H1. inv H.
  - rewrite Z.ltb_irrefl. apply pushdown_left_ghost_unique; auto.
    intros. apply Hgtl in H. apply Hltr in H0. lia.
  - specialize (Hgtl _ H1); destruct (x <? k) eqn:?; try lia. apply Unique_Tree; auto.
    + rewrite -> empty_intersection in *; intros ???.
      eapply H10; eauto.
      apply delete_find_ghost_weak in H; auto.
    + intros ?%delete_find_ghost_weak; auto.
    + intros ?%delete_find_ghost_weak; auto.
  - specialize (Hltr _ H1); destruct (x <? k) eqn:?; try lia. destruct (k <? x) eqn:?; try lia. apply Unique_Tree; auto.
    + rewrite -> empty_intersection in *; intros ???.
      eapply H10; eauto.
      apply delete_find_ghost_weak in H0; auto.
    + intros ?%delete_find_ghost_weak; auto.
    + intros ?%delete_find_ghost_weak; auto.
Qed.

Lemma ghost_tree_pushdown_left: forall t g g_root g_in gl gr x v,
  tree_rep g g_root t * in_tree g g_in * in_tree g gr |--
  EX n, EX n0, EX o1:option ghost_info,
  public_half g_in (n, n0, Some o1) *
  (!!(o1 = Some (x,v,gl,gr)) -->
     EX o3 : option ghost_info,
     public_half gr (Finite_Integer x, n0, Some o3) *
  ((in_tree g gl -* EX o2 : option ghost_info, (public_half gl (n, Finite_Integer x, Some o2) * ((
      (!!(o1 = Some (x,v,gl,gr) /\ o3 = None /\ (key_in_range x (n,n0) = true)) &&
      public_half g_in (n, n0, Some o2) -* |==> tree_rep g g_root (delete x t) * in_tree g g_in)))))%I
    && ((* turn_left *)(ALL gr1 gr2 : gname, ALL k : key, ALL y : val,
        (!!(o1 = Some (x,v,gl,gr) /\ o3 = Some (k, y, gr1, gr2)
          /\ (key_in_range x (n,n0) = true /\ less_than (Finite_Integer x) (Finite_Integer k) = true)) &&
        (public_half g_in (n, n0, Some (Some (k, y, gr, gr2)))
        * public_half gr (n, Finite_Integer k, Some (Some (x, v, gl, gr1))))
        -* |==> tree_rep g g_root t * in_tree g g_in * in_tree g gr)))%I)).
Proof.
  intros. unfold tree_rep at 1. Intros tg.
  sep_apply node_exist_in_tree; Intros.
  sep_apply (ghost_tree_delete tg g_root g_in gl gr x v); auto.
  Intros n n0 o1; Exists n n0 o1; cancel.
  apply imp_andp_adjoint; Intros; subst.
  rewrite prop_imp; [|auto].
  Intros o3; Exists o3; cancel.
  iIntros "(((Hcase & Hin) & Href) & Hr)"; iSplit.
  + iDestruct "Hcase" as "[Hcase _]"; iDestruct "Hcase" as (o2) "(? & Hcase)".
    iIntros "Hl"; iExists o2; iFrame.
    iIntros "[(% & % & %) Hpub]"; subst.
    iPoseProof (update_ghost_ref_delete with "[$Hin $Href $Hr $Hl]") as "Href".
    { apply find_ghost_set_finite. }
    repeat logic_to_iris. iMod "Href" as "[? $]".
    iMod ("Hcase" with "[$Hpub]") as "[(% & % & % & %) ?]"; [auto|].
    iModIntro.
    unfold tree_rep. iExists (delete_ghost x tg).
    rewrite H7 delete_tree_to_gmap; auto; iFrame.
    iPureIntro; split; auto; split3.
    * intros ?%delete_find_ghost_weak; auto.
    * apply delete_ghost_unique; auto.
    * split; auto; apply delete_ghost_sorted; auto.
  + iDestruct "Hcase" as "[_ Hcase]".
    iIntros (gr1 gr2 k y) "H".
    iSpecialize ("Hcase" $! gr1 gr2 k y with "H").
    repeat logic_to_iris. iMod "Hcase" as (tg') "[(% & % & % & %) ?]"; iModIntro.
    unfold tree_rep; iFrame.
    iExists tg'.
    rewrite -> !find_ghost_set_equiv, !H5 in *; iFrame; auto.
Qed.

Lemma public_update : forall g (a b a' : G), my_half g gsh1 a * public_half g b |-- (|==> my_half g gsh1 a' * public_half g a')%I.
Proof.
  intros; unfold public_half'.
  assert_PROP (sepalg.joins a (b.1, None)).
  { iIntros "(my1 & my2 & ?)".
    iPoseProof (own_valid_2(RA := ref_PCM _) with "[$my1 $my2]") as "%"; iPureIntro.
    destruct H as ((?, ?) & [J ?] & ?); simpl in *.
    destruct g0 as [(?, ?)|]; try contradiction.
    eexists; apply J. }
  destruct H.
  erewrite <- sepcon_assoc, my_half_join by eauto.
  sep_apply (public_update g x b a'); Intros; subst x.
  erewrite <- my_half_join with (a1 := a')(a2 := (fst a', None)); eauto.
  rewrite sepcon_assoc; apply derives_refl.
  { split; hnf; simpl.
    * symmetry; apply merge_id.
    * constructor. }
Qed.

Lemma body_pushdown_left: semax_body Vprog Gprog f_pushdown_left pushdown_left_spec.
Proof.
  start_function.
  forward_loop (
    EX p : val, EX lockp: val, EX tb : val, EX lockb: val, EX gb : gname, EX g_del : gname,
    EX r : range, EX gsh : share,
    PROP (key_in_range x r = true)
    LOCAL (temp _tgp p;  gvars gv)
    SEP (atomic_shift (λ M, tree_rep g g_root M) ∅ ⊤ (λ M (_ : ()), fold_right_sepcon [tree_rep g g_root (delete x M)]) (λ _ : (), Q);
        mem_mgr gv;
        in_tree g g_del; my_half g_del gsh (r, Some (Some (x, vx, ga, gb)));
        field_at Ews t_struct_tree_t [StructField _t] tp p;
        data_at Ews t_struct_tree (vint x, (vx, (ta, tb))) tp;
        ltree g g_del lsh2 gsh p lockp; ltree g ga lsh1 gsh1 ta locka; ltree g gb lsh1 gsh1 tb lockb;
        malloc_token Ews t_struct_tree tp; malloc_token Ews tlock lockp; malloc_token Ews t_struct_tree_t p))%assert.
  { Exists p lockp tb lockb gb g_del r gsh; entailer!. }
  clear dependent g_del r gsh.
  Intros p' lockp' tb' lockb' gb' g_del r gsh.
  unfold ltree at 1; Intros.
  forward.
  forward.
  forward.
  unfold ltree at 2; Intros.
  forward.
  forward_call (lockb', lsh1, node_lock_inv gsh1 g tb' gb' lockb').
  Local Typeclasses eauto := 5.
  Time setoid_rewrite node_lock_inv_def at 2.
  Intros b; destruct b as (rangeb, g_infob).
  rewrite node_rep_def. Intros tbv; simpl.
  forward.
  Time forward_if.
  { subst. unfold tree_rep_R. if_tac; [| contradiction]. Intros.
    freeze FR_ghostb := (in_tree _ gb') (my_half gb' _ _).
    freeze FR_lockb := (lock_inv lsh1 lockb' _) (lock_inv lsh2 lockb' _)
      (field_at Ews _ [StructField _t] _ tb') (malloc_token _ _ tb')
      (field_at lsh2 _ [StructField _lock] _ tb') (malloc_token _ _ lockb')
      (field_at lsh1 _ [StructField _lock] _ tb').
    freeze FR_p := (lock_inv lsh2 lockp' _) (malloc_token _ _ tp) (malloc_token _ _ lockp')
      (malloc_token _ _ p') (field_at lsh2 _ [StructField _lock] _ p').
    forward.
    unfold ltree at 1; Intros.
    forward.
    Time forward_call (locka, lsh1, node_lock_inv gsh1 g ta ga locka).
    Time setoid_rewrite node_lock_inv_def at 2.
    Intros a; destruct a as (rangea, g_infoa).
    rewrite node_rep_def; Intros tav; simpl.
    forward.
    forward.
    thaw FR_p.
    forward_call (t_struct_tree, tp, gv).
    { if_tac; entailer!. }
    thaw FR_lockb.
    freeze FR_p := (lock_inv lsh2 lockp' _) (malloc_token _ _ lockp')
      (malloc_token _ _ p') (field_at lsh2 _ [StructField _lock] _ p') (field_at Ews _ [StructField _t] _ p').
    freeze FR_a := (lock_inv lsh1 locka _) (field_at Ews t_struct_tree_t [StructField _t] _ ta)
      (malloc_token _ _ ta) (in_tree _ ga) (tree_rep_R tav _ _ _) (my_half ga _ _)
      (field_at lsh2 _ [StructField _lock] _ ta) (malloc_token _ _ locka) (lock_inv lsh2 locka _)
      (field_at lsh1 _ [StructField _lock] _ ta).
    forward_call (lockb', Ews, lsh2, node_lock_inv_pred gsh1 g tb' gb' lockb', node_lock_inv gsh1 g tb' gb' lockb').
    { lock_props.
      rewrite <- (lock_inv_share_join lsh1 lsh2 Ews lockb') by auto.
      cancel. }
    forward_call (tlock, lockb', gv).
    { if_tac; entailer!. }
    forward_call (t_struct_tree_t, tb', gv).
    { if_tac.
      { saturate_local. subst tb'. contradiction. }
      { unfold_data_at (data_at_ Ews t_struct_tree_t tb'). simpl; cancel.
        erewrite <- (field_at_share_join _ _ Ews _ [StructField _lock] _ tb') by eauto.
        cancel. } }
    thaw FR_a.
    forward.
    forward_call (locka, Ews, lsh2, node_lock_inv_pred gsh1 g ta ga locka, node_lock_inv gsh1 g ta ga locka).
    { lock_props.
      rewrite <- (lock_inv_share_join lsh1 lsh2 Ews locka) by auto.
      entailer!. }
    forward.
    forward_call (tlock, locka, gv).
    { if_tac; entailer!. }
    forward_call (t_struct_tree_t, ta, gv).
    { if_tac.
      { saturate_local. subst ta. contradiction. }
      unfold_data_at (data_at_ Ews t_struct_tree_t ta).
      cancel. simpl.
      erewrite <- (field_at_share_join _ _ Ews _ [StructField _lock] _ ta) by eauto.
      entailer!. }
    thaw FR_p. destruct r as (n, n0).
    assert_PROP (g_infoa <> None) as infoa. {
      unfold tree_rep_R.
      if_tac. entailer!.
      Intros a b c d e a1 a2 a3. entailer!.
    }
    thaw FR_ghostb.
    gather_SEP (atomic_shift _ _ _ _ _) (my_half g_del _ _) (in_tree g g_del) (in_tree g ga) (in_tree g gb')
      (my_half gb' _ _) (my_half ga _ _) (tree_rep_R tav _ g_infoa g).
    rewrite -> 5sepcon_assoc.
    viewshift_SEP 0 (Q * (EX o2, EX n1 n2: number, !!(key_in_range x (n1,n2) = true) &&
      my_half g_del gsh ((n1, n2), o2) * in_tree g g_del * tree_rep_R tav (n1, n2) o2 g)). {
      go_lower. eapply sync_commit_gen1. rewrite <- sepcon_assoc.
      - intros. iIntros "[Ha Hb]".
        iDestruct "Ha" as "((H1 & H3) & (H2 & (H4 & H5 & H6)))".
        iPoseProof ((ghost_tree_pushdown_left _ _ _ g_del ga gb') with "[$H1 $H2 $Hb]") as "Hadd".
        iDestruct "Hadd" as (n1 n2 o) "[[Hmya Ha] Hb]".
        iExists (n1, n2, Some o).
        instantiate (1 := vx). instantiate (1 := x). iFrame.
        iIntros "!> %".
        apply node_info_incl' in H7 as [? Heq]; inv Heq.
        iSpecialize ("Hb" with "[% //]").
        iDestruct "Hb" as (o3) "[Ha Hb]".
        iDestruct ("Hb" with "H3") as (o2) "(Hb & Hd)".
        iDestruct (public_sub with "[$Hb $H5]") as %[? J1].
        iDestruct (public_sub with "[$Ha $H4]") as %[? J2].
        iPoseProof (public_update with "[$Hb $H5]") as ">Hga".
        iPoseProof (public_update with "[$Ha $H4]") as ">Hgb".
        instantiate (1:= (Finite_Integer x, n2, Some o3)).
        instantiate (1:= (n1, Finite_Integer x, Some o2)).
        inv J2.
        iIntros "!>".
        iExists ((n, n0), Some o2), ((n1, n2), Some o2); iSplit.
        { iPureIntro. intros (?, ?) H_sep. destruct H_sep; split; auto; simpl in *.
          inv H10; [constructor|].
          inv H14. }
        iIntros "[He Hf]".
        destruct g_infoa; try contradiction; inv J1.
        repeat logic_to_iris.
        iPoseProof (public_part_update(P := node_ghost) _ _ _ _ (n1, n2, Some o) (n1, n2, Some o) with "[$He $Hf]") as "[_ >[He Hf]]".
        { intros ? [J ?]; split; auto; hnf in J |- *.
          symmetry; rewrite puretree.merge_comm; eapply merge_again; rewrite puretree.merge_comm; eauto. }
        rewrite exp_sepcon1; iExists tt.
        assert (key_in_range x (n1, n2) = true) by (eapply key_in_range_incl; eauto).
        iMod ("Hd" with "[$Hmya $Hf]") as "[$ Hf]"; first auto.
        iDestruct "Hga" as "(Hga1 & (Hga2 & Hga3))".
        iDestruct "Hgb" as "(Hgb1 & (Hgb2 & Hgb3))".
        iMod (own_dealloc with "Hga1") as "_"; iMod (own_dealloc with "Hga2") as "_";
        iMod (own_dealloc with "Hga3") as "_".
        iMod (own_dealloc with "Hgb1") as "_"; iMod (own_dealloc with "Hgb2") as "_";
        iMod (own_dealloc with "Hgb3") as "_".
        iModIntro; iExists (Some o), n1, n2; iFrame "Hf".
        iFrame "He".
        iSplit; first auto.
        iApply range_incl_tree_rep_R; last iFrame.
        eapply range_incl_trans, key_in_range_l; eassumption. }
    forward_call (lockp', lsh2, node_lock_inv_pred gsh g p' g_del lockp', node_lock_inv gsh g p' g_del lockp').
    { lock_props.
      setoid_rewrite node_lock_inv_def at 2. Intros o2 n1 n2. Exists (n1, n2, o2).
      rewrite node_rep_def; simpl. Exists tav. cancel. }
    forward. }
  abbreviate_semax. unfold tree_rep_R at 1.
  if_tac.
  { Intros. contradiction. }
  { Intros gbl gbr k v tbl tbr ltbl ltbr.
    forward_call (p', tp, x, vx, ta, tb', tbv, k, v, tbl, tbr).
    forward.
    destruct r as (rangel, rangeh).
    gather_SEP (atomic_shift _ _ _ _ _) (my_half g_del _ _) (my_half gb' _ _) (in_tree g gb') (in_tree g g_del).
    repeat rewrite sepcon_assoc. do 2 rewrite <- sepcon_assoc.
    replace_SEP 0 (atomic_shift (λ M, tree_rep g g_root M) ∅ ⊤
          (λ M (_ : ()), tree_rep g g_root (delete x M) * emp) (λ _ : (), Q) *
      EX rangedell, EX rangedelh: _, !!(range_incl (rangel, rangeh) (rangedell, rangedelh) = true /\ range_incl rangeb (rangedell, rangedelh) = true /\ x < k) &&
      my_half g_del gsh ((rangedell, rangedelh), Some (Some (k, v, gb', gbr))) * my_half gb' gsh1 ((rangedell, Finite_Integer k), Some (Some (x, vx, ga, gbl)))
    * (in_tree g gb' * in_tree g g_del)). {
      go_lower. rewrite !sepcon_assoc. eapply atomic_rollback.
      - intros. iIntros "((g_del & (gb & (in_gb & in_gdel))) & tree_rep)".
        iPoseProof ((ghost_tree_pushdown_left _ _ _ g_del ga gb') with "[$tree_rep $in_gb $in_gdel]") as (n1 n2 o) "[Ha Hb]".
        iDestruct (public_sub with "[$g_del $Ha]") as %[? J]; inv J.
        instantiate (1 := vx). instantiate (1 := x).
        iPoseProof ("Hb" with "[% //]") as (o3) "[Hpubb Hb]".
        iPoseProof (bi.and_elim_r with "Hb") as "Hb".
        iSpecialize ("Hb" $! gbl gbr k v).
        logic_to_iris.
        iDestruct (public_sub with "[$g_del $Ha]") as %[? J1].
        iDestruct (public_sub with "[$gb $Hpubb]") as %[Hincl J2].
        iDestruct "Ha" as "[Hmya Ha]".
        iPoseProof (public_part_update(P := node_ghost) _ _ _ _ (n1, n2, Some (Some (k, v, gb', gbr))) (n1, n2, Some (Some (k, v, gb', gbr))) with "[$g_del $Ha]") as "[_ >[Hmyga Hpubga]]".
        { intros ? [J J']; split; auto; hnf in J |- *.
          symmetry; rewrite puretree.merge_comm; eapply merge_again; rewrite puretree.merge_comm; eauto.
          destruct c; inv J'; auto; [constructor|].
          inv H14. }
        iPoseProof (public_update _ _ _ (n1, Finite_Integer k, Some (Some (x, vx, ga, gbl))) with "[$gb $Hpubb]") as ">(Hmygb & Hpubgb)".
        inv J2.
        assert (key_in_range x (n1, n2) = true).
        { eapply key_in_range_incl; eauto. }
        assert (x < k).
        { eapply key_in_range_incl in Hincl; [|eauto].
          apply andb_prop in Hincl as []; simpl in *; lia. }
        iDestruct ("Hb" with "[$Hpubgb $Hmya $Hpubga]") as ">(($ & Hgdel) & Hgb)".
        { iPureIntro; repeat (split; auto).
          simpl; lia. }
        iExists n1, n2; iFrame.
        iPureIntro; repeat (split; auto).
        eapply range_incl_trans; try eassumption.
        apply (key_in_range_r _ (_, _)); auto. }
    Intros rangedell rangedelh.
    forward_call (lockp', lsh2, node_lock_inv_pred gsh g p' g_del lockp', node_lock_inv gsh g p' g_del lockp').
    { lock_props.
      setoid_rewrite node_lock_inv_def at 4.
      Exists ((rangedell, rangedelh), Some (Some (k, v, gb', gbr))).
      rewrite node_rep_def; simpl. Exists tbv; cancel.
      unfold tree_rep_R.
      if_tac. { contradiction. }
      Exists gb' gbr k v tb' tbr lockb' ltbr; cancel.
      unfold ltree at 3. do 2 rewrite sepcon_andp_prop'. apply andp_right.
      - apply prop_right. repeat (split; auto). eapply key_in_range_incl; eauto.
      - cancel. eapply derives_trans.
        2: { apply sepcon_derives; [apply now_later| apply derives_refl]. }
        entailer!. }
    Exists tb' lockb' tbl ltbl gbl gb' (rangedell, Finite_Integer k) gsh1; entailer!.
    { eapply key_in_range_incl in H1; [|eauto].
      unfold key_in_range in *; apply andb_prop in H1 as [-> _]; simpl; lia. }
    unfold ltree. entailer!. }
Qed.

Definition delete_inv (b: val) (lock: val) (sh: share) (x: Z) (g_root: gname) gv
           (inv_names : invG) (Q : mpred) (g:gname) : environ -> mpred :=
  (EX np: val, EX r: node_info, EX g_in: gname, EX lock_in: val, EX gsh : share,
  PROP (key_in_range x (fst r) = true)
  LOCAL (temp _l lock_in; temp _tgt np; temp _t b; temp _x (vint x); gvars gv)
  SEP (nodebox_rep g g_root sh lock b;
      field_at lsh2 t_struct_tree_t [StructField _lock] lock_in np ;
      malloc_token Ews tlock lock_in;
      node_rep np g g_in r; my_half g_in gsh r;
      |> lock_inv lsh2 lock_in  (node_lock_inv gsh g np g_in lock_in);
      atomic_shift (λ M, tree_rep g g_root M) ∅ ⊤
        (λ M (_ : ()), fold_right_sepcon [tree_rep g g_root (delete x M)]) (λ _: (), Q); mem_mgr gv))%assert.

Lemma body_delete: semax_body Vprog Gprog f_delete delete_spec.
Proof.
  start_function.
  unfold nodebox_rep, ltree. Intros np.
  forward. (* _tgt = *_t; *)
  forward. (* _l = (_tgt -> _lock); *)
  forward_call (lock, sh, node_lock_inv (fst (Share.split gsh1)) g np g_root lock). (* acquire(_l); *)
  unfold node_lock_inv at 2. rewrite selflock_eq. Intros.
  fold (node_lock_inv (fst (Share.split gsh1)) g np g_root lock). unfold node_lock_inv_pred, sync_inv.
  Intros rp; destruct rp as (rangep, g_infop). rewrite node_rep_def. Intros tp.
  forward_loop (delete_inv b lock sh x g_root gv inv_names Q g).
  { (* current status implies lookup_inv *)
    unfold delete_inv. Exists np (Neg_Infinity, Pos_Infinity, g_infop) g_root lock (fst (Share.split gsh1)).
    sep_apply (my_half_range_inf g_root (Share.split gsh1).1 (Share.split gsh1).2 rangep (Neg_Infinity, Pos_Infinity)).
    entailer!.
    sep_apply (range_incl_tree_rep_R tp _ _ g_infop g (range_incl_infty rangep)).
    unfold nodebox_rep. Exists np. cancel. unfold ltree. entailer!.
    rewrite node_rep_def. Exists tp. simpl. cancel. }
  (* loop body *)
  clear np H0 rangep g_infop tp. unfold delete_inv. Intros np r g_in lock_in gsh.
  rewrite node_rep_def. Intros tp.
  forward. (* _p = (_tgt -> _t); *)
  forward_if. (* if (_p == (tptr tvoid) (0)) *)
  + (* then branch *)
    subst tp. unfold tree_rep_R. simpl. Intros.
    gather_SEP (atomic_shift _ _ _ _ _) (my_half g_in _ _) (in_tree g _).
    viewshift_SEP 0 (Q * (in_tree g g_in * my_half g_in gsh r)). {
      go_lower. apply sync_commit_same1. intros t.
      unfold tree_rep at 1. Intros tg.
      assert_PROP (Ensembles.In (find_ghost_set tg g_root) g_in) as Hin. {
        sep_apply node_exist_in_tree. entailer!. }
      sep_apply (ghost_tree_rep_public_half_ramif _ _ (Neg_Infinity, Pos_Infinity) _ Hin). Intros r0.
      iIntros "([[? ?] Hclose] & ? & ?) !>".
      iExists r0; iFrame.
      iIntros "% !> [? ?] !>".
      apply node_info_incl' in H7 as [].
      iExists tt; iFrame.
      unfold tree_rep; iExists tg; iFrame.
      destruct r, r0; simpl in *; subst.
      iSplit.
      { iPureIntro; repeat (split; auto).
        rewrite delete_notin; auto; subst.
        eapply range_info_not_in_gmap; last eassumption; auto.
        eapply key_in_range_incl; eauto. }
      iApply "Hclose"; iFrame. }
    forward_call (lock_in, lsh2, node_lock_inv_pred gsh g np g_in lock_in, node_lock_inv gsh g np g_in lock_in). (* _release2(_l); *)
    { lock_props. unfold node_lock_inv at 2. rewrite selflock_eq.
      fold (node_lock_inv gsh g np g_in lock_in). unfold node_lock_inv_pred.
      unfold sync_inv. Exists r. rewrite node_rep_def. Exists nullval.
      unfold tree_rep_R. simpl. entailer!. }
    forward. cancel.
  + (* else branch *)
    unfold tree_rep_R. rewrite if_false; auto. Intros ga gb x0 v pa pb locka lockb.
    forward. (* _y = (_p -> _key); *)
    forward_if. (* if (_x < _y) { *)
    * forward. (* _tgt = (_p -> _left); *)
      forward. (* _l_old = _l; *) unfold ltree at 1. Intros.
      forward. (* _l = (_tgt -> _lock); *)
      forward_call (locka, lsh1, node_lock_inv gsh1 g pa ga locka). (* _acquire(_l); *)
      unfold node_lock_inv at 2. rewrite selflock_eq. Intros.
      fold (node_lock_inv gsh1 g pa ga locka). unfold node_lock_inv_pred, sync_inv.
      Intros a. rewrite node_rep_def. Intros tpa.
      gather_SEP (atomic_shift _ _ _ _ _) (my_half g_in _ _) (in_tree g g_in) (my_half ga _ _).
      sep_apply (in_tree_left_range unit
                   (λ M (_ : ()), tree_rep g g_root (delete x M) * emp) (λ _ : (), Q)
                   x x0 g g_root inv_names v g_in ga gb). Intros ba.
      forward_call (lock_in, lsh2, node_lock_inv_pred gsh g np g_in lock_in, node_lock_inv gsh g np g_in lock_in). (* _release2(_l_old); *)
      { lock_props. setoid_rewrite node_lock_inv_def at 4. Exists r.
         rewrite node_rep_def. Exists tp. cancel. unfold tree_rep_R at 2.
         rewrite if_false; auto. Exists ga gb x0 v pa pb locka lockb. entailer!.
         unfold ltree. entailer!. rewrite sepcon_comm. rewrite !later_sepcon. cancel. }
      unfold delete_inv. destruct a as [rangea a]. simpl fst in *. simpl snd in *.
      Exists pa (ba, Finite_Integer x0, a) ga locka gsh1. simpl fst.
      sep_apply (range_incl_tree_rep_R tpa _ _ a g H9). entailer!.
      { simpl. rewrite andb_true_iff. clear -H0 H6 H8. split; [|lia].
        destruct r, g. simpl fst in *.
        unfold key_in_range in H0. apply andb_true_iff in H0. destruct H0.
        eapply less_than_equal_less_than_trans; eauto. }
      rewrite node_rep_def. Exists tpa. simpl. cancel.
    * forward_if. (* if (_y < _x) { *)
      - forward. (* _tgt = (_p -> _right); *)
        forward. (* _l_old__1 = _l; *) unfold ltree at 2. Intros.
        forward. (* _l = (_tgt -> _lock); *)
        forward_call (lockb, lsh1, node_lock_inv gsh1 g pb gb lockb).
        (* _acquire(_l); *)
        unfold node_lock_inv at 2. rewrite selflock_eq. Intros.
        fold (node_lock_inv gsh1 g pb gb lockb). unfold node_lock_inv_pred, sync_inv.
        Intros a. rewrite node_rep_def. Intros tpb.
        gather_SEP (atomic_shift _ _ _ _ _) (my_half g_in _ _) (in_tree g g_in) (my_half gb _ _).
        sep_apply (in_tree_right_range unit
                     (λ M (_ : ()), tree_rep g g_root (delete x M) * emp) (λ _ : (), Q)
                     x x0 g g_root inv_names v g_in ga gb). Intros ta.
        forward_call (lock_in, lsh2, node_lock_inv_pred gsh g np g_in lock_in, node_lock_inv gsh g np g_in lock_in). (* _release2(_l_old__1); *)
        { lock_props. setoid_rewrite node_lock_inv_def at 4. Exists r.
          rewrite node_rep_def. Exists tp. cancel. unfold tree_rep_R at 2.
          rewrite if_false; auto. Exists ga gb x0 v pa pb locka lockb. entailer!.
          unfold ltree. entailer!. rewrite !later_sepcon. cancel. }
        unfold delete_inv. destruct a as [rangea a]. simpl fst in *.
        simpl snd in *. Exists pb (Finite_Integer x0, ta, a) gb lockb gsh1.
        simpl fst. sep_apply (range_incl_tree_rep_R tpb _ _ a g H10). entailer!.
        { unfold key_in_range. rewrite andb_true_iff. clear -H0 H7 H9.
          split. 1: simpl; now rewrite Z.ltb_lt. destruct r, g. simpl fst in *.
          simpl in H9. unfold key_in_range in H0. apply andb_true_iff in H0.
          destruct H0. eapply less_than_less_than_equal_trans; eauto. }
        rewrite node_rep_def. Exists tpb. simpl. cancel.
      - assert (x0 = x) by lia. subst x0. clear H6 H7. destruct r as [range ?].
        simpl fst in *. simpl snd in *. subst g0.
        forward_call (np, tp, lock_in, gsh, x, v, locka, lockb, pa, pb, g, g_root, gv, range, g_in, ga, gb, Q, inv_names).
        { rewrite sepcon_andp_prop'; apply andp_right.
          { entailer!.
            rewrite -> field_compatible_cons in H2; apply H2. }
          unfold ltree; cancel. }
        forward.
Qed.


From Undecidability.Shared Require Import embed_nat Dec.
From Undecidability.Synthetic Require Import Definitions EnumerabilityFacts.

From Undecidability.FOL Require Import FullSyntax Axiomatisations.
From Undecidability.FOL.Arithmetics Require Import Signature Robinson NatModel.

From Undecidability.FOL.Incompleteness Require Import utils fol_utils qdec bin_qdec sigma1 epf epf_mu.
From Undecidability.FOL.Proofmode Require Import Theories ProofMode.

Require Import Lia String List.
Import ListNotations.

(** * Church's thesis for Q *)
Section ctq.
  Context {pei : peirce}.

  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.
  Existing Instance interp_nat.
  Definition CTQ :=
    forall (f : nat -\ nat), exists φ, bounded 2 φ /\ Σ1 φ /\ (forall x y, f x ▷ y <-> Qeq ⊢ ∀ φ[num x .: $0 ..] ↔ $0 == num y).
  Definition CTQ_total :=
    forall (f : nat -> nat), exists φ, bounded 2 φ /\ Σ1 φ /\ forall x, Qeq ⊢ ∀ φ[num x .: $0..] ↔ $0 == num (f x).
  Definition uCTQ :=
    exists φ, bounded 3 φ /\ Σ1 φ /\ forall (f : nat -\ nat), exists c, (forall x y, f x ▷ y <-> Qeq ⊢ ∀ φ[num c .: num x .: $0 ..] ↔ $0 == num y).

  Lemma uctq_ctq : uCTQ -> CTQ.
  Proof.
    intros (φ & Hb & HΣ & Hφ).
    intros f. destruct (Hφ f) as [c Hc].
    exists (φ[(num c)..]).
    split.
    { eapply subst_bounded_max; last eassumption.
      intros [|[|[|n]]] Hn; solve_bounds; apply num_bound. }
    split.
    { apply Σ1_subst, HΣ. }
    intros x y.  specialize (Hc x y).
    enough (φ[num c .: num x .: $0 ..] = φ[(num c)..][num x .: $0..]) by congruence.
    rewrite subst_comp. apply subst_ext.
    intros [|[|[|n]]]; cbn; now rewrite ?num_subst.
  Qed.

  Lemma ctq_ctq_total : CTQ -> CTQ_total.
  Proof.
    intros ctq f. destruct (ctq (partialise f)) as (φ & Hb & HΣ & Hφ).
    exists φ. do 2 (split; first assumption).
    intros x. apply Hφ. exists 0. reflexivity.
  Qed.

End ctq.

Section ctq_epf.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.
  Existing Instance interp_nat.
  Context {pei : peirce}.

  Lemma Q_num_inj x y : Qeq ⊢ num x == num y -> x = y.
  Proof.
    intros H. apply Σ1_soundness with (rho := fun _ => 0) in H.
    - cbn in H. now erewrite !nat_eval_num in H.
    - constructor. apply Qdec_eq.
    - solve_bounds; apply num_bound.
  Qed.

  Lemma prv_enumerable (T : list form) (p' : peirce) :
    enumerable (fun phi => T ⊢ phi).
  Proof.
    edestruct (@tprv_enumerable PA_funcs_signature PA_preds_signature) with (T := list_theory T) as [f Hf].
    - apply enumerable_PA_funcs.
    - exact _.
    - apply enumerable_PA_preds.
    - exact _.
    - apply list_theory_enumerable.
    - exists f. intros phi. unfold enumerator in Hf.
      rewrite <-Hf. split.
      + intros H. exists T. eauto.
      + intros [T' HT']. apply Weak with (A := T'); firstorder.
  Qed.

  (** ** Church's thesis implies EPF *)
  Lemma ctq_epfn : CTQ -> EPF_N.
  Proof.
    unshelve edestruct (@form_enumerable PA_funcs_signature PA_preds_signature enumerable_PA_funcs enumerable_PA_preds) as [f_form Hform].
    assert (semi_decidable (fun ψ => Qeq ⊢ ψ)) as [f_prv Hprv].
    { apply enumerable_semi_decidable.
      - apply form_discrete.
      - apply prv_enumerable. }

    intros ctq.
    unshelve eexists.
    { intros c.
      intros x. unshelve eexists.
      { intros k.
        destruct (f_form c) as [φ|]. 2: exact None.
        destruct (unembed k) as [l y].
        destruct (f_prv (∀ φ[num x .: $0 ..] ↔ $0 == num y) l).
        - exact (Some y).
        - exact None. }
      intros y1 y2 k1 k2. destruct (f_form c) as [φ|] eqn:Hc; cbn.
      2: congruence.
      destruct (unembed k1) as [l1 y'1].
      destruct (unembed k2) as [l2 y'2].
      destruct (f_prv _ l1) eqn:H1, (f_prv _ l2) eqn:H2.  2-4: congruence. intros [= <-] [= <-].
      assert (Qeq ⊢ ∀ φ[num x .: $0..] ↔ $0 == num y'1) as H1'.
      { apply Hprv. eauto. }
      assert (Qeq ⊢ ∀ φ[num x .: $0..] ↔ $0 == num y'2) as H2'.
      { apply Hprv. eauto. }
      enough (Qeq ⊢ num y'1 == num y'2).
      { apply Q_num_inj, H. }
      fspecialize (H2' (num y'1)). rewrite num_subst in H2'.
      fapply H2'.
      fspecialize (H1' (num y'1)). rewrite num_subst in H1'.
      fapply H1'. fapply ax_refl. }
    intros f. destruct (ctq f) as (φ & H1 & H2 & Hφ).
    destruct (Hform φ) as [c Hc]. exists c.
    intros x y. setoid_rewrite Hφ. cbn. split.
    - intros H. apply Hprv in H as [l Hl].
      exists (embed (l, y)). cbn.
      rewrite Hc. rewrite embedP. rewrite Hl.
      reflexivity.
    - intros [k H3]. cbn in H3.
      rewrite Hc in H3. destruct (unembed k) as [l y'].
      destruct f_prv eqn:H.
      + apply Hprv. exists l. now injection H3 as ->.
      + congruence.
  Qed.

End ctq_epf.

Section ctq_repr.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.
  Existing Instance interp_nat.

  Context {p : peirce}.

  (** ** Church's thesis implies weak representability  and strong separability *)
  Lemma ctq_weak_repr (ctq : CTQ_total) (P : nat -> Prop) :
    enumerable P -> exists φ,
    bounded 1 φ /\ Σ1 φ /\ forall x, P x <-> Qeq ⊢ φ[(num x)..].
  Proof.
    intros [f Hf].
    pose (f' := fun x => match f x with Some y => S y | None => 0 end).
    destruct (ctq f') as (φ & Hb & HΣ & Hφ).
    exists (∃(φ[$0 .: (σ $1) ..])).
    repeat apply conj.
    { constructor. eapply subst_bounded_max; last eassumption.
      intros [|[|n]] ?; repeat solve_bounds. }
    { constructor. apply Σ1_subst, HΣ. }
    intros x. unfold enumerator in Hf. setoid_rewrite Hf.
    split.
    - intros [k Hk]. cbn.
      fexists (num k).
      specialize (Hφ k). fspecialize (Hφ (num (f' k))).
      rewrite num_subst in Hφ.
      replace (φ[_][_][_]) with (φ[num k .: $0 ..][(num (f' k))..]).
      { fapply Hφ. fapply ax_refl. }
      rewrite !subst_comp. eapply bounded_subst; first eassumption.
      intros [|[|n]] ?; cbn; rewrite ?num_subst.
      + reflexivity.
      + unfold f'. rewrite Hk. reflexivity.
      + lia.
    - cbn. intros [k Hk]%Σ1_witness.
      2: { apply Σ1_subst, Σ1_subst, HΣ. }
      2: { rewrite subst_comp. eapply subst_bounded_max; last eassumption.
        intros [|[|n]] ?; cbn.
        - constructor. lia.
        - repeat (solve_bounds; rewrite ?num_subst); apply num_bound.
        - lia. }
      exists k.
      enough (f' k = S x) as H.
      { unfold f' in H. now destruct (f k). }
      apply Q_num_inj.
      specialize (Hφ k). fspecialize (Hφ (num (S x))).
      rewrite num_subst in Hφ.
      fapply ax_sym. fapply Hφ.
      replace (φ[_][_][_]) with (φ[num k .: $0 ..][(σ num x)..]) in Hk; first easy.
      rewrite !subst_comp. eapply bounded_subst; first eassumption.
      intros [|[|n]] ?; cbn; rewrite ?num_subst; easy + lia.
  Qed.

  Lemma ctq_strong_sepr (ctq : CTQ) (P Q : nat -> Prop) :
    (forall x, P x -> Q x -> False) ->
    semi_decidable P -> semi_decidable Q ->
    exists φ, bounded 1 φ /\ Σ1 φ /\
      (forall x, P x -> Qeq ⊢ φ[(num x)..]) /\
      (forall x, Q x -> Qeq ⊢ ¬φ[(num x)..]).
  Proof.
    intros Hdisj HP HQ.
    destruct (enumerable_separable Hdisj HP HQ) as [f Hf].
    destruct (ctq (fun x => comp_part_total (fun b : bool => if b then 1 else 0) (f x))) as (φ & Hb & HΣ & Hφ).
    exists (φ[$0 .: (num 1) ..]). repeat split.
    { eapply subst_bounded_max; last eassumption.
      intros [|[|n]] ?; cbn; repeat solve_bounds. }
    { apply Σ1_subst, HΣ. }
    - intros x Hx%Hf.
      assert (comp_part_total (fun b : bool => if b then 1 else 0) (f x) ▷ 1) as H%Hφ.
      { destruct Hx as [k Hk]. exists k. cbn. now rewrite Hk. }
      fspecialize (H (num 1)).
      replace (φ[_][_]) with (φ[num x .: $0..][(num 1)..]).
      { fapply H. fapply ax_refl. }
      rewrite !subst_comp. eapply bounded_subst; first eassumption.
      intros [|[|n]]?; cbn; rewrite ?num_subst; easy + lia.
    - intros x Hx%Hf.
      assert (comp_part_total (fun b : bool => if b then 1 else 0) (f x) ▷ 0) as H%Hφ.
      { destruct Hx as [k Hk]. exists k. cbn. now rewrite Hk. }
      fspecialize (H (num 1)).
      replace (φ[_][_]) with (φ[num x .: $0..][(num 1)..]).
      { fstart. fintros "H". fapply H in "H".
        (* For some reason, these assumption cause fapply to take a long time *)
        clear H Hx x Hφ HΣ Hb φ Hf f HQ HP Hdisj P Q ctq.
        fapply (ax_zero_succ zero). fapply ax_sym.
        ctx. }
      rewrite !subst_comp. eapply bounded_subst; first eassumption.
      intros [|[|n]]?; cbn; rewrite ?num_subst; easy + lia.
  Qed.

End ctq_repr.

Section ctq.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.
  Existing Instance interp_nat.

  Context `{pei : peirce}.

  Variable theta : nat -> nat -\ nat.
  Variable theta_universal : is_universal theta.

  Variable (φ : form).
  Hypothesis φ1_qdec : Qdec φ.
  Hypothesis φ1_bounded : bounded 4 φ.
  Hypothesis wrepr : forall c x y, theta c x ▷ y <-> Qeq ⊢ ∃ φ[$0 .: num c .: num x .: (num y)..].

  Local Definition ψ' : form :=
    φ ∧ ∀∀ ($1 ⊕ $0 ⧀= $5 ⊕ $2) → φ[$0.:$3.:$4.:$1..] → $1 == $5.
  Local Definition ψ : form := ∃ψ'.

  Lemma ψ'_bounded : bounded 4 ψ'.
  Proof.
    repeat (solve_bounds; cbn in *).
    - assumption.
    - eapply subst_bounded_max; last eassumption.
    intros [|[|[|[|n]]]] Hn; cbn; now solve_bounds.
  Qed.
  Lemma ψ_bounded : bounded 3 ψ.
  Proof.
    constructor. apply ψ'_bounded.
  Qed.
  Lemma ψ'_Qdec : Qdec ψ'.
  Proof.
    apply Qdec_and.
    - auto.
    - apply (Qdec_bin_bounded_forall ($3 ⊕ $0)).
      apply Qdec_impl.
      + now apply Qdec_subst.
      + apply Qdec_eq.
  Qed.
  Lemma ψ_Σ1 : Σ1 ψ.
  Proof.
    constructor. constructor.
    apply ψ'_Qdec.
  Qed.
  Lemma ψ_subst c x y : ψ[c.:x.:y..] =
    ∃ φ[$0 .: c`[↑] .: x`[↑] .: y`[↑]..] ∧ ∀∀ ($1 ⊕ $0 ⧀= y`[↑]`[↑]`[↑] ⊕ $2) → φ[$0 .: c`[↑]`[↑]`[↑] .: x`[↑]`[↑]`[↑] .: $1..] → $1 == y`[↑]`[↑]`[↑].
  Proof.
    cbn. do 2 f_equal.
    { eapply bounded_subst; first eassumption.
      intros [|[|[|[|n]]]] Hn; cbn; now solve_bounds. }
    do 4 f_equal.
    rewrite subst_comp.
    eapply bounded_subst; first eassumption.
    intros [|[|[|[|n]]]] Hn; cbn; now solve_bounds.
  Qed.
  Lemma ψ'_subst k c x y :
    ψ'[k .: c .: x .: y ..] = φ[k .: c .: x .: y..] ∧  ∀∀ ($1 ⊕ $0 ⧀= y`[↑]`[↑] ⊕ k`[↑]`[↑]) → φ[$0 .: c`[↑]`[↑] .: x`[↑]`[↑] .: $1..] → $1 == y`[↑]`[↑].
  Proof.
    cbn. f_equal.
    do 4 f_equal.
    rewrite subst_comp.
    eapply bounded_subst; first eassumption.
    intros [|[|[|[|n]]]] Hn; cbn; now solve_bounds.
  Qed.

  Lemma ψ_φ s t u :
    Qeq ⊢ ψ[s.:t.:u..] → ∃ φ[$0 .: s`[↑] .: t`[↑] .: u`[↑]..].
  Proof.
    rewrite ψ_subst. fstart.
    fintros "[k [H1 H2]]".
    fexists k.
    fapply "H1".
  Qed.

  Lemma ψ_theta c x y :
    Qeq ⊢ ∀ ψ[num c .: num x .: $0 ..] ↔ $0 == num y -> theta c x ▷ y.
  Proof.
    intros H. apply wrepr.
    rewrite <-(num_subst c ↑), <-(num_subst x ↑), <-(num_subst y ↑).
    eapply IE; first apply ψ_φ.
    apply AllE with (t := num y) in H.
    cbn -[ψ] in H. replace (ψ[_][_]) with ψ[num c .: num x .: (num y)..] in H.
    2: { rewrite subst_comp. eapply bounded_subst; first apply ψ_bounded.
      intros [|[|[|n]]] Hn; solve_bounds; cbn; try easy; now rewrite num_subst. }
    eapply IE.
    { eapply CE2, H. }
    rewrite num_subst. fapply ax_refl.
  Qed.

  Lemma sat_PAle ρ s t :
    interp_nat; ρ ⊨ (s ⧀= t) <-> (eval ρ s) <= (eval ρ t).
  Proof.
    split.
    - intros [k Hk]. cbn in Hk.
      rewrite !eval_up in Hk. lia.
    - intros H. cbn. exists (eval ρ t - eval ρ s).
      rewrite !eval_up. lia.
  Qed.

  Lemma theta_ψ c x y :
    theta c x ▷ y -> Qeq ⊢ ψ[num c .: num x .: (num y) ..].
  Proof.
    intros H.
    apply Σ1_completeness.
    { apply Σ1_subst, ψ_Σ1. }
    { eapply subst_bounded_max; last apply ψ_bounded.
      intros [|[|[|n]]] Hn; solve_bounds; apply num_bound. }
    intros ρ.
    pose proof H as [k Hk]%wrepr%Σ1_witness; first apply Σ1_soundness with (rho := ρ) in Hk; first last.
    { eapply subst_bounded_max; last eassumption.
      intros [|[|[|[|n]]]] Hn; solve_bounds; apply num_bound. }
    { apply Σ1_subst. now constructor. }
    { rewrite subst_comp. eapply subst_bounded_max; last eassumption.
      intros [|[|[|[|n]]]] Hn; solve_bounds; try easy; cbn; rewrite ?num_subst; apply num_bound. }
    { do 2 apply Σ1_subst. now constructor. }
    exists k. split.
    - pattern (φ[up (num c .: num x .: (num y)..)]).
      erewrite bounded_subst.
      + apply sat_single_nat, Hk.
      + eassumption.
      + intros [|[|[|[|n]]]] Hn; solve_bounds; now try apply num_subst.
    - intros y' k' _ H'. cbn.
      rewrite !num_subst. rewrite nat_eval_num.
      eapply part_functional; last apply H.
      apply wrepr, Σ1_completeness.
      { do 2 constructor. now apply Qdec_subst. }
      { constructor. eapply subst_bounded_max; last eassumption.
        intros [|[|[|[|n]]]] Hn; solve_bounds; now try apply num_bound. }
      intros ρ'. exists k'.
      apply sat_single_nat. do 3 rewrite sat_single_nat in H'.
      evar (f : form).
      replace φ[_][_] with ?f.
      + eapply sat_closed; last apply H'.
        rewrite !subst_comp. eapply subst_bounded_max; last eassumption.
        intros [|[|[|[|n]]]] Hn; cbn; rewrite ?num_subst; apply num_bound + lia.
      + rewrite !subst_comp.
        eapply bounded_subst; first eassumption.
        intros [|[|[|[|n]]]] Hn; cbn; rewrite ?num_subst; congruence + lia.
  Qed.

  Lemma ψ_functional c x y y' :
    Qeq ⊢ ψ[num c .: num x .: (num y) ..] -> Qeq ⊢ ψ[num c .: num x .: y'..] → y' == num y.
  Proof.
    cbn -[ψ'].
    intros [k Hk]%Σ1_witness.
    2: { apply Σ1_subst. constructor. apply ψ'_Qdec. }
    2: { eapply subst_bounded_max; last apply ψ'_bounded.
      intros [|[|[|[|n]]]] Hn; solve_bounds; try easy; cbn; rewrite num_subst; apply num_bound. }
    asimpl in Hk.
    rewrite ψ'_subst in Hk.
    fstart.
    fintros "[k' [Hk21 Hk22]]".
    assert (bounded_t 0 (num y ⊕ num k)) as Hbyk.
    { solve_bounds; apply num_bound. }
    pose proof (@Qsdec_le pei (num y ⊕ num k) (y' ⊕ k') Hbyk) as Hyk.
    fdestruct Hyk as "[H|H]".
    - fspecialize ("Hk22" (num y) (num k)).
      cbn. rewrite !num_subst. asimpl.
      fapply ax_sym. fapply "Hk22".
      + unfold PAle. cbn. rewrite !num_subst. ctx.
      + replace (φ[_]) with (φ[num k .: num c .: num x .: (num y) ..]).
        { fdestruct Hk. ctx. }
        eapply bounded_subst; first eassumption.
        intros [|[|[|[|n]]]] Hn; easy + lia.
    - fdestruct Hk as "[Hk11 Hk12]".
      fspecialize ("Hk12" y' k').
      cbn. asimpl. rewrite !num_subst.
      fapply "Hk12".
      + unfold PAle. cbn. rewrite !num_subst. ctx.
      + replace (φ[_]) with (φ[k' .: num c .: num x .: y' ..]).
        { fdestruct Hk. ctx. }
        eapply bounded_subst; first eassumption.
        intros [|[|[|[|n]]]] Hn; cbn; easy + lia.
  Qed.

  Lemma epf_n_uctq : uCTQ.
  Proof.
    exists ψ.
    split; first apply ψ_bounded.
    split; first apply ψ_Σ1.
    intros f. destruct (theta_universal f) as [c Hc]. exists c.
    intros x y.
    split.
    2: { intros H. apply Hc, ψ_theta, H. }
    intros Hf.
    fstart.
    Opaque ψ.
    fintros y'. fsplit.
    - fintros "H".
      rewrite num_subst. feapply ψ_functional.
      + apply theta_ψ, Hc, Hf.
      + asimpl. rewrite !num_subst.
        evar (ρ : nat -> term).
        replace (ψ[_]) with (ψ[?ρ]).
        { fapply "H". }
        eapply bounded_subst; first apply ψ_bounded.
        intros [|[|[|n]]] Hn; cbn; easy + lia.
    - fintros "H".
      feapply Q_leibniz.
      { feapply ax_sym. fapply "H". }
      asimpl. rewrite !num_subst.
      replace (ψ[_]) with (ψ[num c .: num x .: (num y) ..]).
      { fapply theta_ψ. apply Hc, Hf. }
      eapply bounded_subst; first apply ψ_bounded.
      intros [|[|[|n]]] Hn; cbn; easy + lia.
    Transparent ψ.
  Qed.
End ctq.

Section ctq.
  Existing Instance PA_preds_signature.
  Existing Instance PA_funcs_signature.
  Existing Instance interp_nat.

  Context `{pei : peirce}.

  Definition embed' t := embed t * 2.
  Definition unembed' c := unembed (Nat.div c 2).

  Lemma unembed'_embed' x y : unembed' (embed' (x, y)) = (x, y).
  Proof.
    unfold unembed', embed'.
    rewrite PeanoNat.Nat.div_mul.
    - apply embedP.
    - lia.
  Qed.
  Lemma gaussian_sum x : 2 * nat_rec (fun _ : nat => nat) 0 (fun i m : nat => S i + m) x =
    x * (x + 1).
  Proof.
    induction x as [|x IH]; cbn in *; lia.
  Qed.

  Lemma embed'_expl x y : embed' (x, y) = y * 2 + (y + x) * (y + x + 1).
  Proof.
    unfold embed', embed.
    rewrite <-gaussian_sum. lia.
  Qed.
  Lemma compress_free φ n : bounded (S n) φ -> exists ρ,
    bounded (S (S n)) (φ[ρ]) /\ forall x y, Qeq ⊢ φ[(num (embed' (x, y)))..] ↔ φ[ρ][num x .: (num y)..].
  Proof.
    intros Hb.
    exists (($1 ⊗ (σ σ zero) ⊕ ($1 ⊕ $0) ⊗ ($1 ⊕ $0 ⊕ σ zero)).:(S >> S >> var)).
    split.
    { eapply subst_bounded_max; last eassumption.
      intros [|k] H; cbn.
      - solve_bounds.
      - cbv; solve_bounds. }
    intros x y.
    assert (Qeq ⊢ num (embed' (x, y)) == num y ⊗ (σ σ zero) ⊕ (num y ⊕ num x) ⊗ (num y ⊕ num x ⊕ σ zero)) as Heq.
    { apply Σ1_completeness.
      { constructor. apply Qdec_eq. }
      { repeat solve_bounds; apply num_bound. }
      intros ρ. cbn. rewrite !nat_eval_num. apply embed'_expl. }
    replace (φ[_][_]) with φ[(num y ⊗ σ (σ zero) ⊕ (num y ⊕ num x) ⊗ (num y ⊕ num x ⊕ σ zero))..].
    2: { rewrite subst_comp. apply subst_ext.
      intros [|k]; reflexivity. }
    fsplit.
    - fapply Q_leibniz. apply Heq.
    - fapply Q_leibniz. fapply ax_sym. apply Heq.
  Qed.
  Lemma compress_free3 φ n : bounded (S n) φ -> exists ρ,
    bounded (S (S (S n))) (φ[ρ]) /\ forall x y z, Qeq ⊢ φ[(num (embed' (embed' (x, y), z)))..] ↔ φ[ρ][num x .: num y .: (num z)..].
  Proof.
    intros Hb.
    destruct (compress_free Hb) as (ρ1 & Hb1 & Hρ1).
    destruct (compress_free Hb1) as (ρ2 & Hb2 & Hρ2).
    rewrite subst_comp in Hb2.
    eexists. split.
    { apply Hb2. }
    intros x y z.
    rewrite <-subst_comp.
    fstart. fsplit.
    - fintros "H".
      specialize (Hρ2 x y). apply subst_Weak with (xi := (num z)..) in Hρ2.
      change (map _ _) with Qeq in Hρ2.
      specialize (Hρ1 (embed' (x, y)) z).
      asimpl. asimpl in Hρ1. asimpl in Hρ2.
      rewrite !num_subst in Hρ2.
      fapply Hρ2. fapply Hρ1. ctx.
    - fintros "H". fapply Hρ1.
      specialize (Hρ2 x y). apply subst_Weak with (xi := (num z)..) in Hρ2.
      change (map _ _) with Qeq in Hρ2.
      asimpl. asimpl in Hρ2. rewrite !num_subst in Hρ2.
      fapply Hρ2. ctx.
  Qed.

  Variable theta_mu_universal : is_universal theta_mu.

  Lemma embed'_unembed' t x y :
    embed' (x, y) = t -> unembed' t = (x, y).
  Proof.
    intros <-. apply unembed'_embed'.
  Qed.

  Lemma theta_mu_enumerable : enumerable (fun t => let '(t', y) := unembed' t in let '(c, x) := unembed' t' in theta_mu c x ▷ y).
  Proof.
    apply semi_decidable_enumerable.
    { exists Some. intros x. eauto. }
    unshelve eexists.
    { intros [[c x]%unembed' y]%unembed' k.
      destruct ((theta_mu c x).(core) k) as [y'|].
      - exact (nat_eq_dec y y').
      - exact false. }
    intros t.
    destruct (unembed' t) as [t' y] eqn:H1, (unembed' t') as [c x] eqn:H2.
    split.
    - intros [k Hk]. exists k. cbv zeta match beta.
      rewrite H2. rewrite Hk. now apply Dec_reflect.
    - intros [k Hk]. exists k.
      cbv zeta match beta in Hk.
      rewrite H2 in Hk.
      destruct core.
      + now apply Dec_reflect in Hk.
      + discriminate.
  Qed.

  (** ** EPF_mu implies CTQ *)
  Lemma epf_mu_uctq : uCTQ.
  Proof.
    destruct (@Q_weak_repr pei theta_mu_universal (fun t => let '(t', y) := unembed' t in let '(c, x) := unembed' t' in theta_mu c x ▷ y)) as (φ1 & Hb1 & HΣ1 & Hφ1); first apply theta_mu_enumerable.
    assert (exists φ, Σ1 φ /\ bounded 3 φ /\ forall c x y, theta_mu c x ▷ y <-> Qeq ⊢ φ[num c .: num x .: (num y)..]) as (φ2 & HΣ2 & Hb2 & Hφ2).
    { destruct (compress_free3 Hb1) as (ρ & Hb & Hρ). exists (φ1[ρ]).
      split; first (apply Σ1_subst, HΣ1).
      split; first assumption.
      intros c x y.
      specialize (Hφ1 (embed' (embed' (c, x), y))). rewrite !unembed'_embed' in Hφ1.
      setoid_rewrite Hφ1.
      split; intros H; fapply Hρ; apply H. }
    assert (exists φ, Qdec φ /\ bounded 4 φ /\ forall c x y, theta_mu c x ▷ y <-> Qeq ⊢ ∃ φ[$0 .: num c .: num x .: (num y)..]) as (φ3 & HQ3 & Hb3 & Hφ3).
    { destruct (Σ1_compression Hb2 HΣ2) as (φ & HQ & Hb & Hφ).
      exists φ. do 2 (split; first assumption).
      intros c x y. rewrite Hφ2.
      apply subst_Weak with (xi := num c .: num x .: (num y)..) in Hφ.
      change (map _ _) with Qeq in Hφ. cbn in Hφ.
      replace (φ[$0 .: _]) with (φ[up (num c .: num x .: (num y)..)]).
      { apply prv_intu_peirce in Hφ. split; intros H; fapply Hφ; apply H. }
      eapply bounded_subst; first eassumption.
      intros [|[|[|[|n]]]] H; cbn; lia + now rewrite ?num_subst. }
    eapply epf_n_uctq with (theta := theta_mu) (φ := φ3).
    all: assumption.
  Qed.
  Lemma epf_mu_ctq : CTQ.
  Proof.
    apply uctq_ctq, epf_mu_uctq.
  Qed.

End ctq.


Require Import Arith.
Require FunctionalExtensionality.
Require Import List.
Import List.ListNotations.

Require Import mathcomp.ssreflect.ssreflect.
Set Bullet Behavior "Strict Subproofs".

Require Import StructTact.StructTactics.
Require Import StructTact.Util.

Require Import Chord.Chord.
Require Import Chord.HandlerLemmas.
Require Import Chord.SystemLemmas.

(* for all nodes, query = none -> no request or response in the network for node *)
(* for all nodes, query = some -> exactly one corresponding req or res in net *)
Definition request_for_query (gst : global_state) (src dst : addr) (q : query) (msg : payload) : Prop :=
  query_request q msg /\
  In (src, (dst, msg)) (msgs gst).

Definition response_for_query (gst : global_state) (src dst : addr) (q : query) (msg : payload) : Prop :=
  query_response q msg /\
  In (dst, (src, msg)) (msgs gst).

Definition query_delayed_at (dst : addr) (st : data) (src : addr) (msg : payload) : Prop :=
  In (src, msg) (delayed_queries st).

Inductive reachable_st : global_state -> Prop :=
| reachableInit :
    forall gst,
      initial_st gst ->
      reachable_st gst
| reachableStep :
    forall gst gst',
    reachable_st gst ->
    step_dynamic gst gst' ->
    reachable_st gst'.

Ltac induct_reachable_st :=
  match goal with
  | [H : reachable_st _ |- _ ] => prep_induction H; induction H
  end.

Inductive intermediate_reachable_st : global_state -> Prop :=
| intReachableInit :
    forall gst,
      initial_st gst ->
      intermediate_reachable_st gst
| intReachableStep :
    forall gst gst',
      intermediate_reachable_st gst ->
      step_dynamic gst gst' ->
      intermediate_reachable_st gst'
| intReachableDelayedQueries :
    forall gst h d res,
      In h (nodes gst) ->
      ~ In h (failed_nodes gst) ->
      sigma gst h = Some d ->
      do_delayed_queries h d = res ->
      intermediate_reachable_st (apply_handler_result h res [] gst).

Ltac induct_int_reachable_st :=
  match goal with
  | [H : intermediate_reachable_st _ |- _ ] => prep_induction H; induction H
  end.

Ltac induct type :=
  match goal with
  | [H : type _ |- _ ] => prep_induction H; induction H
  end.

Lemma reachable_intermediate_reachable :
  forall gst,
    reachable_st gst ->
    intermediate_reachable_st gst.
Proof using.
  intros.
  induct_reachable_st; econstructor; now eauto.
Qed.

(* transitive closure of best_succ *)
(* treat as opaque *)
Inductive reachable (gst : global_state) : addr -> addr -> Prop :=
| ReachableSucc : forall from to,
    best_succ gst from to ->
    reachable gst from to
| ReachableTransL : forall from x to,
    best_succ gst from x ->
    reachable gst x to ->
    reachable gst from to.

Ltac induct_reachable :=
  match goal with
  | H : reachable _ _ _ |- _ =>
    induction H
  end.

Lemma ReachableTransR : forall gst from x to,
    reachable gst from x ->
    best_succ gst x to ->
    reachable gst from to.
Proof using.
  intuition.
  induct_reachable.
  - eapply ReachableTransL.
    eauto.
    eapply ReachableSucc.
    eauto.
  - eauto using ReachableTransL.
Qed.

Lemma ReachableTrans : forall gst from x to,
    reachable gst from x ->
    reachable gst x to ->
    reachable gst from to.
Proof using.
  intros gst from x to H.
  generalize dependent to.
  induction H.
  - intuition.
    eauto using ReachableSucc, ReachableTransL.
  - intuition.
    eauto using ReachableSucc, ReachableTransL.
Qed.

(* treat as opaque *)
Definition ring_member (gst : global_state) (h : addr) : Prop :=
  reachable gst h h.
Hint Unfold ring_member.

(* If we have an open query at a live node, we have one of the following:
     - an appropriate request from src to dst
       and no other requests from src to dst
       and no responses from dst to src
       and no pending queries from src in the local state of dst
     - an appropriate response from dst to src
       and no requests from src to dst
       and no other responses from dst to src
       and no pending queries from src in the local state of dst
     - a corresponding pending query from src in the local state of dst
       and no requests from src to dst
       and no responses from dst to src *)
Definition request_in_transit (gst : global_state) (src dst : addr) (q : query) : Prop :=
  forall chan,
    chan = channel gst src dst ->
    exists req,
      query_request q req /\
      In req chan /\
      (* no other requests *)
      (forall m xs ys,
          chan = xs ++ req :: ys ->
          In m (xs ++ ys) ->
          request_payload m ->
          m = req) /\
      (* no responses *)
      (forall m,
          In m (channel gst dst src) ->
          ~ response_payload m) /\
      (forall m st,
          sigma gst dst = Some st ->
          ~ query_delayed_at dst st src m).

Definition response_in_transit (gst : global_state) (src dst : addr) (q : query) : Prop :=
  forall chan,
    chan = channel gst dst src ->
    exists res,
      query_response q res /\
      In res chan /\
      (* no other responses *)
      (forall m xs ys,
          chan = xs ++ res :: ys ->
          In m (xs ++ ys) ->
          response_payload m ->
          m = res) /\
      (* no requests *)
      (forall m,
          In m (channel gst src dst) ->
          ~ request_payload m) /\
      (forall m st,
          sigma gst dst = Some st ->
          ~ query_delayed_at dst st src m).

Definition pending_query (gst : global_state) (src dst : addr) (q : query) : Prop :=
  (forall st,
      exists m,
        sigma gst src = Some st ->
        query_delayed_at dst st src m) /\
  (forall m,
      In m (channel gst src dst) ->
      ~ request_payload m) /\
  (forall m,
      In m (channel gst dst src) ->
      ~ response_payload m).

Lemma coarse_reachable_characterization :
  forall from to gst gst',
    reachable gst from to ->
    nodes gst' = nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    sigma gst' = sigma gst ->
    reachable gst' from to.
Proof using.
  intuition.
  induction H;
    eauto using ReachableSucc, ReachableTransL, coarse_best_succ_characterization.
Qed.

Lemma adding_node_preserves_reachable :
  forall h from to gst gst' st,
    reachable gst from to ->
    ~ In h (nodes gst) ->
    nodes gst' = h :: nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    sigma gst' = update addr_eq_dec (sigma gst) h (Some st) ->
    reachable gst' from to.
Proof using.
  intuition.
  induction H;
    eauto using ReachableSucc, ReachableTransL, adding_nodes_does_not_affect_best_succ.
Qed.

Ltac break_best_succ :=
  match goal with
  | H : best_succ _ _ _ |- _ =>
    let x := fresh in
    pose proof H as x;
    unfold best_succ in x;
    break_exists;
    break_and
  end.

Lemma In_timeouts_in :
  forall t st,
    In t (timeouts_in st) ->
    exists dst q m,
      cur_request st = Some (dst, q, m) /\
      t = Request (addr_of dst) m.
Proof using.
  unfold timeouts_in.
  intros.
  repeat break_match.
  repeat eexists; eauto.
  match type of H with
  | In _ _ => inv H
  end.
  eauto.
  exfalso; auto with *.
  exfalso; auto with *.
Qed.

Definition chord_init_invariant (P : global_state -> Prop) :=
  forall gst,
    initial_st gst ->
    P gst.
Hint Unfold chord_init_invariant.

Definition chord_start_pre_post (P Q : global_state -> Prop) : Prop :=
  forall h gst gst' k st ms nts,
    reachable_st gst ->
    step_dynamic gst gst' ->

    ~ In h (nodes gst) ->
    ~ client_addr h ->
    start_constraint gst h ->
    In k (nodes gst) ->
    ~ In k (failed_nodes gst) ->
    start_handler h [k] = (st, ms, nts) ->

    nodes gst' = h :: nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    timeouts gst' = update addr_eq_dec (timeouts gst) h nts ->
    sigma gst' = update addr_eq_dec (sigma gst) h (Some st) ->
    msgs gst' = map (send h) ms ++ msgs gst ->
    trace gst' = trace gst ++ map e_send (map (send h) ms) ->

    P gst ->
    Q gst'.
Hint Unfold chord_start_pre_post.

Definition chord_start_invariant (P : global_state -> Prop) : Prop :=
  chord_start_pre_post P P.
Hint Unfold chord_start_invariant.

Definition chord_fail_pre_post (P Q : global_state -> Prop) : Prop :=
  forall h gst gst',
    reachable_st gst ->
    step_dynamic gst gst' ->

    In h (nodes gst) ->
    ~ In h (failed_nodes gst) ->
    failure_constraint gst h gst' ->

    nodes gst' = nodes gst ->
    failed_nodes gst' = h :: failed_nodes  gst ->
    timeouts gst' = timeouts gst ->
    sigma gst' = sigma gst ->
    msgs gst' = msgs gst ->
    trace gst' = trace gst ->

    P gst ->
    Q gst'.
Hint Unfold chord_fail_pre_post.

Definition chord_fail_invariant (P : global_state -> Prop) : Prop :=
  chord_fail_pre_post P P.
Hint Unfold chord_fail_invariant.

Definition chord_tick_pre_post (P Q : global_state -> Prop) : Prop :=
  forall gst gst' h st st' ms nts cts eff,
    reachable_st gst ->
    step_dynamic gst gst' ->

    In Tick (timeouts gst h) ->
    In h (nodes gst) ->
    ~ In h (failed_nodes gst) ->
    sigma gst h = Some st ->
    tick_handler h st = (st', ms, nts, cts, eff) ->

    nodes gst' = nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    timeouts gst' = update addr_eq_dec (timeouts gst) h
                           (nts ++ remove_all timeout_eq_dec cts
                                (remove timeout_eq_dec Tick (timeouts gst h))) ->
    sigma gst' = update addr_eq_dec (sigma gst) h (Some st') ->
    msgs gst' = (map (send h) ms) ++ msgs gst ->
    trace gst' = trace gst ++ [e_timeout h Tick] ->

    P gst ->
    Q gst'.
Hint Unfold chord_tick_pre_post.

Definition chord_tick_invariant (P : global_state -> Prop) : Prop :=
  chord_tick_pre_post P P.
Hint Unfold chord_tick_invariant.

Definition chord_keepalive_pre_post (P Q : global_state -> Prop) : Prop :=
  forall gst gst' h st st' ms nts cts eff,
    reachable_st gst ->
    step_dynamic gst gst' ->

    In KeepaliveTick (timeouts gst h) ->
    In h (nodes gst) ->
    ~ In h (failed_nodes gst) ->
    sigma gst h = Some st ->
    keepalive_handler st = (st', ms, nts, cts, eff) ->

    nodes gst' = nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    timeouts gst' = update addr_eq_dec (timeouts gst) h
                           (nts ++ remove_all timeout_eq_dec cts
                                (remove timeout_eq_dec KeepaliveTick (timeouts gst h))) ->
    sigma gst' = update addr_eq_dec (sigma gst) h (Some st') ->
    msgs gst' = (map (send h) ms) ++ msgs gst ->
    trace gst' = trace gst ++ [e_timeout h KeepaliveTick] ->

    P gst ->
    Q gst'.
Hint Unfold chord_keepalive_pre_post.

Definition chord_keepalive_invariant (P : global_state -> Prop) : Prop :=
  chord_keepalive_pre_post P P.
Hint Unfold chord_keepalive_invariant.

Definition chord_rectify_pre_post (P Q : global_state -> Prop) :=
  forall gst gst' h st st' ms nts cts eff,
    reachable_st gst ->
    step_dynamic gst gst' ->

    In RectifyTick (timeouts gst h) ->
    In h (nodes gst) ->
    ~ In h (failed_nodes gst) ->
    sigma gst h = Some st ->
    do_rectify h st = (st', ms, nts, cts, eff) ->

    nodes gst' = nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    timeouts gst' = update addr_eq_dec (timeouts gst) h
                           (nts ++ remove_all timeout_eq_dec cts
                                (remove timeout_eq_dec RectifyTick (timeouts gst h))) ->
    sigma gst' = update addr_eq_dec (sigma gst) h (Some st') ->
    msgs gst' = (map (send h) ms) ++ msgs gst ->
    trace gst' = trace gst ++ [e_timeout h RectifyTick] ->

    P gst ->
    Q gst'.
Hint Unfold chord_rectify_pre_post.

Definition chord_rectify_invariant (P : global_state -> Prop) :=
  chord_rectify_pre_post P P.
Hint Unfold chord_rectify_invariant.

Definition chord_request_pre_post (P Q : global_state -> Prop) : Prop :=
  forall gst gst' h st st' ms nts cts eff t dst req,
    reachable_st gst ->
    step_dynamic gst gst' ->

    t = Request dst req ->
    timeout_constraint gst h t ->
    In t (timeouts gst h) ->
    In h (nodes gst) ->
    ~ In h (failed_nodes gst) ->
    sigma gst h = Some st ->
    request_timeout_handler h st dst req = (st', ms, nts, cts, eff) ->

    nodes gst' = nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    timeouts gst' = update addr_eq_dec (timeouts gst) h
                           (nts ++ remove_all timeout_eq_dec cts
                                (remove timeout_eq_dec t (timeouts gst h))) ->
    sigma gst' = update addr_eq_dec (sigma gst) h (Some st') ->
    msgs gst' = (map (send h) ms) ++ msgs gst ->
    trace gst' = trace gst ++ [e_timeout h t] ->

    P gst ->
    Q gst'.
Hint Unfold chord_request_pre_post.

Definition chord_request_invariant (P : global_state -> Prop) : Prop :=
  chord_request_pre_post P P.
Hint Unfold chord_request_invariant.

Definition chord_recv_handler_pre_post (P Q : global_state -> Prop) : Prop :=
  forall gst gst' src h st p xs ys st' ms nts cts,
    reachable_st gst ->
    step_dynamic gst gst' ->

    recv_handler src h st p = (st', ms, nts, cts) ->
    msgs gst = xs ++ (src, (h, p)) :: ys ->
    In h (nodes gst) ->
    ~ In h (failed_nodes gst') ->
    sigma gst h = Some st ->

    nodes gst' = nodes gst ->
    failed_nodes gst' = failed_nodes gst ->
    timeouts gst' = update addr_eq_dec (timeouts gst) h (nts ++ remove_all timeout_eq_dec cts (timeouts gst h)) ->
    sigma gst' = update addr_eq_dec (sigma gst) h (Some st') ->
    msgs gst' = (map (send h) ms) ++ xs ++ ys ->
    trace gst' = trace gst ++ [e_recv (src, (h, p))] ->

    P gst ->
    Q gst'.
Hint Unfold chord_recv_handler_pre_post.

Definition chord_recv_handler_invariant (P : global_state -> Prop) : Prop :=
  chord_recv_handler_pre_post P P.
Hint Unfold chord_recv_handler_invariant.

Definition chord_input_pre_post (P Q : global_state -> Prop) :=
  forall gst gst' h i to m,
    reachable_st gst ->
    step_dynamic gst gst' ->

    gst' = update_msgs_and_trace gst (m :: msgs gst) (e_send m) ->
    client_addr h ->
    client_payload i ->
    m = send h (to, i) ->
    P gst ->
    Q gst'.
Hint Unfold chord_input_pre_post.

Definition chord_input_invariant (P : global_state -> Prop) :=
  chord_input_pre_post P P.
Hint Unfold chord_input_invariant.

Definition chord_output_pre_post (P Q : global_state -> Prop) :=
  forall gst gst' h xs m ys,
    reachable_st gst ->
    step_dynamic gst gst' ->

    gst' = update_msgs_and_trace gst (xs ++ ys) (e_recv m) ->
    client_addr h ->
    msgs gst = xs ++ m :: ys ->
    h = fst (snd m) ->
    P gst ->
    Q gst'.
Hint Unfold chord_output_pre_post.

Definition chord_output_invariant (P : global_state -> Prop) :=
  chord_output_pre_post P P.
Hint Unfold chord_output_invariant.

Theorem chord_net_invariant :
  forall P,
    chord_init_invariant P ->

    chord_start_invariant P ->
    chord_fail_invariant P ->

    chord_tick_invariant P ->
    chord_keepalive_invariant P ->
    chord_rectify_invariant P ->
    chord_request_invariant P ->

    chord_recv_handler_invariant P ->
    chord_input_invariant P ->
    chord_output_invariant P ->

    forall gst,
      reachable_st gst ->
      P gst.
Proof using.
  intros.
  match goal with
  | [H : reachable_st _ |- _] => induction H
  end.
  - now eapply_prop chord_init_invariant.
  - inv_prop step_dynamic; eauto.
    + destruct (start_handler _ _) as [[? ?] ?] eqn:?; eauto.
    + destruct t; unfold timeout_handler, timeout_handler_eff in *.
      * destruct (tick_handler _ _) as [[[? ?] ?] ?] eqn:?.
        simpl in *; tuple_inversion; eauto.
      * destruct (do_rectify _ _) as [[[? ?] ?] ?] eqn:?.
        simpl in *; tuple_inversion; eauto.
      * destruct (keepalive_handler _) as [[[? ?] ?] ?] eqn:?.
        simpl in *; tuple_inversion; eauto.
      * destruct (request_timeout_handler _ _ _ _) as [[[? ?] ?] ?] eqn:?.
        simpl in *; tuple_inversion; eauto.
    + destruct m as [? [? ?]]; eauto.
Qed.

Lemma chord_fail_pre_post_conj :
  forall Pre P Q,
    chord_fail_pre_post Pre P ->
    chord_fail_pre_post Pre Q ->
    chord_fail_pre_post Pre (fun gst => P gst /\ Q gst).
Proof.
  eauto.
Qed.
Hint Resolve chord_fail_pre_post_conj.

Lemma chord_fail_pre_post_weaken_l :
  forall Pre P Q,
    chord_fail_pre_post Pre (fun gst => P gst /\ Q gst) ->
    chord_fail_pre_post Pre P.
Proof.
  autounfold; intros.
  cut (P gst' /\ Q gst'); [tauto|eauto].
Qed.
Hint Resolve chord_fail_pre_post_weaken_l.

Lemma chord_fail_pre_post_weaken_r :
  forall Pre P Q,
    chord_fail_pre_post Pre (fun gst => P gst /\ Q gst) ->
    chord_fail_pre_post Pre Q.
Proof.
  autounfold; intros.
  cut (P gst' /\ Q gst'); [tauto|eauto].
Qed.
Hint Resolve chord_fail_pre_post_weaken_r.

Lemma chord_fail_pre_post_strengthen_l :
  forall P Q Post,
    chord_fail_pre_post P Post ->
    chord_fail_pre_post (fun gst => P gst /\ Q gst) Post.
Proof.
  autounfold; intros; intuition eauto.
Qed.
Hint Resolve chord_fail_pre_post_strengthen_l.

Lemma chord_fail_pre_post_strengthen_r :
  forall P Q Post,
    chord_fail_pre_post Q Post ->
    chord_fail_pre_post (fun gst => P gst /\ Q gst) Post.
Proof.
  autounfold; intros; intuition eauto.
Qed.
Hint Resolve chord_fail_pre_post_strengthen_r.

Lemma chord_start_pre_post_conj :
  forall Pre P Q,
    chord_start_pre_post Pre P ->
    chord_start_pre_post Pre Q ->
    chord_start_pre_post Pre (fun gst => P gst /\ Q gst).
Proof.
  eauto.
Qed.
Hint Resolve chord_start_pre_post_conj.

Lemma chord_start_pre_post_weaken_l :
  forall Pre P Q,
    chord_start_pre_post Pre (fun gst => P gst /\ Q gst) ->
    chord_start_pre_post Pre P.
Proof.
  autounfold; intros.
  cut (P gst' /\ Q gst'); [tauto|eauto].
Qed.
Hint Resolve chord_start_pre_post_weaken_l.

Lemma chord_start_pre_post_weaken_r :
  forall Pre P Q,
    chord_start_pre_post Pre (fun gst => P gst /\ Q gst) ->
    chord_start_pre_post Pre Q.
Proof.
  autounfold; intros.
  cut (P gst' /\ Q gst'); [tauto|eauto].
Qed.
Hint Resolve chord_start_pre_post_weaken_r.

Lemma chord_start_pre_post_strengthen_l :
  forall P Q Post,
    chord_start_pre_post P Post ->
    chord_start_pre_post (fun gst => P gst /\ Q gst) Post.
Proof.
  autounfold; intros; intuition eauto.
Qed.
Hint Resolve chord_start_pre_post_strengthen_l.

Lemma chord_start_pre_post_strengthen_r :
  forall P Q Post,
    chord_start_pre_post Q Post ->
    chord_start_pre_post (fun gst => P gst /\ Q gst) Post.
Proof.
  autounfold; intros; intuition eauto.
Qed.
Hint Resolve chord_start_pre_post_strengthen_r.

Lemma chord_init_invariant_weaken_l :
  forall P Q,
    chord_init_invariant (fun gst => P gst /\ Q gst) ->
    chord_init_invariant P.
Proof.
  simpl; autounfold; intros; find_apply_hyp_hyp; tauto.
Qed.
Hint Resolve chord_init_invariant_weaken_l.

Lemma chord_init_invariant_weaken_r :
  forall P Q,
    chord_init_invariant (fun gst => P gst /\ Q gst) ->
    chord_init_invariant Q.
Proof.
  simpl; autounfold; intros; find_apply_hyp_hyp; tauto.
Qed.
Hint Resolve chord_init_invariant_weaken_r.

Lemma recv_handler_post_conj :
  forall Pre P Q,
    chord_recv_handler_pre_post Pre P ->
    chord_recv_handler_pre_post Pre Q ->
    chord_recv_handler_pre_post Pre (fun gst => P gst /\ Q gst).
Proof.
  autounfold; eauto.
Qed.
Hint Resolve recv_handler_post_conj.

Lemma recv_handler_pre_strengthen_l :
  forall P Q Post,
    chord_recv_handler_pre_post P Post ->
    chord_recv_handler_pre_post (fun gst => P gst /\ Q gst) Post.
Proof.
  autounfold; intuition eauto.
Qed.
Hint Resolve recv_handler_pre_strengthen_l.

Lemma recv_handler_pre_strengthen_r :
  forall P Q Post,
    chord_recv_handler_pre_post P Post ->
    chord_recv_handler_pre_post (fun gst => Q gst /\ P gst) Post.
Proof.
  autounfold; intuition eauto.
Qed.
Hint Resolve recv_handler_pre_strengthen_r.