Lemma id_P : forall P:Prop, P -> P.
  intros.
  exact H.
Qed.

Lemma id_PP : forall P:Prop, (P -> P) -> P -> P.
  intros.
  assumption.
Qed.

Lemma imp_trans : forall P Q R :Prop, (P -> Q) -> (Q -> R) -> P -> R.
  intros.
  apply H0.
  apply H.
  apply H1.
Qed.

Lemma imp_perm :  forall P Q R :Prop, (P -> Q -> R) -> Q -> P -> R.
  intros.
  apply H;assumption.
Qed.

Lemma ignore_Q : forall P Q R :Prop, (P -> R) -> P -> Q -> R.
  intros.
  apply H.
  assumption.
Qed.

Lemma delta_imp :  forall P Q :Prop,(P -> P -> Q) -> P -> Q.
  intros.
  apply H;assumption.
Qed.

Lemma delta_impR :forall P Q :Prop, (P -> Q) -> P -> P -> Q.
  intros.
  apply H.
  apply H0.
Qed.

Lemma diamond : forall P Q R T:Prop, (P -> Q) ->
                                  (P -> R) ->
                                  (Q -> R -> T) ->
                                  P -> T.
  intros.
  apply H1;[apply H|apply H0];assumption.
Qed.

Lemma weak_peirce : forall P Q:Prop, ((((P -> Q) -> P) -> P) -> Q) -> Q.
  intros.
  apply H.
  intros.
  apply H0.
  intros.
  apply H.
  intros.
  apply H1.
Qed.

Section A_declared.
  Variables
    (A : Set )
    (P Q : A->Prop)
    (R : A->A->Prop).
  Goal (forall a b:A, R a b) -> forall a b:A, R b a.
    intros.
    apply H.
  Qed.
  Goal (forall a:A, P a -> Q a) -> (forall a:A, P a) -> forall a:A, Q a.
    intros.
    apply H.
    apply H0.
  Qed.
  Goal (forall a b:A, R a b) -> forall a:A, R a a.
    intros.
    apply H.
  Qed.
End A_declared.

Goal forall P:Prop, ~ ~ ~ P -> ~ P.
  intros.
  unfold not.
  intros.
  apply H.
  unfold not.
  intros.
  apply H1.
  assumption.
Qed.

Goal forall P Q:Prop, ~ ~ ~ P -> P -> Q.
  unfold not.
  intros.
  elim H.
  intros.
  apply H1.
  assumption.
Qed.

Goal forall P Q:Prop, (P -> Q) -> ~ Q -> ~ P.
  unfold not.
  intros.
  apply H0.
  apply H.
  apply H1.
Qed.

Goal forall P Q R:Prop, (P -> Q) -> (P -> ~ Q) -> P -> R.
  unfold not.
  intros.
  elim H0;[|apply H];assumption.
Qed.

Definition dyslexic_imp := forall P Q:Prop, (P->Q)->Q->P.

Definition dyslexic_contrap :=forall P Q:Prop,(P->Q)->~P->~Q.

Goal dyslexic_imp -> False.
  unfold dyslexic_imp.
  intros.
  apply (H False True);trivial.
Qed.

Goal dyslexic_contrap -> False.
  unfold dyslexic_contrap.
  intros.
  apply (H False True);unfold not;trivial.
Qed.

Theorem abcd_c : forall (A:Set)(a b c d:A), a=c \/ b= c \/ c=c \/ d=c.
  intros.
  right.
  right.
  left.
  reflexivity.
Qed.

Lemma and_assoc : forall A B C:Prop, A /\ (B /\ C) -> (A /\ B) /\ C.
  intros.
  apply and_assoc.
  assumption.
Qed.

Lemma and_imp_dist : forall A B C D:Prop,
                     (A -> B) /\ (C -> D) -> A /\ C -> B /\ D.
  intros.
  destruct H.
  destruct H0.
  split;[apply H|apply H1];assumption.
Qed.

Lemma not_contrad : forall A : Prop, ~(A /\ ~A).
  unfold not.
  intros.
  destruct H.
  apply H0.
  apply H.
Qed.

Lemma or_and_not : forall A B : Prop, (A\/B)/\~A -> B.
  unfold not.
  intros.
  destruct H.
  destruct H;[elim H0|];apply H.
Qed.

Definition peirce := forall P Q:Prop, ((P->Q)->P)->P.
Definition classic := forall P:Prop, ~~P -> P.
Definition excluded_middle := forall P:Prop, P\/~P.
Definition de_morgan_not_and_not := forall P Q:Prop, ~(~P/\~Q)->P\/Q.
Definition implies_to_or := forall P Q:Prop, (P->Q)->(~P\/Q).

Ltac first_step :=
       try unfold peirce;
       try unfold classic;
       try unfold excluded_middle;
       try unfold de_morgan_not_and_not;
       try unfold implies_to_or;
       try unfold not;
       split;
       intros.

Goal peirce <-> classic.
  first_step.
  apply(H P False);intros;elim H0;assumption.
  apply H.
  intros.
  apply H1.
  apply H0.
  intros.
  apply H.
  intros.
  apply H1.
  assumption.
Qed.

Goal classic <-> excluded_middle.
  first_step;
  [
    apply H;
    apply H;
    intros;
    apply H0;
    intros;
    apply H1;
    right;
    intros;
    apply H1;
    left;
    unfold not|

    assert(P \/ (P -> False));
    [
      apply H|

      destruct H1;
      [|elim H0]
    ]
  ];assumption.
Qed.

Goal excluded_middle <-> de_morgan_not_and_not.
  first_step;
  [
    destruct (H P);
    [
      left|

      right;
      destruct (H Q);
      [|
        elim H0;
        split
      ]
    ]|

    apply H;
    intros;
    destruct H0;
    apply H1
  ];assumption.
Qed.

Goal de_morgan_not_and_not <-> implies_to_or.
  first_step;
  [
    apply H;
    intros;
    destruct H1;
    apply H1;
    intros;
    apply H2;
    apply H0|

    assert(~~P \/ ~~Q);
    [
      unfold not;
      apply H;
      intros;
      destruct H0;
      split|

      assert((~P\/P)/\(~Q\/Q));
      [
        split;
        apply H;
        intros|

        destruct H1;
        [left|right];
        destruct H2;
        [destruct H2|destruct H3];
        try assumption;
        elim H1
      ]
    ]
  ];
  assumption.
Qed.

Section on_ex.
  Variables
    (A:Type)
    (P Q:A -> Prop).
  Lemma ex_or : (exists x:A, P x \/ Q x) -> ex P \/ ex Q.
    intros;
    destruct H;
    destruct H;
    [left|right];
    exists x;
    assumption.
  Qed.

  Lemma ex_or_R : ex P \/ ex Q -> (exists x:A, P x \/ Q x).
    intros;
    destruct H;
    destruct H;
    exists x;
    [left|right];
    assumption.
  Qed.

  Lemma two_is_three : (exists x:A, forall R : A->Prop, R x) -> 2 = 3.
    intros;
    destruct H;
    apply( H (fun _ => _ = 3) ).
  Qed.

  Lemma forall_no_ex : (forall x:A, P x) -> ~(exists y:A, ~ P y).
    intros;
    unfold not;
    intros;
    destruct H0;
    apply H0;
    apply H.
  Qed.
End on_ex.

Require Import Arith.

Theorem plus_permute2 :
  forall n m p:nat, n + m + p = n + p + m.
  intros.
  rewrite plus_assoc_reverse.
  rewrite plus_assoc_reverse.
  rewrite plus_comm.
  rewrite (plus_comm n).
  rewrite (plus_comm p).
  reflexivity.
Qed.

Goal forall (A:Set) (a b c:A), a = b -> b = c -> a = c.
  intros.
  rewrite <- H0.
  assumption.
Qed.

Definition my_False : Prop := forall P:Prop, P.

Definition my_not (P:Prop) : Prop := P -> my_False.

Notation "! x"  := (my_not x)(at level 1, no associativity).

Goal forall P:Prop, ! ! ! P -> ! P.
  unfold my_not.
  intros.
  apply H.
  intros.
  apply H0.
  assumption.
Qed.

Goal forall P Q:Prop, ! ! ! P -> P -> Q.
  unfold my_not.
  intros.
  apply H.
  intros.
  apply H0.
  assumption.
Qed.

Goal forall P Q:Prop, (P -> Q) -> ! Q -> ! P.
  unfold my_not.
  intros.
  apply H0.
  apply H.
  assumption.
Qed.

Goal forall P Q R:Prop, (P -> Q) -> (P -> ! Q) -> P -> R.
  unfold my_not.
  intros.
  apply H0;
  try apply H;
  assumption.
Qed.

Require Import Relations.

Section impredicative_eq.
  Variable A : Set.
  Set Implicit Arguments.
  Definition impredicative_eq (a b:A) : Prop := forall P:A -> Prop, P a -> P b.
  Ltac first_step :=
    unfold
      symmetric,
      reflexive,
      transitive,
      equiv,
      inclusion,
      impredicative_eq.
  Theorem impredicative_eq_sym : symmetric A impredicative_eq.
    first_step.
    intros a b H Q.
    apply H.
    trivial.
  Qed.

  Theorem impredicative_eq_refl : reflexive A impredicative_eq.
    first_step.
    intros.
    assumption.
  Qed.

  Theorem impredicative_eq_trans :  transitive A impredicative_eq.
    first_step.
    intros.
    apply H0.
    apply H.
    assumption.
  Qed.

  Theorem impredicative_eq_equiv : equiv A impredicative_eq.
    unfold equiv.
    repeat split.
    apply impredicative_eq_refl.
    apply impredicative_eq_trans.
    apply impredicative_eq_sym.
  Qed.

  Theorem impredicative_eq_least :
    forall R:relation A, reflexive A R -> inclusion A impredicative_eq R.
    first_step.
    intros.
    apply H0.
    apply H.
  Qed.

  Theorem impredicative_eq_eq : forall a b:A, impredicative_eq a b -> a = b.
    first_step.
    intros.
    apply H.
    reflexivity.
  Qed.

  Theorem eq_impredicative_eq : forall a b:A, a = b -> impredicative_eq a b.
    first_step.
    intros.
    rewrite <- H.
    assumption.
  Qed.

  Theorem impredicative_eq_ind :
    forall (x:A) (P:A -> Prop), P x -> forall y:A, impredicative_eq x y -> P y.
    first_step.
    intros.
    apply H0.
    assumption.
  Qed.
End impredicative_eq.

Definition my_and (P Q:Prop) : Prop := forall R:Prop, (P -> Q -> R) -> R.

Definition my_or (P Q:Prop) : Prop :=
  forall R:Prop, (P -> R) -> (Q -> R) -> R.

Definition my_ex (A:Set) (P:A -> Prop) : Prop :=
  forall R:Prop, (forall x:A, P x -> R) -> R.

Theorem my_and_left : forall P Q:Prop, my_and P Q -> P.
  unfold my_and.
  intros.
  apply H.
  intros.
  assumption.
Qed.

Theorem my_and_right : forall P Q:Prop, my_and P Q -> Q.
  unfold my_and.
  intros.
  apply H.
  intros.
  assumption.
Qed.

Theorem my_and_ind : forall P Q R:Prop, (P -> Q -> R) -> my_and P Q -> R.
  unfold my_and.
  intros.
  apply H0.
  assumption.
Qed.

Theorem my_or_introl : forall P Q:Prop, P -> my_or P Q.
  unfold my_or.
  intros.
  apply H0.
  assumption.
Qed.

Theorem my_or_intror : forall P Q:Prop, Q -> my_or P Q.
  unfold my_or.
  intros.
  apply H1.
  assumption.
Qed.

Theorem my_or_ind : forall P Q R:Prop, (P -> R) -> (Q -> R) -> my_or P Q -> R.
  unfold my_or.
  intros.
  apply H1;
  assumption.
Qed.

Theorem my_or_False : forall P:Prop, my_or P my_False -> P.
  unfold my_or, my_False.
  intros.
  apply H.
  trivial.
  intros.
  apply H0.
Qed.

Theorem my_or_comm : forall P Q:Prop, my_or P Q -> my_or Q P.
  unfold my_or.
  intros.
  apply H;
  assumption.
Qed.

Theorem my_ex_intro : forall (A:Set) (P:A -> Prop) (a:A), P a -> my_ex P.
  unfold my_ex.
  intros.
  apply(H0 a).
  assumption.
Qed.

Theorem my_not_ex_all :
  forall (A:Set) (P:A -> Prop), my_not (my_ex P) -> forall a:A, my_not (P a).
  unfold my_ex, my_not.
  intros.
  apply H.
  intros.
  apply(H1 a).
  assumption.
Qed.

Theorem my_ex_ex : forall (A:Set) (P:A -> Prop), my_ex P -> ex P.
  unfold my_ex.
  intros.
  apply H.
  intros.
  exists x.
  assumption.
Qed.

Definition my_le (n p:nat) :=
  forall P : nat -> Prop,
    P n ->
      (forall q : nat, P q -> P (S q)) ->
        P p.

Theorem my_le_n : forall n:nat, my_le n n.
  unfold my_le.
  intros.
  assumption.

Theorem my_le_S : forall n p:nat,
                   my_le n p -> my_le n (S p).
  unfold my_le.
  intros.
  apply H1.
  apply H;
  assumption.
Qed.

Theorem my_le_le : forall n p:nat,
                    my_le n p -> n <= p.
  unfold my_le.
  intros.
  apply H.
  constructor.
  intros.
  constructor.
  assumption.
Qed.


(********************************************************************)
(*                                                                  *)
(*  The Why3 Verification Platform   /   The Why3 Development Team  *)
(*  Copyright 2010-2015   --   INRIA - CNRS - Paris-Sud University  *)
(*                                                                  *)
(*  This software is distributed under the terms of the GNU Lesser  *)
(*  General Public License version 2.1, with the special exception  *)
(*  on linking described in file LICENSE.                           *)
(*                                                                  *)
(********************************************************************)

(* This file is generated by Why3's Coq-realize driver *)
(* Beware! Only edit allowed sections below    *)
Require Import BuiltIn.
Require BuiltIn.
Require int.Int.

Section Exponentiation.

(* Why3 goal *)
Variable t : Type.
Hypothesis t_WhyType : WhyType t.
Existing Instance t_WhyType.

(* Why3 goal *)
Variable one: t.

(* Why3 goal *)
Variable infix_as: t -> t -> t.

(* Why3 goal *)
Hypothesis Assoc : forall (x:t) (y:t) (z:t), ((infix_as (infix_as x y)
  z) = (infix_as x (infix_as y z))).

(* Why3 goal *)
Hypothesis Unit_def_l : forall (x:t), ((infix_as one x) = x).

(* Why3 goal *)
Hypothesis Unit_def_r : forall (x:t), ((infix_as x one) = x).

(* Why3 goal *)
Hypothesis Comm : forall (x:t) (y:t), ((infix_as x y) = (infix_as y x)).

(* Why3 goal *)
Definition power: t -> Z -> t.
intros x n.
exact (iter_nat (Zabs_nat n) t (fun acc => infix_as x acc) one).
Defined.

(* Why3 goal *)
Lemma Power_0 : forall (x:t), ((power x 0%Z) = one).
Proof.
easy.
Qed.

(* Why3 goal *)
Lemma Power_s : forall (x:t) (n:Z), (0%Z <= n)%Z -> ((power x
  (n + 1%Z)%Z) = (infix_as x (power x n))).
Proof.
intros x n h1.
unfold power.
fold (Zsucc n).
now rewrite Zabs_nat_Zsucc.
Qed.

(* Why3 goal *)
Lemma Power_s_alt : forall (x:t) (n:Z), (0%Z < n)%Z -> ((power x
  n) = (infix_as x (power x (n - 1%Z)%Z))).
intros x n h1.
rewrite <- Power_s; auto with zarith.
f_equal; omega.
Qed.

(* Why3 goal *)
Lemma Power_1 : forall (x:t), ((power x 1%Z) = x).
Proof.
exact Unit_def_r.
Qed.

(* Why3 goal *)
Lemma Power_sum : forall (x:t) (n:Z) (m:Z), (0%Z <= n)%Z -> ((0%Z <= m)%Z ->
  ((power x (n + m)%Z) = (infix_as (power x n) (power x m)))).
Proof.
intros x n m Hn Hm.
revert n Hn.
apply natlike_ind.
apply sym_eq, Unit_def_l.
intros n Hn IHn.
replace (Zsucc n + m)%Z with ((n + m) + 1)%Z by ring.
rewrite Power_s by auto with zarith.
rewrite IHn.
now rewrite <- Assoc, <- Power_s.
Qed.

(* Why3 goal *)
Lemma Power_mult : forall (x:t) (n:Z) (m:Z), (0%Z <= n)%Z -> ((0%Z <= m)%Z ->
  ((power x (n * m)%Z) = (power (power x n) m))).
Proof.
intros x n m Hn Hm.
revert m Hm.
apply natlike_ind.
now rewrite Zmult_0_r, 2!Power_0.
intros m Hm IHm.
replace (n * Zsucc m)%Z with (n * m + n)%Z by ring.
rewrite Power_sum by auto with zarith.
rewrite IHm.
now rewrite Comm, <- Power_s.
Qed.

(* Why3 goal *)
Lemma Power_mult2 : forall (x:t) (y:t) (n:Z), (0%Z <= n)%Z ->
  ((power (infix_as x y) n) = (infix_as (power x n) (power y n))).
Proof.
intros x y.
apply natlike_ind.
apply sym_eq.
rewrite 3!Power_0.
apply Unit_def_r.
intros n Hn IHn.
unfold Zsucc.
rewrite 3!(Power_s _ _ Hn).
rewrite IHn.
now rewrite Assoc, <- (Assoc y), (Comm y), 2!Assoc.
Qed.

End Exponentiation.


(*This file contains the proof that a clique generated from the clique
**inductive type is colorable assuming each vertex is uniquely colored
**as specified by the setVertices relation*)
Require Export ThreeSatReduction.

(*connecting x_i to each x_j when i <> j preserves colorability*)
Theorem connectXColorable : forall Gamma Delta G C eta eta' u,
                              ~In u Delta -> setVertices Gamma C 0 eta' eta -> In (u,3*u,3*u+1,3*u+2) Gamma ->
                              connectX Gamma Delta (3*u+2) G -> coloring eta' G C.
Proof.
  intros. genDeps {{ eta; C; eta'}}. remember (3*u+2). induction H2; intros.
  {constructor. }
  {subst. destruct(eq_nat_dec u u0).
   {subst. exfalso. apply H. simpl. auto. }
   {copy H3. eapply XMapsToU in H0; eauto. copy H1. eapply XMapsToU in H1; eauto.
    invertHyp. econstructor; eauto. omega. omega. eapply IHconnectX; eauto. intros c.
    apply H. simpl. auto. }
  }
Qed.

Theorem cliqueColorable : forall Gamma eta Delta C G eta' U,
                            setVertices Gamma C 0 eta' eta ->
                            unique U Delta ->
                            clique Gamma Delta G -> coloring eta' G C.
Proof.
  intros. genDeps {{ eta; C; U }}. induction H1; intros; auto.
  {constructor. eapply IHclique; eauto. inv H0. constructor. inv H2. eauto.
   eapply connectXColorable; eauto. inv H2. eapply uniqueNotIn; eauto.
   apply Union_intror. constructor. }
Qed.


(* Implementation of [FSet A] using lists *)
Require Import HoTT HitTactics.
Require Import FSets set_interface kuratowski.length prelude dec_fset.

Section Operations.
  Context `{Univalence}.

  Global Instance list_empty A : hasEmpty (list A) := nil.

  Global Instance list_single A: hasSingleton (list A) A := fun a => cons a nil.

  Global Instance list_union A : hasUnion (list A).
  Proof.
    intros l1 l2.
    induction l1.
    * apply l2.
    * apply (cons a IHl1).
  Defined.

  Global Instance list_membership A : hasMembership (list A) A.
  Proof.
    intros a l.
    induction l as [ | b l IHl].
    - apply False_hp.
    - apply (hor (a = b) IHl).
  Defined.

  Global Instance list_comprehension A: hasComprehension (list A) A.
  Proof.
    intros ϕ l.
    induction l as [ | b l IHl].
    - apply nil.
    - apply (if ϕ b then cons b IHl else IHl).
  Defined.

  Fixpoint list_to_set A (l : list A) :  FSet A :=
    match l with
    | nil => ∅
    | cons a l => {|a|} ∪ (list_to_set A l)
    end.

End Operations.

Section ListToSet.
  Variable A : Type.
  Context `{Univalence}.

  Lemma member_isIn (a : A) (l : list A)  :
    member a l = a ∈ (list_to_set A l).
  Proof.
    induction l ; unfold member in * ; simpl in *.
    - reflexivity.
    - rewrite IHl.
      unfold hor, merely, lor.
      apply path_iff_hprop ; intros z ; strip_truncations ; destruct z as [z1 | z2].
      * apply (tr (inl (tr z1))).
      * apply (tr (inr z2)).
      * strip_truncations ; apply (tr (inl z1)).
      * apply (tr (inr z2)).
  Defined.

  Definition empty_empty : list_to_set A ∅ = ∅ := idpath.

  Lemma filter_comprehension (ϕ : A -> Bool) (l : list A)  :
    list_to_set A (filter ϕ l) =  {| list_to_set A l & ϕ |}.
  Proof.
    induction l ; cbn in *.
    - reflexivity.
    - destruct (ϕ a) ; cbn in * ; unfold list_to_set in IHl.
      * refine (ap (fun y => {|a|} ∪ y) _).
        apply IHl.
      * rewrite nl.
        apply IHl.
  Defined.

  Definition singleton_single (a : A) : list_to_set A (singleton a) = {|a|} :=
    nr {|a|}.

  Lemma append_union (l1 l2 : list A) :
    list_to_set A (list_union _ l1 l2) = (list_to_set A l1) ∪ (list_to_set A l2).
  Proof.
    induction l1 ; simpl.
    - apply (nl _)^.
    - rewrite IHl1, assoc.
      reflexivity.
  Defined.

  Fixpoint reverse (l : list A) : list A :=
    match l with
    | nil => nil
    | cons a l => {|a|} ∪ (reverse l) ∪ {|a|}
    end.

  Lemma reverse_set (l : list A) :
    list_to_set A l = list_to_set A (reverse l).
  Proof.
    induction l ; simpl.
    - reflexivity.
    - rewrite IHl, append_union.
      simpl.
      symmetry.
      rewrite nr, comm, <- assoc, idem.
      apply comm.
  Defined.

End ListToSet.

Section lists_are_sets.
  Context `{Univalence}.

  Global Instance lists_sets : sets list list_to_set.
  Proof.
    split ; intros.
    - apply empty_empty.
    - apply singleton_single.
    - apply append_union.
    - apply filter_comprehension.
    - apply member_isIn.
  Defined.
End lists_are_sets.

Section refinement_examples.
  Context `{Univalence}.
  Context {A : Type}.

  Definition list_all (ϕ : A -> hProp) : list A -> hProp
    := refinement list list_to_set (all ϕ).

  Lemma list_all_set (ϕ : A -> hProp) (X : list A)
    : list_all ϕ X = all ϕ (list_to_set A X).
  Proof.
    induction X ; try reflexivity.
  Defined.

  Lemma list_all_intro (X : list A) (ϕ : A -> hProp)
    : forall (HX : forall a, a ∈ X -> ϕ a), list_all ϕ X.
  Proof.
    rewrite list_all_set.
    intros H1.
    assert (forall (a : A), a ∈ (list_to_set A X) -> ϕ a) as H2.
    {
      intros a H3.
      rewrite <- (member_isIn A a X) in H3.
      apply (H1 a H3).
    }
    apply (all_intro _ _ H2).
  Defined.

  Lemma list_all_elim (X : list A) (ϕ : A -> hProp) a
    : list_all ϕ X -> (a ∈ X) -> ϕ a.
  Proof.
    rewrite list_all_set, (member_isIn A a X).
    apply all_elim.
  Defined.

  Definition list_exist (ϕ : A -> hProp) : list A -> hProp
    := refinement list list_to_set (exist ϕ).

  Lemma list_exist_set (ϕ : A -> hProp) (X : list A)
    : list_exist ϕ X = exist ϕ (list_to_set A X).
  Proof.
    induction X ; try reflexivity.
  Defined.

  Lemma listexist_intro (X : list A) (ϕ : A -> hProp) a
    : a ∈ X -> ϕ a -> list_exist ϕ X.
  Proof.
    rewrite list_exist_set, (member_isIn A a X).
    apply exist_intro.
  Defined.

  Lemma exist_elim (X : list A) (ϕ : A -> hProp)
    : list_exist ϕ X -> hexists (fun a => a ∈ X * ϕ a).
  Proof.
    rewrite list_exist_set.
    assert (hexists (fun a : A => a ∈ (list_to_set A X) * ϕ a)
            -> hexists (fun a : A => a ∈ X * ϕ a))
      as H2.
    {
      intros H1.
      strip_truncations.
      destruct H1 as [a H1].
      rewrite <- (member_isIn A a X) in H1.
      refine (tr(a;H1)).
    }
    intros H1.
    apply (H2 (exist_elim _ _ H1)).
  Defined.

  Context `{MerelyDecidablePaths A}.

  Global Instance dec_memb a (l : list A) : Decidable (a ∈ l).
  Proof.
    induction l as [ | a0 l] ; simpl.
    - apply _.
    - unfold Decidable.
      destruct IHl as [t | p].
      * apply (inl(tr(inr t))).
      * destruct (H0 a a0) as [t | p'].
        ** left.
           strip_truncations.
           apply (tr(inl t)).
        ** refine (inr(fun n => _)).
           strip_truncations.
           destruct n as [n1 | n2].
           *** apply (p' (tr n1)).
           *** apply (p n2).
  Defined.

  Global Instance dec_memb_list : hasMembership_decidable (list A) A.
  Proof.
    intros a l.
    destruct (dec (a ∈ l)).
    - apply true.
    - apply false.
  Defined.

  Lemma fset_list_memb a (l : list A) : a ∈_d (list_to_set A l) = a ∈_d l.
  Proof.
    unfold member_dec, dec_memb_list, fset_member_bool.
    destruct (dec a ∈ (list_to_set A l)), (dec a ∈ l) ; try reflexivity.
    - contradiction n.
      rewrite <- (f_member _ list_to_set) in t.
      apply t.
    - contradiction n.
      rewrite (f_member _ list_to_set) in t.
      apply t.
  Defined.

  Definition set_length : list A -> nat
    := refinement list list_to_set length.

  Definition set_length_nil : set_length nil = 0 := idpath.

  Definition set_length_cons a l
    : set_length (cons a l) = if (a ∈_d l) then set_length l else S(set_length l).
  Proof.
    unfold set_length, refinement.
    simpl.
    rewrite length_compute, fset_list_memb.
    reflexivity.
  Defined.
End refinement_examples.


Require Import Coq.Lists.List.
Require Import Coq.Logic.ClassicalChoice.

Module Type NAT_CHOICE.

Fixpoint fisrtn_list_from_fun {A: Type} (f: nat -> A) (n: nat) : list A :=
  match n with
  | 0 => nil
  | S m => fisrtn_list_from_fun f m ++ f m :: nil
  end.

Axiom nat_stepwise_choice: forall {A: Type} (P: list A -> Prop),
  P nil ->
  (forall l, P l -> exists a, P (l ++ a :: nil)) ->
  exists f, forall n, P (fisrtn_list_from_fun f n).

End NAT_CHOICE.

Module NatChoice: NAT_CHOICE.

Section NatChoice.

Fixpoint fisrtn_list_from_fun {A: Type} (f: nat -> A) (n: nat) : list A :=
  match n with
  | 0 => nil
  | S m => fisrtn_list_from_fun f m ++ f m :: nil
  end.

Context {A: Type} (P: list A -> Prop).

Definition State: Type := {l: list A | P l}.

Hypothesis H_init: P nil.

Definition state_nil: State := exist _ nil H_init.

Section step.

Variable F: State -> A.
Hypothesis HF: forall l: State, P (proj1_sig l ++ F l :: nil).

Fixpoint step (n: nat): State :=
  match n with
  | 0 => state_nil
  | S m => exist _ _ (HF (step m))
  end.

Lemma fisrtn_list_step: forall n, fisrtn_list_from_fun (fun n0 : nat => F (step n0)) n = proj1_sig (step n).
Proof.
  intros.
  induction n.
  + simpl.
    reflexivity.
  + simpl.
    f_equal; auto.
Qed.

End step.

Lemma nat_stepwise_choice:
  (forall l, P l -> exists a, P (l ++ a :: nil)) ->
  exists f, forall n, P (fisrtn_list_from_fun f n).
Proof.
  intros.
  assert (forall (l: list A | P l), exists a : A, P (proj1_sig l ++ a :: nil)) as HH; [| clear H].
  Focus 1. {
    intros [l ?H].
    apply H; auto.
  } Unfocus.

  apply choice in HH.
  destruct HH as [f ?].

  exists (fun n => f (step f H n)).
  intros.
  rewrite fisrtn_list_step.

  apply (proj2_sig (step f H n)).
Qed.

End NatChoice.

End NatChoice.

Export NatChoice.

Lemma nat_coinduction {A: Type}: forall (P: A -> Prop) (R: A -> A -> Prop) a0,
  P a0 ->
  (forall a, P a -> exists b, R a b /\ P b) ->
  exists l: nat -> A, l 0 = a0 /\ (forall k, R (l k) (l (S k))).
Proof.
  intros.
  pose (Rs :=
            fix Rs (a: A) (l: list A): Prop :=
              match l with
              | nil => True
              | a0 :: l0 => P a0 /\ R a a0 /\ Rs a0 l0
              end).
  destruct (nat_stepwise_choice (Rs a0)) as [l ?].
  + simpl; auto.
  + intro l.
    revert a0 H.
    induction l.
    - simpl; intros.
      destruct (H0 a0 H) as [a1 [? ?]].
      exists a1; auto.
    - simpl; intros ? ? [? [? ?]].
      specialize (IHl _ H1 H3).
      destruct IHl as [a1 ?].
      exists a1; auto.
  + exists (fun n => match n with 0 => a0 | S n => l n end).
    split; auto.
    intros.
    specialize (H1 (S k)).
    destruct k; [simpl in H1; tauto |].
    simpl in H1.
    rewrite <- app_assoc in H1; simpl in H1.
    clear H H0.
    revert a0 H1; induction (fisrtn_list_from_fun l k); intros.
    - simpl in H1.
      tauto.
    - apply (IHl0 a); clear IHl0.
      simpl in H1.
      simpl; tauto.
Qed.

Lemma nat_coinduction' {A: Type}: forall (P: A -> Prop) (R: A -> A -> Prop) a0,
  P a0 ->
  (forall a, P a -> exists b, R a b /\ P b) ->
  exists l: nat -> A, l 0 = a0 /\ (forall k, R (l k) (l (S k))) /\ (forall k, P (l k)).
Proof.
  intros.
  pose (R' := fun (a b: A) => R a b /\ P b).

  destruct (nat_coinduction P R' a0 H) as [l [? ?]].
  + simpl; unfold R'; firstorder.
  + exists l.
    split; auto.
    split; [subst R'; firstorder |].
    intros.
    destruct k; [subst; auto |].
    specialize (H2 k).
    destruct H2; auto.
Qed.


(** Zainspirowane przez podręcznik
    #
    Modeling and Proving in Computational Type Theory Using the Coq Proof Assistant#
    (rozdział 14). *)

Class Provability : Type :=
{
  Provable : Prop -> Prop;
  PMP : forall P Q : Prop, Provable (P -> Q) -> Provable P -> Provable Q;
  PI  : forall P : Prop, Provable (P -> P);
  PK  : forall P Q : Prop, Provable Q -> Provable (P -> Q);
  PC  : forall P Q Z : Prop, Provable (P -> Q) -> Provable ((Q -> Z) -> P -> Z)
}.

Section AbstractProvability.

Context
  (Prv : Provability).

Definition Unprovable (P : Prop) : Prop :=
  ~ Provable P.

Definition Disprovable (P : Prop) : Prop :=
  Provable (~ P).

Definition Consistent (P : Prop) : Prop :=
  ~ Provable (~ P).

Definition Independent (P : Prop) : Prop :=
  ~ Provable P /\ ~ Provable (~ P).

Lemma Independent2Consistent :
  forall {P : Prop},
    Independent P -> Consistent P.
Proof.
  intros P [_ HC]; assumption.
Qed.

Lemma Consistent2Unprovable :
  forall {P : Prop},
    Consistent P -> Unprovable (~ P).
Proof.
  compute.
  intros P C U.
  apply C. assumption.
Qed.

Lemma Provable_contraposition :
  forall P Q : Prop,
    Provable (P -> Q) -> ~ Provable Q -> ~ Provable P.
(* begin hide *)
Proof.
  intros P Q pq nq p.
  apply nq. eapply PMP; eassumption.
Qed.
(* end hide *)

Lemma Provable_contraposition' :
  forall P Q : Prop,
    Provable (P -> Q) -> Unprovable Q -> Unprovable P.
(* begin hide *)
Proof.
  intros P Q pq nq p.
  apply nq. eapply PMP; eassumption.
Qed.
(* end hide *)

Lemma Provable_Consistent :
  forall P Q : Prop,
    Provable (P -> Q) -> Consistent P -> Consistent Q.
(* begin hide *)
Proof.
  intros P Q ppq cp dq.
  apply cp.
  eapply PMP; cycle 1.
  - exact dq.
  - apply PC. assumption.
Qed.
(* end hide *)

Lemma sandwich :
  forall P Q Z : Prop,
    Consistent P -> Unprovable Q -> Provable (P -> Z) -> Provable (Z -> Q) -> Independent Z.
(* begin hide *)
Proof.
  intros P Q Z cp uq p2z z2q.
  split.
  - intros pz. apply uq. eapply PMP; eauto.
  - eapply Provable_Consistent; eauto.
Qed.
(* end hide *)

Lemma PropExt_PI_Provable :
  (forall P Q : Prop, (P <-> Q) -> P = Q) ->
  forall P : Prop,
    P -> Provable P.
(* begin hide *)
Proof.
  intros PropExt P p.
  assert (H : P <-> (P <-> P)) by tauto.
  assert (H' : P = (P -> P)) by firstorder.
  rewrite H'.
  apply PI.
Qed.
(* end hide *)

Lemma ex_14_1_4 :
  forall P Q : Prop,
    Provable (P -> Q) -> Consistent P -> Unprovable Q ->
      Independent P /\ Independent Q.
(* begin hide *)
Proof.
  intros P Q ppq cp uq. split.
  - eapply sandwich; eauto. apply PI.
  - eapply sandwich; eauto. apply PI.
Qed.
(* end hide *)

Lemma PE_Provable_False :
  (forall P : Prop, Provable False -> Provable P) ->
  Provable False <-> forall P : Prop, Provable P.
(* begin hide *)
Proof.
  intros PE. split.
  - intros pf P. apply PE. assumption.
  - intros PPP. apply PPP.
Qed.
(* end hide *)

Lemma Unprovable_False__Consistent_NotFalse :
  Unprovable False -> Consistent (~ False).
(* begin hide *)
Proof.
  unfold Unprovable, Consistent.
  intros f g.
  eapply (PMP (~ False) False) in g.
  - contradiction.
  - apply PI.
Qed.
(* end hide *)

Lemma Consistent_NotFalse__Consistent_Any :
  Consistent (~ False) -> exists P : Prop, Consistent P.
(* begin hide *)
Proof.
  intros cnf. exists (~ False). assumption.
Qed.
(* end hide *)

Lemma Consistent_Any__Provable_Consistent :
  (exists P : Prop, Consistent P) ->
    forall P : Prop, Provable P -> Consistent P.
(* begin hide *)
Proof.
(*   unfold Unprovable, Consistent. *)
  intros [X cx] P p.
  apply Provable_Consistent with X.
  - apply PK. assumption.
  - assumption.
Qed.
(* end hide *)

Lemma Provable_Consistent__Disprovable_Unprovable :
  (forall P : Prop, Provable P -> Consistent P) ->
  forall P : Prop, Disprovable P -> Unprovable P.
(* begin hide *)
Proof.
  unfold Consistent, Disprovable, Unprovable.
  intros H P dp np.
  eapply H; eassumption.
Qed.
(* end hide *)

Lemma Disprovable_Unprovable__Unprovable_False :
  (forall P : Prop, Disprovable P -> Unprovable P) ->
    Unprovable False.
(* begin hide *)
Proof.
  unfold Disprovable, Unprovable.
  intros H.
  apply H.
  apply PI.
Qed.
(* end hide *)

End AbstractProvability.

#[refine]
#[export]
Instance Provability_id : Provability :=
{|
  Provable P := P;
|}.
(* begin hide *)
Proof.
  all: tauto.
Defined.
(* end hide *)

#[refine]
#[export]
Instance Provability_True : Provability :=
{|
  Provable _ := True;
|}.
(* begin hide *)
Proof.
  all: tauto.
Defined.
(* end hide *)


From Coq Require Import Bool.

Theorem bool_fn_applied_thrice : forall (f : bool -> bool) (b : bool),
  f (f (f b)) = f b.
Proof.
  intros f b. destruct b eqn:B.
  - destruct (f true) eqn:Q.
    * rewrite Q. apply Q.
    * destruct (f false) eqn:R.
      + apply Q.
      + apply R.
  - destruct (f false) eqn:Q.
    * destruct (f true) eqn:R.
      + apply R.
      + apply Q.
    * rewrite Q. apply Q.
Qed.

Theorem andb_eq_orb : forall (b c : bool),
  b && c = b || c -> b = c.
Proof.
  intros b. case b.
  - simpl. intros c H. rewrite H. reflexivity.
  - simpl. intros c H. rewrite H. reflexivity.
Qed.

Lemma lemma_2:
  forall n m : nat, n = 0 \/ m = 0 -> n * m = 0.
Proof.
  intros n m H.
  destruct H as [ Ha | Hb ].
  - rewrite Ha. simpl. reflexivity.
  - rewrite Hb. rewrite <- mult_n_O. reflexivity.
Qed.

Lemma lemma_1 : forall P Q : Prop,
  P /\ Q -> Q.
Proof.
  intros P Q H.
  destruct H as (HA & HB).
  apply HB.
Qed.


Require Export "Ascii".
Require Export "Prop".
Open Scope char_scope.

Inductive function : Type:=
  |fInsert: nat -> ascii->function
  |fDelete: nat -> function
  |fId: function.

Definition beq_ascii n m : bool :=
  if ascii_dec n m then true else false
  .

Definition function_eq (a b:function) : bool :=
  match a, b with
  |fDelete n1,fDelete n2 => beq_nat n1 n2
  |fInsert n1 x1, fInsert n2 x2 => andb (beq_nat n1 n2) (beq_ascii x1 x2)
  |_,_ =>false
  end.

Example test_function_eq0: function_eq (fDelete 0) (fDelete 0)= true.
Proof. simpl; reflexivity. Qed.
Example test_function_eq1: function_eq (fDelete 0) (fDelete 3)= false.
Proof. simpl; reflexivity. Qed.
Example test_function_eq2: function_eq (fInsert 0 "a") (fInsert 0 "a")= true.
Proof. simpl; reflexivity. Qed.
Example test_function_eq3: function_eq (fInsert 0 "a") (fInsert 0 "c")= false.
Proof. simpl; reflexivity. Qed.

Fixpoint insert1 n x (l:list ascii):list ascii:=
  match n with
  |0 => x::l
  |S n' =>match l with
    |[] => []
    |h::l' => h::(insert1 n' x l')
    end
  end.

Definition insert n x (l:list ascii): option (list ascii):=
if ble_nat (S(length l)) n then None else Some(insert1 n x l).
Example test_insert0: insert 0 "a" ["0","1","2","3"] = Some ["a","0","1","2","3"].
Proof. simpl; reflexivity. Qed.
Example test_insert1: insert 2 "a" ["0","1","2","3"] = Some ["0","1","a","2","3"].
Proof. simpl; reflexivity. Qed.
Example test_insert2: insert 7 "a" ["0","1","2","3"] = None.
Proof. simpl; reflexivity. Qed.
Example test_insert3: insert 4 "a" ["0","1","2","3"] = Some ["0","1","2","3","a"].
Proof. simpl; reflexivity. Qed.
Example test_insert4: insert 5 "a" ["0","1","2","3"] = None.
Proof. simpl; reflexivity. Qed.

Fixpoint delete1 n (l:list ascii):list ascii:=
  match l with
   |[] => []
   |h::l' =>
    match n with
     |0 => l'
     |S n' =>h::(delete1 n' l')
    end
  end.

Definition delete n (l:list ascii): option (list ascii):=
if ble_nat (length l) n then None else Some(delete1 n l).

Example test_delete0: delete 0 ["0","1","2","3"] = Some ["1","2","3"].
Proof. simpl; reflexivity. Qed.
Example test_delete1: delete 2 ["0","1","2","3"] = Some ["0","1","3"].
Proof. simpl; reflexivity. Qed.
Example test_delete2: delete 8 ["0","1","2","3"] = None.
Proof. simpl; reflexivity. Qed.
Example test_delete3: delete 3 ["0","1","2","3"] = Some ["0","1","2"].
Proof. simpl; reflexivity. Qed.
Example test_delete4: delete 4 ["0","1","2","3"] = None.
Proof. simpl. reflexivity. Qed.

Definition apply (f:function) (l:list ascii): option (list ascii):=
  match f with
  |fInsert n x => insert n x l
  |fDelete n => delete n l
  |fId => Some l
  end.
(*f1 - applied function, f2 - function that we must apply*)
Definition OT (f1 f2:function) (server:bool):function:=
  if function_eq f1 f2 then fId else
  match f1, f2 with
   |fId, _ => f2
   |_, fId => fId
   |fInsert n1 x1, fInsert n2 x2 => (*
    if beq_nat n1 n2
     then (
      if server
       then fInsert (S n2) x2
       else f2)
     else (
      if ble_nat n1 n2
       then fInsert (S n2) x2
       else f2)*)
    if orb (andb server (beq_nat n1 n2)) (negb(ble_nat n2 n1)) (*server or n1<n2*)
     then fInsert (S n2) x2
     else f2
   |fDelete n1, fInsert n2 x2 =>
    if negb (ble_nat n2 n1) (*n1<n2*)
     then fInsert (pred n2) x2
     else f2
   |fInsert n1 x1, fDelete n2 =>
    if ble_nat n1 n2 (*n1<=n2*)
     then fDelete (S n2)
     else f2
   |fDelete n1, fDelete n2 =>
    if negb (ble_nat n2 n1) (*n1<n2*)
     then fDelete (pred n2)
     else f2
   end.
Open Scope string_scope.

Definition xor_boolToProp (b1 b2: bool):Prop:=
  (b1 =false /\ b2=true)\/(b2 =false /\ b1=true).
Definition excluded_middle := forall P:Prop,
  P \/ ~P.

Theorem ble_nat_neg : forall (n0 n1 : nat),false=ble_nat n0 n1->true=ble_nat n1 n0.
Proof.
  intros n0. induction n0.
  Case "n0=0".
   intros. inversion H.
  Case "n0=S n0".
   intros. destruct n1.
    reflexivity.
    simpl. apply IHn0. inversion H. reflexivity.
Qed.

Theorem ble_nat_trans : forall (n0 n1 n2 : nat),true=ble_nat n0 n1->
true = ble_nat n1 n2-> true=ble_nat n0 n2.
Proof.
  intros n0. induction n0.
  Case "n0=0".
   intros. reflexivity.
  Case "n0=S n0".
   intros. destruct n2,n1; try inversion H.
    inversion H0.
    apply IHn0 with (n1:=n1).
     inversion H. reflexivity.
     inversion H0. reflexivity.
Qed.

Theorem ble_nat_negtrans : forall (n0 n1 n2 : nat),false=ble_nat n0 n1->
false = ble_nat n1 n2-> false=ble_nat n0 n2.
Proof.
  intros n0. induction n0.
  Case "n0=0".
   intros. inversion H.
  Case "n0=S n0".
   intros. destruct n2, n1;try inversion H0.
    reflexivity.
    apply IHn0 with (n1:=n1).
     inversion H. reflexivity.
     inversion H0. reflexivity.
Qed.

Theorem ble_nat_negtrans1 : forall (n0 n1 n2 : nat),true = ble_nat n0 n1->
false = ble_nat n2 n1-> false=ble_nat n2 n0.
Proof.
  intros n0. induction n0.
  Case "n0=0".
   intros. destruct n2,n1;try inversion H0;try inversion H;try reflexivity.
  Case "n0=S n0".
   intros. destruct n2, n1;try inversion H0.
    inversion H.
    apply IHn0 with (n1:=n1).
     inversion H. reflexivity.
     inversion H0. reflexivity.
Qed.

Theorem beq_ascii_sym : forall (n1 n2 : ascii),beq_ascii n1 n2=beq_ascii n2 n1.
Proof.
Admitted.

Theorem beq_ascii_eq : forall (n1 n2 : ascii),true = beq_ascii n1 n2 -> n1=n2.
Proof.
Admitted.

Theorem ble_nat_neg0 : forall n n0 ,  false = beq_nat  n n0 ->true = ble_nat n0 n ->false=ble_nat n n0.
Proof.
  intros n. induction n.
   intros. destruct n0.
    inversion H.
    inversion H0.
   intros. destruct n0.
    reflexivity.
    simpl. apply IHn.
     simpl in H,H0. apply H.
     simpl in H0. apply H0.
Qed.

Theorem ble_nat_neg1 : forall n n0 ,  false = beq_nat  n n0 ->false = ble_nat n0 n ->true=ble_nat n n0.
Proof.
  intros n. induction n.
   intros. reflexivity.
   intros. destruct n0.
    inversion H0.
    simpl. apply IHn.
     simpl in H,H0. apply H.
     simpl in H0. apply H0.
Qed.

Theorem ble_nat_neg2 : forall n n0 ,
true = ble_nat (S n) (n0) -> false = ble_nat n0 n.
Proof.
  intros n. induction n.
  intros. destruct n0.
   inversion H.
   reflexivity.
  intros. destruct n0.
   inversion H.
   simpl. apply IHn. simpl in H. apply H.
Qed.

Theorem ble_nat_beq : forall n n0 ,
true = ble_nat n0 (S n) -> false = ble_nat n0 n->true = beq_nat n0 (S n).
Proof.
  intros n. induction n.
   intros. destruct n0. inversion H0. destruct n0. reflexivity. inversion H.
   intros. destruct n0. inversion H0.
    apply IHn with (n0:=n0).
     simpl in H. apply H.
     simpl in H0. apply H0.
Qed.

Theorem bleSF : forall n1 n2 , false = ble_nat n1 (S n2)->false = ble_nat n1 (n2).
Proof.
  intros n1. induction n1.
   simpl. intros. inversion H.
   intros. destruct n2.
    reflexivity.
    simpl. apply IHn1. simpl in H. apply H.
Qed.

Theorem bleST : forall n1 n2 , true = ble_nat (S n1) n2 ->true = ble_nat n1 n2.
Proof.
  intros n1. induction n1.
   simpl. intros. destruct n2.
    inversion H.
    reflexivity.
   intros. destruct n2.
    inversion H.
    simpl. simpl in H. apply IHn1. apply H.
Qed.

Theorem bleSF1 : forall n1 n2 , false = ble_nat n1 n2 ->false = ble_nat (S n1) n2.
Proof.
  intros n1. induction n1.
   simpl. intros. inversion H.
   intros. destruct n2.
    reflexivity.
    simpl. apply IHn1. simpl in H. apply H.
Qed.

Theorem ble_nat_neg3 : forall n n0 ,  false = beq_nat (n) (n0)->
false = ble_nat (S n) (n0) -> false = ble_nat n n0.
Proof.
  intros n. induction n.
   intros. destruct n0.
    inversion H.
    inversion H0.
   intros. destruct n0.
    reflexivity.
    simpl. apply IHn.
     apply H.
     simpl in H0. apply H0.
Qed.

Theorem insert_len : forall n a l l1,apply (fInsert n a) l = Some l1->S (length l)=length l1.
Proof.
  intros n a l. generalize n.
   induction l.
   Case "l=[]".
    simpl. intros.
     destruct l1; destruct n0; try inversion H; try reflexivity.
   Case "l=x::l".
    intros. simpl. destruct l1.
     destruct n0;simpl in H; unfold insert in H.
      simpl in H. inversion H.
      destruct (ble_nat (S (length (x :: l))) (S n0)) in H;inversion H.
     simpl in H.
      destruct n0;simpl in H; unfold insert in H.
       simpl in H. inversion H. simpl. reflexivity.
       remember (ble_nat (S (length (x :: l))) (S n0)) as ble.
        destruct ble;inversion H.
        simpl. apply eq_remove_S. apply IHl with (n:=n0). simpl. unfold insert.
        simpl in Heqble. simpl. rewrite <- Heqble. reflexivity.
Qed.

Theorem delete_len : forall n l l1,apply (fDelete n) l = Some l1->(length l)=S(length l1).
Proof.
 intros n l. generalize n.
  induction l.
  Case "l=[]".
   simpl. intros.
   destruct l1; destruct n0; inversion H.
  Case "l=x::l".
   simpl. intros. destruct l1.
    destruct n0.
     simpl in H.
     inversion H.
     reflexivity. unfold delete in H.  destruct (ble_nat (length (x :: l)) (S n0)); inversion H.
    simpl. intros. apply eq_remove_S.
     destruct n0.
      simpl in H. inversion H.  reflexivity.
      apply IHl with (n:=n0). simpl. unfold delete in H.  simpl in H. unfold delete.
       destruct (ble_nat (length l) n0); inversion H. reflexivity.
Qed.

Theorem OT2 : forall n0 a a0 l,insert1 n0 a0 (insert1 n0 a l) =insert1 (S n0) a (insert1 n0 a0 l).
Proof.
  intros. generalize n0.
  induction l.
   intros. destruct n1; reflexivity.
   intros.
    destruct n1; simpl;try rewrite IHl; reflexivity.
Qed.

Theorem OT3 : forall n n0 a a0 l,true=ble_nat n0 n->
 insert1 n0 a0 (insert1 n a l) = insert1 (S n) a (insert1 n0 a0 l).
Proof.
 intros. generalize dependent n0. generalize dependent n.
  induction l.
   intros. destruct n0. reflexivity. destruct n. inversion H. reflexivity.
   destruct n0. reflexivity. intros. destruct n. inversion H. simpl.
    rewrite IHl.
     reflexivity.
     simpl in H. apply H.
Qed.

Theorem OT5 : forall n n0 a l,true = ble_nat n n0 -> delete1 (S n0) (insert1 n a l) =
insert1 n a (delete1 n0 l).
Proof.
  intros. generalize dependent n0. generalize dependent n.
   induction l.
    intros. destruct n0,n;reflexivity.
    intros.
     destruct n0,n;try reflexivity.
      inversion H.
      simpl.
       rewrite <-IHl. reflexivity.
       simpl in H. apply H.
Qed.

Theorem OT6 : forall n n0 a l a4,false = ble_nat (S (length l)) n -> false = ble_nat (S n) n0->
delete1 n0 (a4 :: insert1 n a l) =insert1 n a (delete1 n0 (a4 :: l)).
Proof.
  intros. generalize dependent n0. generalize dependent n. generalize dependent a4.
   induction l.
    intros. destruct n0,n; try reflexivity.
     inversion H0.
     inversion H.
    intros. destruct n0,n; try reflexivity.
     inversion H0.
     simpl. rewrite <-IHl.
      reflexivity.
      simpl in H. apply H.
      simpl in H0. apply H0.
Qed.

Theorem OT7 : forall n n0 a l,true = ble_nat n0 n->insert1 n0 a (delete1 n l) =
match insert1 n0 a l with
         | [] => []
         | h :: l' => h :: delete1 n l'
         end.
Proof.
  intros. generalize dependent n0. generalize dependent n.
  induction l.
   intros. destruct n0,n; reflexivity.
   intros. destruct n0,n; try reflexivity;try inversion H.
    simpl in IHl. simpl. rewrite IHl.
     reflexivity.
     simpl in H. apply H.
Qed.

Theorem OT8 : forall n n0 a l a0,false = ble_nat (S(length l)) n -> false = ble_nat (S n0) n->
insert1 n0 a (delete1 n (a0 :: l)) = delete1 n (a0 :: insert1 n0 a l).
Proof.
  intros. generalize dependent n0. generalize dependent n. generalize dependent a0.
   induction l.
    intros. destruct n. reflexivity. inversion H.
  intros. destruct n0,n; try reflexivity.
   inversion H0.
   simpl. rewrite <-IHl.
    reflexivity.
    simpl in H. apply H.
    simpl in H0. apply H0.
Qed.

Theorem OT9 : forall n n0 l a,false = ble_nat (length l) n ->false = ble_nat (S n) n0->
delete1 n0 (a :: delete1 n l) = delete1 n (delete1 n0 (a :: l)).
Proof.
  intros. generalize dependent n0. generalize dependent n. generalize dependent a. induction l.
   intros. destruct n0,n; inversion H.
   intros. destruct n0,n;try reflexivity.
    inversion H0.
    simpl. rewrite <-IHl.
     reflexivity.
     simpl in H. apply H.
     simpl in H0. apply H0.
Qed.
Theorem OT11 : forall n0 n l a,false = ble_nat (S n) n0 ->length l = S n->
delete1 n0 (a :: delete1 n l) =delete1 n (delete1 n0 (a :: l)).
Proof.
  intros. generalize dependent n0. generalize dependent n. generalize dependent a. induction l.
   intros. inversion H0.
   intros. destruct n0,n;try reflexivity.
    inversion H.
    simpl. rewrite <-IHl.
     reflexivity.
     inversion H0.  reflexivity.
     simpl in H. apply H.
Qed.

Theorem OT10 : forall n n0 l a,false = ble_nat (length l) n -> false = ble_nat (S n0) n->
      delete1 n0 (delete1 n (a :: l)) = delete1 n (a :: delete1 n0 l).
Proof.
  intros. generalize dependent n0. generalize dependent n. generalize dependent a. induction l.
   intros. destruct n0,n; inversion H.
   intros. destruct n0,n; try reflexivity.
   inversion H0.
   simpl. rewrite <-IHl.
     reflexivity.
     simpl in H. apply H.
     simpl in H0. apply H0.
Qed.

Theorem OT_correctness : forall (f1 f2:function) (b1 b2: bool) (l l1 l2:list ascii),((apply f1 l)=Some l1
 /\ (apply f2 l) =Some l2)-> (apply (OT f1 f2 false) l1 =apply (OT f2 f1 true) l2/\exists l3,apply (OT f2 f1 true) l2=Some l3).
Proof.
  intros. destruct f1,f2.
  Case "f1=inv, f2=inv".
   inversion H. inversion H. apply insert_len in H3. apply insert_len in H2. simpl in H0,H1.
    unfold insert in H0,H1. unfold OT. unfold function_eq.
    remember (beq_nat n n0) as beq. destruct beq.
    SCase "n=n0".
     rewrite beq_nat_sym. rewrite <- Heqbeq. simpl.
      remember (beq_ascii a a0) as beqa. destruct beqa.
      SSCase "a=a0".
       rewrite beq_ascii_sym. rewrite <- Heqbeqa. apply beq_nat_eq in Heqbeq.
        rewrite Heqbeq in H0. apply beq_ascii_eq in Heqbeqa. rewrite Heqbeqa in H0.
        rewrite H0 in H1. inversion H1. split. reflexivity. exists l2. reflexivity.
      SSCase "a!=a0".
       rewrite beq_ascii_sym.  rewrite <- Heqbeqa. apply beq_nat_eq in Heqbeq.  rewrite Heqbeq.
        rewrite <- ble_nat_refl. simpl. unfold insert. rewrite <-H2,<-H3. rewrite Heqbeq in H0.
        replace (ble_nat (S (S (length l))) (S n0)) with (ble_nat (S (length l)) n0) by reflexivity.
        remember (ble_nat (S(length l)) n0) as ble. destruct ble; inversion H0. inversion H1.
        apply bleSF1 in Heqble. rewrite <-Heqble. rewrite OT2.
        split;try exists (insert1 (S n0) a (insert1 n0 a0 l));reflexivity.
    SCase "n!=n0".
     rewrite beq_nat_sym. rewrite <-Heqbeq. simpl. remember (ble_nat n0 n) as ble. destruct ble.
     SSCase "n0<=n".
      inversion Heqble.  apply ble_nat_neg0 in H5;try apply Heqbeq. rewrite <-H5.
       simpl. unfold insert. rewrite <- H2,<-H3.
       replace (ble_nat (S (S (length l))) (S n)) with (ble_nat (S (length l)) n) by reflexivity.
       destruct (ble_nat (S (length l)) n); inversion H0.
       remember (ble_nat (S (length l)) n0) as ble. destruct ble; inversion H1. apply bleSF1 in Heqble0.
       rewrite <-Heqble0. rewrite OT3; try apply Heqble.
       split;try exists (insert1 (S n) a (insert1 n0 a0 l));reflexivity.
     SSCase "n0>n".
      inversion Heqble.  apply ble_nat_neg in H5. rewrite <-H5. simpl. unfold insert.
       rewrite <- H2,<-H3.
       replace (ble_nat (S (S (length l))) (S n0)) with (ble_nat (S (length l)) n0) by reflexivity.
       destruct (ble_nat (S (length l)) n0); inversion H1.
       remember (ble_nat (S (length l)) n) as ble. destruct ble; inversion H0. apply bleSF1 in Heqble0.
       rewrite <-Heqble0. rewrite <-OT3; try apply H5.
       split;try exists (insert1 n a (insert1 n0 a0 l));reflexivity.
  Case "f1=ins, f2=del".
   inversion H. inversion H. apply insert_len in H2. apply delete_len in H3.
    unfold OT. simpl. simpl in H0,H1. unfold insert,delete in H0,H1.
    remember (ble_nat n n0) as ble. destruct ble.
    SCase "n<=n0".
     simpl. unfold delete,insert. rewrite <- H2,<-H3.
      replace (ble_nat ((S (length l))) (S n0)) with (ble_nat ((length l)) n0) by reflexivity.
      remember (ble_nat (length l) n0) as ble. destruct ble;inversion H1.
      inversion Heqble0. apply ble_nat_negtrans1 with (n0:=n) in H6; try apply Heqble.
      rewrite <- H6. destruct (ble_nat (S (length l)) n); inversion H0.
      rewrite OT5;try apply Heqble. split;try exists (insert1 n a (delete1 n0 l));reflexivity.
    SCase "n>n0".
     simpl. unfold delete,insert. rewrite <- H2,<-H3.
      destruct n. inversion Heqble. unfold pred. simpl in H0.
       remember (ble_nat (length l) n) as ble. destruct ble;inversion H0.
       remember (ble_nat (length l) n0) as ble. destruct ble; inversion H1. apply bleSF1 in Heqble1.
       rewrite<- Heqble1. destruct l. inversion H3. simpl in Heqble,Heqble0.
       rewrite OT6;try simpl;try apply Heqble; try apply Heqble0.
       split;try exists (insert1 n a (delete1 n0 (a0 :: l)));reflexivity.
  Case "ins,id".
   simpl. inversion H. inversion H. inversion H1. apply insert_len in H2.
    simpl in H0. unfold insert. unfold insert in H0. rewrite <- H5.
    destruct (ble_nat (S (length l)) n);inversion H0.
    split;try exists (insert1 n a l);reflexivity.
  Case "delete,ins".
   inversion H. inversion H. apply insert_len in H3. apply delete_len in H2.
    unfold OT. simpl. simpl in H0,H1. unfold insert,delete in H0,H1.
    remember (ble_nat n0 n) as ble. destruct ble.
    SCase "n0<=n".
     simpl. unfold insert,delete. rewrite <-H2,<-H3. simpl.
      remember (ble_nat (length l) n) as ble. destruct ble;inversion H0.
      inversion Heqble0. apply ble_nat_negtrans1 with (n0:=n0) in H6;try apply Heqble.
      rewrite <- H6. apply bleSF1 in H6. rewrite <- H6 in H1. inversion H1. rewrite OT7;try apply Heqble.
      split;try exists (match insert1 n0 a l with | [] => [] | h :: l' => h :: delete1 n l' end);reflexivity.
    SCase "n0>n".
     simpl. unfold insert,delete. rewrite <-H2,<-H3. destruct n0. inversion Heqble. unfold pred.
      remember (ble_nat (length l) n) as ble. destruct ble;inversion H0. inversion Heqble0.
      apply bleSF1 in H6. rewrite <- H6. simpl in H1. destruct (ble_nat (length l) n0);
      inversion H1. destruct l. inversion H2. simpl in Heqble, Heqble0.
      rewrite OT8;simpl;try apply Heqble;try apply Heqble0.
      split;try exists (delete1 n (a0 :: insert1 n0 a l));reflexivity.
  Case "del,del".
   inversion H. inversion H. apply delete_len in H3. apply delete_len in H2.
   unfold OT. simpl. simpl in H0,H1. unfold delete in H0,H1.
   remember (beq_nat n n0) as beq. destruct beq.
    SCase "n=n0".
     apply beq_nat_eq in Heqbeq. rewrite <-Heqbeq. rewrite <- Heqbeq in H1.
     rewrite <- beq_nat_refl. simpl. destruct (ble_nat (length l) n); inversion H0.
     inversion H1. split;try exists (delete1 n l);reflexivity.
    SCase "n!=n0".
     remember (ble_nat n0 n) as ble. destruct ble.
      SSCase "n0<=n".
       inversion Heqble. apply ble_nat_neg0 in H5;try apply Heqbeq. rewrite <- H5.
       rewrite beq_nat_sym in Heqbeq. rewrite<-Heqbeq. simpl. unfold delete.
       destruct n. inversion H5. destruct l;inversion H2;inversion H3.
       unfold pred. simpl in H0,H1. remember (ble_nat (length l) n) as ble.
       destruct ble;inversion H0. inversion H5.
       remember (beq_nat (length l) (S n)) as beq. destruct beq.
        apply beq_nat_eq in Heqbeq0. rewrite Heqbeq0. rewrite <- H5.
        rewrite Heqbeq0 in H1.
        remember (match n0 with | 0 => false | S m' => ble_nat (S n) m' end) as mat.
        destruct mat; inversion H1.  rewrite OT11; try apply H5; try apply Heqbeq0.
        split;try exists (delete1 n (delete1 n0 (a :: l)));reflexivity.
       inversion Heqble0.
        replace (ble_nat (length l) n) with  (ble_nat (S (length l)) (S n)) in H10 by reflexivity.
        apply ble_nat_neg3 in H10; try apply Heqbeq0.
        replace (match n0 with| 0 => false | S m' => ble_nat n m' end) with (ble_nat (S n) n0) in H9 by reflexivity.
        apply ble_nat_negtrans with (n0:=length l) in H9; try apply H10.
        rewrite <- H9. destruct (match n0 with | 0 => false| S m' => ble_nat (length l) m' end);inversion H1.
        rewrite OT9; try apply H5; try apply Heqble0.
        split;try exists (delete1 n (delete1 n0 (a :: l)));reflexivity.
      SSCase "n0>n".
       rewrite beq_nat_sym in Heqbeq. rewrite <- Heqbeq.
       inversion Heqble. apply ble_nat_neg in H5. rewrite <- H5. simpl.
       destruct n0. inversion Heqble. unfold pred. unfold delete.
       destruct l; inversion H2; inversion H3. simpl in H1.
       remember (ble_nat (length l) n0) as ble. destruct ble; inversion H1.
       replace (ble_nat (length (a :: l)) n) with (ble_nat (S (length l)) n) in H0 by reflexivity.
       remember (ble_nat (S (length l)) n) as ble. destruct ble; inversion H0.
       remember (beq_nat (length l) n) as beq. destruct beq.
        apply beq_nat_eq in Heqbeq0. rewrite Heqbeq0 in Heqble1, Heqble0.
         apply ble_nat_beq in Heqble0; try apply H5. rewrite beq_nat_sym in Heqble0.
         rewrite <-Heqble0 in Heqbeq. inversion Heqbeq.
        apply ble_nat_neg3 in Heqble1; try apply Heqbeq0. rewrite <-Heqble1.
         rewrite OT10; try apply Heqble1; try apply Heqble.
         split;try exists (delete1 n (a :: delete1 n0 l));reflexivity.
  Case "del,id".
   inversion H. inversion H. apply delete_len in H2. simpl. unfold delete. simpl in H0,H1.
    unfold delete in H0. inversion H1. rewrite<- H5. destruct (ble_nat (length l) n); inversion H0.
    split;try exists (delete1 n l);reflexivity.
  Case "id,ins".
   simpl. inversion H. inversion H. apply insert_len in H3. unfold insert. simpl in H0,H1.
    unfold insert in H1. inversion H0. rewrite<- H5. destruct (ble_nat (S(length l)) n); inversion H1.
    split;try exists (insert1 n a l);reflexivity.
  Case "id,del".
   inversion H. inversion H. apply delete_len in H3. simpl. unfold delete. simpl in H0,H1.
    unfold delete in H1. inversion H0. rewrite<- H5. destruct (ble_nat (length l) n); inversion H1.
    split;try exists (delete1 n l);reflexivity.
  Case "ins,ins".
   simpl. inversion H. inversion H0. inversion H1. rewrite <- H3,<-H4.
     split. reflexivity. exists (l). reflexivity.
Qed.


(* Injective Library *)
(* v0   Olivier Laurent *)

(** * Some properties of injective functions *)

Require Import Relations.
Require Import RelationClasses.
Require Import List_more.

(** Same definition as in standard library [Coq.Sets.Image] *)
Definition injective {A B} (f : A -> B) := forall x y, f x = f y -> x = y.

Definition injective2 {A B C} (f : A -> B -> C) :=
  forall x y x' y', f x y = f x' y' -> x = x' /\ y = y'.

(** * Basic properties of injective functions *)

Lemma comp_inj {A B C} : forall (f : B -> C) (g : A -> B),
  injective f -> injective g -> injective (fun x => f (g x)).
Proof.
intros f g Hf Hg x y Hc.
apply Hg.
apply Hf.
assumption.
Qed.

Lemma section_inj {A B} : forall (f : A -> B) g,
  (forall x, g (f x) = x) -> injective f.
Proof.
intros f g Hsec x y Hf.
rewrite <- Hsec.
rewrite <- Hf.
rewrite Hsec.
reflexivity.
Qed.

Lemma map_inj {A B} : forall f : A -> B, injective f -> injective (map f).
Proof.
intros f Hf l1.
induction l1 ; intros l2 Hmap.
- destruct l2.
  + reflexivity.
  + inversion Hmap.
- destruct l2.
  + inversion Hmap.
  + simpl in Hmap.
    injection Hmap ; intros Htl Hhd.
    apply Hf in Hhd.
    apply IHl1 in Htl.
    subst.
    reflexivity.
Qed.

Lemma map_inj_local {A B} : forall f : A -> B, forall l1 l2,
  (forall x y, In x l1 -> In y l2 -> f x = f y -> x = y) ->
    map f l1 = map f l2 -> l1 = l2.
Proof with try assumption ; try reflexivity.
induction l1 ; intros l2 Hi Hmap.
- destruct l2...
  inversion Hmap.
- destruct l2.
  + inversion Hmap.
  + simpl in Hmap.
    injection Hmap ; intros Htl Hhd.
    apply Hi in Hhd ; try (apply in_eq ; fail).
    apply IHl1 in Htl ; subst...
    intros.
    apply Hi...
    * apply in_cons...
    * apply in_cons...
Qed.

(** * Inverse image of a relation by an injective function *)

Section Relation_inj.

Variable A B : Type.
Variable f : A -> B.
Hypothesis f_inj : injective f.

Variable R : relation B.

Definition f_R := fun x y => R (f x) (f y).

Lemma PreOrder_inj : PreOrder R -> PreOrder f_R.
Proof.
intros Hp.
destruct Hp.
split ; unfold f_R.
- intros x.
  apply PreOrder_Reflexive.
- intros x y z H1 H2.
  eapply PreOrder_Transitive ; eassumption.
Qed.

Lemma Equivalence_inj : Equivalence R -> Equivalence f_R.
Proof.
intros He.
destruct He.
split ; unfold f_R.
- intros x.
  apply Equivalence_Reflexive.
- intros x y H.
  apply Equivalence_Symmetric ; assumption.
- intros x y z H1 H2.
  eapply Equivalence_Transitive ; eassumption.
Qed.

Lemma PartialOrder_inj : forall Ro,
  @PartialOrder _ eq _ _ Ro -> @PartialOrder _ eq _ _ (PreOrder_inj Ro).
Proof.
intros Ro Rp x y ; split ; intros H.
- subst ; split.
  + clear Rp ; apply PreOrder_inj in Ro.
    reflexivity.
  + clear Rp ; apply PreOrder_inj in Ro.
    reflexivity.
- destruct H as [Hr Hs].
  destruct Rp with (f x) (f y) as [_ Hf].
  apply f_inj.
  apply Hf.
  split.
  + apply Hr.
  + apply Hs.
Qed.

End Relation_inj.


Inductive natural : Type := Succ : natural -> natural |  Zero : natural.

Inductive lst : Type := Cons : natural -> lst -> lst |  Nil : lst.

Inductive tree : Type := Node : natural -> tree -> tree -> tree |  Leaf : tree.

Inductive Pair : Type := mkpair : natural -> natural -> Pair
with Zlst : Type := zcons : Pair -> Zlst -> Zlst |  znil : Zlst.

Fixpoint drop (drop_arg0 : natural) (drop_arg1 : lst) : lst
           := match drop_arg0, drop_arg1 with
              | x, Nil => Nil
              | Zero, x => x
              | Succ x, Cons y z => drop x z
              end.

Theorem drop_Nil: forall (x: natural), drop x Nil = Nil.
Proof.
  induction x ; simpl; reflexivity.
Qed.

Theorem drop_Cons: forall (x n: natural) (l: lst), drop (Succ x) (Cons n l) = drop x l.
  induction l; induction x; simpl; reflexivity.
Qed.

Theorem drop_Cons_assoc: forall (x1 x2 x3: natural) (l: lst),
    drop x1 (drop x2 (Cons x3 l)) = drop x2 (drop x1 (Cons x3 l)).
Proof.
  induction x1; induction x2; try (simpl; reflexivity).
  + induction l.
    * rewrite 2 drop_Cons. rewrite <- IHx1.
      rewrite IHx2. rewrite 2 drop_Cons.
      induction l.
      - rewrite IHx1. reflexivity.
      - rewrite 3 drop_Nil. reflexivity.
    * simpl. rewrite 2 drop_Nil. reflexivity.
  + intros. simpl. destruct (drop x1 l); reflexivity.
  + intros. simpl. destruct (drop x2 l); reflexivity.
Qed.

Theorem drop_assoc : forall (x : natural) (y : natural) (z : lst), eq (drop x (drop y z)) (drop y (drop x z)).
Proof.
  induction z.
  + rewrite 2 drop_Cons_assoc. reflexivity.
  + rewrite 3 drop_Nil. reflexivity.
Qed.

Theorem theorem0 : forall (x : natural) (y : natural) (w : natural) (z : lst), eq (drop w (drop x (drop y z))) (drop y (drop x (drop w z))).
Proof.
  intros.
  rewrite (drop_assoc w x).
  rewrite (drop_assoc w y).
  rewrite (drop_assoc x y).
  reflexivity.
Qed.


Definition relation (a : Type) := a -> a -> Prop.

Record poset := mk_poset {
  carrier :> Type;
  ord : relation carrier;
  ord_refl {x} : ord x x;
  ord_trans {x y z} : ord x y -> ord y z -> ord x z;
  ord_antisym {x y} : ord x y -> ord y x -> x = y
}.

Record monotone (a b : poset) := mk_monotone {
  base_f :> carrier a -> carrier b;
  base_f_mono x y : ord a x y -> ord b (base_f x) (base_f y)
}.
Arguments mk_monotone {a b}.
Arguments base_f {a b}.
Arguments base_f_mono {a b}.


Theorem eqb_trans : forall n m p,
  n =? m = true ->
  m =? p = true ->
  n =? p = true.
Proof.
  intros  n m p H1 H2.
  apply eqb_true in H1.
  apply eqb_true in H2.
  rewrite -> H2 in H1.
  rewrite -> H1.
  rewrite eqb_refl.
  reflexivity.
Qed.


Require Import Arith.
Require Import NArith.
Require Import List.
Require Import Sorting.
Require Import Coq.Program.Equality.

Lemma minus_n_0 : forall n, n-0 = n.
Proof.
induction n; trivial.
Defined.

Lemma plus_0_n : forall n, 0+n = n.
Proof.
induction n; trivial.
Defined.

Lemma plus_n_0 : forall n, n+0 = n.
Proof.
induction n; trivial.
simpl; rewrite IHn; reflexivity.
Defined.

Lemma plus_n_1 : forall n, n+1 = S n.
Proof.
induction n; trivial.
simpl; rewrite IHn; reflexivity.
Defined.

Lemma minus_n1_n2_0 : forall n1 n2, n1+n2-0 = n1+n2.
Proof.
induction n1; induction n2; trivial.
Defined.

Fixpoint arity (T:Type) (n:nat) :=
 match n with
 | 0 => Prop
 | S p => T -> arity T p
 end.

(** Warning: cartesianPower T 0 represents T but it is never used *)

Fixpoint cartesianPowerAux (T:Type) (n:nat) :=
 match n with
 | 0 => T
 | S p => (T * cartesianPowerAux T p)%type
 end.

Definition cartesianPower T n := cartesianPowerAux T (n-1).

Definition headCP {T:Type} {n:nat} (cp : cartesianPower T (S n)) : T.
Proof.
induction n.
exact cp.
exact (fst cp).
Defined.

Definition headCPbis {T:Type} {n:nat} (cp : cartesianPower T (S n)) : cartesianPower T 1.
Proof.
induction n.
exact cp.
exact (fst cp).
Defined.

Definition tailCP {T:Type} {n:nat} (cp : cartesianPower T (S (S n))) : (cartesianPower T (S n)).
Proof.
induction n.
exact (snd cp).
exact (snd cp).
Defined.

Definition tailDefaultCP {T:Type} {n:nat} (cp : cartesianPower T (S n)) (Default : cartesianPower T n) : (cartesianPower T n).
Proof.
induction n.
exact Default.
exact (tailCP cp).
Defined.

Definition allButLastCP {T:Type} {n:nat} (cp : cartesianPower T (S (S n))) : (cartesianPower T (S n)).
Proof.
induction n.
exact (headCP cp).
split.
exact (headCP cp).
unfold cartesianPower in IHn.
simpl in *.
rewrite minus_n_0 in IHn.
apply IHn.
exact (tailCP cp).
Defined.

Lemma allButLastCPTl {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S (S n)))),
  allButLastCP (tailCP cp) = tailCP (allButLastCP cp).
Proof.
intro cp; induction n; simpl; reflexivity.
Qed.

Definition lastCP {T:Type} {n:nat} (cp : cartesianPower T (S n)) : T.
Proof.
induction n.
exact cp.
apply IHn.
exact (tailCP cp).
Defined.

Lemma lastCPTl {T:Type} {n:nat} : forall (cp : cartesianPower T (S (S n))), lastCP cp = lastCP (tailCP cp).
Proof.
intro cp; induction n; simpl; reflexivity.
Qed.

Lemma CP_ind {T:Type} {n : nat} : forall (cp cp' : cartesianPower T (S (S n))),
  headCP cp = headCP cp' -> tailCP cp = tailCP cp' -> cp = cp'.
Proof.
intros.
induction n; simpl in *;
apply injective_projections; assumption.
Qed.

Lemma CPPair {T : Type} :
  forall (cp : cartesianPower T 2),
  cp = (fst cp, snd cp).
Proof.
intro cp.
apply CP_ind; simpl; reflexivity.
Qed.

Definition tailCPbis {T:Type} {n:nat} m1 m2 (cp : cartesianPower T m1) :
  (S (S n)) = m1 -> (S n) = m2 -> (cartesianPower T m2).
Proof.
intros Hm1 Hm2.
subst.
exact (tailCP cp).
Defined.

Definition consHeadCP {T:Type} {n:nat} (t : T) (cp : cartesianPower T n) : (cartesianPower T (S n)).
Proof.
induction n.
exact t.
clear IHn.
split.
exact t.
unfold cartesianPower in cp.
simpl in cp.
rewrite minus_n_0 in cp.
exact cp.
Defined.

Lemma consHeadCPHd {T:Type} {n:nat} :
  forall (cp : cartesianPower T n) t,
  headCP (consHeadCP t cp) = t.
Proof.
intro cp; induction n; simpl; reflexivity.
Qed.

Lemma consHeadCPTl {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S n)) t,
  tailCP (consHeadCP t cp) = cp.
Proof.
intro cp; induction n; simpl; reflexivity.
Qed.

Lemma consHeadCPOK {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))),
  cp = consHeadCP (headCP cp) (tailCP cp).
Proof.
intro cp.
induction n.
simpl.
apply CPPair.
apply CP_ind.
simpl; reflexivity.
rewrite consHeadCPTl; reflexivity.
Qed.

Definition consTailCP {T:Type} {n:nat} (cp : cartesianPower T n) (t : T) : (cartesianPower T (S n)).
Proof.
induction n.
exact t.
induction n.
exact (cp, t).
clear IHn0.
split.
exact (headCP cp).
exact (IHn (tailCP cp)).
Defined.

Lemma consTailCPTl {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))) t,
  tailCP (consTailCP cp t) = consTailCP (tailCP cp) t.
Proof.
intro cp; induction n; simpl; reflexivity.
Qed.

Lemma consTailCPOK {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))),
  cp = consTailCP (allButLastCP cp) (lastCP cp).
Proof.
intro cp.
induction n.
simpl.
apply CPPair.
apply CP_ind.
simpl; reflexivity.
assert (H := IHn (tailCP cp)).
rewrite <- lastCPTl in H.
rewrite allButLastCPTl in H.
rewrite <- consTailCPTl in H.
assumption.
Qed.

Lemma consTailCPAbl {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S n)) t,
  allButLastCP (consTailCP cp t) = cp.
Proof.
intros cp t; induction n; try (simpl; reflexivity).
apply CP_ind.
simpl; reflexivity.
rewrite <- IHn.
rewrite <- consTailCPTl.
rewrite allButLastCPTl.
reflexivity.
Qed.

Lemma consTailCPTlD {T:Type} {n:nat} :
  forall (cp : cartesianPower T n) t,
  tailDefaultCP (consHeadCP t cp) cp = cp.
Proof.
intros cp t; induction n; try (simpl; reflexivity).
induction n; simpl; reflexivity.
Qed.

Lemma consHdTlTlHd {T:Type} {n:nat} :
  forall (F L : T) (X : cartesianPower T n),
  consHeadCP F (consTailCP X L) = consTailCP (consHeadCP F X) L.
Proof.
induction n.
intros F L X.
unfold consHeadCP; unfold consTailCP; simpl; reflexivity.
clear IHn.
induction n.
intros F L X.
unfold consHeadCP; unfold consTailCP; simpl; reflexivity.
intros F L X.
apply CP_ind.
simpl; reflexivity.
assert (H := consHeadCPOK X); rewrite H; clear H.
rewrite consHeadCPTl.
rewrite consTailCPTl.
rewrite consHeadCPTl.
reflexivity.
Qed.

Lemma consTlHdHdTl {T:Type} {n:nat} :
  forall (A B C : T) (X : cartesianPower T n),
  consHeadCP A (consHeadCP B (consTailCP X C)) = consTailCP (consHeadCP A (consHeadCP B X)) C.
Proof.
induction n.
intros A B C X.
unfold consHeadCP; unfold consTailCP; simpl; reflexivity.
clear IHn.
induction n.
intros A B C X.
unfold consHeadCP; unfold consTailCP; simpl; reflexivity.
intros A B C X.
apply CP_ind.
simpl; reflexivity.
assert (H := consHeadCPOK X); rewrite H; clear H.
rewrite consHeadCPTl.
rewrite consTailCPTl.
rewrite consHeadCPTl.
rewrite <- IHn.
apply CP_ind.
simpl; reflexivity.
do 2 (rewrite consHeadCPTl).
apply CP_ind.
simpl; reflexivity.
rewrite consHeadCPTl.
rewrite consTailCPTl.
induction n.
simpl; reflexivity.
rewrite consHeadCPTl; reflexivity.
Qed.

Definition CPToList {T:Type} {n:nat} (cp : cartesianPower T n) : list T.
Proof.
induction n.
exact nil.
clear IHn.
induction n.
exact (cons cp nil).
apply cons.
exact (headCP cp).
apply IHn.
exact (tailCP cp).
Defined.

Definition InCP {T:Type} {n:nat} p (cp : cartesianPower T n) := In p (CPToList cp).

Lemma InCPOK {T:Type} {n:nat} : forall p (cp : cartesianPower T (S (S n))),
  InCP p cp <-> ((p = headCP cp) \/ InCP p (tailCP cp)).
Proof.
intros p cp; unfold InCP; induction n; simpl.

  split; intro H.

    elim H; clear H; intro H.

      left; subst; reflexivity.

      right; assumption.

    elim H; clear H; intro H.

      left; subst; reflexivity.

      right; assumption.

  split; intro H.

    elim H; clear H; intro H.

      left; subst; reflexivity.

      right; assumption.

    elim H; clear H; intro H.

      left; subst; reflexivity.

      right; assumption.
Qed.

Lemma lastCPIn {T:Type} {n:nat} : forall (cp : cartesianPower T (S n)), InCP (lastCP cp) cp.
Proof.
unfold InCP.
intro cp; induction n.
simpl; intuition.
simpl.
assert (H := IHn (tailCP cp)).
intuition.
Qed.

Definition nthCP {T:Type} {m:nat} (n : nat) (cp : cartesianPower T m) (Default : T) := nth (n-1) (CPToList cp) Default.

Lemma CPToListOK {T:Type} {n:nat} : forall (cp : cartesianPower T (S (S n))), CPToList cp = cons (headCP cp) (CPToList (tailCP cp)).
Proof.
reflexivity.
Qed.

Lemma CPLHdTlOK {T:Type} {n:nat} : forall (cp : cartesianPower T (S (S n))),
  CPToList cp = ((headCP cp) :: nil) ++ CPToList (tailCP cp).
Proof.
induction n; intro cp; simpl; reflexivity.
Qed.

Lemma consTailOK {T:Type} {n:nat} : forall (cp : cartesianPower T (S n)) t,
  CPToList (consTailCP cp t) = CPToList cp ++ t :: nil.
Proof.
induction n; intros cp t.
simpl; reflexivity.
rewrite CPToListOK.
assert (H : headCP (consTailCP cp t) = headCP cp) by (simpl; reflexivity); rewrite H; clear H.
assert (H : tailCP (consTailCP cp t) = (consTailCP (tailCP cp) t)) by (simpl; reflexivity);
rewrite H; clear H.
rewrite IHn.
simpl; reflexivity.
Qed.

Lemma InNth {T:Type} {n:nat} :
  forall (cp : cartesianPower T n) (t Default : T),
  InCP t cp -> (exists id, id >= 1 /\ id <= n /\ t = nthCP id cp Default).
Proof.
induction n; intros cp t Default HIn.
unfold InCP in HIn.
simpl in HIn.
intuition.
induction n.
exists 1; try intuition.
unfold nthCP; simpl.
unfold InCP in HIn; simpl in HIn.
intuition.
clear IHn0.
apply InCPOK in HIn.
elim HIn; clear HIn; intro HIn.
exists 1; unfold nthCP; simpl; intuition.
assert (H := IHn (tailCP cp) t Default).
apply H in HIn; clear H.
destruct HIn as [id [Hge [Hle HEq]]].
unfold nthCP in *.
exists (S id); try intuition.
assert (H := app_nth2 ((headCP cp) :: nil) (CPToList (tailCP cp)) Default Hge).
rewrite CPToListOK.
assert (H' : (headCP cp :: nil) ++ CPToList (tailCP cp) = (headCP cp :: CPToList (tailCP cp)))
  by (simpl; reflexivity); rewrite <- H'; clear H'.
assert (H' : (S id - 1) = id) by (simpl; rewrite minus_n_0; reflexivity); rewrite H'; clear H'.
rewrite H.
apply HEq.
Qed.

Lemma nthFirst {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S n)) (t Default : T),
  t = nthCP 1 cp Default -> t = headCP cp.
Proof.
induction n; intros cp t Default Hnth.
unfold nthCP in Hnth.
simpl in Hnth.
assumption.
unfold nthCP in Hnth.
simpl in Hnth.
assumption.
Qed.

Lemma lengthOfCPToList {T:Type} {n:nat} : forall (cp : cartesianPower T n), n = length (CPToList cp).
Proof.
intros.
induction n.
simpl.
reflexivity.
clear IHn.
induction n.
simpl.
reflexivity.
apply eq_S.
apply IHn.
Defined.

Lemma lastTailOK {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))),
  lastCP cp = lastCP (tailCP cp).
Proof.
induction n; intro cp; simpl; reflexivity.
Qed.

Lemma consTailCPLast {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S n)) t,
  lastCP (consTailCP cp t) = t.
Proof.
intros cp t; induction n; try (simpl; reflexivity).
rewrite lastTailOK.
apply IHn.
Qed.

Lemma nthLast {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S n)) (Default : T),
  lastCP cp = nthCP (S n) cp Default.
Proof.
unfold nthCP; induction n; intros cp Default.
simpl; reflexivity.
rewrite lastTailOK.
assert (H := IHn (tailCP cp) Default); rewrite H; clear H; clear IHn.
simpl.
rewrite minus_n_0.
reflexivity.
Qed.

Lemma nthCircPerm1 {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))) (t Default : T),
  t = nthCP 1 cp Default -> t = nthCP (S (S n)) (consTailCP (tailCP cp) (headCP cp)) Default.
Proof.
intros cp t Default Hnth.
apply nthFirst in Hnth.
rewrite <- Hnth.
clear Hnth.
unfold nthCP.
rewrite consTailOK.
rewrite app_nth2.
rewrite <- lengthOfCPToList.
simpl.
rewrite <- Minus.minus_diag_reverse.
reflexivity.
rewrite <- lengthOfCPToList.
simpl.
intuition.
Qed.

Lemma nthCircPerm1Eq {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))) (Default : T),
  nthCP 1 cp Default = nthCP (S (S n)) (consTailCP (tailCP cp) (headCP cp)) Default.
Proof.
intros cp Default.
apply nthCircPerm1.
reflexivity.
Qed.

Lemma nthCircPerm2 {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))) (t Default : T) id,
  t = nthCP (S (S id)) cp Default -> id <= n ->
  t = nthCP (S id) (consTailCP (tailCP cp) (headCP cp)) Default.
Proof.
induction n; intros cp t Default id Hnth HIn.
simpl in *.
induction id.
unfold nthCP in *.
simpl in Hnth.
rewrite <- Hnth.
simpl; reflexivity.
assert (H := Le.le_Sn_0 id); intuition.
unfold nthCP in *.
rewrite consTailOK.
rewrite CPLHdTlOK in Hnth.
rewrite app_nth2 in Hnth.
assert (H : S (S id) - 1 - length (headCP cp :: nil)  = S id - 1) by (simpl; reflexivity);
rewrite H in Hnth; clear H.
rewrite app_nth1; try assumption.
rewrite <- lengthOfCPToList.
simpl.
rewrite minus_n_0.
apply Lt.le_lt_n_Sm; assumption.
simpl.
intuition.
Qed.

Lemma nthCircPerm2Eq {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))) (Default : T) id,
  id <= n -> nthCP (S (S id)) cp Default = nthCP (S id) (consTailCP (tailCP cp) (headCP cp)) Default.
Proof.
intros cp Default id Hle.
apply nthCircPerm2.
reflexivity.
assumption.
Qed.

Lemma nthCPTlOK {T:Type} {m:nat} :
  forall (cp : cartesianPower T (S (S m))) (Default : T) n,
  nthCP (S n) (tailCP cp) Default = nthCP (S (S n)) cp Default.
Proof.
induction m; intros cp Default n.
induction n; unfold nthCP; simpl; reflexivity.
assert (H := nthCircPerm2 cp (nthCP (S (S n)) cp Default) Default n).
assert (Hnm := le_lt_dec n (S m)).
elim Hnm; clear Hnm; intro Hnm.
assert (H' : nthCP (S (S n)) cp Default = nthCP (S (S n)) cp Default) by reflexivity; apply H in H'; try assumption;
clear H; rewrite H'; clear H'.
unfold nthCP.
rewrite consTailOK.
rewrite app_nth1; try reflexivity.
rewrite <- lengthOfCPToList.
simpl.
rewrite minus_n_0.
apply Lt.le_lt_n_Sm; assumption.
unfold nthCP.
rewrite nth_overflow.
rewrite nth_overflow; try reflexivity.
rewrite <- lengthOfCPToList; simpl; intuition.
rewrite <- lengthOfCPToList; simpl; rewrite minus_n_0; intuition.
Qed.

Lemma nthEqOK {T:Type} {m:nat} :
  forall (cp1 cp2 : cartesianPower T (S m)) (Default : T),
  (forall n, nthCP n cp1 Default = nthCP n cp2 Default) -> cp1 = cp2.
Proof.
induction m; intros cp1 cp2 Default Hnth.
assert (H := Hnth 1).
unfold nthCP in H.
simpl in H.
assumption.
apply CP_ind.
assert (H := Hnth 1).
unfold nthCP in H.
simpl in H.
assumption.
apply IHm with Default.
intro n; induction n.
assert (H := Hnth 2).
unfold nthCP.
unfold nthCP in H.
do 2 (rewrite CPLHdTlOK in H).
simpl; assumption.
do 2 (rewrite nthCPTlOK).
apply Hnth.
Qed.

Lemma consTailPerm  {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))),
  Permutation.Permutation (CPToList cp) (CPToList (consTailCP (tailCP cp) (headCP cp))).
Proof.
intro cp.
rewrite CPLHdTlOK.
rewrite consTailOK.
apply Permutation.Permutation_app_comm.
Qed.

Definition ListToCP {T : Type} (l : list T) (Default : T) : cartesianPower T (length l).
Proof.
induction l.
exact Default.
induction l.
exact a.
clear IHl0.
split.
exact a.
unfold cartesianPower in IHl.
simpl in IHl.
rewrite minus_n_0 in IHl.
exact IHl.
Defined.

Fixpoint circPermNCP {T:Type} {m:nat} (n : nat) (cp : cartesianPower T (S (S m))) :=
  match n with
  | 0 => cp
  | S p => circPermNCP p (consTailCP (tailCP cp) (headCP cp))
  end.

Lemma circPermNCP0 {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))),
  cp = circPermNCP 0 cp.
Proof.
simpl; reflexivity.
Qed.

Lemma circPermNCPOK {T:Type} {m:nat} :
  forall (n : nat) (cp : cartesianPower T (S (S m))),
  circPermNCP (S n) cp = circPermNCP n (consTailCP (tailCP cp) (headCP cp)).
Proof.
unfold circPermNCP; reflexivity.
Qed.

Lemma nthCircPermNAny {T:Type} {m:nat} :
  forall (cp : cartesianPower T (S (S m))) (Default : T) id n,
  id + n <= S m -> nthCP (S id + n) cp Default = nthCP (S id) (circPermNCP n cp) Default.
Proof.
intros cp Default id n Hle; revert cp; induction n; intro cp.
rewrite plus_n_0; simpl; reflexivity.
rewrite circPermNCPOK.
assert (H : id + n <= S m) by (apply le_Sn_le; rewrite plus_n_Sm; assumption).
assert (H' : id + n <= m) by (apply le_S_n; transitivity (id + S n); intuition).
rewrite <- IHn; try assumption.
rewrite <- plus_n_Sm.
apply nthCircPerm2Eq; assumption.
Qed.

Lemma circPermNIdFirst {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))) (Default : T),
  nthCP 1 cp Default = nthCP 1 (circPermNCP (S (S n)) cp) Default.
Proof.
intros cp Default.
rewrite nthCircPerm1Eq.
assert (H : 0 + S n <= S n) by intuition.
assert (H' := nthCircPermNAny (consTailCP (tailCP cp) (headCP cp)) Default 0 (S n) H); clear H.
assert (H : 1 + S n = S (S n)) by intuition; rewrite H in H'; clear H; rewrite H'.
apply eq_sym.
rewrite circPermNCPOK.
reflexivity.
Qed.

Lemma circPermNConsTlOK {T:Type} {m:nat} :
  forall (n : nat) (cp : cartesianPower T (S (S m))),
  consTailCP (tailCP (circPermNCP n cp)) (headCP (circPermNCP n cp)) = circPermNCP n (consTailCP (tailCP cp) (headCP cp)).
Proof.
intros n; induction n; intro cp.
simpl; reflexivity.
apply eq_sym.
rewrite circPermNCPOK.
rewrite <- IHn.
rewrite <- circPermNCPOK.
reflexivity.
Qed.

Lemma circPermPerm {T:Type} {m:nat} :
  forall (n : nat) (cp : cartesianPower T (S (S m))),
  circPermNCP (S (S (S n))) cp = circPermNCP 1 (circPermNCP (S (S n)) cp).
Proof.
intros n cp.
rewrite circPermNCPOK.
apply eq_sym.
rewrite circPermNCPOK.
rewrite <- circPermNCP0.
apply circPermNConsTlOK.
Qed.

Lemma nthCP01 {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S n)) Default,
  nthCP 0 cp Default = nthCP 1 cp Default.
Proof.
unfold nthCP.
assert (H : 0 - 1 = 0) by (simpl; reflexivity); rewrite H; clear H.
assert (H : 1 - 1 = 0) by (simpl; reflexivity); rewrite H; clear H.
reflexivity.
Qed.

Lemma circPermNIdAux {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))) (Default : T),
  cp = circPermNCP (S (S n)) cp.
Proof.
intros cp Default.
apply nthEqOK with Default.
intro m.
assert (Hmn := le_lt_dec m (S (S n))).
elim Hmn; clear Hmn; intro Hmn.
revert cp; induction m; intro cp.
do 2 (rewrite nthCP01).
apply circPermNIdFirst.
clear IHm.
revert cp; induction m; intro cp.
apply circPermNIdFirst.
assert (H : m <= n) by (do 2 (apply le_S_n); assumption).
rewrite nthCircPerm2Eq; try assumption; clear H.
assert (H : S m <= S (S n)) by intuition.
rewrite IHm; try assumption; clear H; clear IHm.
rewrite <- circPermNCPOK.
rewrite circPermPerm.
assert (H : m + 1 <= S n) by (rewrite plus_n_1; intuition).
rewrite <- nthCircPermNAny; try assumption; clear H.
rewrite plus_n_1; reflexivity.
induction m.
assert (H := lt_n_0 (S (S n))); intuition.
clear IHm.
unfold nthCP.
rewrite nth_overflow.
rewrite nth_overflow; try reflexivity.
rewrite <- lengthOfCPToList.
simpl.
rewrite minus_n_0.
apply gt_S_le.
assumption.
rewrite <- lengthOfCPToList.
simpl.
rewrite minus_n_0.
apply gt_S_le.
assumption.
Qed.

Lemma circPermNId {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S (S n))),
  cp = circPermNCP (S (S n)) cp.
Proof.
intro cp.
apply circPermNIdAux.
exact (headCP cp).
Qed.

Lemma circPermNConsOK {T:Type} {n:nat} :
  forall (cp : cartesianPower T (S n)) (t1 t2 : T),
  circPermNCP (S n) (consTailCP (consTailCP cp t1) t2) = consHeadCP t1 (consHeadCP t2 cp).
Proof.
induction n; intros cp t1 t2.
simpl; reflexivity.
clear IHn.
assert (H := circPermNId (consHeadCP t1 (consHeadCP t2 cp))); rewrite H; clear H.
apply eq_sym.
rewrite circPermNCPOK.
assert (H : headCP (consHeadCP t1 (consHeadCP t2 cp)) = t1) by (simpl; reflexivity); rewrite H; clear H.
assert (H : tailCP (consHeadCP t1 (consHeadCP t2 cp)) = consHeadCP t2 cp)
  by (simpl; reflexivity); rewrite H; clear H.
rewrite circPermNCPOK.
assert (H : headCP (consTailCP (consHeadCP t2 cp) t1) = t2) by (simpl; reflexivity); rewrite H; clear H.
assert (H : tailCP (consTailCP (consHeadCP t2 cp) t1) = consTailCP cp t1)
  by (simpl; reflexivity); rewrite H; clear H.
reflexivity.
Qed.

Lemma listInd {T : Type} : forall n (l l' : list T) Default,
  length l = (S n) ->
  length l' = (S n) ->
  hd Default l = hd Default l' ->
  tl l = tl l' ->
  l = l'.
Proof.
intros n l.
induction l.
intros l' Default Hl.
simpl in Hl; discriminate.
intros l' Default Hl Hl' Hhd Htl.
induction l'.
simpl in Hl'; discriminate.
simpl in Hhd.
simpl in Htl.
subst.
reflexivity.
Qed.

Lemma CPLHd {T : Type} :
  forall (a : T) l Default,
  hd Default (CPToList (ListToCP (a :: l) Default)) = a.
Proof.
intros a l Default.
induction l.
simpl; reflexivity.
simpl; reflexivity.
Qed.

Lemma ListToCPTl {T : Type} :
  forall (a a0 : T) l (Ha0l : (S (length l)) = length (a0  :: l)) Haa0l Default,
  tailCPbis (length (a :: a0 :: l)) (length (a :: l)) (ListToCP (a :: a0 :: l) Default) Haa0l Ha0l =
  ListToCP (a0 :: l) Default.
Proof.
intros a a0 l Ha0l Haa0l Default.
simpl in *.
unfold tailCPbis.
unfold tailCP.
repeat (elim_eq_rect; simpl).
induction l; simpl; reflexivity.
Qed.

Lemma CPToListTl1 {T : Type} :
  forall (a a0 : T) l (cp : cartesianPower T (length (a :: a0 :: l))), tl (CPToList cp) = CPToList (tailCP cp).
Proof.
simpl; reflexivity.
Qed.

Lemma CPToListTl2 {T : Type} {n : nat} :
  forall (cp : cartesianPower T (S (S n))), tl (CPToList cp) = CPToList (tailCP cp).
Proof.
intro cp.
induction n.
simpl; reflexivity.
apply listInd with (S n) (fst cp).
apply eq_add_S.
assert (H := lengthOfCPToList cp); rewrite H.
simpl; reflexivity.
assert (H := lengthOfCPToList (tailCP cp)); rewrite H.
reflexivity.
simpl; reflexivity.
simpl; reflexivity.
Qed.

Lemma CPCPL {T : Type} :
  forall (a : T) l (cp1 : cartesianPower T (length (a :: l)))
  (cp2 : cartesianPower T (S(length l))),
  cp1 = cp2 -> CPToList cp1 = CPToList cp2.
Proof.
intros; subst; reflexivity.
Qed.

Lemma CPLCP {T : Type} {n : nat} :
  forall (cp1 cp2 : cartesianPower T (S n)),
  CPToList cp1 = CPToList cp2 -> cp1 = cp2.
Proof.
induction n; intros cp1 cp2 HCPL.

  simpl in *.
  injection HCPL.
  auto.

  do 2 (rewrite CPToListOK in HCPL).
  apply CP_ind.

    injection HCPL; auto.

    apply IHn.
    injection HCPL; auto.
Qed.

Lemma CPLRec {T : Type} :
  forall (a : T) l Default,
  (a :: (CPToList (ListToCP l Default))) = CPToList (ListToCP (a :: l) Default).
Proof.
intros a l Default.
assert (HlAux := lengthOfCPToList (ListToCP l Default)).
assert (Hl : S (length l) = length (a :: CPToList (ListToCP l Default))) by (simpl; apply eq_S; assumption);
clear HlAux; apply eq_sym in Hl.
assert (Hal := lengthOfCPToList (ListToCP (a :: l) Default)); apply eq_sym in Hal.
apply listInd with (length l) Default; try assumption.
rewrite CPLHd; simpl; reflexivity.
assert (H : tl (a :: CPToList (ListToCP l Default)) = CPToList (ListToCP l Default)) by (simpl; reflexivity);
rewrite H; clear H.
induction l.
simpl; reflexivity.
clear IHl.
assert (H := CPToListTl1 a a0 l (ListToCP (a :: a0 :: l) Default)); rewrite H; clear H.
assert (H := CPCPL a0 l (ListToCP (a0 :: l) Default) (tailCP (ListToCP (a :: a0 :: l) Default)));
apply H; clear H.
assert (Ha0l : (S (length l)) = length (a0  :: l)) by (simpl; reflexivity).
assert (Haa0l : (S (S (length l))) = length (a :: a0  :: l)) by (simpl; reflexivity).
assert (H := ListToCPTl a a0 l Ha0l Haa0l Default); rewrite <- H; clear H.
unfold tailCPbis.
repeat (elim_eq_rect; simpl); reflexivity.
Qed.

Lemma CPLOK {T : Type} : forall (l : list T) Default,
  CPToList (ListToCP l Default) = l.
Proof.
intros l Default.
induction l.
simpl; reflexivity.
rewrite <- CPLRec.
rewrite IHl.
reflexivity.
Qed.

Definition fixLastCP {T:Type} {n:nat} (appPred : cartesianPower T (S (S n)) -> Prop) (t : T) : cartesianPower T (S n) -> Prop.
Proof.
intro cp.
apply appPred.
exact (consTailCP cp t).
Defined.

Lemma fixLastCPOK {T:Type} {n:nat} :
  forall (appPred : cartesianPower T (S (S n)) -> Prop) (cp : cartesianPower T (S n)) (t : T),
  appPred (consTailCP  cp t) = (fixLastCP appPred t) cp.
Proof.
intros appPred cp; unfold fixLastCP; reflexivity.
Qed.

Definition app {T:Type} {n:nat} (pred : arity T n) (cp : cartesianPower T n) : Prop.
Proof.
induction n; [apply pred|clear IHn].
induction n; [exact (pred cp)|exact (IHn (pred (headCP cp)) (tailCP cp))].
Defined.

Definition app_n_1 {T:Type} {n:nat} (pred : arity T (S n)) (cp : cartesianPower T n) (x : T) : Prop.
Proof.
induction n; [exact (pred x)|clear IHn].
induction n; [exact (pred cp x)|exact (IHn (pred (headCP cp)) (tailCP cp))].
Defined.

Lemma app_n_1_app {T:Type} {n:nat} :
  forall (pred : arity T (S (S n))) (x : T)
         (cpp : cartesianPower T (S n)) (cpt : cartesianPower T (S (S n))),
    app_n_1 pred cpp x -> allButLastCP cpt = cpp -> lastCP cpt = x ->
    app pred cpt.
Proof.
intros.
induction n.

  simpl in *.
  rewrite H0; rewrite H1.
  apply H.

  apply IHn with (tailCP cpp); clear IHn.

    unfold app_n_1 in *.
    assert (H3 : (fst cpt) = fst (cpp)) by (rewrite <- H0; simpl; reflexivity).
    simpl in *.
    rewrite H3.
    apply H.

    rewrite <- H0.
    induction n.

      simpl; reflexivity.

      apply CP_ind.

        simpl; reflexivity.

        simpl in *; reflexivity.

    rewrite <- H1.
    induction n.

      simpl; reflexivity.

      simpl; reflexivity.
Qed.

Lemma app_app_n_1 {T:Type} {n:nat} :
  forall (pred : arity T (S (S n))) (x : T) (cpp : cartesianPower T (S n)) (cpt : cartesianPower T (S (S n))),
  app pred cpt -> allButLastCP cpt = cpp -> lastCP cpt = x ->
  app_n_1 pred cpp x.
Proof.
intros.
induction n.

  simpl in *.
  rewrite <- H0; rewrite <- H1.
  apply H.

  apply IHn with (tailCP cpt); clear IHn.

    unfold app in *.
    assert (H3 : (fst cpt) = fst (cpp)) by (rewrite <- H0; simpl; reflexivity).
    simpl in *.
    rewrite <- H3.
    apply H.

    rewrite <- H0.
    induction n.

      simpl; reflexivity.

      apply CP_ind.

        simpl; reflexivity.

        simpl in *; reflexivity.

    rewrite <- H1.
    induction n.

      simpl; reflexivity.

      simpl; reflexivity.
Qed.

Lemma app_n_1_app_eq {T:Type} {n:nat} :
  forall (pred : arity T (S (S n))) (x : T) (cpp : cartesianPower T (S n)) (cpt : cartesianPower T (S (S n))),
  allButLastCP cpt = cpp -> lastCP cpt = x ->
  (app pred cpt <-> app_n_1 pred cpp x).
Proof.
intros.
split.

  intro H1.
  apply (app_app_n_1 pred x cpp cpt H1 H H0).

  intro H1.
  apply (app_n_1_app pred x cpp cpt H1 H H0).
Qed.

Definition app_1_n {T:Type} {n:nat} (pred : arity T (S n)) (x : T) (cp : cartesianPower T n) : Prop.
Proof.
induction n; [exact (pred x)|clear IHn].
induction n; [exact (pred x cp)|clear IHn].
assert (newPred : arity T (S n)) by (exact (pred x (headCP cp))).
exact (app newPred (tailCP cp)).
Defined.

Lemma app_1_n_app {T:Type} {n:nat} :
  forall (pred : arity T (S (S n))) (x : T) (cpp : cartesianPower T (S n)) (cpt : cartesianPower T (S (S n))),
  app_1_n pred x cpp -> headCP cpt = x -> tailCP cpt = cpp ->
  app pred cpt.
Proof.
intros.
induction n.

  simpl in *.
  rewrite H0; rewrite H1.
  apply H.

  clear IHn.
  simpl in *.
  rewrite H0; rewrite H1.
  apply H.
Qed.

Lemma app_app_1_n {T:Type} {n:nat} :
  forall (pred : arity T (S (S n))) (x : T) (cpp : cartesianPower T (S n)) (cpt : cartesianPower T (S (S n))),
  app pred cpt -> headCP cpt = x -> tailCP cpt = cpp ->
  app_1_n pred x cpp.
Proof.
intros.
induction n.

  simpl in *.
  rewrite <- H0; rewrite <- H1.
  apply H.

  clear IHn.
  simpl in *.
  rewrite <- H0; rewrite <- H1.
  apply H.
Qed.

Lemma app_1_n_app_eq {T:Type} {n:nat} :
  forall (pred : arity T (S (S n))) (x : T) (cpp : cartesianPower T (S n)) (cpt : cartesianPower T (S (S n))),
  headCP cpt = x -> tailCP cpt = cpp ->
  (app pred cpt <-> app_1_n pred x cpp).
Proof.
intros.
split.

  intro H1.
  apply (app_app_1_n pred x cpp cpt H1 H H0).

  intro H1.
  apply (app_1_n_app pred x cpp cpt H1 H H0).
Qed.

Definition app_2_n {T:Type} {n:nat} (pred : arity T (S (S n))) (x1 x2 : T) (cp : cartesianPower T n) : Prop.
Proof. exact (app (pred x1 x2) cp). Defined.

Lemma app_2_n_app {T:Type} {n:nat} :
  forall (pred : arity T (S (S (S n)))) (x1 x2 : T)
  (cpp : cartesianPower T (S n)) (cpt : cartesianPower T (S (S (S n)))),
  app_2_n pred x1 x2 cpp -> headCP cpt = x1 -> headCP (tailCP cpt) = x2 -> tailCP (tailCP cpt) = cpp ->
  app pred cpt.
Proof.
intros.
induction n.

  simpl in *.
  rewrite H0; rewrite H1; rewrite H2.
  apply H.

  clear IHn.
  simpl in *.
  rewrite H0; rewrite H1; rewrite H2.
  apply H.
Qed.

Lemma app_2_n_app_default {T:Type} {n:nat} :
  forall (pred : arity T (S (S n))) (x1 x2 : T)
  (cpp Default : cartesianPower T n) (cpt : cartesianPower T (S (S n))),
  app_2_n pred x1 x2 cpp -> headCP cpt = x1 ->
  headCP (tailCP cpt) = x2 ->
  tailDefaultCP (tailCP cpt) Default = cpp ->
  app pred cpt.
Proof.
intros.
induction n.

  simpl in *.
  rewrite H0; rewrite H1.
  apply H.

  simpl in *.
  rewrite H0; rewrite H1; rewrite H2.
  apply H.
Qed.

Lemma app_app_2_n {T:Type} {n:nat} :
  forall (pred : arity T (S (S (S n)))) (x1 x2 : T)
  (cpp : cartesianPower T (S n)) (cpt : cartesianPower T (S (S (S n)))),
  app pred cpt -> headCP cpt = x1 -> headCP (tailCP cpt) = x2 -> tailCP (tailCP cpt) = cpp ->
  app_2_n pred x1 x2 cpp.
Proof.
intros.
induction n.

  simpl in *.
  rewrite <- H0; rewrite <- H1; rewrite <- H2.
  apply H.

  clear IHn.
  simpl in *.
  rewrite <- H0; rewrite <- H1; rewrite <- H2.
  apply H.
Qed.

Lemma app_app_2_n_default {T:Type} {n:nat} :
  forall (pred : arity T (S (S n))) (x1 x2 : T)
  (cpp Default : cartesianPower T n) (cpt : cartesianPower T (S (S n))),
  app pred cpt -> headCP cpt = x1 -> headCP (tailCP cpt) = x2 -> tailDefaultCP (tailCP cpt) Default = cpp ->
  app_2_n pred x1 x2 cpp.
Proof.
intros.
induction n.

  simpl in *.
  rewrite <- H0; rewrite <- H1; rewrite <- H2.
  apply H.

  clear IHn.
  simpl in *.
  rewrite <- H0; rewrite <- H1; rewrite <- H2.
  apply H.
Qed.

Lemma app_2_n_app_eq {T:Type} {n:nat} :
  forall (pred : arity T (S (S (S n)))) (x1 x2 : T)
  (cpp : cartesianPower T (S n)) (cpt : cartesianPower T (S (S (S n)))),
  headCP cpt = x1 -> headCP (tailCP cpt) = x2 -> tailCP (tailCP cpt) = cpp ->
  (app pred cpt <-> app_2_n pred x1 x2 cpp).
Proof.
intros.
split.

  intro H2.
  apply (app_app_2_n pred x1 x2 cpp cpt H2 H H0 H1).

  intro H2.
  apply (app_2_n_app pred x1 x2 cpp cpt H2 H H0 H1).
Qed.

Lemma PermOKAux {T : Type} {m : nat} :
  forall (appPred : (cartesianPower T (S (S m))) -> Prop) n,
  (forall (A : T) (X : cartesianPower T (S m)), appPred (consHeadCP A X) -> appPred (consTailCP X A)) ->
  forall (X : cartesianPower T (S (S m))),
          appPred X -> appPred (circPermNCP n X).
Proof.
intros appPred n HPerm.
induction n.
simpl; auto.
intros X HappPred.
assert (H : appPred (circPermNCP n X)) by (apply IHn; assumption); clear IHn; clear HappPred.
rewrite consHeadCPOK in H.
apply HPerm in H.
rewrite circPermNCPOK.
rewrite <- circPermNConsTlOK.
assumption.
Qed.

Lemma PermOK {T : Type} {n : nat} :
  forall (cp1 cp2 : cartesianPower T (S (S n))) (appPred : (cartesianPower T (S (S n))) -> Prop),
  (forall (A : T) (X : cartesianPower T (S n)),
    appPred (consHeadCP A X) -> appPred (consTailCP X A)) ->
  (forall (A B : T) (X : cartesianPower T n),
    appPred (consHeadCP A (consHeadCP B X)) -> appPred (consHeadCP B (consHeadCP A X))) ->
  appPred cp1 ->
  Permutation.Permutation (CPToList cp1) (CPToList cp2) ->
  appPred cp2.
Proof.
induction n; intros cp1 cp2 appPred pred_perm_1 pred_perm_2 Hpred HPerm.

  assert (Hcp1 := CPPair cp1); rewrite Hcp1 in *; clear Hcp1.
  assert (Hcp2 := CPPair cp2); rewrite Hcp2 in *; clear Hcp2.
  simpl in *.
  apply Permutation.Permutation_length_2 in HPerm.
  elim HPerm; clear HPerm; intro HPerm; destruct HPerm as [HEq1 HEq2]; rewrite <- HEq1; rewrite <- HEq2.

    assumption.

    apply pred_perm_1; assumption.

  rewrite consTailCPOK.
  assert (H' := lastCPIn cp2).
  assert (H : InCP (lastCP cp2) cp1)
    by (unfold InCP;apply Permutation.Permutation_in with (CPToList cp2);
        try apply Permutation.Permutation_sym; assumption); clear H'.
  assert (H' := InNth cp1 (lastCP cp2) (headCP cp2) H); clear H.
  destruct H' as [id [Hge [Hle Hnth]]].
  assert (H : exists cp, appPred cp /\ Permutation.Permutation (CPToList cp2) (CPToList cp) /\
                                       lastCP cp = lastCP cp2).

    induction id; try (unfold ge in Hge; assert (H := Le.le_Sn_0 0); contradiction); clear IHid.
    revert Hnth; revert HPerm; revert Hpred; revert cp1; induction id; intros.

      exists (consTailCP (tailCP cp1) (headCP cp1)).
      split.

        apply pred_perm_1.
        rewrite <- consHeadCPOK.
        assumption.

        split.

          apply Permutation.perm_trans with (CPToList cp1); try (apply consTailPerm).
          apply Permutation.Permutation_sym; assumption.

          apply nthCircPerm1 in Hnth.
          rewrite Hnth.
          assert (H := nthLast (consTailCP (tailCP cp1) (headCP cp1)) (headCP cp2)); rewrite H; reflexivity.

      assert (H := Hle).
      do 2 (apply Le.le_S_n in H).
      apply nthCircPerm2 in Hnth; try assumption; clear H.
      apply Le.le_Sn_le in Hle.
      assert (H : S id >= 1) by intuition; clear Hge; rename H into Hge.
      assert (H : appPred (consTailCP (tailCP cp1) (headCP cp1)))
        by (apply pred_perm_1; rewrite <- consHeadCPOK; assumption) ; clear Hpred; rename H into Hpred.
      assert (H := consTailPerm cp1); apply Permutation.Permutation_sym in H.
      assert (H' : Permutation.Permutation (CPToList (consTailCP (tailCP cp1) (headCP cp1))) (CPToList cp2))
        by (apply Permutation.perm_trans with (CPToList cp1); assumption); clear HPerm; rename H' into HPerm.
      assert (H' := IHid Hge Hle (consTailCP (tailCP cp1) (headCP cp1)) Hpred HPerm Hnth).
      destruct H' as [cp [Hpredcp [HPermcp Hlastcp]]]; exists cp.
      do 2 (split; try assumption).

  clear Hnth; clear Hle; clear Hge; clear id; clear HPerm; clear Hpred; clear cp1.
  destruct H as [cp [Hpred [HPerm Hlast]]]; rewrite <- Hlast.
  assert (H := consTailCPOK cp); rewrite H in HPerm; clear H.
  assert (H := consTailCPOK cp2); rewrite H in HPerm; clear H.
  do 2 (rewrite consTailOK in HPerm).
  rewrite Hlast in HPerm.
  apply Permutation.Permutation_app_inv_r in HPerm.
  assert (ablcp := allButLastCP cp).
  assert (ablcp2 := allButLastCP cp2).
  assert (pred_perm_3 := PermOKAux appPred (S n) pred_perm_1).
  assert (HPerm1 : (forall (A : T) (X : cartesianPower T (S n)),
                   (fixLastCP appPred (lastCP cp)) (consHeadCP A X) ->
                   (fixLastCP appPred (lastCP cp)) (consTailCP X A))).

    unfold fixLastCP; intros A X HappPred.
    induction n.

      simpl in HappPred.
      apply pred_perm_2.
      simpl.
      assumption.

      clear IHn0.
      induction n.

        simpl.
        simpl in HappPred.
        simpl in pred_perm_1.
        simpl in pred_perm_2.
        apply pred_perm_2 in HappPred.
        apply pred_perm_1 in HappPred; simpl in HappPred.
        apply pred_perm_2 in HappPred.
        apply pred_perm_1 in HappPred; simpl in HappPred.
        apply pred_perm_3 in HappPred; simpl in HappPred.
        assumption.

        clear IHn0.
        induction n.

          simpl.
          simpl in HappPred.
          simpl in pred_perm_1.
          simpl in pred_perm_2.
          apply pred_perm_2 in HappPred.
          apply pred_perm_1 in HappPred; simpl in HappPred.
          apply pred_perm_2 in HappPred.
          apply pred_perm_1 in HappPred; simpl in HappPred.
          apply pred_perm_2 in HappPred.
          apply pred_perm_1 in HappPred; simpl in HappPred.
          apply pred_perm_1 in HappPred; simpl in HappPred.
          apply pred_perm_1 in HappPred; simpl in HappPred.
          assumption.

          clear IHn0.
          assert (H := consHeadCPOK X); rewrite H in *; clear H.
          assert (H := consTailCPOK (tailCP X)); rewrite H in *; clear H.
          set (B := headCP X) in *.
          set (CP := allButLastCP (allButLastCP (tailCP X))) in *.
          set (C := tailCP (allButLastCP (tailCP X))) in *.
          set (D := lastCP (tailCP X)) in *.
          set (E := lastCP cp) in *.
          apply pred_perm_3 in HappPred; rewrite consTlHdHdTl in HappPred; rewrite circPermNConsOK in HappPred.
          apply pred_perm_1 in HappPred; do 2 (rewrite <- consHdTlTlHd in HappPred).
          apply pred_perm_2 in HappPred.
          apply pred_perm_1; rewrite <- consHdTlTlHd; rewrite <- circPermNConsOK.
          apply pred_perm_3.
          do 2 (apply pred_perm_1; rewrite consHdTlTlHd); rewrite consHdTlTlHd.
          apply pred_perm_1.
          assumption.
  assert (HPerm2 : (forall (A B : T) (X : cartesianPower T n),
                   (fixLastCP appPred (lastCP cp)) (consHeadCP A (consHeadCP B X)) ->
                   (fixLastCP appPred (lastCP cp)) (consHeadCP B (consHeadCP A X))))
    by (unfold fixLastCP; intros A B X HappPred; rewrite <- consTlHdHdTl;
        apply pred_perm_2; rewrite consTlHdHdTl; assumption).
  apply Permutation.Permutation_sym in HPerm.
  assert (H := IHn (allButLastCP cp) (allButLastCP cp2) (fixLastCP appPred (lastCP cp)) HPerm1 HPerm2).
  apply H; try assumption.
  rewrite <- fixLastCPOK.
  rewrite <- consTailCPOK.
  assumption.
Qed.

Lemma lengthNilOK {A : Type} : forall (l : list A),
  length l = 0 -> l = nil.
Proof.
intros l Hlength; induction l.

  reflexivity.

  simpl in Hlength.
  discriminate.
Qed.

Lemma NoDupOK {A : Type} : forall (l l' : list A),
  incl l l' ->
  length l = length l' ->
  NoDup l ->
  Permutation.Permutation l l'.
Proof.
intro l; induction l; intros l' Hincl Hlength HNoDup.

  simpl in Hlength.
  apply eq_sym in Hlength.
  apply lengthNilOK in Hlength.
  subst.
  apply Permutation.perm_nil.

  induction l'.

    simpl in Hlength.
    discriminate.

    clear IHl'.
    rename a0 into a'.
    assert (HIn := in_eq a l).
    assert (H := Hincl).
    unfold incl in H.
    apply H in HIn.
    clear H.
    apply in_split in HIn.
    destruct HIn as [l1 [l2 Hl']].
    rewrite Hl' in *.
    apply Permutation.Permutation_cons_app.
    apply IHl.

      unfold incl.
      intros e HIn.
      unfold incl in Hincl.
      assert (H := Hincl e).
      clear Hincl.
      assert (HIn' := in_cons a e l HIn).
      apply H in HIn'.
      clear H.
      apply in_app_or in HIn'.
      elim HIn'; clear HIn'; intro HIn'.

        apply in_or_app.
        auto.

        apply in_inv in HIn'.
        elim HIn'; clear HIn'; intro HIn'.

          subst.
          assert (H := NoDup_remove_2 nil l e).
          simpl in H.
          apply H in HNoDup.
          contradiction.

          apply in_or_app.
          auto.

      rewrite app_length.
      rewrite app_length in Hlength.
      simpl in Hlength.
      rewrite <- plus_n_Sm in Hlength.
      apply eq_add_S in Hlength.
      assumption.

      assert (H := NoDup_remove_1 nil l a).
      simpl in H.
      apply H.
      assumption.
Qed.

Lemma NoDup_dec {A : Type} : forall (l : list A),
  (forall x y : A, {x = y} + {x <> y}) ->
  NoDup l \/ ~ NoDup l.
Proof.
intros l HDec.
induction l.

  left.
  apply NoDup_nil.

  elim IHl; clear IHl; intro H.

    assert (HIn := in_dec HDec a l).
    elim HIn; clear HIn; intro HIn.

      right.
      clear H.
      intro H.
      assert (H' := NoDup_remove_2 nil l a).
      simpl in H'.
      apply H' in H.
      contradiction.

      left.
      apply NoDup_cons; assumption.

    right.
    intro H'.
    apply H.
    clear H.
    assert (H := NoDup_remove_1 nil l a).
    simpl in H.
    auto.
Qed.

Lemma NotNoDupDup {A : Type} : forall (l : list A),
  (forall x y : A, {x = y} + {x <> y}) ->
  ~ NoDup l->
  exists e l1 l2, l = l1 ++ e :: l2 /\ In e (l1 ++ l2).
Proof.
intros l HDec.
induction l; intro HDup.

  assert (H := NoDup_nil A).
  contradiction.

  assert (HIn := in_dec HDec a l).
  elim HIn; clear HIn; intro HIn.

    exists a; exists nil; exists l.
    simpl.
    auto.

    assert (HDup' := NoDup_dec l HDec).
    elim HDup'; clear HDup'; intro HDup'.

      exfalso.
      apply HDup.
      apply NoDup_cons; assumption.

      apply IHl in HDup'.
      clear HDec; clear HDup; clear HIn.
      destruct HDup' as [e [l1 [l2 [HEq HIn]]]]; clear IHl.
      exists e; exists (a :: l1); exists l2.
      simpl.
      split.

        rewrite HEq; reflexivity.

        right; assumption.
Qed.

Definition pred_conj_aux {T:Type} {n:nat} (pred : arity T (S n)) (m : nat) (cp : cartesianPower T (S m)) (cpwd : cartesianPower T n) : Prop.
Proof.
induction m.
exact (app_1_n pred cp cpwd).
exact ((app_1_n pred (headCP cp) cpwd) /\ IHm (tailCP cp)).
Defined.

Lemma pcaHdTl {T:Type} {n:nat} : forall (pred : arity T (S n)) m cp cpwd,
  pred_conj_aux pred (S m) cp cpwd = (app_1_n pred (headCP cp) cpwd /\ pred_conj_aux pred m (tailCP cp) cpwd).
Proof.
unfold pred_conj_aux; unfold nat_rect; reflexivity.
Qed.

Definition pred_conj {T:Type} {n:nat} (pred : arity T (S n)) (cp : cartesianPower T (S n)) (cpwd : cartesianPower T n) : Prop.
Proof.
exact (pred_conj_aux pred n cp cpwd).
Defined.