(************************************************************************)
(*  v      *   The Coq Proof Assistant  /  The Coq Development Team     *)
(* <O___,, *   INRIA - CNRS - LIX - LRI - PPS - Copyright 1999-2015     *)
(*   \VV/  **************************************************************)
(*    //   *      This file is distributed under the terms of the       *)
(*         *       GNU Lesser General Public License Version 2.1        *)
(************************************************************************)
(*
Require Setoid.
Require Import PeanoNat Le Gt Minus Bool.
*)
Require Import HoTT FunextAxiom.
Require Import HottCat.Misc HottCat.Option HottCat.TFunctors.

Set Implicit Arguments.
Set Maximal Implicit Insertion.
(* Set Universe Polymorphism. *)

(******************************************************************)
(** * Basics: definition of polymorphic lists and some operations *)
(******************************************************************)

(** The definition of [list] is now in [Init/Datatypes],
    as well as the definitions of [length] and [app] *)

Open Scope list_scope.
Open Scope type_scope.

(** Standard notations for lists.
In a special module to avoid conflicts. *)
Module ListNotations.
Notation " [ ] " := nil (format "[ ]") : list_scope.
Notation " [ x ] " := (cons x nil) : list_scope.
Notation " [ x ; .. ; y ] " := (cons x .. (cons y nil) ..) : list_scope.
End ListNotations.

Import ListNotations.

Section List_eq.
  Context {A: Type}.
  (**************************)
  (** *** Equality type for lists: two elements are equall iff their hnf's are equal. *)
  (**************************)

  Fixpoint list_code (l l': list A) :=
    match l, l' with
    | [], [] => Unit
    | x::xs, y::ys => (x = y) /\ (list_code xs ys)
    | _, _ => Empty
    end.

  Infix "=list" := list_code (at level 70, right associativity).

  Fixpoint list_code_id (l: list A): l =list l :=
    match l with
    | [] => tt
    | x :: xs => (idpath, list_code_id xs)
    end.

  Definition list_encode (l l': list A): (l = l') -> (l =list l')
    := fun p => match p with | idpath => list_code_id _ end.

  Fixpoint list_decode (l l': list A): (l =list l') -> (l = l').
    induction l, l'; induction 1.
    exact idpath.
    f_ap.
    exact (list_decode l l' snd).
    Defined.

  Global Instance isequiv_list_encode {l l': list A}:
                                      IsEquiv (@list_encode l l').
    refine (isequiv_adjointify (@list_encode l l') (@list_decode l l') _ _); revert l l'.
    - unfold Sect.
      (* Should make up some tactic to use here TODO *)
      pose (T := fun (l l' : list A) (x : l =list l') => list_encode (list_decode l l' x) = x).
      refine (fix sect (l l': list A) (x : l =list l'): T l l' x:= _ ).
      unfold T; intros.
      induction l, l'; simpl.
      * exact (path_contr _ _).
      * induction x.
      * induction x.
      * destruct x as [p Ix].
        induction p.
        Lemma cons_encode (l l': list A) (a: A) (p: l = l'):
            list_encode (ap (cons a) p) = (idpath, list_encode p).
          path_induction. done.
          Defined.
        path_via (@idpath A a, list_encode (list_decode l l' Ix)).
        exact (@cons_encode l l' a _).
        f_ap. exact (sect l l' Ix).
    - unfold Sect; intros.
      path_induction.
      simpl.
      induction l. done.
      simpl. rewrite IHl. done.
  Defined.

  Definition equiv_path_list (l l': list A): (l = l') <~> (l =list l')
    := {| equiv_fun := @list_encode l l'; equiv_isequiv := _ |}.

End List_eq.

Section Lists.

  Context {A : Type}.

  (** Lists length. *)
  Fixpoint length (l: list A): nat :=
    match l with
    | [] => O
    | x :: xs => S (length xs)
    end.

  (** Head and tail *)

  Definition hd (default:A) (l:list A) :=
    match l with
      | [] => default
      | x :: _ => x
    end.

  Definition hd_error (l:list A) :=
    match l with
      | [] => error
      | x :: _ => value x
    end.

  Definition tl (l:list A) :=
    match l with
      | [] => nil
      | a :: m => m
    end.

  (** The [In] predicate *)
  Fixpoint In (a:A) (l:list A) : Type :=
    match l with
      | [] => Empty
      | b :: m => (b = a) + In a m
    end.

  (*****************************)
  (** ** Nth element of a list *)
  (*****************************)

  Fixpoint nth (n:nat) (l:list A) (default:A) {struct l} : A :=
    match n, l with
      | O, x :: l' => x
      | O, other => default
      | S m, [] => default
      | S m, x :: t => nth m t default
    end.
(*
  Fixpoint nth_ok (n:nat) (l:list A) (default:A) {struct l} : bool :=
    match n, l with
      | O, x :: l' => true
      | O, other => false
      | S m, [] => false
      | S m, x :: t => nth_ok m t default
    end.

*)
(*
  (*****************)
  (** ** Remove    *)
  (*****************)

  Hypothesis eq_dec : forall x y : A, {x = y}+{x <> y}.

  Fixpoint remove (x : A) (l : list A) : list A :=
    match l with
      | [] => []
      | y::tl => if (eq_dec x y) then remove x tl else y::(remove x tl)
    end.

  Theorem remove_In : forall (l : list A) (x : A), ~ In x (remove x l).
  Proof.
    induction l as [|x l]; auto.
    intro y; simpl; destruct (eq_dec y x) as [yeqx | yneqx].
    apply IHl.
    unfold not; intro HF; simpl in HF; destruct HF; auto.
    apply (IHl y); assumption.
  Qed.
*)

(******************************)
(** ** Last element of a list *)
(******************************)

  (** [last l d] returns the last element of the list [l],
    or the default value [d] if [l] is empty. *)

  Fixpoint last (l:list A) (d:A) : A :=
  match l with
    | [] => d
    | [a] => a
    | a :: l => last l d
  end.

  (** [removelast l] remove the last element of [l] *)

  Fixpoint removelast (l:list A) : list A :=
    match l with
      | [] =>  []
      | [a] => []
      | a :: l => a :: removelast l
    end.

End Lists.

Section List_discrim.

  Context {A : Type}.

  (** Discrimination *)
  Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l.
  Proof.
    intros x l p.
    apply (ap length) in p.
    exact (nat_discr p).
  Qed.

  Lemma nil_cons' (x:A) (l:list A): x :: l <> [].
  Proof.
    intro p. exact (nil_cons p^).
  Qed.

  Theorem cons_discr: forall (x: A) (l: list A), ([] = x :: l) <~> Empty.
    intros.
    refine (BuildEquiv _ Empty (@nil_cons x l)
            (BuildIsEquiv _ Empty _ _ _ _ _) ).
    - induction 1.
    - unfold Sect. induction x0.
    - unfold Sect; intro.
      cut Empty; [ induction 1 | exact (nil_cons x0) ].
    - intro. assert Empty; [ exact (nil_cons x0) | contradiction ].
    Qed.

  Theorem app_cons_not_nil : forall (x y:list A) (a:A), [] <> x ++ a :: y.
  Proof.
    unfold not.
    destruct x as [| a l]; simpl; intros.
    exact (cons_discr a y X).
    exact (cons_discr a _ X).
  Qed.

End List_discrim.

(** We use "discrim" auto database as a subsitute for "discriminate" tactic. *)
Hint Resolve nil_cons nil_cons' app_cons_not_nil: discrim.

Section Head_facts.
  Context {A: Type}.

  (** *** Genereric facts *)

  (** Destruction *)

  Theorem destruct_list : forall l : list A, {x:A & {tl:list A | l = x::tl}} + (l = []).
  Proof.
    induction l as [|a tail].
    right; reflexivity.
    left; exists a, tail; reflexivity.
  Defined.

  Fixpoint path_list_hd_tl (l l': list A):
        (l = l') <~> (hd_error l) = (hd_error l') /\ (tl l) = (tl l').
    induction l, l'.
    - simpl. refine (_ oE (prod_unit_l ([] = []))^-1 ).
      exact (@equiv_functor_prod_r Unit (error = error) ([] = [])
                              (@equiv_path_opt A error error)^-1).
    - simpl. refine (_ oE cons_discr a l').
      refine (_ oE (prod_empty_l ([] = l'))^-1).
      exact (@equiv_functor_prod_r Empty (error = value a) ([] = l')
                              (@equiv_path_opt A error (value a))^-1).
    -
    Qed.

  Lemma hd_error_tl_repr : forall l (a:A) r,
    hd_error l = Some a /\ tl l = r <~> l = a :: r.
  Proof.
    destruct l as [|x xs].
    - unfold hd_error, tl; intros a r.
      refine (equiv_compose (B:= Empty) _ _).
      * exact ((cons_discr a r)^-1.(equiv_fun)).
      * intro x; cut(Empty * ([] = r)).
        destruct 1; exact fst.
        destruct x.
        exact (@equiv_path_opt A error (Some a) fst , snd).
      * exact (equiv_isequiv (equiv_inverse _)).
    - intros. simpl.
      refine (equiv_adjointify _ _ _ _).
      * intros (p, ps); f_ap.
        exact (equiv_path_opt p).
      * intro p. exact (ap hd_error p, ap tl p).
      * unfold Sect.
        intro p.
(*        assert (f := list_encode p).
        assert (ap hd_error p = ap (@value A) (fst f)).
        induction p.*)
        intro p; generalize (ap tl p); generalize (ap hd_error p); simpl.
        path_induction.
        assert (forall s: x = a, ap11 match s
                in (_ = y) return (cons x = cons y) with
                | idpath => 1
                end 1 = p).
        { path_induction; simpl.
          (* Could optimize this part TODO *)
          pose (t := fun (a b c: list A) (p: a = b) (q: a =c),
                     (p^ @ q) #
          assert (forall (a b c: list A) (p: a = b) (q: a =c),
                  exists s: b = c, s # p = q).
          path_induction. exact (idpath; idpath).
          pose (t := (X (x::xs) (x::xs) (x::xs) idpath p).2).
          simpl in t.
          exact t.
        generalize (Option.option_encode p0); simpl.
        path_induction.
        set (s := Option.option_encode p0).
        simpl in s.
        simpl.
        unfold Option.option_encode.
        Admitted.

  Lemma hd_error_some_nil : forall l (a:A),
        (hd_error l = Some a) -> (l <> nil).
  Proof.
    unfold hd_error.
    destruct l; intros.
    cut Empty; [ induction 1 | exact (error_ne_some a X) ].
    exact (@nil_cons' A a l).
  Qed.

  Theorem length_zero_iff_nil (l : list A):
    length l = 0 <~> l=[].
  Proof.
    assert (p: l = [] <~> length l = 0).
    refine (equiv_adjointify (ap length) _ _ _).
    - destruct l; auto. simpl. intro s; cut Empty.
      exact (inverse o (cons_discr a l)^-1).
      exact (nat_discr s^).
    - unfold Sect; simpl; intros.
      destruct l; auto.
      revert x; simpl.
      assert (forall (x y: nat) (p: 0 = x) (q: 0 = y),
              {s: x = y & s # p = q}).
      path_induction; refine (idpath; _); done.
      intro p.
      Compute (X 0 0 idpath p).
      apply (X 0 0 idpath) in p.

  (** *** Head and tail *)

  Theorem hd_error_nil : hd_error (@nil A) = None.
  Proof.
    simpl; reflexivity.
  Qed.

  Theorem hd_error_cons : forall (l : list A) (x : A), hd_error (x::l) = Some x.
  Proof.
    intros; simpl; reflexivity.
  Defined.

End Head_facts.

Hint Resolve hd_error_cons hd_error_nil: datatypes.

Section App_facts.
  Context {A: Type}.

  (**************************)
  (** *** Facts about [app] *)
  (**************************)

  (** Concat with [nil] *)
  Theorem app_nil_l : forall l:list A, [] ++ l = l.
  Proof.
    reflexivity.
  Defined.

  Theorem app_nil_r : forall l:list A, l ++ [] = l.
  Proof.
    induction l; simpl; f_ap.
  Defined.

  (* begin hide *)
  (* Deprecated *)
  Theorem app_nil_end : forall (l:list A), l = l ++ [].
  Proof. intro; symmetry; apply app_nil_r. Defined.
  (* end hide *)

  (** [app] is associative *)
  Theorem app_assoc : forall l m n:list A, l ++ m ++ n = (l ++ m) ++ n.
  Proof.
    intros l m n; induction l; simpl; f_ap.
  Defined.

  (* begin hide *)
  (* Deprecated *)
  Theorem app_assoc_reverse : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n.
  Proof.
     intros; exact ((app_assoc l m n)^).
  Defined.
  Hint Resolve app_assoc_reverse.
  (* end hide *)

  (** [app] commutes with [cons] *)
  Theorem app_comm_cons : forall (x y:list A) (a:A), a :: (x ++ y) = (a :: x) ++ y.
  Proof.
    auto.
  Defined.

  Lemma app_nil (l l': list A): (l ++ l' = []) -> (l = []) /\ (l' = []).
  Proof.
    destruct l; auto.
    intro p. apply (concat (app_comm_cons l l' a)) in p.
    elimtype Empty. exact (cons_discr a _ p^).
  Qed.

End App_facts.

Hint Resolve app_comm_cons app_assoc app_assoc_reverse app_nil_r app_nil_l: datatypes.

Section Facts.
  Context {A: Type}.

  (****************************************)
  (** *** Facts about last and removelast *)
  (****************************************)

  Lemma cons_removelast : forall (l: list A) (a: A),
      l <> [] -> removelast (a :: l) = a :: (removelast l).
  Proof.
    induction l; intros.
    elimtype Empty; exact (X idpath).
    destruct l; auto.
  Qed.

  Lemma app_removelast_last : forall (l: list A) (d: A),
        (l = []) \/ (l = removelast l ++ [last l d]).
  Proof.
    induction l; intros.
    left; auto.
    right. assert (p := IHl d).
    destruct p.
    induction (p^); done.
    assert (l <> []).
    { intro t; apply (concat p^) in t.
      exact (app_cons_not_nil (removelast l) [] (last l d) t^). }
    assert (s := ap (cons a) p).
    refine (concat s _).
    path_via (removelast (a :: l) ++ [last l d]).
    exact (ap (fun x => x++ [last l d]) (cons_removelast a X)^).
    assert (last l d = last (a::l) d).
    { destruct l; auto. elimtype Empty; exact (X idpath). }
    exact (ap (fun x => removelast (a::l) ++ [x]) X0).
  Defined.

  Lemma exists_last :
    forall l, l <> [] -> { l' : (list A) & { a : A | l = l' ++ [a]}}.
  Proof.
    induction l.
    destruct 1; auto.
    intros _.
    destruct l.
    exists [], a; auto.
    destruct IHl as [l' (a',H)]. exact (cons_discr a0 l o inverse).
    rewrite H.
    exists (a::l'), a'; auto.
  Defined.

  Lemma removelast_app : forall (l l': list A),
        l' <> [] -> removelast (l++l') = l ++ removelast l'.
  Proof.
    induction l.
    simpl; auto.
    simpl; intros.
    assert (l++l' <> []).
    destruct l.
    simpl; auto.
    eauto using app_cons_not_nil with path_hints.
    intro; cut (l' ++ a0 :: l = []).
    exact (app_cons_not_nil l' l a0 o inverse).
    apply (app_nil _ _)  in X0.
    destruct X0 as [p q].
    exact ((ap (fun x => x ++ a0::l)) q @ ap (fun x => [] ++ x) p).
    apply (IHl l') in X.
    destruct (l++l').
    elimtype Empty; exact (X0 idpath).
    exact (ap (cons a) X).
  Defined.

  (************************)
  (** *** Facts about [In] *)
  (************************)

  (** Characterization of [In] *)

  Theorem in_eq : forall (a:A) (l:list A), In a (a :: l).
  Proof.
    simpl; auto.
  Defined.

  Theorem in_cons : forall (a b:A) (l:list A), In b l -> In b (a :: l).
  Proof.
    simpl; auto.
  Defined.

  Theorem not_in_cons (x a : A) (l : list A):
    ~ In x (a::l) <~> x<>a /\ ~ In x l.
  Proof.
    Admitted.

  Theorem in_nil : forall a:A, ~ In a [].
  Proof.
    unfold not, In; auto.
  Qed.

  Theorem in_split : forall x (l:list A), In x l -> exists l1 l2, l = l1++x::l2.
  Proof.
  induction l; simpl; destruct 1.
  exact ([] ; (l; ap (fun y => y ::l) p)).
  apply IHl in i.
  destruct i as (l1 & l2 & s).
  refine (a::l1; (l2; _ )).
  transitivity (a:: (l1 ++ x :: l2)).
  exact (ap (cons a) s).
  exact (app_comm_cons _ _ _).
  Defined.

  (** Inversion *)
  Lemma in_inv : forall (a b:A) (l:list A), In b (a :: l) -> a = b \/ In b l.
  Proof.
    intros a b l H. destruct H; auto.
  Defined.

  (** Decidability of [In] *)
  Theorem in_dec :
    (forall x y:A, (x = y) + (x <> y)) ->
    forall (a:A) (l:list A), (In a l) + (~ In a l).
  Proof.
    intro H; induction l as [| a0 l IHl].
    right; apply in_nil.
    destruct (H a0 a); simpl; auto.
    destruct IHl; simpl; auto.
    right; unfold not; intros [Hc1| Hc2]; auto.
  Defined.

  (** Compatibility with other operations *)

  Open Scope nat_scope.

  Lemma app_length : forall l l' : list A, length (l++l') = length l + length l'.
  Proof.
    induction l; intro; simpl; auto. exact (ap S (IHl l')).
  Defined.

  Lemma in_app_or : forall (l m:list A) (a:A),
                    In a (l ++ m) -> In a l + In a m.
  Proof.
    intros l m a.
    elim l; simpl; auto.
    intros a0 y H H0.
    destruct H0; auto.
    apply H in i; destruct i; auto.
  Defined.

  Lemma in_or_app : forall (l m:list A) (a:A), In a l + In a m -> In a (l ++ m).
  Proof.
    intros l m a.
    elim l; simpl; intro H.
    destruct H; auto. induction e.
    intros.
    destruct X0; auto.
    destruct s; auto.
  Defined.

  Lemma in_app_iff : forall l l' (a:A), In a (l++l') <~> In a l + In a l'.
  Proof.
    intros.
    refine (equiv_adjointify (in_app_or l l' a) (in_or_app l l' a) _ _).
    - unfold Sect. intros.
  Admitted.

  Lemma app_inv_head:
   forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2.
  Proof.
    induction l; simpl; auto. intros.
    exact (IHl l1 l2 (ap tl X)).
  Defined.

  Lemma app_inv_tail:
    forall l l1 l2 : list A, l1 ++ l = l2 ++ l -> l1 = l2.
  Proof.
    intros l l1 l2; revert l1 l2 l.
    induction l1 as [ | x1 l1]; destruct l2 as [ | x2 l2];
     simpl; auto; intros l H.
  Admitted.

  (** Facts deduced from the result of a concatenation *)

  Theorem app_eq_nil : forall l l':list A,
                       (l ++ l' = []) -> ((l = []) + (l' = [])).
  Proof.
    destruct l as [| x l]; destruct l' as [| y l']; simpl; auto.
    intro; elimtype Empty. exact (cons_discr x _ X^).
  Qed.

  Theorem app_eq_unit :
    forall (x y:list A) (a:A),
      (x ++ y = [a]) -> (x = [] /\ y = [a]) \/ (x = [a] /\ y = []).
  Proof.
    destruct x as [| a l]; [ destruct y as [| a l] | destruct y as [| a0 l0] ]; simpl.
    intros a H. elimtype Empty. exact (cons_discr _ _ H).
    left; split; auto.
    right; split; auto.
    exact ((app_nil_r (a::l))^ @ X).
    intros. elimtype Empty.
    apply (ap length) in X. SearchAbout length "++".
    apply (concat (app_length (a::l) (a0::l0))^ ) in X.
    simpl in X.
    apply (ap pred) in X; simpl in X.
    apply (concat (nat_plus_n_Sm _ _)) in X.
    exact (nat_discr X^).
  Defined.

  Lemma app_inj_tail :
    forall (x y:list A) (a b:A), x ++ [a] = y ++ [b] -> x = y /\ a = b.
  Proof.
    induction x as [| x l IHl];
      [ destruct y as [| a l] | destruct y as [| a l0] ];
      simpl; auto.
    - intros a b H.
      apply (ap (hd a)) in H; auto.
    - intros a0 b H.
      exact (ap removelast H, ap last H).
      injection H as H1 H0.
      apply app_cons_not_nil in H0 as [].
    - intros a b H.
      injection H as H1 H0.
      assert ([] = l ++ [a]) by auto.
      apply app_cons_not_nil in H as [].
    - intros a0 b H.
      injection H as <- H0.
      destruct (IHl l0 a0 b H0) as (<-,<-).
      split; auto.
  Qed.

End Facts.

Hint Resolve app_assoc app_assoc_reverse: datatypes v62.
Hint Resolve app_comm_cons app_cons_not_nil: datatypes v62.
Hint Immediate app_eq_nil: datatypes v62.
Hint Resolve app_eq_unit app_inj_tail: datatypes v62.
Hint Resolve in_eq in_cons in_inv in_nil in_app_or in_or_app: datatypes v62.

(*******************************************)
(** * Operations on the elements of a list *)
(*******************************************)

Section Elts.

  Context {A : Type}.

  (*****************************)
  (** ** Nth element of a list *)
  (*****************************)

  Lemma nth_in_or_default :
    forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}.
  Proof.
    intros n l d; revert n; induction l.
    - right; destruct n; trivial.
    - intros [|n]; simpl.
      * left; auto.
      * destruct (IHl n); auto.
  Qed.

  Lemma nth_S_cons :
    forall (n:nat) (l:list A) (d a:A),
      In (nth n l d) l -> In (nth (S n) (a :: l) d) (a :: l).
  Proof.
    simpl; auto.
  Qed.

  Fixpoint nth_error (l:list A) (n:nat) {struct n} : Exc A :=
    match n, l with
      | O, x :: _ => value x
      | S n, _ :: l => nth_error l n
      | _, _ => error
    end.

  Definition nth_default (default:A) (l:list A) (n:nat) : A :=
    match nth_error l n with
      | Some x => x
      | None => default
    end.

  Lemma nth_default_eq :
    forall n l (d:A), nth_default d l n = nth n l d.
  Proof.
    unfold nth_default; induction n; intros [ | ] ?; simpl; auto.
  Qed.

  (** Results about [nth] *)

  Lemma nth_In :
    forall (n:nat) (l:list A) (d:A), n < length l -> In (nth n l d) l.
  Proof.
    unfold lt; induction n as [| n hn]; simpl.
    - destruct l; simpl; [ inversion 2 | auto ].
    - destruct l as [| a l hl]; simpl.
      * inversion 2.
      * intros d ie; right; apply hn; auto with arith.
  Qed.

  Lemma In_nth l x d : In x l ->
    exists n, n < length l /\ nth n l d = x.
  Proof.
    induction l as [|a l IH].
    - easy.
    - intros [H|H].
      * subst; exists 0; simpl; auto with arith.
      * destruct (IH H) as (n & Hn & Hn').
        exists (S n); simpl; auto with arith.
  Qed.

  Lemma nth_overflow : forall l n d, length l <= n -> nth n l d = d.
  Proof.
    induction l; destruct n; simpl; intros; auto.
    - inversion H.
    - apply IHl; auto with arith.
  Qed.

  Lemma nth_indep :
    forall l n d d', n < length l -> nth n l d = nth n l d'.
  Proof.
    induction l.
    - inversion 1.
    - intros [|n] d d'; simpl; auto with arith.
  Qed.

  Lemma app_nth1 :
    forall l l' d n, n < length l -> nth n (l++l') d = nth n l d.
  Proof.
    induction l.
    - inversion 1.
    - intros l' d [|n]; simpl; auto with arith.
  Qed.

  Lemma app_nth2 :
    forall l l' d n, n >= length l -> nth n (l++l') d = nth (n-length l) l' d.
  Proof.
    induction l; intros l' d [|n]; auto.
    - inversion 1.
    - intros; simpl; rewrite IHl; auto with arith.
  Qed.

  Lemma nth_split n l d : n < length l ->
    exists l1, exists l2, l = l1 ++ nth n l d :: l2 /\ length l1 = n.
  Proof.
    revert l.
    induction n as [|n IH]; intros [|a l] H; try easy.
    - exists nil; exists l; now simpl.
    - destruct (IH l) as (l1 & l2 & Hl & Hl1); auto with arith.
      exists (a::l1); exists l2; simpl; split; now f_equal.
  Qed.

  (** Results about [nth_error] *)

  Lemma nth_error_In l n x : nth_error l n = Some x -> In x l.
  Proof.
    revert n. induction l as [|a l IH]; intros [|n]; simpl; try easy.
    - injection 1; auto.
    - eauto.
  Qed.

  Lemma In_nth_error l x : In x l -> exists n, nth_error l n = Some x.
  Proof.
    induction l as [|a l IH].
    - easy.
    - intros [H|H].
      * subst; exists 0; simpl; auto with arith.
      * destruct (IH H) as (n,Hn).
        exists (S n); simpl; auto with arith.
  Qed.

  Lemma nth_error_None l n : nth_error l n = None <-> length l <= n.
  Proof.
    revert n. induction l; destruct n; simpl.
    - split; auto.
    - split; auto with arith.
    - split; now auto with arith.
    - rewrite IHl; split; auto with arith.
  Qed.

  Lemma nth_error_Some l n : nth_error l n <> None <-> n < length l.
  Proof.
   revert n. induction l; destruct n; simpl.
    - split; [now destruct 1 | inversion 1].
    - split; [now destruct 1 | inversion 1].
    - split; now auto with arith.
    - rewrite IHl; split; auto with arith.
  Qed.

  Lemma nth_error_split l n a : nth_error l n = Some a ->
    exists l1, exists l2, l = l1 ++ a :: l2 /\ length l1 = n.
  Proof.
    revert l.
    induction n as [|n IH]; intros [|x l] H; simpl in *; try easy.
    - exists nil; exists l. injection H; clear H; intros; now subst.
    - destruct (IH _ H) as (l1 & l2 & H1 & H2).
      exists (x::l1); exists l2; simpl; split; now f_equal.
  Qed.

  Lemma nth_error_app1 l l' n : n < length l ->
    nth_error (l++l') n = nth_error l n.
  Proof.
    revert l.
    induction n; intros [|a l] H; auto; try solve [inversion H].
    simpl in *. apply IHn. auto with arith.
  Qed.

  Lemma nth_error_app2 l l' n : length l <= n ->
    nth_error (l++l') n = nth_error l' (n-length l).
  Proof.
    revert l.
    induction n; intros [|a l] H; auto; try solve [inversion H].
    simpl in *. apply IHn. auto with arith.
  Qed.

  (****************************************)
  (** ** Counting occurences of a element *)
  (****************************************)

  Fixpoint count_occ (l : list A) (x : A) : nat :=
    match l with
      | [] => 0
      | y :: tl =>
        let n := count_occ tl x in
        if eq_dec y x then S n else n
    end.

  (** Compatibility of count_occ with operations on list *)
  Theorem count_occ_In l x : In x l <-> count_occ l x > 0.
  Proof.
    induction l as [|y l]; simpl.
    - split; [destruct 1 | apply gt_irrefl].
    - destruct eq_dec as [->|Hneq]; rewrite IHl; intuition.
  Qed.

  Theorem count_occ_not_In l x : ~ In x l <-> count_occ l x = 0.
  Proof.
    rewrite count_occ_In. unfold gt. now rewrite Nat.nlt_ge, Nat.le_0_r.
  Qed.

  Lemma count_occ_nil x : count_occ [] x = 0.
  Proof.
    reflexivity.
  Qed.

  Theorem count_occ_inv_nil l :
    (forall x:A, count_occ l x = 0) <-> l = [].
  Proof.
    split.
    - induction l as [|x l]; trivial.
      intros H. specialize (H x). simpl in H.
      destruct eq_dec as [_|NEQ]; [discriminate|now elim NEQ].
    - now intros ->.
  Qed.

  Lemma count_occ_cons_eq l x y :
    x = y -> count_occ (x::l) y = S (count_occ l y).
  Proof.
    intros H. simpl. now destruct (eq_dec x y).
  Qed.

  Lemma count_occ_cons_neq l x y :
    x <> y -> count_occ (x::l) y = count_occ l y.
  Proof.
    intros H. simpl. now destruct (eq_dec x y).
  Qed.

End Elts.

(*******************************)
(** * Manipulating whole lists *)
(*******************************)

Section ListOps.

  Variable A : Type.

  (*************************)
  (** ** Reverse           *)
  (*************************)

  Fixpoint rev (l:list A) : list A :=
    match l with
      | [] => []
      | x :: l' => rev l' ++ [x]
    end.

  Lemma rev_app_distr : forall x y:list A, rev (x ++ y) = rev y ++ rev x.
  Proof.
    induction x as [| a l IHl].
    destruct y as [| a l].
    simpl.
    auto.

    simpl.
    rewrite app_nil_r; auto.

    intro y.
    simpl.
    rewrite (IHl y).
    rewrite app_assoc; trivial.
  Qed.

  Remark rev_unit : forall (l:list A) (a:A), rev (l ++ [a]) = a :: rev l.
  Proof.
    intros.
    apply (rev_app_distr l [a]); simpl; auto.
  Qed.

  Lemma rev_involutive : forall l:list A, rev (rev l) = l.
  Proof.
    induction l as [| a l IHl].
    simpl; auto.

    simpl.
    rewrite (rev_unit (rev l) a).
    rewrite IHl; auto.
  Qed.

  (** Compatibility with other operations *)

  Lemma in_rev : forall l x, In x l <-> In x (rev l).
  Proof.
    induction l.
    simpl; intuition.
    intros.
    simpl.
    intuition.
    subst.
    apply in_or_app; right; simpl; auto.
    apply in_or_app; left; firstorder.
    destruct (in_app_or _ _ _ H); firstorder.
  Qed.

  Lemma rev_length : forall l, length (rev l) = length l.
  Proof.
    induction l;simpl; auto.
    rewrite app_length.
    rewrite IHl.
    simpl.
    elim (length l); simpl; auto.
  Qed.

  Lemma rev_nth : forall l d n,  n < length l ->
    nth n (rev l) d = nth (length l - S n) l d.
  Proof.
    induction l.
    intros; inversion H.
    intros.
    simpl in H.
    simpl (rev (a :: l)).
    simpl (length (a :: l) - S n).
    inversion H.
    rewrite <- minus_n_n; simpl.
    rewrite <- rev_length.
    rewrite app_nth2; auto.
    rewrite <- minus_n_n; auto.
    rewrite app_nth1; auto.
    rewrite (minus_plus_simpl_l_reverse (length l) n 1).
    replace (1 + length l) with (S (length l)); auto with arith.
    rewrite <- minus_Sn_m; auto with arith.
    apply IHl ; auto with arith.
    rewrite rev_length; auto.
  Qed.

  (**  An alternative tail-recursive definition for reverse *)

  Fixpoint rev_append (l l': list A) : list A :=
    match l with
      | [] => l'
      | a::l => rev_append l (a::l')
    end.

  Definition rev' l : list A := rev_append l [].

  Lemma rev_append_rev : forall l l', rev_append l l' = rev l ++ l'.
  Proof.
    induction l; simpl; auto; intros.
    rewrite <- app_assoc; firstorder.
  Qed.

  Lemma rev_alt : forall l, rev l = rev_append l [].
  Proof.
    intros; rewrite rev_append_rev.
    rewrite app_nil_r; trivial.
  Qed.

(*********************************************)
(** Reverse Induction Principle on Lists  *)
(*********************************************)

  Section Reverse_Induction.

    Lemma rev_list_ind :
      forall P:list A-> Prop,
	P [] ->
	(forall (a:A) (l:list A), P (rev l) -> P (rev (a :: l))) ->
	forall l:list A, P (rev l).
    Proof.
      induction l; auto.
    Qed.

    Theorem rev_ind :
      forall P:list A -> Prop,
	P [] ->
	(forall (x:A) (l:list A), P l -> P (l ++ [x])) -> forall l:list A, P l.
    Proof.
      intros.
      generalize (rev_involutive l).
      intros E; rewrite <- E.
      apply (rev_list_ind P).
      auto.

      simpl.
      intros.
      apply (H0 a (rev l0)).
      auto.
    Qed.

  End Reverse_Induction.

  (*************************)
  (** ** Concatenation     *)
  (*************************)

  Fixpoint concat (l : list (list A)) : list A :=
  match l with
  | nil => nil
  | cons x l => x ++ concat l
  end.

  Lemma concat_nil : concat nil = nil.
  Proof.
  reflexivity.
  Qed.

  Lemma concat_cons : forall x l, concat (cons x l) = x ++ concat l.
  Proof.
  reflexivity.
  Qed.

  Lemma concat_app : forall l1 l2, concat (l1 ++ l2) = concat l1 ++ concat l2.
  Proof.
  intros l1; induction l1 as [|x l1 IH]; intros l2; simpl.
  + reflexivity.
  + rewrite IH; apply app_assoc.
  Qed.

  (***********************************)
  (** ** Decidable equality on lists *)
  (***********************************)

  Hypothesis eq_dec : forall (x y : A), {x = y}+{x <> y}.

  Lemma list_eq_dec : forall l l':list A, {l = l'} + {l <> l'}.
  Proof. decide equality. Defined.

End ListOps.

(***************************************************)
(** * Applying functions to the elements of a list *)
(***************************************************)

(************)
(** ** Map  *)
(************)

Section Map.
  Variables (A : Type) (B : Type).
  Variable f : A -> B.

  Fixpoint map (l:list A) : list B :=
    match l with
      | [] => []
      | a :: t => (f a) :: (map t)
    end.

  Lemma map_cons (x:A)(l:list A) : map (x::l) = (f x) :: (map l).
  Proof.
    reflexivity.
  Qed.

  Lemma in_map :
    forall (l:list A) (x:A), In x l -> In (f x) (map l).
  Proof.
    induction l; firstorder (subst; auto).
  Qed.

  Lemma in_map_iff : forall l y, In y (map l) <-> exists x, f x = y /\ In x l.
  Proof.
    induction l; firstorder (subst; auto).
  Qed.

  Lemma map_length : forall l, length (map l) = length l.
  Proof.
    induction l; simpl; auto.
  Qed.

  Lemma map_nth : forall l d n,
    nth n (map l) (f d) = f (nth n l d).
  Proof.
    induction l; simpl map; destruct n; firstorder.
  Qed.

  Lemma map_nth_error : forall n l d,
    nth_error l n = Some d -> nth_error (map l) n = Some (f d).
  Proof.
    induction n; intros [ | ] ? Heq; simpl in *; inversion Heq; auto.
  Qed.

  Lemma map_app : forall l l',
    map (l++l') = (map l)++(map l').
  Proof.
    induction l; simpl; auto.
    intros; rewrite IHl; auto.
  Qed.

  Lemma map_rev : forall l, map (rev l) = rev (map l).
  Proof.
    induction l; simpl; auto.
    rewrite map_app.
    rewrite IHl; auto.
  Qed.

  Lemma map_eq_nil : forall l, map l = [] -> l = [].
  Proof.
    destruct l; simpl; reflexivity || discriminate.
  Qed.

  (** [map] and count of occurrences *)

  Hypothesis decA: forall x1 x2 : A, {x1 = x2} + {x1 <> x2}.
  Hypothesis decB: forall y1 y2 : B, {y1 = y2} + {y1 <> y2}.
  Hypothesis Hfinjective: forall x1 x2: A, (f x1) = (f x2) -> x1 = x2.

  Theorem count_occ_map x l:
    count_occ decA l x = count_occ decB (map l) (f x).
  Proof.
    revert x. induction l as [| a l' Hrec]; intro x; simpl.
    - reflexivity.
    - specialize (Hrec x).
      destruct (decA a x) as [H1|H1], (decB (f a) (f x)) as [H2|H2].
      * rewrite Hrec. reflexivity.
      * contradiction H2. rewrite H1. reflexivity.
      * specialize (Hfinjective H2). contradiction H1.
      * assumption.
  Qed.

  (** [flat_map] *)

  Definition flat_map (f:A -> list B) :=
    fix flat_map (l:list A) : list B :=
    match l with
      | nil => nil
      | cons x t => (f x)++(flat_map t)
    end.

  Lemma in_flat_map : forall (f:A->list B)(l:list A)(y:B),
    In y (flat_map f l) <-> exists x, In x l /\ In y (f x).
  Proof using A B.
    induction l; simpl; split; intros.
    contradiction.
    destruct H as (x,(H,_)); contradiction.
    destruct (in_app_or _ _ _ H).
    exists a; auto.
    destruct (IHl y) as (H1,_); destruct (H1 H0) as (x,(H2,H3)).
    exists x; auto.
    apply in_or_app.
    destruct H as (x,(H0,H1)); destruct H0.
    subst; auto.
    right; destruct (IHl y) as (_,H2); apply H2.
    exists x; auto.
  Qed.

End Map.

Lemma flat_map_concat_map : forall A B (f : A -> list B) l,
  flat_map f l = concat (map f l).
Proof.
intros A B f l; induction l as [|x l IH]; simpl.
+ reflexivity.
+ rewrite IH; reflexivity.
Qed.

Lemma concat_map : forall A B (f : A -> B) l, map f (concat l) = concat (map (map f) l).
Proof.
intros A B f l; induction l as [|x l IH]; simpl.
+ reflexivity.
+ rewrite map_app, IH; reflexivity.
Qed.

Lemma map_id : forall (A :Type) (l : list A),
  map (fun x => x) l = l.
Proof.
  induction l; simpl; auto; rewrite IHl; auto.
Qed.

Lemma map_map : forall (A B C:Type)(f:A->B)(g:B->C) l,
  map g (map f l) = map (fun x => g (f x)) l.
Proof.
  induction l; simpl; auto.
  rewrite IHl; auto.
Qed.

Lemma map_ext :
  forall (A B : Type)(f g:A->B), (forall a, f a = g a) -> forall l, map f l = map g l.
Proof.
  induction l; simpl; auto.
  rewrite H; rewrite IHl; auto.
Qed.

(************************************)
(** Left-to-right iterator on lists *)
(************************************)

Section Fold_Left_Recursor.
  Variables (A : Type) (B : Type).
  Variable f : A -> B -> A.

  Fixpoint fold_left (l:list B) (a0:A) : A :=
    match l with
      | nil => a0
      | cons b t => fold_left t (f a0 b)
    end.

  Lemma fold_left_app : forall (l l':list B)(i:A),
    fold_left (l++l') i = fold_left l' (fold_left l i).
  Proof.
    induction l.
    simpl; auto.
    intros.
    simpl.
    auto.
  Qed.

End Fold_Left_Recursor.

Lemma fold_left_length :
  forall (A:Type)(l:list A), fold_left (fun x _ => S x) l 0 = length l.
Proof.
  intros A l.
  enough (H : forall n, fold_left (fun x _ => S x) l n = n + length l) by exact (H 0).
  induction l; simpl; auto.
  intros; rewrite IHl.
  simpl; auto with arith.
Qed.

(************************************)
(** Right-to-left iterator on lists *)
(************************************)

Section Fold_Right_Recursor.
  Variables (A : Type) (B : Type).
  Variable f : B -> A -> A.
  Variable a0 : A.

  Fixpoint fold_right (l:list B) : A :=
    match l with
      | nil => a0
      | cons b t => f b (fold_right t)
    end.

End Fold_Right_Recursor.

  Lemma fold_right_app : forall (A B:Type)(f:A->B->B) l l' i,
    fold_right f i (l++l') = fold_right f (fold_right f i l') l.
  Proof.
    induction l.
    simpl; auto.
    simpl; intros.
    f_equal; auto.
  Qed.

  Lemma fold_left_rev_right : forall (A B:Type)(f:A->B->B) l i,
    fold_right f i (rev l) = fold_left (fun x y => f y x) l i.
  Proof.
    induction l.
    simpl; auto.
    intros.
    simpl.
    rewrite fold_right_app; simpl; auto.
  Qed.

  Theorem fold_symmetric :
    forall (A : Type) (f : A -> A -> A),
    (forall x y z : A, f x (f y z) = f (f x y) z) ->
    forall (a0 : A), (forall y : A, f a0 y = f y a0) ->
    forall (l : list A), fold_left f l a0 = fold_right f a0 l.
  Proof.
    intros A f assoc a0 comma0 l.
    induction l as [ | a1 l ]; [ simpl; reflexivity | ].
    simpl. rewrite <- IHl. clear IHl. revert a1. induction l; [ auto | ].
    simpl. intro. rewrite <- assoc. rewrite IHl. rewrite IHl. auto.
  Qed.

  (** [(list_power x y)] is [y^x], or the set of sequences of elts of [y]
      indexed by elts of [x], sorted in lexicographic order. *)

  Fixpoint list_power (A B:Type)(l:list A) (l':list B) :
    list (list (A * B)) :=
    match l with
      | nil => cons nil nil
      | cons x t =>
	flat_map (fun f:list (A * B) => map (fun y:B => cons (x, y) f) l')
        (list_power t l')
    end.

  (*************************************)
  (** ** Boolean operations over lists *)
  (*************************************)

  Section Bool.
    Variable A : Type.
    Variable f : A -> bool.

  (** find whether a boolean function can be satisfied by an
       elements of the list. *)

    Fixpoint existsb (l:list A) : bool :=
      match l with
	| nil => false
	| a::l => f a || existsb l
      end.

    Lemma existsb_exists :
      forall l, existsb l = true <-> exists x, In x l /\ f x = true.
    Proof.
      induction l; simpl; intuition.
      inversion H.
      firstorder.
      destruct (orb_prop _ _ H1); firstorder.
      firstorder.
      subst.
      rewrite H2; auto.
    Qed.

    Lemma existsb_nth : forall l n d, n < length l ->
      existsb l = false -> f (nth n l d) = false.
    Proof.
      induction l.
      inversion 1.
      simpl; intros.
      destruct (orb_false_elim _ _ H0); clear H0; auto.
      destruct n ; auto.
      rewrite IHl; auto with arith.
    Qed.

    Lemma existsb_app : forall l1 l2,
      existsb (l1++l2) = existsb l1 || existsb l2.
    Proof.
      induction l1; intros l2; simpl.
        solve[auto].
      case (f a); simpl; solve[auto].
    Qed.

  (** find whether a boolean function is satisfied by
    all the elements of a list. *)

    Fixpoint forallb (l:list A) : bool :=
      match l with
	| nil => true
	| a::l => f a && forallb l
      end.

    Lemma forallb_forall :
      forall l, forallb l = true <-> (forall x, In x l -> f x = true).
    Proof.
      induction l; simpl; intuition.
      destruct (andb_prop _ _ H1).
      congruence.
      destruct (andb_prop _ _ H1); auto.
      assert (forallb l = true).
      apply H0; intuition.
      rewrite H1; auto.
    Qed.

    Lemma forallb_app :
      forall l1 l2, forallb (l1++l2) = forallb l1 && forallb l2.
    Proof.
      induction l1; simpl.
        solve[auto].
      case (f a); simpl; solve[auto].
    Qed.
  (** [filter] *)

    Fixpoint filter (l:list A) : list A :=
      match l with
	| nil => nil
	| x :: l => if f x then x::(filter l) else filter l
      end.

    Lemma filter_In : forall x l, In x (filter l) <-> In x l /\ f x = true.
    Proof.
      induction l; simpl.
      intuition.
      intros.
      case_eq (f a); intros; simpl; intuition congruence.
    Qed.

  (** [find] *)

    Fixpoint find (l:list A) : option A :=
      match l with
	| nil => None
	| x :: tl => if f x then Some x else find tl
      end.

    Lemma find_some l x : find l = Some x -> In x l /\ f x = true.
    Proof.
     induction l as [|a l IH]; simpl; [easy| ].
     case_eq (f a); intros Ha Eq.
     * injection Eq as ->; auto.
     * destruct (IH Eq); auto.
    Qed.

    Lemma find_none l : find l = None -> forall x, In x l -> f x = false.
    Proof.
     induction l as [|a l IH]; simpl; [easy|].
     case_eq (f a); intros Ha Eq x IN; [easy|].
     destruct IN as [<-|IN]; auto.
    Qed.

  (** [partition] *)

    Fixpoint partition (l:list A) : list A * list A :=
      match l with
	| nil => (nil, nil)
	| x :: tl => let (g,d) := partition tl in
	  if f x then (x::g,d) else (g,x::d)
      end.

  Theorem partition_cons1 a l l1 l2:
    partition l = (l1, l2) ->
    f a = true ->
    partition (a::l) = (a::l1, l2).
  Proof.
    simpl. now intros -> ->.
  Qed.

  Theorem partition_cons2 a l l1 l2:
    partition l = (l1, l2) ->
    f a=false ->
    partition (a::l) = (l1, a::l2).
  Proof.
    simpl. now intros -> ->.
  Qed.

  Theorem partition_length l l1 l2:
    partition l = (l1, l2) ->
    length l = length l1 + length l2.
  Proof.
    revert l1 l2. induction l as [ | a l' Hrec]; intros l1 l2.
    - now intros [= <- <- ].
    - simpl. destruct (f a), (partition l') as (left, right);
      intros [= <- <- ]; simpl; rewrite (Hrec left right); auto.
  Qed.

  Theorem partition_inv_nil (l : list A):
    partition l = ([], []) <-> l = [].
  Proof.
    split.
    - destruct l as [|a l' _].
      * intuition.
      * simpl. destruct (f a), (partition l'); now intros [= -> ->].
    - now intros ->.
  Qed.

  Theorem elements_in_partition l l1 l2:
    partition l = (l1, l2) ->
    forall x:A, In x l <-> In x l1 \/ In x l2.
  Proof.
    revert l1 l2. induction l as [| a l' Hrec]; simpl; intros l1 l2 Eq x.
    - injection Eq as <- <-. tauto.
    - destruct (partition l') as (left, right).
      specialize (Hrec left right eq_refl x).
      destruct (f a); injection Eq as <- <-; simpl; tauto.
  Qed.

  End Bool.

  (******************************************************)
  (** ** Operations on lists of pairs or lists of lists *)
  (******************************************************)

  Section ListPairs.
    Variables (A : Type) (B : Type).

  (** [split] derives two lists from a list of pairs *)

    Fixpoint split (l:list (A*B)) : list A * list B :=
      match l with
	| [] => ([], [])
	| (x,y) :: tl => let (left,right) := split tl in (x::left, y::right)
      end.

    Lemma in_split_l : forall (l:list (A*B))(p:A*B),
      In p l -> In (fst p) (fst (split l)).
    Proof.
      induction l; simpl; intros; auto.
      destruct p; destruct a; destruct (split l); simpl in *.
      destruct H.
      injection H; auto.
      right; apply (IHl (a0,b) H).
    Qed.

    Lemma in_split_r : forall (l:list (A*B))(p:A*B),
      In p l -> In (snd p) (snd (split l)).
    Proof.
      induction l; simpl; intros; auto.
      destruct p; destruct a; destruct (split l); simpl in *.
      destruct H.
      injection H; auto.
      right; apply (IHl (a0,b) H).
    Qed.

    Lemma split_nth : forall (l:list (A*B))(n:nat)(d:A*B),
      nth n l d = (nth n (fst (split l)) (fst d), nth n (snd (split l)) (snd d)).
    Proof.
      induction l.
      destruct n; destruct d; simpl; auto.
      destruct n; destruct d; simpl; auto.
      destruct a; destruct (split l); simpl; auto.
      destruct a; destruct (split l); simpl in *; auto.
      apply IHl.
    Qed.

    Lemma split_length_l : forall (l:list (A*B)),
      length (fst (split l)) = length l.
    Proof.
      induction l; simpl; auto.
      destruct a; destruct (split l); simpl; auto.
    Qed.

    Lemma split_length_r : forall (l:list (A*B)),
      length (snd (split l)) = length l.
    Proof.
      induction l; simpl; auto.
      destruct a; destruct (split l); simpl; auto.
    Qed.

  (** [combine] is the opposite of [split].
      Lists given to [combine] are meant to be of same length.
      If not, [combine] stops on the shorter list *)

    Fixpoint combine (l : list A) (l' : list B) : list (A*B) :=
      match l,l' with
	| x::tl, y::tl' => (x,y)::(combine tl tl')
	| _, _ => nil
      end.

    Lemma split_combine : forall (l: list (A*B)),
      let (l1,l2) := split l in combine l1 l2 = l.
    Proof.
      induction l.
      simpl; auto.
      destruct a; simpl.
      destruct (split l); simpl in *.
      f_equal; auto.
    Qed.

    Lemma combine_split : forall (l:list A)(l':list B), length l = length l' ->
      split (combine l l') = (l,l').
    Proof.
      induction l; destruct l'; simpl; intros; auto; try discriminate.
      injection H; clear H; intros.
      rewrite IHl; auto.
    Qed.

    Lemma in_combine_l : forall (l:list A)(l':list B)(x:A)(y:B),
      In (x,y) (combine l l') -> In x l.
    Proof.
      induction l.
      simpl; auto.
      destruct l'; simpl; auto; intros.
      contradiction.
      destruct H.
      injection H; auto.
      right; apply IHl with l' y; auto.
    Qed.

    Lemma in_combine_r : forall (l:list A)(l':list B)(x:A)(y:B),
      In (x,y) (combine l l') -> In y l'.
    Proof.
      induction l.
      simpl; intros; contradiction.
      destruct l'; simpl; auto; intros.
      destruct H.
      injection H; auto.
      right; apply IHl with x; auto.
    Qed.

    Lemma combine_length : forall (l:list A)(l':list B),
      length (combine l l') = min (length l) (length l').
    Proof.
      induction l.
      simpl; auto.
      destruct l'; simpl; auto.
    Qed.

    Lemma combine_nth : forall (l:list A)(l':list B)(n:nat)(x:A)(y:B),
      length l = length l' ->
      nth n (combine l l') (x,y) = (nth n l x, nth n l' y).
    Proof.
      induction l; destruct l'; intros; try discriminate.
      destruct n; simpl; auto.
      destruct n; simpl in *; auto.
    Qed.

  (** [list_prod] has the same signature as [combine], but unlike
     [combine], it adds every possible pairs, not only those at the
     same position. *)

    Fixpoint list_prod (l:list A) (l':list B) :
      list (A * B) :=
      match l with
	| nil => nil
	| cons x t => (map (fun y:B => (x, y)) l')++(list_prod t l')
      end.

    Lemma in_prod_aux :
      forall (x:A) (y:B) (l:list B),
	In y l -> In (x, y) (map (fun y0:B => (x, y0)) l).
    Proof.
      induction l;
	[ simpl; auto
	  | simpl; destruct 1 as [H1| ];
	    [ left; rewrite H1; trivial | right; auto ] ].
    Qed.

    Lemma in_prod :
      forall (l:list A) (l':list B) (x:A) (y:B),
	In x l -> In y l' -> In (x, y) (list_prod l l').
    Proof.
      induction l;
	[ simpl; tauto
	  | simpl; intros; apply in_or_app; destruct H;
	    [ left; rewrite H; apply in_prod_aux; assumption | right; auto ] ].
    Qed.

    Lemma in_prod_iff :
      forall (l:list A)(l':list B)(x:A)(y:B),
	In (x,y) (list_prod l l') <-> In x l /\ In y l'.
    Proof.
      split; [ | intros; apply in_prod; intuition ].
      induction l; simpl; intros.
      intuition.
      destruct (in_app_or _ _ _ H); clear H.
      destruct (in_map_iff (fun y : B => (a, y)) l' (x,y)) as (H1,_).
      destruct (H1 H0) as (z,(H2,H3)); clear H0 H1.
      injection H2; clear H2; intros; subst; intuition.
      intuition.
    Qed.

    Lemma prod_length : forall (l:list A)(l':list B),
      length (list_prod l l') = (length l) * (length l').
    Proof.
      induction l; simpl; auto.
      intros.
      rewrite app_length.
      rewrite map_length.
      auto.
    Qed.

  End ListPairs.

(*****************************************)
(** * Miscellaneous operations on lists  *)
(*****************************************)

(******************************)
(** ** Length order of lists  *)
(******************************)

Section length_order.
  Variable A : Type.

  Definition lel (l m:list A) := length l <= length m.

  Variables a b : A.
  Variables l m n : list A.

  Lemma lel_refl : lel l l.
  Proof.
    unfold lel; auto with arith.
  Qed.

  Lemma lel_trans : lel l m -> lel m n -> lel l n.
  Proof.
    unfold lel; intros.
    now_show (length l <= length n).
    apply le_trans with (length m); auto with arith.
  Qed.

  Lemma lel_cons_cons : lel l m -> lel (a :: l) (b :: m).
  Proof.
    unfold lel; simpl; auto with arith.
  Qed.

  Lemma lel_cons : lel l m -> lel l (b :: m).
  Proof.
    unfold lel; simpl; auto with arith.
  Qed.

  Lemma lel_tail : lel (a :: l) (b :: m) -> lel l m.
  Proof.
    unfold lel; simpl; auto with arith.
  Qed.

  Lemma lel_nil : forall l':list A, lel l' nil -> nil = l'.
  Proof.
    intro l'; elim l'; auto with arith.
    intros a' y H H0.
    now_show (nil = a' :: y).
    absurd (S (length y) <= 0); auto with arith.
  Qed.
End length_order.

Hint Resolve lel_refl lel_cons_cons lel_cons lel_nil lel_nil nil_cons:
  datatypes v62.

(******************************)
(** ** Set inclusion on list  *)
(******************************)

Section SetIncl.

  Variable A : Type.

  Definition incl (l m:list A) := forall a:A, In a l -> In a m.
  Hint Unfold incl.

  Lemma incl_refl : forall l:list A, incl l l.
  Proof.
    auto.
  Qed.
  Hint Resolve incl_refl.

  Lemma incl_tl : forall (a:A) (l m:list A), incl l m -> incl l (a :: m).
  Proof.
    auto with datatypes.
  Qed.
  Hint Immediate incl_tl.

  Lemma incl_tran : forall l m n:list A, incl l m -> incl m n -> incl l n.
  Proof.
    auto.
  Qed.

  Lemma incl_appl : forall l m n:list A, incl l n -> incl l (n ++ m).
  Proof.
    auto with datatypes.
  Qed.
  Hint Immediate incl_appl.

  Lemma incl_appr : forall l m n:list A, incl l n -> incl l (m ++ n).
  Proof.
    auto with datatypes.
  Qed.
  Hint Immediate incl_appr.

  Lemma incl_cons :
    forall (a:A) (l m:list A), In a m -> incl l m -> incl (a :: l) m.
  Proof.
    unfold incl; simpl; intros a l m H H0 a0 H1.
    now_show (In a0 m).
    elim H1.
    now_show (a = a0 -> In a0 m).
    elim H1; auto; intro H2.
    now_show (a = a0 -> In a0 m).
    elim H2; auto. (* solves subgoal *)
    now_show (In a0 l -> In a0 m).
    auto.
  Qed.
  Hint Resolve incl_cons.

  Lemma incl_app : forall l m n:list A, incl l n -> incl m n -> incl (l ++ m) n.
  Proof.
    unfold incl; simpl; intros l m n H H0 a H1.
    now_show (In a n).
    elim (in_app_or _ _ _ H1); auto.
  Qed.
  Hint Resolve incl_app.

End SetIncl.

Hint Resolve incl_refl incl_tl incl_tran incl_appl incl_appr incl_cons
  incl_app: datatypes v62.

(**************************************)
(** * Cutting a list at some position *)
(**************************************)

Section Cutting.

  Variable A : Type.

  Fixpoint firstn (n:nat)(l:list A) : list A :=
    match n with
      | 0 => nil
      | S n => match l with
		 | nil => nil
		 | a::l => a::(firstn n l)
	       end
    end.

  Fixpoint skipn (n:nat)(l:list A) : list A :=
    match n with
      | 0 => l
      | S n => match l with
		 | nil => nil
		 | a::l => skipn n l
	       end
    end.

  Lemma firstn_skipn : forall n l, firstn n l ++ skipn n l = l.
  Proof.
    induction n.
    simpl; auto.
    destruct l; simpl; auto.
    f_equal; auto.
  Qed.

  Lemma firstn_length : forall n l, length (firstn n l) = min n (length l).
  Proof.
    induction n; destruct l; simpl; auto.
  Qed.

   Lemma removelast_firstn : forall n l, n < length l ->
     removelast (firstn (S n) l) = firstn n l.
   Proof.
     induction n; destruct l.
     simpl; auto.
     simpl; auto.
     simpl; auto.
     intros.
     simpl in H.
     change (firstn (S (S n)) (a::l)) with ((a::nil)++firstn (S n) l).
     change (firstn (S n) (a::l)) with (a::firstn n l).
     rewrite removelast_app.
     rewrite IHn; auto with arith.

     clear IHn; destruct l; simpl in *; try discriminate.
     inversion_clear H.
     inversion_clear H0.
   Qed.

   Lemma firstn_removelast : forall n l, n < length l ->
     firstn n (removelast l) = firstn n l.
   Proof.
     induction n; destruct l.
     simpl; auto.
     simpl; auto.
     simpl; auto.
     intros.
     simpl in H.
     change (removelast (a :: l)) with (removelast ((a::nil)++l)).
     rewrite removelast_app.
     simpl; f_equal; auto with arith.
     intro H0; rewrite H0 in H; inversion_clear H; inversion_clear H1.
   Qed.

End Cutting.

(**********************************************************************)
(** ** Predicate for List addition/removal (no need for decidability) *)
(**********************************************************************)

Section Add.

  Variable A : Type.

  (* [Add a l l'] means that [l'] is exactly [l], with [a] added
     once somewhere *)
  Inductive Add (a:A) : list A -> list A -> Prop :=
    | Add_head l : Add a l (a::l)
    | Add_cons x l l' : Add a l l' -> Add a (x::l) (x::l').

  Lemma Add_app a l1 l2 : Add a (l1++l2) (l1++a::l2).
  Proof.
   induction l1; simpl; now constructor.
  Qed.

  Lemma Add_split a l l' :
    Add a l l' -> exists l1 l2, l = l1++l2 /\ l' = l1++a::l2.
  Proof.
   induction 1.
   - exists nil; exists l; split; trivial.
   - destruct IHAdd as (l1 & l2 & Hl & Hl').
     exists (x::l1); exists l2; split; simpl; f_equal; trivial.
  Qed.

  Lemma Add_in a l l' : Add a l l' ->
   forall x, In x l' <-> In x (a::l).
  Proof.
   induction 1; intros; simpl in *; rewrite ?IHAdd; tauto.
  Qed.

  Lemma Add_length a l l' : Add a l l' -> length l' = S (length l).
  Proof.
   induction 1; simpl; auto with arith.
  Qed.

  Lemma Add_inv a l : In a l -> exists l', Add a l' l.
  Proof.
   intro Ha. destruct (in_split _ _ Ha) as (l1 & l2 & ->).
   exists (l1 ++ l2). apply Add_app.
  Qed.

  Lemma incl_Add_inv a l u v :
    ~In a l -> incl (a::l) v -> Add a u v -> incl l u.
  Proof.
   intros Ha H AD y Hy.
   assert (Hy' : In y (a::u)).
   { rewrite <- (Add_in AD). apply H; simpl; auto. }
   destruct Hy'; [ subst; now elim Ha | trivial ].
  Qed.

End Add.

(********************************)
(** ** Lists without redundancy *)
(********************************)

Section ReDun.

  Variable A : Type.

  Inductive NoDup : list A -> Prop :=
    | NoDup_nil : NoDup nil
    | NoDup_cons : forall x l, ~ In x l -> NoDup l -> NoDup (x::l).

  Lemma NoDup_Add a l l' : Add a l l' -> (NoDup l' <-> NoDup l /\ ~In a l).
  Proof.
   induction 1 as [l|x l l' AD IH].
   - split; [ inversion_clear 1; now split | now constructor ].
   - split.
     + inversion_clear 1. rewrite IH in *. rewrite (Add_in AD) in *.
       simpl in *; split; try constructor; intuition.
     + intros (N,IN). inversion_clear N. constructor.
       * rewrite (Add_in AD); simpl in *; intuition.
       * apply IH. split; trivial. simpl in *; intuition.
  Qed.

  Lemma NoDup_remove l l' a :
    NoDup (l++a::l') -> NoDup (l++l') /\ ~In a (l++l').
  Proof.
  apply NoDup_Add. apply Add_app.
  Qed.

  Lemma NoDup_remove_1 l l' a : NoDup (l++a::l') -> NoDup (l++l').
  Proof.
  intros. now apply NoDup_remove with a.
  Qed.

  Lemma NoDup_remove_2 l l' a : NoDup (l++a::l') -> ~In a (l++l').
  Proof.
  intros. now apply NoDup_remove.
  Qed.

  Theorem NoDup_cons_iff a l:
    NoDup (a::l) <-> ~ In a l /\ NoDup l.
  Proof.
    split.
    + inversion_clear 1. now split.
    + now constructor.
  Qed.

  (** Effective computation of a list without duplicates *)

  Hypothesis decA: forall x y : A, {x = y} + {x <> y}.

  Fixpoint nodup (l : list A) : list A :=
    match l with
      | [] => []
      | x::xs => if in_dec decA x xs then nodup xs else x::(nodup xs)
    end.

  Lemma nodup_In l x : In x (nodup l) <-> In x l.
  Proof.
    induction l as [|a l' Hrec]; simpl.
    - reflexivity.
    - destruct (in_dec decA a l'); simpl; rewrite Hrec.
      * intuition; now subst.
      * reflexivity.
  Qed.

  Lemma NoDup_nodup l: NoDup (nodup l).
  Proof.
    induction l as [|a l' Hrec]; simpl.
    - constructor.
    - destruct (in_dec decA a l'); simpl.
      * assumption.
      * constructor; [ now rewrite nodup_In | assumption].
  Qed.

  Lemma nodup_inv k l a : nodup k = a :: l -> ~ In a l.
  Proof.
    intros H.
    assert (H' : NoDup (a::l)).
    { rewrite <- H. apply NoDup_nodup. }
    now inversion_clear H'.
  Qed.

  Theorem NoDup_count_occ l:
    NoDup l <-> (forall x:A, count_occ decA l x <= 1).
  Proof.
    induction l as [| a l' Hrec].
    - simpl; split; auto. constructor.
    - rewrite NoDup_cons_iff, Hrec, (count_occ_not_In decA). clear Hrec. split.
      + intros (Ha, H) x. simpl. destruct (decA a x); auto.
        subst; now rewrite Ha.
      + split.
        * specialize (H a). rewrite count_occ_cons_eq in H; trivial.
          now inversion H.
        * intros x. specialize (H x). simpl in *. destruct (decA a x); auto.
          now apply Nat.lt_le_incl.
  Qed.

  Theorem NoDup_count_occ' l:
    NoDup l <-> (forall x:A, In x l -> count_occ decA l x = 1).
  Proof.
    rewrite NoDup_count_occ.
    setoid_rewrite (count_occ_In decA). unfold gt, lt in *.
    split; intros H x; specialize (H x);
    set (n := count_occ decA l x) in *; clearbody n.
    (* the rest would be solved by omega if we had it here... *)
    - now apply Nat.le_antisymm.
    - destruct (Nat.le_gt_cases 1 n); trivial.
      + rewrite H; trivial.
      + now apply Nat.lt_le_incl.
  Qed.

  (** Alternative characterisations of being without duplicates,
      thanks to [nth_error] and [nth] *)

  Lemma NoDup_nth_error l :
    NoDup l <->
    (forall i j, i<length l -> nth_error l i = nth_error l j -> i = j).
  Proof.
    split.
    { intros H; induction H as [|a l Hal Hl IH]; intros i j Hi E.
      - inversion Hi.
      - destruct i, j; simpl in *; auto.
        * elim Hal. eapply nth_error_In; eauto.
        * elim Hal. eapply nth_error_In; eauto.
        * f_equal. apply IH; auto with arith. }
    { induction l as [|a l]; intros H; constructor.
      * intro Ha. apply In_nth_error in Ha. destruct Ha as (n,Hn).
        assert (n < length l) by (now rewrite <- nth_error_Some, Hn).
        specialize (H 0 (S n)). simpl in H. discriminate H; auto with arith.
      * apply IHl.
        intros i j Hi E. apply eq_add_S, H; simpl; auto with arith. }
  Qed.

  Lemma NoDup_nth l d :
    NoDup l <->
    (forall i j, i<length l -> j<length l ->
       nth i l d = nth j l d -> i = j).
  Proof.
    split.
    { intros H; induction H as [|a l Hal Hl IH]; intros i j Hi Hj E.
      - inversion Hi.
      - destruct i, j; simpl in *; auto.
        * elim Hal. subst a. apply nth_In; auto with arith.
        * elim Hal. subst a. apply nth_In; auto with arith.
        * f_equal. apply IH; auto with arith. }
    { induction l as [|a l]; intros H; constructor.
      * intro Ha. eapply In_nth in Ha. destruct Ha as (n & Hn & Hn').
        specialize (H 0 (S n)). simpl in H. discriminate H; eauto with arith.
      * apply IHl.
        intros i j Hi Hj E. apply eq_add_S, H; simpl; auto with arith. }
  Qed.

  (** Having [NoDup] hypotheses bring more precise facts about [incl]. *)

  Lemma NoDup_incl_length l l' :
    NoDup l -> incl l l' -> length l <= length l'.
  Proof.
   intros N. revert l'. induction N as [|a l Hal N IH]; simpl.
   - auto with arith.
   - intros l' H.
     destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. }
     rewrite (Add_length AD). apply le_n_S. apply IH.
     now apply incl_Add_inv with a l'.
  Qed.

  Lemma NoDup_length_incl l l' :
    NoDup l -> length l' <= length l -> incl l l' -> incl l' l.
  Proof.
   intros N. revert l'. induction N as [|a l Hal N IH].
   - destruct l'; easy.
   - intros l' E H x Hx.
     destruct (Add_inv a l') as (l'', AD). { apply H; simpl; auto. }
     rewrite (Add_in AD) in Hx. simpl in Hx.
     destruct Hx as [Hx|Hx]; [left; trivial|right].
     revert x Hx. apply (IH l''); trivial.
     * apply le_S_n. now rewrite <- (Add_length AD).
     * now apply incl_Add_inv with a l'.
  Qed.

End ReDun.

(** NoDup and map *)

(** NB: the reciprocal result holds only for injective functions,
    see FinFun.v *)

Lemma NoDup_map_inv A B (f:A->B) l : NoDup (map f l) -> NoDup l.
Proof.
 induction l; simpl; inversion_clear 1; subst; constructor; auto.
 intro H. now apply (in_map f) in H.
Qed.

(***********************************)
(** ** Sequence of natural numbers *)
(***********************************)

Section NatSeq.

  (** [seq] computes the sequence of [len] contiguous integers
      that starts at [start]. For instance, [seq 2 3] is [2::3::4::nil]. *)

  Fixpoint seq (start len:nat) : list nat :=
    match len with
      | 0 => nil
      | S len => start :: seq (S start) len
    end.

  Lemma seq_length : forall len start, length (seq start len) = len.
  Proof.
    induction len; simpl; auto.
  Qed.

  Lemma seq_nth : forall len start n d,
    n < len -> nth n (seq start len) d = start+n.
  Proof.
    induction len; intros.
    inversion H.
    simpl seq.
    destruct n; simpl.
    auto with arith.
    rewrite IHlen;simpl; auto with arith.
  Qed.

  Lemma seq_shift : forall len start,
    map S (seq start len) = seq (S start) len.
  Proof.
    induction len; simpl; auto.
    intros.
    rewrite IHlen.
    auto with arith.
  Qed.

  Lemma in_seq len start n :
    In n (seq start len) <-> start <= n < start+len.
  Proof.
   revert start. induction len; simpl; intros.
   - rewrite <- plus_n_O. split;[easy|].
     intros (H,H'). apply (Lt.lt_irrefl _ (Lt.le_lt_trans _ _ _ H H')).
   - rewrite IHlen, <- plus_n_Sm; simpl; split.
     * intros [H|H]; subst; intuition auto with arith.
     * intros (H,H'). destruct (Lt.le_lt_or_eq _ _ H); intuition.
  Qed.

  Lemma seq_NoDup len start : NoDup (seq start len).
  Proof.
   revert start; induction len; simpl; constructor; trivial.
   rewrite in_seq. intros (H,_). apply (Lt.lt_irrefl _ H).
  Qed.

End NatSeq.

Section Exists_Forall.

  (** * Existential and universal predicates over lists *)

  Variable A:Type.

  Section One_predicate.

    Variable P:A->Prop.

    Inductive Exists : list A -> Prop :=
      | Exists_cons_hd : forall x l, P x -> Exists (x::l)
      | Exists_cons_tl : forall x l, Exists l -> Exists (x::l).

    Hint Constructors Exists.

    Lemma Exists_exists (l:list A) :
      Exists l <-> (exists x, In x l /\ P x).
    Proof.
      split.
      - induction 1; firstorder.
      - induction l; firstorder; subst; auto.
    Qed.

    Lemma Exists_nil : Exists nil <-> False.
    Proof. split; inversion 1. Qed.

    Lemma Exists_cons x l:
      Exists (x::l) <-> P x \/ Exists l.
    Proof. split; inversion 1; auto. Qed.

    Lemma Exists_dec l:
      (forall x:A, {P x} + { ~ P x }) ->
      {Exists l} + {~ Exists l}.
    Proof.
      intro Pdec. induction l as [|a l' Hrec].
      - right. now rewrite Exists_nil.
      - destruct Hrec as [Hl'|Hl'].
        * left. now apply Exists_cons_tl.
        * destruct (Pdec a) as [Ha|Ha].
          + left. now apply Exists_cons_hd.
          + right. now inversion_clear 1.
    Qed.

    Inductive Forall : list A -> Prop :=
      | Forall_nil : Forall nil
      | Forall_cons : forall x l, P x -> Forall l -> Forall (x::l).

    Hint Constructors Forall.

    Lemma Forall_forall (l:list A):
      Forall l <-> (forall x, In x l -> P x).
    Proof.
      split.
      - induction 1; firstorder; subst; auto.
      - induction l; firstorder.
    Qed.

    Lemma Forall_inv : forall (a:A) l, Forall (a :: l) -> P a.
    Proof.
      intros; inversion H; trivial.
    Qed.

    Lemma Forall_rect : forall (Q : list A -> Type),
      Q [] -> (forall b l, P b -> Q (b :: l)) -> forall l, Forall l -> Q l.
    Proof.
      intros Q H H'; induction l; intro; [|eapply H', Forall_inv]; eassumption.
    Qed.

    Lemma Forall_dec :
      (forall x:A, {P x} + { ~ P x }) ->
      forall l:list A, {Forall l} + {~ Forall l}.
    Proof.
      intro Pdec. induction l as [|a l' Hrec].
      - left. apply Forall_nil.
      - destruct Hrec as [Hl'|Hl'].
        + destruct (Pdec a) as [Ha|Ha].
          * left. now apply Forall_cons.
          * right. now inversion_clear 1.
        + right. now inversion_clear 1.
    Qed.

  End One_predicate.

  Lemma Forall_Exists_neg (P:A->Prop)(l:list A) :
   Forall (fun x => ~ P x) l <-> ~(Exists P l).
  Proof.
   rewrite Forall_forall, Exists_exists. firstorder.
  Qed.

  Lemma Exists_Forall_neg (P:A->Prop)(l:list A) :
    (forall x, P x \/ ~P x) ->
    Exists (fun x => ~ P x) l <-> ~(Forall P l).
  Proof.
   intro Dec.
   split.
   - rewrite Forall_forall, Exists_exists; firstorder.
   - intros NF.
     induction l as [|a l IH].
     + destruct NF. constructor.
     + destruct (Dec a) as [Ha|Ha].
       * apply Exists_cons_tl, IH. contradict NF. now constructor.
       * now apply Exists_cons_hd.
  Qed.

  Lemma Forall_Exists_dec (P:A->Prop) :
    (forall x:A, {P x} + { ~ P x }) ->
    forall l:list A,
    {Forall P l} + {Exists (fun x => ~ P x) l}.
  Proof.
    intros Pdec l.
    destruct (Forall_dec P Pdec l); [left|right]; trivial.
    apply Exists_Forall_neg; trivial.
    intro x. destruct (Pdec x); [now left|now right].
  Qed.

  Lemma Forall_impl : forall (P Q : A -> Prop), (forall a, P a -> Q a) ->
    forall l, Forall P l -> Forall Q l.
  Proof.
    intros P Q H l. rewrite !Forall_forall. firstorder.
  Qed.

End Exists_Forall.

Hint Constructors Exists.
Hint Constructors Forall.

Section Forall2.

  (** [Forall2]: stating that elements of two lists are pairwise related. *)

  Variables A B : Type.
  Variable R : A -> B -> Prop.

  Inductive Forall2 : list A -> list B -> Prop :=
    | Forall2_nil : Forall2 [] []
    | Forall2_cons : forall x y l l',
      R x y -> Forall2 l l' -> Forall2 (x::l) (y::l').

  Hint Constructors Forall2.

  Theorem Forall2_refl : Forall2 [] [].
  Proof. intros; apply Forall2_nil. Qed.

  Theorem Forall2_app_inv_l : forall l1 l2 l',
    Forall2 (l1 ++ l2) l' ->
    exists l1' l2', Forall2 l1 l1' /\ Forall2 l2 l2' /\ l' = l1' ++ l2'.
  Proof.
    induction l1; intros.
      exists [], l'; auto.
      simpl in H; inversion H; subst; clear H.
      apply IHl1 in H4 as (l1' & l2' & Hl1 & Hl2 & ->).
      exists (y::l1'), l2'; simpl; auto.
  Qed.

  Theorem Forall2_app_inv_r : forall l1' l2' l,
    Forall2 l (l1' ++ l2') ->
    exists l1 l2, Forall2 l1 l1' /\ Forall2 l2 l2' /\ l = l1 ++ l2.
  Proof.
    induction l1'; intros.
      exists [], l; auto.
      simpl in H; inversion H; subst; clear H.
      apply IHl1' in H4 as (l1 & l2 & Hl1 & Hl2 & ->).
      exists (x::l1), l2; simpl; auto.
  Qed.

  Theorem Forall2_app : forall l1 l2 l1' l2',
    Forall2 l1 l1' -> Forall2 l2 l2' -> Forall2 (l1 ++ l2) (l1' ++ l2').
  Proof.
    intros. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto.
  Qed.
End Forall2.

Hint Constructors Forall2.

Section ForallPairs.

  (** [ForallPairs] : specifies that a certain relation should
    always hold when inspecting all possible pairs of elements of a list. *)

  Variable A : Type.
  Variable R : A -> A -> Prop.

  Definition ForallPairs l :=
    forall a b, In a l -> In b l -> R a b.

  (** [ForallOrdPairs] : we still check a relation over all pairs
     of elements of a list, but now the order of elements matters. *)

  Inductive ForallOrdPairs : list A -> Prop :=
    | FOP_nil : ForallOrdPairs nil
    | FOP_cons : forall a l,
      Forall (R a) l -> ForallOrdPairs l -> ForallOrdPairs (a::l).

  Hint Constructors ForallOrdPairs.

  Lemma ForallOrdPairs_In : forall l,
    ForallOrdPairs l ->
    forall x y, In x l -> In y l -> x=y \/ R x y \/ R y x.
  Proof.
    induction 1.
    inversion 1.
    simpl; destruct 1; destruct 1; repeat subst; auto.
    right; left. apply -> Forall_forall; eauto.
    right; right. apply -> Forall_forall; eauto.
  Qed.

  (** [ForallPairs] implies [ForallOrdPairs]. The reverse implication is true
    only when [R] is symmetric and reflexive. *)

  Lemma ForallPairs_ForallOrdPairs l: ForallPairs l -> ForallOrdPairs l.
  Proof.
    induction l; auto. intros H.
    constructor.
    apply <- Forall_forall. intros; apply H; simpl; auto.
    apply IHl. red; intros; apply H; simpl; auto.
  Qed.

  Lemma ForallOrdPairs_ForallPairs :
    (forall x, R x x) ->
    (forall x y, R x y -> R y x) ->
    forall l, ForallOrdPairs l -> ForallPairs l.
  Proof.
    intros Refl Sym l Hl x y Hx Hy.
    destruct (ForallOrdPairs_In Hl _ _ Hx Hy); subst; intuition.
  Qed.
End ForallPairs.

(** * Inversion of predicates over lists based on head symbol *)

Ltac is_list_constr c :=
 match c with
  | nil => idtac
  | (_::_) => idtac
  | _ => fail
 end.

Ltac invlist f :=
 match goal with
  | H:f ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | H:f _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | H:f _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | H:f _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | H:f _ _ _ _ ?l |- _ => is_list_constr l; inversion_clear H; invlist f
  | _ => idtac
 end.

(** * Exporting hints and tactics *)

Hint Rewrite
  rev_involutive (* rev (rev l) = l *)
  rev_unit (* rev (l ++ a :: nil) = a :: rev l *)
  map_nth (* nth n (map f l) (f d) = f (nth n l d) *)
  map_length (* length (map f l) = length l *)
  seq_length (* length (seq start len) = len *)
  app_length (* length (l ++ l') = length l + length l' *)
  rev_length (* length (rev l) = length l *)
  app_nil_r (* l ++ nil = l *)
  : list.

Ltac simpl_list := autorewrite with list.
Ltac ssimpl_list := autorewrite with list using simpl.

(* begin hide *)
(* Compatibility notations after the migration of [list] to [Datatypes] *)
Notation list := list (only parsing).
Notation list_rect := list_rect (only parsing).
Notation list_rec := list_rec (only parsing).
Notation list_ind := list_ind (only parsing).
Notation nil := nil (only parsing).
Notation cons := cons (only parsing).
Notation length := length (only parsing).
Notation app := app (only parsing).
(* Compatibility Names *)
Notation tail := tl (only parsing).
Notation head := hd_error (only parsing).
Notation head_nil := hd_error_nil (only parsing).
Notation head_cons := hd_error_cons (only parsing).
Notation ass_app := app_assoc (only parsing).
Notation app_ass := app_assoc_reverse (only parsing).
Notation In_split := in_split (only parsing).
Notation In_rev := in_rev (only parsing).
Notation In_dec := in_dec (only parsing).
Notation distr_rev := rev_app_distr (only parsing).
Notation rev_acc := rev_append (only parsing).
Notation rev_acc_rev := rev_append_rev (only parsing).
Notation AllS := Forall (only parsing). (* was formerly in TheoryList *)

Hint Resolve app_nil_end : datatypes v62.
(* end hide *)

Section Repeat.

  Variable A : Type.
  Fixpoint repeat (x : A) (n: nat ) :=
    match n with
      | O => []
      | S k => x::(repeat x k)
    end.

  Theorem repeat_length x n:
    length (repeat x n) = n.
  Proof.
    induction n as [| k Hrec]; simpl; rewrite ?Hrec; reflexivity.
  Qed.

  Theorem repeat_spec n x y:
    In y (repeat x n) -> y=x.
  Proof.
    induction n as [|k Hrec]; simpl; destruct 1; auto.
  Qed.

End Repeat.

(* Unset Universe Polymorphism. *)


(******************************************************************************)
Require Import Ensembles.
Require Import Coq.Lists.List.
Require Import Arith.
Require Import misc.

Require Import ListExt.
Require Import folProp.
Require Import folProof.
Require Import Languages.
Require Import subAll.
Require Import subProp.
Require Import folLogic3.
Require Import folReplace.
Require Import LNT.
Require Import Max.
Require Import codeNatToTerm.

#[local] Arguments apply _ _ _ : clear implicits.

Fixpoint LNN2LNT_term (t : fol.Term LNN) : Term :=
  match t with
  | var v => var v
  | apply f ts => apply LNT f (LNN2LNT_terms _ ts)
  end

 with LNN2LNT_terms (n : nat) (ts : fol.Terms LNN n) {struct ts} :
 Terms n :=
  match ts in (fol.Terms _ n0) return (Terms n0) with
  | Tnil => @Tnil LNT
  | Tcons m s ss => Tcons (LNN2LNT_term s) (LNN2LNT_terms m ss)
  end.

Definition LTFormula :=
  existH 2 (equal (Plus (var 0) (Succ (var 2))) (var 1)).

Definition translateLT (ts : fol.Terms LNN (arityR LNN LT_)) : Formula.
Proof.
  simpl in ts; destruct  (consTerms _ _ ts) as [(a,b) p].
  destruct  (consTerms _ _ b) as [(a0,b0) p0].
  set (x := LNN2LNT_term a) in *.
  set (y := LNN2LNT_term a0) in *.
  apply (subAllFormula LNT LTFormula).
  intro n; induction n as [| n Hrecn].
  - exact x.
  - induction n  as [| n0 HrecH0].
    + exact y.
    + exact (var n0).
Defined.

Lemma LNN2LNT_natToTerm (n:nat): LNN2LNT_term (natToTermLNN n) = natToTerm n.
Proof.
  induction n as [| n Hrecn].
  - reflexivity.
  - simpl; now rewrite Hrecn.
Qed.

Lemma translateLT1 :
 forall a a0 b0,
 translateLT (Tcons a (Tcons a0 b0)) =
 subAllFormula LNT LTFormula
   (fun H : nat =>
    nat_rec (fun _ : nat => fol.Term LNT) (LNN2LNT_term a)
      (fun (H0 : nat) (_ : fol.Term LNT) =>
       nat_rec (fun _ : nat => fol.Term LNT) (LNN2LNT_term a0)
         (fun (H1 : nat) (_ : fol.Term LNT) => var H1) H0) H).
Proof.
  intros a a0 b0; unfold translateLT.
  destruct (consTerms LNN 1 (Tcons a (Tcons a0 b0))) as [(a1, b) p].
  simpl; destruct (consTerms LNN 0 b) as [(a2, b1) p0].
  simpl in p; inversion p.
  assert (b = Tcons a0 b0)
    by refine (inj_right_pair2 _ eq_nat_dec _ _ _ _ H1).
  rewrite H in p0; simpl in p0; inversion p0; reflexivity.
Qed.

Fixpoint LNN2LNT_formula (f : fol.Formula LNN) : Formula :=
  match f with
  | equal t1 t2 => equal (LNN2LNT_term t1) (LNN2LNT_term t2)
  | atomic r ts =>
      match
        r as l return (fol.Terms LNN (arityR LNN l) -> Formula)
      with
      | LT_ => fun t0 : fol.Terms LNN (arityR LNN LT_) => translateLT t0
      end ts
  | impH A B => impH (LNN2LNT_formula A) (LNN2LNT_formula B)
  | notH A => notH (LNN2LNT_formula A)
  | forallH v A => forallH v (LNN2LNT_formula A)
  end.

Lemma LNN2LNT_or (a b : fol.Formula LNN):
  LNN2LNT_formula (orH a b) =
    orH (LNN2LNT_formula a) (LNN2LNT_formula b).
Proof. reflexivity. Qed.

Lemma LNN2LNT_and (a b : fol.Formula LNN):
 LNN2LNT_formula (andH a b) =
 andH (LNN2LNT_formula a) (LNN2LNT_formula b).
Proof. reflexivity. Qed.

Lemma LNN2LNT_iff (a b : fol.Formula LNN):
 LNN2LNT_formula (iffH a b) =
   iffH (LNN2LNT_formula a) (LNN2LNT_formula b).
Proof. reflexivity. Qed.

Lemma LNN2LNT_exist (v : nat) (a : fol.Formula LNN) :
 LNN2LNT_formula (existH  v a) = existH v (LNN2LNT_formula a).
Proof. reflexivity. Qed.

Lemma LNN2LNT_freeVarTerm (t : fol.Term LNN):
 freeVarTerm LNT (LNN2LNT_term t) = freeVarTerm LNN t.
Proof.
  induction t using
    Term_Terms_ind
    with
    (P0 := fun (n : nat) (ts : fol.Terms LNN n) =>
             freeVarTerms LNT n (LNN2LNT_terms n ts) = freeVarTerms LNN n ts).
  - intros; reflexivity.
  - intros; simpl; repeat rewrite freeVarTermApply; now apply IHt.
  - intros; simpl; reflexivity.
  - transitivity (freeVarTerm LNN t ++ freeVarTerms LNN n t0).
    + rewrite <- IHt0; rewrite <- IHt; reflexivity.
    + reflexivity.
Qed.

Lemma LNN2LNT_freeVarTerms (n : nat) (ts : fol.Terms LNN n):
    freeVarTerms LNT n (LNN2LNT_terms n ts) = freeVarTerms LNN n ts.
Proof.
  induction ts as [| n t ts Hrects].
  - reflexivity.
  - simpl; transitivity (freeVarTerm LNN t ++ freeVarTerms LNN n ts).
    + rewrite <- Hrects; rewrite <- LNN2LNT_freeVarTerm; reflexivity.
    + reflexivity.
Qed.

Lemma LNN2LNT_freeVarFormula (f : fol.Formula LNN) (v : nat):
  In v (freeVarFormula LNT (LNN2LNT_formula f)) <->
    In v (freeVarFormula LNN f).
Proof.
  induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf].
  - simpl; repeat rewrite LNN2LNT_freeVarTerm; tauto.
  - destruct r. (* is LT *)
    simpl.
    destruct (consTerms _ _ t) as [(a,b) p].
    simpl in p; rewrite <- p.
    destruct (consTerms _ _ b) as [(a0, b0) p0].
    simpl in p0; rewrite <- p0.
    rewrite translateLT1.
    rewrite <- (nilTerms _ b0).
    unfold freeVarTerms in |- *.
    fold (freeVarTerm LNN) in |- *.
    rewrite <- app_nil_end.
    split.
    + intros H; decompose record (freeVarSubAllFormula1 _ _ _ _ H) /r.
      intros H x [H0| H0] H2.
      * rewrite <- H0 in H2.
        simpl in H2.
        rewrite LNN2LNT_freeVarTerm in H2; auto with datatypes.
      * destruct H0 as [H0| H0].
        -- rewrite <- H0 in H2.
           simpl in H2.
           rewrite LNN2LNT_freeVarTerm in H2.
           auto with datatypes.
        -- contradiction.
    + intro H; destruct (in_app_or _ _ _ H) as [H0 | H0].
      * eapply freeVarSubAllFormula2.
        simpl in |- *.
        left.
        reflexivity.
        simpl in |- *.
        rewrite LNN2LNT_freeVarTerm.
        auto.
      * eapply freeVarSubAllFormula2.
        simpl in |- *.
        right.
        left.
        reflexivity.
        simpl in |- *.
        rewrite LNN2LNT_freeVarTerm.
        auto.
  - simpl in |- *.
    induction Hrecf1 as (H, H0).
    induction Hrecf0 as (H1, H2).
    split.
    + intros H3; apply in_or_app.
      destruct (in_app_or _ _ _ H3); tauto.
    + intros H3; apply in_or_app.
      destruct (in_app_or _ _ _ H3); tauto.
  - assumption.
  - simpl in |- *.
    induction Hrecf as (H, H0).
    split.
    + intros H1; apply in_in_remove.
      * eapply in_remove_neq; apply H1.
      * apply H; eapply List.in_remove; apply H1.
    + intros H1; apply in_in_remove.
      * eapply in_remove_neq, H1.
      * apply H0.
        eapply in_remove, H1.
Qed.

Lemma LNN2LNT_freeVarFormula1 (f : fol.Formula LNN) (v : nat):
 In v (freeVarFormula LNT (LNN2LNT_formula f)) ->
 In v (freeVarFormula LNN f).
Proof.
  intros ?; destruct (LNN2LNT_freeVarFormula f v); auto.
Qed.

Lemma LNN2LNT_freeVarFormula2 (f : fol.Formula LNN) (v : nat):
  In v (freeVarFormula LNN f) ->
  In v (freeVarFormula LNT (LNN2LNT_formula f)).
Proof.
intros ? ; destruct (LNN2LNT_freeVarFormula f v); auto.
Qed.

Lemma LNN2LNT_subTerm (t : fol.Term LNN) (v : nat) (s : fol.Term LNN):
 LNN2LNT_term (substituteTerm LNN t v s) =
 substituteTerm LNT (LNN2LNT_term t) v (LNN2LNT_term s).
Proof.
  elim t using  Term_Terms_ind
    with
    (P0 := fun (n : nat) (ts : fol.Terms LNN n) =>
             LNN2LNT_terms n (substituteTerms LNN n ts v s) =
               substituteTerms LNT n (LNN2LNT_terms n ts) v
                 (LNN2LNT_term s)).
  - intros n; simpl; destruct (eq_nat_dec v n); auto.
  - simpl in |- *; intros f t0 H; now rewrite H.
  - reflexivity.
  - intros n t0 H t1 H0; simpl; now rewrite H, H0.
Qed.

Lemma LNN2LNT_subTerms
  (n : nat) (ts : fol.Terms LNN n) (v : nat) (s : fol.Term LNN):
  LNN2LNT_terms n (substituteTerms LNN n ts v s) =
    substituteTerms LNT n (LNN2LNT_terms n ts) v (LNN2LNT_term s).
Proof.
  induction ts as [| n t ts Hrects].
  - reflexivity.
  - simpl; now rewrite Hrects,  LNN2LNT_subTerm.
Qed.

(** still fragile proof. Use libhyps *)

Lemma LNN2LNT_subFormula
 (T : System) (f : fol.Formula LNN) (v : nat) (s : fol.Term LNN):
 SysPrf T
   (iffH (LNN2LNT_formula (substituteFormula LNN f v s))
      (substituteFormula LNT (LNN2LNT_formula f) v (LNN2LNT_term s))).
Proof.
  apply sysExtend with (Empty_set Formula).
  -  intros x H; destruct H.
  - generalize f v s; clear T f v s; intro f.
    elim f using Formula_depth_ind2; intros.
    + simpl; rewrite (subFormulaEqual LNT).
      repeat rewrite LNN2LNT_subTerm; apply iffRefl.
    + induction r.
      rewrite subFormulaRelation; simpl.
      destruct (consTerms _ _ t) as [(a,b) p].
      simpl in p; rewrite <- p.
      destruct (consTerms _ _ b) as [(a0,b0) p0].
      simpl in p0; rewrite <- p0.
      rewrite translateLT1.
      apply iffSym; eapply iffTrans.
      * apply (subSubAllFormula LNT).
      * rewrite <- (nilTerms _ b0).
        replace
          (substituteTerms LNN 2 (Tcons a (Tcons a0 (Tnil))) v s)
          with
          (Tcons (substituteTerm _ a v s)
             (Tcons (substituteTerm _ a0 v s) (Tnil))).
        rewrite translateLT1.
        rewrite
          (subAllFormula_ext LNT LTFormula
             (fun H : nat =>
                nat_rec (fun _ : nat => fol.Term LNT)
                  (LNN2LNT_term (substituteTerm LNN a v s))
                  (fun (H0 : nat) (_ : fol.Term LNT) =>
                     nat_rec (fun _ : nat => fol.Term LNT)
                       (LNN2LNT_term (substituteTerm LNN a0 v s))
                       (fun (H1 : nat) (_ : fol.Term LNT) => var H1) H0) H)
             (fun n : nat =>
                substituteTerm LNT
                  (nat_rec (fun _ : nat => fol.Term LNT) (LNN2LNT_term a)
                     (fun (H0 : nat) (_ : fol.Term LNT) =>
                        nat_rec (fun _ : nat => fol.Term LNT) (LNN2LNT_term a0)
                          (fun (H1 : nat) (_ : fol.Term LNT) => var H1) H0) n) v
                  (LNN2LNT_term s))).
        -- apply iffRefl.
        -- intros m H; destruct m as [| n].
           ++ simpl; apply LNN2LNT_subTerm.
           ++ destruct n as [| n].
              ** simpl in |- *.
                 apply LNN2LNT_subTerm.
              ** simpl in H.
                 decompose sum H.
                 discriminate H0.
                 discriminate H1.
        -- reflexivity.
    + rewrite subFormulaImp; simpl.
      rewrite (subFormulaImp LNT).
      apply (reduceImp LNT).
      apply H.
      apply H0.
    + rewrite subFormulaNot.
      simpl; rewrite (subFormulaNot LNT).
      apply (reduceNot LNT).
      apply H.
    + simpl; decompose record (subFormulaForall2 LNN a v v0 s) /r.
      intros x H1 H0 H2 H4; rewrite H4; clear H4.
      decompose record
        (subFormulaForall2 LNT (LNN2LNT_formula a) v v0 (LNN2LNT_term s)) /r.
      intros x0 H4 H3 H5 H7; rewrite H7; clear H7.
      destruct (eq_nat_dec v v0) as [e | ].
      * simpl; apply iffRefl.
      * simpl; apply iffTrans with
          (forallH x0
             (substituteFormula LNT
                (LNN2LNT_formula
                   (substituteFormula LNN
                      (substituteFormula LNN a v (var x)) v0 s)) x
                (var x0))).
        apply (rebindForall LNT).
        intros H6.
        assert
          (H7: In x0
             (freeVarFormula LNT
                (LNN2LNT_formula
                   (substituteFormula LNN
                      (substituteFormula LNN a v (var x))
                      v0 s))))
          by (eapply List.in_remove; apply H6).
        assert
          (H8: In x0
                 (freeVarFormula LNN
                    (substituteFormula LNN (substituteFormula LNN a v
                                              (var x)) v0
                       s)))
          by (apply LNN2LNT_freeVarFormula1; assumption).
        induction (freeVarSubFormula3 _ _ _ _ _ H8).
        assert
          (H10: In x0 (freeVarFormula LNN
                         (substituteFormula LNN a v (var x))))
          by (eapply in_remove; apply H9).
        induction (freeVarSubFormula3 _ _ _ _ _ H10).
        elim H5.
        eapply in_in_remove.
        { eapply in_remove_neq, H11. }
        { apply LNN2LNT_freeVarFormula2.
          eapply in_remove.
          apply H11.
        }
        elim (in_remove_neq _ _ _ _ _ H6).
        destruct H11 as [H11| H11].
        -- auto.
        -- contradiction.
        -- elim H4.
        rewrite LNN2LNT_freeVarTerm.
        assumption.
        -- apply (reduceForall LNT).
           apply (notInFreeVarSys LNT).
           apply
             iffTrans
             with
             (substituteFormula LNT
                (substituteFormula LNT
                   (substituteFormula LNT (LNN2LNT_formula a) v
                      (var x)) v0
                   (LNN2LNT_term s)) x (var x0)).
           apply (reduceSub LNT).
           apply (notInFreeVarSys LNT).
           eapply iffTrans.
           apply H.
           eapply eqDepth.
           symmetry  in |- *; rewrite subFormulaDepth;
             symmetry  in |- *. (*Hack to rewrite the right occ*)
           reflexivity.
           apply depthForall.
           apply (reduceSub LNT).
           apply (notInFreeVarSys LNT).
           eapply iffTrans.
           apply H.
           apply depthForall.
           simpl in |- *.
           apply iffRefl.
           eapply iffTrans.
           apply (subFormulaExch LNT).
           auto.
           rewrite LNN2LNT_freeVarTerm.
           auto.
           simpl in |- *.
           tauto.
           apply (reduceSub LNT).
           apply (notInFreeVarSys LNT).
           apply (subFormulaTrans LNT).
           unfold not in |- *; intros; elim H2.
           apply  in_in_remove.
           { eapply in_remove_neq, H6. }
           { apply LNN2LNT_freeVarFormula1.
             eapply in_remove.
             apply H6.
           }

Qed.

Fixpoint LNT2LNN_term (t : Term) : fol.Term LNN :=
  match t with
  | var v => var v
  | apply f ts => apply LNN f (LNT2LNN_terms _ ts)
  end

 with LNT2LNN_terms (n : nat) (ts : Terms n) {struct ts} :
 fol.Terms LNN n :=
  match ts in (fol.Terms _ n0) return (fol.Terms LNN n0) with
  | Tnil => @Tnil LNN
  | Tcons m s ss => Tcons (LNT2LNN_term s) (LNT2LNN_terms m ss)
  end.

Lemma LNT2LNN_natToTerm (n:  nat) :
  LNT2LNN_term (natToTerm n) = natToTermLNN n.
Proof.
  induction n as [| n Hrecn].
  - reflexivity.
  - simpl; now rewrite Hrecn.
Qed.

Fixpoint LNT2LNN_formula (f : Formula) : fol.Formula LNN :=
  match f with
  | equal t1 t2 => equal (LNT2LNN_term t1) (LNT2LNN_term t2)
  | atomic r ts => match r with
                   end
  | impH A B => impH (LNT2LNN_formula A) (LNT2LNN_formula B)
  | notH A => notH  (LNT2LNN_formula A)
  | forallH v A => forallH v (LNT2LNN_formula A)
  end.

Lemma LNT2LNT_term (t : Term): LNN2LNT_term (LNT2LNN_term t) = t.
Proof.
  elim t using
    Term_Terms_ind
    with
    (P0 := fun (n : nat) (ts : fol.Terms LNT n) =>
             LNN2LNT_terms n (LNT2LNN_terms n ts) = ts);
    simpl in |- *.
  - reflexivity.
  - intros f t0 H.  unfold LNNArityF. now rewrite H.
  - reflexivity.
  - intros n t0 H t1 H0. now rewrite H, H0.
Qed.

Lemma LNT2LNT_formula (f : Formula):
 LNN2LNT_formula (LNT2LNN_formula f) = f.
Proof.
  induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf];
    simpl.
- now repeat rewrite LNT2LNT_term.
- destruct r.
- now rewrite Hrecf1, Hrecf0.
- now rewrite Hrecf.
- now rewrite Hrecf.
Qed.

Lemma LNT2LNN_subTerm  (t : Term) (v : nat) (s : Term):
  LNT2LNN_term (substituteTerm LNT t v s) =
    substituteTerm LNN (LNT2LNN_term t) v (LNT2LNN_term s).
Proof.
  elim t using
    Term_Terms_ind
    with
    (P0 := fun (n : nat) (ts : fol.Terms LNT n) =>
             LNT2LNN_terms n (substituteTerms LNT n ts v s) =
               substituteTerms LNN n (LNT2LNN_terms n ts) v
                 (LNT2LNN_term s)); simpl.
  - intro n; destruct (eq_nat_dec v n); reflexivity.
  - intros f t0 H; rewrite H; reflexivity.
  - reflexivity.
  - intros n t0 H t1 H0; now rewrite H, H0.
Qed.

Lemma LNT2LNN_freeVarTerm ( t : Term):
  freeVarTerm LNN (LNT2LNN_term t) = freeVarTerm LNT t.
Proof.
  elim t using
    Term_Terms_ind
    with
    (P0 := fun (n : nat) (ts : fol.Terms LNT n) =>
             freeVarTerms _ n (LNT2LNN_terms n ts) = freeVarTerms LNT n ts);
    simpl in |- *.
  - reflexivity.
  - intros f t0 H; transitivity
                     (freeVarTerms LNN (LNTFunctionArity f)
                        (LNT2LNN_terms (LNTFunctionArity f) t0)).
    + reflexivity.
    + now rewrite H.
  - reflexivity.
  - intros n t0 H t1 H0; transitivity
                           (freeVarTerm LNN (LNT2LNN_term t0) ++
                              freeVarTerms LNN n (LNT2LNN_terms n t1)).
    + reflexivity.
    + now rewrite H, H0.
Qed.

Lemma LNT2LNN_freeVarFormula (f : Formula):
  freeVarFormula LNN (LNT2LNN_formula f) = freeVarFormula LNT f.
Proof.
  induction f as [t t0| r t| f1 Hrecf1 f0 Hrecf0| f Hrecf| n f Hrecf];
    simpl in |- *.
  - repeat rewrite LNT2LNN_freeVarTerm; reflexivity.
  - destruct r.
  - now rewrite Hrecf1,  Hrecf0.
  - assumption.
  - now rewrite Hrecf.
Qed.

Lemma LNT2LNN_subFormula :
  forall (f : Formula) (v : nat) (s : Term),
    LNT2LNN_formula (substituteFormula LNT f v s) =
      substituteFormula LNN (LNT2LNN_formula f) v (LNT2LNN_term s).
Proof.
  intro f.
  elim f using Formula_depth_ind2; simpl in |- *.
  - intros t t0 v s; now repeat rewrite LNT2LNN_subTerm.
  - intro r; destruct r.
  - intros f0 H f1 H0 v s; rewrite (subFormulaImp LNT).
    simpl; now rewrite H, H0, (subFormulaImp LNN).
  - intros f0 H n H0; rewrite (subFormulaNot LNT); simpl.
    now rewrite H, (subFormulaNot LNN).
  - intros v a H v0 s;
      rewrite (subFormulaForall LNT), (subFormulaForall LNN).
    destruct (eq_nat_dec v v0) as [e | n].
    + reflexivity.
    + rewrite LNT2LNN_freeVarTerm.
      destruct (In_dec eq_nat_dec v (freeVarTerm LNT s)) as [i | i].
      * simpl; repeat rewrite H; simpl.
        -- now rewrite LNT2LNN_freeVarFormula.
        -- apply depthForall.
        -- eapply eqDepth.
           ++ symmetry; rewrite subFormulaDepth; symmetry.
              reflexivity.
           ++ apply depthForall.
      * simpl; rewrite H.
        -- reflexivity.
        -- apply depthForall.
Qed.

Section Translate_Proof.

Variable U : fol.System LNN.
Variable V : System.

Hypothesis
  AxiomsOK :
    forall f : fol.Formula LNN, mem _ U f ->
    exists Axm : Formulas,
    (exists prf : Prf LNT Axm (LNN2LNT_formula f),
       (forall g : Formula, In g Axm -> mem _ V g)) /\
    forall v, In v (freeVarListFormula LNT Axm) ->
              (In v (freeVarFormula LNN f)).

Lemma translatePrf f :
 forall axm, Prf LNN axm f ->
  (forall g, In g axm -> mem _ U g) ->
  exists Axm : Formulas,
    (exists prf : Prf LNT Axm (LNN2LNT_formula f),
       (forall g : Formula, In g Axm -> mem _ V g)) /\
    forall v, In v (freeVarListFormula LNT Axm) ->
              (In v (freeVarListFormula LNN axm)).
Proof.
  intros x x0 H; induction x0
    as
    [A|
      Axm1 Axm2 A B x0_1 Hrecx0_1 x0_0 Hrecx0_0|
      Axm A v n x0 Hrecx0|
      A B|
      A B C|
      A B|
      A v t|
      A v n|
      A B v|
    |
    |
    |
      R|
      f].
  - destruct (AxiomsOK A).
    + apply H; now constructor.
    + exists x; destruct H0 as [H0 H1].
      split.
      * apply H0.
      * intros v H2; simpl; rewrite <- app_nil_end.
        apply H1, H2.
  - assert (H0: forall g : fol.Formula LNN,
               In g Axm2 -> mem (fol.Formula LNN) U g).
    { intros g H0; apply H; apply in_or_app; now right.
    }
    assert (H1: forall g : fol.Formula LNN,
               In g Axm1 -> mem (fol.Formula LNN) U g).
    { intros g H1; apply H; apply in_or_app; now left. }
    destruct (Hrecx0_0 H0) as [x [[x0 I0] Z0]].
    destruct (Hrecx0_1 H1) as [x1 [[x2 I1] Z1]].
    clear H0 H1; rename I0 into H0; rename I1 into H1.
    exists (x1 ++ x);  simpl in x2; split.
    + exists (MP LNT _ _ _ _ x2 x0).
      intros g H2; induction (in_app_or _ _ _ H2); auto.
    + intros v H2;  rewrite freeVarListFormulaApp.
      rewrite freeVarListFormulaApp in H2;  apply in_or_app.
      destruct (in_app_or _ _ _ H2); auto with *.
  - destruct (Hrecx0 H) as [x [[x1 H0] Z]]; exists x.
    assert (H1: ~ In v (freeVarListFormula LNT x)) by firstorder.
    split.
    + exists (GEN LNT _ _ _ H1 x1) ; assumption.
    + assumption.
  - exists (nil (A:=Formula)); split.
    + exists (IMP1 LNT (LNN2LNT_formula A) (LNN2LNT_formula B)).
      contradiction.
    + contradiction.
  - exists (nil (A:=Formula)); split.
    * exists (IMP2 LNT (LNN2LNT_formula A) (LNN2LNT_formula B)
                (LNN2LNT_formula C)); contradiction.
    * contradiction.
  - exists (nil (A:=Formula)); split.
    * exists (CP LNT (LNN2LNT_formula A) (LNN2LNT_formula B)).
      contradiction.
    * contradiction.
  - assert (H0: SysPrf (Empty_set _)
                  (LNN2LNT_formula
                     (impH (forallH v A)
                        (substituteFormula LNN A v t)))).
    { simpl in |- *.
      apply impE with
        (impH (forallH v (LNN2LNT_formula A))
           (substituteFormula LNT (LNN2LNT_formula A) v
              (LNN2LNT_term t))).
      apply iffE1.
      apply (reduceImp LNT).
      apply iffRefl.
      apply iffSym.
      apply LNN2LNT_subFormula.
      exists (nil (A:=Formula)).
      exists (FA1 LNT (LNN2LNT_formula A) v (LNN2LNT_term t)).
      contradiction.
    }
    destruct H0 as [x H0]; exists x; split.
    + destruct H0 as [x0 H0]; exists x0.
      intros g H1; elim (H0 g H1).
    + intros v0 H1; destruct H0.
      * destruct x.
        -- assumption.
        -- assert (H2: In f (f::x)) by  auto with *.
           elim (H0 f H2).
  - exists (nil (A:=Formula)).
    assert (H0: ~ In v (freeVarFormula LNT (LNN2LNT_formula A))).
    { unfold not in |- *; intros; elim n.
      apply LNN2LNT_freeVarFormula1.
      auto.
    } split.
    + exists (FA2 LNT (LNN2LNT_formula A) v H0); contradiction.
    + contradiction.
  - exists (nil (A:=Formula)); split.
    + exists (FA3 LNT (LNN2LNT_formula A) (LNN2LNT_formula B) v);
        contradiction.
    + contradiction.
  - exists (nil (A:=Formula)); split.
    + exists (EQ1 LNT); contradiction.
    + contradiction.
  - exists (nil (A:=Formula)); split.
    + exists (EQ2 LNT); contradiction.
    + contradiction.
  - exists (nil (A:=Formula)); split.
    + exists (EQ3 LNT); contradiction.
    + contradiction.
  - assert (H0: SysPrf (Empty_set _) (LNN2LNT_formula (AxmEq4 LNN R))).
    { induction R; simpl; repeat apply impI.
       apply impE
        with
        (iffH
           (translateLT
              (Tcons (var 2)
                 (Tcons (var 0) (Tnil))))
           (translateLT
              (Tcons (var 3)
                 (Tcons (var 1) (Tnil))))).
      - apply impRefl.
      - repeat rewrite translateLT1; simpl; unfold newVar; simpl.
        apply impE
          with
          (iffH (existH 3 (equal (Plus (var 2) (Succ (var 3))) (var 0)))
             (existH 4 (equal (Plus (var 3) (Succ (var 4))) (var 1)))).
        + apply impRefl.
        + eapply iffTrans with
            (existH 4
               (substituteFormula LNT
                  (equal (Plus (var 2) (Succ (var 3))) (var 0)) 3
                  (var 4))).
          * apply (rebindExist LNT).
            simpl in |- *. intro H0; decompose sum H0.
            -- discriminate H1.
            -- discriminate H2.
          * apply (reduceExist LNT).
            intros (x, (H0, H1)).
            destruct H1 as [x H1| x H1]; [ destruct H1 as [x H1| x H1] |
                                           destruct H1 ].
            -- elim H1.
            -- induction H1.
               simpl in H0.
               decompose sum H0.
               discriminate H1.
               discriminate H2.
            -- simpl in H0; decompose sum H0.
               discriminate H1.
               discriminate H2.
            -- repeat rewrite (subFormulaEqual LNT); simpl.
               apply iffI.
               ++ apply impI.
                  apply eqTrans with (var 0).
                  ** apply eqTrans with (Plus (var 2) (Succ (var 4))).
                     apply eqPlus.
                     apply eqSym.
                     apply Axm.
                     left.
                     left.
                     right.
                     constructor.
                     apply eqRefl.
                     apply Axm.
                     right; constructor.
                  ** apply Axm; left; right; constructor.
               ++ apply impI.
                  apply eqTrans with (var 1).
                  **  apply eqTrans with (Plus (var 3) (Succ (var 4))).
                      fold (Succ (var 4)) in |- *.
                      fold (Plus (var 2) (Succ (var 4))) in |- *.
                      apply eqPlus.
                      apply Axm.
                      left.
                      left.
                      right.
                      constructor.
                      apply eqRefl.
                      apply Axm.
                      right; constructor.
                  ** apply eqSym.
                     apply Axm; left; right; constructor.
    }
    destruct H0 as [x H0]; exists x.
    destruct H0 as [x0 H0]; split.
    + exists x0; intros g H1; elim (H0 g H1).
    + intros v H1; destruct x.
      * assumption.
      * assert (H2: In f (f::x)) by auto with *.
        elim (H0 _ H2).
  - replace (LNN2LNT_formula (AxmEq5 LNN f)) with (AxmEq5 LNT f).
    + exists (nil (A:=Formula)); split.
      * exists (EQ5 LNT f); contradiction.
      * contradiction.
    + induction f; reflexivity.
Qed.

End Translate_Proof.

Lemma translateProof (U : fol.System LNN) (V : System):
    ClosedSystem LNT V ->
    (forall f : fol.Formula LNN,
        mem (fol.Formula LNN) U f -> SysPrf V (LNN2LNT_formula f)) ->
    forall f : fol.Formula LNN,
      folProof.SysPrf LNN U f -> SysPrf V (LNN2LNT_formula f).
Proof.
  intros H H0 f [x H1].
  assert (H2: forall f : fol.Formula LNN,
             mem (fol.Formula LNN) U f ->
             exists Axm : Formulas,
               ex
                 (fun _ : Prf LNT Axm (LNN2LNT_formula f) =>
                    forall g : Formula, In g Axm ->
                                        mem (fol.Formula LNT) V g) /\
                 (forall v : nat,
                     In v (freeVarListFormula LNT Axm) ->
                     In v (freeVarFormula LNN f))).
  { intros f0 H2; destruct (H0 f0 H2) as [x0 H3].
    exists x0; split.
    - apply H3.
    - intros v H4; destruct H3.
      clear x1; induction x0.
      + elim H4.
      + destruct (in_app_or _ _ _ H4) as [H5 | H5].
        *  elim H with v a.
           apply H3.
           auto with *.
           assumption.
        * apply IHx0.
          firstorder.
          apply H5.
  }
  destruct H1.
  destruct (translatePrf U V H2 f x x0 H1).
  exists x1; tauto.
Qed.