(* This program is free software; you can redistribute it and/or      *)
(* modify it under the terms of the GNU Lesser General Public License *)
(* as published by the Free Software Foundation; either version 2.1   *)
(* of the License, or (at your option) any later version.             *)
(*                                                                    *)
(* This program is distributed in the hope that it will be useful,    *)
(* but WITHOUT ANY WARRANTY; without even the implied warranty of     *)
(* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the      *)
(* GNU General Public License for more details.                       *)
(*                                                                    *)
(* You should have received a copy of the GNU Lesser General Public   *)
(* License along with this program; if not, write to the Free         *)
(* Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA *)
(* 02110-1301 USA                                                     *)

Require Import Bool.
Require Import Sumbool.
Require Import Arith.
Require Import ZArith NArith Nnat Ndec Ndigits.
From IntMap Require Import Allmaps.
Require Import Wf_nat.

Require Import BDDvar_ad_nat.
Require Import bdd1.
Require Import bdd2.
Require Import bdd3.
Require Import bdd4.
Require Import bdd5_1.
Require Import bdd5_2.
Require Import bdd6.
Require Import bdd7.
Require Import BDDdummy_lemma_2.
Require Import BDDdummy_lemma_3.
Require Import BDDdummy_lemma_4.
Require Import bdd8.
Require Import bdd9.
Require Import bdd10.
Require Import bdd11.

Definition is_tauto (be : bool_expr) :=
  N.eqb BDDone
    (fst
       (snd (BDDof_bool_expr initBDDconfig initBDDneg_memo initBDDor_memo be))).

Definition is_valid (be : bool_expr) :=
  forall vb : var_binding, bool_fun_of_bool_expr be vb = true.

Lemma initBDDor_memo_OK : BDDor_memo_OK initBDDconfig initBDDor_memo.
Proof.
  unfold BDDor_memo_OK in |- *. intros. discriminate H.
Qed.

Lemma initBDDneg_memo_OK : BDDneg_memo_OK initBDDconfig initBDDneg_memo.
Proof.
  unfold BDDneg_memo_OK in |- *. intros. discriminate H.
Qed.

Lemma initBDDneg_memo_OK_2 : BDDneg_memo_OK_2 initBDDconfig initBDDneg_memo.
Proof.
  unfold BDDneg_memo_OK_2 in |- *. intros. discriminate H.
Qed.

Lemma is_tauto_is_correct :
 forall be : bool_expr, is_tauto be = true -> is_valid be.
Proof.
  unfold is_tauto, is_valid in |- *. intros.
  elim
   (BDDof_bool_expr_correct be initBDDconfig initBDDneg_memo initBDDor_memo
      initBDDconfig_OK initBDDneg_memo_OK_2 initBDDor_memo_OK).
  intros. elim H1. intros. elim H3. intros. elim H5. intros. elim H7. intros.
  rewrite <- (Neqb_complete _ _ H) in H9.
  exact
   (bool_fun_eq_trans _ _ _ (bool_fun_eq_symm _ _ H9)
      (bool_fun_of_BDDone _ H0) vb).
Qed.

Lemma is_tauto_is_complete :
 forall be : bool_expr, is_valid be -> is_tauto be = true.
Proof.
  unfold is_tauto, is_valid in |- *. intros.
  elim
   (BDDof_bool_expr_correct be initBDDconfig initBDDneg_memo initBDDor_memo
      initBDDconfig_OK initBDDneg_memo_OK_2 initBDDor_memo_OK).
  intros. elim H1. intros. elim H3. intros. elim H5. intros. elim H7. intros.
  rewrite <-
   (BDDunique
      (fst (BDDof_bool_expr initBDDconfig initBDDneg_memo initBDDor_memo be))
      H0 BDDone
      (fst
         (snd
            (BDDof_bool_expr initBDDconfig initBDDneg_memo initBDDor_memo be))))
   .
  reflexivity.
  unfold config_node_OK in |- *. unfold node_OK in |- *. right. left. reflexivity.
  exact H2.
  apply bool_fun_eq_symm.
  apply bool_fun_eq_trans with (bf2 := bool_fun_of_bool_expr be). exact H9.
  apply bool_fun_eq_trans with (bf2 := bool_fun_one). exact H.
  apply bool_fun_eq_symm. exact (bool_fun_of_BDDone _ H0).
Qed.


Require Coq.Classes.EquivDec.
Require Coq.Lists.List.
Import List.ListNotations.
Require Import Coq.Program.Program.

Require Import Leapfrog.Syntax.
Require Import Leapfrog.FinType.
Require Import Leapfrog.Sum.
Require Import Leapfrog.ConfRel.
Require Import Leapfrog.Notations.
Require Import Leapfrog.BisimChecker.

Open Scope p4a.

Notation eth_size := 112.
Notation ip_size := 160.
Notation vlan_size := 32.
Notation udp_size := 64.

(*
This example is an undefined-value example inspired by the running
example in the SafeP4 paper (https://arxiv.org/pdf/1906.07223.pdf).
*)

Module ReadUndef.
  Inductive state :=
  | ParseEth
  | DefaultVLAN
  | ParseVLAN
  | ParseIP
  | ParseUDP.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | HdrEth
  | HdrIP
  | HdrVLAN
  | HdrUDP.

  Definition sz (h: header) : nat :=
    match h with
    | HdrEth => 112
    | HdrIP => 160
    | HdrVLAN => 32
    | HdrUDP => 64
    end.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition states (s: state) : P4A.state state sz :=
    match s with
    | ParseEth =>
      {| st_op := extract(HdrEth);
         st_trans := transition select (| (EHdr (Hdr_sz := sz) HdrEth)[0 -- 0] |) {{
                                    [| exact #b|0 |] ==> inl DefaultVLAN ;;;
                                    [| exact #b|1 |] ==> inl ParseVLAN ;;;
                                    reject
                                }}
      |}
    | DefaultVLAN =>
      {| st_op := HdrVLAN <- ELit _ (Ntuple.n_tuple_repeat _ false) ;;
                  extract(HdrIP);
         st_trans := transition (inl ParseUDP)
      |}
    | ParseIP =>
      {| st_op := extract(HdrIP);
         st_trans := transition (inl ParseUDP)
      |}
    | ParseVLAN =>
      {| st_op := extract(HdrVLAN);
         st_trans := transition (inl ParseIP)
      |}
    | ParseUDP =>
      {| st_op := extract(HdrUDP);
         st_trans := transition select (| (EHdr (Hdr_sz := sz) HdrVLAN)[3--0] |) {{
                                    [| exact #b|1|1|1|1 |] ==> reject ;;;
                                    accept
                                }}
      |}
    end.

  Program Definition aut: Syntax.t state _ :=
    {| t_states := states |}.
  Solve Obligations with (destruct s || destruct h; cbv; Lia.lia).

End ReadUndef.

Module ReadUndefIncorrect.
  Inductive state :=
  | ParseEth
  | DefaultVLAN
  | ParseVLAN
  | ParseIP
  | ParseUDP.

  Scheme Equality for state.
  Global Instance state_eqdec: EquivDec.EqDec state eq := state_eq_dec.
  Global Instance state_finite: @Finite state _ state_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Inductive header :=
  | HdrEth
  | HdrIP
  | HdrVLAN
  | HdrUDP.

  Definition sz (h: header) : nat :=
    match h with
    | HdrEth => 112
    | HdrIP => 160
    | HdrVLAN => 32
    | HdrUDP => 64
    end.

  Scheme Equality for header.
  Global Instance header_eqdec: EquivDec.EqDec header eq := header_eq_dec.
  Global Instance header_finite: @Finite header _ header_eq_dec.
  Proof.
    solve_finiteness.
  Defined.

  Definition states (s: state) : P4A.state state sz :=
    match s with
    | ParseEth =>
      {| st_op := extract(HdrEth);
         st_trans := transition select (| (EHdr (Hdr_sz := sz) HdrEth)[0 -- 0] |) {{
                                    [| exact #b|0 |] ==> inl DefaultVLAN ;;;
                                    [| exact #b|1 |] ==> inl ParseVLAN ;;;
                                    reject
                                }}
      |}
    | DefaultVLAN =>
      {| st_op := extract(HdrIP);
         st_trans := transition (inl ParseUDP)
      |}
    | ParseIP =>
      {| st_op := extract(HdrIP);
         st_trans := transition (inl ParseUDP)
      |}
    | ParseVLAN =>
      {| st_op := extract(HdrVLAN);
         st_trans := transition (inl ParseIP)
      |}
    | ParseUDP =>
      {| st_op := extract(HdrUDP);
         st_trans := transition select (| (EHdr (Hdr_sz := sz) HdrVLAN)[3--0] |) {{
                                    [| exact #b|1|1|1|1 |] ==> reject ;;;
                                    accept
                                }}
      |}
    end.

  Program Definition aut: Syntax.t state _ :=
    {| t_states := states |}.
  Solve Obligations with (destruct s || destruct h; cbv; Lia.lia).

End ReadUndefIncorrect.


Require Import VST.msl.ghost.
Require Import VST.msl.ghost_seplog.
Require Import VST.msl.sepalg_generators.
Require Import VST.veric.compcert_rmaps.
Require Import VST.progs.ghosts.
Require Import VST.progs.conclib.
Require Import VST.progs.invariants.
Import Ensembles.

(* Where should this sit? *)

Section Timeless.

Definition except0 P := P || |>FF.

Definition timeless P := |>P |-- except0 P.

Definition timeless' (P : mpred) := forall (a a' : rmap),
  predicates_hered.app_pred P a' -> age a a' ->
  predicates_hered.app_pred P a.

Lemma timeless'_timeless : forall P, timeless' P -> timeless P.
Proof.
  unfold timeless; intros.
  change (_ |-- _) with (predicates_hered.derives (|>P) (P || |>FF)); intros ? HP.
  destruct (level a) eqn: Ha.
  - right; intros ? ?%laterR_level; omega.
  - left.
    destruct (levelS_age a n) as [b [Hb]]; auto.
    specialize (HP _ (semax_lemmas.age_laterR Hb)).
    eapply H; eauto.
Qed.

Lemma except0_mono : forall P Q, P |-- Q -> except0 P |-- except0 Q.
Proof.
  intros; unfold except0.
  apply orp_left; [apply orp_right1 | apply orp_right2]; auto.
Qed.

Lemma except0_intro : forall P, P |-- except0 P.
Proof.
  intros; unfold except0.
  apply orp_right1; auto.
Qed.

Lemma except0_trans : forall P, except0 (except0 P) |-- except0 P.
Proof.
  intros; unfold except0.
  apply orp_left; [|apply orp_right2]; auto.
Qed.

Lemma except0_timeless : forall P Q, P |-- except0 Q -> timeless P -> |> P |-- except0 Q.
Proof.
  intros.
  eapply derives_trans; eauto.
  eapply derives_trans, except0_trans.
  apply except0_mono; auto.
Qed.

Lemma except0_frame_r : forall P Q, except0 P * Q |-- except0 (P * Q).
Proof.
  intros; unfold except0.
  rewrite distrib_orp_sepcon.
  apply orp_left; [apply orp_right1 | apply orp_right2]; auto.
  eapply derives_trans; [apply sepcon_derives, now_later; apply derives_refl|].
  rewrite <- later_sepcon; apply later_derives.
  rewrite FF_sepcon; auto.
Qed.

Lemma except0_frame_l : forall P Q, P * except0 Q |-- except0 (P * Q).
Proof.
  intros; rewrite sepcon_comm, (sepcon_comm _ Q); apply except0_frame_r.
Qed.

Lemma except0_bupd_elim : forall P, except0 (|==> except0 P) |-- |==> except0 P.
Proof.
  intros; unfold except0.
  apply orp_left; auto.
  eapply derives_trans, bupd_intro.
  apply orp_right2; auto.
Qed.

Lemma except0_bupd : forall P, except0 (|==> P) = |==> (except0 P).
Proof.
  intro; apply pred_ext.
  - eapply derives_trans, except0_bupd_elim.
    apply except0_mono, bupd_mono, except0_intro.
  - change (predicates_hered.derives (own.bupd (except0 P)) (except0 (own.bupd P))).
    intros ??; simpl in H.
    destruct (level a) eqn: Hl.
    + right.
      change ((|> FF)%pred a).
      intros ??%laterR_level; omega.
    + left.
      rewrite <- Hl in *.
      intros ? J; specialize (H _ J) as (? & ? & a' & ? & ? & ? & HP); subst.
      do 2 eexists; eauto; do 2 eexists; eauto; repeat split; auto.
      destruct HP as [|Hfalse]; auto.
      destruct (levelS_age a' n) as (a'' & Hage & ?); [omega|].
      exfalso; apply (Hfalse a'').
      constructor; auto.
Qed.

Lemma except0_sepcon : forall P Q, except0 (P * Q) = except0 P * except0 Q.
Proof.
  intros; unfold except0.
  rewrite distrib_orp_sepcon, !distrib_orp_sepcon2.
  apply pred_ext.
  - apply orp_left.
    + apply orp_right1, orp_right1; auto.
    + apply orp_right2, orp_right2.
      rewrite <- later_sepcon, FF_sepcon; auto.
  - apply orp_left; apply orp_left.
    + apply orp_right1; auto.
    + apply orp_right2.
      eapply derives_trans; [apply sepcon_derives, derives_refl; apply now_later|].
      rewrite <- later_sepcon; apply later_derives; rewrite sepcon_FF; auto.
    + apply orp_right2.
      eapply derives_trans; [apply sepcon_derives, now_later; apply derives_refl|].
      rewrite <- later_sepcon; apply later_derives; rewrite FF_sepcon; auto.
    + apply orp_right2.
      rewrite <- later_sepcon, FF_sepcon; auto.
Qed.

Lemma except0_andp : forall P Q, except0 (P && Q) = except0 P && except0 Q.
Proof.
  intros; unfold except0.
  rewrite distrib_orp_andp.
  rewrite 2(andp_comm _ (_ || _)), !distrib_orp_andp.
  apply pred_ext.
  - apply orp_left.
    + apply orp_right1, orp_right1.
      rewrite andp_comm; auto.
    + apply orp_right2, orp_right2.
      rewrite <- later_andp, FF_andp; auto.
  - apply orp_left; apply orp_left.
    + apply orp_right1.
      rewrite andp_comm; auto.
    + apply orp_right2.
      rewrite andp_comm.
      eapply derives_trans; [apply andp_derives, derives_refl; apply now_later|].
      rewrite <- later_andp; apply later_derives; rewrite andp_FF; auto.
    + apply orp_right2.
      rewrite andp_comm.
      eapply derives_trans; [apply andp_derives, now_later; apply derives_refl|].
      rewrite <- later_andp; apply later_derives; rewrite FF_andp; auto.
    + apply orp_right2.
      rewrite <- later_andp, FF_andp; auto.
Qed.

Lemma except0_exp : forall {A} (x : A) P, except0 (EX x : A, P x) = EX x : A, except0 (P x).
Proof.
  intros; unfold except0; apply pred_ext.
  - apply orp_left.
    + Intro y; Exists y; apply orp_right1; auto.
    + Exists x; apply orp_right2; auto.
  - Intro y; apply orp_left; [apply orp_right1; Exists y | apply orp_right2]; auto.
Qed.

Lemma timeless_sepcon : forall P Q, timeless P -> timeless Q -> timeless (P * Q).
Proof.
  unfold timeless; intros.
  rewrite later_sepcon, except0_sepcon.
  apply sepcon_derives; auto.
Qed.

Lemma timeless_andp : forall P Q, timeless P -> timeless Q -> timeless (P && Q).
Proof.
  unfold timeless; intros.
  rewrite later_andp, except0_andp.
  apply andp_derives; auto.
Qed.

Lemma own_timeless : forall {P : Ghost} g (a : G), timeless (own g a NoneP).
Proof.
  intros; apply timeless'_timeless.
  intros ?? (v & ? & Hg) ?.
  exists v; simpl in *.
  split.
  + intros; eapply age1_resource_at_identity; eauto.
  + erewrite age1_ghost_of in Hg by eauto.
    rewrite own.ghost_fmap_singleton in *.
    apply own.ghost_fmap_singleton_inv in Hg as ([] & -> & Heq).
    inv Heq.
    destruct p; inv H3.
    simpl; repeat f_equal.
    extensionality l.
    destruct (_f l); auto.
Qed.

Lemma timeless_exp : forall {A} (x : A) P, (forall x, timeless (P x)) -> timeless (EX x : A, P x).
Proof.
  unfold timeless; intros.
  rewrite later_exp' by auto.
  Intro y.
  eapply derives_trans; eauto.
  apply except0_mono.
  Exists y; auto.
Qed.

Lemma timeless_prop : forall P, timeless (!! P).
Proof.
  intro; apply timeless'_timeless.
  intro; auto.
Qed.

Lemma address_mapsto_timeless : forall m v sh p, timeless (res_predicates.address_mapsto m v sh p).
Proof.
  intros; apply timeless'_timeless.
  repeat intro.
  simpl in *.
  destruct H as (b & [? HYES] & ?); exists b; split; [split|]; auto.
  intro b'; specialize (HYES b').
  if_tac.
  - destruct HYES as (rsh & Ha'); exists rsh.
    erewrite age_to_resource_at.age_resource_at in Ha' by eauto.
    destruct (a @ b'); try discriminate; inv Ha'.
    destruct p0; inv H6; simpl.
    f_equal.
    apply proof_irr.
  - rewrite age1_resource_at_identity; eauto.
  - rewrite age1_ghost_of_identity; eauto.
Qed.

Lemma timeless_FF : timeless FF.
Proof.
  unfold timeless, except0.
  apply orp_right2; auto.
Qed.

Lemma timeless_emp : timeless emp.
Proof.
  apply timeless'_timeless; intros ????.
  apply all_resource_at_identity.
  - intro.
    eapply age1_resource_at_identity; eauto.
    eapply resource_at_identity; eauto.
  - eapply age1_ghost_of_identity; eauto.
    eapply ghost_of_identity; eauto.
Qed.

Lemma nonlock_permission_bytes_timeless : forall sh l z,
  timeless (res_predicates.nonlock_permission_bytes sh l z).
Proof.
  intros; apply timeless'_timeless.
  repeat intro.
  simpl in *.
  destruct H; split.
  intro b'; specialize (H b').
  if_tac.
  - erewrite age1_resource_at in H by (rewrite ?resource_at_approx; eauto).
    destruct (a @ b'); auto.
  - rewrite age1_resource_at_identity; eauto.
  - rewrite age1_ghost_of_identity; eauto.
Qed.

Lemma timeless_orp : forall P Q, timeless P -> timeless Q -> timeless (P || Q).
Proof.
  unfold timeless, except0; intros.
  rewrite later_orp.
  apply orp_left; eapply derives_trans; try eassumption; apply orp_left.
  - apply orp_right1, orp_right1; auto.
  - apply orp_right2; auto.
  - apply orp_right1, orp_right2; auto.
  - apply orp_right2; auto.
Qed.

Lemma mapsto_timeless : forall sh t v p, timeless (mapsto sh t p v).
Proof.
  intros; unfold mapsto.
  destruct (access_mode t); try apply timeless_FF.
  destruct (type_is_volatile); try apply timeless_FF.
  destruct p; try apply timeless_FF.
  if_tac.
  - apply timeless_orp.
    + apply timeless_andp; [apply timeless_prop | apply address_mapsto_timeless].
    + apply timeless_andp; [apply timeless_prop|].
      apply (timeless_exp Vundef); intro; apply address_mapsto_timeless.
  - apply timeless_andp; [apply timeless_prop | apply nonlock_permission_bytes_timeless].
Qed.

Lemma memory_block'_timeless : forall sh n b z,
  timeless (mapsto_memory_block.memory_block' sh n b z).
Proof.
  induction n; simpl; intros.
  - apply timeless_emp.
  - apply timeless_sepcon, IHn.
    apply mapsto_timeless.
Qed.

Lemma memory_block_timeless : forall sh n p,
  timeless (memory_block sh n p).
Proof.
  intros.
  destruct p; try apply timeless_FF.
  apply timeless_andp; [apply timeless_prop | apply memory_block'_timeless].
Qed.

Lemma struct_pred_timeless : forall {CS : compspecs} sh m f t off
  (IH : Forall (fun it : ident * type =>
        forall (v : reptype (t it)) (p : val),
        timeless (data_at_rec sh (t it) v p)) m) v p,
  timeless (struct_pred m (fun (it : ident * type) v =>
      withspacer sh (f it + sizeof (t it)) (off it)
        (at_offset (data_at_rec sh (t it) v) (f it))) v p).
Proof.
  induction m; intros.
  - apply timeless_emp.
  - destruct a; inv IH.
    destruct m.
    + unfold withspacer, at_offset; simpl.
      if_tac; auto.
      apply timeless_sepcon; auto.
      unfold spacer.
      if_tac.
      * apply timeless_emp.
      * unfold at_offset; apply memory_block_timeless.
    + rewrite struct_pred_cons2.
      apply timeless_sepcon; auto.
      unfold withspacer, at_offset; simpl.
      if_tac; auto.
      apply timeless_sepcon; auto.
      unfold spacer.
      if_tac.
      * apply timeless_emp.
      * unfold at_offset; apply memory_block_timeless.
Qed.

Lemma union_pred_timeless : forall {CS : compspecs} sh m t off
  (IH : Forall (fun it : ident * type =>
        forall (v : reptype (t it)) (p : val),
        timeless (data_at_rec sh (t it) v p)) m) v p,
  timeless (union_pred m (fun (it : ident * type) v =>
      withspacer sh (sizeof (t it)) (off it)
        (data_at_rec sh (t it) v)) v p).
Proof.
  induction m; intros.
  - apply timeless_emp.
  - destruct a; inv IH.
    destruct m.
    + unfold withspacer, at_offset; simpl.
      if_tac; auto.
      apply timeless_sepcon; auto.
      unfold spacer.
      if_tac.
      * apply timeless_emp.
      * unfold at_offset; apply memory_block_timeless.
    + rewrite union_pred_cons2.
      destruct v; auto.
      unfold withspacer, at_offset; simpl.
      if_tac; auto.
      apply timeless_sepcon; auto.
      unfold spacer.
      if_tac.
      * apply timeless_emp.
      * unfold at_offset; apply memory_block_timeless.
Qed.

Lemma data_at_rec_timeless : forall {CS : compspecs} sh t v p,
  timeless (data_at_rec sh t v p).
Proof.
  intros ???.
  type_induction.type_induction t; intros; rewrite data_at_rec_eq; try apply timeless_FF.
  - simple_if_tac; [apply memory_block_timeless | apply mapsto_timeless].
  - simple_if_tac; [apply memory_block_timeless | apply mapsto_timeless].
  - simple_if_tac; [apply memory_block_timeless | apply mapsto_timeless].
  - simple_if_tac; [apply memory_block_timeless | apply mapsto_timeless].
  - apply timeless_andp; [apply timeless_prop|].
    rewrite Z.sub_0_r.
    forget (Z.to_nat (Z.max 0 z)) as n.
    set (lo := 0) at 1.
    clearbody lo.
    revert lo; induction n; simpl; intros.
    + apply timeless_emp.
    + apply timeless_sepcon, IHn.
      unfold at_offset; apply IH.
  - apply struct_pred_timeless; auto.
  - apply union_pred_timeless; auto.
Qed.

Lemma data_at_timeless : forall {CS : compspecs} sh t v p, timeless (data_at sh t v p).
Proof.
  intros; apply timeless_andp; [apply timeless_prop | apply data_at_rec_timeless].
Qed.

End Timeless.

Section FancyUpdates.

Context {inv_names : invG}.

Definition fupd (E1 E2 : Ensemble iname) P :=
  (wsat * ghost_set g_en E1) -* |==> except0 (wsat * ghost_set g_en E2 * P).

Notation "|={ E1 , E2 }=> P" := (fupd E1 E2 P) (at level 62): logic.
Notation "|={ E }=> P" := (fupd E E P) (at level 62): logic.

Lemma fupd_mono : forall E1 E2 P Q, P |-- Q -> |={E1, E2}=> P |-- |={E1, E2}=> Q.
Proof.
  intros; unfold fupd.
  rewrite <- wand_sepcon_adjoint.
  rewrite sepcon_comm; eapply derives_trans; [apply modus_ponens_wand|].
  apply bupd_mono, except0_mono; cancel.
Qed.

Lemma bupd_fupd : forall E P, |==> P |-- |={E}=> P.
Proof.
  intros; unfold fupd.
  rewrite <- wand_sepcon_adjoint.
  eapply derives_trans; [apply bupd_frame_r|].
  rewrite sepcon_comm; apply bupd_mono, except0_intro.
Qed.

Lemma fupd_frame_r : forall E1 E2 P Q, (|={E1,E2}=> P) * Q |-- |={E1,E2}=> (P * Q).
Proof.
  intros; unfold fupd.
  rewrite <- wand_sepcon_adjoint.
  rewrite sepcon_comm, <- sepcon_assoc.
  eapply derives_trans; [apply sepcon_derives, derives_refl; apply modus_ponens_wand|].
  eapply derives_trans; [apply bupd_frame_r|].
  apply bupd_mono.
  rewrite <- sepcon_assoc.
  apply except0_frame_r.
Qed.

Lemma fupd_intro_mask : forall E1 E2 P (Hdec : forall a, In E2 a \/ ~In E2 a),
  Included E2 E1 -> P |-- |={E1,E2}=> |={E2,E1}=> P.
Proof.
  intros; unfold fupd.
  rewrite <- wand_sepcon_adjoint.
  eapply derives_trans, bupd_intro.
  eapply derives_trans, except0_intro.
  rewrite ghost_set_subset with (s' := E2) by auto.
  cancel.
  rewrite <- wand_sepcon_adjoint.
  eapply derives_trans, bupd_intro.
  eapply derives_trans, except0_intro; cancel.
Qed.

Lemma fupd_trans : forall E1 E2 E3 P, (|={E1,E2}=> |={E2,E3}=> P) |-- |={E1,E3}=> P.
Proof.
  intros; unfold fupd.
  rewrite <- wand_sepcon_adjoint.
  rewrite sepcon_comm.
  eapply derives_trans; [apply modus_ponens_wand|].
  eapply derives_trans; [apply bupd_mono, except0_mono, modus_ponens_wand|].
  eapply derives_trans, bupd_trans; apply bupd_mono.
  apply except0_bupd_elim.
Qed.

Lemma fupd_timeless : forall E P, timeless P -> |> P |-- |={E}=> P.
Proof.
  intros; unfold fupd.
  eapply derives_trans; [apply except0_timeless; auto; apply except0_intro|].
  rewrite <- wand_sepcon_adjoint.
  eapply derives_trans; [apply except0_frame_r|].
  rewrite sepcon_comm.
  apply bupd_intro.
Qed.

Lemma fupd_frame_l : forall E1 E2 P Q, P * (|={E1,E2}=> Q) |-- |={E1,E2}=> (P * Q).
Proof.
  intros; rewrite sepcon_comm, (sepcon_comm P Q); apply fupd_frame_r.
Qed.

(* This is a generally useful pattern. *)
Lemma fupd_mono' : forall E1 E2 P Q (a : rmap) (Himp : (P >=> Q) (level a)),
  app_pred (fupd E1 E2 P) a -> app_pred (fupd E1 E2 Q) a.
Proof.
  intros.
  assert (app_pred ((|={E1,E2}=> P * approx (S (level a)) emp)) a) as HP'.
  { apply (fupd_frame_r _ _ _ _ a).
    do 3 eexists; [apply join_comm, core_unit | split; auto].
    split; [|apply core_identity].
    rewrite level_core; auto. }
  eapply fupd_mono in HP'; eauto.
  change (predicates_hered.derives (P * approx (S (level a)) emp) Q).
  intros a0 (? & ? & J & HP & [? Hemp]).
  destruct (join_level _ _ _ J).
  apply join_comm, Hemp in J; subst.
  eapply Himp in HP; try apply necR_refl; auto; omega.
Qed.

Lemma fupd_bupd : forall E1 E2 P Q, P |-- |==> (|={E1,E2}=> Q) -> P |-- |={E1,E2}=> Q.
Proof.
  intros; eapply derives_trans, fupd_trans; eapply derives_trans, bupd_fupd; auto.
Qed.

Lemma fupd_bupd_elim : forall E1 E2 P Q, P |-- |={E1,E2}=> Q -> |==> P |-- |={E1,E2}=> Q.
Proof.
  intros; apply fupd_bupd, bupd_mono; auto.
Qed.

Lemma fupd_intro : forall E P, P |-- |={E}=> P.
Proof.
  intros; eapply derives_trans, bupd_fupd; apply bupd_intro.
Qed.

Lemma fupd_timeless' : forall E1 E2 P Q, timeless P -> P |-- |={E1,E2}=> Q ->
  |> P |-- |={E1,E2}=> Q.
Proof.
  intros.
  eapply derives_trans; [apply fupd_timeless; auto|].
  eapply derives_trans, fupd_trans.
  apply fupd_mono; eauto.
Qed.

Lemma fupd_except0_elim : forall E1 E2 P Q, P |-- |={E1,E2}=> Q -> except0 P |-- |={E1,E2}=> Q.
Proof.
  intros.
  unfold except0.
  apply orp_left; auto.
  unfold fupd.
  rewrite <- wand_sepcon_adjoint.
  eapply derives_trans, bupd_intro.
  unfold except0.
  apply orp_right2.
  eapply derives_trans; [apply sepcon_derives, now_later; apply derives_refl|].
  rewrite <- later_sepcon; apply later_derives.
  rewrite FF_sepcon; auto.
Qed.

Lemma wsat_fupd_elim : forall P, wsat * (|={Empty_set _,Empty_set _}=> P) |-- |==> except0 (wsat * P).
Proof.
  intros; unfold fupd.
  rewrite <- wsat_empty_eq; apply modus_ponens_wand.
Qed.

Lemma fupd_prop' : forall E1 E2 E2' P Q, Included E1 E2 -> (forall a, In E1 a \/ ~ In E1 a) ->
  Q |-- |={E1,E2'}=> !!P ->
  |={E1, E2}=> Q |-- |={E1}=> !!P && (|={E1, E2}=> Q).
Proof.
  unfold fupd; intros ??????? HQ.
  rewrite <- wand_sepcon_adjoint in *.
  rewrite sepcon_comm; eapply derives_trans; [apply modus_ponens_wand|].
  apply bupd_mono.
  eapply derives_trans, except0_trans; apply except0_mono.
  rewrite ghost_set_subset with (s' := E1) by auto.
  rewrite (add_andp (_ * _ * Q) (except0 (!! P))) at 1.
- eapply derives_trans; [apply andp_derives, derives_refl; apply except0_intro|].
  rewrite <- except0_andp; apply except0_mono.
  Intros.
  apply andp_right; [apply prop_right; auto | cancel].
  rewrite <- wand_sepcon_adjoint.
  eapply derives_trans, bupd_intro; eapply derives_trans, except0_intro; cancel.
- rewrite sepcon_comm, <- !sepcon_assoc.
  eapply derives_trans; [apply sepcon_derives, derives_refl; rewrite sepcon_assoc; apply HQ|].
  setoid_rewrite <- (own.bupd_prop P) at 2.
  rewrite except0_bupd.
  eapply derives_trans; [apply bupd_frame_r | apply bupd_mono].
  eapply derives_trans; [apply except0_frame_r | apply except0_mono].
  rewrite (sepcon_comm _ (!!P)), !sepcon_assoc.
  apply derives_left_sepcon_right_corable, derives_refl.
  change (!!P)%pred with (!!P); apply corable_prop.
Qed.

Lemma fupd_prop : forall E1 E2 P Q, Included E1 E2 -> (forall a, In E1 a \/ ~ In E1 a) ->
  Q |-- !!P ->
  |={E1, E2}=> Q |-- |={E1}=> !!P && (|={E1, E2}=> Q).
Proof.
  intros; eapply fupd_prop'; auto.
  eapply derives_trans; eauto.
  apply fupd_intro.
Qed.

Lemma inv_alloc : forall E P, |> P |-- |={E}=> EX i : _, invariant i P.
Proof.
  intros; unfold fupd.
  rewrite <- wand_sepcon_adjoint.
  rewrite <- sepcon_assoc, (sepcon_comm _ wsat).
  eapply derives_trans; [apply sepcon_derives, derives_refl; apply wsat_alloc|].
  eapply derives_trans; [apply bupd_frame_r|].
  apply bupd_mono.
  rewrite sepcon_assoc, (sepcon_comm _ (ghost_set _ _)), <- sepcon_assoc.
  apply except0_intro.
Qed.

Lemma make_inv : forall E P Q, P |-- Q -> P |-- |={E}=> EX i : _, invariant i Q.
Proof.
  intros.
  eapply derives_trans, inv_alloc; auto.
  eapply derives_trans, now_later; auto.
Qed.

Lemma inv_close_aux : forall E (i : iname) P,
  ghost_list(P := token_PCM) g_dis (list_singleton i (Some tt)) * invariant i P * |> P *
  (wsat * ghost_set g_en (Subtract E i))
  |-- |==> except0 (wsat * (ghost_set g_en (Singleton i) * ghost_set g_en (Subtract E i))).
Proof.
  intros.
  sep_apply (wsat_close i P).
  eapply derives_trans; [apply bupd_frame_r | apply bupd_mono].
  rewrite <- sepcon_assoc; apply except0_intro.
Qed.

Lemma inv_open : forall E i P, In E i ->
  invariant i P |-- |={E, Subtract E i}=> (|> P) * (|>P -* |={Subtract E i, E}=> emp).
Proof.
  intros; unfold fupd.
  rewrite <- wand_sepcon_adjoint.
  erewrite ghost_set_remove; eauto.
  rewrite invariant_dup.
  sep_apply (wsat_open i P).
  eapply derives_trans; [apply bupd_frame_r | apply bupd_mono].
  eapply derives_trans, except0_intro.
  cancel.
  rewrite <- !wand_sepcon_adjoint.
  apply inv_close_aux.
  { intro; omega. }
Qed.

(* these last two are probably redundant *)
Lemma inv_close : forall E i P, In E i ->
  invariant i P * |> P * ghost_list(P := exclusive_PCM _) g_dis (list_singleton i (Some tt)) |--
  |={Subtract E i, E}=> TT.
Proof.
  intros; unfold fupd.
  rewrite <- !wand_sepcon_adjoint.
  rewrite (sepcon_comm _ (ghost_list _ _)), <- 2sepcon_assoc, sepcon_assoc.
  eapply derives_trans; [apply inv_close_aux|].
  erewrite (ghost_set_remove _ _ E); eauto.
  apply bupd_mono, except0_mono; cancel.
  { intro; omega. }
Qed.

Lemma inv_access : forall E i P, In E i ->
  invariant i P |-- |={E, Subtract E i}=> |> P * (|> P -* |={Subtract E i, E}=> TT).
Proof.
  intros.
  eapply derives_trans; [apply inv_open; eauto|].
  apply fupd_mono; cancel.
  apply wand_derives; auto.
  apply fupd_mono; auto.
Qed.

(* Consider putting rules for invariants and fancy updates in msl (a la ghost_seplog), and proofs
   in veric (a la own). *)

End FancyUpdates.

Notation "|={ E1 , E2 }=> P" := (fupd E1 E2 P) (at level 62): logic.
Notation "|={ E }=> P" := (fupd E E P) (at level 62): logic.


(*Require Export CatSem.PCF_order_comp.RPCF_syntax.*)
Require Export CatSem.PCF.PCF_RMonad.
Require Export CatSem.PCF_order_comp.RPCF_rep.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Transparent Obligations.
Unset Automatic Introduction.

Program Instance PCFE_rep_struct :
       PCFPO_rep_struct PCFEM (fun t => t) := {
  app r s := PCFApp r s;
  abs r s := PCFAbs r s;
  rec t := PCFRec t ;
  tttt := PCFconsts ttt ;
  ffff := PCFconsts fff;
  Succ := PCFconsts succ;
  Pred := PCFconsts preds;
  CondN := PCFconsts condN;
  CondB := PCFconsts condB;
  Zero := PCFconsts zero ;
  nats m := PCFconsts (Nats m);
  bottom t := PCFbottom t
}.
Next Obligation.
Proof.
  unfold Rsubst_star_map.
  simpl.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  apply app_abs.
Qed.
Next Obligation.
Proof.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
Qed.
Next Obligation.
Proof.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
Qed.
Next Obligation.
Proof.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
Qed.
Next Obligation.
Proof.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
Qed.
Next Obligation.
Proof.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
Qed.
Next Obligation.
Proof.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
Qed.
Next Obligation.
Proof.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
Qed.
Next Obligation.
Proof.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
Qed.
Next Obligation.
Proof.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
Qed.
Next Obligation.
Proof.
  apply clos_refl_trans_1n_contains.
  apply relorig.
  constructor.
Qed.

Definition PCFE_rep : PCFPO_rep := Build_PCFPO_rep PCFE_rep_struct.


Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.Ensembles_ext.
Require Import CertiGraph.lib.EquivDec_ext.
Require Import CertiGraph.lib.List_ext.
Require Import CertiGraph.lib.relation_list.
Require Import CertiGraph.lib.Morphisms_ext.
Require Import CertiGraph.msl_ext.log_normalize.
Require Import CertiGraph.msl_ext.iter_sepcon.
Require Import CertiGraph.msl_ext.ramification_lemmas.
Require Import CertiGraph.graph.graph_model.
Require Import CertiGraph.graph.path_lemmas.
Require Import CertiGraph.graph.reachable_computable.
Require Import CertiGraph.graph.reachable_ind.
Require Import CertiGraph.graph.graph_gen.
Require Import CertiGraph.graph.graph_relation.
Require Import CertiGraph.graph.subgraph2.
Require Import CertiGraph.graph.dag.
Require Import CertiGraph.graph.weak_mark_lemmas.
Require Import CertiGraph.graph.graph_morphism.
Require Import CertiGraph.graph.local_graph_copy.
Require Import CertiGraph.msl_application.Graph.
Require Import Coq.Logic.Classical.

Local Open Scope logic.

Class CompactCopySetting V E M := {
  default_v: V;
  default_e: E;
  default_g: M
}.

Section PointwiseGraph_Copy.

Context {V E M: Type}.
Context {SGBA: PointwiseGraphBasicAssum V E}.
Context {CCS: CompactCopySetting V E M}.

Instance MGS: WeakMarkGraph.MarkGraphSetting V.
Proof.
  apply (WeakMarkGraph.Build_MarkGraphSetting _ (fun x => default_v <> x)).
  intros; destruct_eq_dec default_v x; [right | left]; simpl; congruence.
Defined.

Global Existing Instance MGS.

Instance GMS: GraphMorphismSetting V E M V E V E M :=
  Build_GraphMorphismSetting _ _ _ _ _ _ _ _ (fun v => v) (fun e => e) default_v default_e default_g.

Global Existing Instance GMS.

Notation Graph := (LabeledGraph V E V E M).
Notation SGraph := (PointwiseGraph V E V E).

Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Definition vcopy1 x (g1 g2 g2': Graph) :=
  g1 ~=~ g2 /\
  WeakMarkGraph.mark1 x g1 g2 /\
  LocalGraphCopy.vcopy1 x g1 g2 g2'.

Definition ecopy1 e (p1 p2: Graph * Graph) :=
  let (g1, g1') := p1 in
  let (g2, g2') := p2 in
  g1 ~=~ g2 /\
  WeakMarkGraph.nothing (src g1 e) g1 g2 /\
  LocalGraphCopy.ecopy1 e (g1, g1') (g2, g2').

Definition copy x (g1 g2: Graph) (g2': Graph) :=
  g1 ~=~ g2 /\
  WeakMarkGraph.mark x g1 g2 /\
  LocalGraphCopy.copy (WeakMarkGraph.marked g1) x g1 g2 g2'.

Definition extended_copy x (p1 p2: Graph * Graph) :=
  let (g1, g1') := p1 in
  let (g2, g2') := p2 in
  g1 ~=~ g2 /\
  WeakMarkGraph.mark x g1 g2 /\
  LocalGraphCopy.extended_copy (WeakMarkGraph.marked g1) x (g1, g1') (g2, g2').

Definition edge_copy g e := relation_list ((extended_copy (dst g e)) :: (ecopy1 e) :: nil).

Definition edge_copy_list g es := relation_list (map (edge_copy g) es).

Lemma copy_invalid_refl: forall (g: Graph) (root: V) (src0 dst0: E -> V) (default_v: V) (default_e: E) (default_g : M),
  ~ vvalid g root ->
  copy root g g (empty_labeledgraph src0 dst0 default_v default_e default_g).
Proof.
  intros.
  split; [| split].
  + reflexivity.
  + apply WeakMarkGraph.mark_invalid_refl; auto.
  + apply LocalGraphCopy.copy_invalid_refl; auto.
Qed.

Lemma marked_root_copy_refl: forall (g: Graph) (root: V) (src0 dst0: E -> V) (default_v: V) (default_e: E) (default_g : M),
  WeakMarkGraph.marked g root ->
  copy root g g (empty_labeledgraph src0 dst0 default_v default_e default_g).
Proof.
  intros.
  split; [| split].
  + reflexivity.
  + apply WeakMarkGraph.mark_marked_root_refl; auto.
  + apply LocalGraphCopy.copy_marked_root_refl; auto.
Qed.

Lemma copy_vvalid_weak_eq: forall (g1 g2 g2'': Graph) x x0,
  ~ vvalid g1 x /\ ~ vvalid g2'' x0 \/ x0 = LocalGraphCopy.vmap g2 x ->
  copy x g1 g2 g2'' ->
  Same_set (vvalid g2'') (reachable g2'' x0).
Proof.
  intros.
  eapply (LocalGraphCopy.copy_vvalid_weak_eq g1 g2 g2'' _ x x0); auto.
  destruct H0 as [_ [_ ?]]; eauto.
Qed.

Lemma vcopy1_copied_root_valid: forall (G G1 G1': Graph) x x0,
  vcopy1 x G G1 G1' ->
  x0 = LocalGraphCopy.vmap G1 x ->
  vvalid G1' x0.
Proof.
  intros.
  apply (LocalGraphCopy.vcopy1_copied_root_valid G G1 G1' x x0); auto.
  destruct H as [_ [_ ?]]; eauto.
Qed.

Lemma extended_copy_vvalid_mono: forall (G1 G2 G1' G2': Graph) x x0,
  extended_copy x (G1, G1') (G2, G2') ->
  vvalid G1' x0 ->
  vvalid G2' x0.
Proof.
  intros.
  eapply (LocalGraphCopy.extended_copy_vvalid_mono G1 G2 G1' G2' _ x x0); auto.
  destruct H as [_ [_ ?]]; eauto.
Qed.

Lemma extended_copy_evalid_mono: forall (G1 G2 G1' G2': Graph) x e,
  extended_copy x (G1, G1') (G2, G2') ->
  evalid G1' e ->
  evalid G2' e.
Proof.
  intros.
  eapply (LocalGraphCopy.extended_copy_evalid_mono G1 G2 G1' G2' _ x e); auto.
  destruct H as [_ [_ ?]]; eauto.
Qed.

Lemma ecopy1_vvalid_mono: forall (G1 G2 G1' G2': Graph) e x0,
  ecopy1 e (G1, G1') (G2, G2') ->
  vvalid G1' x0 ->
  vvalid G2' x0.
Proof.
  intros.
  eapply (LocalGraphCopy.ecopy1_vvalid_mono G1 G2 G1' G2' e x0); auto.
  destruct H as [_ [_ ?]]; eauto.
Qed.

Lemma ecopy1_evalid_mono: forall (G1 G2 G1' G2': Graph) e e0,
  ecopy1 e (G1, G1') (G2, G2') ->
  evalid G1' e0 ->
  evalid G2' e0.
Proof.
  intros.
  eapply (LocalGraphCopy.ecopy1_evalid_mono G1 G2 G1' G2' e e0); auto.
  destruct H as [_ [_ ?]]; eauto.
Qed.

Lemma edge_copy_si: forall (g g1 g2 g1' g2': Graph) (e0: E),
  edge_copy g e0 (g1, g1') (g2, g2') ->
  g1 ~=~ g2.
Proof.
  intros.
  unfold edge_copy in H.
  destruct_relation_list GG in H.
  destruct GG as [G G'].
  destruct H0 as [? _].
  destruct H as [? _].
  transitivity G; auto.
Qed.

Lemma edge_copy_spec: forall (g g1 g2 g1' g2': Graph) (root: V) (es_done: list E) (e0: E),
  edge_copy g e0 (g1, g1') (g2, g2') ->
  evalid g1 e0 ->
  src g1 e0 = root ->
  Same_set
    (WeakMarkGraph.marked g1)
    (let M0 := Union _ (WeakMarkGraph.marked g) (eq root) in
     let PV1 := reachable_by_through_set g (map (dst g) es_done) (Complement _ M0) in
     let M_rec := Union _ M0 PV1 in
     M_rec) ->
  LocalGraphCopy.edge_copy g root (WeakMarkGraph.marked g) (es_done, e0) (g1, g1') (g2, g2') /\
  WeakMarkGraph.componded root (WeakMarkGraph.mark (dst g e0)) g1 g2.
Proof.
  intros.
  unfold edge_copy in H.
  destruct_relation_list gg in H; destruct gg as [g3 g3'].
  destruct H as [? [? ?]], H3 as [? [? ?]].
  split.
  + cbv iota zeta in H2.
    unfold LocalGraphCopy.edge_copy.
    erewrite app_same_relation by (rewrite <- H2; reflexivity).
    split_relation_list ((g3, g3') :: nil); auto.
  + unfold WeakMarkGraph.componded.
    apply compond_intro with g3.
    2: {
      erewrite <- si_src1 in H4; [| exact H3 | exact H0].
      rewrite <- H1; auto.
    }
    apply compond_intro with g1; [apply WeakMarkGraph.eq_do_nothing; auto |].
    auto.
Qed.

Lemma edge_copy_spec': forall root es e0 es_done es_later (g g1 g2 g3 g1' g2' g3': Graph),
  vvalid g root ->
  WeakMarkGraph.unmarked g root ->
  es = es_done ++ e0 :: es_later ->
  (forall e, In e es <-> out_edges g root e) ->
  NoDup es ->
  vcopy1 root g g1 g1' ->
  relation_list
   (map (LocalGraphCopy.edge_copy g root (WeakMarkGraph.marked g))
     (cprefix es_done)) (g1, g1') (g2, g2') ->
  relation_list
   (map (fun v => WeakMarkGraph.componded root (WeakMarkGraph.mark v)) (map (dst g) es_done))
      g1 g2->
  edge_copy g e0 (g2, g2') (g3, g3') ->
  LocalGraphCopy.edge_copy g root (WeakMarkGraph.marked g) (es_done, e0) (g2, g2') (g3, g3') /\
  WeakMarkGraph.componded root (WeakMarkGraph.mark (dst g e0)) g2 g3.
Proof.
  intros.
  destruct H4 as [_ [? ?]].
  pose proof WeakMarkGraph.triple_mark1_componded_mark_list root (map (dst g) es_done) (map (dst g) (e0 :: es_later)) (map (dst g) es) g g2 H H0.
  spec H9; [apply out_edges_step_list; auto |].
  spec H9; [rewrite <- map_app; f_equal; auto |].
  spec H9; [split_relation_list (g :: g1 :: g1 :: nil) |].
    1: apply WeakMarkGraph.eq_do_nothing; auto.
    1: auto.
    1: apply WeakMarkGraph.eq_do_nothing; auto.
    1: auto.
  cbv iota zeta in H9.

  pose proof LocalGraphCopy.triple_vcopy1_edge_copy_list g g1 g2 g1' g2' root es es_done (e0 :: es_later) (WeakMarkGraph.marked g) H H0 H2 H3 H1.
  spec H10; [intro v; destruct (node_pred_dec (WeakMarkGraph.marked g) v); auto |].
  specialize (H10 H8 H5).
  cbv iota zeta in H10.

  assert (evalid g2 e0 /\ src g e0 = root).
  1: {
    destruct H10 as [_ [? _]].
    rewrite <- (proj1 (proj2 H10)); auto.
    assert (In e0 es) by (rewrite H1, in_app_iff; simpl; auto).
    rewrite H2 in H11. auto.
  }

  apply edge_copy_spec; auto.
  + tauto.
  + destruct H10 as [_ [? _]], H11 as [? ?].
    erewrite <- si_src2 by eauto.
    auto.
  + destruct H9 as [_ ?]; auto.
Qed.

Lemma vcopy1_edge_copy_list_spec: forall root es es_done es_later (g g1 g2 g1' g2': Graph),
  vvalid g root ->
  WeakMarkGraph.unmarked g root ->
  es = es_done ++ es_later ->
  (forall e, In e es <-> out_edges g root e) ->
  NoDup es ->
  vcopy1 root g g1 g1' ->
  edge_copy_list g es_done (g1, g1') (g2, g2') ->
  LocalGraphCopy.edge_copy_list g root es_done (WeakMarkGraph.marked g) (g1, g1') (g2, g2') /\
  WeakMarkGraph.componded_mark_list root (map (dst g) es_done) g1 g2.
Proof.
  intros.
  unfold edge_copy_list in H5.
  rewrite map_snd_cprefix' in H5.
  eapply relation_list_weaken_ind' with
    (R' := fun (p: list E * E) =>
           relation_conjunction
            (LocalGraphCopy.edge_copy g root (WeakMarkGraph.marked g) p)
            (fst_relation (WeakMarkGraph.componded root (WeakMarkGraph.mark (dst g (snd p))))))
     in H5.
  + apply relation_list_conjunction in H5.
    destruct H5.
    split; auto.
    rewrite <- map_map in H6.
    unfold fst_relation in H6.
    apply respectful_relation_list in H6.
    unfold respectful_relation in H6; simpl in H6.
    unfold WeakMarkGraph.componded_mark_list.
    rewrite map_map.
    rewrite map_snd_cprefix'.
    auto.
  + clear g2 g2' H5.
    intros.
    clear H6.
    unfold relation_conjunction, predicate_intersection; simpl.
    destruct a2 as [g2 g2'], a3 as [g3 g3'].
    unfold fst_relation, respectful_relation; simpl.
    pose proof in_cprefix _ _ _ H5.
    apply in_cprefix_cprefix in H5.
    subst bs_done.
    destruct b0 as [es_done0 e0]; simpl in H7 |- *.
    pose proof in_cprefix' _ _ _ H6.
    destruct H5 as [es_later0 ?].
    apply relation_list_conjunction in H7.
    destruct H7.
    rewrite <- (map_map (snd) (fun e => fst_relation
               (WeakMarkGraph.componded root
                  (WeakMarkGraph.mark (dst g e))))) in H9.
    rewrite map_snd_cprefix in H9.
    rewrite <- map_map in H9.
    unfold fst_relation in H9.
    apply respectful_relation_list in H9.
    unfold respectful_relation in H9; simpl in H9.
    subst es_done.
    rewrite <- app_assoc in H1.
    eapply edge_copy_spec'; try eassumption.
    rewrite map_map; auto.
Qed.

Lemma vcopy1_edge_copy_list_copy: forall root es (g1 g2 g3 g2' g3': Graph),
  vvalid g1 root ->
  WeakMarkGraph.unmarked g1 root ->
  (forall e, In e es <-> out_edges g1 root e) ->
  NoDup es ->
  vcopy1 root g1 g2 g2' ->
  edge_copy_list g1 es (g2, g2') (g3, g3') ->
  copy root g1 g3 g3'.
Proof.
  intros.
  pose proof vcopy1_edge_copy_list_spec root es es nil g1 g2 g3 g2' g3' H H0 (eq_sym (app_nil_r _)) H1 H2 H3 H4.
  destruct H5.
  split; [| split].
  + pose proof LocalGraphCopy.triple_vcopy1_edge_copy_list g1 g2 g3 g2' g3' root es es nil (WeakMarkGraph.marked g1) H H0 H1 H2 (eq_sym (app_nil_r _)).
    spec H7; [intro v; destruct (node_pred_dec (WeakMarkGraph.marked g1) v); auto |].
    destruct H3 as [_ [_ ?]].
    specialize (H7 H3 H5).
    destruct H7 as [_ [? _]]; auto.
  + pose proof WeakMarkGraph.mark1_componded_mark_list_mark root (map (dst g1) es) g1 g3 H H0.
    apply H7.
    - apply out_edges_step_list; auto.
    - destruct H3 as [_ [? _]].
      split_relation_list (g1 :: g2 :: g2 :: g3 :: nil); auto; apply WeakMarkGraph.eq_do_nothing; auto.
  + destruct H3 as [_ [_ ?]].
    apply (LocalGraphCopy.vcopy1_edge_copy_list_copy g1 g2 g3 g2' g3' root es (WeakMarkGraph.marked g1)); auto.
    intro v; destruct (node_pred_dec (WeakMarkGraph.marked g1) v); auto.
Qed.

Lemma extend_copy_emap_root: forall (g g1 g2 g3 g1' g2' g3' : Graph) root es es_done e0 es_later,
  vvalid g root ->
  WeakMarkGraph.unmarked g root ->
  es = es_done ++ e0 :: es_later ->
  (forall e : E, In e es <-> out_edges g root e) ->
  NoDup es ->
  vcopy1 root g g1 g1' ->
  edge_copy_list g es_done (g1, g1') (g2, g2') ->
  extended_copy (dst g e0) (g2, g2') (g3, g3') ->
  map (LocalGraphCopy.emap g2) es_done = map (LocalGraphCopy.emap g3) es_done.
Proof.
  intros.
  destruct (vcopy1_edge_copy_list_spec root es es_done _ g g1 g2 g1' g2' H H0 H1 H2 H3 H4 H5).
  pose proof WeakMarkGraph.triple_mark1_componded_mark_list root (map (dst g) es_done) (map (dst g) (e0 :: es_later)) (map (dst g) es) g g2 H H0.
  spec H9; [apply out_edges_step_list; auto |].
  spec H9; [rewrite <- map_app; f_equal; auto |].
  spec H9; [split_relation_list (g :: g1 :: g1 :: nil) |].
    1: apply WeakMarkGraph.eq_do_nothing; auto.
    1: destruct H4 as [? [? ?]]; auto.
    1: apply WeakMarkGraph.eq_do_nothing; auto.
    1: auto.
  cbv iota zeta in H9.
  destruct H9 as [_ ?].

  eapply LocalGraphCopy.extend_copy_emap_root; eauto.
  + intros; destruct (node_pred_dec (WeakMarkGraph.marked g) v); auto.
  + destruct H4 as [_ [_ ?]]; auto.
  + intros; rewrite <- (app_same_set H9).
    destruct (node_pred_dec (WeakMarkGraph.marked g2) v); auto.
  + rewrite <- H9.
    destruct H6 as [_ [_ ?]]. exact e.
Qed.

Lemma extended_copy_vmap_root: forall (g1 g2 g1' g2': Graph) x x0,
  WeakMarkGraph.marked g1 x0 ->
  extended_copy x (g1, g1') (g2, g2') ->
  LocalGraphCopy.vmap g1 x0 = LocalGraphCopy.vmap g2 x0.
Proof.
  intros.
  destruct H0 as [_ [_ ?]]; eapply (LocalGraphCopy.extended_copy_vmap_root g1 g2 g1' g2' x x0); eauto.
Qed.

Lemma ecopy1_vmap_root: forall (g1 g2 g1' g2': Graph) e x0,
  ecopy1 e (g1, g1') (g2, g2') ->
  LocalGraphCopy.vmap g1 x0 = LocalGraphCopy.vmap g2 x0.
Proof.
  intros.
  destruct H as [_ [_ ?]].
  apply (LocalGraphCopy.ecopy1_vmap_root g1 g2 g1' g2' e x0); auto.
Qed.

(*
(* might be useful for non-bigraph cases *)
Lemma vcopy1_edge_copy_list_vmap_root: forall root es es_done es_later (g g1 g2 g1' g2': Graph),
  vvalid g root ->
  WeakMarkGraph.unmarked g root ->
  es = es_done ++ es_later ->
  (forall e, In e es <-> out_edges g root e) ->
  NoDup es ->
  vcopy1 root g g1 g1' ->
  edge_copy_list g es_done (g1, g1') (g2, g2') ->
  LocalGraphCopy.vmap g1 root = LocalGraphCopy.vmap g2 root.
Proof.
  intros.
  destruct (vcopy1_edge_copy_list_spec root es es_done _ g g1 g2 g1' g2' H H0 H1 H2 H3 H4 H5).
  pose proof WeakMarkGraph.triple_mark1_componded_mark_list root (map (dst g) es_done) (map (dst g) es_later) (map (dst g) es) g g2 H H0.
  spec H8; [apply out_edges_step_list; auto |].
  spec H8; [rewrite <- map_app; f_equal; auto |].
  spec H8; [split_relation_list (g :: g1 :: g1 :: nil) |].
    1: apply WeakMarkGraph.eq_do_nothing; auto.
    1: destruct H4 as [? [? ?]]; auto.
    1: apply WeakMarkGraph.eq_do_nothing; auto.
    1: auto.
  cbv iota zeta in H8.
  destruct H8 as [_ ?].

  pose proof LocalGraphCopy.triple_vcopy1_edge_copy_list g g1 g2 g1' g2' root es es_done es_later (WeakMarkGraph.marked g) H H0 H2 H3 H1.
  spec H9; [intro v; destruct (node_pred_dec (WeakMarkGraph.marked g) v); auto |].
  specialize (H9 (proj2 (proj2 H4)) H6).

  destruct H9 as [_ [_ [_ [? _]]]].

Lemma vcopy1_edge_copy_list_extended_copy_vmap_root: forall root es es_done e0 es_later (g1 g2 g3 g2' g3' g4 g4'': Graph),
  vvalid g1 root ->
  WeakMarkGraph.unmarked g1 root ->
  es = es_done ++ e0 :: es_later ->
  (forall e, In e es <-> out_edges g1 root e) ->
  NoDup es ->
  vcopy1 root g1 g2 g2' ->
  edge_copy_list g1 es_done (g2, g2') (g3, g3') ->
  copy (dst g1 e0) g3 g4 g4'' ->
  disjointed_guard (vvalid g4'') (vvalid g3') (evalid g4'') (evalid g3') ->
  exists g4': Graph,
  extended_copy (dst g1 e0) (g3, g3') (g4, g4') /\
*)
Lemma vcopy1_edge_copy_list_copy_extended_copy: forall root es es_done e0 es_later (g1 g2 g3 g2' g3' g4 g4'': Graph),
  vvalid g1 root ->
  WeakMarkGraph.unmarked g1 root ->
  es = es_done ++ e0 :: es_later ->
  (forall e, In e es <-> out_edges g1 root e) ->
  NoDup es ->
  vcopy1 root g1 g2 g2' ->
  edge_copy_list g1 es_done (g2, g2') (g3, g3') ->
  copy (dst g1 e0) g3 g4 g4'' ->
  disjointed_guard (vvalid g4'') (vvalid g3') (evalid g4'') (evalid g3') ->
  exists g4': Graph,
  extended_copy (dst g1 e0) (g3, g3') (g4, g4') /\
  guarded_labeled_graph_equiv (vvalid g4'') (evalid g4'') g4'' g4' /\
  guarded_labeled_graph_equiv (vvalid g3') (evalid g3') g3' g4'.
Proof.
  intros.
  unfold reachable_vertices_at.
  pose proof vcopy1_edge_copy_list_spec root es es_done _ g1 g2 g3 g2' g3' H H0 H1 H2 H3 H4 H5.
  destruct H8.
  pose proof LocalGraphCopy.copy_extend_copy g1 g3 g4 g3' g4'' root es es_done e0 es_later (WeakMarkGraph.marked g1) H H0 H2 H3 H1.
  spec H10; [intro v; destruct (node_pred_dec (WeakMarkGraph.marked g1) v); auto |].
  cbv zeta in H10.
  pose proof WeakMarkGraph.triple_mark1_componded_mark_list root (map (dst g1) es_done) (map (dst g1) (e0 :: es_later)) (map (dst g1) es) g1 g3 H H0.
  spec H11; [apply out_edges_step_list; auto |].
  spec H11; [rewrite <- map_app; f_equal; auto |].
  spec H11; [split_relation_list (g1 :: g2 :: g2 :: nil) |].
    1: apply WeakMarkGraph.eq_do_nothing; auto.
    1: destruct H4 as [? [? ?]]; auto.
    1: apply WeakMarkGraph.eq_do_nothing; auto.
    1: auto.
  cbv iota zeta in H11.
  destruct H11 as [_ ?].

  rewrite <- H11 in H10.
  spec H10; [destruct H6 as [? [? ?]]; auto |].
  spec H10; [auto |].
  spec H10; [intros v; rewrite <- (app_same_set H11); destruct (node_pred_dec (WeakMarkGraph.marked g3) v); auto |].
  destruct H10 as [g4' [? [? ?]]].
  rewrite <- H11 in H10.
  exists g4'.
  split; [| split]; auto.
  destruct H6 as [? [? ?]]; split; [| split]; auto.
Qed.

Lemma copy_and_extended_copy: forall g1 g1' g2 g2' g2'' x0,
  copy x0 g1 g2 g2'' ->
  extended_copy x0 (g1, g1') (g2, g2') ->
  Prop_join (vvalid g1') (vvalid g2'') (vvalid g2').
Proof.
  intros.
  destruct H as [_ [_ ?]].
  destruct H0 as [_ [_ ?]].
  destruct H as [_ [_ [_ [? [? _]]]]].
  destruct H0 as [_ [_ [_ [? _]]]].
  destruct H0 as [? [? _]].
  rewrite <- H in H0.
  rewrite <- H1 in H2.
  auto.
Qed.
(*
Lemma vcopy1_edge_copy_list_copy_extended_copy': forall root es es_done e0 es_later (g1 g2 g3 g2' g3' g4 g4'': Graph),
  vvalid g1 root ->
  WeakMarkGraph.unmarked g1 root ->
  es = es_done ++ e0 :: es_later ->
  (forall e, In e es <-> out_edges g1 root e) ->
  NoDup es ->
  vcopy1 root g1 g2 g2' ->
  edge_copy_list g1 es_done (g2, g2') (g3, g3') ->
  copy (dst g1 e0) g3 g4 g4'' ->
  disjointed_guard (vvalid g4'') (vvalid g3') (evalid g4'') (evalid g3') ->
  exists g4': Graph,
  extended_copy (dst g1 e0) (g3, g3') (g4, g4') /\
  (Included (vvalid g4'') (vguard g4'') -> Included (vvalid g4'') (vguard g4') -> vertices_identical (vvalid g4'') (Graph_PointwiseGraph g4'') (Graph_PointwiseGraph g4')) /\
  (Included
     (Intersection _ (vvalid g3') (fun x1 => LocalGraphCopy.vmap g2 root <> x1))
     (vguard g3') -> Included
     (Intersection _ (vvalid g3') (fun x1 => LocalGraphCopy.vmap g2 root <> x1))
     (vguard g4') -> vertices_identical
     (Intersection _ (vvalid g3') (fun x1 => LocalGraphCopy.vmap g2 root <> x1)) (Graph_PointwiseGraph g3') (Graph_PointwiseGraph g4')).
Proof.
  intros.
  unfold reachable_vertices_at.
  pose proof vcopy1_edge_copy_list_spec root es es_done _ g1 g2 g3 g2' g3' H H0 H1 H2 H3 H4 H5.
  destruct H8.
  pose proof LocalGraphCopy.copy_extend_copy' g1 g3 g4 g3' g4'' root es es_done e0 es_later (WeakMarkGraph.marked g1) H H0 H2 H3 H1.
  spec H10; [intro v; destruct (node_pred_dec (WeakMarkGraph.marked g1) v); auto |].
  cbv zeta in H10.
  pose proof WeakMarkGraph.triple_mark1_componded_mark_list root (map (dst g1) es_done) (map (dst g1) (e0 :: es_later)) (map (dst g1) es) g1 g3 H H0.
  spec H11; [apply out_edges_step_list; auto |].
  spec H11; [rewrite <- map_app; f_equal; auto |].
  spec H11; [split_relation_list (g1 :: g2 :: g2 :: nil) |].
    1: apply WeakMarkGraph.eq_do_nothing; auto.
    1: destruct H4 as [? [? ?]]; auto.
    1: apply WeakMarkGraph.eq_do_nothing; auto.
    1: auto.
  cbv iota zeta in H11.
  destruct H11 as [_ ?].

  rewrite <- H11 in H10.
  spec H10; [destruct H6 as [? [? ?]]; auto |].
  spec H10; [auto |].
  spec H10; [intros v; rewrite <- (app_same_set H11); destruct (node_pred_dec (WeakMarkGraph.marked g3) v); auto |].
  destruct H10 as [g4' [? [? ?]]].
  rewrite <- H11 in H10.
  exists g4'.
  assert (extended_copy (dst g1 e0) (g3, g3') (g4, g4')) by (destruct H6 as [? [? ?]]; split; [| split]; auto).
  split; [| split]; auto.
  + intros; apply GSG_PartialGraphPreserve; auto.
    - apply Included_refl.
    - pose proof copy_and_extended_copy _ _ _ _ _ _ H6 H14.
      unfold Included, Ensembles.In; intros.
      rewrite (proj1 H17); auto.
  + intros; apply GSG_PartialGraphPreserve; auto.
    - apply Intersection1_Included, Included_refl.
    - apply Intersection1_Included.
      pose proof copy_and_extended_copy _ _ _ _ _ _ H6 H14.
      unfold Included, Ensembles.In; intros.
      rewrite (proj1 H17); auto.
    - eapply si_stronger_partial_labeledgraph_simple; [| exact H13].
      apply Intersection1_Included, Included_refl.
Qed.
*)
Lemma vcopy1_edge_copy_list_weak_copy_extended_copy: forall {P: Graph -> Type} {NP: NormalGeneralGraph P},
  forall root es es_done e0 es_later (g1 g2 g3 g2' g3' g4 g4'': Graph) (root0: V),
  vvalid g1 root ->
  WeakMarkGraph.unmarked g1 root ->
  es = es_done ++ e0 :: es_later ->
  (forall e, In e es <-> out_edges g1 root e) ->
  NoDup es ->
  vcopy1 root g1 g2 g2' ->
  edge_copy_list g1 es_done (g2, g2') (g3, g3') ->
  root0 = LocalGraphCopy.vmap g2 root ->
  copy (dst g1 e0) g3 g4 g4'' ->
  disjointed_guard (vvalid g4'') (vvalid g3') (evalid g4'') (evalid g3') ->
  (exists Pg3': P (gpredicate_sub_labeledgraph
                    (fun v' => root0 <> v')
                    (fun e' => ~ In e' (map (LocalGraphCopy.emap g3) es_done)) g3'), True) ->
  (exists Pg4'': P g4'', True) ->
  exists g4': Graph,
  extended_copy (dst g1 e0) (g3, g3') (g4, g4') /\
  (exists Pg4': P (gpredicate_sub_labeledgraph
                    (fun v' => root0 <> v')
                    (fun e' => ~ In e' (map (LocalGraphCopy.emap g4) es_done)) g4'), True) /\
  guarded_labeled_graph_equiv (vvalid g4'') (evalid g4'') g4'' g4' /\
  guarded_labeled_graph_equiv (vvalid g3') (evalid g3') g3' g4'.
Proof.
  intros.
  pose proof vcopy1_edge_copy_list_copy_extended_copy root es es_done e0 es_later g1 g2 g3 g2' g3' g4 g4''.
  repeat (spec H11; [auto |]).
  destruct H11 as [g4' [? [? ?]]].
  exists g4'; split; [| split; [| split]]; auto.
  destruct H9 as [? _], H10 as [? _].
  apply (lge_preserved _
          (gpredicate_sub_labeledgraph
            (Intersection _ (vvalid g3') (fun v' : V => root0 <> v'))
            (Intersection _ (evalid g3') (fun e' : E => ~ In e' (map (LocalGraphCopy.emap g3) es_done))) g4')) in x.
  2: {
    etransitivity.
    + apply gpredicate_sub_labeledgraph_equiv.
      - symmetry; apply Intersection_absort_left.
        apply Intersection1_Included, Included_refl.
      - symmetry; apply Intersection_absort_left.
        apply Intersection1_Included, Included_refl.
    + eapply stronger_gpredicate_sub_labeledgraph_simple; [| | eauto].
      - apply Intersection1_Included, Included_refl.
      - apply Intersection1_Included, Included_refl.
  }
  apply (lge_preserved _ (gpredicate_sub_labeledgraph (vvalid g4'') (evalid g4'') g4')) in x0.
  2: {
    etransitivity.
    + symmetry; apply gpredicate_sub_labeledgraph_self.
    + eapply stronger_gpredicate_sub_labeledgraph_simple; [| | eauto].
      - apply Included_refl.
      - apply Included_refl.
  }
  eexists; auto.
  apply (lge_preserved
          (gpredicate_sub_labeledgraph
            (Intersection _ (vvalid g4') (fun v' : V => root0 <> v'))
            (Intersection _ (evalid g4') (fun e' : E => ~ In e' (map (LocalGraphCopy.emap g4) es_done))) g4')).
  1: {
    apply gpredicate_sub_labeledgraph_equiv.
    + apply Intersection_absort_left.
      apply Intersection1_Included, Included_refl.
    + apply Intersection_absort_left.
      apply Intersection1_Included, Included_refl.
  }
  eapply join_preserved; [| | exact x | exact x0].
  + destruct H11 as [_ [_ HH]].
    destruct HH as [_ [_ [_ [HH _]]]].
    destruct H7 as [_ [_ ?]].
    destruct HH as [? _].
    destruct H7 as [_ [_ [_ [? _]]]].
    rewrite <- H7 in H9.
    apply Prop_join_shrink1; auto.
    destruct (vcopy1_edge_copy_list_spec root _ _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5).
    eapply LocalGraphCopy.edge_copy_list_vvalid_mono in H10; [exact H10 |].
    destruct H4 as [_ [_ ?]].
    eapply LocalGraphCopy.vcopy1_copied_root_valid in H4; eauto.
  + replace (map (@LocalGraphCopy.emap V E V E (@SGBA_VE V E SGBA)
                    (@SGBA_EE V E SGBA) V E M V E M GMS g4) es_done) with (map (LocalGraphCopy.emap g3) es_done)
      by (apply (extend_copy_emap_root g1 g2 g3 g4 g2' g3' g4' root es es_done e0 es_later); auto).
    destruct H11 as [_ [_ HH]].
    destruct HH as [_ [_ [_ [HH _]]]].
    destruct H7 as [_ [_ ?]].
    destruct HH as [_ [? _]].
    destruct H7 as [_ [_ [_ [_ [? _]]]]].
    rewrite <- H7 in H9.
    apply Prop_join_shrink; auto.
    unfold Included, Ensembles.In.
    intros e ? ?.
    destruct H9 as [_ ?].
    apply (H9 e); auto.
    destruct (vcopy1_edge_copy_list_spec root _ _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5).
    eapply (LocalGraphCopy.vcopy1_edge_copy_list_mapped_root_edge_evalid g1 g2 g3 g2' g3'); eauto.
      1: intros; destruct (node_pred_dec (WeakMarkGraph.marked g1) v); auto.
      1: destruct H4 as [? [? ?]]; auto.
Qed.

Context {GV GE: Type}.
Context {SGC: PointwiseGraphConstructor V E V E M GV GE}.
Context {L_SGC: Local_PointwiseGraphConstructor V E V E M GV GE}.

Lemma vcopy1_edge_copy_list_weak_copy_extended_copy': forall {P: Graph -> Type} {NP: NormalGeneralGraph P},
  forall root es es_done e0 es_later (g1 g2 g3 g2' g3' g4 g4'': Graph) (root0: V),
  vvalid g1 root ->
  WeakMarkGraph.unmarked g1 root ->
  es = es_done ++ e0 :: es_later ->
  (forall e, In e es <-> out_edges g1 root e) ->
  NoDup es ->
  vcopy1 root g1 g2 g2' ->
  edge_copy_list g1 es_done (g2, g2') (g3, g3') ->
  root0 = LocalGraphCopy.vmap g2 root ->
  copy (dst g1 e0) g3 g4 g4'' ->
  disjointed_guard (vvalid g4'') (vvalid g3') (evalid g4'') (evalid g3') ->
  (exists Pg3': P (gpredicate_sub_labeledgraph
                    (fun v' => root0 <> v')
                    (fun e' => ~ In e' (map (LocalGraphCopy.emap g3) es_done)) g3'), True) ->
  (exists Pg4'': P g4'', True) ->
  exists g4': Graph,
  extended_copy (dst g1 e0) (g3, g3') (g4, g4') /\
  (exists Pg4': P (gpredicate_sub_labeledgraph
                    (fun v' => root0 <> v')
                    (fun e' => ~ In e' (map (LocalGraphCopy.emap g4) es_done)) g4'), True) /\
  (Included (vvalid g4'') (vguard g4'') -> Included (vvalid g4'') (vguard g4') -> vertices_identical (vvalid g4'') (Graph_PointwiseGraph g4'') (Graph_PointwiseGraph g4')) /\
  (Included
     (Intersection _ (vvalid g3') (fun x1 => LocalGraphCopy.vmap g2 root <> x1))
     (vguard g3') -> Included
     (Intersection _ (vvalid g3') (fun x1 => LocalGraphCopy.vmap g2 root <> x1))
     (vguard g4') -> vertices_identical
     (Intersection _ (vvalid g3') (fun x1 => LocalGraphCopy.vmap g2 root <> x1)) (Graph_PointwiseGraph g3') (Graph_PointwiseGraph g4')).
Proof.
  intros.
  pose proof vcopy1_edge_copy_list_copy_extended_copy root es es_done e0 es_later g1 g2 g3 g2' g3' g4 g4''.
  repeat (spec H11; [auto |]).
  destruct H11 as [g4' [? [? ?]]].
  exists g4'; split; [| split]; auto.
  1: {
    destruct H9 as [? _], H10 as [? _].
    apply (lge_preserved _
            (gpredicate_sub_labeledgraph
              (Intersection _ (vvalid g3') (fun v' : V => root0 <> v'))
              (Intersection _ (evalid g3') (fun e' : E => ~ In e' (map (LocalGraphCopy.emap g3) es_done))) g4')) in x.
    2: {
      etransitivity.
      + apply gpredicate_sub_labeledgraph_equiv.
        - symmetry; apply Intersection_absort_left.
          apply Intersection1_Included, Included_refl.
        - symmetry; apply Intersection_absort_left.
          apply Intersection1_Included, Included_refl.
      + eapply stronger_gpredicate_sub_labeledgraph_simple; [| | eauto].
        - apply Intersection1_Included, Included_refl.
        - apply Intersection1_Included, Included_refl.
    }
    apply (lge_preserved _ (gpredicate_sub_labeledgraph (vvalid g4'') (evalid g4'') g4')) in x0.
    2: {
      etransitivity.
      + symmetry; apply gpredicate_sub_labeledgraph_self.
      + eapply stronger_gpredicate_sub_labeledgraph_simple; [| | eauto].
        - apply Included_refl.
        - apply Included_refl.
    }
    eexists; auto.
    apply (lge_preserved
            (gpredicate_sub_labeledgraph
              (Intersection _ (vvalid g4') (fun v' : V => root0 <> v'))
              (Intersection _ (evalid g4') (fun e' : E => ~ In e' (map (LocalGraphCopy.emap g4) es_done))) g4')).
    1: {
      apply gpredicate_sub_labeledgraph_equiv.
      + apply Intersection_absort_left.
        apply Intersection1_Included, Included_refl.
      + apply Intersection_absort_left.
        apply Intersection1_Included, Included_refl.
    }
    eapply join_preserved; [| | exact x | exact x0].
    + destruct H11 as [_ [_ HH]].
      destruct HH as [_ [_ [_ [HH _]]]].
      destruct H7 as [_ [_ ?]].
      destruct HH as [? _].
      destruct H7 as [_ [_ [_ [? _]]]].
      rewrite <- H7 in H9.
      apply Prop_join_shrink1; auto.
      destruct (vcopy1_edge_copy_list_spec root _ _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5).
      eapply LocalGraphCopy.edge_copy_list_vvalid_mono in H10; [exact H10 |].
      destruct H4 as [_ [_ ?]].
      eapply LocalGraphCopy.vcopy1_copied_root_valid in H4; eauto.
    + replace (map (@LocalGraphCopy.emap V E V E (@SGBA_VE V E SGBA)
                      (@SGBA_EE V E SGBA) V E M V E M GMS g4) es_done) with (map (LocalGraphCopy.emap g3) es_done)
        by (apply (extend_copy_emap_root g1 g2 g3 g4 g2' g3' g4' root es es_done e0 es_later); auto).
      destruct H11 as [_ [_ HH]].
      destruct HH as [_ [_ [_ [HH _]]]].
      destruct H7 as [_ [_ ?]].
      destruct HH as [_ [? _]].
      destruct H7 as [_ [_ [_ [_ [? _]]]]].
      rewrite <- H7 in H9.
      apply Prop_join_shrink; auto.
      unfold Included, Ensembles.In.
      intros e ? ?.
      destruct H9 as [_ ?].
      apply (H9 e); auto.
      destruct (vcopy1_edge_copy_list_spec root _ _ _ _ _ _ _ _ H H0 H1 H2 H3 H4 H5).
      eapply (LocalGraphCopy.vcopy1_edge_copy_list_mapped_root_edge_evalid g1 g2 g3 g2' g3'); eauto.
        1: intros; destruct (node_pred_dec (WeakMarkGraph.marked g1) v); auto.
        1: destruct H4 as [? [? ?]]; auto.
  }
  1: {
    intros.
    pose proof vcopy1_edge_copy_list_spec root es es_done (e0 :: es_later) g1 g2 g3 g2' g3' H H0 H1 H2 H3 H4 H5.
    destruct H14.
    pose proof WeakMarkGraph.triple_mark1_componded_mark_list root (map (dst g1) es_done) (map (dst g1) (e0 :: es_later)) (map (dst g1) es) g1 g3 H H0.
    spec H16; [apply out_edges_step_list; auto |].
    spec H16; [rewrite <- map_app; f_equal; auto |].
    spec H16; [split_relation_list (g1 :: g2 :: g2 :: nil) |].
      1: apply WeakMarkGraph.eq_do_nothing; auto.
      1: destruct H4 as [? [? ?]]; auto.
      1: apply WeakMarkGraph.eq_do_nothing; auto.
      1: auto.
    cbv iota zeta in H16.
    destruct H16 as [_ ?].

    pose proof LocalGraphCopy.vcopy1_edge_copy_list_copy_and_copy_extend g1 g2 g3 g4 g2' g3' g4'' g4' root es es_done e0 es_later (WeakMarkGraph.marked g1) H H0 H2 H3 H1.
    spec H17; [intros; apply decidable_prop_decidable; apply node_pred_dec |].
    spec H17; [destruct H4 as [? [? ?]]; auto |].
    spec H17; [auto |].
    cbv zeta in H17.
    rewrite <- H16 in H17.
    spec H17; [destruct H7 as [? [? ?]]; auto |].
    spec H17; [auto |].
    spec H17; [intros; rewrite <- (app_same_set H16); apply decidable_prop_decidable; apply node_pred_dec |].
    spec H17; [destruct H11 as [? [? ?]]; auto |].
    spec H17; [auto |].
    spec H17; [auto |].
    destruct H17 as [? [? [? ?]]].
    split; intros; apply GSG_PartialGraphPreserve; auto.
    + apply Included_refl.
    + destruct H17.
      intros ? ?; unfold Ensembles.In; rewrite H17; tauto.
    + apply Intersection1_Included, Included_refl.
    + apply Intersection1_Included.
      destruct H17.
      intros ? ?; unfold Ensembles.In; rewrite H17; tauto.
    + eapply si_stronger_partial_labeledgraph_simple; [| eassumption].
      apply Intersection1_Included, Included_refl.
  }
Qed.

End PointwiseGraph_Copy.