Definition direct_plus :=
  nat_rec (fun n:nat => nat -> nat) (fun p:nat => p)
    (fun (n':nat) (plus_n':nat -> nat) (p:nat) => S (plus_n' p)).

Lemma test : direct_plus 8 9 = 17.
Proof. reflexivity. Qed.

Theorem direct_plus_correct : forall n p:nat, n + p = direct_plus n p.
Proof.
 simple induction n; destruct  p; simpl in |- * ; auto.
Qed.


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

(*i $Id: Logic.v 14641 2011-11-06 11:59:10Z herbelin $ i*)

Set Implicit Arguments.

Require Import Notations.

(** * Propositional connectives *)

(** [True] is the always true proposition *)
Inductive True : Prop :=
  I : True.

(** [False] is the always false proposition *)
Inductive False : Prop :=.

(** [not A], written [~A], is the negation of [A] *)
Definition not (A:Prop) := A -> False.

Notation "~ x" := (not x) : type_scope.

Hint Unfold not: core.

  (** [and A B], written [A /\ B], is the conjunction of [A] and [B]

      [conj p q] is a proof of [A /\ B] as soon as
      [p] is a proof of [A] and [q] a proof of [B]

      [proj1] and [proj2] are first and second projections of a conjunction *)

Inductive and (A B:Prop) : Prop :=
  conj : A -> B -> A /\ B

where "A /\ B" := (and A B) : type_scope.

Section Conjunction.

  Variables A B : Prop.

  Theorem proj1 : A /\ B -> A.
  Proof.
    destruct 1; trivial.
  Qed.

  Theorem proj2 : A /\ B -> B.
  Proof.
    destruct 1; trivial.
  Qed.

End Conjunction.

(** [or A B], written [A \/ B], is the disjunction of [A] and [B] *)

Inductive or (A B:Prop) : Prop :=
  | or_introl : A -> A \/ B
  | or_intror : B -> A \/ B

where "A \/ B" := (or A B) : type_scope.

(** [iff A B], written [A <-> B], expresses the equivalence of [A] and [B] *)

Definition iff (A B:Prop) := (A -> B) /\ (B -> A).

Notation "A <-> B" := (iff A B) : type_scope.

Section Equivalence.

Theorem iff_refl : forall A:Prop, A <-> A.
  Proof.
    split; auto.
  Qed.

Theorem iff_trans : forall A B C:Prop, (A <-> B) -> (B <-> C) -> (A <-> C).
  Proof.
    intros A B C [H1 H2] [H3 H4]; split; auto.
  Qed.

Theorem iff_sym : forall A B:Prop, (A <-> B) -> (B <-> A).
  Proof.
    intros A B [H1 H2]; split; auto.
  Qed.

End Equivalence.

Hint Unfold iff: extcore.

(** Some equivalences *)

Theorem neg_false : forall A : Prop, ~ A <-> (A <-> False).
Proof.
intro A; unfold not; split.
intro H; split; [exact H | intro H1; elim H1].
intros [H _]; exact H.
Qed.

Theorem and_cancel_l : forall A B C : Prop,
  (B -> A) -> (C -> A) -> ((A /\ B <-> A /\ C) <-> (B <-> C)).
Proof.
intros; tauto.
Qed.

Theorem and_cancel_r : forall A B C : Prop,
  (B -> A) -> (C -> A) -> ((B /\ A <-> C /\ A) <-> (B <-> C)).
Proof.
intros; tauto.
Qed.

Theorem and_comm : forall A B : Prop, A /\ B <-> B /\ A.
Proof.
intros; tauto.
Qed.

Theorem and_assoc : forall A B C : Prop, (A /\ B) /\ C <-> A /\ B /\ C.
Proof.
intros; tauto.
Qed.

Theorem or_cancel_l : forall A B C : Prop,
  (B -> ~ A) -> (C -> ~ A) -> ((A \/ B <-> A \/ C) <-> (B <-> C)).
Proof.
intros; tauto.
Qed.

Theorem or_cancel_r : forall A B C : Prop,
  (B -> ~ A) -> (C -> ~ A) -> ((B \/ A <-> C \/ A) <-> (B <-> C)).
Proof.
intros; tauto.
Qed.

Theorem or_comm : forall A B : Prop, (A \/ B) <-> (B \/ A).
Proof.
intros; tauto.
Qed.

Theorem or_assoc : forall A B C : Prop, (A \/ B) \/ C <-> A \/ B \/ C.
Proof.
intros; tauto.
Qed.

(** Backward direction of the equivalences above does not need assumptions *)

Theorem and_iff_compat_l : forall A B C : Prop,
  (B <-> C) -> (A /\ B <-> A /\ C).
Proof.
intros; tauto.
Qed.

Theorem and_iff_compat_r : forall A B C : Prop,
  (B <-> C) -> (B /\ A <-> C /\ A).
Proof.
intros; tauto.
Qed.

Theorem or_iff_compat_l : forall A B C : Prop,
  (B <-> C) -> (A \/ B <-> A \/ C).
Proof.
intros; tauto.
Qed.

Theorem or_iff_compat_r : forall A B C : Prop,
  (B <-> C) -> (B \/ A <-> C \/ A).
Proof.
intros; tauto.
Qed.

Lemma iff_and : forall A B : Prop, (A <-> B) -> (A -> B) /\ (B -> A).
Proof.
intros A B []; split; trivial.
Qed.

Lemma iff_to_and : forall A B : Prop, (A <-> B) <-> (A -> B) /\ (B -> A).
Proof.
intros; tauto.
Qed.

(** [(IF_then_else P Q R)], written [IF P then Q else R] denotes
    either [P] and [Q], or [~P] and [Q] *)

Definition IF_then_else (P Q R:Prop) := P /\ Q \/ ~ P /\ R.

Notation "'IF' c1 'then' c2 'else' c3" := (IF_then_else c1 c2 c3)
  (at level 200, right associativity) : type_scope.

(** * First-order quantifiers *)

(** [ex P], or simply [exists x, P x], or also [exists x:A, P x],
    expresses the existence of an [x] of some type [A] in [Set] which
    satisfies the predicate [P].  This is existential quantification.

    [ex2 P Q], or simply [exists2 x, P x & Q x], or also
    [exists2 x:A, P x & Q x], expresses the existence of an [x] of
    type [A] which satisfies both predicates [P] and [Q].

    Universal quantification is primitively written [forall x:A, Q]. By
    symmetry with existential quantification, the construction [all P]
    is provided too.
*)

(** Remark: [exists x, Q] denotes [ex (fun x => Q)] so that [exists x,
   P x] is in fact equivalent to [ex (fun x => P x)] which may be not
   convertible to [ex P] if [P] is not itself an abstraction *)

Inductive ex (A:Type) (P:A -> Prop) : Prop :=
  ex_intro : forall x:A, P x -> ex (A:=A) P.

Inductive ex2 (A:Type) (P Q:A -> Prop) : Prop :=
  ex_intro2 : forall x:A, P x -> Q x -> ex2 (A:=A) P Q.

Definition all (A:Type) (P:A -> Prop) := forall x:A, P x.

(* Rule order is important to give printing priority to fully typed exists *)

Notation "'exists' x , p" := (ex (fun x => p))
  (at level 200, x ident, right associativity) : type_scope.
Notation "'exists' x : t , p" := (ex (fun x:t => p))
  (at level 200, x ident, right associativity,
    format "'[' 'exists'  '/  ' x  :  t ,  '/  ' p ']'")
  : type_scope.

Notation "'exists2' x , p & q" := (ex2 (fun x => p) (fun x => q))
  (at level 200, x ident, p at level 200, right associativity) : type_scope.
Notation "'exists2' x : t , p & q" := (ex2 (fun x:t => p) (fun x:t => q))
  (at level 200, x ident, t at level 200, p at level 200, right associativity,
    format "'[' 'exists2'  '/  ' x  :  t ,  '/  ' '[' p  &  '/' q ']' ']'")
  : type_scope.

(** Derived rules for universal quantification *)

Section universal_quantification.

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

  Theorem inst : forall x:A, all (fun x => P x) -> P x.
  Proof.
    unfold all in |- *; auto.
  Qed.

  Theorem gen : forall (B:Prop) (f:forall y:A, B -> P y), B -> all P.
  Proof.
    red in |- *; auto.
  Qed.

End universal_quantification.

(** * Equality *)

(** [eq x y], or simply [x=y] expresses the equality of [x] and
    [y]. Both [x] and [y] must belong to the same type [A].
    The definition is inductive and states the reflexivity of the equality.
    The others properties (symmetry, transitivity, replacement of
    equals by equals) are proved below. The type of [x] and [y] can be
    made explicit using the notation [x = y :> A]. This is Leibniz equality
    as it expresses that [x] and [y] are equal iff every property on
    [A] which is true of [x] is also true of [y] *)

Inductive eq (A:Type) (x:A) : A -> Prop :=
    eq_refl : x = x :>A

where "x = y :> A" := (@eq A x y) : type_scope.

Notation "x = y" := (x = y :>_) : type_scope.
Notation "x <> y  :> T" := (~ x = y :>T) : type_scope.
Notation "x <> y" := (x <> y :>_) : type_scope.

Implicit Arguments eq [ [A] ].

Implicit Arguments eq_ind [A].
Implicit Arguments eq_rec [A].
Implicit Arguments eq_rect [A].

Hint Resolve I conj or_introl or_intror eq_refl: core.
Hint Resolve ex_intro ex_intro2: core.

Section Logic_lemmas.

  Theorem absurd : forall A C:Prop, A -> ~ A -> C.
  Proof.
    unfold not in |- *; intros A C h1 h2.
    destruct (h2 h1).
  Qed.

  Section equality.
    Variables A B : Type.
    Variable f : A -> B.
    Variables x y z : A.

    Theorem eq_sym : x = y -> y = x.
    Proof.
      destruct 1; trivial.
    Defined.
    Opaque eq_sym.

    Theorem eq_trans : x = y -> y = z -> x = z.
    Proof.
      destruct 2; trivial.
    Defined.
    Opaque eq_trans.

    Theorem f_equal : x = y -> f x = f y.
    Proof.
      destruct 1; trivial.
    Defined.
    Opaque f_equal.

    Theorem not_eq_sym : x <> y -> y <> x.
    Proof.
      red in |- *; intros h1 h2; apply h1; destruct h2; trivial.
    Qed.

  End equality.

  Definition eq_ind_r :
    forall (A:Type) (x:A) (P:A -> Prop), P x -> forall y:A, y = x -> P y.
    intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
  Defined.

  Definition eq_rec_r :
    forall (A:Type) (x:A) (P:A -> Set), P x -> forall y:A, y = x -> P y.
    intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
  Defined.

  Definition eq_rect_r :
    forall (A:Type) (x:A) (P:A -> Type), P x -> forall y:A, y = x -> P y.
    intros A x P H y H0; elim eq_sym with (1 := H0); assumption.
  Defined.
End Logic_lemmas.

Theorem f_equal2 :
  forall (A1 A2 B:Type) (f:A1 -> A2 -> B) (x1 y1:A1)
    (x2 y2:A2), x1 = y1 -> x2 = y2 -> f x1 x2 = f y1 y2.
Proof.
  destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal3 :
  forall (A1 A2 A3 B:Type) (f:A1 -> A2 -> A3 -> B) (x1 y1:A1)
    (x2 y2:A2) (x3 y3:A3),
    x1 = y1 -> x2 = y2 -> x3 = y3 -> f x1 x2 x3 = f y1 y2 y3.
Proof.
  destruct 1; destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal4 :
  forall (A1 A2 A3 A4 B:Type) (f:A1 -> A2 -> A3 -> A4 -> B)
    (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4),
    x1 = y1 -> x2 = y2 -> x3 = y3 -> x4 = y4 -> f x1 x2 x3 x4 = f y1 y2 y3 y4.
Proof.
  destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
Qed.

Theorem f_equal5 :
  forall (A1 A2 A3 A4 A5 B:Type) (f:A1 -> A2 -> A3 -> A4 -> A5 -> B)
    (x1 y1:A1) (x2 y2:A2) (x3 y3:A3) (x4 y4:A4) (x5 y5:A5),
    x1 = y1 ->
    x2 = y2 ->
    x3 = y3 -> x4 = y4 -> x5 = y5 -> f x1 x2 x3 x4 x5 = f y1 y2 y3 y4 y5.
Proof.
  destruct 1; destruct 1; destruct 1; destruct 1; destruct 1; reflexivity.
Qed.

(* Aliases *)

Notation sym_eq := eq_sym (only parsing).
Notation trans_eq := eq_trans (only parsing).
Notation sym_not_eq := not_eq_sym (only parsing).

Notation refl_equal := eq_refl (only parsing).
Notation sym_equal := eq_sym (only parsing).
Notation trans_equal := eq_trans (only parsing).
Notation sym_not_equal := not_eq_sym (only parsing).

Hint Immediate eq_sym not_eq_sym: core.

(** Basic definitions about relations and properties *)

Definition subrelation (A B : Type) (R R' : A->B->Prop) :=
  forall x y, R x y -> R' x y.

Definition unique (A : Type) (P : A->Prop) (x:A) :=
  P x /\ forall (x':A), P x' -> x=x'.

Definition uniqueness (A:Type) (P:A->Prop) := forall x y, P x -> P y -> x = y.

(** Unique existence *)

Notation "'exists' ! x , P" := (ex (unique (fun x => P)))
  (at level 200, x ident, right associativity,
    format "'[' 'exists' !  '/  ' x ,  '/  ' P ']'") : type_scope.
Notation "'exists' ! x : A , P" :=
  (ex (unique (fun x:A => P)))
  (at level 200, x ident, right associativity,
    format "'[' 'exists' !  '/  ' x  :  A ,  '/  ' P ']'") : type_scope.

Lemma unique_existence : forall (A:Type) (P:A->Prop),
  ((exists x, P x) /\ uniqueness P) <-> (exists! x, P x).
Proof.
  intros A P; split.
  intros ((x,Hx),Huni); exists x; red; auto.
  intros (x,(Hx,Huni)); split.
  exists x; assumption.
  intros x' x'' Hx' Hx''; transitivity x.
  symmetry; auto.
  auto.
Qed.

(** * Being inhabited *)

(** The predicate [inhabited] can be used in different contexts. If [A] is
    thought as a type, [inhabited A] states that [A] is inhabited. If [A] is
    thought as a computationally relevant proposition, then
    [inhabited A] weakens [A] so as to hide its computational meaning.
    The so-weakened proof remains computationally relevant but only in
    a propositional context.
*)

Inductive inhabited (A:Type) : Prop := inhabits : A -> inhabited A.

Hint Resolve inhabits: core.

Lemma exists_inhabited : forall (A:Type) (P:A->Prop),
  (exists x, P x) -> inhabited A.
Proof.
  destruct 1; auto.
Qed.

(** Declaration of stepl and stepr for eq and iff *)

Lemma eq_stepl : forall (A : Type) (x y z : A), x = y -> x = z -> z = y.
Proof.
intros A x y z H1 H2. rewrite <- H2; exact H1.
Qed.

Declare Left Step eq_stepl.
Declare Right Step eq_trans.

Lemma iff_stepl : forall A B C : Prop, (A <-> B) -> (A <-> C) -> (C <-> B).
Proof.
intros; tauto.
Qed.

Declare Left Step iff_stepl.
Declare Right Step iff_trans.


Require Import
        Ascii
        List
        String
        Utils.Functions.ListUtils
        Tactics.Tactics.

Import ListNotations.

Fixpoint string_to_list (s : string) : list ascii :=
  match s with
  | EmptyString => []
  | String a' s' => a' :: string_to_list s'
  end.

Lemma string_to_list_inj : forall s s', string_to_list s = string_to_list s' -> s = s'.
Proof.
  induction s ; destruct s' ; crush ; fequals*.
Qed.

Lemma string_to_list_app
  : forall s s', string_to_list (s ++ s') = (string_to_list s) ++ (string_to_list s').
Proof.
  induction s ; destruct s' ; crush.
Qed.

Fixpoint list_to_string (xs : list ascii) : string :=
  match xs with
  | [] => EmptyString
  | x :: xs => String x (list_to_string xs)
  end.

Lemma list_to_string_app
  : forall xs ys, list_to_string (xs ++ ys) =
             ((list_to_string xs) ++ (list_to_string ys))%string.
Proof.
  induction xs ; crush.
Qed.

Lemma list_to_string_inj
  : forall xs ys, list_to_string xs = list_to_string ys -> xs = ys.
Proof.
  induction xs ; destruct ys ; crush ; fequals*.
Qed.

Lemma list_to_string_empty
  : forall xs, list_to_string xs = EmptyString -> xs = [].
Proof.
  induction xs ; crush.
Qed.

Lemma string_to_list_list_to_string
  : forall xs, string_to_list (list_to_string xs) = xs.
Proof.
  induction xs ; crush.
Qed.

Lemma string_to_list_empty
  : forall s, string_to_list s = [] -> s = EmptyString.
Proof.
  induction s ; crush.
Qed.

Lemma list_to_string_string_to_list
  : forall s, list_to_string (string_to_list s) = s.
Proof.
  induction s ; crush.
Qed.

Section PARTS_STRING.

  Definition parts_string (s : string) : list (list string) :=
    map (map list_to_string) (parts (string_to_list s)).

  Open Scope string_scope.

  Definition str_concat (xs : list string) :=
    fold_right append "" xs.

  Lemma list_to_string_concat
    : forall x, list_to_string (concat x) = str_concat (map list_to_string x).
  Proof.
    induction x ; crush.
    rewrite <- IHx.
    rewrite list_to_string_app ; auto.
  Qed.

  Lemma parts_string_correct
    : forall s yss, In yss (parts_string s) -> str_concat yss = s.
  Proof.
    pose ascii_dec as K.
    unfold parts_string.
    intros s yss H.
    eapply in_map_iff in H.
    destruct H as [x [Heq HIn]].
    apply parts_append_correct in HIn ; auto.
    substs. rewrite <- (string_to_list_list_to_string (concat x)) in HIn.
    eapply string_to_list_inj in HIn.
    rewrite list_to_string_concat in HIn.
    auto.
  Qed.

  Lemma map_to_string_empty
    : forall xs, map list_to_string xs = [""] -> xs = [[]].
  Proof.
    induction xs ; intros H ; simpl in * ; try discriminate.
    inverts* H.
    apply map_eq_nil in H2.
    substs. apply list_to_string_empty in H1 ; substs*.
  Qed.

  Lemma parts_string_empty
    : forall s, In [""] (parts_string s) -> s = "".
  Proof.
    pose ascii_dec as K.
    intros ; unfold parts_string in *.
    apply in_map_iff in H.
    destruct H as [x [Heq Hin]].
    apply parts_append_correct in Hin ; auto.
    apply map_to_string_empty in Heq.
    substs. simpl in *. symmetry in Hin.
    apply string_to_list_empty in Hin ; auto.
  Qed.

End PARTS_STRING.

Section SPLIT_STRING.

  Definition splits_string (s : string) :=
    map (fun p => (list_to_string (fst p), list_to_string (snd p)))
        (splits (string_to_list s)).

  Lemma splits_string_correct
    : forall s s1 s2, In (s1,s2) (splits_string s) -> (s1 ++ s2)%string = s.
  Proof.
    unfold splits_string.
    intros s s1 s2 Hin.
    apply in_map_iff in Hin.
    destruct Hin as [[s11 s22] [Heq Hin]].
    simpl in *.
    apply splits_append_correct in Hin.
    injects Heq.
    rewrite <- list_to_string_app.
    rewrite <- list_to_string_string_to_list.
    fequals*.
  Qed.

  Lemma append_splits_string_correct
    : forall s s1 s2, s = (s1 ++ s2)%string -> In (s1,s2) (splits_string s).
  Proof.
    unfold splits_string.
    intros s s1 s2 Heq.
    rewrite <- list_to_string_string_to_list in Heq.
    rewrite <- (list_to_string_string_to_list s) in Heq.
    eapply list_to_string_inj in Heq.
    rewrite string_to_list_app in Heq.
    apply append_splits_correct in Heq.
    apply in_map_iff.
    exists ((string_to_list s1), (string_to_list s2)) ; crush.
    fequals ; apply list_to_string_string_to_list.
  Qed.
End SPLIT_STRING.


(* This file is directly inspired by the corresponding Coq file
   Sorting/Permutation.v *)

From Coq Require Import List Compare_dec CMorphisms FinFun Permutation.
From OLlibs Require Import List_Type.
Import ListNotations. (* For notations [] and [a;b;c] *)

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

Section Permutation.

Variable A:Type.

Inductive Permutation_Type : list A -> list A -> Type :=
| Permutation_Type_nil_nil : Permutation_Type [] []
| Permutation_Type_skip x l l' : Permutation_Type l l' -> Permutation_Type (x::l) (x::l')
| Permutation_Type_swap x y l : Permutation_Type (y::x::l) (x::y::l)
| Permutation_Type_trans l l' l'' :
    Permutation_Type l l' -> Permutation_Type l' l'' -> Permutation_Type l l''.

#[local] Hint Constructors Permutation_Type : core.

(** Some facts about [Permutation] *)

Theorem Permutation_Type_nil : forall (l : list A), Permutation_Type [] l -> l = [].
Proof.
  intros l HF.
  remember (@nil A) as m in HF.
  induction HF; discriminate || auto.
Qed.

Theorem Permutation_Type_nil_cons : forall (l : list A) (x : A),
 Permutation_Type nil (x::l) -> False.
Proof.
  intros l x HF.
  apply Permutation_Type_nil in HF; discriminate.
Qed.

(** Permutation over lists is a equivalence relation *)

Theorem Permutation_Type_refl : forall l : list A, Permutation_Type l l.
Proof.
  induction l; constructor. exact IHl.
Qed.

Theorem Permutation_Type_sym : forall l l' : list A,
 Permutation_Type l l' -> Permutation_Type l' l.
Proof.
  intros l l' Hperm; induction Hperm; auto.
  apply Permutation_Type_trans with (l':=l'); assumption.
Qed.

End Permutation.

#[export] Hint Resolve Permutation_Type_refl Permutation_Type_nil_nil
                       Permutation_Type_skip : core.

(* These hints do not reduce the size of the problem to solve and they
   must be used with care to avoid combinatoric explosions *)

#[local] Hint Resolve Permutation_Type_swap Permutation_Type_trans : core.
#[local] Hint Resolve Permutation_Type_sym : core.

(* This provides reflexivity, symmetry and transitivity and rewriting
   on morphims to come *)

#[export] Instance Permutation_Type_Equivalence A : Equivalence (@Permutation_Type A) | 10 := {
  Equivalence_Reflexive := @Permutation_Type_refl A ;
  Equivalence_Symmetric := @Permutation_Type_sym A ;
  Equivalence_Transitive := @Permutation_Type_trans A }.

#[export] Instance Permutation_Type_cons A :
  Proper (Logic.eq ==> @Permutation_Type A ==> @Permutation_Type A) (@cons A) | 10.
Proof. repeat intro; subst; auto using Permutation_Type_skip. Qed.

Section Permutation_properties.

Variable A:Type.

Implicit Types a b : A.
Implicit Types l m : list A.

(** Compatibility with others operations on lists *)

Theorem Permutation_Type_in : forall (l l' : list A) (x : A),
  Permutation_Type l l' -> In x l -> In x l'.
Proof. intros l l' x Hperm; induction Hperm; simpl; tauto. Qed.

#[export] Instance Permutation_Type_in' :
  Proper (Logic.eq ==> @Permutation_Type A ==> iff) (@In A) | 10.
Proof. repeat red; intros; subst; eauto using Permutation_Type_in. Qed.

Theorem Permutation_Type_in_inf : forall (l l' : list A) (x : A),
 Permutation_Type l l' -> In_inf x l -> In_inf x l'.
Proof.
  intros l l' x Hperm; induction Hperm; simpl; tauto.
Qed.

#[export] Instance Permutation_Type_in_inf' :
  Proper (Logic.eq ==> @Permutation_Type A ==> arrow) (@In_inf A) | 10.
Proof.
  intros l1 l2 Heq l1' l2' HP Hi ; subst.
  eauto using Permutation_Type_in_inf.
Qed.

Lemma Permutation_Type_app_tail : forall (l l' tl : list A),
 Permutation_Type l l' -> Permutation_Type (l++tl) (l'++tl).
Proof.
  intros l l' tl Hperm; induction Hperm as [|x l l'|x y l|l l' l'']; simpl; auto.
  eapply Permutation_Type_trans with (l':=l'++tl); trivial.
Qed.

Lemma Permutation_Type_app_head : forall (l tl tl' : list A),
 Permutation_Type tl tl' -> Permutation_Type (l++tl) (l++tl').
Proof.
  intros l tl tl' Hperm; induction l;
   [trivial | repeat rewrite <- app_comm_cons; constructor; assumption].
Qed.

Theorem Permutation_Type_app : forall (l m l' m' : list A),
 Permutation_Type l l' -> Permutation_Type m m' -> Permutation_Type (l++m) (l'++m').
Proof.
  intros l m l' m' Hpermll' Hpermmm';
   induction Hpermll' as [|x l l'|x y l|l l' l''];
    repeat rewrite <- app_comm_cons; auto.
  apply Permutation_Type_trans with (l' := (x :: y :: l ++ m));
   [idtac | repeat rewrite app_comm_cons; apply Permutation_Type_app_head]; trivial.
  apply Permutation_Type_trans with (l' := (l' ++ m')); try assumption.
  apply Permutation_Type_app_tail; assumption.
Qed.

#[export] Instance Permutation_Type_app' :
 Proper (@Permutation_Type A ==> @Permutation_Type A ==> @Permutation_Type A) (@app A) | 10.
Proof. repeat intro; now apply Permutation_Type_app. Qed.

Lemma Permutation_Type_add_inside : forall a (l l' tl tl' : list A),
  Permutation_Type l l' -> Permutation_Type tl tl' ->
  Permutation_Type (l ++ a :: tl) (l' ++ a :: tl').
Proof. intros; apply Permutation_Type_app; auto. Qed.

Lemma Permutation_Type_cons_append : forall (l : list A) x,
  Permutation_Type (x :: l) (l ++ x :: nil).
Proof. induction l; intros; auto. simpl.
eapply Permutation_Type_trans ; [ apply Permutation_Type_swap | apply Permutation_Type_skip ].
apply IHl. Qed.
#[local] Hint Resolve Permutation_Type_cons_append : core.

Theorem Permutation_Type_app_comm : forall (l l' : list A),
  Permutation_Type (l ++ l') (l' ++ l).
Proof.
  induction l as [|x l]; simpl; intro l'.
  rewrite app_nil_r; trivial.
  eapply Permutation_Type_trans ; [ apply Permutation_Type_skip ; apply IHl | ].
  rewrite app_comm_cons.
  replace (l' ++ x :: l) with ((l' ++ x :: nil) ++ l)
    by (rewrite <- app_assoc ; reflexivity).
  apply Permutation_Type_app_tail. apply Permutation_Type_cons_append.
Qed.
#[local] Hint Resolve Permutation_Type_app_comm : core.

Theorem Permutation_Type_cons_app : forall (l l1 l2:list A) a,
  Permutation_Type l (l1 ++ l2) -> Permutation_Type (a :: l) (l1 ++ a :: l2).
Proof.
  intros l l1 l2 a H.
  eapply Permutation_Type_trans ; [ apply Permutation_Type_skip ; apply H | ].
  rewrite app_comm_cons.
  replace (l1 ++ a :: l2) with ((l1 ++ a :: nil) ++ l2)
    by (rewrite <- app_assoc ; reflexivity).
  apply Permutation_Type_app_tail. apply Permutation_Type_cons_append.
Qed.
#[local] Hint Resolve Permutation_Type_cons_app : core.

Lemma Permutation_Type_Add_inf a l l' : Add_inf a l l' -> Permutation_Type (a::l) l'.
Proof.
 induction 1; simpl; trivial.
 eapply Permutation_Type_trans ; [ apply Permutation_Type_swap | ].
 now apply Permutation_Type_skip.
Qed.

Theorem Permutation_Type_middle : forall (l1 l2:list A) a,
  Permutation_Type (a :: l1 ++ l2) (l1 ++ a :: l2).
Proof.
  auto.
Qed.
#[local] Hint Resolve Permutation_Type_middle : core.

Theorem Permutation_Type_rev : forall (l : list A), Permutation_Type l (rev l).
Proof.
  induction l as [| x l]; simpl; trivial.
  eapply Permutation_Type_trans ; [ apply Permutation_Type_cons_append | ].
  apply Permutation_Type_app_tail. assumption.
Qed.

#[export] Instance Permutation_Type_rev' :
  Proper (@Permutation_Type A ==> @Permutation_Type A) (@rev A) | 10.
Proof.
  intros l1 l2 HP.
  eapply Permutation_Type_trans ; [ | eapply Permutation_Type_trans ].
  - apply Permutation_Type_sym.
    apply Permutation_Type_rev.
  - eassumption.
  - apply Permutation_Type_rev.
Qed.

Theorem Permutation_Type_length : forall (l l' : list A),
 Permutation_Type l l' -> length l = length l'.
Proof.
  intros l l' Hperm; induction Hperm; simpl; auto. now transitivity (length l').
Qed.

#[export] Instance Permutation_Type_length' :
  Proper (@Permutation_Type A ==> Logic.eq) (@length A) | 10.
Proof. exact Permutation_Type_length. Qed.

Theorem Permutation_Type_ind_bis :
 forall P : list A -> list A -> Prop,
   P [] [] ->
   (forall x l l', Permutation_Type l l' -> P l l' -> P (x :: l) (x :: l')) ->
   (forall x y l l', Permutation_Type l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
   (forall l l' l'', Permutation_Type l l' -> P l l' -> Permutation_Type l' l'' -> P l' l'' -> P l l'') ->
   forall l l', Permutation_Type l l' -> P l l'.
Proof.
  intros P Hnil Hskip Hswap Htrans.
  induction 1; auto.
  apply Htrans with (x::y::l); auto.
  apply Hswap; auto.
  induction l; auto.
  apply Hskip; auto.
  apply Hskip; auto.
  induction l; auto.
  eauto.
Qed.

Theorem Permutation_Type_rect_bis :
 forall P : list A -> list A -> Type,
   P [] [] ->
   (forall x l l', Permutation_Type l l' -> P l l' -> P (x :: l) (x :: l')) ->
   (forall x y l l', Permutation_Type l l' -> P l l' -> P (y :: x :: l) (x :: y :: l')) ->
   (forall l l' l'', Permutation_Type l l' -> P l l' -> Permutation_Type l' l'' -> P l' l'' -> P l l'') ->
   forall l l', Permutation_Type l l' -> P l l'.
Proof.
  intros P Hnil Hskip Hswap Htrans.
  induction 1; auto.
  apply Htrans with (x::y::l); auto.
  apply Hswap; auto.
  induction l; auto.
  apply Hskip; auto.
  apply Hskip; auto.
  induction l; auto.
  eauto.
Qed.

Theorem Permutation_Type_nil_app_cons : forall (l l' : list A) (x : A),
 Permutation_Type nil (l++x::l') -> False.
Proof.
  intros l l' x HF.
  apply Permutation_Type_nil in HF. destruct l; discriminate.
Qed.

Ltac InvAdd_Type := repeat (match goal with
 | H: Add_inf ?x _ (_ :: _) |- _ => inversion H; clear H; subst
 end).

Ltac finish_basic_perms_Type H :=
  try constructor; try rewrite Permutation_Type_swap; try constructor; trivial;
  (rewrite <- H; now apply Permutation_Type_Add_inf) ||
  (rewrite H; symmetry; now apply Permutation_Type_Add_inf).

Theorem Permutation_Type_Add_inf_inv a l1 l2 :
  Permutation_Type l1 l2 -> forall l1' l2', Add_inf a l1' l1 -> Add_inf a l2' l2 ->
   Permutation_Type l1' l2'.
Proof.
 revert l1 l2. refine (Permutation_Type_rect_bis _ _ _ _ _).
 - (* nil *)
   inversion_clear 1.
 - (* skip *)
   intros x l1 l2 PE IH. intros. InvAdd_Type; try finish_basic_perms_Type PE.
   constructor. now apply IH.
 - (* swap *)
   intros x y l1 l2 PE IH. intros. InvAdd_Type; try finish_basic_perms_Type PE.
   eapply Permutation_Type_trans ; [ apply Permutation_Type_swap | ].
   do 2 constructor. now apply IH.
 - (* trans *)
   intros l1 l l2 PE IH PE' IH' l1' l2' AD1 AD2.
   assert {l' : list A & Add_inf a l' l } as [l' AD].
   { clear IH PE' IH' AD2 l2 l2'. revert l1' AD1. induction PE ; intros.
     - inversion AD1.
     - inversion AD1 ; subst.
       + apply (existT _ l'). constructor.
       + apply IHPE in X.
         destruct X as [l'0 X].
         apply (existT _ (x :: l'0)).
         constructor. assumption.
     - inversion AD1 ; subst.
       + apply (existT _ (x :: l)). do 2 constructor.
       + inversion X ; subst.
         * apply (existT _ (y :: l)). do 2 constructor.
         * apply (existT _ (x :: y :: l1)). do 2 constructor. assumption.
     - apply IHPE1 in AD1.
       destruct AD1 as [l'0 AD1]. apply IHPE2 in AD1. assumption. }
   eapply Permutation_Type_trans.
   + apply IH.
     * apply AD1.
     * apply AD.
   + now apply IH'.
Qed.

Theorem Permutation_Type_app_inv (l1 l2 l3 l4:list A) a :
  Permutation_Type (l1++a::l2) (l3++a::l4) -> Permutation_Type (l1++l2) (l3 ++ l4).
Proof.
 intros. eapply Permutation_Type_Add_inf_inv; eauto using Add_inf_app.
Qed.

Theorem Permutation_Type_cons_inv l l' a :
 Permutation_Type (a::l) (a::l') -> Permutation_Type l l'.
Proof.
  intro. eapply Permutation_Type_Add_inf_inv; eauto using Add_inf_head.
Qed.

Theorem Permutation_Type_cons_app_inv l l1 l2 a :
 Permutation_Type (a :: l) (l1 ++ a :: l2) -> Permutation_Type l (l1 ++ l2).
Proof.
  intro. eapply Permutation_Type_Add_inf_inv; eauto using Add_inf_head, Add_inf_app.
Qed.

Theorem Permutation_Type_app_inv_l : forall l l1 l2,
 Permutation_Type (l ++ l1) (l ++ l2) -> Permutation_Type l1 l2.
Proof.
  induction l; simpl; auto.
  intros.
  apply IHl.
  apply Permutation_Type_cons_inv with a; auto.
Qed.

Theorem Permutation_Type_app_inv_r l l1 l2 :
 Permutation_Type (l1 ++ l) (l2 ++ l) -> Permutation_Type l1 l2.
Proof.
 intros HP.
 eapply Permutation_Type_trans in HP ; [ | apply Permutation_Type_app_comm ].
 eapply Permutation_Type_app_inv_l.
 eapply Permutation_Type_trans ; [ apply HP | ].
 apply Permutation_Type_app_comm.
Qed.

Lemma Permutation_Type_length_1_inv: forall a l, Permutation_Type [a] l -> l = [a].
Proof.
  intros a l H; remember [a] as m in H.
  induction H; try (injection Heqm as -> ->);
    discriminate || auto.
  apply Permutation_Type_nil in H as ->; trivial.
Qed.

Lemma Permutation_Type_length_1: forall a b, Permutation_Type [a] [b] -> a = b.
Proof.
  intros a b H.
  apply Permutation_Type_length_1_inv in H; injection H as ->; trivial.
Qed.

Lemma Permutation_Type_length_2_inv :
  forall a1 a2 l, Permutation_Type [a1;a2] l -> { l = [a1;a2] } + { l = [a2;a1] }.
Proof.
  intros a1 a2 l H; remember [a1;a2] as m in H.
  revert a1 a2 Heqm.
  induction H; intros; try (injection Heqm as ? ?; subst);
    discriminate || (try tauto).
  apply Permutation_Type_length_1_inv in H as ->; left; auto.
  apply IHPermutation_Type1 in Heqm as [H1|H1]; apply IHPermutation_Type2 in H1 as [];
    auto.
Qed.

Lemma Permutation_Type_length_2 :
  forall a1 a2 b1 b2, Permutation_Type [a1;a2] [b1;b2] ->
    { a1 = b1 /\ a2 = b2 } + { a1 = b2 /\ a2 = b1 }.
Proof.
  intros a1 b1 a2 b2 H.
  apply Permutation_Type_length_2_inv in H as [H|H]; injection H as -> ->; auto.
Qed.

Lemma NoDup_inf_Permutation_Type l l' : NoDup_inf l -> NoDup_inf l' ->
  (forall x:A, iffT (In_inf x l) (In_inf x l')) -> Permutation_Type l l'.
Proof.
 intros N. revert l'. induction N as [|a l Hal Hl IH].
 - destruct l'; simpl; auto.
   intros Hl' H. exfalso. apply (H a); auto.
 - intros l' Hl' H.
   assert (Ha : In_inf a l') by (apply H; simpl; auto).
   destruct (Add_inf_inv _ _ Ha) as (l'' & AD).
   etransitivity; [ | apply (Permutation_Type_Add_inf AD) ].
   apply Permutation_Type_skip.
   apply IH; clear IH.
   * apply NoDup_NoDup_inf.
     apply NoDup_inf_NoDup in Hl'.
     apply Add_inf_Add in AD.
     now apply (NoDup_Add AD).
   * split.
     + apply incl_inf_Add_inf_inv with a l'; trivial. intro. apply H.
     + intro Hx.
       assert (Hx' : In_inf x (a::l)).
       { apply H. apply (Add_inf_in_inf_inv AD). now right. }
       destruct Hx'; simpl; trivial. subst.
       apply in_inf_in in Hx.
       apply Add_inf_Add in AD.
       apply NoDup_inf_NoDup in Hl'.
       rewrite (NoDup_Add AD) in Hl'. tauto.
Qed.

Lemma NoDup_inf_Permutation_Type_bis l l' : NoDup_inf l ->
  length l' <= length l -> incl_inf l l' -> Permutation_Type l l'.
Proof.
 intros. apply NoDup_inf_Permutation_Type; auto.
 - apply NoDup_inf_NoDup in X; apply NoDup_NoDup_inf.
   apply incl_inf_incl in X0.
   now apply NoDup_incl_NoDup with l.
 - split; auto.
   apply NoDup_inf_length_incl_inf; trivial.
Qed.

Lemma Permutation_Type_NoDup_inf l l' : Permutation_Type l l' -> NoDup_inf l -> NoDup_inf l'.
Proof.
 induction 1; auto.
 * inversion_clear 1; constructor; eauto using Permutation_Type_in_inf.
 * inversion_clear 1 as [|? ? H1 H2]. inversion_clear H2; simpl in *.
   constructor. simpl; intuition. constructor; intuition.
Qed.

#[export] Instance Permutation_Type_NoDup_inf' :
 Proper (@Permutation_Type A ==> iffT) (@NoDup_inf A) | 10.
Proof. repeat red; eauto using Permutation_Type_NoDup_inf. Qed.

End Permutation_properties.

Section Permutation_map.

Variable A B : Type.
Variable f : A -> B.

Lemma Permutation_Type_map l l' :
  Permutation_Type l l' -> Permutation_Type (map f l) (map f l').
Proof.
 induction 1; simpl; eauto.
Qed.

#[export] Instance Permutation_Type_map' :
  Proper (@Permutation_Type A ==> @Permutation_Type B) (map f) | 10.
Proof. exact Permutation_Type_map. Qed.

End Permutation_map.

(*
Lemma nat_bijection_Permutation n f :
 bFun n f ->
 Injective f ->
 let l := seq 0 n in Permutation (map f l) l.
Proof.
 intros Hf BD.
 apply NoDup_Permutation_bis; auto using Injective_map_NoDup, seq_NoDup.
 * now rewrite map_length.
 * intros x. rewrite in_map_iff. intros (y & <- & Hy').
   rewrite in_seq in *. simpl in *.
   destruct Hy' as (_,Hy'). auto with arith.
Qed.
*)

Section Permutation_Type_alt.
Variable A:Type.
Implicit Type a : A.
Implicit Type l : list A.

(** Alternative characterization of permutation
    via [nth_error] and [nth] *)

Let adapt f n :=
 let m := f (S n) in if le_lt_dec m (f 0) then m else pred m.

Let adapt_injective f : Injective f -> Injective (adapt f).
Proof.
 unfold adapt. intros Hf x y EQ.
 destruct le_lt_dec as [LE|LT]; destruct le_lt_dec as [LE'|LT'].
 - now apply eq_add_S, Hf.
 - apply PeanoNat.Nat.lt_eq_cases in LE.
   destruct LE as [LT|EQ']; [|now apply Hf in EQ'].
   unfold lt in LT. rewrite EQ in LT.
   rewrite (PeanoNat.Nat.lt_succ_pred _ _ LT') in LT.
   elim (proj1 (PeanoNat.Nat.lt_nge _ _) LT' LT).
 - apply PeanoNat.Nat.lt_eq_cases in LE'.
   destruct LE' as [LT'|EQ']; [|now apply Hf in EQ'].
   unfold lt in LT'. rewrite <- EQ in LT'.
   rewrite (PeanoNat.Nat.lt_succ_pred _ _ LT) in LT'.
   elim (proj1 (PeanoNat.Nat.lt_nge _ _) LT LT').
 - apply eq_add_S, Hf.
   now rewrite <- (PeanoNat.Nat.lt_succ_pred _ _ LT), <- (PeanoNat.Nat.lt_succ_pred _ _ LT'), EQ.
Qed.

Let adapt_ok a l1 l2 f : Injective f -> length l1 = f 0 ->
 forall n, nth_error (l1++a::l2) (f (S n)) = nth_error (l1++l2) (adapt f n).
Proof.
 unfold adapt. intros Hf E n.
 destruct le_lt_dec as [LE|LT].
 - apply PeanoNat.Nat.lt_eq_cases in LE.
   destruct LE as [LT|EQ]; [|now apply Hf in EQ].
   rewrite <- E in LT.
   rewrite 2 nth_error_app1; auto.
 - rewrite <- (PeanoNat.Nat.lt_succ_pred _ _ LT) at 1.
   rewrite <- E, <- (PeanoNat.Nat.lt_succ_pred _ _ LT) in LT.
   rewrite 2 nth_error_app2; auto with arith.
   rewrite PeanoNat.Nat.sub_succ_l; auto with arith.
Qed.

Lemma Permutation_Type_nth_error l l' :
 Permutation_Type l l' ->
  (length l = length l' /\
   exists f, Injective f /\ forall n, nth_error l' n = nth_error l (f n)).
Proof.
  intros P.
  split; [now apply Permutation_Type_length|].
  induction P.
  exists (fun n => n).
  split; try red; auto.
  - destruct IHP as (f & Hf & Hf').
    exists (fun n => match n with O => O | S n => S (f n) end).
    split; try red.
    + intros [|y] [|z]; simpl; now auto.
    + intros [|n]; simpl; auto.
  - exists (fun n => match n with 0 => 1 | 1 => 0 | n => n end).
    split; try red.
    + intros [|[|z]] [|[|t]]; simpl; now auto.
    + intros [|[|n]]; simpl; auto.
  - destruct IHP1 as (f & Hf & Hf').
    destruct IHP2 as (g & Hg & Hg').
    exists (fun n => f (g n)).
    split; try red.
    + auto.
    + intros n. rewrite <- Hf'; auto.
Qed.

Lemma nth_error_Permutation_Type l l' :
  length l = length l' ->
   forall f, Injective f -> (forall n, nth_error l' n = nth_error l (f n)) ->
  Permutation_Type l l'.
Proof.
  revert l. induction l'.
  - intros [|l]; now auto.
  - intros l E f Hf Hf'.
    simpl in E.
    assert (Ha : nth_error l (f 0) = Some a)
     by (symmetry; apply (Hf' 0)).
    destruct (nth_error_split_inf l (f 0) Ha) as [(l1, l2) L12 L1].
    rewrite L12. symmetry; apply Permutation_Type_cons_app; symmetry.
    apply IHl' with (adapt f).
    + revert E. rewrite L12, !app_length. simpl.
      rewrite <- plus_n_Sm. now injection 1.
    + now apply adapt_injective.
    + intro n. rewrite <- (adapt_ok a), <- L12; auto.
      apply (Hf' (S n)).
Qed.

Lemma Permutation_Type_nth_error_bis l l' :
 Permutation l l' ->
  exists f:nat->nat,
    Injective f /\
    bFun (length l) f /\
    (forall n, nth_error l' n = nth_error l (f n)).
Proof.
  intros HP; apply Permutation_nth_error in HP as [E [f [Hf Hf']]].
  exists f. do 2 (split; trivial).
  intros n Hn.
  destruct (PeanoNat.Nat.le_gt_cases (length l) (f n)) as [LE|LT]; trivial.
  rewrite <- nth_error_None, <- Hf', nth_error_None, <- E in LE.
  elim (proj1 (PeanoNat.Nat.lt_nge _ _) Hn LE).
Qed.

Lemma nth_error_Permutation_Type_bis l l' :
  forall f, Injective f -> bFun (length l) f ->
    (forall n, nth_error l' n = nth_error l (f n)) ->
  Permutation_Type l l'.
Proof.
  intros f Hf Hf2 Hf3; apply nth_error_Permutation_Type with f; auto.
  assert (H : length l' <= length l') by auto with arith.
  rewrite <- nth_error_None, Hf3, nth_error_None in H.
  destruct (PeanoNat.Nat.le_gt_cases (length l) (length l')) as [LE|LT];
   [|apply Hf2 in LT; elim (proj1 (PeanoNat.Nat.lt_nge _ _) LT H)].
  apply (proj1 (PeanoNat.Nat.lt_eq_cases _ _)) in LE. destruct LE as [LT|EQ]; trivial.
  rewrite <- nth_error_Some, Hf3, nth_error_Some in LT.
  assert (Hf' : bInjective (length l) f).
  { intros x y _ _ E. now apply Hf. }
  rewrite (bInjective_bSurjective Hf2) in Hf'.
  destruct (Hf' _ LT) as (y & Hy & Hy').
  apply Hf in Hy'. subst y. elim (PeanoNat.Nat.lt_irrefl _ Hy).
Qed.

Lemma Permutation_Type_nth l l' d :
 Permutation l l' ->
  (let n := length l in
   length l' = n /\
   exists f:nat->nat,
    bFun n f /\
    bInjective n f /\
    (forall x, x < n -> nth x l' d = nth (f x) l d)).
Proof.
 intros H.
 assert (E := Permutation_length H).
 split; auto.
 apply Permutation_nth_error_bis in H.
 destruct H as (f & Hf & Hf2 & Hf3).
 exists f. split; [|split]; auto.
 intros x y _ _ Hxy. now apply Hf.
 intros n Hn. rewrite <- 2 nth_default_eq. unfold nth_default.
 now rewrite Hf3.
Qed.

Lemma nth_Permutation_Type l l' d :
  let n := length l in
   length l' = n ->
   forall f, bFun n f -> bInjective n f ->
    (forall x, x < n -> nth x l' d = nth (f x) l d) ->
 Permutation l l'.
Proof.
 intros nl E f Hf1 Hf2 Hf3.
 rewrite Permutation_nth_error.
 split; auto.
 exists (fun n => if le_lt_dec (length l) n then n else f n).
 split.
 - intros x y.
   destruct le_lt_dec as [LE|LT];
    destruct le_lt_dec as [LE'|LT']; auto.
   + apply Hf1 in LT'. intros ->.
     elim (PeanoNat.Nat.lt_irrefl (f y)). eapply PeanoNat.Nat.lt_le_trans; eauto.
   + apply Hf1 in LT. intros <-.
     elim (PeanoNat.Nat.lt_irrefl (f x)). eapply PeanoNat.Nat.lt_le_trans; eauto.
 - intros n.
   destruct le_lt_dec as [LE|LT].
   + assert (LE' : length l' <= n) by (now rewrite E).
     rewrite <- nth_error_None in LE, LE'. congruence.
   + assert (LT' : n < length l') by (now rewrite E).
     specialize (Hf3 n LT). rewrite <- 2 nth_default_eq in Hf3.
     unfold nth_default in Hf3.
     apply Hf1 in LT.
     subst nl.
     rewrite <- nth_error_Some in LT, LT'.
     do 2 destruct nth_error; congruence.
Qed.

End Permutation_Type_alt.

(* begin hide *)
Notation Permutation_Type_app_swap := Permutation_Type_app_comm (only parsing).
(* end hide *)

Lemma Permutation_Type_Permutation A : forall l1 l2 : list A,
  Permutation_Type l1 l2 -> Permutation.Permutation l1 l2.
Proof.
intros l1 l2 HP.
induction HP ; try constructor ; try assumption.
etransitivity ; eassumption.
Qed.


Require Import Coq.Logic.Classical_Prop.
Require Import Coq.Sets.Ensembles.
Require Export Coq.Lists.List.
Require Import Coq.omega.Omega.

Definition LindenbaumChain {A: Type} (step: nat -> Ensemble A -> Ensemble A) (init: Ensemble A): nat -> Ensemble A :=
  fix l (n: nat): Ensemble A :=
    match n with
    | 0 => init
    | S n => step n (l n)
    end.

Definition LindenbaumConstruction {A: Type} (step: nat -> Ensemble A -> Ensemble A) (init: Ensemble A): Ensemble A :=
  fun a => exists n, LindenbaumChain step init n a.

Definition Lindenbaum_spec_included {A: Type}: forall (step: nat -> Ensemble A -> Ensemble A) (init: Ensemble A) n ,
  Included _ (LindenbaumChain step init n) (LindenbaumConstruction step init).
Proof.
  intros.
  intros ? ?.
  exists n; auto.
Qed.

Definition Lindenbaum_spec_pos {A: Type}: forall (step: nat -> Ensemble A -> Ensemble A) (init: Ensemble A) (Pl: list A -> Prop) (Ps: Ensemble A -> Prop),
  (forall S, Ps S <-> exists l, Forall S l /\ Pl l) ->
  (forall n S, Included _ S (step n S)) ->
  ~ Ps init ->
  (forall n S, ~ Ps S -> ~ Ps (step n S)) ->
  ~ Ps (LindenbaumConstruction step init).
Proof.
  intros.

  assert (forall n m, n <= m -> Included _ (LindenbaumChain step init n) (LindenbaumChain step init m)).
  Focus 1. {
    clear - H0.
    intros.
    induction H.
    - intros ? ?; auto.
    - intros ? ?.
      apply H0; auto.
  } Unfocus.
  clear H0; rename H3 into H0.

  rewrite H; intros [l [? ?]].
  unfold LindenbaumConstruction in H3.

  assert (exists n, Forall (LindenbaumChain step init n) l).
  Focus 1. {
    clear - H3 H0.
    induction H3.
    + exists 0; constructor.
    + destruct IHForall as [n1 ?].
      destruct H as [n2 ?].
      exists (max n1 n2).
      constructor.
      - apply (H0 n2); auto.
        apply Max.le_max_r.
      - revert H1; apply Forall_impl; intros.
        apply (H0 n1); auto.
        apply Max.le_max_l.
  } Unfocus.
  clear H3; rename H5 into H3.

  assert (forall n, ~ Ps (LindenbaumChain step init n)).
  Focus 1. {
    induction n.
    + auto.
    + apply H2; auto.
  } Unfocus.

  destruct H3 as [n ?].
  specialize (H5 n).
  rewrite H in H5.
  apply H5; clear H5.
  exists l; auto.
Qed.

Definition Lindenbaum_spec_neg {A: Type}: forall (step: nat -> Ensemble A -> Ensemble A) (init: Ensemble A) a n,
  LindenbaumChain step init n a ->
  LindenbaumConstruction step init a.
Proof.
  intros.
  exists n; auto.
Qed.


(** * Intervals.v : Cpo of intervals of U *)

Add Rec LoadPath "." as ALEA.

Set Implicit Arguments.
Require Export Uprop.
Require Export Arith.
Require Export Omega.

(* Module Univ_prop (Univ:Universe). *)

Open Local Scope U_scope.

(** ** Definition *)
Record IU : Type := mk_IU {low:U; up:U; proper:low <= up}.

Hint Resolve proper.

(** the all set : [[0,1]] *)
Definition full := mk_IU 0 1 (Upos 1).
(** singleton : [[x]] *)
Definition singl (x:U) := mk_IU x x (Ole_refl x).
(** down segment : [[0,x]] *)
Definition inf (x:U) := mk_IU 0 x (Upos x).
(** up segment : [[x,1]] *)
Definition sup (x:U) := mk_IU x 1 (Unit x).

(** ** Relations *)
Definition Iin (x:U) (I:IU) := low I <= x /\ x <= up I.

Definition Iincl I J := low J <= low I /\ up I <= up J.

Definition Ieq I J := low I == low J /\ up I == up J.
Hint Unfold Iin Iincl Ieq.

(** ** Properties *)
Lemma Iin_low : forall I, Iin (low I) I.
auto.
Save.

Lemma Iin_up : forall I, Iin (up I) I.
auto.
Save.

Hint Resolve Iin_low Iin_up.

Lemma Iin_singl_elim : forall x y, Iin x (singl y) -> x == y.
unfold Iin; intuition (simpl; intros; auto).
Save.

Lemma Iin_inf_elim : forall x y, Iin x (inf y) -> x <= y.
unfold Iin; intuition (simpl; auto).
Save.

Lemma Iin_sup_elim : forall x y, Iin x (sup y) -> y <= x.
unfold Iin; intuition (simpl; auto).
Save.

Lemma Iin_singl_intro : forall x y, x == y -> Iin x (singl y).
auto.
Save.

Lemma Iin_inf_intro : forall x y, x <= y -> Iin x (inf y).
auto.
Save.

Lemma Iin_sup_intro : forall x y, y <= x -> Iin x (sup y).
auto.
Save.

Hint Immediate Iin_inf_elim Iin_sup_elim Iin_singl_elim.
Hint Resolve Iin_inf_intro Iin_sup_intro Iin_singl_intro.

Lemma Iin_class : forall I x, class (Iin x I).
unfold class, Iin; split.
apply Ule_class; intuition.
apply Ule_class; intuition.
Save.

Lemma Iincl_class : forall I J, class (Iincl I J).
unfold class, Iincl; split.
apply Ule_class; intuition.
apply Ule_class; intuition.
Save.

Lemma Ieq_class : forall I J, class (Ieq I J).
unfold class, Ieq; split.
apply Ueq_class; intuition.
apply Ueq_class; intuition.
Save.
Hint Resolve Iin_class Iincl_class Ieq_class.

Lemma Iincl_in : forall I J, Iincl I J -> forall x, Iin x I -> Iin x J.
unfold Iin,Iincl; intuition.
transitivity (low I); auto.
transitivity (up I); auto.
Save.

Lemma Iincl_low : forall I J, Iincl I J -> low J <= low I.
unfold Iincl; intuition.
Save.

Lemma Iincl_up : forall I J, Iincl I J -> up I <= up J.
unfold Iincl; intuition.
Save.

Hint Immediate Iincl_low Iincl_up.

Lemma Iincl_refl : forall I, Iincl I I.
unfold Iincl; intuition.
Save.
Hint Resolve Iincl_refl.

Lemma Iincl_trans : forall I J K, Iincl I J -> Iincl J K -> Iincl I K.
unfold Iincl; intuition.
transitivity (low J); auto.
transitivity (up J); auto.
Save.

Instance IUord : ord IU := {Oeq := fun I J => Ieq I J; Ole := fun I J => Iincl J I}.
abstract (split; intros;
[auto|unfold Iincl, Ieq; intuition|red; intros; apply Iincl_trans with y; auto]).
Defined.

Lemma low_le_compat : forall I J:IU, I <= J -> low I <= low J.
simpl; auto.
Save.

Lemma up_le_compat : forall I J : IU, I <= J -> up J <= up I.
simpl; auto.
Save.

Instance low_mon : monotonic low.
red; auto.
Save.

Definition Low : IU -m> U := mon low.

Instance up_mon : monotonic (o2:=Iord U) up.
red; simpl; auto.
Save.

Definition Up :  IU -m-> U := mon (o2:=Iord U) up.

Lemma Ieq_incl : forall I J, Ieq I J -> Iincl I J.
unfold Ieq,Iincl; intuition.
Save.

Lemma Ieq_incl_sym : forall I J, Ieq I J -> Iincl J I.
unfold Ieq,Iincl; intuition.
Save.
Hint Immediate Ieq_incl Ieq_incl_sym.

Lemma lincl_eq_compat : forall I J K L,
     Ieq I J -> Iincl J K -> Ieq K L -> Iincl I L.
intros; apply Iincl_trans with J; auto.
intros; apply Iincl_trans with K; auto.
Save.

Lemma lincl_eq_trans : forall I J K,
     Iincl I J -> Ieq J K -> Iincl I K.
intros; apply lincl_eq_compat with I J; auto.
Save.

Lemma Ieq_incl_trans : forall I J K,
     Ieq I J -> Iincl J K -> Iincl I K.
intros; apply lincl_eq_compat with J K; auto.
Save.

Lemma Iincl_antisym : forall I J, Iincl I J -> Iincl J I -> Ieq I J.
unfold Iincl; intuition.
Save.
Hint Immediate Iincl_antisym.

Lemma Ieq_refl : forall I, Ieq I I.
unfold Ieq; auto.
Save.
Hint Resolve Ieq_refl.

Lemma Ieq_sym : forall I J, Ieq I J -> Ieq J I.
unfold Ieq; intuition.
Save.
Hint Immediate Ieq_sym.

Lemma Ieq_trans : forall I J K, Ieq I J -> Ieq J K -> Ieq I K.
unfold Ieq; intuition.
transitivity (low J); auto.
transitivity (up J); auto.
Save.

Lemma Isingl_eq : forall x y, Iincl (singl x) (singl y) -> x==y.
unfold Iincl, singl; intuition.
Save.
Hint Immediate Isingl_eq.

Lemma Iincl_full : forall I, Iincl I full.
unfold Iincl, full; intuition.
Save.
Hint Resolve Iincl_full.

(** ** Operations on intervals *)

Definition Iplus I J := mk_IU (low I + low J) (up I + up J)
                                           (Uplus_le_compat _ _ _ _ (proper I) (proper J)).

Lemma low_Iplus : forall I J, low (Iplus I J)=low I + low J.
trivial.
Save.

Lemma up_Iplus : forall I J, up (Iplus I J)=up I + up J.
trivial.
Save.

Lemma Iplus_in : forall I J x y, Iin x I -> Iin y J -> Iin (x+y) (Iplus I J).
unfold Iin,Iplus; intuition (simpl; auto).
Save.

Lemma lplus_in_elim :
forall I J z, low I <= [1-]up J -> Iin z (Iplus I J)
                -> exc (fun x => Iin x I /\
                                                   exc (fun y => Iin y J /\ z==x+y)).
intros I J z H (H1,H2); simpl in H1,H2; intros.
assert (low I <= z).
transitivity (low I + low J); auto.
apply (Ule_total (z-low I)  (up J)); intros.
apply class_exc.
(* case [z-low I <= up j] *)
apply exc_intro with (low I); split; auto.
apply exc_intro with (z-low I); split; auto.
assert (low I <= [1-]low J).
transitivity ([1-]up J); auto.
split; auto.
apply Uplus_le_perm_right; auto.
rewrite Uplus_sym; auto.
(* case [up j <= z-low I] *)
assert (up J <= z); auto.
transitivity (z - low I); auto.
apply exc_intro with (z-up J); split; auto.
split; auto.
apply Uplus_le_perm_left; auto.
rewrite Uplus_sym; auto.
apply exc_intro with (up J); auto.
Save.

Definition Imult I J := mk_IU (low I * low J) (up I * up J)
                                            (Umult_le_compat  _  _  _ _ (proper I) (proper J)).

Lemma low_Imult : forall I J, low (Imult I J) = low I * low J.
trivial.
Save.

Lemma up_Imult : forall I J, up (Imult I J) = up I * up J.
trivial.
Save.

Definition Imultk p I := mk_IU (p * low I) (p * up I) (Umult_le_compat_right p _ _ (proper I)).

Lemma low_Imultk : forall p I, low (Imultk p I) = p * low I.
trivial.
Save.

Lemma up_Imultk : forall p I, up (Imultk p I) = p * up I.
trivial.
Save.

Lemma Imult_in : forall I J x y, Iin x I -> Iin y J -> Iin (x*y) (Imult I J).
unfold Iin; intuition (simpl; auto).
Save.

Lemma Imultk_in : forall p I x , Iin x I -> Iin (p*x) (Imultk p I).
unfold Iin; intuition (simpl; auto).
Save.

(** ** Limits of intervals *)

Definition Ilim : forall I: nat -m> IU, IU.
intros; exists (lub (Low@I)) (glb (Up@I)).
abstract (unfold glb; apply lub_inv; simpl; auto).
Defined.

Lemma low_lim : forall (I:nat -m> IU), low (Ilim I) = lub (Low @ I).
trivial.
Save.

Lemma up_lim : forall (I:nat -m> IU),   up (Ilim I) = glb (Up @ I).
trivial.
Save.

Lemma lim_Iincl :  forall (I:nat -m> IU) n, Iincl (Ilim I) (I n).
unfold Ilim,Iincl; simpl; split.
apply (le_lub (Low @ I) n).
apply (glb_le (Up @ I) n).
Save.
Hint Resolve lim_Iincl.

Lemma Iincl_lim :  forall J (I:nat -m>IU), (forall n, Iincl J (I n)) -> Iincl J (Ilim I).
unfold Ilim,Iincl; simpl; split.
apply lub_le with (f:=Low @ I); intro.
case (H n); auto.
apply le_glb with (f:=Up @ I); intro.
case (H n); auto.
Save.

Lemma IIim_incl_stable : forall (I J:nat -m> IU), (forall n, Iincl (I n) (J n)) -> Iincl (Ilim I) (Ilim J).
intros; apply Iincl_lim.
intros; apply Iincl_trans with (I n); auto.
Save.
Hint Resolve IIim_incl_stable.

Instance IUcpo : cpo IU := {D0:=full; lub:=Ilim}.
abstract (intros; simpl; auto).
abstract (intros; simpl; auto).
abstract (intros; simpl; apply Iincl_lim; auto).
Defined.

(*
(** *** Fixpoints *)
Section Ifixpoint.
Variable A : Type.
Variable F : (A -> IU) -> A -> IU.
Hypothesis Fmon : forall I J, (forall x, Iincl (I x) (J x)) -> forall x, Iincl (F I x) (F J x).

Fixpoint Iiter (n:nat) : A -> IU :=
     match n with O => fun x => full | S m => F (Iiter  m) end.

Lemma Iiter_decr : forall x n, Iincl (Iiter (S n) x) (Iiter n x).
intros x n; generalize x; induction n; simpl; auto.
Save.
Hint Resolve Iiter_decr.

Definition Ifix (x:A) := Ilim (fun n => Iiter n x) (Iiter_decr x).

Lemma Iincl_fix : forall (x:A), Iincl (F Ifix x) (Ifix x).
unfold Ifix at 2; intros.
apply Iincl_lim.
destruct n; simpl; auto.
apply Fmon.
unfold Ifix; intros.
apply (lim_Iincl (fun n0 : nat => Iiter n0 x0)).
Save.

Lemma Iincl_inv : forall f, (forall x, Iincl (f x) (F f x)) -> forall x, Iincl (f x) (Ifix x).
unfold Ifix; intros; apply Iincl_lim.
intro n; generalize x; induction n; simpl; intros; auto.
apply Iincl_trans with (F f x0); auto.
Save.

End Ifixpoint.
*)


Require Import Coq.Unicode.Utf8 Arith Ring Setoid.

Fixpoint fact (n : nat) : nat :=
  match n with
  | O => 1
  | S n' => fact n' * S n'
  end.

Inductive fact_state : Set :=
| AnswerIs : nat -> fact_state
| WithAccumulator : nat -> nat -> fact_state.

Inductive fact_init (original_input : nat) : fact_state -> Prop :=
| FactInit : fact_init original_input (WithAccumulator original_input 1).

Inductive fact_final : fact_state -> Prop :=
| FactFinal : forall ans, fact_final (AnswerIs ans).

Inductive fact_step : fact_state -> fact_state -> Prop :=
| FactDone : forall acc,
  fact_step (WithAccumulator O acc) (AnswerIs acc)
| FactStep : forall n acc,
  fact_step (WithAccumulator (S n) acc) (WithAccumulator n (acc * S n)).

Definition fact_invariant (original_input : nat) (st : fact_state) : Prop :=
  match st with
  | AnswerIs ans => fact original_input = ans
  | WithAccumulator n acc => fact original_input = fact n * acc
  end.

Ltac t := simpl; intuition;
          repeat match goal with
                 | [ H : _ = _ |- _ ] => rewrite H
                 end; intuition; ring || eauto.

Theorem fact_invariant_init : forall original_input st,
  fact_init original_input st
  -> fact_invariant original_input st.
Proof.
  destruct 1; t.
Qed.

Theorem fact_invariant_preserve : forall original_input st st',
  fact_step st st'
  -> fact_invariant original_input st
  -> fact_invariant original_input st'.
Proof.
  destruct 1; t.
Qed.

Theorem fact_invariant_final : forall original_input st,
  fact_final st
  -> fact_invariant original_input st
  -> st = AnswerIs (fact original_input).
Proof.
  destruct 1; t.
Qed.

Record transition_system := {
  State : Set;
  Init : State -> Prop;
  Step : State -> State -> Prop;
  Final : State -> Prop
}.

Definition fact_ts (original_input : nat) := {|
  State := fact_state;
  Init := fact_init original_input;
  Step := fact_step;
  Final := fact_final
|}.

Inductive runFrom (ts : transition_system) : State ts -> State ts -> Prop :=
| RunFinal : forall st,
  Final ts st
  -> runFrom ts st st
| RunStep : forall st st' st'',
  Step ts st st'
  -> runFrom ts st' st''
  -> runFrom ts st st''.

Inductive run (ts : transition_system) (st : State ts) : Prop :=
| Run : forall st0,
  Init ts st0
  -> runFrom ts st0 st
  -> run ts st.

Lemma runFrom_final : forall ts st st',
  runFrom ts st st'
  -> Final ts st'.
Proof.
  induction 1; t.
Qed.

Hint Resolve runFrom_final.

Lemma run_final : forall ts st,
  run ts st
  -> Final ts st.
Proof.
  destruct 1; t.
Qed.

Inductive isInvariant (ts : transition_system) (inv : State ts -> Prop) : Prop :=
| IsInvariant : (forall st, Init ts st -> inv st)
  -> (forall st st', Step ts st st' -> inv st -> inv st')
  -> isInvariant ts inv.

Theorem invariant_preserved : forall ts (inv : State ts -> Prop),
  (forall st st', Step ts st st' -> inv st -> inv st')
  -> forall st st', runFrom ts st st'
    -> inv st
    -> inv st'.
Proof.
  induction 2; t.
Qed.

Theorem invariant_final : forall ts inv st,
  isInvariant ts inv
  -> run ts st
  -> inv st.
Proof.
  destruct 1; destruct 1; eapply invariant_preserved; t.
Qed.

Lemma fact_right_answer : forall original_input st,
  Final (fact_ts original_input) st
  -> fact_invariant original_input st
  -> st = AnswerIs (fact original_input).
Proof.
  destruct 1; destruct 1; reflexivity.
Qed.

Hint Constructors isInvariant.
Hint Extern 1 (Init _ _) => constructor.
Hint Resolve run_final fact_right_answer.
Hint Extern 1 (fact_invariant _ _) => eapply invariant_final.
Hint Extern 1 (fact_invariant _ _) => apply fact_invariant_init.
Hint Extern 1 (fact_invariant _ _) => eapply fact_invariant_preserve; eassumption.

Theorem fact_ts_correct : forall original_input st,
  run (fact_ts original_input) st
  -> st = AnswerIs (fact original_input).
Proof.
  eauto 6.
Qed.

(* ---------- Exercise ------------- *)


Welcome to Coq ciosx:/builds/workspace/coq-8.5pl3-macos,(detached from 2290dbb) (2290dbb9c95b63e693ced647731623e64297f5c8)

Coq < Module Playground2.
Interactive Module Playground2 started

Coq < Require Import Arith Classical.
[Loading ML file z_syntax_plugin.cmxs ... done]
[Loading ML file quote_plugin.cmxs ... done]
[Loading ML file newring_plugin.cmxs ... done]
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked
<W> Grammar extension: in [tactic:simple_tactic], some rule has been masked

Coq < Fixpoint plus (n : nat) (m : nat) : nat := match n with | O => m | S n' => S (plus n' m) end.
plus is defined
plus is recursively defined (decreasing on 1st argument)

Coq < Fixpoint mult (n m : nat) : nat := match n with | O => O | S n' => plus m (mult n' m) end.
mult is defined
mult is recursively defined (decreasing on 1st argument)

Coq < Fixpoint minus (n m:nat) : nat := match n, m with | O , _ => O | S _ , O => n | S n', S m' => minus n' m' end.
minus is defined
minus is recursively defined (decreasing on 1st argument)

Coq < End Playground2.
Module Playground2 is defined

Coq < Fixpoint exp (base power : nat) : nat := match power with | O => S O | S p => mult base (exp base p) end.
exp is defined
exp is recursively defined (decreasing on 2nd argument)

Coq < Compute (exp 2 3).
     = 8
     : nat

Coq < Example exp_test1: (exp 3 3) = 27.
1 subgoal

  ============================
  exp 3 3 = 27

exp_test1 < Proof.
1 subgoal

  ============================
  exp 3 3 = 27

exp_test1 < simpl.
1 subgoal

  ============================
  27 = 27

exp_test1 < reflexivity.
No more subgoals.

exp_test1 < Qed.
Proof.
simpl.
reflexivity.

Qed.
exp_test1 is defined