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

Require Import Le Gt Minus Bool.

Set Implicit Arguments.

(******************************************************************)
(** * 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.

Section Lists.

  Variable A : Type.

  (** Head and tail *)

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

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

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

  (** The [In] predicate *)
  Fixpoint In (a:A) (l:list A) : Prop :=
    match l with
      | nil => False
      | b :: m => b = a \/ In a m
    end.

End Lists.

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

Import ListNotations.

(** ** Facts about lists *)

Section Facts.

  Variable A : Type.

  (** *** Genereric facts *)

  (** Discrimination *)
  Theorem nil_cons : forall (x:A) (l:list A), [] <> x :: l.
  Proof.
    intros; discriminate.
  Qed.

  (** 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.
  Qed.

  (** *** 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.
  Qed.

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

  (** Characterization of [In] *)

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

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

  Theorem in_nil : forall a:A, ~ In a [].
  Proof.
    unfold not; intros a H; inversion_clear H.
  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.
  subst a; auto.
  exists [], l; auto.
  destruct (IHl H) as (l1,(l2,H0)).
  exists (a::l1), l2; simpl; f_equal; auto.
  Qed.

  (** 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; inversion_clear H; auto.
  Qed.

  (** 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.

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

  (** Discrimination *)
  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.
    discriminate H.
    discriminate H.
  Qed.

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

  Theorem app_nil_r : forall l:list A, l ++ [] = l.
  Proof.
    induction l; simpl; f_equal; auto.
  Qed.

  (* begin hide *)
  (* Deprecated *)
  Theorem app_nil_end : forall (l:list A), l = l ++ [].
  Proof. symmetry; apply app_nil_r. Qed.
  (* 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_equal; auto.
  Qed.

  (* begin hide *)
  (* Deprecated *)
  Theorem app_assoc_reverse : forall l m n:list A, (l ++ m) ++ n = l ++ m ++ n.
  Proof.
     auto using app_assoc.
  Qed.
  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.
  Qed.

  (** 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; discriminate.
    intros H; discriminate H.
  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; discriminate H.
    left; split; auto.
    right; split; auto.
    generalize H.
    generalize (app_nil_r l); intros E.
    rewrite -> E; auto.
    intros.
    injection H.
    intro.
    cut ([] = l ++ a0 :: l0); auto.
    intro.
    generalize (app_cons_not_nil _ _ _ H1); intro.
    elim H2.
  Qed.

  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.
    injection H.
    auto.
    intros a0 b H.
    injection H; intros.
    generalize (app_cons_not_nil _ _ _ H0); destruct 1.
    intros a b H.
    injection H; intros.
    cut ([] = l ++ [a]); auto.
    intro.
    generalize (app_cons_not_nil _ _ _ H2); destruct 1.
    intros a0 b H.
    injection H; intros.
    destruct (IHl l0 a0 b H0).
    split; auto.
    rewrite <- H1; rewrite <- H2; reflexivity.
  Qed.

  (** Compatibility wtih other operations *)

  Lemma app_length : forall l l' : list A, length (l++l') = length l + length l'.
  Proof.
    induction l; simpl; auto.
  Qed.

  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.
    now_show ((a0 = a \/ In a y) \/ In a m).
    elim H0; auto.
    intro H1.
    now_show ((a0 = a \/ In a y) \/ In a m).
    elim (H H1); auto.
  Qed.

  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.
    now_show (In a m).
    elim H; auto; intro H0.
    now_show (In a m).
    elim H0. (* subProof completed *)
    intros y H0 H1.
    now_show (H = a \/ In a (y ++ m)).
    elim H1; auto 4.
    intro H2.
    now_show (H = a \/ In a (y ++ m)).
    elim H2; auto.
  Qed.

  Lemma in_app_iff : forall l l' (a:A), In a (l++l') <-> In a l \/ In a l'.
  Proof.
    split; auto using in_app_or, in_or_app.
  Qed.

  Lemma app_inv_head:
   forall l l1 l2 : list A, l ++ l1 = l ++ l2 -> l1 = l2.
  Proof.
    induction l; simpl; auto; injection 1; auto.
  Qed.

  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.
    absurd (length (x2 :: l2 ++ l) <= length l).
    simpl; rewrite app_length; auto with arith.
    rewrite <- H; auto with arith.
    absurd (length (x1 :: l1 ++ l) <= length l).
    simpl; rewrite app_length; auto with arith.
    rewrite H; auto with arith.
    injection H; clear H; intros; f_equal; eauto.
  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.

  Variable A : Type.

  (*****************************)
  (** ** 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.

  Lemma nth_in_or_default :
    forall (n:nat) (l:list A) (d:A), {In (nth n l d) l} + {nth n l d = d}.
  (* Realizer nth_ok. Program_all. *)
  Proof.
    intros n l d; generalize n; induction l; intro n0.
    right; case n0; trivial.
    case n0; simpl.
    auto.
    intro n1; elim (IHl n1); 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.

  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 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; simpl; intros; auto.
    inversion H.
    destruct n; 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.
    intros.
    inversion H.
    intros l' d n.
    case n; simpl; auto.
    intros; rewrite IHl; 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.
    simpl.
    destruct n; auto.
    intros l' d n.
    case n; simpl; auto.
    intros.
    inversion H.
    intros.
    rewrite IHl; auto with arith.
  Qed.

  (*****************)
  (** ** 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.

  Lemma app_removelast_last :
    forall l d, l <> [] -> l = removelast l ++ [last l d].
  Proof.
    induction l.
    destruct 1; auto.
    intros d _.
    destruct l; auto.
    pattern (a0::l) at 1; rewrite IHl with d; auto; discriminate.
  Qed.

  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)]; try discriminate.
    rewrite H.
    exists (a::l'), a'; auto.
  Qed.

  Lemma removelast_app :
    forall l l', l' <> [] -> removelast (l++l') = l ++ removelast l'.
  Proof.
    induction l.
    simpl; auto.
    simpl; intros.
    assert (l++l' <> []).
    destruct l.
    simpl; auto.
    simpl; discriminate.
    specialize (IHl l' H).
    destruct (l++l'); [elim H0; auto|f_equal; auto].
  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 : forall (l : list A) (x : A), In x l <-> count_occ l x > 0.
  Proof.
    induction l as [|y l].
    simpl; intros; split; [destruct 1 | apply gt_irrefl].
    simpl. intro x; destruct (eq_dec y x) as [Heq|Hneq].
    rewrite Heq; intuition.
    pose (IHl x). intuition.
  Qed.

  Theorem count_occ_inv_nil : forall (l : list A), (forall x:A, count_occ l x = 0) <-> l = [].
  Proof.
    split.
    (* Case -> *)
    induction l as [|x l].
    trivial.
    intro H.
    elim (O_S (count_occ l x)).
    apply sym_eq.
    generalize (H x).
    simpl. destruct (eq_dec x x) as [|HF].
    trivial.
    elim HF; reflexivity.
    (* Case <- *)
    intro H; rewrite H; simpl; reflexivity.
  Qed.

  Lemma count_occ_nil : forall (x : A), count_occ [] x = 0.
  Proof.
    intro x; simpl; reflexivity.
  Qed.

  Lemma count_occ_cons_eq : forall (l : list A) (x y : A), x = y -> count_occ (x::l) y = S (count_occ l y).
  Proof.
    intros l x y H; simpl.
    destruct (eq_dec x y); [reflexivity | contradiction].
  Qed.

  Lemma count_occ_cons_neq : forall (l : list A) (x y : A), x <> y -> count_occ (x::l) y = count_occ l y.
  Proof.
    intros l x y H; simpl.
    destruct (eq_dec x y); [contradiction | reflexivity].
  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.

  (***********************************)
  (** ** 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.
    induction l as [| x l IHl]; destruct l' as [| y l'].
    left; trivial.
    right; apply nil_cons.
    right; unfold not; intro HF; apply (nil_cons (sym_eq HF)).
    destruct (eq_dec x y) as [xeqy|xneqy]; destruct (IHl l') as [leql'|lneql'];
      try (right; unfold not; intro HF; injection HF; intros; contradiction).
    rewrite xeqy; rewrite leql'; left; trivial.
  Qed.

End ListOps.

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

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

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

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

  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.

  (** [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.
    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 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 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.
  intro A.
  cut (forall (l:list A) n, fold_left (fun x _ => S x) l n = n + length l).
  intros.
  exact (H l 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 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 x y:A, f x y = f y x) ->
      forall (a0:A) (l:list A), fold_left f l a0 = fold_right f a0 l.
  Proof.
    destruct l as [| a l].
    reflexivity.
    simpl.
    rewrite <- H0.
    generalize a0 a.
    induction l as [| a3 l IHl]; simpl.
    trivial.
    intros.
    rewrite H.
    rewrite (H0 a2).
    rewrite <- (H a1).
    rewrite (H0 a1).
    rewrite IHl.
    reflexivity.
  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.

  (** [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.

  End Bool.

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

  Section ListPairs.
    Variables A B : Type.

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

    Fixpoint split (l:list (A*B)) : list A * list B :=
      match l with
	| nil => (nil, nil)
	| (x,y) :: tl => let (g,d) := split tl in (x::g, y::d)
      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.

(********************************)
(** ** 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_remove_1 : forall l l' a, NoDup (l++a::l') -> NoDup (l++l').
  Proof.
  induction l; simpl.
  inversion_clear 1; auto.
  inversion_clear 1.
  constructor.
  contradict H0.
  apply in_or_app; destruct (in_app_or _ _ _ H0); simpl; tauto.
  apply IHl with a0; auto.
  Qed.

  Lemma NoDup_remove_2 : forall l l' a, NoDup (l++a::l') -> ~In a (l++l').
  Proof.
  induction l; simpl.
  inversion_clear 1; auto.
  inversion_clear 1.
  contradict H0.
  destruct H0.
  subst a0.
  apply in_or_app; right; red; auto.
  destruct (IHl _ _ H1); auto.
  Qed.

End ReDun.

(***********************************)
(** ** 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.

End NatSeq.

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

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

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

Lemma Exists_nil : forall A (P:A->Prop), Exists P nil <-> False.
Proof. split; inversion 1. Qed.

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

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

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

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

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

Lemma Forall_impl : forall A (P Q : A -> Prop), (forall a, P a -> Q a) ->
  forall l, Forall P l -> Forall Q l.
Proof.
  intros A P Q Himp l H.
  induction H; firstorder.
Qed.

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

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

Theorem Forall2_refl : forall A B (R:A->B->Prop), Forall2 R [] [].
Proof. exact Forall2_nil. Qed.

Theorem Forall2_app_inv_l : forall A B (R:A->B->Prop) l1 l2 l',
  Forall2 R (l1 ++ l2) l' ->
  exists l1' l2', Forall2 R l1 l1' /\ Forall2 R 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 A B (R:A->B->Prop) l1' l2' l,
  Forall2 R l (l1' ++ l2') ->
  exists l1 l2, Forall2 R l1 l1' /\ Forall2 R 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 A B (R:A->B->Prop) l1 l2 l1' l2',
  Forall2 R l1 l1' -> Forall2 R l2 l2' -> Forall2 R (l1 ++ l2) (l1' ++ l2').
Proof.
  intros. induction l1 in l1', H, H0 |- *; inversion H; subst; simpl; auto.
Qed.

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

Definition ForallPairs A (R : A -> A -> Prop) 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 A (R : A -> A -> Prop) : list A -> Prop :=
  | FOP_nil : ForallOrdPairs R nil
  | FOP_cons : forall a l,
     Forall (R a) l -> ForallOrdPairs R l -> ForallOrdPairs R (a::l).
Hint Constructors ForallOrdPairs.

Lemma ForallOrdPairs_In : forall A (R:A->A->Prop) l,
 ForallOrdPairs R 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 : forall A (R:A->A->Prop) l,
 ForallPairs R l -> ForallOrdPairs R 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 A (R:A->A->Prop),
 (forall x, R x x) ->
 (forall x y, R x y -> R y x) ->
 forall l, ForallOrdPairs R l -> ForallPairs R l.
Proof.
 intros A R Refl Sym l Hl x y Hx Hy.
 destruct (ForallOrdPairs_In Hl _ _ Hx Hy); subst; intuition.
Qed.

(** * 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 *)


Require Export GeoCoq.Tarski_dev.Ch05_bet_le.

Ltac eCol := eauto with col.

Section T6_1.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

Lemma bet_out : forall A B C, B <> A -> Bet A B C -> Out A B C.
Proof.
    intros.
    unfold Out.
    repeat split; auto.
    intro; treat_equalities; auto.
Qed.

Lemma bet_out_1 : forall A B C, B <> A -> Bet C B A -> Out A B C.
Proof.
    intros.
    apply bet_out; Between.
Qed.

Lemma out_dec : forall P A B, Out P A B \/ ~ Out P A B.
Proof.
    intros.
    unfold Out.
    elim (bet_dec P A B);intro; elim (bet_dec P B A);intro; elim (eq_dec_points A P);intro; elim (eq_dec_points B P);intro; tauto.
Qed.

Lemma out_diff1 : forall A B C, Out A B C -> B <> A.
Proof.
    intros.
    unfold Out in H.
    spliter.
    assumption.
Qed.

Lemma out_diff2 : forall A B C, Out A B C -> C <> A.
Proof.
    intros.
    unfold Out in H.
    spliter.
    assumption.
Qed.

Lemma out_distinct : forall A B C, Out A B C -> B <> A /\ C <> A.
Proof.
    intros.
    split.
      eapply out_diff1;eauto.
    eapply out_diff2;eauto.
Qed.

Lemma out_col : forall A B C, Out A B C -> Col A B C.
Proof.
    intros.
    unfold Col.
    unfold Out in H.
    spliter.
    induction H1;Between.
Qed.

Lemma l6_2 : forall A B C P,  A<>P -> B<>P -> C<>P -> Bet A P C -> (Bet B P C <-> Out P A B).
Proof.
    intros.
    unfold Out.
    split.
      intros.
      repeat split; try assumption; eapply l5_2;eBetween.
    intro; spliter; induction H5; eBetween.
Qed.

Lemma bet_out__bet : forall A B C P, Bet A P C -> Out P A B -> Bet B P C.
Proof.
    intros A B C P HBet HOut.
    destruct (eq_dec_points C P).
      subst; Between.
    apply (l6_2 A); trivial; destruct HOut as [HPA [HPB]]; auto.
Qed.

Lemma l6_3_1 : forall A B P, Out P A B -> (A<>P /\ B<>P /\ exists C, C<>P /\ Bet A P C /\ Bet B P C).
Proof.
    unfold Out.
    intros.
    spliter.
    repeat split; try assumption.
    induction H1.
      assert(exists C, Bet A P C /\ P <> C) by (apply point_construction_different).
      ex_and H2 C.
      exists C.
      repeat split; eBetween.
    assert(exists C, Bet B P C /\ P <> C) by (apply point_construction_different).
    ex_and H2 C.
    exists C.
    repeat split;eBetween.
Qed.

Lemma l6_3_2 : forall A B P,
  (A<>P /\ B<>P /\ exists C, C<>P /\ Bet A P C /\ Bet B P C) -> Out P A B.
Proof.
    intros.
    spliter.
    ex_and H1 C.
    unfold Out.
    repeat split; try assumption; eapply l5_2; eBetween.
Qed.

Lemma l6_4_1 : forall A B P, Out P A B -> Col A P B /\ ~ Bet A P B.
Proof.
    unfold Out.
    intros.
    spliter.
    unfold Col.
    induction H1; split.
      Between.
      intro; apply H; eapply between_equality;eauto.
      right; left; assumption.
    intro; apply H0; eapply between_equality; eBetween.
Qed.

Lemma l6_4_2 : forall A B P, Col A P B /\ ~ Bet A P B -> Out P A B.
Proof.
    unfold Col.
    intros.
    spliter.
    unfold Out.
    induction H.
      contradiction.
    induction (eq_dec_points A P).
      subst P; intuition.
    induction (eq_dec_points B P).
      subst P; intuition.
    induction H; repeat split; Between.
Qed.

(** out reflexivity. l6_5 *)

Lemma out_trivial : forall P A, A<>P -> Out P A A.
Proof.
    intros.
    unfold Out.
    repeat split; Between.
Qed.

(** out symmetry. *)

Lemma l6_6 : forall P A B, Out P A B -> Out P B A.
Proof.
    unfold Out.
    intuition.
Qed.

(** out transitivity. *)

Lemma l6_7 : forall P A B C, Out P A B -> Out P B C -> Out P A C.
Proof.
    unfold Out.
    intros.
    spliter.
    repeat split; try assumption.
    induction H4; induction H2.
      left; eapply between_exchange4; eauto.
      eapply l5_3; eauto.
      eapply (l5_1 P B); auto.
    right; eBetween.
Qed.

Lemma bet_out_out_bet : forall A B C A' C',
 Bet A B C -> Out B A A' -> Out B C C' -> Bet A' B C'.
Proof.
    intros.
    unfold Out in *.
    spliter.
    induction H5; induction H3.
      assert(Bet A' B C) by (apply outer_transitivity_between2 with A; Between).
      apply outer_transitivity_between with C; auto.
      assert(Bet A' B C) by (apply outer_transitivity_between2 with A; Between).
      apply between_inner_transitivity with C; assumption.
      assert(Bet A' B C) by (apply between_exchange3 with A; Between).
      apply outer_transitivity_between with C; auto.
    assert(Bet A' B C) by (apply between_exchange3 with A; Between).
    eapply between_inner_transitivity with C; assumption.
Qed.

Lemma out2_bet_out : forall A B C X P,
 Out B A C -> Out B X P -> Bet A X C -> Out B A P /\ Out B C P.
Proof.
    intros.
    unfold Out in *.
    spliter.
    induction H5; induction H3.
      repeat split; try assumption.
        left; eapply between_exchange4 with X; try assumption.
        apply between_inner_transitivity with C; assumption.
      apply l5_1 with X; try auto.
      apply between_exchange2 with A; assumption.
      repeat split; try assumption.
        apply l5_3 with X; try assumption.
        apply between_inner_transitivity with C; assumption.
      right; apply between_exchange4 with X; try assumption.
      apply between_exchange2 with A; assumption.
      repeat split; try assumption.
        apply l5_1 with X; try auto.
        apply between_exchange2 with C; Between.
      left; apply between_exchange4 with X; try assumption.
      apply between_inner_transitivity with A; Between.
    repeat split; try assumption.
      right; apply between_exchange4 with X; try assumption.
      apply between_exchange2 with C; Between.
    apply l5_3 with X; try assumption.
    apply between_inner_transitivity with A; Between.
Qed.

Lemma l6_11_uniqueness : forall A B C R X Y,
  Out A X R -> Cong A X B C ->
  Out A Y R -> Cong A Y B C ->
  X=Y.
Proof.
    unfold Out.
    intros.
    spliter.
    assert (Cong A X A Y) by CongR.
    induction H6; induction H4.
      apply l4_19 with A R; try assumption.
      apply l4_3 with A A; Between; Cong.
      assert (Bet A X Y) by eBetween.
      eapply between_cong; eauto.
      assert (Bet A Y X) by eBetween.
      apply sym_equal; apply between_cong with A; Cong.
    assert (Bet A X Y \/ Bet A Y X) by (eapply l5_1; eauto).
    induction H8.
      apply between_cong with A; assumption.
    apply sym_equal; apply between_cong with A; Cong.
Qed.

Lemma l6_11_existence : forall A B C R,
  R<>A -> B<>C -> exists X, Out A X R /\ Cong A X B C.
Proof.
    intros.
    assert (exists X : Tpoint, (Bet A R X \/ Bet A X R) /\ Cong A X B C) by (apply (segment_construction_2);assumption).
    ex_and H1 X.
    exists X.
    unfold Out;repeat split; try intro;treat_equalities;intuition.
Qed.

Lemma segment_construction_3 : forall A B X Y, A <> B -> X <> Y -> exists C, Out A B C /\ Cong A C X Y.
Proof.
    intros.
    destruct (l6_11_existence A X Y B) as [C [HC1 HC2]]; auto.
    apply l6_6 in HC1.
    exists C; auto.
Qed.

Lemma l6_13_1 : forall P A B, Out P A B -> Le
 P A P B -> Bet P A B.
Proof.
    unfold Out.
    intros.
    spliter.
    induction H2; try assumption.
    unfold Le
 in H0.
    ex_and H0 Y.
    assert(Y = A).
      apply (l6_11_uniqueness P P A B); Between; Cong.
        unfold Out; repeat split; auto.
        intro; treat_equalities; auto.
      unfold Out; repeat split; auto.
    subst Y; assumption.
Qed.

Lemma l6_13_2 : forall P A B, Out P A B -> Bet P A B -> Le
 P A P B.
Proof.
    intros.
    unfold Le.
    exists A.
    split; Cong.
Qed.

Lemma l6_16_1 : forall P Q S X, P<>Q -> Col S P Q -> Col X P Q -> Col X P S.
Proof.
    intros.
    destruct (eq_dec_points S P).
      subst; Col.
    assert((Bet P S X \/ Bet P X S) -> (Bet P S X \/ Bet S X P)) by (intro; induction H3; Between).
    unfold Col.
    induction H0;induction H1.
      right; apply H3; eapply (l5_2 Q P); Between.
      induction H1; left; eBetween.
      induction H0; left; eBetween.
    induction H0; induction H1.
      right; apply H3; eapply l5_1; eauto.
      right; right; eBetween.
      right; left; eBetween.
    right; apply H3; eapply l5_3; eBetween.
Qed.

Lemma col_transitivity_1 : forall P Q A B,
  P<>Q -> Col P Q A -> Col P Q B -> Col P A B.
Proof.
    intros.
    induction (eq_dec_points A P).
      subst; unfold Col; Between.
    assert (T:=l6_16_1 P Q A B).
    apply col_permutation_1; apply T; Col.
Qed.

Lemma col_transitivity_2 : forall P Q A B,
 P<>Q -> Col P Q A -> Col P Q B -> Col Q A B.
Proof.
    intros.
    apply (col_transitivity_1 Q P A B);Col.
Qed.

(** Unicity of intersection *)

Lemma l6_21 : forall A B C D P Q,
  ~ Col A B C -> C<>D -> Col A B P -> Col A B Q -> Col C D P -> Col C D Q -> P=Q.
Proof.
    intros.
    elim (eq_dec_points P Q); intro; try assumption.
    cut False.
      intro; intuition.
    apply not_col_distincts in H.
    spliter.
    assert (Col C P Q) by (apply col_transitivity_1 with D; Col).
    assert (Col Q B C).
      induction (eq_dec_points Q A).
        subst; apply col_transitivity_1 with P; Col.
      apply col_transitivity_1 with P; Col; apply col_permutation_1, col_transitivity_1 with A; Col.
    assert (Col A B C).
      induction (eq_dec_points Q A).
        subst Q; assumption.
      induction (eq_dec_points Q B).
        subst; apply col_permutation_2; apply col_transitivity_1 with P; Col.
      apply col_permutation_2; apply col_transitivity_1 with Q; Col.
    contradiction.
Qed.

Lemma col2__eq : forall A B X Y,
  Col A X Y -> Col B X Y -> ~ Col A X B ->
  X = Y.
Proof.
    intros.
    apply l6_21 with A X B X; Col.
    intro; subst; Col.
Qed.

End T6_1.

#[global]
Hint Resolve col_transitivity_1 col_transitivity_2 out_col : col.

Section T6_2.

Context `{TnEQD:Tarski_neutral_dimensionless_with_decidable_point_equality}.

(** This is l6_25 of Tarski *)
Lemma not_col_exists : forall A B,
 A<>B -> exists C, ~ Col A B C.
Proof.
    intros.
    assert (T:=lower_dim_ex).
    induction T.
    induction H0.
    induction H0.
    induction (col_dec A B x).
      induction(col_dec A B x0).
        induction(col_dec A B x1).
          induction (eq_dec_points A x).
            assert (~(Col x x0 x1)) by (unfold Col; auto).
            treat_equalities; eCol.
          assert (Col A x x0)  by eCol.
          assert (Col A x x1)  by eCol.
          assert (Col A x0 x1) by eCol.
          assert (Col x x0 x1) by eCol.
          contradiction.
        exists x1; assumption.
      exists x0; assumption.
    exists x; assumption.
Qed.

(*
Lemma t2_8 : forall A B C D E : Tpoint,
 Bet A B C -> Bet D B E -> Cong A B D B -> Cong B C B E -> Cong A E C D.
Proof.
    intros.
    induction (eq_dec_points A B); try (treat_equalities; Cong).
    assert (Cong A B D B -> Cong B C B E -> Cong A D D A -> Cong B D B A -> Bet A B C -> Bet D B E -> A <> B -> Cong C D E A).
      apply five_segment.
    apply cong_symmetry.
    apply cong_right_commutativity.
    apply H4; Cong; Between.
Qed.
*)

Lemma col3 : forall X Y A B C,
 X <> Y ->
 Col X Y A -> Col X Y B -> Col X Y C ->
 Col A B C.
Proof.
    intros.
    assert (Col X A B) by (apply col_transitivity_1 with Y; assumption).
    induction(eq_dec_points C X).
      subst X; apply col_permutation_1; assumption.
    apply col_permutation_1.
    apply col_transitivity_1 with X; try assumption.
      apply col_permutation_2.
      apply col_transitivity_1 with Y; assumption.
    apply col_permutation_2.
    apply col_transitivity_1 with Y; assumption.
Qed.

Lemma colx : forall A B C X Y, A <> B -> Col X Y A -> Col X Y B -> Col A B C -> Col X Y C.
Proof.
    intros.
    destruct (eq_dec_points X Y).
      subst; Col.
    apply (col3 A B); auto; apply col_permutation_1.
      apply col_transitivity_1 with Y; Col.
      apply (col_transitivity_2 X); Col.
Qed.

Lemma out2__bet : forall A B C, Out A B C -> Out C A B -> Bet A B C.
Proof.
    intros A B C Hout1 Hout2.
    apply l6_4_1 in Hout2.
    destruct Hout2 as [_ Hout2].
    destruct Hout1 as [_ [_ [|]]].
    assumption.
    exfalso.
    apply Hout2.
    assumption.
Qed.

Lemma bet2_le2__le1346 : forall A B C A' B' C', Bet A B C -> Bet A' B' C' -> Le
 A B A' B' -> Le
 B C B' C' ->
  Le
 A C A' C'.
Proof.
  intros A B C A' B' C' HBet HBet' HleAB HleBC.

  elim(eq_dec_points A B).
  { intro.
    subst B.
    apply (le_transitivity _ _ B' C'); auto.
    apply le_comm.
    exists B'.
    split; Between; Cong.
  }
  intro.
  elim(eq_dec_points B C).
  { intro.
    subst C.
    apply (le_transitivity _ _ A' B'); auto.
    exists B'; Cong.
  }
  intro.

  assert(A' <> B') by (intro; subst B'; assert(A = B); auto; apply (le_zero _ _ A'); auto).
  assert(B' <> C') by (intro; subst C'; assert(B = C); auto; apply (le_zero _ _ B'); auto).
  destruct HleAB as [B0 []].
  assert(A' <> B0) by (intro; subst B0; assert(A = B); auto; apply (cong_reverse_identity A'); Cong).
  assert(HC0 := segment_construction A' B0 B C).
  destruct HC0 as [C0 []].
  assert(B0 <> C0) by (intro; subst C0; assert(B = C); auto; apply (cong_reverse_identity B0); auto).
  exists C0.
  split; [|apply (l2_11 _ B _ _ B0); Cong].
  apply (outer_transitivity_between2 _ B0); auto.
  assert(Bet B0 B' C') by (apply between_symmetry; apply (between_inner_transitivity _ _ _ A'); Between).
  apply l6_13_1.
  - elim(eq_dec_points B0 B').
    { intro.
      subst.
      apply (l6_2 _ _ A'); Between.
    }
    intro.
    apply (l6_7 _ _ B').
    apply (l6_2 _ _ A'); Between.
    apply bet_out; auto.
  - apply (le_transitivity _ _ B' C').
      apply (l5_6 B C B' C'); Cong.
      apply le_comm.
      exists B'.
      split; Between; Cong.
Qed.

Lemma bet2_le2__le2356 : forall A B C A' B' C', Bet A B C -> Bet A' B' C' ->
  Le A B A' B' -> Le A' C' A C -> Le B' C' B C.
Proof.
  intros A B C A' B' C' HBet HBet' HLe1 HLe2.
  elim(eq_dec_points A B).
  { intro; treat_equalities.
    apply (le_transitivity _ _ A' C'); auto.
    destruct (l5_12_a A' B' C'); auto.
  }
  intro.
  assert (A<>C) by (intro; treat_equalities; auto).
  destruct (l5_5_1 A B A' B' HLe1) as [B0 [HBet1 HCong1]].
  assert (A<>B0) by (intro; treat_equalities; auto).
  destruct HLe2 as [C0 [HBet2 HCong2]].
    assert (A<>C0) by (intro; treat_equalities; auto).
  assert (Bet A B0 C0).
  { apply l6_13_1.
      apply (l6_7 _ _ B); [|apply (l6_7 _ _ C)]; [apply l6_6| |apply l6_6]; apply bet_out; auto.
    apply (l5_6 A' B' A' C'); Cong.
    destruct (l5_12_a A' B' C'); auto.
  }
  apply (l5_6 B0 C0 B C); Cong; [apply (le_transitivity _ _ B C0)|].
    destruct (l5_12_a B B0 C0); eBetween.
    destruct (l5_12_a B C0 C); eBetween.
    apply cong_commutativity; apply (l4_3 _ _ A _ _ A'); Between; Cong.
Qed.

Lemma bet2_le2__le1245 : forall A B C A' B' C', Bet A B C -> Bet A' B' C' ->
  Le B C B' C' -> Le A' C' A C -> Le A' B' A B.
Proof.
  intros A B C A' B' C'; intros.
  apply le_comm.
  apply (bet2_le2__le2356 C _ _ C'); Le; Between.
Qed.

Lemma cong_preserves_bet : forall B A' A0 E D' D0,
  Bet B A' A0 -> Cong B A' E D' -> Cong B A0 E D0 -> Out E D' D0 ->
  Bet E D' D0.
Proof.
    intros.
    unfold Out in H2.
    spliter.
    induction H4.
      assumption.
    assert (Le
 E D0 E D').
      eapply l5_5_2.
      exists D'.
      split.
        assumption.
      Cong.
    assert(Le
 E D' E D0).
      apply (l5_6 B A' B A0); trivial.
      apply l5_5_2.
      exists A0.
      split.
        assumption.
      Cong.
    assert(Cong E D' E D0).
      apply le_anti_symmetry.
        assumption.
      assumption.
    assert(D0 = D').
      eapply between_cong.
        apply H4.
      Cong.
    subst D'.
    Between.
Qed.

Lemma out_cong_cong : forall B A A0 E D D0,
 Out B A A0 -> Out E D D0 ->
 Cong B A E D -> Cong B A0 E D0 ->
 Cong A A0 D D0.
Proof.
    intros.
    unfold Out in H.
    spliter.
    induction H4.
      assert (Bet E D D0).
        apply (cong_preserves_bet B A A0); assumption.
      apply cong_commutativity.
      eapply l4_3.
        apply between_symmetry.
        apply H4.
        apply between_symmetry.
        apply H5.
        Cong.
      Cong.
    assert (Bet E D0 D).
      apply (cong_preserves_bet B A0 A); trivial.
      apply l6_6.
      assumption.
    eapply l4_3;eBetween;Cong.
Qed.

Lemma not_out_bet : forall A B C, Col A B C -> ~ Out B A C -> Bet A B C.
Proof.
    intros.
    unfold Out in H0.
    induction (eq_dec_points A B).
      subst.
      Between.
    induction (eq_dec_points B C).
      subst.
      Between.
    unfold Col in *.
    decompose [or] H;clear H.
      assumption.
      exfalso.
      apply H0.
      intuition.
    exfalso.
    apply H0.
    intuition.
Qed.

Lemma or_bet_out : forall A B C, Bet A B C \/ Out B A C \/ ~Col A B C.
Proof.
    intros.
    destruct (col_dec A B C); auto.
    destruct (out_dec B A C); auto.
    left; apply not_out_bet; trivial.
Qed.

Lemma not_bet_out : forall A B C,
 Col A B C -> ~Bet A B C -> Out B A C.
Proof.
    intros.
    destruct (or_bet_out A B C) as [HBet|[HOut|HNCol]]; trivial; contradiction.
Qed.

Lemma not_bet_and_out :
 forall A B C,
 ~ (Bet A B C /\ Out B A C).
Proof.
    intros.
    intro.
    spliter.
    unfold Out in H0.
    spliter.
    induction H2.
      assert ( A = B).
        eapply between_equality.
          apply H.
        assumption.
      contradiction.
    assert(C = B).
      eapply between_equality.
        apply between_symmetry.
        apply H.
      assumption.
    contradiction.
Qed.

Lemma out_to_bet :
 forall A B C A' B' C',
  Col A' B' C' ->
 (Out B A C <-> Out B' A' C') ->
  Bet A B C ->
  Bet A' B' C'.
Proof.
    intros.
    induction(out_dec B A C).
      unfold Out in H2.
      spliter.
      induction H4.
        assert( A = B).
          eapply between_equality.
            apply H1.
          assumption.
        contradiction.
      assert(C = B).
        apply(between_symmetry) in H4.
        eapply between_equality.
          apply between_symmetry.
          apply H1.
        apply between_symmetry.
        assumption.
      contradiction.
    destruct H0.
    assert (~Out B' A' C').
      intro.
      apply H2.
      apply H3.
      assumption.
    apply not_out_bet.
      assumption.
    assumption.
Qed.

Lemma col_out2_col  : forall A B C AA CC, Col A B C -> Out B A AA -> Out B C CC -> Col AA B CC.
Proof.
    intros.
    induction H.
      assert (Bet AA B CC).
        eapply bet_out_out_bet.
          apply H.
          assumption.
        assumption.
      unfold Col.
      left.
      assumption.
    induction H.
      assert(Out B AA CC).
        eapply l6_7.
          eapply l6_6.
          apply H0.
        apply l6_6.
        eapply l6_7.
          apply l6_6.
          apply H1.
        apply bet_out.
          unfold Out in *.
          spliter.
          assumption.
          unfold Out in *.
          spliter.
          assumption.
      apply col_permutation_4.
      apply out_col.
      assumption.
    assert(Out B AA CC).
      eapply l6_6.
      eapply l6_7.
        eapply l6_6.
        apply H1.
      eapply l6_6.
      eapply l6_7.
        eapply l6_6.
        apply H0.
      apply bet_out.
        unfold Out in *.
        spliter.
        assumption.
        unfold Out in *.
        spliter.
      apply between_symmetry.
      assumption.
    apply col_permutation_4.
    apply out_col.
    assumption.
Qed.

Lemma bet2_out_out : forall A B C B' C', B <> A -> B' <> A -> Out A C C' -> Bet A B C -> Bet A B' C' -> Out A B B'.
Proof.
    intros.
    induction(eq_dec_points B' C').
      subst C'.
      unfold Out in *.
      spliter.
      repeat split; try assumption.
      induction H5.
        left.
        eapply between_exchange4.
          apply H2.
        assumption.
      eapply l5_3.
        apply H2.
      assumption.
    unfold Out in *.
    spliter.
    repeat split.
      assumption.
      assumption.
    induction H6.
      assert(Bet A B C').
        eapply between_exchange4.
          apply H2.
        assumption.
      eapply l5_3.
        apply H7.
      assumption.
    assert(Bet B' C' C).
      eapply between_exchange3.
        apply H3.
      assumption.
    assert(Bet A B' C).
      eapply outer_transitivity_between.
        apply H3.
        assumption.
      assumption.
    eapply l5_3.
      apply H2.
    assumption.
Qed.

Lemma bet2__out : forall A B C B', A <> B -> A <> B' -> Bet A B C -> Bet A B' C -> Out A B B'.
Proof.
    intros.
    apply bet2_out_out with C C; auto.
    apply bet_neq12__neq in H1; auto.
    apply out_trivial; auto.
Qed.

Lemma out_bet_out_1 : forall A B C P,
 Out P A C -> Bet A B C -> Out P A B.
Proof.
    intros.
    induction (eq_dec_points B P).
      subst P.
      apply False_ind.
      apply (not_bet_and_out A B C).
      split; assumption.
    unfold Out in *.
    spliter.
    repeat split.
      assumption.
      assumption.
    induction H3.
      left.
      eapply between_inner_transitivity.
        apply H3.
      assumption.
    right.
    eapply between_exchange2.
      apply H3.
    apply between_symmetry.
    assumption.
Qed.

Lemma out_bet_out_2 : forall A B C P,
 Out P A C -> Bet A B C -> Out P B C.
Proof.
    intros.
    apply l6_6.
    eapply out_bet_out_1.
      apply l6_6.
      apply H.
    apply between_symmetry.
    assumption.
Qed.

Lemma out_bet__out : forall A B P Q,
 Bet P Q A -> Out Q A B -> Out P A B.
Proof.
    intros A B P Q HBet Hout.
    destruct Hout as [HAQ [HBQ [HQAB|HQBA]]]; [|apply l6_6];
    apply bet_out; eBetween; intro; treat_equalities; auto.
Qed.

Lemma segment_reverse : forall A B C, Bet A B C -> exists B', Bet A B' C /\ Cong C B' A B.
Proof.
  intros.
  destruct (eq_dec_points A B).
    subst B; exists C; finish.
  destruct (segment_construction_3 C A A B) as [B' []]; auto.
    intro; treat_equalities; auto.
  exists B'; split; trivial.
  apply between_symmetry, (cong_preserves_bet A B C); Cong.
  apply l6_6; assumption.
Qed.

Lemma diff_col_ex : forall A B, exists C, A <> C /\ B <> C /\ Col A B C.
Proof.
    intros.
    assert (exists C, Bet A B C /\ B <> C).
      apply point_construction_different.
    ex_and H C.
    exists C.
    split.
      intro.
      induction (eq_dec_points A B).
        subst B.
        subst C.
        intuition.
      treat_equalities.
      auto.
    assert_cols.
    auto.
Qed.

Lemma diff_bet_ex3 : forall A B C,
 Bet A B C ->
 exists D, A <> D /\ B <> D /\ C <> D /\ Col A B D.
Proof.
    intros.
    induction (eq_dec_points A B).
      induction (eq_dec_points B C).
        assert (exists D, Bet B C D /\ C <> D).
          apply point_construction_different.
        ex_and H2 D.
        exists D.
        repeat split.
          subst C.
          subst A.
          assumption.
          subst A.
          subst C.
          assumption.
          assumption.
        unfold Col.
        left.
        subst A.
        subst C.
        assumption.
      assert (exists D, Bet B C D /\ C <> D).
        apply point_construction_different.
      ex_and H2 D.
      exists D.
      repeat split.
        intro.
        subst D.
        apply between_symmetry in H.
        apply H1.
        eapply between_equality.
          apply H2.
        apply H.
        intro.
        subst D.
        subst A.
        apply between_identity in H2.
        apply H3.
        subst B.
        reflexivity.
        assumption.
      unfold Col.
      left.
      eapply outer_transitivity_between.
        apply H.
        apply H2.
      assumption.
    induction (eq_dec_points B C).
      subst C.
      cut(exists D : Tpoint, A <> D /\ B <> D /\ Col A B D).
        intro.
        ex_and H1 D.
        exists D.
        repeat split.
          assumption.
          assumption.
          assumption.
        assumption.
      apply diff_col_ex.
    assert (exists D, Bet B C D /\ C <> D).
      apply point_construction_different.
    ex_and H2 D.
    exists D.
    repeat split.
      intro.
      subst D.
      assert (B = C).
        eapply between_equality.
          apply H2.
        apply between_symmetry.
        assumption.
      apply H1.
      assumption.
      intro.
      subst D.
      apply between_identity in H2.
      subst C.
      apply H1.
      reflexivity.
      assumption.
    unfold Col.
    left.
    eapply outer_transitivity_between.
      apply H.
      assumption.
    assumption.
Qed.

Lemma diff_col_ex3 : forall A B C,
 Col A B C -> exists D, A <> D /\ B <> D /\ C <> D /\ Col A B D.
Proof.
    intros.
    assert(cas1 := diff_bet_ex3 A B C).
    assert(cas2 := diff_bet_ex3 B C A).
    assert(cas3 := diff_bet_ex3 C A B).
    unfold Col in H.
    induction H.
      apply (diff_bet_ex3 A B C).
      assumption.
    induction H.
      assert (HH:=H).
      induction (eq_dec_points B C).
        subst C.
        assert (exists C, A <> C /\ B <> C /\ Col A B C).
          apply (diff_col_ex).
        ex_and H0 D.
        exists D.
        repeat split; assumption.
      apply cas2 in HH.
      ex_and HH D.
      exists D.
      repeat split; try assumption.
      apply col_permutation_2.
      eapply col_transitivity_1.
        apply H0.
        assumption.
      unfold Col.
      left.
      assumption.
    induction (eq_dec_points A C).
      subst C.
      assert (exists C, A <> C /\ B <> C /\ Col A B C).
        apply (diff_col_ex).
      ex_and H0 D.
      exists D.
      repeat split; assumption.
    assert (HH:=H).
    apply cas3 in HH.
    ex_and HH D.
    exists D.
    repeat split; try assumption.
    apply col_permutation_5.
    eapply col_transitivity_1.
      apply H0.
      apply col_permutation_4.
      assumption.
    unfold Col.
    right;right.
    apply between_symmetry.
    assumption.
Qed.

Lemma Out_cases : forall A B C, Out A B C \/ Out A C B -> Out A B C.
Proof.
    intros.
    induction H.
      assumption.
    apply l6_6.
    assumption.
Qed.

End T6_2.

#[global]
Hint Resolve bet_out bet_out_1 out_trivial l6_6 : out.

Ltac Out := auto 4 with out.


Set Warnings "-notation-overridden,-parsing".
Require Export List.
(** * Полиморфизм *)

(* ================================================================= *)
(** ** Пары *)

Module pairs.

(* Для каждого базового типа определяем тип рары *)

Inductive bool : Set :=
| true : bool
| false : bool
.
Inductive boolprod : Set :=
| boolpair : bool -> bool -> boolprod
.

Inductive day : Set :=
| monday
| tuesday
| wendnsday
| thursday
| friday
| saturday
| sunday
.
Inductive dayprod : Set :=
| daypair : day -> day -> dayprod.

Inductive nat : Set :=
| O : nat
| S : nat -> nat
.
Inductive natprod : Set :=
| natpair : nat -> nat -> natprod.

(* Можно дать общее определение *)

Inductive prodset (X Y : Set) : Set :=
| pairset : X -> Y -> prodset X Y
.

Inductive prodtype' (X Y : Type) : Type :=
| pairtype' : X -> Y -> prodtype' X Y
.

Compute (pairtype' bool nat true O).

Check prodtype'.
Check pairtype' bool bool.
Check pairtype'.

Compute (pairtype' _ _ true O).

Compute (pairtype' _ _ monday (pairtype' _ _ false 4)).

Arguments pairtype' {X} {Y} _ _.

Compute (pairtype' true O).

Inductive prod {X Y : Type} : Type :=
| pair : X -> Y -> prod
.
Compute (pair true O).

End pairs.

Notation "( x , y )" := (pair x y).
Notation "X * Y" := (prod X Y).

Definition fst {X Y : Type} (p : X * Y) : X :=
  match p with
  | (x, _) => x
  end.

Definition snd {X Y : Type} (p : X * Y) : Y :=
  match p with
  | (_, y) => y
  end.

Definition swap {X Y : Type} (p : X * Y) : Y * X :=
  match p with
  | (x, y) => (y, x)
  end.

Compute (swap (true, 13)).

Inductive day : Set :=
| monday
| tuesday
| wendnsday
| thursday
| friday
| saturday
| sunday
.
Compute (monday, (false, 4)).

(** ** Списки *)

Reset Initial.

Inductive boollist : Type :=
  | boolnil : boollist
  | boolcons : bool -> boollist -> boollist.

  Inductive natlist : Type :=
  | natnil : natlist
  | natcons : nat -> natlist -> natlist.

Inductive list (X : Type) : Type :=
  | nil : list X
  | cons : X -> list X -> list X.

Check list.
(* ===> list : Type -> Type *)

Check (nil nat).
(* ===> nil nat : list nat *)

Check (cons nat 3 (nil nat)).
(* ===> cons nat 3 (nil nat) : list nat *)

Check nil.
(* ===> nil : forall X : Type, list X *)

Check cons.
(* ===> cons : forall X : Type, X -> list X -> list X *)

Check (cons nat 2 (cons nat 1 (nil nat))).

Fixpoint repeat (X : Type) (x : X) (count : nat) : list X :=
  match count with
  | 0 => nil X
  | S count' => cons X x (repeat X x count')
  end.

Compute (repeat nat 4 2).

Example test_repeat1 :
  repeat nat 4 2 = cons nat 4 (cons nat 4 (nil nat)).
Proof. reflexivity.  Qed.

(** To use [repeat] to build other kinds of lists, we simply
    instantiate it with an appropriate type parameter: *)

Compute (repeat bool false 4).

Example test_repeat2 :
  repeat bool false 1 = cons bool false (nil bool).
Proof. reflexivity.  Qed.

Fixpoint repeat'' X x count : list X :=
  match count with
  | 0        => nil _
  | S count' => cons _ x (repeat'' X x count')
  end.

Definition list123 :=
  cons nat 1 (cons nat 2 (cons nat 3 (nil nat))).

Definition list123' :=
  cons _ 1 (cons _ 2 (cons _ 3 (nil _))).

Arguments nil {X}.
Arguments cons {X} _ _.
Arguments repeat {X} x count.

Compute (cons 1 (cons 2 (cons 3 nil))).

Fixpoint repeat''' {X : Type} (x : X) (count : nat) : list X :=
  match count with
  | 0        => nil
  | S count' => cons x (repeat''' x count')
  end.

(*  механизм неявных типов обычно не используется при
    определении самих индуктивных типов *)

Inductive list' {X : Type} : Type :=
  | nil' : list'
  | cons' : X -> list' -> list'.

  Fixpoint app' {X : Type} (l1 l2 : @list' X) : list' :=
  match l1 with
  | nil'      => l2
  | cons' h t => cons' h (app' t l2)
  end.

Fixpoint app {X : Type} (l1 l2 : list X) : (list X) :=
  match l1 with
  | nil      => l2
  | cons h t => cons h (app t l2)
  end.

  Notation "x ++ y" := (app x y)
                     (right associativity, at level 60).
                     Notation "[ ]" := nil.

                     Notation "n :: l" := (cons  n l)
                                          (at level 60, right associativity).
                     Notation "[ x ; .. ; y ]" := (cons x .. (cons y nil) ..).

Fixpoint rev {X : Type} (l : list X) : list X :=
match l with
| nil => nil
| h :: t => (rev t) ++ [h]
end.

Fixpoint length {X : Type} (l : list X) : nat :=
match l with
| [] => O
| n :: l' => S (length l')
end.

Example test_rev1 :
  rev (cons 1 (cons 2 nil)) = (cons 2 (cons 1 nil)).
Proof.
  reflexivity.
Qed.

Example test_rev2:
  rev (cons true nil) = cons true nil.
Proof.
  reflexivity.
Qed.

Example test_length1: length (cons 1 (cons 2 (cons 3 nil))) = 3.
Proof.
  reflexivity.
Qed.

Notation "x :: y" := (cons x y)
 (at level 60, right associativity).
Notation "[ ]" := nil.
Notation "[ x ; .. ; y ]" := (cons x .. (cons y []) ..).
Notation "x ++ y" := (app x y) (at level 60, right associativity).

Compute ([1; 2; 3]).
Compute ([true; false; false]).

Definition list123_ := [1; 2; 3].

Theorem app_nill_r :
  forall (X : Type) (l : list X),
  l ++ [] = l.
Proof.
  intros*.
  induction l; simpl. reflexivity.
  rewrite IHl. reflexivity.
Qed.

Theorem app_assoc :
  forall X (l m n : list X),
  l ++ m ++ n = (l ++ m) ++ n.
Proof.
  intros*.
  induction l; simpl. reflexivity.
  rewrite IHl. reflexivity.
Qed.

Lemma app_length :
  forall (X : Type)(l1 l2 : list X),
  length (l1 ++ l2) = (length l1) + (length l2).
Proof.
  intros*.
  induction l1; simpl. reflexivity.
  rewrite IHl1. reflexivity.
Qed.

Theorem rev_app_distr: forall X (l1 l2 : list X),
  rev (l1 ++ l2) = rev l2 ++ rev l1.
Proof.
  intros*.
  induction l1; simpl.
  -rewrite app_nill_r. reflexivity.
  -rewrite IHl1. rewrite app_assoc. reflexivity.
Qed.

Theorem rev_involutive : forall X : Type, forall l : list X,
  rev (rev l) = l.
Proof.
  intros*.
  induction l; simpl. reflexivity.
  rewrite rev_app_distr. rewrite IHl. reflexivity.
Qed.

Fixpoint combine {X Y : Type} (lx : list X) (ly : list Y)
           : list (X * Y) :=
  match lx, ly with
  | [], _ => []
  | _, [] => []
  | x :: tx, y :: ty => (x, y) :: (combine tx ty)
  end.

Check @combine.
(*  ==> forall X Y : Type, list X -> list Y -> list (X * Y)
*)
(* какой тип у этой функции? чему равно значение *)
Compute (combine [1;2] [false;false;true;true]).
(* ==> [(1, false); (2, false)] *)

(* обратная фнукция к [combine] *)

Fixpoint split {X Y : Type} (l : list (X * Y)) : (list X) * (list Y) :=
match l with
| [] => ([], [])
| (f, s) :: t => ((f :: fst (split t)), (s :: snd (split t)))
end.

Example test_split:
  split [(1,false);(2,false)] = ([1;2],[false;false]).
Proof.
  reflexivity.
Qed.

Theorem app_eq_nil :
  forall (A : Type) (l l' : list A),
  l ++ l' = [] -> l = [] /\ l' = [].
Proof.
  destruct l as [| x l]; destruct l' as [| y l']; simpl; auto.
  intro; discriminate.
  intros H. discriminate H.
Qed.

Theorem app_comm_cons :
forall A : Type,
  forall (x y:list A) (a:A),
  a :: (x ++ y) = (a :: x) ++ y.
Proof.
  intros*.
  induction x; simpl; reflexivity.
Qed.

Fixpoint take {A : Type} (n : nat) (l : list A) : list A :=
match n with
|O => nil
|S n' => match l with
      |nil => nil
      |h :: t => h :: take n' t
      end
end.

Fixpoint skip {A : Type} (n : nat) (l : list A) : list A :=
match n with
|O => l
|S n' => match l with
      |nil => nil
      |h :: t => skip n' t
      end
end.

Compute (take 5 [1;2;3;4;5;6;7]).
Compute (skip 5 [1;2;3;4;5;6;7]).

Lemma firstn_skipn :
  forall (A : Type) (n : nat) (l : list A),
  take n l ++ skip n l = l.
Proof.
  intros*.
  induction n. simpl. reflexivity.
  rewrite <- IHn.

Qed.


Require Import List.

Require Import defns.

Require Import nl_fusion.
Require Import nl_eq.
Require Import nl_sgn.
Require Import nl_whr.

(**
    * Structural and algorithmic equality

 **)

(** streq and algeq symmetry **)
Lemma streq_nl_te_symmetry:
  forall (sS : snsgn) (sG : snctx) (M N : nte) (tau : snTy),
    ( streq_nl_te sS sG M N tau ) ->
    ( streq_nl_te sS sG N M tau )
with algeq_nl_te_symmetry:
  forall (sS : snsgn) (sG : snctx) (M N : nte) (tau : snTy),
    ( algeq_nl_te sS sG M N tau ) ->
    ( algeq_nl_te sS sG N M tau ).
Proof.
  (* lemma 1 *)
  intros.
  induction H.
  apply streq_nl_te_var_zero; assumption.
  apply streq_nl_te_var_succ; assumption.
  apply streq_nl_te_con; assumption.
  apply streq_nl_te_pi_elim with tau2.
  assumption.
  apply algeq_nl_te_symmetry; assumption.
  (* lemma 2 *)
  intros.
  induction H.
  apply algeq_nl_te_whr_r with nM'; assumption.
  apply algeq_nl_te_whr_l with nN'; assumption.
  apply algeq_nl_te_streq.
  apply streq_nl_te_symmetry; assumption.
  apply algeq_nl_te_eta_exp with nN' nM'; assumption.
Qed.

(** determinacy of streq **)

Lemma streq_nl_te_determinacy_l:
  forall (sS : snsgn) (sG : snctx) (M N : nte) (tau : snTy),
    ( streq_nl_te sS sG M N tau ) -> ~ (exists M', whr_nl_te M M').
Proof.
  intros sS sG M N tau H.
  induction H.
  - intro Hc.
    decompose record Hc.
    inversion H0.
  - intro Hc.
    decompose record Hc.
    inversion H1.
  - intro Hc.
    decompose record Hc.
    inversion H1.
  - intro.
    destruct nM1.
    + decompose record H1.
      inversion H2.
      inversion H6.
    + decompose record H1.
      inversion H2.
      inversion H6.
    + decompose record H1.
      inversion H2.
      inversion H6.
    + inversion H.
    + apply IHstreq_nl_te.
      decompose record H1.
      inversion H2.
      exists nM'.
      assumption.
Qed.

Lemma streq_nl_te_determinacy_r:
  forall (sS : snsgn) (sG : snctx) (M N : nte) (tau : snTy),
    ( streq_nl_te sS sG M N tau ) -> ~ (exists N', whr_nl_te N N').
Proof.
  intros.
  eauto using streq_nl_te_determinacy_l, streq_nl_te_symmetry.
Qed.

Lemma streq_nl_te_ixc_determinacy:
  forall (ixc ixc': Ixc) (sS : snsgn) (sG : snctx) (tau : snTy),
  streq_nl_te sS sG (termstar_nl_ixc ixc) (termstar_nl_ixc ixc') tau ->
  forall (tau' : snTy),
    streq_nl_te sS sG (termstar_nl_ixc ixc) (termstar_nl_ixc ixc') tau' ->
    tau = tau'.
Proof.
  intro.
  induction ixc; intros ixc' sS sG tau Hstreq1 tau' Hstreq2.
  - inversion Hstreq1 as [ sS' sG' tau0 HwfsS HsS' HsG' | | | ].
    inversion Hstreq2 as [ sS'' sG'' tau1 HwfsS'' HsS'' HsG'' | | | ].
    rewrite <- HsG' in HsG''.
    inversion HsG''.
    eauto using eq_trans.
  - (* step *)
    inversion Hstreq1 as [ sS' sG' tau0 HwfsS HsS' HsG' | | | ].
    inversion Hstreq2 as [ sS'' sG'' tau1 HwfsS'' HsS'' HsG'' | | | ].
    eapply IHixc.
    eauto.
    rewrite <- H11 in H4; inversion H4.
    rewrite <- H9 in H2; inversion H2.
    eauto.
Qed.

Lemma streq_nl_te_strong_determinacy:
  forall (sS : snsgn) (sG : snctx) (M N : nte) (tau : snTy),
    ( streq_nl_te sS sG M N tau ) ->
    forall tau' , ( streq_nl_te sS sG M N tau' ) ->
    tau = tau'.
Proof.
  intros.
  generalize dependent tau'.
  induction H.
  intros.
  inversion H0.
  reflexivity.
  (* ixc *)
  intros.
  inversion H1.
  eauto using streq_nl_te_ixc_determinacy.
  (* con *)
  intros.
  inversion H1.
  eauto using boundsnCon_determinacy.
  (* pi_elim *)
  intros.
  inversion H1.
  assert (stype_nl_pi_intro tau2 tau1 = stype_nl_pi_intro tau3 tau').
  apply IHstreq_nl_te.
  assumption.
  inversion H11.
  reflexivity.
Qed.

(** streq is preserved along cs **)
(*
Fixpoint streq_nl_te_cs (sS : snsgn) (sG sG' : snctx) (M M' N N' : nte) (tau tau' : snTy) (i : Ixc)
  (H : streq_nl_te sS sG M N tau ) {struct H}:
    cs_nte M i M' -> cs_nte N i N' -> cs_snctx sG i tau' sG' ->
    ( streq_nl_te sS sG' M' N' tau )
with algeq_nl_te_cs (sS : snsgn) (sG sG' : snctx) (M M' N N' : nte) (tau tau' : snTy) (i : Ixc)
    (H : algeq_nl_te sS sG M N tau ) {struct H}:
    cs_nte M i M' -> cs_nte N i N' -> cs_snctx sG i tau' sG' ->
    ( algeq_nl_te sS sG' M' N' tau ).
Proof.
  intros.
  generalize dependent N'.
  generalize dependent M'.
  generalize dependent i.
  generalize dependent tau'.
  generalize dependent sG'.

  induction H.

  intros.
  inversion H0.
  rewrite <- H3 in H1; inversion H1.
  rewrite <- H3 in H2; inversion H2.
  inversion H9; constructor; auto; constructor; auto.

  rewrite <- H4 in H1; inversion H1.
  rewrite <- H4 in H2; inversion H2.
  constructor; auto.

  (* S ixc *)
  intros.
  inversion H1.
  rewrite <- H4 in H3; inversion H3.
  rewrite <- H4 in H2; inversion H2.

  constructor; auto.
  eapply IHstreq_nl_te.
  exact H10.
  constructor.
  constructor.

  rewrite <- H6 in H3; inversion H3.
  rewrite <- H6 in H2; inversion H2.

  constructor; auto.
  eapply IHstreq_nl_te; eauto.

  intros.
  inversion H1.
  inversion H3.
  constructor; auto.

  intros.
  inversion H1.
  inversion H3.
  econstructor.
  eapply IHstreq_nl_te; eauto.
  eapply algeq_nl_te_cs; eauto.

  (* lemma 2 *)
  intros.
  generalize dependent N'.
  generalize dependent M'.
  generalize dependent tau'.
  generalize dependent i.
  generalize dependent sG'.
  induction H.

  intros.
  assert ({nM'' | cs_nte nM' i nM''}) by (eapply cs_nte_dec).
  inversion H4.

  eapply algeq_nl_te_whr_l.
  eapply whr_nl_te_cs; eauto.
  eapply IHalgeq_nl_te; eauto.

  intros.
  assert ({nN'' | cs_nte nN' i nN''}) by (eapply cs_nte_dec).
  inversion H4.

  eapply algeq_nl_te_whr_r.
  eapply whr_nl_te_cs; eauto.
  eapply IHalgeq_nl_te; eauto.

  intros.
  constructor.
  eapply streq_nl_te_cs; eauto.

  intros.
  assert ({M'' | cs_nte M' 0 M''}) by (apply cs_nte_dec).
  destruct H5.
  assert ({N'' | cs_nte N' 0 N''}) by (apply cs_nte_dec).
  destruct H5.

  econstructor.
  exact c.
  exact c0.

  eapply IHalgeq_nl_te.
  apply cs_snctx_cs; eauto.
  constructor.

  eapply cs_nte_cs.
  exact H3.
  exact c.
  exact H.

  constructor.
  constructor.
  eapply cs_nte_cs.
  exact H4.
  exact c0.
  exact H0.
  constructor.
Qed.
*)

(** algeq lifts along whr **)

Lemma algeq_nl_te_whr_lift_l:
  forall (sS : snsgn) (sG : snctx) (M M' N : nte) (tau : snTy),
    whr_nl_te M M' ->
    algeq_nl_te sS sG M' N (tau) ->
    algeq_nl_te sS sG M N (tau).
Proof.
  intros.
  generalize dependent M.
  induction H0.
  intros.
  eapply algeq_nl_te_whr_l; eauto.
  intros.
  eapply algeq_nl_te_whr_r; eauto.
  intros.
  eapply algeq_nl_te_whr_l.
  eauto.
  constructor; eauto.
  (* step *)
  intros.
  assert ({csM | cs_nte M 0 csM }) by (apply cs_nte_dec).
  destruct H3.
  eapply algeq_nl_te_eta_exp.
  exact c.
  exact H0.
  apply IHalgeq_nl_te.
  apply whr_nl_te_head.
  eapply whr_nl_te_cs; eauto.
Qed.

Lemma algeq_nl_te_whr_lift_r:
  forall (sS : snsgn) (sG : snctx) (M N N': nte) (tau : snTy),
    whr_nl_te N N' ->
    algeq_nl_te sS sG M N' (tau) ->
    algeq_nl_te sS sG M N (tau).
Proof.
  eauto using algeq_nl_te_symmetry, algeq_nl_te_whr_lift_l.
Qed.

(** algeq can be inversed along whr **)

Lemma algeq_nl_te_whr_inversion_l:
  forall (sS : snsgn) (sG : snctx) (M M' N : nte) (tau : snTy),
    whr_nl_te M M' ->
    algeq_nl_te sS sG M N (tau) ->
    algeq_nl_te sS sG M' N (tau).
Proof.
  intros.
  generalize dependent M'.
  induction H0.
  intros.
  assert (M' = nM') by (eauto using whr_nl_te_determinacy).
  rewrite H2.
  assumption.
  intros.
  eapply algeq_nl_te_whr_r; eauto.
  intros.
  apply streq_nl_te_determinacy_l in H.
  destruct H.
  exists M'; eauto.
  (* step *)
  intros.
  assert ({csM' | cs_nte M' 0 csM' }) by (apply cs_nte_dec).
  destruct H3.
  eapply algeq_nl_te_eta_exp.
  exact c.
  exact H0.
  apply IHalgeq_nl_te.
  apply whr_nl_te_head.
  eapply whr_nl_te_cs; eauto.
Qed.

Lemma algeq_nl_te_whr_inversion_r:
  forall (sS : snsgn) (sG : snctx) (M N N': nte) (tau : snTy),
    whr_nl_te N N' ->
    algeq_nl_te sS sG M N (tau) ->
    algeq_nl_te sS sG M N' (tau).
Proof.
  eauto using algeq_nl_te_symmetry, algeq_nl_te_whr_inversion_l.
Qed.

(**
streq and algeq are preserved by context shiftin inverse
**)
(*
Fixpoint streq_nl_te_cs_inversion (sS : snsgn) (sG sG' : snctx) (M M' N N' : nte) (tau tau' : snTy)
  (H : streq_nl_te sS sG' M' N' tau ) (i : Ixc) {struct H}:
    cs_nte M i M' -> cs_nte N i N' -> cs_snctx sG i tau' sG' ->
    ( streq_nl_te sS sG M N tau )
with algeq_nl_te_cs_inversion (sS : snsgn) (sG sG' : snctx) (M M' N N' : nte) (tau tau' : snTy)
    (H : algeq_nl_te sS sG' M' N' tau ) (i : Ixc) {struct H}:
    cs_nte M i M' -> cs_nte N i N' -> cs_snctx sG i tau' sG' ->
    ( algeq_nl_te sS sG M N tau ).
Proof.
  intros.
  generalize dependent N.
  generalize dependent M.
  generalize dependent i.
  generalize dependent tau'.
  generalize dependent sG.

  induction H.

  intros.
  inversion H0.
  rewrite <- H4 in H1; inversion H1.
  rewrite <- H4 in H2; inversion H2.
  constructor; auto.

  intros.
  inversion H1.
  rewrite <- H5 in H3; inversion H3.
  rewrite <- H5 in H2; inversion H2.
  rewrite <- H13 in H0; inversion H0.

  destruct ixc.

  assert (snctx5 = tau'1 :: snctx0).
  apply cs_snctx_zeroc; auto.
  rewrite H14 in H0.
  inversion H0.
  constructor; auto.

  destruct ixc'.
  inversion H0.

  constructor; auto.
  eapply IHstreq_nl_te.
  exact H13.
  constructor.
  constructor.

  rewrite <- H6 in H3; inversion H3.
  rewrite <- H6 in H2; inversion H2.
  constructor; auto.
  eapply IHstreq_nl_te; eauto.

  intros.
  inversion H1.
  inversion H3.
  constructor; auto.

  intros.
  inversion H1.
  inversion H3.
  econstructor.
  eapply IHstreq_nl_te; eauto.
  eapply algeq_nl_te_cs_inversion; eauto.

  (* lemma 2 *)
  intros.
  generalize dependent N.
  generalize dependent M.
  (* generalize dependent tau'. *)
  generalize dependent i.
  generalize dependent sG.
  induction H.

  intros.

  assert ({M' | whr_nl_te M M'}).
  eapply whr_nl_te_cs_dec_inverse; eauto.
  destruct H4.

  eapply algeq_nl_te_whr_l.
  exact w.
  eapply IHalgeq_nl_te; eauto.
  eapply whr_nl_te_cs_inversion_flip; eauto.

  intros.
  assert ({N' | whr_nl_te N N'}).
  eapply whr_nl_te_cs_dec_inverse; eauto.
  destruct H4.

  eapply algeq_nl_te_whr_r.
  exact w.
  eapply IHalgeq_nl_te; eauto.
  eapply whr_nl_te_cs_inversion_flip; eauto.

  intros.
  constructor.
  eapply streq_nl_te_cs_inversion; eauto.

  intros.
  assert ({M'' | cs_nte M 0 M''}) by (apply cs_nte_dec).
  destruct H5.
  assert ({N'' | cs_nte N 0 N''}) by (apply cs_nte_dec).
  destruct H5.

  econstructor.
  exact c.
  exact c0.

  eapply IHalgeq_nl_te.
  apply cs_snctx_cs; eauto.
  constructor.

  eapply cs_nte_cs.
  exact H3.
  exact H.
  exact c.

  constructor.
  constructor.
  eapply cs_nte_cs.
  exact H4.
  exact H0.
  exact c0.
  constructor.
Qed.
*)

(** transformation of streq to algeq  **)
(*
Lemma streq_nl_te_algeq:
  forall (sS : snsgn) (sG : snctx) (M N : nte) (tau : snTy),
    wfssig_nl sS ->
    ( streq_nl_te sS sG M N tau) ->
    ( algeq_nl_te sS sG M N tau).
Proof.
  intros.
  generalize dependent N.
  generalize dependent M.
  generalize dependent sG.
  induction tau.
  intros.
  constructor; auto.

  intros.
  assert ({M' | cs_nte M 0 M'}) by (apply cs_nte_dec).
  destruct H1.
  assert ({N' | cs_nte N 0 N'}) by (apply cs_nte_dec).
  destruct H1.

  econstructor.
  exact c.
  exact c0.
  eapply IHtau2.
  eapply streq_nl_te_pi_elim with (tau2 := tau1).
  eapply streq_nl_te_cs.
  exact H0.
  exact c.
  exact c0.
  eapply cs_snctx_var.
  eapply IHtau1.
  constructor.
  exact H.
Qed.
*)

(**
* Weak algorithmic equality
**)

(** walgeq is preserved by context shifting **)
(*
Lemma walgeq_nl_Ty_cs:
  forall (sS : snsgn) (sG sG' : snctx) (A A' B B' : nTy) (tau : snTy) (kappa : snK) (i : Ixc),
    walgeq_nl_Ty sS sG A B kappa ->
    cs_nTy A i A' -> cs_nTy B i B' -> cs_snctx sG i tau sG' ->
    walgeq_nl_Ty sS sG' A' B' kappa.
Proof.
  intros.
  generalize dependent B'.
  generalize dependent A'.
  generalize dependent sG'.
  generalize dependent tau.
  generalize dependent i.
  induction H.
  - (* tcon *)
    intros.
    inversion H1; inversion H3.
    constructor; auto.
  - (* pi_intro *)
    intros.
    inversion H4; inversion H5.
    assert ({nB'' | cstu_nTy nB' 0 nB''}) by (apply cstu_nTy_dec).
    destruct H18.
    assert ({nB''0 | cstu_nTy nB'0 0 nB''0}) by (apply cstu_nTy_dec).
    destruct H18.
    econstructor.
    eapply IHwalgeq_nl_Ty1; eauto.
    eauto.
    eauto.
    assert (erasure_nTy nA1 = erasure_nTy nA') by (eapply eq_nTy_erasure; eauto).
    rewrite <- H18.
    eapply IHwalgeq_nl_Ty2.
    eapply cs_snctx_var_succ; eauto.
    eapply cs_nTy_cstu.
    exact H11.
    exact H0.
    exact c.
    eapply cs_nTy_cstu; eauto.
  -  (* pi_elim *)
    intros.
    inversion H1; inversion H3.
    eapply walgeq_nl_Ty_pi_elim.
    eapply IHwalgeq_nl_Ty; eauto.
    eapply algeq_nl_te_cs; eauto.
Qed.
*)

(** decidability for nomalizing terms **)

Lemma algeq_nl_te_decnorm:
  forall (sS : snsgn) (sG : snctx) (M M' N N' : nte) (tau : snTy),
    (algeq_nl_te sS sG M M' tau) ->
    (algeq_nl_te sS sG N N' tau) ->
    (algeq_nl_te sS sG M N tau) \/
    (~ algeq_nl_te sS sG M N tau).
Proof.
  intros sS sG M M' N N' tau H.
  generalize dependent N.
  generalize dependent N'.
  induction H.

  - intros.
    apply IHalgeq_nl_te in H1.

    destruct H1.

    + left.
      econstructor; eauto.

    + right.
      intro.
      apply H1; auto.
      eapply algeq_nl_te_whr_inversion_l; eauto.

  - intros.
    apply IHalgeq_nl_te in H1.

    destruct H1.

    + left.
      assumption.

    + right.
      intro.
      apply H1; auto.

  - intros.

    generalize dependent nM.
    generalize dependent nN.

    induction H0.

    + intros.
      apply IHalgeq_nl_te in H1.
      destruct H1.

      * left.
        eapply algeq_nl_te_whr_r; eauto.

      * right.
        intro.

        apply H1.
        eapply algeq_nl_te_whr_inversion_r; eauto.

    + intros.
      apply IHalgeq_nl_te in H1.
      assumption.

    + intros.

      admit. (* ??? *)

    + intros.
      eapply IHalgeq_nl_te in H2.