(** * Rel: Properties of Relations *)

(** This short (and optional) chapter develops some basic definitions
    and a few theorems about binary relations in Coq.  The key
    definitions are repeated where they are actually used (in the
    [Smallstep] chapter), so readers who are already comfortable with
    these ideas can safely skim or skip this chapter.  However,
    relations are also a good source of exercises for developing
    facility with Coq's basic reasoning facilities, so it may be
    useful to look at this material just after the [IndProp]
    chapter. *)

Require Export IndProp.
Require Import Coq.omega.Omega.

(** A binary _relation_ on a set [X] is a family of propositions
    parameterized by two elements of [X] -- i.e., a proposition about
    pairs of elements of [X].  *)

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

(** Confusingly, the Coq standard library hijacks the generic term
    "relation" for this specific instance of the idea. To maintain
    consistency with the library, we will do the same.  So, henceforth
    the Coq identifier [relation] will always refer to a binary
    relation between some set and itself, whereas the English word
    "relation" can refer either to the specific Coq concept or the
    more general concept of a relation between any number of possibly
    different sets.  The context of the discussion should always make
    clear which is meant. *)

(** An example relation on [nat] is [le], the less-than-or-equal-to
    relation, which we usually write [n1 <= n2]. *)

Print le.
(* ====> Inductive le (n : nat) : nat -> Prop :=
             le_n : n <= n
           | le_S : forall m : nat, n <= m -> n <= S m *)
Check le : nat -> nat -> Prop.
Check le : relation nat.
(** (Why did we write it this way instead of starting with [Inductive
    le : relation nat...]?  Because we wanted to put the first [nat]
    to the left of the [:], which makes Coq generate a somewhat nicer
    induction principle for reasoning about [<=].) *)

(* ################################################################# *)
(** * Basic Properties *)

(** As anyone knows who has taken an undergraduate discrete math
    course, there is a lot to be said about relations in general,
    including ways of classifying relations (as reflexive, transitive,
    etc.), theorems that can be proved generically about certain sorts
    of relations, constructions that build one relation from another,
    etc.  For example... *)

(* ----------------------------------------------------------------- *)
(** *** Partial Functions *)

(** A relation [R] on a set [X] is a _partial function_ if, for every
    [x], there is at most one [y] such that [R x y] -- i.e., [R x y1]
    and [R x y2] together imply [y1 = y2]. *)

Definition partial_function {X: Type} (R: relation X) :=
  forall x y1 y2 : X, R x y1 -> R x y2 -> y1 = y2.

(** For example, the [next_nat] relation defined earlier is a partial
    function. *)

Print next_nat.
(* ====> Inductive next_nat (n : nat) : nat -> Prop :=
           nn : next_nat n (S n) *)
Check next_nat : relation nat.

Theorem next_nat_partial_function : partial_function next_nat.
Proof.
  unfold partial_function.
  intros x y1 y2 H1 H2.
  inversion H1. inversion H2.
  reflexivity.
Qed.

(** However, the [<=] relation on numbers is not a partial
    function.  (Assume, for a contradiction, that [<=] is a partial
    function.  But then, since [0 <= 0] and [0 <= 1], it follows that
    [0 = 1].  This is nonsense, so our assumption was
    contradictory.) *)

Theorem le_not_a_partial_function : ~ (partial_function le).
Proof.
  unfold not. unfold partial_function. intros Hc.
  assert (0 = 1) as Nonsense. {
    apply Hc with (x := 0).
    - apply le_n.
    - apply le_S. apply le_n. }
  inversion Nonsense.
Qed.

(** **** Exercise: 2 stars, optional  *)
(** Show that the [total_relation] defined in earlier is not a partial
    function. *)
Theorem total_relation_is_not_a_partial_function :
  ~ (partial_function total_relation).
Proof.
  unfold not, partial_function. intros Htr.
  pose proof Htr 1 2 3.
  assert (t1 : total_relation 1 2). apply tr_1. auto.
  assert (t2 : total_relation 1 3). apply tr_1. auto.
  pose proof H t1 t2. inversion H0.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
(** Show that the [empty_relation] that we defined earlier is a
    partial function. *)
Theorem rempty_relation_is_partial_function :
  partial_function empty_relation.
Proof.
  unfold partial_function. intros x y1 y2 H1 H2. inversion H2.
Qed.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Reflexive Relations *)

(** A _reflexive_ relation on a set [X] is one for which every element
    of [X] is related to itself. *)

Definition reflexive {X: Type} (R: relation X) :=
  forall a : X, R a a.

Theorem le_reflexive : reflexive le.
Proof.
  unfold reflexive. intros n. apply le_n.
Qed.

(* ----------------------------------------------------------------- *)
(** *** Transitive Relations *)

(** A relation [R] is _transitive_ if [R a c] holds whenever [R a b]
    and [R b c] do. *)

Definition transitive {X: Type} (R: relation X) :=
  forall a b c : X, (R a b) -> (R b c) -> (R a c).

Theorem le_trans : transitive le.
Proof.
  intros n m o Hnm Hmo.
  induction Hmo.
  - (* le_n *) apply Hnm.
  - (* le_S *) apply le_S. apply IHHmo.
Qed.

Theorem lt_trans: transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  apply le_S in Hnm.
  apply le_trans with (a := (S n)) (b := (S m)) (c := o).
  apply Hnm.
  apply Hmo.
Qed.

(** **** Exercise: 2 stars, optional  *)
(** We can also prove [lt_trans] more laboriously by induction,
    without using [le_trans].  Do this.*)
Lemma n_le_m__n_le_Sm : forall n m, n <= m -> n <= S m.
Proof.
  intros n m Hnm. induction Hnm. auto. auto.
Qed.

Theorem lt_trans' : transitive lt.
Proof.
  (* Prove this by induction on evidence that [m] is less than [o]. *)
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
  - apply n_le_m__n_le_Sm. apply Hnm.
  - apply n_le_m__n_le_Sm. apply IHHm'o.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
(** Prove the same thing again by induction on [o]. *)

Theorem lt_trans'' : transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction o as [| o'].
  - inversion Hmo.
  - apply le_S. inversion Hmo. rewrite <- H0.
    apply Hnm. apply IHo'. apply H0.
Qed.
(** [] *)

(** The transitivity of [le], in turn, can be used to prove some facts
    that will be useful later (e.g., for the proof of antisymmetry
    below)... *)

Theorem le_Sn_le : forall n m, S n <= m -> n <= m.
Proof.
  intros n m H. apply le_trans with (S n).
  - apply le_S. apply le_n.
  - apply H.
Qed.

(** **** Exercise: 1 star, optional  *)
Theorem le_S_n : forall n m,
  (S n <= S m) -> (n <= m).
Proof.
  intros n m. intros H. inversion H. trivial.
  apply le_Sn_le. apply H1.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional (le_Sn_n_inf)  *)
(** Provide an informal proof of the following theorem:

    Theorem: For every [n], [~ (S n <= n)]

    A formal proof of this is an optional exercise below, but try
    writing an informal proof without doing the formal proof first.

    Proof:
    (* FILL IN HERE *)
    []
 *)

(** **** Exercise: 1 star, optional  *)
Theorem le_Sn_n : forall n, ~ (S n <= n).
Proof.
  intros n. unfold not. intros H. induction n.
  - inversion H.
  - apply IHn. apply le_S_n. apply H.
Qed.
(** [] *)

(** Reflexivity and transitivity are the main concepts we'll need for
    later chapters, but, for a bit of additional practice working with
    relations in Coq, let's look at a few other common ones... *)

(* ----------------------------------------------------------------- *)
(** *** Symmetric and Antisymmetric Relations *)

(** A relation [R] is _symmetric_ if [R a b] implies [R b a]. *)

Definition symmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a).

(** **** Exercise: 2 stars, optional  *)
Theorem le_not_symmetric : ~ (symmetric le).
Proof.
  unfold not, symmetric. intros.
  assert (t : 0 <= 1) by omega.
  pose proof H 0 1 t. inversion H0.
Qed.
(** [] *)

(** A relation [R] is _antisymmetric_ if [R a b] and [R b a] together
    imply [a = b] -- that is, if the only "cycles" in [R] are trivial
    ones. *)

Definition antisymmetric {X: Type} (R: relation X) :=
  forall a b : X, (R a b) -> (R b a) -> a = b.

(** **** Exercise: 2 stars, optional  *)
Theorem le_antisymmetric : antisymmetric le.
Proof.
  unfold antisymmetric. intros a b Hab Hba. omega.
Qed.
(** [] *)

(** **** Exercise: 2 stars, optional  *)
Lemma le_step1 : forall n m, n < m -> S n <= m.
Proof.
  intros n m Hnm. inversion Hnm. omega. omega.
Qed.

Lemma le_step2 : forall n m, S n <= S m -> n <= m.
Proof.
  intros n m Hnm. omega.
Qed.

Theorem le_step : forall n m p, n < m -> m <= S p -> n <= p.
Proof.
  intros n m p Hnm Hmp. apply le_step1 in Hnm. apply le_step2.
  omega.
Qed.
(** [] *)

(* ----------------------------------------------------------------- *)
(** *** Equivalence Relations *)

(** A relation is an _equivalence_ if it's reflexive, symmetric, and
    transitive.  *)

Definition equivalence {X:Type} (R: relation X) :=
  (reflexive R) /\ (symmetric R) /\ (transitive R).

(* ----------------------------------------------------------------- *)
(** *** Partial Orders and Preorders *)

(** A relation is a _partial order_ when it's reflexive,
    _anti_-symmetric, and transitive.  In the Coq standard library
    it's called just "order" for short. *)

Definition order {X:Type} (R: relation X) :=
  (reflexive R) /\ (antisymmetric R) /\ (transitive R).

(** A preorder is almost like a partial order, but doesn't have to be
    antisymmetric. *)

Definition preorder {X:Type} (R: relation X) :=
  (reflexive R) /\ (transitive R).

Theorem le_order :
  order le.
Proof.
  unfold order. split.
    - (* refl *) apply le_reflexive.
    - split.
      + (* antisym *) apply le_antisymmetric.
      + (* transitive. *) apply le_trans.  Qed.

(* ################################################################# *)
(** * Reflexive, Transitive Closure *)

(** The _reflexive, transitive closure_ of a relation [R] is the
    smallest relation that contains [R] and that is both reflexive and
    transitive.  Formally, it is defined like this in the Relations
    module of the Coq standard library: *)

Inductive clos_refl_trans {A: Type} (R: relation A) : relation A :=
    | rt_step : forall x y, R x y -> clos_refl_trans R x y
    | rt_refl : forall x, clos_refl_trans R x x
    | rt_trans : forall x y z,
          clos_refl_trans R x y ->
          clos_refl_trans R y z ->
          clos_refl_trans R x z.

(** For example, the reflexive and transitive closure of the
    [next_nat] relation coincides with the [le] relation. *)

Theorem next_nat_closure_is_le : forall n m,
  (n <= m) <-> ((clos_refl_trans next_nat) n m).
Proof.
  intros n m. split.
  - (* -> *)
    intro H. induction H.
    + (* le_n *) apply rt_refl.
    + (* le_S *)
      apply rt_trans with m. apply IHle. apply rt_step.
      apply nn.
  - (* <- *)
    intro H. induction H.
    + (* rt_step *) inversion H. apply le_S. apply le_n.
    + (* rt_refl *) apply le_n.
    + (* rt_trans *)
      apply le_trans with y.
      apply IHclos_refl_trans1.
      apply IHclos_refl_trans2. Qed.

(** The above definition of reflexive, transitive closure is natural:
    it says, explicitly, that the reflexive and transitive closure of
    [R] is the least relation that includes [R] and that is closed
    under rules of reflexivity and transitivity.  But it turns out
    that this definition is not very convenient for doing proofs,
    since the "nondeterminism" of the [rt_trans] rule can sometimes
    lead to tricky inductions.  Here is a more useful definition: *)

Inductive clos_refl_trans_1n {A : Type}
                             (R : relation A) (x : A)
                             : A -> Prop :=
  | rt1n_refl : clos_refl_trans_1n R x x
  | rt1n_trans (y z : A) :
      R x y -> clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.

(** Our new definition of reflexive, transitive closure "bundles"
    the [rt_step] and [rt_trans] rules into the single rule step.
    The left-hand premise of this step is a single use of [R],
    leading to a much simpler induction principle.

    Before we go on, we should check that the two definitions do
    indeed define the same relation...

    First, we prove two lemmas showing that [clos_refl_trans_1n] mimics
    the behavior of the two "missing" [clos_refl_trans]
    constructors.  *)

Lemma rsc_R : forall (X:Type) (R:relation X) (x y : X),
       R x y -> clos_refl_trans_1n R x y.
Proof.
  intros X R x y H.
  apply rt1n_trans with y. apply H. apply rt1n_refl.
Qed.

(** **** Exercise: 2 stars, optional (rsc_trans)  *)
Lemma rsc_trans :
  forall (X:Type) (R: relation X) (x y z : X),
      clos_refl_trans_1n R x y  ->
      clos_refl_trans_1n R y z ->
      clos_refl_trans_1n R x z.
Proof.
  intros. induction H.
  - apply H0.
  - apply rt1n_trans with y. apply H.
    apply IHclos_refl_trans_1n. apply H0.
Qed.
(** [] *)

(** Then we use these facts to prove that the two definitions of
    reflexive, transitive closure do indeed define the same
    relation. *)

(** **** Exercise: 3 stars, optional (rtc_rsc_coincide)  *)
Theorem rtc_rsc_coincide :
         forall (X:Type) (R: relation X) (x y : X),
  clos_refl_trans R x y <-> clos_refl_trans_1n R x y.
Proof.
  intros X R x y. split. intros H.
  - induction H. apply rt1n_trans with y.
    assumption. constructor. constructor.
    apply rsc_trans with y. assumption. assumption.
  - intros H. induction H. apply rt_refl. apply rt_trans with y.
    apply rt_step. assumption. assumption.
Qed.
(** [] *)

(** $Date: 2016-05-26 16:17:19 -0400 (Thu, 26 May 2016) $ *)


(* A category is very much like a graph. It has vertices
   named objects and vertices named arrows. Each arrow goes
   from an object to an object (possibly the same!). *)
Class Cat (obj: Type) (arr: obj -> obj -> Type): Type :=
  MkCat {
    (* For each object, there is an arrow called `id` which
    goes from the object to itself. *)
    id: forall {o: obj}, arr o o;

    (* Given an arrow `f` from object `a` to `b` and an arrow
       `g` from `b` to `c`. We can compose these arrow. The
       result is an arrow from `a` to `c`. *)
    compose: forall {a b c: obj}, arr a b -> arr b c -> arr a c;

    (* Here comes some properties of `id` and `compose` *)

    (* For any arrow `f`, compose id f = f *)
    neutralLeft:   forall {a b: obj} (f: arr a b), compose id f = f;

    (* For any arrow `f`, compose f id = f  *)
    neutralRight:  forall {a b: obj} (f: arr a b), compose f id = f;

    (* For any arrows `f`, `g` and `h`,
        composing f with g, and then the result with h
       gives exatctly the same result as
        composing f with the result of the composition of g and h

       Which means, like string concatenation than we can commpose
       the way we preserve the order of each element in the sequence. *)
    associativity: forall {a b c d: obj} (f: arr a b) (g: arr b c) (h: arr c d),
                     compose (compose f g) h = compose f (compose g h);
  }.

(* `LE n m` encode the property that `n ≤ m`
    i.e. `n` is less or equal to `m` *)
Inductive LE : nat -> nat -> Prop :=
    LERefl: forall {o: nat}, LE o o
  | LENext: forall {a b: nat}, LE a b -> LE a (S b)
.

(* Taking naturals as objects and `LE` as arrows,
   this actually forms a category! *)
Instance natPoset: Cat nat LE := ???
.


(** This first serie of  exercises asks you to prove some derived
    inference rules *)

Lemma P3Q : forall P Q : Prop, (((P->Q)->Q)->Q) -> P -> Q.
Proof.
 intros P.
 intro Q.
 intro H.
 intro p.
 apply H.
 intro H0.
 apply H0.
 assumption.
Qed.

Lemma triple_neg : forall P:Prop, ~~~P -> ~P.
Proof.
 intros P.
 unfold not.
 apply P3Q.
Qed.

Lemma not_or_1 : forall P Q : Prop, ~(P \/ Q) -> ~P.
Proof.
 intros P Q.
 unfold not.
 intro H.
 intro H0.
 apply H.
 left.
 apply H0.
Qed.

Lemma de_morgan_1 : forall P Q: Prop, ~ (P \/ Q) <-> ~P /\ ~Q.
Proof.
 intros P Q.
 split.
 intro H.
 split.
 apply (not_or_1 P Q).
 apply H.
 intro H1.
 apply H.
 right.
 apply H1.
 intro J.
 intro J1.
 destruct J1.
 destruct J.
 destruct H0.
 apply H.
 destruct J.
 destruct H1.
 apply H.
Qed.

Lemma de_morgan_2 : forall P Q: Prop, ~ P \/ ~Q  -> ~(P /\ Q).
Proof.
 intros P Q.
 intro H.
 intro H0.
 destruct H.
 destruct H0.
 apply H.
 apply H0.
 destruct H0.
 apply H.
 apply H1.
Qed.

Lemma all_perm :
 forall (A:Type) (P:A -> A -> Prop),
   (forall x y:A, P x y) ->
   forall x y:A, P y x.
Proof.
 intro H.
 intro H0.
 intro H1.
 intros H2.
 intro H3.
 apply H1.
Qed.

Lemma resolution :
 forall (A:Type) (P Q R S:A -> Prop),
   (forall a:A, Q a -> R a -> S a) ->
   (forall b:A, P b -> Q b) ->
   forall c:A, P c -> R c -> S c.
Proof.
 intros.
 apply H.
 apply H0.
 apply H1.
 apply H2.
Qed.

Lemma not_ex_forall_not : forall (A: Type) (P: A -> Prop),
                      ~(exists x, P x) <-> forall x, ~ P x.
Proof.
 intros.
 split.
 intro H1.
 intro x0.
 unfold not.
 intros.
 destruct H1.
 exists x0.
 assumption.
 unfold not.
 apply P.
 intros.
Admitted.

Lemma ex_not_forall_not : forall (A: Type) (P: A -> Prop),
                       (exists x, P x) -> ~ (forall x, ~ P x).
Proof.
Admitted.

Lemma diff_sym : forall (A:Type) (a b : A), a <> b -> b <> a.
Proof.
Admitted.

Lemma fun_diff :  forall (A B:Type) (f : A -> B) (a b : A),
                       f a <> f b -> a <> b.
Proof.
Admitted.

(**  this exercise deals with five equivalent characterizations of
     classical logic

   Some  solutions may use the following patterns :
    unfold Ident [in H].
    destruct (H t1 ... t2)
    generalize t.
    exact t.

   Please look at Coq's documentation before doing these exercises *)

Definition Double_neg : Prop := forall P:Prop, ~~P -> P.

Definition Exm : Prop := forall P : Prop, P \/ ~P.

Definition Classical_impl : Prop := forall P Q:Prop, (P -> Q) -> ~P \/ Q.

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

Definition Not_forall_not_exists : Prop :=
           forall (A:Type)(P:A->Prop), ~(forall x:A, ~P x) -> ex P.

Lemma  Exm_Double_neg : Exm -> Double_neg.
Proof.
Admitted.

Lemma Double_neg_Exm :  Double_neg -> Exm.
Proof.
 Admitted.

Lemma Peirce_Double_neg : Peirce -> Double_neg.
Proof.
Admitted.

Lemma Exm_Peirce : Exm -> Peirce.
Proof.
Admitted.

Lemma Classical_impl_Exm : Classical_impl -> Exm.
Admitted.

Lemma Exm_Classical_impl : Exm -> Classical_impl.
Proof.
Admitted.

Lemma Not_forall_not_exists_Double_neg :  Not_forall_not_exists -> Double_neg.
Proof.
Admitted.

Lemma Exm_Not_forall_not_exists: Exm -> Not_forall_not_exists.
Admitted.

(** Consider the following definitions (which could be found in the standard
   library *)

Section On_functions.
Variables (U V W : Type).

Variable g : V -> W.
Variable f : U -> V.

 Definition injective : Prop := forall x y:U, f x = f y -> x = y.
 Definition surjective : Prop := forall v : V, exists u:U, f u = v.

Lemma injective' : injective -> forall x y:U, x <> y -> f x <> f y.
Proof.
Admitted.

 Definition compose := fun u : U => g (f u).

End On_functions.
Implicit Arguments compose [U V W].
Implicit Arguments injective [U V].
Implicit Arguments surjective [U V].

Lemma injective_comp : forall U V W (f:U->V)(g : V -> W),
                       injective (compose g f) -> injective f.
Proof.
Admitted.

Lemma surjective_comp : forall U V W (f:U->V)(g : V -> W),
                       surjective (compose g f) -> surjective g.
Proof.
Admitted.

Lemma comp_injective : forall U V W (f:U->V)(g : V -> W),
                       injective f -> injective g -> injective (compose g f).
Proof.
Admitted.

Fixpoint iterate (A:Type)(f:A->A)(n:nat) {struct n} : A -> A :=
 match n with 0 => (fun a => a)
            | S p => fun a => f (iterate _ f p a)
 end.

 Lemma iterate_inj : forall U (f:U->U) ,
                      injective f ->
                      forall n: nat, injective   (iterate _ f n).
Proof.
 induction n;simpl.
Admitted.

(** Last serie of exercises : Consider the following definitions
   See "impredicatve definitions" in the book *)

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

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

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

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

Definition my_exists (A:Type)(P:A->Prop) : Prop :=
  forall R: Prop,
    (forall a: A, P a -> R) -> R.

Lemma my_False_ok : False <-> my_False.
Proof.
Admitted.

Lemma my_or_intro_l : forall P Q:Prop, P -> my_or P Q.
Proof.
Admitted.

Lemma my_or_ok : forall P Q:Prop, P \/ Q <-> my_or P Q.
Proof.
Admitted.

Lemma my_and_ok :  forall P Q:Prop, P /\ Q <-> my_and P Q.
Proof.
Admitted.

Lemma my_ex_ok :  forall (A:Type)(P:A->Prop),
                   (exists x, P x) <-> (my_exists A P).
Proof.
Admitted.


Lemma decid_egal:
 forall (n m : nat), { n = m } + { n <> m }.
double induction n m;intros.
left.
reflexivity.
right.
discriminate.
right.
discriminate.
elim (H0 n0).
intro.
left.
congruence.
intro.
right.
SearchAbout (_ <> _ -> _ <> _).
apply not_eq_S.
assumption.
Defined.
Recursive Extraction decid_egal.

Inductive is_fact : nat -> nat -> Prop :=
| is_fact_O : is_fact 0 1
| is_fact_S : forall n f : nat, is_fact n f -> is_fact (S n) ((S n)*f).

Lemma fact:
 forall (n : nat), { v : nat | is_fact n v }.
  intro.
  elim n.
  exists 1.
  apply is_fact_O.

  intros.
  elim H.
  intros.
  exists ((S n0)* x).
  apply is_fact_S.
  assumption.

Open Scope list_scope.
Inductive is_map (f : nat -> nat) : (list nat) -> (list nat) -> Prop :=
 | is_map_nil : is_map f nil nil
 | is_map_rec : forall (l1 l2 : list nat) (a : nat),
                 is_map f l1 l2 ->
                 is_map f (a::l1) ((f a)::l2).

Lemma map :forall (f : nat -> nat)(l1 : list nat) , { l2 : list nat | is_map f l1 l2 }.
induction l1.
exists nil.
apply is_map_nil.

elim IHl1.
intros.
exists ((f a)::x).
apply is_map_rec.
apply p.
Defined.

(*
Fixpoint add (n : nat) :  nat :=
match n with
| n => (S n)
end.
*)


Require Import PeanoNat Lia.

Require Import ssreflect ssrbool ssrfun.

Set Default Goal Selector "!".

(* induction/recursion principle wrt. a decreasing measure f *)
(* example: elim /(measure_rect length) : l. *)
Lemma measure_rect {X : Type} (f : X -> nat) (P : X -> Type) :
  (forall x, (forall y, f y < f x -> P y) -> P x) -> forall (x : X), P x.
Proof.
  exact: (well_founded_induction_type (Wf_nat.well_founded_lt_compat X f _ (fun _ _ => id)) P).
Qed.

Lemma iter_plus {X: Type} {f: X -> X} {x: X} {n m: nat} :
  Nat.iter (n + m) f x = Nat.iter m f (Nat.iter n f x).
Proof. by rewrite Nat.add_comm /Nat.iter nat_rect_plus. Qed.

Lemma pow_3_mod_2 (n: nat) : 3 ^ n mod 2 = 1.
Proof.
  elim: n; first by (cbv; lia).
  move=> n IH. rewrite Nat.pow_succ_r' Nat.mul_mod ?IH; first by lia.
  by cbv; lia.
Qed.

Lemma pow_5_mod_2 (n: nat) : 5 ^ n mod 2 = 1.
Proof.
  elim: n; first by (cbv; lia).
  move=> n IH. rewrite Nat.pow_succ_r' Nat.mul_mod ?IH; first by lia.
  by cbv; lia.
Qed.

Lemma pow_2_mod_3 (n: nat) : 2 ^ n mod 3 = 1 \/ 2 ^ n mod 3 = 2.
Proof.
  elim: n; first by (cbv; lia).
  move=> n IH. rewrite Nat.pow_succ_r' Nat.mul_mod; first by lia.
  move: IH => [->|->]; cbv; by lia.
Qed.

Lemma pow_5_mod_3 (n: nat) : 5 ^ n mod 3 = 1 \/ 5 ^ n mod 3 = 2.
Proof.
  elim: n; first by (cbv; lia).
  move=> n IH. rewrite Nat.pow_succ_r' Nat.mul_mod; first by lia.
  move: IH => [->|->]; cbv; by lia.
Qed.

Lemma mod_frac_lt {n m: nat} : (S m) mod (n + 1) = 0 -> S m < (S m * (n + 2)) / (n + 1).
Proof.
  have ->: S m * (n + 2) = S m + S m * (n + 1) by lia.
  have := Nat.div_mod_eq (S m) (n + 1).
  rewrite Nat.div_add; lia.
Qed.


Lemma ExampleCHI: forall A B C: Prop, (A -> B -> C) -> (A -> B) -> (A -> C).
(*intros.*)
intros A B C X Y Z.

apply X.

assumption.

apply Y.
assumption.
Qed.

Print ExampleCHI.

(* In natural deduction:

G, A |- A (axiom)

G, A |- B
-------------------- (-> intro)
G |- A -> B

G |- A -> B      G |- A
-------------------------(-> elim)
G |- B

*)

Section Minimal_propositional_logic.
 Variables P Q R S : Prop.

Lemma diamond : (P -> Q) -> (P -> R) -> (Q -> R -> S) -> P -> S.
 Proof.
 intros H0 H1 H2 H3.
 apply H2.
 - apply H0.
   assumption.
 - apply H1; assumption.
 Qed.

Print diamond.

End Minimal_propositional_logic.

Print diamond.

Section Minimal_first_order_logic.
 Variables (A : Set)
   (P Q : A -> Prop)
   (R : A -> A -> Prop).

Theorem all_imp_dist :
  (forall a:A, P a -> Q a) -> (forall a:A, P a) -> forall a:A, Q a.
 Proof.
 intros.
 apply H.
 apply H0.
 Qed.

Print all_imp_dist.

Theorem all_delta : (forall a b:A, R a b) -> forall a:A, R a a.
 Proof.
 intros.
 apply H.
 Qed.

End Minimal_first_order_logic.

Lemma P3Q : forall P Q : Prop, (((P->Q)->Q)->Q) -> P -> Q.
Proof.
 intros P Q H p; apply H.
 intro H0;apply H0;assumption.
Qed.

Print P3Q.


(*** Exercício de Programação Funcional**)

(** Defina um programa que compute o antecessor do antecessor de um dado número n **)

(** 1 star **)

Definition minustwo (n : nat) : nat :=
  match n with
  | 0 => 0
  | 1 => 0
  | S(S(n')) => n'
 end.

(** Teste a função minustwo **)
(** 1 star **)

Example test_minustwo_1 : minustwo 4 = 2.
  Proof.
  simpl.
  reflexivity.
  Qed.

(** 1 star **)
Example test_minustwo_2 : minustwo 1 = 0.
  Proof.
  simpl.
  reflexivity.
  Qed.

(** 1 star **)
Example test_minustwo_3 : minustwo 0 = 0.
  Proof.
  simpl.
  reflexivity.
  Qed.

(** Defina uma função que some 2 **)
(** 1 star **)

Definition plustwo (n : nat) : nat := S(S(n)).

(** Teste a função plustwo **)
(** 1 star **)

Example test_plustwo_1 : plustwo 4 = 6.
  Proof.
  unfold plustwo.
  reflexivity.

(** 1 star **)
Example test_plustwo_2 : plustwo 0 = 2.
  Proof.
  unfold plustwo.
  reflexivity.

Inductive fruta : Type :=
  | morango : fruta
  | uva : fruta
  | laranja : fruta.

Inductive salada : Type :=
  | salada1 : fruta -> salada
  | salada2 : fruta -> fruta -> salada
  | salada3 : fruta -> fruta -> fruta -> salada.

(** Defina o tipo fruta (morango, uva e laranja) **)
(** 1 star **)

(** Defina o tipo salada, onde uma salada é formada pela combinação de até três frutas **)
(** 1 star **)


Require Import not.

Definition LEM          := forall (P:Prop), P \/ ¬P.
Definition Double_Neg   := forall (P:Prop), (¬¬P) -> P.
Definition Peirce       := forall (P Q:Prop), ((P -> Q) -> P) -> P.
Definition DeMorgan     := forall (P Q:Prop), ¬(¬P /\ ¬Q) -> P \/ Q.
Definition Implies      := forall (P Q: Prop), (P -> Q) -> (¬P \/ Q).

Theorem LEM_irrefutable : forall (P:Prop),
    ¬ ¬ (P \/ ¬ P).
Proof.
    intros P H.
    assert ( ¬P ) as H'. { intro Hp. apply H. left. exact Hp. }
    apply H. right. exact H'.
Qed.

Theorem LEM_Double_Neg : LEM <-> Double_Neg.
Proof.
    unfold LEM, Double_Neg. split.
    - intros H P H'. destruct (H P) as [H1|H1].
        + exact H1.
        + exfalso. apply H'. exact H1.
    - intros H P. apply H. apply LEM_irrefutable.
Qed.

Theorem LEM_Peirce : LEM <-> Peirce.
Proof.
    unfold LEM, Peirce. split.
    - intros H P Q H'. destruct (H P) as [H1|H1].
        + exact H1.
        + apply H'. intros H0. exfalso. apply H1. exact H0.
    - intros H P. apply H with (Q := False).
        intros H'. right. intros H0. apply H'. left. exact H0.
Qed.

Theorem LEM_DeMorgan : LEM <-> DeMorgan.
Proof.
    unfold LEM, DeMorgan. split.
    - intros H P Q H'.
        assert ((P \/ Q) \/ ¬(P \/Q)) as H0. { apply H. }
        destruct H0 as [H1|H1].
            + exact H1.
            + exfalso. apply H'. split.
                { intros H0. apply H1. left. exact H0. }
                { intros H0. apply H1. right. exact H0. }
    - intros H P. apply H. intros [H1 H2]. apply H2. exact H1.
Qed.

Theorem LEM_Implies : LEM <-> Implies.
Proof.
    unfold LEM, Implies. split.
    - intros H P Q H'. destruct (H P) as [H1|H1].
        + right. apply H'. exact H1.
        + left. exact H1.
    - intros H P. assert (¬P \/ P) as H0.
        { apply H. intros H'. exact H'. }
        destruct H0 as [H1|H1].
            + right. exact H1.
            + left. exact H1.
Qed.

Theorem restricted_LEM : forall (P:Prop) (b:bool),
    (P <-> b = true) -> P \/ ¬P.
Proof.
    intros P b [H1 H2]. destruct b eqn:H.
    - left. apply H2. reflexivity.
    - right. intros H'. apply H1 in H'. inversion H'.
Qed.

Theorem not_exists_forall : forall (a:Type) (P:a -> Prop),
    ¬ (exists x, P x) -> forall x, ¬ P x.
Proof. intros a P H x Px. apply H. exists x. exact Px. Qed.

(* we need LEM for this one *)
Theorem not_exists_forall_strong : LEM ->
    forall (a:Type) (P:a -> Prop), ¬ (exists x, ¬ P x) -> forall x, P x.
Proof.
    intros H a P H' x. assert (Double_Neg) as H0. { apply LEM_Double_Neg. exact H. }
    apply H0. set (Q := fun x => ¬ P x). apply (not_exists_forall a Q). exact H'.
Qed.


Class ordered (T : Type) :=
  { eq  : T -> T -> bool
  ; lt  : T -> T -> bool
  ; leq : T -> T -> bool

  ; eq_sym
      : forall (t1 t2 : T)
      , eq t1 t2 = eq t2 t1
  ; lt_asym
      : forall (t1 t2 : T) (b : bool)
      , lt t1 t2 = true -> lt t2 t1 = false
  ; eq_implies_leq
      : forall (t1 t2 : T)
      , eq t1 t2 = true -> leq t1 t2 = true
  ; lt_implies_leq
      : forall (t1 t2 : T)
      , lt t1 t2 = true -> leq t1 t2 = true
  ; lt_not_eq
      : forall (t1 t2 : T)
      , lt t1 t2 = true -> eq t1 t2 = false
  }.

Notation "x =? y"   := (eq x y) (at level 70).
Notation "x <? y"   := (lt x y) (at level 70).
Notation "x <=? y"  := (leq x y) (at level 70).

Section OrderedNat.

  Fixpoint nat_eq (n0 n1 : nat) : bool :=
    match (n0, n1) with
      | (O, O)       => true
      | (S m0, S m1) => nat_eq m0 m1
      | _            => false
    end.

  Fixpoint nat_lt (n0 n1 : nat) : bool :=
    match (n0, n1) with
      | (O, O)   => false
      | (O, S _) => true
      | (S _, O) => false
      | (S m0, S m1) => nat_lt m0 m1
    end.

  Definition nat_leq (n0 n1 : nat) : bool :=
    nat_eq n0 n1 || nat_lt n0 n1.

  Theorem nat_eq_sym
    : forall (t1 t2 : nat)
    , nat_eq t1 t2 = nat_eq t2 t1.
  Proof.
  Admitted.

  Theorem nat_lt_asym
    : forall (t1 t2 : nat) (b : bool)
    , (nat_lt t1 t2 = true) -> (nat_lt t2 t1 = false).
  Proof.
  Admitted.

  Theorem nat_eq_implies_leq
    : forall (t1 t2 : nat)
    , nat_eq t1 t2 = true -> nat_leq t1 t2 = true.
  Proof.
  Admitted.

  Theorem nat_lt_implies_leq
    : forall (t1 t2 : nat)
    , nat_lt t1 t2 = true -> nat_leq t1 t2 = true.
  Proof.
  Admitted.

  Theorem nat_lt_not_eq
    : forall (t1 t2 : nat)
    , nat_lt t1 t2 = true -> nat_eq t1 t2 = false.
  Proof.
  Admitted.

  Instance orderedNat : ordered nat :=
    { eq              := nat_eq
    ; lt              := nat_lt
    ; leq             := nat_leq
    ; eq_sym          := nat_eq_sym
    ; lt_asym         := nat_lt_asym
    ; eq_implies_leq  := nat_eq_implies_leq
    ; lt_implies_leq  := nat_lt_implies_leq
    ; lt_not_eq       := nat_lt_not_eq
    }.

End OrderedNat.

Class set (S : Type) (A : Type) : Type :=
  { empty  : S
  ; insert : A -> S -> S
  ; member : A -> S -> bool

  ; empty_member
      : forall (a : A)
      , member a empty = false
  ; insert_non_member
      : forall (s : S) (a : A)
      , member a s = false -> member a (insert a s) = true
  ; insert_member_idenpotent
      : forall (s : S) (a : A)
      , member a (insert a s) = member a (insert a (insert a s))
  }.

Section BinarySearchTree.

  Inductive tree (A : Type) : Type :=
    | Leaf   : tree A
    | Branch : tree A -> A -> tree A -> tree A
    .

  (* How to represent the balanced tree property in for tree? *)

  Fixpoint tree_member {A : Type} `{ordered A} (x : A) (t : tree A) : bool :=
    match t with
      | Leaf _         => false
      | Branch _ l y r =>
          match (x <? y) with
            | true  => tree_member x l
            | false =>
                match (y <? x) with
                  | true  => tree_member x r
                  | false => true
                end
          end
    end.

  Fixpoint tree_insert {A : Type} `{o : ordered A} (x : A) (t : tree A) : tree A :=
    match t with
      | Leaf _         => Branch A (Leaf A) x (Leaf A)
      | Branch _ l y r =>
          match (x <? y) with
            | true  => Branch A (tree_insert x l) y r
            | false =>
                match (y <? x) with
                  | true  => Branch A l y (tree_insert x r)
                  | false => Branch A l y r
                end
          end
    end.

End BinarySearchTree.

Section UnbalancedSet.

Theorem tree_empty_member
  : forall (A : Type) (o : ordered A) (a : A)
  , tree_member a (Leaf A) = false.
Proof.
Admitted.

Theorem tree_insert_member
  : forall (A : Type) (o : ordered A) (s : tree A) (a : A)
  , tree_member a (tree_insert a s) = true.
Proof.
Admitted.

Theorem tree_insert_non_member
  : forall (A : Type) (o : ordered A) (s : tree A) (a : A)
  , tree_member a s = false -> tree_member a (tree_insert a s) = true.
Proof.
Admitted.

Theorem tree_insert_member_idenpotent
  : forall (A : Type) (o : ordered A) (s : tree A) (a : A)
  , tree_member a (tree_insert a s) = tree_member a (tree_insert a (tree_insert a s)).
Proof.
Admitted.

Instance unbalanced_set_tree {A : Type} `{o : ordered A} : set (tree A) A :=
  { empty                     := Leaf A
  ; insert                    := tree_insert
  ; member                    := tree_member
  ; empty_member              := tree_empty_member _ _
  ; insert_non_member         := tree_insert_non_member _ _
  ; insert_member_idenpotent  := tree_insert_member_idenpotent _ _
  }.

End UnbalancedSet.


Inductive day : Type :=
| monday : day
| tuesday : day
| wednesday : day
| thursday : day
| friday : day
| saturday : day
| sunday : day.

Definition next_weekday(d: day) : day :=
  match d with
  | monday => tuesday
  | tuesday => wednesday
  | wednesday => thursday
  | thursday => friday
  | friday => monday
  | saturday => monday
  | sunday => monday
  end.

Example test_next_weekday:
  (next_weekday (next_weekday saturday)) = tuesday.
Proof.
  simpl. reflexivity.
Qed.

Inductive bool : Type :=
| true: bool
| false: bool.

Definition negb (b: bool) : bool :=
  match b with
  | true => false
  | false => true
  end.

Definition andb (b1: bool) (b2: bool) : bool :=
  match b1 with
  | true => b2
  | false => false
  end.

Definition orb (b1: bool) (b2: bool) : bool :=
  match b1 with
  | true => true
  | false => b2
  end.

Example test_orb1: (orb true false) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_orb2: (orb false false) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_orb3: (orb false true) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_orb4: (orb true true) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Infix "&&" := andb.
Infix "||" := orb.

Example test_orb5 : false || false || true = true.
Proof.
  simpl.
  reflexivity.
Qed.

Definition nandb (b1: bool) (b2: bool) : bool :=
  match b1 with
  | true => match b2 with
            | true => false
            |false => true
            end
  | false => true
  end.

Example test_nandb1: (nandb true false) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_nandb2: (nandb false false) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_nandb3: (nandb false true) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_nandb4: (nandb true true) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Definition andb3 (b1: bool) (b2: bool) (b3 :bool) : bool :=
  match b1 with
  | true => andb b2 b3
  | false => false
  end.

Example test_andb31: (andb3 true true true) = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_andb32: (andb3 false true true) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_andb33: (andb3 true false true) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_andb34: (andb3 true true false) = false.
Proof.
  simpl.
  reflexivity.
Qed.

Module Playground1.
  Inductive nat: Type :=
  | O : nat
  | S : nat -> nat.

  Definition pred (n: nat) :nat :=
    match n with
    | O => O
    | S n' => n'
    end.

End Playground1.

Definition minustwo (n: nat) :nat :=
  match n with
  | O => O
  | S O => O
  | S (S n') => n'
  end.

Fixpoint evenb (n: nat) :bool:=
  match n with
  | O => true
  | S O => false
  | S (S n') => evenb n'
  end.

Definition oddb (n: nat): bool :=
  negb (evenb n).

Example test_oddb1: oddb 1 = true.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_oddb2: oddb 4 = false.
Proof.
  simpl.
  reflexivity.
Qed.

Module Playground2.
  Fixpoint plus (n: nat) (m: nat) :nat :=
    match n with
    | O => m
    | S n'=> S (plus n' m)
    end.

  Fixpoint mult (n m: nat) :nat :=
    match n with
    | O => O
    | S n' => plus m (mult n' m)
    end.

  Example test_mult1: (mult 3 3) = 9.
  Proof.
    simpl.
    reflexivity.
  Qed.

  Fixpoint minus (n m:nat) :nat :=
    match n, m with
    | O, _ => O
    | S _, O => n
    | S n', S m' => minus n' m'
    end.

End Playground2.

Fixpoint exp (base power: nat) :nat :=
  match power with
  | O => S O
  | S p => mult base (exp base p)
  end.

Fixpoint factorial (n: nat) :nat :=
  match n with
  | O => S O
  | S n' => mult (factorial n') (S n')
  end.

Example test_factorial1: (factorial 3) = 6.
Proof.
  simpl.
  reflexivity.
Qed.

Example test_factorial2: (factorial 5) = (mult 10 12).
Proof.
  simpl.
  reflexivity.
Qed.

Theorem plus_1_l: forall n: nat, 1 + n = S n.
Proof.
  intros n.
  reflexivity.
Qed.

Theorem mult_0_l: forall n: nat, 0 * n = 0.
Proof.
  intros n.
  reflexivity.
Qed.

Theorem plus_n_O: forall n: nat, n = n + O.
Proof.
  intros.
  induction n.
  - reflexivity.
  - simpl. rewrite <- IHn. reflexivity.
Qed.

Theorem plus_id_example: forall n m:nat, n = m -> n + n = m + m.
Proof.
  intros n m.
  intros H.
  rewrite -> H.
  reflexivity.
Qed.

Theorem plus_id_exercise: forall n m o:nat, n = m -> m = o -> n + m = m + o.
Proof.
  intros n m o.
  intros H1.
  intros H2.
  rewrite -> H1.
  rewrite -> H2.
  reflexivity.
Qed.

Theorem mult_0_plus: forall n m: nat, (0 + n) * m = n * m.
Proof.
  intros n m.
  rewrite -> plus_O_n.
  reflexivity.
Qed.

Theorem mult_S_1: forall n m:nat, m = S n -> m * (1 + n) = m * m.
Proof.
  intros n m.
  intros H.
  rewrite -> plus_1_l.
  rewrite <- H.
  reflexivity.
Qed.

Fixpoint beq_nat (n m:nat) : bool :=
  match n with
  | O => match m with
         | O => true
         | S m' => false
         end
  | S n' => match m with
            | O => false
            | S m' => beq_nat n' m'
            end
  end.

Fixpoint leb (n m: nat) : bool :=
  match n with
  | O => true
  | S n' => match m with
            | O => false
            | S m' => leb n' m'
            end
  end.

Fixpoint blt_nat (n m: nat): bool :=
  match n with
  | O => match m with
         | O => false
         | S n' => true
         end
  | S n' => match m with
            | O => false
            | S m' => blt_nat n' m'
            end
  end.

Theorem plus_1_neq_0_firsttry: forall n: nat, beq_nat (n + 1) 0 = false.
Proof.
  intros [].
  - reflexivity.
  - reflexivity.
Qed.

Theorem plus_1_neq_0: forall n:nat, beq_nat (n + 1) 0 = false.
Proof.
  intros n.
  destruct n as [| n'].
  - simpl.
    reflexivity.
  - simpl.
    reflexivity.
Qed.

Theorem negb_involutive: forall b:bool, negb (negb b) = b.
Proof.
  intros b.
  destruct b.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_commutative: forall b c, andb b c = andb c b.
Proof.
  intros b c.
  destruct b.
  - destruct c.
    + reflexivity.
    + reflexivity.
  - destruct c.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb_commutative': forall b c:bool, andb b c = andb c b.
Proof.
  intros b c.
  destruct b.
  - destruct c.
    + reflexivity.
    + reflexivity.
  - destruct c.
    + reflexivity.
    + reflexivity.
Qed.

Theorem andb3_exchange: forall b c d, andb (andb b c) d = andb (andb b d) c.
Proof.
  intros b c d.
  destruct b.
  - destruct c.
    + destruct d.
      * reflexivity.
      * reflexivity.
    + destruct d.
      * reflexivity.
      * reflexivity.
  - destruct c.
    + destruct d.
      * reflexivity.
      * reflexivity.
    + destruct d.
      * reflexivity.
      * reflexivity.
Qed.

Theorem plus_1_neq_0': forall n: nat, beq_nat (n + 1) 0 = false.
Proof.
  intros [|n].
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_commutative'': forall b c, andb b c = andb c b.
Proof.
  intros [] [].
  - reflexivity.
  - reflexivity.
  - reflexivity.
  - reflexivity.
Qed.

Theorem andb_true_elim2: forall b c: bool, andb b c = true -> c = true.
Proof.
  intros.
  induction b.
  - simpl in H. apply H.
  - inversion H.
Qed.

Theorem zero_nbeq_plus_1: forall n:nat, beq_nat 0 (n + 1) = false.
Proof.
  intros [].
  - reflexivity.
  - reflexivity.
Qed.

Fixpoint plus' (n: nat) (m: nat) : nat :=
  match n with
  | O => m
  | S n' => S (plus' n' m)
  end.

Theorem identity_fn_applied_twice:
  forall (f: bool -> bool), (forall (x: bool), f x = x) -> forall (b: bool), f (f b) = b.
Proof.
  intros f.
  intros H.
  intros [].
  - rewrite -> H.
    rewrite -> H.
    reflexivity.
  - rewrite -> H.
    rewrite -> H.
    reflexivity.
Qed.

Theorem andb_eq_orb:
  forall (b c: bool), (andb b c = orb b c) -> b = c.
Proof.
  intros [] c.
  - simpl.
    intros H.
    rewrite -> H.
    reflexivity.
  - simpl.
    intros H.
    rewrite -> H.
    reflexivity.
Qed.


Require Import Arith.
Require Import Omega.
Require Import List.
Import ListNotations.

Fixpoint list_max (xs : list nat) : nat :=
    match xs with
    | [] => 0
    | x :: xs => max x (list_max xs)
    end.

Lemma list_max_in_list : forall xs,
    xs <> [] ->
    In (list_max xs) xs.
induction xs; intros Hxs.
- exfalso. congruence.
- simpl. destruct (Max.max_dec a (list_max xs)) as [Hmax | Hmax].
  + left. congruence.
  + destruct xs as [| b xs].
    * left. simpl. rewrite Max.max_0_r. reflexivity.
    * right. rewrite Hmax. apply IHxs. discriminate.
Qed.

Lemma list_max_ge : forall xs x,
    In x xs ->
    x <= list_max xs.
induction xs; intros ? Hin.
- inversion Hin.
- destruct Hin as [Hin | Hin].
  + subst a. simpl. apply Max.le_max_l.
  + simpl. apply Nat.le_trans with (m := list_max xs).
    * apply IHxs. exact Hin.
    * apply Max.le_max_r.
Qed.

Print Init.Nat.max.

Fixpoint max''' (n m : nat) : nat :=
    match n with
    | 0 => m
    | S n' =>
            match m with
            | 0 => n
            | S m' => S (max n' m')
            end
    end.

Definition max'' (n m : nat) : nat :=
    nat_rect (fun _ => nat -> nat)
        (fun m => m)
        (fun n' IHn m =>
            nat_rect (fun _ => nat)
                (S n')
                (fun m' IHm => S (IHn m'))
            m)
    n m.

Definition max' (n m : nat) : nat :=
    nat_rect (fun _ => nat -> unit -> nat)
        (fun m dummy => m)
        (fun n' IHn m dummy =>
            nat_rect (fun _ => unit -> nat)
                (fun dummy => S n')
                (fun m' IHm dummy => S (IHn m' dummy))
            m dummy)
    n m tt.

Lemma max'_correct : forall n m, max' n m = max n m.
induction n; destruct m; simpl; try reflexivity.
- rewrite <- IHn. reflexivity.
Qed.

Definition list_max' (xs : list nat) : nat :=
    list_rect (fun _ => nat)
        (0)
        (fun x xs IHxs => max' x IHxs)
    xs.

Lemma list_max'_correct : forall xs, list_max' xs = list_max xs.
induction xs; simpl; try reflexivity.
- rewrite IHxs. apply max'_correct.
Qed.

Require String.
Require Import HList Utopia SourceLifted SourceValues CompilationUnit.
Require Import OeufPlugin.OeufPlugin.

Set Printing All.
Oeuf Reflect list_max' As list_max_cu.
Unset Printing All.

Check list_max_cu : compilation_unit.

Lemma list_max_cu_validate : hhead (genv_denote (exprs list_max_cu)) hnil = list_max'.
reflexivity.
Qed.

Require Pretty.

Oeuf Eval lazy Then Write To File "list_max.oeuf" (Pretty.compilation_unit.print list_max_cu).


(* ================================================================== *)
(* ===================== Reasoning about lists  ===================== *)
(* ================================================================== *)

Set Implicit Arguments.

Require Import List.
Require Import Omega.
Import ListNotations.

Inductive In (A:Type) (y:A) : list A -> Prop :=
| InHead : forall (xs:list A), In y (cons y xs)
| InTail : forall (x:A) (xs:list A), In y xs -> In y (cons x xs).

Inductive Prefix (A:Type) : list A -> list A -> Prop :=
| PreNil : forall (l:list A), Prefix nil l
| PreCons : forall (x:A) (l1 l2:list A), Prefix l1 l2 -> Prefix (x::l1) (x::l2).

Inductive SubList (A:Type) : list A -> list A -> Prop :=
| SLnil : forall (l:list A), SubList nil l
| SLcons1 : forall (x:A) (l1 l2:list A), SubList l1 l2 -> SubList (x::l1) (x::l2)
| SLcons2 : forall (x:A) (l1 l2:list A), SubList l1 l2 -> SubList l1 (x::l2).

Lemma ex1_a : SubList (5::3::nil) (5::7::3::4::nil).
Proof.
  constructor.
  constructor.
  constructor.
  constructor.
Qed.

Lemma ex1_b : forall (A:Type) (l:list A), SubList l l.
Proof.
  intros.
  induction l.
  constructor.
  constructor.
  assumption.
Qed.

Lemma ex1_c : forall (A B:Type) (f:A->B) (l1 l2:list A), SubList l1 l2 -> SubList (map f l1) (map f l2).
Proof.
  intros.
  induction H.
  constructor.
  simpl.
  constructor.
  assumption.
  simpl.
  constructor.
  assumption.
Qed.

Lemma ex1_d : forall (A:Type) (x:A) (l : list A), In x l -> exists l1, exists l2, l = l1 ++ (x::l2).
Proof.
  intros.
  induction H.
  exists nil. exists xs. simpl. reflexivity.
  destruct IHIn as [I1 H1]. destruct H1 as [I2 H1]. exists (x0::I1). exists I2.  rewrite <-app_comm_cons.
  rewrite H1. reflexivity.
Qed.

Fixpoint drop (A:Type) (n:nat) (l : list A)  : list A :=
  match n with               (* Dar match com n, pois a guarda para quando l é nil está definida na função tl do lists.*)
  | 0 => l                   (* Quando n igual a 0, retorna a lista. *)
  | S n' => drop n' (tl l)   (* Quando n maior que 0, remove-se o primeiro elemento com a função tl de lists. *)
  end.

Eval compute in drop 2 (5::7::3::4::nil). (* Provar q funciona *)

Lemma ex2_a : drop 2 (5::7::3::4::nil) = (3::4::nil).
Proof.
  constructor.
Qed.

Lemma ex2_b : forall (A:Type) (n:nat) (l:list A), SubList (drop n l) l.
Proof.
  intros H n.
  induction n.
  - unfold drop. apply ex1_b.
  - induction l.
    + simpl. apply IHn.
    + simpl. constructor. apply IHn.
Qed.

Inductive Sorted : list nat -> Prop :=
| sort0 : Sorted nil
| sort1 : forall a:nat, Sorted (a::nil)
| sort2 : forall z1 z2:nat, forall l:list nat, z1 <= z2 -> Sorted (z2 :: l) -> Sorted (z1 :: z2 :: l).

Lemma ex3_a : forall (x y:nat) (l:list nat), x<=y -> (Sorted (y::l)) -> Sorted (x::l).
Proof.
  intros.
  induction l.
  - constructor.
  - constructor.
    + rewrite H. inversion H0. exact H3.
    + inversion H0. exact H5.
Qed.

(*---------- LEMAS AUXILIARES PARA RESOLVER O EX3_B ----------*)
Lemma sorted_min : forall (x y:nat) (l:list nat), Sorted(x::y::l) -> x <= y.
Proof.
  intros.
  inversion H.
  exact H2.
Qed.

Lemma aux: forall (y a :nat) (l:list nat),In y (a::l)  ->  y = a \/ In y l.
Proof.
intros.
inversion H.
- left. trivial.
- right. assumption.
Qed.

Lemma auxObvious: forall (x y :nat) (l:list nat), x<=y -> Sorted(x::y::l) -> Sorted(x::l).
Proof.
  intros.
  inversion H0.
  generalize H5.
  generalize H3.
  apply ex3_a.
Qed.
(*---------- ----- ---------- ---- -------- - ----- ----------*)

Lemma ex3_b : forall (x y:nat) (l:list nat), (In y l) /\ (Sorted (x::l)) -> x <= y.
Proof.
  intros.
  inversion H.
  induction l.
  - inversion H0.
  - apply sorted_min in H1. apply aux in H0. destruct H0.
    + rewrite H0. exact H1.
    + apply IHl.
      * split.
        { - exact H0. }
        { - destruct H. generalize H2. generalize H1. apply auxObvious. }
      * exact H0.
      * destruct H. generalize H2. generalize H1. apply auxObvious.
Qed.

Lemma ex4_a : forall (A:Type) (l:list A), Prefix l l.
Proof.
  intros.
  induction l.
  constructor.
  constructor.
  assumption.
Qed.

(*---------- LEMAS AUXILIARES PARA RESOLVER O EX4_B ----------*)
Lemma pref_conc_def : forall (A:Type) (l1 l2:list A), Prefix l1 l2 -> exists l3, l2 = l1 ++ l3.
Proof.
  intros.
  induction H.
    - exists l. simpl. trivial.
    - destruct IHPrefix. exists x0. rewrite H0. apply app_comm_cons.
Qed.

Lemma pref_conc_prefix : forall (A:Type) (l1 l2:list A), Prefix l1 (l1++l2).
Proof.
  intros.
  induction l1.
  - simpl. constructor.
  - simpl. constructor. exact IHl1.
Qed.
(*---------- ----- ---------- ---- -------- - ----- ----------*)

Lemma ex4_b : forall (A:Type) (l1 l2 l3:list A), Prefix l1 l2 /\ Prefix l2 l3 -> Prefix l1 l3.
Proof.
  intros.
  destruct H as [H1 H2].
  apply pref_conc_def in H1.
  destruct H1.
  apply pref_conc_def in H2.
  destruct H2.
  rewrite  H0.
  rewrite  H.
  assert(((l1++x)++x0)=(l1++(x++x0))).
    - apply app_assoc_reverse.
    - rewrite H1. apply pref_conc_prefix.
Qed.

Lemma auxEqual : forall (A:Type) (x:A) (l1 l2:list A), l1 = l2 -> x::l1 = x::l2.
Proof.
  intros.
  induction H.
  trivial.
Qed.

Lemma ex4_c : forall (A:Type) (l1 l2:list A), Prefix l1 l2 /\ Prefix l2 l1 -> l1 = l2.
Proof.
  intros.
  destruct H.
  induction H.
  - inversion H0. trivial.
  - apply auxEqual. apply IHPrefix. inversion H0. exact H2.
Qed.


Require Import Eqdep_dec Peano_dec Substitution JMeq.
Require Import Image Arith.
Require Export InductiveFiniteSets Arith.

(**  * Definitions and proofs about co products of Finite types, etc  *)

Set Implicit Arguments.

Section FinSum_defs.

Implicit Arguments fz [n ].

 Fixpoint fin_inl (n m : nat ) (i : Fin n) {struct i} : Fin (n + m) :=
          match i  in Fin n return Fin (n + m) with
          | fz _  => fz
          | fs x k => fs (fin_inl  m  k)
          end.

 Fixpoint  fin_inr (n m : nat) (i:Fin m) {struct n}: Fin (n + m) :=
     match n return Fin (n + m) with
        | O => i
        | S n' => fs (fin_inr n' i)
       end.

  (** View for CoProducts of finite types  *)
  Inductive FinSum (n m : nat)  : Fin (n + m) -> Type :=
         | is_inl : forall i: Fin n ,  FinSum n m (fin_inl m  i)
         | is_inr : forall j: Fin m, FinSum  n m  (fin_inr  n j).

  Fixpoint finsplit (n m : nat) {struct n}
                : forall  (i : Fin (n + m)), FinSum n m i :=
     match n as e return (forall  (i : Fin (e + m)), FinSum e m i) with
     | O => fun i => is_inr _ i
     | S n' => fun i =>  let f := finSN i in
                   match f in (FinSN f0) return (FinSum (S n') m f0) with
                   | isfz => is_inl m  (fz (n := n'))
                   | isfs j =>  let f0 := (finsplit n' m j) in
          match f0 in (FinSum _ _ f1) return (FinSum (S n') m (fs f1)) with
                     | is_inl x => is_inl m (fs x)
                     | is_inr y => is_inr (S n') y
                     end
                  end
     end.

(** * Results and Proofs *)
 Lemma finsplit_inl : forall (n m: nat) (i : Fin n),
             finsplit n m (fin_inl m i) = is_inl m   i.
 Proof.
   intros n m; induction i; simpl; trivial.
   rewrite IHi; reflexivity.
 Qed.

 Lemma finsplit_inr : forall (n m: nat) (i : Fin m),
        finsplit n m (fin_inr  n i) = is_inr  n  i.
 Proof.
   induction n; simpl; trivial.
   intros m i; rewrite (IHn m i); reflexivity.
 Qed.

 Lemma fin_inl_inject : forall (n m : nat) (i j : Fin n),
       fin_inl  m i = fin_inl  m j -> i = j.
 Proof.
   induction i; destruct j using FinSn_rect; auto.
   intro H ; discriminate H.
   intro H; rewrite (IHi j (fsInject  H)) ; trivial.
   intro H; discriminate H.
 Qed.

Lemma fin_inr_inject : forall (n m : nat) (i j : Fin m),
   fin_inr n  i = fin_inr n  j -> i = j.
Proof.
   induction n; simpl; auto.
   apply (fun m i j H =>  (IHn m i j (fsInject H))).
Qed.

 Definition fincase (n m : nat)(X : Type )  (l : Fin n -> X) ( r : Fin m -> X)
     (i : Fin ( n + m)):=
   let f := finsplit n m i in
   match f with
   | is_inl i => l i
   | is_inr j => r j
   end.

 Lemma f_fincase (n m : nat) (X Y : Type) (f : X -> Y)
                (l : Fin n -> X) ( r : Fin m -> X) (i : Fin ( n + m)) :
       f (fincase l r i) = fincase (fun x  => f (l x)) (fun x => f (r x)) i .
 Proof.
  unfold fincase; intros n m X Y f l r i.
  destruct (finsplit n m i); trivial.
 Qed.

Definition FinCase (n m : nat) (i : Fin (n + m)) : Fin n + Fin m :=
   match finsplit n m i with
   | is_inl a => inl (Fin m) a
   | is_inr a => inr (Fin n) a
   end.

Definition CaseFin (n m : nat) (i : Fin n + Fin m ) : Fin (n + m) :=
  match i with
  | inl a => fin_inl  m a
  | inr b => fin_inr n  b
  end.

Lemma FinCaseFin : forall (n m : nat)(i : Fin n + Fin m),
    FinCase n m (CaseFin i) = i.
Proof.
  unfold FinCase; unfold CaseFin.
  intros n m i; destruct i; auto.
  rewrite (finsplit_inl m f); reflexivity.
  rewrite (finsplit_inr n f); reflexivity.
Qed.

Lemma CaseFinCase :
   forall (n m : nat)(i : Fin (n + m)), CaseFin (FinCase n m i) = i.
Proof.
  unfold CaseFin; unfold FinCase.
  intros n m i; destruct (finsplit n m i); trivial.
Qed.

Lemma FinCase_inl (n m  : nat) (i : Fin n) :
   (FinCase n m (fin_inl  m i) )= (inl (Fin m) i).
Proof.
  intros n m i;  unfold FinCase.
  rewrite  finsplit_inl; trivial.
Qed.

Lemma FinCase_inr (n m  : nat) (i : Fin m) :
    (FinCase n m  (fin_inr  n i) )= (inr (Fin n) i).
Proof.
  intros n m i;
  unfold FinCase.
  rewrite  finsplit_inr; trivial.
Qed.

Lemma fincase1 (A: Type) (n m : nat)
    (f : Fin (S n) -> A) (g : Fin m -> A)  (a : Fin (n + m)) :
               fincase f g (fs a) = fincase (fun i => f (fs i)) g a.
Proof.
  unfold fincase; intros A n m f0 g0 a ; simpl.
  destruct (finsplit n m a); trivial .
Qed.

Lemma finCase_eq  (n m : nat)
     (f : Fin n -> nat) (g : Fin m -> nat)  (a : Fin (n + m)) :
               match  FinCase n m  a with
               inl z => f z
               | inr z => g z
               end = fincase f g a.
 Proof.
  unfold fincase; unfold FinCase.
  intros n m f0 g0 i.
  destruct (finsplit n m i); trivial.
 Qed.

 Lemma fincaseS (n m : nat) (f : Fin (S n) -> nat)
     (g : Fin m -> nat)  (a : Fin (n + m)) :
               match  FinCase n m  a with
               inl z => f (fs z)
               | inr z => g z
               end =
              match FinCase (S n) m (fs a) with
              | inl z => f z
              | inr z => g z
             end.
Proof.
  intros n m f0 g0 a.
  generalize (finCase_eq (fun x => f0 (fs x)) g0 a).
  intro H; simpl in H.
  rewrite H.
  rewrite (finCase_eq f0 g0 (fs a)).
  apply (sym_equal (fincase1 f0 g0 a)).
Qed.

End FinSum_defs.

Section reversing_inductive_finite_sets.
 (** * Top and Embed *)

 Implicit Arguments fz [ n].
 Fixpoint emb (n : nat) (i:Fin n) {struct i }: Fin (S n) :=
   match i in Fin n  return Fin (S n) with
   |  fz _  =>  fz
   |  fs _ j => fs (emb j)
   end.

 Fixpoint tp (n:nat) : Fin (S n) :=
    match n return Fin (S n) with
    | O => fz
    | S x' => fs (tp x' )
   end.

(** View on tp and emb *)
Inductive FinEmtp (n : nat) : Fin (S  n) -> Type :=
   | isTp :  FinEmtp (tp n)
   | isEmb : forall  (i : Fin n), FinEmtp (emb i).

 Fixpoint finEmtp (n : nat) : forall i : Fin (S n) ,  FinEmtp i :=
   match n as e return (forall i : Fin (S e), FinEmtp i) with
   | O => fun i => let f := finSN i in
          match f in (FinSN f0) return FinEmtp f0 with
          | isfz => isTp 0
          | isfs j => match (fin_0_empty j) with end
          end
   | S n' => fun f => let f' := finSN f in
           match f' in (FinSN f0) return FinEmtp f0 with
           | isfz => isEmb (fz (n := n'))
           | isfs i => let k := finEmtp i in
              match k in (FinEmtp  f1) return (FinEmtp  (fs f1)) with
              | isTp => isTp (S n')
              | isEmb i => isEmb (fs  i)
              end
           end
   end.

 Definition FinEmTp_rect
     : forall (n : nat) (P : Fin (S n) -> Type),
       (forall y : Fin n, P (emb y)) -> P (tp n) -> forall x : Fin (S n), P x :=
   fun n P H0 H1 x => match (finEmtp x) in (FinEmtp  e) return (P e) with
                    | isTp => H1
                    | isEmb i => (H0 i)
                    end.

  (** forgetful function using the emb _ tp view *)
  Fixpoint foo1 n : Fin n -> nat :=
    match n as e return Fin e -> nat with
    | O => fun i =>
             match (fin_0_empty i) return nat with end
    | S m => fun i => match (finEmtp i) with
                      | isTp => m
                      | isEmb j => foo1 j
                      end
    end.

  (* tp not fz *)
  Lemma tp_not_fz : forall n, tp (S n) <> fz (n := S n).
  simpl. unfold not;  intros n H; inversion H.
 Qed.

 Lemma tp_emb (n : nat) (i : Fin n): tp n = emb i -> False.
 Proof.
   induction i; simpl.
   intros h; discriminate h.
    apply (fun H => IHi (fsInject H)).
 Qed.

Lemma fs_emb (n : nat) (i : Fin n) : fs i = emb i -> False.
Proof.
  induction i.
  intro h; discriminate h.
  simpl. apply (fun H => IHi (fsInject H)).
Qed.

(* emb is injective *)
 Lemma  embInject ( n :nat) (i j: Fin n) :   emb i = emb j -> i = j .
 Proof.
   induction i; destruct j using FinSn_rect; simpl.
   intro h; discriminate h. trivial.
   intro h; rewrite (IHi j (fsInject h)); trivial.
   intro h; discriminate h.
Qed.

 (** Reversing the nat-indexed family, Fin  *)
 Fixpoint rv (n:nat) (i:Fin n) {struct i} : Fin n :=
    match  i in Fin n  return Fin n with
    |  fz p => tp p
    |  fs _ k => emb  (rv k)
   end.

 Lemma emb_S :  forall n: nat, forall i: Fin n, rv  (emb i) = fs (rv i).
 Proof.
   induction  i; simpl; auto.
   rewrite IHi;  simpl;  trivial.
 Qed.

 (** reversing Fin is involutive *)
 Theorem idem_rvFin: forall n: nat, forall i:Fin n,  rv (rv i) = i.
 Proof.
   induction i; simpl;  auto.
   induction n; simpl; auto.
   rewrite IHn ; trivial.
   rewrite (emb_S (rv i));  rewrite IHi; reflexivity.
 Qed.

 Lemma fsFz (n : nat) (i : Fin n) : rv fz = rv (fs i) -> False .
 Proof.
   intros  n i; simpl; generalize (rv i) .
   induction f; simpl; try  (intro h; discriminate h).
   exact (fun H => IHf f (fsInject H)).
 Qed.

  (** rev in injective *)
 Lemma rvInject (n : nat) (i j : Fin n) : rv i = rv j -> i = j.
 Proof.
    induction n.
    abstract inversion i.
    intros i j; destruct j using FinSn_rect .
    destruct i using FinSn_rect.
    intro H; elim (IHn i j (embInject (rv i) (rv  j) H)); trivial.
    intro H; case (fsFz j H).
    destruct i using FinSn_rect; auto.
    intro H; case (fsFz i (sym_equal H)).
Qed.

 Lemma rvdist (n: nat) (i j: Fin n): rv  i = j -> i = rv j.
 Proof.
  intros n i j H;
  apply (eq_subs (fun x : Fin n => x = rv (n := n) j)
       (idem_rvFin i) (f_equal (rv (n := n)) H)).
 Qed.

 Lemma rvdistJM (n m : nat) (H : n = m) (i : Fin n) (j : Fin m) :
        JMeq (rv i) j -> JMeq i (rv j).
 Proof.
  intros n m H ; case H.
  intros i j h; rewrite  (rvdist i (JMeq_eq h) ); trivial.
 Qed.

Lemma idmrv_subst: forall (n : nat) (i : Fin n)
  (P : Fin n -> Fin n -> Type), P (rv (rv i))  (rv i) -> P i (rv i).
 Proof.
   intros n i P;
   rewrite (idem_rvFin i);
   trivial.
 Qed.

Definition rv_elim (n: nat) (i : Fin n)
  (P : Fin n -> Fin n -> Type ) (H : forall j, P (rv j) j) : P i (rv i) :=
   idmrv_subst i P (H (rv i)).

 Section Foo.
    (** *** Redunctions *)

   Lemma foo_emb : forall n (i : Fin n), foo (emb i) = foo i.
     induction i; simpl; auto.
   Qed.

    Lemma foo_rvtp:  forall n : nat, foo (rv (tp n)) = 0.
      induction n; simpl ; auto.
      rewrite <- IHn.
      apply foo_emb.
    Qed.

    Lemma foo_tp : forall n, foo (tp n) = n.
      induction n; simpl; auto.
    Qed.

    Lemma fooRv n (i : Fin n) : foo (rv i) = n - (foo i) - 1.
    Proof.
      induction i; simpl. rewrite <- (minus_n_O ).
      apply foo_tp. rewrite foo_emb. trivial.
    Qed.

    Lemma foo_inl n m (i : Fin n) : foo (fin_inl m i) = foo i.
    Proof.
       induction i; simpl; auto.
    Qed.

     Lemma foo_inr n m (i : Fin m) : foo (fin_inr n i) =  n + (foo i).
    Proof.
      induction n; simpl; auto.
    Qed.

   Lemma foo_nm n m (i : Fin (n + m)) : foo i =
       match finsplit  n m  i with
       | is_inl a => foo a
       | is_inr a => n + foo a
       end.
    Proof.
      intros n m i; destruct (finsplit n m i);
      [rewrite (foo_inl m i); trivial |  rewrite (foo_inr n j); trivial].
   Qed.

 End Foo.

Section Alternative_Reverse.
 (** * Alternative Definition of rev *)

 Definition S1 (n:nat) : S n = n + 1.
 Proof.
  induction n; auto.
  exact (eq_subs (fun x : nat => S x = S n + 1) (sym_equal IHn)
    (refl_equal (S n + 1)) ).
 Defined.

 Axiom eq_unique : forall (A : Set) (a : A) (H : a = a), H = refl_equal a.
 Axiom extensionality : forall (A B: Type)  (f g: A ->  B ),
      (forall a , f a = g a )-> f =g.

 Definition Rv (n : nat) : Fin n ->   Fin n.
  induction n.
  intro i; try inversion i.
  exact (fun i : Fin (S n) =>
       fincase (fun (x:  Fin n) => fs (IHn x)) (fun _ : Fin 1 => fz )
         (eq_subs Fin (S1 n) i) ).
 Defined.

Lemma Rv_fs (n : nat) (i : Fin (S n)) :
   Rv i = fincase (fun a : Fin n => fs (Rv a)) (fun _ : Fin 1 => fz )
    (eq_subs Fin (S1 n)  i).
 Proof.
    intros n i; destruct i using FinSn_rect; auto.
 Qed.

 Lemma F_fincase (n : nat) (i : Fin (n + 1) )(F : forall m : nat, Fin m ->
     Fin (S m)) :
     fincase (fun x : Fin n => F (S n) (fs (Rv x)))
       (fun _ : Fin 1 => F (S n)  fz ) i =
   F (S n) (fincase (fun x : Fin n => fs (Rv x)) (fun _ : Fin 1 => fz ) i).
 Proof.
  intros n i F; unfold fincase.
  destruct (finsplit n 1 i); trivial.
 Qed.

 Lemma fs_eq_subs (n m : nat) (H : n = m) (i : Fin n) :
      fs (eq_subs Fin H i) = eq_subs Fin (f_equal S H) (fs i).
  Proof.
   intros n m H; case H; trivial.
  Qed.

 Lemma match_rem1 (n m : nat) (H : n = m) (H1 : S n = S m)  (i : Fin n) :
   match H1 in ( _ = y ) return (Fin y) with
   | refl_equal => fs i
   end =
   match H in ( _ = y ) return (Fin (S y)) with
   | refl_equal => fs i
   end .
 Proof.
  intros n m H; case H.
  intro H1; rewrite (eq_unique H1); trivial.
 Qed.

(*Require Import Peano_dec. *)

 Lemma emb_Rv : forall  (n : nat) (i : Fin n), Rv (fs i) = emb (Rv i).
 Proof.
  induction n.
  intro i; try inversion i.
  intro i; destruct i using FinSn_rect.
  replace (emb (Rv (fs i))) with
    (fincase (fun x : Fin n => fs (emb (Rv x))) (fun _ : Fin 1 => fz )
                            (eq_subs Fin (S1 n) (fs i))).
  rewrite  (extensionality  (fun x : Fin n => fs (emb (Rv x)))
           (fun x : Fin n => fs (Rv (fs x)))
           (fun a : Fin n => fs_eq (sym_eq (IHn a))) ).
  rewrite (Rv_fs (fs (fs i))).
  replace (eq_subs Fin (S1 (S n)) (fs (fs i))) with
       (fs (eq_subs Fin (S1 n) (fs i))).
  unfold fincase.
  destruct (finsplit n 1 (eq_subs Fin (S1 n) (fs i))).
  generalize  (finsplit_inl  1 (fs i0)).
  intro H; simpl fin_inl in H; rewrite H; trivial.
  destruct j using FinSn_rect.
  inversion j.
  Implicit Arguments fz [ ].
  simpl; rewrite (finsplit_inr n (fz 0) ); trivial.
  rewrite (fs_eq_subs (S1 n) ).
   rewrite (proof_irrelevance (S (S n) = S n + 1)
     (S1 (S n)) (f_equal S (S1 n)) ); trivial.
  simpl Rv at 2; rewrite <- (F_fincase n (eq_subs Fin (S1 n) (fs i)) emb);  trivial.
  simpl .
  rewrite <- (F_fincase n (eq_subs Fin (S1 n) (fz n)) emb);  trivial.
  rewrite   (extensionality
 (fun x : Fin n  => emb (fs  (Rv x))) (fun x : Fin n => fs (Rv (fs x)))
 (fun x : Fin n => fs_eq (sym_equal (IHn x)))
  ).
 replace  (eq_subs Fin
        (eq_subs (fun x : nat => S x = S (n + 1)) (sym_equal (S1 n))
           (refl_equal (S (n + 1)))) (fs (fz n))) with (fs  (eq_subs Fin (S1 n) (fz n))).
 rewrite (fincase1 (fun x : Fin (S n) => fs (fincase (fun x0 : Fin n => fs (Rv x0))
                    (fun _ : Fin 1 => fz n) (eq_subs Fin (S1 n) x)))
     (fun _ : Fin 1 => fz (S n))
          (eq_subs Fin (S1 n) (fz n))); trivial.
 replace (eq_subs (fun x : nat => S x = S (n + 1)) (sym_equal (S1 n))
        (refl_equal (S (n + 1)))) with (S1 (S n)); auto.
 rewrite (proof_irrelevance (S (S n) = S n + 1)
     (S1 (S n)) (f_equal S (S1 n)) ); trivial.
 rewrite  (fs_eq_subs (S1 n) (fz n)); trivial.
Qed.

 Lemma fz_eq_subs (n m : nat) (H : S n =  S m) :
   fz m = match H in ( _ = y) return (Fin  y)  with
         | refl_equal => fz n
          end.
 Proof.
   intros n m H ; injection  H.
   intro H1; destruct  H1.
   apply  (eq_subs (fun x : S n = S n => fz n =
                          match x in (_ = y) return (Fin y) with
                          | refl_equal => fz n
                          end ) (sym_equal (eq_unique H))); trivial.
 Qed.

 Lemma rv_Rv : forall (n : nat) (i : Fin n), rv i = Rv i.
 Proof.
  induction n.
  intro i; try inversion i.
  intro i; destruct i using FinSn_rect.
  rewrite (emb_Rv i); rewrite <- (IHn i); trivial.
  destruct n.
  simpl; trivial.
  simpl Rv.
  replace  (eq_subs Fin
        (eq_subs (fun x : nat => S x = S (n + 1)) (sym_equal (S1 n))
           (refl_equal (S (n + 1)))) (fz (S n))) with
              (eq_subs Fin (S1 (S n)) (fz (S n))); auto .
  apply (eq_subs (fun x : Fin (S n + 1) => fs (tp n) =
     fincase
     (fun x : Fin (S n) =>
      fs (fincase (fun x0 : Fin n => fs (Rv x0)) (fun _ : Fin 1 => fz n)
          (eq_subs Fin (S1 n) x))) (fun _ : Fin 1 => fz (S n)) x )
                 (fz_eq_subs (S1  (S n)))).
  unfold fincase; simpl.
  apply  (eq_subs (fun x : Fin (S n) => fs (tp n) = fs x) (Rv_fs (fz n)) ).
  rewrite <- (IHn (fz n)); trivial.
 Qed.

 End  Alternative_Reverse.

End reversing_inductive_finite_sets.
(* Implicit Arguments fz [ ]. *)

 Section Rotate.
(** * Rotate *)

 (* rotates the first position to the last , and remainig ones
    one level up *)
 Definition rot n (i :  Fin n)  :  Fin n :=
   match i in Fin e return Fin e with
   | fz x => tp x
   | fs _ j => emb j
   end.

 Fixpoint rotn n : forall m, Fin m -> Fin m :=
    match n with
    | O => fun _ i => i
    (* | S O => rot *)
    | S n' => fun m i => (rotn n' (rot i))
    end.

 Definition rotn1 n m (i : Fin m)  := match le_lt_dec m n with
                                      | left _ => rotn (n - m) i
                                      | right _ => i
                                      end.
 Definition rotn2 n (i : Fin n) := rotn1 n i.

Lemma rotn_Sn : forall n m (i : Fin m), rot (rotn n i) = rotn (S n) i.
 Proof.
  induction n; simpl; auto.
  intros. rewrite (IHn m (rot i)); simpl; trivial.
 Qed.

 Lemma rotn_rotn : forall n m x (i : Fin x), rotn n (rotn m i) = rotn (n+m) i.
 Proof.
   induction n; simpl; auto.
   intros. rewrite <- (IHn m x (rot i)); trivial.
   rewrite (rotn_Sn m i); simpl; trivial.
 Qed.

 Lemma rotn_minus : forall n (i : Fin n), rotn (n - n) i = i.
 Proof.
    intros ; rewrite  minus_diag; simpl; trivial.
 Qed.

 Lemma rotn_minus1 : forall n (i : Fin n), rotn (S n - n) i = rot i.
 Proof.
   intros n i; rewrite <- (minus_Sn_m _ _ (le_n n)); simpl.
   rewrite rotn_minus; trivial.
 Qed.

 Lemma rotn_nm : forall (n m : nat) (i : Fin m), rotn (n + m - n) i = rotn m i.
 Proof.
  induction n; simpl. intros.
  rewrite <- (minus_n_O m); trivial.
  intros. apply (IHn m i).
 Qed.

(*Lemma rotn_rot_swap : forall n m (i : Fin m), rot (rotn n i) = rotn n (rot i).
 Proof.
   induction n; simpl; trivial.
 Qed. *)

 Lemma rot_inject : forall n (i j: Fin n), rot i = rot j -> i = j.
   destruct i; destruct j using FinSn_rect; simpl; auto.
   intro. destruct (tp_emb _ H).
   intro H; rewrite (embInject _ _ H ); trivial.
   intros H; destruct (tp_emb _ (sym_eq H)).
 Qed.

 Lemma rotn_inject : forall n m (i j : Fin m), rotn n i = rotn n j -> i = j.
 Proof.
   induction n; simpl; auto.
  intros. apply (rot_inject i j (IHn m (rot i) (rot j) H)).
 Qed.

 Lemma foo_rot (n : nat) (i : Fin n):
     foo (rot i) = match i in Fin e return nat with
             | fz m => foo (tp m)
             | fs _ j => foo (emb j)
             end.
     destruct i; simpl; trivial.
  Qed.

 Definition un_rot (n : nat) :  Fin n -> Fin n :=
   match n as e return Fin e -> Fin e with
   | O => fun i => i
   | S m => fun i => match finEmtp i with
                     | isEmb i => fs i
                     | isTp  => fz m
                     end
   end.

 Lemma un_rot_inject : forall n (i j : Fin n), un_rot i = un_rot j -> i = j.
 Proof.
   destruct n; try intros; simpl. inversion i.
   destruct (finEmtp i);  destruct (finEmtp j); trivial.
   simpl in H. destruct (finEmtp (tp n));
   destruct (finEmtp (emb i)); trivial. inversion H.
   inversion H. rewrite (fsInject H); trivial.
   simpl in *.
   destruct (finEmtp (emb i)). destruct (finEmtp (tp n)); trivial.
   destruct (finEmtp (tp n)). inversion H.  rewrite (fsInject H); trivial.
   simpl in H. destruct (finEmtp (emb i)). destruct (finEmtp (emb i0)); trivial.
   inversion H. destruct ( finEmtp (emb i0)). inversion H.
   rewrite (fsInject H); trivial.
 Qed.

 (* rot in inverse  to un_rot *)
 Lemma rot_un_rot_id : forall n (i : Fin n), rot (un_rot i) = i.
 Proof.
   destruct i; simpl.
   destruct n; simpl; trivial.
   destruct (finEmtp (fs i)); simpl; trivial.
 Qed.

 Lemma un_rot_rot_id : forall n (i : Fin n), un_rot (rot i) = i.
 Proof.
   destruct i; simpl.
   induction n; simpl; trivial.
   destruct (finEmtp (tp n)); auto.
   inversion IHn.
   induction i; simpl; trivial.
   destruct ( finEmtp (emb i)); simpl.
   inversion IHi. rewrite IHi; trivial.
 Qed.

End Rotate.

(* Fixpoint eqFin (n :nat) (i  : Fin n): Fin n ->  bool :=
   match i in Fin e return Fin e -> bool with
  | fz _ => fun j => match finSN j with
                     | isfz => true
                     | _    => false
                     end
  | fs _ x => fun j => match finSN j with
                      | isfs x1 => eqFin x x1
                      | _ => false
                      end
  end.

 Lemma FinEq_ok : forall n (i j : Fin n), eqFin i j = true -> i = j.
 Proof.
   induction i. destruct j using FinSn_rect;  simpl; auto.
   intro H; discriminate H.
   destruct j using FinSn_rect; simpl; auto.
    intro H; rewrite (IHi _ H); trivial.
   intro H; discriminate H.
 Qed. *)

Definition nofin (X: Type) (i : Fin 0) : X.
    intros X  i; inversion  i.
 Defined.

Definition caseFin (n: nat) (X: Type) :  X ->  (Fin n -> X) -> Fin (S n) ->  X.
   intros n X x h i.
   destruct (finSN i) as [x | k].
   exact x.
   exact (h k).
Defined.

Definition finplus_swap (n m : nat) (i : Fin (n + m)) : Fin (m + n) :=
  match finsplit n m i with
  | is_inl a => fin_inr  m a
  | is_inr a => fin_inl n  a
  end.

 Lemma finsplit_unique : forall n m (i : Fin (n +m)) ( x : FinSum n m i) ,
    x = finsplit n m i.
 Proof.
    intros n m i x; destruct x.
    exact (sym_equal (finsplit_inl m i)).
    exact (sym_equal (finsplit_inr n j)).
 Defined.

 Lemma finsplit_inl_inr : forall (n m : nat) (i : Fin n) (j : Fin m),
     fin_inl  m i = fin_inr n j -> False.
 Proof.
    intros n m i j; induction i; simpl.
    intro H; discriminate H.
    exact (fun x => IHi (fsInject x)).
 Qed.

Lemma fin_inlS  (n : nat) (i j: Fin n):  forall m : nat,
       fin_inl m i = fin_inl m  j -> fin_inl  (S m) i = fin_inl (S m) j.
Proof.
  intros n i j m; induction i; simpl; auto.
  destruct j using FinSn_rect ; simpl; auto.
  intros H; discriminate H.
  destruct j using FinSn_rect; simpl  ; auto.
   exact (fun a => fs_eq (IHi j (fsInject a))).
  intro H; discriminate H.
Qed.

Lemma fin_inlP  (n : nat) (i j: Fin n):
  forall m : nat,  fin_inl  m i = fin_inl  m j ->
        fin_inl  (pred m) i = fin_inl  (pred m) j.
 Proof.
  intros n i j m; induction i; simpl; auto.
  destruct j using FinSn_rect ; simpl; auto.
  intros H; discriminate H.
  destruct j using FinSn_rect; simpl  ; auto.
  exact (fun a => fs_eq (IHi j (fsInject a))).
  intro H; discriminate H.
 Qed.

Lemma fin_inrS (m : nat) (i j : Fin m) :
   forall n : nat, fin_inr n  i = fin_inr n  j ->
                     fin_inr (S n)  i = fin_inr (S n)  j.
Proof.
   destruct n; simpl; exact (fun a => fs_eq a).
Qed.

Lemma fin_inrP (m : nat) (i j : Fin m) :
     forall n : nat, fin_inr n  i = fin_inr n  j ->
                  fin_inr (pred n)  i = fin_inr (pred n)  j.
 Proof.
   destruct n; simpl; trivial.
   exact (fun a => fsInject a).
Qed.

 Require Import Arith.

Lemma fininl_embO (n : nat) ( i : Fin n) :
    emb (fin_inl  0 i) = fin_inl  0 (emb i).
Proof.
   induction i; simpl ; auto.
   exact (fs_eq IHi).
Qed.

Lemma fin_inl_inr  (n m : nat) (i : Fin n) (j: Fin m):
     fin_inl  m i = fin_inr n  j  -> False.
Proof.
  intros n m i j.
  induction i;  simpl.
  intro h; inversion h.
  exact (fun x => IHi (fsInject x)).
Qed.

Lemma rv_fin_inlO (n : nat) (i : Fin n) : rv (fin_inl  0 i) = fin_inl 0 (rv i).
  induction i; simpl.
  induction n; simpl ; auto.
  rewrite IHn; reflexivity.
  rewrite <- (fininl_embO (rv i)).
  rewrite IHi; reflexivity.
 Qed.

Lemma emb_tpm (n : nat) : emb (tp (S n)) = fz (S (S n)) -> False .
Proof.
 simpl;  intros n H.
 discriminate H.
Qed.

Section FinTimes_.
  (** Products of finite types *)

 Fixpoint fpair  (n m : nat) (i : Fin n) (j : Fin m) : Fin (n * m) :=
   match i in (Fin e) return Fin (e * m) with
   | fz n => fin_inl (n * m) j
   | fs _ i1 => fin_inr m (fpair i1 j)
   end.

Inductive FinTimes (n m : nat) : Fin (n * m) -> Set :=
  |isfpair : forall (i : Fin n) (j : Fin m), FinTimes n m (fpair  i j).

 Fixpoint fintimes (n m : nat) : forall i :  Fin (n * m), FinTimes n m i :=
   match n as e return (forall i : Fin (e * m),  FinTimes e m i) with
   | O => fun i => match (fin_0_empty i) return ( FinTimes 0 m i) with end
   | S n0 => fun i => match finsplit _ _ i in (FinSum _ _ f0)
                                    return (FinTimes (S n0) m f0) with
             | is_inl l => isfpair (fz _) l
             | is_inr r => match (fintimes _ _ r) in (FinTimes _ _ f1)
                             return  (FinTimes (S n0) m (fin_inr m f1)) with
                           | isfpair i1 j0 => isfpair (fs i1) j0
                           end
             end
   end.

 (* distritutivity of times over plus *)
 Definition dist (n m o : nat) (x : Fin (n * (m + o))) : Fin (n * m + n * o) :=
   match fintimes n (m + o) x with
   | isfpair i j =>
      match finsplit m o j with
      | is_inl i0 => fin_inl (n * o) (fpair i i0)
      | is_inr j0 => fin_inr (n * m) (fpair i j0)
     end
 end.

End FinTimes_.

Definition finJmeq (n m : nat) (H : n = m) (i: Fin n) :
   JMeq i (eq_subs (fun x : nat => Fin x) H i).
 intros n m H; case H.
 intro i; auto.
Qed.

Section JMeq_fin_inl_or_inr.
(** * Miscellaneous *)
Lemma fin_emb (n m : nat) (H : n = m) (i : Fin m) (J : Fin n) :
     JMeq i J -> JMeq (emb i) (emb J).
 Proof.
   intros n m H; elim H.
   intros i J H0 ; elim H0; apply JMeq_refl.
 Qed.

 Lemma fin_inl_O : forall (n : nat) (i : Fin n), JMeq (fin_inl  0 i) i.
 Proof.
   intro n; induction i; simpl.
   apply  (eq_subs (fun x : nat => JMeq (fz (n + 0)) (fz x)) (sym_equal (plus_n_O n)) ).
   apply JMeq_refl.
   exact (fin_fs  (plus_n_O n) IHi).
 Qed.

 Lemma match_simpl : forall (n m : nat) (i : Fin (n + m)) ,
             match
                match
                   match finsplit n m i with
                   | is_inl a => inl (Fin m) a
                   | is_inr a => inr (Fin n) a
                   end
                 with
                 | inl a1 => inl (Fin m) (rv a1)
                 | inr a1 => inr (Fin n) (rv a1)
                 end
               with
               | inl b => inr (Fin m) b
               | inr b => inl (Fin n)  b
               end =
             match finsplit n m  i  with
             | is_inl a => inr (Fin m) (rv a)
             | is_inr a => inl (Fin n) (rv a)
             end.
   Proof.
       intros n m i; destruct (finsplit n m i); trivial.
  Qed.

(*  Lemma match_simpl_rv : forall (n m : nat) (i : Fin (n + m)) ,
             match
                match
                   match finsplit n m (rv i) with
                   | is_inl a => inl (Fin m) a
                   | is_inr a => inr (Fin n) a
                   end
                 with
                 | inl a1 => inl (Fin m) (rv a1)
                 | inr a1 => inr (Fin n) (rv a1)
                 end
               with
               | inl b => inr (Fin m) b
               | inr b => inl (Fin n)  b
               end =
             match finsplit n m  i  with
             | is_inl a => inr (Fin m) (rv a)
             | is_inr a => inl (Fin n) (rv a)
             end.
   Proof.
       intros n m i.  rewrite (match_simpl _ _ (rv i)).

  destruct (finsplit n m i); trivial.
  Qed. *)

Lemma fin_Jmeq (n m : nat) (i : Fin  m) :
     JMeq (fs (fin_inr n   i)) (fin_inr n  (fs i)).
Proof.
  induction n; simpl; auto.
  intros m i;
  apply  (fin_fs (sym_equal (plus_n_Sm n m)) (IHn m i) ).
Qed.

Lemma JM_rvEmb  (n m : nat) (i : Fin n) :
    JMeq (emb (fin_inr m  i)) (fin_inr m  (emb i)).
Proof.
  induction m; simpl.
  intro i; apply JMeq_refl.
  intro i; exact (fin_fs (sym_equal (plus_Snm_nSm m n)) (IHm i)).
Qed.

Lemma Jmeq_fsInject (n m : nat) (i :Fin n) (j : Fin m) :
     n = m -> JMeq (fs i) (fs j) -> JMeq i j.
Proof.
  intros n m i j H; destruct H.
  intro H; elim (fsInject (JMeq_eq H)) ;  trivial.
Qed.

Implicit Arguments fin_inl [ ].
Implicit Arguments fin_inr [ ].
Lemma fin_Jmeq_l (n m : nat) (i : Fin n) :
    JMeq (fin_inl n (S m) i) (fin_inl (S n) m (fs i)) -> False.
Proof.
  intros n m i; induction i.
  intro H.
  generalize (JMeq_eq (eq_subs (fun x : nat => JMeq (fz x) (fs (fz (n + m))))
              (sym_equal (plus_Snm_nSm n m)) H )).
  clear H; intro H; discriminate H.
 intro H; simpl in H.
 apply (IHi (Jmeq_fsInject (sym_equal (plus_Snm_nSm n m)) H) ).
Qed.

Lemma JM_rvEmb1 (n m : nat) ( i : Fin n) :
    JMeq (fin_inl n (S m) i ) (emb (fin_inl n m i)).
Proof.
 induction i.
 apply  (eq_subs (fun x : nat => JMeq (fz (n + S m)) (fz x))  (sym_equal (plus_Snm_nSm n m ))).
 apply JMeq_refl.
 apply (fin_fs (plus_Snm_nSm n m ) IHi).
Qed.

Lemma rvFin_inl (n m : nat) (i : Fin n) :
     JMeq (rv (fin_inl n m i)) (fin_inr m n (rv i)).
Proof.
  induction i. induction n; simpl.
  induction m; simpl; auto.
  apply (fin_fs (sym_equal (S1 m)) IHm ).
  simpl in IHn.
  apply (trans_JMeq  (fin_fs (plus_comm m (S n)) IHn) (fin_Jmeq m (tp n))).
  apply (trans_JMeq  (fin_emb (plus_comm m n) IHi) (JM_rvEmb m (rv i))).
Qed.

Lemma rvFin_inr (n m : nat) (i : Fin n) :
 JMeq (rv (fin_inr m n i)) (fin_inl n m (rv i)).
Proof.
  induction m; simpl.
  induction i; simpl.
  apply (sym_JMeq (fin_inl_O (tp n))).
  apply (sym_JMeq (fin_inl_O (emb (rv i)))).
  apply (fun i => trans_JMeq (fin_emb (plus_comm  n m)  (IHm i) )
           (sym_JMeq (JM_rvEmb1 m (rv i)))).
Qed.

Lemma inl_inr_eq (n : nat) (i j : Fin n) :
    JMeq (fin_inr 0 n i) (fin_inl n 0 j) -> i = j.
Proof.
  induction j; auto.
  destruct i using FinSn_rect; simpl.
  apply (eq_subs (fun x => JMeq (fs i) (fz x) -> fs i = fz n)
         (sym_equal (plus_0_r n))) .
  intro H; apply (JMeq_eq H);auto.
  trivial.
  destruct i using FinSn_rect.
  intro H; rewrite (IHj i (Jmeq_fsInject (sym_equal (plus_0_r  n)) H)); trivial.
  apply  (eq_subs (fun x => JMeq (fz x) (fs (fin_inl n 0 j)) -> fz n = fs j)
           (plus_0_r n)).
  intro H; generalize (JMeq_eq H); intro h; discriminate h.
Qed.

Lemma finsumX (n m : nat) (i : Fin (n + m)) (j k : Fin (m + n))(g : k = (rv j))
              (si  : FinSum n m  i) (sk :   FinSum m n k) :  JMeq i j ->
  match si with
  | is_inl a => inr (Fin m) (rv a)
  | is_inr a => inl (Fin n) (rv a)
  end
  =
  match sk with
  | is_inl a => inl (Fin n) a
  | is_inr a => inr (Fin m) a
  end.
 intros n m i j k g si sk H.
 destruct si; destruct sk.
 rewrite (rvdist j (sym_equal g)) in H.
case (fin_inl_inr i (rv i0) (JMeq_eq (trans_JMeq H (rvFin_inl n i0)))).
rewrite (rvdist j  (sym_equal g)) in H .
rewrite (fin_inl_inject m i (rv j0) (JMeq_eq (trans_JMeq H (rvFin_inr m j0)))).
rewrite (idem_rvFin j0) ; trivial.
rewrite (rvdist j (sym_equal g)) in H.
rewrite  (fin_inr_inject n j0 (rv i) (JMeq_eq (trans_JMeq H (rvFin_inl n i)))).
rewrite (idem_rvFin i); trivial.
rewrite (rvdist j (sym_equal g)) in H.
case  (fin_inl_inr (rv j1) j0 (sym_equal (JMeq_eq (trans_JMeq H (rvFin_inr m j1))))).
Qed.

 Lemma finsplit_rv_swap : forall n m (i : Fin (n + m)) (j : Fin (m + n)),
   JMeq i j ->
    match finsplit n m (rv i) with
    | is_inl a => inl (Fin m) a
    | is_inr b => inr (Fin n) b
   end =
   match finsplit m n j with
   | is_inl a => inr (Fin n) (rv a)
   | is_inr b => inl (Fin m) (rv b)
   end.
 Proof.
   intros n m i j H; rewrite (finsumX  (refl_equal (rv i))  (finsplit m n j)
      (finsplit n m (rv i)) (sym_JMeq H)); trivial.
 Qed.

 Implicit Arguments finsplit_rv_swap [n m].

Lemma fin_inr_inr (n x y : nat) (i : Fin y) :
  JMeq (fin_inr n (x + y) (fin_inr x y i)) (fin_inr (n + x) y i).
 Proof.
  intros n x y i; induction n; simpl; auto.
  apply (dp_rwt Fin (fun (a : nat) (fa : Fin a) =>
        JMeq (fs fa) (fs (fin_inr (n + x) y i)))
       (sym_equal (plus_assoc n x y)) (sym_JMeq IHn) ); trivial.
 Qed.

Lemma fin_inl_inrN (n m x z y : nat) (H : m + x = z + y) (i : Fin n ) (j : Fin y)
  :  JMeq (fin_inl n (m + x) i) (fin_inr (n + z) y j) -> False .
 Proof.
  intros n m x z y H; rewrite H.
  clear H; intros .
  induction i; simpl in *.
  generalize (JMeq_eq (eq_subs (fun x : nat => JMeq (fz x)
       (fs (fin_inr (n + z) y j))) (plus_assoc n z y) H));
  clear H; intro H.
  discriminate H .
  apply (IHi (Jmeq_fsInject (plus_assoc n z y) H )).
 Qed.

 Lemma fin_inr_inrPlus  (n x y a b: nat) (H : x + y  = a + b) (i : Fin (x + y))
  (j : Fin b) :  (JMeq i (fin_inr a b j) -> False) ->
     JMeq (fin_inr n (x + y) i) (fin_inr (n + a) b j) -> False.
 Proof.
  intros n x y a b H; rewrite H.
  clear H; intros i j H.
  induction n; simpl in *; trivial.
  apply (fun A => IHn (Jmeq_fsInject (plus_assoc n a b) A )).
 Qed.

  Lemma finl_inl_inlx  (x z w : nat) (i : Fin x) :
  JMeq (fin_inl x (z + w) i) (fin_inl (x + z) w (fin_inl x z i)).
Proof.
  intros; induction i;  simpl.
  apply (eq_subs (fun x => JMeq (fz x) (fz (n + z + w))) (plus_assoc_reverse n z w) ); trivial.
  apply (fin_fs  (plus_assoc_reverse n z w) IHi ).
Qed.

 Lemma fin_inl_JM (n m x : nat)(H : n = m ) (i : Fin n) (j : Fin m) :
   JMeq (fin_inl n x i)(fin_inl m x j) -> JMeq i j.
 Proof.
  intros n m x  H; case H.
  intros i j h; rewrite (fin_inl_inject x i j (JMeq_eq h)); trivial.
 Qed.

Lemma fin_inr_inlJm (x y z : nat) (i : Fin y) :
   JMeq (fin_inr x (y + z) (fin_inl y z i)) (fin_inl (x + y) z (fin_inr x y  i)).
 Proof.
  induction x; simpl.
  intros; trivial.
   intros y z i.
  apply (fin_fs (plus_assoc_reverse x y z) (IHx y z i)).
Qed.

 Lemma fin_inl_inl_inr1 (x y k z w : nat) (H: y = k)  (i : Fin x ) (j : Fin k) :
   JMeq (fin_inl (x + (y + z)) w (fin_inl x (y + z) i))
        (fin_inl (x + k) (z + w) (fin_inr x k j)) -> False.
  Proof.
  intros x y k z w H; case H.
  intros. induction x. inversion i.
  destruct i using FinSn_rect.
  simpl in *.
  apply (IHx i (Jmeq_fsInject
        (trans_equal
        ( trans_equal (plus_assoc_reverse x (y + z) w )
          (sym_equal (f_equal (plus x) (plus_assoc y z w))))
        (plus_assoc x y (z + w) )) H0)).
   simpl in H0.
    set (R := JMeq_eq (eq_subs (fun k : nat  => JMeq (fz k )
                 (fs (fin_inl (x + y) (z + w) (fin_inr x y j))))
       (trans_equal
        ( trans_equal (plus_assoc_reverse x (y + z) w )
          (sym_equal (f_equal (plus x) (plus_assoc y z w))))
        (plus_assoc x y (z + w))) H0 )).
  discriminate R.
  Qed.

 Lemma fin_inl_inr_lr (x y k w z : nat) (H : z = k + w) (i : Fin z ) (j : Fin x) :
   JMeq (fin_inr x (y + z ) (fin_inr y z i))
        (fin_inl (x + (y + k)) w (fin_inl x (y + k) j)) -> False.
 Proof.
  intros x y k w z H; try rewrite  H.   intros.
  induction j; simpl in *.
  set (R := JMeq_eq (eq_subs (fun p : nat =>
      JMeq (fs (fin_inr n (y + (k + w)) (fin_inr y (k + w) i))) (fz p))
    ( trans_equal (plus_assoc_reverse n (y + k) w )
         (f_equal (plus n) (plus_assoc_reverse y k w))) H0 ));
     discriminate R.
  apply (IHj (Jmeq_fsInject
         (sym_equal (trans_equal (plus_assoc_reverse n (y + k) w )
        (f_equal (plus n) (plus_assoc_reverse y k w))))  H0 )).
 Qed.

 Lemma fin_inl_inrJm (x y z : nat) (i : Fin y) :
   JMeq (fin_inl (x + y) z (fin_inr x y i)) (fin_inr x (y + z) (fin_inl y z i)).
 Proof.
  induction x; simpl; auto.
   intros y z i;  apply (fin_fs (plus_assoc x y z) (IHx y z i)).
Qed.

Lemma fin_inrJm (x n m : nat) (H : n = m) (i : Fin n) (j : Fin m) :
  JMeq (fin_inr x n i) (fin_inr x m j) -> JMeq i j.
Proof.
  intros x n m H; case H.
  intros i j h; case (fin_inr_inject x i j (JMeq_eq h)); trivial.
Qed.

Lemma fin_inlJm (x n m : nat) (H : n = m) (i : Fin n) (j : Fin m) :
  JMeq (fin_inl n x i) (fin_inl m x j) -> JMeq i j.
Proof.
  intros x n m H; case H.
  intros i j h;  case (fin_inl_inject x i j (JMeq_eq h)); trivial.
Qed.

Lemma Jmeq_fin_inl_inr3 (x z k Y : nat) (H : Y = z + k) (i : Fin Y ) (j : Fin x ) :
   JMeq (fin_inr x Y i) (fin_inl (x + z) k (fin_inl x z j)) -> False.
Proof.
 intros x z k Y H; try rewrite H.
 intros.
 induction j; simpl in *.
 set (P := JMeq_eq (eq_subs (fun q : nat => JMeq (fs (fin_inr n (z + k) i)) (fz q))
         (plus_assoc_reverse  n z k) H0 )); discriminate P.
 apply (IHj (Jmeq_fsInject (plus_assoc  n z k) H0 ))  .
 Qed.

Lemma Jmeq_fin_inr (z y x : nat) (H : y = x) (j : Fin x) (i : Fin y) :
   JMeq (fin_inr z x j) (fin_inr z y i) -> JMeq i j.
Proof.
 intros z y x H; case H; clear H.
 intros j i H; case (fin_inr_inject z j i (JMeq_eq H) ); trivial.
Qed.

Lemma fin_inl_inrZ1 ( n z y A : nat) (H : A = z + y)  (i : Fin n) (j : Fin y):
       JMeq (fin_inl n A i) (fin_inr (n + z) y j) -> False.
Proof.
 intros n z y A H; rewrite  H.
 intros; clear H.
 induction i; simpl in *.
  set (P := JMeq_eq (eq_subs (fun a => JMeq (fz a) (fs (fin_inr (n + z) y j)) )
              (plus_assoc n z y) H0)); discriminate P.
  apply (IHi (Jmeq_fsInject  (plus_assoc n z y) H0 )).
Qed.

End JMeq_fin_inl_or_inr.

Section ZipMaps.

 Definition ziP (n m : nat) : Fin (n + m) -> Fin n + Fin m.
    induction n. simpl.
    exact (fun _ i => inr _ i).
    intros m h. destruct m.
     destruct (finsplit _ _ h).
    exact (inl _ i). exact (inr _ j).
    destruct (finsplit _ _ h).
    destruct (finSN i).
    exact (inl _ (fz _ )).
    destruct i.
    exact (inr _ (fz _ )).
    destruct (IHn _ (fin_inl m (fs i))).
    exact (inl _ (fs (fs i))).
    exact (inr _ (fs f)).
    destruct (finEmtp j).
    exact (inr _ (tp _ )).
    destruct i.
    exact (inl _ (tp _ )).
    destruct (IHn _ (fin_inr n i)).
    exact (inl _ (emb f)).
    exact (inr _ (fs (emb f))).
 Defined.

(* Eval compute in  ((ziP 2 3)  (fz 4)). *)

End ZipMaps.

Section Exponential.
  (** * Exponential of Finite Types  *)

  Fixpoint eXP (n m : nat) {struct n}:=
    match n,m with
    | O, m => 1
    | S n', m => m  * (eXP n' m)
    end.
  Notation "m -^ n" := (eXP n m) (at level 14).

 Fixpoint finex (n m : nat) {struct n}: (Fin n -> Fin m) -> Fin (m -^ n) :=
  match n as e return ((Fin e -> Fin m) -> Fin (m -^ e)) with
  | O => fun _ => (fz 0)
  | S n' => fun f =>
           fpair (f (fz n')) (finex (fun i => f (fs i)))
  end.

 Inductive FunView (n m : nat)  : Fin (m -^ n) -> Set :=
   lam : forall f : Fin n -> Fin m, FunView n m (finex f).

 Definition funView : forall n m i, FunView n m i.
    induction n; simpl.
    intros n  i; destruct (finSN i).
    exact (lam (nofin (Fin n))).
    destruct (fin_0_empty i).
    intros m i.
    destruct (fintimes m (m -^ n) i) as [p0 ff].
    destruct (IHn m ff) as [ g ].
    replace (fpair p0 (finex g)) with (finex (caseFin p0 g)).
    exact (lam (caseFin p0 g)).
    destruct p0; simpl;
    repeat (rewrite (extensionality g (fun i => g i) (fun a => refl_equal (g a)));
    trivial).
 Defined.

 Definition fapp : forall (n m : nat), Fin (eXP n m) -> Fin n -> Fin m :=
    fun n m i => match  (funView n m i) with
                 | lam f => f
                 end.

 End Exponential.

 (* some tactice for rewriting goals with fin *)

  Ltac rewriteHyp :=
  match goal with
    | [ H : _ |- _ ] => rewrite H; auto; [idtac]
  end.


Require Import Coq.Classes.RelationClasses.
Require Import Sets.
Require Import Ordinal.

Class Preorder {L:Set} (leq: L->L->Prop) := {
  preorder_reflexive :> Reflexive leq;
  preorder_transitive :> Transitive leq;
}.

Class PartialOrder {L:Set} (leq: L->L->Prop) := {
  po_preorder  :> Preorder leq;
  antisymmetry :>  forall {x y}, leq x y -> leq y x -> x=y;
}.

(* I define 2 kinds of complete lattices. The first kind is easier to deal with,
as the lub and glb operations are defined as function. However, when I have to
prove that a set forms a complete lattice, it isn't clear how to define these
operations as functions. Therefore, in this case I prefer the second one which
requires only the existence of these operations. *)

Class FunctionalCompleteLattice {L:Set} (leq: L->L->Prop) := {
  fcl_po  :> PartialOrder leq;
  lub     :  Pow L -> L;
  glb     :  Pow L -> L;
  fcl_lub :  forall X: Pow L, LeastUpperBound leq (Full_set L) (lub X) X;
  fcl_glb :  forall X: Pow L, GreatestLowerBound leq (Full_set L) (glb X) X;
}.

Class CompleteLattice {L:Set} (leq: L->L->Prop) (S: Pow L) := {
  cl_po  :> PartialOrder leq;
  cl_lub :  forall X: Pow L, X ⊆ S -> (exists x, x ∈ S /\ LeastUpperBound leq S x X);
  cl_glb :  forall X: Pow L, X ⊆ S -> (exists x, x ∈ S /\ GreatestLowerBound leq S x X);
}.

Class CompletePrelattice {L:Set} (leq: L->L->Prop) (S:Pow L) := {
  cpl_preorder :> Preorder leq;
  cpl_lub      :  forall X: Pow L, X ⊆ S -> (exists x, x ∈ S /\ LeastUpperBound leq S x X);
  cpl_glb      :  forall X: Pow L, X ⊆ S -> (exists x, x ∈ S /\ GreatestLowerBound leq S x X);
}.

Definition Strict {L:Set} (leq:L->L->Prop) (x y:L) := leq x y /\ ~leq y x.
Definition Equiv  {L:Set} (leq:L->L->Prop) (x y:L) := leq x y /\ leq y x.
Definition Approx {L:Set} (leq:Ord->L->L->Prop) (a:Ord) (x y:L) := forall b, b<a -> leq b x y.

Definition Equiv_class {L:Set} (equiv:L->L->Prop) (x:L) := fun y => equiv x y.

Class LexicographicLattice {L:Set} (sqleq:L->L->Prop) (k:Ord) (sqleqa:Ord->L->L->Prop) := {
  ll_cl            :> FunctionalCompleteLattice sqleq;
  ll_preorders     :> forall a, a<k -> Preorder (sqleqa a);
  k_limit          :  Limit k;
  sqlt_determined1: forall x y, Strict sqleq x y -> exists a, a<k /\ Strict (sqleqa a) x y;
  sqlt_determined2: forall x y a, a<k -> Strict (sqleqa a) x y -> Strict sqleq x y;
  property1        : forall a x y, a<k -> sqleqa a x y -> Approx (fun b => Equiv (sqleqa b)) a x y;
  property2        : forall x y, Approx (fun b => Equiv (sqleqa b)) k x y -> x=y;
  property3_lub    : forall x a, Equiv (sqleqa a) (lub (Equiv_class (Equiv (sqleqa a)) x)) x;
  property3_glb    : forall x a, Equiv (sqleqa a) (glb (Equiv_class (Equiv (sqleqa a)) x)) x;
}.

Lemma Unique_lub {L:Set} {leq:L->L->Prop} (X:Pow L) {x y:L}:
  (FunctionalCompleteLattice leq) ->
  LeastUpperBound leq (Full_set L) x X ->
  LeastUpperBound leq (Full_set L) y X ->
  x = y.
Proof.
  intros.
  destruct H.
  destruct H0.
  apply antisymmetry.
  exact (H1 y (full_intro L y) H0).
  exact (H2 x (full_intro L x) H).
Qed.

Lemma Empty_set_lub {L:Set} {leq:L->L->Prop} (X:Pow L) {x:L}:
  (FunctionalCompleteLattice leq) ->
  LeastUpperBound leq X x (Empty_set L) ->
  forall y, y∈X -> leq x y.
Proof.
  intros.
  destruct H.
  apply (H1 y H0).
  unfold UpperBound.
  unfold Forall_left.
  intros.
  induction H2.
Qed.