Require Import CertiGraph.lib.Ensembles_ext.
Require Import Coq.Lists.List.
Require Import VST.msl.seplog.
Require Import VST.msl.log_normalize.
Require Import VST.msl.ramification_lemmas.
Require Import VST.msl.Coqlib2.
Require Import CertiGraph.lib.Coqlib.
Require Import CertiGraph.lib.EquivDec_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.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 CertiGraph.msl_application.GraphBi.
Require Import CertiGraph.msl_application.Graph_Copy.
Require Import Coq.Logic.Classical.

Open Scope logic.

Section PointwiseGraph_Copy_Bi.

Context {pSGG_Bi: pPointwiseGraph_Graph_Bi}.
Context {sSGG_Bi: sPointwiseGraph_Graph_Bi addr (addr * LR)}.

Existing Instances pSGG_Bi sSGG_Bi SGAvn.

Local Coercion Graph'_LGraph: Graph' >-> LGraph.
Local Coercion Graph_LGraph: Graph >-> LGraph.
Local Coercion LGraph_SGraph: LGraph >-> SGraph.
Local Identity Coercion Graph_GeneralGraph: Graph >-> GeneralGraph.
Local Identity Coercion Graph'_GeneralGraph: Graph' >-> GeneralGraph.
Local Identity Coercion LGraph_LabeledGraph: LGraph >-> LabeledGraph.
Local Identity Coercion SGraph_PointwiseGraph: SGraph >-> PointwiseGraph.
Local Coercion pg_lg: LabeledGraph >-> PreGraph.

Notation Graph := (@Graph pSGG_Bi addr (addr * LR) unit).
Notation Graph' := (@Graph' pSGG_Bi addr (addr * LR) unit).

Instance CCS: CompactCopySetting addr (addr * LR) unit.
  apply (Build_CompactCopySetting _ _ _ null (null, L) tt).
Defined.

Global Existing Instance CCS.

Definition empty_Graph': Graph' := empty_Graph' null (null, L) tt.

Definition initial_copied_Graph (x x0: addr) (g: Graph): LGraph
  := single_vertex_labeledgraph (LocalGraphCopy.vmap (Graph_vgen g x x0) x) null (null, L) tt.

Opaque empty_Graph initial_copied_Graph.

Lemma vertex_at_not_null: forall (x: addr) (gx: addr * addr * addr),
  @derives pred _
    (vertex_at x gx) (!! (null <> x)).
Proof.
  intros.
  destruct (classic (null = x)).
  + subst x.
    apply derives_trans with FF.
    apply vertex_at_not_null.
    apply FF_left.
  + apply prop_right; auto.
Qed.

Lemma copy_null_refl: forall (g: Graph),
  copy null g g empty_Graph'.
Proof. intros; apply copy_invalid_refl, invalid_null; auto. Qed.

Lemma copy_vgamma_not_null_refl: forall (g: Graph) (root: addr) d l r,
  vgamma g root = (d, l, r) ->
  d <> null ->
  copy root g g empty_Graph'.
Proof.
  intros; apply marked_root_copy_refl.
  simpl.
  inversion H.
  subst; congruence.
Qed.

Lemma vmap_weaken: forall (g1: Graph) (g2: Graph') x x0 BLA,
  (x = null /\ x0 = null \/ x0 = BLA) ->
  (~ vvalid g1 x /\ ~ vvalid g2 x0 \/ x0 = BLA).
Proof.
  intros.
  destruct H; [left | right]; auto.
  destruct H.
  pose proof (@valid_not_null _ _ _ _ g1 _ (maGraph g1) x).
  pose proof (@valid_not_null' _ _ _ _ g2 _ (maGraph' g2) x0).
  unfold is_null_SGBA in *; simpl in *.
  auto.
Qed.

Lemma root_stable_ramify: forall (g: Graph) (x: addr) (gx: addr * addr * addr),
  vgamma g x = gx ->
  vvalid g x ->
  @derives pred _
    (reachable_vertices_at x g)
    (vertex_at x gx *
      (vertex_at x gx -* reachable_vertices_at x g)).
Proof. intros; apply va_reachable_root_stable_ramify; auto. Qed.

Lemma root_update_ramify1: forall (g: Graph) (x x0: addr) (lx: addr) (gx gx': addr * addr * addr),
  vvalid g x ->
  vertices_at (Intersection _ (vvalid (initial_copied_Graph x x0 g)) (fun u : addr => x0 <> u)) (initial_copied_Graph x x0 g) = emp.
Proof.
  intros.
    erewrite <- vertices_at_False.
    apply vertices_at_Same_set.
    rewrite Same_set_spec; intros ?.
Transparent initial_copied_Graph. simpl. Opaque initial_copied_Graph.
    unfold update_vlabel.
    if_tac; [| congruence].
    split; [intros [? ?]; congruence | tauto].
Qed.

Lemma root_update_ramify2: forall (g: Graph) (x x0: addr) (lx: addr) (gx gx': addr * addr * addr) F,
  vgamma g x = gx ->
  vgamma (Graph_vgen g x lx) x = gx' ->
  vvalid g x ->
  @derives pred _
    (F * reachable_vertices_at x g)
    (vertex_at x gx *
      (vertex_at x gx' -*
       F * (emp * reachable_vertices_at x (Graph_vgen g x lx)))).
Proof.
  intros.
  rewrite !(sepcon_comm F).
  apply RAMIF_PLAIN.frame.
  rewrite emp_sepcon.
  apply va_reachable_root_update_ramify; auto.
Qed.

Lemma root_update_ramify (* {sSGG_Bi': sPointwiseGraph_Graph_Bi addr (addr * LR)} *): forall (g: Graph) (x x0: addr) (lx: addr) (gx gx': addr * addr * addr) F,
  vgamma g x = gx ->
  vgamma (Graph_vgen g x lx) x = gx' ->
  vvalid g x ->
  @derives pred _
    (F * @reachable_vertices_at _ _ _ _ (@SGBA pSGG_Bi) _ _ _ (@SGC_Bi pSGG_Bi _ _ _) _ (@SGP pSGG_Bi _ _ sSGG_Bi) (@SGA pSGG_Bi _ _ sSGG_Bi) x g)
    (vertex_at x gx *
      (vertex_at x gx' -*
       F * (@vertices_at _ _ _ _ (@SGBA pSGG_Bi) _ (@SGP pSGG_Bi _ _ sSGG_Bi) _ (Intersection _ (vvalid (initial_copied_Graph x x0 g)) (fun u : addr => x0 <> u)) (initial_copied_Graph x x0 g) * reachable_vertices_at x (Graph_vgen g x lx)))).
Proof.
  intros.
  rewrite !(sepcon_comm F).
  apply RAMIF_PLAIN.frame.
  assert (@vertices_at _ _ _ _ (@SGBA pSGG_Bi) _ (@SGP pSGG_Bi _ _ sSGG_Bi) _ (Intersection _ (vvalid (initial_copied_Graph x x0 g)) (fun u : addr => x0 <> u)) (initial_copied_Graph x x0 g) = emp).
  {
    erewrite <- vertices_at_False.
    apply vertices_at_Same_set.
    rewrite Same_set_spec; intros ?.
Transparent initial_copied_Graph. simpl. Opaque initial_copied_Graph.
    unfold update_vlabel.
    if_tac; [| congruence].
    split; [intros [? ?]; congruence | tauto].
  }
  rewrite H2, emp_sepcon.
  apply va_reachable_root_update_ramify; auto.
Qed.

Lemma not_null_copy1: forall (G: Graph) (x x0: addr) l r,
  vgamma G x = (null, l, r) ->
  vvalid G x ->
  x0 <> null ->
  vcopy1 x G (Graph_vgen G x x0) (initial_copied_Graph x x0 G) /\
  x0 = LocalGraphCopy.vmap (Graph_vgen G x x0) x /\
  is_guarded_BiMaFin' (fun v => x0 <> v) (fun e => ~ In e nil) (initial_copied_Graph x x0 G).
Proof.
  intros.
  split; [split; [| split] | split].
  + reflexivity.
  + split; [| split].
    - reflexivity.
    - simpl.
      unfold update_vlabel.
      destruct_eq_dec x x; congruence.
    - intros.
      simpl.
      unfold update_vlabel; simpl.
      destruct_eq_dec x n'; [congruence |].
      tauto.
  + split; [| split; [| split]].
    - reflexivity.
    - apply guarded_pointwise_relation_spec; intros.
      simpl.
      unfold update_vlabel; simpl.
      destruct_eq_dec x x1; [congruence | auto].
    - apply guarded_pointwise_relation_spec; intros.
      auto.
    - reflexivity.
  + simpl.
    unfold update_vlabel; simpl.
    destruct_eq_dec x x; [auto | congruence].
  + assert (LocalGraphCopy.vmap (Graph_vgen G x x0) x = x0).
    1: {
      simpl.
      unfold update_vlabel; simpl.
      destruct_eq_dec x x; auto; congruence.
    }
    pattern x0 at 1; rewrite <- H2.
    apply single_vertex_guarded_BiMaFin'.
Qed.

Lemma left_weak_valid: forall (G G1: Graph) (G1': LGraph) (x l r: addr),
  vgamma G x = (null, l, r) ->
  vvalid G x ->
  vcopy1 x G G1 G1' ->
  @weak_valid _ _ _ _ G1 _ (maGraph _) l.
Proof.
  intros.
  destruct H1 as [? _].
  eapply weak_valid_si; [symmetry; exact H1 |].
  eapply gamma_left_weak_valid; eauto.
Qed.

Lemma right_weak_valid: forall (G G1 G2 G3: Graph) (G1' G2' G3': LGraph) (x l r: addr),
  vgamma G x = (null, l, r) ->
  vvalid G x ->
  vcopy1 x G G1 G1' ->
  extended_copy l (G1: LGraph, G1') (G2: LGraph, G2') ->
  ecopy1 (x, L) (G2: LGraph, G2') (G3: LGraph, G3') ->
  @weak_valid _ _ _ _ G3 _ (maGraph _) r.
Proof.
  intros.
  destruct H1 as [? _], H2 as [? _], H3 as [? _].
  rewrite <- H2, <- H1 in H3.
  eapply weak_valid_si; [symmetry; eauto |].
  eapply gamma_right_weak_valid; eauto.
Qed.

Lemma graph_ramify_left: forall (g g1: Graph) (g1': LGraph) (x l r: addr) (F1 F2: pred) F3,
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  F1 * (F2 * reachable_vertices_at x g1) |--
  reachable_vertices_at l g1 *
   (ALL a: Graph' * Graph * addr,
     !! (copy l g1 (snd (fst a)) (fst (fst a)) /\ (l = null /\ snd a = null \/ snd a = LocalGraphCopy.vmap (snd (fst a)) l)) -->
     (reachable_vertices_at l (snd (fst a)) * F3 (snd a) (fst (fst a)) -*
      F1 * (F2 * (reachable_vertices_at x (snd (fst a)) * F3 (snd a) (fst (fst a)))))).
Proof.
  intros.
  destruct H1 as [? [? ?]].
  rewrite <- sepcon_assoc, (sepcon_comm (F1 * F2)).
  RAMIF_Q'.formalize.
  match goal with
  | |- _ |-- _ * allp (_ --> (_ -* ?A)) =>
    replace A with
    (fun p : Graph' * Graph * addr =>
            reachable_vertices_at x (snd (fst p)) *
            F3 (snd p) (fst (fst p)) * (F1 * F2)) by
    (extensionality p; rewrite <- (sepcon_assoc F1 F2), (sepcon_comm _ (F1 * F2)); auto)
  end.
  apply RAMIF_Q'.frame; [auto |].
  apply RAMIF_Q'.frame_post; [auto |].
  simpl.

  eapply vertices_at_ramif_xQ.
  eexists.
  split; [| split].
  + rewrite <- H1.
    eapply Prop_join_reachable_left; eauto.
  + intros.
    destruct H4 as [[? [? ?]] _].
    rewrite <- H4, <- H1.
    eapply Prop_join_reachable_left; eauto.
  + intros [[? ?] ?] [? _].
    simpl in H4 |- *.
    rewrite vertices_identical_spec.
    intros.
    simpl.
    destruct H4 as [? [? ?]].
    f_equal; [f_equal |].
    - destruct H7 as [_ [? _]].
      rewrite guarded_pointwise_relation_spec in H7.
      apply H7; clear H7.
      unfold Complement, Ensembles.In.
      intro.
      apply reachable_by_is_reachable in H7.
      rewrite Intersection_spec in H5.
      rewrite <- H1 in H7.
      destruct H5; auto.
    - apply dst_L_eq; auto.
      rewrite Intersection_spec in H5.
      destruct H5 as [? _].
      rewrite H1 in H5.
      apply reachable_foot_valid in H5; auto.
    - apply dst_R_eq; auto.
      rewrite Intersection_spec in H5.
      destruct H5 as [? _].
      rewrite H1 in H5.
      apply reachable_foot_valid in H5; auto.
Qed.

Lemma graph_ramify_right: forall (g g1 g2 g3: Graph) (g1' g2' g3': LGraph) (x l r: addr) (F1 F2: pred) F3,
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  ecopy1 (x, L) (g2: LGraph, g2') (g3: LGraph, g3') ->
  F1 * (F2 * reachable_vertices_at x g3) |--
  reachable_vertices_at r g3 *
   (ALL a: Graph' * Graph * addr,
     !! (copy r g3 (snd (fst a)) (fst (fst a)) /\ (r = null /\ snd a = null \/ snd a = LocalGraphCopy.vmap (snd (fst a)) r)) -->
     (reachable_vertices_at r (snd (fst a)) * F3 (snd a) (fst (fst a)) -*
      F1 * (F2 * (reachable_vertices_at x (snd (fst a)) * F3 (snd a) (fst (fst a)))))).
Proof.
  intros.
  destruct H1 as [? [? ?]].
  rewrite <- sepcon_assoc, (sepcon_comm (F1 * F2)).
  RAMIF_Q'.formalize.
  match goal with
  | |- _ |-- _ * allp (_ --> (_ -* ?A)) =>
    replace A with
    (fun p : Graph' * Graph * addr =>
            reachable_vertices_at x (snd (fst p)) *
            F3 (snd p) (fst (fst p)) * (F1 * F2)) by
    (extensionality p; rewrite <- (sepcon_assoc F1 F2), (sepcon_comm _ (F1 * F2)); auto)
  end.
  apply RAMIF_Q'.frame; [auto |].
  apply RAMIF_Q'.frame_post; [auto |].
  simpl.

  eapply vertices_at_ramif_xQ.
  eexists.
  split; [| split].
  + destruct H2 as [? _], H3 as [? _]; rewrite <- s0, <- s, <- H1.
    eapply Prop_join_reachable_right; eauto.
  + intros.
    destruct H6 as [[? [? ?]] _].
    destruct H2 as [? _], H3 as [? _]. rewrite <- H6, <- H3, <- H2, <- H1.
    eapply Prop_join_reachable_right; eauto.
  + intros [[[? ?] ?] ?] [? _].
    destruct H2 as [? _], H3 as [? _]; rewrite H2, H3 in H1.
    simpl in H6 |- *.
    rewrite vertices_identical_spec.
    intros.
    simpl.
    destruct H6 as [? [? ?]].
    f_equal; [f_equal |].
    - destruct H9 as [_ [? _]].
      rewrite guarded_pointwise_relation_spec in H9.
      apply H9; clear H9.
      unfold Complement, Ensembles.In.
      intro.
      apply reachable_by_is_reachable in H9.
      rewrite Intersection_spec in H7.
      rewrite <- H1 in H9.
      destruct H7; auto.
    - apply dst_L_eq; auto.
      rewrite Intersection_spec in H7.
      destruct H7 as [? _].
      rewrite H1 in H7.
      apply reachable_foot_valid in H7; auto.
    - apply dst_R_eq; auto.
      rewrite Intersection_spec in H7.
      destruct H7 as [? _].
      rewrite H1 in H7.
      apply reachable_foot_valid in H7; auto.
Qed.

Lemma is_BiMaFin_disjoint_guard: forall (g1':  @LGraph pSGG_Bi (@addr pSGG_Bi) (prod (@addr pSGG_Bi) LR) unit) (g2'': Graph') x0 es0,
  is_guarded_BiMaFin' (fun v => x0 <> v) (fun e => ~ In e es0) g1' ->
  vvalid g1' x0 ->
  (forall e, In e es0 -> fst e = x0) ->
  Disjoint addr (vvalid g2'') (vvalid g1') ->
  disjointed_guard (vvalid g2'') (vvalid g1') (evalid g2'') (evalid g1').
Proof.
  intros.
  split; auto.
  rewrite Disjoint_spec in *.
  intros e ? ?.
  pose proof @valid_graph' _ _ _ _ g2'' _ (maGraph' _) e H3.
  apply (H2 _ H5).
  destruct (in_dec equiv_dec e es0); destruct e as [v lr].
  + specialize (H1 _ i).
    simpl in H1.
    rewrite left_right_sound0' by auto.
    subst; auto.
  + destruct H as [X _].
    pose (pg1 := Build_GeneralGraph _ _ _ (fun g: LGraph => BiMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e => ~ In e es0) g1') X: Graph').
    assert (evalid pg1 (v, lr)) by (simpl; rewrite Intersection_spec; split; auto).
    assert (src g2'' (v, lr) = src pg1 (v, lr)) by (rewrite !left_right_sound0'; auto).
    apply (@valid_graph' _ _ _ _ pg1 _ (maGraph' _)) in H.
    rewrite H6; auto.
    destruct H; auto.
Qed.

Lemma is_BiMaFin_not_evalid: forall (g1': @LGraph pSGG_Bi (@addr pSGG_Bi) (prod (@addr pSGG_Bi) LR) unit)x0 es0 e0,
  is_guarded_BiMaFin' (fun v => x0 <> v) (fun e => ~ In e es0) g1' ->
  vvalid g1' x0 ->
  (forall e, In e es0 -> fst e = x0) ->
  fst e0 = x0 ->
  ~ In e0 es0 ->
  ~ evalid g1' e0.
Proof.
  intros.
  intro.
  destruct H as [X ?].
  set (G := (Build_GeneralGraph _ _ _ (fun g => BiMaFin' (pg_lg g)) _ X: Graph')).
  assert (evalid G e0).
  1: {
    simpl.
    rewrite Intersection_spec; auto.
  }
  pose proof @valid_graph' _ _ _ _ G _ (maGraph' _) _ H5.
  destruct e0.
  simpl in H2; subst a.
  rewrite (left_right_sound0' _ _ _ H5) in H6.
  simpl in H6.
  rewrite Intersection_spec in H6.
  destruct H6.
  auto.
Qed.

Lemma extend_copy_left: forall (g g1 g2: Graph) (g1': LGraph) (g2'': Graph') (x l r x0 l0: addr) d0,
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  copy l g1 g2 g2'' ->
  x0 = LocalGraphCopy.vmap g1 x ->
  l = null /\ l0 = null \/ l0 = LocalGraphCopy.vmap g2 l ->
  is_guarded_BiMaFin' (fun v => x0 <> v) (fun e => ~ In e nil) g1' ->
  @derives pred _
  (vertex_at x0 d0 * vertices_at (Intersection _ (vvalid g1') (fun x => x0 <> x)) g1' * reachable_vertices_at l0 g2'')
  (EX g2': LGraph,
    !! (extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') /\ is_guarded_BiMaFin' (fun v => x0 <> v) (fun e => ~ In e nil) g2') &&
    (vertex_at x0 d0 * vertices_at (Intersection _ (vvalid g2') (fun x => x0 <> x)) g2')).
Proof.
  intros.
  rename H5 into BMF.
  inversion H0.
  pose proof @vcopy1_edge_copy_list_weak_copy_extended_copy' _ _ _ _ _ _ _ _ _ _ BiMaFin'_Normal x ((x, L) :: (x, R) :: nil) nil (x, L) ((x, R) :: nil) g g1 g1 g1' g1' g2 g2'' x0 H.
  spec H5; [simpl; unfold Complement, Ensembles.In; congruence |].
  spec H5; [reflexivity |].
  spec H5; [intros; apply (biGraph_out_edges g (biGraph _)); auto |].
  spec H5; [repeat constructor; intro HH; inversion HH; inversion H9 |].
  spec H5; [auto |].
  spec H5; [hnf; auto |].
  spec H5; [auto |].
  spec H5; [subst l; auto |].

  unfold reachable_vertices_at.
  pose proof vertices_at_sepcon_unique_1x (Graph_PointwiseGraph g2'') x0 (reachable g2'' l0) d0.
  pose proof vertices_at_sepcon_unique_xx g1' (Graph_PointwiseGraph g2'') (Intersection _ (vvalid g1') (fun x => x0 <> x)) (reachable g2'' l0).

  rewrite sepcon_assoc, (add_andp _ _ H10); normalize.
  rewrite (sepcon_comm (vertices_at _ _)), <- sepcon_assoc, (add_andp _ _ H9); normalize.
  clear H9 H10.
  spec H5.
  {
    apply is_BiMaFin_disjoint_guard with (x0 := x0) (es0 := nil); auto.
    + eapply vcopy1_copied_root_valid in H1; auto.
      subst x0; auto.
    + intros ? [].
    + apply (vmap_weaken g1 g2'') in H4.
      rewrite (copy_vvalid_weak_eq g1 g2 g2'' l l0 H4 H2).
      apply Disjoint_comm.
      apply (Disjoint_x1' _ _ _ H11 H12).
  }

  unfold map in H5; rewrite H3 in BMF.
  rewrite <- H3 in BMF;
  specialize (H5 BMF).
  specialize (H5 (Graph'_is_BiMaFin' _)).

  destruct H5 as [g2' [? [? [? ?]]]].
  apply (exp_right g2').

  pose proof vertex_at_not_null x0 d0.
  rewrite (add_andp _ _ H14) at 1.
  rewrite andp_comm, !sepcon_andp_prop'.
  apply derives_extract_prop.
  intro.
  clear H14. assert (x0 <> null) by congruence; clear H15.

  apply andp_right; [apply prop_right; split; auto | rewrite sepcon_assoc; apply sepcon_derives; auto].
  assert (Prop_join (vvalid g1') (vvalid g2'') (vvalid g2')) as HPJ.
  1: {
    eapply copy_and_extended_copy; eauto.
    rewrite <- H7; auto.
  }
  assert (Prop_join (Intersection addr (vvalid g1') (fun x1 : addr => x0 <> x1))
                (vvalid g2'')
                (Intersection addr (vvalid g2') (fun x1 : addr => x0 <> x1))) as HPJ1.
  1: {
    apply Prop_join_shrink1; auto.
    eapply vcopy1_copied_root_valid in H1; auto.
    rewrite H3; auto.
  }
  rewrite (vertices_at_vertices_identical (Graph_PointwiseGraph g2'') (LGraph_SGraph g2')).
  rewrite (vertices_at_vertices_identical (LGraph_SGraph g1') (LGraph_SGraph g2')).
  + erewrite vertices_at_sepcon_xx; [apply derives_refl |].
    rewrite Prop_join_comm.
    apply (vmap_weaken g1 g2'') in H4.
    rewrite <- (copy_vvalid_weak_eq g1 g2 g2'' l l0 H4 H2).
    auto.
  + rewrite <- H3 in H13.
    apply H13.
    - unfold Included, Ensembles.In; intros.
      destruct BMF as [BMF _].
      pose (pg1 := Build_GeneralGraph _ _ _ (fun g: LGraph => BiMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e : addr * LR => ~ In e nil) g1') BMF: Graph').
      assert (vvalid pg1 x1) by (simpl; auto).
      apply vvalid_vguard' in H16.
      simpl in H16.
      rewrite !Intersection_spec in H16.
      simpl; tauto.
    - unfold Included, Ensembles.In; intros.
      destruct H9 as [X _].
      pose (pg2 := Build_GeneralGraph _ _ _ (fun g: LGraph => BiMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e : addr * LR => ~ In e nil) g2') X: Graph').
      assert (vvalid pg2 x1). simpl. rewrite Intersection_spec in H15 |- *. rewrite (proj1 HPJ); tauto.
      apply vvalid_vguard' in H9.
      simpl in H9.
      rewrite !Intersection_spec in H9.
      simpl; tauto.
  + apply (vmap_weaken g1 g2'') in H4.
    pose proof copy_vvalid_weak_eq _ _ _ _ _ H4 H2.
    rewrite <- H15.
    apply H10.
    - intros ? ?; apply vvalid_vguard'; auto.
    - unfold Included, Ensembles.In; intros.
      destruct H9 as [X _].
      pose (pg2 := Build_GeneralGraph _ _ _ (fun g: LGraph => BiMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e : addr * LR => ~ In e nil) g2') X: Graph').
      assert (vvalid pg2 x1). simpl. rewrite (proj1 HPJ1). tauto.
      apply vvalid_vguard' in H9.
      simpl in H9.
      rewrite !Intersection_spec in H9.
      simpl; tauto.
Qed.

Lemma labeledgraph_add_edge_ecopy1_left: forall (g g1 g2: Graph) (g1' g2': LGraph) (x l r x0 l0: addr),
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  x0 = LocalGraphCopy.vmap g1 x ->
  l = null /\ l0 = null \/ l0 = LocalGraphCopy.vmap g2 l ->
  is_guarded_BiMaFin' (fun v => x0 <> v) (fun e => ~ In e nil) g2' ->
  x0 <> null ->
  let g3 := Graph_egen g2 (x, L) (x0, L): Graph in
  let g3' := labeledgraph_add_edge g2' (x0, L) x0 l0 (null, L): LGraph in
  ecopy1 (x, L) (g2: LGraph, g2') (g3: LGraph, g3') /\
  is_guarded_BiMaFin' (fun v => x0 <> v) (fun e => ~ In e ((x0, L) :: nil)) g3' /\
  (x0, L) = LocalGraphCopy.emap g3 (x, L) /\
  dst g3' (x0, L) = l0.
Proof.
  intros.
  unfold ecopy1.
  assert (~ evalid g2' (x0, L)) as HH.
  1: {
    eapply is_BiMaFin_not_evalid; eauto; [| intros ? []].
    eapply extended_copy_vvalid_mono in H2; [exact H2 |].
    eapply vcopy1_copied_root_valid in H1; auto.
    subst x0; auto.
  }
  split; [split; [| split] | split; [| split]].
  + reflexivity.
  + apply WeakMarkGraph.labeledgraph_egen_do_nothing.
  + assert (g ~=~ g2) as HH0.
    1: {
      destruct H1 as [? _], H2 as [? _].
      rewrite <- H2, <- H1; reflexivity.
    }
    assert (x0 = LocalGraphCopy.vmap g2 (src g2 (x, L))) as HH1.
    1: {
      rewrite left_right_sound by (rewrite <- (proj1 HH0); auto).
      destruct H1 as [_ [? _]], H2 as [_ [_ ?]].
      subst x0.
      destruct H2 as [_ [? _]].
      rewrite guarded_pointwise_relation_spec in H2.
      apply H2.
      unfold Complement, Ensembles.In; intro.
      apply reachable_by_foot_prop in H3.
      apply H3.
      destruct H1 as [_ [? _]]; auto.
    }
    destruct H4.
    - pose proof LocalGraphCopy.labeledgraph_egen_ecopy1_not_vvalid g2 g2' (x, L) (x0, L) x0 l0.
      apply H7; clear H7; auto.
      * destruct H4.
        subst l0.
        destruct H5 as [[? ? ?] _].
        pose proof @valid_not_null' _ _ _ _ (gpredicate_sub_labeledgraph (fun v : addr => x0 <> v)
            (fun e : addr * LR => ~ In e nil) g2') _ ma' null.
        intro.
        apply H5; [| reflexivity].
        simpl.
        rewrite Intersection_spec; split; auto.
      * inversion H0.
        rewrite <- (si_dst1 _ _ _ HH0); [| apply (@left_valid _ _ _ _ _ _ g (biGraph _)); auto].
        destruct H4; rewrite H9; subst l.
        intro.
        apply (@valid_not_null _ _ _ _ g2 _ (maGraph _) null); auto; reflexivity.
    - pose proof LocalGraphCopy.labeledgraph_egen_ecopy1 g2 g2' (x, L) (x0, L) x0 l0.
      apply H7; clear H7; auto.

      subst l0.
      f_equal.
      inversion H0.
      destruct H1 as [? _], H2 as [? _].
      rewrite <- H1 in H2.
      rewrite (si_dst1 _ _ _ H2); auto.
      apply (@left_valid _ _ _ _ _ _ g (biGraph _)); auto.
  + eapply is_guarded_BiMaFin'_labeledgraph_add_edge; [auto | | exact H5].
    rewrite Same_set_spec; intro e; simpl.
    rewrite Intersection_spec.
    assert (e = (x0, L) <-> (x0, L) = e) by (split; intros; congruence).
    tauto.
  + simpl.
    unfold update_elabel; simpl.
    destruct_eq_dec (x, L) (x, L); auto; congruence.
  + subst g3'.
    simpl.
    unfold updateEdgeFunc.
    rewrite if_true; reflexivity.
Qed.

Lemma va_labeledgraph_add_edge_left: forall (g g1 g2: Graph) (g1' g2': LGraph) (x l r x0 l0: addr),
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  x0 = LocalGraphCopy.vmap g1 x ->
  is_guarded_BiMaFin' (fun x => x0 <> x) (fun e => ~ In e nil) g2' ->
  vertices_at (Intersection _ (vvalid g2') (fun x => x0 <> x)) g2' = vertices_at (Intersection _ (vvalid (labeledgraph_add_edge g2' (x0, L) x0 l0 (null, L))) (fun x => x0 <> x)) (LGraph_SGraph (labeledgraph_add_edge g2' (x0, L) x0 l0 (null, L))).
Proof.
  intros.
  eapply va_labeledgraph_add_edge_eq'; eauto.
  eapply is_BiMaFin_not_evalid; eauto.
  + eapply extended_copy_vvalid_mono in H2; [exact H2 |].
    eapply vcopy1_copied_root_valid in H1; auto.
    subst x0; auto.
  + intros ? [].
Qed.

Lemma va_labeledgraph_egen_left: forall (g2: Graph) (x x0: addr),
  reachable_vertices_at x g2 = reachable_vertices_at x (Graph_egen g2 (x, L) (x0, L)).
Proof.
  intros.
  apply va_labeledgraph_egen_eq.
Qed.

Lemma extend_copy_right: forall (g g1 g2 g3 g4: Graph) (g1' g2' g3': LGraph) (g4'': Graph') (x l r x0 r0: addr) d0,
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  ecopy1 (x, L) (g2: LGraph, g2') (g3: LGraph, g3') ->
  copy r g3 g4 g4'' ->
  x0 = LocalGraphCopy.vmap g1 x ->
  (x0, L) = LocalGraphCopy.emap g3 (x, L) ->
  r = null /\ r0 = null \/ r0 = LocalGraphCopy.vmap g4 r ->
  is_guarded_BiMaFin' (fun v => x0 <> v) (fun e => ~ In e ((x0, L) :: nil)) g3' ->
  @derives pred _
  (vertex_at x0 d0 * vertices_at (Intersection _ (vvalid g3') (fun x => x0 <> x)) g3' * reachable_vertices_at r0 g4'')
  (EX g4': LGraph,
    !! (extended_copy r (g3: LGraph, g3') (g4: LGraph, g4') /\ is_guarded_BiMaFin' (fun v => x0 <> v) (fun e => ~ In e ((x0, L) :: nil)) g4') &&
   (vertex_at x0 d0 * vertices_at (Intersection _ (vvalid g4') (fun x => x0 <> x)) g4')).
Proof.
  intros.
  rename H8 into BMF.
  inversion H0.
  pose proof @vcopy1_edge_copy_list_weak_copy_extended_copy' _ _ _ _ _ _ _ _ _ _ BiMaFin'_Normal x ((x, L) :: (x, R) :: nil) ((x, L) :: nil) (x, R) nil g g1 g3 g1' g3' g4 g4'' x0 H.
  spec H8; [simpl; unfold Complement, Ensembles.In; congruence |].
  spec H8; [reflexivity |].
  spec H8; [intros; apply (biGraph_out_edges g (biGraph _)); auto |].
  spec H8; [repeat constructor; intro HH; inversion HH; inversion H12 |].
  spec H8; [auto |].
  spec H8.
  1: {
    unfold edge_copy_list; simpl map.
    split_relation_list (@nil (@LGraph _ addr (addr * LR) unit * @LGraph _ addr (addr * LR) unit)).
    unfold edge_copy.
    split_relation_list ((g2: LGraph, g2') :: nil); auto.
    rewrite H10; auto.
  }
  spec H8; [subst r; auto |].
  spec H8; [subst r; auto |].

  unfold reachable_vertices_at.
  pose proof vertices_at_sepcon_unique_1x (Graph_PointwiseGraph g4'') x0 (reachable g4'' r0) d0.
  pose proof vertices_at_sepcon_unique_xx g3' (Graph_PointwiseGraph g4'') (Intersection _ (vvalid g3') (fun x => x0 <> x)) (reachable g4'' r0).

  rewrite sepcon_assoc, (add_andp _ _ H13); normalize.
  rewrite (sepcon_comm (vertices_at _ _)), <- sepcon_assoc, (add_andp _ _ H12); normalize.
  clear H12 H13.
  spec H8.
  1: {
    apply is_BiMaFin_disjoint_guard with (x0 := x0) (es0 := (x0, L) :: nil); auto.
    + eapply ecopy1_vvalid_mono in H3; [exact H3 |].
      eapply extended_copy_vvalid_mono in H2; [exact H2 |].
      eapply vcopy1_copied_root_valid in H1; auto.
      subst x0; auto.
    + intros ? [? | []].
      subst e; auto.
    + apply (vmap_weaken g3 g4'') in H7.
      rewrite (copy_vvalid_weak_eq g3 g4 g4'' r r0 H7 H4).
      apply Disjoint_comm.
      apply (Disjoint_x1' _ _ _ H14 H15).
  }

  unfold map in H8. rewrite H6 in BMF.
  specialize (H8 BMF).
  specialize (H8 (Graph'_is_BiMaFin' _)).

  destruct H8 as [g4' [? [? [? ?]]]].
  apply (exp_right g4').

  pose proof vertex_at_not_null x0 d0.
  rewrite (add_andp _ _ H17) at 1.
  rewrite andp_comm, !sepcon_andp_prop'.
  apply derives_extract_prop.
  intro.
  clear H17. assert (x0 <> null) by congruence; clear H18.

  pose proof (extend_copy_emap_root g g1 g3 g4 g1' g3' g4' x ((x, L) :: (x, R) :: nil) ((x, L) :: nil) (x, R) nil H).
  spec H18; [simpl; unfold Complement, Ensembles.In; congruence |].
  spec H18; [reflexivity |].
  spec H18; [intros; apply (biGraph_out_edges g (biGraph _)); auto |].
  spec H18; [repeat constructor; intro HH; inversion HH; inversion H19 |].
  spec H18; [auto |].
  spec H18.
  1: {
    unfold edge_copy_list; simpl map.
    split_relation_list (@nil (@LGraph _ addr (addr * LR) unit * @LGraph _ addr (addr * LR) unit)).
    unfold edge_copy.
    split_relation_list ((g2: LGraph, g2') :: nil); auto.
    rewrite H10; auto.
  }
  spec H18; [subst r; auto |].
  rewrite H6.
  replace ((@LocalGraphCopy.emap _ _ _ _ _ _ _ _ _ _ _ _ GMS g3 (x, L)) :: nil) with (LocalGraphCopy.emap g4 (x, L) :: nil) by (symmetry; auto).
  simpl in H18.

  apply andp_right; [apply prop_right; split; auto | rewrite sepcon_assoc; apply sepcon_derives; auto].
  assert (Prop_join (vvalid g3') (vvalid g4'') (vvalid g4')).
  1: {
    eapply copy_and_extended_copy; eauto.
    rewrite <- H11; auto.
  }
  assert (Prop_join (Intersection addr (vvalid g3') (fun x1 : addr => x0 <> x1))
                (vvalid g4'')
                (Intersection addr (vvalid g4') (fun x1 : addr => x0 <> x1))) as HPJ1.
  1: {
    apply Prop_join_shrink1; auto.
    eapply ecopy1_vvalid_mono in H3; [exact H3 |].
    eapply extended_copy_vvalid_mono in H2; [exact H2 |].
    eapply vcopy1_copied_root_valid in H1; auto.
    rewrite H5; auto.
  }
  rewrite (vertices_at_vertices_identical (Graph_PointwiseGraph g4'') (LGraph_SGraph g4')).
  rewrite (vertices_at_vertices_identical (LGraph_SGraph g3') (LGraph_SGraph g4')).
  + erewrite vertices_at_sepcon_xx; [apply derives_refl |].
    rewrite Prop_join_comm.
    apply (vmap_weaken g3 g4'') in H7.
    rewrite <- (copy_vvalid_weak_eq g3 g4 g4'' r r0 H7 H4).
    auto.
  + rewrite <- H5 in H16.
    apply H16.
    - unfold Included, Ensembles.In; intros.
      destruct BMF as [BMF _].
      pose (pg1 := Build_GeneralGraph _ _ _ (fun g: LGraph => BiMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e : addr * LR => ~ In e (LocalGraphCopy.emap g3 (x, L) :: nil)) g3') BMF: Graph').
      assert (vvalid pg1 x1) by (simpl; auto).
      apply vvalid_vguard' in H21.
      simpl in H21.
      rewrite !Intersection_spec in H21.
      simpl; tauto.
    - unfold Included, Ensembles.In; intros.
      destruct H12 as [X _].
      pose (pg2 := Build_GeneralGraph _ _ _ (fun g: LGraph => BiMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e : addr * LR => ~ In e (LocalGraphCopy.emap g4 (x, L) :: nil)) g4') X: Graph').
      assert (vvalid pg2 x1). simpl. rewrite (proj1 HPJ1); tauto.
      apply vvalid_vguard' in H12.
      simpl in H12.
      rewrite !Intersection_spec in H12.
      simpl; tauto.
  + apply (vmap_weaken g3 g4'') in H7.
    pose proof copy_vvalid_weak_eq _ _ _ _ _ H7 H4.
    rewrite <- H20.
    apply H13.
    - intros ? ?; apply vvalid_vguard'; auto.
    - unfold Included, Ensembles.In; intros.
      destruct H12 as [X _].
      pose (pg2 := Build_GeneralGraph _ _ _ (fun g: LGraph => BiMaFin' g) (gpredicate_sub_labeledgraph (fun v => x0 <> v) (fun e : addr * LR => ~ In e _) g4') X: Graph').
      assert (vvalid pg2 x1). simpl. rewrite (proj1 HPJ1). tauto.
      apply vvalid_vguard' in H12.
      simpl in H12.
      rewrite !Intersection_spec in H12.
      simpl; tauto.
Qed.

Lemma labeledgraph_add_edge_ecopy1_right: forall (g g1 g2 g3 g4: Graph) (g1' g2' g3' g4': LGraph) (x l r x0 r0: addr),
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  ecopy1 (x, L) (g2: LGraph, g2') (g3: LGraph, g3') ->
  extended_copy r (g3: LGraph, g3') (g4: LGraph, g4') ->
  x0 = LocalGraphCopy.vmap g1 x ->
  (x0, L) = LocalGraphCopy.emap g3 (x, L) ->
  r = null /\ r0 = null \/ r0 = LocalGraphCopy.vmap g4 r ->
  is_guarded_BiMaFin' (fun v => x0 <> v) (fun e => ~ In e ((x0, L) :: nil)) g4' ->
  x0 <> null ->
  let g5 := Graph_egen g4 (x, R) (x0, R): Graph in
  let g5' := labeledgraph_add_edge g4' (x0, R) x0 r0 (null, L): LGraph in
  ecopy1 (x, R) (g4: LGraph, g4') (g5: LGraph, g5') /\
  is_guarded_BiMaFin' (fun v => x0 <> v) (fun e => ~ In e ((x0, L) :: (x0, R) :: nil)) g5' /\
  (x0, R) = LocalGraphCopy.emap g5 (x, R) /\
  dst g5' (x0, R) = r0.
Proof.
  intros.
  unfold ecopy1.
  assert (~ evalid g4' (x0, R)) as HH.
  1: {
    eapply is_BiMaFin_not_evalid; eauto.
    + eapply extended_copy_vvalid_mono in H4; [exact H4 |].
      eapply ecopy1_vvalid_mono in H3; [exact H3 |].
      eapply extended_copy_vvalid_mono in H2; [exact H2 |].
      eapply vcopy1_copied_root_valid in H1; auto.
      subst x0; auto.
    + intros ? [? | []].
      subst e; auto.
    + intros [? | []].
      inversion H10.
  }
  split; [split; [| split] | split; [| split]].
  + reflexivity.
  + apply WeakMarkGraph.labeledgraph_egen_do_nothing.
  + assert (g ~=~ g4) as HH0.
    1: {
      destruct H1 as [? _], H2 as [? _], H3 as [? _], H4 as [? _].
      rewrite <- H4, <- H3, <- H2, <- H1; reflexivity.
    }
    assert (x0 = LocalGraphCopy.vmap g4 (src g4 (x, R))) as HH1.
    1: {
      rewrite left_right_sound by (rewrite <- (proj1 HH0); auto).
      subst x0.
      assert (WeakMarkGraph.marked g1 x).
      1: {
        destruct H1 as [_ [? _]].
        destruct H1 as [_ [? _]]; auto.
      }
      assert (WeakMarkGraph.marked g3 x).
      1: {
        destruct H3 as [_ [? _]].
        rewrite <- (proj2 H3).
        eapply WeakMarkGraph.mark_marked; [destruct H2 as [_ [H2 _]]; exact H2 | auto].
      }
      rewrite (extended_copy_vmap_root g1 g2 g1' g2' l x) by auto.
      rewrite (ecopy1_vmap_root g2 g3 g2' g3' (x, L) x H3).
      rewrite (extended_copy_vmap_root g3 g4 g3' g4' r x) by auto.
      reflexivity.
    }
    destruct H7.
    - pose proof LocalGraphCopy.labeledgraph_egen_ecopy1_not_vvalid g4 g4' (x, R) (x0, R) x0 r0.
      apply H10; clear H10; auto.
      * destruct H7.
        subst r0.
        destruct H8 as [[? ? ?] _].
        pose proof @valid_not_null' _ _ _ _ (gpredicate_sub_labeledgraph (fun v : addr => x0 <> v)
            (fun e : addr * LR => ~ In e ((x0, L) :: nil)) g4') _ ma' null.
        intro.
        apply H8; [| reflexivity].
        simpl.
        rewrite Intersection_spec; split; auto.
      * inversion H0.
        rewrite <- (si_dst1 _ _ _ HH0); [| apply (@right_valid _ _ _ _ _ _ g (biGraph _)); auto].
        destruct H7; rewrite H13; subst r.
        intro.
        apply (@valid_not_null _ _ _ _ g4 _ (maGraph _) null); auto; reflexivity.
    - pose proof LocalGraphCopy.labeledgraph_egen_ecopy1 g4 g4' (x, R) (x0, R) x0 r0.
      apply H10; clear H10; auto.

      subst r0.
      f_equal.
      inversion H0.
      rewrite (si_dst1 _ _ _ HH0); auto.
      apply (@right_valid _ _ _ _ _ _ g (biGraph _)); auto.
  + eapply is_guarded_BiMaFin'_labeledgraph_add_edge; [auto | | exact H8].
    rewrite Same_set_spec; intro e; simpl.
    rewrite Intersection_spec.
    assert (e = (x0, R) <-> (x0, R) = e) by (split; intros; congruence).
    tauto.
  + simpl.
    unfold update_elabel; simpl.
    destruct_eq_dec (x, R) (x, R); auto; congruence.
  + subst g5'.
    simpl.
    unfold updateEdgeFunc.
    rewrite if_true; reflexivity.
Qed.

Lemma va_labeledgraph_add_edge_right: forall (g g1 g2 g3 g4: Graph) (g1' g2' g3' g4': LGraph) (x l r x0 r0: addr),
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  ecopy1 (x, L) (g2: LGraph, g2') (g3: LGraph, g3') ->
  extended_copy r (g3: LGraph, g3') (g4: LGraph, g4') ->
  x0 = LocalGraphCopy.vmap g1 x ->
  is_guarded_BiMaFin' (fun x => x0 <> x) (fun e => ~ In e ((x0, L) :: nil)) g4' ->
  vertices_at (Intersection _ (vvalid g4') (fun x => x0 <> x)) g4' = vertices_at (Intersection _ (vvalid (labeledgraph_add_edge g4' (x0, R) x0 r0 (null, L))) (fun x => x0 <> x)) (LGraph_SGraph (labeledgraph_add_edge g4' (x0, R) x0 r0 (null, L))).
Proof.
  intros.
  eapply va_labeledgraph_add_edge_eq'; eauto.
  eapply is_BiMaFin_not_evalid; eauto.
  + eapply extended_copy_vvalid_mono in H4; [exact H4 |].
    eapply ecopy1_vvalid_mono in H3; [exact H3 |].
    eapply extended_copy_vvalid_mono in H2; [exact H2 |].
    eapply vcopy1_copied_root_valid in H1; auto.
    subst x0; auto.
  + intros ? [? | []].
    subst e; auto.
  + intros [? | []].
    inversion H7.
Qed.

Lemma va_labeledgraph_egen_right: forall (g2: Graph) (x x0: addr),
  reachable_vertices_at x g2 = reachable_vertices_at x (Graph_egen g2 (x, R) (x0, R)).
Proof.
  intros.
  apply va_labeledgraph_egen_eq.
Qed.

Lemma copy_final: forall (g g1 g2 g3 g4 g5: Graph) (g1' g2' g3' g4' g5': LGraph) x l r x0 l0 r0,
  vvalid g x ->
  vgamma g x = (null, l, r) ->
  x0 = LocalGraphCopy.vmap g1 x ->
  l = null /\ l0 = null \/ l0 = LocalGraphCopy.vmap g2 l ->
  forall (H999: dst g3' (x0, L) = l0),
  (x0, L) = LocalGraphCopy.emap g3 (x, L) ->
  r = null /\ r0 = null \/ r0 = LocalGraphCopy.vmap g4 r ->
  forall (H998: dst g5' (x0, R) = r0),
  (x0, R) = LocalGraphCopy.emap g5 (x, R) ->
  is_guarded_BiMaFin'
    (fun v => x0 <> v)
    (fun e => ~ In e ((x0, L) :: (x0, R) :: nil)) g5' ->
  vcopy1 x g g1 g1' ->
  extended_copy l (g1: LGraph, g1') (g2: LGraph, g2') ->
  ecopy1 (x, L) (g2: LGraph, g2') (g3: LGraph, g3') ->
  extended_copy r (g3: LGraph, g3') (g4: LGraph, g4') ->
  ecopy1 (x, R) (g4: LGraph, g4') (g5: LGraph, g5') ->
  @derives pred _
  (vertex_at x0 (null, l0, r0) * vertices_at (Intersection _ (vvalid g5') (fun v => x0 <> v)) g5')
  (EX gg5': Graph',
  !! (copy x g g5 gg5' /\ LocalGraphCopy.vmap g1 x = LocalGraphCopy.vmap g5 x) && reachable_vertices_at x0 gg5').
Proof.
  intros.
  assert (copy x g g5 g5').
  {
    eapply vcopy1_edge_copy_list_copy.
    + assumption.
    + simpl in H0 |- *; unfold Complement, Ensembles.In. congruence.
    + intros; apply (biGraph_out_edges g (biGraph _)); auto.
    + repeat constructor; intro HH; inversion HH; inversion H12.
    + exact H7.
    + hnf.
      exists (g3: LGraph, g3').
      - exists (g1: LGraph, g1'); auto.
        exists (g2: LGraph, g2').
        * exists (g1: LGraph, g1'); auto.
          simpl in H0.
          inversion H0.
          rewrite H14.
          exact H8.
        * exact H9.
      - hnf.
        exists (g4: LGraph, g4').
        * exists (g3: LGraph, g3'); auto.
          simpl in H0.
          inversion H0.
          rewrite H15.
          exact H10.
        * exact H11.
  }
  rewrite (add_andp _ _ (vertex_at_not_null x0 (null, l0, r0))).
  normalize.
  assert (x0 <> null) as LOCAL' by congruence; clear H13.

  assert (LocalGraphCopy.vmap g5 x = x0 /\
          src g5' (x0, L) = x0 /\
          src g5' (x0, R) = x0 /\
          dst g5' (x0, L) = l0 /\
          dst g5' (x0, R) = r0 /\
          evalid g5' (x0, L) /\
          evalid g5' (x0, R) /\
          vvalid g5' x0) as LOCAL.
  {
    pose proof fun H => extended_copy_vmap_root _ _ _ _ _ x H H8 as Hvmap12.
    specialize (Hvmap12 ltac:(simpl in H1 |- *; subst x0; congruence)).
    pose proof ecopy1_vmap_root _ _ _ _ _ x H9 as Hvmap23.
    pose proof fun H => extended_copy_vmap_root _ _ _ _ _ x H H10 as Hvmap34.
    specialize (Hvmap34 ltac:(simpl in H1, Hvmap12, Hvmap23 |- *; subst x0; congruence)).
    pose proof ecopy1_vmap_root _ _ _ _ _ x H11 as Hvmap45.
    split; [congruence |].
    pose proof vcopy1_copied_root_valid _ _ _ _ _ H7 H1 as Hx0_g5'.
    apply (extended_copy_vvalid_mono _ _ _ _ _ _ H8) in Hx0_g5'.
    apply (ecopy1_vvalid_mono _ _ _ _ _ _ H9) in Hx0_g5'.
    apply (extended_copy_vvalid_mono _ _ _ _ _ _ H10) in Hx0_g5'.
    apply (ecopy1_vvalid_mono _ _ _ _ _ _ H11) in Hx0_g5'.
    assert (vvalid g2 x) as Hx_g2.
    {
      rewrite <- (proj1 (proj1 H8)), <- (proj1 (proj1 H7)).
      auto.
    }
    assert (vvalid g3 x) as Hx_g3.
    {
      rewrite <- (proj1 (proj1 H9)).
      auto.
    }
    assert (vvalid g4 x) as Hx_g4.
    {
      rewrite <- (proj1 (proj1 H10)).
      auto.
    }
    assert (vvalid g5 x) as Hx_g5.
    {
      rewrite <- (proj1 (proj1 H11)).
      auto.
    }
    assert (src g3' (x0, L) = x0 /\ dst g3' (x0, L) = l0 /\ evalid g3' (x0, L)) as [Hx0L_src [Hx0L_dst Hx0L_v]].
    {
      destruct H9 as [_ [_ ?]].
      destruct H9 as [? [? [? [? [? ?]]]]].
      destruct H15 as [_ [? _]].
      destruct H15 as [? _].
      rewrite (H15 (x0, L)).
      rewrite left_right_sound in H16 by auto.
      rewrite <- H3 in *.
      rewrite <- H16 by auto.
      simpl in H0; inversion H0.
      split; [congruence | split; tauto].
    }
    pose proof (extended_copy_evalid_mono _ _ _ _ _ _ H10 Hx0L_v) as Hx0L_v'.
    pose proof proj2 (proj2 H10).
    destruct H13 as [_ [_ [_ [? [_ _]]]]].
    destruct H13 as [_ [_ [? ?]]].
    rewrite H13 in Hx0L_src by auto.
    rewrite H14 in Hx0L_dst by auto.
    clear H13 H14 Hx0L_v; rename Hx0L_v' into Hx0L_v.
    pose proof (ecopy1_evalid_mono _ _ _ _ _ _ H11 Hx0L_v) as Hx0L_v'.
    pose proof proj2 (proj2 H11).
    destruct H13 as [_ [_ [_ [? [_ _]]]]].
    destruct H13 as [_ [_ [? ?]]].
    rewrite H13 in Hx0L_src by auto.
    rewrite H14 in Hx0L_dst by auto.
    clear H13 H14 Hx0L_v; rename Hx0L_v' into Hx0L_v.
    assert (src g5' (x0, R) = x0 /\ dst g5' (x0, R) = r0 /\ evalid g5' (x0, R)) as [Hx0R_src [Hx0R_dst Hx0R_v]].
    {
      destruct H11 as [_ [_ ?]].
      destruct H11 as [? [? [? [? [? ?]]]]].
      destruct H15 as [_ [? _]].
      destruct H15 as [? _].
      rewrite (H15 (x0, R)).
      rewrite left_right_sound in H16 by auto.
      rewrite <- H5 in *.
      rewrite <- H16 by auto.
      simpl in H0; inversion H0.
      split; [congruence | split; tauto].
    }
    tauto.
  }
  pose proof H6.
  destruct H13 as [? _].
  assert (BiMaFin' g5').
  {
    constructor.
    + constructor.
      - intros.
        congruence.
      - intros.
        destruct (classic (x0 = x2)).
        * subst x2.
          destruct (classic (e = (x0, L))); [| destruct (classic (e = (x0, R)))].
         ++ subst e; tauto.
         ++ subst e; tauto.
         ++ split; [intros [? ?]; exfalso | tauto].
            pose proof @ma' _ _ x1.
            pose proof @valid_graph' _ _ _ _ _ _ H18 e.
            simpl in H19.
            rewrite !Intersection_spec in H19.
            specialize (H19 ltac:(pose proof @eq_sym _ (x0, L) e; pose proof @eq_sym _ (x0, R) e; tauto)).
            rewrite H16 in H19. tauto.
        * pose proof @bi' _ _ x1.
          pose proof @only_two_edges _ _ _ _ _ _ _ H15 x2 e.
          simpl in H16.
          rewrite !Intersection_spec in H16.
          specialize (H16 ltac:(tauto)).
          rewrite <- H16; split; [| tauto].
          intros [? ?]; repeat split; auto.
          intros [| [| []]]; subst e; rewrite <- H17 in H14; apply H14; symmetry; tauto.
    + constructor.
      - intros.
        destruct (classic ((x0, L) = e)); [| destruct (classic ((x0, R) = e))].
        * unfold is_null_SGBA; simpl.
          subst e.
          replace (src g5' (x0, L)) with x0 by (symmetry; tauto).
          tauto.
        * unfold is_null_SGBA; simpl.
          subst e.
          replace (src g5' (x0, R)) with x0 by (symmetry; tauto).
          tauto.
        * pose proof @ma' _ _ x1.
          pose proof @valid_graph' _ _ _ _ _ _ H16.
          unfold weak_valid in H17.
          simpl in H17.
          specialize (H17 e).
          rewrite !Intersection_spec in H17.
          specialize (H17 ltac:(tauto)).
          tauto.
      - intros.
        pose proof @ma' _ _ x1.
        pose proof @valid_not_null' _ _ _ _ _ _ H15.
        specialize (H16 x2).
        simpl in H16.
        rewrite Intersection_spec in H16.
        destruct (classic (x0 = x2)); [subst x2 |]; tauto.
    + assert (FiniteGraph
           (gpredicate_sub_labeledgraph (fun v : addr => x0 = v)
              (fun e : addr * LR => In e ((x0, L) :: (x0, R) :: nil)) g5')).
      {
        constructor; simpl.
        - exists (x0 :: nil).
          split; [repeat constructor; intros [] |].
          intros.
          rewrite Intersection_spec.
          split; intros.
          * destruct H13 as [|[]].
            subst x2.
            tauto.
          * left.
            tauto.
        - exists ((x0, L) :: (x0, R) :: nil).
          split; [repeat constructor; [intros [| []]; congruence | intros []] |].
          intros.
          rewrite Intersection_spec.
          split; intros.
          * destruct H13 as [| [| []]];
            subst x2; tauto.
          * simpl. tauto.
      }
      apply (@fin' _ _) in x1.
      pose proof fun H H0 => finite_graph_join g5' _ _ (fun _ => True) _ _ (fun _ => True) H H0 x1 X.
      spec X0.
    {
      split.
      + intros; tauto.
      + intros; tauto.
    }
    spec X0.
    {
      split.
      + intros; tauto.
      + intros; tauto.
    }
    pose proof @gpredicate_sub_labeledgraph_equiv _ _ _ _ _ _ _ g5' (fun _ => True) (vvalid g5') (fun _ => True) (evalid g5').
    spec H13.
      { rewrite Same_set_spec; intro; rewrite !Intersection_spec; tauto. }
    spec H13.
      { rewrite Same_set_spec; intro; rewrite !Intersection_spec; tauto. }
    pose proof finite_graph_si _ _ (proj1 H13); clear H13.
    pose proof @gpredicate_sub_labeledgraph_self _ _ _ _ _ _ _ g5'.
    pose proof finite_graph_si _ _ (proj1 H13); clear H13.
    apply X2, X1, X0.
  }
  apply (exp_right (Build_GeneralGraph _ _ _ _ (labeledgraph_vgen g5' x0 null) X)); clear x1.
  apply andp_right.
  + apply prop_right.
    split; auto.
    rewrite <- H1; symmetry; tauto.
  + match goal with
    | |- _ |-- _ ?A => change A with (labeledgraph_vgen g5' x0 null)
    end.
    replace (vertices_at (Intersection addr (vvalid g5') (fun v : addr => x0 <> v)) g5')
      with (vertices_at (Intersection addr (vvalid g5') (fun v : addr => x0 <> v)) (LGraph_SGraph (labeledgraph_vgen g5' x0 null))).
    2: {
       apply vertices_at_vertices_identical.
       rewrite (update_irr _ g5' x0) by (rewrite Intersection_spec; tauto).
       apply (GSG_VGenPreserve (Intersection addr (vvalid g5') (fun v : addr => x0 <> v)) g5').
       + reflexivity.
       + unfold Included, Ensembles.In; intro; rewrite Intersection_spec.
         intros [? _]. apply (vvalid_vguard' (Build_GeneralGraph _ _ _ _ g5' X)), H13.
       + unfold Included, Ensembles.In; intro; rewrite Intersection_spec.
         intros [? _]. apply (vvalid_vguard' (Build_GeneralGraph _ _ _ _ g5' X)), H13.
    }
    change (vvalid g5') with (vvalid (labeledgraph_vgen g5' x0 null)).
    apply derives_refl', vertices_at_sepcon_1x.
    - apply Prop_join_comm.
      rewrite <- copy_vvalid_weak_eq; [apply Ensemble_join_Intersection_Complement | .. | exact H12].
      * unfold Included, Ensembles.In; intros; subst; tauto.
      * intros; tauto.
      * right; symmetry; tauto.
    - change (vgamma (Graph_PointwiseGraph (labeledgraph_vgen g5' x0 null)) x0)
        with (vgamma (LGraph_SGraph (labeledgraph_vgen g5' x0 null)) x0).
      simpl.
      unfold update_vlabel. rewrite if_true by reflexivity.
      repeat f_equal; tauto.
Qed.

End PointwiseGraph_Copy_Bi.


(* begin hide *)
(**********************************************************************)
(* Equations                                                          *)
(* Copyright (c) 2009-2021 Matthieu Sozeau <matthieu.sozeau@inria.fr> *)
(**********************************************************************)
(* This file is distributed under the terms of the                    *)
(* GNU Lesser General Public License Version 2.1                      *)
(**********************************************************************)
(* end hide *)
(** * Definitional interpreter for STLC extended with references

  This is a port of the first part of "Intrinsically-Typed Definitional
  Interpreters for Imperative Languages", Poulsen, Rouvoet, Tolmach,
  Krebbers and Visser. POPL'18.

  It uses well-typed and well-scoped syntax and a monad indexed over an
  indexed set of stores to define an interpreter for an imperative
  programming language.

  This showcases the use of dependent pattern-matching and
  pattern-matching lambdas in Equations. We implement a variant where
  store extension is resolved using type class resolution as well as the
  dependent-passing style version. *)

Require Import Program.Basics Program.Tactics.
Require Import Coq.Vectors.VectorDef.
Require Import List.
Import ListNotations.
Require Import Utf8.
From Equations Require Import Equations.

Set Warnings "-notation-overridden".
(** The Σ notation of equations clashes with the Σ's used below,
    so we redefine the Σ notation using ∃ instead.
 *)

Notation "'∃' x .. y , P" := (sigma (fun x => .. (sigma (fun y => P)) ..))
  (at level 200, x binder, y binder, right associativity,
  format "'[  ' '[  ' ∃  x  ..  y ']' ,  '/' P ']'") : type_scope.

Notation "( x , .. , y , z )" :=
  (@sigmaI _ _ x .. (@sigmaI _ _ y z) ..)
      (right associativity, at level 0,
       format "( x ,  .. ,  y ,  z )") : equations_scope.

Notation " x .1 " := (pr1 x) (at level 3, format "x .1") : equations_scope.
Notation " x .2 " := (pr2 x) (at level 3, format "x .2") : equations_scope.

Local Open Scope equations_scope.

Set Equations Transparent.

(** [t] is just [Vector.t] here. *)
Derive Signature NoConfusion NoConfusionHom for t.

(** Types include unit, bool, function types and references *)
Inductive Ty : Set :=
| unit : Ty
| bool : Ty
| arrow (t u : Ty) : Ty
| ref : Ty -> Ty.

Derive NoConfusion for Ty.

Infix "⇒" := arrow (at level 80).

Definition Ctx := list Ty.

Reserved Notation " x ∈ s " (at level 70, s at level 10).

#[universes(template)]
Inductive In {A} (x : A) : list A -> Type :=
| here {xs} : x ∈ (x :: xs)
| there {y xs} : x ∈ xs -> x ∈ (y :: xs)
where " x ∈ s " := (In x s).
Derive Signature NoConfusion for In.

Arguments here {A x xs}.
Arguments there {A x y xs} _.

Inductive Expr : Ctx -> Ty -> Set :=
| tt {Γ} : Expr Γ unit
| true {Γ} : Expr Γ bool
| false {Γ} : Expr Γ bool
| ite {Γ t} : Expr Γ bool -> Expr Γ t -> Expr Γ t -> Expr Γ t
| var {Γ} {t} : In t Γ -> Expr Γ t
| abs {Γ} {t u} : Expr (t :: Γ) u -> Expr Γ (t ⇒ u)
| app {Γ} {t u} : Expr Γ (t ⇒ u) -> Expr Γ t -> Expr Γ u
| new {Γ t} : Expr Γ t -> Expr Γ (ref t)
| deref {Γ t} : Expr Γ (ref t) -> Expr Γ t
| assign {Γ t} : Expr Γ (ref t) -> Expr Γ t -> Expr Γ unit.

(** We derive both [NoConfusion] and [NoConfusionHom] principles here, the later
    allows to simplify pattern-matching problems on [Expr] which would otherwise
    require K. It relies on an inversion analysis of every constructor, showing
    that the context and type indexes in the conclusions of every constructor
    are forced arguments. *)
Derive Signature NoConfusion NoConfusionHom for Expr.

#[universes(template)]
Inductive All {A} (P : A -> Type) : list A -> Type :=
| all_nil : All P []
| all_cons {x xs} : P x -> All P xs -> All P (x :: xs).
Arguments all_nil {A} {P}.
Arguments all_cons {A P x xs} _ _.
Derive Signature NoConfusion NoConfusionHom for All.

Section MapAll.
  Context {A} {P Q : A -> Type} (f : forall x, P x -> Q x).

  Equations map_all {l : list A} : All P l -> All Q l :=
   | all_nil := all_nil
   | all_cons p ps := all_cons (f _ p) (map_all ps).

  Equations map_all_in {l : list A} (f : forall x, x ∈ l -> P x -> Q x) : All P l -> All Q l :=
    | f, all_nil := all_nil
    | f,  all_cons p ps := all_cons (f _ here p) (map_all_in (fun x inl => f x (there inl)) ps).
End MapAll.

Definition StoreTy := list Ty.

Inductive Val : Ty -> StoreTy -> Set :=
| val_unit {Σ} : Val unit Σ
| val_true {Σ} : Val bool Σ
| val_false {Σ} : Val bool Σ
| val_closure {Σ Γ t u} : Expr (t :: Γ) u -> All (fun t => Val t Σ) Γ -> Val (t ⇒ u) Σ
| val_loc {Σ t} : t ∈ Σ -> Val (ref t) Σ.

Derive Signature NoConfusion NoConfusionHom for Val.

Definition Env (Γ : Ctx) (Σ : StoreTy) : Set := All (fun t => Val t Σ) Γ.

Definition Store (Σ : StoreTy) := All (fun t => Val t Σ) Σ.

Equations lookup : forall {A P xs} {x : A}, All P xs -> x ∈ xs -> P x :=
  lookup (all_cons p _) here := p;
  lookup (all_cons _ ps) (there ins) := lookup ps ins.

Equations update : forall {A P xs} {x : A}, All P xs -> x ∈ xs -> P x -> All P xs :=
  update (all_cons p ps) here        p' := all_cons p' ps;
  update (all_cons p ps) (there ins) p' := all_cons p (update ps ins p').

Equations lookup_store {Σ t} : t ∈ Σ -> Store Σ -> Val t Σ :=
  lookup_store l σ := lookup σ l.

Equations update_store {Σ t} : t ∈ Σ -> Val t Σ -> Store Σ -> Store Σ :=
  update_store l v σ := update σ l v.

Definition store_incl (Σ Σ' : StoreTy) := sigma (fun Σ'' => Σ' = Σ'' ++ Σ).
Infix "⊑" := store_incl (at level 10).

Equations app_assoc {A} (x y z : list A) : x ++ y ++ z = (x ++ y) ++ z :=
  app_assoc nil y z := eq_refl;
  app_assoc (cons x xs) y z := f_equal (cons x) (app_assoc xs y z).

Section StoreIncl.
  Equations pres_in {Σ Σ'} (incl : Σ ⊑ Σ') t (p : t ∈ Σ) : t ∈ Σ' :=
    pres_in (Σ'', eq_refl) t p := aux Σ''
       where aux Σ'' : t ∈ (Σ'' ++ Σ) :=
       aux nil := p;
       aux (cons ty tys) := there (aux tys).

  Equations refl_incl {Σ} : Σ ⊑ Σ := refl_incl := ([], eq_refl).

  Equations trans_incl {Σ Σ' Σ''} (incl : Σ ⊑ Σ') (incl' : Σ' ⊑ Σ'') : Σ ⊑ Σ'' :=
    trans_incl (p, eq_refl) (q, eq_refl) := (q ++ p, app_assoc _ _ _).

  Equations store_ext_incl {Σ t} : Σ ⊑ (t :: Σ) :=
    store_ext_incl := ([t], eq_refl).

  Context {Σ Σ'} (incl : Σ ⊑ Σ').

  Equations weaken_val {t} (v : Val t Σ) : Val t Σ' := {
   weaken_val (@val_unit ?(Σ)) := val_unit;
   weaken_val val_true := val_true;
   weaken_val val_false := val_false;
   weaken_val (val_closure b e) := val_closure b (weaken_vals e);
   weaken_val (val_loc H) := val_loc (pres_in incl _ H) }
  where weaken_vals {l} (a : All (fun t => Val t Σ) l) : All (fun t => Val t Σ') l :=
  weaken_vals all_nil := all_nil;
  weaken_vals (all_cons p ps) := all_cons (weaken_val p) (weaken_vals ps).

  Equations weakenv_vals {l} a : @weaken_vals l a = map_all (fun t v => weaken_val v) a :=
    weakenv_vals all_nil := eq_refl;
    weakenv_vals (all_cons p ps) := f_equal (all_cons (weaken_val p)) (weakenv_vals ps).

  Definition weaken_env {Γ} (v : Env Γ Σ) : Env Γ Σ' := map_all (@weaken_val) v.

End StoreIncl.

Infix "⊚" := trans_incl (at level 10).

Equations M : forall (Γ : Ctx) (P : StoreTy -> Type) (Σ : StoreTy), Type :=
  M Γ P Σ := forall (E : Env Γ Σ) (μ : Store Σ), option (∃ Σ' (μ' : Store Σ') (_ : P Σ'), Σ ⊑ Σ').

Equations bind {Σ Γ} {P Q : StoreTy -> Type} (f : M Γ P Σ) (g : ∀ {Σ'}, P Σ' -> M Γ Q Σ') : M Γ Q Σ :=
  bind f g E μ with f E μ :=
     | None := None
     | Some (Σ', μ', x, ext) with g _ x (weaken_env ext E) μ' :=
          | None := None;
          | Some (_, μ'', y, ext') := Some (_, μ'', y, ext ⊚ ext').

Infix ">>=" := bind (at level 20, left associativity).

Definition transp_op {Γ Σ P} (x : Store Σ -> P Σ) : M Γ P Σ :=
  fun E μ => Some (Σ, μ, x μ, refl_incl).

Equations ret : ∀ {Γ Σ P}, P Σ → M Γ P Σ :=
  ret (Σ:=Σ) a E μ := Some (Σ, μ, a, refl_incl).

Equations getEnv : ∀ {Γ Σ}, M Γ (Env Γ) Σ :=
  getEnv (Σ:=Σ) E μ := Some (Σ, μ, E, refl_incl).

Equations usingEnv {Γ Γ' Σ P} (E : Env Γ Σ) (m : M Γ P Σ) : M Γ' P Σ :=
  usingEnv E m E' μ := m E μ.

Equations timeout : ∀ {Γ Σ P}, M Γ P Σ :=
  timeout _ _ := None.

Section StoreOps.
  Context {Σ : StoreTy} {Γ : Ctx} {t : Ty}.

  Equations storeM (v : Val t Σ) : M Γ (Val (ref t)) Σ :=
    storeM v E μ :=
      let v : Val t (t :: Σ) := weaken_val store_ext_incl v in
      let μ' := map_all (fun t' => weaken_val store_ext_incl) μ in
      Some (t :: Σ, all_cons v μ', val_loc here, store_ext_incl).

  Equations derefM (l : t ∈ Σ) : M Γ (Val t) Σ :=
    derefM l := transp_op (lookup_store l).

  Equations updateM (l : t ∈ Σ) (v : Val t Σ) : M Γ (Val unit) Σ :=
    updateM l v E μ := Some (Σ, update_store l v μ, val_unit, refl_incl).
End StoreOps.

Reserved Notation "P ⊛ Q" (at level 10).

Inductive storepred_prod (P Q : StoreTy -> Type) : StoreTy -> Type :=
  | storepred_pair {Σ} : P Σ -> Q Σ -> (P ⊛ Q) Σ
where "P ⊛ Q" := (storepred_prod P Q).
Arguments storepred_pair {P Q Σ}.

Class Weakenable (P : StoreTy -> Type) : Type :=
  weaken : forall {Σ Σ'}, Σ ⊑ Σ' -> P Σ -> P Σ'.

#[local] Instance val_weaken {t} : Weakenable (Val t) := fun Σ Σ' incl => weaken_val incl.
#[local] Instance env_weaken {Γ} : Weakenable (Env Γ) := fun Σ Σ' incl => weaken_env incl.
#[local] Instance loc_weaken (t : Ty) : Weakenable (In t) := fun Σ Σ' incl => pres_in incl t.

Class IsIncludedOnce (Σ Σ' : StoreTy) : Type := is_included_once : Σ ⊑ Σ'.
#[local] Hint Mode IsIncludedOnce + + : typeclass_instances.

#[local] Instance IsIncludedOnce_ext {T} Σ : IsIncludedOnce Σ (T :: Σ) := store_ext_incl.

Class IsIncluded (Σ Σ' : StoreTy) : Type := is_included : Σ ⊑ Σ'.
#[local] Hint Mode IsIncluded + + : typeclass_instances.

#[local] Instance IsIncluded_refl Σ : IsIncluded Σ Σ := refl_incl.
#[local] Instance IsIncluded_trans Σ Σ' Σ'' : IsIncludedOnce Σ Σ' -> IsIncluded Σ' Σ'' -> IsIncluded Σ Σ'' :=
  fun H H' => trans_incl H H'.

Equations wk {Σ Σ' P} {W : Weakenable P} (p : P Σ) {incl : IsIncluded Σ Σ'} : P Σ' :=
  wk p := weaken incl p.

Equations bind_ext {Σ Γ} {P Q : StoreTy -> Type} (f : M Γ P Σ) (g : ∀ {Σ'} `{IsIncluded Σ Σ'}, P Σ' -> M Γ Q Σ') : M Γ Q Σ :=
  bind_ext f g E μ with f E μ :=
    { | None := None;
      | Some (Σ', μ', x, ext) with g _ ext x (weaken_env ext E) μ' :=
          { | None := None;
            | Some (_, μ'', y, ext') := Some (_, μ'', y, ext ⊚ ext') } }.

Infix ">>='" := bind_ext (at level 20, left associativity).

Equations eval_ext (n : nat) {Γ Σ t} (e : Expr Γ t) : M Γ (Val t) Σ :=
  | 0, _                := timeout
  | S k, tt           := ret val_unit
  | S k, true         := ret val_true
  | S k, false        := ret val_false
  | S k, ite b tr fa    := eval_ext k b >>=' λ{ | _ | ext | val_true => eval_ext k tr;
                                                      | _ | ext | val_false => eval_ext k fa }

  | S k, var x        := getEnv >>=' fun {Σ ext} E => ret (lookup E x)
  | S k, abs x        := getEnv >>=' fun {Σ ext} E => ret (val_closure x E)
  | S k, @app Γ A B e1 e2 :=
      eval_ext k e1 >>=' λ{ | _ | ext | val_closure e' E =>
      eval_ext k e2 >>=' fun {Σ' ext'} v => usingEnv (all_cons v (wk (P:=Env _) E)) (eval_ext k e')}
  | S k, new e      := eval_ext k e >>=' fun {Σ ext} v => storeM v
  | S k, deref l    := eval_ext k l >>=' λ{ | _ | ext | val_loc l' => derefM l' }
  | S k, assign l e := eval_ext k l >>=' λ{ | _ | ext | val_loc l' =>
                                eval_ext k e >>=' λ{ | _ | ext' | v => updateM (wk l') (wk v) }}.

Equations strength {Σ Γ} {P Q : StoreTy -> Type} {w : Weakenable Q} (m : M Γ P Σ) (q : Q Σ) : M Γ (P ⊛ Q) Σ :=
  strength m q E μ with m E μ => {
    | None => None
    | Some (Σ', μ', p, ext) => Some (Σ', μ', storepred_pair p (weaken ext q), ext) }.

Infix "^" := strength.

(* Issue: improve pattern matching lambda to have implicit arguments implicit.
   Hard because Coq does not keep the implicit status of bind's [g] argument. *)

Equations eval (n : nat) {Γ Σ t} (e : Expr Γ t) : M Γ (Val t) Σ :=
  eval 0 _                := timeout;
  eval (S k) tt           := ret val_unit;
  eval (S k) true         := ret val_true;
  eval (S k) false        := ret val_false;
  eval (S k) (ite b tr fa)  := eval k b >>= λ{ | _ | val_true => eval k tr;
                                             | _ | val_false => eval k fa };

  eval (S k) (var x)      := getEnv >>= fun Σ E => ret (lookup E x);
  eval (S k) (abs x)      := getEnv >>= fun Σ E => ret (val_closure x E);
  eval (S k) (app e1 e2) :=
      eval k e1 >>= λ{ | _ | val_closure e' E =>
                             (eval k e2 ^ E) >>= fun Σ' '(storepred_pair v E) => usingEnv (all_cons v E) (eval k e')};
  eval (S k) (new e)      := eval k e >>= fun Σ v => storeM v;
  eval (S k) (deref l)    := eval k l >>= λ{ | _ | val_loc l' => derefM l' };
  eval (S k) (assign l e) := eval k l >>= λ{ | _ | val_loc l' =>
                             (eval k e ^ l') >>= λ{ | _ | storepred_pair v l'' => updateM l'' v }}.

Definition idu : Expr [] (unit ⇒ unit) :=
  abs (var here).

Definition idapp : Expr [] unit := app idu tt.

(** All definitions are axiom-free (and actually not even dependent on a provable UIP instance), so
 everything computes. *)
Eval vm_compute in eval 100 idapp all_nil all_nil.

Definition neg : Expr [] (bool ⇒ bool) :=
  abs (ite (var here) false true).

Definition letref {t u} (v : Expr [] t) (b : Expr [ref t] u) : Expr [] u :=
  app (abs b) (new v).
Obligation Tactic := idtac.

Equations in_app_weaken {Σ Σ' Σ'' : StoreTy} {t} (p : t ∈ (Σ ++ Σ'')) : t ∈ (Σ ++ Σ' ++ Σ'') by struct Σ :=
  in_app_weaken (Σ:=nil) p := pres_in (Σ', eq_refl) t p;
  in_app_weaken (Σ:=cons _ tys) here := here;
  in_app_weaken (Σ:=cons _ tys) (there p) := there (in_app_weaken p).

Equations pres_in_prefix {Σ Σ' Σ''} (incl : Σ' ⊑ Σ'') {t} (p : t ∈ (Σ ++ Σ')) : t ∈ (Σ ++ Σ'') :=
  pres_in_prefix (Σ'', eq_refl) p := in_app_weaken p.

(** [Equations?] enters refinement mode, which can be used to solve the case of variables in proof mode. *)
Equations? weaken_expr {Γ Γ' t u} (e1 : Expr (Γ ++ Γ') t) : Expr (Γ ++ u :: Γ') t :=
  weaken_expr tt              := tt;
  weaken_expr true            := true;
  weaken_expr false           := false;
  weaken_expr (ite b tr fa)   := ite (weaken_expr b) (weaken_expr tr) (weaken_expr fa);
  weaken_expr (var (t:=ty) x) := var _;
  weaken_expr (abs (t:=t) x)  := abs (weaken_expr (Γ := t :: Γ) x);
  weaken_expr (app e1 e2)     := app (weaken_expr e1) (weaken_expr e2);
  weaken_expr (new e)         := new (weaken_expr e);
  weaken_expr (deref l)       := deref (weaken_expr l);
  weaken_expr (assign l e)    := assign (weaken_expr l) (weaken_expr e).
Proof.
  clear weaken_expr. apply (pres_in_prefix (Σ' := Γ') ([u], eq_refl) x).
Defined.

Definition seq {Γ u} (e1 : Expr Γ unit) (e2 : Expr Γ u) : Expr Γ u :=
  app (abs (weaken_expr (Γ := []) e2)) e1.

(* let x = ref true in
   x := false; !x *)

Definition letupdate : Expr [] bool :=
  letref true (seq (assign (var here) false) (deref (var here))).

Eval vm_compute in eval 100 letupdate all_nil all_nil.
(** [[
   = Some ([bool], all_cons val_false all_nil, val_false, [bool], eq_refl)
   : option (∃ (Σ' : StoreTy) (_ : Store Σ') (_ : Val bool Σ'), [] ⊑ Σ')
   ]]
*)


(**
CoLoR, a Coq library on rewriting and termination.
See the COPYRIGHTS and LICENSE files.

- Adam Koprowski, 2006-04-27

The beta-reduction relation of simply typed lambda-calculus
is introduced in this file.
*)

Set Implicit Arguments.

From CoLoR Require Import RelExtras ListExtras TermsRed TermsConv LogicUtil.
From Coq Require Import Setoid Lia.

Module TermsBeta (Sig : TermsSig.Signature).

  Module Export TR := TermsRed.TermsRed Sig.

  Definition beta_subst : forall M (Mapp: isApp M)
    (MLabs: isAbs (appBodyL Mapp)),
    correct_subst (absBody MLabs) {x/(lift (appBodyR Mapp) 1)}.

  Proof.
    intros M Mapp MLabs.
    apply one_var_subst_correct.
    rewrite lift_type.
    rewrite absBody_env.
    unfold decl, VarD; simpl.
    intros A' eqT.
    inversion eqT.
    destruct M as [EM PtM TM TypM].
    destruct TypM; try contr.
    rewrite (@abs_type (appBodyL Mapp) MLabs A B); trivial.
    rewrite lift_env.
    rewrite absBody_env.
    unfold liftedEnv, finalSeg; simpl.
    rewrite initialSeg_full; try solve [auto with datatypes | lia].
    unfold decl; apply env_comp_cons.
    rewrite appBodyL_env.
    rewrite appBodyR_env.
    apply env_comp_refl.
    auto.
  Defined.

  Lemma beta_env : forall M (Mapp: isApp M) (MLabs: isAbs (appBodyL Mapp)),
    env (subst (beta_subst M Mapp MLabs)) = None :: env M.

  Proof.
    intros.
    rewrite subst_env; simpl.
    unfold subst_ran; simpl.
    rewrite lift_env; simpl.
    unfold liftedEnv; simpl.
    rewrite absBody_env; simpl.
    rewrite appBodyL_env; simpl.
    rewrite finalSeg_full; simpl.
    rewrite appBodyR_env; simpl.
    rewrite env_sub_empty.
    rewrite env_sum_double; trivial.
  Qed.

  Lemma beta_lowering : forall M (Mapp: isApp M) (MLabs: isAbs (appBodyL Mapp)),
    env (subst (beta_subst M Mapp MLabs)) |= 0 :! .

  Proof. intros. rewrite beta_env. right; trivial. Qed.

  Inductive BetaStep : relation Term :=
  | Beta: forall M (Mapp: isApp M) (MLabs: isAbs (appBodyL Mapp)),
      BetaStep M
      (lower (subst (beta_subst M Mapp MLabs)) (beta_lowering M Mapp MLabs)).

  Definition BetaReduction := Reduction BetaStep.

  Notation "M -b-> N" := (BetaReduction M N) (at level 30).

  Lemma beta_type: forall M (Mapp: isApp M) (MLabs: isAbs (appBodyL Mapp)),
    absType MLabs = type (appBodyR Mapp).

  Proof.
    intros.
    destruct M as [??? typingM].
    destruct typingM; try contr.
    assert (type (appBodyL Mapp) = A --> B).
    trivial.
    rewrite (abs_type (appBodyL Mapp) MLabs H); trivial.
  Qed.

  Lemma beta_notFunS: forall M N, M -b-> N -> isFunS M -> False.

  Proof.
    intros M N MN.
    term_inv M.
    unfold Tr in MN.
    inversion MN; term_inv M.
    inversion H; try_solve.
  Qed.

  Lemma beta_direct_funApp : forall M (Mapp: isApp M)
    (MLabs: isAbs (appBodyL Mapp)), isFunS (appHead M) -> False.

  Proof.
    intros M Mapp MLabs Mhead.
    absurd (isFunS (appHead M)); trivial.
    rewrite (appHead_app M Mapp) in Mhead.
    assert (MLnotApp: ~isApp (appBodyL Mapp)).
    apply abs_isnot_app; trivial.
    rewrite (appHead_notApp (appBodyL Mapp) MLnotApp) in Mhead.
    exfalso. term_inv (appBodyL Mapp).
  Qed.

  Lemma app_beta_isapp : forall M N f,
    M -b-> N -> term (appHead M) = ^f -> isApp N.

  Proof.
    intro M; term_inv M.
     (* function symbol *)
    intros; exfalso.
    apply beta_notFunS with Tr N; trivial.
    unfold Tr; auto with terms.
     (* application *)
    intros N f MbN Mhead.
    inversion MbN; try solve [contr | trivial].
     (* direct beta step *)
    exfalso. inversion H.
    apply beta_direct_funApp with Tr I; eauto with terms.
  Qed.

  Lemma app_beta_headSymbol : forall M N f, M -b-> N -> term (appHead M) = ^f ->
    term (appHead N) = ^f.

  Proof.
    destruct M as [E Pt T TypM].
    induction TypM; simpl; intros N f' Nbeta Mhead; try discr;
      inversion Nbeta; try contr.
    inversion H; contr.
     (* 1) direct beta reduction (left applicant - abstraction) *)
    inversion H. exfalso.
    apply beta_direct_funApp with (buildT (TApp TypM1 TypM2)) Mapp0;
      eauto with terms.
     (* 2) beta reduction in left part of application *)
    term_inv N.
    unfold Tr.
    rewrite appHead_app_explicit.
    apply IHTypM1 with (N := @appBodyL (buildT (TApp T1 T2)) I).
    simpl; trivial.
    rewrite appHead_app_explicit in Mhead; trivial.
     (* 3) beta reduction in right part of application *)
    term_inv N.
    rewrite <- Mhead.
    unfold Tr.
    rewrite !appHead_app_explicit.
    congruence.
  Qed.

  Lemma app_beta_funS : forall M N,
    isFunS (appHead M) -> M -b-> N -> isFunS (appHead N).

  Proof.
    intros.
    destruct (funS_fun (appHead M) H) as [f Mf].
    apply funS_is_funS with f.
    apply (app_beta_headSymbol H0 Mf).
  Qed.

  Lemma app_beta_args : forall M N f,
    isApp M -> M -b-> N -> term (appHead M) = ^f ->
    exists l, exists el, isArg (fst el) M /\ isArg (snd el) N
      /\ fst el -b-> snd el /\
      appArgs M = fst l ++ fst el::snd l /\ appArgs N = fst l ++ snd el::snd l.

  Proof.
    destruct M as [E Pt T TypM].
    induction TypM; try solve [intros; inversion H].
    intros N f Mapp MbetaN Mhead.
    inversion MbetaN; try contr.
    inversion H. exfalso.
    apply beta_direct_funApp with (buildT (TApp TypM1 TypM2)) Mapp1;
      eauto with terms.
     (* -) beta in left argument *)
    simpl in *.
    rewrite (appHead_app (buildT (TApp TypM1 TypM2)) I) in Mhead;
      trivial.
    case (isApp_dec (buildT TypM1)).
    intro M1app.
     (*   - M = @(@(...), _) *)
    destruct (IHTypM1 (appBodyL Napp) f)
      as [[al ar] [[tl tr] [tlM [trN [tltr [Margs Nargs]]]]]];
      simpl in *; trivial.
    exists (al, ar ++ appBodyR Napp::nil); exists (tl, tr);
      repeat split; simpl; trivial.
    apply appArg_left with I; trivial.
    apply appArg_left with Napp; trivial.
    rewrite (appArgs_app (buildT (TApp TypM1 TypM2)) I); simpl.
    rewrite Margs; rewrite H0.
    rewrite <- ass_app; auto with datatypes.
    rewrite (appArgs_app N Napp); simpl.
    rewrite Nargs.
    rewrite <- ass_app; auto with datatypes.
     (*   - M = @(_, _) *)
    intro M1nApp; simpl in *.
    rewrite appHead_notApp in Mhead; simpl in Mhead. exfalso.
    apply beta_notFunS with (buildT TypM1) (appBodyL Napp);
      eauto with terms.
    trivial.
     (* -) beta in right argument *)
    term_inv N.
    exists (appArgs (buildT TypM1), nil(A:=Term)).
    exists (buildT TypM2, buildT T2); repeat split; simpl; trivial.
    apply appArg_right with I; trivial.
    apply appArg_right with I; trivial.
    rewrite appArgs_app with (buildT (TApp TypM1 TypM2)) I; trivial.
    rewrite appArgs_app with Tr I.
    rewrite H0; trivial.
  Qed.

  Lemma app_beta_args_eq : forall M N Q f,
    isApp M -> M -b-> N -> term (appHead M) = ^f ->
    isArg Q N -> (isArg Q M \/ (exists2 Mb, Mb -b-> Q & isArg Mb M)).

  Proof.
    intros M N Q f Mapp MbN Mhead QargN.
    destruct (app_beta_args Mapp MbN Mhead) as
      [[al ar] [[tl tr] [tlM [trN [tltr [Margs Nargs]]]]]];
      simpl in * .
    unfold isArg in QargN; rewrite Nargs in QargN.
    destruct (in_app_or QargN).
    left.
    unfold isArg; rewrite Margs; auto with datatypes.
    inversion H.
    right; exists tl.
    rewrite <- H0; trivial.
    unfold isArg; rewrite Margs; auto with datatypes.
    left.
    unfold isArg; rewrite Margs; auto with datatypes.
  Qed.

  Lemma beta_funS_normal : forall M N, isFunS M -> ~(M -b-> N).

  Proof. intros M N Mf MN. inversion MN; inversion H; term_inv M. Qed.

  Lemma beta_var_normal : forall M N, isVar M -> ~(M -b-> N).

  Proof. intros M N Mvar MN. inversion MN; inversion H; term_inv M. Qed.

  Lemma betaStep_env_preserving : forall M N, BetaStep M N -> env M = env N.

  Proof.
    intros.
    inversion H.
    rewrite lower_env.
    rewrite beta_env.
    unfold loweredEnv, finalSeg; simpl.
    rewrite initialSeg_full; trivial.
    lia.
  Qed.

  Lemma beta_env_preserving : forall M N, M -b-> N -> env M = env N.

  Proof.
    intros.
    apply Red_env_preserving with BetaStep; trivial.
    apply betaStep_env_preserving.
  Qed.

  Lemma betaStep_type_preserving : forall M N, BetaStep M N -> type M = type N.

  Proof.
    intros.
    inversion H.
    rewrite lower_type.
    rewrite subst_type.
    destruct M as [ME MPt MT M].
    destruct M; try contr.
    assert (MlT: type (appBodyL Mapp0) = A --> B); [simpl; trivial | idtac].
    rewrite (absBody_type (appBodyL Mapp0) MLabs MlT); simpl; trivial.
  Qed.

  Lemma subject_reduction : forall M N, M -b-> N -> type M = type N.

  Proof.
    intros.
    apply Red_type_preserving with BetaStep; trivial.
    apply betaStep_type_preserving.
  Qed.

  Lemma beta_monotonous : monotonous BetaReduction.

  Proof. unfold BetaReduction; apply red_monotonous. Qed.

  Lemma betaStep_conv_comp_aux : forall M M' N N' Q, M ~(Q) M' -> N ~(Q) N' ->
    BetaStep M N -> env M' = env N' -> BetaStep M' N'.

  Proof.
    intros M M' N N' Q MQM' NQN' MN M'N'env.
    inversion MN.
    assert (M'app: isApp M').
    assert (MM' : M ~ M') by (exists Q; trivial).
    rewrite <- MM'; trivial.
    assert (M'Labs: isAbs (appBodyL M'app)).
    setoid_replace (appBodyL M'app) with (appBodyL Mapp0); trivial.
    apply app_conv_app_left.
    sym; exists Q; trivial.
    replace N' with (lower (subst (beta_subst M' M'app M'Labs))
      (beta_lowering M' M'app M'Labs)).
    constructor.
    rewrite terms_lift_eq with (lower (subst (beta_subst M' M'app M'Labs))
      (beta_lowering M' M'app M'Labs)) N'; trivial.
    apply term_eq.
    autorewrite with terms datatypes using unfold liftedEnv, loweredEnv; simpl.
    rewrite M'N'env; trivial.
    rewrite prelift_prelower.
    autorewrite with terms.
    rewrite <- lift_term.
    apply (@presubst_singleton_conv_sim
      (term (absBody MLabs)) (term (absBody M'Labs))
      (lift (appBodyR Mapp0) 1) (lift (appBodyR M'app) 1) (envSubst_lift1 Q)
      (term (lift N 1)) (term (lift N' 1))
    ).
    destruct Q; simpl; trivial.
    assert (Conv: (absBody MLabs) ~(envSubst_lift1 Q) (absBody M'Labs)).
    apply abs_conv_absBody_aux.
    apply app_conv_app_left_aux; trivial.
    destruct Conv; trivial.
    apply terms_conv_conv_lift.
    apply app_conv_app_right_aux; trivial.
    assert (Conv: (lift N 1) ~(envSubst_lift1 Q) (lift N' 1)).
    apply terms_conv_conv_lift; trivial.
    destruct Conv; trivial.
    rewrite <- H0.
    rewrite prelift_prelower.
    autorewrite with terms using trivial.
  Qed.

  Lemma beta_conv_comp : forall M M' N N' Q,
    M ~(Q) M' -> N ~(Q) N' -> M -b-> N -> env M' = env N' -> M' -b-> N'.

  Proof.
    intros.
    unfold BetaReduction.
    apply red_conv_comp with M N Q; trivial.
    intros.
    apply betaStep_conv_comp_aux with M0 N0 Q0; trivial.
  Qed.

  Lemma subst_at0 : forall M G (MG: correct_subst M (None :: lift_subst G 1)),
    env M |= 0 :! -> env (subst MG) |= 0 :! .

  Proof.
    intros.
    rewrite subst_env.
    destruct (env M).
    rewrite subst_ran_cons_none.
    destruct (subst_empty_dec G); simpl.
    rewrite subst_ran_lifted_empty; trivial.
    rewrite subst_ran_lifted_ne; solve [trivial | constructor 2; trivial].
    destruct o.
    destruct H; try_solve.
    simpl.
    rewrite subst_ran_cons_none.
    destruct (subst_empty_dec G); simpl.
    rewrite subst_ran_lifted_empty; trivial.
    rewrite subst_ran_lifted_ne; solve [trivial | constructor 2; trivial].
  Qed.

  Lemma subst_envs_comp_cons : forall G,
    subst_envs_comp G -> subst_envs_comp (None :: G).

  Proof.
    intros.
    intros i j Ti Tj Gi Gj.
    destruct i; destruct j.
    try_solve.
    inversion Gi.
    inversion Gj.
    apply (H i j).
    inversion Gi; trivial.
    inversion Gj; trivial.
  Qed.

  Lemma correct_subst_lift : forall M N G (M0: env M |= 0 :!),
    correct_subst N G -> N = lower M M0 ->
    correct_subst M (None :: lift_subst G 1).

  Proof.
    intros ???? [envNG domNG ranNG] H.
    rewrite H in domNG.
    rewrite H in ranNG.
    rewrite lower_env in domNG.
    rewrite lower_env in ranNG.
    clear H.
    constructor.
    apply subst_envs_comp_cons.
    apply lifted_subst_envs_comp; trivial.
    destruct (env M).
    apply env_comp_empty.
    destruct o.
    destruct M0; try_solve.
    simpl.
    rewrite subst_dom_lifted.
    apply env_comp_cons; auto.
    unfold loweredEnv in domNG.
    simpl in domNG.
    rewrite finalSeg_cons in domNG; trivial.
    simpl.
    rewrite subst_ran_cons_none.
    rewrite subst_dom_lifted.
    destruct (subst_empty_dec G).
    rewrite subst_ran_lifted_empty; trivial.
    simpl; apply env_comp_sym; apply env_comp_empty.
    rewrite subst_ran_lifted_ne; trivial.
    simpl.
    destruct (env M).
    apply env_comp_empty.
    destruct o.
    destruct M0; try_solve.
    apply env_comp_cons; auto.
    unfold loweredEnv in ranNG.
    simpl in ranNG.
    rewrite finalSeg_cons in ranNG; trivial.
  Qed.

  Lemma lower_subst_aux : forall M G i, env M |= i :! ->
    presubst_aux (prelower_aux (term M) i) i (copy i None ++ G) =
    prelower_aux (presubst_aux (term M) i
      (copy i None ++ None :: lift_subst G 1)) i.

  Proof.
    destruct M as [E Pt TM M].
    induction M; intros G i Mi; unfold prelower, presubst; simpl.
     (* variable *)
    destruct (Compare_dec.le_gt_dec i x); simpl.
    destruct (eq_nat_dec i x).
     (*   - x = i *)
    rewrite e in Mi.
    exfalso; eapply varD_UD_absurd; eauto.
     (*   - x > i *)
    destruct x; simpl. lia.
    replace (copy i None ++ None :: lift_subst G 1) with
      ((None :: copy i None) ++ lift_subst G 1).
    simpl.
    repeat rewrite nth_app_right; rewrite copy_length; try lia.
    destruct (varSubst_dec G (x - i)) as [[T GT] | Gn].
    rewrite GT, (nth_lift_subst_s G 1 (x - i) GT), !lift_term, <- prelift_fold.
    apply prelower_prelift.
    set (w := var_notSubst_lift 1 Gn).
    inversion Gn; inversion w; rewrite H; rewrite H0; simpl;
      destruct (Compare_dec.le_gt_dec i (S x));
	solve [trivial | lia].
    rewrite <- list_app_first_last.
    rewrite <- copy_add; trivial.
    rewrite <- app_nil_end; trivial.
     (*   - x < i *)
    rewrite !nth_app_left, nth_copy_in.
    simpl.
    destruct (Compare_dec.le_gt_dec i x); trivial.
    lia.
    lia.
    rewrite copy_length; lia.
    rewrite copy_length; lia.
     (* function symbol *)
    trivial.
     (* abstraction *)
    set (w := IHM G (S i)).
    simpl in w.
    rewrite w; trivial.
     (* application *)
    rewrite IHM1; trivial.
    rewrite IHM2; trivial.
  Qed.

  Lemma lower_subst : forall M N G (M0: env M |= 0 :!) (MG: correct_subst N G)
    (MG': correct_subst M (None :: lift_subst G 1))
    (MG'0: env (subst MG') |= 0 :! := (subst_at0 G MG' M0)),
    N = lower M M0 -> subst MG = lower (subst MG') MG'0.

  Proof.
    intros.
    apply term_eq; autorewrite with terms; rewrite H; autorewrite with terms.

    destruct M as [envM ???].
    autorewrite with terms using simpl.
    unfold loweredEnv; simpl.
    destruct (subst_empty_dec G).
    destruct envM; simpl.
    autorewrite with terms; trivial.
    autorewrite with terms datatypes; trivial.
    destruct o; autorewrite with datatypes; trivial.
    destruct envM; simpl.
    autorewrite with datatypes terms.
    destruct (subst_ran G); trivial.
    destruct o; autorewrite with datatypes terms using simpl; trivial.

    unfold presubst, prelower.
    apply (lower_subst_aux M G M0).
  Qed.

  Lemma lower_eq : forall M N (M0: env M |= 0 :!) (N0: env N |= 0 :!), M = N ->
    lower M M0 = lower N N0.

  Proof.
    intros.
    apply term_eq.
    rewrite !lower_env; rewrite H; trivial.
    rewrite !lower_term; rewrite H; trivial.
  Qed.

  Lemma subst_single_eq : forall M M' P P' (MP: correct_subst M {x/P})
    (MP': correct_subst M' {x/P'}), M = M' -> P = P' -> subst MP = subst MP'.

  Proof.
    intros.
    apply term_eq.
    rewrite !subst_env, H, H0; trivial.
    rewrite !subst_term, H, H0; trivial.
  Qed.

  Lemma double_subst_aux : forall M P G i
    (PG: correct_subst P (None :: lift_subst G 1)),
    presubst_aux (presubst_aux M i (copy i None ++ {x/P}))
    i (copy (S i) None ++ lift_subst G 1) =
    presubst_aux (presubst_aux M i (copy (S i) None ++ lift_subst G 1))
    i (copy i None ++ {x/subst PG}).

  Proof.
    induction M; unfold presubst; intros; simpl.

    destruct (Compare_dec.gt_eq_gt_dec i x) as [[x_gt_i | x_eq_i] | x_lt_i].
    rewrite nth_beyond; autorewrite with terms datatypes; simpl; try lia.
    replace (None :: copy i None ++ lift_subst G 1) with
      (copy (S i) None ++ lift_subst G 1); trivial.
    rewrite nth_app_right; autorewrite with terms datatypes; try lia.
    destruct (varSubst_dec G (x - S i)) as [[T GT] | Gn].
    rewrite (var_subst_lift 1 GT), !lift_term, <- prelift_fold,
      presubst_beyond; trivial.
    autorewrite with datatypes using simpl; try lia.
    destruct (var_notSubst_lift 1 Gn); rewrite H;
      replace (%x) with (prelift (%0) x); trivial;
      rewrite presubst_beyond; solve
	[ trivial
	| autorewrite with datatypes using simpl; try lia
	].

    rewrite x_eq_i.
    rewrite nth_app_right; autorewrite with datatypes using try lia.
    rewrite <- Minus.minus_n_n; simpl.
    replace (None :: copy x None ++ lift_subst G 1) with
      (copy (S x) None ++ lift_subst G 1); trivial.
    rewrite nth_app_left; autorewrite with datatypes terms using simpl;
      try lia.
    rewrite nth_app_right; autorewrite with datatypes terms using simpl;
      try lia.
    rewrite <- Minus.minus_n_n; simpl.
    autorewrite with terms.
    rewrite <- presubst_prelift_comm; simpl.
    rewrite subst_lift_subst; simpl.
    rewrite lift_subst_distr.
    rewrite lift_empty_subst.
    rewrite <- copy_add; trivial.

    replace (None :: copy i None ++ lift_subst G 1) with
      (copy (S i) None ++ lift_subst G 1); trivial.
    rewrite !nth_app_left; autorewrite with terms datatypes using simpl;
      try lia.
    replace (None :: copy i None ++ lift_subst G 1) with
      (copy (S i) None ++ lift_subst G 1); trivial.
    replace (None :: copy i (None (A:=Term)))
      with (copy (S i) (None (A:=Term))); trivial.
    rewrite !nth_app_left; autorewrite with terms datatypes using simpl;
      try lia.
    rewrite nth_app_left; autorewrite with terms datatypes using trivial.

    trivial.
    replace (None :: copy i None ++ {x/P}) with
      (copy (S i) None ++ {x/P}); trivial.
    replace (None :: None :: copy i None ++ lift_subst G 1) with
      (copy (S (S i)) None ++ lift_subst G 1); trivial.
    replace (None :: copy i None ++ {x/subst PG}) with
      (copy (S i) None ++ {x/subst PG}); trivial.
    rewrite (IHM P G (S i) PG); trivial.
    replace (None :: copy i None ++ lift_subst G 1) with
      (copy (S i) None ++ lift_subst G 1); trivial.
    rewrite <- IHM1.
    rewrite <- IHM2.
    trivial.
  Qed.

  Lemma double_subst : forall M G P (MP: correct_subst M {x/P})
    (MPG: correct_subst (subst MP) (None :: lift_subst G 1))
    (MG: correct_subst M (None :: lift_subst G 1))
    (PG: correct_subst P (None :: lift_subst G 1))
    (MGP: correct_subst (subst MG) {x/subst PG}), subst MPG = subst MGP.

  Proof.
    intros.
    apply term_eq.

    autorewrite with terms.
    cut (tail (env M) [+] tail (env P) [-] subst_dom G [+] subst_ran G =
      tail (env M) [-] subst_dom G [+] subst_ran G [+]
      (tail (env P) [-] subst_dom G [+] subst_ran G)).
    destruct (subst_empty_dec G).
    (*SLOW*)destruct (env M); destruct (env P); try destruct o;
      try destruct o0; simpl; (autorewrite with terms using simpl); try_solve.
    (*VERY SLOW*)destruct (env M); destruct (env P); try destruct o;
      try destruct o0; simpl; (autorewrite with terms using simpl);
      try destruct (subst_ran G); try destruct (subst_dom G);
      try destruct e; try destruct o; try destruct o0; try_solve.
    rewrite env_sum_assoc.
    rewrite <- (env_sum_assoc (subst_ran G)).
    rewrite env_sum_remove_double.
    rewrite <- env_sum_assoc.
    rewrite env_sub_move; trivial.

    autorewrite with terms datatypes.
    unfold presubst.
    set (w := double_subst_aux (term M) G 0 PG).
    simpl in w; trivial.
  Qed.

  Lemma double_lift : forall M G
    (CS: correct_subst (lift M 1) (None :: lift_subst G 1))
    (CS': correct_subst M G), subst CS = lift (subst CS') 1.

  Proof.
    intros.
    apply term_eq.
    destruct (subst_empty_dec G);
      autorewrite with terms datatypes using unfold liftedEnv; simpl; trivial.
    autorewrite with terms.
    replace (None :: lift_subst G 1) with (copy (S 0) None ++ lift_subst G 1);
    trivial.
    apply presubst_prelift_comm.
  Qed.

  Lemma subst_on_beta : forall M (Mapp: isApp M) (MLabs: isAbs (appBodyL Mapp))
    G (CS: correct_subst M G)
    (CSin: correct_subst (absBody MLabs) (None :: lift_subst G 1))
    (CSapp: isApp (subst CS) := app_subst_app Mapp CS)
    (CSLabs: isAbs (appBodyL CSapp)),
    subst CSin = absBody CSLabs.

  Proof.
    intros; apply term_eq.

    assert (absType MLabs = absType CSLabs).
    apply type_eq_absType_eq.
    unfold CSapp; apply type_appBodyL_subst.
    destruct (subst_empty_dec G); autorewrite with terms using unfold decl;
      try_solve.

    autorewrite with terms datatypes using simpl.
    rewrite (absBody_term (appBodyL CSapp) CSLabs (A := absType MLabs)
      (Pt := presubst (term (absBody MLabs)) (None :: lift_subst G 1)));
      trivial.
    rewrite (appBodyL_term (subst CS) (PtL := \absType MLabs =>
      presubst (term (absBody MLabs)) (None::lift_subst G 1))
      (PtR := presubst (term (appBodyR Mapp)) G)); trivial.
    autorewrite with terms.
    rewrite (app_term M Mapp).
    rewrite (abs_term (appBodyL Mapp) MLabs).
    unfold presubst; simpl.
    rewrite subst_lift_subst; trivial.
  Qed.

  Lemma beta_lower_subst : forall M N G (Mapp: isApp M)
    (MLabs: isAbs (appBodyL Mapp))
    (MN: correct_subst M G) (NS: correct_subst N G)
    (MNS_app: isApp (subst MN) := app_subst_app Mapp MN)
    (MNS_Labs: isAbs (appBodyL MNS_app)),
    N = lower (subst (beta_subst M Mapp MLabs)) (beta_lowering M Mapp MLabs) ->
    subst NS = lower (subst (beta_subst (subst MN) MNS_app MNS_Labs))
      (beta_lowering (subst MN) MNS_app MNS_Labs).

  Proof.
    intros.
    set (s0 := correct_subst_lift (subst (beta_subst M Mapp MLabs))
      (beta_lowering M Mapp MLabs) NS H).
    rewrite (lower_subst (beta_lowering M Mapp MLabs) NS s0 H).
    apply lower_eq.
    assert (s1: correct_subst (absBody MLabs) (None :: lift_subst G 1)).
    inversion MN; inversion NS; inversion s0; prove_correct_subst.
    assert
      (s2: correct_subst (lift (appBodyR Mapp) 1) (None :: lift_subst G 1)).
    inversion MN; inversion NS; inversion s0; prove_correct_subst.
    assert (s3: correct_subst (subst s1) {x/subst s2}).
    constructor.
    apply subst_envs_comp_single.
    assert (forall E, {x/type (appBodyR Mapp)} [<->] Some (absType MLabs) :: E).
    intro; apply env_comp_cons.
    auto with terms.
    left; rewrite beta_type; trivial.
    destruct (subst_empty_dec G); autorewrite with terms using simpl; auto.
    destruct (subst_empty_dec G);
      autorewrite with terms datatypes using simpl; auto with terms.
    rewrite (double_subst G (beta_subst M Mapp MLabs) s0 s1 s2 s3).
    apply term_eq.
    destruct (subst_empty_dec G);
      autorewrite with datatypes terms using simpl; trivial.
    autorewrite with datatypes terms using simpl.
    assert (Leq: presubst (term (absBody MLabs)) (None :: lift_subst G 1) =
      term (absBody MNS_Labs)).
    cut (term (subst s1) = term (absBody MNS_Labs)).
    autorewrite with terms.
    intro; rewrite H0; trivial.
    rewrite (subst_on_beta Mapp MLabs MN s1 MNS_Labs); trivial.
    assert (R'eq: subst (subst_appR_c Mapp MN) = appBodyR MNS_app).
    destruct (app_subst Mapp MN).
    rewrite <- H1.
    rewrite (app_proof_irr (subst MN) (app_subst_app Mapp MN) MNS_app); trivial.
    assert (Req: subst s2 = lift (appBodyR MNS_app) 1).
    rewrite (double_lift s2 (subst_appR_c Mapp MN)).
    rewrite R'eq; trivial.
    try_solve.
  Qed.

  Lemma betaStep_subst_stable : forall M N G (MS: correct_subst M G)
    (NS: correct_subst N G), BetaStep M N -> BetaStep (subst MS) (subst NS).

  Proof.
    intros M N G MS NS MN.
    inversion MN.
    set (MNS_app := app_subst_app Mapp0 MS).
    assert (MNS_Labs: isAbs (appBodyL MNS_app)).
    eapply abs_isAbs.
    assert (MS_term : term (subst MS) = presubst_aux (term (appBodyL Mapp0))
      0 G [presubst_aux (term (appBodyR Mapp0)) 0 G]).
    rewrite subst_term; term_inv M.
    rewrite (appBodyL_term (subst MS) MS_term).
    rewrite (abs_term (appBodyL Mapp0) MLabs).
    simpl; eauto.
    rewrite (beta_lower_subst Mapp0 MLabs MS NS MNS_Labs); auto.
    constructor.
  Qed.

  Lemma beta_subst_stable : forall M N G (MS: correct_subst M G)
    (NS: correct_subst N G), M -b-> N -> subst MS -b-> subst NS.

  Proof.
    destruct M as [E Pt T M]; induction M; intros.

     (* variable *)
    absurd (buildT (TVar v) -b-> N); trivial.
    apply beta_var_normal; simpl; trivial.

     (* function symbol *)
    absurd (buildT (TFun E f) -b-> N); trivial.
    apply beta_funS_normal; simpl; trivial.

     (* abstraction *)
    inversion H; try_solve.
    inversion H0; try_solve.
    clear Mabs.
    assert (Mabs: isAbs (buildT (TAbs M))).
    simpl; trivial.
    destruct (abs_subst Mabs MS) as [Ms_type Ms_body].
    destruct (abs_subst Nabs NS) as [Ns_type Ns_body].
    constructor 4 with (abs_subst_abs Mabs MS) (abs_subst_abs Nabs NS).
    rewrite Ms_type; rewrite Ns_type; trivial.
    rewrite Ms_body; rewrite Ns_body.
    apply IHM; trivial.

     (* application *)
    inversion H; try_solve.
     (*  - beta reduction *)
    constructor 1.
    apply betaStep_subst_stable; trivial.

     (*  - reduction in left argument *)
    clear Mapp; assert (Mapp: isApp (buildT (TApp M1 M2))); simpl; trivial.
    destruct (app_subst Mapp MS) as [Ml Mr].
    destruct (app_subst Napp NS) as [Nl Nr].
    constructor 2 with (app_subst_app Mapp MS) (app_subst_app Napp NS).
    rewrite Ml; rewrite Nl; apply IHM1; trivial.
    rewrite Mr; rewrite Nr; trivial.
    apply term_eq.
    rewrite !subst_env, <- H1; trivial.
    rewrite !subst_term, <- H1; trivial.

     (*  - reduction in right argument *)
    clear Mapp; assert (Mapp: isApp (buildT (TApp M1 M2))); simpl; trivial.
    destruct (app_subst Mapp MS) as [Ml Mr].
    destruct (app_subst Napp NS) as [Nl Nr].
    constructor 3 with (app_subst_app Mapp MS) (app_subst_app Napp NS).
    rewrite Mr; rewrite Nr; apply IHM2; trivial.
    rewrite Ml; rewrite Nl; trivial.
    apply term_eq.
    rewrite !subst_env, <- H1; trivial.
    rewrite !subst_term, <- H1; trivial.
  Qed.

  Lemma beta_abs_reduct : forall M (Mabs: isAbs M) N, M -b-> N ->
    exists Nabs: isAbs N, absBody Mabs -b-> absBody Nabs.

  Proof.
    intros M Mabs N MN.
    inversion MN; term_inv M; try_solve.
    inversion H; try_solve.
    exists Nabs; trivial.
  Qed.

  Lemma beta_app_reduct : forall M N (Mapp: isApp M),
    M -b-> N ->
    (exists MLabs: isAbs (appBodyL Mapp),
      N = lower (subst (beta_subst M Mapp MLabs)) (beta_lowering M Mapp MLabs))
    \/ exists Napp: isApp N,
      (appBodyL Mapp  =   appBodyL Napp /\ appBodyR Mapp -b-> appBodyR Napp)
      \/ (appBodyL Mapp -b-> appBodyL Napp /\ appBodyR Mapp  =   appBodyR Napp).

  Proof.
    intros M N Mapp MN.
    inversion MN; term_inv M; try_solve.
    left; inversion H.
    exists MLabs.
    rewrite (app_proof_irr Tr Mapp Mapp1); trivial.
    right; exists Napp; fo.
    right; exists Napp; fo.
  Qed.

  Lemma beta_var_consistent : forall M N,
    M -b-> N -> envSubset (activeEnv N) (activeEnv M).

  Proof.
    intros.
    apply red_var_consistent with BetaStep; trivial.
    clear M N H; intros M N MN.
    destruct MN.
    rewrite activeEnv_lower.
    rewrite (activeEnv_app M Mapp).
    rewrite (activeEnv_abs (appBodyL Mapp) MLabs).
    destruct (isVarDecl_dec (activeEnv (absBody MLabs)) 0) as [[B Ml0] | Mln].
    assert (Mlb0: exists A, activeEnv (absBody MLabs) |= 0 := A).
    exists B; trivial.
    rewrite (singleton_subst_activeEnv_subst (beta_subst M Mapp MLabs)
      (singletonSubst_cond (lift (appBodyR Mapp) 1)) Mlb0).
    rewrite (activeEnv_lift (appBodyR Mapp) 1).
    simpl; autorewrite with datatypes using unfold loweredEnv; simpl.
    apply env_subset_refl.
    rewrite (singleton_subst_activeEnv_noSubst (beta_subst M Mapp MLabs) Mln
      (singletonSubst_cond (lift (appBodyR Mapp) 1))); trivial.
    unfold loweredEnv; autorewrite with datatypes using simpl.
    apply env_subset_sum_l.
    simpl.
    apply env_comp_subset with (tail (env (subst (beta_subst M Mapp MLabs))))
      (env (appBodyR Mapp)).
    autorewrite with terms datatypes using simpl; auto with terms.
    apply env_subset_tail; apply activeEnv_subset.
    apply activeEnv_subset.
    rewrite finalSeg1_tail.
    apply env_subset_refl.
  Qed.

  Lemma betaStep_dec: forall M N, {BetaStep M N} + {~BetaStep M N}.

  Proof.
    intros.
    destruct (isApp_dec M) as [Mapp | Mnapp].
    destruct (isAbs_dec (appBodyL Mapp)) as [MLabs | MLnabs].
    destruct (eq_Term_dec N (lower (subst (beta_subst M Mapp MLabs))
      (beta_lowering M Mapp MLabs))).
    left; rewrite e; constructor.
    right; intro MN; inversion MN.
    apply n; rewrite <- H0.
    apply term_eq.
    autorewrite with terms using trivial.
    autorewrite with terms using trivial.
    replace (absBody MLabs0) with (absBody MLabs).
    replace (appBodyR Mapp1) with (appBodyR Mapp); trivial.
    term_inv M.
    apply absBody_eq; term_inv M.
    right; intro MN; inversion MN.
    absurd (isAbs (appBodyL Mapp1)); trivial.
    replace (appBodyL Mapp1) with (appBodyL Mapp); trivial.
    term_inv M.
    right; intro MN; inversion MN; try_solve.
  Qed.

  Lemma beta_dec: forall M N, {M -b-> N} + {~ M -b-> N}.

  Proof.
    intros; unfold BetaReduction.
    apply red_dec.
    apply betaStep_dec.
  Qed.

End TermsBeta.


Load LFindLoad.
Load LFindLoad.
From adtind Require Import goal7.

From lfind Require Import LFind.
Require Import Extraction.
Extract Inductive nat => nat [ "(O)" "S" ].
Extract Inductive list => list [ "Nil" "Cons" ].
Extraction "/home/yousef/lemmafinder/benchmark/_lfind_smallclam_lf_goal7_theorem0_58_plus_comm/goal7_lfind_orig.ml"  adtind.goal7.plus adtind.goal7.len adtind.goal7.qreva.
Success.