(* ---------------------------------------------------------------------
   This file contains definitions and proof scripts related to
   (i) closure operations for context-free grammars,
   (ii) context-free grammars simplification
   (iii) context-free grammar Chomsky normalization and
   (iv) pumping lemma for context-free languages.

   More information can be found in the paper "Formalization of the
   Pumping Lemma for Context-Free Languages", submitted to JFR.

   Marcus Vinícius Midena Ramos
   mvmramos@gmail.com
   --------------------------------------------------------------------- *)

Require Import List.
Require Import Ring.
Require Import Omega.
Require Import NPeano.

Require Import misc_arith.
Require Import misc_list.
Require Import cfg.
Require Import cfl.
Require Import inaccessible.
Require Import useless.
Require Import unitrules.
Require Import emptyrules.
Require Import simplification.
Require Import trees.
Require Import allrules.
Require Import chomsky.
Require Import pigeon.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

Import ListNotations.
Open Scope list_scope.

(* --------------------------------------------------------------------- *)
(* PUMPING LEMMA                                                         *)
(* --------------------------------------------------------------------- *)

Section Pumping.

Variable non_terminal terminal: Type.
Notation sentence:= (list terminal).

Lemma pumping_aux:
forall g: cfg _ _,
forall t1 t2: btree (non_terminal' non_terminal terminal) _,
forall n: _,
forall c1 c2: list bool,
forall v x: sentence,
btree_decompose t1 c1 = Some (v, t2, x) ->
btree_cnf g t1 ->
broot t1 = n ->
bcode t1 (c1 ++ c2) ->
c1 <> [] ->
broot t2 = n ->
bcode t2 c2 ->
(forall i: nat,
 exists t': btree _ _,
 btree_cnf g t' /\
 broot t' = n /\
 btree_decompose t' (iter c1 i) = Some (iter v i, t2, iter x i) /\
 bcode t' (iter c1 i ++ c2) /\
 get_nt_btree (iter c1 i) t' = Some n).
Proof.
induction i.
- exists t2.
  simpl.
  split.
  + apply btree_cnf_subtree with (t2:= t2) in H0.
    * exact H0.
    * {
      apply btree_decompose_subtree_bcode in H.
      - apply subtree_bcode_subtree in H.
        exact H.
      - exact H3.
      }
  + split.
    * exact H4.
    * {
      split.
      - rewrite btree_decompose_empty.
        reflexivity.
      - split.
        + exact H5.
        + destruct t2.
          * simpl in H4.
            subst.
            reflexivity.
          * simpl in H4.
            subst.
            reflexivity.
      }
- destruct IHi as [t' [H10 [H11 [H12 [H13 H14]]]]].
  assert (H15: exists t'': btree _ _, btree_subst t' t1 (iter c1 i) = Some t'').
    {
    apply bcode_btree_subst with (c2:= c2).
    exact H13.
    }
  destruct H15 as [t'' H15].
  exists t''.
  split.
  + apply btree_subst_preserves_cnf with (g:= g) (c1':= c2) in H15.
    * exact H15.
    * exact H10.
    * exact H13.
    * exact H0.
    * congruence.
  + split.
    * {
      apply btree_subst_preserves_broot_v1 in H15.
      - congruence.
      - congruence.
      }
    * {
      split.
      - apply btree_subst_decompose with (t2:= t2) (x:= iter v i) (y:= iter x i) in H15.
        + simpl.
          repeat rewrite iter_comm.
          replace (iter x i ++ x) with (x ++ iter x i).
          * {
            apply btree_decompose_combine with (t1:= t1).
            - exact H15.
            - exact H.
            }
          * rewrite iter_comm.
            reflexivity.
        + exact H12.
      - split.
        + apply btree_subst_bcode with (c1':= c2) (c2:= c1 ++ c2) in H15.
          * simpl.
            rewrite iter_comm.
            rewrite <- app_assoc.
            exact H15.
          * exact H13.
          * exact H2.
        + simpl.
            rewrite iter_comm.
            {
            apply btree_subst_get_nt with (c1':= c2) (c2:= c1) (c2':= c2) (n:= n) in H15.
            - exact H15.
            - exact H13.
            - exact H2.
            - apply btree_decompose_get_nt in H.
              congruence.
            }
      }
Qed.

End Pumping.

Section Pumping_2.

Variable terminal: Type.
Notation sentence:= (list terminal).

Theorem pumping_lemma:
forall l: lang terminal,
(contains_empty l \/ ~ contains_empty l) /\ (contains_non_empty l \/ ~ contains_non_empty l) ->
cfl l ->
exists n: nat,
forall s: sentence,
l s ->
length s >= n ->
exists u v w x y: sentence,
s = u ++ v ++ w ++ x ++ y /\
length (v ++ x) >= 1 /\
length (u ++ y) >= 1 /\
length (v ++ w ++ x) <= n /\
forall i: nat, l (u ++ (iter v i) ++ w ++ (iter x i) ++ y).
Proof.
intros l H1 H2.
inversion H2 as [non_terminal H3].
clear H2.
destruct H3 as [g H3].
(* Find g' in CNF *)
assert (H2: exists g': cfg (chomsky.non_terminal' (emptyrules.non_terminal' non_terminal) terminal) terminal, (g_equiv g' g) /\ (is_cnf g' \/ is_cnf_with_empty_rule g') /\ start_symbol_not_in_rhs g').
  {
  apply g_cnf_exists.
  destruct H1 as [H1 H2].
  split.
  - destruct H1 as [H1 | H1].
    + left.
      specialize (H3 []).
      destruct H3 as [H3 _].
      apply H3.
      exact H1.
    + right.
      intros H4.
      apply H1.
      specialize (H3 []).
      destruct H3 as [_ H3].
      apply H3.
      exact H4.
  - destruct H2 as [H2 | H2].
    + left.
      destruct H2 as [w [H2 H4]].
      specialize (H3 w).
      destruct H3 as [H3 _].
      exists w.
      split.
      * apply H3.
        exact H2.
      * exact H4.
    + right.
      intros H4.
      apply H2.
      destruct H4 as [w [H4 H5]].
      specialize (H3 w).
      destruct H3 as [_ H3].
      exists w.
      split.
      * apply H3.
        exact H4.
      * exact H5.
  }
destruct H2 as [g' [H2 H4]].
(* Change g for g' *)
apply lang_eq_change_g with (non_terminal':= chomsky.non_terminal' (emptyrules.non_terminal' non_terminal) terminal) (g':= g') in H3.
- assert (H3':= H3).
  assert (H3copy:= H3).
  destruct (rules_finite g') as [n' [ntl' [tl' H5]]].
  assert (H5':= H5).
  (* exists n *)
  exists (2 ^ (length ntl')).
  intros s H6 H7.
  specialize (H3 s).
  destruct H3 as [H3 _].
  specialize (H3 H6).
  assert (H6':= H6).
  unfold lang_of_g in H3.
  destruct H4 as [H4 H4'].
  assert (H4copy:= H4).
  unfold produces, generates in H3.
  (* Find btree *)
  apply derives_g_cnf_equiv_btree_v4 with (n:= start_symbol g') (s:= s) in H4.
  + destruct H4 as [t [H4 [H8 H9]]].
    clear g H1 H2 H3 H5 H6.
    apply length_ge with (t:= t) in H7.
    assert (HHH:= H7).
    * (* Find bpath *)
      {
      apply btree_exists_bpath with (ntl:= ntl') in H7.
      - destruct H7 as [z [H20 [H21 [m [r [t0 [H22 [H23 [H24 H25]]]]]]]]].
        assert (H26: forall s, In s r -> In s (map inl ntl')).
          {
          intros s0 H27.
          specialize (H25 s0).
          apply H25.
          apply in_or_app.
          right.
          exact H27.
          }
        clear H25.
        assert (H27: exists r': list (non_terminal' (emptyrules.non_terminal' non_terminal) terminal), r = map inl r').
          {
          exists (get_As _ _ r).
          apply get_As_correct.
          intros e H28.
          specialize (H26 e H28).
          apply in_split in H26.
          destruct H26 as [l1 [l2 H26]].
          symmetry in H26.
          apply map_expand in H26.
          destruct H26 as [s1' [s2' [_ [_ H26]]]].
          symmetry in H26.
          change (e :: l2) with ([e] ++ l2) in H26.
          apply map_expand in H26.
          destruct H26 as [s1'0 [s2'0 [_ [H26 _]]]].
          destruct s1'0.
          - simpl in H26.
            inversion H26.
          - simpl in H26.
            inversion H26.
            exists n.
            reflexivity.
          }
        destruct H27 as [r' H27].
        assert (H28: length r' = length r).
          {
          rewrite H27.
          rewrite map_length.
          reflexivity.
          }
        assert (H24':= H24).
        rewrite <- H28 in H24.
        rewrite H27 in H26.
        assert (H29: forall n: non_terminal' (emptyrules.non_terminal' non_terminal) terminal, In n r' -> In n ntl').
          {
          intros n H99.
          assert (H29: In (inl n) (map (@inl _ terminal) r')).
            {
            apply in_map.
            exact H99.
            }
          specialize (H26 (inl n) H29).
          apply in_split in H26.
          destruct H26 as [l1 [l2 H26]].
          symmetry in H26.
          apply map_expand in H26.
          destruct H26 as [s1' [s2' [H40 [H41 H42]]]].
          symmetry in H42.
          change (inl n :: l2) with ([inl n] ++ l2) in H42.
          apply map_expand in H42.
          destruct H42 as [s1'0 [s2'0 [H42 [H43 H44]]]].
          destruct s1'0.
          - simpl in H43.
            inversion H43.
          - simpl in H43.
            inversion H43.
            subst.
            apply in_or_app.
            right.
            simpl.
            left.
            reflexivity.
          }
        apply pigeon in H29.
        + destruct H29 as [n [r1' [r2' [r3' H29]]]].
          rewrite H29 in H27.
          repeat rewrite map_app in H27.
          (* Prepare path *)
          assert (Hpath:= H22).
          rewrite H27 in Hpath.
          repeat rewrite <- app_assoc in Hpath.
          assert (H20copy:= H20).
          rewrite Hpath in H20copy.
          apply bpath_insert_head in H20copy.
          * destruct H20copy as [p12' H20copy].
            rewrite app_assoc in Hpath.
            rewrite <- H20copy in Hpath.
            rewrite <- app_assoc in Hpath.
            (* Find subtrees and u, v, w, x, y *)
            apply bpath_exists_bcode in H20.
            destruct H20 as [c [H100 H101]].
            rewrite Hpath in H101.
            rewrite app_assoc in H101.
            assert (H101copy:= H101).
            {
            apply bcode_split in H101.
            - destruct H101 as [c1 [c2 [H101 [H102 [t1 [u [y [H104 [H105 H106]]]]]]]]].
              assert (H105copy:= H105).
              assert (Ht:= H105).
              apply btree_decompose_bfrontier in H105.
              destruct H105 as [Ht_a Ht_b].
              assert (Hc1: c1 <> []).
                {
                simpl in H102.
                assert (length c1 > 0) by omega.
                apply length_not_zero in H.
                apply not_eq_sym.
                exact H.
                }
              specialize (Ht_b Hc1).
              assert (Ht_c: subtree_bcode t t1 c1).
                {
                apply btree_decompose_subtree_bcode in H105copy.
                - exact H105copy.
                - exact Hc1.
                }
              rewrite app_assoc in H104.
              assert (H104copy:= H104).
              apply bcode_split in H104.
              + destruct H104 as [c3 [c4 [H104 [H107 [t2 [v [x [H109 [H110 H111]]]]]]]]].
                assert (H110copy:= H110).
                assert (Ht1:= H110).
                apply btree_decompose_bfrontier in H110.
                destruct H110 as [Ht1_a Ht1_b].
                assert (Hc3: c3 <> []).
                  {
                  simpl in H107.
                  assert (length c3 > 0) by omega.
                  apply length_not_zero in H.
                  apply not_eq_sym.
                  exact H.
                  }
                specialize (Ht1_b Hc3).
                assert (Ht1_c: subtree_bcode t1 t2 c3).
                  {
                  apply btree_decompose_subtree_bcode in H110copy.
                  - exact H110copy.
                  - exact Hc3.
                  }
                remember (bfrontier t2) as w.
                (* Find roots *)
                assert (Hroot_t1: broot t1 = n).
                  {
                  apply bpath_bcode_split in H104copy.
                  destruct H104copy as [H104copy _].
                  apply bpath_broot with (d:= inl (broot t1)) in H104copy.
                  simpl in H104copy.
                  inversion H104copy.
                  reflexivity.
                  }
                assert (Hroot_t2: broot t2 = n).
                  {
                  apply bpath_bcode_split in H109.
                  destruct H109 as [H109 _].
                  apply bpath_broot with (d:= inl (broot t2)) in H109.
                  simpl in H109.
                  inversion H109.
                  reflexivity.
                  }
                (* Find heights *)
                remember (length ntl') as k.
                assert (H114: bheight t1 <= k + 1 /\ bheight t1 >= 2).
                  {
                  split.
                  - rewrite H106.
                    rewrite H27 in H24'.
                    repeat rewrite app_length in H24'.
                    repeat rewrite app_length.
                    simpl in H24'.
                    simpl.
                    omega.
                  - rewrite H106.
                    rewrite H27 in H24'.
                    repeat rewrite app_length in H24'.
                    repeat rewrite app_length.
                    simpl in H24'.
                    simpl.
                    omega.
                  }
                assert (H115: bheight t2 <= k /\ bheight t2 >= 1).
                  {
                  split.
                  - rewrite H111.
                    rewrite H27 in H24'.
                    repeat rewrite app_length in H24'.
                    repeat rewrite app_length.
                    simpl in H24'.
                    simpl.
                    omega.
                  - rewrite H111.
                    rewrite H27 in H24'.
                    repeat rewrite app_length in H24'.
                    repeat rewrite app_length.
                    simpl in H24'.
                    simpl.
                    omega.
                  }
                (* Exists u, v, w, x, y *)
                exists u, v, w, x, y.
                split.
                * (* s = u ++ v ++ w ++ x ++ y *)
                  rewrite <- H9.
                  rewrite Ht_a.
                  rewrite Ht1_a.
                  repeat rewrite <- app_assoc.
                  reflexivity.
                * {
                  split.
                  - (* length (v ++ x) >= 1 *)
                    apply length_not_zero_inv in Ht1_b.
                    omega.
                  - split.
                    + (* length (u ++ y) >= 1 *)
                      apply length_not_zero_inv in Ht_b.
                      omega.
                    + split.
                      * (* length (v ++ w ++ x) <= 2 ^ k *)
                        destruct H114 as [H114 H116].
                        apply bheight_le in H114.
                        rewrite Ht1_a in H114.
                        {
                        replace (k + 1 - 1) with k in H114.
                        - exact H114.
                        - omega.
                        }
                      * (* uv^iwx^iy *)
                        intros i.
                        assert (Ht': exists t': btree _ _,
                                     btree_cnf g' t' /\
                                     broot t' = n /\
                                     btree_decompose t' (iter c3 i) = Some (iter v i, t2, iter x i) /\
                                     bcode t' (iter c3 i ++ c4) /\
                                     get_nt_btree (iter c3 i) t' = Some n).
                          {
                          apply pumping_aux with (g:= g') (t1:= t1) (t2:= t2) (n:= n) (c1:= c3) (c2:= c4) (v:= v) (x:= x) (i:= i).
                          - exact Ht1.
                          - apply subtree_bcode_subtree in Ht_c.
                            apply btree_cnf_subtree with (g:= g') in Ht_c.
                            + exact Ht_c.
                            + exact H4.
                          - exact Hroot_t1.
                          - rewrite <- H104.
                            apply bpath_bcode_split in H104copy.
                            apply H104copy.
                          - exact Hc3.
                          - congruence.
                          - apply bpath_bcode_split in H109.
                            apply H109.
                          }
                        destruct Ht' as [t' [Ht'_1 [Ht'_2 [Ht'_3 Ht'_4]]]].
                        assert (Ht'': exists t'': btree _ _, btree_subst t t' c1 = Some t'').
                          {
                          rewrite H101 in H100.
                          apply bcode_btree_subst with (t2:= t') in H100.
                          destruct H100 as [t'' H100].
                          exists t''.
                          exact H100.
                          }
                        destruct Ht'' as [t'' Ht''].
                        assert (Ht''_1: broot t'' = start_symbol g').
                          {
                          apply btree_subst_preserves_broot_v2 in Ht''.
                          - congruence.
                          - exact Hc1.
                          }
                        assert (Ht''_2: bfrontier t'' = u ++ iter v i ++ w ++ iter x i ++ y).
                          {
                          apply btree_subst_bfrontier with (t2:= t1) (x:= u) (y:= y) in Ht''.
                          - apply btree_decompose_bfrontier in Ht'_3.
                            destruct Ht'_3 as [Ht'_3 _].
                            rewrite Ht'_3 in Ht''.
                            rewrite Heqw.
                            repeat rewrite <- app_assoc in Ht''.
                            exact Ht''.
                          - exact Ht_c.
                          - exact Ht.
                          }
                        assert (Ht''_3: btree_cnf g' t'').
                          {
                          apply btree_subst_preserves_cnf with (g:= g') (c1':= c3 ++ c4) in Ht''.
                          - exact Ht''.
                          - exact H4.
                          - rewrite <- H104.
                            rewrite <- H101.
                            exact H100.
                          - exact Ht'_1.
                          - apply btree_decompose_get_nt in Ht.
                            congruence.
                          }
                        {
                        apply btree_equiv_produces_g_cnf in Ht''_3.
                        - unfold lang_eq in H3'.
                          specialize (H3' (u ++ iter v i ++ w ++ iter x i ++ y)).
                          destruct H3' as [_ H3'].
                          unfold lang_of_g in H3'.
                          apply H3'.
                          rewrite <- Ht''_2.
                          exact Ht''_3.
                        - congruence.
                        }
                  }
              + rewrite app_length.
                simpl.
                omega.
              + repeat rewrite app_length.
                simpl.
                omega.
              + rewrite H106.
                repeat rewrite app_length.
                reflexivity.
            - rewrite app_length.
              simpl.
              omega.
            - repeat rewrite app_length.
              simpl.
              omega.
            - rewrite Hpath in H21.
              repeat rewrite app_length in H21.
              repeat rewrite app_length.
              omega.
            }
          * rewrite H8.
            {
            apply start_symbol_only_once with (g:= g') (t:= t) (p1:= m ++ map inl r1') (p2:= map inl r2') (p3:= map inl r3' ++ [inr t0]).
            - exact H4'.
            - exact H4.
            - repeat rewrite <- app_assoc.
              exact H20copy.
            }
        + apply (nt_eqdec g').
        + rewrite H28.
          exact H24'.
      - apply cnf_bnts with (g:= g') (n:= n') (tl:= tl').
        + exact H5'.
        + exact H4.
      }
    * exact H9.
  + assert (Hntl': 2 ^ length ntl' > 0).
      {
      apply pow_2_gt_0.
      }
    assert (Hs: length s > 0) by omega.
    apply length_not_zero in Hs.
    apply not_eq_sym.
    exact Hs.
  + exact H4'.
  + exact H3.
- exact H2.
Qed.

Theorem pumping_lemma_v2:
forall l: lang terminal,
(contains_empty l \/ ~ contains_empty l) /\ (contains_non_empty l \/ ~ contains_non_empty l) ->
cfl l ->
exists n: nat,
forall s: sentence,
l s ->
length s >= n ->
exists u v w x y: sentence,
s = u ++ v ++ w ++ x ++ y /\
length (v ++ x) >= 1 /\
length (v ++ w ++ x) <= (n - 1) * 2 /\
forall i: nat, l (u ++ (iter v i) ++ w ++ (iter x i) ++ y).
Proof.
intros l H1 H2.
inversion H2 as [non_terminal H3].
clear H2.
destruct H3 as [g H3].
(* Find g' in CNF *)
assert (H2: exists g': cfg (chomsky.non_terminal' (emptyrules.non_terminal' non_terminal) terminal) terminal, (g_equiv g' g) /\ (is_cnf g' \/ is_cnf_with_empty_rule g') /\ start_symbol_not_in_rhs g').
  {
  apply g_cnf_exists.
  destruct H1 as [H1 H2].
  split.
  - destruct H1 as [H1 | H1].
    + left.
      specialize (H3 []).
      destruct H3 as [H3 _].
      apply H3.
      exact H1.
    + right.
      intros H4.
      apply H1.
      specialize (H3 []).
      destruct H3 as [_ H3].
      apply H3.
      exact H4.
  - destruct H2 as [H2 | H2].
    + left.
      destruct H2 as [w [H2 H4]].
      specialize (H3 w).
      destruct H3 as [H3 _].
      exists w.
      split.
      * apply H3.
        exact H2.
      * exact H4.
    + right.
      intros H4.
      apply H2.
      destruct H4 as [w [H4 H5]].
      specialize (H3 w).
      destruct H3 as [_ H3].
      exists w.
      split.
      * apply H3.
        exact H4.
      * exact H5.
  }
destruct H2 as [g' [H2 H4]].
(* Change g for g' *)
apply lang_eq_change_g with (non_terminal':= chomsky.non_terminal' (emptyrules.non_terminal' non_terminal) terminal) (g':= g') in H3.
- assert (H3':= H3).
  assert (H3copy:= H3).
  destruct (rules_finite g') as [n' [ntl' [tl' H5]]].
  assert (H5':= H5).
  assert (H5'':= H5).
  (* exists n *)
  exists (2 ^ ((length ntl') - 1) + 1).
  intros s H6 H7.
  specialize (H3 s).
  destruct H3 as [H3 _].
  specialize (H3 H6).
  assert (H6':= H6).
  unfold lang_of_g in H3.
  destruct H4 as [H4 H4'].
  assert (H4copy:= H4).
  unfold produces, generates in H3.
  (* Find btree *)
  apply derives_g_cnf_equiv_btree_v4 with (n:= start_symbol g') (s:= s) in H4.
  + destruct H4 as [t [H4 [H8 H9]]].
    clear g H1 H2 H3 H5 H6.
    apply length_ge_v2 with (t:= t) in H7.
    assert (HHH:= H7).
    * (* Find bpath *)
      {
      apply btree_exists_bpath with (ntl:= ntl') in H7.
      - destruct H7 as [z [H20 [H21 [m [r [t0 [H22 [H23 [H24 H25]]]]]]]]].
        assert (H26: forall s, In s r -> In s (map inl ntl')).
          {
          intros s0 H27.
          specialize (H25 s0).
          apply H25.
          apply in_or_app.
          right.
          exact H27.
          }
        clear H25.
        assert (H27: exists r': list (non_terminal' (emptyrules.non_terminal' non_terminal) terminal), r = map inl r').
          {
          exists (get_As _ _ r).
          apply get_As_correct.
          intros e H28.
          specialize (H26 e H28).
          apply in_split in H26.
          destruct H26 as [l1 [l2 H26]].
          symmetry in H26.
          apply map_expand in H26.
          destruct H26 as [s1' [s2' [_ [_ H26]]]].
          symmetry in H26.
          change (e :: l2) with ([e] ++ l2) in H26.
          apply map_expand in H26.
          destruct H26 as [s1'0 [s2'0 [_ [H26 _]]]].
          destruct s1'0.
          - simpl in H26.
            inversion H26.
          - simpl in H26.
            inversion H26.
            exists n.
            reflexivity.
          }
        destruct H27 as [r' H27].
        assert (H28: length r' = length r).
          {
          rewrite H27.
          rewrite map_length.
          reflexivity.
          }
        assert (H24':= H24).
        rewrite <- H28 in H24.
        rewrite H27 in H26.
        assert (H29: forall n: non_terminal' (emptyrules.non_terminal' non_terminal) terminal, In n r' -> In n ntl').
          {
          intros n H99.
          assert (H29: In (inl n) (map (@inl _ terminal) r')).
            {
            apply in_map.
            exact H99.
            }
          specialize (H26 (inl n) H29).
          apply in_split in H26.
          destruct H26 as [l1 [l2 H26]].
          symmetry in H26.
          apply map_expand in H26.
          destruct H26 as [s1' [s2' [H40 [H41 H42]]]].
          symmetry in H42.
          change (inl n :: l2) with ([inl n] ++ l2) in H42.
          apply map_expand in H42.
          destruct H42 as [s1'0 [s2'0 [H42 [H43 H44]]]].
          destruct s1'0.
          - simpl in H43.
            inversion H43.
          - simpl in H43.
            inversion H43.
            subst.
            apply in_or_app.
            right.
            simpl.
            left.
            reflexivity.
          }
        apply pigeon in H29.
        + destruct H29 as [n [r1' [r2' [r3' H29]]]].
          rewrite H29 in H27.
          repeat rewrite map_app in H27.
          (* Prepare path *)
          assert (Hpath:= H22).
          rewrite H27 in Hpath.
          repeat rewrite <- app_assoc in Hpath.
          assert (H20copy:= H20).
          rewrite Hpath in H20copy.
          apply bpath_insert_head in H20copy.
          * destruct H20copy as [p12' H20copy].
            rewrite app_assoc in Hpath.
            rewrite <- H20copy in Hpath.
            rewrite <- app_assoc in Hpath.
            (* Find subtrees and u, v, w, x, y *)
            apply bpath_exists_bcode in H20.
            destruct H20 as [c [H100 H101]].
            rewrite Hpath in H101.
            rewrite app_assoc in H101.
            assert (H101copy:= H101).
            {
            apply bcode_split in H101.
            - destruct H101 as [c1 [c2 [H101 [H102 [t1 [u [y [H104 [H105 H106]]]]]]]]].
              assert (H105copy:= H105).
              assert (Ht:= H105).
              apply btree_decompose_bfrontier in H105.
              destruct H105 as [Ht_a Ht_b].
              assert (Hc1: c1 <> []).
                {
                simpl in H102.
                assert (length c1 > 0) by omega.
                apply length_not_zero in H.
                apply not_eq_sym.
                exact H.
                }
              specialize (Ht_b Hc1).
              assert (Ht_c: subtree_bcode t t1 c1).
                {
                apply btree_decompose_subtree_bcode in H105copy.
                - exact H105copy.
                - exact Hc1.
                }
              rewrite app_assoc in H104.
              assert (H104copy:= H104).
              apply bcode_split in H104.
              + destruct H104 as [c3 [c4 [H104 [H107 [t2 [v [x [H109 [H110 H111]]]]]]]]].
                assert (H110copy:= H110).
                assert (Ht1:= H110).
                apply btree_decompose_bfrontier in H110.
                destruct H110 as [Ht1_a Ht1_b].
                assert (Hc3: c3 <> []).
                  {
                  simpl in H107.
                  assert (length c3 > 0) by omega.
                  apply length_not_zero in H.
                  apply not_eq_sym.
                  exact H.
                  }
                specialize (Ht1_b Hc3).
                assert (Ht1_c: subtree_bcode t1 t2 c3).
                  {
                  apply btree_decompose_subtree_bcode in H110copy.
                  - exact H110copy.
                  - exact Hc3.
                  }
                remember (bfrontier t2) as w.
                (* Find roots *)
                assert (Hroot_t1: broot t1 = n).
                  {
                  apply bpath_bcode_split in H104copy.
                  destruct H104copy as [H104copy _].
                  apply bpath_broot with (d:= inl (broot t1)) in H104copy.
                  simpl in H104copy.
                  inversion H104copy.
                  reflexivity.
                  }
                assert (Hroot_t2: broot t2 = n).
                  {
                  apply bpath_bcode_split in H109.
                  destruct H109 as [H109 _].
                  apply bpath_broot with (d:= inl (broot t2)) in H109.
                  simpl in H109.
                  inversion H109.
                  reflexivity.
                  }
                (* Find heights *)
                remember (length ntl') as k.
                assert (H114: bheight t1 <= k + 1 /\ bheight t1 >= 2).
                  {
                  split.
                  - rewrite H106.
                    rewrite H27 in H24'.
                    repeat rewrite app_length in H24'.
                    repeat rewrite app_length.
                    simpl in H24'.
                    simpl.
                    omega.
                  - rewrite H106.
                    rewrite H27 in H24'.
                    repeat rewrite app_length in H24'.
                    repeat rewrite app_length.
                    simpl in H24'.
                    simpl.
                    omega.
                  }
                assert (H115: bheight t2 <= k /\ bheight t2 >= 1).
                  {
                  split.
                  - rewrite H111.
                    rewrite H27 in H24'.
                    repeat rewrite app_length in H24'.
                    repeat rewrite app_length.
                    simpl in H24'.
                    simpl.
                    omega.
                  - rewrite H111.
                    rewrite H27 in H24'.
                    repeat rewrite app_length in H24'.
                    repeat rewrite app_length.
                    simpl in H24'.
                    simpl.
                    omega.
                  }
                (* Exists u, v, w, x, y *)
                exists u, v, w, x, y.
                split.
                * (* s = u ++ v ++ w ++ x ++ y *)
                  rewrite <- H9.
                  rewrite Ht_a.
                  rewrite Ht1_a.
                  repeat rewrite <- app_assoc.
                  reflexivity.
                * {
                  split.
                  - (* length (v ++ x) >= 1 *)
                    apply length_not_zero_inv in Ht1_b.
                    omega.
                  - split.
                    + (* length (v ++ w ++ x) <= 2 ^ k *)
                      destruct H114 as [H114 H116].
                      apply bheight_le in H114.
                      rewrite Ht1_a in H114.
                      replace (k + 1 - 1) with k in H114.
                      * {
                        replace ((2 ^ (k - 1) + 1 - 1) * 2) with (2 ^ k).
                        - exact H114.
                        - replace (2 ^ (k - 1) + 1 - 1) with (2 ^ (k - 1)).
                          + replace k with (k - 1 + 1) at 1.
                            * rewrite Nat.pow_add_r.
                              simpl.
                              reflexivity.
                            * omega.
                          + omega.
                        }
                      * omega.
                    + (* uv^iwx^iy *)
                      intros i.
                      assert (Ht': exists t': btree _ _,
                                   btree_cnf g' t' /\
                                   broot t' = n /\
                                   btree_decompose t' (iter c3 i) = Some (iter v i, t2, iter x i) /\
                                   bcode t' (iter c3 i ++ c4) /\
                                   get_nt_btree (iter c3 i) t' = Some n).
                        {
                        apply pumping_aux with (g:= g') (t1:= t1) (t2:= t2) (n:= n) (c1:= c3) (c2:= c4) (v:= v) (x:= x) (i:= i).
                        - exact Ht1.
                        - apply subtree_bcode_subtree in Ht_c.
                          apply btree_cnf_subtree with (g:= g') in Ht_c.
                          + exact Ht_c.
                          + exact H4.
                        - exact Hroot_t1.
                        - rewrite <- H104.
                          apply bpath_bcode_split in H104copy.
                          apply H104copy.
                        - exact Hc3.
                        - congruence.
                        - apply bpath_bcode_split in H109.
                          apply H109.
                        }
                      destruct Ht' as [t' [Ht'_1 [Ht'_2 [Ht'_3 Ht'_4]]]].
                      assert (Ht'': exists t'': btree _ _, btree_subst t t' c1 = Some t'').
                        {
                        rewrite H101 in H100.
                        apply bcode_btree_subst with (t2:= t') in H100.
                        destruct H100 as [t'' H100].
                        exists t''.
                        exact H100.
                        }
                      destruct Ht'' as [t'' Ht''].
                      assert (Ht''_1: broot t'' = start_symbol g').
                        {
                        apply btree_subst_preserves_broot_v2 in Ht''.
                        - congruence.
                        - exact Hc1.
                        }
                      assert (Ht''_2: bfrontier t'' = u ++ iter v i ++ w ++ iter x i ++ y).
                        {
                        apply btree_subst_bfrontier with (t2:= t1) (x:= u) (y:= y) in Ht''.
                        - apply btree_decompose_bfrontier in Ht'_3.
                          destruct Ht'_3 as [Ht'_3 _].
                          rewrite Ht'_3 in Ht''.
                          rewrite Heqw.
                          repeat rewrite <- app_assoc in Ht''.
                          exact Ht''.
                        - exact Ht_c.
                        - exact Ht.
                        }
                      assert (Ht''_3: btree_cnf g' t'').
                        {
                        apply btree_subst_preserves_cnf with (g:= g') (c1':= c3 ++ c4) in Ht''.
                        - exact Ht''.
                        - exact H4.
                        - rewrite <- H104.
                          rewrite <- H101.
                          exact H100.
                        - exact Ht'_1.
                        - apply btree_decompose_get_nt in Ht.
                          congruence.
                        }
                      apply btree_equiv_produces_g_cnf in Ht''_3.
                      * unfold lang_eq in H3'.
                        specialize (H3' (u ++ iter v i ++ w ++ iter x i ++ y)).
                        destruct H3' as [_ H3'].
                        unfold lang_of_g in H3'.
                        apply H3'.
                        rewrite <- Ht''_2.
                        exact Ht''_3.
                      * congruence.
                  }
              + rewrite app_length.
                simpl.
                omega.
              + repeat rewrite app_length.
                simpl.
                omega.
              + rewrite H106.
                repeat rewrite app_length.
                reflexivity.
            - rewrite app_length.
              simpl.
              omega.
            - repeat rewrite app_length.
              simpl.
              omega.
            - rewrite Hpath in H21.
              repeat rewrite app_length in H21.
              repeat rewrite app_length.
              omega.
            }
          * rewrite H8.
            {
            apply start_symbol_only_once with (g:= g') (t:= t) (p1:= m ++ map inl r1') (p2:= map inl r2') (p3:= map inl r3' ++ [inr t0]).
            - exact H4'.
            - exact H4.
            - repeat rewrite <- app_assoc.
              exact H20copy.
            }
        + apply (nt_eqdec g').
        + rewrite H28.
          exact H24'.
      - apply cnf_bnts with (g:= g') (n:= n') (tl:= tl').
        + exact H5'.
        + exact H4.
      }
    * destruct H5'' as [H5'' _].
      apply in_split in H5''.
      destruct H5'' as [l1 [l2 H5'']].
      rewrite H5''.
      rewrite app_length.
      change (start_symbol g' :: l2) with ([start_symbol g'] ++ l2).
      rewrite app_length.
      simpl.
      omega.
    * exact H9.
  + assert (Hntl': 2 ^ length ntl' > 0).
      {
      apply pow_2_gt_0.
      }
    assert (Hs: length s > 0) by omega.
    apply length_not_zero in Hs.
    apply not_eq_sym.
    exact Hs.
  + exact H4'.
  + exact H3.
- exact H2.
Qed.

End Pumping_2.


Require Import rt.util.all.
Require Import rt.model.arrival.basic.task rt.model.arrival.basic.job rt.model.priority.
Require Import rt.model.schedule.global.workload.
Require Import rt.model.schedule.global.basic.schedule.
From mathcomp Require Import ssreflect ssrbool eqtype ssrnat seq fintype bigop.

Module Interference.

  Import Schedule ScheduleOfSporadicTask Priority Workload.

  Section InterferenceDefs.

    Context {sporadic_task: eqType}.
    Context {Job: eqType}.
    Variable job_arrival: Job -> time.
    Variable job_cost: Job -> time.
    Variable job_task: Job -> sporadic_task.

    (* Assume any job arrival sequence...*)
    Variable arr_seq: arrival_sequence Job.

    (* ... and any schedule. *)
    Context {num_cpus: nat}.
    Variable sched: schedule Job num_cpus.

    (* Consider any job j that incurs interference. *)
    Variable j: Job.

    (* Recall the definition of backlogged (pending and not scheduled). *)
    Let job_is_backlogged (t: time) :=
      backlogged job_arrival job_cost sched j t.

    (* First, we define total interference. *)
    Section TotalInterference.

      (* The total interference incurred by job j during [t1, t2) is the
         cumulative time in which j is backlogged in this interval. *)
      Definition total_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2) job_is_backlogged t.

    End TotalInterference.

    (* Next, we define job interference. *)
    Section JobInterference.

      (* Let job_other be a job that interferes with j. *)
      Variable job_other: Job.

      (* The interference caused by job_other during [t1, t2) is the cumulative
         time in which j is backlogged while job_other is scheduled. *)
      Definition job_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2)
          \sum_(cpu < num_cpus)
            (job_is_backlogged t && scheduled_on sched job_other cpu t).

    End JobInterference.

    (* Next, we define task interference. *)
    Section TaskInterference.

      (* In order to define task interference, consider any interfering task tsk_other. *)
      Variable tsk_other: sporadic_task.

      (* The interference caused by tsk during [t1, t2) is the cumulative time
         in which j is backlogged while tsk is scheduled. *)
      Definition task_interference (t1 t2: time) :=
        \sum_(t1 <= t < t2)
          \sum_(cpu < num_cpus)
            (job_is_backlogged t &&
            task_scheduled_on job_task sched tsk_other cpu t).

    End TaskInterference.

    (* Next, we define an approximation of the total interference based on
       each per-task interference. *)
    Section TaskInterferenceJobList.

      Variable tsk_other: sporadic_task.

      Definition task_interference_joblist (t1 t2: time) :=
        \sum_(j <- jobs_scheduled_between sched t1 t2 | job_task j == tsk_other)
         job_interference j t1 t2.

    End TaskInterferenceJobList.

    (* Now we prove some basic lemmas about interference. *)
    Section BasicLemmas.

      (* First, we show that the total interference cannot be larger than the interval length. *)
      Lemma total_interference_le_delta :
        forall t1 t2,
          total_interference t1 t2 <= t2 - t1.
      Proof.
        unfold total_interference; intros t1 t2.
        apply leq_trans with (n := \sum_(t1 <= t < t2) 1);
          first by apply leq_sum; ins; apply leq_b1.
        by rewrite big_const_nat iter_addn mul1n addn0 leqnn.
      Qed.

      (* Next, we show that job interference is bounded by the service of the interfering job. *)
      Lemma job_interference_le_service :
        forall j_other t1 t2,
          job_interference j_other t1 t2 <= service_during sched j_other t1 t2.
      Proof.
        intros j_other t1 t2; unfold job_interference, service_during.
        apply leq_sum; intros t _.
        unfold service_at; rewrite [\sum_(_ < _ | scheduled_on _ _ _  _)_]big_mkcond.
        apply leq_sum; intros cpu _.
        destruct (job_is_backlogged t); [rewrite andTb | by rewrite andFb].
        by destruct (scheduled_on sched j_other cpu t).
      Qed.

      (* We also prove that task interference is bounded by the workload of the interfering task. *)
      Lemma task_interference_le_workload :
        forall tsk t1 t2,
          task_interference tsk t1 t2 <= workload job_task sched tsk t1 t2.
      Proof.
        unfold task_interference, workload; intros tsk t1 t2.
        apply leq_sum; intros t _.
        apply leq_sum; intros cpu _.
        destruct (job_is_backlogged t); [rewrite andTb | by rewrite andFb].
        unfold task_scheduled_on, service_of_task.
        by destruct (sched cpu t).
      Qed.

    End BasicLemmas.

    (* Now we prove some bounds on interference for sequential jobs. *)
    Section InterferenceSequentialJobs.

      (* If jobs are sequential, ... *)
      Hypothesis H_sequential_jobs: sequential_jobs sched.

      (* ... then the interference incurred by a job in an interval
         of length delta is at most delta. *)
      Lemma job_interference_le_delta :
        forall j_other t1 delta,
          job_interference j_other t1 (t1 + delta) <= delta.
      Proof.
        rename H_sequential_jobs into SEQ.
        unfold job_interference, sequential_jobs in *.
        intros j_other t1 delta.
        apply leq_trans with (n := \sum_(t1 <= t < t1 + delta) 1);
          last by rewrite big_const_nat iter_addn mul1n addn0 addKn leqnn.
        apply leq_sum; intros t _.
        destruct ([exists cpu, scheduled_on sched j_other cpu t]) eqn:EX.
        {
          move: EX => /existsP [cpu SCHED].
          rewrite (bigD1 cpu) // /=.
          rewrite big_mkcond (eq_bigr (fun x => 0)) /=;
            first by simpl_sum_const; rewrite leq_b1.
          intros cpu' _; des_if_goal; last by done.
          destruct (scheduled_on sched j_other cpu' t) eqn:SCHED'; last by rewrite andbF.
          move: SCHED SCHED' => /eqP SCHED /eqP SCHED'.
          by specialize (SEQ j_other t cpu cpu' SCHED SCHED'); rewrite SEQ in Heq.
        }
        {
          apply negbT in EX; rewrite negb_exists in EX.
          move: EX => /forallP EX.
          rewrite (eq_bigr (fun x => 0)); first by simpl_sum_const.
          by intros cpu _; specialize (EX cpu); apply negbTE in EX; rewrite EX andbF.
        }
      Qed.

    End InterferenceSequentialJobs.

    (* Next, we show that the cumulative per-task interference bounds the total
       interference. *)
    Section BoundUsingPerJobInterference.

      Lemma interference_le_interference_joblist :
        forall tsk t1 t2,
          task_interference tsk t1 t2 <= task_interference_joblist tsk t1 t2.
      Proof.
        intros tsk t1 t2.
        unfold task_interference, task_interference_joblist, job_interference, job_is_backlogged.
        rewrite [\sum_(_ <- _ sched _ _ | _) _]exchange_big /=.
        rewrite big_nat_cond [\sum_(_ <= _ < _ | true) _]big_nat_cond.
        apply leq_sum; move => t /andP [LEt _].
        rewrite exchange_big /=.
        apply leq_sum; intros cpu _.
        destruct (backlogged job_arrival job_cost sched j t) eqn:BACK;
          last by rewrite andFb (eq_bigr (fun x => 0));
            first by rewrite big_const_seq iter_addn mul0n addn0.
        rewrite andTb.
        destruct (task_scheduled_on job_task sched tsk cpu t) eqn:SCHED; last by done.
        unfold scheduled_on, task_scheduled_on in *.
        destruct (sched cpu t) as [j' |] eqn:SOME; last by done.
        rewrite big_mkcond /= (bigD1_seq j') /=; last by apply undup_uniq.
        {
          by rewrite SCHED eq_refl.
        }
        {
          unfold jobs_scheduled_between.
          rewrite mem_undup; apply mem_bigcat_nat with (j := t); first by done.
          apply mem_bigcat_ord with (j := cpu); first by apply ltn_ord.
          by unfold make_sequence; rewrite SOME mem_seq1 eq_refl.
        }
      Qed.

    End BoundUsingPerJobInterference.

  End InterferenceDefs.

End Interference.


Require Import Ensembles ssrfun Description Relations_1 IndefiniteDescription
  Classical_Prop.

Arguments In {U} _ _.
Arguments Included {U} _ _.
Arguments Same_set {U}.
Arguments Equivalence {U}.

Module base.

Section definition.

Definition map {A B : Type} (f : A -> B) (X : Ensemble A) (Y : Ensemble B) :=
  forall x, In X x -> exists y, In Y y /\ f x = y.

Definition injective1 {A B : Type} (f : A -> B) (X : Ensemble A) (Y : Ensemble B) :=
  map f X Y /\ forall a b, a <> b -> f a <> f b.

Definition injective2 {A B : Type} (f : A -> B) (X : Ensemble A) (Y : Ensemble B) :=
  map f X Y /\ forall a b, f a = f b -> a = b.

Definition surjective {A B : Type} (f : A -> B) (X : Ensemble A) (Y : Ensemble B) :=
  map f X Y /\ forall b, exists a, f a = b.

Definition bijective {A B : Type} (f : A -> B) (X : Ensemble A) (Y : Ensemble B) :=
  surjective f X Y /\ injective2 f X Y.

Inductive invertible {X Y:Type} (f:X->Y) : Prop :=
  | intro_invertible: forall g:Y->X,
  (forall x:X, g (f x) = x) -> (forall y:Y, f (g y) = y) ->
  invertible f.

Definition operation {A B D : Type} (f : A -> B -> D)
  (X : Ensemble A) (Y : Ensemble B) (Z : Ensemble D) :=
  forall x y, In X x -> In Y y -> exists z, In Z z /\ f x y = z.

Definition one_operation {A : Type} (f : A -> A) (X Y : Ensemble A) :=
  map f X Y.

Definition binary_operation {A : Type} (f : A -> A -> A) (X : Ensemble A) :=
  operation f X X X.

(* 同态映射 *)
Definition homomorphism_map {A B : Type} (X : Ensemble A) (Y : Ensemble B)
  (f : A -> A -> A) (g : B -> B -> B) (h : A -> B) :=
  binary_operation f X /\ binary_operation g Y /\ map h X Y /\
  forall a b, h (f a b) = g (h a) (h b).

(* 同态满射 *)
Definition homomorphism {A B : Type} (X : Ensemble A) (Y : Ensemble B)
  (f : A -> A -> A) (g : B -> B -> B) (h : A -> B) :=
  binary_operation f X /\ binary_operation g Y /\ surjective h X Y /\
  forall a b, h (f a b) = g (h a) (h b).

(* 同构 *)
Definition isomorphism {A B : Type} (X : Ensemble A) (Y : Ensemble B)
  (f : A -> A -> A) (g : B -> B -> B) (h : A -> B) :=
  binary_operation f X /\ binary_operation g Y /\ bijective h X Y /\
  forall a b, h (f a b) = g (h a) (h b).

Definition exists_solution {A : Type} (f : A -> A -> A) (X : Ensemble A) :=
  forall a b, (exists x, f a x = b) /\ (exists y,f y a = b).

(* A不为空 *)
Definition notEmpty {A : Type} (X : Ensemble A) :=
  exists a, In X a.

Lemma injec {A B : Type} (f : A -> B) (X : Ensemble A) (Y : Ensemble B) :
  injective1 f X Y <-> injective2 f X Y.
Proof.
  split; intros.
  - destruct H. split; auto; intros.
    generalize (classic (a = b)); intros.
    destruct H2; auto. apply H0 in H2; auto.
    contradiction.
  - destruct H. split; auto.
Qed.

(* 可证 *)
Lemma logic_pro : forall (P Q : Prop), (P -> Q) -> (~ Q -> ~ P).
Proof.
  intros; auto.
Qed.

End definition.

Section base_law.

Record assoc_law {A : Type} (X : Ensemble A) : Type := Assoc {
  add :> A -> A -> A; (* 代数运算 *)
  _ : binary_operation add X;
  _ : associative add; (* 加法满足结合律 *)
  _ : notEmpty X;
}.

End base_law.

End base.

Export base.


Load "Tactics4_Constructions.v".

Section BOLYAI.

(* Quels que soient les points A B C *)
(* si A B et C ne sont pas colineaires *)
(* alors on sait construire un cercle gamma *)
(* tel que A soit sur gamma et B soit sur gamma et C soit sur gamma. *)

Theorem Bolyai : forall A B C : Point,
~ Collinear A B C ->
{gamma : Circle | OnCircle gamma A /\ OnCircle gamma B /\ OnCircle gamma C}.
Proof.
(* Soient A B C trois points, *)
(* Soit H l'hypothese A , B et C non colineaires, *)
intros.
(* Soit d1 la mediatrice du segment [A,B], *)
setMidLine A B ipattern:d1.
(* Soit d2 la mediatrice du segment [B,C], *)
setMidLine B C ipattern:d2.
(* En utilisant les droites (AB) et (BC) il vient d1 et d2 sont secantes, *)
from (Ruler A B H0, Ruler B C H4) (SecantLines d1 d2).
(* Soit E le point d'intesection de d1 et d2, *)
setInterLines d1 d2 ipattern:E.
(* Soit gamma le cercle de centre E et de rayon EB, *)
setCircle E E B ipattern:gamma.
(* gamma repond a la question, *)
answerIs gamma.
(* de l'hypothese H1 : pour tout point M, si M est sur d1, les distances MA et MB sont egales, il vient les distances EA et EB sont egales, *)
 from H1 (Distance E A = Distance E B).
(* de l'hypothese H5 : pour tout point M, si M est sur d2, les distances MB et MC sont egales, il vient les distances EB et EC sont egales, *)
 from H5 (Distance E B = Distance E C).
Qed.

End BOLYAI.


Inductive T : Type :=
  | Tbool
  | Tarrow : T -> T -> T.

Section t.

  Variable V : T -> Type.
  Inductive term : T -> Type :=
  | Var : forall t, V t -> term t
  | Abs : forall a b, (V a -> term b) -> term (Tarrow a b)
  | App : forall a b, term (Tarrow a b) -> term a -> term b.
End t.

Definition Term t := forall V, term V t.

Arguments Abs {V a b} _.
Arguments Var {V t} _.
Example K a b : Term (Tarrow a (Tarrow b a))  := fun V => Abs (fun x => Abs (fun y => Var x)).


(*** Predicates on a list ***)

Require Import Arith.
Require Import Bool.
Require Import List.
Require Import Ott.ott_list_base.
Require Import Ott.ott_list_core.
Require Import Ott.ott_list_takedrop.

Section List_predicate_inductive.
(* Properties of [Forall_list] and [Exists_list] *)

Variables A : Type.
Implicit Types x : A.
Implicit Types xs l : list A.
Implicit Types p : A -> bool.
Implicit Types P : A -> Prop.
Set Implicit Arguments.

Lemma not_Exists_list_nil : forall P, ~(Exists_list P nil).
Proof. intros P H; inversion H. Qed.
Hint Resolve not_Exists_list_nil : core.

Lemma Forall_list_dec :
  forall P (dec : forall x, {P x} + {~P x}) l,
    {Forall_list P l} + {~Forall_list P l}.
Proof.
  induction l; simpl in * . solve [auto].
  destruct (dec a); [destruct IHl | idtac]; auto;
    right; intro; inversion_clear H; tauto.
Qed.

Lemma Exists_list_dec :
  forall P (dec : forall x, {P x} + {~P x}) l,
    {Exists_list P l} + {~Exists_list P l}.
Proof.
  induction l; simpl in * . solve [auto].
  destruct (dec a); [idtac | destruct IHl]; auto;
    right; intro; inversion_clear H; tauto.
Qed.

Lemma Forall_Exists_list_dec :
  forall P Q (dec : forall x, {P x} + {Q x}) l,
    {Forall_list P l} + {Exists_list Q l}.
Proof.
  induction l; simpl in * . solve [auto].
  destruct (dec a); destruct IHl; auto.
Qed.

Lemma Forall_list_In :
  forall P x l, In x l -> Forall_list P l -> P x.
Proof.
  induction l; intros; simpl in *; destruct H;
    inversion H0; subst; auto.
Qed.

Lemma In_Forall_list :
  forall P l, (forall x, In x l -> P x) -> Forall_list P l.
Proof.
  induction l; constructor; firstorder.
Qed.

Lemma exists_In_Exists_list :
  forall P l, Exists_list P l -> exists x, In x l /\ P x.
Proof.
  induction 1.
  exists x; simpl; tauto.
  elim IHExists_list; intros. exists x0; simpl; tauto.
Qed.

Lemma Forall_list_app_left :
  forall P l l', Forall_list P (l++l') -> Forall_list P l.
Proof.
  intros; induction l; simpl in * . auto.
  inversion_clear H. auto.
Qed.
Lemma Forall_list_app_right :
  forall P l l', Forall_list P (l++l') -> Forall_list P l'.
Proof.
  induction l; intros. auto. inversion_clear H; auto.
Qed.
Lemma app_Forall_list :
  forall P l l', Forall_list P l -> Forall_list P l' -> Forall_list P (l++l').
Proof.
  intros; induction l; simpl in * . assumption.
  inversion_clear H. auto.
Qed.
Hint Resolve app_Forall_list Forall_list_app_left Forall_list_app_right : core.

Lemma Exists_list_app_or :
  forall P l l', Exists_list P (l++l') ->
    Exists_list P l \/ Exists_list P l'.
Proof.
  intros; induction l; simpl in * . solve [auto].
  inversion_clear H. solve [auto].
  destruct (IHl H0); solve [auto].
Qed.
Lemma app_Exists_list_left :
  forall P l l', Exists_list P l -> Exists_list P (l++l').
Proof.
  intros; induction l; inversion_clear H; simpl; auto.
Qed.
Lemma app_Exists_list_right :
  forall P l l', Exists_list P l' -> Exists_list P (l++l').
Proof.
  intros; induction l; simpl; auto.
Qed.
Hint Resolve Exists_list_app_or app_Exists_list_left app_Exists_list_right : core.

Lemma rev_Forall_list :
  forall P l, Forall_list P l -> Forall_list P (rev l).
Proof. induction 1; simpl; auto. Qed.
Lemma rev_Exists_list :
  forall P l, Exists_list P l -> Exists_list P (rev l).
Proof. induction 1; simpl; auto. Qed.
Lemma Forall_list_rev :
  forall P l, Forall_list P (rev l) -> Forall_list P l.
Proof.
  intros. rewrite <- (rev_involutive l). apply rev_Forall_list; assumption.
Qed.
Lemma Exists_list_rev :
  forall P l, Exists_list P (rev l) -> Exists_list P l.
Proof.
  intros. rewrite <- (rev_involutive l). apply rev_Exists_list; assumption.
Qed.

Lemma take_Forall_list :
  forall P n l, Forall_list P l -> Forall_list P (take n l).
Proof.
  intros; generalize dependent n; induction l; intros;
    inversion_clear H; destruct n; simpl; auto.
Qed.
Lemma drop_Forall_list :
  forall P n l, Forall_list P l -> Forall_list P (drop n l).
Proof.
  intros; generalize dependent n; induction l; intros;
    inversion_clear H; destruct n; simpl; auto.
Qed.
Lemma Forall_list_take_drop :
  forall P n l,
    Forall_list P (take n l) -> Forall_list P (drop n l) -> Forall_list P l.
Proof. intros; rewrite <- (take_app_drop l n); auto. Qed.

Lemma take_drop_Exists_list :
  forall P n l, Exists_list P l ->
    Exists_list P (take n l) \/ Exists_list P (drop n l).
Proof. intros; rewrite <- (take_app_drop l n) in H; auto. Qed.
Lemma Exists_list_take :
  forall P n l, Exists_list P (take n l) -> Exists_list P l.
Proof. intros; rewrite <- (take_app_drop l n); auto. Qed.
Lemma Exists_list_drop :
  forall P n l, Exists_list P (drop n l) -> Exists_list P l.
Proof. intros; rewrite <- (take_app_drop l n); auto. Qed.

Lemma Forall_list_implies :
  forall (P Q:A->Prop) xs,
    (forall x, In x xs -> P x -> Q x) ->
    Forall_list P xs -> Forall_list Q xs.
Proof. induction 2; firstorder. Qed.
Lemma Exists_list_implies :
  forall (P Q:A->Prop) xs,
    (forall x, In x xs -> P x -> Q x) ->
    Exists_list P xs -> Exists_list Q xs.
Proof. induction 2; firstorder. Qed.

End List_predicate_inductive.

Hint Resolve not_Exists_list_nil : lists.
Hint Resolve In_Forall_list : lists.
Hint Resolve Forall_list_app_left Forall_list_app_right : lists.
Hint Resolve app_Forall_list Exists_list_app_or : lists.
Hint Resolve app_Exists_list_left app_Exists_list_right : lists.
Hint Resolve rev_Forall_list rev_Exists_list : lists.
Hint Resolve Forall_list_rev Exists_list_rev : lists.
Hint Resolve take_Forall_list drop_Forall_list Forall_list_take_drop
             take_drop_Exists_list Exists_list_take Exists_list_drop
             : take_drop.
Hint Resolve Forall_list_implies Exists_list_implies : lists.

Section List_predicate_fold.
(* Properties of [forall_list] and [exists_list] *)

Variables A : Type.
Implicit Types x : A.
Implicit Types xs l : list A.
Implicit Types p : A -> bool.
Implicit Types P : A -> Prop.
Set Implicit Arguments.

Lemma forall_list_eq_fold_left_map :
  forall p l,
    forall_list p l = fold_left andb (map p l) true.
Proof.
  unfold forall_list; intros. generalize true.
  induction l; intros; simpl in * . reflexivity.
  rewrite IHl. reflexivity.
Qed.
Lemma forall_list_eq_fold_right_map :
  forall p l,
    forall_list p l = fold_right andb true (map p l).
Proof.
  intros. rewrite forall_list_eq_fold_left_map.
  apply fold_symmetric; auto with bool.
Qed.
Lemma forall_list_eq_fold_left :
  forall p l,
    forall_list p l = fold_left (fun b z => b && p z) l true.
Proof. auto. Qed.
Lemma forall_list_eq_fold_right :
  forall p l,
    forall_list p l = fold_right (fun z b => b && p z) true l.
Proof.
  intros; rewrite forall_list_eq_fold_right_map.
  induction l; simpl. reflexivity. rewrite IHl. auto with bool.
Qed.

Lemma exists_list_eq_fold_left_map :
  forall p l,
    exists_list p l = fold_left orb (map p l) false.
Proof.
  unfold exists_list; intros. generalize false.
  induction l; intros; simpl in * . reflexivity.
  rewrite IHl. reflexivity.
Qed.
Lemma exists_list_eq_fold_right_map :
  forall p l,
    exists_list p l = fold_right orb false (map p l).
Proof.
  intros. rewrite exists_list_eq_fold_left_map.
  apply fold_symmetric; auto with bool.
Qed.
Lemma exists_list_eq_fold_left :
  forall p l,
    exists_list p l = fold_left (fun b z => b || p z) l false.
Proof. auto. Qed.
Lemma exists_list_eq_fold_right :
  forall p l,
    exists_list p l = fold_right (fun z b => b || p z) false l.
Proof.
  intros; rewrite exists_list_eq_fold_right_map.
  induction l; simpl. reflexivity. rewrite IHl. auto with bool.
Qed.

Lemma forall_list_extensionality :
  forall p p' l, (forall x, p x = p' x) -> forall_list p l = forall_list p' l.
Proof.
  intros; repeat rewrite forall_list_eq_fold_right.
  induction l; simpl. reflexivity. rewrite IHl; rewrite H. reflexivity.
Qed.

Lemma exists_list_extensionality :
  forall p p' l, (forall x, p x = p' x) -> exists_list p l = exists_list p' l.
Proof.
  intros; repeat rewrite exists_list_eq_fold_right.
  induction l; simpl. reflexivity. rewrite IHl; rewrite H. reflexivity.
Qed.

End List_predicate_fold.

Section List_predicate_relationship.

Variables A : Type.
Implicit Types x : A.
Implicit Types xs l : list A.
Implicit Types p : A -> bool.
Implicit Types P : A -> Prop.
Set Implicit Arguments.

(* TODO: lemmas relating Forall_list and forall_list, Exists_list
   and exists_list, forall_list and exists_list. *)

Lemma Forall_if_implies_if_forall :
  forall P p l,
    Forall_list (fun z => if p z then P z else ~P z) l ->
    if forall_list p l then Forall_list P l else ~Forall_list P l.
Proof.
  intros; rewrite forall_list_eq_fold_right.
  induction H; simpl in * . apply Forall_nil.
  destruct (fold_right (fun (z : A) (b : bool) => b && p z) true l).
  destruct (p x); simpl. apply Forall_cons; assumption.
  intro No; inversion No; tauto.
  simpl; intro No; inversion No; tauto.
Qed.

End List_predicate_relationship.

(*** More about maps ***)

Section List_predicate_map.

Variables A B C : Type.
Implicit Types x : A.
Implicit Types y : B.
Implicit Types z : C.
Implicit Types xs l : list A.
Implicit Types ys : list B.
Implicit Types zs : list C.
Implicit Types f : A -> B.
Implicit Types g : B -> C.
Implicit Types P : A -> Prop.
Implicit Types Q : B -> Prop.
Implicit Types R : C -> Prop.
Implicit Types m n : nat.
Set Implicit Arguments.

Lemma map_take :
  forall f l n, map f (take n l) = take n (map f l).
Proof.
  intros. generalize dependent n; induction l; intros.
  destruct n; reflexivity.
  destruct n. reflexivity. simpl; rewrite IHl; reflexivity.
Qed.

Lemma map_drop :
  forall f l n, map f (drop n l) = drop n (map f l).
Proof.
  intros. generalize dependent n; induction l; intros.
  destruct n; reflexivity.
  destruct n. reflexivity. simpl; rewrite IHl; reflexivity.
Qed.

Lemma Forall_list_implies_map :
  forall P Q f l,
    (forall x, P x -> Q (f x)) ->
    Forall_list P l -> Forall_list Q (map f l).
Proof. induction 2; simpl; auto with lists. Qed.
Lemma Exists_list_implies_map :
  forall P Q f l,
    (forall x, P x -> Q (f x)) ->
    Exists_list P l -> Exists_list Q (map f l).
Proof. induction 2; simpl; auto with lists. Qed.

Lemma Forall_list_map_implies :
  forall P Q f l,
    (forall x, Q (f x) -> P x) ->
    Forall_list Q (map f l) -> Forall_list P l.
Proof.
  intros. induction l; simpl in * . apply Forall_nil.
  inversion_clear H0. auto with lists.
Qed.
Lemma Exists_list_map_implies :
  forall P Q f l,
    (forall x, Q (f x) -> P x) ->
    Exists_list Q (map f l) -> Exists_list P l.
Proof.
  intros. induction l; simpl in *;
    inversion_clear H0; auto with lists.
Qed.

Lemma Forall_list_map_intro :
  forall Q f l,
    Forall_list (fun x => Q (f x)) l -> Forall_list Q (map f l).
Proof. induction 1; simpl; auto with lists. Qed.
Lemma Exists_list_map_intro :
  forall Q f l,
    Exists_list (fun x => Q (f x)) l -> Exists_list Q (map f l).
Proof. induction 1; simpl; auto with lists. Qed.

Lemma Forall_list_map_elim :
  forall Q f l,
    Forall_list Q (map f l) -> Forall_list (fun x => Q (f x)) l.
Proof.
  intros. induction l; simpl in * . apply Forall_nil.
  inversion_clear H. auto with lists.
Qed.
Lemma Exists_list_map_elim :
  forall Q f l,
    Exists_list Q (map f l) -> Exists_list (fun x => Q (f x)) l.
Proof.
  intros. induction l; simpl in *;
    inversion_clear H; auto with lists.
Qed.

End List_predicate_map.

Hint Rewrite map_take map_drop : take_drop.
Hint Resolve Forall_list_implies_map Exists_list_implies_map : lists.
Hint Resolve Forall_list_map_implies Exists_list_map_implies : lists.
Hint Resolve Forall_list_map_intro Exists_list_map_intro : lists.
Hint Resolve Forall_list_map_elim Exists_list_map_elim : lists.

(* Simplify hypotheses and goals involving [Forall_list]. Simplifications
   involve rewriting [Forall_list ?P ?l] into equivalent statements
   where [?l] is simpler. Recognised ``complex'' constructors for [?l]
   are [nil], [cons], [app], [map], [rev]. In the goal, only
   simplifications that do not solve or split the goal are considered.
 *)
Ltac simplify_Forall_list :=
  let tmp := fresh "tmp" in (
    repeat match goal with
             | H : Forall_list ?P nil |- _ => clear H
             | H : Forall_list ?P (cons ?a ?l) |- _ =>
               inversion_clear H;
               match goal with H':_ |- _ => rename H' into H end
             | H : Forall_list ?P (app ?l0 ?l1) |- _ =>
               rename H into tmp;
               assert (H := Forall_list_app_right l0 l1 tmp);
               generalize H; clear H;
               assert (H := Forall_list_app_left l0 l1 tmp);
               intro; match goal with H':_ |- _ =>
                        move H' after tmp; simpl in H'
                      end;
               move H after tmp; clear tmp; simpl in H
             | H : Forall_list ?P (map ?f ?l) |- _ =>
               (*apply Forall_list_map_elim in H*) (*>=V8.1 only*)
               rename H into tmp;
               assert (H := Forall_list_map_elim f l tmp);
               move H after tmp; clear tmp; simpl in H
             | H : Forall_list ?P (rev ?l) |- _ =>
               rename H into tmp;
               assert (tmp := Forall_list_rev l H);
               move H after tmp; clear tmp; simpl in H
           end;
    repeat ((apply Forall_list_map_intro ||
             apply rev_Forall_list
            ); simpl)
  ).