Require Import Coq.Logic.ProofIrrelevance.
Require Import Coq.omega.Omega.
Require Import RamifyCoq.lib.Coqlib.
Require Import RamifyCoq.lib.EnumEnsembles.
Require Import RamifyCoq.lib.List_ext.
Require Import RamifyCoq.lib.EquivDec_ext.
Require Import RamifyCoq.graph.graph_model.
Require Import RamifyCoq.graph.find_not_in.
Require Import Coq.Lists.List.
Require Import Coq.Lists.ListDec.

Section PATH_LEM.

Context {V E: Type}.
Context {EV: EqDec V eq}.
Context {EE: EqDec E eq}.
Notation Gph := (PreGraph V E).

(******************************************

Definitions

******************************************)

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

Fixpoint valid_path' (g: Gph) (p: list E) : Prop :=
  match p with
    | nil => True
    | n :: nil => strong_evalid g n
    | n1 :: ((n2 :: _) as p') => strong_evalid g n1 /\ dst g n1 = src g n2 /\ valid_path' g p'
  end.

Definition valid_path (g: Gph) (p: path) :=
  match p with
  | (v, nil) => vvalid g v
  | (v, (e :: _) as p') => v = src g e /\ valid_path' g p'
  end.

Fixpoint epath_to_vpath' (g: Gph) (p : list E) {struct p} : list V :=
  match p with
  | nil => nil
  | e :: nil => src g e :: dst g e :: nil
  | e :: el => src g e :: epath_to_vpath' g el
  end.

Definition epath_to_vpath (g: Gph) (p: path) : list V :=
  match p with
  | (v, nil) => v :: nil
  | (_, p') => epath_to_vpath' g p'
  end.

Definition ptail (g: Gph) (p: path) : path :=
  match p with
  | (v, nil) => (v, nil)
  | (_, e :: el) => (dst g e, el)
  end.

Definition graph_is_acyclic (g: Gph) : Prop := forall p : path, valid_path g p -> NoDup (epath_to_vpath g p).

Definition path_prop (g: Gph) (P : Ensemble V)  (p: path) : Prop :=
  P (fst p) /\ Forall (fun e => P (src g e) /\ P (dst g e)) (snd p).

Definition good_path (g: Gph) (P : Ensemble V) : (path -> Prop) := fun p => valid_path g p /\ path_prop g P p.

Definition phead (p : path) : V := match p with | (v, _) => v end.

Fixpoint pfoot' (g: Gph) (l : list E) (v : V) : V :=
  match l with
  | nil => v
  | e :: nil => dst g e
  | _ :: l' => pfoot' g l' v
  end.

Definition pfoot (g: Gph) (p: path) : V := match p with (v, l) => pfoot' g l v end.

Definition path_ends (g: Gph) (p: path) (n1 n2 : V) : Prop := phead p = n1 /\ pfoot g p = n2.

Definition reachable_by_path (g: Gph) (p: path) (n : V) (P : Ensemble V) : Ensemble V :=
  fun n' => path_ends g p n n' /\ good_path g P p.
Notation " g '|=' p 'is' n1 '~o~>' n2 'satisfying' P" := (reachable_by_path g p n1 P n2) (at level 1).

Definition reachable_by (g: Gph) (n : V) (P : Ensemble V) : Ensemble V := fun n' => exists p, g |= p is n ~o~> n' satisfying P.
Notation " g '|=' n1 '~o~>' n2 'satisfying' P " := (reachable_by g n1 P n2) (at level 1).

Definition reachable_by_acyclic (g: Gph) (n : V) (P : Ensemble V) : Ensemble V :=
  fun n' => exists p, NoDup (epath_to_vpath g p) /\ g |= p is n ~o~> n' satisfying P.
Notation " g '|=' n1 '~~>' n2 'satisfying' P " := (reachable_by_acyclic g n1 P n2) (at level 1).

Definition reachable (g: Gph) (n : V): Ensemble V:= reachable_by g n (fun _ => True).

Definition reachable_by_through_set (g: Gph) (S : list V) (P : Ensemble V) : Ensemble V:= fun n => exists s, In s S /\ reachable_by g s P n.

Definition reachable_through_set (g: Gph) (S : list V) : Ensemble V:= fun n => exists s, In s S /\ reachable g s n.

Definition reachable_list (g: Gph) (x : V) (L : list V) : Prop := forall y, In y L <-> reachable g x y.

Definition reachable_set_list (g: Gph) (S : list V) (l : list V) : Prop := forall x : V, In x l <-> reachable_through_set g S x.

Definition is_tree (g : Gph) (x : V) : Prop := forall y, reachable g x y -> exists !(p : path), g |= p is x ~o~> y satisfying (fun _ => True).

Definition paths_meet_at (g: Gph) (p1 p2 : path) := fun n => pfoot g p1 = n /\ phead p2 = n.

Definition paths_meet (g: Gph) (p1 p2 : path) : Prop := exists n, paths_meet_at g p1 p2 n.

Definition In_path (g: Gph) (v: V) (p: path): Prop := v = fst p \/ exists e, In e (snd p) /\ (v = src g e \/ v = dst g e).

Definition Subpath (g: Gph) (p1 p2: path): Prop := incl (snd p1) (snd p2) /\ In_path g (fst p1) p2.

(******************************************

Path Lemmas

******************************************)

Lemma path_ends_meet: forall (g: Gph) p1 p2 n1 n2 n3,
  path_ends g p1 n1 n2 ->
  path_ends g p2 n2 n3 ->
  paths_meet g p1 p2.
Proof.
  unfold path_ends, paths_meet; intros.
  destruct H, H0. exists n2. split; tauto.
Qed.

Lemma pfoot_last: forall (g: Gph) p n s, pfoot g (s, p +:: n) = dst g n.
Proof.
  intros. induction p. 1: simpl; auto.
  rewrite <- app_comm_cons. simpl in *. destruct (p +:: n) eqn:? .
  + destruct p; inversion Heql.
  + auto.
Qed.

Lemma pfoot_head_irrel: forall l (g: Gph) v1 v2 n, pfoot g (v1, n :: l) = pfoot g (v2, n :: l).
Proof.
  induction l; intros; simpl; auto. specialize (IHl g v1 v2 a). simpl in *. apply IHl.
Qed.

Lemma paths_foot_head_meet: forall (g: Gph) p1 p2 n v s, dst g n = v -> paths_meet g (s, p1 +:: n) (v, p2).
Proof. intros. exists v. split. 2: simpl; auto. rewrite pfoot_last. auto. Qed.

Definition path_glue (p1 p2 : path) : path := (fst p1, (snd p1) ++ (snd p2)).
Notation "p1 '+++' p2" := (path_glue p1 p2) (at level 20, left associativity).

Lemma path_glue_nil_l: forall p v, (v, nil) +++ p = (v, snd p).
Proof.
  unfold path_glue.  trivial.
Qed.

Lemma path_glue_nil_r: forall p v, p +++ (v, nil) = p.
Proof.
  unfold path_glue. simpl. intros. rewrite app_nil_r. destruct p. trivial.
Qed.

Lemma path_glue_assoc: forall (g: Gph) (p1 p2 p3 : path),
  paths_meet g p1 p2 -> paths_meet g p2 p3 -> (p1 +++ p2) +++ p3 = p1 +++ (p2 +++ p3).
Proof.
  unfold path_glue. intros. destruct p1 as [v1 p1]. destruct p2 as [v2 p2].
  destruct p3 as [v3 p3]. simpl. rewrite <- app_assoc. auto.
Qed.

Lemma path_ends_glue: forall g n1 n2 n3 p1 p2,
  path_ends g p1 n1 n2 -> path_ends g p2 n2 n3 -> path_ends g (p1 +++ p2) n1 n3.
Proof.
  intros. destruct H, H0. split.
  icase p1. icase p2. icase p1. simpl in *. subst v0 v. destruct l; simpl.
  + rewrite app_nil_r. subst. auto.
  + clear H1. revert H2. induction l0; intros.
    - rewrite app_nil_l. pose proof (pfoot_head_irrel l g n1 n2 e). unfold pfoot in H.
      rewrite H. auto.
    - specialize (IHl0 H2). clear H2. rewrite <- app_comm_cons. simpl.
      remember (l0 ++ e :: l) as l'. destruct l'; auto. destruct l0; inversion Heql'.
Qed.

Lemma paths_meet_cons: forall g v e p1 p2, paths_meet g (v, e :: p1) p2 -> paths_meet g (dst g e, p1) p2.
Proof.
  intros. destruct H as [? [? ?]]. exists x. split; auto. simpl in H |-* . destruct p1. 1: simpl; auto.
  pose proof (pfoot_head_irrel p1 g v (dst g e) e0). unfold pfoot in H1. rewrite H in H1. auto.
Qed.

Lemma valid_path_cons: forall g v e p, valid_path g (v, e :: p) -> valid_path g (dst g e, p).
Proof.
  intros. destruct H. simpl in *. destruct p.
  + destruct H0 as [? [? ?]]. auto.
  + destruct H0; auto.
Qed.

Lemma valid_path_tail: forall g p, valid_path g p -> valid_path g (ptail g p).
Proof.
  intros. destruct p as [v p]. destruct p; unfold ptail; auto.
  apply valid_path_cons with v; auto.
Qed.

Lemma valid_path_split: forall g p1 p2, paths_meet g p1 p2 -> valid_path g (p1 +++ p2) -> valid_path g p1 /\ valid_path g p2.
Proof.
  intros g p1. destruct p1 as [v1 p1]. revert v1.
  induction p1; intros; destruct p2 as [v2 p2]; unfold path_glue, fst, snd in H0.
  + split.
    - simpl in H0 |-* . destruct p2; auto. destruct H0. subst. simpl in H1. destruct p2; [|destruct H1 as [H1 _]]; destruct H1 as [_ [H1 _]]; apply H1.
    - rewrite app_nil_l in H0. destruct H as [x [? ?]]. simpl in H, H1. subst v1. subst v2. auto.
  + specialize (IHp1 (dst g a) (v2, p2)). unfold path_glue, fst, snd in IHp1. rewrite <- app_comm_cons in H0.
    specialize (IHp1 (paths_meet_cons _ _ _ _ _ H) (valid_path_cons _ _ _ _ H0)). destruct IHp1. split; auto.
    clear H2 H. destruct H0. split; auto. simpl in *.  destruct p1. destruct (nil ++ p2); intuition. split; auto.
    destruct ((e :: p1) ++ p2); intuition.
Qed.

Lemma valid_path_merge: forall (g : Gph) p1 p2,
                          paths_meet g p1 p2 -> valid_path g p1 -> valid_path g p2 -> valid_path g (p1 +++ p2).
Proof.
  intros g p1. destruct p1 as [v1 p1]. revert v1.
  induction p1; intros; destruct p2 as [v p2]; unfold path_glue; unfold fst, snd.
  + destruct H as [v' [? ?]]. simpl in H, H2. rewrite <- H in H2. clear v' H.
    subst. rewrite app_nil_l. auto.
  + specialize (IHp1 (dst g a) (v, p2)). unfold path_glue, fst, snd in IHp1. specialize (IHp1 (paths_meet_cons _ _ _ _ _ H) (valid_path_cons _ _ _ _ H0) H1).
    rewrite <- app_comm_cons. destruct H0. red. split; auto.
    clear H1. simpl in *. destruct (p1 ++ p2) eqn:? .
    - destruct p1. auto. rewrite <- app_comm_cons in Heql. inversion Heql.
    - destruct p1; intuition.
Qed.

Lemma valid_path_app: forall g v p1 p2,
    valid_path g (v, p1 ++ p2) <->
    valid_path g (v, p1) /\ valid_path g (pfoot g (v, p1), p2).
Proof.
  intros. assert (paths_meet g (v, p1) (pfoot g (v, p1), p2)) by
      (exists (pfoot g (v, p1)); split; auto). split; intros.
  - apply valid_path_split; auto.
  - destruct H0. apply valid_path_merge in H; auto.
Qed.

Lemma valid_path_si: forall (g1 g2: Gph),
    structurally_identical g1 g2 -> forall p, valid_path g1 p <-> valid_path g2 p.
Proof.
  cut (forall g1 g2 : Gph, g1 ~=~ g2 -> forall p : path, valid_path g1 p -> valid_path g2 p).
  1: intros; split; apply H; [| symmetry]; auto.
  intros. destruct p as [v p]. revert v H0. induction p; intros.
  + destruct H as [? _]. simpl in *. rewrite <- H. auto.
  + specialize (IHp (dst g1 a)). destruct H0. simpl in H1. split.
    - destruct H as [_ [? [? _]]]. destruct p; [| destruct H1 as [? _]]; destruct H1 as [? [? ?]]; specialize (H a); rewrite <- H2; intuition.
    - assert (strong_evalid g1 a -> strong_evalid g2 a). {
        intros. destruct H2 as [? [? ?]]. destruct H as [? [? [? ?]]]. assert (evalid g2 a) by (rewrite <- H5; auto).
        specialize (H6 _ H2 H8). specialize (H7 _ H2 H8). rewrite H6, H7 in *. rewrite H in H3, H4. split; auto.
      } destruct p. 1: simpl; apply H2; auto. destruct H1 as [? ?]. unfold valid_path in IHp. specialize (IHp H3).
      destruct H3, IHp. simpl. split. 1: apply H2; auto. split.
      * rewrite <- H5. symmetry. specialize (H2 H1). destruct H1, H2. destruct H as [_ [_ [_ ?]]]. apply H; auto.
      * apply H6.
Qed.

Lemma epath_to_vpath_cons: forall g v e p a l, epath_to_vpath g (v, e :: p) = a :: l -> epath_to_vpath g (dst g e, p) = l.
Proof. intros. simpl in *. destruct p; inversion H; auto. Qed.

Lemma epath_to_vpath_split: forall (g: Gph) n l1 l2 p, valid_path g p -> epath_to_vpath g p = l1 ++ (n :: l2) ->
                                                       exists p1 p2, p = p1 +++ p2 /\ valid_path g p1 /\ valid_path g p2 /\
                                                                     epath_to_vpath g p1 = l1 +:: n /\ epath_to_vpath g p2 = n :: l2.
Proof.
  intros g n. induction l1; intros.
  + rewrite app_nil_l in H0. exists (n, nil), p. simpl. split; [|split; [|split; [|split]]]; auto; destruct p as [v p].
    - unfold path_glue. simpl. simpl in H. destruct p. 1: inversion H0; auto. f_equal; auto. simpl in H0. destruct H. subst v. destruct p; inversion H0; auto.
    - simpl in H0, H. destruct p. 1: inversion H0; subst; auto. destruct H. simpl in H0, H1.
      destruct p; [|destruct H1 as [? _]]; destruct H1 as [_ [? _]]; inversion H0; subst; auto.
  + destruct p as [v p]. rewrite <- app_comm_cons in H0. destruct p. 1: simpl in H0; inversion H0; destruct l1; inversion H3.
    specialize (IHl1 l2 (dst g e, p) (valid_path_cons _ _ _ _ H) (epath_to_vpath_cons _ _ _ _ _ _ H0)). destruct IHl1 as [p1 [p2 [? [? [? [? ?]]]]]].
    exists (v, e :: (snd p1)), p2. split; [|split; [|split; [|split]]]; auto; destruct p1 as [v1 p1]; destruct p2 as [v2 p2]; unfold path_glue, fst, snd in *.
    - rewrite <- app_comm_cons. inversion H1. auto.
    - clear H4 H5 H0 H3. inversion H1. subst p. clear H1. destruct H. split; auto. simpl in *. destruct p1.
      * destruct (nil ++ p2); intuition.
      * rewrite <- H3 in H2. split; auto. destruct ((e0 :: p1) ++ p2); intuition.
    - rewrite <- app_comm_cons. inversion H1. subst p. clear H1 H3 H5. simpl epath_to_vpath in *. destruct p1.
      * rewrite <- H4. f_equal. destruct (nil ++ p2); inversion H0; auto. rewrite H7; auto.
      * rewrite H4. f_equal; auto. destruct ((e0 :: p1) ++ p2); inversion H0; auto.
Qed.

Lemma epath_to_vpath_pfoot: forall g p l a, epath_to_vpath g p = l +:: a -> pfoot g p = a.
Proof.
  intros g p. destruct p as [v p]; revert v. induction p; intros.
  + simpl in *. destruct l. rewrite app_nil_l in H. inversion H; auto. inversion H. destruct l; inversion H2.
  + simpl in H |-* . destruct p.
    - destruct l. rewrite app_nil_l in H. inversion H. destruct l.
      * simpl in H. inversion H. auto.
      * simpl in H. inversion H. destruct l; inversion H3.
    - destruct l. 1: rewrite app_nil_l in H; inversion H; destruct p; inversion H2. rewrite <- app_comm_cons in H.
      pose proof (pfoot_head_irrel p g v (src g e) e). unfold pfoot at 1 in H0. rewrite H0. apply IHp with l.
      inversion H. simpl. auto.
Qed.

Lemma epath_to_vpath_phead: forall g p l a, valid_path g p -> epath_to_vpath g p = a :: l -> phead p = a.
Proof.
  intros. destruct p. simpl. destruct l0; simpl in *. inversion H0; auto.
  destruct H. subst v. destruct l0; inversion H0; auto.
Qed.

Lemma pfoot_app_cons: forall g v1 v2 e l1 l2, pfoot g (v1, l1 ++ e :: l2) = pfoot g (v2, e :: l2).
Proof.
  intros. induction l1.
  + rewrite app_nil_l. apply pfoot_head_irrel.
  + rewrite <- app_comm_cons. rewrite <- IHl1. simpl. destruct (l1 ++ e :: l2) eqn:? ; auto.
    destruct l1; inversion Heql.
Qed.

Lemma pfoot_cons: forall g v e p, pfoot g (v, e :: p) = pfoot g (dst g e, p).
Proof.
  intros. destruct p; simpl; auto.
  destruct p; auto. apply (pfoot_head_irrel p g v (dst g e) e1).
Qed.

Lemma Subpath_refl: forall g p, Subpath g p p.
Proof.
  intros. destruct p as [v p]. split.
  + apply incl_refl.
  + left; auto.
Qed.

Lemma Subpath_trans: forall g p1 p2 p3, Subpath g p1 p2 -> Subpath g p2 p3 -> Subpath g p1 p3.
Proof.
  intros. destruct p1 as [v1 p1]. destruct p2 as [v2 p2]. destruct p3 as [v3 p3].
  destruct H, H0. split; unfold fst, snd in *. 1: apply incl_tran with p2; auto. destruct H1, H2.
  + subst v1 v2. left; auto.
  + subst. right; auto.
  + subst. destruct H1 as [e [? ?]]. right. exists e. split; auto.
  + destruct H1 as [e [? ?]]. right. exists e. split; auto.
Qed.

Lemma path_acyclic:
  forall (g: Gph) (p: path) n1 n2,
    path_ends g p n1 n2 -> valid_path g p -> Dup (epath_to_vpath g p) ->
    exists p', length (snd p') < length (snd p) /\ Subpath g p' p /\ path_ends g p' n1 n2 /\ valid_path g p'.
Proof.
  intros. apply Dup_cyclic in H1. destruct H1 as [a [L1 [L2 [L3 ?]]]]. rewrite <- app_comm_cons in H1.
  destruct (epath_to_vpath_split _ _ _ _ _ H0 H1) as [p1 [p2 [? [? [? [? ?]]]]]]. rewrite app_comm_cons in H6.
  destruct (epath_to_vpath_split _ _ _ _ _ H4 H6) as [p3 [p4 [? [? [? [? ?]]]]]]. exists (p1 +++ p4).
  split; [|split; [|split]];
  [destruct p as [v p]; destruct p1 as [v1 p1]; destruct p2 as [v2 p2]; destruct p3 as [v3 p3]; destruct p4 as [v4 p4]; unfold path_glue, fst, snd in * ..|].
  + clear - H2 H7 H10. inversion H2. subst p. rewrite !app_length. apply Plus.plus_lt_compat_l. inversion H7. rewrite app_length.
    destruct p3. 1: simpl in H10 |-* ; inversion H10; destruct L2; inversion H5. simpl; intuition.
  + clear - H2 H7. inversion H2. subst p. inversion H7. split. 2: left; simpl; auto. simpl. apply incl_app.
    * apply incl_appl, incl_refl.
    * apply incl_appr, incl_appr, incl_refl.
  + inversion H2; subst. clear H2. inversion H7. subst. clear H7. destruct H. split; simpl in H; auto. destruct p4.
    - rewrite app_nil_r in *. apply epath_to_vpath_pfoot in H5. rewrite H5. simpl in H11. inversion H11. subst L3.
      replace (L1 ++ a :: L2 +:: a) with ((L1 ++ a :: L2) +:: a) in H1.
      * apply epath_to_vpath_pfoot in H1. rewrite H2 in H1. auto.
      * rewrite <- app_assoc. rewrite app_comm_cons. auto.
    - rewrite pfoot_app_cons with (v2 := v1). rewrite app_assoc in H2. rewrite pfoot_app_cons with (v2 := v1) in H2. auto.
  + apply valid_path_merge; auto. exists a. split. apply epath_to_vpath_pfoot in H5. auto.
    apply epath_to_vpath_phead in H11; auto.
Qed.

Lemma valid_path_acyclic:
  forall (g : Gph) (p : path) n1 n2,
    path_ends g p n1 n2 -> valid_path g p ->
    exists p', Subpath g p' p /\ path_ends g p' n1 n2 /\ NoDup (epath_to_vpath g p') /\ valid_path g p'.
Proof.
  intros until p. destruct p as [v p]. revert v. remember (length p). assert (length p <= n) by omega. clear Heqn. revert p H. induction n; intros.
  + assert (p = nil) by (destruct p; auto; simpl in H; exfalso; intuition). subst. exists (v, nil). simpl. simpl in H1.
    split. 1: apply Subpath_refl. do 2 (split; auto). constructor. intro; inversion H2. apply NoDup_nil.
  + destruct (NoDup_dec EV (epath_to_vpath g (v, p))).
    - exists (v, p); split; [apply Subpath_refl | split; auto].
    - destruct (path_acyclic _ _ _ _ H0 H1 n0) as [[v2 p2] [? [? [? ?]]]]. simpl in H2. assert (length p2 <= n) by intuition.
      specialize (IHn p2 H6 _ _ _ H4 H5). simpl in IHn, H3. destruct IHn as [p' [? ?]]. exists p'. split; auto.
      apply Subpath_trans with (v2, p2); auto.
Qed.

Lemma valid_path_edge: forall (g: Gph) v e p, valid_path g (v, e :: p) -> g |= v ~> (dst g e).
Proof.
  intros. destruct H. assert (strong_evalid g e) by (simpl in H0; destruct p; intuition).
  destruct H1 as [? [? ?]]. hnf. subst v. do 2 (split; auto).
  rewrite step_spec. exists e. auto.
Qed.

Lemma valid_path_cons_iff: forall g v e p, valid_path g (v, e :: p) <-> v = src g e /\ strong_evalid g e /\ valid_path g (dst g e, p).
Proof.
  intros. split; intros.
  + pose proof (valid_path_cons _ _ _ _ H). destruct H. subst v.
    do 2 (split; auto). simpl in H1. destruct p; intuition.
  + destruct H as [? [? ?]]. simpl in *. split; auto. destruct p; auto.
Qed.

Lemma path_prop_weaken: forall g (P1 P2 : Ensemble V) p,
  (forall d, P1 d -> P2 d) -> path_prop g P1 p -> path_prop g P2 p.
Proof.
  intros; hnf in *; intros; hnf in *; destruct p. simpl in *. destruct H0. split.
  - apply H; auto.
  - eapply Forall_impl; eauto. simpl. intuition.
Qed.

Lemma path_prop_subpath: forall g P p1 p2,
    Subpath g p1 p2 -> valid_path g p2 -> path_prop g P p2 -> path_prop g P p1.
Proof.
  intros. destruct p1 as [v1 p1]. destruct p2 as [v2 p2]. red in H1 |-* .
  simpl in H1 |-* . destruct H1. destruct H. unfold fst, snd in *. split.
  2: eapply Forall_incl; eauto. destruct H3. 1: simpl in H3; subst; easy.
  destruct H3 as [e [? ?]]. simpl in H3. rewrite Forall_forall in H2.
  specialize (H2 _ H3). destruct H2. destruct H4; subst; easy.
Qed.

Lemma path_prop_tail: forall g P p, path_prop g P p -> path_prop g P (ptail g p).
Proof.
  intros. destruct p as [v p]. red in H |-* . destruct p; simpl in *; auto.
  destruct H. split.
  - rewrite Forall_forall in H0. apply (H0 _ (in_eq e p)).
  - eapply Forall_incl; eauto. apply incl_tl, incl_refl.
Qed.

Lemma path_prop_equiv: forall g P p, valid_path g p -> (path_prop g P p <-> forall n, In_path g n p -> P n).
Proof.
  intros. destruct p as [v p]. unfold path_prop. unfold fst, snd. split; intros.
  - destruct H0. destruct H1. 1: subst; easy. destruct H1 as [e [? ?]]. simpl in H1.
    rewrite Forall_forall in H2. specialize (H2 _ H1). destruct H2, H3; subst; easy.
  - split. 1: apply H0; left; auto. rewrite Forall_forall. intros.
    split; apply H0; right; unfold snd; exists x; split; auto.
Qed.

Lemma pfoot_in_cons: forall g e p v x, pfoot g (v, e :: p) = x -> exists e', In e' (e :: p) /\ dst g e' = x.
Proof.
  intros. revert v e H. induction p; intros. simpl in H.
  + exists e. split; auto. apply in_eq.
  + specialize (IHp (dst g e) a).
    assert (pfoot g (dst g e, a :: p) = x). {
      clear IHp. simpl in *. destruct p; auto.
      pose proof (pfoot_head_irrel p g v (dst g e) e0). unfold pfoot in H0.
      rewrite H in H0. auto.
    } specialize (IHp H0).
    destruct IHp as [e' [? ?]]. exists e'. split; auto.
    apply in_cons. auto.
Qed.

Lemma path_prop_split: forall (g: Gph) p1 p2 P,
    paths_meet g p1 p2 -> valid_path g (p1 +++ p2) -> path_prop g P (p1 +++ p2) ->
    path_prop g P p1 /\ path_prop g P p2.
Proof.
  intros. destruct p1 as [v1 p1]. destruct p2 as [v2 p2]. unfold path_prop. red in H1.
  unfold path_glue, fst, snd in H0, H1 |-* . destruct H1. split; split; auto.
  - eapply Forall_incl; eauto. apply incl_appl, incl_refl.
  - rewrite Forall_forall in H2. red in H. destruct H as [n [? ?]]. destruct p1.
    + simpl in H, H3. subst. easy.
    + apply pfoot_in_cons in H. destruct H as [e' [? ?]]. simpl in H3. subst.
      apply H2. apply in_or_app. left. easy.
  - eapply Forall_incl; eauto. apply incl_appr, incl_refl.
Qed.

Lemma path_prop_app: forall g v p1 p2 P, valid_path g (v, p1 ++ p2) -> path_prop g P (v, p1 ++ p2) -> path_prop g P (v, p1) /\ path_prop g P (pfoot g (v, p1), p2).
Proof. intros. assert (paths_meet g (v, p1) (pfoot g (v, p1), p2)) by (exists (pfoot g (v, p1)); split; auto). apply path_prop_split; auto. Qed.

Lemma good_path_split: forall (g: Gph) p1 p2 P, paths_meet g p1 p2 -> good_path g P (p1 +++ p2) -> (good_path g P p1) /\ (good_path g P p2).
Proof.
  intros. destruct H0. apply path_prop_split in H1; auto. destruct H1.
  apply valid_path_split in H0; auto. destruct H0.
  unfold good_path. split; split; auto.
Qed.

Lemma good_path_app: forall g v p1 p2 P, good_path g P (v, p1 ++ p2) -> good_path g P (v, p1) /\ good_path g P (pfoot g (v, p1), p2).
Proof. intros. assert (paths_meet g (v, p1) (pfoot g (v, p1), p2)) by (exists (pfoot g (v, p1)); split; auto). apply good_path_split; auto. Qed.

Lemma path_prop_merge: forall (g: Gph) p1 p2 P,
    paths_meet g p1 p2 -> path_prop g P p1 -> path_prop g P p2 ->
    path_prop g P (p1 +++ p2).
Proof.
  intros. destruct p1 as [v1 p1]. destruct p2 as [v2 p2]. unfold path_prop in *.
  unfold path_glue, fst, snd in *. destruct H0, H1. split; auto.
  apply Forall_app; easy.
Qed.

Lemma good_path_merge: forall (g: Gph) p1 p2 P,
    paths_meet g p1 p2 -> good_path g P p1 -> good_path g P p2 ->
    good_path g P (p1 +++ p2).
Proof.
  intros. destruct H0, H1. split.
  + apply valid_path_merge; auto.
  + apply path_prop_merge; auto.
Qed.

Lemma good_path_weaken: forall (g: Gph) p (P1 P2 : Ensemble V),
                          (forall d, P1 d -> P2 d) -> good_path g P1 p -> good_path g P2 p.
Proof.
  intros. split; destruct H0; auto.
  apply path_prop_weaken with P1; auto.
Qed.

Lemma good_path_acyclic:
  forall (g: Gph) P p n1 n2,
    path_ends g p n1 n2 -> good_path g P p -> exists p', path_ends g p' n1 n2 /\ NoDup (epath_to_vpath g p') /\ good_path g P p'.
Proof.
  intros. destruct H0. pose proof H0. apply valid_path_acyclic with (n1 := n1) (n2 := n2) in H0; trivial.
  destruct H0 as [p' [? [? [? ?]]]]. exists p'. do 3 (split; trivial).
  apply path_prop_subpath with p; trivial.
Qed.

Lemma good_path_tail: forall (g: Gph) P p, good_path g P p -> good_path g P (ptail g p).
Proof. intros. destruct H. split; [apply valid_path_tail | apply path_prop_tail]; auto. Qed.

Lemma reachable_by_is_reachable (g: Gph): forall n1 n2 P,
    g |= n1 ~o~> n2 satisfying P -> reachable g n1 n2.
Proof.
  intros. unfold reachable. destruct H as [l [? [? ?]]]. exists l.
  do 2 (split; auto). red. split; auto. rewrite Forall_forall; intros; auto.
Qed.

Lemma reachable_by_through_set_is_reachable_through_set (g: Gph):
  forall l n P, reachable_by_through_set g l P n -> reachable_through_set g l n.
Proof.
  intros.
  destruct H as [s [? ?]]; exists s; split; auto.
  apply reachable_by_is_reachable in H0; auto.
Qed.

Lemma reachable_by_path_is_reachable_by (g: Gph):
  forall p n1 n2 P, g |= p is n1 ~o~> n2 satisfying P -> g |= n1 ~o~> n2 satisfying P.
Proof. intros. exists p; auto. Qed.

Lemma reachable_by_path_weaken (g: Gph):
  forall p n1 n2 P1 P2, Included P1 P2 -> g |= p is n1 ~o~> n2 satisfying P1 -> g |= p is n1 ~o~> n2 satisfying P2.
Proof. intros. destruct H0 as [? ?]. split; auto. apply good_path_weaken with P1; auto. Qed.

Lemma reachable_by_path_is_reachable (g: Gph):
  forall p n1 n2 P, g |= p is n1 ~o~> n2 satisfying P -> reachable g n1 n2.
Proof. intros. apply reachable_by_path_is_reachable_by in H. apply reachable_by_is_reachable with P. auto. Qed.

Lemma reachable_Same_set (g: Gph) (S1 S2 : list V):
  S1 ~= S2 -> Same_set (reachable_through_set g S1) (reachable_through_set g S2).
Proof. intros; destruct H; split; repeat intro; destruct H1 as [y [HIn Hrch]]; exists y; split; auto. Qed.

(* Lemma reachable_by_path_nil: forall (g : Gph) n1 n2 P, ~ g |= nil is n1 ~o~> n2 satisfying P. *)
(* Proof. repeat intro. destruct H as [[? _] _]. disc. Qed. *)

Lemma reachable_by_path_head: forall (g: Gph) p n1 n2 P, g |= p is n1 ~o~> n2 satisfying P -> phead p = n1.
Proof. intros. destruct H as [[? _] _]. trivial. Qed.

Lemma reachable_by_path_foot: forall (g: Gph) p n1 n2 P, g |= p is n1 ~o~> n2 satisfying P -> pfoot g p = n2.
Proof. intros. destruct H as [[_ ?] _]. trivial. Qed.

Lemma reachable_by_path_merge: forall (g: Gph) p1 n1 n2 p2 n3 P,
                                 g |= p1 is n1 ~o~> n2 satisfying P ->
                                 g |= p2 is n2 ~o~> n3 satisfying P ->
                                 g |= (p1 +++ p2) is n1 ~o~> n3 satisfying P.
Proof.
  intros. destruct H. destruct H0.
  split. apply path_ends_glue with n2; auto.
  apply good_path_merge; auto.
  eapply path_ends_meet; eauto.
Qed.

Lemma reachable_by_path_split_glue:
  forall (g: Gph) P p1 p2 n1 n2 n, paths_meet_at g p1 p2 n ->
                                   g |= (p1 +++ p2) is n1 ~o~> n2 satisfying P ->
                                   g |= p1 is n1 ~o~> n satisfying P /\
                                   g |= p2 is n ~o~> n2 satisfying P.
Proof.
  intros. destruct H0 as [[? ?] ?]. apply good_path_split in H2.
  + destruct H2. destruct H. split; split; auto; split; auto.
    clear H2 H3. destruct p1 as [v1 p1]. destruct p2 as [v2 p2].
    unfold path_glue, fst, snd in * |-. destruct p2.
    - rewrite app_nil_r in * |-. simpl in *. rewrite H in H1. subst v2. auto.
    - rewrite pfoot_app_cons with (v2 := v1) in H1. rewrite pfoot_head_irrel with (v2 := v2) in H1. auto.
  + exists n; auto.
Qed.

Lemma pfoot_split: forall g v p1 e p2, valid_path g (v, p1 ++ e :: p2) -> pfoot g (v, p1) = src g e.
Proof.
  intros g v p1. revert v. induction p1; intros.
  + simpl. rewrite app_nil_l in H. destruct H. auto.
  + rewrite <- app_comm_cons in H. specialize (IHp1 (dst g a) e p2).
    apply valid_path_cons in H. specialize (IHp1 H). simpl. destruct p1.
    - simpl in IHp1. auto.
    - rewrite pfoot_head_irrel with (v2 := v) in IHp1. apply IHp1.
Qed.

Lemma reachable_by_path_split: forall (g: Gph) v p1 p2 n1 n2 P,
    g |= (v, p1 ++ p2) is n1 ~o~> n2 satisfying P -> g |= (v, p1) is n1 ~o~> pfoot g (v, p1) satisfying P /\ g |= (pfoot g (v, p1), p2) is pfoot g (v, p1) ~o~> n2 satisfying P.
Proof. intros. apply reachable_by_path_split_glue; [unfold paths_meet_at; simpl | unfold path_glue; unfold fst, snd]; auto. Qed.

Lemma reachable_by_path_app_cons: forall (g: Gph) v p1 e p2 n1 n2 P,
    g |= (v, p1 ++ e :: p2) is n1 ~o~> n2 satisfying P -> g |= (v, p1) is n1 ~o~> (src g e) satisfying P /\ g |= (dst g e, p2) is (dst g e) ~o~> n2 satisfying P.
Proof.
  intros. pose proof (reachable_by_path_split_glue g P (v, p1) (src g e, e :: p2) n1 n2 (src g e)).
  assert (paths_meet_at g (v, p1) (src g e, e :: p2) (src g e)) by (hnf; split; [apply (pfoot_split g v p1 e p2); destruct H as [_ [? _]] | simpl]; auto).
  specialize (H0 H1 H). destruct H0. split; auto.  pose proof (reachable_by_path_split_glue g P (src g e, e :: nil) (dst g e, p2) (src g e) n2 (dst g e)).
  assert (paths_meet_at g (src g e, e :: nil) (dst g e, p2) (dst g e)) by (hnf; simpl; auto). specialize (H3 H4 H2). destruct H3. auto.
Qed.

Lemma in_path_split: forall g p n, In_path g n p -> valid_path g p -> exists p1 p2, p = p1 +++ p2 /\ paths_meet_at g p1 p2 n.
Proof.
  intros. destruct p as [v p]. hnf in H. simpl in H. destruct H.
  + subst. exists (v, nil), (v, p). unfold path_glue. simpl. split; split; auto.
  + destruct H as [e [? ?]]. destruct (in_split _ _ H) as [p1 [p2 ?]]. destruct H1.
    - exists (v, p1), (src g e, e :: p2). unfold path_glue. simpl. subst p. split; auto.
      subst n. split; auto. apply pfoot_split in H0. auto.
    - exists (v, p1 +:: e), (dst g e, p2). unfold path_glue. simpl. subst p. rewrite <- app_assoc.
      rewrite <- app_comm_cons. rewrite app_nil_l. split; auto. split.
      * rewrite pfoot_last. auto.
      * simpl. auto.
Qed.

Lemma reachable_by_path_split_in: forall (g : Gph) P p n n1 n2,
  g |= p is n1 ~o~> n2 satisfying P ->
  In_path g n p -> exists p1 p2, p = p1 +++ p2 /\
                                 g |= p1 is n1 ~o~> n satisfying P /\
                                 g |= p2 is n ~o~> n2 satisfying P.
Proof.
  intros. apply in_path_split in H0.
  + destruct H0 as [p1 [p2 [? ?]]]. subst p. exists p1, p2. split; auto.
    apply reachable_by_path_split_glue; auto.
  + destruct H as [? [? ?]]; auto.
Qed.

(* Lemma reachable_by_path_Forall: forall (g: Gph) p n1 n2 P, *)
(*   g |= p is n1 ~o~> n2 satisfying P -> Forall P p. *)
(* Proof. intros. destruct H as [_ [_ ?]]. apply H. Qed. *)

Lemma reachable_by_path_In: forall (g: Gph) p n1 n2 P n,
  g |= p is n1 ~o~> n2 satisfying P -> In_path g n p -> P n.
Proof. intros. destruct H as [_ [? ?]]. rewrite path_prop_equiv in H1; auto. Qed.

Lemma pfoot_si: forall (g1 g2: Gph) p, g1 ~=~ g2 -> valid_path g1 p -> pfoot g1 p = pfoot g2 p.
Proof.
  intros. destruct p as [v p]. revert v H0. induction p; intros.
  + simpl. auto.
  + simpl. destruct p.
    - simpl in H0. destruct H0 as [? [? [? ?]]]. destruct H as [? [? [? ?]]]. specialize (H4 a). apply H6; intuition.
    - specialize (IHp (dst g1 a)). apply valid_path_cons in H0. specialize (IHp H0).
      pose proof (pfoot_head_irrel p g1 v (dst g1 a) e). pose proof (pfoot_head_irrel p g2 v (dst g1 a) e). unfold pfoot in *.
      rewrite H1, H2. apply IHp.
Qed.

Lemma valid_path_strong_evalid: forall g v p e, valid_path g (v, p) -> In e p -> strong_evalid g e.
Proof.
  intros g v p. revert v. induction p; intros. 1: inversion H0. simpl in H0. destruct H0.
  + subst. destruct H. simpl in H0. destruct p; intuition.
  + apply valid_path_cons in H. specialize (IHp _ _ H H0). auto.
Qed.

Lemma In_path_si: forall (g1 g2: Gph) p x, g1 ~=~ g2 -> valid_path g1 p -> (In_path g1 x p <-> In_path g2 x p).
Proof.
  cut (forall g1 g2 p x, g1 ~=~ g2 -> valid_path g1 p -> In_path g1 x p -> In_path g2 x p); intros.
  + split; intros; [apply H with g1 | apply H with g2]; auto. 1: symmetry; auto. apply valid_path_si with g1; auto. symmetry; auto.
  + destruct p as [v p]. unfold In_path in *. simpl in H1 |-* . destruct H1; [left | right]; auto.
    destruct H1 as [e [? ?]]. exists e. split; auto. destruct (valid_path_strong_evalid _ _ _ _ H0 H1) as [? [? ?]]. destruct H as [? [? [? ?]]]. specialize (H6 e).
    assert (src g1 e = src g2 e) by (apply H7; intuition). assert (dst g1 e = dst g2 e) by (apply H8; intuition). rewrite <- H9, <- H10. auto.
Qed.

Lemma path_prop_si: forall (g1 g2: Gph) P p,
    g1 ~=~ g2 -> valid_path g1 p -> path_prop g1 P p -> path_prop g2 P p.
Proof.
  intros. destruct p as [v p]. unfold path_prop in *. simpl in H1 |-* . destruct H1.
  split; auto. rewrite Forall_forall in *. intros. specialize (H2 _ H3).
  destruct H as [_ [? [? ?]]]. specialize (H x). specialize (H4 x). specialize (H5 x).
  destruct (valid_path_strong_evalid _ _ _ _ H0 H3) as [? _].
  rewrite <- H4; [|intuition..]. rewrite <- H5; intuition.
Qed.

Lemma reachable_by_path_si: forall (g1 g2: Gph) p n1 n2 P,
    g1 ~=~ g2 -> (g1 |= p is n1 ~o~> n2 satisfying P <-> g2 |= p is n1 ~o~> n2 satisfying P).
Proof.
  cut (forall g1 g2 p n1 n2 P, g1 ~=~ g2 -> g1 |= p is n1 ~o~> n2 satisfying P -> g2 |= p is n1 ~o~> n2 satisfying P); intros.
  + split; intros; [apply (H g1 g2) | apply (H g2 g1)]; auto. symmetry; auto.
  + destruct H0 as [[? ?] [? ?]]. split; split; auto.
    - rewrite <- (pfoot_si g1 g2 p); auto.
    - rewrite <- (valid_path_si g1 g2 H); auto.
    - apply (path_prop_si g1); auto.
Qed.

Lemma in_path_or_cons: forall g v e p n, v = src g e -> (In_path g n (v, e :: p) <-> n = v \/ In_path g n (dst g e, p)).
Proof.
  intros. subst. unfold In_path. simpl. intuition.
  + destruct H0 as [e0 [? ?]]. destruct H. 1: subst; intuition. right; right; exists e0. split; auto.
  + right. exists e. intuition.
  + right. destruct H as [? [? ?]]. exists x. intuition.
Qed.

Lemma valid_path_valid: forall (g : Gph) p n, valid_path g p -> In_path g n p -> vvalid g n.
Proof.
  intros g p. destruct p as [v p]. revert v. induction p; intros.
  + simpl in *. hnf in H0. simpl in H0. destruct H0. 1: subst; auto. destruct H0 as [e [? _]]. inversion H0.
  + rewrite in_path_or_cons in H0. 2: destruct H; auto. destruct H0.
    - subst. destruct H. subst. simpl in H0. destruct p; [|destruct H0 as [H0 _]]; destruct H0 as [_ [? _]]; auto.
    - apply valid_path_cons in H. apply (IHp (dst g a)); auto.
Qed.

Lemma valid_path_evalid: forall (g : Gph) v p e, valid_path g (v, p) -> In e p -> evalid g e.
Proof. intros. apply (valid_path_strong_evalid g v) in H0; auto. destruct H0; auto. Qed.

Lemma pfoot_in: forall g p n, pfoot g p = n -> In_path g n p.
Proof.
  intros. destruct p as [v p]. destruct p.
  + simpl in H. subst. left. simpl; auto.
  + apply pfoot_in_cons in H. right. unfold snd. destruct H as [e' [? ?]].
    exists e'. split; auto.
Qed.

Lemma pfoot_spec: forall g p n, pfoot g p = n <-> p = (n, nil) \/ exists v l e, p = (v, l +:: e) /\ dst g e = n.
Proof.
  intros. destruct p as [h p]. revert h. induction p; intros; split; intros.
  + simpl in H. subst; left; auto.
  + simpl in *. destruct H. 1: inversion H; auto. destruct H as [? [? [? [? ?]]]]. inversion H. destruct x0; inversion H3.
  + right. rewrite pfoot_cons in H. rewrite IHp in H. destruct H.
    - inversion H. subst p. exists h, nil, a. simpl. auto.
    - destruct H as [v [l [e [? ?]]]]. inversion H. exists h, (a :: l), e. simpl. auto.
  + destruct H. inversion H. destruct H as [v [l [e [? ?]]]]. rewrite pfoot_cons. rewrite IHp. destruct l.
    - simpl in H. inversion H. subst. left; auto.
    - simpl in H. right. exists (dst g a), l, e. inversion H. auto.
Qed.

(******************************************

Reachable Lemmas

******************************************)

Lemma reachable_by_refl: forall (g : Gph) n (P: V -> Prop),
    vvalid g n -> P n -> g |= n ~o~> n satisfying P.
Proof.
  intros. exists (n, nil). split. 1: vm_compute; auto. split; red; simpl; auto.
Qed.

Lemma reachable_by_trans: forall (g: Gph) n1 n2 n3 P,
  g |= n1 ~o~> n2 satisfying P ->
  g |= n2 ~o~> n3 satisfying P ->
  g |= n1 ~o~> n3 satisfying P.
Proof. do 2 destruct 1. exists (x +++ x0). apply reachable_by_path_merge with n2; auto. Qed.

Lemma reachable_by_through_set_reachable_by: forall (g: Gph) l x y P,
  reachable_by_through_set g l P x -> reachable_by g x P y -> reachable_by_through_set g l P y.
Proof.
  intros.
  destruct H as [s [? ?]]; exists s; split; auto.
  apply reachable_by_trans with x; auto.
Qed.

Lemma reachable_by_head_valid: forall (g : Gph) n1 n2 P, g |= n1 ~o~> n2 satisfying P -> vvalid g n1.
Proof.
  repeat intro. destruct H as [p [[? _] [? _]]]. destruct p as [v p]. simpl in *. subst.
  destruct p; auto. destruct H0. simpl in H0. subst. destruct p; [|destruct H0 as [H0 _]]; destruct H0 as [? [? ?]]; auto.
Qed.

Lemma reachable_by_foot_valid: forall (g : Gph) n1 n2 P, g |= n1 ~o~> n2 satisfying P -> vvalid g n2.
Proof.
  repeat intro. destruct H as [p [[? ?] [? ?]]]. apply pfoot_in in H0.
  apply (valid_path_valid _ _ n2) in H1; auto.
Qed.

Lemma reachable_by_head_prop: forall (g: Gph) n1 n2 P, g |= n1 ~o~> n2 satisfying P -> P n1.
Proof.
  intros. destruct H as [p ?]. eapply reachable_by_path_In; eauto.
  apply reachable_by_path_head in H. destruct p as [v p]. simpl in H. subst. left; auto.
Qed.

Lemma reachable_by_foot_prop: forall (g: Gph) n1 n2 P, g |= n1 ~o~> n2 satisfying P -> P n2.
Proof.
  intros. destruct H as [p ?]. eapply reachable_by_path_In; eauto.
  apply reachable_by_path_foot in H. apply pfoot_in. trivial.
Qed.

Lemma reachable_by_through_set_foot_valid: forall (g : Gph) S n P, reachable_by_through_set g S P n -> vvalid g n.
Proof.
  intros.
  destruct H as [s [? ?]].
  eapply reachable_by_foot_valid with (n1 := s); eauto.
Qed.

Lemma reachable_by_through_set_foot_prop: forall (g : Gph) S n P, reachable_by_through_set g S P n -> P n.
Proof.
  intros.
  destruct H as [s [? ?]].
  eapply reachable_by_foot_prop with (n1 := s); eauto.
Qed.

Lemma edge_P_reachable_by: forall (g: Gph) n1 n2 (P: Ensemble V),
    P n1 -> P n2 -> g |= n1 ~> n2 -> g |= n1 ~o~> n2 satisfying P.
Proof.
  intros. destruct H1 as [? [? ?]]. rewrite step_spec in H3.
  destruct H3 as [e [? [? ?]]]. exists (n1, e :: nil). split; split; auto.
  - simpl. split; auto. split; intuition. rewrite H4. auto. rewrite H5; auto.
  - red. simpl. rewrite Forall_forall. subst. split; intros; auto. simpl in H4.
    destruct H4. 2: easy. subst. easy.
Qed.

Lemma edge_reachable_by:
  forall (g: Gph) n1 n2 n3 (P: Ensemble V),
     P n1 ->
     g |= n1 ~> n2 ->
     g |= n2 ~o~> n3 satisfying P ->
     g |= n1 ~o~> n3 satisfying P.
Proof.
  intros. apply reachable_by_trans with n2; auto.
  apply reachable_by_head_prop in H1.
  apply edge_P_reachable_by; auto.
Qed.

Lemma step_reachable_by:
  forall (g: Gph) n1 n2 n3 (P: Ensemble V),
     vvalid g n1 ->
     P n1 ->
     step g n1 n2 ->
     g |= n2 ~o~> n3 satisfying P ->
     g |= n1 ~o~> n3 satisfying P.
Proof.
  intros.
  eapply edge_reachable_by; eauto.
  split; [| split]; auto.
  apply reachable_by_head_valid in H2; auto.
Qed.

Lemma reachable_by_edge:
  forall (g: Gph) n1 n2 n3 (P: Ensemble V),
     P n3 ->
     g |= n1 ~o~> n2 satisfying P ->
     g |= n2 ~> n3 ->
     g |= n1 ~o~> n3 satisfying P.
Proof.
  intros. apply reachable_by_trans with n2; auto.
  apply reachable_by_foot_prop in H0.
  apply edge_P_reachable_by; auto.
Qed.

Lemma reachable_by_step:
  forall (g: Gph) n1 n2 n3 (P: Ensemble V),
     vvalid g n3 ->
     P n3 ->
     g |= n1 ~o~> n2 satisfying P ->
     step g n2 n3 ->
     g |= n1 ~o~> n3 satisfying P.
Proof.
  intros.
  eapply reachable_by_edge; eauto.
  split; [| split]; auto.
  apply reachable_by_foot_valid in H1; auto.
Qed.

Lemma reachable_by_through_set_edge:
  forall (g: Gph) l n2 n3 (P: Ensemble V),
     P n3 ->
     reachable_by_through_set g l P n2 ->
     edge g n2 n3 ->
     reachable_by_through_set g l P n3.
Proof.
  intros.
  destruct H0 as [s [? ?]].
  exists s; split; auto.
  apply reachable_by_edge with n2; auto.
Qed.

Lemma reachable_by_through_set_step:
  forall (g: Gph) l n2 n3 (P: Ensemble V),
     vvalid g n3 ->
     P n3 ->
     reachable_by_through_set g l P n2 ->
     step g n2 n3 ->
     reachable_by_through_set g l P n3.
Proof.
  intros.
  eapply reachable_by_through_set_edge; eauto.
  split; [| split]; auto.
  apply reachable_by_through_set_foot_valid in H1; auto.
Qed.

Lemma reachable_refl: forall (g: Gph) x, vvalid g x -> reachable g x x.
Proof. intros; apply reachable_by_refl; auto. Qed.

Lemma reachable_trans: forall (g: Gph) x y z,
  reachable g x y -> reachable g y z -> reachable g x z.
Proof. intros. eapply reachable_by_trans; eauto. Qed.

Lemma reachable_through_set_reachable: forall (g: Gph) l x y,
  reachable_through_set g l x -> reachable g x y -> reachable_through_set g l y.
Proof.
  intros.
  destruct H as [s [? ?]]; exists s; split; auto.
  apply reachable_trans with x; auto.
Qed.

Lemma reachable_head_valid: forall (g : Gph) n1 n2, reachable g n1 n2 -> vvalid g n1.
Proof. intros; eapply reachable_by_head_valid; eauto. Qed.

Lemma reachable_foot_valid: forall (g : Gph) n1 n2, reachable g n1 n2 -> vvalid g n2.
Proof. intros; eapply reachable_by_foot_valid; eauto. Qed.

Lemma reachable_through_set_foot_valid: forall (g : Gph) S n, reachable_through_set g S n -> vvalid g n.
Proof.
  intros.
  destruct H as [s ?].
  apply reachable_foot_valid with s; tauto.
Qed.

Lemma edge_reachable:
  forall (g : Gph) x y z, reachable g y z -> edge g x y -> reachable g x z.
Proof. intros. eapply edge_reachable_by; eauto. Qed.

Lemma step_reachable:
  forall (g : Gph) x y z, step g x y -> reachable g y z -> vvalid g x -> reachable g x z.
Proof. intros. eapply step_reachable_by; eauto. Qed.

Lemma reachable_edge:
  forall (g : Gph) x y z, reachable g x y -> edge g y z -> reachable g x z.
Proof. intros. eapply reachable_by_edge; eauto. Qed.

Lemma reachable_step:
  forall (g : Gph) x y z, reachable g x y -> step g y z -> vvalid g z -> reachable g x z.
Proof. intros. eapply reachable_by_step; eauto. Qed.

Lemma reachable_through_set_edge:
  forall (g: Gph) l n2 n3,
     reachable_through_set g l n2 ->
     edge g n2 n3 ->
     reachable_through_set g l n3.
Proof.
  intros.
  destruct H as [s [? ?]].
  exists s; split; auto.
  apply reachable_edge with n2; auto.
Qed.

Lemma reachable_through_set_step:
  forall (g: Gph) l n2 n3,
     vvalid g n3 ->
     reachable_through_set g l n2 ->
     step g n2 n3 ->
     reachable_through_set g l n3.
Proof.
  intros.
  eapply reachable_through_set_edge; eauto.
  split; [| split]; auto.
  apply reachable_through_set_foot_valid in H0; auto.
Qed.

(******************************************

Other Reachable Lemmas

******************************************)

Lemma reachable_acyclic: forall (g: Gph) n1 P n2,
  g |= n1 ~o~> n2 satisfying P <->
  g |= n1 ~~> n2 satisfying P.
Proof.
  split; intros.
  destruct H as [p [? ?]].
  apply (good_path_acyclic g P p n1 n2 H) in H0.
  destruct H0 as [p' [? ?]].
  exists p'. destruct H1. split; auto. split; auto.
  destruct H as [p [? ?]].
  exists p. trivial.
Qed.

Lemma reachable_by_subset_reachable: forall (g: Gph) n P,
  Included (reachable_by g n P) (reachable g n).
Proof.
  repeat intro. unfold reachable.
  destruct H as [p [? [? ?]]]. exists p.
  split; trivial.
  split; trivial. apply path_prop_weaken with P; auto.
Qed.

Lemma reachable_through_empty (g: Gph):
  Same_set (reachable_through_set g nil) (Empty_set V).
Proof.
  split; repeat intro.
  destruct H; destruct H; apply in_nil in H; tauto.
  hnf in H; tauto.
Qed.

Lemma reachable_through_empty_eq (g: Gph):
  forall S, Same_set (reachable_through_set g S) (Empty_set V) <-> forall y, In y S -> ~ vvalid g y.
Proof.
  intros; split.
  + induction S; intros; [unfold In; intros; tauto |].
    intros.
    destruct (in_inv H0).
    - subst a; intro.
      destruct H. specialize (H y).
      spec H; [| inversion H].
      unfold Ensembles.In. exists y.
      split; [apply in_eq | apply reachable_by_refl; [|hnf]; trivial].
    - assert (Same_set (reachable_through_set g (a :: S)) (reachable_through_set g S)).
      1: {
        split.
        + apply Extensionality_Ensembles in H; rewrite H.
          intro x; intro. inversion H2.
        + intro; intros. destruct H2 as [s [? ?]].
          exists s; split; trivial; apply in_cons; trivial.
      }
      rewrite <- H2 in IHS. pose proof (IHS H y).
      apply H3; trivial.
  + intros. split; repeat intro.
    destruct H0 as [y [? ?]]. apply H in H0. apply reachable_head_valid in H1; tauto. hnf in H0; tauto.
Qed.

Lemma reachable_through_set_eq (g: Gph):
  forall a S x, reachable_through_set g (a :: S) x <-> reachable g a x \/ reachable_through_set g S x.
Proof.
  intros; split; intros. destruct H as [s [? ?]]. apply in_inv in H. destruct H. subst. left; auto. right. exists s.
  split; auto. destruct H. exists a. split. apply in_eq. auto. destruct H as [s [? ?]]. exists s. split. apply in_cons. auto.
  auto.
Qed.

Lemma reachable_path_in:
  forall (g: Gph) (p: path) (l y : V),
    g |= p is l ~o~> y satisfying (fun _ : V => True) ->
    forall z, In_path g z p -> reachable g l z.
Proof.
  intros. apply reachable_by_path_split_in with (n := z) in H; auto.
  destruct H as [p1 [p2 [? [? ?]]]]. exists p1. apply H1.
Qed.

Lemma reachable_path_edge_in:
  forall (g: Gph) (p: path) (l y : V),
    g |= p is l ~o~> y satisfying (fun _ : V => True) ->
    forall e, In e (snd p) -> reachable g l (src g e) /\ reachable g l (dst g e).
Proof.
  intros. split.
  - assert (In_path g (src g e) p) by (right; exists e; split; auto).
    eapply reachable_path_in; eauto.
  - assert (In_path g (dst g e) p) by (right; exists e; split; auto).
    eapply reachable_path_in; eauto.
Qed.

Lemma reachable_by_path_in: forall (g: Gph) (p: path) (l y : V) (P: V -> Prop),
    g |= p is l ~o~> y satisfying P -> forall z, In_path g z p -> g |= l ~o~> z satisfying P.
Proof.
  intros. apply reachable_by_path_split_in with (n := z) in H; auto.
  destruct H as [p1 [p2 [? [? ?]]]]. exists p1. apply H1.
Qed.

Lemma reachable_path_in':
  forall (g: Gph) (p: path) (l y : V), g |= p is l ~o~> y satisfying (fun _ : V => True) ->
                                         forall z, In_path g z p -> reachable g z y.
Proof.
  intros. apply reachable_by_path_split_in with (n := z) in H; auto.
  destruct H as [p1 [p2 [? [? ?]]]]. exists p2. apply H2.
Qed.

Lemma reachable_by_path_in': forall (g: Gph) (p: path) (l y : V) (P: V -> Prop),
    g |= p is l ~o~> y satisfying P -> forall z, In_path g z p -> g |= z ~o~> y satisfying P.
Proof.
  intros. apply reachable_by_path_split_in with (n := z) in H; auto.
  destruct H as [p1 [p2 [? [? ?]]]]. exists p2. apply H2.
Qed.

Lemma reachable_list_permutation:
  forall (g: Gph) x l1 l2,
    reachable_list g x l1 -> reachable_list g x l2 -> NoDup l1 -> NoDup l2 -> Permutation l1 l2.
Proof. intros. apply NoDup_Permutation; auto. intro y. rewrite (H y), (H0 y). tauto. Qed.

Lemma reachable_through_set_single:
  forall (g: Gph) x y, reachable_through_set g (x :: nil) y <-> reachable g x y.
Proof.
  intros.
  unfold reachable_through_set; split; intros.
  + destruct H as [? [[? | ?] ?]]; [subst; auto |].
    inversion H.
  + exists x; split; auto.
    left; auto.
Qed.

Lemma reachable_through_set_single':
  forall (g: Gph) x, Same_set (reachable_through_set g (x :: nil)) (reachable g x).
Proof.
  intros.
  rewrite Same_set_spec; intros y.
  apply reachable_through_set_single.
Qed.

Lemma reachable_valid_and_through_single:
  forall (g: Gph) {x y}, reachable g x y -> (vvalid g y /\ reachable_through_set g (x :: nil) y).
Proof.
  intros. split.
  + apply reachable_foot_valid in H; auto.
  + exists x. split.
    - apply in_eq.
    - auto.
Qed.

Lemma reachable_list_EnumCovered: forall (g: Gph) x l, reachable_list g x l -> EnumCovered V (reachable g x).
Proof.
  unfold reachable_list, EnumCovered, Ensembles.In.
  intros.
  exists (nodup equiv_dec l).
  split.
  + apply NoDup_nodup.
  + intros y ?.
    specialize (H y).
    rewrite nodup_In.
    tauto.
Qed.

Lemma reachable_set_list_EnumCovered: forall (g: Gph) S l, reachable_set_list g S l -> EnumCovered V (reachable_through_set g S).
Proof.
  unfold reachable_set_list, EnumCovered, Ensembles.In.
  intros.
  exists (nodup equiv_dec l).
  split.
  + apply NoDup_nodup.
  + intros y ?.
    specialize (H y).
    rewrite nodup_In.
    tauto.
Qed.

Lemma epath_to_vpath_cons_eq: forall g v e p, v = src g e -> epath_to_vpath g (v, e :: p) = v :: epath_to_vpath g (dst g e, p).
Proof.
  intros. remember (epath_to_vpath g (v, e :: p)) as l. destruct l. 1: simpl in Heql; destruct p; inversion Heql.
  symmetry in Heql. rewrite (epath_to_vpath_cons _ _ _ _ _ _ Heql). f_equal. subst.
  simpl in Heql. destruct p; inversion Heql; auto.
Qed.

Lemma in_path_eq_epath_to_vpath: forall g p x, valid_path g p -> (In x (epath_to_vpath g p) <-> In_path g x p).
Proof.
  intros. destruct p as [v p]. revert v H. induction p; intros.
  + simpl. unfold In_path. simpl. intuition. destruct H1 as [e [? _]]; exfalso; auto.
  + pose proof (valid_path_cons _ _ _ _ H). destruct H as [? _]. specialize (IHp _ H0).
    rewrite epath_to_vpath_cons_eq; auto. rewrite in_path_or_cons; auto. rewrite <- IHp.
    simpl. intuition.
Qed.

Lemma NoDup_epath_to_vpath_edge: forall g p, valid_path g p -> NoDup (epath_to_vpath g p) -> forall e, In e (snd p) -> src g e <> dst g e.
Proof.
  intros g p. destruct p as [v p]. revert v; induction p; intros. 1: simpl in H1; inversion H1. simpl in H1. destruct H1.
  + subst. simpl in H. destruct H. simpl in H0. destruct p.
    - apply NoDup_cons_2 in H0. intro. apply H0. rewrite H2. apply in_eq.
    - destruct H1 as [? [? ?]]. apply NoDup_cons_2 in H0. intro. apply H0. clear H0. rewrite H4. rewrite H2. destruct p; apply in_eq.
  + rewrite valid_path_cons_iff in H. destruct H as [? [? ?]]. rewrite epath_to_vpath_cons_eq in H0; auto. unfold snd in IHp.
    apply IHp with (dst g a); auto. apply NoDup_cons_1 in H0. auto.
Qed.

Lemma reachable_by_ind: forall (g: Gph) x y P,
                           g |= x ~o~> y satisfying P -> x = y \/
                                                         exists z, g |= x ~> z /\
                                                                   g |= z ~o~> y satisfying (fun n => P n /\ n <> x).
Proof.
  intros. rewrite reachable_acyclic in H. destruct (equiv_dec x y). 1: left; auto. right.
  destruct H as [path [? [[? ?] [? ?]]]]. destruct path as [v p]. simpl in H0. subst v.
  destruct p. 1: simpl in H1; exfalso; auto. exists (dst g e). destruct H2. split.
  - subst x. assert (strong_evalid g e) by (simpl in H2; destruct p; intuition).
    destruct H0 as [? [? ?]]. do 2 (split; auto). rewrite step_spec. exists e. intuition.
  - exists (dst g e, p). split; split.
    + simpl; auto.
    + rewrite pfoot_cons in H1; auto.
    + apply valid_path_cons with x. split; auto.
    + clear H1. red in H3 |-* . simpl in H3 |-* . destruct H3. split.
      * subst x. apply NoDup_epath_to_vpath_edge with (e := e) in H; simpl; auto.
        rewrite Forall_forall in H3. split; auto. apply H3. left; easy.
      * rewrite Forall_forall in *. intros. specialize (H3 _ (in_cons e x0 p H4)).
        destruct H3. rewrite epath_to_vpath_cons_eq in H; auto.
        apply NoDup_cons_2 in H. rewrite in_path_eq_epath_to_vpath in H.
        2: simpl in *; destruct p; [red in H2|]; intuition.
        split; split; auto; intro; apply H; unfold In_path; unfold fst, snd;
          right; exists x0; split; intuition.
Qed.

Lemma reachable_by_weaken: forall (g: Gph) x y P Q,
                                  Included P Q ->
                                  g |= x ~o~> y satisfying P ->
                                  g |= x ~o~> y satisfying Q.
Proof.
  intros. destruct H0 as [p [? [? ?]]].
  exists p. do 2 (split; auto). apply path_prop_weaken with P; auto.
Qed.

Lemma reachable_by_ind_equiv:
  forall (g: PreGraph V E) n1 l n2 (P: Ensemble V),
     let P' := Intersection _ P (Complement _ (eq n1)) in
     vvalid g n1 ->
     step_list g n1 l ->
     P n1 ->
     (g |= n1 ~o~> n2 satisfying P <->
     n1 = n2 \/ reachable_by_through_set g l P' n2).
Proof.
  intros.
  split; intros.
  + apply reachable_by_ind in H2.
    destruct H2; [auto | right].
    destruct H2 as [n [[? [? ?]] ?]].
    exists n.
    split; [rewrite (H0 n); auto |].
    eapply reachable_by_weaken; [| eauto].
    clear.
    intro n; unfold P', Ensembles.In.
    rewrite Intersection_spec.
    unfold Complement, Ensembles.In.
    assert (n <> n1 <-> n1 <> n) by (split; intros; congruence).
    tauto.
  + destruct H2.
    - subst; eapply reachable_by_refl; auto.
    - destruct H2 as [n [? ?]].
      rewrite (H0 n) in H2.
      apply edge_reachable_by with n.
      * auto.
      * split; [| split]; auto.
        apply reachable_by_head_valid in H3; auto.
      * eapply reachable_by_weaken; [| eauto].
        apply Intersection1_Included, Included_refl.
Qed.

Lemma reachable_by_through_set_weaken:
  forall (g: Gph) l x P Q,
    Included P Q ->
    reachable_by_through_set g l P x ->
    reachable_by_through_set g l Q x.
Proof.
  intros.
  destruct H0 as [s [? ?]].
  exists s; split; auto.
  eapply reachable_by_weaken; eauto.
Qed.

Lemma reachable_by_eq: forall (g: Gph) x y P Q,
                                  (forall z, P z <-> Q z) ->
                                  (g |= x ~o~> y satisfying P <-> g |= x ~o~> y satisfying Q).
Proof.
  intros until y.
  intros; split; apply reachable_by_weaken; firstorder.
Qed.

Lemma reachable_through_set_app: forall g S1 S2 x,
  reachable_through_set g S1 x \/ reachable_through_set g S2 x <-> reachable_through_set g (S1 ++ S2) x.
Proof.
  intros; split; intros; [destruct H as [[s ?] | [s ?]] | destruct H as [s ?]].
  + exists s; split; [| tauto].
    rewrite in_app_iff; tauto.
  + exists s; split; [| tauto].
    rewrite in_app_iff; tauto.
  + rewrite in_app_iff in H; destruct H as [[? | ?] ?]; [left | right];
    exists s; tauto.
Qed.

Lemma reachable_through_set_app_left: forall g S1 S2 x,
  reachable_through_set g S1 x -> reachable_through_set g (S1 ++ S2) x.
Proof.
  intros.
  rewrite <- reachable_through_set_app; tauto.
Qed.

Lemma reachable_through_set_app_right: forall g S1 S2 x,
  reachable_through_set g S2 x -> reachable_through_set g (S1 ++ S2) x.
Proof.
  intros.
  rewrite <- reachable_through_set_app; tauto.
Qed.

Lemma reachable_by_through_nil: forall g P n, reachable_by_through_set g nil P n <-> False.
Proof.
  intros; split; intro.
  + destruct H as [s [? ?]]. inversion H.
  + exfalso; auto.
Qed.

Lemma reachable_by_through_nil': forall g P, Same_set (reachable_by_through_set g nil P) (Empty_set _).
Proof.
  intros.
  rewrite Same_set_spec; intro n'.
  pose proof Empty_set_iff V n'.
  unfold Ensembles.In in H.
  rewrite H.
  apply reachable_by_through_nil.
Qed.

Lemma reachable_by_through_singleton:
  forall g P n1 n2, reachable_by_through_set g (n1 :: nil) P n2 <-> g |= n1 ~o~> n2 satisfying P.
Proof.
  intros. unfold reachable_by_through_set; split; intro.
  + destruct H as [s [? ?]]. simpl in H. destruct H; [subst | exfalso]; auto.
  + exists n1. split; [apply in_eq | auto].
Qed.

Lemma reachable_by_through_singleton':
  forall g P n, Same_set (reachable_by_through_set g (n :: nil) P) (reachable_by g n P).
Proof.
  intros.
  rewrite Same_set_spec; intro n'.
  apply reachable_by_through_singleton.
Qed.

Lemma reachable_by_through_app: forall g P n l1 l2, reachable_by_through_set g (l1 ++ l2) P n <-> reachable_by_through_set g l1 P n \/ reachable_by_through_set g l2 P n.
Proof.
  intros.
  unfold reachable_by_through_set.
  split; [intros [s [? ?]] | intros [[s [? ?]] | [s [? ?]]]].
  + rewrite in_app_iff in H.
    destruct H; [left | right]; exists s; auto.
  + exists s.
    rewrite in_app_iff; auto.
  + exists s.
    rewrite in_app_iff; auto.
Qed.

Lemma reachable_by_through_app': forall g P l1 l2,
  Same_set
   (reachable_by_through_set g (l1 ++ l2) P)
   (Union _ (reachable_by_through_set g l1 P) (reachable_by_through_set g l2 P)).
Proof.
  intros.
  rewrite Same_set_spec; intro n; rewrite Union_spec.
  apply reachable_by_through_app.
Qed.

Lemma reachable_by_through_non_foot: forall g P n l l0, reachable_by_through_set g l P n -> reachable_by_through_set g (l ++ l0 :: nil) P n.
Proof.
  intros.
  rewrite reachable_by_through_app; tauto.
Qed.

Lemma reachable_by_through_foot: forall g P n l l0, reachable_by g l0 P n -> reachable_by_through_set g (l ++ l0 :: nil) P n.
Proof.
  intros.
  rewrite reachable_by_through_app, reachable_by_through_singleton; tauto.
Qed.

Definition ReachDecidable (g: Gph) (x : V) (P : V -> Prop) :=
  forall y, Decidable (g |= x ~o~> y satisfying P).

Lemma is_tree_sub_is_tree: forall (g: Gph) root, vvalid g root -> is_tree g root -> forall v, step g root v -> is_tree g v.
Proof.
  repeat intro. assert (reachable g root y) by (apply step_reachable with v; auto). specialize (H0 _ H3).
  destruct H0 as [proot [? ?]]. destruct H2 as [p ?]. exists p. split; auto. intro p'. intros.
  rewrite  step_spec in H1. destruct H1 as [e [? [? ?]]].
  assert (forall path, g |= path is v ~o~> y satisfying (fun _ : V => True) -> g |= (root, e :: nil) +++ path is root ~o~> y satisfying (fun _ : V => True)). {
    intro ppp; intros. clear -H H1 H6 H7 H8. apply reachable_by_path_merge with v; auto.
    split; split; simpl; auto.
    + split; auto. hnf. apply reachable_by_path_is_reachable in H8. apply reachable_by_head_valid in H8. subst. auto.
    + hnf. rewrite Forall_forall; intros; auto.
  } pose proof (H8 _ H2). pose proof (H8 _ H5). pose proof (H4 _ H9). pose proof (H4 _ H10). rewrite H11 in H12. inversion H12.
  destruct p as [v1 p1]. destruct p' as [v2 p2]. simpl in H14. f_equal; auto.
  clear -H2 H5. apply reachable_by_path_head in H2. simpl in H2. apply reachable_by_path_head in H5. simpl in H5. subst. auto.
Qed.

Lemma root_reachable_by_derive: forall (P: V -> Prop) g root,
    forall n, g |= root ~o~> n satisfying P ->
              n = root \/
              exists e, out_edges g root e /\ g |= dst g e ~o~> n
                                                satisfying (fun x : V => P x /\ x <> root).
Proof.
  intros. apply reachable_by_ind in H. destruct H; [left | right]; auto.
  destruct H as [z [[? [? ?]] ?]]. rewrite step_spec in H1. destruct H1 as [e [? [? ?]]]. subst z.
  exists e; split; auto. hnf. auto.
Qed.

Lemma In_path_glue: forall g p1 p2 v, In_path g v (p1 +++ p2) -> In_path g v p1 \/ In_path g v p2.
Proof.
  intros. destruct p1 as [v1 p1]. destruct p2 as [v2 p2]. unfold path_glue in H. simpl in H. unfold In_path in *. simpl in *. destruct H. 1: left; left; auto.
  destruct H as [e [? ?]]. rewrite in_app_iff in H. destruct H; [left | right]; right; exists e; split; auto.
Qed.

Lemma valid_path_reachable: forall g p v1 v2, valid_path g p -> In_path g v1 p -> In_path g v2 p -> reachable g v1 v2 \/ reachable g v2 v1.
Proof.
  intros. assert (g |= p is (phead p) ~o~> (pfoot g p) satisfying (fun _ => True)) by (split; split; simpl; auto; rewrite path_prop_equiv; intros; auto).
  destruct (reachable_by_path_split_in _ _ _ _ _ _ H2 H0) as [p1 [p2 [? [? ?]]]]. rewrite H3 in H1. apply In_path_glue in H1. destruct H1.
  + right. apply (reachable_path_in' _ _ _ _ H4); auto.
  + left. apply (reachable_path_in _ _ _ _ H5); auto.
Qed.

Lemma In_path_Subpath: forall g p1 p2 v, In_path g v p1 -> Subpath g p1 p2 -> In_path g v p2.
Proof.
  intros. destruct p1 as [v1 p1]. destruct p2 as [v2 p2]. unfold In_path in H. destruct H0. simpl in *. destruct H.
  + subst. auto.
  + right. destruct H as [e [? ?]]. exists e. split; auto.
Qed.

Lemma valid_path_unique_edge: forall (g : Gph) (p : path) s t e,
    path_ends g p s t -> valid_path g p -> In e (snd p) ->
    exists p1 p2, Subpath g (s, p1 ++ e :: p2) p /\
                  path_ends g (s, p1 ++ e :: p2) s t /\
                  valid_path g (s, p1 ++ e :: p2) /\ ~ In e p1 /\ ~ In e p2 /\
                  length (p1 ++ e :: p2) <= length (snd p).
Proof.
  intros g p. destruct p as [v p]. simpl snd. revert v. remember (length p).
  assert (length p <= n) by omega. rewrite Heqn. clear Heqn.
  revert p H. induction n; intros.
  - assert (p = nil) by (destruct p; auto; simpl in H; omega). simpl in *.
    subst p. inversion H2.
  - simpl in H2. assert (v = s) by (destruct H0; now simpl in H0). subst v.
    apply in_split in H2. destruct H2 as [l1 [l2 ?]]. subst p.
    destruct (in_dec equiv_dec e l1).
    + apply in_split in i. destruct i as [l1' [l3 ?]]. subst l1. rename l1' into l1.
      assert (length (l1 ++ e :: l2) <= n) by
          (rewrite !app_length in *; simpl length in *; omega).
      assert (path_ends g (s, l1 ++ e :: l2) s t). {
        split; [simpl; auto|]. destruct H0. now rewrite (pfoot_app_cons _ _ s) in *. }
      assert (valid_path g (s, l1 ++ e :: l2)). {
        clear -H1. rewrite !valid_path_app, !valid_path_cons_iff in *.
        destruct H1 as [[? [? [? ?]]] [? [? ?]]]. split; auto. }
      assert (In e (l1 ++ e :: l2)) by (rewrite in_app_iff; right; now left).
      specialize (IHn _ H2 _ _ _ _ H3 H4 H5).
      destruct IHn as [p1 [p2 [? [? [? [? [? ?]]]]]]]. exists p1, p2.
      split; [|split; [|split; [|split; [|split]]]]; auto.
      * apply Subpath_trans with (s, l1 ++ e :: l2); auto.
        red. unfold In_path. simpl. split; [|now left]. apply incl_app.
        2: now apply incl_appr. now do 2 apply incl_appl.
      * transitivity (length (l1 ++ e :: l2)); auto. rewrite !app_length. simpl. omega.
    + destruct (in_dec equiv_dec e l2); [clear n0|].
      2: exists l1, l2; split; [apply Subpath_refl | auto]. apply in_split in i.
      destruct i as [l3 [l2' ?]]. subst l2. rename l2' into l2.
      assert (length (l1 ++ e :: l2) <= n). {
        rewrite app_length in *; simpl length in *. rewrite app_length in H.
        simpl length in H. omega. }
      assert (path_ends g (s, l1 ++ e :: l2) s t). {
        split; [simpl; auto|]. destruct H0. rewrite app_comm_cons, app_assoc in H3.
        now rewrite (pfoot_app_cons _ _ s) in *. }
      assert (valid_path g (s, l1 ++ e :: l2)). {
        clear -H1. rewrite valid_path_app, valid_path_cons_iff in *.
        rewrite valid_path_app, valid_path_cons_iff in H1.
        destruct H1 as [? [? [? [? [? [? ?]]]]]]. split; auto. }
      assert (In e (l1 ++ e :: l2)) by (rewrite in_app_iff; right; now left).
      specialize (IHn _ H2 _ _ _ _ H3 H4 H5).
      destruct IHn as [p1 [p2 [? [? [? [? [? ?]]]]]]]. exists p1, p2.
      split; [|split; [|split; [|split; [|split]]]]; auto.
      * apply Subpath_trans with (s, l1 ++ e :: l2); auto.
        red. unfold In_path. simpl. split; [|now left]. apply incl_app.
        1: now apply incl_appl. rewrite app_comm_cons, app_assoc. now apply incl_appr.
      * transitivity (length (l1 ++ e :: l2)); auto.
        do 2 (rewrite !app_length; simpl). omega.
Qed.

Lemma good_path_unique_edge: forall (g: Gph) P p s t e,
    path_ends g p s t -> good_path g P p -> In e (snd p) ->
    exists p1 p2, Subpath g (s, p1 ++ e :: p2) p /\
                  path_ends g (s, p1 ++ e :: p2) s t /\
                  good_path g P (s, p1 ++ e :: p2) /\ ~ In e p1 /\ ~ In e p2 /\
                  length (p1 ++ e :: p2) <= length (snd p).
Proof.
  intros. destruct H0. pose proof H0. eapply valid_path_unique_edge in H0; eauto.
  destruct H0 as [p1 [p2 [? [? [? [? [? ?]]]]]]]. exists p1, p2. do 4 (split; auto).
  apply path_prop_subpath with p; trivial.
Qed.

Lemma reachable_path_unique_edge: forall (g: Gph) (p: path) (s t : V) (e: E) P,
    g |= p is s ~o~> t satisfying P -> In e (snd p) ->
    exists p1 p2, g |= (s, p1 ++ e :: p2) is s ~o~> t satisfying P /\
                  ~ In e p1 /\ ~ In e p2 /\ length (p1 ++ e :: p2) <= length (snd p).
Proof.
  intros. destruct H. eapply good_path_unique_edge in H0; eauto.
  destruct H0 as [p1 [p2 [? [? [? [? [? ?]]]]]]]. exists p1, p2. do 2 (split; auto).
Qed.

Lemma reachable_src_no_edge: forall (g: Gph) (p: path) (s: V) (e: E) P,
    g |= p is s ~o~> src g e satisfying P ->
    exists p', g |= p' is s ~o~> src g e satisfying P /\ ~ In e (snd p') /\
               length (snd p') <= length (snd p).
Proof.
  intros. destruct (in_dec equiv_dec e (snd p)). 2: (exists p; now split).
  eapply reachable_path_unique_edge in i; eauto. destruct i as [p1 [p2 [? [? [? ?]]]]].
  apply reachable_by_path_app_cons in H0. destruct H0. exists (s, p1).
  split; [|split]; auto. simpl. rewrite app_length in H3. omega.
Qed.

End PATH_LEM.

Arguments path_glue {_ _} _ _.

Module PathNotation.
Notation "p1 '+++' p2" := (path_glue p1 p2) (at level 20, left associativity).
End PathNotation.

Notation " g '|=' p 'is' n1 '~o~>' n2 'satisfying' P" := (reachable_by_path g p n1 P n2) (at level 1).
Notation " g '|=' n1 '~o~>' n2 'satisfying' P " := (reachable_by g n1 P n2) (at level 1).
Notation " g '|=' n1 '~~>' n2 'satisfying' P " := (reachable_by_acyclic g n1 P n2) (at level 1).


Inductive bool : Type :=
	| true : bool
	| false : bool.

Definition andb (a b : bool) : bool :=
	match a with
		| true => b
		| false => false
	end.


(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2010     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)

(** * Typeclass-based setoids, tactics and standard instances.

   Author: Matthieu Sozeau
   Institution: LRI, CNRS UMR 8623 - University Paris Sud
*)

Set Implicit Arguments.
Unset Strict Implicit.

Generalizable Variables A.

Require Import Coq.Program.Program.

Require Import Relation_Definitions.
Require Export Coq.Classes.RelationClasses.
Require Export Coq.Classes.Morphisms.

(** A setoid wraps an equivalence. *)

Class Setoid A := {
  equiv : relation A ;
  setoid_equiv :> Equivalence equiv }.

(* Too dangerous instance *)
(* Program Instance [ eqa : Equivalence A eqA ] =>  *)
(*   equivalence_setoid : Setoid A := *)
(*   equiv := eqA ; setoid_equiv := eqa. *)

(** Shortcuts to make proof search easier. *)

Definition setoid_refl `(sa : Setoid A) : Reflexive equiv.
Proof. typeclasses eauto. Qed.

Definition setoid_sym `(sa : Setoid A) : Symmetric equiv.
Proof. typeclasses eauto. Qed.

Definition setoid_trans `(sa : Setoid A) : Transitive equiv.
Proof. typeclasses eauto. Qed.

Existing Instance setoid_refl.
Existing Instance setoid_sym.
Existing Instance setoid_trans.

(** Standard setoids. *)

(* Program Instance eq_setoid : Setoid A := *)
(*   equiv := eq ; setoid_equiv := eq_equivalence. *)

Program Instance iff_setoid : Setoid Prop :=
  { equiv := iff ; setoid_equiv := iff_equivalence }.

(** Overloaded notations for setoid equivalence and inequivalence. Not to be confused with [eq] and [=]. *)

(** Subset objects should be first coerced to their underlying type, but that notation doesn't work in the standard case then. *)
(* Notation " x == y " := (equiv (x :>) (y :>)) (at level 70, no associativity) : type_scope. *)

Notation " x == y " := (equiv x y) (at level 70, no associativity) : type_scope.

Notation " x =/= y " := (complement equiv x y) (at level 70, no associativity) : type_scope.

(** Use the [clsubstitute] command which substitutes an equality in every hypothesis. *)

Ltac clsubst H :=
  match type of H with
    ?x == ?y => substitute H ; clear H x
  end.

Ltac clsubst_nofail :=
  match goal with
    | [ H : ?x == ?y |- _ ] => clsubst H ; clsubst_nofail
    | _ => idtac
  end.

(** [subst*] will try its best at substituting every equality in the goal. *)

Tactic Notation "clsubst" "*" := clsubst_nofail.

Lemma nequiv_equiv_trans : forall `{Setoid A} (x y z : A), x =/= y -> y == z -> x =/= z.
Proof with auto.
  intros; intro.
  assert(z == y) by (symmetry ; auto).
  assert(x == y) by (transitivity z ; eauto).
  contradiction.
Qed.

Lemma equiv_nequiv_trans : forall `{Setoid A} (x y z : A), x == y -> y =/= z -> x =/= z.
Proof.
  intros; intro.
  assert(y == x) by (symmetry ; auto).
  assert(y == z) by (transitivity x ; eauto).
  contradiction.
Qed.

Ltac setoid_simplify_one :=
  match goal with
    | [ H : (?x == ?x)%type |- _ ] => clear H
    | [ H : (?x == ?y)%type |- _ ] => clsubst H
    | [ |- (?x =/= ?y)%type ] => let name:=fresh "Hneq" in intro name
  end.

Ltac setoid_simplify := repeat setoid_simplify_one.

Ltac setoidify_tac :=
  match goal with
    | [ s : Setoid ?A, H : ?R ?x ?y |- _ ] => change R with (@equiv A R s) in H
    | [ s : Setoid ?A |- context C [ ?R ?x ?y ] ] => change (R x y) with (@equiv A R s x y)
  end.

Ltac setoidify := repeat setoidify_tac.

(** Every setoid relation gives rise to a morphism, in fact every partial setoid does. *)

Program Instance setoid_morphism `(sa : Setoid A) : Proper (equiv ++> equiv ++> iff) equiv :=
  proper_prf.

Program Instance setoid_partial_app_morphism `(sa : Setoid A) (x : A) : Proper (equiv ++> iff) (equiv x) :=
  proper_prf.

(** Partial setoids don't require reflexivity so we can build a partial setoid on the function space. *)

Class PartialSetoid (A : Type) :=
  { pequiv : relation A ; pequiv_prf :> PER pequiv }.

(** Overloaded notation for partial setoid equivalence. *)

Infix "=~=" := pequiv (at level 70, no associativity) : type_scope.

(** Reset the default Program tactic. *)

Obligation Tactic := program_simpl.


(** Proof Reflection in Coq ; subst_lems.v ; 050128 ; Dimitri Hendriks; Coq 8.0pl1 *)

Require Export lift_lems.

Set Implicit Arguments.

Section substitution_lemmas.

Variable l1 l2 : list nat.

Let P := prf l1 l2.
Let F := frm l1 l2.
Let T := trm l1.
Let Ts := trms l1.
Let C := list F.

Lemma simpl_subst_var :
 forall (i n : nat) (t : T), subst_var n (lift n i) t = var _ i.
Proof.
simple induction i; simpl in |- *.
simple destruct n; reflexivity.
intros i' IH n t.
case n.
reflexivity.
intro n'. simpl in |- *.
rewrite (IH n' t).
case i'; reflexivity.
Qed.

Lemma simpl_subst_trm :
 forall (n : nat) (t u : T), subst_trm n (lift_trm n t) u = t.
Proof.
intros n t u.
move t after u. (*!*)
induction t.
simpl in |- *; apply simpl_subst_var.
simpl in |- *.
rewrite mapn_mapn.
set (f := (fun x : trm l1 => subst_trm n (lift_trm n x) u)).
pattern l at 2 in |- *.
rewrite <- (mapn_id (A:=T) (n:=select i) l).
set (g := fun t : T => t) in *.
rewrite (mapn_inn f g l H).
reflexivity.
Qed.

Lemma simpl_subst_trms :
 forall (n z : nat) (l : Ts z) (u : T),
 mapn (fun t => subst_trm n t u) (mapn (lift_trm n) l) = l.
Proof.
intros n z l u.
induction l; simpl in |- *.
reflexivity.
rewrite simpl_subst_trm; rewrite IHl; reflexivity.
Qed.

Lemma simpl_subst_frm :
 forall (p : F) (n : nat) (t : T), subst_frm n (lift_frm n p) t = p.
Proof.
simple induction p; clear p; simpl in |- *.
reflexivity.
reflexivity.
intros i l n t.
rewrite simpl_subst_trms.
reflexivity.
intros p IHp q IHq n t.
rewrite (IHp n t).
rewrite (IHq n t).
reflexivity.
intros p IHp q IHq n t.
rewrite (IHp n t).
rewrite (IHq n t).
reflexivity.
intros p IHp q IHq n t.
rewrite (IHp n t).
rewrite (IHq n t).
reflexivity.
intros p IHp n t.
rewrite (IHp (S n) t).
reflexivity.
intros p IHp n t.
rewrite (IHp (S n) t).
reflexivity.
Qed.

Lemma commute_lift_subst_var :
 forall (i m n : nat) (t : T),
 m <= n -> lift_trm m (subst_var n i t) = subst_var (S n) (lift m i) t.
Proof.
simple induction i.
simple destruct m.
simple destruct n; reflexivity.
intros m' n t.
case n.
intro H. inversion H.
reflexivity.
intros i' IH m n t.
case m.
intro. case n; reflexivity.
intro m'.
case n.
intro H. inversion H.
intros n' H.
simpl in |- *.
rewrite <- (IH m' n' t).
symmetry  in |- *.
apply permute_lift_trm.
exact (le_O_n m').
exact (le_S_n m' n' H).
Qed.

Lemma commute_lift_subst_trm :
 forall (m n : nat) (t u : T),
 m <= n -> lift_trm m (subst_trm n t u) = subst_trm (S n) (lift_trm m t) u.
Proof.
intros m n t u H.
move t after H.
induction t.
simpl in |- *; rewrite (commute_lift_subst_var n0 u H); reflexivity.
simpl in |- *.
rewrite mapn_mapn.
rewrite mapn_mapn.
set (f := fun x : trm l1 => lift_trm m (subst_trm n x u)).
set (g := fun x : trm l1 => subst_trm (S n) (lift_trm m x) u).
rewrite (mapn_inn f g l H0).
reflexivity.
Qed.

Lemma commute_lift_subst_trms :
 forall (m n z : nat) (l : Ts z) (u : T),
 m <= n ->
 mapn (lift_trm m) (mapn (fun t => subst_trm n t u) l) =
 mapn (fun t => subst_trm (S n) t u) (mapn (lift_trm m) l).
Proof.
intros m n z l u h.
induction l; simpl in |- *.
reflexivity.
rewrite commute_lift_subst_trm with (1 := h); rewrite IHl; reflexivity.
Qed.

Lemma commute_lift_subst_frm :
 forall (p : F) (m n : nat) (t : T),
 m <= n -> lift_frm m (subst_frm n p t) = subst_frm (S n) (lift_frm m p) t.
Proof.
simple induction p; clear p; simpl in |- *.
reflexivity.
reflexivity.
intros i l m n t H.
rewrite commute_lift_subst_trms.
reflexivity.
exact H.
intros p IHp q IHq m n t H.
rewrite (IHp m n t H).
rewrite (IHq m n t H).
reflexivity.
intros p IHp q IHq m n t H.
rewrite (IHp m n t H).
rewrite (IHq m n t H).
reflexivity.
intros p IHp q IHq m n t H.
rewrite (IHp m n t H).
rewrite (IHq m n t H).
reflexivity.
intros p IHp m n t H.
rewrite (IHp (S m) (S n) t (le_n_S m n H)).
reflexivity.
intros p IHp m n t H.
rewrite (IHp (S m) (S n) t (le_n_S m n H)).
reflexivity.
Qed.

Lemma commute_lift_subst_cxt :
 forall (G : C) (m n : nat) (t : T),
 m <= n -> lift_cxt m (subst_cxt n G t) = subst_cxt (S n) (lift_cxt m G) t.
Proof.
intros G m n t H.
unfold lift_cxt, subst_cxt in |- *.
rewrite map_map.
rewrite map_map.
apply map_feeg.
intro p.
apply commute_lift_subst_frm.
exact H.
Qed.

Lemma distr_subst_var :
 forall (i m k : nat) (t t' : T),
 subst_trm (m + k) (subst_var m i t) t' =
 subst_trm m (subst_var (S (m + k)) i t') (subst_trm k t t').
Proof.
simple induction i.
simple destruct m; reflexivity.
intros i' IH.
simple destruct m; simpl in |- *.
intros k t t'.
rewrite (simpl_subst_trm 0 (subst_var k i' t') (subst_trm k t t')).
reflexivity.
intros m' k t t'.
rewrite <- (commute_lift_subst_trm (subst_var m' i' t) t' (le_O_n (m' + k))).
rewrite <-
 (commute_lift_subst_trm (subst_var (S (m' + k)) i' t')
    (subst_trm k t t') (le_O_n m')).
rewrite (IH m' k t t').
reflexivity.
Qed.

Lemma distr_subst_trm :
 forall (t u u' : T) (m k : nat),
 subst_trm (m + k) (subst_trm m t u) u' =
 subst_trm m (subst_trm (S (m + k)) t u') (subst_trm k u u').
Proof.
intros t u u' m k.
move t after k. (*!*)
induction t.
simpl in |- *; rewrite distr_subst_var; reflexivity.
simpl in |- *.
rewrite mapn_mapn.
rewrite mapn_mapn.
set (f := fun t : trm l1 => subst_trm (m + k) (subst_trm m t u) u') in *.
set
 (g :=
  fun t : trm l1 => subst_trm m (subst_trm (S (m + k)) t u') (subst_trm k u u'))
 in *.
rewrite (mapn_inn f g l H).
reflexivity.
Qed.

Lemma distr_subst_trms :
 forall (z : nat) (l : Ts z) (u u' : T) (m k : nat),
 mapn (fun t => subst_trm (m + k) t u') (mapn (fun t => subst_trm m t u) l) =
 mapn (fun t => subst_trm m t (subst_trm k u u'))
   (mapn (fun t => subst_trm (S (m + k)) t u') l).
Proof.
intros z l u u' m k.
induction l; simpl in |- *.
reflexivity.
rewrite distr_subst_trm; rewrite IHl; reflexivity.
Qed.

Lemma distr_subst_frm :
 forall (p : F) (t t' : T) (m k : nat),
 subst_frm (m + k) (subst_frm m p t) t' =
 subst_frm m (subst_frm (S (m + k)) p t') (subst_trm k t t').
Proof.
simple induction p; clear p; simpl in |- *.
reflexivity.
reflexivity.
intros i l t t' m k.
rewrite distr_subst_trms.
reflexivity.
intros p IHp q IHq t t' m k.
rewrite (IHp t t' m k).
rewrite (IHq t t' m k).
reflexivity.
intros p IHp q IHq t t' m k.
rewrite (IHp t t' m k).
rewrite (IHq t t' m k).
reflexivity.
intros p IHp q IHq t t' m k.
rewrite (IHp t t' m k).
rewrite (IHq t t' m k).
reflexivity.
intros p IHp t t' m k.
replace (S (m + k)) with (S m + k).
rewrite (IHp t t' (S m) k).
reflexivity.
reflexivity.
intros p IHp t t' m k.
replace (S (m + k)) with (S m + k).
rewrite (IHp t t' (S m) k).
reflexivity.
reflexivity.
Qed.

(* *)
Let v := var l1.

Lemma subst_var_id : forall n i : nat, subst_var n (lift (S n) i) (v 0) = v i.
Proof.
induction n.
destruct i as [| n]; reflexivity.
destruct i as [| n0].
reflexivity.
rename n0 into i.
assert (e : lift (S (S n)) (S i) = S (lift (S n) i)).
reflexivity.
rewrite e.
assert
 (e' :
  subst_var (S n) (S (lift (S n) i)) (v 0) =
  lift_trm 0 (subst_var n (lift (S n) i) (v 0))).
reflexivity.
rewrite e'.
rewrite IHn; reflexivity.
Qed.

Lemma subst_trm_id :
 forall (n : nat) (t : T), subst_trm n (lift_trm (S n) t) (v 0) = t.
Proof.
induction t.
exact (subst_var_id n n0).
simpl in |- *.
rewrite mapn_mapn.
set (f := fun t : trm l1 => subst_trm n (lift_trm (S n) t) (v 0)) in *.
pattern l at 2 in |- *.
rewrite <- (mapn_id (A:=T) (n:=select i) l).
set (g := fun t : trm l1 => t) in *.
rewrite (mapn_inn f g l H).
reflexivity.
Qed.

Lemma subst_trms_id :
 forall (n z : nat) (l : Ts z),
 mapn (fun t => subst_trm n t (v 0)) (mapn (lift_trm (S n)) l) = l.
Proof.
intros n z l.
induction l; simpl in |- *.
reflexivity.
rewrite subst_trm_id; rewrite IHl; reflexivity.
Qed.

Lemma subst_frm_id :
 forall (p : F) (n : nat), subst_frm n (lift_frm (S n) p) (v 0) = p.
Proof.
simple induction p; clear p; simpl in |- *.
reflexivity.
reflexivity.
intros i l n.
rewrite subst_trms_id.
reflexivity.
intros p IHp q IHq n.
rewrite (IHp n).
rewrite (IHq n).
reflexivity.
intros p IHp q IHq n.
rewrite (IHp n).
rewrite (IHq n).
reflexivity.
intros p IHp q IHq n.
rewrite (IHp n).
rewrite (IHq n).
reflexivity.
intros p IHp n.
rewrite (IHp (S n)).
reflexivity.
intros p IHp n.
rewrite (IHp (S n)).
reflexivity.
Qed.

End substitution_lemmas.


(** Authors: Jianzhou Zhao. *)

Require Import Metatheory.

Lemma cons_inv_head: forall A (l1 l2:list A) x y,
  l1 ++ [x] = l2 ++ [y] ->
  l1 = l2.
Proof.
  intros A l1 l2 x y EQ.
  assert (l1 = l2 /\ x = y) as H.
    apply app_inj_tail. auto.
  tauto.
Qed.

Lemma cons_inv_tail: forall A (l1 l2:list A) x y,
  [x] ++ l1 = [y] ++ l2 ->
  l1 = l2.
Proof.
  intro A.
  induction l1; intros l2 x y EQ;
    simpl in EQ; inversion EQ; subst; auto.
Qed.

Lemma concat_inv_head: forall A (l1 l2 l3 l4:list A),
  l1 = l3 ->
  l1 ++ l2 = l3 ++ l4 ->
  l2 = l4.
Proof.
  intros A l1 l2 l3 l4 EQ13 EQ1234; subst.
  induction l3; simpl in EQ1234; auto.
    apply IHl3.
      simpl_env in EQ1234.
      eapply cons_inv_tail; eauto.
Qed.

Lemma concat_inv_tail: forall A (l1 l2 l3 l4:list A),
  l2 = l4 ->
  l1 ++ l2 = l3 ++ l4 ->
  l1 = l3.
Proof.
  intros A l1 l2 l3 l4 EQ24 EQ1234.
  assert (rev (l1 ++ l2) = rev (l3 ++ l4)) as H.
    rewrite EQ1234. auto.
  rewrite distr_rev in H. rewrite distr_rev in H.
  assert (rev l1 = rev l3) as H'.
    eapply concat_inv_head.
      assert (rev l2 = rev l4) as J.
        rewrite EQ24. auto.
      eapply J. auto.
  rewrite <- rev_involutive.
  rewrite <- (rev_involutive l1).
  rewrite H'. auto.
Qed.

Lemma uniq_eq_inv2: forall A (E1:list (atom*A)) x a E2 F1 F2 b,
  uniq (E1 ++ [(x, a)] ++ E2) ->
  E1 ++ [(x, a)] ++ E2 = F1 ++ [(x, b)] ++ F2 ->
   E1 = F1 /\ E2 = F2 /\ a = b
.
Proof.
  intros A E1 x a E2.
  remember (E1 ++ [(x, a)] ++ E2) as G.
  generalize dependent G. generalize dependent E2. generalize dependent a. generalize dependent x.
  induction E1; intros x a1 E2 G EQG F1 F2 b Uniq EQ; auto.
  subst.
    destruct F1. simpl in *. inversion EQ; subst. repeat split; auto.
    simpl in *. inversion EQ. rewrite EQ in Uniq. subst p. simpl_env in Uniq.
    assert (x `notin` dom [(x, a1)]).
    inversion Uniq. simpl_env in *. fsetdec.
    inversion Uniq. simpl_env in *. fsetdec.
    subst.
    destruct F1. subst. simpl in EQ.  inversion EQ. subst a.
    assert (x `notin` dom [(x, b)]).
    inversion Uniq. simpl_env in *. fsetdec.
    inversion Uniq. simpl_env in *. fsetdec.
    rewrite_env (a :: (E1 ++ [(x, a1)] ++ E2)) in EQ.
    rewrite_env (p :: (F1 ++ [(x, b)] ++ F2)) in EQ.
    inversion EQ. subst a.
    assert (E1 = F1 /\ E2 = F2 /\ a1 = b). apply (IHE1 x a1 E2 (E1 ++ [(x, a1)] ++ E2)). auto.
    eapply uniq_app_2. rewrite_env ([p] ++ E1 ++ [(x, a1)] ++ E2) in Uniq. eauto. auto.
    destruct H as [Q1 [Q2 Q3]]. subst. repeat split; auto.
Qed.

Lemma uniq_eq_inv: forall A (E1:list (atom*A)) E2 F1 F2 Y,
  uniq (E1 ++ [Y] ++ E2) ->
  E1 ++ [Y] ++ E2 = F1 ++ [Y] ++ F2 ->
   E1 = F1 /\ E2 = F2
.
Proof.
  intros A E1 E2 F1 F2 Y Uniq EQ.
  destruct Y as [x a].
  apply uniq_eq_inv2 in EQ; auto.
  decompose [and] EQ; auto.
Qed.

Lemma uniq_distinct: forall B A (E1:list (atom*B)) X E2,
  uniq ((A :: E1) ++ [X] ++ E2) ->
  A <> X.
Proof.
  intros B A E1 X E2 H.
  inversion H; subst.
  destruct X; subst.
  rewrite dom_app in H3.
  simpl in H3.
  intros J. inversion J; subst.
  apply H3. fsetdec.
Qed.

Lemma uniq_eq_cases: forall A (E1:list (atom*A)) E2 F1 F2 X Y,
  X <> Y ->
  uniq (E1 ++ [X] ++ E2) ->
  uniq (F1 ++ [Y] ++ F2) ->
  E1 ++ [X] ++ E2 = F1 ++ [Y] ++ F2 ->
  (exists M,
    (E2 =  M ++ [Y] ++ F2  /\
     F1 = E1 ++ [X] ++ M))
  \/
  (exists M,
    (E1 = F1 ++ [Y] ++ M /\
     F2 = M ++ [X] ++ E2))
.
Proof.
  intros A E1.
  induction E1. intros.
    destruct F1. simpl in *. inversion H2. contradiction.
       simpl in H2.  inversion H2. subst p. left. exists F1. simpl. auto.
    (* cons case *)
    intros.
    destruct F1. simpl in *. inversion H2. subst a. right. exists E1. auto.
    (* hard case. *)
    assert (a <> X).
    eapply uniq_distinct. eapply H0.
    assert (p <> Y).
    eapply uniq_distinct. eapply H1.
    inversion H2.
    subst a.
    assert (uniq (E1 ++ [X] ++ E2)).
    rewrite_env ([p] ++ (E1 ++ [X] ++ E2)) in H0.
    eapply  uniq_app_2. eapply H0.
    rewrite_env ([p] ++ (F1 ++ [Y] ++ F2)) in H1.
    assert (uniq (F1 ++ [Y] ++ F2)).
    eapply uniq_app_2. eapply H1.
    destruct (IHE1 E2 F1 F2 X Y H H5 H6 H7).
    left. destruct H8. exists x. destruct H8. subst. auto.
    right. destruct H8. exists x. destruct H8. subst. auto.
Qed.

Lemma uniq_eq_mid: forall A,
   (forall (x y:(atom * A)%type), {x = y}+{~x = y}) ->
   forall (E1:list (atom*A)) X E2 F1 F2,
   uniq (E1 ++ [X] ++ E2) ->
   E1 ++ [X] ++ E2 = F1 ++ F2 ->
      (* X is in F1 *)
   (exists F12, F1 = E1 ++ [X] ++ F12 /\ E2 = F12 ++ F2) \/
      (* X is in F2 *)
   (exists F21, E1 = F1 ++ F21 /\ F2 = F21 ++ [X] ++ E2).
Proof with auto.
  intros A Eq_binding_dec E1 X E2 F1 F2 Uniq EQ.
  destruct F2.
  left. exists E2. simpl in *. rewrite <- app_nil_end. rewrite <- app_nil_end in EQ. auto.
  destruct (Eq_binding_dec X p).
  subst p. rewrite_env (F1 ++ [X] ++ F2) in EQ.
  right. exists nil. rewrite <- app_nil_end. rewrite_env ([X] ++ E2).
  assert (E1 = F1 /\ E2 = F2).
  eapply uniq_eq_inv. eapply Uniq.
  auto. destruct H. subst; auto.
  rewrite_env (F1 ++ [p] ++ F2) in EQ.
  lapply (uniq_eq_cases A E1 E2 F1 F2 X p n Uniq).  intros.
  destruct (H EQ).
  left. destruct H0. exists x. tauto.
  right. destruct H0. exists ([p] ++ x). simpl in H0. simpl. destruct H0. subst. tauto.
  rewrite EQ in Uniq. auto.
Qed.

Lemma uniq_join: forall A (E:list (atom*A)) F G,
  uniq (F ++ E) ->
  uniq (G ++ E) ->
  uniq (G ++ F) ->
  uniq (G ++ F ++ E).
Proof.
  intros A E F G Uniq1 Uniq2 Uniq3.
  solve_uniq.
Qed.

Lemma uniq_commute: forall A (E:list (atom*A)) G,
  uniq (E ++ G) ->
  uniq (G ++ E).
Proof.
  intros A E G H.
  solve_uniq.
Qed.

Lemma binds_weaken_at_tail : forall A (x:atom) (a:A) F G,
  binds x a F ->
  binds x a (F ++ G).
Proof.
  auto.
Qed.

(* Decidability results: *)
Lemma in_dom_dec: forall A x (E:list (atom*A)),
  {x `in` dom E} + {~ x `in` dom E}.
Proof.
  intros A x; induction E.
  right. fsetdec.
  destruct a. destruct IHE.
    left. rewrite_env ([(a, a0)] ++ E). rewrite dom_app. simpl. fsetdec.
    destruct (x == a).
    subst. left. simpl. fsetdec. right. simpl. fsetdec.
Qed.

Lemma uniq_dec: forall A (E:list (atom*A)),
  {uniq E} + {~uniq E}.
Proof.
  induction E; auto.
  destruct a.
  destruct (in_dom_dec A a E).
  destruct IHE. right. unfold not. intros. inversion H. contradiction.
  right. unfold not; intros; inversion H; contradiction.
  destruct IHE. left. apply uniq_cons; auto.
  right. unfold not. intros; inversion H; contradiction.
Qed.

Lemma nil_eq_one_mid_false : forall A (E:list (atom*A)) X G,
  nil = E ++ [X] ++ G -> False.
Proof.
  intros A E X G EQ.
  eapply nil_neq_one_mid; eauto.
Qed.

Lemma one_mid_eq_nil_false : forall A (E:list (atom*A)) X G,
  E ++ [X] ++ G = nil -> False.
Proof.
  intros A E X G EQ.
  eapply one_mid_neq_nil; eauto.
Qed.

Lemma fresh_tail_In : forall A (F G : list (atom*A)) x,
  uniq (F ++ G) -> x `in` (dom F) -> x `notin` (dom G).
Proof with auto.
  induction F as [|(y,b)]; intros G x H J; simpl_env in *.
  assert False by fsetdec. intuition.
  assert (x `in` singleton y \/ x `in` dom F) as K.
    fsetdec.
  destruct K as [K | K].
    assert (x = y) by fsetdec; subst.
      inversion H; subst...
    assert (uniq (F ++ G)) by eauto using uniq_app_2...
Qed.

Lemma fresh_mid_tail_In : forall A (E F G:list (atom*A)) (x:atom),
  uniq (G ++ F ++ E) -> x `in` (dom F) -> x `notin` (dom E).
Proof with auto.
  induction E as [|(y,b)]; intros F G x Ok J; simpl_env in *...
  assert (uniq (G ++ F ++ E)).
    rewrite_env ((G ++ F) ++ E).
    rewrite_env ((G ++ F) ++ [(y,b)] ++ E) in Ok.
    eauto using uniq_remove_mid.
  assert (uniq (F ++ [(y,b)] ++ E)) by eauto using uniq_app_2.
  assert (x `notin` (dom ([(y,b)] ++ E))).
    eapply fresh_tail_In. apply H0. auto.
  auto.
Qed.

Lemma uniq_map_app_l_inv : forall A (E:list (atom*A)) F f,
  uniq (map f F ++ E) -> uniq (F ++ E).
Proof with auto.
  intros. solve_uniq.
Qed.

(* Auxilliary definitions to add enough structure about permutations! *)

Inductive permute {A}: list (atom*A) -> list (atom*A) -> Prop :=
| permute_empty: permute nil nil
| permute_cons: forall D DL DR x b,
    permute D (DL ++ DR) ->
    permute ([(x, b)] ++ D) (DL ++ [(x, b)] ++ DR).

Lemma permute_refl: forall A (D:list (atom*A)),
  permute D D.
Proof.
  induction D.
  apply permute_empty.
  destruct a.
  assert ((permute ((a, a0)::D)
                  ((a, a0)::D)) =
         (permute ([(a, a0)] ++ D)
                  (nil ++ [(a, a0)] ++ D))).
  simpl_env; auto.
  rewrite -> H.
  apply permute_cons. simpl_env. auto.
Qed.

Lemma dom_permute: forall A (D1 D2:list (atom*A)),
  permute D1 D2 ->
  dom D1 [=] dom D2.
Proof.
  induction D1.
  intros.
  inversion H. simpl_env in *. auto. fsetdec.
  intros.
  inversion H. subst. simpl_env in *.
  rewrite (IHD1 (DL ++ DR)). rewrite dom_app. fsetdec. auto.
Qed.

Lemma uniq_exchange: forall A (D1 D2:list (atom*A)) x b,
  uniq ([(x, b)] ++ D1 ++ D2) ->
  uniq (D1 ++ [(x, b)] ++ D2).
Proof.
  induction D1; intros; simpl_env in *.
  auto.
  simpl_env. destruct a.
  simpl_env in *. simpl. apply uniq_cons; auto.
  simpl_env. apply IHD1; auto.
  eapply uniq_remove_mid. apply H.
  inversion H. inversion H2. rewrite dom_app in *.
  simpl_env in *. fsetdec.
Qed.

Lemma uniq_env_permute: forall A (D1 D2:list (atom*A)),
  uniq D1 ->
  permute D1 D2 ->
  uniq D2.
Proof.
  induction D1; intros D2 OK P.
  inversion P. auto.
  inversion P. subst.
  apply uniq_exchange. simpl. apply uniq_cons. apply IHD1; auto.
  inversion OK; auto. rewrite <- (dom_permute A D1).
  inversion OK; auto. auto.
Qed.

Lemma permute_weakening: forall A,
  (forall (x y:(atom * A)%type), {x = y}+{~x = y})->
  forall (D1L:list (atom*A)) D1R D2L D2R x b,
  uniq (D1L ++ [(x, b)] ++ D1R) ->
  permute (D1L ++ D1R) (D2L ++ D2R) ->
  permute (D1L ++ [(x, b)] ++ D1R) (D2L ++ [(x, b)] ++ D2R).
Proof.
  intros A Eq_lbinding_dec.
  induction D1L; intros D1R D2L D2R x b OK P; simpl_env in *; auto.
  Case "emtpy".
    apply permute_cons; auto.
  Case "cons".
  destruct a. simpl_env in *.
  inversion P.
  subst.
  lapply (uniq_eq_mid _ Eq_lbinding_dec DL (a, a0) DR D2L D2R). intros.
  destruct H as [LEFT | RIGHT]. simpl_env in H3. auto.
  destruct LEFT as [F12 [Q1 Q2]].
  subst.  simpl_env in *.
  apply permute_cons. rewrite_env ((DL ++ F12) ++ [(x, b)] ++ D2R).
  apply IHD1L; auto. simpl_env. auto.
  eapply uniq_app_2. apply OK. simpl_env. auto.
  destruct RIGHT as [F21 [Q1 Q2]].
  subst. simpl_env in *.
  rewrite_env ((D2L ++ [(x, b)] ++ F21) ++ [(a, a0)] ++ DR).
  apply permute_cons. simpl_env. apply IHD1L; auto.
  eapply uniq_app_2. apply OK.
  inversion OK. subst.
  apply uniq_exchange. simpl. apply uniq_cons. apply (uniq_env_permute A (D1L ++ D1R)).
  eapply uniq_remove_mid. simpl_env in H2. apply H2. auto.
  rewrite <- (dom_permute _ (D1L ++ D1R)).
  rewrite dom_app in *. simpl_env  in *. fsetdec. auto.
Qed.

Lemma permute_sym: forall A,
  (forall (x y:(atom * A)%type), {x = y}+{~x = y})->
  forall (D1 D2:list (atom*A)),
  uniq D1 ->
  permute D1 D2 ->
  permute D2 D1.
Proof.
  intros A Eq_lbinding_dec.
  induction D1; intros D2 OK PERM.
  inversion PERM. apply permute_empty.
  inversion PERM. subst.
  rewrite_env (nil ++ [(x, b)] ++ D1).
  apply permute_weakening; auto. inversion OK.
  subst. apply uniq_exchange. simpl. apply uniq_cons. apply (uniq_env_permute _ D1); auto.
  rewrite <- (dom_permute _ D1). auto. auto.
  simpl_env. apply IHD1. auto. inversion OK; auto. auto.
Qed.


Set Implicit Arguments.

Require Import
        Syntax.Regex
        Derivatives.Brzozowski
        Prefix.PrefixDef
        Tactics.Tactics.

Fixpoint brzozowski_prefix (e : regex)(s : string) : bool :=
  match s with
  | EmptyString => null e
  | String a' s' =>
    orb (null e) (brzozowski_prefix (deriv a' e) s')
  end.

Theorem brzozowski_prefix_sound
  : forall s e, Is_true (brzozowski_prefix e s) -> prefix e s.
Proof.
  induction s ; intros e H ; simpl in *.
  +
    apply null_sound in H.
    apply MkPrefix with (x := "")(y := "") ; auto.
  +
    apply orb_prop_elim in H.
    destruct H.
    -
      apply null_sound in H.
      apply MkPrefix with (x := "")(y := String a s) ; auto.
    -
      apply IHs in H.
      inverts* H.
      apply deriv_sound in H0.
      apply MkPrefix with (x := String a x)(y := y) ; auto.
Qed.

Theorem brzozowski_prefix_complete
  : forall s e, prefix e s -> Is_true (brzozowski_prefix e s).
Proof.
  induction s ; intros e H ; simpl in * ; inverts* H.
  +
    apply empty_string_concat in H1 ; destruct H1 ; substs.
    apply null_complete in H0 ; auto.
  +
    destruct x ; simpl in *.
    -
      substs.
      apply null_complete in H0.
      apply orb_prop_intro.
      left*.
    -
      injects H1.
      apply deriv_complete in H0.
      apply orb_prop_intro ; right*.
Qed.


(* Copyright 2012-2015 by Adam Petcher.				*
 * Use of this source code is governed by the license described	*
 * in the LICENSE file at the root of the source tree.		*)

Set Implicit Arguments.

Require Import FCF.FCF.
Require Import FCF.SemEquiv.
Require Import FCF.DetSem.

Fixpoint splitVector(A : Set)(n m : nat) : Vector.t A (n + m) -> (Vector.t A n * Vector.t A m) :=
  match n with
          | 0 =>
            fun (v : Vector.t A (O + m)) => (@Vector.nil A, v)
          | S n' =>
            fun (v : Vector.t A (S n' + m)) =>
              let (v1, v2) := splitVector _ _ (Vector.tl v) in
                (Vector.cons _ (Vector.hd v) _ v1, v2)
    end.

Theorem splitVector_append :
  forall (A : Set) n1 (v1 : Vector.t A n1) n2 (v2 : Vector.t A n2),
    splitVector n1 n2 (Vector.append v1 v2) = (v1, v2).

  induction v1; intuition; simpl in *.
  remember ( splitVector n n2 (Vector.append v1 v2)) as z.
  destruct z.
  rewrite IHv1 in Heqz.
  inversion Heqz; subst.
  trivial.
Qed.

Theorem append_splitVector_h :
  forall (A : Set) n1 n2 (x : Vector.t A (n1 + n2)),
   (Vector.append (fst (splitVector n1 n2 x)) (snd (splitVector n1 n2 x))) = x.

  induction n1; intuition; simpl in *.
  destruct (vector_S x).
  destruct H.
  subst.
  simpl.
  remember (splitVector n1 n2 x1) as z.
  destruct z.
  simpl.
  f_equal.
  specialize (IHn1 n2 x1).
  rewrite <- Heqz in IHn1.
  simpl in *.
  trivial.

Qed.

Theorem append_splitVector:
  forall (A : Set) n1 n2 (x : Vector.t A (n1 + n2)) x1 x2,
    (x1, x2) = (splitVector n1 n2 x) ->
   (Vector.append x1 x2) = x.

  intuition.
  specialize (append_splitVector_h _ _ x); intuition.
  rewrite <- H in H0.
  simpl in *.
  trivial.

Qed.

Theorem shiftOut_plus :
  forall (n1 n2 : nat) s b s',
    shiftOut s (n1 + n2) = Some (b, s') ->
    exists b1 b2 s'',
      shiftOut s n1 = Some (b1, s'') /\
      shiftOut s'' n2 = Some (b2, s') /\
      splitVector n1 n2 b = (b1, b2).

  induction n1; intuition; simpl in *.
  rewrite shiftOut_0.
  econstructor.
  econstructor.
  econstructor.
  intuition.
  trivial.

  destruct s; simpl in *.
  discriminate.
  case_eq (shiftOut s (n1 + n2)); intuition.
  rewrite H0 in H.
  destruct p.
  inversion H; clear H; subst.
  edestruct IHn1.
  eauto.
  destruct H.
  destruct H.
  intuition.
  rewrite H1.
  econstructor.
  econstructor.
  econstructor.
  intuition.
  eauto.
  simpl.
  rewrite H3.
  trivial.

  rewrite H0 in H.
  discriminate.

Qed.

Theorem shiftOut_plus_None :
  forall n1 n2 s,
    shiftOut s (n1 + n2) = None ->
    shiftOut s n1 = None \/
    (exists x s', shiftOut s n1 = Some (x, s') /\
      shiftOut s' n2 = None).

  induction n1; intuition; simpl in *.
  rewrite shiftOut_0.
  right.
  econstructor.
  econstructor.
  intuition.

  destruct s; simpl in *.
  intuition.

  case_eq (shiftOut s (n1 + n2)); intuition.
  rewrite H0 in H.
  destruct p.
  discriminate.
  edestruct IHn1.
  eauto.
  rewrite H1.
  intuition.

  destruct H1.
  destruct H1.
  intuition.

  rewrite H2.
  right.

  econstructor.
  econstructor.
  intuition.
Qed.

Theorem Vector_cons_app_assoc :
  forall (A : Type)(a : A)(n1 n2 : nat)(v1 : Vector.t A n1)(v2 : Vector.t A n2),
    Vector.cons _ a _ (Vector.append v1 v2) =
    Vector.append (Vector.cons _ a _ v1) v2.

  induction n1; intuition; simpl in *.

Qed.

Theorem shiftOut_plus_if :
  forall n1 n2 s s' s'' b1 b2,
    shiftOut s n1 = Some (b1, s') ->
    shiftOut s' n2 = Some (b2, s'') ->
    shiftOut s (n1 + n2) = Some (Vector.append b1 b2, s'').

  induction n1; intuition; simpl in *.
  rewrite shiftOut_0 in H.
  inversion H; clear H; subst.
  simpl in *.
  trivial.

  destruct s; simpl in *.
  discriminate.
  case_eq (shiftOut s n1); intuition.
  rewrite H1 in H.
  destruct p.
  inversion H; clear H; subst.
  erewrite IHn1; eauto.

  rewrite Vector_cons_app_assoc.
  trivial.

  rewrite H1 in H.
  discriminate.
Qed.

Theorem shiftOut_plus_None_if :
  forall n1 n2 s,
    (shiftOut s n1 = None \/
      (exists b s', shiftOut s n1 = Some (b, s') /\
        shiftOut s' n2 = None)) ->
    shiftOut s (n1 + n2) = None.

  induction n1; intuition; simpl in *.
  rewrite shiftOut_0 in H0.
  discriminate.
  destruct H0.
  destruct H.
  intuition.
  rewrite shiftOut_0 in H0.
  inversion H0; clear H0; subst.
  trivial.

  destruct s; simpl in *.
  trivial.

  case_eq (shiftOut s n1); intuition.
  rewrite H in H0.
  destruct p.
  discriminate.

  rewrite H in H0.
  erewrite IHn1.
  trivial.
  intuition.

  destruct H0.
  destruct H.
  intuition.
  destruct s; simpl in *.
  discriminate.

  case_eq (shiftOut s n1); intuition.
  rewrite H in H0.
  destruct p.
  inversion H0; clear H0; subst.
  erewrite IHn1.
  trivial.
  right.
  econstructor.
  econstructor.
  intuition.
  eauto.
  trivial.

  rewrite H in H0.
  discriminate.

Qed.

Theorem Rnd_split_equiv :
  forall n1 n2 z ,
    evalDist
    (x <-$ {0, 1}^(n1 + n2);
      ret (splitVector n1 n2 x)) z ==
    evalDist
    (x1 <-$ {0, 1}^n1;
      x2 <-$ {0, 1}^n2;
      ret (x1, x2)) z.

  intuition.

  eapply det_eq_impl_dist_sem_eq; wftac.
  unfold evalDet_equiv.
  intuition.
  inversion H; clear H; subst.
  inversion H0; clear H0; subst.
  simpl in *.
  case_eq (shiftOut s (plus n1 n2)); intuition.
  destruct p.
  specialize (shiftOut_plus _ _ _ H); intuition.
  destruct H0.
  destruct H0.
  destruct H0.
  intuition.

  rewrite H in H4.
  inversion H4; clear H4; subst.
  simpl in *.
  inversion H8; clear H8; subst.
  simpl in *.
  inversion H7; clear H7; subst.
  econstructor.
  econstructor.
  eauto.
  simpl.
  rewrite H1.
  econstructor.
  eauto.
  simpl.
  econstructor.
  eauto.
  simpl.
  rewrite H0.
  econstructor.
  eauto.
  simpl.
  econstructor.
  eauto.
  rewrite H3.
  econstructor.

  rewrite H in H4.
  inversion H4; clear H4; subst.

  inversion H0; clear H0; subst.
  simpl in *.
  case_eq (shiftOut s (n1 + n2)); intuition.
  rewrite H in H4.
  destruct p.
  inversion H4; clear H4; subst.
  simpl in *.
  inversion H5; clear H5; subst.
  simpl in *.
  inversion H4.

  specialize (shiftOut_plus_None _ _ _ H); intuition.
  econstructor.
  econstructor.
  eauto.
  simpl.
  rewrite H1.
  econstructor.
  destruct H1.
  destruct H0.
  intuition.
  econstructor.
  econstructor.
  eauto.
  simpl.
  rewrite H1.
  econstructor.
  eauto.
  simpl.
  econstructor.
  eauto.
  simpl.
  rewrite H2.
  econstructor.

  inversion H; clear H; subst.
  inversion H0; clear H0; subst.
  simpl in *.
  case_eq (shiftOut s n1); intuition.
  rewrite H in H4.
  destruct p.
  inversion H4; clear H4; subst.
  inversion H5; clear H5; subst.
  simpl in *.
  case_eq (shiftOut b1 n2); intuition.
  rewrite H0 in H4.
  destruct p.
  inversion H4; clear H4; subst.
  simpl in *.
  inversion H6; clear H6; subst.
  simpl in *.
  inversion H5; clear H5; subst.
  econstructor.
  econstructor.
  eauto.
  simpl.

  erewrite shiftOut_plus_if; eauto.
  econstructor.
  eauto.
  simpl.
  econstructor.
  eauto.
  simpl.

  rewrite splitVector_append.
  econstructor.

  rewrite H0 in H4.
  inversion H4; clear H4; subst.
  rewrite H in H4.
  inversion H4.

  inversion H0; clear H0; subst.
  simpl in *.
  case_eq (shiftOut s n1); intuition.
  rewrite H in H4.
  destruct p.
  inversion H4; clear H4; subst.
  simpl in *.
  inversion H5; clear H5; subst.
  simpl in *.
  case_eq (shiftOut b1 n2); intuition.
  rewrite H0 in H4.
  destruct p.
  inversion H4; clear H4; subst.
  simpl in *.
  inversion H6; clear H6; subst.
  simpl in *.
  inversion H5.

  econstructor.
  econstructor.
  eauto.
  simpl.

  erewrite shiftOut_plus_None_if.
  econstructor.
  right.
  econstructor.
  econstructor.
  intuition.
  eauto.
  trivial.

  rewrite H in H4.
  econstructor.
  econstructor.
  eauto.
  simpl.
  erewrite shiftOut_plus_None_if.
  econstructor.

  intuition.
Qed.