Require Export kat_alph atoms gl kat.
Require Import Bool.

Module KATPdrvs(X:KAT_Alph).

  Import X.
  Module Export M := KAT(X).

  Definition lte(x y:kat) := katu x y === y.

  (** Empty word property/boolean satisfiability for kat-terms. *)
  Fixpoint ewp(t:kat)(a:atom) : bool :=
    match t with
      | kats x => false
      | katb b => evalT a b
      | katu t1 t2 => ewp t1 a || ewp t2 a
      | katc t1 t2 => ewp t1 a && ewp t2 a
      | katst t1 => true
    end.

  Lemma ewp_dec :
    forall k a,
      {ewp k a = false}+{ewp k a = true}.
  Proof.
    induction k;simpl;intros;intuition.
  Qed.

  Lemma ewp_cases_epsilon_false :
    forall r a,
      ewp r a = false -> ~In _ (kat2gl r) (gs_end a).
  Proof.
    induction r;intros.
    simpl in H.
    intro.
    inversion H0.

    simpl in H.
    intro.
    inversion H0.
    congruence.

    simpl in H.
    simpl.
    intro.
    apply Bool.orb_false_iff in H.
    destruct H.
    pose proof (IHr1 a H).
    pose proof (IHr2 a H1).
    inversion H0;contradiction.

    simpl in H.
    intro.
    apply Bool.andb_false_iff in H.
    destruct H.
    pose proof (IHr1 a H).
    inversion H0.
    apply fusion_prod_split_gs_end in H2.
    destruct H2;subst.
    contradiction.
    pose proof (IHr2 a H).
    inversion H0.
    apply fusion_prod_split_gs_end in H2.
    destruct H2;subst.
    contradiction.

    simpl in H;discriminate.
  Qed.

  Lemma ewp_cases_epsilon_true :
    forall r a,
      ewp r a = true -> In _ (kat2gl r) (gs_end a).
  Proof.
    induction r;intros;try discriminate.
    constructor;auto.
    apply Bool.orb_true_iff in H.
    destruct H.
    pose proof IHr1 _ H.
    left.
    assumption.
    pose proof IHr2 _ H.
    right;auto.
    apply Bool.andb_true_iff in H.
    destruct H.
    pose proof IHr1 _ H.
    pose proof IHr2 _ H0.
    assert(exists H, fusion_prod (gs_end a) (gs_end a) H = (gs_end a)).
    simpl.
    unfold compatible.
    simpl.
    exists(refl_equal a).
    reflexivity.
    destruct H3.
    rewrite <- H3.
    constructor;auto.
    econstructor 1 with O.
    simpl.
    constructor.
  Qed.

  Lemma ewp_gs_split_aux :
    forall (r1 r2:kat) a,
      ~ In gstring (gl_conc r1 r2) (gs_end a) ->
      ~ In _ (kat2gl r1) (gs_end a) \/
      ~ In _ (kat2gl r2) (gs_end a).
  Proof.
    intros.
    destruct(ewp_dec r1 a);destruct(ewp_dec r2 a).
    apply ewp_cases_epsilon_false in e.
    apply ewp_cases_epsilon_false in e0;auto.
    left;intro.
    apply ewp_cases_epsilon_false in e.
    contradiction.
    right;intro.
    apply ewp_cases_epsilon_false in e0;auto.
    elimtype False.
    apply H.
    apply ewp_cases_epsilon_true in e.
    apply ewp_cases_epsilon_true in e0;auto.
    change (gs_end a) with (fusion_prod (gs_end a) (gs_end a) (refl_equal a)).
    constructor;auto.
  Qed.

  Lemma ewp_cases_epsilon_false_inv :
    forall r a,
      ~In _ (kat2gl r) (gs_end a) -> ewp r a = false.
  Proof.
    induction r;simpl;intros;auto.
    apply not_true_is_false.
    intro.
    apply H.
    constructor;auto.
    apply Bool.orb_false_iff.
    split.
    apply IHr1.
    intro;apply H;auto.
    left;auto.
    apply IHr2.
    intro;apply H;right;auto.
    apply Bool.andb_false_iff.
    pose proof ewp_gs_split_aux _ _ _ H.
    destruct H0;eauto.
    elim H.
    constructor 1 with O.
    simpl.
    constructor.
  Qed.

  Lemma ewp_cases_epsilon_true_inv :
    forall r a,
      In _ (kat2gl r) (gs_end a) -> ewp r a = true.
  Proof.
    induction r;simpl;intros;auto.
    inversion H.
    inversion H;auto.
    apply Bool.orb_true_iff.
    inversion_clear H.
    left;apply (IHr1 a H0).
    right;apply (IHr2 a H0).
    inversion H.
    apply Bool.andb_true_iff.
    split.
    apply IHr1.
    apply fusion_prod_split_gs_end in H0.
    destruct H0;subst;auto.
    apply fusion_prod_split_gs_end in H0.
    destruct H0;subst;auto.
  Qed.

  (** Partial derivative of a kat-term by a pair (Atom,Symbol) *)
  Fixpoint pdrv(x:kat)(a:atom)(s:Z) : set kat :=
    match x with
      | kats y =>
          match compare y s with
            | Eq => {katb ba1}
            | _ => {}
          end
      | katb b => {}
      | katu x1 x2 => pdrv x1 a s ++ pdrv x2 a s
      | katc x1 x2 =>
          if ewp x1 a then
            dsr (pdrv x1 a s) x2 ++ pdrv x2 a s
          else
            dsr (pdrv x1 a s) x2
      | katst x1 => dsr (pdrv x1 a s) (katst x1)
    end.

  Lemma ewp_empty_symbol :
    forall e x y,
      e === kats y -> ewp e x === false.
  Proof.
    induction e;intros;
    simpl;auto;
    abstract(inversion H).
  Qed.

  Lemma val_with_test_true :
    forall t alpha,
      evalT alpha t = true ->
      ewp (katb t) alpha === true.
  Proof.
    intros.
    functional induction (evalT alpha t);try discriminate;
    simpl;auto.
  Qed.

  Lemma val_with_test_false :
    forall t alpha,
      evalT alpha t = false ->
      ewp (katb t) alpha === false.
  Proof.
    intros.
    functional induction (evalT alpha t);try discriminate;
    simpl;auto.
  Qed.

  Lemma not_eq_katu :
    forall e1 e2, katu e1 e2 <> e2.
  Proof.
    double induction e1 e2;intros;intro;
    try discriminate.
    injection H1;intros.
    specialize H0 with z.
    rewrite <- H2 in H0 at 2.
    rewrite <- H3 in H0.
    elim H0;auto.
    injection H1;intros.
    specialize H0 with t.
    rewrite H3 in H0.
    contradiction.
    injection H3;intros.
    eapply H0.
    eapply H1.
    eapply H2.
    rewrite <- H4 at 2.
    rewrite <- H5.
    reflexivity.
    eapply H0.
    apply H1.
    apply H2.
    injection H3;intros.
    rewrite <- H4 at 2.
    rewrite <- H5.
    reflexivity.
    injection H2;intros.
    eapply H0.
    apply H1.
    rewrite <- H3 at 2.
    rewrite <- H4.
    reflexivity.
  Qed.

  Global Instance ewp_m : Proper(_eq ==> _eq ==> _eq) ewp.
  Proof.
    repeat red.
    intros.
    inv H.
  Qed.

  Global Instance pdrv_m : Proper(_eq ==> _eq ==> _eq ==> _eq) pdrv.
  Proof.
    repeat red.
    intros.
    inv H. subst.
    inv H0. subst.
    inv H1;subst.
    split;intros;auto.
  Qed.

  (** Derivatives of a set of kat terms wrt. an atom and a symbol. *)

  Definition pdrv_set (sre:set kat)(a:atom)(s:Z) :=
    fold (fun x => union (pdrv x a s)) sre {}%set.

  Definition ewp_set(sre:set kat)(a:atom) :=
    fold (fun x => orb (ewp x a)) sre false.

  Instance pdrv_set_proper : forall a s, Proper(_eq ==> _eq ==> _eq)
    (fun x0 => union (pdrv x0 a s)).
  Proof.
    repeat red;split;intros;
    normalize_notations;
    [rewrite H0,H in H1|
     rewrite H0,H];auto.
  Qed.

  Instance ewp_set_proper :
    forall a,
      Proper(_eq ==> _eq ==> _eq) (fun x => orb (ewp x a)).
  Proof.
    repeat red;intros.
    rewrite H0.
    rewrite H.
    reflexivity.
  Qed.

  Lemma pdrv_set_transpose : forall a s,
    transpose Equal (fun x0 => union (pdrv x0 a s)).
  Proof.
    repeat red;intros;
    split;intros;auto;
    apply union_iff in H;
    destruct H.
    apply union_3;apply union_2;auto.
    apply union_iff in H;destruct H.
    apply union_2;auto.
    apply union_3;apply union_3;auto.
    apply union_3;apply union_2;auto.
    apply union_iff in H;destruct H.
    apply union_2;auto.
    apply union_3;apply union_3;auto.
  Qed.

  Hint Resolve pdrv_set_transpose : typeclass_instances.

  Lemma ewp_set_transp : forall a, transpose eq (fun y : kat => orb (ewp y a)).
  Proof.
    repeat red;intros;auto with bool.
    destruct(ewp x a);destruct(ewp y a);case z;simpl;reflexivity.
  Qed.

  Hint Resolve ewp_set_transp : typeclass_instances.

  Add Morphism pdrv_set : pdrv_set_m.
  Proof.
    induction x using set_induction;intros.
    normalize_notations.
    unfold pdrv_set.
    rewrite fold_1b;auto.
    rewrite H0 in H.
    rewrite fold_1b;auto.
    unfold pdrv_set.
    normalize_notations.
    rewrite H3.
    generalize(@fold_2 kat _ _ _ x1 x2 x3
               _ _ Equal_ST {}%set (fun x : kat => union (pdrv x x0 y1))
              (pdrv_set_proper x0 y1) (pdrv_set_transpose x0 y1) H H0);intros.
    assert(SetProperties.Add x3 x1 y).
    apply Add_Equal.
    apply Add_Equal in H0.
    rewrite <- H1.
    rewrite H0.
    reflexivity.
    generalize(@fold_2 kat _ _ _ x1 y x3
              _ _ Equal_ST {}%set (fun x : kat => union (pdrv x y0 y1))
              (pdrv_set_proper y0 y1) (pdrv_set_transpose y0 y1) H H5);intros.
    rewrite H6.
    rewrite H4.
    eapply union_m. apply pdrv_m;auto. inv H2. unfold _eq.
    apply ord_Eq_unique.
    assumption.
    apply IHx1.
    reflexivity.
    apply H2.
    reflexivity.
  Qed.

  Lemma true_ewp_set :
    forall s x a,
      x \In s -> ewp x a = true -> ewp_set s a = true.
  Proof.
    induction s using set_induction;intros.
    apply empty_is_empty_1 in H.
    rewrite H in H0.
    inversion H0.

    unfold ewp_set.
    apply H0 in H1.
    destruct H1.
    generalize (@fold_2 kat _ _ _ s1 s2 x _ (@eq bool) eq_equivalence
      false (fun y : kat => orb (ewp y a))
      (ewp_set_proper a) (ewp_set_transp a) H H0);intro.
    rewrite H3.
    rewrite H1.
    rewrite H2;simpl.
    reflexivity.

    generalize (@fold_2 kat _ _ _ s1 s2 x _ (@eq bool) eq_equivalence
      false (fun y : kat => orb (ewp y a))
      (ewp_set_proper a) (ewp_set_transp a) H H0);intro.
    rewrite H3.
    apply (IHs1 _ a H1) in H2.
    unfold ewp_set in H2.
    rewrite H2.
    rewrite Bool.orb_comm;simpl;reflexivity.
  Qed.

  Lemma ewp_set_true :
    forall s a,
      ewp_set s a = true -> exists x,( x \In s /\ ewp x a = true).
  Proof.
    induction s using set_induction;intros.
    unfold ewp_set in H0.
    rewrite fold_1b in H0;auto.
    inversion H0.

    unfold ewp_set in H1.
    generalize (@fold_2 kat _ _ _ s1 s2 x _ (@eq bool) eq_equivalence
      false (fun y : kat => orb (ewp y a))
      (ewp_set_proper a) (ewp_set_transp a) H H0);intro.
    rewrite H2 in H1;clear H2.
    assert (Bool.Is_true ((ewp x a)||( fold (fun y : kat => orb (ewp y a)) s1 false))).
    unfold Bool.Is_true.
    rewrite H1.
    trivial.
    apply Bool.orb_prop_elim in H2.
    unfold Bool.Is_true in H2.
    destruct H2.
    exists x.
    destruct(ewp x a).
    split.
    apply H0.
    left;reflexivity.
    reflexivity.
    elim H2.
    apply Bool.Is_true_eq_true in H2.
    apply IHs1 in H2.
    do 2 destruct H2.
    exists x0;split;auto.
    apply H0.
    right;auto.
  Qed.

  Open Scope set_scope.

  Lemma pdrv_set_singleton : forall r a s,
    (pdrv_set {r}%set a s)===(pdrv r a s).
  Proof.
    intros.
    unfold pdrv_set.
    generalize(@fold_2 kat _ _ _ {}%set {r}%set r
      _ _ Equal_ST {}%set (fun x : kat => union (pdrv x a s))
        (pdrv_set_proper a s) (pdrv_set_transpose a s));intros.
    assert(~r \In {}).
    intro.
    inversion H0.
    assert(SetProperties.Add r {} {r}).
    apply Add_Equal.
    vm_compute;auto.
    generalize(H H0 H1);clear H;intros.
    rewrite H;clear H.
    rewrite fold_1b.
    rewrite empty_union_2.
    reflexivity.
    vm_compute;intros.
    inversion x0.
    vm_compute;intros.
    inversion x0.
  Qed.

  Lemma pdrv_set_empty : forall a s,
    (pdrv_set {} a s)==={}.
  Proof.
    intros.
    unfold pdrv_set.
    rewrite fold_1b.
    reflexivity.
    vm_compute;intros.
    inversion x0.
  Qed.

  Lemma In_pdrv_set : forall s x a t,
    x \In (pdrv_set s a t) -> exists y, y \In s /\ x \In (pdrv y a t).
  Proof.
    induction s using set_induction;intros.
    apply empty_is_empty_1 in H.
    rewrite H in H0.
    rewrite pdrv_set_empty in H0.
    inversion H0.
    generalize(@fold_2 kat _ _ _ s1 s2 x _ _ Equal_ST {}%set _
      (pdrv_set_proper a t) (pdrv_set_transpose a t) H H0);intro.
    unfold pdrv_set in H1.
    rewrite H2 in H1.
    clear H2.
    apply union_iff in  H1.
    destruct H1.

    exists x.
    split.
    apply H0.
    left;auto.
    assumption.

    apply IHs1 in H1.
    do 2 destruct H1.
    exists x1.
    split.
    apply H0.
    right;auto.

    assumption.
  Qed.

  Lemma In_pdrv_in_pdrv_set : forall s x y a t,
    y \In (pdrv x a t) -> x \In s -> y \In (pdrv_set s a t).
  Proof.
    induction s using set_induction;intros.
    elim (H x);auto.

    generalize(@fold_2 kat _ _ _ s1 s2 x _ _ Equal_ST {}%set _
      (pdrv_set_proper a t) (pdrv_set_transpose a t) H H0);intro.
    fold (pdrv_set s2 a t) in H3.
    fold (pdrv_set s1 a t) in H3.
    rewrite H3.
    apply H0 in H2.
    destruct H2.

    rewrite H2.
    apply union_2;auto.
    generalize(IHs1 _ _ _ _ H1).
    intro.
    apply H4 in H2.
    apply union_3.
    assumption.
  Qed.

  (** Monotonicity of the set derivative w.r.t. a symbol [a] *)
  Lemma pdrv_contained : forall x y a t,
    x[<=]y -> (pdrv_set x a t)[<=](pdrv_set y a t).
  Proof.
    induction x using set_induction;intros.
    red;intros.
    apply empty_is_empty_1 in H.
    rewrite H in H1.
    rewrite pdrv_set_empty in H1.
    inversion H1.
    intros a0 H2.
    unfold pdrv_set in H2.
    apply((@fold_2 kat _ _ _ x1 x2 x3
      _ _ Equal_ST {}%set (fun x : kat => union (pdrv x a t)))) in H2;
    auto with typeclass_instances.
    apply union_1 in H2.
    destruct H2.
    eapply In_pdrv_in_pdrv_set.
    apply H2.
    apply H1.
    apply H0;auto.
    apply IHx1.
    red;intros.
    apply H1.
    apply H0;auto.
    apply H2.
  Qed.

  Hint Resolve
    pdrv_set_singleton
    pdrv_set_empty
    In_pdrv_set
    In_pdrv_in_pdrv_set : gl_hints.

  (** Operations on sets of partial derivatives *)
  Lemma pdrv_set_add : forall s x a t,
    (pdrv_set (add x s) a t)===((pdrv x a t)++(pdrv_set s a t)).
  Proof.
    induction s using set_induction;intros.
    generalize H;intro H1;apply empty_is_empty_1 in H1.
    rewrite H1.
    rewrite pdrv_set_empty;auto with sets.

    apply Add_Equal in H0.
    split;intros.
    rewrite H0 in H1.
    apply In_pdrv_set in H1.
    do 2 destruct H1.
    apply add_iff in H1.
    destruct H1.
    rewrite H1.
    apply union_2;auto.
    apply add_iff in H1.
    destruct H1.
    apply union_3.
    rewrite H0.
    apply IHs1.
    apply union_2.
    rewrite H1.
    assumption.
    rewrite H0.
    apply union_3.
    rewrite IHs1.
    apply union_3.
    apply In_pdrv_in_pdrv_set with x1;auto.

    apply union_1 in H1.
    destruct H1.
    eapply In_pdrv_in_pdrv_set.
    apply H1.
    apply add_1.
    reflexivity.

    apply In_pdrv_set in H1.
    do 2 destruct H1.
    eapply In_pdrv_in_pdrv_set.
    apply H2.
    apply add_2.
    assumption.
  Qed.

  Lemma pdrv_set_union : forall s1 s2 a t,
    (pdrv_set (s1++s2) a t)===((pdrv_set s1 a t)++(pdrv_set s2 a t)).
  Proof.
    induction s1 using set_induction;intros.
    apply empty_is_empty_1 in H.
    rewrite H.
    rewrite pdrv_set_empty.
    rewrite empty_union_1.
    rewrite empty_union_1.
    reflexivity.

    vm_compute;intros.
    inversion x0.

    vm_compute;intros.
    inversion x0.

    split;intros.
    apply In_pdrv_set in H1.
    do 2 destruct H1.
    apply union_1 in H1.
    destruct H1.
    apply Add_Equal in H0.
    rewrite H0 in H1.
    rewrite add_union_singleton in H1.
    apply union_1 in H1.
    destruct H1.
    apply singleton_1 in H1.
    rewrite H0.
    rewrite pdrv_set_add.
    apply union_2.
    apply union_2.
    rewrite H1;auto.

    generalize(In_pdrv_in_pdrv_set _ _ _ _ _ H2 H1);intro.
    rewrite H0.
    rewrite pdrv_set_add.
    apply union_2.
    apply union_3.
    auto.
    generalize(In_pdrv_in_pdrv_set _ _ _ _ _ H2 H1);intro.
    apply union_3;auto.
    apply union_1 in H1.
    apply Add_Equal in H0.
    destruct H1.
    rewrite H0 in H1.
    rewrite pdrv_set_add in H1.
    apply union_1 in H1;destruct H1.
    rewrite H0.
    rewrite union_add.
    rewrite pdrv_set_add.
    apply union_2;auto.

    rewrite H0.
    rewrite union_add.
    rewrite pdrv_set_add.
    apply union_3.
    rewrite IHs1_1.
    apply union_2;auto.
    rewrite H0.
    rewrite union_add.
    rewrite pdrv_set_add.
    apply union_3.
    rewrite IHs1_1.
    apply union_3;auto.
  Qed.

  Fixpoint PI (r:kat) : set kat :=
    match r with
      | katb b => {}
      | kats _ => {katb ba1}
      | katu x y  => (PI x)++(PI y)
      | katc x y  => ((PI x)[.]y)++(PI y)
      | katst x   => (PI x)[.](katst x)
    end.

  Functional Scheme PI_ind := Induction for PI Sort Prop.
  Functional Scheme PI_rec := Induction for PI Sort Set.

  Add Morphism PI : PI_m.
  Proof.
    intro x.
    functional induction (PI x);
      intros;normalize_notations;inversion_clear H;simpl;auto;
      try (apply leibniz_test in H0;subst;auto).
  Qed.

  Lemma in_pdrv_0 : ~exists y, y \In (PI (katb ba0)).
  Proof.
    intro H.
    destruct H as [y Nin].
    simpl in Nin.
    inversion Nin.
  Qed.

  Lemma in_pdrv_1 : ~exists y, y \In (PI (katb ba1)).
  Proof.
    intro H;simpl in H.
    destruct H as [y Nin].
    inversion Nin.
  Qed.

  Lemma in_pdrv_sy : forall y s, y \In (PI (kats s)) -> y === (katb ba1).
  Proof.
    intros.
    simpl in H.
    apply singleton_1 in H.
    symmetry;auto.
  Qed.

  Lemma in_pdrv_union :
    forall x y z,
      x \In (PI (katu y z)) ->
      x \In (PI y) \/ x \In (PI z).
  Proof.
    intros.
    simpl in H.
    apply union_1 in H.
    assumption.
  Qed.

  Lemma in_pdrv_conc :
    forall x y z,
      Not_0_1 z -> x \In (PI (katc y  z)) ->
      x \In (PI z) \/ exists y', x === katc y' z /\ y' \In (PI y).
  Proof.
    intros.
    simpl in H0.
    apply union_iff in H0.
    destruct H0.
    apply in_dsr in H0.
    destruct H0 as [y' [H11 H12]].
    right.
    exists y'.
    intuition.
    assumption.
    simpl in H0.
    left;assumption.
  Qed.

  Lemma in_pdrv_star :
    forall x y,
      x \In (PI (katst y)) -> exists y', x === katc y' (katst y) /\ y' \In (PI y).
  Proof.
    intros.
    simpl in H.
    apply in_dsr_re_star in H.
    destruct H as [y' [H11 H12]].
    exists y'.
    intuition.
  Qed.

  (** Transitivity of the PI function *)
  Lemma PI_trans :
    forall x y,
      y \In (PI x) -> forall z, z \In (PI y) -> z \In (PI x).
  Proof.
    induction x;simpl;intros.
    apply singleton_1 in H.
    rewrite <- H in H0.
    simpl in H0.
    inversion H0.
    inversion H.

    apply union_1 in H.
    destruct H.
    generalize(IHx1 _ H _ H0);intro.
    apply union_2;auto.
    generalize(IHx2 _ H _ H0);intro.
    apply union_3;auto.

    destruct (dsr_cases (PI x1) x2).
    rewrite H1 in H.
    apply union_iff in H.
    destruct H.
    inversion H.
    apply union_3.
    eapply IHx2.
    apply H;auto.
    assumption.

    destruct H1.
    rewrite H1 in H |- *.
    apply union_iff in H.
    destruct H;[apply union_2|apply union_3].
    eapply IHx1.
    apply H.
    assumption.
    eapply IHx2.
    apply H.
    assumption.
    destruct H1.
    apply union_1 in H.
    destruct H.
    apply (in_dsr (PI x1) x2 y) in H;auto.
    do 2 destruct H.
    rewrite H3 in H0.
    simpl in H0.
    apply union_1 in H0.
    destruct H0.
    apply union_2.
    apply (in_dsr (PI x) x2 z) in H0;auto.
    do 2 destruct H0.
    rewrite H4.
    rewrite H2.
    apply elem_conc_in_fold_conc.
    eapply IHx1.
    apply H.
    assumption.
    apply union_3.
    assumption.
    apply union_3.
    eapply IHx2.
    apply H.
    apply H0.
    (* kleene's star *)
    apply elem_conc_in_ex in H.
    do 2 destruct H.
    rewrite H1 in H0.
    simpl in H0.
    apply union_1 in H0.
    destruct H0.
    apply elem_conc_in_ex in H0.
    do 2 destruct 0.
    rewrite H2.
    apply elem_conc_in_fold_conc;auto.
    eapply IHx.
    apply H.
    assumption.
    assumption.
  Qed.

  Definition PD(r:kat) := {r}%set++(PI r).

  Fixpoint sylen (r:kat) : nat :=
    (match r with
      | kats _ => 1
      | katb _ => 0
      | katu x y => sylen x + sylen y
      | katc x y => sylen x + sylen y
      | katst x => sylen x
    end)%nat.

  Lemma PI_upper_bound : forall r, (cardinal (PI r)) <= (sylen r).
  Proof.
    induction r;simpl;auto.
    rewrite union_cardinal_inter.
    abstract omega.
    rewrite union_cardinal_inter.
    generalize(dsr_cardinal (PI r1) r2).
    intro.
    abstract omega.
    rewrite fold_conc_card.
    assumption.
  Qed.

  Theorem PD_upper_bound : forall r, (cardinal (PD r)) <= (S (sylen r)).
  Proof.
    unfold PD.
    intros.
    generalize(PI_upper_bound r);intro H.
    rewrite union_cardinal_inter.
    rewrite singleton_cardinal.
    unfold plus.
    abstract omega.
  Qed.

  Theorem all_pdrv_in_PI : forall x a r, (pdrv x a r)[<=](PI x).
  Proof.
    induction x;unfold Subset;simpl;intros.
    case_eq(compare z r);intros;
    rewrite H0 in H.
    assumption.
    inversion H.
    inversion H.
    assumption.

    apply union_1 in H.
    destruct H.
    apply union_2.
    apply (IHx1 a r);assumption.
    apply union_3.
    apply (IHx2 a r).
    assumption.

    destruct(ewp x1 a).
    apply union_1 in H.
    destruct H.
    generalize(dsr_cases (pdrv x1 a r) x2);intro.
    destruct H0 as [H11 | [ H12 | H13]].
    rewrite H11 in H.
    inversion H.

    destruct(eq_dec x2 (katb ba0)).
    rewrite H0 in H.
    simpl in H.
    inversion H.
    destruct(eq_dec x2 (katb ba1)).
    rewrite H1 in H |- *.
    simpl in *.
    apply IHx1 in H.
    apply union_2;auto.
    apply in_dsr in H;auto.
    destruct H as [y' [H11 H13]].
    rewrite H13.
    apply union_2.
    apply elem_conc_dsr_in;auto.
    eapply IHx1.
    apply H11.
    destruct H13.
    apply in_dsr in H;auto.
    destruct H as [y' [H11 H12]].
    rewrite H12.
    apply union_2.
    apply elem_conc_dsr_in;auto.
    eapply IHx1.
    apply H11.
    apply union_3.
    eapply IHx2.
    apply H.

    destruct(eq_dec x2 (katb ba0)).
    rewrite H0 in H.
    simpl in H.
    inversion H.
    destruct(eq_dec x2 (katb ba1)).
    rewrite H1 in H |- *.
    simpl in *.
    apply union_2.
    apply (IHx1 _ _ _ H).
    apply in_dsr in H;auto.
    destruct H as [y' [H11 H12]].
    rewrite H12.
    apply union_2.
    apply elem_conc_dsr_in;auto.
    apply (IHx1 _ _ _ H11).

    apply elem_conc_in_ex in H.
    destruct H as [y [H11 H12]].
    rewrite H12.
    apply elem_conc_in_fold_conc.
    eapply IHx.
    apply H11.
  Qed.

  Lemma PD_trans :
    forall x y,
      y \In (PD x) -> forall z, z \In (PD y) -> z \In (PD x).
  Proof.
    intros.
    unfold PD in *.
    apply union_1 in H0;destruct H0.
    apply singleton_1 in H0;subst;auto.
    apply union_1 in H;destruct H.
    apply union_2.
    rewrite <- H0.
    assumption.

    apply union_3.
    rewrite <- H0.
    assumption.

    apply union_1 in H.
    destruct H.
    apply singleton_1 in H.
    apply (PI_m x y) in H.
    apply H in H0.
    apply union_3;auto.

    apply union_3.
    eapply PI_trans.
    apply H.
    assumption.
  Qed.

  (** Derivation by a guarded string. *)
  Reserved Notation "x %dw y" (at level 60).
  Fixpoint pdrv_iw (sre:set kat)(w:ilist) : set kat :=
    match w with
      | <[] => sre
      | xs <:: x => pdrv_set (sre %dw xs) (fst x) (snd x)
    end
    where "x %dw y" := (pdrv_iw x y).

  Functional Scheme pdrv_iw_ind := Induction for pdrv_iw Sort Prop.
  Functional Scheme pdrv_iw_rec := Induction for pdrv_iw Sort Set.

(** Simple/base properties *)
  Lemma pdrv_iw_sy_icons : forall w r s,
    (s %dw (w <:: r))=== (pdrv_set (s %dw w) (fst r) (snd r)).
  Proof.
    induction w;simpl;split;intros;
      try assumption.
  Qed.

  Lemma pdrv_iw_sy_nil : forall s,
    (s %dw <[])===s.
  Proof.
    simpl.
    reflexivity.
  Qed.

  Lemma pdrv_iw_empty : forall w,
    ({} %dw w)==={}%set.
  Proof.
    induction w;simpl.
    reflexivity.
    split;intros.
    rewrite IHw in H.
    rewrite pdrv_set_empty in H.
    assumption.
    inversion H.
  Qed.

  Add Morphism pdrv_iw : pdrv_iw_m.
  Proof.
    intros.
    apply ilist_eq_leibniz in H0.
    rewrite H0.
    revert x y H.
    clear H0.
    revert y0.
    induction y0.
    simpl;intros.
    assumption.
    intros.
    do 2 rewrite pdrv_iw_sy_icons.
    generalize H;intro.
    apply IHy0 in H0.
    rewrite H0.
    reflexivity.
  Qed.

  (** wprdv expansion by concatenation of two words *)
  Lemma pdrv_iw_app : forall w w' s,
    (s %dw (w <++ w'))===(pdrv_iw (s %dw w) w').
  Proof.
    intros w w';revert w' w.
    induction w';simpl;intros.
    reflexivity.
    rewrite IHw'.
    reflexivity.
  Qed.

  Lemma pdrv_iw_union : forall w s1 s2,
    ((s1++s2) %dw w)===((s1 %dw w)++(s2 %dw w)).
  Proof.
    induction w;simpl.
    reflexivity.
    intros.
    split;intros.
    rewrite IHw in H.
    rewrite <- pdrv_set_union.
    assumption.
    rewrite IHw.
    rewrite <- pdrv_set_union in H.
    auto.
  Qed.

  (** Existance of elements *)
  Lemma in_pdrv_iw_pdrv : forall s w x,
    x \In (s %dw w) -> exists y, y \In s /\ x \In ({y}%set %dw  w).
  Proof.
    induction s using set_induction;simpl;intros.
    apply empty_is_empty_1 in H.
    rewrite H in H0.
    rewrite pdrv_iw_empty in H0.
    inversion H0.

    apply Add_Equal in H0.
    rewrite H0 in H1.
    rewrite add_union_singleton in H1.
    rewrite pdrv_iw_union in H1.
    eapply union_1 in H1.
    destruct H1.
    exists x.
    split;auto.
    rewrite H0.
    apply add_1.
    reflexivity.
    apply IHs1 in H1.
    destruct H1 as [y [H2 H3]].
    exists y.
    split;auto.
    rewrite H0.
    apply add_2.
    assumption.
  Qed.

  Lemma iw_pdrv_in_pdrv : forall w s x y,
     y \In s ->  x \In ({y}%set %dw  w) -> x \In (s %dw w).
  Proof.
    induction w ;simpl;intros.
    apply singleton_1 in H0;subst;auto.
    rewrite <- H0.
    assumption.

    apply In_pdrv_set in H0.
    do 2 destruct H0.
    apply IHw with (x:=x0) in H;auto.
    eapply In_pdrv_in_pdrv_set.
    apply H1.
    assumption.
  Qed.

  Lemma pdrv_set_comp : forall s x a0 a1,
    x \In (pdrv_set (pdrv_set s (fst a1) (snd a1)) (fst a0) (snd a0)) ->
    x \In (s %dw ((<[]<::a1)<::a0)).
  Proof.
    intros.
    simpl.
    assumption.
  Qed.

  (** Finally, the definition [wpdrv] uses [pdrv_iw] but first transforms an [ilist] into its corresponding [word] type. *)

  Definition wpdrv (r:kat)(w:list AtSy) :=
    pdrv_iw ({r}%set) (list_to_ilist w).
  Notation "x %dW y" := (wpdrv x y)(at level 60).

  (** Derivation of a single regular expression by a word *)
  Definition wpdrv_set (s:set kat)(w:list AtSy) :=
    s %dw (<@ w).

  Notation "x %dWS y" := (wpdrv_set x y)(at level 60).

  Add Morphism wpdrv with signature _eq ==> _eq ==> Equal as wpdrv_m.
  Proof.
    induction 2.
    normalize_notations.
    unfold wpdrv.
    simpl.
    rewrite H.
    reflexivity.
    unfold wpdrv.
    simpl.
    do 2 rewrite pdrv_iw_app.
    apply pdrv_iw_m.
    split;intros;
    normalize_notations.
    apply  in_pdrv_iw_pdrv in H2.
    destruct H2 as [y' [H11 H12]].
    eapply iw_pdrv_in_pdrv with y'.
    rewrite <- H.
    assumption.
    rewrite <- H0.
    assumption.
    rewrite H.
    rewrite H0.
    assumption.
    normalize_notations.
    induction H1.
    simpl.
    reflexivity.
    normalize_notations.
    destruct a0.
    destruct a'0.
    inversion_clear H1.
    rewrite H4.
    inv H3.
    simpl.
    rewrite H2.
    reflexivity.
  Qed.

  Add Morphism wpdrv_set with signature Equal ==> _eq ==> Equal as wpdrv_set_m.
  Proof.
    unfold wpdrv_set.
    intuition.
    normalize_notations.
    rewrite H.
    rewrite H0.
    reflexivity.
  Qed.

  Add Morphism wpdrv_set with signature Subset ++> _eq  ++> Subset
    as wpdrv_set_subset.
  Proof.
    induction 2;simpl.
    unfold wpdrv_set in *;simpl.
    assumption.

    red;intros.
    normalize_notations.
    apply in_pdrv_iw_pdrv in H2.
    do 2 destruct H2.
    eapply iw_pdrv_in_pdrv.
    apply H in H2.
    apply H2.
    simpl in *.
    rewrite H0 in H3.
    rewrite H1 in H3.
    assumption.
  Qed.

  Lemma wpdrv_nil : forall r,
    (r %dW nil)==={r}%set.
  Proof.
    intro.
    unfold wpdrv;simpl.
    reflexivity.
  Qed.

  Lemma wpdrv_set_nil : forall s,
    (s %dWS nil)===s.
  Proof.
    intros.
    unfold wpdrv_set.
    simpl.
    reflexivity.
  Qed.

  Lemma wpdrv_set_singleton : forall s w,
    {s}%set %dWS w === s %dW w.
  Proof.
    induction w;simpl.
    rewrite wpdrv_set_nil.
    rewrite wpdrv_nil.
    reflexivity.
    unfold wpdrv_set;simpl.
    rewrite  pdrv_iw_app.
    simpl.
    rewrite pdrv_set_singleton.
    unfold wpdrv;simpl.
    rewrite pdrv_iw_app.
    simpl.
    rewrite pdrv_set_singleton.
    reflexivity.
  Qed.

  Lemma wpdrv_set_empty : forall w,
    ({} %dWS w)==={}%set.
  Proof.
    intro.
    unfold wpdrv_set.
    rewrite pdrv_iw_empty.
    reflexivity.
  Qed.

  Lemma wpdrv_sy_nil : forall r x,
    (r %dW (x::nil))===(pdrv_set {r}%set (fst x) (snd x)).
  Proof.
    intros.
    unfold wpdrv;simpl.
    reflexivity.
  Qed.

  Lemma wpdrv_cons : forall r x w,
      (r %dW (w++(x::nil)))===((r %dW w) %dWS (x::nil)).
  Proof.
    intros.
    unfold wpdrv,wpdrv_set.
    destruct(exListFromIlist (w)).
    rewrite IlistFromListConc.
    rewrite <- H.
    revert x0 H r.
    induction x0;simpl;intros.
    reflexivity.
    reflexivity.
  Qed.

  Lemma wpdrv_set_app : forall s w1 w2,
    (s %dWS (w1++w2)) === ((s %dWS w1) %dWS w2).
  Proof.
    induction w1;simpl;intros.
    rewrite wpdrv_set_nil;auto.
    unfold wpdrv_set;simpl.
    repeat rewrite pdrv_iw_app.
    unfold wpdrv_set in IHw1.
    rewrite IlistFromListConc.
    rewrite pdrv_iw_app.
    reflexivity.
  Qed.

  Lemma wpdrv_set_eq_prv_set_case : forall s a,
    (pdrv_set s (fst a) (snd a))===(s %dWS (a::nil)).
  Proof.
    intros.
    unfold wpdrv_set.
    simpl.
    reflexivity.
  Qed.

  Lemma wpdrv_app : forall r w w',
    (r %dW (w++w'))===((r %dW w) %dWS w').
  Proof.
    intros.
    unfold wpdrv,wpdrv_set.
    destruct(exListFromIlist (w')).
    rewrite IlistFromListConc.
    rewrite <- H.
    revert  x r w w' H.
    induction x;simpl;intros.
    reflexivity.
    rewrite <-  pdrv_iw_app.
    reflexivity.
  Qed.

  (** * Partial derivatives w.r.t words belong to PD *)
  Lemma all_wpdrv_in_PD : forall w x r, x \In ({r}%set %dw w) -> x \In PD(r).
  Proof.
    induction w.
    simpl.
    unfold PD;intros.
    apply union_2;auto.

    simpl;intros.
    eapply In_pdrv_set in H.
    do 2 destruct H.
    apply IHw in H.
    unfold PD.
    unfold PD in H.
    apply union_1 in H.
    destruct H.
    apply singleton_1 in H.
    subst.
    apply all_pdrv_in_PI in H0.
    apply union_3.
    apply(PI_m _ _ H) in H0;auto.

    apply all_pdrv_in_PI in H0.
    apply union_3.
    eapply PI_trans.
    apply H.
    assumption.
  Qed.

  Lemma SL_conc :
      forall (l1 l2:kat) a s,
      if ewp l1 a then
        LQ (gl_conc l1 l2) a s == gl_union (gl_conc (LQ l1 a s) l2) (LQ l2 a s)
        else
          LQ (gl_conc l1 l2) a s == (gl_conc (LQ l1 a s) l2).
  Proof.
    intros.
    destruct(ewp_dec l1 a) as [H1|H1];rewrite H1.
    split;red;intros.
    inv H.
    subst.
    inv H0.
    apply blop in H2.
    destruct H2 as [H2|H2].
    destruct H2 as [x' [t' [H2 H5]]].
    rewrite <- H5.
    constructor.
    constructor.
    rewrite <- H2 ; auto.
    assumption.
    destruct H2.
    apply ewp_cases_epsilon_false in H1.
    rewrite <- H2 in H1.
    contradiction.
    inv H.
    inv H0.
    inv H3.
    subst.
    constructor.
    pose proof fusion_prod_gs_generic_inv a s x0 y T.
    destruct H3.
    rewrite H3.
    constructor.
    inv H0.
    assumption.

    split;red;intros.
    inv H.
    inv H0.
    subst.
    apply blop in H5.
    destruct H5.
    destruct H2.
    destruct H2.
    destruct H2.
    subst.
    left.
    constructor;auto.
    constructor;auto.
    destruct H2.
    subst.
    right.
    constructor.
    assumption.
    inv H.
    inv H0.
    subst.
    constructor.
    pose proof fusion_prod_gs_generic_inv a s x1 y T.
    destruct H2.
    rewrite H2.
    constructor.
    inv H3.
    assumption.
    constructor.
    inv H0.
    subst.
    change(gs_conc a s x) with (fusion_prod (gs_end a) (gs_conc a s x) (refl_equal a)).
    constructor.
    apply ewp_cases_epsilon_true in H1.
    assumption.
    assumption.
  Qed.

  Lemma LQ_star_l :
    forall (l:kat)  a s,
      LQ (gl_star (kat2gl l)) a s == gl_conc (LQ l a s) (gl_star l).
  Proof.
    intros.
    split;red;intros.
    inv H.
    subst.
    inv H0.
    subst.
    revert n H1.
    induction n;intros.
    simpl in H1.
    inv H1.
    simpl in H1.
    inversion H1.
    apply blop in H2.
    destruct H2.
    destruct H2.
    destruct H2.
    destruct H2.
    rewrite <- H5.
    constructor.
    constructor.
    rewrite <- H2;auto.
    econstructor 1 with n.
    assumption.
    destruct H2.
    rewrite H5 in H4.
    apply IHn in H4.
    assumption.

    constructor.
    inv H.
    subst.
    inv H1.
    subst.
    inv H1.
    subst.
    constructor 1 with (S n).
    simpl.
    pose proof fusion_prod_gs_generic_inv a s x0 y T.
    destruct H4.
    rewrite H4.
    constructor;auto.
    inv H0.
  Qed.

  Theorem pdrv_correct :
    forall a s r,
      SkatL (pdrv r a s) == LQ (kat2gl r) a s.
  Proof.
    induction r;simpl;intros.

    case_eq(compare z s);intros.
    normalize_notations.
    apply compare_2 in H.
    inv H.
    subst.
    rewrite(LQ_SyL_eq a _ _ H).
    rewrite SkatL_singleton.
    autorewrite with gl_rw.
    reflexivity.
    apply compare_1 in H.
    apply lt_not_eq in H.
    rewrite(LQ_SyL_neq a _ _ H).
    rewrite SkatL_empty.
    reflexivity.
    apply compare_3 in H.
    apply lt_not_eq in H.
    symmetry in H.
    rewrite(LQ_SyL_neq a _ _ H).
    rewrite SkatL_empty.
    reflexivity.

    rewrite LQ_Test.
    rewrite SkatL_empty.
    reflexivity.

    rewrite LQ_union.
    rewrite SkatL_union.
    rewrite IHr1,IHr2.
    reflexivity.

    case_eq(ewp r1 a);intros.
    rewrite SkatL_union.
    rewrite SkatL_dsr.
    rewrite IHr1.
    rewrite IHr2.
    symmetry.
    pose proof H.
    apply ewp_cases_epsilon_true in H0.
    pose proof SL_conc r1 r2 a s.
    rewrite H in H1.
    assumption.
    pose proof SL_conc r1 r2 a s.
    rewrite H in H0.
    rewrite SkatL_dsr.
    rewrite IHr1.
    symmetry.
    assumption.

    rewrite LQ_star_l.
    rewrite SkatL_fconc.
    rewrite IHr.
    reflexivity.
  Qed.

  Lemma LangOfPdrvSet :
    forall s a x,
      L[pdrv_set s a x] == LQ L[s] a x.
  Proof.
    induction s using set_induction;simpl;intros.
    apply empty_is_empty_1 in H.
    rewrite H.
    rewrite pdrv_set_empty.
    gl_goal.
    inversion H0.
    inversion H1.
    inversion_clear H0.
    apply SkatL_empty in H1.
    inversion H1.
    apply Add_Equal in H0.
    rewrite H0.
    rewrite add_union_singleton.
    rewrite pdrv_set_union.
    do 2 rewrite SkatL_union.
    rewrite LQ_union.
    rewrite pdrv_set_singleton.
    rewrite pdrv_correct.
    rewrite SkatL_singleton.
    rewrite IHs1.
    reflexivity.
  Qed.

  Lemma SkatL_dsr_re0 : forall s, L[s[.](katb ba0)] == L[{}%set].
  Proof.
    intro.
    simpl.
    reflexivity.
  Qed.

  Lemma Skat_dsr_re1 : forall s, L[s[.](katb ba1)] == L[s].
  Proof.
    intro.
    simpl.
    reflexivity.
  Qed.

  Lemma LQw_single : forall (r:kat) a s,
    LQw_alt (kat2gl r) ((a,s)::nil) == LQ (kat2gl r) a s.
  Proof.
    intros.
    apply LQw_alt_eq_LQ.
  Qed.

  Lemma LQw_split_app :
    forall w1 w2 r,
      LQw_alt (kat2gl r) (w1 ++ w2) == LQw_alt (LQw_alt r w1) (w2).
  Proof.
    induction w1;simpl.
    intros.
    gl_goal.
    inv H;subst.
    constructor.
    constructor.
    simpl.
    assumption.
    inv H;subst.
    inv H0;subst.
    simpl in H1.
    constructor.
    assumption.

    intros;simpl.
    gl_goal.
    inv H.
    subst.
    constructor.
    constructor.
    simpl.
    simpl in H0.
    rewrite to_gstring_app in H0.
    assumption.

    inv H.
    subst.
    inv H0.
    subst.
    constructor.
    rewrite app_comm_cons.
    simpl.
    simpl in H1.
    rewrite to_gstring_app.
    assumption.
  Qed.

  Lemma LQw_alt_split_app :
    forall w1 w2 r,
      LQw_alt r (app w1 w2) == LQw_alt (LQw_alt r w1) w2.
  Proof.
    induction w1;simpl;intros.
    gl_goal.
    repeat constructor.
    destruct H.
    simpl;auto.

    inversion H.
    subst;simpl in *.
    inversion H0.
    subst.
    constructor;simpl in *.
    assumption.

    gl_goal.
    inversion H.
    subst.
    constructor.
    constructor.
    simpl in *.
    rewrite <- to_gstring_app.
    auto.

    inversion H;simpl in *;subst.
    inversion H0;subst.
    constructor.
    simpl in *.
    rewrite to_gstring_app.
    assumption.
  Qed.

  (* Lemma SkatL_iw_pdrv_app : *)
  (*   forall w r a, *)
  (*     SkatL ({r}%set %dw ((<[] <:: a) <++ <@ w)) == *)
  (*           LQw_alt (SkatL ({r}%set %dw ((<[] <:: a)))) (w). *)
  (* Proof. *)
  (*   induction w;intros. *)
  (*   simpl;gl_goal. *)
  (*   inv H;subst. *)
  (*   constructor. *)
  (*   simpl. *)
  (*   econstructor 1 with r0;auto. *)
  (*   inv H. *)
  (*   inv H0. *)
  (*   subst. *)
  (*   constructor 1 with r0;auto. *)

  (*   admit. *)
  (* Qed. *)

  Lemma Lqw_Lq_app : forall w (r:kat) a s,
    LQw_alt r (@>((inil<::(a,s))<++w)) == LQw_alt (LQ r a s) (@>w).
  Proof.
    induction w;simpl;intros.
    gl_goal.
    inversion H.
    subst.
    simpl in H0.
    constructor.
    constructor.
    simpl.
    auto.
    constructor.
    simpl.
    inversion H;subst.
    inversion H0;subst.
    simpl in H1.
    assumption.

    rewrite LQw_split_app.
    rewrite IHw.
    gl_goal.
    inv H.
    subst.
    constructor.
    simpl.
    inv H0.
    subst.
    rewrite to_gstring_app.
    assumption.
    inv H.
    subst.
    inv H0.
    subst.
    constructor.
    constructor.
    constructor.
    rewrite <- to_gstring_app.
    assumption.
  Qed.

  Lemma wpdrv_corr :
    forall w r,
      SkatL (pdrv_iw r w) == LQw_alt (SkatL r) (@>w).
  Proof.
    induction w;simpl;intros.
    rewrite LQw_alt_nil.
    reflexivity.

    rewrite LQw_alt_split_app.
    rewrite LangOfPdrvSet.
    gl_goal.
    inv H;subst.
    apply IHw in H0.
    constructor.
    simpl.
    assumption.

    inv H.
    subst.
    apply IHw in H0.
    constructor.
    simpl in H0.
    assumption.
  Qed.

  Theorem wpdrv_correct :
    forall w r,
      SkatL (wpdrv r w) == LQw_alt (kat2gl r) w.
  Proof.
    intros.
    unfold wpdrv.
    rewrite wpdrv_corr.
    rewrite ListFromIlist.
    rewrite SkatL_singleton.
    reflexivity.
  Qed.

  Instance ewp_set_m : Proper (_eq ==> _eq ==> _eq) ewp_set.
  Proof.
    repeat red.
    induction x using set_induction;intros.
    unfold ewp_set.
    apply empty_is_empty_1 in H.
    rewrite H in H0.
    assert(y[=]{}).
    rewrite <- H0.
    reflexivity.
    apply empty_is_empty_2 in H.
    apply empty_is_empty_2 in H2.
    rewrite fold_1b;auto.
    rewrite fold_1b;auto.
    unfold ewp_set.
    rewrite fold_2;eauto with typeclass_instances.
    fold(ewp_set x1 x).
    assert(SetProperties.Add x3 x1 y).
    apply Add_Equal.
    rewrite <- H1.
    apply Add_Equal.
    assumption.
    rewrite fold_2;eauto with typeclass_instances.
    fold(ewp_set x1 y0).
    inv H2.
  Qed.

  Lemma ewp_of_re_set_singleton : forall s a,
      ewp_set {s}%set a = ewp s a.
    Proof.
      intros.
      unfold ewp_set.
      rewrite (@fold_2 kat _ _ _ {} {s} s bool);eauto with typeclass_instances.
      rewrite fold_1b;eauto with typeclass_instances.
      rewrite Bool.orb_comm.
      simpl.
      reflexivity.
      intro.
      inv H.
      red;intros.
      split;intros.
      apply singleton_1 in H;auto.
      destruct H.
      apply singleton_2;auto.
      inv H.
    Qed.

    Lemma gs_end_aux :
      forall w a0,
        (gs_end (last (to_gstring w (gs_end a0)))) = gs_end a0.
    Proof.
      induction w;simpl;intros.
      reflexivity.
      rewrite IHw.
      reflexivity.
    Qed.

    Lemma gs_in_pdrv :
      forall w (r:kat) a,
        In _ (kat2gl r) ((to_gstring w) (gs_end a)) -> ewp_set (wpdrv r w) a = true.
    Proof.
      induction w;simpl.
      intros.
      unfold wpdrv;simpl.
      unfold ewp_set;simpl.
      replace (fold (fun x : kat => orb (ewp x a)) {r} false) with ((ewp r a) || false).
      apply ewp_cases_epsilon_true_inv in H.
      rewrite H;auto.
      fold (ewp_set {r} a).
      rewrite ewp_of_re_set_singleton.
      apply ewp_cases_epsilon_true_inv in H.
      rewrite H.
      simpl.
      reflexivity.

      intros.
      simpl in H.
      apply w_in_gl_eq_last_in_LQw in H.
      simpl in H.
      apply wpdrv_correct in H.
      inversion_clear H.
      apply true_ewp_set with (x:=r0).
      rewrite <- surjective_pairing in H0.
      assert(forall z, from_gstring (to_gstring z (gs_end a0)) = z).
      induction z.
      simpl.
      reflexivity.
      simpl.
      rewrite IHz;auto.
      rewrite <- surjective_pairing.
      reflexivity.
      rewrite (H w) in H0.
      assumption.
      apply ewp_cases_epsilon_true_inv.
      simpl in H1.
      rewrite gs_end_aux in H1.
      assumption.
    Qed.

    Lemma gs_in_pdrv_true :
      forall w (r:kat) a,
        ewp_set (wpdrv r w) a = true -> In _ (kat2gl r) ((to_gstring w) (gs_end a)).
    Proof.
      induction w;simpl;intros.
      unfold wpdrv in H;simpl in H.
      apply ewp_set_true in H.
      do 2 destruct H.
      apply singleton_1 in H.
      apply ewp_cases_epsilon_true in H0.
      inv H.

      apply last_in_LQw_eq_w_in_gl.
      eapply wpdrv_correct.
      apply ewp_set_true in H.
      do 2 destruct H.
      econstructor 1 with x.
      simpl.
      rewrite <- surjective_pairing.
      assert(forall z, from_gstring (to_gstring z (gs_end a0)) = z).
      induction z.
      simpl.
      reflexivity.
      simpl.
      rewrite IHz;auto.
      rewrite <- surjective_pairing.
      reflexivity.
      rewrite (H1 w).
      assumption.
      apply ewp_cases_epsilon_true in H0.
      simpl.
      rewrite gs_end_aux.
      assumption.
    Qed.

    Lemma gs_not_in_pdrv :
      forall w (r:kat) a,
        ~In _ (kat2gl r) ((to_gstring w) (gs_end a)) -> ewp_set (wpdrv r w) a = false.
    Proof.
      intros.
      apply Bool.not_true_is_false.
      intro.
      apply H.
      apply gs_in_pdrv_true;auto.
    Qed.

    Lemma gs_not_in_pdrv_true :
      forall w (r:kat) a,
        ewp_set (wpdrv r w) a = false ->  ~In _ (kat2gl r) ((to_gstring w) (gs_end a)).
    Proof.
      intros.
      intro.
      apply  gs_in_pdrv in H0.
      rewrite H in H0.
      discriminate.
    Qed.

    Lemma ewp_set_fails_imp_gl_eq_false :
      forall w r1 r2 a,
        ewp_set (wpdrv r1 w) a <> ewp_set (wpdrv r2 w) a ->
        ~(r1 == r2).
    Proof.
      intros.
      case_eq(ewp_set (r1 %dW w) a);
        case_eq(ewp_set (r2 %dW w) a);intros.
      rewrite H0,H1 in H;elim H;auto.
      apply gs_not_in_pdrv_true in H0.
      apply gs_in_pdrv_true in H1.
      intro.
      apply H2 in H1.
      contradiction.
      apply gs_in_pdrv_true in H0.
      apply gs_not_in_pdrv_true in H1.
      intro.
      apply H2 in H0.
      contradiction.
      rewrite H0,H1 in H;elim H;auto.
    Qed.

    Lemma ewp_set_singleton :
      forall r a,
        ewp_set {r} a = ewp r a.
    Proof.
      intros.
      unfold ewp_set.
      pose proof @fold_2 kat _ _ _ {} {r} r bool _ _ false (fun x : kat => orb (ewp x a)).
      rewrite H;auto with typeclass_instances.
      clear H.
      case_eq(ewp r a);intros.
      simpl.
      reflexivity.
      simpl.
      rewrite fold_1b;auto.
      red;intros.
      intro.
      inversion H0.
      intro.
      inversion H0.
      red.
      intros.
      split;intros.
      apply singleton_1 in H0.
      left;auto.
      destruct H0.
      rewrite H0.
      apply singleton_2;auto.
      inv H0.
    Qed.

  Lemma all_ewp_set_tru_gl_eq_true :
    forall r1 r2,
      (forall w a,
         ewp_set (wpdrv r1 w) a = ewp_set (wpdrv r2 w) a) ->
      r1 == r2.
  Proof.
    intros.
    split;intros.
    red;intros.
    pose proof H (from_gstring x).
    clear H.
    revert x r1 r2 H1 H0.
    induction x;simpl;intros.
    specialize H1 with o.
    case_eq(ewp_set (r1 %dW nil) o);intros.
    unfold AtSy in H.
    rewrite H in H1.
    assert(ewp_set (r2 %dW nil) o = true).
    symmetry in H1.
    assumption.
    apply gs_in_pdrv_true in H2.
    simpl in H2.
    assumption.
    apply gs_not_in_pdrv_true in H.
    simpl in H.
    contradiction.
    specialize H1 with (last x).
    case_eq(ewp_set (r1 %dW ((o, z) :: from_gstring x)) (last x));
      case_eq(ewp_set (r2 %dW ((o, z) :: from_gstring x)) (last x));intros.
    apply gs_in_pdrv_true in H.
    apply gs_in_pdrv_true in H2.
    simpl in H.
    simpl in H2.
    rewrite <- from_to_gstring in H.
    assumption.
    rewrite H,H2 in H1.
    discriminate.
    rewrite H,H2 in H1.
    discriminate.
    apply gs_not_in_pdrv_true in H2.
    simpl in H2.
    elim H2.
    rewrite <- from_to_gstring.
    assumption.

    red;intros.
    pose proof H (from_gstring x).
    clear H.
    revert x r1 r2 H1 H0.
    induction x;simpl;intros.
    specialize H1 with o.
    case_eq(ewp_set (r2 %dW nil) o);intros.
    unfold AtSy in H.
    rewrite H in H1.
    apply gs_in_pdrv_true in H1.
    simpl in H1.
    assumption.
    apply gs_not_in_pdrv_true in H.
    simpl in H.
    contradiction.
    specialize H1 with (last x).
    case_eq(ewp_set (r1 %dW ((o, z) :: from_gstring x)) (last x));
      case_eq(ewp_set (r2 %dW ((o, z) :: from_gstring x)) (last x));intros.
    apply gs_in_pdrv_true in H.
    apply gs_in_pdrv_true in H2.
    simpl in H.
    simpl in H2.
    rewrite <- from_to_gstring in H2.
    assumption.
    rewrite H,H2 in H1.
    discriminate.
    rewrite H,H2 in H1.
    discriminate.
    apply gs_not_in_pdrv_true in H.
    simpl in H.
    elim H.
    rewrite <- from_to_gstring.
    assumption.
  Qed.

  (* Lemma all_ewp_set_tru_gl_eq_true_eq : *)
  (*   forall r1 r2, *)
  (*     (forall w a, *)
  (*        ewp_set (wpdrv r1 w) a = ewp_set (wpdrv r2 w) a) <-> *)
  (*     (forall w a, List.In a (smaller_ords (pow2 ntests)) -> *)
  (*                  ewp_set (wpdrv r1 w) a = ewp_set (wpdrv r2 w) a). *)
  (* Proof. *)
  (*   split;intros. *)
  (*   apply H. *)
  (*   apply H. *)
  (*   apply all_in_smaller_ords. *)
  (* Qed. *)

  Lemma all_ewp_set_tru_gl_eq_true_eq_set :
    forall r1 r2,
      (forall w a,
         ewp_set (wpdrv r1 w) a = ewp_set (wpdrv r2 w) a) <->
      (forall w a, a \In (smaller_ordsS (pow2 ntests)) ->
                   ewp_set (wpdrv r1 w) a = ewp_set (wpdrv r2 w) a).
  Proof.
    split;intros.
    apply H.
    apply H.
    apply all_in_smaller_ordsS.
  Qed.

  (* Lemma all_ewp_set_tru_gl_eq_true_final : *)
  (*   forall r1 r2, *)
  (*     (forall w a, List.In a (smaller_ords (pow2 ntests)) -> *)
  (*        ewp_set (wpdrv r1 w) a = ewp_set (wpdrv r2 w) a) -> *)
  (*     r1 == r2. *)
  (* Proof. *)
  (*   intros. *)
  (*   apply all_ewp_set_tru_gl_eq_true. intros. *)
  (*   apply all_ewp_set_tru_gl_eq_true_eq. *)
  (*   apply H. *)
  (* Qed. *)

  Lemma all_ewp_set_tru_gl_eq_true_final_set :
    forall r1 r2,
      (forall w a, a \In (smaller_ordsS (pow2 ntests)) ->
         ewp_set (wpdrv r1 w) a = ewp_set (wpdrv r2 w) a) ->
      r1 == r2.
  Proof.
    intros.
    apply all_ewp_set_tru_gl_eq_true. intros.
    apply all_ewp_set_tru_gl_eq_true_eq_set.
    apply H.
  Qed.

End KATPdrvs.


Require Export FunctorCategory Category.Product.
Require Import Common Functor.Product Functor.Product.ProductFunctor.

Set Implicit Arguments.
Generalizable All Variables.
Set Asymmetric Patterns.
Set Universe Polymorphism.

Local Open Scope functor_scope.

Section Law3.
  Context `{Funext}.
  Variable C1 : PreCategory.
  Variable C2 : PreCategory.
  Variable D : PreCategory.

  Definition ExponentialLaw3Functor
  : Functor [D, C1 * C2] ([D, C1] * [D, C2])
    := Build_Functor
         [D, C1 * C2] ([D, C1] * [D, C2])
         (fun H => (fst_Functor ∘ H, snd_Functor ∘ H))
         (fun s d m =>
            (NTWhiskerL fst_Functor m,
             NTWhiskerL snd_Functor m))
         (fun _ _ _ _ _ => path_prod' (NTWhiskerL_CompositionOf _ _ _)
                                      (NTWhiskerL_CompositionOf _ _ _))
         (fun _ => path_prod' (RightIdentityNaturalTransformationWhisker _ _)
                              (RightIdentityNaturalTransformationWhisker _ _)).

  Definition ExponentialLaw3Functor_Inverse
  : Functor ([D, C1] * [D, C2]) [D, C1 * C2]
    := FunctorProduct_Functor _ _ _.
End Law3.


Add LoadPath "~/fcf/fcf/src/FCF".
Require Import FCF.
Require Import Asymptotic.
Require Import Vector.
Require Import Bvector.
Check Bvector.

(* first attempt : distributions are parametrized by some n. properties are deterministic functions to bool on these distributions. *)

Infix "-" := ratSubtract : rat_scope.

Section whps.

Definition Prob {A : nat -> Set}   (D : forall n, Comp (A n)) (P : forall n, A n -> bool) := fun n => Pr[x <-$ D n; ret P _ x].

Definition wlp {A : nat -> Set} (D : forall n, Comp (A n)) (P : forall n, A n -> bool) := negligible (fun n => Prob D P n).
Definition whp {A : nat -> Set} (D : forall n, Comp (A n)) (P : forall n, A n -> bool) := negligible (fun n => (1 - Prob D P n)%rat).

Notation "D ⊨ P 'w/hp'" := (whp D P) (at level 99).
Notation "D ⊨ P 'w/lp'" := (wlp D P) (at level 99).

Definition wp_impl {A : nat -> Set} (P Q : forall n, A n -> bool) := forall (n : nat) (x : A n), P n x = true -> Q n x = true.

Notation "P ~> Q" := (wp_impl P Q) (at level 99).

Theorem prob_le : forall A (D : forall n, Comp (A n)) P Q n, P ~> Q -> Prob D P n <= Prob D Q n.
intuition.
unfold Prob.
unfold wp_impl in H.
comp_skip.
dist_compute.
exfalso.
pose (H n x e).
intuition.

unfold leRat.
unfold bleRat.
simpl.
auto.
Qed.

Theorem prob_opple : forall A (D : forall n, Comp (A n)) P Q n, P ~> Q -> 1 - Prob D Q n <= 1 - Prob D P n.
intuition.
pose (prob_le A D P Q n H).
apply ratSubtract_leRat_r.
intuition.
Qed.

Theorem whp_impl : forall A (D : forall n, Comp (A n)) P Q, D ⊨ P w/hp -> wp_impl P Q -> D ⊨ Q w/hp.
intuition.
unfold whp in *.

unfold negligible in *.
intuition.
destruct (H c).
exists x.
intuition.
pose (H1 x0 pf_nz H2).
pose (prob_opple A D P Q x0 H0).
pose (leRat_trans H3 l).
intuition.
Qed.

Theorem wlp_impl : forall A (D : forall n, Comp (A n)) P Q, D ⊨ P w/lp -> Q ~> P -> D ⊨ Q w/lp.
intuition.
unfold wlp in *.

unfold negligible in *.
intuition.
destruct (H c).
exists x.
intuition.
pose (H1 x0 pf_nz H2).
pose (prob_le A D Q P x0 H0).
pose (leRat_trans H3 l).
intuition.
Qed.

Theorem union_bound : forall A (D : forall n, Comp (A n)) P Q n, Prob D (fun n x => P n x && Q n x) n <= Prob D P n + Prob D Q n.
Abort.
(* is the above right to prove the below? *)

Theorem whp_and : forall A (D : forall n, Comp (A n)) P Q, D ⊨ P w/hp -> D ⊨ Q w/hp -> D ⊨ (fun n x => andb (P n x) (Q n x)) w/hp.
intuition.
unfold whp in *.
unfold negligible in *.
intuition.
destruct (H c).
destruct (H0 c).
exists (Nat.max x x0).
intuition.
unfold gt in H3.
apply Nat.max_lub_lt_iff in H3.
destruct H3.
unfold gt in H1.
pose (H1 x1 pf_nz H3).
unfold gt in H2.
pose (H2 x1 pf_nz H5).

unfold Prob in *.

assert (Pr [x <-$ D x1; ret P x1 x && Q x1 x ] <= Pr [x <-$ D x1; ret P x1 x ] + Pr [x <-$ D x1; ret Q x1 x ]). (* union bound *)
comp_skip.
simpl.

Definition Prob_bv := Prob (fun n => x <-$ {0,1}^n; ret x).
Definition wlp_bv := wlp (fun n => x <-$ {0,1}^n; ret x).
Definition whp_bv := whp (fun n => x <-$ {0,1}^n; ret x).

End whps.


Require Import Bitoychain.Coqlib.
Require Import Bitoychain.Coqlib2.
Require Import Coq.Lists.List.
Import ListNotations.

Lemma Zlength_length:
  forall A (al: list A) (n: Z),
    0 <= n ->
    (Zlength al = n <-> length al = Z.to_nat n).
Proof.
intros. rewrite Zlength_correct.
split; intro.
rewrite <- (Z2Nat.id n) in H0 by omega.
apply Nat2Z.inj in H0; auto.
rewrite H0.
apply Z2Nat.inj; try omega.
rewrite Nat2Z.id; auto.
Qed.

Lemma firstn_app1: forall {A} n (p l: list A),
  (n <= Datatypes.length p)%nat ->
   firstn n (p ++ l) = firstn n p.
Proof. intros A n.
induction n; simpl; intros. trivial.
  destruct p; simpl in H. omega.
  apply le_S_n in H. simpl. f_equal. auto.
Qed.

Lemma firstn_app2: forall {A} (n: nat) (al bl: list A),
 (n >= length al)%nat ->
 firstn n (al++bl) = al ++ firstn (n - length al) bl.
Proof.
intros. revert al H.
induction n; destruct al; intros.
reflexivity.
inv H.
simpl.
destruct bl; auto.
simpl.
f_equal. apply IHn.
simpl in H; omega.
Qed.

Lemma firstn_list_repeat {A} (v:A): forall i k, (i<=k)%nat ->
      firstn i (list_repeat k v) = list_repeat i v.
Proof.
  induction i; simpl; trivial; intros.
  destruct k. omega. simpl. rewrite IHi; trivial. omega.
Qed.

Lemma firstn_app:
 forall {A} n m (al: list A), firstn n al ++ firstn m (skipn n al) =
  firstn (n+m) al.
Proof. induction n; destruct al; intros; simpl; auto.
destruct m; reflexivity.
f_equal; auto.
Qed.

Lemma nth_skipn:
  forall {A} i n data (d:A),
       nth i (skipn n data) d = nth (i+n) data d.
Proof.
intros.
revert i data; induction n; simpl; intros.
f_equal; omega.
destruct data; auto.
destruct i; simpl; auto.
rewrite IHn.
replace (i + S n)%nat with (S (i + n))%nat by omega; auto.
Qed.

Lemma skipn_skipn: forall {A} n m (xs: list A),
  skipn n (skipn m xs) = skipn (m + n) xs.
Proof.
  intros.
  revert xs; induction m; intros.
  + reflexivity.
  + simpl.
    destruct xs.
    - destruct n; reflexivity.
    - apply IHm.
Qed.

Lemma firstn_exact_length: forall {A} (xs: list A), firstn (length xs) xs = xs.
Proof.
  intros.
  induction xs.
  + reflexivity.
  + simpl.
    rewrite IHxs.
    reflexivity.
Qed.

Lemma skipn_exact_length: forall {A} (xs: list A), skipn (length xs) xs = nil.
Proof.
  intros.
  induction xs.
  + reflexivity.
  + simpl.
    rewrite IHxs.
    reflexivity.
Qed.

Lemma len_le_1_rev: forall {A} (contents: list A),
  (length contents <= 1)%nat ->
  contents = rev contents.
Proof.
  intros.
  destruct contents.
  + reflexivity.
  + destruct contents.
    - reflexivity.
    - simpl in H. omega.
Qed.

Lemma firstn_firstn: forall {A} (contents: list A) n m,
  (n <= m)%nat ->
  firstn n (firstn m contents) = firstn n contents.
Proof.
  intros.
  revert n m H;
  induction contents;
  intros.
  + destruct n, m; reflexivity.
  + destruct n, m; try solve [omega].
    - simpl; reflexivity.
    - simpl; reflexivity.
    - simpl.
      rewrite IHcontents by omega.
      reflexivity.
Qed.

Lemma firstn_1_skipn: forall {A} n (ct: list A) d,
  (n < length ct)%nat ->
  nth n ct d :: nil = firstn 1 (skipn n ct).
Proof.
  intros.
  revert ct H; induction n; intros; destruct ct.
  + simpl in H; omega.
  + simpl. reflexivity.
  + simpl in H; omega.
  + simpl in H |- *.
    rewrite IHn by omega.
    reflexivity.
Qed.

Lemma skipn_length: forall {A} (contents: list A) n,
  length (skipn n contents) = (length contents - n)%nat.
Proof.
  intros.
  revert n;
  induction contents;
  intros.
  + destruct n; reflexivity.
  + destruct n; simpl.
    - reflexivity.
    - apply IHcontents.
Qed.

Lemma nth_firstn: forall {A} (contents: list A) n m d,
  (n < m)%nat ->
  nth n (firstn m contents) d = nth n contents d.
Proof.
  intros.
  revert n m H;
  induction contents;
  intros.
  + destruct n, m; reflexivity.
  + destruct n, m; try omega.
    - simpl. reflexivity.
    - simpl. apply IHcontents. omega.
Qed.

Lemma skipn_length_short:
  forall {A} n (al: list A),
    (length al <= n)%nat ->
    (length (skipn n al) = 0)%nat.
Proof.
 induction n; destruct al; simpl; intros; auto.
 omega.
 apply IHn. omega.
Qed.

Lemma skipn_short:
   forall {A} n (al: list A), (n >= length al)%nat -> skipn n al = nil.
Proof.
intros.
pose proof (skipn_length_short n al).
assert (length al <= n)%nat by auto.
specialize (H0 H1).
destruct (skipn n al); inv H0; auto.
Qed.

Lemma nth_map':
  forall {A B} (f: A -> B) d d' i al,
  (i < length al)%nat ->
   nth i (map f al) d = f (nth i al d').
Proof.
induction i; destruct al; simpl; intros; try omega; auto.
apply IHi; omega.
Qed.

Lemma skipn_nil: forall A n, skipn n (@nil A) = nil.
Proof. induction n; simpl; auto.
Qed.

Lemma skipn_drop:
 forall A n m (al: list A), skipn n (skipn m al) = skipn (n+m) al.
Proof.
induction m; intros.
* simpl; auto. f_equal; omega.
* replace (n + S m)%nat with (S (n + m))%nat by omega.
  destruct al; [ rewrite skipn_nil; auto | ].
  unfold skipn at 3; fold skipn.
 rewrite <- IHm.
 f_equal.
Qed.

Lemma skipn_app1:
 forall A n (al bl: list A),
  (n <= length al)%nat ->
  skipn n (al++bl) = skipn n al ++ bl.
Proof.
intros. revert al H;
induction n; destruct al; intros; simpl in *; try omega; auto.
apply IHn; omega.
Qed.

Lemma skipn_app2:
 forall A n (al bl: list A),
  (n >= length al)%nat ->
  skipn n (al++bl) = skipn (n-length al) bl.
Proof.
intros. revert al H;
induction n; destruct al; intros; simpl in *; try omega; auto.
apply IHn; omega.
Qed.

Lemma list_repeat_app: forall A a b (x:A),
  list_repeat a x ++ list_repeat b x = list_repeat (a+b) x.
Proof.
intros; induction a; simpl; f_equal.
auto.
Qed.

Lemma firstn_same:
  forall A n (b: list A), (n >= length b)%nat -> firstn n b = b.
Proof.
induction n; destruct b; simpl; intros; auto.
inv H.
f_equal; auto.
apply IHn.
omega.
Qed.

Lemma nth_firstn_low:
 forall A i n al (d: A),
  (i < n <= length al)%nat -> nth i (firstn n al) d = nth i al d.
Proof.
intros.
revert n al H; induction i; destruct n,al; simpl; intros; auto; try omega.
apply IHi; omega.
Qed.

Lemma nth_error_nth:
  forall A (d: A) i al, (i < length al)%nat -> nth_error al i = Some (nth i al d).
Proof.
induction i; destruct al; simpl; intros; auto.
inv H.
inv H.
apply IHi; omega.
Qed.

Lemma skipn_rev:
  forall {A} n (vl: list A),
   skipn n (rev vl) = rev (firstn (length vl - n) vl).
Proof.
induction n; intros.
simpl. rewrite Nat.sub_0_r. rewrite firstn_exact_length. auto.
destruct (rev vl) eqn:?.
pose proof (rev_length vl). rewrite Heql in H.
destruct vl; inv H. reflexivity.
simpl.
assert (vl = rev l ++ rev [a]).
rewrite <- rev_app_distr. simpl app. rewrite <- Heql; rewrite rev_involutive; auto.
rewrite H.
rewrite app_length.
simpl length.
rewrite <- (rev_involutive l) at 1.
rewrite IHn.
replace (length (rev l) + 1 - S n)%nat with (length (rev l) -n)%nat by omega.
f_equal.
rewrite firstn_app1 by omega.
reflexivity.
Qed.

Lemma Forall_list_repeat:
  forall {A} (P: A -> Prop) (n: nat) (a: A),
    P a -> Forall P (list_repeat n a).
Proof.
induction n; intros.
constructor.
constructor; auto.
Qed.

Lemma skipn_firstn: forall {A} n m (xs: list A),
  skipn n (firstn m xs) = firstn (m-n) (skipn n xs).
Proof.
intros.
revert xs n; induction m; intros.
simpl. destruct n; reflexivity.
destruct xs; simpl.
rewrite skipn_nil.
destruct match n with
            | O => S m
            | S l => (m - l)%nat
            end; reflexivity.
destruct n.
simpl. reflexivity.
simpl.
apply IHm.
Qed.

Lemma rev_skipn:
 forall {A} n (vl: list A),
  rev (skipn n vl) = firstn (length vl -n) (rev vl).
Proof.
induction n; intros.
simpl. rewrite Nat.sub_0_r.
rewrite <- rev_length.
rewrite firstn_exact_length.
auto.
destruct vl.
simpl. auto.
simpl.
rewrite IHn.
rewrite firstn_app1 by (rewrite rev_length; omega).
auto.
Qed.

Lemma firstn_skipn_rev:
  forall {A} lo n (vl: list A),
  (n+lo <= length vl)%nat ->
  firstn n (skipn lo (rev vl)) =
  rev (firstn n (skipn (length vl - (lo+n))%nat vl)).
Proof.
intros.
rewrite skipn_rev.
assert (n = (length vl - lo) - (length vl - (lo+n)))%nat by omega.
rewrite H0 at 2.
rewrite <- skipn_firstn.
rewrite rev_skipn.
rewrite firstn_length. rewrite min_l by omega.
f_equal.
auto.
Qed.

Lemma map_firstn:
  forall A B (F: A -> B) n (al: list A),
  map F (firstn n al) = firstn n (map F al).
Proof.
induction n; destruct al; simpl; intros; auto.
f_equal; auto.
Qed.

Lemma map_skipn:
  forall A B (F: A -> B) n (al: list A),
  map F (skipn n al) = skipn n (map F al).
Proof.
induction n; destruct al; simpl; intros; auto.
Qed.

Lemma Zlength_app: forall T (al bl: list T),
    Zlength (al++bl) = Zlength al + Zlength bl.
Proof. induction al; intros. simpl app; rewrite Zlength_nil; omega.
 simpl app; repeat rewrite Zlength_cons; rewrite IHal; omega.
Qed.

Lemma Zlength_rev: forall T (vl: list T), Zlength (rev vl) = Zlength vl.
Proof. induction vl; simpl; auto. rewrite Zlength_cons. rewrite <- IHvl.
rewrite Zlength_app. rewrite Zlength_cons. rewrite Zlength_nil; omega.
Qed.

Lemma Zlength_map: forall A B (f: A -> B) l, Zlength (map f l) = Zlength l.
Proof. induction l; simpl; auto. repeat rewrite Zlength_cons. f_equal; auto.
Qed.

Lemma ZtoNat_Zlength:
 forall {A} (l: list A), Z.to_nat (Zlength l) = length l.
Proof.
intros. rewrite Zlength_correct. apply Nat2Z.id.
Qed.
Hint Rewrite @ZtoNat_Zlength : norm.

Lemma Zlength_nonneg:
 forall {A} (l: list A), 0 <= Zlength l.
Proof.
intros. rewrite Zlength_correct. omega.
Qed.

(** START of tactics copied from val_lemmas.v *)
Definition Zlength' := @Zlength.

Ltac pose_Zlength_nonneg1 A :=
     lazymatch goal with
      | H:  0 <= Zlength A |- _ => idtac
      | H:  0 <= Zlength A /\ _ |- _ => idtac
      | |- _ => pose proof (Zlength_nonneg A)
     end;  change (Zlength A) with (Zlength' _ A) in *.

Ltac pose_Zlength_nonneg :=
 repeat
  match goal with
  | |- context [Zlength ?A] => pose_Zlength_nonneg1 A
  | H: context [Zlength ?A] |- _ => pose_Zlength_nonneg1 A
(*   | H:= context [Zlength ?A] |- _ => pose_Zlength_nonneg1 A *)
 end;
  unfold Zlength' in *.
(** END of tactics copied from val_lemmas.v *)

Ltac list_solve := autorewrite with sublist; pose_Zlength_nonneg; omega.

Definition Znth {X} n (xs: list X) (default: X) :=
  if (zlt n 0) then default else nth (Z.to_nat n) xs default.

Lemma Znth_map:
  forall {A:Type} (d': A) (B:Type) i (f: A -> B) (al: list A) (b: B),
  0 <= i < Zlength al ->
  @Znth B i (map f al) b = f (Znth i al d').
Proof.
unfold Znth.
intros.
rewrite if_false by omega.
rewrite if_false by omega.
rewrite nth_map' with (d'0 := d'); auto.
apply Nat2Z.inj_lt. rewrite Z2Nat.id by omega.
rewrite <- Zlength_correct; omega.
Qed.

Hint Rewrite (Znth_map 0) (Znth_map 1%positive) (Znth_map O)
    using (auto; rewrite ?Zlength_map in *; omega) : sublist.

(* Add these in a later file where things are in scope ...
Hint Rewrite (Znth_map Int.zero) (Znth_map Vundef)
    using (auto; rewrite ?Zlength_map in *; omega) : sublist.
*)

Lemma Znth_succ: forall {A} i lo (v: list A), Z.succ lo <= i -> Znth (i - lo) v = Znth (i - (Z.succ lo)) (skipn 1 v).
Proof.
  intros.
  extensionality default.
  unfold Znth.
  if_tac; [omega |].
  if_tac; [omega |].
  rewrite nth_skipn.
  f_equal.
  change 1%nat with (Z.to_nat 1).
  rewrite <- Z2Nat.inj_add by omega.
  f_equal.
  omega.
Qed.

Lemma Znth_0_cons {A} l (v:A) d: Znth 0 (v::l) d = v.
Proof. reflexivity. Qed.

Lemma Znth_pos_cons {A} i l (v:A) d: 0<i -> Znth i (v::l) d = Znth (i-1) l d.
Proof. intros. unfold Znth. if_tac. omega. if_tac. omega.
  assert (Z.to_nat i = S (Z.to_nat (i-1))).
    rewrite <- Z2Nat.inj_succ. assert (i = Z.succ (i - 1)). omega. rewrite <- H2. trivial. omega.
  rewrite H2; reflexivity.
Qed.

Lemma Znth_In : forall {A} i l (d : A), 0 <= i < Zlength l -> In (Znth i l d) l.
Proof.
  intros; unfold Znth.
  destruct (zlt i 0); [omega|].
  apply nth_In; rewrite Zlength_correct in *.
  apply Nat2Z.inj_lt; rewrite Z2Nat.id; omega.
Qed.

Lemma split3_full_length_list: forall {A} lo mid hi (ct: list A) d,
  lo <= mid < hi ->
  Zlength ct = hi - lo ->
  ct = firstn (Z.to_nat (mid - lo)) ct ++
       (Znth (mid - lo) ct d :: nil) ++
       skipn (Z.to_nat (mid - lo + 1)) ct.
Proof.
  intros.
  rewrite <- firstn_skipn with (l := ct) (n := Z.to_nat (mid - lo)) at 1.
  f_equal.
  rewrite Z2Nat.inj_add by omega.
  rewrite <- skipn_skipn.
  replace (Znth (mid - lo) ct d :: nil) with (firstn (Z.to_nat 1) (skipn (Z.to_nat (mid - lo)) ct)).
  + rewrite firstn_skipn; reflexivity.
  + unfold Znth.
    if_tac; [omega |].
    rewrite firstn_1_skipn; [reflexivity |].
    rewrite <- (Nat2Z.id (length ct)).
    apply Z2Nat.inj_lt.
    - omega.
    - omega.
    - rewrite Zlength_correct in H0.
      omega.
Qed.

Lemma Forall_Znth:
 forall {A} (F: A -> Prop) (al: list A) i d,
   0 <= i < Zlength al ->
   Forall F al ->
   F (Znth i al d).
Proof.
intros.
unfold Znth. rewrite if_false by omega.
rewrite Zlength_correct in H.
assert (Z.to_nat i < length al)%nat.
apply Nat2Z.inj_lt. rewrite Z2Nat.id by omega; omega.
clear H.
revert al H0 H1; induction (Z.to_nat i); destruct al; intros; simpl in *.
omega.
inv H0. auto.
inv H1.
inv H0.
apply IHn; auto.
omega.
Qed.

Lemma app_Znth1:
  forall A (l l': list A) (d: A) (i:Z),
  i < Zlength l -> Znth i (l++l') d = Znth i l d.
Proof.
intros.
unfold Znth.
if_tac; auto.
apply app_nth1.
apply Nat2Z.inj_lt. rewrite Z2Nat.id by omega.
rewrite Zlength_correct in H; auto.
Qed.

Lemma app_Znth2:
  forall A (l l': list A) (d: A) (i:Z),
  i >= Zlength l -> Znth i (l++l') d = Znth (i-Zlength l) l' d.
Proof.
intros.
unfold Znth.
pose proof (Zlength_nonneg l).
if_tac.
rewrite if_true by omega; auto.
rewrite if_false by omega.
rewrite app_nth2.
f_equal.
rewrite Z2Nat.inj_sub by auto.
rewrite Zlength_correct.
rewrite Nat2Z.id; auto.
apply Nat2Z.inj_ge. rewrite Z2Nat.id by omega.
rewrite <- Zlength_correct; auto.
Qed.

Lemma Znth_firstn:
  forall {A} (al: list A) (n m : Z) (d: A),
  n<m -> Znth n (firstn (Z.to_nat m) al) d = Znth n al d.
Proof.
intros.
unfold Znth.
if_tac; auto.
apply nth_firstn.
apply Z2Nat.inj_lt; omega.
Qed.

Lemma Znth_skipn: forall {A} i n xs (default: A),
  0 <= i ->
  0 <= n ->
  Znth i (skipn (nat_of_Z n) xs) default = Znth (i+n) xs default.
Proof.
  intros.
  unfold Znth.
  rewrite if_false by omega. rewrite if_false by omega.
  rewrite nth_skipn. f_equal.
  rewrite Z2Nat.inj_add by omega. auto.
Qed.

Lemma Z2Nat_neg: forall i, i < 0 -> Z.to_nat i = 0%nat.
Proof.
  intros.
  destruct i; try reflexivity.
  pose proof Zgt_pos_0 p; omega.
Qed.

Lemma Zlength_firstn:
  forall {A} n (v: list A), Zlength (firstn (Z.to_nat n) v) = Z.min (Z.max 0 n) (Zlength v).
Proof.
intros. rewrite !Zlength_correct.
rewrite firstn_length.
(* solve by SMT *)
rewrite Zmin_spec, Zmax_spec.
if_tac; [rewrite min_l | rewrite min_r].
if_tac.
rewrite Z2Nat_neg; auto.
apply Z2Nat.id; omega.
if_tac in H.
rewrite Z2Nat_neg; auto. omega.
rewrite <- (Nat2Z.id (length v)).
apply Z2Nat.inj_le; try omega.
auto.
if_tac in H.
destruct (length v); try omega.
rewrite inj_S in H. omega.
rewrite <- (Nat2Z.id (length v)).
apply Z2Nat.inj_le; try omega.
Qed.

Lemma Zlength_skipn:
  forall {A} n (v: list A),
  Zlength (skipn (Z.to_nat n) v) = Z.max 0 (Zlength v - (Z.max 0n)).
Proof.
intros.
(* solve by SMT *)
rewrite !Zlength_correct.
rewrite skipn_length. rewrite !Zmax_spec.
if_tac.
if_tac in H.
omega.
apply inj_minus2. apply Nat2Z.inj_gt. rewrite Z2Nat.id by omega.
omega.
if_tac.
rewrite (Z2Nat_neg n) by omega.
rewrite Nat.sub_0_r.
omega.
rewrite Nat2Z.inj_sub.
rewrite Z2Nat.id by omega. auto.
apply Nat2Z.inj_le.
rewrite Z2Nat.id by omega.  omega.
Qed.

Lemma Znth_cons:
 forall {A} i (al: list A) d bl,
  0 <= i < Zlength al  ->
  Znth i al d :: bl = firstn (Z.to_nat 1) (skipn (Z.to_nat i) al) ++ bl.
Proof.
intros.
pose proof (Znth_skipn 0 i al).
rewrite Z.add_0_l in H0.
rewrite <- H0 by omega; clear H0.
change (Znth 0 (skipn (nat_of_Z i) al) d :: bl) with
   ([Znth 0 (skipn (Z.to_nat i) al) d] ++ bl).
f_equal.
unfold Znth.
rewrite if_false  by omega.
assert (Zlength (skipn (Z.to_nat i) al) > 0).
rewrite Zlength_skipn.
rewrite (Z.max_r 0 i) by omega.
rewrite Z.max_r by omega.
omega.
destruct (skipn (Z.to_nat i) al).
rewrite Zlength_nil in H0; omega.
reflexivity.
Qed.

Lemma Zfirstn_app1:
 forall A n (al bl: list A),
  n <= Zlength al -> firstn (Z.to_nat n) (al++bl) = firstn (Z.to_nat n) al.
Proof.
intros.
apply firstn_app1.
apply Nat2Z.inj_le. rewrite Zlength_correct in H.
destruct (zlt n 0).
rewrite Z2Nat_neg by auto. change (Z.of_nat 0) with 0; omega.
rewrite Z2Nat.id by omega.
omega.
Qed.

Lemma Zfirstn_same:
  forall A n (b: list A), n >= Zlength b -> firstn (Z.to_nat n) b = b.
Proof.
intros.
apply firstn_same.
rewrite Zlength_correct in H.
apply Nat2Z.inj_ge.
rewrite Z2Nat.id by omega.
auto.
Qed.

Lemma Zfirstn_app2: forall {A} n (al bl: list A),
 n >= Zlength al ->
 firstn (Z.to_nat n) (al++bl) = al ++ firstn (Z.to_nat (n - Zlength al)) bl.
Proof.
intros.
rewrite firstn_app2.
f_equal. f_equal.
rewrite Z2Nat.inj_sub.
rewrite Zlength_correct, Nat2Z.id. auto.
apply Zlength_nonneg.
apply Nat2Z.inj_ge.
rewrite Zlength_correct in H.
rewrite Z2Nat.id by omega.
auto.
Qed.

Lemma Zfirstn_firstn: forall {A} (contents: list A) n m,
  n <= m ->
  firstn (Z.to_nat n) (firstn (Z.to_nat m) contents) = firstn (Z.to_nat n) contents.
Proof.
intros.
destruct (zlt n 0).
rewrite (Z2Nat_neg n) by omega.
reflexivity.
apply firstn_firstn.
apply Z2Nat.inj_le; omega.
Qed.
Lemma Zskipn_app1:
 forall A n (al bl: list A),
  n <= Zlength al ->
  skipn (Z.to_nat n) (al++bl) = skipn (Z.to_nat n) al ++ bl.
Proof.
intros.
apply skipn_app1.
rewrite Zlength_correct in H.
apply Nat2Z.inj_le.
destruct (zlt n 0).
rewrite (Z2Nat_neg n) by omega.
change (Z.of_nat 0) with 0.  omega.
rewrite Z2Nat.id by omega.
auto.
Qed.

Lemma Zskipn_app2:
 forall A n (al bl: list A),
  n >= Zlength al ->
  skipn (Z.to_nat n) (al++bl) = skipn (Z.to_nat (n-Zlength al)) bl.
Proof.
intros.
rewrite Zlength_correct in *.
rewrite skipn_app2.
f_equal.
rewrite Z2Nat.inj_sub by omega.
rewrite Nat2Z.id.
auto.
apply Nat2Z.inj_ge.
destruct (zlt n 0).
rewrite (Z2Nat_neg n) by omega.
change (Z.of_nat 0) with 0.  omega.
rewrite Z2Nat.id by omega.
auto.
Qed.

Lemma Znth_rev:
  forall {A} i (al:list A) d,
  0 <= i < Zlength al ->
  Znth i (rev al) d = Znth (Zlength al - i - 1) al d.
Proof.
intros.
 unfold Znth. rewrite !if_false by omega.
rewrite !Z2Nat.inj_sub by omega.
rewrite Zlength_correct in*.
rewrite Nat2Z.id.
assert (Z.to_nat i < length al)%nat.
apply Nat2Z.inj_lt. rewrite Z2Nat.id by omega. omega.
change (Z.to_nat 1) with 1%nat.
clear H.
rewrite rev_nth; auto.
f_equal.
omega.
Qed.

Lemma Zskipn_firstn: forall {A} n m (xs: list A),
 0 <= n ->
 skipn (Z.to_nat n) (firstn (Z.to_nat m) xs) =
  firstn (Z.to_nat (m-n)) (skipn (Z.to_nat n) xs).
Proof.
intros.
rewrite skipn_firstn.
f_equal.
rewrite Z2Nat.inj_sub; auto.
Qed.

Lemma Zskipn_skipn: forall {A} n m (xs: list A),
  0 <= n -> 0 <= m ->
  skipn (Z.to_nat n) (skipn (Z.to_nat m) xs) = skipn (Z.to_nat (m + n)) xs.
Proof.
  intros.
  rewrite skipn_skipn.
 f_equal.
 rewrite Z2Nat.inj_add; auto.
Qed.

Lemma Zfirstn_app:
 forall {A} n m (al: list A),
  0 <= n -> 0 <= m ->
  firstn (Z.to_nat n) al ++ firstn (Z.to_nat m) (skipn (Z.to_nat n) al) =
  firstn (Z.to_nat (n+m)) al.
Proof.
intros.
rewrite firstn_app.
f_equal.
rewrite Z2Nat.inj_add; omega.
Qed.

Lemma Zfirstn_exact_length:
  forall {A} n (al: list A),
  n = Zlength al ->
  firstn (Z.to_nat n) al = al.
Proof.
intros.
subst.
rewrite Zlength_correct.
rewrite Nat2Z.id.
apply firstn_exact_length.
Qed.

(*****   SUBLIST  ******)

Definition sublist {A} (lo hi: Z) (al: list A) : list A :=
  firstn (Z.to_nat (hi-lo)) (skipn (Z.to_nat lo) al).

Definition upd_Znth {A} (i: Z) (al: list A) (x: A): list A :=
   sublist 0 i al ++ x :: sublist (i+1) (Zlength al) al.

Lemma sublist_sublist {A} i j k m (l:list A): 0<=m -> 0<=k <=i -> i <= j-m ->
  sublist k i (sublist m j l) = sublist (k+m) (i+m) l.
Proof.
 unfold sublist; intros.
  rewrite skipn_firstn.
  rewrite firstn_firstn, skipn_skipn, <- Z2Nat.inj_add,(Z.add_comm _ k), Zminus_plus_simpl_r; trivial.
  omega.
  rewrite <- Z2Nat.inj_sub; trivial. apply Z2Nat.inj_le; try omega. omega.
Qed.
(*
Lemma sublist_sublist:
  forall {A} lo hi lo' hi' (al: list A),
 0 <= lo <= hi ->
 hi <= hi'-lo' ->
 0 <= lo' <= hi' ->
 hi' <= Zlength al ->
 sublist lo hi (sublist lo' hi' al) = sublist (lo+lo') (hi+lo') al.
Proof.
intros.
unfold sublist.
rewrite Zskipn_firstn by omega.
rewrite Zfirstn_firstn by omega.
rewrite Zskipn_skipn by omega.
f_equal. f_equal. omega.
f_equal. f_equal. omega.
Qed.
*)
Lemma sublist_rejoin:
  forall {A} lo mid hi (al: list A),
  0 <= lo <= mid ->
  mid <= hi <= Zlength al ->
  sublist lo mid al ++ sublist mid hi al = sublist lo hi al.
Proof.
intros.
unfold sublist.
replace (hi-lo) with ((mid-lo)+(hi-mid)) by omega.
rewrite <- Zfirstn_app by omega.
f_equal.
rewrite Zskipn_skipn by omega.
f_equal. f_equal. f_equal. omega.
Qed.

Lemma sublist_map:
  forall {A B} (F: A -> B) lo hi (al: list A),
  sublist lo hi (map F al) = map F (sublist lo hi al).
Proof.
intros.
unfold sublist.
rewrite map_firstn, map_skipn; auto.
Qed.

Lemma map_sublist:
  forall {A B} (F: A -> B) lo hi (al: list A),
  map F (sublist lo hi al) = sublist lo hi (map F al).
Proof.
intros.
symmetry. apply sublist_map.
Qed.

Lemma sublist_len_1:
  forall {A} i (al: list A) d,
  0 <= i < Zlength al ->
  sublist i (i+1) al = Znth i al d :: nil.
Proof.
  intros.
  unfold sublist.
  replace (i+1-i) with 1 by omega.
  rewrite Znth_cons by omega.
  symmetry; apply app_nil_r.
Qed.

Lemma Znth_cons_sublist:
  forall {A} i (al: list A) d bl,
  0 <= i < Zlength al ->
  Znth i al d :: bl = sublist i (i+1) al ++ bl.
Proof.
  intros.
  erewrite sublist_len_1 by eauto.
  reflexivity.
Qed.

Lemma Zlength_sublist:
  forall {A} lo hi (al: list A),
 0 <= lo <= hi -> hi <= Zlength al ->
 Zlength (sublist lo hi al) = hi-lo.
Proof.
intros.
unfold sublist.
rewrite Zlength_firstn, Z.max_r by omega.
rewrite Zlength_skipn.
rewrite (Z.max_r 0 lo) by omega.
rewrite Z.max_r by omega.
rewrite Z.min_l by omega.
auto.
Qed.

Lemma sublist_same_gen:
forall {A} lo hi (al: list A),
  lo = 0 -> hi >= Zlength al ->
  sublist lo hi al = al.
Proof.
intros.
unfold sublist; subst.
rewrite Z.sub_0_r.
simpl; rewrite firstn_all2; auto.
apply Nat2Z.inj_le.
pose proof (Zlength_nonneg al).
rewrite Z2Nat.id, <- Zlength_correct; omega.
Qed.

Lemma sublist_same:
forall {A} lo hi (al: list A),
  lo = 0 -> hi = Zlength al ->
  sublist lo hi al = al.
Proof.
intros; apply sublist_same_gen; omega.
Qed.

Lemma Znth_sublist:
  forall {A} lo i hi (al: list A) d,
 0 <= lo ->
 0 <= i < hi-lo ->
 Znth i (sublist lo hi al) d = Znth (i+lo) al d.
Proof.
intros.
unfold sublist.
rewrite Znth_firstn by omega.
rewrite Znth_skipn by omega. auto.
Qed.

Lemma rev_sublist:
  forall {A} lo hi (al: list A),
  0 <= lo <= hi -> hi <= Zlength al ->
  rev (sublist lo hi al) = sublist (Zlength al - hi) (Zlength al - lo) (rev al).
Proof.
intros.
unfold sublist.
replace (skipn (Z.to_nat lo) al)
 with (skipn (length al - (Z.to_nat (Zlength al - hi) + (Z.to_nat (hi - lo)))) al).
rewrite <- firstn_skipn_rev.
f_equal.
f_equal. omega.
apply Nat2Z.inj_le.
rewrite Nat2Z.inj_add.
rewrite <- Zlength_correct.
rewrite !Z2Nat.id by omega.
omega.
f_equal.
apply Nat2Z.inj.
rewrite Nat2Z.inj_sub.
rewrite Nat2Z.inj_add.
rewrite !Z2Nat.id by omega.
rewrite <- Zlength_correct; omega.
apply Nat2Z.inj_le.
rewrite <- Zlength_correct.
rewrite Nat2Z.inj_add.
rewrite !Z2Nat.id by omega.
omega.
Qed.

Lemma sublist_nil:
  forall {A} lo (al: list A),
  sublist lo lo al = nil.
Proof.
intros.
unfold sublist.
rewrite Z.sub_diag. reflexivity.
Qed.

Lemma sublist_nil_gen : forall {A} (l : list A) i j, j <= i -> sublist i j l = [].
Proof.
  intros; unfold sublist.
  replace (Z.to_nat (j - i)) with O; auto.
  apply Nat2Z.inj; simpl.
  destruct (Z_eq_dec (j - i) 0); [rewrite e; auto|].
  rewrite Z2Nat_neg; auto; omega.
Qed.

Lemma sublist_rev:
  forall {A} lo hi (al: list A),
  0 <= lo <= hi -> hi <= Zlength al ->
  sublist lo hi (rev al) = rev (sublist (Zlength al - hi) (Zlength al - lo) al).
Proof.
intros.
rewrite rev_sublist by omega.
f_equal; omega.
Qed.

Lemma sublist_app:
  forall {A} lo hi (al bl: list A),
  0 <= lo <= hi -> hi <= Zlength al + Zlength bl ->
  sublist lo hi (al++bl) =
  sublist (Z.min lo (Zlength al)) (Z.min hi (Zlength al)) al ++
  sublist (Z.max (lo-Zlength al) 0) (Z.max (hi-Zlength al) 0) bl.
Proof.
intros.
unfold sublist.
destruct (zlt hi (Zlength al)).
rewrite (Z.min_l hi (Zlength al)) by omega.
rewrite (Z.min_l lo (Zlength al)) by omega.
rewrite (Z.max_r (hi-Zlength al) 0) by omega.
rewrite (Z.max_r (lo-Zlength al) 0) by omega.
simpl firstn.
rewrite <- app_nil_end.
rewrite Zskipn_app1 by omega.
rewrite Zfirstn_app1
 by (rewrite Zlength_skipn, !Z.max_r; try omega;
      rewrite Z.max_r; omega).
auto.
rewrite (Z.min_r hi (Zlength al)) by omega.
rewrite (Z.max_l (hi-Zlength al) 0) by omega.
destruct (zlt lo (Zlength al)).
rewrite (Z.min_l lo (Zlength al)) by omega.
rewrite (Z.max_r (lo-Zlength al) 0) by omega.
rewrite Zskipn_app1 by omega.
rewrite Zfirstn_app2
 by (rewrite Zlength_skipn, !Z.max_r; try omega;
      rewrite Z.max_r; omega).
rewrite Zlength_skipn, !Z.max_r; try omega;
      rewrite ?Z.max_r; try omega.
simpl skipn.
f_equal.

rewrite Zfirstn_exact_length; auto.
rewrite Zlength_skipn, !Z.max_r; try omega.
rewrite Z.max_r; omega.
f_equal.
f_equal.
omega.
rewrite (Z.min_r lo (Zlength al)) by omega.
rewrite (Z.max_l (lo-Zlength al) 0) by omega.
rewrite Zskipn_app2 by omega.
rewrite Z.sub_diag.
simpl app.
f_equal.
f_equal.
omega.
Qed.

Lemma sublist_split:
  forall {A} lo mid hi (al: list A),
  0 <= lo <= mid ->
  mid <= hi <= Zlength al ->
  sublist lo hi al = sublist lo mid al ++ sublist mid hi al.
Proof.
intros.
symmetry; apply sublist_rejoin; auto.
Qed.

Lemma sublist_last_1 : forall {A} lo hi (al : list A) d, 0 <= lo <= hi -> hi + 1 <= Zlength al ->
  sublist lo (hi + 1) al = sublist lo hi al ++ [Znth hi al d].
Proof.
  intros.
  erewrite sublist_split with (mid := hi)(hi0 := hi + 1), sublist_len_1 with (d0 := d); auto; omega.
Qed.

Lemma Zlen_le_1_rev:
 forall {A} (al: list A),
  Zlength al <= 1 -> rev al = al.
Proof.
intros.
symmetry.
apply len_le_1_rev.
apply Nat2Z.inj_le. rewrite <- Zlength_correct; apply H.
Qed.

Lemma skipn_0:
  forall A (l: list A), skipn 0 l = l.
Proof.
reflexivity.
Qed.

Lemma sublist_1_cons {A} l (v:A) n: sublist 1 n (v::l) = sublist 0 (n-1) l.
Proof.
  unfold sublist. rewrite Z2Nat.inj_sub, skipn_0, Zminus_0_r. simpl. rewrite Z2Nat.inj_sub. trivial.
  omega. omega.
Qed.

Lemma sublist_nil': forall (A : Type) (lo lo': Z) (al : list A), lo=lo' -> sublist lo lo' al = [].
Proof. intros. subst. apply sublist_nil. Qed.

Lemma sublist_skip {A} (l:list A) i : 0<=i ->  sublist i (Zlength l) l = skipn (Z.to_nat i) l.
Proof. unfold sublist; intros. apply firstn_same. rewrite skipn_length.
  rewrite Z2Nat.inj_sub, Zlength_correct, Nat2Z.id. omega. trivial.
Qed.

Lemma sublist_firstn {A} (l:list A) i: sublist 0 i l = firstn (Z.to_nat i) l.
Proof. unfold sublist; intros. rewrite Zminus_0_r, skipn_0. trivial. Qed.

Lemma sublist_app1:
  forall (A : Type) (k i : Z) (al bl : list A),
  0 <= k <= i -> i <= Zlength al -> sublist k i (al ++ bl) = sublist k i al.
Proof. intros.
  unfold sublist. rewrite skipn_app1. rewrite firstn_app1. trivial.
  rewrite skipn_length, Z2Nat.inj_sub. apply Nat2Z.inj_le.
  repeat rewrite Nat2Z.inj_sub. rewrite Z2Nat.id, <- Zlength_correct. omega. omega.
  rewrite <- ZtoNat_Zlength. apply Z2Nat.inj_le; omega.
  apply Z2Nat.inj_le; omega. omega. rewrite <- ZtoNat_Zlength. apply Z2Nat.inj_le; omega.
Qed.

Lemma sublist0_app1 {A} i (al bl:list A): 0<= i <= Zlength al ->
  sublist 0 i (al ++ bl) = sublist 0 i al.
Proof. intros. apply sublist_app1; omega. Qed.

Lemma sublist_app2 {A} i j (al bl:list A): 0<=Zlength al <= i->
  sublist i j (al ++ bl) = sublist (i-Zlength al) (j-Zlength al) bl.
Proof.
  unfold sublist; intros.
  rewrite skipn_app2.
  repeat rewrite Z2Nat.inj_sub. repeat rewrite ZtoNat_Zlength.
  remember ((Z.to_nat i - length al)%nat) as k.
  rewrite <- Nat.sub_add_distr.
  assert (K: (length al + k = Z.to_nat i)%nat).
    subst k. rewrite <- le_plus_minus. trivial.
    apply Nat2Z.inj_le. rewrite Z2Nat.id. rewrite Zlength_correct in H; apply H. omega.
  rewrite K. trivial.
  omega. omega. omega. omega.
  apply Nat2Z.inj_le. rewrite Z2Nat.id. rewrite Zlength_correct in H; apply H. omega.
Qed.

Lemma sublist_sublist0 {A} i j k (l:list A): 0<=k -> k<=i<=j ->
  sublist k i (sublist 0 j l) = sublist k i l.
Proof. intros. rewrite sublist_sublist; repeat rewrite Zplus_0_r; trivial; omega. Qed.

Lemma sublist_sublist00 {A} i j (l:list A): 0<=i<=j ->
  sublist 0 i (sublist 0 j l) = sublist 0 i l.
Proof. intros. apply sublist_sublist0; omega. Qed.

Lemma skipn_list_repeat:
   forall A k n (a: A),
     (k <= n)%nat -> skipn k (list_repeat n a) = list_repeat (n-k) a.
Proof.
 induction k; destruct n; simpl; intros; auto.
 apply IHk; auto. omega.
Qed.

(* not this version!
Lemma sublist_list_repeat {A} i j k (v:A) (I: 0<=i)
          (IJK: (Z.to_nat i <= Z.to_nat j <= k)%nat):
      sublist i j (list_repeat k v) = list_repeat (Z.to_nat (j-i)) v.
Proof.
  unfold sublist.
  rewrite skipn_list_repeat; try omega.
  rewrite Z2Nat.inj_sub; try omega.
  rewrite firstn_list_repeat; trivial; omega.
Qed.
*)

Lemma sublist_list_repeat {A} i j k (v:A) (I: 0<=i)
          (IJK: i <= j <= k):
      sublist i j (list_repeat (Z.to_nat k) v) = list_repeat (Z.to_nat (j-i)) v.
Proof.
  unfold sublist.
  rewrite skipn_list_repeat.
  rewrite firstn_list_repeat.
  trivial.
  rewrite <- Z2Nat.inj_sub by omega.
  apply Z2Nat.inj_le; omega.
  apply Z2Nat.inj_le; omega.
Qed.

Lemma Zlength_list_repeat:
  forall {A} n (x: A),
  0 <= n ->
  Zlength (list_repeat (Z.to_nat n) x) = n.
Proof.
intros.
rewrite Zlength_correct.
rewrite length_list_repeat.
apply Z2Nat.id; auto.
Qed.

Lemma list_repeat_0:
  forall {A} (x:A), list_repeat (Z.to_nat 0) x = nil.
Proof.
simpl. auto.
Qed.

Lemma Znth_list_repeat_inrange:
  forall {A} i n (a d: A),
   (0 <= i < n)%Z ->
   Znth i (list_repeat (Z.to_nat n) a) d = a.
Proof.
intros.
unfold Znth; rewrite if_false by omega.
assert (Z.to_nat i < Z.to_nat n)%nat
  by (apply Z2Nat.inj_lt; omega).
forget (Z.to_nat n) as k.
revert k H0; induction (Z.to_nat i); destruct k; simpl; intros.
omega. auto. omega. apply IHn0; omega.
Qed.

Lemma firstn_nil {A} n: firstn n (nil:list A) = nil.
Proof.  destruct n; reflexivity. Qed.

Lemma firstn_In {A} (x:A): forall l n, In x (firstn n l) -> In x l.
Proof.
  induction l; simpl; intros.
  rewrite firstn_nil in H. inv H.
  destruct n; simpl in *. contradiction.
  destruct H; eauto.
Qed.
Lemma skipn_In {A} (x:A): forall l n, In x (skipn n l) -> In x l.
Proof.
  induction l; simpl; intros.
  rewrite skipn_nil in H. inv H.
  destruct n; simpl in *. trivial. right; eauto.
Qed.

Lemma sublist_In {A} lo hi data (x:A) (I:In x (sublist lo hi data)): In x data.
Proof. eapply skipn_In. eapply firstn_In. apply I. Qed.

Lemma Zlength_list_repeat' {A} n (v:A): Zlength (list_repeat n v) = Z.of_nat n.
Proof. rewrite Zlength_correct, length_list_repeat; trivial. Qed.

Lemma sublist0_app2 {A : Type} i (al bl : list A):
  Zlength al <= i <= Zlength al + Zlength bl ->
  sublist 0 i (al ++ bl) = al ++ sublist 0 (i - Zlength al) bl.
Proof. specialize (Zlength_nonneg al); specialize (Zlength_nonneg bl); intros.
rewrite <- (sublist_rejoin 0 (Zlength al) i); try rewrite Zlength_app; try omega.
rewrite sublist0_app1, sublist_same; try omega.
 rewrite sublist_app2, Zminus_diag; trivial. omega.
Qed.

Lemma sublist_rejoin':
  forall {A} lo mid mid' hi (al: list A),
  mid=mid' ->
  0 <= lo <= mid ->
  mid' <= hi <= Zlength al ->
  sublist lo mid al ++ sublist mid' hi al = sublist lo hi al.
Proof.
intros.
subst mid'.
apply sublist_rejoin; auto.
Qed.

Hint Rewrite @sublist_nil' using list_solve: sublist.
Hint Rewrite @app_nil_l : sublist.
Hint Rewrite @Zlength_rev : sublist.
Hint Rewrite @sublist_rejoin' using list_solve : sublist.

Lemma subsub1:
 forall a b : Z, (a-(a-b)) = b.
Proof.  intros. omega. Qed.
Hint Rewrite subsub1 : sublist.

Lemma sublist_app':
  forall {A} lo hi (al bl: list A),
  0 <= lo <= Zlength al ->
  0 <= hi-Zlength al <= Zlength bl ->
  sublist lo hi (al++bl) =
  sublist lo (Zlength al) al ++
  sublist 0 (hi-Zlength al) bl.
Proof.
intros.
unfold sublist.
simpl.
rewrite Zskipn_app1 by omega.
rewrite Zfirstn_app2
 by (rewrite Zlength_skipn, Z.max_r;
      rewrite ?Z.max_r; omega).
rewrite Zlength_skipn, Z.max_r;
      rewrite ?Z.max_r; try omega.
rewrite (Zfirstn_exact_length (Zlength al - lo))
 by (rewrite Zlength_skipn, Z.max_r;
      rewrite ?Z.max_r; omega).
f_equal.
f_equal.
f_equal.
omega.
Qed.

Lemma upd_Znth_Zlength {A} i (l:list A) v: 0<=i < Zlength l ->
      Zlength (upd_Znth i l v) = Zlength l.
Proof. intros.
   unfold upd_Znth. rewrite Zlength_app, Zlength_cons; simpl.
  repeat rewrite Zlength_sublist; simpl; omega.
Qed.

Lemma upd_Znth_map {A B} (f:A -> B) i l v:
      upd_Znth i (map f l) (f v) =
      map f (upd_Znth i l v).
Proof. unfold upd_Znth; intros. rewrite map_app, Zlength_map.
  do 2 rewrite sublist_map; trivial.
Qed.

Lemma upd_Znth_lookup K {A}: forall l (L:Zlength l = K) i j d (v:A) (I: 0<=i<K) (J: 0<=j<K),
   (i=j /\ Znth i (upd_Znth j l v) d = v) \/
   (i<>j /\ Znth i (upd_Znth j l v) d = Znth i l d).
Proof.
  intros. unfold upd_Znth.
  destruct (zeq i j); subst.
  + left; split; trivial.
    rewrite app_Znth2; rewrite Zlength_sublist; try rewrite Zminus_0_r; try rewrite Zminus_diag; try omega.
    rewrite Znth_0_cons. trivial.
  + right; split; trivial.
    destruct (zlt i j).
    - rewrite app_Znth1; try rewrite Zlength_sublist; try omega.
      rewrite Znth_sublist; try omega. rewrite Zplus_0_r; trivial.
    - rewrite app_Znth2; rewrite Zlength_sublist; try omega.
      rewrite Zminus_0_r, Znth_pos_cons, Znth_sublist; try omega.
      assert (H: i - j - 1 + (j + 1) = i) by omega. rewrite H; trivial.
Qed.

Lemma upd_Znth_lookup' K {A}: forall l (L:Zlength l = K) i (I: 0<=i<K) j (J: 0<=j<K) d (v:A),
    Znth i (upd_Znth j l v) d = if zeq i j then v else Znth i l d.
Proof. intros.
  destruct (upd_Znth_lookup K l L i j d v I J) as [[X Y] | [X Y]]; if_tac; try omega; trivial.
Qed.

Lemma upd_Znth_char {A} n l1 (v:A) l2 w: Zlength l1=n ->
      upd_Znth n (l1 ++ v :: l2) w = l1 ++ w :: l2.
Proof. intros. unfold upd_Znth.
  specialize (Zlength_nonneg l1); intros.
  f_equal. rewrite sublist0_app1. apply sublist_same; omega. omega.
  f_equal. rewrite sublist_app2, <- H, Zlength_app, Zlength_cons. do 2 rewrite Zminus_plus.
                rewrite sublist_1_cons. apply sublist_same; omega. omega.
Qed.

Lemma upd_Znth_same {A}: forall i l u (d:A), 0<= i< Zlength l -> Znth i (upd_Znth i l u) d = u.
Proof.
  intros. rewrite (upd_Znth_lookup' _ _ (eq_refl _)); trivial.
  rewrite zeq_true; trivial.
Qed.

Lemma upd_Znth_diff {A}: forall i j l u (d:A), 0<= i< Zlength l -> 0<= j< Zlength l -> i<>j ->
      Znth i (upd_Znth j l u) d = Znth i l d.
Proof.
  intros. rewrite (upd_Znth_lookup' _ _ (eq_refl _)); trivial.
  rewrite zeq_false; trivial.
Qed.

Lemma upd_Znth_app1 {A} i l1 l2 (I: 0 <= i < Zlength l1) (v:A):
      upd_Znth i (l1++l2) v = upd_Znth i l1 v ++ l2.
Proof.
  assert (L2NN:= Zlength_nonneg l2).
  unfold upd_Znth.
  rewrite sublist_app1, Zlength_app, <- app_assoc; try omega.
  f_equal. simpl. f_equal.
  rewrite <- (sublist_rejoin (i+1) (Zlength l1)); try omega.
  rewrite sublist_app1; try omega. f_equal.
  rewrite sublist_app2, Zminus_diag, Zminus_plus; try omega.
  apply sublist_same; trivial.
  rewrite Zlength_app; omega.
Qed.

Lemma upd_Znth_app2 {A} (l1 l2:list A) i v:
  Zlength l1 <= i <= Zlength l1 + Zlength l2 ->
  upd_Znth i (l1 ++ l2) v = l1 ++ upd_Znth (i-Zlength l1) l2 v.
Proof. unfold upd_Znth. intros.
  rewrite sublist0_app2; trivial. rewrite <- app_assoc. f_equal. f_equal. f_equal.
  rewrite sublist_app2, Zlength_app, Zminus_plus.
  assert (i + 1 - Zlength l1 = i - Zlength l1 + 1) by omega. rewrite H0; trivial.
  specialize (Zlength_nonneg l1); omega.
Qed.

Lemma upd_Znth0 {A} (l:list A) v:
upd_Znth 0 l v = v :: sublist 1 (Zlength l) l.
Proof. unfold upd_Znth. rewrite sublist_nil. reflexivity. Qed.

Lemma sublist_upd_Znth_l: forall {A} (l: list A) i lo hi v,
  0 <= lo <= hi ->
  hi <= i < Zlength l ->
  sublist lo hi (upd_Znth i l v) = sublist lo hi l.
Proof.
  intros.
  unfold upd_Znth.
  rewrite sublist_app1.
  2: omega.
  2: rewrite Zlength_sublist by omega; omega.
  rewrite sublist_sublist by omega.
  f_equal; omega.
Qed.

Lemma sublist_upd_Znth_r: forall {A} (l: list A) i lo hi v,
  0 <= i < lo ->
  lo <= hi <= Zlength l ->
  sublist lo hi (upd_Znth i l v) = sublist lo hi l.
Proof.
  intros.
  unfold upd_Znth.
  replace (sublist 0 i l ++ v :: sublist (i + 1) (Zlength l) l) with
    ((sublist 0 i l ++ v :: nil) ++ sublist (i + 1) (Zlength l) l)
    by (rewrite <- app_assoc; auto).
  rewrite sublist_app2.
  2: rewrite Zlength_app, Zlength_sublist, Zlength_correct by omega; simpl; omega.
  rewrite Zlength_app, Zlength_sublist, Zlength_correct by omega; simpl.
  rewrite sublist_sublist by omega.
  f_equal; omega.
Qed.

Lemma sublist_upd_Znth_lr: forall {A} (l: list A) i lo hi v,
  0 <= lo <= i->
  i < hi <= Zlength l ->
  sublist lo hi (upd_Znth i l v) = upd_Znth (i - lo) (sublist lo hi l) v.
Proof.
  intros.
  unfold upd_Znth.
  change (v :: sublist (i + 1) (Zlength l) l) with
    ((v :: nil) ++ sublist (i + 1) (Zlength l) l).
  rewrite !sublist_app'.
  2: change (Zlength [v]) with 1; omega.
  2: change (Zlength [v]) with 1; rewrite !Zlength_sublist by omega; omega.
  2: rewrite !Zlength_sublist by omega; omega.
  2: rewrite Zlength_app, !Zlength_sublist by omega; change (Zlength [v]) with 1; omega.
  rewrite !Zlength_sublist by omega.
  change (Zlength [v]) with 1.
  rewrite sublist_len_1 with (d := v) by (change (Zlength [v]) with 1; omega).
  change (Znth 0 [v] v) with v.
  simpl.
  rewrite !sublist_sublist by omega.
  f_equal; [| f_equal]; f_equal; omega.
Qed.

(*Hint Rewrite @Zlength_list_repeat'  : sublist.*)
Hint Rewrite @Znth_list_repeat_inrange : sublist.
Hint Rewrite @Zlength_cons @Zlength_nil: sublist.
Hint Rewrite @list_repeat_0: sublist.
Hint Rewrite <- @app_nil_end : sublist.
Hint Rewrite @Zlength_app: sublist.
Hint Rewrite @Zlength_map: sublist.
Hint Rewrite @Zlength_list_repeat using list_solve: sublist.
Hint Rewrite Z.sub_0_r Z.add_0_l Z.add_0_r : sublist.
Hint Rewrite @Zlength_sublist using list_solve: sublist.
Hint Rewrite Z.max_r Z.max_l using omega : sublist.
Hint Rewrite Z.min_r Z.min_l using omega : sublist.
Hint Rewrite Z.add_simpl_r Z.sub_add Z.sub_diag : sublist.
Hint Rewrite @sublist_sublist using list_solve : sublist.
Hint Rewrite @sublist_app1 using list_solve : sublist.
Hint Rewrite @sublist_app2 using list_solve : sublist.
Hint Rewrite @sublist_list_repeat  using list_solve : sublist.
Hint Rewrite @sublist_same using list_solve : sublist.
Hint Rewrite Z.add_simpl_l : sublist.
Hint Rewrite Z.add_add_simpl_l_l Z.add_add_simpl_l_r
     Z.add_add_simpl_r_l Z.add_add_simpl_r_r : sublist.
Hint Rewrite Z.add_0_r : sublist.
Hint Rewrite @app_Znth1 using list_solve : sublist.
Hint Rewrite @app_Znth2 using list_solve : sublist.
Hint Rewrite @Znth_sublist using list_solve : sublist.
Hint Rewrite @upd_Znth_Zlength using list_solve : sublist.

Hint Rewrite @sublist_nil : sublist.

Lemma list_repeat_app':
 forall {A: Type} a b (x:A),
    0 <= a -> 0 <= b ->
    list_repeat (Z.to_nat a) x ++ list_repeat (Z.to_nat b) x = list_repeat (Z.to_nat (a+b)) x.
Proof.
 intros.
 rewrite list_repeat_app. f_equal.
  apply Nat2Z.inj. rewrite <- Z2Nat.inj_add; auto.
Qed.

Lemma Znth_overflow:
  forall {A} i (al: list A) d, i >= Zlength al -> Znth i al d = d.
Proof.
intros.
  pose proof (Zlength_nonneg al).
   unfold Znth. rewrite if_false by omega.
  apply nth_overflow.
  apply Nat2Z.inj_le. rewrite <- Zlength_correct.
  rewrite Z2Nat.id by omega. omega.
Qed.

Lemma Znth_underflow:
  forall {A} i (al: list A) d,  i < 0 -> Znth i al d = d.
Proof.
intros.
   unfold Znth. rewrite if_true by omega. auto.
Qed.

Lemma Znth_outofbounds:
  forall {A} i (al: list A) d,  (i < 0 \/ i >= Zlength al) -> Znth i al d = d.
Proof.
intros.
  destruct H. apply Znth_underflow; auto. apply Znth_overflow; auto.
Qed.

Lemma sublist_one:
  forall {A} lo hi (al: list A) d,
    0 <= lo -> hi <= Zlength al ->
    lo+1=hi -> sublist lo hi al = Znth lo al d :: nil.
Proof.
intros.
subst.
rewrite Znth_cons_sublist by omega. rewrite <- app_nil_end.
auto.
Qed.

Lemma Forall_app :
forall {A} P (l1 l2 :list A),
Forall P (l1 ++ l2) <->
Forall P l1 /\ Forall P l2.
intros.
split; induction l1; intros.
inv H. destruct l2; inv H0. auto.
split. auto. simpl in H2. inv H2.
constructor; auto.
split. inv H. constructor; auto. apply IHl1 in H3.
intuition.
inv H. apply IHl1 in H3. intuition.
simpl. intuition.
simpl. constructor.
destruct H. inv H. auto.
apply IHl1. intuition.
inv H0; auto.
Qed.

Lemma Forall_firstn:
  forall A (f: A -> Prop) n l, Forall f l -> Forall f (firstn n l).
Proof.
induction n; destruct l; intros.
constructor. constructor. constructor.
inv H. simpl. constructor; auto.
Qed.

Lemma Forall_skipn:
  forall A (f: A -> Prop) n l, Forall f l -> Forall f (skipn n l).
Proof.
induction n; destruct l; intros.
constructor. inv H; constructor; auto. constructor.
inv H. simpl.  auto.
Qed.

Lemma Forall_map:
  forall {A B} (f: B -> Prop) (g: A -> B) al,
   Forall f (map g al) <-> Forall (Basics.compose f g) al.
Proof.
intros.
induction al; simpl; intuition; inv H1; constructor; intuition.
Qed.

Lemma Forall_sublist:
  forall {A} (f: A -> Prop) lo hi al,
   Forall f al -> Forall f (sublist lo hi al).
Proof.
intros. unfold sublist.
apply Forall_firstn. apply Forall_skipn. auto.
Qed.