Require Import Coq.Classes.Morphisms.
Require Import Coq.omega.Omega.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import RamifyCoq.lib.EnumEnsembles.
Require Import RamifyCoq.lib.List_ext.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.path_lemmas.
Require Import RamifyCoq.graph.graph_gen.
Require Import RamifyCoq.graph.FiniteGraph.

Section LIST_DEF.

  Variable V E: Type.

  Definition GList := (V * list (E * V))%type.

  Fixpoint shiftLeft (v: V) (l: list (E * V)) : list (V * E) :=
    match l with
    | nil => nil
    | (e, v') :: l' => (v, e) :: (shiftLeft v' l')
    end.

  Fixpoint tailVertex (v: V) (l: list (E * V)) : V :=
    match l with
    | nil => v
    | (e, v') :: l' => tailVertex v' l'
    end.

  Lemma tailVertex_foot: forall v l e' v', tailVertex v (l +:: (e', v')) = v'.
  Proof. intros. revert v. induction l; simpl; auto. destruct a; auto. Qed.

  Lemma shiftLeft_app: forall v e x l1 l2, In (v, e) (shiftLeft x (l1 ++ l2)) <-> In (v, e) (shiftLeft x l1) \/ In (v, e) (shiftLeft (tailVertex x l1) l2).
  Proof.
    intros v e x. apply (rev_ind (fun l1 => forall l2, In (v, e) (shiftLeft x (l1 ++ l2)) <-> In (v, e) (shiftLeft x l1) \/ In (v, e) (shiftLeft (tailVertex x l1) l2))).
    - intros. simpl. intuition.
    - intros. rewrite <- app_assoc, <- app_comm_cons, app_nil_l. rewrite H. destruct x0 as [e' v']. simpl. rewrite H. simpl. rewrite tailVertex_foot. intuition.
  Qed.

  Fixpoint listVertices' (l: list (E * V)) : list V :=
    match l with
    | nil => nil
    | (e, v) :: l' => v :: (listVertices' l')
    end.

  Lemma listVertices'_length: forall l, length (listVertices' l) = length l.
  Proof. induction l; intros; simpl; auto. destruct a. simpl. rewrite IHl; auto. Qed.

  Lemma listVertices'_In_app: forall l1 l2 v,
      In v (listVertices' (l1 ++ l2)) <->
      In v (listVertices' l1) \/ In v (listVertices' l2).
  Proof. intros l1; induction l1; intros; simpl. 1: tauto. destruct a. simpl. rewrite IHl1. tauto. Qed.

  Lemma listVertices'_In_rev: forall l v,
      In v (listVertices' l) <-> In v (listVertices' (rev l)).
  Proof. induction l; intros; simpl. 1: tauto. destruct a. simpl. rewrite listVertices'_In_app. simpl. rewrite IHl. tauto. Qed.

  Lemma listVertices'_In_length_reachable {EV: EqDec V eq} {EE: EqDec E eq}:
    forall (g: PreGraph V E) root len r (X: EnumCovered V (reachable g root)),
      length (proj1_sig X) <= len -> NoDup (listVertices' r) -> len <= length r ->
      (forall v, In v (listVertices' r) -> reachable g root v) ->
      forall v, reachable g root v -> In v (listVertices' r).
  Proof.
    intros. destruct X as [pl [? ?]]. simpl in H. unfold Ensembles.In in i.
    assert (incl (listVertices' r) pl) by (hnf; intros; apply H2 in H4; apply i in H4; auto). apply NoDup_Permutation_bis in H4; auto.
    1: specialize (i _ H3); apply Permutation_sym in H4; apply Permutation_in with pl; auto.
    apply NoDup_incl_length in H4; auto. rewrite <- listVertices'_length in H1. intuition.
  Qed.

  Definition listVertices (l: GList) :=
    match l with (v, l') => v :: listVertices' l' end.

  Fixpoint listEdges' (l: list (E * V)): list E :=
    match l with
    | nil => nil
    | (e, v) :: l' => e :: (listEdges' l')
    end.

  Lemma listEdges'_length: forall l, length (listEdges' l) = length l. Proof. induction l; intros; simpl; auto. destruct a. simpl. rewrite IHl; auto. Qed.

  Lemma listEdges'_app: forall l1 l2, listEdges' (l1 ++ l2) = listEdges' l1 ++ listEdges' l2.
  Proof. intro l1; induction l1; intros; simpl; auto. destruct a. simpl. rewrite IHl1. auto. Qed.

  Lemma listEdges'_In_app: forall l1 l2 e, In e (listEdges' (l1 ++ l2)) <-> In e (listEdges' l1) \/ In e (listEdges' l2).
  Proof. intros. rewrite listEdges'_app. rewrite in_app_iff. intuition. Qed.

  Lemma listEdges'_Permutation_rev: forall l, Permutation (listEdges' l) (listEdges' (rev l)).
  Proof.
    induction l; simpl.
    - apply perm_nil.
    - destruct a. simpl. rewrite listEdges'_app. simpl. rewrite IHl. apply Permutation_cons_append.
  Qed.

  Lemma listEdges'_In_rev: forall l e, In e (listEdges' l) <-> In e (listEdges' (rev l)).
  Proof. intros. pose proof (listEdges'_Permutation_rev l). rewrite H. intuition. Qed.

  Lemma listEdges'_NoDup_rev: forall l, NoDup (listEdges' l) <-> NoDup (listEdges' (rev l)).
  Proof. intros. pose proof (listEdges'_Permutation_rev l). rewrite H. tauto. Qed.

  Lemma listEdges'_In_length_reachable {EV: EqDec V eq} {EE: EqDec E eq}:
    forall (g: PreGraph V E) root len r (X: EnumCovered V (reachable g root)),
      length (proj1_sig X) <= len -> NoDup (listEdges' r) -> len <= length r ->
      (forall e, In e (listEdges' r) -> evalid g e /\ reachable g root (src g e) /\ vvalid g (dst g e)) ->
      (forall s e1 e2, reachable g root s -> src g e1 = s -> src g e2 = s -> evalid g e1 -> evalid g e2 -> vvalid g (dst g e1) -> vvalid g (dst g e2) -> e1 = e2) ->
      forall e, evalid g e -> reachable g root (src g e) -> vvalid g (dst g e) -> In e (listEdges' r).
  Proof.
    intros. destruct X as [pl [? ?]]. simpl in H. unfold Ensembles.In in i. remember (map (src g) (listEdges' r)).
    assert (incl l pl). {
      hnf; intros; subst l; rewrite in_map_iff in H7; destruct H7 as [e' [? ?]].
      apply H2 in H8. destruct H8 as [? [? ?]]; rewrite H7 in H9; apply i; auto.
    } apply NoDup_Permutation_bis in H7; auto.
    - specialize (i _ H5). apply Permutation_sym in H7. apply (Permutation_in (src g e)) in H7; auto. subst l.
      rewrite in_map_iff in H7. destruct H7 as [e' [? ?]]. pose proof H8. apply H2 in H8. destruct H8 as [? [? ?]].
      assert (e = e') by (apply (H3 (src g e)); auto). subst e; auto.
    - subst l. remember (listEdges' r) as l. clear Heql H7. induction l; simpl. 1: apply NoDup_nil. apply NoDup_cons.
      + clear IHl. intro. rewrite in_map_iff in H7. destruct H7 as [a' [? ?]]. assert (In a (a :: l)) by apply in_eq. assert (In a' (a :: l)) by (apply in_cons; auto).
        apply H2 in H9. apply H2 in H10. destruct H9 as [? [? ?]]. destruct H10 as [? [? ?]]. assert (a = a') by (apply (H3 (src g a)); auto). subst a'.
        rewrite NoDup_cons_iff in H0. destruct H0. clear -H0 H8. auto.
      + apply IHl.
        * rewrite NoDup_cons_iff in H0. destruct H0; auto.
        * intros. apply H2. simpl; right; auto.
    - clear -H H1 Heql. pose proof (map_length (src g) (listEdges' r)). rewrite <- Heql in *. rewrite listEdges'_length in H0. rewrite H0. intuition.
  Qed.

  Definition listEdges (l: GList) := listEdges' (snd l).

End LIST_DEF.

Arguments listVertices {_} {_} _.
Arguments listEdges {_} {_} _.

Section IS_LIST.

  Context {Vertex: Type}.
  Context {Edge: Type}.
  Context {EV: EqDec Vertex eq}.
  Context {EE: EqDec Edge eq}.

  Variable g : PreGraph Vertex Edge.

  Definition is_list (x: Vertex) : Prop :=
    exists p, valid_path g p /\ forall y, reachable g x y -> exists (py: path), unique (fun pa => g |= pa is x ~o~> y satisfying (fun _ => True)) py /\ Subpath g py p.

    Lemma is_list_no_loop: forall root s p, is_list root -> reachable g root s -> snd p <> nil -> ~ g |= p is s ~o~> s satisfying (fun _ => True).
  Proof.
    repeat intro. destruct H as [pf [? ?]]. apply H3 in H0. clear H3. destruct H0 as [ps [[? ?] ?]]. pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H0 H2).
    apply H3 in H5. destruct ps as [v ps]. unfold path_glue in H5. simpl in H5. inversion H5. destruct p; simpl in *. rewrite app_nil_end in H7 at 1.
    apply app_inv_head in H7. auto.
  Qed.

  Lemma is_list_no_edge_loop: forall root s t, is_list root -> reachable g root s -> g |= s ~> t -> reachable g t s -> False.
  Proof.
    intros. destruct H1 as [? [? ?]]. rewrite step_spec in H4. destruct H4 as [e [? [? ?]]]. destruct H2 as [p ?].
    assert (g |= (s, e :: nil) is s ~o~> t satisfying (fun _ => True)). {
      split; split; simpl; auto.
      + unfold strong_evalid. rewrite H5, H6. split; auto.
      + hnf. rewrite Forall_forall; intros; auto.
    } pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H7 H2). apply (is_list_no_loop root) in H8; auto. simpl. intro. inversion H9.
  Qed.

  Lemma is_list_no_self_edge: forall root s, is_list root -> reachable g root s -> g |= s ~> s -> False.
  Proof. intros. apply (is_list_no_edge_loop root s s); auto. apply reachable_foot_valid in H0. apply reachable_refl; auto. Qed.

  Lemma is_list_same_src_same_edge: forall root s e1 e2, is_list root -> reachable g root s -> src g e1 = s -> src g e2 = s -> evalid g e1 -> evalid g e2 ->
                                                         vvalid g (dst g e1) -> vvalid g (dst g e2) -> e1 = e2.
  Proof.
    intros. assert (vvalid g s) by (apply reachable_foot_valid in H0; auto).
    assert (g |= (s, e1 :: nil) is s ~o~> dst g e1 satisfying (fun _ => True)) by
        (split; split; simpl; auto; [split; [|unfold strong_evalid; rewrite H1] | hnf; rewrite Forall_forall; intros]; auto).
    assert (g |= (s, e2 :: nil) is s ~o~> dst g e2 satisfying (fun _ => True)) by
        (split; split; simpl; auto; [split; [|unfold strong_evalid; rewrite H2] | hnf; rewrite Forall_forall; intros]; auto).
    destruct H0 as [ps ?]. destruct ps as [vs ps]. assert (vs = root) by (destruct H0 as [[? _] _]; simpl in H0; auto). subst vs.
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H0 H8). unfold path_glue, fst, snd in H10. pose proof (reachable_by_path_is_reachable _ _ _ _ _ H10).
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H0 H9). unfold path_glue, fst, snd in H12. pose proof (reachable_by_path_is_reachable _ _ _ _ _ H12).
    destruct H as [pf [? ?]]. apply H14 in H11. destruct H11 as [p1 [[? ?] ?]]. apply H14 in H13. destruct H13 as [p2 [[? ?] ?]]. clear H14.
    assert (In_path g (dst g e1) pf) by (apply In_path_Subpath with p1; auto; destruct H11 as [[_ ?] _]; apply pfoot_in; auto).
    assert (In_path g (dst g e2) pf) by (apply In_path_Subpath with p2; auto; destruct H13 as [[_ ?] _]; apply pfoot_in; auto).
    pose proof (valid_path_reachable _ _ _ _ H H14 H19). clear H11 H13 H16 H18 H14 H19. pose proof (H15 _ H10). pose proof (H17 _ H12). destruct H20.
    + destruct H14 as [[vx px] ?]. assert (vx = dst g e1) by (destruct H14 as [[? _] _]; simpl in H14; auto). subst vx.
      pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H10 H14). unfold path_glue, fst, snd in H16. apply H17 in H16. rewrite H13 in H16. inversion H16.
      pose proof (f_equal (@length Edge) H19). rewrite !app_length in H18. simpl in H18. assert (length px = 0) by intuition. destruct px. 2: inversion H20.
      clear H18 H20. rewrite app_nil_r in H19. apply app_inj_tail in H19. destruct H19. auto.
    + destruct H14 as [[vx px] ?]. assert (vx = dst g e2) by (destruct H14 as [[? _] _]; simpl in H14; auto). subst vx.
      pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H12 H14). unfold path_glue, fst, snd in H16. apply H15 in H16. rewrite H11 in H16. inversion H16.
      pose proof (f_equal (@length Edge) H19). rewrite !app_length in H18. simpl in H18. assert (length px = 0) by intuition. destruct px. 2: inversion H20.
      clear H18 H20. rewrite app_nil_r in H19. apply app_inj_tail in H19. destruct H19. auto.
  Qed.

  Lemma is_list_edge_dst_the_same: forall root s d v, is_list root -> reachable g root s -> g |= s ~> d -> g |= s ~> v -> d = v.
  Proof.
    intros. destruct H1 as [? [? ?]]. destruct H2 as [? [? ?]]. rewrite step_spec in H4, H6. destruct H4 as [e1 [? [? ?]]]. destruct H6 as [e2 [? [? ?]]].
    subst v d. assert (e1 = e2) by (apply (is_list_same_src_same_edge root s e1 e2); auto). subst e1. auto.
  Qed.

  Lemma is_list_edge_src_the_same: forall root s d v, vvalid g root -> is_list root -> reachable g root s -> reachable g root v -> g |= s ~> d -> g |= v ~> d -> s = v.
  Proof.
    intros. destruct H3 as [? [? ?]]. rewrite step_spec in H6. destruct H6 as [es [? [? ?]]]. destruct H4 as [? [? ?]]. rewrite step_spec in H10. destruct H10 as [ev [? [? ?]]].
    assert (g |= (s, es :: nil) is s ~o~> d satisfying (fun _ => True)). {
      split; split; simpl; auto; [unfold strong_evalid; rewrite H7, H8; split; auto | hnf; rewrite Forall_forall; intros; auto].
    }
    assert (g |= (v, ev :: nil) is v ~o~> d satisfying (fun _ => True)). {
      split; split; simpl; auto; [unfold strong_evalid; rewrite H11, H12; split; auto | hnf; rewrite Forall_forall; intros; auto].
    } destruct H1 as [[vs ps] ?]. destruct H2 as [[vv pv] ?].
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H1 H13). unfold path_glue, fst, snd in H15.
    pose proof (reachable_by_path_merge _ _ _ _ _ _ _ H2 H14). unfold path_glue, fst, snd in H16. destruct H0 as [pf [? ?]].
    pose proof (reachable_by_path_is_reachable _ _ _ _ _ H16). apply H17 in H18. destruct H18 as [pp [[? ?] ?]]. apply H19 in H15. apply H19 in H16. rewrite H15 in H16.
    inversion H16. apply app_inj_tail in H23. destruct H23. subst es. rewrite H7 in H11. auto.
  Qed.

End IS_LIST.

Section LIST_TO_GRAPH.

  Context {Vertex: Type}.
  Context {Edge: Type}.
  Context {EV: EqDec Vertex eq}.
  Context {EE: EqDec Edge eq}.

  Fixpoint listToGraph' (g: PreGraph Vertex Edge) (v: Vertex) (l: list (Edge * Vertex)) : PreGraph Vertex Edge :=
    match l with
    | nil => g
    | (e, v') :: l' => listToGraph' (pregraph_add_whole_edge g e v v') v' l'
    end.

  Lemma listToGraph'_preserve_vvalid: forall g v v' l, vvalid g v -> vvalid (listToGraph' g v' l) v.
  Proof.
    intros. revert g v v' H. induction l; intros; simpl; auto.
    destruct a as [e vv]. apply IHl. apply addEdge_preserve_vvalid. auto.
  Qed.

  Definition listToGraph (gl: GList Vertex Edge) : PreGraph Vertex Edge :=
    match gl with (v, l) => listToGraph' (single_vertex_pregraph v) v l end.

  Lemma list_vertices_vvalid: forall g v l x, vvalid g v -> In x (listVertices (v, l)) -> vvalid (listToGraph' g v l) x.
  Proof.
    intros. destruct (equiv_dec v x).
    + hnf in e. subst v. clear H0. apply listToGraph'_preserve_vvalid; auto.
    + compute in c. revert g v H H0 c. induction l; intros. 1: simpl in *; destruct H0; exfalso; auto.
      destruct a; simpl in *. destruct H0. 1: exfalso; auto. destruct (equiv_dec v0 x).
      - hnf in e0. subst. apply listToGraph'_preserve_vvalid, addEdge_add_vvalid.
      - compute in c0. destruct H0. 1: exfalso; auto. apply IHl; auto. apply addEdge_add_vvalid.
  Qed.

  Lemma v_in_list_are_valid:
    forall gl x, In x (listVertices gl) -> vvalid (listToGraph gl) x.
  Proof. intro gl. destruct gl as [v l]. simpl. intros. apply list_vertices_vvalid; simpl; auto. Qed.

  Lemma valid_v_are_in_list: forall g v l x, vvalid (listToGraph' g v l) x -> vvalid g x \/ In x (listVertices (v, l)).
  Proof.
    intros g v l. revert g v. induction l; intros; simpl in *. 1: left; auto. destruct a.
    specialize (IHl (pregraph_add_whole_edge g e v v0) v0 x H). simpl. clear H. simpl in IHl. unfold addValidFunc in IHl. intuition.
  Qed.

  Lemma list_vertices_vvalid_iff: forall g v l x, vvalid g v -> (vvalid g x \/ In x (listVertices (v, l)) <-> vvalid (listToGraph' g v l) x).
  Proof.
    intros. split; intros.
    + destruct H0; [apply listToGraph'_preserve_vvalid | apply list_vertices_vvalid]; auto.
    + apply valid_v_are_in_list; auto.
  Qed.

  Lemma valid_v_eq_in_list: forall gl x, vvalid (listToGraph gl) x <-> In x (listVertices gl).
  Proof. intros. destruct gl as [v l]. simpl. rewrite <- list_vertices_vvalid_iff; simpl; tauto. Qed.

  Lemma listToGraph'_preserve_evalid: forall g v e l, evalid g e -> evalid (listToGraph' g v l) e.
  Proof.
    intros. revert g v e H. induction l; intros; simpl; auto.
    destruct a. apply IHl. apply addEdge_preserve_evalid. auto.
  Qed.

  Lemma list_edges_evalid: forall g v l e, In e (listEdges' Vertex Edge l) -> evalid (listToGraph' g v l) e.
  Proof.
    intros. revert g v H. induction l; simpl; intros. 1: exfalso; auto. destruct a. simpl in H. destruct H.
    + subst. apply listToGraph'_preserve_evalid, addEdge_add_evalid.
    + apply IHl. auto.
  Qed.

  Lemma e_in_list_are_valid:
    forall gl e, In e (listEdges gl) -> evalid (listToGraph gl) e.
  Proof. intros gl e. destruct gl as [v l]. apply list_edges_evalid. Qed.

  Lemma valid_e_are_in_list: forall g v l e, evalid (listToGraph' g v l) e -> evalid g e \/ In e (listEdges' Vertex Edge l).
  Proof.
    intros g v l. revert g v. induction l; simpl; intros; auto.
    destruct a. apply IHl in H. simpl in *. unfold addValidFunc in H. intuition.
  Qed.

  Lemma list_edges_evalid_iff: forall g v l e, evalid g e \/ In e (listEdges' Vertex Edge l) <-> evalid (listToGraph' g v l) e.
  Proof.
    intros; split; intros.
    + destruct H; [apply listToGraph'_preserve_evalid | apply list_edges_evalid]; auto.
    + apply (valid_e_are_in_list _ v); auto.
  Qed.

  Lemma valid_e_eq_in_list: forall gl e, evalid (listToGraph gl) e <-> In e (listEdges gl).
  Proof.
    intros. destruct gl as [v l]. unfold listEdges. simpl. rewrite <- list_edges_evalid_iff. simpl. tauto.
  Qed.

  Lemma listToGraph'_FiniteGraph: forall g v l, vvalid g v -> FiniteGraph g -> FiniteGraph (listToGraph' g v l).
  Proof.
    intros. destruct X as [[vl [_ ?]] [el [_ ?]]]. unfold Ensembles.In in *.
    apply Build_FiniteGraph; [exists (nodup equiv_dec (listVertices (v, l) ++ vl)) | exists (nodup equiv_dec (listEdges (v, l) ++ el))]; split; intros.
    + apply NoDup_nodup.
    + rewrite nodup_In. unfold Ensembles.In . rewrite in_app_iff, H0, <- list_vertices_vvalid_iff; tauto.
    + apply NoDup_nodup.
    + rewrite nodup_In. unfold Ensembles.In . rewrite in_app_iff, H1, <- list_edges_evalid_iff; tauto.
  Qed.

  Instance listToGraphFinite (gl: GList Vertex Edge) : FiniteGraph (listToGraph gl).
  Proof.
    destruct gl as [v l]. simpl. apply listToGraph'_FiniteGraph; simpl; auto.
    apply Build_FiniteGraph; [exists (v :: nil) | exists nil]; split; intros.
    + apply NoDup_cons; [intro S; simpl in S; auto | apply NoDup_nil].
    + unfold Ensembles.In . simpl. tauto.
    + apply NoDup_nil.
    + unfold Ensembles.In . simpl. tauto.
  Defined.

  Definition collectEdges (g: PreGraph Vertex Edge) (x: Vertex) (l: list Edge) := filter (fun e => if equiv_dec (src g e) x then true else false) l.

  Lemma collectEdges_In: forall g v l e, In e (collectEdges g v l) <-> In e l /\ src g e = v.
  Proof. intros. unfold collectEdges. rewrite filter_In. destruct (equiv_dec (src g e) v); hnf in * |- ; intuition. Qed.

  Lemma listToGraph'_src: forall g v l e x, src (listToGraph' g v l) e = x -> src g e = x \/ In e (listEdges (v, l)) /\ In x (listVertices (v, l)).
  Proof.
    intros. revert g v e x H. induction l; intros; simpl in *. 1: left; auto. destruct a. apply IHl in H. clear IHl.
    simpl. unfold listEdges, snd in H. destruct H.
    + rewrite addEdge_src_iff in H. intuition.
    + right. destruct H. split; intuition.
  Qed.

  Lemma listToGraph'_dst: forall g v l e x, dst (listToGraph' g v l) e = x -> dst g e = x \/ (In e (listEdges (v, l)) /\ In x (listVertices (v, l))).
  Proof.
    intros. revert g v e x H. induction l; intros; simpl in *. 1: left; auto. destruct a. apply IHl in H. clear IHl.
    simpl. unfold listEdges, snd in H. destruct H.
    + rewrite addEdge_dst_iff in H. intuition.
    + right. destruct H. split; intuition.
  Qed.

  Lemma listToGraph'_In: forall g v l e, In e (listEdges (v, l)) ->
                                         In (src (listToGraph' g v l) e) (listVertices (v, l)) /\ In (dst (listToGraph' g v l) e) (listVertices (v, l)).
  Proof.
    intros. revert g v e H. induction  l; intros; simpl in *. 1: intuition. destruct a. simpl in H. destruct H.
    2: apply (IHl (pregraph_add_whole_edge g e0 v v0) v0) in H; simpl; intuition.
    subst. remember (src (listToGraph' (pregraph_add_whole_edge g e v v0) v0 l) e) as x1. remember (dst (listToGraph' (pregraph_add_whole_edge g e v v0) v0 l) e) as x2.
    symmetry in Heqx1, Heqx2. pose proof Heqx1. pose proof Heqx2. apply listToGraph'_src in Heqx1. apply listToGraph'_dst in Heqx2. destruct Heqx1.
    + rewrite addEdge_src_iff in H1. destruct H1 as [[? ?] | [? ?]]. 1: exfalso; tauto. subst v. destruct Heqx2.
      * rewrite addEdge_dst_iff in H2. destruct H2 as [[? ?] | [? ?]]. 1: exfalso; tauto. subst v0. intuition.
      * destruct H2. apply (IHl (pregraph_add_whole_edge g e x1 v0)) in H2. destruct H2. rewrite H0 in H4. simpl. intuition.
    + destruct H1. apply (IHl (pregraph_add_whole_edge g e v v0)) in H1. rewrite H, H0 in H1. simpl. intuition.
  Qed.

  Lemma listToGraph'_In_dst: forall g v l e, In e (listEdges (v, l)) -> In (dst (listToGraph' g v l) e) (listVertices (v, l)).
  Proof. intros. apply (listToGraph'_In g) in H. intuition. Qed.

  Lemma listToGraph'_In_src: forall g v l e, In e (listEdges (v, l)) -> In (src (listToGraph' g v l) e) (listVertices (v, l)).
  Proof. intros. apply (listToGraph'_In g) in H. intuition. Qed.

  Lemma listToGraph'_not_In: forall g v l e, ~ In e (listEdges (v, l)) -> src (listToGraph' g v l) e = src g e /\ dst (listToGraph' g v l) e = dst g e.
  Proof.
    intros g v l. revert g v. induction l; intros; simpl in *; auto. destruct a. simpl in H.
    assert (~ In e (listEdges (v0, l))) by (unfold listEdges, snd; intro; apply H; right; auto). apply (IHl (pregraph_add_whole_edge g e0 v v0)) in H0. destruct H0.
    rewrite H0, H1. simpl. unfold updateEdgeFunc. destruct (equiv_dec e0 e); auto. hnf in e1. exfalso; apply H. left; auto.
  Qed.

  Lemma listToGraph'_not_In_dst: forall g v l e, ~ In e (listEdges (v, l)) -> dst (listToGraph' g v l) e = dst g e.
  Proof. intros. apply (listToGraph'_not_In g) in H. tauto. Qed.

  Lemma listToGraph'_not_In_src: forall g v l e, ~ In e (listEdges (v, l)) -> src (listToGraph' g v l) e = src g e.
  Proof. intros. apply (listToGraph'_not_In g) in H. tauto. Qed.

  Lemma listToGraph'_NoDup_In_dst:
    forall g v l e, NoDup (listEdges' Vertex Edge l) -> In e (listEdges' Vertex Edge l) -> exists v', In (e, v') l /\ dst (listToGraph' g v l) e = v'.
  Proof.
    intros. revert g v e H H0. induction l; simpl; intros. 1: exfalso; auto. destruct a. simpl in H0. destruct H0.
    - subst e0. exists v0. split.
      + left; auto.
      + apply NoDup_cons_iff in H. destruct H. apply (listToGraph'_not_In_dst (pregraph_add_whole_edge g e v v0) v0) in H. rewrite H. rewrite addEdge_dst_iff. right; split; auto.
    - specialize (IHl (pregraph_add_whole_edge g e0 v v0) v0 e). rewrite NoDup_cons_iff in H. destruct H. specialize (IHl H1 H0). destruct IHl as [v1 [? ?]]. exists v1. split; auto.
  Qed.

  Lemma listToGraph'_NoDup_In_src: forall g v l e, NoDup (listEdges' Vertex Edge l) -> In e (listEdges' Vertex Edge l) ->
                                                   exists v', In (v', e) (shiftLeft Vertex Edge v l) /\ src (listToGraph' g v l) e = v'.
  Proof.
    intros. revert g v e H H0. induction l; simpl; intros. 1: exfalso; auto. destruct a. simpl in H0. destruct H0.
    - subst e0. exists v. simpl. split.
      + left; auto.
      + apply NoDup_cons_iff in H. destruct H. apply (listToGraph'_not_In_src (pregraph_add_whole_edge g e v v0) v0) in H. rewrite H. rewrite addEdge_src_iff. right; split; auto.
    - specialize (IHl (pregraph_add_whole_edge g e0 v v0) v0 e). rewrite NoDup_cons_iff in H. destruct H. specialize (IHl H1 H0). destruct IHl as [v1 [? ?]]. exists v1.
      split; auto. simpl. right; auto.
  Qed.

  Lemma listToGraph'_LF: forall g v l, vvalid g v -> LocalFiniteGraph g -> LocalFiniteGraph (listToGraph' g v l).
  Proof.
    intros. destruct X. apply Build_LocalFiniteGraph. intros. unfold Enumerable, Ensembles.In in *. destruct (local_enumerable x) as [l' [? ?]].
    exists (nodup equiv_dec (collectEdges (listToGraph' g v l) x (l' ++ listEdges (v, l)))). split. 1: apply NoDup_nodup.
    intro e. rewrite nodup_In, collectEdges_In, in_app_iff. rewrite H1. unfold out_edges. rewrite <- list_edges_evalid_iff. intuition.
    apply listToGraph'_src in H4. intuition.
  Qed.

  Instance listToGraphLF (gl: GList Vertex Edge) : LocalFiniteGraph (listToGraph gl).
  Proof. apply LocalFiniteGraph_FiniteGraph, listToGraphFinite. Defined.

  Lemma listToGraph_vvalid_dec: forall gl v, Decidable (vvalid (listToGraph gl) v).
  Proof.
    intros. destruct (in_dec equiv_dec v (listVertices gl)); [left | right].
    + rewrite valid_v_eq_in_list; auto.
    + intro; apply n. rewrite <- valid_v_eq_in_list. auto.
  Qed.

  Lemma listToGraph_evalid_dec: forall gl e, Decidable (evalid (listToGraph gl) e).
  Proof.
    intros. destruct (in_dec equiv_dec e (listEdges gl)); [left | right].
    + rewrite valid_e_eq_in_list; auto.
    + intro; apply n. rewrite <- valid_e_eq_in_list. auto.
  Qed.

End LIST_TO_GRAPH.

Section GRAPH_TO_LIST.

  Context {Vertex: Type}.
  Context {Edge: Type}.
  Context {EV: EqDec Vertex eq}.
  Context {EE: EqDec Edge eq}.

  Class ValidVertexAccessible (g: PreGraph Vertex Edge) :=
    {
      filterE: list Edge -> list Edge;
      filter_valid: forall l e, Forall (evalid g) l -> In e (filterE l) <-> vvalid g (dst g e) /\ In e l
    }.

  Variable g : PreGraph Vertex Edge.
  Variable vva : ValidVertexAccessible g.

  Definition ToListInput := (nat * Vertex * list (Edge * Vertex))%type.

  Definition lengthInput (i : ToListInput) := match i with (len, _, l) => len - length l end.

  Definition inputOrder (i1 i2 : ToListInput) := lengthInput i1 < lengthInput i2.

  Lemma inputOrder_wf': forall len i, lengthInput i <= len -> Acc inputOrder i.
  Proof.
    induction len; intros; constructor; intros; unfold inputOrder in * |-.
    + exfalso. intuition.
    + apply IHlen. intuition.
  Qed.

  Lemma inputOrder_wf : well_founded inputOrder. Proof. red; intro; eapply inputOrder_wf'; eauto. Qed.

  Variable LF: LocalFiniteGraph g.

  Lemma construct_omega: forall len (r : list (Edge * Vertex)), (~ len <= length r) -> len - S (length r) < len - length r.
  Proof. intros; omega. Qed.

  Definition toEdgeList : ToListInput -> list (Edge * Vertex).
  Proof.
    refine (
        Fix inputOrder_wf (fun _ => list (Edge * Vertex))
            (fun (inp : ToListInput) =>
               match inp return
                     ((forall inp2, inputOrder inp2 inp -> list (Edge * Vertex))
                      -> list (Edge * Vertex)) with
                 (len, x, r) =>
                 fun f =>
                   if le_dec len (length r)
                   then r
                   else let eList := filterE (edge_func g x) in
                        match eList with
                        | nil => r
                        | e :: _ => f (len, dst g e, (e, dst g e) :: r) _
                        end
               end)).
    unfold inputOrder, lengthInput. simpl. apply construct_omega; auto.
  Defined.

  Lemma toEdgeList_unfold:
    forall i,
      toEdgeList i =
      match i with (len, x, r) =>
                   if le_dec len (length r)
                   then r
                   else let eList := filterE (edge_func g x) in
                        match eList with
                        | nil => r
                        | e :: _ => toEdgeList (len, dst g e, (e, dst g e) :: r)
                        end
      end.
  Proof.
    intros. destruct i as [[len x] r]. unfold toEdgeList at 1. rewrite Fix_eq.
    + destruct (le_dec len (length r)); auto.
    + intros. assert (f = g0) by (extensionality y; extensionality p; auto).
      subst; auto.
  Qed.

  Lemma toEdgeList_In: forall len x r, (forall e v, In (e, v) r -> v = dst g e) -> forall e v, In (e, v) (toEdgeList (len, x, r)) -> v = dst g e.
  Proof.
    intros len x r. remember (lengthInput (len, x, r)) as n. assert (lengthInput (len, x, r) <= n) by omega. clear Heqn. revert len x r H.
    induction n; intros; simpl; unfold lengthInput in H; rewrite toEdgeList_unfold in H1; destruct (le_dec len (length r)).
    - apply H0; auto.
    - exfalso; intuition.
    - apply H0; auto.
    - simpl in H1. destruct (filterE (edge_func g x)) eqn:? .
      + apply H0; auto.
      + specialize (IHn len (dst g e0) ((e0, dst g e0) :: r)). apply IHn; auto.
        * simpl. clear -H. intuition.
        * intros. simpl in H2. destruct H2.
          -- inversion H2. auto.
          -- apply H0; auto.
  Qed.

  Lemma shiftLeft_toEdgeList_In: forall root len x r, (forall v e, In (v, e) (shiftLeft Vertex Edge root (rev r)) -> v = src g e) ->
                                                      (r = nil -> x = root) ->
                                                      (forall e v l, r = (e, v) :: l -> x = v) ->
                                                      forall e v, In (v, e) (shiftLeft Vertex Edge root (rev (toEdgeList (len, x, r)))) -> v = src g e.
  Proof.
    intros root len x r. remember (lengthInput (len, x, r)) as n. assert (lengthInput (len, x, r) <= n) by omega. clear Heqn. revert len x r H.
    induction n; intros; simpl; unfold lengthInput in H; rewrite toEdgeList_unfold in H3; destruct (le_dec len (length r)).
    - apply H0; auto.
    - exfalso; intuition.
    - apply H0; auto.
    - simpl in H3. destruct (filterE (edge_func g x)) eqn:? .
      + apply H0; auto.
      + specialize (IHn len (dst g e0) ((e0, dst g e0) :: r)). assert (In e0 (e0 :: l)) by (simpl; left; auto). rewrite <- Heql in H4. rewrite filter_valid in H4.
        2: rewrite Forall_forall; intros; rewrite edge_func_spec in H5; destruct H5; auto.
        destruct H4. rewrite edge_func_spec in H5. destruct H5. apply IHn; auto; clear IHn H4 H5.
        * simpl. clear -H. intuition.
        * intros. simpl in H4. destruct r.
          -- simpl in H4. assert (x = root) by (apply H1; auto). subst x. destruct H4. 2: exfalso; auto. inversion H4. subst e1. subst v0. auto.
          -- destruct p as [e' v']. simpl in H4. assert (x = v') by (apply (H2 e' v' r); auto). subst v'.
             rewrite shiftLeft_app in H4. rewrite tailVertex_foot in H4. destruct H4.
             ++ simpl in H0. apply H0 in H4; auto.
             ++ simpl in H4. destruct H4. 2: exfalso; auto. inversion H4. subst v0. subst e1. auto.
        * intros. inversion H4.
        * intros. inversion H4. auto.
  Qed.

  Lemma toEdgeList_edge_NoDup:
    forall root len x r, is_list g root -> reachable g root x -> NoDup (listEdges' Vertex Edge r) ->
                         (forall e, In e (listEdges' Vertex Edge r) -> ~ reachable g x (src g e)) -> NoDup (listEdges' Vertex Edge (toEdgeList (len, x, r))).
  Proof.
    intros root len x r ?. remember (lengthInput (len, x, r)) as n. assert (lengthInput (len, x, r) <= n) by omega. clear Heqn. revert len x r H0.
    induction n; intros; simpl; unfold lengthInput in H0; rewrite toEdgeList_unfold; destruct (le_dec len (length r)); auto.
    - exfalso; intuition.
    - simpl. destruct (filterE (edge_func g x)) eqn:?; auto. specialize (IHn len (dst g e) ((e, dst g e) :: r)).
      assert (In e (e :: l)) by (simpl; left; auto). rewrite <- Heql in H4. rewrite filter_valid in H4.
      2: rewrite Forall_forall; intros; rewrite edge_func_spec in H5; destruct H5; auto. destruct H4. rewrite edge_func_spec in H5. destruct H5.
      assert (g |= x ~> (dst g e)) by (hnf; rewrite step_spec; apply reachable_foot_valid in H1; intuition; exists e; intuition). apply IHn; clear IHn; auto; simpl.
      + intuition.
      + apply reachable_edge with x; auto.
      + apply NoDup_cons; auto. intro. apply H3 in H8. apply H8. rewrite H6. apply reachable_refl. apply reachable_foot_valid in H1. auto.
      + simpl. intros. destruct H8.
        * subst e0. rewrite H6. intro. apply (is_list_no_edge_loop _ root) in H8; auto.
        * intro. apply H3 in H8. apply H8. apply edge_reachable with (dst g e); auto.
  Qed.

  Lemma toEdgeList_reachable: forall root len x r,
      reachable g root x -> (forall v, In v (listVertices' Vertex Edge r) -> reachable g root v) ->
      forall v, In v (listVertices' Vertex Edge (toEdgeList (len, x, r))) -> reachable g root v.
  Proof.
    intros root len x r. remember (lengthInput (len, x, r)) as n. assert (lengthInput (len, x, r) <= n) by omega. clear Heqn. revert len x r H.
    induction n; intros; simpl; unfold lengthInput in H; rewrite toEdgeList_unfold in H2;
      destruct (le_dec len (length r)); [apply H1; auto | exfalso; intuition | apply H1; auto |].
    simpl in H2. destruct (filterE (edge_func g x)) eqn:? . 1: apply H1; auto. specialize (IHn len (dst g e) ((e, dst g e) :: r)).
    assert (reachable g root (dst g e)). {
      assert (In e (e :: l)) by (simpl; left; auto). rewrite <- Heql in H3. rewrite filter_valid in H3.
      2: rewrite Forall_forall; intros; rewrite edge_func_spec in H4; destruct H4; auto. apply reachable_edge with x; auto.
      destruct H3. rewrite edge_func_spec in H4. hnf. rewrite step_spec. apply reachable_foot_valid in H0. intuition. exists e. intuition.
    } apply IHn; auto. 1: simpl; intuition. simpl; intros. destruct H4. 2: apply H1; auto. subst v0. auto.
  Qed.

  Lemma toEdgeList_edge_reachable: forall root len x r,
      (forall e, In e (listEdges' Vertex Edge r) -> evalid g e /\ reachable g root (src g e) /\ reachable g root (dst g e)) -> reachable g root x ->
      forall e, In e (listEdges' Vertex Edge (toEdgeList (len, x, r))) -> evalid g e /\ reachable g root (src g e) /\ reachable g root (dst g e).
  Proof.
    intros root len x r. remember (lengthInput (len, x, r)) as n. assert (lengthInput (len, x, r) <= n) by omega. clear Heqn. revert len x r H.
    induction n; intros; simpl; unfold lengthInput in H; rewrite toEdgeList_unfold in H2; destruct (le_dec len (length r));
      [apply H0; auto | exfalso; intuition | apply H0; auto |]. simpl in H2.
    destruct (filterE (edge_func g x)) eqn:? . 1: apply H0; auto. specialize (IHn len (dst g e0) ((e0, dst g e0) :: r)). assert (In e0 (e0 :: l)) by (simpl; left; auto).
    rewrite <- Heql, filter_valid in H3. 2: rewrite Forall_forall; intros; rewrite edge_func_spec in H4; destruct H4; auto.
    destruct H3. rewrite edge_func_spec in H4. destruct H4.
    assert (reachable g root (dst g e0)). {
      apply reachable_edge with x; auto. hnf. rewrite step_spec. split; [|split]; [apply reachable_foot_valid in H1 | | exists e0; split]; auto.
    } apply IHn; auto; clear IHn.
    + unfold lengthInput. simpl. intuition.
    + intros. simpl in H7. destruct H7. 2: apply H0; auto. subst e1. rewrite H5; split; [|split]; auto.
  Qed.

  Lemma toEdgeList_tail: forall len x r, exists l, toEdgeList (len, x, r) = l ++ r.
  Proof.
    intros. remember (lengthInput (len, x, r)). assert (lengthInput (len, x, r) <= n) by omega. clear Heqn. revert len x r H. induction n; intros; simpl.
    + unfold lengthInput in H. rewrite toEdgeList_unfold. destruct (le_dec len (length r)). exists nil; simpl; auto. exfalso; omega.
    + unfold lengthInput in H. rewrite toEdgeList_unfold. destruct (le_dec len (length r)). exists nil; simpl; auto. simpl. destruct (filterE (edge_func g x)).
      exists nil; simpl; auto. assert (lengthInput (len, dst g e, (e, dst g e) :: r) <= n) by (simpl; omega). apply IHn in H0.
      destruct H0 as [l' ?]. exists (l' ++ (e, dst g e) :: nil). rewrite <- app_assoc, <- app_comm_cons. simpl. auto.
  Qed.

  Lemma reachable_toEdgeList:
    forall root len x r (X: EnumCovered Vertex (reachable g root)),
      is_list g root -> length (proj1_sig X) <= len -> reachable g root x -> NoDup (listVertices' Vertex Edge r) ->
      (forall v, reachable g root v -> v <> root -> reachable g x v \/ In v (listVertices' Vertex Edge r)) ->
      (forall v, In v (listVertices' Vertex Edge r) -> reachable g root v) -> (forall v, reachable g x v -> x <> v -> ~ In v (listVertices' Vertex Edge r)) ->
      (x <> root -> In x (listVertices' Vertex Edge r)) -> forall v, reachable g root v -> v <> root -> In v (listVertices' Vertex Edge (toEdgeList (len, x, r))).
  Proof.
    intros root len x r ? ?. remember (lengthInput (len, x, r)) as n. assert (lengthInput (len, x, r) <= n) by omega. clear Heqn. revert len x r H0.
    induction n; intros; simpl; unfold lengthInput in H0; rewrite toEdgeList_unfold; destruct (le_dec len (length r));
      [apply (listVertices'_In_length_reachable _ _ _ _ len _ X) | simpl; exfalso; intuition | apply (listVertices'_In_length_reachable _ _ _ _ len _ X)| ]; auto.
    assert (HS: Forall (evalid g) (edge_func g x)) by (rewrite Forall_forall; intros; rewrite edge_func_spec in H10; destruct H10; auto).
    simpl. destruct (filterE (edge_func g x)) eqn:? .
    + specialize (H4 _ H8 H9). destruct H4; auto. clear IHn. apply reachable_by_ind in H4. destruct H4. 1: subst x; apply H7; auto.
      exfalso. destruct H4 as [z [[? [? ?]] ?]]. rewrite step_spec in H11. destruct H11 as [e [? [? ?]]].
      assert (vvalid g (dst g e) /\ In e (edge_func g x)) by (split; [rewrite H14 | rewrite edge_func_spec; split]; auto).
      rewrite <- filter_valid in H15; auto. rewrite Heql in H15. simpl in H15; auto.
    + specialize (IHn len (dst g e) ((e, dst g e) :: r)). assert (S: len - length ((e, dst g e) :: r) <= n) by (simpl; clear -H0; intuition). specialize (IHn S H1); clear S.
      assert (g |= x ~> (dst g e)). {
        assert (In e (e :: l)) by (simpl; left; auto). rewrite <- Heql in H10. rewrite filter_valid in H10; auto.
        rewrite edge_func_spec in H10. hnf. rewrite step_spec. destruct H10 as [? [? ?]]. apply reachable_foot_valid in H2. split; [|split; [|exists e]]; auto.
      } assert (vvalid g root) by (apply reachable_head_valid in H2; auto). apply IHn; auto; clear IHn.
      * apply reachable_edge with x; auto.
      * simpl. apply NoDup_cons; auto. apply H6. 1: apply reachable_edge with x; auto; apply reachable_refl; apply reachable_foot_valid in H2; auto.
        intro. subst x. apply (is_list_no_self_edge g root) in H10; auto.
      * intros. specialize (H4 _ H12 H13). simpl. destruct H4. 2: right; right; auto. apply reachable_by_ind in H4. destruct H4. 1: right; right; subst x; apply H7; auto.
        destruct H4 as [z [? ?]]. pose proof (is_list_edge_dst_the_same _ _ _ _ _ H H2 H4 H10). subst z. apply reachable_by_is_reachable in H14. left; auto.
      * simpl; intros. destruct H12. 2: apply H5; auto. subst v0. apply reachable_edge with x; auto.
      * intros. simpl. intro. destruct H14; auto. revert H14. apply H6. 1: apply edge_reachable with (dst g e); auto. intro. subst v0.
        apply (is_list_no_edge_loop g root x (dst g e)); auto.
      * simpl; intros; left; auto.
  Qed.

  Lemma reachable_edge_toEdgeList:
    forall root len x r (X: EnumCovered Vertex (reachable g root)), is_list g root -> length (proj1_sig X) <= len -> reachable g root x -> NoDup (listEdges' Vertex Edge r) ->
      (forall e, evalid g e -> reachable g root (src g e) -> vvalid g (dst g e) -> reachable g x (src g e) \/ In e (listEdges' Vertex Edge r)) ->
      (forall e, In e (listEdges' Vertex Edge r) -> evalid g e /\ reachable g root (src g e) /\ vvalid g (dst g e)) ->
      (forall e, evalid g e -> reachable g x (src g e) -> vvalid g (dst g e) -> ~ In e (listEdges' Vertex Edge r)) ->
      forall e, evalid g e -> reachable g root (src g e) -> vvalid g (dst g e) -> In e (listEdges' Vertex Edge (toEdgeList (len, x, r))).
  Proof.
    intros root len x r ? ?. remember (lengthInput (len, x, r)) as n. assert (lengthInput (len, x, r) <= n) by omega. clear Heqn. revert len x r H0.
    assert (forall s e1 e2, reachable g root s -> src g e1 = s -> src g e2 = s -> evalid g e1 -> evalid g e2 -> vvalid g (dst g e1) -> vvalid g (dst g e2) -> e1 = e2)
      by (intros s e1 e2; apply (is_list_same_src_same_edge g root); auto).
    induction n; intros; simpl; unfold lengthInput in H1; rewrite toEdgeList_unfold; destruct (le_dec len (length r)).
    - apply (listEdges'_In_length_reachable _ _ g root len _ X); auto.
    - exfalso; intuition.
    - apply (listEdges'_In_length_reachable _ _ g root len _ X); auto.
    - assert (HS: Forall (evalid g) (edge_func g x)) by (rewrite Forall_forall; intros; rewrite edge_func_spec in H11; destruct H11; auto).
      simpl. destruct (filterE (edge_func g x)) eqn:? .
      + specialize (H5 _ H8 H9 H10). destruct H5; auto. clear IHn. apply reachable_by_ind in H5. destruct H5.
        * subst x. assert (vvalid g (dst g e) /\ In e (edge_func g (src g e))) by (split; auto; rewrite edge_func_spec; split; auto).
          rewrite <- filter_valid in H5; auto. rewrite Heql in H5. inversion H5.
        * destruct H5 as [z [[? [? ?]] ?]]. rewrite step_spec in H12. destruct H12 as [e' [? [? ?]]].
          assert (vvalid g (dst g e') /\ In e' (edge_func g x)) by (split; [rewrite H15 | rewrite edge_func_spec; split]; auto).
          rewrite <- filter_valid in H16; auto. rewrite Heql in H16. inversion H16.
      + specialize (IHn len (dst g e0) ((e0, dst g e0) :: r)). assert (In e0 (e0 :: l)) by (simpl; left; auto). rewrite <- Heql in H11.
        rewrite filter_valid in H11; auto. destruct H11. rewrite edge_func_spec in H12. destruct H12.
        assert (g |= x ~> (dst g e0)) by (apply reachable_foot_valid in H3; split; [|split; [|exists e0]]; auto). apply IHn; clear IHn; auto.
        * simpl. clear -H1. intuition.
        * apply reachable_edge with x; auto.
        * simpl. apply NoDup_cons; auto. apply H7; auto. rewrite H13. apply reachable_refl. apply reachable_foot_valid in H3; auto.
        * intros. specialize (H5 _ H15 H16 H17). destruct H5.
          -- apply reachable_by_ind in H5. destruct H5.
             ++ assert (e1 = e0) by (apply (H0 x); auto). subst e1. simpl. right; left; auto.
             ++ destruct H5 as [z [? ?]]. pose proof (is_list_edge_dst_the_same _ _ _ _ _ H H3 H5 H14). subst z. apply reachable_by_is_reachable in H18; left; auto.
          -- right. simpl. right. auto.
        * simpl. intros. destruct H15.
          -- subst e1. rewrite H13. split; [|split]; auto.
          -- apply H6; auto.
        * intros. simpl. intro. destruct H18.
          -- subst e1. rewrite H13 in H16. apply (is_list_no_edge_loop g root x (dst g e0)); auto.
          -- revert H18. apply H7; auto. apply edge_reachable with (dst g e0); auto.
  Qed.

  Definition graphToList (bound: nat) (x: Vertex) : GList Vertex Edge := (x, rev (toEdgeList (bound, x, nil))).

End GRAPH_TO_LIST.

Section GtoL_LtoG_EQ.

  Context {Vertex: Type}.
  Context {Edge: Type}.
  Context {EV: EqDec Vertex eq}.
  Context {EE: EqDec Edge eq}.

  (* Lemma listToGraph'_vva: forall (g: PreGraph Vertex Edge) v l, vvalid g v -> ValidVertexAccessible g -> ValidVertexAccessible (listToGraph' g v l). *)
  (* Proof. *)
  (*   intros. destruct X as [filterG ?]. *)
  (*   remember (fun l' => filterG l' ++ filter (fun e => if in_dec equiv_dec (dst (listToGraph' g v l) e) (listVertices (v, l)) then true else false) l') as f. *)
  (*   apply (Build_ValidVertexAccessible _ f). intros l' e ?. subst f. rewrite in_app_iff. rewrite filter_valid0. rewrite filter_In, <- list_vertices_vvalid_iff; auto. *)
  (*   intuition; remember (dst (listToGraph' g v l) e) as x; symmetry in Heqx. *)
  (*   + apply listToGraph'_dst in Heqx. destruct Heqx. 1: rewrite H1 in H0; auto. intuition. *)
  (*   + destruct (in_dec equiv_dec x (listVertices (v, l))). 2: inversion H2. right; auto. *)
  (*   + apply listToGraph'_dst in Heqx. destruct Heqx. 1: left; rewrite <- H1 in H0; intuition. destruct H1. right. split; auto. *)
  (*     destruct (in_dec equiv_dec x (listVertices (v, l))); auto. *)
  (*   + destruct (in_dec equiv_dec x (listVertices (v, l))). right; auto. exfalso; auto. *)
  (* Qed. *)

  Instance listToGraph_vva (gl: GList Vertex Edge) : ValidVertexAccessible (listToGraph gl).
  Proof.
    apply (Build_ValidVertexAccessible _ (fun (l: list Edge) => filter (fun e => if (listToGraph_vvalid_dec gl (dst (listToGraph gl) e)) then true else false) l)).
    intros. rewrite filter_In. destruct (listToGraph_vvalid_dec gl (dst (listToGraph gl) e)); intuition.
  Defined.

  Lemma gToLst_lstToG_eq': forall (g: PreGraph Vertex Edge) v l r len
                                  (H: vvalid g v) (LF: LocalFiniteGraph (listToGraph' g v l)) (VVA: ValidVertexAccessible (listToGraph' g v l)),
      length l + length r <= len -> NoDup (listVertices (v, l)) -> NoDup (listEdges (v, l)) -> (forall x e, In x (listVertices (v, l)) -> ~ out_edges g x e) ->
      toEdgeList (listToGraph' g v l) VVA LF (len, v, r) = rev l ++ r.
  Proof.
    intros g v l r len. remember (lengthInput (len, v, r)) as n. simpl in Heqn. assert (len - length r <= n) by omega. clear Heqn. revert  g v l r len H.
    induction n; intros; simpl.
    + rewrite toEdgeList_unfold. destruct (le_dec len (length r)). 2: exfalso; intuition. destruct l; simpl; auto. simpl in H1; exfalso; intuition.
    + rewrite toEdgeList_unfold. destruct (le_dec len (length r)). destruct l; simpl; auto. simpl in H1; exfalso; intuition. simpl. destruct l; simpl.
      * destruct (filterE (edge_func g v)) eqn:?; auto. assert (In e (e :: l)) by (simpl; auto). rewrite <- Heql in H5. rewrite filter_valid, edge_func_spec in H5.
        exfalso. apply (H4 v e); simpl. 1: left; auto. hnf. destruct H5; auto. rewrite Forall_forall. intros. rewrite edge_func_spec in H6. destruct H6; auto.
      * destruct p as [e0 v0].
        assert (In e0 (@filterE _ _ _ _ (listToGraph' (pregraph_add_whole_edge g e0 v v0) v0 l) VVA (@edge_func _ _ _ _ (listToGraph' (pregraph_add_whole_edge g e0 v v0) v0 l) LF v))). {
          rewrite filter_valid. 2: rewrite Forall_forall; intros; rewrite edge_func_spec in H5; destruct H5; auto. split.
          + apply listToGraph'_preserve_vvalid. rewrite listToGraph'_not_In_dst.
            * replace (dst (pregraph_add_whole_edge g e0 v v0) e0) with v0. apply addEdge_add_vvalid. symmetry. rewrite addEdge_dst_iff. right. auto.
            * unfold listEdges in H3 |-* ; simpl in H3 |-* ; rewrite NoDup_cons_iff in H3; destruct H3; auto.
          + rewrite edge_func_spec. split. 1: apply listToGraph'_preserve_evalid, addEdge_add_evalid. rewrite listToGraph'_not_In_src.
            * rewrite addEdge_src_iff. right; auto.
            * clear -H3. unfold listEdges in *. simpl in *. apply NoDup_cons_iff in H3. destruct H3; auto.
        } destruct (filterE (edge_func (listToGraph' (pregraph_add_whole_edge g e0 v v0) v0 l) v)) eqn: ?. 1: simpl in H5; intuition.
        assert (e = e0). {
          assert (In e (e :: l0)) by (simpl; auto). rewrite <- Heql0 in H6. rewrite filter_valid in H6.
          2: rewrite Forall_forall; intros; rewrite edge_func_spec in H7; destruct H7; auto.
          destruct H6. rewrite edge_func_spec in H7. destruct H7. destruct (in_dec equiv_dec e (listEdges (v0, l))).
          + apply (listToGraph'_In_src (pregraph_add_whole_edge g e0 v v0)) in i.
            rewrite H8 in i. simpl in H2, i; rewrite NoDup_cons_iff in H2; destruct H2; exfalso; apply H2; simpl; auto.
          + apply listToGraph'_src in H8. rewrite addEdge_src_iff in H8. destruct H8 as [[[? ?] | [? ?]] | [? ?]]; [ | | exfalso]; auto.
            apply valid_e_are_in_list in H7. unfold listEdges in n. simpl in n. destruct H7. 2: exfalso; auto. simpl in H7. unfold addValidFunc in H7.
            destruct H7; auto. unfold out_edges in H4. specialize (H4 v e). exfalso. apply H4; [left|]; auto.
        } subst e. clear l0 Heql0 H5. remember (dst (listToGraph' (pregraph_add_whole_edge g e0 v v0) v0 l) e0) as x. symmetry in Heqx. apply listToGraph'_dst in Heqx.
        destruct Heqx as [? | [? ?]]. 2: unfold listEdges in H5, H3; simpl in H5, H3; rewrite NoDup_cons_iff in H3; exfalso; intuition.
        rewrite addEdge_dst_iff in H5. destruct H5 as [[? ?] | [_ ?]]. 1: exfalso; tauto. subst x. rewrite <- app_assoc, <- app_comm_cons. simpl. rewrite IHn; auto.
        - simpl; intuition.
        - apply addEdge_add_vvalid.
        - simpl in H1 |-* ; intuition.
        - simpl in H2 |-* . rewrite NoDup_cons_iff in H2. destruct H2; auto.
        - clear -H3. unfold listEdges in *. simpl in *. rewrite NoDup_cons_iff in H3. destruct H3; auto.
        - intros xo eo ? ?. unfold out_edges in H4, H6. simpl in H6. unfold addValidFunc, updateEdgeFunc in H6. destruct H6.
          destruct (equiv_dec e0 eo).
          -- subst xo. simpl in H2. unfold listVertices in H5. rewrite NoDup_cons_iff in H2. destruct H2; intuition.
          -- compute in c. destruct H6; auto. specialize (H4 xo eo). apply H4; auto. simpl in H5 |-* . right; auto.
  Qed.

  Lemma gToLst_lstToG_eq: forall v l, NoDup (listVertices (v, l)) -> NoDup (listEdges (v, l)) ->
      graphToList (listToGraph (v, l)) (listToGraph_vva (v, l)) (listToGraphLF (v, l)) (length l) v = (v, l).
  Proof.
    intros. unfold graphToList. f_equal. remember (listToGraph_vva (v, l)) as VVA. clear HeqVVA.
    remember (listToGraphLF (v, l)) as LF. clear HeqLF. unfold listToGraph in *. rewrite gToLst_lstToG_eq'; auto.
    + rewrite app_nil_r. apply rev_involutive.
    + simpl; auto.
    + simpl; intuition.
    + intros. unfold out_edges. simpl. intro. destruct H2; auto.
  Qed.

End GtoL_LtoG_EQ.

Section LtoG_GtoL_EQ.

  Context {Vertex: Type}.
  Context {Edge: Type}.
  Context {EV: EqDec Vertex eq}.
  Context {EE: EqDec Edge eq}.

  Lemma lstToG_gToLst_eq: forall (g: PreGraph Vertex Edge) (LF: LocalFiniteGraph g) (VVA: ValidVertexAccessible g) root (X: EnumCovered Vertex (reachable g root)),
      vvalid g root -> is_list g root -> (listToGraph (graphToList g VVA LF (length (proj1_sig X)) root)) ~=~ (predicate_subgraph g (reachable g root)).
  Proof.
    intros. hnf. split; [|split; [|split]]; intros; simpl.
    - unfold predicate_vvalid. rewrite <- list_vertices_vvalid_iff; simpl; auto.
      rewrite <- listVertices'_In_rev. split; intros.
      + destruct H1 as [? | [? | ?]];
          [subst v; split; [| apply reachable_refl]; auto ..| ].
        apply (toEdgeList_reachable g VVA LF root) in H1.
        * split; auto. apply reachable_foot_valid in H1; auto.
        * apply reachable_refl; auto.
        * intros. simpl in H2. exfalso; auto.
      + destruct (equiv_dec root v). 1: hnf in e; left; auto. compute in c.
        right; right. apply (reachable_toEdgeList _ _ _ root _ _ _ X); auto.
        * apply reachable_refl; auto.
        * simpl. apply NoDup_nil.
        * simpl. intros. exfalso; auto.
        * intros. exfalso; auto.
        * destruct H1; auto.
    - unfold predicate_evalid. rewrite <- list_edges_evalid_iff. simpl.
      cut (In e (listEdges' Vertex Edge (rev (toEdgeList g VVA LF (length (proj1_sig X), root, nil)))) <->
           evalid g e /\ reachable g root (src g e) /\ reachable g root (dst g e)). 1: intros; intuition. rewrite <- listEdges'_In_rev. split; intros.
      + apply (toEdgeList_edge_reachable g VVA LF root) in H1; auto.
        * intros. simpl in H2; exfalso; auto.
        * apply reachable_refl; auto.
      + destruct H1 as [? [? ?]]. apply reachable_foot_valid in H3. apply (reachable_edge_toEdgeList _ _ _ root _ _ _ X); auto.
        * apply reachable_refl; auto.
        * simpl; apply NoDup_nil.
        * simpl; intros. exfalso; auto.
    - simpl in *. unfold predicate_evalid in H2. rewrite <- list_edges_evalid_iff in H1. simpl in H1. destruct H1. 1: exfalso; auto.
      apply (listToGraph'_NoDup_In_src (single_vertex_pregraph root) root) in H1.
      + destruct H1 as [v' [? ?]]. rewrite H3. apply shiftLeft_toEdgeList_In in H1; auto; intros.
        * simpl in H4. exfalso; auto.
        * inversion H4.
      + rewrite <- listEdges'_NoDup_rev. apply toEdgeList_edge_NoDup with root; auto.
        * apply reachable_refl; auto.
        * simpl. apply NoDup_nil.
    - simpl in *. unfold predicate_evalid in H2. rewrite <- list_edges_evalid_iff in H1. simpl in H1. destruct H1. 1: exfalso; auto.
      apply (listToGraph'_NoDup_In_dst (single_vertex_pregraph root) root) in H1.
      + destruct H1 as [v' [? ?]]. rewrite H3. rewrite <- in_rev in H1. apply toEdgeList_In in H1; auto. intros. simpl in H4. exfalso; auto.
      + rewrite <- listEdges'_NoDup_rev. apply toEdgeList_edge_NoDup with root; auto.
        * apply reachable_refl; auto.
        * simpl. apply NoDup_nil.
  Qed.

End LtoG_GtoL_EQ.


Require Import String Ensembles.
Require Import Common.
Require Export Computation.Notations.

Inductive Comp : Type -> Type :=
| Return : forall A, A -> Comp A
| Bind : forall A B, Comp A -> (A -> Comp B) -> Comp B
| Pick : forall A, Ensemble A -> Comp A.

Bind Scope comp_scope with Comp.
Arguments Bind [A%type B%type] _%comp _.
Arguments Return [_] _.
Arguments Pick [_] _.

Notation ret := Return.

Notation "x >>= y" := (Bind x%comp y%comp) : comp_scope.
Notation "x <- y ; z" := (Bind y%comp (fun x => z%comp))
                           (at level 81, right associativity,
                            format "'[v' x  <-  y ; '/' z ']'") : comp_scope.
Notation "x ;; z" := (Bind x%comp (fun _ => z%comp))
                       (at level 81, right associativity,
                        format "'[v' x ;; '/' z ']'") : comp_scope.
Notation "{ x  |  P }" := (@Pick _ (fun x => P)) : comp_scope.
Notation "{ x : A  |  P }" := (@Pick A%type (fun x => P)) : comp_scope.

Section comp.
  Definition Lift `{ctx : Context} A B (f : A -> B)
  : Comp A -> Comp B
    := fun x => (x' <- x;
                 Return (f x'))%comp.

  Definition Or `{ctx : Context}
  : Comp bool -> Comp bool -> Comp bool
    := fun c1 c2 =>
         (b1 <- c1;
          if b1
          then Return true
          else c2)%comp.
End comp.

Section computes_to.

  Inductive computes_to : forall A, Comp A -> A -> Prop :=
  | ReturnComputes : forall A v, @computes_to A (Return v) v
  | BindComputes : forall A B comp_a f comp_a_value comp_b_value,
                     @computes_to A comp_a comp_a_value
                     -> @computes_to B (f comp_a_value) comp_b_value
                     -> @computes_to B (Bind comp_a f) comp_b_value
  | PickComputes : forall A (P : Ensemble A) v, P v -> @computes_to A (Pick P) v.

  Theorem computes_to_inv A (c : Comp A) v
  : computes_to c v -> match c in (Comp A) return A -> Prop with
                         | Return _ x => @eq _ x
                         | Bind _ _ x f => fun v => exists comp_a_value,
                                                      computes_to x comp_a_value
                                                      /\ computes_to (f comp_a_value) v
                         | Pick _ P => P
                       end v.
  Proof.
    destruct 1; eauto.
  Qed.
End computes_to.

Notation "c ↝ v" := (computes_to c v).

Section is_computational.

  (** A [Comp] is maximally computational if it could be written without [Pick]. *)
  Inductive is_computational : forall A, Comp A -> Prop :=
  | Return_is_computational : forall A (x : A), is_computational (Return x)
  | Bind_is_computational : forall A B (cA : Comp A) (f : A -> Comp B),
                              is_computational cA
                              -> (forall a,
                                    @computes_to _ cA a -> is_computational (f a))
                              -> is_computational (Bind cA f).

  Theorem is_computational_inv A (c : Comp A)
  : is_computational c
    -> match c with
         | Return _ _ => True
         | Bind _ _ x f => is_computational x
                           /\ forall v, x ↝ v
                                        -> is_computational (f v)
         | Pick _ _ => False
       end.
  Proof.
    destruct 1; eauto.
  Qed.

  (** It's possible to extract the value from a fully detiministic computation *)
  Fixpoint is_computational_unique_val A (c : Comp A) {struct c}
  : is_computational c -> { a | unique (computes_to c) a }.
  Proof.
    refine match c as c return is_computational c -> { a | unique (computes_to c) a } with
             | Return T x => fun _ => exist (unique (computes_to (ret x)))
                                            x
                                            _
             | Pick _ _ => fun H => match is_computational_inv H with end
             | Bind _ _ x f
               => fun H
                  => let H' := is_computational_inv H in
                     let xv := @is_computational_unique_val _ _ (proj1 H') in
                     let fxv := @is_computational_unique_val _ _ (proj2 H' _ (proj1 (proj2_sig xv))) in
                     exist (unique (computes_to _))
                           (proj1_sig fxv)
                           _
           end;
    clearbodies;
    clear is_computational_unique_val;
    first [ abstract (repeat econstructor; intros; inversion_by computes_to_inv; eauto)
          | abstract (
                simpl in *;
                unfold unique in *;
                destruct_sig;
                repeat econstructor;
                intros;
                eauto;
                inversion_by computes_to_inv;
                apply_hyp;
                do_with_hyp ltac:(fun H => erewrite H by eassumption);
                eassumption
          ) ].
  Defined.

  Definition is_computational_val A (c : Comp A) (H : is_computational c) : A
    := proj1_sig (@is_computational_unique_val A c H).
  Definition is_computational_val_computes_to A (c : Comp A) (H : is_computational c) : c ↝ (is_computational_val H)
    := proj1 (proj2_sig (@is_computational_unique_val A c H)).
  Definition is_computational_val_unique A (c : Comp A) (H : is_computational c)
  : forall x, c ↝ x -> is_computational_val H = x
    := proj2 (proj2_sig (@is_computational_unique_val A c H)).
  Definition is_computational_val_all_eq A (c : Comp A) (H : is_computational c)
  : forall x y, c ↝ x -> c ↝ y -> x = y.
  Proof.
    intros.
    transitivity (@is_computational_val A c H); [ symmetry | ];
    apply is_computational_val_unique;
    assumption.
  Qed.
End is_computational.

(** The old program might be non-deterministic, and the new program
      less so.  This means we want to say that if [new] can compute to
      [v], then [old] should be able to compute to [v], too. *)
Definition refine {A}
           (old : Comp A)
           (new : Comp A)
  := forall v, new ↝ v -> old ↝ v.

(* A definition and notation for pretty printing the goals used to
   interactively deriving refinements. *)

Definition Refinement_Of {A} (c : Comp A) :=
  {c' | refine c c'}.

Notation "'Refinement' 'of' c" :=
  {c' | refine c c'}
    (at level 0, no associativity,
     format "'Refinement'  'of' '/' '[v'    c ']' " )
  : comp_scope.

(** Define a symmetrized version of [refine] for ease of rewriting *)
Definition refineEquiv {A}
           (old : Comp A)
           (new : Comp A)
  := refine old new /\ refine new old.

Local Obligation Tactic := repeat first [ solve [ eauto ]
                                        | progress hnf in *
                                        | intro
                                        | split
                                        | progress split_and ].

Global Program Instance refine_PreOrder A : PreOrder (@refine A).
Global Program Instance refineEquiv_Equivalence A : Equivalence (@refineEquiv A).


(****************************************************************************)
(*                                                                          *)
(*                                   Menhir                                 *)
(*                                                                          *)
(*           Jacques-Henri Jourdan, CNRS, LRI, Université Paris Sud         *)
(*                                                                          *)
(*  Copyright Inria. All rights reserved. This file is distributed under    *)
(*  the terms of the GNU Lesser General Public License as published by the  *)
(*  Free Software Foundation, either version 3 of the License, or (at your  *)
(*  option) any later version, as described in the file LICENSE.            *)
(*                                                                          *)
(****************************************************************************)

From Coq Require Import List Syntax.
Require Import Alphabet.
Require Grammar Automaton Interpreter.
From Coq.ssr Require Import ssreflect.

Module Make(Import A:Automaton.T) (Import Inter:Interpreter.T A).

(** * Correctness of the interpreter **)

(** We prove that, in any case, if the interpreter accepts returning a
    semantic value, then this is a semantic value of the input **)

Section Init.

Variable init:initstate.

(** [word_has_stack_semantics] relates a word with a stack, stating that the
    word is a concatenation of words that have the semantic values stored in
    the stack. **)
Inductive word_has_stack_semantics:
  forall (word:list token) (stack:stack), Prop :=
  | Nil_stack_whss: word_has_stack_semantics [] []
  | Cons_stack_whss:
    forall (wordq:list token) (stackq:stack),
      word_has_stack_semantics wordq stackq ->

    forall (wordt:list token) (s:noninitstate)
           (pt:parse_tree (last_symb_of_non_init_state s) wordt),

    word_has_stack_semantics
       (wordq++wordt) (existT noninitstate_type s (pt_sem pt)::stackq).

(** [pop] preserves the invariant **)
Lemma pop_spec_ptl A symbols_to_pop action word_stk stk (res : A) stk' :
  pop_spec symbols_to_pop stk action stk' res ->
  word_has_stack_semantics word_stk stk ->
  exists word_stk' word_res (ptl:parse_tree_list symbols_to_pop word_res),
    (word_stk' ++ word_res = word_stk)%list /\
    word_has_stack_semantics word_stk' stk' /\
    ptl_sem ptl action = res.
Proof.
  intros Hspec. revert word_stk.
  induction Hspec as [stk sem|symbols_to_pop st stk action sem stk' res Hspec IH];
    intros word_stk Hword_stk.
  - exists word_stk, [], Nil_ptl. rewrite -app_nil_end. eauto.
  - inversion Hword_stk. subst_existT.
    edestruct IH as (word_stk' & word_res & ptl & ? & Hword_stk'' & ?); [eassumption|].
    subst. eexists word_stk', (word_res ++ _)%list, (Cons_ptl ptl _).
    split; [|split]=>//. rewrite app_assoc //.
Qed.

(** [reduce_step] preserves the invariant **)
Lemma reduce_step_invariant (stk:stack) (prod:production) Hv Hi word buffer :
  word_has_stack_semantics word stk ->
  match reduce_step init stk prod buffer Hv Hi with
  | Accept_sr sem buffer_new =>
    exists pt : parse_tree (NT (start_nt init)) word,
    buffer = buffer_new /\ pt_sem pt = sem
  | Progress_sr stk' buffer_new =>
    buffer = buffer_new /\ word_has_stack_semantics word stk'
  | Fail_sr => True
  end.
Proof.
  intros Hword_stk. unfold reduce_step.
  match goal with
  | |- context [pop_state_valid init ?stp stk ?x1 ?x2 ?x3 ?x4 ?x5] =>
    generalize (pop_state_valid init stp stk x1 x2 x3 x4 x5)
  end.
  destruct pop as [stk' sem] eqn:Hpop=>/= Hv'.
  apply pop_spec_ok in Hpop. apply pop_spec_ptl with (word_stk := word) in Hpop=>//.
  destruct Hpop as (word1 & word2 & ptl & <- & Hword1 & <-).
  generalize (reduce_step_subproof1 init stk prod Hv stk' (fun _ : True => Hv')).
  destruct goto_table as [[st' EQ]|].
  - intros _. split=>//.
    change (ptl_sem ptl (prod_action prod)) with (pt_sem (Non_terminal_pt prod ptl)).
    generalize (Non_terminal_pt prod ptl). rewrite ->EQ. intros pt. by constructor.
  - intros Hstk'. destruct Hword1; [|by destruct Hstk'].
    generalize (reduce_step_subproof0 init prod [] (fun _ : True => Hstk')).
    simpl in Hstk'. rewrite -Hstk' // => EQ. rewrite cast_eq.
    exists (Non_terminal_pt prod ptl). by split.
Qed.

(** [step] preserves the invariant **)
Lemma step_invariant stk word buffer safe Hi :
  word_has_stack_semantics word stk ->
  match step safe init stk buffer Hi with
  | Accept_sr sem buffer_new =>
    exists word_new (pt:parse_tree (NT (start_nt init)) word_new),
      (word ++ buffer = word_new ++ buffer_new)%buf /\
      pt_sem pt = sem
  | Progress_sr stk_new buffer_new =>
    exists word_new,
      (word ++ buffer = word_new ++ buffer_new)%buf /\
      word_has_stack_semantics word_new stk_new
  | Fail_sr => True
  end.
Proof.
  intros Hword_stk. unfold step.
  generalize (reduce_ok safe (state_of_stack init stk)).
  destruct action_table as [prod|awt].
  - intros Hv.
    apply (reduce_step_invariant stk prod (fun _ => Hv) Hi word buffer) in Hword_stk.
    destruct reduce_step=>//.
    + destruct Hword_stk as (pt & <- & <-); eauto.
    + destruct Hword_stk as [<- ?]; eauto.
  - destruct buffer as [tok buffer]=>/=.
    move=> /(_ (token_term tok)) Hv. destruct (awt (token_term tok)) as [st EQ|prod|]=>//.
    + eexists _. split; [by apply app_buf_assoc with (l2 := [_])|].
      change (token_sem tok) with (pt_sem (Terminal_pt tok)).
      generalize (Terminal_pt tok). generalize [tok].
      rewrite -> EQ=>word' pt /=. by constructor.
    + apply (reduce_step_invariant stk prod (fun _ => Hv) Hi word (tok::buffer))
        in Hword_stk.
      destruct reduce_step=>//.
      * destruct Hword_stk as (pt & <- & <-); eauto.
      * destruct Hword_stk as [<- ?]; eauto.
Qed.

(** [step] preserves the invariant **)
Lemma parse_fix_invariant stk word buffer safe log_n_steps Hi :
  word_has_stack_semantics word stk ->
  match proj1_sig (parse_fix safe init stk buffer log_n_steps Hi) with
  | Accept_sr sem buffer_new =>
    exists word_new (pt:parse_tree (NT (start_nt init)) word_new),
      (word ++ buffer = word_new ++ buffer_new)%buf /\
      pt_sem pt = sem
  | Progress_sr stk_new buffer_new =>
    exists word_new,
      (word ++ buffer = word_new ++ buffer_new)%buf /\
      word_has_stack_semantics word_new stk_new
  | Fail_sr => True
  end.
Proof.
  revert stk word buffer Hi.
  induction log_n_steps as [|log_n_steps IH]=>/= stk word buffer Hi Hstk;
    [by apply step_invariant|].
  assert (IH1 := IH stk word buffer Hi Hstk).
  destruct parse_fix as [[] Hi']=>/=; try by apply IH1.
  destruct IH1 as (word' & -> & Hstk')=>//. by apply IH.
Qed.

(** The interpreter is correct : if it returns a semantic value, then the input
    word has this semantic value.
**)
Theorem parse_correct safe buffer log_n_steps:
  match parse safe init buffer log_n_steps with
  | Parsed_pr sem buffer_new =>
    exists word_new (pt:parse_tree (NT (start_nt init)) word_new),
      buffer = (word_new ++ buffer_new)%buf /\
      pt_sem pt = sem
  | _ => True
  end.
Proof.
  unfold parse.
  assert (Hparse := parse_fix_invariant [] [] buffer safe log_n_steps
                                        (parse_subproof init)).
  destruct proj1_sig=>//. apply Hparse. constructor.
Qed.

End Init.

End Make.


From FileSync Require Import
     Syntax.
From AsyncTest Require Import
     Jexp.

Definition traceT := list (labelT * IR).

Example tget_strong (l : labelT) (p : jpath) (t : traceT) : IR :=
  odflt (JSON__Object []) $ get l t >>= jget p.

Definition tget_weak' (jget : jpath -> IR -> option IR)
           (l : labelT) (p : jpath) (t : traceT) : IR :=
  odflt (last (pick_some $ map (jget p ∘ snd) t) $ JSON__Object []) $
        get l t >>= jget p.

Definition tget_weak : labelT -> jpath -> traceT -> IR := tget_weak' jget_weak.

Fixpoint jexp_to_IR' (tget : labelT -> jpath -> traceT -> IR)
         (t : traceT) (e : jexp) : IR :=
  match e with
  | Jexp__Const  j   => j
  | Jexp__Array  l   => JSON__Array  $ map     (jexp_to_IR' tget t) l
  | Jexp__Object m   => JSON__Object $ map_snd (jexp_to_IR' tget t) m
  | Jexp__Ref  l p f => f $ tget l p t
  end.

Example jexp_to_IR_strong : traceT -> jexp -> IR := jexp_to_IR' tget_strong.

Definition jexp_to_IR_weak : traceT -> jexp -> IR := jexp_to_IR' tget_weak.

Definition findpath' (p : jpath) : traceT -> list labelT :=
  fmap fst ∘ filter (fun lj => if jget_weak p (snd lj) is Some _
                             then true else false).

Definition findpath (p : jpath) (f : IR -> IR) (t : traceT) : list jexp :=
  l <- findpath' p t;; [Jexp__Ref l p f].


Require Import List.
Import ListNotations.

Require Import Chord.Chord.

Require Import Chord.SystemReachable.

Definition has_pred (gst : global_state) (h : addr) (p : option pointer) : Prop :=
  exists st,
    sigma gst h = Some st /\
    pred st = p.

Lemma has_pred_intro :
  forall gst h p st,
    sigma gst h = Some st ->
    pred st = p ->
    has_pred gst h p.
Proof.
  unfold has_pred.
  eauto.
Qed.


Require Import VST.floyd.proofauto.
Require Import tree_flatten.
From SSL_VST Require Import core.
Instance CompSpecs : compspecs. make_compspecs prog. Defined.
Definition Vprog : varspecs. mk_varspecs prog. Defined.

Definition free_spec :=
  DECLARE _free
          WITH ty: type, x: val
                              PRE  [ (tptr tvoid) ]
                              PROP()
                              PARAMS(x)
                              SEP (data_at_ Tsh ty x)
                              POST [ Tvoid ]
                              PROP()
                              LOCAL()
                              SEP (emp).

Definition malloc_spec :=
  DECLARE _malloc
        WITH t: type
        PRE [ tuint ]
        PROP()
        PARAMS(Vint (Int.repr (sizeof t)))
        SEP()
        POST [tptr tvoid] EX p:_,
        PROP()
        RETURN(p)
        SEP(data_at_ Tsh t p).

Inductive tree_card : Set :=
    | tree_card_0 : tree_card
    | tree_card_2 : tree_card -> tree_card -> tree_card.

Fixpoint tree (x: val) (s: (list Z)) (self_card: tree_card) {struct self_card} : mpred := match self_card with
    | tree_card_0  =>  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp
    | tree_card_2 _alpha_514 _alpha_513 =>
      EX v : Z,
      EX s2 : (list Z),
      EX r : val,
      EX s1 : (list Z),
      EX l : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null r) && !!(is_pointer_or_null l) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = ((([(v : Z)] : list Z) ++ (s1 : list Z)) ++ (s2 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 3) [(inl ((Vint (Int.repr v)) : val)); (inr (l : val)); (inr (r : val))] (x : val)) * (tree (l : val) (s1 : list Z) (_alpha_513 : tree_card)) * (tree (r : val) (s2 : list Z) (_alpha_514 : tree_card))
end.

Inductive treeN_card : Set :=
    | treeN_card_0 : treeN_card
    | treeN_card_2 : treeN_card -> treeN_card -> treeN_card.

Fixpoint treeN (x: val) (n: Z) (self_card: treeN_card) {struct self_card} : mpred := match self_card with
    | treeN_card_0  =>  !!((x : val) = nullval) && !!((n : Z) = 0) && emp
    | treeN_card_2 _alpha_516 _alpha_515 =>
      EX n1 : Z,
      EX v : val,
      EX r : val,
      EX n2 : Z,
      EX l : val,
 !!(Int.min_signed <= n1 <= Int.max_signed) && !!(is_pointer_or_null v) && !!(is_pointer_or_null r) && !!(Int.min_signed <= n2 <= Int.max_signed) && !!(is_pointer_or_null l) && !!(~ ((x : val) = nullval)) && !!(0 <= (n1 : Z)) && !!(0 <= (n2 : Z)) && !!((n : Z) = ((1 + (n1 : Z)) + (n2 : Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 3) [(inr (v : val)); (inr (l : val)); (inr (r : val))] (x : val)) * (treeN (l : val) (n1 : Z) (_alpha_515 : treeN_card)) * (treeN (r : val) (n2 : Z) (_alpha_516 : treeN_card))
end.

Inductive sll_card : Set :=
    | sll_card_0 : sll_card
    | sll_card_1 : sll_card -> sll_card.

Fixpoint sll (x: val) (s: (list Z)) (self_card: sll_card) {struct self_card} : mpred := match self_card with
    | sll_card_0  =>  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp
    | sll_card_1 _alpha_517 =>
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (sll (nxt : val) (s1 : list Z) (_alpha_517 : sll_card))
end.

Definition sll_append_spec :=
  DECLARE _sll_append
   WITH x1: val, ret: val, _alpha_519: sll_card, _alpha_518: sll_card, x2: val, s2: (list Z), s1: (list Z)
   PRE [ (tptr (Tunion _sslval noattr)), (tptr (Tunion _sslval noattr)) ]
   PROP( is_pointer_or_null((x1 : val)); is_pointer_or_null((ret : val)); is_pointer_or_null((x2 : val)) )
   PARAMS(x1; ret)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (x2 : val))] (ret : val)); (sll (x1 : val) (s1 : list Z) (_alpha_518 : sll_card)); (sll (x2 : val) (s2 : list Z) (_alpha_519 : sll_card)))
   POST[ tvoid ]
   EX y: val,
   EX _alpha_520: sll_card,
   EX s: (list Z),
   PROP( ((s : list Z) = ((s1 : list Z) ++ (s2 : list Z))); is_pointer_or_null((y : val)) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (y : val))] (ret : val)); (sll (y : val) (s : list Z) (_alpha_520 : sll_card))).

Definition tree_flatten_spec :=
  DECLARE _tree_flatten
   WITH z: val, x: val, s: (list Z), _alpha_521: tree_card
   PRE [ (tptr (Tunion _sslval noattr)) ]
   PROP( is_pointer_or_null((z : val)); is_pointer_or_null((x : val)) )
   PARAMS(z)
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (x : val))] (z : val)); (tree (x : val) (s : list Z) (_alpha_521 : tree_card)))
   POST[ tvoid ]
   EX y: val,
   EX _alpha_522: sll_card,
   PROP( is_pointer_or_null((y : val)) )
   LOCAL()
   SEP ((data_at Tsh (tarray (Tunion _sslval noattr) 1) [(inr (y : val))] (z : val)); (sll (y : val) (s : list Z) (_alpha_522 : sll_card))).

Lemma tree_x_valid_pointerP x s self_card: tree x s self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve tree_x_valid_pointerP : valid_pointer.
Lemma tree_local_factsP x s self_card :
  tree x s self_card|-- !!(((((x : val) = nullval)) -> (self_card = tree_card_0))/\(((~ ((x : val) = nullval))) -> (exists _alpha_514 _alpha_513, self_card = tree_card_2 _alpha_514 _alpha_513))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve tree_local_factsP : saturate_local.
Lemma unfold_tree_card_0  (x: val) (s: (list Z)) : tree x s (tree_card_0 ) =  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp. Proof. auto. Qed.
Lemma unfold_tree_card_2 (_alpha_514 : tree_card) (_alpha_513 : tree_card) (x: val) (s: (list Z)) : tree x s (tree_card_2 _alpha_514 _alpha_513) =
      EX v : Z,
      EX s2 : (list Z),
      EX r : val,
      EX s1 : (list Z),
      EX l : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null r) && !!(is_pointer_or_null l) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = ((([(v : Z)] : list Z) ++ (s1 : list Z)) ++ (s2 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 3) [(inl ((Vint (Int.repr v)) : val)); (inr (l : val)); (inr (r : val))] (x : val)) * (tree (l : val) (s1 : list Z) (_alpha_513 : tree_card)) * (tree (r : val) (s2 : list Z) (_alpha_514 : tree_card)). Proof. auto. Qed.
Lemma treeN_x_valid_pointerP x n self_card: treeN x n self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve treeN_x_valid_pointerP : valid_pointer.
Lemma treeN_local_factsP x n self_card :
  treeN x n self_card|-- !!(((((x : val) = nullval)) -> (self_card = treeN_card_0))/\(((~ ((x : val) = nullval))) -> (exists _alpha_516 _alpha_515, self_card = treeN_card_2 _alpha_516 _alpha_515))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve treeN_local_factsP : saturate_local.
Lemma unfold_treeN_card_0  (x: val) (n: Z) : treeN x n (treeN_card_0 ) =  !!((x : val) = nullval) && !!((n : Z) = 0) && emp. Proof. auto. Qed.
Lemma unfold_treeN_card_2 (_alpha_516 : treeN_card) (_alpha_515 : treeN_card) (x: val) (n: Z) : treeN x n (treeN_card_2 _alpha_516 _alpha_515) =
      EX n1 : Z,
      EX v : val,
      EX r : val,
      EX n2 : Z,
      EX l : val,
 !!(Int.min_signed <= n1 <= Int.max_signed) && !!(is_pointer_or_null v) && !!(is_pointer_or_null r) && !!(Int.min_signed <= n2 <= Int.max_signed) && !!(is_pointer_or_null l) && !!(~ ((x : val) = nullval)) && !!(0 <= (n1 : Z)) && !!(0 <= (n2 : Z)) && !!((n : Z) = ((1 + (n1 : Z)) + (n2 : Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 3) [(inr (v : val)); (inr (l : val)); (inr (r : val))] (x : val)) * (treeN (l : val) (n1 : Z) (_alpha_515 : treeN_card)) * (treeN (r : val) (n2 : Z) (_alpha_516 : treeN_card)). Proof. auto. Qed.
Lemma sll_x_valid_pointerP x s self_card: sll x s self_card |-- valid_pointer x. Proof. destruct self_card; simpl; entailer;  entailer!; eauto. Qed.
Hint Resolve sll_x_valid_pointerP : valid_pointer.
Lemma sll_local_factsP x s self_card :
  sll x s self_card|-- !!(((((x : val) = nullval)) -> (self_card = sll_card_0))/\(((~ ((x : val) = nullval))) -> (exists _alpha_517, self_card = sll_card_1 _alpha_517))/\is_pointer_or_null((x : val))).
 Proof.  destruct self_card;  simpl; entailer; saturate_local; apply prop_right; eauto. Qed.
Hint Resolve sll_local_factsP : saturate_local.
Lemma unfold_sll_card_0  (x: val) (s: (list Z)) : sll x s (sll_card_0 ) =  !!((x : val) = nullval) && !!((s : list Z) = ([] : list Z)) && emp. Proof. auto. Qed.
Lemma unfold_sll_card_1 (_alpha_517 : sll_card) (x: val) (s: (list Z)) : sll x s (sll_card_1 _alpha_517) =
      EX v : Z,
      EX s1 : (list Z),
      EX nxt : val,
 !!(Int.min_signed <= v <= Int.max_signed) && !!(is_pointer_or_null nxt) && !!(~ ((x : val) = nullval)) && !!((s : list Z) = (([(v : Z)] : list Z) ++ (s1 : list Z))) && (data_at Tsh (tarray (Tunion _sslval noattr) 2) [(inl ((Vint (Int.repr v)) : val)); (inr (nxt : val))] (x : val)) * (sll (nxt : val) (s1 : list Z) (_alpha_517 : sll_card)). Proof. auto. Qed.
Definition Gprog : funspecs :=
  ltac:(with_library prog [tree_flatten_spec; free_spec; malloc_spec;sll_append_spec]).

Lemma body_tree_flatten : semax_body Vprog Gprog f_tree_flatten tree_flatten_spec.
Proof.
start_function.
ssl_open_context.
assert_PROP (isptr z). { entailer!. }
try rename x into x2.
forward.
forward_if.

 - {
assert_PROP (_alpha_521 = tree_card_0) as ssl_card_assert. { entailer!; ssl_dispatch_card. }
ssl_card tree ssl_card_assert .
assert_PROP (((x2 : val) = nullval)). { entailer!. }
let ssl_var := fresh in assert_PROP(s = ([] : list Z)) as ssl_var; try rewrite ssl_var in *. { entailer!. }
forward; entailer!.
Exists nullval.
Exists (sll_card_0  : sll_card).
ssl_entailer.
rewrite (unfold_sll_card_0 ) at 1.
ssl_entailer.

}
 - {
assert_PROP (exists _alpha_514 _alpha_513, _alpha_521 = tree_card_2 _alpha_514 _alpha_513) as ssl_card_assert. { entailer!; ssl_dispatch_card. }
ssl_card tree ssl_card_assert _alpha_514x2 _alpha_513x2.
assert_PROP ((~ ((x2 : val) = nullval))). { entailer!. }
Intros vx2 s2x2 rx2 s1x2 lx2.
let ssl_var := fresh in assert_PROP(s = ((([(vx2 : Z)] : list Z) ++ (s1x2 : list Z)) ++ (s2x2 : list Z))) as ssl_var; try rewrite ssl_var in *. { entailer!. }
try rename vx2 into vx22.
forward.
try rename lx2 into lx22.
forward.
try rename rx2 into rx22.
forward.
forward.
assert_PROP(is_pointer_or_null((z : val))). { entailer!. }
assert_PROP(is_pointer_or_null((lx22 : val))). { entailer!. }
forward_call ((z : val), (lx22 : val), (s1x2 : list Z), (_alpha_513x2 : tree_card)).
let ret := fresh vret in Intros ret; destruct ret as [y1 _alpha_5221].
assert_PROP(is_pointer_or_null((y1 : val))). { entailer!. }
try rename y1 into y12.
forward.
forward.
assert_PROP(is_pointer_or_null((z : val))). { entailer!. }
assert_PROP(is_pointer_or_null((rx22 : val))). { entailer!. }
forward_call ((z : val), (rx22 : val), (s2x2 : list Z), (_alpha_514x2 : tree_card)).
let ret := fresh vret in Intros ret; destruct ret as [y2 _alpha_5222].
assert_PROP(is_pointer_or_null((y2 : val))). { entailer!. }
try rename y2 into y22.
forward.
assert_PROP(is_pointer_or_null((y12 : val))). { entailer!. }
assert_PROP(is_pointer_or_null((z : val))). { entailer!. }
assert_PROP(is_pointer_or_null((y22 : val))). { entailer!. }
forward_call ((y12 : val), (z : val), (_alpha_5222 : sll_card), (_alpha_5221 : sll_card), (y22 : val), (s2x2 : list Z), (s1x2 : list Z)).
ssl_entailer.
let ret := fresh vret in Intros ret; destruct ret as [[y3 _alpha_520] s3].
assert_PROP(is_pointer_or_null((y3 : val))). { entailer!. }
let ssl_var := fresh in assert_PROP(s3 = ((s1x2 : list Z) ++ (s2x2 : list Z))) as ssl_var; try rewrite ssl_var in *. { entailer!. }
try rename y3 into y32.
forward.
forward_call (tarray (Tunion _sslval noattr) 2).
Intros y4.
assert_PROP (isptr y4). { entailer!. }
forward_call (tarray (Tunion _sslval noattr) 3, x2).
forward.
forward.
forward.
forward; entailer!.
Exists (y4 : val).
Exists (sll_card_1 (_alpha_520 : sll_card) : sll_card).
ssl_entailer.
rewrite (unfold_sll_card_1 (_alpha_520 : sll_card)) at 1.
Exists (vx22 : Z).
Exists ((s1x2 : list Z) ++ (s2x2 : list Z)).
Exists (y32 : val).
ssl_entailer.

}
Qed.


Require Import LibTactics.
Require Import Metalib.Metatheory.
Require Export syntax_ott.
Require Import
        rules_inf
        Infrastructure
        Disjointness
        SubtypingInversion
        KeyProperties.

Require Import Arith Lia.

Lemma TypedReduce_disjoint_unique: forall (v1 v2 v1' v2': exp) (A A' B B' C: typ),
    value v1 -> value v2 ->
    Typing nil v1 Inf A -> Typing nil v2 Inf B ->
    pType v1 A' -> pType v2 B' -> disjoint A' B' ->
    TypedReduce v1 C v1' -> TypedReduce v2 C v2' ->
    consistent v1 v2 -> v1' = v2'.
Proof with (solve_false; auto).
  intros v1 v2 v1' v2' A A' B B' C Val1 Val2 Typ1 Typ2 pTyp1 pTyp2 Dis R1 R2 Cons.
      forwards*: principal_type_checks v1.
      forwards*: principal_type_checks v2.
      subst.
      forwards* S1: TypedReduce_sub R1.
      forwards* S2: TypedReduce_sub R2.
      apply disjoint_eqv in Dis.
      forwards*: Dis S1 S2.
      forwards*: TypedReduce_toplike R1 R2.
Qed.

Lemma TypedReduce_unique: forall (v1 v2 v1' v2': exp) (A B C: typ),
    value v1 -> value v2 ->
    Typing nil v1 Inf A -> Typing nil v2 Inf B ->
    TypedReduce v1 C v1' -> TypedReduce v2 C v2' ->
    consistent v1 v2 -> v1' = v2'.
Proof with (lia; auto).
  intros v1 v2 v1' v2' A B C Val1 Val2 Typ1 Typ2 R1 R2 Cons.
  gen A B v1 v2 v1' v2'. indTypSize (size_typ C).
  lets [?|(?&?&?)]: ord_or_split C.
  - (* ord *)
    gen A B. induction Cons; intros;
      try solve [
              inverts keep R1;
              try solve [forwards: TypedReduce_toplike R1 R2; try eassumption; auto 4];
              inverts keep R2;
              try solve [forwards~: TypedReduce_toplike R1 R2; try eassumption; auto 4];
              solve_false; auto 4].
    + (* rcd *)
      inverts Val1. inverts Typ1.
      inverts Val2. inverts Typ2.
      inverts keep R1; try solve [forwards~: TypedReduce_toplike R1 R2];
        inverts keep R2; try solve [forwards~: TypedReduce_toplike R1 R2];
          solve_false; auto.
      simpl in SizeInd. forwards*: IH H10 H13. lia. congruence.
    + (* disjoint *)
      forwards*: principal_type_checks u1. forwards*: principal_type_checks u2.
      subst.
      forwards* S1: TypedReduce_sub R1.
      forwards* S2: TypedReduce_sub R2.
      apply disjoint_eqv in H2. forwards*: H2 S1 S2.
      forwards*: TypedReduce_toplike R1 R2.
    +
      inverts Val1.
      inverts keep R1; try solve [forwards~: TypedReduce_toplike R1 R2]; solve_false; auto.
      inverts Typ1; forwards*: IHCons1.
      inverts Typ1; forwards*: IHCons2.
    +
      inverts Val2.
      inverts keep R2; try solve [forwards*: TypedReduce_toplike R1 R2]; solve_false; auto.
      inverts Typ2; forwards*: IHCons1.
      inverts Typ2; forwards*: IHCons2.
  - intros.
    inverts keep R1; try solve [forwards*: TypedReduce_toplike R1 R2]; solve_false; auto.
    inverts keep R2; try solve [forwards*: TypedReduce_toplike R1 R2]; solve_false; auto.
    split_unify.
    assert (HS: forall A B C, spl A B C -> size_typ B < size_typ A /\ size_typ C < size_typ A). {
      intros. induction H0; simpl; try lia.
    }
    lets* (?&?): HS H.
    forwards*: IH H1 H4. lia. forwards*: IH H2 H5. lia.
    subst*.
Qed.

Lemma papp_unique: forall v1 v2 e1 e2 A,
    value v1 -> value v2 -> Typing nil (e_app v1 v2) Inf A -> papp v1 (vl_exp v2) e1 -> papp v1 (vl_exp v2) e2 -> e1 = e2.
Proof with eauto.
  intros v1 v2 e1 e2 A Val1 Val2 Typ P1 P2.
  gen e2 A.
  inductions P1; intros; inverts* P2.
  - inverts Typ. lets (?&?&?): Typing_chk2inf H8.
    forwards*: TypedReduce_unique H0 H7. congruence.
  - inverts Val1.
    inverts Typ.
    lets (?&?&?): Typing_chk2inf H8.
    inverts H5; inverts H7;
      forwards*: IHP1_1 H1;
      forwards*: IHP1_2 H4;
      subst*.
Qed.

Lemma papp_unique2: forall v1 la e1 e2 A,
    value v1 -> Typing nil (e_proj v1 la) Inf A -> papp v1 (vl_la la) e1 -> papp v1 (vl_la la) e2 -> e1 = e2.
Proof with eauto.
  intros v1 la e1 e2 A Val1 Typ P1 P2. gen e2 A.
  inductions P1; intros; inverts* P2.
  - inverts Val1.
    inverts Typ.
    inverts H6;
      inverts H7;
      forwards*: IHP1_1 H1;
      forwards*: IHP1_2 H4;
      subst*.
Qed.

Theorem step_unique: forall A (e e1 e2 : exp),
    Typing nil e Inf A -> step e e1 -> step e e2 -> e1 = e2.
Proof with solve_false.
  introv Typ Red1.
  gen A e2.
  lets Red1' : Red1.
  induction Red1;
    introv Typ Red2.
  - (* papp*)
    inverts* Red2.
    + forwards*: papp_unique H1 H7.
    + forwards*: step_not_value H6...
    + forwards*: step_not_value H6...
  - (* proj*)
    inverts* Red2.
    + forwards*: papp_unique2 H0 H5.
    + forwards*: step_not_value H4...
  - (* annov*)
    inverts* Red2.
    + (* annov*)
      inverts* Typ.
      inverts H4.
      forwards*: TypedReduce_unique H0 H5.
    + (* anno*)
      forwards*: step_not_value H4...
  - (* appl*)
    inverts Red2;
      try solve [forwards*: step_not_value Red1]...
    + (* appl*)
      inverts Typ.
      forwards* : IHRed1. subst*.
  - (* appr*)
    inverts* Red2;
      try solve [forwards*: step_not_value Red1]...
    + (* appr*)
      inverts* Typ. lets (?&?&?): Typing_chk2inf H7.
      forwards*: IHRed1.
      congruence.
  - (* merge*)
    inverts Typ;
      inverts* Red2;
      try solve [forwards*: step_not_value Red1_2];
      try solve [forwards*: step_not_value Red1_1];
      forwards*: IHRed1_1;
      forwards*: IHRed1_2;
      subst*...
  - (* mergel*)
    inverts* Red2;
      try solve [forwards*: step_not_value H4]...
    + (* mergel*)
      inverts* Typ;
        forwards*: IHRed1;
        congruence.
  - (* merger*)
    inverts* Red2;
      try solve [forwards*: step_not_value H2]...
    + (* merger*)
      inverts* Typ;
        forwards*: IHRed1;
        congruence.
  - (* anno*)
    inverts* Red2;
      inverts* Typ;
      try solve [inverts* Red1];
      try solve [lets*: step_not_value Red1]...
    inverts H1.
    forwards*: IHRed1...
    congruence.
  - (* fix*)
    inverts* Red2.
  - (* rcd*)
    inverts* Typ. inverts* Red2. forwards*: IHRed1. congruence.
  - (* proj*)
    inverts* Typ. inverts* Red2; try solve [forwards*: step_not_value Red1]...
    forwards*: IHRed1. congruence.
Qed.