From iris.proofmode Require Import tactics.
Require Export cgraphs.cgraphs.uforests.
From cgraphs.cgraphs Require Export util.
From stdpp Require Export gmap.
Require Export cgraphs.cgraphs.multiset.
From stdpp Require Import fin_maps.
Require Import cgraphs.cgraphs.mapexcl.

Ltac sdec := repeat case_decide; simplify_eq.

(* Definition uforest V := gset (V * V). *)
Notation cgraph V L := (gmap V (gmap V L)).

Section cgraph.
  Context {V : Type}.
  Context `{Countable V}.
  Context {L : ofe}.

  Definition out_edges (g : cgraph V L) (v : V) : gmap V L :=
    match g !! v with
    | Some e => e
    | None => ∅
    end.

  Definition ms_insert (v v' : V) (ev' : gmap V L) (ins : multiset L) : multiset L :=
    from_option singleton ε (ev' !! v) ⋅ ins.

  Definition in_labels (g : cgraph V L) (v : V) : multiset L :=
    map_fold (ms_insert v) ε g.

  Definition edge (g : cgraph V L) (v1 v2 : V) := is_Some (out_edges g v1 !! v2).

  Definition swap {A B} : (A*B -> B*A) := λ '(x,y), (y,x).
  Definition make_undirected (g : gset (V*V)) : gset (V*V) :=
    g ∪ (set_map swap g).

  Definition dedges (g : cgraph V L) : gset (V*V) :=
    dom (gmap_uncurry g).
  Definition to_uforest (g : cgraph V L) : uforest V :=
    make_undirected $ dedges g.

  Definition no_short_loops (g : cgraph V L) :=
    ∀ v1 v2, ¬ (edge g v1 v2 ∧ edge g v2 v1).

  Definition cgraph_wf (g : cgraph V L) := no_short_loops g ∧ is_uforest (to_uforest g).

  Definition uconn (g : cgraph V L) := rtsc (edge g).

  Section general.

    Lemma in_labels_insert g i x v :
      g !! i = None ->
      in_labels (<[i:=x]> g) v ≡ from_option singleton ε (x !! v) ⋅ in_labels g v.
    Proof.
      intros Hi.
      unfold in_labels at 1.
      erewrite map_fold_insert with (R := (≡));
      eauto; first apply _; first solve_proper.
      intros. unfold ms_insert.
      destruct (z1 !! v) eqn:E;
      destruct (z2 !! v) eqn:F; simpl; eauto.
      rewrite assoc.
      rewrite (comm (⋅) {[ o ]}).
      rewrite assoc. done.
    Qed.

    Lemma in_labels_delete g i v y :
      g !! i = Some y ->
      from_option singleton ε (y !! v) ⋅ in_labels (delete i g) v ≡ in_labels g v.
    Proof.
      intro.
      pose proof (in_labels_insert (delete i g) i y v) as HH.
      rewrite insert_delete in HH; last done.
      rewrite HH; last by apply lookup_delete.
      done.
    Qed.

    Lemma in_labels_update g i x y v :
      g !! i = Some y ->
      from_option singleton ε (y !! v) ⋅ in_labels (<[i:=x]> g) v ≡
      from_option singleton ε (x !! v) ⋅ in_labels g v.
    Proof.
      intro.
      assert (<[i:=x]> g = <[i:=x]> $ delete i g) as ->.
      { by rewrite insert_delete_insert. }
      rewrite in_labels_insert; last by apply lookup_delete.
      rewrite comm. rewrite -assoc.
      rewrite (comm (⋅) (in_labels _ _)).
      rewrite in_labels_delete; eauto.
    Qed.

    Lemma out_edges_in_labels g v1 v2 l :
      out_edges g v1 !! v2 ≡ Some l ->
      ∃ x, in_labels g v2 ≡ {[ l ]} ⋅ x.
    Proof.
      revert v1 v2 l.
      induction g using map_ind; intros.
      - rewrite lookup_empty in H0. inversion H0.
      - unfold out_edges in H1.
        rewrite lookup_insert_spec in H1.
        case_decide; simplify_eq.
        + exists (in_labels m v2).
          rewrite in_labels_insert; eauto.
          rewrite H1. done.
        + destruct (m !! v1) eqn:E. 2: { rewrite lookup_empty in H1. inversion H1. }
          destruct (IHg v1 v2 l).
          { unfold out_edges. rewrite E. done. }
          setoid_rewrite in_labels_insert; eauto.
          setoid_rewrite H3.
          exists (from_option singleton ε (x !! v2) ⋅ x0).
          rewrite !assoc.
          rewrite (comm (⋅) _ {[ l ]}).
          done.
    Qed.

    Lemma out_edges_in_labels_L g v1 v2 l :
      out_edges g v1 !! v2 = Some l ->
      ∃ x, in_labels g v2 ≡ {[ l ]} ⋅ x.
    Proof.
      intros HH.
      eapply out_edges_in_labels. erewrite HH. done.
    Qed.

    Lemma no_in_labels_no_out_edge g v1 v2 :
      in_labels g v2 ≡ ε ->
      out_edges g v1 !! v2 = None.
    Proof.
      destruct (out_edges g v1 !! v2) eqn:E; eauto.
      eapply out_edges_in_labels_L in E as []. rewrite H0. intros HH.
      eapply multiset_empty_mult in HH.
      destruct HH as [H1%multiset_empty_neq_singleton H2]. done.
    Qed.

    Lemma out_edges_insert (g : cgraph V L) (v1 v2 : V) e :
      out_edges (<[ v1 := e ]> g) v2 =
        if decide (v1 = v2) then e
        else out_edges g v2.
    Proof.
      rewrite /out_edges. rewrite lookup_insert_spec.
      repeat case_decide; simplify_eq; done.
    Qed.

    Lemma in_labels_out_edges g v2 l x :
      in_labels g v2 ≡ {[ l ]} ⋅ x ->
      ∃ v1, out_edges g v1 !! v2 ≡ Some l.
    Proof.
      unfold in_labels.
      revert x; induction g using map_ind; intros a.
      - rewrite map_fold_empty.
        intros HH.
        symmetry in HH.
        eapply multiset_empty_mult in HH as []. subst.
        eapply multiset_empty_neq_singleton in H0 as [].
      - erewrite map_fold_insert with (R := (≡)); last done.
        + unfold ms_insert. destruct (x !! v2) eqn:E; simpl; intros HH.
          * eapply mset_xsplit in HH as (?&?&?&?&?&?&?&?).
            eapply multiset_singleton_mult in H1.
            eapply multiset_singleton_mult in H3.
            {
              destruct H1 as [[]|[]]; destruct H3 as [[]|[]].
              - rewrite ->H6 in H2.
                edestruct IHg; eauto.
                exists x4.
                rewrite out_edges_insert.
                case_decide; subst; eauto.
                unfold out_edges in H7.
                rewrite H0 in H7.
                rewrite lookup_empty in H7. inversion H7.
              - rewrite ->H1 in H3.
                exfalso. eapply multiset_empty_neq_singleton.
                eapply multiset_unit_equiv_eq. rewrite <- H3. done.
              - rewrite ->H6 in H2.
                edestruct IHg; eauto.
                exists x4.
                rewrite out_edges_insert.
                case_decide; subst; eauto.
                unfold out_edges in H7.
                rewrite H0 in H7.
                rewrite lookup_empty in H7. inversion H7.
              - rewrite ->H1 in H3.
                eapply multiset_singleton_inj in H3.
                exists i.
                rewrite out_edges_insert.
                case_decide; simplify_eq.
                rewrite -H3 E //.
            }
          * edestruct IHg.
            { rewrite <- HH. rewrite left_id. done. }
            exists x0.
            rewrite out_edges_insert.
            case_decide; simplify_eq; eauto.
            unfold out_edges in H1. rewrite H0 in H1.
            rewrite lookup_empty in H1. inversion H1.
        + apply _.
        + solve_proper.
        + intros. unfold ms_insert.
          rewrite ->(comm (⋅) (from_option singleton ε (z1 !! v2))).
          rewrite -assoc.
          rewrite ->(comm (⋅) y). done.
    Qed.

    Lemma in_labels_out_edges1 g v2 l :
      in_labels g v2 ≡ {[ l ]} ->
      ∃ v1, out_edges g v1 !! v2 ≡ Some l.
    Proof.
      assert ({[ l ]} ≡ {[ l ]} ⋅ (ε : multiset L)) as H1.
      { rewrite right_id //. }
      rewrite H1.
      eapply in_labels_out_edges.
    Qed.

    Lemma in_labels_out_edges2 g v l1 l2 :
      in_labels g v ≡ {[ l1 ]} ⋅ {[ l2 ]} ->
      ∃ v1 v2, v1 ≠ v2 ∧
        out_edges g v1 !! v ≡ Some l1 ∧
        out_edges g v2 !! v ≡ Some l2.
    Proof.
      unfold in_labels.
      induction g using map_ind.
      { rewrite map_fold_empty.
        intros HH.
        symmetry in HH.
        eapply multiset_empty_mult in HH as []. subst.
        eapply multiset_empty_neq_singleton in H0 as []. }
      rewrite /ms_insert.
      erewrite map_fold_insert with (R := (≡)); [|apply _|solve_proper|..|done].
      2: {
        intros.
        rewrite /ms_insert (comm (⋅) (from_option singleton ε (z1 !! v))) -assoc (comm (⋅) y) //.
      }
      destruct (x !! v) eqn:E; simpl; intros HH.
      - eapply multiset_xsplit_singleton in HH as [[? HH]|[? HH]]; setoid_subst.
        + edestruct in_labels_out_edges1 as [v' Hv']; first exact HH.
          exists i,v'.
          assert (i ≠ v').
          { intros ->.
            unfold out_edges in Hv'.
            rewrite H0 lookup_empty in Hv'.
            inversion Hv'. }
          split; eauto.
          rewrite !out_edges_insert; split; case_decide; simplify_eq; eauto.
          rewrite E //.
        + edestruct in_labels_out_edges1 as [v' Hv']; first exact HH.
          exists v',i.
          assert (i ≠ v').
          { intros ->.
            unfold out_edges in Hv'.
            rewrite H0 lookup_empty in Hv'.
            inversion Hv'. }
          split; eauto.
          rewrite !out_edges_insert; split; case_decide; simplify_eq; eauto.
          rewrite E //.
      - rewrite left_id in HH.
        eapply IHg in HH as (v1&v2&Hvneq&Hout1&Hout2).
        exists v1,v2.
        split; first done.
        rewrite !out_edges_insert.
        split.
        + case_decide; last done. subst.
          unfold out_edges in Hout1,Hout2.
          rewrite H0 lookup_empty in Hout1.
          inversion Hout1.
        + case_decide; last done. subst.
          unfold out_edges in Hout1,Hout2.
          rewrite H0 lookup_empty in Hout2.
          inversion Hout2.
    Qed.

    Lemma not_rtsc `{R : A -> A -> Prop} x :
      (∀ y, ¬ R x y ∧ ¬ R y x) ->
      (∀ y, rtsc R x y -> x = y).
    Proof.
      intros Hy y Hr.
      induction Hr; eauto. destruct H0; naive_solver.
    Qed.

    Lemma no_edges_no_uconn g v v' :
      out_edges g v = ∅ ->
      in_labels g v ≡ ε ->
      uconn g v' v -> v = v'.
    Proof.
      intros Hout Hin Hconn.
      eapply not_rtsc; last done.
      intros y. unfold edge. split; intros [].
      - rewrite Hout in H0. rewrite lookup_empty in H0. simplify_eq.
      - eapply no_in_labels_no_out_edge in Hin. erewrite H0 in Hin. simplify_eq.
    Qed.

    Lemma some_edge_L (g : cgraph V L) (v1 v2 : V) (l : L) :
      out_edges g v1 !! v2 = Some l -> edge g v1 v2.
    Proof.
      unfold edge. intros ->. eauto.
    Qed.

    Lemma some_edge (g : cgraph V L) (v1 v2 : V) (l : L) :
      out_edges g v1 !! v2 ≡ Some l -> edge g v1 v2.
    Proof.
      intro. inversion H0.
      unfold edge. rewrite -H1. eauto.
    Qed.

    Lemma not_uconn_out_disjoint g v1 v2 :
      ¬ uconn g v1 v2 -> out_edges g v1 ##ₘ out_edges g v2.
    Proof.
      intros HH v.
      destruct (out_edges g v1 !! v) eqn:E;
      destruct (out_edges g v2 !! v) eqn:F; simpl; eauto.
      assert (edge g v1 v); eauto using some_edge_L.
      assert (edge g v2 v); eauto using some_edge_L.
      apply HH.
      eapply rtc_transitive; eapply rtc_once; [left|right]; eauto.
    Qed.
  End general.

  Section acyclicity.
    Lemma elem_of_swap (e : gset (V*V)) (x y : V) :
      (x, y) ∈ (set_map swap e : gset (V*V)) <-> (y, x) ∈ e.
    Proof.
      rewrite elem_of_map.
      split.
      - intros ([]&?&?); simpl in *. simplify_eq. done.
      - intros. exists (y,x); eauto.
    Qed.

    Lemma make_undirected_sc (R : V -> V -> Prop) (e : gset (V*V)) :
      (∀ x y, (x,y) ∈ e <-> R x y) ->
      ∀ x y, (x,y) ∈ make_undirected e <-> sc R x y.
    Proof.
      intros. unfold make_undirected.
      rewrite elem_of_union.
      rewrite elem_of_swap.
      split; intros []; [left|right|..]; naive_solver.
    Qed.

    Lemma gmap_uncurry_out_edges g x y :
      gmap_uncurry g !! (x, y) = out_edges g x !! y.
    Proof.
      rewrite lookup_gmap_uncurry.
      unfold out_edges.
      destruct (g !! x); simpl; eauto.
    Qed.

    Lemma elem_of_dedges x y g :
      (x, y) ∈ dedges g ↔ edge g x y.
    Proof.
      unfold dedges.
      rewrite elem_of_dom.
      unfold edge.
      rewrite gmap_uncurry_out_edges. done.
    Qed.

    Lemma elem_of_to_uforest g x y :
      (x,y) ∈ to_uforest g <-> sc (edge g) x y.
    Proof.
      unfold to_uforest.
      eapply make_undirected_sc. intros.
      eapply elem_of_dedges.
    Qed.

    Lemma out_edges_empty v :
      out_edges ∅ v = ∅.
    Proof.
      unfold out_edges. rewrite lookup_empty //.
    Qed.

    Lemma edge_empty v1 v2 :
      edge ∅ v1 v2 <-> False.
    Proof.
      split; intros [].
      rewrite out_edges_empty lookup_empty in H0. simplify_eq.
    Qed.

    Lemma to_uforest_empty :
      to_uforest ∅ = ∅.
    Proof.
      eapply set_eq. intros [x y].
      rewrite elem_of_to_uforest.
      rewrite elem_of_empty.
      split; intros []; unfold edge in *;
      rewrite out_edges_empty lookup_empty in H0; destruct H0; simplify_eq.
    Qed.

  End acyclicity.

  Section empty_cgraph.
    Lemma in_labels_empty v :
      in_labels ∅ v ≡ ε.
    Proof.
      unfold in_labels. rewrite map_fold_empty. done.
    Qed.

    Lemma empty_wf :
      cgraph_wf ∅.
    Proof.
      unfold cgraph_wf.
      split.
      - intros ??. rewrite !edge_empty. naive_solver.
      - rewrite to_uforest_empty. eapply forest_empty.
    Qed.
  End empty_cgraph.

  Section insert_edge.
    (* This function is only supposed to be called if there is not already an edge
       between v1 and v2. In fact, it's only supposed to be called if v1 and v2
       are complete disconnected. *)
    Definition insert_edge (g : cgraph V L) (v1 v2 : V) (l : L) :=
      <[ v1 := <[ v2 := l ]> $ out_edges g v1 ]> g.

    Lemma out_edges_insert_edge (g : cgraph V L) (v1 v2 v3 : V) (l : L) :
      out_edges (insert_edge g v1 v2 l) v3 =
        if decide (v1 = v3) then <[ v2 := l ]> $ out_edges g v3
        else out_edges g v3.
    Proof.
      unfold insert_edge. rewrite out_edges_insert.
      repeat case_decide; simplify_eq; done.
    Qed.

    Lemma in_labels_insert_edge (g : cgraph V L) (v1 v2 v3 : V) (l : L) :
      ¬ edge g v1 v2 ->
      in_labels (insert_edge g v1 v2 l) v3 ≡
        if decide (v2 = v3) then {[ l ]} ⋅ in_labels g v3
        else in_labels g v3.
    Proof.
      intros Hnotedge.
      unfold insert_edge.
      destruct (g !! v1) eqn:E.
      - assert (g !! v1 = Some g0) as HH; eauto.
        pose proof (in_labels_update g v1 (<[v2:=l]> (out_edges g v1)) g0 v3 HH) as H0.
        rewrite lookup_insert_spec in H0.
        destruct (g0 !! v3) eqn:F; simpl in *.
        + case_decide; simplify_eq; simpl in *.
          * exfalso. apply Hnotedge.
            unfold edge. unfold out_edges.
            rewrite E. rewrite F. eauto.
          * unfold out_edges in H0 at 2.
            rewrite E in H0.
            rewrite F in H0. simpl in *.
            apply cancelable in H0; eauto; first apply _; done.
        + rewrite ->left_id in H0. 2: { intro. simpl. rewrite left_id. done. }
          rewrite H0. case_decide; simpl; eauto. unfold out_edges.
          rewrite HH. rewrite F. simpl. rewrite left_id. done.
      - rewrite in_labels_insert; eauto.
        rewrite lookup_insert_spec.
        case_decide; simplify_eq; try done.
        unfold out_edges.
        rewrite E. rewrite lookup_empty.
        simpl. rewrite left_id. done.
    Qed.

    Lemma edge_insert_edge g v1 v2 x y l :
      edge (insert_edge g v1 v2 l) x y <-> edge g x y ∨ (x = v1 ∧ y = v2).
    Proof.
      unfold edge.
      rewrite out_edges_insert_edge.
      case_decide; subst.
      - rewrite lookup_insert_spec. case_decide; subst.
        + naive_solver.
        + naive_solver.
      - naive_solver.
    Qed.

    Lemma sc_edge_insert_edge g v1 v2 x y l :
      sc (edge (insert_edge g v1 v2 l)) x y <-> sc (edge g) x y ∨ (x = v1 ∧ y = v2) ∨ (x = v2 ∧ y = v1).
    Proof.
      split.
      - intros []; rewrite ->edge_insert_edge in H0;
        destruct H0; try naive_solver.
        + left. left. done.
        + left. right. done.
      - intros [].
        + destruct H0;[left|right]; rewrite edge_insert_edge; eauto.
        + destruct H0;[left|right]; rewrite edge_insert_edge; eauto.
          naive_solver.
    Qed.

    Lemma to_uforest_insert_edge g v1 v2 l :
      to_uforest (insert_edge g v1 v2 l) = to_uforest g ∪ uedge v1 v2.
    Proof.
      eapply set_eq. intros [x y].
      rewrite elem_of_union.
      rewrite !elem_of_to_uforest.
      rewrite !sc_edge_insert_edge.
      unfold uedge. set_solver.
    Qed.

    Lemma rtc_impl (R1 R2 : V -> V -> Prop) x y :
      (∀ x y, R1 x y <-> R2 x y) ->
      rtc R1 x y -> rtc R2 x y.
    Proof.
      intros. induction H1; try done.
      rewrite ->H0 in H1.
      econstructor; eauto.
    Qed.

    Lemma rtc_iff (R1 R2 : V -> V -> Prop) x y :
      (∀ x y, R1 x y <-> R2 x y) ->
      rtc R1 x y <-> rtc R2 x y.
    Proof.
      intros. split; eauto using rtc_impl.
      assert (∀ x y : V, R2 x y ↔ R1 x y) by naive_solver.
      eauto using rtc_impl.
    Qed.

    Lemma uconn_connected0 g v1 v2 :
      cgraph_wf g ->
      uconn g v1 v2 <-> connected0 (to_uforest g) v1 v2.
    Proof.
      unfold uconn. intros.
      rewrite connected0_elem_of. 2: { by destruct H0. }
      assert (∀ x y, sc (edge g) x y <-> (x,y) ∈ to_uforest g).
      { intros. rewrite elem_of_to_uforest. done. }
      unfold rtsc.
      erewrite rtc_iff; eauto.
      intros.
      split.
      - intros. left. rewrite elem_of_to_uforest. done.
      - intros []; rewrite ->elem_of_to_uforest in H2; eauto.
        destruct H2; [right|left]; done.
    Qed.

    Lemma insert_edge_wf g v1 v2 l :
      ¬ uconn g v1 v2 ->
      cgraph_wf g ->
      cgraph_wf (insert_edge g v1 v2 l).
    Proof.
      intros H0 [].
      split.
      - intros x y. rewrite !edge_insert_edge.
        intros [].
        destruct H3; destruct H4.
        + eapply H1; eauto.
        + destruct H4; subst.
          eapply H0. eapply rtc_once.
          right. done.
        + destruct H3; subst.
          eapply H0. eapply rtc_once.
          right. done.
        + destruct H3. destruct H4. subst.
          eapply H0. constructor.
      - rewrite to_uforest_insert_edge.
        eapply forest_connect; eauto.
        rewrite -uconn_connected0; done.
    Qed.
  End insert_edge.

  Section delete_edge.
    Definition delete_edge (g : cgraph V L) (v1 v2 : V) :=
      <[ v1 := delete v2 (out_edges g v1) ]> g.

    Lemma out_edges_delete_edge (g : cgraph V L) (v1 v2 v3 : V) :
      out_edges (delete_edge g v1 v2) v3 =
        if decide (v1 = v3) then delete v2 (out_edges g v3)
        else out_edges g v3.
    Proof.
      unfold delete_edge. rewrite out_edges_insert.
      repeat case_decide; simplify_eq; done.
    Qed.

    Lemma in_labels_delete_edge_eq (g : cgraph V L) (v1 v2 : V) (l : L) (x : multiset L) :
      out_edges g v1 !! v2 = Some l ->
      in_labels g v2 ≡ {[ l ]} ⋅ x ->
      in_labels (delete_edge g v1 v2) v2 ≡ x.
    Proof.
      intros H1 H2.
      unfold delete_edge.
      destruct (g !! v1) eqn:E; last first.
      { unfold out_edges in H1. rewrite E lookup_empty in H1. simplify_eq. }
      pose proof (in_labels_update g v1 (delete v2 (out_edges g v1)) g0 v2 E) as H0.
      destruct (g0 !! v2) eqn:F; simpl in *.
      - rewrite lookup_delete in H0.
        simpl in *.
        rewrite ->H2 in H0.
        unfold out_edges in H1.
        rewrite E in H1. rewrite F in H1. simplify_eq.
        revert H0. rewrite left_id. intros H0.
        apply cancelable in H0; eauto; first apply _; done.
      - unfold out_edges in H1. rewrite E F in H1. simplify_eq.
    Qed.

    Lemma in_labels_delete_edge_neq (g : cgraph V L) (v1 v2 v3 : V) :
      v2 ≠ v3 ->
      in_labels (delete_edge g v1 v2) v3 ≡ in_labels g v3.
    Proof.
      intros Hneq.
      unfold delete_edge.
      destruct (g !! v1) eqn:E.
      - pose proof (in_labels_update g v1 (delete v2 (out_edges g v1)) g0 v3 E) as H0.
        destruct (g0 !! v3) eqn:F.
        + simpl in *.
          rewrite lookup_delete_spec in H0.
          unfold out_edges in H0 at 2.
          rewrite E in H0.
          rewrite F in H0.
          case_decide; simplify_eq.
          simpl in *. apply cancelable in H0; eauto; first apply _; done.
        + simpl in *. rewrite ->left_id in H0.
          2: { intro. simpl. rewrite left_id. done. }
          rewrite H0.
          rewrite lookup_delete_spec.
          unfold out_edges. rewrite E.
          rewrite F. case_decide; simplify_eq; simpl.
          rewrite left_id. done.
      - rewrite in_labels_insert; eauto.
        rewrite lookup_delete_spec.
        unfold out_edges.
        rewrite E. rewrite lookup_empty.
        case_decide; simpl; rewrite left_id //.
    Qed.

    Lemma edge_delete_edge g v1 v2 w1 w2 :
      v1 ≠ w1 ∨ v2 ≠ w2 ->
      edge g w1 w2 ->
      edge (delete_edge g v1 v2) w1 w2.
    Proof.
      intros.
      unfold edge.
      rewrite out_edges_delete_edge.
      case_decide; simplify_eq; eauto.
      rewrite lookup_delete_spec.
      case_decide; simplify_eq; eauto.
      naive_solver.
    Qed.

    Lemma edge_delete_edge' g v1 v2 w1 w2 :
      edge g w1 w2 ->
      edge (delete_edge g v1 v2) w1 w2 ∨ (v1 = w1 ∧ v2 = w2).
    Proof.
      intros.
      pose proof (edge_delete_edge g v1 v2 w1 w2).
      destruct (decide (v1 = w1));
      destruct (decide (v2 = w2));
      naive_solver.
    Qed.

    Lemma edge_delete_edge'' g v1 v2 x y :
      edge (delete_edge g v1 v2) x y <-> edge g x y ∧ ¬ (x = v1 ∧ y = v2).
    Proof.
      split.
      - intros.
        move: H0.
        unfold edge. rewrite !out_edges_delete_edge.
        repeat case_decide; subst.
        + rewrite lookup_delete_spec.
          case_decide; subst; first by intros []. naive_solver.
        +  naive_solver.
      - intros []. eapply edge_delete_edge; eauto.
        destruct (decide (x = v1)); destruct (decide (y = v2)); naive_solver.
    Qed.

    Lemma sc_or (R : V -> V -> Prop) x y :
      sc R x y <-> R x y ∨ R y x.
    Proof.
      split; intros []; eauto; [left|right]; eauto.
    Qed.

    Lemma elem_of_uedge (x y a b : V) :
      (x, y) ∈ uedge a b <-> (x = a ∧ y = b) ∨ (x = b ∧ y = a).
    Proof.
      unfold uedge.
      set_solver.
    Qed.

    Lemma edge_dec g x y : Decision (edge g x y).
    Proof.
      unfold edge.
      destruct (out_edges g x !! y).
      - left. eauto.
      - right. eauto.
    Qed.

    Lemma to_uforest_delete_edge g v1 v2 :
      no_short_loops g ->
      edge g v1 v2 ->
      to_uforest (delete_edge g v1 v2) = to_uforest g ∖ uedge v1 v2.
    Proof.
      intros.
      eapply set_eq. intros [x y].
      rewrite elem_of_difference.
      rewrite !elem_of_to_uforest.
      rewrite !sc_or.
      specialize (H0 v1 v2).
      rewrite !edge_delete_edge''.
      rewrite elem_of_uedge.
      naive_solver.
    Qed.

    Definition cgraph_equiv g1 g2 :=
      ∀ v, out_edges g1 v = out_edges g2 v.

    Lemma cgraph_equiv_edge g1 g2 v1 v2 :
      cgraph_equiv g1 g2 ->
      edge g1 v1 v2 ->
      edge g2 v1 v2.
    Proof.
      unfold edge. intros ->. done.
    Qed.

    Lemma uconn_equiv g1 g2 v1 v2 :
      cgraph_equiv g1 g2 ->
      uconn g1 v1 v2 -> uconn g2 v1 v2.
    Proof.
      intros He Hc.
      induction Hc; try reflexivity.
      eapply rtc_transitive; eauto.
      eapply rtc_once.
      destruct H0;[left|right]; eauto using cgraph_equiv_edge.
    Qed.

    Lemma delete_edge_not_edge g v1 v2 :
      ¬ edge g v1 v2 ->
      cgraph_equiv (delete_edge g v1 v2) g.
    Proof.
      intros ??.
      rewrite out_edges_delete_edge.
      case_decide; subst; eauto.
      rewrite delete_notin; eauto.
      destruct (out_edges g v !! v2) eqn:E; eauto.
      exfalso. eapply H0. unfold edge. rewrite E. eauto.
    Qed.

    Lemma cgraph_equiv_sym g1 g2 :
      cgraph_equiv g1 g2 -> cgraph_equiv g2 g1.
    Proof.
      intros ??.
      symmetry. eapply H0.
    Qed.

    Lemma to_uforest_proper : Proper (cgraph_equiv ==> (=)) to_uforest.
    Proof.
      solve_proper_prepare.
      eapply set_eq.
      intros [a b].
      rewrite !elem_of_to_uforest.
      rewrite !sc_or.
      split; intros []; eauto using cgraph_equiv_edge,cgraph_equiv_sym.
    Qed.

    Lemma delete_edge_wf g v1 v2 :
      cgraph_wf g ->
      cgraph_wf (delete_edge g v1 v2).
    Proof.
      intros [].
      unfold cgraph_wf.
      split.
      - unfold no_short_loops. intros x y [].
        apply edge_delete_edge'' in H2 as [].
        apply edge_delete_edge'' in H3 as [].
        unfold no_short_loops in *.
        eapply H0. eauto.
      - destruct (decide (edge g v1 v2)).
        + rewrite to_uforest_delete_edge; eauto.
          eapply forest_delete; done.
        + assert (to_uforest (delete_edge g v1 v2) = to_uforest g).
          {
            eapply to_uforest_proper.
            eapply delete_edge_not_edge. done.
          }
          rewrite H2. done.
    Qed.

    Lemma delete_edge_uconn g v1 v2 :
      cgraph_wf g ->
      edge g v1 v2 ->
      ¬ uconn (delete_edge g v1 v2) v1 v2.
    Proof.
      intros [] ?.
      rewrite uconn_connected0.
      rewrite to_uforest_delete_edge; eauto.
      eapply forest_disconnect; eauto.
      rewrite elem_of_to_uforest; eauto.
      - left. done.
      - eapply delete_edge_wf. done.
    Qed.

    Lemma no_self_edge g v1 v2 :
      cgraph_wf g ->
      edge g v1 v2 -> v1 ≠ v2.
    Proof.
      intros H1 H2 ->.
      eapply delete_edge_uconn; eauto. reflexivity.
    Qed.

    Lemma no_self_edge' g v1 v2 :
      cgraph_wf g ->
      sc (edge g) v1 v2 -> v1 ≠ v2.
    Proof.
      intros H1 [] ->; eapply no_self_edge; eauto.
    Qed.

    Lemma no_self_edge'' g v :
      cgraph_wf g ->
      out_edges g v !! v = None.
    Proof.
      intros.
      destruct (_!!_) eqn:E; eauto.
      exfalso.
      eapply no_self_edge; eauto using some_edge_L.
    Qed.

    Lemma no_triangle g v1 v2 v3 :
      cgraph_wf g ->
      sc (edge g) v1 v2 ->
      sc (edge g) v2 v3 ->
      sc (edge g) v3 v1 ->
      False.
    Proof.
      intros Hwf H1 H2 H3.
      assert (v1 ≠ v2); eauto using no_self_edge'.
      assert (v2 ≠ v3); eauto using no_self_edge'.
      assert (v3 ≠ v1); eauto using no_self_edge'.
      destruct H1,H2,H3; eapply delete_edge_uconn; eauto;
      eapply rtc_transitive; eapply rtc_once;
      try (solve [left; eapply edge_delete_edge; eauto] ||
           solve [right; eapply edge_delete_edge; eauto]).
      - left. eapply edge_delete_edge; eauto.
      - left. eapply edge_delete_edge.
        + right. intro. eapply H4. symmetry. done.
        + eauto.
      - right. eapply edge_delete_edge; eauto.
    Qed.

    Lemma edge_out_disjoint g v1 v2 :
      cgraph_wf g -> edge g v1 v2 -> out_edges g v1 ##ₘ out_edges g v2.
    Proof.
      intros Hwf Hv12 v.
      destruct (out_edges g v1 !! v) eqn:E;
      destruct (out_edges g v2 !! v) eqn:F; simpl; eauto.
      eapply no_triangle; eauto.
      - left. eauto.
      - left. unfold edge. erewrite F. eauto.
      - right. unfold edge. rewrite E. eauto.
    Qed.
  End delete_edge.

  Section update_edge.
    Definition update_edge g v1 v2 l' :=
      insert_edge (delete_edge g v1 v2) v1 v2 l'.

    Lemma update_edge_out_edges g v1 v2 l' v :
      out_edges (update_edge g v1 v2 l') v =
        if decide (v = v1) then <[ v2 := l' ]> (out_edges g v)
        else out_edges g v.
    Proof.
      unfold update_edge.
      rewrite out_edges_insert_edge.
      rewrite out_edges_delete_edge.
      repeat case_decide; simplify_eq; eauto.
      apply map_eq. intros v.
      rewrite insert_delete_insert //.
    Qed.

    Lemma update_in_labels_eq g v1 v2 l l' x :
      out_edges g v1 !! v2 = Some l ->
      in_labels g v2 ≡ {[ l ]} ⋅ x ->
      in_labels (update_edge g v1 v2 l') v2 ≡ {[ l' ]} ⋅ x.
    Proof.
      intros H1 H2.
      rewrite /update_edge in_labels_insert_edge.
      - case_decide; simplify_eq.
        rewrite in_labels_delete_edge_eq;eauto.
      - unfold edge. rewrite out_edges_delete_edge.
        case_decide; simplify_eq. rewrite lookup_delete. done.
    Qed.

    Lemma update_in_labels_neq g v v1 v2 l' :
      v ≠ v2 ->
      in_labels (update_edge g v1 v2 l') v ≡ in_labels g v.
    Proof.
      intros H1.
      rewrite /update_edge in_labels_insert_edge.
      - case_decide; simplify_eq. rewrite in_labels_delete_edge_neq; eauto.
      - unfold edge. rewrite out_edges_delete_edge.
        case_decide; simplify_eq. rewrite lookup_delete. done.
    Qed.

    Lemma update_edge_wf g v1 v2 l' :
      cgraph_wf g ->
      edge g v1 v2 ->
      cgraph_wf (update_edge g v1 v2 l').
    Proof.
      intros H1 H2.
      unfold update_edge.
      apply insert_edge_wf.
      - apply delete_edge_uconn; eauto.
      - eapply delete_edge_wf; eauto.
    Qed.
  End update_edge.

  Section move_edge.
    (* Move an edge v1 --[l]--> v3 to be v2 --[l]--> v *)
    (* This is only allowed if there is also an edge between v1 and v2. *)
    Definition move_edge g v1 v2 v3 :=
      match out_edges g v1 !! v3 with
      | Some l => insert_edge (delete_edge g v1 v3) v2 v3 l
      | None => g
      end.

    Lemma move_edge_out_edges g v1 v2 v3 v l :
      out_edges g v1 !! v3 = Some l ->
      out_edges (move_edge g v1 v2 v3) v =
        if decide (v = v2) then <[ v3 := l ]> $ out_edges g v
        else if decide (v = v1) then delete v3 $ out_edges g v
        else out_edges g v.
    Proof.
      intros H1.
      unfold move_edge. rewrite H1.
      rewrite out_edges_insert_edge.
      rewrite out_edges_delete_edge.
      repeat case_decide; simplify_eq; eauto; apply map_eq; intro;
      rewrite ?lookup_union ?lookup_insert_spec ?lookup_delete_spec ?lookup_empty;
      repeat case_decide; simplify_eq; eauto.
    Qed.

    Lemma move_edge_in_labels g v1 v2 v3 v :
      cgraph_wf g ->
      sc (edge g) v1 v2 ->
      in_labels (move_edge g v1 v2 v3) v ≡ in_labels g v.
    Proof.
      intros Hwf Hv12.
      unfold move_edge.
      destruct (_!!_) eqn:E; eauto.
      rewrite in_labels_insert_edge.
      - case_decide; simplify_eq.
        + destruct (out_edges_in_labels_L _ _ _ _ E).
          rewrite in_labels_delete_edge_eq; eauto.
          by symmetry.
        + rewrite in_labels_delete_edge_neq; eauto.
      - unfold edge.
        assert (v1 ≠ v2); eauto using no_self_edge'.
        rewrite out_edges_delete_edge.
        case_decide; simplify_eq.
        intro HH.
        eapply no_triangle; eauto.
        + left; eauto.
        + right. unfold edge. erewrite E. eauto.
    Qed.

    Lemma move_edge_in_labels' g v1 v2 v3 v :
      cgraph_wf g ->
      ¬ uconn g v1 v2 ->
      in_labels (move_edge g v1 v2 v3) v ≡ in_labels g v.
    Proof.
      intros Hwf Hv12.
      unfold move_edge.
      destruct (_!!_) eqn:E; eauto.
      rewrite in_labels_insert_edge.
      - case_decide; simplify_eq.
        + destruct (out_edges_in_labels_L _ _ _ _ E).
          rewrite in_labels_delete_edge_eq; eauto.
          by symmetry.
        + rewrite in_labels_delete_edge_neq; eauto.
      - unfold edge.
        assert (v1 ≠ v2). { intros ->. apply Hv12. reflexivity. }
        rewrite out_edges_delete_edge.
        case_decide; simplify_eq.
        intros [].
        assert (edge g v1 v3); eauto using some_edge_L.
        assert (edge g v2 v3); eauto using some_edge_L.
        apply Hv12.
        eapply rtc_transitive; eapply rtc_once;[left|right]; eauto.
    Qed.

    Lemma move_edge_wf g v1 v2 v3 :
      v2 ≠ v3 ->
      cgraph_wf g ->
      sc (edge g) v1 v2 ->
      cgraph_wf (move_edge g v1 v2 v3).
    Proof.
      intros Hneq Hwf Hv12.
      unfold move_edge.
      destruct (_!!_) eqn:E; eauto.
      apply insert_edge_wf; eauto using delete_edge_wf.
      intro Hconn.
      eapply (delete_edge_uconn g v1 v3); eauto.
      - unfold edge. rewrite E. eauto.
      - unfold uconn in *.
        assert (sc (edge (delete_edge g v1 v3)) v1 v2). {
          destruct Hv12.
          - left. unfold edge. rewrite out_edges_delete_edge.
            case_decide; simplify_eq.
            rewrite lookup_delete_ne; eauto.
          - right. unfold edge. rewrite out_edges_delete_edge.
            case_decide; simplify_eq; eauto.
            exfalso. eapply no_self_edge; eauto.
        }
        eapply transitivity; last done.
        econstructor; first done.
        econstructor.
    Qed.

    Lemma edge_delete_edge''' g v1 v2 w1 w2 :
      edge (delete_edge g w1 w2) v1 v2 -> edge g v1 v2.
    Proof.
      rewrite /delete_edge /edge /out_edges.
      destruct (g !! w1) eqn:F; simpl; rewrite lookup_insert_spec; repeat case_decide;
      rewrite ?lookup_delete_spec; repeat case_decide; simplify_eq;
      try destruct (g !! v1) eqn:E; simpl; rewrite ?lookup_empty; eauto; try intros [];
      simplify_eq. rewrite H0. eauto.
    Qed.

    Lemma delete_edge_preserves_not_uconn g v1 v2 w1 w2 :
      uconn (delete_edge g w1 w2) v1 v2 -> uconn g v1 v2.
    Proof.
      intros HH. induction HH; try reflexivity.
      eapply rtc_transitive; eauto. eapply rtc_once.
      destruct H0; [left|right]; eauto using edge_delete_edge'''.
    Qed.

    Lemma move_edge_wf' g v1 v2 v3 :
      v2 ≠ v3 ->
      cgraph_wf g ->
      ¬ uconn g v1 v2 ->
      cgraph_wf (move_edge g v1 v2 v3).
    Proof.
      intros Hneq Hwf Hv12.
      unfold move_edge.
      destruct (_!!_) eqn:E; eauto.
      apply insert_edge_wf; eauto using delete_edge_wf.
      assert (¬ uconn g v3 v2).
      { intro. apply Hv12.
        eapply rtc_transitive; eauto.
        eapply rtc_once. left. eauto using some_edge_L. }
      intro. apply delete_edge_preserves_not_uconn in H1.
      apply H0. symmetry. done.
    Qed.

    Lemma move_edge_uconn g v1 v2 v3 :
      cgraph_wf g ->
      ¬ uconn g v1 v2 ->
      ¬ uconn (move_edge g v1 v2 v3) v1 v2.
    Proof.
      intros Hwf H1.
      destruct (out_edges g v1 !! v3) eqn:E; last first.
      { unfold move_edge. rewrite E. done. }
      assert (¬ uconn (delete_edge (move_edge (insert_edge g v1 v2 o) v1 v2 v3) v1 v2) v1 v2).
      {
        eapply delete_edge_uconn.
        - eapply move_edge_wf.
          + intros ->. eapply H1. eapply rtc_once. left. eauto using some_edge_L.
          + eapply insert_edge_wf; eauto.
          + left. unfold edge.
            rewrite out_edges_insert_edge.
            case_decide; simplify_eq. rewrite lookup_insert. eauto.
        - unfold edge.
          erewrite move_edge_out_edges; last first.
          + rewrite out_edges_insert_edge.
            case_decide; simplify_eq.
            rewrite lookup_insert_spec.
            case_decide; simplify_eq; eauto.
          + rewrite !out_edges_insert_edge.
            repeat case_decide; simplify_eq.
            * rewrite !lookup_insert_spec.
              case_decide; simplify_eq. eauto.
            * rewrite lookup_delete_spec lookup_insert_spec.
              case_decide; simplify_eq.
              -- exfalso. apply H1.
                 eapply rtc_once. left. eauto using some_edge_L.
              -- case_decide; simplify_eq. eauto.
      }
      intro. apply H0.
      eapply uconn_equiv; eauto.
      intro.
      rewrite out_edges_delete_edge.
      erewrite move_edge_out_edges; last done.
      erewrite move_edge_out_edges; last first.
      { rewrite out_edges_insert_edge. case_decide; eauto.
        rewrite lookup_insert_spec. case_decide; simplify_eq; eauto. }
      rewrite !out_edges_insert_edge.
      repeat case_decide; simplify_eq; eauto.
      - assert (v2 ≠ v3). { intros ->. eapply no_self_edge; eauto using some_edge_L. }
        rewrite delete_insert_ne; eauto.
        rewrite delete_insert; eauto.
        destruct (out_edges g v2 !! v2) eqn:F; eauto.
        exfalso. eapply no_self_edge; eauto using some_edge_L.
      - rewrite delete_commute.
        rewrite delete_insert; eauto.
        destruct (out_edges g v !! v2) eqn:F; eauto.
        exfalso. apply H1. apply rtc_once.
        left. eapply some_edge_L; eauto.
    Qed.
  End move_edge.

  Section move_edges.
    Lemma move_edges g v1 v2 e1 e2 :
      cgraph_wf g ->
      ¬ uconn g v1 v2 ->
      e1 ##ₘ e2 ->
      out_edges g v1 = e1 ∪ e2 ->
      ∃ g', cgraph_wf g' ∧
        ¬ uconn g' v1 v2 ∧
        (∀ v, out_edges g' v =
          if decide (v = v1) then e1
          else if decide (v = v2) then out_edges g v ∪ e2
          else out_edges g v) ∧
        (∀ v, in_labels g' v ≡ in_labels g v).
    Proof.
      revert g e1.
      induction e2 using map_ind; intros g e1;
      intros Hwf Hnuconn Hdisj Hout.
      - exists g. rewrite right_id_L in Hout.
        split_and!; eauto. intro.
        repeat case_decide; simplify_eq; eauto.
        rewrite right_id_L //.
      - specialize (IHe2 (move_edge g v1 v2 i) e1).
        destruct IHe2.
        + apply move_edge_wf'; eauto. intros ->. apply Hnuconn.
          apply rtc_once.
          left.
          unfold edge.
          rewrite Hout.
          rewrite lookup_union lookup_insert.
          destruct (e1 !! i); eauto.
        + apply move_edge_uconn; eauto.
        + solve_map_disjoint.
        + destruct (out_edges g v1 !! i) eqn:E.
          2: { rewrite Hout in E. rewrite lookup_union lookup_insert in E.
            destruct (e1 !! i); simpl in *; simplify_eq.  }
          erewrite move_edge_out_edges; eauto.
          repeat case_decide; simplify_eq.
          -- exfalso. apply Hnuconn. reflexivity.
          -- rewrite Hout. rewrite delete_union.
             rewrite delete_insert; eauto.
             rewrite delete_notin; eauto.
             solve_map_disjoint.
        + destruct H1 as (H1 & H2 & H3 & H4).
          exists x0. split_and!; eauto.
          -- intros v. rewrite H3.
             assert (out_edges g v1 !! i = Some x).
             { rewrite Hout. rewrite lookup_union lookup_insert.
                destruct (e1 !! i) eqn:E; simpl; eauto.
                specialize (Hdisj i). rewrite E in Hdisj. rewrite lookup_insert in Hdisj.
                simpl in *. done. }
             repeat case_decide; simplify_eq; eauto.
             ++ erewrite move_edge_out_edges; eauto.
                case_decide; simplify_eq.
                apply map_eq; intro.
                rewrite !lookup_union !lookup_insert_spec;
                repeat case_decide; simplify_eq; eauto.
                rewrite H0. simpl.
                destruct (out_edges g v2 !! i0) eqn:E; eauto; simpl.
                exfalso.
                apply Hnuconn.
                eapply rtc_transitive; eapply rtc_once; [left|right];
                eauto using some_edge_L.
             ++ erewrite move_edge_out_edges; eauto.
                repeat case_decide; simplify_eq. done.
          -- intros v. rewrite H4. rewrite move_edge_in_labels'; eauto.
    Qed.

    Lemma move_edges' g v1 v2 e1 e2 :
      cgraph_wf g ->
      ¬ uconn g v1 v2 ->
      e1 ##ₘ e2 ->
      out_edges g v1 = e1 ∪ e2 ->
      ∃ g', cgraph_wf g' ∧
        ¬ uconn g' v1 v2 ∧
        out_edges g' v1 = e1 ∧
        out_edges g' v2 = out_edges g v2 ∪ e2 ∧
        (∀ v, v ≠ v1 -> v ≠ v2 -> out_edges g' v = out_edges g v) ∧
        (∀ v, in_labels g' v ≡ in_labels g v).
    Proof.
      intros.
      edestruct move_edges as (?&?&?&?&?); eauto.
      eexists. split_and!; eauto.
      - specialize (H6 v1). case_decide; simplify_eq; done.
      - specialize (H6 v2). repeat case_decide; simplify_eq; done.
      - intros. specialize (H6 v); repeat case_decide; simplify_eq; eauto.
    Qed.
  End move_edges.

  Section exchange.
    Lemma exchange g v1 v2 e1 e2 :
      cgraph_wf g ->
      ¬ uconn g v1 v2 ->
      e1 ##ₘ e2 ->
      out_edges g v1 ∪ out_edges g v2 = e1 ∪ e2 ->
      ∃ g', cgraph_wf g' ∧
        ¬ uconn g' v1 v2 ∧
        out_edges g' v1 = e1 ∧
        out_edges g' v2 = e2 ∧
        (∀ v, v ≠ v1 -> v ≠ v2 -> out_edges g' v = out_edges g v) ∧
        (∀ v, in_labels g' v ≡ in_labels g v).
    Proof.
      intros Hwf Hnuconn Hdisj Hsplit.
      assert (out_edges g v1 ##ₘ out_edges g v2) as Hdisj'.
      { apply not_uconn_out_disjoint. done. }
      destruct (map_cross_split (e1 ∪ e2) _ _ _ Hdisj' Hdisj)
        as (e11 & e12 & e21 & e22 & Hdisj1 & Hdisj2 & Hdisj3 & Hdisj4 &
            ? & ? & HH1 & HH2); eauto; subst.

      destruct (move_edges' g v1 v2 e11 e12)
        as (g' & Hwf' & Hnuconn' & Hv1 & Hv2 & Hv & Hin); eauto.
      rewrite <-H1 in Hv2.
      rewrite <-assoc_L in Hv2; last apply _.
      rewrite map_union_comm in Hv2; last solve_map_disjoint.

      destruct (move_edges' g' v2 v1 (e22 ∪ e12) e21)
        as (g'' & Hwf'' & Hnuconn'' & Hv1' & Hv2' & Hv' & Hin'); eauto.
      { intro. apply Hnuconn'. symmetry. done. }
      { solve_map_disjoint. }

      eexists. split_and!; eauto.
      - intro. symmetry in H2. eauto.
      - rewrite Hv2' Hv1 //.
      - rewrite Hv1'. rewrite map_union_comm; eauto.
      - intros. rewrite Hv'; eauto.
      - intros. rewrite Hin'. eauto.
    Qed.
  End exchange.

  Section exchange_alloc.
    Lemma exchange_alloc g v1 v2 e1 e2 l :
      cgraph_wf g ->
      ¬ uconn g v1 v2 ->
      e1 ##ₘ e2 ->
      out_edges g v1 ∪ out_edges g v2 = e1 ∪ e2 ->
      ∃ g', cgraph_wf g' ∧
        out_edges g' v1 = <[v2:=l]> e1 ∧
        out_edges g' v2 = e2 ∧
        (∀ v, v ≠ v1 -> v ≠ v2 -> out_edges g' v = out_edges g v) ∧
        in_labels g' v2 ≡ {[ l ]} ⋅ in_labels g v2 ∧
        (∀ v, v ≠ v2 -> in_labels g' v ≡ in_labels g v).
    Proof.
      intros Hwf Hnuconn Hdisj Hsplit.
      destruct (exchange g v1 v2 e1 e2)
        as (g' & Hwf' & Hnuconn' & Hout1 & Hout2 & Hrest & Hin); eauto.
      exists (insert_edge g' v1 v2 l).
      split_and!.
      - eapply insert_edge_wf; eauto.
      - rewrite out_edges_insert_edge. sdec; done.
      - rewrite out_edges_insert_edge. sdec; eauto.
        exfalso. apply Hnuconn'. reflexivity.
      - intros. rewrite out_edges_insert_edge. sdec. eauto.
      - rewrite in_labels_insert_edge.
        + sdec. rewrite Hin. done.
        + intro. eapply Hnuconn'. eapply rtc_once. left. done.
      - intros. rewrite in_labels_insert_edge.
        + sdec. rewrite Hin. done.
        + intro. eapply Hnuconn'. eapply rtc_once. left. done.
    Qed.
  End exchange_alloc.

  Section exchange_dealloc.
    Lemma exchange_dealloc g v1 v2 e1 e2 l :
      cgraph_wf g ->
      out_edges g v1 !! v2 = Some l ->
      e1 ##ₘ e2 ->
      delete v2 (out_edges g v1) ∪ out_edges g v2 = e1 ∪ e2 ->
      ∃ g', cgraph_wf g' ∧
        ¬ uconn g' v1 v2 ∧
        out_edges g' v1 = e1 ∧
        out_edges g' v2 = e2 ∧
        (∀ v, v ≠ v1 -> v ≠ v2 -> out_edges g' v = out_edges g v) ∧
        (∀ x, in_labels g v2 ≡ {[ l ]} ⋅ x -> in_labels g' v2 ≡ x) ∧
        (∀ v, v ≠ v2 -> in_labels g' v ≡ in_labels g v).
    Proof.
      intros Hwf H1 Hdisj Hsplit.
      destruct (exchange (delete_edge g v1 v2) v1 v2 e1 e2)
        as (g' & Hwf' & Hnuconn' & Hout1 & Hout2 & Hrest & Hin).
      - eapply delete_edge_wf; eauto.
      - eapply delete_edge_uconn; eauto using some_edge_L.
      - eauto.
      - rewrite !out_edges_delete_edge. sdec; eauto.
        exfalso. eapply no_self_edge; eauto using some_edge_L.
      - exists g'. split_and!; eauto.
        + intros. rewrite Hrest; eauto.
          rewrite out_edges_delete_edge. sdec. done.
        + intros. rewrite Hin. rewrite in_labels_delete_edge_eq; last done; eauto.
        + intros. rewrite Hin.
          rewrite in_labels_delete_edge_neq; eauto.
    Qed.
  End exchange_dealloc.

  Section exchange_relabel.
    Lemma exchange_relabel g v1 v2 e1 e2 l l' :
      cgraph_wf g ->
      out_edges g v1 !! v2 = Some l ->
      e1 ##ₘ e2 ->
      delete v2 (out_edges g v1) ∪ out_edges g v2 = e1 ∪ e2 ->
      ∃ g', cgraph_wf g' ∧
        out_edges g' v1 = <[v2:=l']> e1 ∧
        out_edges g' v2 = e2 ∧
        (∀ v, v ≠ v1 -> v ≠ v2 -> out_edges g' v = out_edges g v) ∧
        (∀ x, in_labels g v2 ≡ {[ l ]} ⋅ x -> in_labels g' v2 ≡ {[ l' ]} ⋅ x) ∧
        (∀ v, v ≠ v2 -> in_labels g' v ≡ in_labels g v).
    Proof.
      intros Hwf H1 Hdisj Hsplit.
      destruct (exchange_dealloc g v1 v2 e1 e2 l)
        as (g' & Hwf' & Hnuconn' & Hout1 & Hout2 & Hrest & Hin2 & Hin); eauto.
      exists (insert_edge g' v1 v2 l').
      split_and!; eauto.
      - eapply insert_edge_wf; eauto.
      - rewrite out_edges_insert_edge. sdec; done.
      - rewrite out_edges_insert_edge. sdec; eauto.
        exfalso. apply Hnuconn'. reflexivity.
      - intros. rewrite out_edges_insert_edge. sdec.
        rewrite Hrest; eauto.
      - intros. rewrite in_labels_insert_edge.
        + sdec. rewrite Hin2; done.
        + intro. eapply Hnuconn'. eapply rtc_once. left. done.
      - intros. rewrite in_labels_insert_edge.
        + sdec. rewrite Hin; done.
        + intro. eapply Hnuconn'. eapply rtc_once. left. done.
    Qed.
  End exchange_relabel.

  Section setoids.

    Lemma exchange_alloc_S g v1 v2 e1 e2 l :
      cgraph_wf g ->
      ¬ uconn g v1 v2 ->
      e1 ##ₘ e2 ->
      out_edges g v1 ∪ out_edges g v2 ≡ e1 ∪ e2 ->
      ∃ g', cgraph_wf g' ∧
        out_edges g' v1 ≡ <[v2:=l]> e1 ∧
        out_edges g' v2 ≡ e2 ∧
        (∀ v, v ≠ v1 -> v ≠ v2 -> out_edges g' v ≡ out_edges g v) ∧
        in_labels g' v2 ≡ {[ l ]} ⋅ in_labels g v2 ∧
        (∀ v, v ≠ v2 -> in_labels g' v ≡ in_labels g v).
    Proof.
      intros Hwf Hnuconn Hdisj Hsplit.
      eapply map_union_equiv_eq in Hsplit as (y' & z' & Hsplit & Hy' & Hz').
      destruct (exchange_alloc g v1 v2 y' z' l)
        as (?&?&?&?&?&?&?); eauto.
      { rewrite Hy' Hz' //. }
      exists x.
      split_and!; eauto.
      - rewrite H1 Hy' //.
      - rewrite H2 Hz' //.
      - intros. rewrite H3 //.
    Qed.

    Lemma exchange_dealloc_S g v1 v2 e1 e2 l :
      cgraph_wf g ->
      out_edges g v1 !! v2 ≡ Some l ->
      e1 ##ₘ e2 ->
      delete v2 (out_edges g v1) ∪ out_edges g v2 ≡ e1 ∪ e2 ->
      ∃ g', cgraph_wf g' ∧
        ¬ uconn g' v1 v2 ∧
        out_edges g' v1 ≡ e1 ∧
        out_edges g' v2 ≡ e2 ∧
        (∀ v, v ≠ v1 -> v ≠ v2 -> out_edges g' v ≡ out_edges g v) ∧
        (∀ x, in_labels g v2 ≡ {[ l ]} ⋅ x -> in_labels g' v2 ≡ x) ∧
        (∀ v, v ≠ v2 -> in_labels g' v ≡ in_labels g v).
    Proof.
      intros Hwf Hout1 Hdisj Hsplit.
      eapply Some_equiv_eq in Hout1 as (y' & Hout1 & Hy').
      eapply map_union_equiv_eq in Hsplit as (y2' & z' & Hsplit & Hy2' & Hz').
      destruct (exchange_dealloc g v1 v2 y2' z' y')
        as (?&?&?&?&?&?&?&?); eauto.
      { rewrite Hy2' Hz' //. }
      eexists x.
      split_and!; eauto.
      - rewrite H2 //.
      - rewrite H3 //.
      - intros. rewrite H4 //.
      - intros. rewrite <-Hy' in H7. rewrite H5; last done. done.
    Qed.

    Lemma exchange_relabel_S g v1 v2 e1 e2 l l' :
      cgraph_wf g ->
      out_edges g v1 !! v2 ≡ Some l ->
      e1 ##ₘ e2 ->
      delete v2 (out_edges g v1) ∪ out_edges g v2 ≡ e1 ∪ e2 ->
      ∃ g', cgraph_wf g' ∧
        out_edges g' v1 ≡ <[v2:=l']> e1 ∧
        out_edges g' v2 ≡ e2 ∧
        (∀ v, v ≠ v1 -> v ≠ v2 -> out_edges g' v ≡ out_edges g v) ∧
        (∀ x, in_labels g v2 ≡ {[ l ]} ⋅ x -> in_labels g' v2 ≡ {[ l' ]} ⋅ x) ∧
        (∀ v, v ≠ v2 -> in_labels g' v ≡ in_labels g v).
    Proof.
      intros Hwf H1 Hdisj Hsplit.
      assert (∃ l2, l ≡ l2 ∧ out_edges g v1 !! v2 = Some l2)
        as (l2 & Hl2 & H1').
      { eapply Some_equiv_eq in H1 as (y' & HH & Hy').
        exists y'. eauto. }
      assert (∃ e1' e2',
        e1 ≡ e1' ∧ e2 ≡ e2' ∧
        e1' ##ₘ e2' ∧
        delete v2 (out_edges g v1) ∪ out_edges g v2 = e1' ∪ e2')
        as (e1' & e2' & He1 & He2 & Hdisj' & Hsplit').
      {
        eapply map_union_equiv_eq in Hsplit as (y' & z' & HH & Hy' & Hz').
        exists y', z'.
        split_and!; eauto.
        rewrite Hy'.
        rewrite Hz'. done.
      }
      destruct (exchange_relabel g v1 v2 e1' e2' l2 l')
        as (g' & Hwf' & Hv1' & Hv2' & Hrest' & Hin2' & Hin'); eauto.
      exists g'. split_and!; eauto.
      - rewrite Hv1'. rewrite He1. done.
      - rewrite Hv2'. done.
      - intros. rewrite Hrest'; eauto.
      - intros. rewrite Hin2'; first done.
        rewrite H0. rewrite Hl2. done.
    Qed.
  End setoids.

  Lemma cgraph_ind (R : V -> V -> Prop) (g : cgraph V L) (P : V -> Prop) :
    cgraph_wf g ->
    asym R ->
    (∀ x, (∀ y, R x y -> sc (edge g) x y -> P y) -> P x) -> (∀ x, P x).
  Proof.
    intros [] Hasy Hind.
    eapply uforest_ind; eauto.
    intros. eapply Hind.
    intros. eapply H2; eauto.
    eapply elem_of_to_uforest.
    done.
  Qed.

  (*
     The relation R x y l tells us for each pair of objects (x,y), what
     the waiting direction is for an edge x--[l]-->y labeled with l.
     If R x y l, then the waiting direction is in the same direction as the edge.
     If ¬R x y l, then waiting direction is in the opposite direction as the edge.
     So R tells us the waiting direction *relative to* the edge direction.
  *)
  Lemma cgraph_ind' (R : V -> V -> L -> Prop) (g : cgraph V L) (P : V -> Prop) :
    (∀ x y, Proper ((≡) ==> iff) (R x y)) ->
    cgraph_wf g ->
    (∀ x,
      (∀ y l, out_edges g x !! y ≡ Some l -> R x y l -> P y) ->
      (∀ y l, out_edges g y !! x ≡ Some l -> ¬ R y x l -> P y) ->
      P x) ->
    (∀ x, P x).
  Proof.
    intros Hproper Hwf Hind.
    eapply (cgraph_ind (λ x y,
      ∃ l, (out_edges g x !! y ≡ Some l ∧ R x y l) ∨
           (out_edges g y !! x ≡ Some l ∧ ¬ R y x l))); eauto.
    - destruct Hwf.
      intros ?? (l1 & [[]|[]]) (l2 & [[]|[]]).
      + exfalso. eapply H0; eauto using some_edge.
      + exfalso. rewrite ->H2 in H4. inversion H4. subst.
        eapply H5. rewrite <-H8. done.
      + exfalso. rewrite ->H2 in H4. inversion H4. subst.
        eapply H3. rewrite H8. done.
      + exfalso. eapply H0; eauto using some_edge.
    - intros. eapply Hind; intros.
      + eapply H0; eauto.
        left. eauto using some_edge.
      + eapply H0; eauto.
        right. eauto using some_edge.
  Qed.

  (* A version of the lemma where the R doesn't depend on the label. *)
  Lemma cgraph_ind'' (R : V -> V -> Prop) (g : cgraph V L) (P : V -> Prop) :
    cgraph_wf g ->
    (∀ x,
      (∀ y, edge g x y -> R x y -> P y) ->
      (∀ y, edge g y x -> ¬ R y x -> P y) ->
      P x) ->
    (∀ x, P x).
  Proof.
    intros Hwf Hind.
    eapply (cgraph_ind' (λ x y l, R x y)); [solve_proper|eauto|].
    intros. eapply Hind; intros ? [] ?.
    + eapply H0; eauto. rewrite H2. done.
    + eapply H1; eauto. rewrite H2. done.
  Qed.

End cgraph.


Require Export Iron.SystemF2Closure.Type.

(******************************************************************************)
(* Constants *)
Inductive const : Type :=
  | CUnit   : const
  | CNat    : nat   -> const
  | CBool   : bool  -> const.
Hint Constructors const.

Fixpoint typeOfConst (c : const) : ty :=
  match c with
  | CUnit     => TUnit
  | CNat  _   => TNat
  | CBool _   => TBool
  end.

(* Primitive Operators *)
Inductive op1 : Type :=
  | OSucc   : op1
  | OIsZero : op1.
Hint Constructors op1.

(* Values *)
Inductive val : Type :=
  | VVar    : nat   -> val
  | VLoc    : nat   -> val
  | VLam    : ty    -> exp -> val
  | VLAM    : ki    -> exp -> val
  | VConst  : const -> val

(* Expressions *)
with     exp : Type :=
  | XVal    : val -> exp

  (* Lift a literal to a pure computation. *)
  | XClose  : val -> exp    (* Construct a computation type. *)
  | XOpen   : val -> exp    (* Open   up a computation type. *)

  (* Sequence evaluation. *)
  | XLet    : ty  -> exp -> exp -> exp

  (* Function application. *)
  | XApp    : val -> val -> exp

  (* Type application. *)
  | XAPP    : val -> ty  -> exp

  (* Pure operators *)
  | XOp1    : op1 -> val -> exp

  (* Store operators *)
  | XNew    : exp -> exp
  | XAlloc  : ty  -> val -> exp
  | XRead   : ty  -> val -> exp
  | XWrite  : ty  -> val -> val -> exp.

Hint Constructors val.
Hint Constructors exp.

(******************************************************************************)
(* Induction principle for expressions. *)
Lemma exp_mutind : forall
    (PX : exp -> Prop)
    (PV : val -> Prop)
 ,  (forall n,                                     PV (VVar   n))
 -> (forall l,                                     PV (VLoc   l))
 -> (forall t x,        PX x                    -> PV (VLam   t x))
 -> (forall k x,        PX x                    -> PV (VLAM   k x))
 -> (forall c,                                     PV (VConst c))
 -> (forall v,          PV v                    -> PX (XVal   v))
 -> (forall v,          PV v                    -> PX (XClose v))
 -> (forall v,          PV v                    -> PX (XOpen v))
 -> (forall t x1 x2,    PX x1 -> PX x2          -> PX (XLet   t x1 x2))
 -> (forall v1 v2,      PV v1 -> PV v2          -> PX (XApp   v1 v2))
 -> (forall v t,        PV v                    -> PX (XAPP   v  t))
 -> (forall o v,        PV v                    -> PX (XOp1 o v))
 -> (forall x,          PX x                    -> PX (XNew   x))
 -> (forall r v,        PV v                    -> PX (XAlloc r v))
 -> (forall r v,        PV v                    -> PX (XRead  r v))
 -> (forall r v1 v2,    PV v1 -> PV v2          -> PX (XWrite r v1 v2))
 ->  forall x, PX x.
Proof.
 intros PX PV.
 intros hVar hLoc hLam hLAM hConst
        hVal
        hClose hOpen
        hLet  hApp   hAPP   hOp1
        hNew  hAlloc hRead  hWrite.
 refine (fix  IHX x : PX x := _
         with IHV v : PV v := _
         for  IHX).

 (* expressions *)
 case x; intros.
 apply hVal.   apply IHV.
 apply hClose. apply IHV.
 apply hOpen.  apply IHV.
 apply hLet.   apply IHX. apply IHX.
 apply hApp.   apply IHV. apply IHV.
 apply hAPP.   apply IHV.
 apply hOp1.   apply IHV.
 apply hNew.   apply IHX.
 apply hAlloc. apply IHV.
 apply hRead.  apply IHV.
 apply hWrite. apply IHV. apply IHV.

 (* values *)
 case v; intros.
 apply hVar.
 apply hLoc.
 apply hLam. apply IHX.
 apply hLAM. apply IHX.
 apply hConst.
Qed.


Load LFindLoad.
From lfind Require Import LFind.
From adtind Require Import goal1.

Set Printing Depth 1000.
Definition lfind_eval  x:=
Succ x.

Compute lfind_eval  (Succ (Succ (Succ (Succ (Succ Zero))))).

Compute lfind_eval  (Succ (Succ Zero)).

Compute lfind_eval  (Succ (Succ (Succ Zero))).

Compute lfind_eval  (Succ Zero).

Compute lfind_eval  (Zero).


Load LFindLoad.
From lfind Require Import LFind.
From QuickChick Require Import QuickChick.
From adtind Require Import goal33.

Derive Show for natural.

              Derive Arbitrary for natural.

              Instance Dec_Eq_natural : Dec_Eq natural.

              Proof. dec_eq. Qed.

Lemma conj24synthconj5 : forall  (lv0 : natural) (lv1 : natural) (lv2 : natural) (lv3 : natural), (@eq natural (plus (plus lv0 lv1) (plus Zero (Succ lv2))) (plus (mult lv2 lv3) lv3)).
Admitted.
QuickChick conj24synthconj5.


(** * 6.887 Formal Reasoning About Programs - Lab 7
    * Linear Types *)

Require Import Frap.
Require Import Classical. (* Classical lets us compare two terms of any type,
                           * which simplifies the proof. *)

Ltac compare_for_equality e1 e2 := destruct (classic (e1 = e2)); subst; simplify; try equality.

(* Authors: Peng Wang (wangpeng@csail.mit.edu), Adam Chlipala (adamc@csail.mit.edu) *)

(** * Linear Types *)

(* The references type system presented in lecture keeps track of allocated
 * memory cells but doesn't keep track of "freed" cells (actually it doesn't
 * even allow freeing).  *Linear types* provide more precise control of memory
 * (and other resource) usage.  In a linear type system, each constructed object
 * can and must be used exactly once.  After it's used, it is considered
 * *consumed* and can't be used again.  There cannot be "double freeing", where
 * an object is consumed twice; nor can there be any "dangling object", an
 * object that is unused but can't be mentioned anymore.
 *
 * To statically guarantee these properties, the main idea of linear type
 * systems is to treat each variable in the typing context (i.e. static scoping
 * context) as a resource floating around that's available to use, and once that
 * variable is mentioned in an expression, it is considered *consumed* and
 * removed from the typing context (i.e. goes out of scope).  Additionally, for
 * an expression to be well-typed against a typing context, the expression must
 * use up all the variables in the context.  There cannot be any extra variables
 * left behind.  (Cue bad joke about "no man left behind!" in classic war
 * movies.)
 *
 * Let's define a linear type system and prove it sound.  We recommend
 * consulting book source file TypesAndMutation.v for the self-contained proof
 * of the type system for mutable references without deallocation, which has
 * much in common with this new proof. *)

Notation loc := nat.

Inductive exp : Set :=
| Var (x : var)
| Const (b : bool)
| If (condition true_branch false_branch : exp)
| Abs (x : var) (e1 : exp)
| App (e1 e2 : exp)

| Loc (l : loc)
(* Like in the last type system for references, explicit locations only appear
 * in the middle of executions.  They shouldn't appear in a program. *)
.

Inductive type :=
| Bool
| Fun (dom ran : type)
.

(* When are two finite maps disjoint? *)
Definition disjoint {K V} (G1 G2 : fmap K V) :=
  forall x t1 t2,
    G1 $? x = Some t1 ->
    G2 $? x = Some t2 ->
    False.

Arguments disjoint / .

(* Finite map [m] splits into disjoint maps [m1] and [m2]. *)
Definition split {K V} (m m1 m2 : fmap K V) :=
  (m1 $<= m) /\
  (m2 $<= m) /\
  disjoint m1 m2 /\
  (forall k, m1 $? k = None -> m2 $? k = None -> m $? k = None).
(* The [$<=] operator is for "submap": all mappings of the first map are also in
 * the second map. *)

(* This is a version of typing rules that doesn't mention explicit locations. It
 * is what we need to type-check a program. *)
Inductive hasty0 : fmap var type -> exp -> type -> Prop :=
| Ht0Var : forall x t,
    hasty0 ($0 $+ (x, t)) (Var x) t
(* Since variable [x] is the whole expression, the context must only contain
 * [x], as we couldn't possibly "use up" any other variables.  A linearly typed
 * expression is obligated to use up all variables in scope! *)

| Ht0Const : forall b,
    hasty0 $0 (Const b) Bool
(* No variable is used, so the context must be empty. *)

| Ht0If : forall G G1 G2 e e1 e2 t,
    hasty0 G1 e Bool ->
    hasty0 G2 e1 t ->
    hasty0 G2 e2 t ->
    split G G1 G2 ->
    hasty0 G (If e e1 e2) t
(* For a compound expression such as [If], we must partition the resource pool
 * (i.e. typing context [G]) and let each subexpression use one subpool. *)

| Ht0Abs : forall G x e1 t1 t2,
    hasty0 (G $+ (x, t1)) e1 t2 ->
    G $? x = None ->
    (* [x] mustn't "shadow" an existing resource, because each resource must be
     * consumed exactly once. *)
    hasty0 G (Abs x e1) (Fun t1 t2)

| Ht0App : forall G G1 G2 e1 e2 t1 t2,
    hasty0 G1 e1 (Fun t1 t2) ->
    hasty0 G2 e2 t1 ->
    split G G1 G2 ->
    hasty0 G (App e1 e2) t2
(* Partitions resource pool, similarly to [If]. *)
.

Hint Constructors hasty0.

Fixpoint subst (e1 : exp) (x : string) (e2 : exp) : exp :=
  match e2 with
    | Var y => if y ==v x then e1 else Var y
    | Const n => Const n
    | If e2c e2t e2f => If (subst e1 x e2c) (subst e1 x e2t) (subst e1 x e2f)
    | Abs y e2' => Abs y (if y ==v x then e2' else subst e1 x e2')
    | App e2' e2'' => App (subst e1 x e2') (subst e1 x e2'')
    | Loc l => Loc l
  end.

(* Now let's turn to operational semantics and see how the "consumed once"
 * policy is enforced by the runtime.  To enforce it, we evaluate an expression
 * with a heap.  Every constructed object (e.g. a Boolean value, a function
 * abstraction, etc.) is immediatly put onto the heap, and the expression only
 * retains a pointer.  Once the pointer is used in an elimination step (e.g.
 * condition test, function application, etc.), the object is removed from the
 * heap. Thus, if the expression attempts to use the pointer again, it will get
 * stuck. *)

Definition heap := fmap loc exp.

Inductive value : exp -> Prop :=
| VLoc : forall l, value (Loc l)
(* We only treat pointers as final values, since constructed objects are
 * immediately put onto the heap.  Note that it is especially realistic to
 * represent function values with locations, since real functional-language
 * implementations almost always represent functions with *closures*,
 * dynamically allocated data structures of arbitrary tree shapes, stored in a
 * garbage-collected heap.  The linear type system saves us from needing to do
 * garbage collection, as we can reclaim storage for each value as we use it. *)
.

Inductive step0 : heap * exp -> heap * exp -> Prop :=
| Beta : forall h l x e v,
    h $? l = Some (Abs x e) ->
    value v ->
    step0 (h, App (Loc l) v) (h $- l, subst v x e)
(* Retrieve the function abstraction via the pointer [l] and remove it from the
 * heap. *)

| IfTrue : forall h l e1 e2,
    h $? l = Some (Const true) ->
    step0 (h, If (Loc l) e1 e2) (h $- l, e1)
(* Retrieve the Boolean value via the pointer [l] and remove it from the
 * heap. *)

| IfFalse : forall h l e1 e2,
    h $? l = Some (Const false) ->
    step0 (h, If (Loc l) e1 e2) (h $- l, e2)

| StoreConst : forall h b l,
    h $? l = None ->
    step0 (h, Const b) (h $+ (l, Const b), Loc l)
(* When a value is constructed, it is immediately put onto the heap and referred
 * to by a pointer in the expression. *)

| StoreAbs : forall h x e l,
    h $? l = None ->
    step0 (h, Abs x e) (h $+ (l, Abs x e), Loc l)
.

Inductive context : Set :=
| Hole : context
| If1 : context -> exp -> exp -> context
| App1 : context -> exp -> context
| App2 : exp -> context -> context
.

Inductive plug : context -> exp -> exp -> Prop :=
| PlugHole : forall e, plug Hole e e
| PlugIf1 : forall C e e' e1 e2,
    plug C e e'
    -> plug (If1 C e1 e2) e (If e' e1 e2)
| PlugApp1 : forall e e' C e2,
  plug C e e'
  -> plug (App1 C e2) e (App e' e2)
| PlugApp2 : forall e e' v1 C,
  value v1
  -> plug C e e'
  -> plug (App2 v1 C) e (App v1 e')
.

Inductive step : heap * exp -> heap * exp -> Prop :=
| StepRule : forall C e1 e2 e1' e2' h h',
  plug C e1 e1'
  -> plug C e2 e2'
  -> step0 (h, e1) (h', e2)
  -> step (h, e1') (h', e2').

Definition trsys_of (e : exp) := {|
  Initial := {($0, e)};
  Step := step
|}.

(** * Type soundness *)

(* This is an extended version of the typing rules that involves heap typing.
 * Heap typing is treated in a similar way as the typing context, i.e. it
 * cannot contain unused resources and it is properly partitioned among
 * subexpressions, etc.  *)
Inductive hasty : fmap loc type -> fmap var type -> exp -> type -> Prop :=
| HtVar : forall x t,
    hasty $0 ($0 $+ (x, t)) (Var x) t
(* No mention of locations, so heap typing must be empty. *)

| HtConst : forall b,
    hasty $0 $0 (Const b) Bool

| HtIf : forall H H1 H2 G G1 G2 e e1 e2 t,
    hasty H1 G1 e Bool ->
    hasty H2 G2 e1 t ->
    hasty H2 G2 e2 t ->
    split H H1 H2 ->
    split G G1 G2 ->
    hasty H G (If e e1 e2) t
(* Heap typing [H] is partitioned similarly to typing context [G]. *)

| HtAbs : forall H G x e1 t1 t2,
    hasty H (G $+ (x, t1)) e1 t2 ->
    G $? x = None ->
    hasty H G (Abs x e1) (Fun t1 t2)

| HtApp : forall H H1 H2 G G1 G2 e1 e2 t1 t2,
    hasty H1 G1 e1 (Fun t1 t2) ->
    hasty H2 G2 e2 t1 ->
    split H H1 H2 ->
    split G G1 G2 ->
    hasty H G (App e1 e2) t2

| HtLoc : forall l t,
    hasty ($0 $+ (l, t)) $0 (Loc l) t
(* [l] is the whole expression, so the heap typing contains only [l]. *)
.

Hint Constructors hasty.

(* Some lemmas about [fmap] that are likely to come in handy: *)
Lemma includes_refl K V (m : fmap K V) : m $<= m.
Proof.
  intros.
  eapply includes_intro; intros.
  eauto.
Qed.

Lemma split_0_intro K V (m : fmap K V) : split m $0 m.
Proof.
  intros.
  unfold split in *; simplify; propositional; eauto.
  eapply includes_refl.
Qed.

(* CHALLENGE #1: prove that [hasty0] implies [hasty] with an empty heap. *)

Lemma hasty0_hasty G e t :
  hasty0 G e t ->
  hasty $0 G e t.
Proof.
Admitted.

(* The only things that can be stored on the heap are Boolean constants and
 * function abstractions. *)
Inductive storable : exp -> Prop :=
| SConst : forall b,
    storable (Const b)
| SAbs : forall x e,
    storable (Abs x e)
.

(* The heap is finite. *)
Inductive growable (h : heap) : Prop :=
| Growable : forall bound,
    (forall l, l >= bound -> h $? l = None) ->
    growable h.

Hint Constructors value plug step0 step storable growable.

(* Another bunch of fmap lemmas *)
Lemma fmap_eq_elim {K V} {m1 m2 : fmap K V} : m1 = m2 -> forall k, m1 $? k = m2 $? k.
Proof.
  intros.
  subst.
  eauto.
Qed.

Lemma add_neq_empty K V (m : fmap K V) (k : K) (v : V) : m $+ (k, v) <> $0.
Proof.
  intro H.
  specialize (fmap_eq_elim H k).
  simplify; equality.
Qed.

Lemma includes_elim {K V} {m1 m2 : fmap K V} :
  m1 $<= m2 ->
  forall k v,
    m1 $? k = Some v ->
    m2 $? k = Some v.
Proof.
  intros.
  eauto.
Qed.

Lemma includes_empty K V (m : fmap K V) : m $<= $0 -> m = $0.
Proof.
  intros.
  maps_equal.
  cases (m $? k); eauto.
  specialize (includes_elim H _ _ Heq); simplify; eauto.
Qed.

Lemma split_0 K V (G1 G2 : fmap K V) : split $0 G1 G2 -> G1 = $0 /\ G2 = $0.
Proof.
  intros.
  unfold split in *; propositional; eapply includes_empty; eauto.
Qed.

Ltac t0 := match goal with
           | [ H : ex _ |- _ ] => invert H
           | [ H : _ /\ _ |- _ ] => invert H
           | [ |- context[?x ==v ?y] ] => cases (x ==v y)
           | [ H : Some _ = Some _ |- _ ] => invert H
           | [ H : growable _ |- _ ] => invert H
           | [ H : step _ _ |- _ ] => invert H
           | [ H : step0 _ _ |- _ ] => invert1 H
           | [ H : hasty _ _ ?e _, H' : storable ?e |- _ ] => (invert H'; invert H); []
           | [ H : hasty _ _ ?e _, H' : value ?e |- _ ] => (invert H'; invert H); []
           | [ H : hasty _ _ _ _ |- _ ] => invert1 H
           | [ H : plug _ _ _ |- _ ] => invert1 H
           | [ H : split _ _ _ |- _ ] => eapply split_0 in H
           | [ H : _ $+ (_, _) = $0 |- _ ] => eapply add_neq_empty in H
           | [ H : $0 = _ $+ (_, _) |- _ ] => symmetry in H; eapply add_neq_empty in H
           end; subst.

(* A tactic that will be your friend *)
Ltac t := simplify; propositional; repeat (t0; simplify); try equality; eauto 7.

Hint Extern 2 (exists _ : _ * _, _) => eexists (_ $+ (_, _), _).

(* ========== BEGIN : a WHOLE bunch of [fmap] lemmas! ===================== *)
Lemma includes_None K V (m1 m2 : fmap K V) : m1 $<= m2 -> forall k, m2 $? k = None -> m1 $? k = None.
Proof.
  intros.
  cases (m1 $? k); eauto.
  specialize (includes_elim H _ _ Heq); intros Hsome; t.
Qed.
Hint Resolve includes_None.

Lemma includes_trans K V (m1 m2 m3 : fmap K V) : m1 $<= m2 -> m2 $<= m3 -> m1 $<= m3.
Proof.
  intros.
  eapply includes_intro; intros.
  t.
Qed.

Lemma remove_includes K V (m : fmap K V) k : m $- k $<= m.
Proof.
  intros.
  eapply includes_intro; intros.
  compare_for_equality k0 k.
Qed.

Lemma join_Some_elim K V (m1 m2 : fmap K V) k v : (m1 $++ m2) $? k = Some v -> m1 $? k = Some v \/ m2 $? k = Some v.
Proof.
  intros.
  cases (m1 $? k).
  {
    rewrite lookup_join1 in H; t.
    eapply lookup_Some_dom; eauto.
  }
  {
    rewrite lookup_join2 in H; eauto.
    eapply lookup_None_dom; eauto.
  }
Qed.

Lemma join_None_intro K V (m1 m2 : fmap K V) k : m1 $? k = None -> m2 $? k = None -> (m1 $++ m2) $? k = None.
Proof.
  intros.
  rewrite lookup_join2; eauto.
  eapply lookup_None_dom; eauto.
Qed.

Lemma join_None_elim K V (m1 m2 : fmap K V) k : (m1 $++ m2) $? k = None -> m1 $? k = None /\ m2 $? k = None.
Proof.
  intros.
  cases (m1 $? k).
  {
    rewrite lookup_join1 in H; t.
    eapply lookup_Some_dom; eauto.
  }
  {
    rewrite lookup_join2 in H; eauto.
    eapply lookup_None_dom; eauto.
  }
Qed.

Lemma join_add K V (m1 m2 : fmap K V) k v : m1 $++ m2 $+ (k, v) = m1 $+ (k, v) $++ m2.
Proof.
  intros.
  maps_equal.
  {
    rewrite lookup_join1; simplify; eauto.
    sets.
  }
  cases (m1 $? k0).
  {
    eapply lookup_Some_dom in Heq.
    rewrite lookup_join1; simplify; eauto.
    rewrite lookup_join1; simplify; eauto.
    sets.
  }
  {
    eapply lookup_None_dom in Heq.
    rewrite lookup_join2; simplify; eauto.
    rewrite lookup_join2; simplify; eauto.
    sets.
  }
Qed.

Lemma join_includes K V (m1 m2 m : fmap K V) : m1 $<= m -> m2 $<= m -> m1 $++ m2 $<= m.
Proof.
  intros.
  eapply includes_intro; intros.
  eapply join_Some_elim in H1; t.
Qed.

Lemma includes_join_l K V (m1 m2 : fmap K V) : m1 $<= m1 $++ m2.
Proof.
  eapply includes_intro.
  t.
  rewrite lookup_join1; eauto.
  eapply lookup_Some_dom; eauto.
Qed.

Lemma includes_join_r K V (m1 m2 : fmap K V) : disjoint m1 m2 -> m2 $<= m1 $++ m2.
Proof.
  simplify.
  eapply includes_intro.
  t.
  cases (m1 $? k); subst; simplify.
  {
    exfalso; t.
  }
  rewrite lookup_join2; eauto.
  eapply lookup_None_dom; eauto.
Qed.

Lemma add_remove K V (m : fmap K V) k v : m $? k = None -> m $+ (k, v) $- k = m.
Proof.
  intros.
  maps_equal.
  compare_for_equality k0 k.
Qed.

Lemma add_remove_neq V (m : fmap loc V) k v k' :
  k' <> k ->
  m $+ (k, v) $- k' = m $- k' $+ (k, v).
Proof.
  intros.
  maps_equal.
  cases (k0 ==n k'); subst; simplify; eauto.
Qed.

Lemma remove_add K V (m : fmap K V) k v : m $? k = Some v -> m = m $- k $+ (k, v).
Proof.
  intros.
  maps_equal; eauto.
Qed.

Lemma disjoint_add K V (m1 m2 : fmap K V) k v : disjoint m1 m2 -> m2 $? k = None -> disjoint (m1 $+ (k, v)) m2.
Proof.
  t.
Qed.

Lemma split_symm {K V} {m m1 m2 : fmap K V} : split m m1 m2 -> split m m2 m1.
Proof.
  intros.
  unfold split in *; t.
Qed.

Lemma join_split K V (m1 m2 : fmap K V) : disjoint m1 m2 -> split (m1 $++ m2) m1 m2.
Proof.
  intros.
  unfold split in *; t.
  {
    eapply includes_join_l; eauto.
  }
  {
    eapply includes_join_r; eauto.
  }
  {
    eapply join_None_intro; eauto.
  }
Qed.

Lemma split_to_0 K V (m m2 : fmap K V) : split m $0 m2 -> m = m2.
Proof.
  intros.
  unfold split in *; t.
  maps_equal.
  cases (m2 $? k); t.
Qed.

Lemma split_0_intro_r K V (m : fmap K V) : split m m $0.
Proof.
  eapply split_symm.
  eapply split_0_intro.
Qed.

Lemma split_singleton_elim K V (m m2 : fmap K V) k v : split m ($0 $+ (k, v)) m2 -> m = m2 $+ (k, v) /\ m2 $? k = None.
Proof.
  unfold split in *.
  t.
  {
    maps_equal.
    eapply includes_lookup; eauto; simplify; eauto.
    cases (m2 $? k0).
    {
      eapply includes_lookup; eauto; simplify; eauto.
    }
    eapply H3; simplify; eauto.
  }
  {
    cases (m2 $? k); try trivial.
    exfalso.
    eapply H1; eauto.
    simplify; eauto.
  }
Qed.

Lemma split_lookup_same K V (m m1 m2 : fmap K V) k v1 v2 : split m m1 m2 -> m $? k = Some v1 -> m1 $? k = Some v2 -> v2 = v1.
Proof.
  intros.
  assert (Hinc : m1 $<= m) by (unfold split in *; t).
  specialize (includes_elim Hinc _ _ H1); intros Hsome.
  rewrite H0 in Hsome.
  equality.
Qed.

Lemma split_None K V (m m1 m2 : fmap K V) k : split m m1 m2 -> m $? k = None -> m1 $? k = None /\ m2 $? k = None.
Proof.
  intros.
  unfold split in *; t.
Qed.

Lemma split_remove K V (m m1 m2 : fmap K V) k v : split m m1 m2 -> m1 $? k = Some v -> split (m $- k) (m1 $- k) m2.
Proof.
  intros.
  unfold split in *; t.
  {
    eapply includes_intro; intros.
    compare_for_equality k0 k;
      specialize (includes_elim H1 _ _ H3); intros Hv; simplify; t.
  }
  {
    eapply includes_intro; intros.
    compare_for_equality k0 k;
      specialize (includes_elim H _ _ H3); intros Hv; simplify; t.
    exfalso; t.
  }
  {
    compare_for_equality x k;
      specialize (includes_elim H _ _ H5); intros Hv; simplify; t.
  }
  {
    compare_for_equality k0 k;
    t.
  }
Qed.

Lemma split_distr_intro K V (G G1 G2 : fmap K V) k v :
  split G G1 G2 ->
  G $? k = None ->
  split (G $+ (k, v)) (G1 $+ (k, v)) G2.
Proof.
  intros.
  unfold split in *; t.
  {
    eapply includes_intro; intros.
    compare_for_equality k0 k;
      specialize (includes_elim H _ _ H3); intros Hv; simplify; t.
  }
  {
    compare_for_equality x k;
      specialize (includes_elim H _ _ H5); intros Hv; simplify; t.
  }
  {
    compare_for_equality k0 k;
    t.
  }
Qed.

Lemma split_distr K V (G G1 G2 : fmap K V) k v :
  split (G $+ (k, v)) G1 G2 ->
  G $? k = None ->
  G1 = G1 $- k $+ (k, v) /\ G2 $? k = None /\ split G (G1 $- k) G2 \/
                                            G2 = G2 $- k $+ (k, v) /\ G1 $? k = None /\ split G G1 (G2 $- k).
Proof.
  intros.
  unfold split in *.
  cases (G1 $? k); subst; simplify.
  {
    left.
    assert (Hv : v0 = v).
    {
      t.
      specialize (includes_elim H1 _ _ Heq); intros Hv; simplify.
      t.
    }
    subst.
    t; eauto.
    {
      eapply remove_add; eauto.
    }
    {
      cases (G2 $? k); eauto.
      exfalso; t.
    }
    {
      eapply includes_intro; intros.
      compare_for_equality k0 k;
      specialize (includes_elim H1 _ _ H3); intros Hv; simplify.
      eauto.
    }
    {
      cases (G2 $? k); eauto.
      {
        exfalso; t.
      }
      eapply includes_intro; intros.
      compare_for_equality k0 k;
      specialize (includes_elim H _ _ H3); intros Hv; simplify.
      eauto.
    }
    {
      compare_for_equality x k;
      exfalso; t.
    }
    {
      compare_for_equality k0 k;
      specialize (H4 k0); t.
    }
  }
  cases (G2 $? k); subst; simplify.
  {
    right.
    assert (Hv : v0 = v).
    {
      t.
      specialize (includes_elim H _ _ Heq0); intros Hv; simplify.
      t.
    }
    subst.
    t; eauto.
    {
      eapply remove_add; eauto.
    }
    {
      eapply includes_intro; intros.
      compare_for_equality k0 k;
      specialize (includes_elim H1 _ _ H3); intros Hv; simplify.
      eauto.
    }
    {
      eapply includes_intro; intros.
      compare_for_equality k0 k;
      specialize (includes_elim H _ _ H3); intros Hv; simplify.
      eauto.
    }
    {
      compare_for_equality x k;
      exfalso; t.
    }
    {
      compare_for_equality k0 k;
      specialize (H4 k0); t.
    }
  }
  t.
  specialize (H4 k); t.
Qed.

Lemma split_singleton_intro K V (m : fmap K V) k v : m $? k = None -> split (m $+ (k, v)) ($0 $+ (k, v)) m.
Proof.
  intros.
  eapply split_distr_intro; eauto.
  eapply split_0_intro.
Qed.

Lemma split_twice {K V} {m m1 m2 m1a m1b : fmap K V} : split m m1 m2 -> split m1 m1a m1b -> split m (m1a $++ m2) m1b /\ split (m1a $++ m2) m1a m2.
Proof.
  intros.
  unfold split in *.
  t; eauto using includes_trans.
  {
    eapply join_includes; eauto using includes_trans.
  }
  {
    eapply join_Some_elim in H5.
    t.
  }
  {
    eapply join_None_elim in H5.
    t.
  }
  {
    eapply includes_join_l; eauto.
  }
  {
    eapply includes_join_r; t.
  }
  {
    eapply join_None_intro; eauto.
  }
Qed.
(* ========== END : a WHOLE bunch of [fmap] lemmas! ===================== *)

(* some [growable] lemmas *)
Lemma growable_0 : growable $0.
Proof.
  eapply Growable with (bound := 0).
  simplify.
  eauto.
Qed.

Lemma growable_singleton m k v : growable m -> growable (m $+ (k, v)).
Proof.
  intros.
  invert H.
  eapply Growable with (bound := max bound (k + 1)).
  intros.
  cases (l ==n k); subst; simplify; try linear_arithmetic.
  eapply H0; linear_arithmetic.
Qed.

(* We need a relation describing when a heap adheres to a heap typing.  Getting
 * it right turned out to be very tricky!  So we'll just give it away here, with
 * all the lemmas about it that you'll need. *)
Inductive heapty : fmap loc type -> heap -> Prop :=
| HtEmpty :
    heapty $0 $0
| HtAdd : forall ht h l t e ht'' ht',
    ht $? l = None ->
    h $? l = None ->
    storable e ->
    split ht'' ht ht' ->
    (* Heap cells in [h $+ (l, e)] reachable from [e] are accounted as [e]'s private
       resources, so they are not covered by [ht]. However, when we remove [(l, e)]
       from [h $+ (l, e)], those cells are exposed and no longer [e]'s private
       resources, so there must exists some extra heap typing [ht'] to cover them. *)
    heapty ht'' h ->
    (* [h] is therefore covered by [ht $++ ht'], which is [ht'']. *)
    hasty ht' $0 e t ->
    (* the extra heap typing [ht'] should actually cover [e]'s private resources *)
    heapty (ht $+ (l, t)) (h $+ (l, e))
.

Hint Constructors heapty.

Lemma heapty_elim_None ht h :
  heapty ht h ->
  forall l,
    h $? l = None ->
    ht $? l = None.
Proof.
  induct 1; t.
  cases (l0 ==n l); subst; simplify; try equality.
  eapply IHheapty in H5.
  eapply split_None in H2; t.
Qed.

Lemma split_heapty ht h :
  heapty ht h ->
  forall ht1 ht2,
    split ht ht1 ht2 ->
    exists h1 h2,
      split h h1 h2 /\
      heapty ht1 h1 /\
      heapty ht2 h2.
Proof.
  induct 1; t.
  {
    exists $0, $0.
    t.
    eapply split_0_intro; eauto.
  }
  generalize H5; intro Hsp.
  eapply split_distr in Hsp; try trivial.
  t.
  {
    assert (Hsp : split ht'' (ht1 $- l $++ ht') ht2).
    {
      specialize (split_twice H2 H9); intros Hsp.
      t.
    }
    eapply IHheapty in Hsp.
    destruct Hsp as [h1 [h2 Hsp] ].
    propositional.
    assert (Hsp : split (h $+ (l, e)) (h1 $+ (l, e)) h2).
    {
      eapply split_distr_intro; eauto.
    }
    do 2 eexists; t.
    rewrite H7.
    assert (Hsp2 : split (ht1 $- l $++ ht') (ht1 $- l) ht').
    {
      specialize (split_twice H2 H9); intros Hsp3.
      t.
    }
    econstructor; simplify; try trivial.
    {
      eapply split_None in H8; eauto.
      propositional.
    }
    {
      eapply Hsp2.
    }
    {
      eauto.
    }
    {
      eauto.
    }
  }
  {
    assert (Hsp : split ht'' ht1 (ht2 $- l $++ ht')).
    {
      specialize (split_twice H2 (split_symm H9)); intros Hsp.
      t.
      eapply split_symm; eauto.
    }
    eapply IHheapty in Hsp.
    destruct Hsp as [h1 [h2 Hsp] ].
    propositional.
    assert (Hsp : split (h $+ (l, e)) h1 (h2 $+ (l, e))).
    {
      eapply split_symm.
      eapply split_distr_intro; eauto.
      eapply split_symm; eauto.
    }
    do 2 eexists; t.
    rewrite H7.
    assert (Hsp2 : split (ht2 $- l $++ ht') (ht2 $- l) ht').
    {
      specialize (split_twice H2 (split_symm H9)); intros Hsp3.
      t.
    }
    econstructor; simplify; try trivial.
    {
      eapply split_None in H8; eauto.
      propositional.
    }
    {
      eapply Hsp2.
    }
    {
      eauto.
    }
    {
      eauto.
    }
  }
Qed.

Lemma split_heapty_intro h1 ht1 :
  heapty ht1 h1 ->
  forall h ht2 h2,
    split h h1 h2 ->
    heapty ht2 h2 ->
    exists ht,
      split ht ht1 ht2 /\
      heapty ht h.
Proof.
  induct 1; t.
  {
    eapply split_to_0 in H.
    subst.
    exists ht2.
    propositional.
    eapply split_0_intro.
  }
  assert (Hsp : split (h0 $- l) h h2).
  {
    eapply split_remove with (k := l) in H5; simplify; eauto.
    rewrite add_remove in H5 by (simplify; eauto).
    eauto.
  }
  assert (Hh0 : h0 = h0 $- l $+ (l, e)).
  {
    eapply remove_add.
    unfold split in *; t.
    specialize (includes_elim H2 l); simplify; eauto.
  }
  eapply IHheapty in Hsp; eauto.
  destruct Hsp as [Ht''' Hsp].
  propositional.
  exists (ht $++ ht2 $+ (l, t)).
  assert (Hsp : split Ht''' (ht $++ ht2) ht').
  {
    specialize (split_twice H7 H2); intros Hsp.
    t.
  }
  assert (Hsp2 : split (ht $++ ht2) ht ht2).
  {
    specialize (split_twice H7 H2); intros Hsp2.
    t.
  }
  assert (Hnone : (ht $++ ht2) $? l = None).
  {
    eapply heapty_elim_None with (l := l) in H8; simplify; eauto.
    eapply split_None in Hsp; t.
  }
  propositional.
  {
    rewrite join_add.
    eapply join_split.
    eapply disjoint_add.
    {
      unfold split in *; t.
    }
    eapply split_None in Hnone; t.
  }
  rewrite Hh0.
  econstructor; simplify; try trivial.
  {
    eapply Hsp.
  }
  {
    eauto.
  }
  {
    eauto.
  }
Qed.

Lemma heapty_elim ht h :
  heapty ht h ->
  (forall l t,
      ht $? l = Some t ->
      exists e ht' ht'',
        h $? l = Some e /\
        storable e /\
        split ht'' (ht $- l) ht' /\
        heapty ht'' (h $- l) /\
        hasty ht' $0 e t) /\
  (ht = $0 -> h = $0).
Proof.
  induct 1; t.
  cases (l0 ==n l); subst; simplify.
  {
    invert H7.
    repeat rewrite add_remove by (simplify; eauto).
    do 3 eexists; t.
  }
  assert (Hht'' : ht'' $? l0 = Some t0) by (unfold split in *; t).
  repeat rewrite add_remove_neq by eauto.
  eapply H5 in Hht''.
  t.
  exists x, x0, (ht $- l0 $++ x0 $+ (l, t)).
  assert (Hsp0 : split (ht'' $- l0) (ht $- l0) ht').
  {
    eapply split_remove in H2; eauto.
  }
  assert (Hsp : split x1 (ht $- l0 $++ x0) ht').
  {
    specialize (split_twice H10 Hsp0); intros Hsp.
    t.
  }
  assert (Hsp2 : split (ht $- l0 $++ x0) (ht $- l0) x0).
  {
    specialize (split_twice H10 Hsp0); intros Hsp2.
    t.
  }
  assert (Hnone : (ht $- l0 $++ x0) $? l = None).
  {
    eapply heapty_elim_None with (l := l) in H11; t.
    eapply split_None in Hsp; t.
  }
  t; try trivial.
  {
    rewrite join_add.
    eapply join_split.
    eapply disjoint_add.
    {
      unfold split in *; t.
    }
    eapply split_None in Hnone; t.
  }
  econstructor; simplify; try trivial.
  {
    eapply Hsp.
  }
  {
    eauto.
  }
  {
    eauto.
  }
Qed.

(* The next challenge is to prove the safety of well-typed programs.  We break
 * it apart into several challenges to make it more manageable. *)

(* CHALLENGE #2: prove this [progress'] lemma. *)
Lemma progress' : forall ht e t,
    hasty ht $0 e t ->
    forall h h',
      heapty ht h ->
      h $<= h' ->
      growable h' ->
      value e
      \/ exists he', step (h', e) he'.
Proof.
Admitted.

Hint Resolve includes_refl.
Hint Resolve remove_includes.
Hint Resolve split_0_intro.
Hint Resolve split_0_intro_r.
Hint Resolve split_singleton_intro.
Hint Resolve split_remove.
Hint Resolve split_distr_intro.
Hint Resolve growable_singleton.
Hint Resolve growable_0.

Lemma progress : forall ht e t h,
    hasty ht $0 e t ->
    heapty ht h ->
    growable h ->
    value e
    \/ exists he', step (h, e) he'.
Proof.
  t.
  eapply progress' with (h := h) (h' := h) in H; eauto.
Qed.

Lemma weakening_override : forall (G G' : fmap var type) x t,
  (forall x' t', G $? x' = Some t' -> G' $? x' = Some t')
  -> (forall x' t', G $+ (x, t) $? x' = Some t'
                    -> G' $+ (x, t) $? x' = Some t').
Proof.
  simplify.
  cases (x ==v x'); simplify; eauto.
Qed.

Hint Resolve weakening_override.

Lemma hasty_change : forall H G e t,
  hasty H G e t
  -> forall G', G' = G
    -> hasty H G' e t.
Proof.
  t.
Qed.

Hint Resolve hasty_change.

(* A property about extending heap typings *)
Lemma heap_override : forall H h k t t0 l,
  H $? k = Some t
  -> heapty H h
  -> h $? l = None
  -> H $+ (l, t0) $? k = Some t.
Proof.
  intros.
  eapply heapty_elim in H1.
  t.
  cases (l ==n k); subst; simplify; eauto.
  apply H3 in H0; t.
Qed.

Hint Resolve heap_override.

(* CHALLENGE #3: prove this [preservation0] lemma. *)
Lemma preservation0 : forall h1' e1 h2' e2,
    step0 (h1', e1) (h2', e2) ->
    forall h1 hctx H1 t,
      split h1' h1 hctx ->
      heapty H1 h1 ->
      growable h1' ->
      hasty H1 $0 e1 t ->
      exists H2 h2,
        hasty H2 $0 e2 t /\
        heapty H2 h2 /\
        growable h2' /\
        split h2' h2 hctx.
Proof.
Admitted.

Hint Resolve preservation0.

(* CHALLENGE #4: prove this [generalize_plug] lemma. *)
Lemma generalize_plug : forall C e1 e1',
  plug C e1 e1' ->
  forall H t,
    hasty H $0 e1' t ->
    exists H1 Hctx t0,
      hasty H1 $0 e1 t0 /\
      split H H1 Hctx /\
      forall e2 e2' H1' H',
        hasty H1' $0 e2 t0 ->
        plug C e2 e2' ->
        split H' H1' Hctx ->
        hasty H' $0 e2' t.
Proof.
Admitted.

(* CHALLENGE #5: prove [preservation]. *)
Lemma preservation : forall h1 e1 h2 e2,
  step (h1, e1) (h2, e2) ->
  forall H1 t,
    hasty H1 $0 e1 t ->
    heapty H1 h1 ->
    growable h1 ->
    exists H2,
      hasty H2 $0 e2 t /\
      heapty H2 h2 /\
      growable h2.
Proof.
Admitted.

Hint Resolve progress preservation.

(* CHALLENGE #6: prove theorem [safety]. *)
Theorem safety : forall e t, hasty $0 $0 e t
  -> invariantFor (trsys_of e)
                  (fun he' => value (snd he')
                              \/ exists he'', step he' he'').
Proof.
Admitted.


(** * Dictionaries implemented as character-based tries *)

(* Author: Xavier Leroy, Collège de France and Inria.
   Copyright: Inria.
   License: BSD-3-Clause. *)

From Coq Require Import Ascii String OrderedType.
From Tries Require Import AsciiOrder.

Module AO := OrderedAscii.
Module AOF := OrderedTypeFacts AO.

Ltac inv H := inversion H; subst; clear H.

Module Stringmap.

Module Raw.

Section STRINGMAP.

Context {A: Type}.

(** ** Representation of tries *)

(** The data structure is a trie where each node carries a mapping from
    characters (Coq type [ascii]) to subtrees.  In other words, this is
    a trie with a branching factor of 256 at each node.
    The mapping from characters to subtrees is represented sparsely
    as a sorted association list, with type [forest] below. *)

Inductive tree :=
  | Empty: tree
  | Node : option A -> forest -> tree
with forest : Type :=
  | Nil : forest
  | Cons: ascii -> tree -> forest -> forest.

Fixpoint In_forest (x: ascii) (f: forest) : Prop :=
  match f with
  | Nil => False
  | Cons k t f => x = k \/ In_forest x f
  end.

(** The well-formedness invariant states that the association lists
    are sorted, i.e. characters occur in increasing order. *)

Inductive wf: tree -> Prop :=
  | wf_Empty: wf Empty
  | wf_Node: forall ov f, wff f -> wf (Node ov f)
with wff: forest -> Prop :=
  | wff_Nil: wff Nil
  | wff_Cons: forall k t f,
      wf t -> wff f ->
      (forall x, In_forest x f -> AO.lt k x) ->
      wff (Cons k t f).

(** ** Basic operations: [empty], [get], [set], [remove] *)

Fixpoint get (s: string) (m: tree) {struct m} : option A :=
  match m, s with
  | Empty, _ => None
  | Node v _, EmptyString => v
  | Node _ cl, String x s => getf x s cl
  end
with getf (x: ascii) (s: string) (f: forest) : option A :=
  match f with
  | Nil => None
  | Cons k t f =>
      match AO.compare x k with
      | LT _ => None
      | EQ _ => get s t
      | GT _ => getf x s f
      end
  end.

Fixpoint singleton (s: string) (v: A) : tree :=
  match s with
  | EmptyString => Node (Some v) Nil
  | String x s => Node None (Cons x (singleton s v) Nil)
  end.

Fixpoint set (s: string) (v: A) (m: tree) {struct m} : tree :=
  match m, s with
  | Empty, _ => singleton s v
  | Node _ cl, EmptyString => Node (Some v) cl
  | Node v0 cl, String x s => Node v0 (setf x s v cl)
  end
with setf (x: ascii) (s: string) (v: A) (f: forest) {struct f} : forest :=
  match f with
  | Nil => Cons x (singleton s v) Nil
  | Cons k c f' =>
      match AO.compare x k with
      | LT _ => Cons x (singleton s v) f
      | EQ _ => Cons k (set s v c) f'
      | GT _ => Cons k c (setf x s v f')
      end
  end.

(** Smart constructors for [Node] and [Cons] that avoid the creation
    of trivially empty trees or forests. *)

Definition Node' (ov: option A) (f: forest) : tree :=
  match ov, f with
  | None, Nil => Empty
  | _, _ => Node ov f
  end.

Definition Cons' (x: ascii) (t: tree) (f: forest) : forest :=
  match t with Empty => f | _ => Cons x t f end.

Fixpoint remove (s: string) (m: tree) {struct m} : tree :=
  match m, s with
  | Empty, _ => Empty
  | Node _ cl, EmptyString => Node' None cl
  | Node v0 cl, String x s => Node' v0 (removef x s cl)
  end
with removef (x: ascii) (s: string) (f: forest) {struct f} : forest :=
  match f with
  | Nil => Nil
  | Cons k c f' =>
      match AO.compare x k with
      | LT _ => f
      | EQ _ => Cons' k (remove s c) f'
      | GT _ => Cons k c (removef x s f')
      end
  end.

(** ** Well-formedness properties for the basic operations *)

Lemma getf_In:
  forall x s v f, getf x s f = Some v -> In_forest x f.
Proof.
  induction f; simpl; intros.
- discriminate.
- destruct (AO.compare x a).
+ discriminate.
+ red in e; auto.
+ auto.
Qed.

Lemma getf_notIn:
  forall x s f, ~(In_forest x f) -> getf x s f = None.
Proof.
  intros. destruct (getf x s f) as [v|] eqn:G; auto. elim H. eapply getf_In; eauto.
Qed.

Lemma wf_singleton: forall v s, wf (singleton s v).
Proof.
  induction s as [ | x s]; simpl.
- repeat constructor.
- repeat constructor. auto. simpl; tauto.
Qed.

Remark In_setf:
  forall k x s v f, In_forest k (setf x s v f) <-> k = x \/ In_forest k f.
Proof.
  induction f; simpl.
- tauto.
- destruct (AO.compare x a); simpl.
+ tauto.
+ red in e; subst x. tauto.
+ rewrite IHf. tauto.
Qed.

Lemma wf_set: forall m, wf m -> forall s v, wf (set s v m)
with wf_setf: forall f, wff f -> forall x s v, wff (setf x s v f).
Proof.
- destruct 1; simpl; intros.
+ apply wf_singleton.
+ destruct s as [ | x s]. constructor; auto. constructor; apply wf_setf; auto.
- destruct 1; simpl; intros.
+ repeat constructor. apply wf_singleton. simpl; tauto.
+ destruct (AO.compare x k).
* constructor. apply wf_singleton. constructor; auto.
  simpl; intros y [E|E]. subst; auto. eapply AO.lt_trans; eauto.
* constructor. apply wf_set; auto. auto. auto.
* constructor. auto. apply wf_setf; auto.
  intros y I. rewrite In_setf in I; destruct I as [I|I].
  subst; auto. auto.
Qed.

Lemma wf_Node': forall ov f, wff f -> wf (Node' ov f).
Proof.
  unfold Node'; intros; destruct ov, f; constructor; auto.
Qed.

Lemma get_Node': forall s ov f,
  get s (Node' ov f) = get s (Node ov f).
Proof.
  intros. unfold Node'; destruct ov, f; auto. simpl. destruct s; auto.
Qed.

Lemma wf_Cons': forall k t f,
  wff (Cons k t f) -> wff (Cons' k t f).
Proof.
  unfold Cons'; intros. destruct t; auto. inv H; auto.
Qed.

Lemma In_Cons': forall x k t f,
  In_forest x (Cons' k t f) -> x = k \/ In_forest x f.
Proof.
  unfold Cons'; intros. destruct t; auto.
Qed.

Lemma getf_Cons': forall x s k t f,
  wff (Cons k t f) ->
  getf x s (Cons' k t f) = getf x s (Cons k t f).
Proof.
  unfold Cons'; intros. destruct t; auto. simpl. inv H.
  assert (P: ~AO.lt k x -> getf x s f = None).
  { intros. apply getf_notIn. red; intros; elim H; auto. }
  destruct (AO.compare x k); auto.
  apply P. apply AOF.lt_not_gt; auto.
  apply P. apply AOF.eq_not_gt; auto.
Qed.

Remark In_removef:
  forall k x s f, In_forest k (removef x s f) -> In_forest k f.
Proof.
  induction f; simpl.
- tauto.
- destruct (AO.compare x a); simpl.
+ tauto.
+ red in e; subst x. intros. eapply In_Cons'; eauto.
+ tauto.
Qed.

Lemma wf_remove: forall m, wf m -> forall s, wf (remove s m)
with wf_removef: forall f, wff f -> forall x s, wff (removef x s f).
Proof.
Local Opaque Node'.
- destruct 1; simpl; intros.
+ constructor.
+ destruct s as [ | x s]; apply wf_Node'; auto.
- destruct 1; simpl; intros.
+ constructor.
+ destruct (AO.compare x k).
* constructor; auto.
* apply wf_Cons'. constructor; auto.
* constructor; auto. intros. apply H1. eapply In_removef; eauto.
Qed.

(** ** Good variable properties for the basic operations *)

Lemma gsings: forall v s, get s (singleton s v) = Some v.
Proof.
  induction s as [ | x s]; simpl.
- auto.
- AOF.elim_comp_eq x x. auto.
Qed.

Lemma gsingo: forall v s s', s' <> s -> get s' (singleton s v) = None.
Proof.
  induction s as [ | x s]; destruct s' as [ | x' s']; intros; simpl.
- congruence.
- auto.
- auto.
- destruct (AO.compare x' x); auto.
  apply IHs. red in e; congruence.
Qed.

Lemma gss: forall m, wf m -> forall v s, get s (set s v m) = Some v
with gssf: forall f, wff f -> forall x s v, getf x s (setf x s v f) = Some v.
Proof.
- destruct 1; simpl; intros.
+ apply gsings.
+ destruct s as [ | x s]. auto. apply gssf; auto.
- destruct 1; simpl; intros.
+ AOF.elim_comp_eq x x. apply gsings.
+ destruct (AO.compare x k); simpl.
* AOF.elim_comp_eq x x. apply gsings.
* AOF.elim_comp_eq x k. apply gss; auto.
* AOF.elim_comp_gt x k. apply gssf; auto.
Qed.

Lemma gso:
  forall m, wf m ->
  forall v s s',
  s' <> s -> get s' (set s v m) = get s' m
with gsof:
  forall f, wff f ->
  forall x s v x' s',
  String x' s' <> String x s -> getf x' s' (setf x s v f) = getf x' s' f.
Proof.
- destruct 1; simpl; intros.
+ apply gsingo; auto.
+ destruct s as [ | x s]; destruct s' as [ | x' s']; simpl.
* congruence.
* auto.
* auto.
* apply gsof; auto.
- destruct 1; intros; simpl.
+ destruct (AO.compare x' x); auto.
  red in e. apply gsingo; congruence.
+ destruct (AO.compare x k); simpl.
* destruct (AO.compare x' x).
** AOF.elim_comp_lt x' k. auto. eapply AO.lt_trans; eauto.
** red in e; subst x'. AOF.elim_comp_lt x k. apply gsingo. congruence.
** auto.
* destruct (AO.compare x' k); auto. apply gso; auto. red in e; red in e0; congruence.
* destruct (AO.compare x' k); auto.
Qed.

Lemma grs: forall m, wf m -> forall s, get s (remove s m) = None
with grsf: forall f, wff f -> forall x s, getf x s (removef x s f) = None.
Proof.
- destruct 1; intros; simpl.
+ auto.
+ destruct s as [ | x s]; rewrite get_Node'. auto. apply grsf; auto.
- destruct 1; intros; simpl.
+ auto.
+ destruct (AO.compare x k); simpl.
* AOF.elim_comp_lt x k. auto.
* rewrite getf_Cons'. simpl. AOF.elim_comp_eq x k. apply grs; auto.
  constructor; auto using wf_remove.
* AOF.elim_comp_gt x k. apply grsf; auto.
Qed.

Lemma gro: forall m, wf m -> forall s s', s' <> s -> get s' (remove s m) = get s' m
with grof: forall f, wff f -> forall x s x' s', String x' s' <> String x s -> getf x' s' (removef x s f) = getf x' s' f.
Proof.
- destruct 1; intros; simpl.
+ auto.
+ destruct s as [ | x s]; destruct s' as [ | x' s']; subst; rewrite get_Node'; simpl.
* congruence.
* auto.
* auto.
* apply grof; auto.
- destruct 1; intros; simpl.
+ auto.
+ destruct (AO.compare x k); simpl.
* auto.
* rewrite getf_Cons'. simpl. destruct (AO.compare x' k); auto.
  apply gro; auto. red in e; red in e0; congruence.
  constructor; auto using wf_remove.
* destruct (AO.compare x' k); auto.
Qed.

End STRINGMAP.

Arguments tree: clear implicits.

End Raw.

(** ** Wrapping the data type and its well-formedness invariant in a sigma type *)

Definition t (A: Type) := { m: Raw.tree A | Raw.wf m }.

Definition empty (A: Type) : t A := exist _ Raw.Empty Raw.wf_Empty.

Definition get {A: Type} (s: string) (m: t A) : option A :=
  Raw.get s (proj1_sig m).

Definition set {A: Type} (s: string) (v: A) (m: t A) : t A :=
  exist _ (Raw.set s v (proj1_sig m)) (Raw.wf_set (proj1_sig m) (proj2_sig m) s v).

Definition remove {A: Type} (s: string) (m: t A) : t A :=
  exist _ (Raw.remove s (proj1_sig m)) (Raw.wf_remove (proj1_sig m) (proj2_sig m) s).

Theorem gempty: forall (A: Type) s, get s (empty A) = None.
Proof. intros; reflexivity. Qed.

Theorem gss: forall (A: Type) s v (m: t A), get s (set s v m) = Some v.
Proof. intros; apply Raw.gss. apply proj2_sig. Qed.

Theorem gso: forall (A: Type) s s' v (m: t A), s' <> s -> get s' (set s v m) = get s' m.
Proof. intros; apply Raw.gso; auto. apply proj2_sig. Qed.

Theorem gsspec: forall (A: Type) s s' v (m: t A),
  get s' (set s v m) = if string_dec s' s then Some v else get s' m.
Proof. intros. destruct (string_dec s' s). subst; apply gss. apply gso; auto. Qed.

Theorem grs: forall (A: Type) s (m: t A), get s (remove s m) = None.
Proof. intros; apply Raw.grs. apply proj2_sig. Qed.

Theorem gro: forall (A: Type) s s' (m: t A), s' <> s -> get s' (remove s m) = get s' m.
Proof. intros; apply Raw.gro; auto. apply proj2_sig. Qed.

Theorem grspec: forall (A: Type) s s' (m: t A),
  get s' (remove s m) = if string_dec s' s then None else get s' m.
Proof. intros. destruct (string_dec s' s). subst; apply grs. apply gro; auto. Qed.

End Stringmap.