(**************************************************************)
(*   Copyright Dominique Larchey-Wendling [*]                 *)
(*                                                            *)
(*                             [*] Affiliation LORIA -- CNRS  *)
(**************************************************************)
(*      This file is distributed under the terms of the       *)
(*         CeCILL v2 FREE SOFTWARE LICENSE AGREEMENT          *)
(**************************************************************)

Require Import Arith Omega.

Require Import utils recalg computable.

Set Implicit Arguments.

Section relational_semantics.

  (* Recursive functions can be interpreted in Coq as (functional) relations *)

  Notation natfun := (fun k => vec nat k -> nat -> Prop).

  Section defs.

    Definition s_cst c : natfun 0 := fun _ x => x=c.
    Definition s_zero  : natfun 1 := fun _ x => x=0.
    Definition s_succ  : natfun 1 := fun v x => x=S (vec_head v).
    Definition s_proj k (p : pos k) : natfun k := fun v x => vec_pos v p = x.

    Variable k i : nat.

    Implicit Types (f : natfun k) (g : natfun (S k)) (h : natfun (S (S k))) (gj : vec (natfun i) k).

    Definition s_comp f gj : natfun i := fun v x => exists gl, f gl x /\ forall p, vec_pos gj p v (vec_pos gl p).

    (** the recursor s_rec_r f h n v x
                 <-> exists x0,...,xn,  f      v  x0,
                                        h (0##x0##v) x1,
                                        h (1##x1##v) x2,
                                        ...
                                        h (.##..##v) xn,
                                    and xn = x
    **)

    Definition s_rec f h v := μ_rec f (fun v x y => h (x##y##v)) (vec_tail v) (vec_head v).

    Definition s_min g v := μ_min (fun n => g (n##v)).

  End defs.

  (** we define the semantics of a recursive algorithm of arity k
      which is a relation vec nat k -> nat -> Prop, obviously functional (see below)
      We interpret the constants ra_* with the corresponding s_* operator on relations
   **)

  Definition ra_rel : forall k, recalg k -> natfun k.
  Proof.
    apply recalg_rect with (P := fun k _ => natfun k).
    exact s_cst.
    exact s_zero.
    exact s_succ.
    exact s_proj.
    intros ? ? ? ? hf hgj; exact (s_comp hf (vec_set_pos hgj)).
    intros ? ? ? hf hg; exact (s_rec hf hg).
    intros ? ? hf; exact (s_min hf).
  Defined.

  Notation "[| f |]" := (@ra_rel _ f) (at level 0).

  Fact ra_rel_fix_cst i :         [| ra_cst i     |]      = s_cst i.                   Proof. reflexivity. Qed.
  Fact ra_rel_fix_zero :          [| ra_zero      |]      = s_zero.                    Proof. reflexivity. Qed.
  Fact ra_rel_fix_succ :          [| ra_succ      |]      = s_succ.                    Proof. reflexivity. Qed.
  Fact ra_rel_fix_proj k p :      [| @ra_proj k p |]      = s_proj p.                  Proof. reflexivity. Qed.
  Fact ra_rel_fix_rec k f g :     [| @ra_rec k f g |]     = s_rec [|f|] [|g|].         Proof. reflexivity. Qed.
  Fact ra_rel_fix_min k f :       [| @ra_min k f |]       = s_min [|f|].               Proof. reflexivity. Qed.
  Fact ra_rel_fix_comp k i f gj : [| @ra_comp k i f gj |] = s_comp [|f|] (vec_map (fun x => [|x|]) gj).
  Proof.
    simpl ra_rel; f_equal.
    apply vec_pos_ext; intros p.
    rewrite vec_pos_set, vec_pos_map; trivial.
  Qed.

  Section functional.

    Lemma s_cst_fun c : functional (s_cst c).
    Proof. intros v x y Hx Hy; rewrite Hy; trivial. Qed.

    Lemma s_zero_fun : functional s_zero.
    Proof. intros v x y Hx Hy; rewrite Hy; trivial. Qed.

    Lemma s_succ_fun : functional s_succ.
    Proof. intros v x y Hx Hy; rewrite Hy; trivial. Qed.

    Lemma s_proj_fun k p : functional (@s_proj k p).
    Proof.
      intros v x y Hx Hy.
      red in Hx, Hy.
      rewrite <- Hx.
      trivial.
    Qed.

    Variable k i : nat.
    Implicit Types (f : natfun k) (gj : vec (natfun i) k) (g : natfun (S k)) (h : natfun (S (S k))).

    Lemma s_comp_fun f gj : functional f -> (forall p, functional (vec_pos gj p)) -> functional (s_comp f gj).
    Proof.
      intros f_fun gj_fun v x y [ gx [ Hx1 Hx2 ] ] [ gy [ Hy1 Hy2 ] ].
      cutrewrite (gx = gy) in Hx1.
      apply (@f_fun gy); trivial.
      apply vec_pos_ext.
      intros p; apply (gj_fun p v); auto.
    Qed.

    Lemma s_rec_fun f h : functional f -> functional h -> functional (s_rec f h).
    Proof.
      intros Hf Hh ? ? ?.
      apply μ_rec_fun; auto.
      intros ? ? ? ? ?; apply Hh.
    Qed.

    Lemma s_min_fun g : functional g -> functional (s_min g).
    Proof.
      intros Hg ? ? ?; apply μ_min_fun.
      intros ? ? ?; apply Hg.
    Qed.

  End functional.

  Hint Resolve s_cst_fun s_zero_fun s_succ_fun s_proj_fun s_rec_fun s_min_fun.

  (* [| f |] is a functional/deterministic relation *)

  Theorem ra_rel_fun k (f : recalg k) v x y : [|f|] v x -> [|f|] v y -> x = y.
  Proof.
    revert v x y; change (functional [|f|]).
    induction f; try (simpl; auto; fail).
    rewrite ra_rel_fix_comp.
    apply s_comp_fun; auto.
    intro; rewrite vec_pos_map; auto.
  Qed.

End relational_semantics.

Notation "[| f |]" := (@ra_rel _ f) (at level 0).

Section recalg_coq.

  (** This code compute the μ-recursive algorithm f into
      Coq code that mimics the algorithm f

      It needs a termination certificate in the form
      of a proof that the predicate [|f|] v is inhabited

      Notice: refine is used to allow better extraction
        to OCaml code

      This gives a VERY short proof of the totality of Coq !!!
   *)

  Fixpoint ra_compute k (ra : recalg k) : forall v, computable ([|ra|] v).
  Proof.
    destruct ra as [ n | | | k p | k i f gj | k f g | k f ]; intros v Hv.

    exists n; reflexivity.
    exists 0; reflexivity.
    exists (S (vec_head v)); reflexivity.
    exists (vec_pos v p); reflexivity.

    refine (match @vec_compute _ _ (fun f y => [|f|] v y)
                                   (fun p => match p with exist _ w Hw => ra_compute _ _ v _ end)
                                   _ gj _ with
      | exist _ w Hw => match ra_compute _ f w _ with
        | exist _ x Hx => exist _ x _
      end
    end); trivial.
    apply vec_reif with (R := fun p => [|vec_pos gj p|] v).
      intros p.
      destruct Hv as (q & w & _ & Hw).
      specialize (Hw p); rewrite vec_pos_set in Hw.
      exists (vec_pos w p); trivial.
    destruct Hv as (q & w' & Hw1 & Hw2).
      exists q; cutrewrite (w = w'); auto.
      apply vec_pos_ext.
      intros p; generalize (Hw p) (Hw2 p).
      rewrite vec_pos_set; apply ra_rel_fun.
    exists w; split; auto.
      intros; rewrite vec_pos_set; apply Hw.

    revert Hv; simpl; apply rec_compute.
    intros ? ?; apply ra_rel_fun.
    intros (w & Hw); simpl.
    apply ra_compute; trivial.
    intros ? ? ? ?; apply ra_rel_fun.
    intros ? ? (w & Hw); apply ra_compute; simpl; auto.

    revert Hv; simpl; apply min_compute; auto.
    intros ? ? ?; apply ra_rel_fun.
    intros (w & Hw); apply ra_compute; trivial.
  Defined.

End recalg_coq.

Section Coq_is_total.

  Variables (k : nat) (f : recalg k) (Hf : forall v, exists x, [|f|] v x).

  Theorem Coq_is_total : { cf | forall v, [|f|] v (cf v) }.
  Proof.
    exists (fun v => proj1_sig (ra_compute _ _ (Hf v))).
    intros v; apply (proj2_sig (ra_compute _ _ (Hf v))).
  Defined.

End Coq_is_total.

Check ra_compute.
Print Assumptions ra_compute.

Print ra_compute.

Check Coq_is_total.
Print Assumptions Coq_is_total.

Print ra_compute.

Extraction ra_compute.

Extraction "ra_coq.ml" ra_compute Coq_is_total.


Section Session1_2021_Induction_Exercice_3.

(* Déclaration d’un domaine pour les éléments des listes *)
Variable A : Set.

(* Définition du type inductif représentant les entiers naturels *)
Inductive naturel : Set :=
  Zero : naturel
  | Succ : naturel -> naturel.

(* Déclaration du nom de la fonction somme *)
Variable somme_spec : naturel -> naturel -> naturel.

(* Spécification du comportement de somme pour Zero en premier paramètre *)
Axiom somme_Zero : forall (n : naturel), (somme_spec Zero n) = n.

(* Spécification du comportement de somme pour Succ en premier paramètre *)
Axiom somme_Succ : forall (n m : naturel), (somme_spec (Succ n) m) = (Succ (somme_spec n m)).

(* Preuve du comportement de somme pour Zero en second paramètre *)
Theorem somme_Zero_droite : forall (v : naturel), (somme_spec v Zero) = v.
Proof.
intro v.
induction v.
rewrite somme_Zero.
reflexivity.
rewrite somme_Succ.
rewrite IHv.
reflexivity.
Qed.

(* Preuve du comportement de somme pour Succ en second paramètre *)
Theorem somme_Succ_droite : forall (m n : naturel), (somme_spec m (Succ n)) =  Succ (somme_spec m n).
Proof.
intro m.
intro n.
induction m.
rewrite !somme_Zero.
reflexivity.
rewrite !somme_Succ.
rewrite IHm.
reflexivity.
Qed.

(* Preuve que somme est commutative *)
Theorem somme_commutative : forall (v1 v2 : naturel), (somme_spec v1 v2) = (somme_spec v2 v1).
Proof.
intro v1.
intro v2.
induction v1.
rewrite !somme_Zero_droite.
rewrite !somme_Zero.
reflexivity.
rewrite !somme_Succ_droite.
rewrite !somme_Succ.
rewrite IHv1.
reflexivity.
Qed.

(* Implantation de la fonction somme *)
Fixpoint somme_impl (v1 v2 : naturel) {struct v1} : naturel :=
  match v1 with
  | Zero => v2
  | Succ n => Succ (somme_impl n v2)
end.

(* Preuve que l'implantation de la fonction somme est correcte *)
Theorem somme_correcte : forall (v1 v2 : naturel),
   (somme_spec v1 v2) = (somme_impl v1 v2).
Proof.
intros v1 v2.
induction v1.
simpl.
rewrite somme_Zero.
reflexivity.
simpl.
rewrite somme_Succ.
rewrite IHv1.
reflexivity.
Qed.

End Session1_2021_Induction_Exercice_3.


From mathcomp Require Import ssreflect.
Require Import Classical.
Require Import Coq.Program.Basics.
Require Import Coq.Logic.Description.
Require Import Coq.Logic.ClassicalDescription.
Require Import Coq.Logic.FunctionalExtensionality.
Require Import Coq.Sets.Finite_sets_facts.
Require Import Coq.Sets.Image.
Require Import Coq.Arith.Plus.
Require Import Coq.Arith.Minus.
Require Import Coq.Arith.Mult.
Require Import Coq.Arith.PeanoNat.
Require Import Coq.Arith.Le.

Definition Injective {A B : Type} (f : A -> B) := forall x y, f x = f y -> x = y.

Definition Surjective {A B : Type} (f : A -> B) := forall y, exists x, f x = y.

Definition Bijective {A B : Type} (f : A -> B) := exists (g : B -> A), (forall x, g (f x) = x) /\ (forall y, f (g y) = y).

Lemma InjSurjBij : forall (A B : Type) (f : A -> B), Injective f -> Surjective f -> Bijective f.
Proof.
move=> A B f H1 H2.
suff: (forall (b : B), {a : A | f a = b}).
move=> H3.
exists (fun (b : B) => proj1_sig (H3 b)).
apply conj.
move=> x.
apply (H1 (proj1_sig (H3 (f x))) x).
apply (proj2_sig (H3 (f x))).
move=> y.
apply (proj2_sig (H3 y)).
move=> b.
apply (constructive_definite_description (fun (a : A) => f a = b)).
apply (proj1 (unique_existence (fun (a : A) => f a = b))).
apply conj.
apply (H2 b).
move=> a1 a2 H3 H4.
apply (H1 a1 a2).
rewrite H4.
apply H3.
Qed.

Lemma BijInj : forall (A B : Type) (f : A -> B), Bijective f -> Injective f.
Proof.
move=> A B f.
elim.
move=> g H1 a1 a2 H2.
rewrite - (proj1 H1 a1).
rewrite - (proj1 H1 a2).
rewrite H2.
reflexivity.
Qed.

Lemma BijSurj : forall (A B : Type) (f : A -> B), Bijective f -> Surjective f.
Proof.
move=> A B f.
elim.
move=> g H1 b.
exists (g b).
apply (proj2 H1 b).
Qed.

Lemma BijChain : forall (A B C : Type) (f : A -> B) (g : B -> C), Bijective f -> Bijective g -> Bijective (compose g f).
Proof.
move=> A B C f g.
elim.
move=> fi H1.
elim.
move=> gi H2.
exists (fun (c : C) => fi (gi c)).
apply conj.
move=> a.
rewrite (proj1 H2 (f a)).
apply (proj1 H1 a).
move=> c.
unfold compose.
rewrite (proj2 H1 (gi c)).
apply (proj2 H2 c).
Qed.

Lemma SurjChain : forall (A B C : Type) (f : A -> B) (g : B -> C), Surjective f -> Surjective g -> Surjective (compose g f).
Proof.
move=> A B C f g H1 H2 c.
elim (H2 c).
move=> b H3.
elim (H1 b).
move=> a H4.
exists a.
unfold compose.
rewrite H4.
apply H3.
Qed.

Lemma InjChain : forall (A B C : Type) (f : A -> B) (g : B -> C), Injective f -> Injective g -> Injective (compose g f).
Proof.
move=> A B C f g H1 H2 a1 a2 H3.
apply (H1 a1 a2).
apply (H2 (f a1) (f a2) H3).
Qed.

Lemma ChainSurj : forall (A B C : Type) (f : A -> B) (g : B -> C), Surjective (compose g f) -> Surjective g.
Proof.
move=> A B C f g H1 c.
elim (H1 c).
move=> a H2.
exists (f a).
apply H2.
Qed.

Lemma ChainInj : forall (A B C : Type) (f : A -> B) (g : B -> C), Injective (compose g f) -> Injective f.
Proof.
move=> A B C f g H1 a1 a2 H2.
apply (H1 a1 a2).
unfold compose.
rewrite H2.
reflexivity.
Qed.

Lemma InvUnique : forall (A B : Type) (f : A -> B) (g1 g2 : B -> A), ((forall x, g1 (f x) = x) /\ (forall y, f (g1 y) = y)) -> ((forall x, g2 (f x) = x) /\ (forall y, f (g2 y) = y)) -> g1 = g2.
Proof.
move=> A B f g1 g2 H1 H2.
apply functional_extensionality.
move=> x.
apply (BijInj A B f).
exists g1.
apply H1.
rewrite (proj2 H2 x).
apply (proj2 H1 x).
Qed.

Lemma BijectiveInvExist : forall (A B : Type) (f : A -> B), Bijective f -> {g : B -> A | (forall x, g (f x) = x) /\ (forall y, f (g y) = y)}.
Proof.
move=> A B f H1.
apply constructive_definite_description.
apply (proj1 (unique_existence (fun (g : B -> A) => (forall x, g (f x) = x) /\ (forall y, f (g y) = y)))).
apply conj.
elim H1.
move=> g H2.
exists g.
apply H2.
move=> g1 g2 H2 H3.
apply (InvUnique A B f g1 g2 H2 H3).
Qed.

Lemma sig_map : forall {T : Type} (P : T -> Prop) (x : {x : T | P x}) (y : {x : T | P x}), proj1_sig x = proj1_sig y -> x = y.
Proof.
move=> A P x y.
case x.
move=> xv xp.
case y.
move=> yv yp .
simpl.
move=> H1.
subst xv.
rewrite (proof_irrelevance (P yv) yp xp).
by [].
Qed.

Lemma CardinalSigSame : forall (T : Type) (A : Ensemble T) (n : nat), (cardinal T A n) <-> (cardinal {t : T | A t} (Full_set {t : T | A t}) n).
Proof.
suff: (forall (n : nat) (T : Type) (A : Ensemble T) (B : Ensemble T), cardinal T (Intersection T A B) n <-> cardinal {t : T | A t} (fun (x : {t : T | A t}) => B (proj1_sig x)) n).
move=> H1 T A n.
suff: (A = Intersection T A (Full_set T)).
move=> H2.
rewrite {1} H2.
suff: ((Full_set {t : T | A t}) = (fun x : {t : T | A t} => (Full_set T) (proj1_sig x))).
move=> H3.
rewrite H3.
apply (H1 n T A (Full_set T)).
apply Extensionality_Ensembles.
apply conj.
move=> a H3.
apply (Full_intro T (proj1_sig a)).
move=> t H3.
apply (Full_intro {t0 : T | A t0} t).
apply Extensionality_Ensembles.
apply conj.
move=> a H2.
apply (Intersection_intro T A (Full_set T) a H2 (Full_intro T a)).
move=> a.
elim.
move=> a0 H2 H3.
apply H2.
elim.
move=> T A B.
apply conj.
move=> H1.
suff: ((fun x : {t : T | A t} => B (proj1_sig x)) = Empty_set {t : T | A t}).
move=> H2.
rewrite H2.
apply (card_empty {t : T | A t}).
apply Extensionality_Ensembles.
apply conj.
move=> t H2.
apply False_ind.
suff: (In T (Empty_set T) (proj1_sig t)).
elim.
rewrite - (cardinal_invert T (Intersection T A B) 0 H1).
apply (Intersection_intro T A B (proj1_sig t)).
apply (proj2_sig t).
apply H2.
move=> x.
elim.
move=> H1.
suff: (Intersection T A B = Empty_set T).
move=> H2.
rewrite H2.
apply (card_empty T).
apply Extensionality_Ensembles.
apply conj.
move=> t.
elim.
move=> t0 H2 H3.
apply False_ind.
suff: (In {t : T | A t} (Empty_set {t : T | A t}) (exist A t0 H2)).
elim.
rewrite - (cardinal_elim {t : T | A t} (fun x : {t : T | A t} => B (proj1_sig x)) 0 H1).
apply H3.
move=> t.
elim.
move=> n H1 T A B.
apply conj.
move=> H2.
elim (cardinal_invert T (Intersection T A B) (S n) H2).
move=> B0.
elim.
move=> b H3.
suff: (In T A b).
move=> H4.
suff: ((fun x : {t : T | A t} => B (proj1_sig x)) = Add {t : T | A t} (fun x : {t : T | A t} => (fun t : T => B t /\ t <> b) (proj1_sig x)) (exist A b H4)).
move=> H5.
rewrite H5.
suff: (cardinal {t : T | A t} (fun x : {t : T | A t} => B (proj1_sig x) /\ proj1_sig x <> b) n).
move=> H6.
apply (card_add {t : T | A t} (fun x : {t : T | A t} => B (proj1_sig x) /\ proj1_sig x <> b) n H6 (exist A b H4)).
move=> H7.
apply (proj2 H7).
reflexivity.
apply (proj1 (H1 T A (fun t : T => B t /\ t <> b))).
suff: (Intersection T A (fun t : T => B t /\ t <> b) = B0).
move=> H6.
rewrite H6.
apply (proj2 (proj2 H3)).
apply Extensionality_Ensembles.
apply conj.
move=> t.
elim.
move=> t0 H6 H7.
suff: (In T (Intersection T A B) t0).
rewrite (proj1 H3).
move=> H8.
suff: (t0 <> b).
elim H8.
move=> t1 H9 H10.
apply H9.
move=> t1.
elim.
move=> H9.
apply False_ind.
apply H9.
reflexivity.
apply (proj2 H7).
apply (Intersection_intro T A B t0 H6 (proj1 H7)).
move=> t H6.
apply (Intersection_intro T A (fun t : T => B t /\ t <> b) t).
suff: (In T (Intersection T A B) t).
elim.
move=> t0 H7 H8.
apply H7.
rewrite (proj1 H3).
left.
apply H6.
apply conj.
suff: (In T (Intersection T A B) t).
elim.
move=> t0 H7 H8.
apply H8.
rewrite (proj1 H3).
left.
apply H6.
move=> H7.
apply (proj1 (proj2 H3)).
rewrite - H7.
apply H6.
apply Extensionality_Ensembles.
apply conj.
move=> t H5.
elim (classic (proj1_sig t = b)).
move=> H6.
right.
suff: (t = exist A b H4).
move=> H7.
rewrite H7.
apply (In_singleton {t0 : T | A t0} (exist A b H4)).
apply sig_map.
apply H6.
move=> H6.
left.
apply conj.
apply H5.
apply H6.
move=> t.
elim.
move=> t0 H5.
apply (proj1 H5).
move=> t0 H5.
unfold In.
suff: (In T (Intersection T A B) (proj1_sig t0)).
elim.
move=> t1 H6 H7.
apply H7.
rewrite (proj1 H3).
elim H5.
right.
apply (In_singleton T b).
suff: (In T (Intersection T A B) b).
elim.
move=> t H4 H5.
apply H4.
rewrite (proj1 H3).
right.
apply (In_singleton T b).
move=> H2.
elim (cardinal_invert {t : T | A t} (fun x : {t : T | A t} => B (proj1_sig x)) (S n) H2).
move=> B0.
elim.
move=> b H3.
suff: (Intersection T A B = Add T (Intersection T A (fun (t : T) => exists (H : A t), B0 (exist A t H))) (proj1_sig b)).
move=> H4.
rewrite H4.
suff: (cardinal T (Intersection T A (fun t : T => exists H : A t, B0 (exist A t H))) n).
move=> H5.
apply (card_add T (Intersection T A (fun t : T => exists H : A t, B0 (exist A t H))) n H5 (proj1_sig b)).
move=> H6.
suff: (forall (H : A (proj1_sig b)), ~ B0 (exist A (proj1_sig b) H)).
elim H6.
move=> t H7 H8 H9.
elim H8.
move=> H10 H11.
apply (H9 H10 H11).
move=> H7 H8.
apply (proj1 (proj2 H3)).
suff: (b = (exist A (proj1_sig b) H7)).
move=> H9.
rewrite H9.
apply H8.
apply sig_map.
reflexivity.
apply (proj2 (H1 T A (fun t : T => exists H : A t, B0 (exist A t H)))).
suff: ((fun x : {t : T | A t} => exists H : A (proj1_sig x), B0 (exist A (proj1_sig x) H)) = B0).
move=> H5.
rewrite H5.
apply (proj2 (proj2 H3)).
apply Extensionality_Ensembles.
apply conj.
move=> t.
elim.
move=> H5 H6.
suff: (t = (exist A (proj1_sig t) H5)).
move=> H7.
rewrite H7.
apply H6.
apply sig_map.
reflexivity.
move=> t H5.
exists (proj2_sig t).
suff: ((exist A (proj1_sig t) (proj2_sig t)) = t).
move=> H6.
rewrite H6.
apply H5.
apply sig_map.
reflexivity.
apply Extensionality_Ensembles.
apply conj.
move=> t H4.
elim (classic (t = proj1_sig b)).
move=> H5.
right.
rewrite H5.
apply (In_singleton T (proj1_sig b)).
move=> H5.
left.
suff: (t <> proj1_sig b).
elim H4.
move=> t0 H6 H7 H8.
apply (Intersection_intro T A (fun t1 : T => exists H : A t1, B0 (exist A t1 H)) t0 H6).
exists H6.
suff: (~ In {t : T | A t} (Singleton {t : T | A t} b) (exist A t0 H6)).
suff: (In {t : T | A t} (fun x : {t : T | A t} => B (proj1_sig x)) (exist A t0 H6)).
rewrite (proj1 H3).
elim.
move=> t1 H9 H10.
apply H9.
move=> t1 H9 H10.
apply False_ind.
apply (H10 H9).
apply H7.
move=> H9.
apply H8.
suff: (exist A t0 H6 = b).
move=> H10.
rewrite - H10.
reflexivity.
elim H9.
reflexivity.
apply H5.
move=> t.
elim.
move=> t0.
elim.
move=> t1 H4 H5.
apply (Intersection_intro T A B t1 H4).
elim H5.
move=> H6 H7.
suff: (In {t : T | A t} (fun x : {t : T | A t} => B (proj1_sig x)) (exist A t1 H6)).
apply.
rewrite (proj1 H3).
left.
apply H7.
move=> t0.
elim.
apply (Intersection_intro T A B (proj1_sig b)).
apply (proj2_sig b).
suff: (In {t : T | A t} (fun x : {t : T | A t} => B (proj1_sig x)) b).
apply.
rewrite (proj1 H3).
right.
apply (In_singleton {t : T | A t} b).
Qed.

Lemma FiniteSigSame : forall (T : Type) (A : Ensemble T), (Finite T A) <-> (Finite {t : T | A t} (Full_set {t : T | A t})).
Proof.
move=> T A.
apply conj.
move=> H1.
elim (finite_cardinal T A H1).
move=> n H2.
apply (cardinal_finite {t : T | A t} (Full_set {t : T | A t}) n).
apply (proj1 (CardinalSigSame T A n) H2).
move=> H1.
elim (finite_cardinal {t : T | A t} (Full_set {t : T | A t}) H1).
move=> n H2.
apply (cardinal_finite T A n).
apply (proj2 (CardinalSigSame T A n) H2).
Qed.

Lemma CountCardinalBijective : forall (T : Type) (N : nat), (exists (f : {n : nat | n < N} -> T), Bijective f) <-> cardinal T (Full_set T) N.
Proof.
move=> T N.
apply conj.
elim.
move=> f H1.
suff: (forall (k : nat), (k <= N) -> cardinal T (fun (t : T) => exists (m : {n : nat | n < N}), proj1_sig m < k /\ t = f m) k).
move=> H2.
suff: (Full_set T = (fun t : T => exists m : {n : nat | n < N}, proj1_sig m < N /\ t = f m)).
move=> H3.
rewrite H3.
apply (H2 N (le_n N)).
apply Extensionality_Ensembles.
apply conj.
move=> t H3.
elim (BijSurj {n : nat | n < N} T f H1 t).
move=> m H4.
exists m.
apply conj.
apply (proj2_sig m).
rewrite H4.
reflexivity.
move=> t H3.
apply (Full_intro T t).
elim.
move=> H2.
suff: ((fun t : T => exists m : {n : nat | n < N}, proj1_sig m < 0 /\ t = f m) = Empty_set T).
move=> H3.
rewrite H3.
apply (card_empty T).
apply Extensionality_Ensembles.
apply conj.
move=> t.
elim.
move=> m H3.
apply False_ind.
apply (le_not_lt O (proj1_sig m)).
apply (le_0_n (proj1_sig m)).
apply (proj1 H3).
move=> t.
elim.
move=> k H2 H3.
suff: ((fun t : T => exists m : {n : nat | n < N}, proj1_sig m < S k /\ t = f m) = Add T (fun t : T => exists m : {n : nat | n < N}, proj1_sig m < k /\ t = f m) (f (exist (fun n : nat => n < N) k H3))).
move=> H4.
rewrite H4.
suff: (k <= N).
move=> H5.
apply (card_add T (fun t : T => exists m : {n : nat | n < N}, proj1_sig m < k /\ t = f m) k (H2 H5) (f (exist (fun n : nat => n < N) k H3))).
elim.
move=> m H6.
apply (le_not_lt k k (le_n k)).
suff: (k = proj1_sig (exist (fun n : nat => n < N) k H3)).
move=> H7.
rewrite {1} H7.
suff: ((exist (fun n : nat => n < N) k H3) = m).
move=> H8.
rewrite H8.
apply (proj1 H6).
apply (BijInj {n : nat | n < N} T f H1 (exist (fun n : nat => n < N) k H3) m).
apply (proj2 H6).
reflexivity.
apply (le_trans k (S k) N (le_S k k (le_n k)) H3).
apply Extensionality_Ensembles.
apply conj.
move=> t.
elim.
move=> m H4.
elim (le_lt_or_eq (proj1_sig m) k).
move=> H5.
left.
exists m.
apply conj.
apply H5.
apply (proj2 H4).
move=> H5.
right.
suff: ((exist (fun n : nat => n < N) k H3) = m).
move=> H6.
rewrite H6.
rewrite (proj2 H4).
apply (In_singleton T (f m)).
apply sig_map.
rewrite H5.
reflexivity.
apply (le_S_n (proj1_sig m) k (proj1 H4)).
move=> t.
elim.
move=> t0.
elim.
move=> m H4.
exists m.
apply conj.
apply (le_S (S (proj1_sig m)) k (proj1 H4)).
apply (proj2 H4).
move=> t0.
elim.
exists (exist (fun n : nat => n < N) k H3).
apply conj.
apply (le_n (S k)).
reflexivity.
move=> H1.
suff: (forall (m : nat) (A : Ensemble T), cardinal T A m -> exists f : {n : nat | n < m} -> {t : T | A t}, Bijective f).
move=> H2.
elim (H2 N (Full_set T) H1).
move=> f H3.
exists (fun m : {n : nat | n < N} => proj1_sig (f m)).
apply (BijChain {n : nat | n < N} {t : T | Full_set T t} T f).
apply H3.
exists (fun t : T => (exist (Full_set T) t (Full_intro T t))).
apply conj.
move=> t0.
apply sig_map.
reflexivity.
move=> y.
reflexivity.
elim.
move=> A H2.
rewrite (cardinal_elim T A 0 H2).
suff: (forall (n : nat), n < 0 -> False).
move=> H3.
exists (fun m : {n : nat | n < 0} => match (H3 (proj1_sig m) (proj2_sig m)) with
end).
exists (fun t0 : {t : T | Empty_set T t} => match (proj2_sig t0) with
end).
apply conj.
move=> m.
apply False_ind.
apply (H3 (proj1_sig m) (proj2_sig m)).
move=> t0.
elim (proj2_sig t0).
move=> n.
apply (le_not_lt 0 n (le_0_n n)).
move=> k H2 A H3.
elim (cardinal_invert T A (S k) H3).
move=> A0.
elim.
move=> a H4.
elim (H2 A0 (proj2 (proj2 H4))).
move=> f H5.
suff: (In T A a).
move=> H6.
suff: (forall (a0 : T), In T A0 a0 -> In T A a0).
move=> H7.
exists (fun m : {n : nat | n < S k} => match excluded_middle_informative (proj1_sig m < k) with
  | left H => exist A (proj1_sig (f (exist (fun n : nat => n < k) (proj1_sig m) H))) (H7 (proj1_sig (f (exist (fun n : nat => n < k) (proj1_sig m) H))) (proj2_sig (f (exist (fun n : nat => n < k) (proj1_sig m) H))))
  | right _ => exist A a H6
end).
apply InjSurjBij.
move=> m1 m2.
elim (excluded_middle_informative (proj1_sig m1 < k)).
move=> H8.
elim (excluded_middle_informative (proj1_sig m2 < k)).
move=> H9 H10.
apply sig_map.
suff: ((exist (fun n : nat => n < k) (proj1_sig m1) H8) = (exist (fun n : nat => n < k) (proj1_sig m2) H9)).
move=> H11.
suff: (proj1_sig m1 = proj1_sig (exist (fun n : nat => n < k) (proj1_sig m1) H8)).
move=> H12.
rewrite H12.
rewrite H11.
reflexivity.
reflexivity.
suff: (f (exist (fun n : nat => n < k) (proj1_sig m1) H8) = f (exist (fun n : nat => n < k) (proj1_sig m2) H9)).
move=> H11.
elim H5.
move=> g H12.
rewrite - (proj1 H12 (exist (fun n : nat => n < k) (proj1_sig m1) H8)).
rewrite H11.
apply (proj1 H12 (exist (fun n : nat => n < k) (proj1_sig m2) H9)).
apply sig_map.
suff: (proj1_sig (f (exist (fun n : nat => n < k) (proj1_sig m1) H8)) = proj1_sig (exist A (proj1_sig (f (exist (fun n : nat => n < k) (proj1_sig m1) H8))) (H7 (proj1_sig (f (exist (fun n : nat => n < k) (proj1_sig m1) H8))) (proj2_sig (f (exist (fun n : nat => n < k) (proj1_sig m1) H8)))))).
move=> H11.
rewrite H11.
rewrite H10.
reflexivity.
reflexivity.
move=> H9 H10.
apply False_ind.
apply (proj1 (proj2 H4)).
suff: (In T A0 (proj1_sig (exist A a H6))).
apply.
rewrite - H10.
simpl.
apply (proj2_sig (f (exist (fun n : nat => n < k) (proj1_sig m1) H8))).
move=> H8.
elim (excluded_middle_informative (proj1_sig m2 < k)).
move=> H9 H10.
apply False_ind.
apply (proj1 (proj2 H4)).
suff: (In T A0 (proj1_sig (exist A a H6))).
apply.
rewrite H10.
simpl.
apply (proj2_sig (f (exist (fun n : nat => n < k) (proj1_sig m2) H9))).
move=> H9 H10.
apply sig_map.
elim (le_lt_or_eq (proj1_sig m1) k).
move=> H11.
elim (H8 H11).
move=> H11.
elim (le_lt_or_eq (proj1_sig m2) k).
move=> H12.
elim (H9 H12).
move=> H12.
rewrite H12.
apply H11.
apply (le_S_n (proj1_sig m2) k (proj2_sig m2)).
apply (le_S_n (proj1_sig m1) k (proj2_sig m1)).
move=> a0.
suff: (In T (Add T A0 a) (proj1_sig a0)).
move=> H8.
suff: (exists m : {n : nat | n < S k}, proj1_sig match excluded_middle_informative (proj1_sig m < k) with
  | left H => exist A (proj1_sig (f (exist (fun n : nat => n < k) (proj1_sig m) H))) (H7 (proj1_sig (f (exist (fun n : nat => n < k) (proj1_sig m) H))) (proj2_sig (f (exist (fun n : nat => n < k) (proj1_sig m) H))))
  | right _ => exist A a H6
end = proj1_sig a0).
elim.
move=> m H9.
exists m.
apply sig_map.
apply H9.
elim H8.
move=> t H9.
elim H5.
move=> g H10.
suff: (forall (n : nat), n < k -> n < S k).
move=> H11.
exists (exist (fun n : nat => n < S k) (proj1_sig (g (exist A0 t H9))) (H11 (proj1_sig (g (exist A0 t H9))) (proj2_sig (g (exist A0 t H9))))).
elim (excluded_middle_informative (proj1_sig (exist (fun n : nat => n < S k) (proj1_sig (g (exist A0 t H9))) (H11 (proj1_sig (g (exist A0 t H9))) (proj2_sig (g (exist A0 t H9))))) < k)).
simpl.
move=> H12.
suff: ((exist (fun n : nat => n < k) (proj1_sig (g (exist A0 t H9))) H12) = (g (exist A0 t H9))).
move=> H13.
rewrite H13.
rewrite (proj2 H10 (exist A0 t H9)).
reflexivity.
apply sig_map.
reflexivity.
move=> H12.
apply False_ind.
apply H12.
simpl.
apply (proj2_sig (g (exist A0 t H9))).
move=> n H11.
apply (le_S (S n) k H11).
move=> t.
elim.
exists (exist (fun m : nat => m < S k) k (le_n (S k))).
elim (excluded_middle_informative (proj1_sig (exist (fun m : nat => m < S k) k (le_n (S k))) < k)).
simpl.
move=> H9.
apply False_ind.
apply (le_not_lt k k (le_n k) H9).
move=> H9.
reflexivity.
rewrite - (proj1 H4).
apply (proj2_sig a0).
move=> a0 H7.
rewrite (proj1 H4).
left.
apply H7.
rewrite (proj1 H4).
right.
apply (In_singleton T a).
Qed.

Lemma CountFiniteBijective : forall (T : Type), (exists (N : nat) (f : {n : nat | n < N} -> T), Bijective f) <-> Finite T (Full_set T).
Proof.
move=> T.
apply conj.
elim.
move=> N.
elim.
move=> f H1.
apply (cardinal_finite T (Full_set T) N).
apply (proj1 (CountCardinalBijective T N)).
exists f.
apply H1.
move=> H1.
elim (finite_cardinal T (Full_set T) H1).
move=> N H2.
exists N.
apply (proj2 (CountCardinalBijective T N) H2).
Qed.

Lemma CountCardinalSurjective : forall (T : Type) (N : nat) (f : {n : nat | n < N} -> T), Surjective f -> exists (M : nat), M <= N /\ cardinal T (Full_set T) M.
Proof.
move=> T N f H1.
suff: (forall (k : nat), k <= N -> exists (M : nat), M <= k /\ cardinal T (Im {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < k) f) M).
move=> H2.
suff: (Full_set T = Im {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < N) f).
move=> H3.
rewrite H3.
apply (H2 N (le_n N)).
apply Extensionality_Ensembles.
apply conj.
move=> t H3.
elim (H1 t).
move=> m0 H4.
apply (Im_intro {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < N) f m0).
apply (proj2_sig m0).
rewrite H4.
reflexivity.
move=> t H3.
apply (Full_intro T t).
elim.
move=> H2.
exists O.
apply conj.
apply (le_n O).
suff: (Im {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < 0) f = Empty_set T).
move=> H3.
rewrite H3.
apply (card_empty T).
apply Extensionality_Ensembles.
apply conj.
move=> t.
elim.
move=> m H3.
apply False_ind.
apply (le_not_lt O (proj1_sig m) (le_0_n (proj1_sig m)) H3).
move=> t.
elim.
move=> k H2 H3.
elim (H2 (le_trans k (S k) N (le_S k k (le_n k)) H3)).
move=> M H4.
elim (classic (In T (Im {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < k) f) (f (exist (fun n : nat => n < N) k H3)))).
move=> H5.
exists M.
apply conj.
apply (le_S M k (proj1 H4)).
suff: (Im {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < S k) f = (Im {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < k) f)).
move=> H6.
rewrite H6.
apply (proj2 H4).
apply Extensionality_Ensembles.
apply conj.
move=> t.
elim.
move=> m H6 y H7.
rewrite H7.
elim (le_lt_or_eq (S (proj1_sig m)) (S k) H6).
move=> H8.
apply (Im_intro {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < k) f m).
apply (lt_S_n (proj1_sig m) k H8).
reflexivity.
move=> H8.
suff: (m = (exist (fun n : nat => n < N) k H3)).
move=> H9.
rewrite H9.
apply H5.
apply sig_map.
apply (eq_add_S (proj1_sig m) k H8).
move=> t.
elim.
move=> m H6 y H7.
apply (Im_intro {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < S k) f m).
apply (le_S (S (proj1_sig m)) k H6).
apply H7.
move=> H5.
exists (S M).
apply conj.
apply (le_n_S M k (proj1 H4)).
suff: (Im {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < S k) f = Add T (Im {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < k) f) (f (exist (fun n : nat => n < N) k H3))).
move=> H6.
rewrite H6.
apply (card_add T (Im {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < k) f) M (proj2 H4) (f (exist (fun n : nat => n < N) k H3))).
apply H5.
apply Extensionality_Ensembles.
apply conj.
move=> t.
elim.
move=> m H6 y H7.
elim (le_lt_or_eq (S (proj1_sig m)) (S k) H6).
move=> H8.
left.
apply (Im_intro {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < k) f m).
apply (lt_S_n (proj1_sig m) k H8).
apply H7.
move=> H8.
right.
rewrite H7.
suff: ((exist (fun n : nat => n < N) k H3) = m).
move=> H9.
rewrite H9.
apply (In_singleton T (f m)).
apply sig_map.
apply (eq_add_S k (proj1_sig m)).
rewrite H8.
reflexivity.
move=> t.
elim.
move=> t0.
elim.
move=> m H6 y H7.
apply (Im_intro {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < S k) f m).
apply (le_S (S (proj1_sig m)) k H6).
apply H7.
move=> t0.
elim.
apply (Im_intro {n : nat | n < N} T (fun m : {n : nat | n < N} => proj1_sig m < S k) f (exist (fun n : nat => n < N) k H3)).
apply (le_n (S k)).
reflexivity.
Qed.

Lemma CountFiniteSurjective : forall (T : Type) (N : nat) (f : {n : nat | n < N} -> T), Surjective f -> Finite T (Full_set T).
Proof.
move=> T N f H1.
elim (CountCardinalSurjective T N f H1).
move=> n H2.
apply (cardinal_finite T (Full_set T) n (proj2 H2)).
Qed.

Lemma CountCardinalInjective : forall (T : Type) (N : nat) (f : T -> {n : nat | n < N}), Injective f -> exists (M : nat), M <= N /\ cardinal T (Full_set T) M.
Proof.
move=> T N f H1.
suff: (forall (k : nat), k <= N -> exists (M : nat), M <= k /\ cardinal T (fun t : T => proj1_sig (f t) < k) M).
move=> H2.
suff: (Full_set T = (fun t : T => proj1_sig (f t) < N)).
move=> H3.
rewrite H3.
apply (H2 N (le_n N)).
apply Extensionality_Ensembles.
apply conj.
move=> t H3.
apply (proj2_sig (f t)).
move=> t H3.
apply (Full_intro T t).
elim.
move=> H2.
exists O.
apply conj.
apply (le_n O).
suff: ((fun t : T => proj1_sig (f t) < 0) = Empty_set T).
move=> H3.
rewrite H3.
apply (card_empty T).
apply Extensionality_Ensembles.
apply conj.
move=> t H3.
apply False_ind.
apply (le_not_lt O (proj1_sig (f t)) (le_0_n (proj1_sig (f t))) H3).
move=> t.
elim.
move=> k H2 H3.
elim (H2 (le_trans k (S k) N (le_S k k (le_n k)) H3)).
move=> M H4.
elim (classic (Inhabited T (fun t : T => proj1_sig (f t) = k))).
elim.
move=> t H5.
exists (S M).
apply conj.
apply (le_n_S M k (proj1 H4)).
suff: ((fun t0 : T => proj1_sig (f t0) < S k) = Add T (fun t : T => proj1_sig (f t) < k) t).
move=> H6.
rewrite H6.
apply (card_add T (fun t : T => proj1_sig (f t) < k) M (proj2 H4) t).
move=> H7.
apply (lt_not_le (proj1_sig (f t)) k H7).
rewrite H5.
apply (le_n k).
apply Extensionality_Ensembles.
apply conj.
move=> t0 H6.
elim (le_lt_or_eq (S (proj1_sig (f t0))) (S k) H6).
move=> H7.
left.
apply (lt_S_n (proj1_sig (f t0)) k H7).
move=> H7.
right.
suff: (t0 = t).
move=> H8.
rewrite H8.
apply (In_singleton T t).
apply (H1 t0 t).
apply sig_map.
rewrite H5.
apply (eq_add_S (proj1_sig (f t0)) k H7).
move=> t0.
elim.
move=> t1 H6.
apply (le_S (S (proj1_sig (f t1))) k H6).
move=> t1.
elim.
unfold In.
rewrite H5.
apply (le_n (S k)).
move=> H5.
exists M.
apply conj.
apply (le_S M k (proj1 H4)).
suff: ((fun t : T => proj1_sig (f t) < S k) = (fun t : T => proj1_sig (f t) < k)).
move=> H6.
rewrite H6.
apply (proj2 H4).
apply Extensionality_Ensembles.
apply conj.
move=> t H6.
elim (le_lt_or_eq (S (proj1_sig (f t))) (S k) H6).
move=> H7.
apply (lt_S_n (proj1_sig (f t)) k H7).
move=> H7.
apply False_ind.
apply H5.
apply (Inhabited_intro T (fun t : T => proj1_sig (f t) = k) t).
apply (eq_add_S (proj1_sig (f t)) k H7).
move=> t.
apply (le_S (S (proj1_sig (f t))) k).
Qed.

Lemma CountFiniteInjective : forall (T : Type) (N : nat) (f : T -> {n : nat | n < N}), Injective f -> Finite T (Full_set T).
Proof.
move=> T N f H1.
elim (CountCardinalInjective T N f H1).
move=> n H2.
apply (cardinal_finite T (Full_set T) n (proj2 H2)).
Qed.

Lemma CountInjectiveLe : forall (N M : nat) (f : {n : nat | n < N} -> {n : nat | n < M}), Injective f -> N <= M.
Proof.
move=> N M f H1.
elim (CountCardinalInjective {n : nat | n < N} M f H1).
move=> K H2.
suff: (N = K).
move=> H3.
rewrite H3.
apply (proj1 H2).
rewrite (cardinal_is_functional {n : nat | n < N} (Full_set {n : nat | n < N}) K (proj2 H2) (Full_set {n : nat | n < N}) N).
reflexivity.
apply (proj1 (CountCardinalBijective {n : nat | n < N} N)).
exists (fun (m : {n : nat | n < N}) => m).
exists (fun (m : {n : nat | n < N}) => m).
apply conj.
move=> x.
reflexivity.
move=> y.
reflexivity.
reflexivity.
Qed.

Lemma BijectiveSigFull : forall (T : Type) (A : Ensemble T), (forall (t : T), In T A t) -> {f : T -> {t : T | In T A t} | (forall (t : T), t = proj1_sig (f t)) /\ Bijective f}.
Proof.
move=> T A H1.
exists (fun (t : T) => exist A t (H1 t)).
apply conj.
move=> t.
reflexivity.
exists (fun (t0 : {t : T | In T A t}) => proj1_sig t0).
apply conj.
move=> x.
reflexivity.
move=> y.
apply sig_map.
reflexivity.
Qed.

Lemma BijectiveSigFullInv : forall (T : Type) (A : Ensemble T), (forall (t : T), In T A t) -> {f : {t : T | In T A t} -> T | (forall (t0 : {t : T | In T A t}), proj1_sig t0 = f t0) /\ Bijective f}.
Proof.
move=> T A H1.
exists (fun (t0 : {t : T | In T A t}) => proj1_sig t0).
apply conj.
move=> t0.
reflexivity.
exists (fun (t : T) => exist A t (H1 t)).
apply conj.
move=> x.
apply sig_map.
reflexivity.
move=> y.
reflexivity.
Qed.

Lemma BijectiveSameSig : forall (T : Type) (A B : Ensemble T), A = B -> {f : {t : T | In T A t} -> {t : T | In T B t} | (forall (t0 : {t : T | In T A t}), proj1_sig t0 = proj1_sig (f t0)) /\ Bijective f}.
Proof.
move=> T A B H1.
rewrite H1.
exists (fun (t0 : {t : T | In T B t}) => t0).
apply conj.
move=> t0.
reflexivity.
exists (fun (t0 : {t : T | In T B t}) => t0).
apply conj.
move=> x.
reflexivity.
move=> y.
reflexivity.
Qed.

Lemma BijectiveSigSig : forall (T : Type) (A B : Ensemble T), {f : {t : T | In T (Intersection T A B) t} -> {t0 : {t : T | In T A t} | In T B (proj1_sig t0)} | (forall (t0 : {t : T | In T (Intersection T A B) t}), proj1_sig t0 = proj1_sig (proj1_sig (f t0))) /\ Bijective f}.
Proof.
move=> T A B.
suff: (forall (t0 : {t : T | In T (Intersection T A B) t}), In T A (proj1_sig t0)).
move=> H1.
suff: (forall (t0 : {t : T | In T (Intersection T A B) t}), In T B (proj1_sig t0)).
move=> H2.
exists (fun (t0 : {t : T | In T (Intersection T A B) t}) => exist (fun (a : {t : T | In T A t}) => In T B (proj1_sig a)) (exist A (proj1_sig t0) (H1 t0)) (H2 t0)).
apply conj.
move=> t0.
reflexivity.
suff: (forall (x : {t0 : {t : T | In T A t} | In T B (proj1_sig t0)}),In T (Intersection T A B) (proj1_sig (proj1_sig x))).
move=> H3.
exists (fun (x : {t0 : {t : T | In T A t} | In T B (proj1_sig t0)}) => exist (Intersection T A B) (proj1_sig (proj1_sig x)) (H3 x)).
apply conj.
move=> x.
apply sig_map.
reflexivity.
move=> y.
apply sig_map.
apply sig_map.
reflexivity.
move=> x.
apply (Intersection_intro T A B (proj1_sig (proj1_sig x))).
apply (proj2_sig (proj1_sig x)).
apply (proj2_sig x).
move=> t0.
elim (proj2_sig t0).
move=> x H2 H3.
apply H3.
move=> t0.
elim (proj2_sig t0).
move=> x H2 H3.
apply H2.
Qed.

Lemma BijectiveSigSigInv : forall (T : Type) (A B : Ensemble T), {f : {t0 : {t : T | In T A t} | In T B (proj1_sig t0)} -> {t : T | In T (Intersection T A B) t} | (forall (x : {t0 : {t : T | In T A t} | In T B (proj1_sig t0)}), proj1_sig (proj1_sig x) = proj1_sig (f x)) /\ Bijective f}.
Proof.
move=> T A B.
suff: (forall (x : {t0 : {t : T | In T A t} | In T B (proj1_sig t0)}),In T (Intersection T A B) (proj1_sig (proj1_sig x))).
move=> H1.
exists (fun (x : {t0 : {t : T | In T A t} | In T B (proj1_sig t0)}) => exist (Intersection T A B) (proj1_sig (proj1_sig x)) (H1 x)).
apply conj.
move=> x.
reflexivity.
suff: (forall (t0 : {t : T | In T (Intersection T A B) t}), In T A (proj1_sig t0)).
move=> H2.
suff: (forall (t0 : {t : T | In T (Intersection T A B) t}), In T B (proj1_sig t0)).
move=> H3.
exists (fun (t0 : {t : T | In T (Intersection T A B) t}) => exist (fun (a : {t : T | In T A t}) => In T B (proj1_sig a)) (exist A (proj1_sig t0) (H2 t0)) (H3 t0)).
apply conj.
move=> x.
apply sig_map.
apply sig_map.
reflexivity.
move=> y.
apply sig_map.
reflexivity.
move=> t0.
elim (proj2_sig t0).
move=> x H3 H4.
apply H4.
move=> t0.
elim (proj2_sig t0).
move=> x H3 H4.
apply H3.
move=> x.
apply (Intersection_intro T A B (proj1_sig (proj1_sig x))).
apply (proj2_sig (proj1_sig x)).
apply (proj2_sig x).
Qed.

Lemma ForallSavesBijective_dep : forall (T : Type) (A : T -> Type) (B : T -> Type) (F : forall (t : T), (A t) -> (B t)), (forall (t : T), Bijective (F t)) -> Bijective (fun (x : forall (t : T), (A t)) (t0 : T) => (F t0 (x t0))).
Proof.
move=> T A B F H1.
suff: (forall (t : T), {g : (B t) -> (A t) | (forall (x : A t), g ((F t) x) = x) /\ (forall (y : B t), (F t) (g y) = y)}).
move=> H2.
exists (fun (y : forall (t : T), B t) (t0 : T) => proj1_sig (H2 t0) (y t0)).
apply conj.
move=> x.
apply functional_extensionality_dep.
move=> t.
apply (proj1 (proj2_sig (H2 t)) (x t)).
move=> y.
apply functional_extensionality_dep.
move=> t.
apply (proj2 (proj2_sig (H2 t)) (y t)).
move=> t.
apply constructive_definite_description.
apply (proj1 (unique_existence (fun (g : B t -> A t) => (forall (x : A t), g (F t x) = x) /\ (forall y : B t, F t (g y) = y)))).
apply conj.
elim (H1 t).
move=> g H2.
exists g.
apply H2.
move=> g1 g2 H2 H3.
apply functional_extensionality_dep.
move=> y.
rewrite - {1} (proj2 H3 y).
apply (proj1 H2 (g2 y)).
Qed.

Lemma ForallSavesBijective : forall (T A B: Type) (F : T -> A -> B), (forall (t : T), Bijective (F t)) -> Bijective (fun (x : T -> A) (t0 : T) => (F t0 (x t0))).
Proof.
move=> T A B F.
apply (ForallSavesBijective_dep T (fun (t : T) => A) (fun (t : T) => B) F).
Qed.

Lemma ForallSavesInjective_dep : forall (T : Type) (A : T -> Type) (B : T -> Type) (F : forall (t : T), (A t) -> (B t)), (forall (t : T), Injective (F t)) -> Injective (fun (x : forall (t : T), (A t)) (t0 : T) => (F t0 (x t0))).
Proof.
move=> T A B F H1 x1 x2 H2.
apply functional_extensionality_dep.
move=> t.
apply (H1 t (x1 t) (x2 t)).
suff: (F t (x1 t) = let temp := (fun t0 : T => F t0 (x1 t0)) in temp t).
move=> H3.
rewrite H3.
rewrite H2.
reflexivity.
reflexivity.
Qed.

Lemma ForallSavesInjective : forall (T A B: Type) (F : T -> A -> B), (forall (t : T), Injective (F t)) -> Injective (fun (x : T -> A) (t0 : T) => (F t0 (x t0))).
Proof.
move=> T A B F.
apply (ForallSavesInjective_dep T (fun (t : T) => A) (fun (t : T) => B) F).
Qed.

Definition Single := exist (fun (n : nat) => (n < 1)) O (le_n 1).

Lemma SingleSame : forall (v : {n : nat | n < 1}), v = Single.
Proof.
move=> v.
apply sig_map.
rewrite (le_antisym (proj1_sig Single) 0 (le_S_n (proj1_sig Single) 0 (proj2_sig Single)) (le_0_n (proj1_sig Single))).
apply (le_antisym (proj1_sig v) 0 (le_S_n (proj1_sig v) 0 (proj2_sig v)) (le_0_n (proj1_sig v))).
Qed.

Lemma CountReverseSig : forall (N : nat), {f : {n : nat | n < N} -> {n : nat | n < N} | forall (m : {n : nat | n < N}), S (proj1_sig m + proj1_sig (f m)) = N}.
Proof.
move=> N.
suff: (forall (k : {n : nat | n < N}), N - S (proj1_sig k) < N).
move=> H1.
exists (fun (m : {n : nat | n < N}) => (exist (fun (k : nat) => k < N) (N - S (proj1_sig m)) (H1 m))).
move=> m.
simpl.
apply (le_plus_minus_r (S (proj1_sig m)) N (proj2_sig m)).
move=> k.
apply (plus_lt_reg_l (N - S (proj1_sig k)) N (S (proj1_sig k))).
rewrite (le_plus_minus_r (S (proj1_sig k)) N (proj2_sig k)).
apply (le_n_S N (proj1_sig k + N)).
apply (le_plus_r (proj1_sig k) N).
Qed.

Definition CountReverse (N : nat) := proj1_sig (CountReverseSig N).

Definition CountReverseNature (N : nat) : (forall (m : {n : nat | n < N}), S (proj1_sig m + proj1_sig (CountReverse N m)) = N) := proj2_sig (CountReverseSig N).

Lemma CountReverseInvolutive : forall (N : nat) (m : {n : nat | n < N}), CountReverse N (CountReverse N m) = m.
Proof.
move=> N m.
apply sig_map.
apply (plus_reg_l (proj1_sig (CountReverse N (CountReverse N m))) (proj1_sig m) (proj1_sig (CountReverse N m))).
apply eq_add_S.
rewrite (plus_comm (proj1_sig (CountReverse N m)) (proj1_sig m)).
rewrite (CountReverseNature N m).
apply (CountReverseNature N (CountReverse N m)).
Qed.

Lemma AddConnectSig : forall (N M : nat), {f : {n : nat | n < N} + {n : nat | n < M} -> {n : nat | n < N + M} | (forall (m : {n : nat | n < N}), proj1_sig m = proj1_sig (f (inl m))) /\ (forall (m : {n : nat | n < M}), N + proj1_sig m = proj1_sig (f (inr m)))}.
Proof.
move=> N M.
suff: (forall (m : {n : nat | n < N}), proj1_sig m < N + M).
move=> H1.
suff: (forall (m : {n : nat | n < M}), N + proj1_sig m < N + M).
move=> H2.
exists (fun (m : {n : nat | n < N} + {n : nat | n < M}) => match m with
  | inl k => exist (fun (l : nat) => l < N + M) (proj1_sig k) (H1 k)
  | inr k => exist (fun (l : nat) => l < N + M) (N + proj1_sig k) (H2 k)
end).
apply conj.
move=> m.
reflexivity.
move=> m.
reflexivity.
move=> m.
apply (plus_lt_compat_l (proj1_sig m) M N (proj2_sig m)).
move=> m.
apply (le_trans (S (proj1_sig m)) N (N + M) (proj2_sig m) (le_plus_l N M)).
Qed.

Definition AddConnect (N M : nat) := proj1_sig (AddConnectSig N M).

Definition AddConnectNature (N M : nat) : (forall (m : {n : nat | n < N}), proj1_sig m = proj1_sig (AddConnect N M (inl m))) /\ (forall (m : {n : nat | n < M}), N + proj1_sig m = proj1_sig (AddConnect N M (inr m))) := proj2_sig (AddConnectSig N M).

Lemma AddConnectInvSig : forall (N M : nat), {f : {n : nat | n < N + M} -> {n : nat | n < N} + {n : nat | n < M} | (forall (m : {n : nat | n < N + M}), (proj1_sig m < N) -> match (f m) with
  | inl k => proj1_sig m = proj1_sig k
  | inr _ => False
end) /\ (forall (m : {n : nat | n < N + M}), (N <= proj1_sig m) -> match (f m) with
  | inl _ => False
  | inr k => proj1_sig m = N + proj1_sig k
end)}.
Proof.
move=> N M.
suff: (forall (m : {n : nat | n < N + M}), ~ proj1_sig m < N -> proj1_sig m - N < M).
move=> H1.
exists (fun (m : {n : nat | n < N + M}) => match excluded_middle_informative (proj1_sig m < N) with
  | left H => inl (exist (fun (k : nat) => k < N) (proj1_sig m) H)
  | right H => inr (exist (fun (k : nat) => k < M) (proj1_sig m - N) (H1 m H))
end).
apply conj.
move=> m H2.
elim (excluded_middle_informative (proj1_sig m < N)).
move=> H3.
reflexivity.
move=> H3.
apply (H3 H2).
move=> m H2.
elim (excluded_middle_informative (proj1_sig m < N)).
move=> H3.
apply (le_not_lt N (proj1_sig m) H2 H3).
move=> H3.
apply (le_plus_minus N (proj1_sig m) H2).
move=> m H1.
apply (plus_lt_reg_l (proj1_sig m - N) M N).
rewrite (le_plus_minus_r N (proj1_sig m)).
apply (proj2_sig m).
elim (le_or_lt N (proj1_sig m)).
apply.
move=> H2.
apply False_ind.
apply (H1 H2).
Qed.

Definition AddConnectInv (N M : nat) := proj1_sig (AddConnectInvSig N M).

Definition AddConnectInvNature (N M : nat) : (forall (m : {n : nat | n < N + M}), proj1_sig m < N -> match AddConnectInv N M m with
  | inl k => proj1_sig m = proj1_sig k
  | inr _ => False
end) /\ (forall (m : {n : nat | n < N + M}), N <= proj1_sig m -> match AddConnectInv N M m with
  | inl _ => False
  | inr k => proj1_sig m = N + proj1_sig k
end) := proj2_sig (AddConnectInvSig N M).

Lemma AddConnectInvRelation : forall (N M : nat), (forall (m : {n : nat | n < N} + {n : nat | n < M}), AddConnectInv N M (AddConnect N M m) = m) /\ (forall (m : {n : nat | n < N + M}), AddConnect N M (AddConnectInv N M m) = m).
Proof.
move=> N M.
apply conj.
elim.
move=> m.
suff: (match AddConnectInv N M (AddConnect N M (inl m)) return Prop with
  | inl k => proj1_sig (AddConnect N M (inl m)) = proj1_sig k
  | inr _ => False
end).
elim (AddConnectInv N M (AddConnect N M (inl m))).
move=> k H1.
suff: (k = m).
move=> H2.
rewrite H2.
reflexivity.
apply sig_map.
rewrite - H1.
rewrite (proj1 (AddConnectNature N M) m).
reflexivity.
move=> k.
elim.
apply (proj1 (AddConnectInvNature N M) (AddConnect N M (inl m))).
rewrite - (proj1 (AddConnectNature N M) m).
apply (proj2_sig m).
move=> m.
suff: (match AddConnectInv N M (AddConnect N M (inr m)) return Prop with
  | inl _ => False
  | inr k => proj1_sig (AddConnect N M (inr m)) = N + proj1_sig k
end).
elim (AddConnectInv N M (AddConnect N M (inr m))).
move=> k.
elim.
move=> k H1.
suff: (m = k).
move=> H2.
rewrite H2.
reflexivity.
apply sig_map.
apply (plus_reg_l (proj1_sig m) (proj1_sig k) N).
rewrite (proj2 (AddConnectNature N M) m).
apply H1.
apply (proj2 (AddConnectInvNature N M) (AddConnect N M (inr m))).
rewrite - (proj2 (AddConnectNature N M) m).
apply (le_plus_l N (proj1_sig m)).
move=> m.
elim (le_or_lt N (proj1_sig m)).
move=> H1.
suff: (match AddConnectInv N M m return Prop with
  | inl _ => False
  | inr k => proj1_sig m = N + proj1_sig k
end).
elim (AddConnectInv N M m).
move=> k.
elim.
move=> k H2.
apply sig_map.
rewrite H2.
rewrite (proj2 (AddConnectNature N M) k).
reflexivity.
apply (proj2 (AddConnectInvNature N M) m).
apply H1.
move=> H1.
suff: (match AddConnectInv N M m return Prop with
  | inl k => proj1_sig m = proj1_sig k
  | inr _ => False
end).
elim (AddConnectInv N M m).
move=> k H2.
apply sig_map.
rewrite H2.
rewrite (proj1 (AddConnectNature N M) k).
reflexivity.
move=> k.
elim.
apply (proj1 (AddConnectInvNature N M) m).
apply H1.
Qed.

Lemma CountAdd : forall (N M : nat), {f : {n : nat | n < N} + {n : nat | n < M} -> {n : nat | n < N + M} | Bijective f}.
Proof.
move=> N M.
exists (AddConnect N M).
exists (AddConnectInv N M).
apply (AddConnectInvRelation N M).
Qed.

Lemma MultConnectSig : forall (N M : nat), {f : {n : nat | n < N} * {n : nat | n < M} -> {n : nat | n < N * M} | forall (m : {n : nat | n < N} * {n : nat | n < M}), proj1_sig (f m) = proj1_sig (fst m) * M + proj1_sig (snd m)}.
Proof.
elim.
move=> M.
exists (fun (xy : {n : nat | n < 0} * {n : nat | n < M}) => match (PeanoNat.Nat.nlt_0_r (proj1_sig (fst xy)) (proj2_sig (fst xy))) with
end).
move=> m.
elim (PeanoNat.Nat.nlt_0_r (proj1_sig (fst m)) (proj2_sig (fst m))).
move=> N H1 M.
exists (compose (AddConnect M (N * M)) (fun (m : {n : nat | n < S N} * {n : nat | n < M}) => match AddConnectInv 1 N (fst m) with
  | inl _ => inl (snd m)
  | inr a => inr (proj1_sig (H1 M) (a, snd m))
end)).
move=> m.
unfold compose.
rewrite - {2} (proj2 (AddConnectInvRelation 1 N) (fst m)).
elim (AddConnectInv 1 N (fst m)).
move=> a.
rewrite - (proj1 (AddConnectNature 1 N) a).
rewrite (SingleSame a).
rewrite - (proj1 (AddConnectNature M (N * M)) (snd m)).
reflexivity.
move=> b.
rewrite - (proj2 (AddConnectNature M (N * M))).
rewrite - (proj2 (AddConnectNature 1 N)).
rewrite (proj2_sig (H1 M)).
simpl.
apply plus_assoc.
Qed.

Definition MultConnect (N M : nat) := proj1_sig (MultConnectSig N M).

Definition MultConnectNature (N M : nat) : forall (m : {n : nat | n < N} * {n : nat | n < M}), proj1_sig (MultConnect N M m) = proj1_sig (fst m) * M + proj1_sig (snd m) := proj2_sig (MultConnectSig N M).

Lemma MultConnectInvSig : forall (N M : nat), {f : {n : nat | n < N * M} -> {n : nat | n < N} * {n : nat | n < M} | forall (m : {n : nat | n < N * M}), proj1_sig m = proj1_sig (fst (f m)) * M + proj1_sig (snd (f m))}.
Proof.
elim.
move=> M.
rewrite (mult_0_l M).
exists (fun (x : {n : nat | n < 0}) => match (PeanoNat.Nat.nlt_0_r (proj1_sig x) (proj2_sig x)) with
end).
move=> x.
elim (PeanoNat.Nat.nlt_0_r (proj1_sig x) (proj2_sig x)).
move=> N H1 M.
exists (compose (fun (m : {n : nat | n < M} + {n : nat | n < N * M}) => match m with
  | inl a => (AddConnect 1 N (inl Single), a)
  | inr b => (AddConnect 1 N (inr (fst (proj1_sig (H1 M) b))), snd (proj1_sig (H1 M) b))
end) (AddConnectInv M (N * M))).
move=> m.
unfold compose.
rewrite - {1} (proj2 (AddConnectInvRelation M (N * M)) m).
elim (AddConnectInv M (N * M) m).
move=> a.
simpl.
rewrite - (proj1 (AddConnectNature M (N * M)) a).
rewrite - (proj1 (AddConnectNature 1 N) Single).
reflexivity.
move=> b.
simpl.
rewrite - (proj2 (AddConnectNature M (N * M)) b).
rewrite - (proj2 (AddConnectNature 1 N)).
rewrite (proj2_sig (H1 M) b).
rewrite plus_assoc.
reflexivity.
Qed.

Definition MultConnectInv (N M : nat) := proj1_sig (MultConnectInvSig N M).

Definition MultConnectInvNature (N M : nat) : forall (m : {n : nat | n < N * M}), proj1_sig m = proj1_sig (fst (MultConnectInv N M m)) * M + proj1_sig (snd (MultConnectInv N M m)) := proj2_sig (MultConnectInvSig N M).

Lemma MultConnectInvRelation : forall (N M : nat), (forall (m : {n : nat | n < N} * {n : nat | n < M}), MultConnectInv N M (MultConnect N M m) = m) /\ (forall (m : {n : nat | n < N * M}), MultConnect N M (MultConnectInv N M m) = m).
Proof.
suff: (forall (N M : nat) (a b : {n : nat | n < N} * {n : nat | n < M}), proj1_sig (fst a) * M + proj1_sig (snd a) = proj1_sig (fst b) * M + proj1_sig (snd b) -> a = b).
move=> H1 N M.
apply conj.
move=> m.
apply (H1 N M).
rewrite - (MultConnectInvNature N M).
apply (MultConnectNature N M m).
move=> m.
apply sig_map.
rewrite (MultConnectNature N M).
rewrite (MultConnectInvNature N M).
reflexivity.
suff: (forall (N M : nat) (a b : {n : nat | n < N} * {n : nat | n < M}), proj1_sig (fst a) * M + proj1_sig (snd a) = proj1_sig (fst b) * M + proj1_sig (snd b) -> proj1_sig (fst a) <= proj1_sig (fst b)).
move=> H1 N M a b H2.
suff: (fst a = fst b).
move=> H3.
apply injective_projections.
apply H3.
apply sig_map.
apply (plus_reg_l (proj1_sig (snd a)) (proj1_sig (snd b)) (proj1_sig (fst a) * M)).
rewrite {2} H3.
apply H2.
apply sig_map.
apply le_antisym.
apply (H1 N M a b H2).
apply (H1 N M b a).
rewrite H2.
reflexivity.
move=> N M a b H1.
elim (le_or_lt (proj1_sig (fst a)) (proj1_sig (fst b))).
apply.
move=> H2.
elim (lt_irrefl (proj1_sig (fst a) * M + proj1_sig (snd a))).
rewrite {1} H1.
apply (le_trans (S (proj1_sig (fst b) * M + proj1_sig (snd b))) (proj1_sig (fst a) * M)).
apply (le_trans (S (proj1_sig (fst b) * M + proj1_sig (snd b))) ((S (proj1_sig (fst b))) * M)).
simpl.
rewrite (plus_comm (proj1_sig (fst b) * M) (proj1_sig (snd b))).
apply (plus_le_compat_r (S (proj1_sig (snd b))) M).
apply (proj2_sig (snd b)).
apply (mult_le_compat_r (S (proj1_sig (fst b))) (proj1_sig (fst a)) M H2).
apply le_plus_l.
Qed.

Lemma CountMult : forall (N M : nat), {f : {n : nat | n < N} * {n : nat | n < M} -> {n : nat | n < N * M} | Bijective f}.
Proof.
move=> N M.
exists (MultConnect N M).
exists (MultConnectInv N M).
apply (MultConnectInvRelation N M).
Qed.

Lemma CountPow : forall (N M : nat), {f : ({n : nat | n < N} -> {n : nat | n < M}) -> {n : nat | n < M ^ N} | Bijective f}.
Proof.
move=> N M.
elim N.
simpl.
exists (fun (_ : {n : nat | n < 0} -> {n : nat | n < M}) => exist (fun (n : nat) => n < S O) O (le_n (S O))).
exists (fun (m : {n : nat | n < S O}) (k : {n : nat | n < O}) => match (PeanoNat.Nat.nlt_0_r (proj1_sig k) (proj2_sig k)) with
end).
apply conj.
move=> x.
apply functional_extensionality.
move=> k.
apply False_ind.
apply (PeanoNat.Nat.nlt_0_r (proj1_sig k) (proj2_sig k)).
move=> y.
apply sig_map.
simpl.
elim (le_lt_or_eq (proj1_sig y) O).
move=> H1.
apply False_ind.
apply (PeanoNat.Nat.nlt_0_r (proj1_sig y) H1).
move=> H1.
rewrite H1.
reflexivity.
apply (le_S_n (proj1_sig y) O (proj2_sig y)).
move=> K.
elim.
move=> f1 H1.
simpl.
suff: ({f : ({n : nat | n < S K} -> {n : nat | n < M}) -> ({n : nat | n < M} * {n : nat | n < M ^ K}) | Bijective f}).
elim.
move=> f2 H2.
exists (compose (proj1_sig (CountMult M (M ^ K))) f2).
apply BijChain.
apply H2.
apply (proj2_sig (CountMult M (M ^ K))).
exists (fun (x : {n : nat | n < S K} -> {n : nat | n < M}) => (x (exist (fun (n : nat) => n < S K) K (le_n (S K))), f1 (fun (m : {n : nat | n < K}) => x (exist (fun (n : nat) => n < S K) (proj1_sig m) (le_trans (S (proj1_sig m)) K (S K) (proj2_sig m) (le_S K K (le_n K))))))).
elim H1.
move=> g1 H2.
exists (fun (x : {n : nat | n < M} * {n : nat | n < M ^ K}) (k : {n : nat | n < S K}) => match excluded_middle_informative (proj1_sig k < K) with
  | left H => g1 (snd x) (exist (fun (n : nat) => n < K) (proj1_sig k) H)
  | right H => fst x
end).
apply conj.
move=> x.
apply functional_extensionality.
move=> k.
elim (excluded_middle_informative (proj1_sig k < K)).
move=> H3.
simpl.
rewrite (proj1 H2 (fun m : {n : nat | n < K} => x (exist (fun n : nat => n < S K) (proj1_sig m) (Nat.le_trans (S (proj1_sig m)) K (S K) (proj2_sig m) (le_S K K (le_n K)))))).
suff: ((exist (fun n : nat => n < S K) (proj1_sig (exist (fun n : nat => n < K) (proj1_sig k) H3)) (Nat.le_trans (S (proj1_sig (exist (fun n : nat => n < K) (proj1_sig k) H3))) K (S K) (proj2_sig (exist (fun n : nat => n < K) (proj1_sig k) H3)) (le_S K K (le_n K)))) = k).
move=> H4.
rewrite H4.
reflexivity.
apply sig_map.
reflexivity.
move=> H3.
suff: ((exist (fun n : nat => n < S K) K (le_n (S K))) = k).
move=> H4.
rewrite H4.
reflexivity.
apply sig_map.
elim (le_lt_or_eq (proj1_sig k) K (le_S_n (proj1_sig k) K (proj2_sig k))).
move=> H4.
apply False_ind.
apply (H3 H4).
move=> H4.
rewrite H4.
reflexivity.
move=> y.
simpl.
elim (excluded_middle_informative (K < K)).
move=> H3.
apply False_ind.
apply (lt_irrefl K H3).
move=> H3.
apply injective_projections.
reflexivity.
apply (BijInj {n : nat | n < M ^ K} ({n : nat | n < K} -> {n : nat | n < M}) g1).
exists f1.
apply conj.
apply (proj2 H2).
apply (proj1 H2).
simpl.
rewrite (proj1 H2 (fun m : {n : nat | n < K} => match excluded_middle_informative (proj1_sig m < K) with
  | left H => g1 (snd y) (exist (fun n : nat => n < K) (proj1_sig m) H)
  | right _ => fst y
end)).
apply functional_extensionality.
move=> k.
elim (excluded_middle_informative (proj1_sig k < K)).
move=> H4.
suff: ((exist (fun n : nat => n < K) (proj1_sig k) H4) = k).
move=> H5.
rewrite H5.
reflexivity.
apply sig_map.
reflexivity.
move=> H4.
apply False_ind.
apply (H4 (proj2_sig k)).
Qed.

Lemma CountPowFinite : forall (N M : nat), Finite ({n : nat | (n < N)%nat} -> {n : nat | (n < M)%nat}) (Full_set ({n : nat | (n < N)%nat} -> {n : nat | (n < M)%nat})).
Proof.
move=> N M.
apply (cardinal_finite ({n : nat | (n < N)%nat} -> {n : nat | (n < M)%nat}) (Full_set ({n : nat | (n < N)%nat} -> {n : nat | (n < M)%nat})) (M ^ N)).
apply (proj1 (CountCardinalBijective ({n : nat | (n < N)%nat} -> {n : nat | (n < M)%nat}) (M ^ N))).
elim (proj2_sig (CountPow N M)).
move=> g H1.
exists g.
exists (proj1_sig (CountPow N M)).
apply conj.
apply (proj2 H1).
apply (proj1 H1).
Qed.

Lemma CountInjBij : forall (N : nat) (f : {n : nat | (n < N)%nat} -> {n : nat | (n < N)%nat}), Injective f -> Bijective f.
Proof.
move=> N f H1.
apply InjSurjBij.
apply H1.
suff: (Im {n : nat | (n < N)%nat} {n : nat | (n < N)%nat} (Full_set {n : nat | (n < N)%nat}) f = (Full_set {n : nat | (n < N)%nat})).
move=> H2 k.
suff: (In {n : nat | (n < N)%nat} (Im {n : nat | (n < N)%nat} {n : nat | (n < N)%nat} (Full_set {n : nat | (n < N)%nat}) f) k).
elim.
move=> x H3 y H4.
exists x.
rewrite H4.
reflexivity.
rewrite H2.
apply (Full_intro {n : nat | (n < N)%nat} k).
suff: (cardinal {n : nat | (n < N)%nat} (Im {n : nat | (n < N)%nat} {n : nat | (n < N)%nat} (Full_set {n : nat | (n < N)%nat}) f) N).
move=> H2.
apply Extensionality_Ensembles.
apply conj.
move=> k H3.
apply (Full_intro {n : nat | (n < N)%nat} k).
move=> k H3.
apply NNPP.
move=> H4.
apply (lt_irrefl N).
apply (incl_card_le {n : nat | (n < N)%nat} (Add {n : nat | (n < N)%nat} (Im {n : nat | (n < N)%nat} {n : nat | (n < N)%nat} (Full_set {n : nat | (n < N)%nat}) f) k) (Full_set {n : nat | (n < N)%nat}) (S N) N).
apply (card_add {n : nat | (n < N)%nat}).
apply H2.
apply H4.
apply CountCardinalBijective.
exists (fun (k : {n : nat | (n < N)%nat}) => k).
exists (fun (k : {n : nat | (n < N)%nat}) => k).
apply conj.
move=> l.
reflexivity.
move=> l.
reflexivity.
move=> l H5.
apply (Full_intro {n : nat | (n < N)%nat} l).
suff: (forall (m : nat), (m <= N)%nat -> cardinal {n : nat | (n < N)%nat} (Im {n : nat | (n < N)%nat} {n : nat | (n < N)%nat} (fun (k : {n : nat | (n < N)%nat}) => (proj1_sig k < m)%nat) f) m).
move=> H2.
suff: ((Full_set {n : nat | (n < N)%nat}) = (fun (k : {n : nat | (n < N)%nat}) => (proj1_sig k < N)%nat)).
move=> H3.
rewrite H3.
apply (H2 N).
apply (le_n N).
apply Extensionality_Ensembles.
apply conj.
move=> k H3.
apply (proj2_sig k).
move=> k H3.
apply (Full_intro {n : nat | (n < N)%nat} k).
elim.
move=> H2.
suff: ((Im {n : nat | (n < N)%nat} {n : nat | (n < N)%nat} (fun (k : {n : nat | (n < N)%nat}) => (proj1_sig k < O)%nat) f) = Empty_set {n : nat | (n < N)%nat}).
move=> H3.
rewrite H3.
apply card_empty.
apply Extensionality_Ensembles.
apply conj.
move=> k.
elim.
move=> x H3.
apply False_ind.
apply (le_not_lt O (proj1_sig x) (le_0_n (proj1_sig x)) H3).
move=> k.
elim.
move=> m H2 H3.
suff: ((Im {n : nat | (n < N)%nat} {n : nat | (n < N)%nat} (fun k : {n : nat | (n < N)%nat} => (proj1_sig k < S m)%nat) f) = Add {n : nat | (n < N)%nat} (Im {n : nat | (n < N)%nat} {n : nat | (n < N)%nat} (fun k : {n : nat | (n < N)%nat} => (proj1_sig k < m)%nat) f) (f (exist (fun (n : nat) => (n < N)%nat) m H3))).
move=> H4.
rewrite H4.
apply card_add.
apply (H2 (le_trans m (S m) N (le_S m m (le_n m)) H3)).
move=> H5.
suff: (forall (k : {n : nat | (n < N)%nat}), (proj1_sig k < m)%nat -> f k <> f (exist (fun n : nat => (n < N)%nat) m H3)).
elim H5.
move=> x H6 y H7 H8.
apply (H8 x H6).
rewrite H7.
reflexivity.
move=> k H6 H7.
apply (lt_irrefl (proj1_sig k)).
suff: (k = (exist (fun n : nat => (n < N)%nat) m H3)).
move=> H8.
rewrite {2} H8.
apply H6.
apply H1.
apply H7.
apply Extensionality_Ensembles.
apply conj.
move=> k.
elim.
move=> x H4 y H5.
rewrite H5.
elim (le_lt_or_eq (proj1_sig x) m).
move=> H6.
left.
apply (Im_intro {n : nat | (n < N)%nat} {n : nat | (n < N)%nat} (fun (k : {n : nat | (n < N)%nat}) => (proj1_sig k < m)%nat) f x H6).
reflexivity.
move=> H6.
right.
suff: (x = (exist (fun n : nat => (n < N)%nat) m H3)).
move=> H7.
rewrite H7.
apply In_singleton.
apply sig_map.
apply H6.
apply le_S_n.
apply H4.
move=> k.
elim.
move=> k0.
elim.
move=> x H4 y H5.
apply (Im_intro {n : nat | (n < N)%nat} {n : nat | (n < N)%nat} (fun (k : {n : nat | (n < N)%nat}) => (proj1_sig k < S m)%nat) f x).
apply (le_trans (S (proj1_sig x)) m (S m) H4 (le_S m m (le_n m))).
apply H5.
move=> x.
elim.
apply (Im_intro {n : nat | (n < N)%nat} {n : nat | (n < N)%nat} (fun (k : {n : nat | (n < N)%nat}) => (proj1_sig k < S m)%nat) f (exist (fun n : nat => (n < N)%nat) m H3)).
apply (le_n (S m)).
reflexivity.
Qed.

Lemma SkipOneSig : forall (N : nat) (m : {n : nat | n < N}), {f : {n : nat | n < pred N} -> {n : nat | n < N} | forall (k : {n : nat | n < pred N}), (proj1_sig k < proj1_sig m -> proj1_sig (f k) = proj1_sig k) /\ (proj1_sig k >= proj1_sig m -> proj1_sig (f k) = S (proj1_sig k))}.
Proof.
elim.
move=> m.
apply constructive_definite_description.
apply False_ind.
apply (le_not_lt 0 (proj1_sig m) (le_0_n (proj1_sig m)) (proj2_sig m)).
move=> k H1 m.
simpl.
suff: (forall (l : {n : nat | n < k}), proj1_sig l < S k).
move=> H2.
suff: (forall (l : {n : nat | n < k}), S (proj1_sig l) < S k).
move=> H3.
exists (fun (l : {n : nat | n < k}) => match excluded_middle_informative (proj1_sig l < proj1_sig m) with
  | left _ => exist (fun (n : nat) => n < S k) (proj1_sig l) (H2 l)
  | right _ => exist (fun (n : nat) => n < S k) (S (proj1_sig l)) (H3 l)
end).
move=> l.
apply conj.
move=> H4.
elim (excluded_middle_informative (proj1_sig l < proj1_sig m)).
move=> H5.
reflexivity.
move=> H5.
apply False_ind.
apply (H5 H4).
move=> H4.
elim (excluded_middle_informative (proj1_sig l < proj1_sig m)).
move=> H5.
apply False_ind.
apply (le_not_lt (proj1_sig m) (proj1_sig l) H4 H5).
move=> H5.
reflexivity.
move=> l.
apply (lt_n_S (proj1_sig l) k (proj2_sig l)).
move=> l.
apply (le_S (S (proj1_sig l)) k (proj2_sig l)).
Qed.

Definition SkipOne (N : nat) (m : {n : nat | n < N}) := proj1_sig (SkipOneSig N m).

Definition SkipOneNature (N : nat) (m : {n : nat | n < N}) : forall (k : {n : nat | n < pred N}), (proj1_sig k < proj1_sig m -> proj1_sig ((SkipOne N m) k) = proj1_sig k) /\ (proj1_sig k >= proj1_sig m -> proj1_sig ((SkipOne N m) k) = S (proj1_sig k)) := proj2_sig (SkipOneSig N m).

Lemma SkipOneInj : forall (N : nat) (m : {n : nat | n < N}), Injective (SkipOne N m).
Proof.
elim.
move=> m.
apply False_ind.
apply (le_not_lt O (proj1_sig m) (le_0_n (proj1_sig m)) (proj2_sig m)).
move=> N H1 m k1 k2 H2.
elim (le_or_lt (proj1_sig m) (proj1_sig k1)).
move=> H3.
elim (le_or_lt (proj1_sig m) (proj1_sig k2)).
move=> H4.
apply sig_map.
apply (Nat.succ_inj (proj1_sig k1) (proj1_sig k2)).
rewrite - (proj2 (SkipOneNature (S N) m k1) H3).
rewrite - (proj2 (SkipOneNature (S N) m k2) H4).
rewrite H2.
reflexivity.
move=> H4.
apply False_ind.
apply (le_not_lt (proj1_sig (SkipOne (S N) m k1)) (proj1_sig (SkipOne (S N) m k2))).
rewrite H2.
apply (le_n (proj1_sig (SkipOne (S N) m k2))).
rewrite (proj1 (SkipOneNature (S N) m k2) H4).
rewrite (proj2 (SkipOneNature (S N) m k1) H3).
apply (lt_trans (proj1_sig k2) (proj1_sig m) (S (proj1_sig k1)) H4).
apply (le_n_S (proj1_sig m) (proj1_sig k1) H3).
move=> H3.
elim (le_or_lt (proj1_sig m) (proj1_sig k2)).
move=> H4.
apply False_ind.
apply (le_not_lt (proj1_sig (SkipOne (S N) m k2)) (proj1_sig (SkipOne (S N) m k1))).
rewrite H2.
apply (le_n (proj1_sig (SkipOne (S N) m k2))).
rewrite (proj1 (SkipOneNature (S N) m k1) H3).
rewrite (proj2 (SkipOneNature (S N) m k2) H4).
apply (lt_trans (proj1_sig k1) (proj1_sig m) (S (proj1_sig k2)) H3).
apply (le_n_S (proj1_sig m) (proj1_sig k2) H4).
move=> H4.
apply sig_map.
rewrite - (proj1 (SkipOneNature (S N) m k1) H3).
rewrite - (proj1 (SkipOneNature (S N) m k2) H4).
rewrite H2.
reflexivity.
Qed.

Lemma SkipOneMonotonicallyIncreasing : forall (N : nat) (m : {n : nat | n < N}) (k1 k2 : {n : nat | n < pred N}), proj1_sig k1 < proj1_sig k2 -> proj1_sig (SkipOne N m k1) < proj1_sig (SkipOne N m k2).
Proof.
elim.
move=> m.
apply False_ind.
apply (le_not_lt O (proj1_sig m) (le_0_n (proj1_sig m)) (proj2_sig m)).
move=> N H1 m k1 k2 H2.
elim (le_or_lt (proj1_sig m) (proj1_sig k1)).
move=> H3.
rewrite (proj2 (SkipOneNature (S N) m k1) H3).
rewrite (proj2 (SkipOneNature (S N) m k2) (le_trans (proj1_sig m) (proj1_sig k1) (proj1_sig k2) H3 (lt_le_weak (proj1_sig k1) (proj1_sig k2) H2))).
apply (le_n_S (S (proj1_sig k1)) (proj1_sig k2) H2).
move=> H3.
rewrite (proj1 (SkipOneNature (S N) m k1) H3).
elim (le_or_lt (proj1_sig m) (proj1_sig k2)).
move=> H4.
rewrite (proj2 (SkipOneNature (S N) m k2) H4).
apply (le_S (S (proj1_sig k1)) (proj1_sig k2) H2).
move=> H4.
rewrite (proj1 (SkipOneNature (S N) m k2) H4).
apply H2.
Qed.


Record Cat : Type := mkCat
{ Obj : Type
; hom: Obj * Obj -> Set
; id : forall A: Obj, hom (A,A)
; comp :  forall (A: Obj) ( B: Obj) (C : Obj) ( f: hom (A, B)) ( g : hom (B,C)), hom (A,C)
; id_ax : forall (A: Obj) (B : Obj) (f : hom (A,B)), (comp A A B (id A) f = f) /\ (comp A B B f (id B) = f)
; ass : forall (A: Obj)(B:Obj)(C:Obj)(D:Obj)(f:hom (A,B))(g : hom (B,C))(h: hom (C,D)), comp A C D (comp A B C f g) h =   comp A B D f (comp B C D g h)
}.

Record Smallcat ( S : Set) :=  mkSmallcat { cat : Cat; small : (Obj cat) = S}.

Definition SmallCat := sigT Smallcat.

Definition Arrows ( C :Cat) := sigT (hom C).

Definition Src ( C :Cat) ( a : Arrows C) := fst (projT1 a).

Definition Targ ( C :Cat) ( a : Arrows C) := snd (projT1 a).

Definition Terminal (C : Cat) ( A : Obj C) := forall ( B : Obj C), exists ( f :(hom C) (B,A)), forall ( g: (hom C) (B,A)), g = f.

Definition Iso (C : Cat) (A : Obj C) ( B : Obj C) := exists ( f : (hom C) (A,B)), exists ( g : (hom C) (B,A)), ((comp C) A B A f g = (id C) A /\ (comp C) B A B g f = (id C)
B).

Theorem isoterm : forall (C :Cat) ( A : Obj C) ( B : Obj C), Terminal C A /\ Terminal C B -> Iso C A B.
Proof.
(intros **).
(unfold Iso).
(unfold Terminal).
(destruct H).
(unfold Terminal).
(unfold Terminal in H).
(unfold Terminal in H0).
(pose proof (H B)).
(pose proof (H0 A)).
(destruct H1).
(destruct H2).
(pose proof (H A)).
(destruct H3).
(pose proof (H3 ((id C) A))).
(pose proof (H3 (comp C A B A x0 x))).
(pose proof (H0 B)).
(destruct H6).
(pose proof (H6 (id C B))).
(pose proof (H6 (comp C B A B x x0))).
(pose proof (Logic.conj H5 H8)).
(rewrite <- H4 in H9).
(rewrite <- H7 in H9).
(pose proof
  (ex_intro
     (fun x : hom C (B, A) =>
      comp C A B A x0 x = id C A /\ comp C B A B x x0 = id C B) x H9)).
(pose proof
  (ex_intro
     (fun x0 : hom C (A, B) =>
      exists x : hom C (B, A),
        comp C A B A x0 x = id C A /\ comp C B A B x x0 = id C B) x0 H10)).
assumption.
Qed.

Record Functor ( X: Cat * Cat) :=  mkFunctor {
obj : (Obj (fst X)) -> (Obj (snd X));
arr :  forall ( a : Obj (fst X) ) ( b : Obj (fst X) ), hom (fst X) (a,b) -> hom (snd X) ( obj a, obj b);
f_id : forall (a : Obj (fst X)), arr a a (id (fst X) a) = id (snd X) (obj a);
f_comp :  forall (a : Obj (fst X)) (b : Obj (fst X)) (c : Obj (fst X))( f: hom (fst X) (a,b)) ( g: hom (fst X) (b,c)),
arr a c ((comp (fst X)) a b c f g) = (comp (snd X)) (obj a) (obj b) (obj c) (arr a b f) (arr b c g)  }.

Definition Func := sigT Functor.

Record NatTrans ( X: Cat * Cat) ( F : Functor X) (G : Functor X) := mkNatTrans{
eta : forall ( A : Obj (fst X) ), (hom (snd X)) ((obj X F) A,  (obj X G) A );
nat_com : forall (A : Obj (fst X)) ( B : Obj (fst X)) ( f : (hom (fst X)) (A,B) ),
(comp (snd X))  ((obj X F) A) ((obj X F) B) ((obj X G) B )   ((arr X F) A B f) (eta B)
= (comp (snd X))  ((obj X F) A) ((obj X G) A) ((obj X G) B) (eta A) ((arr X G) A B f)  }.

Record Diagram := mkDiagram { index : SmallCat; C : Cat ; diag : Functor ( cat (projT1 index) (projT2 index), C)}.

Definition Shom (x : Set * Set) := let (a,b):= x in a ->b.

Definition Sid (x : Set) :=  fun (a : x) => a.

Definition Scomp (a : Set)(b : Set)(c :Set) (f : Shom(a,b)) (g : Shom(b,c)) := fun (x: a) => g (f x).

Theorem Sid_ax : forall ( a : Set) ( b : Set) ( f : Shom (a,b) ), (Scomp a a b (Sid a) f = f) /\     (Scomp a b b f (Sid b) = f).
Proof.
(intros **).
(unfold Scomp).
split.
 (unfold Sid).
 (simpl).
 auto.
 (unfold Sid).
 auto.
Qed.

Theorem  Sass : forall (A: Set)(B:Set)(C:Set)(D:Set)(f:Shom (A,B))(g : Shom (B,C))(h: Shom (C,D)), Scomp A C D (Scomp A B C f g) h =   Scomp A B D f
(Scomp B C D g h).
Proof.
intros.
(unfold Scomp).
(pose proof (eq_refl (fun x : A => h (g (f x))))).
assumption.
Qed.

Definition SET := mkCat Set Shom Sid Scomp Sid_ax Sass.

Definition PShv ( A :Cat) := Functor (A, SET).


Require Import Coq.Init.Datatypes.
Require Import Coq.Lists.List.
Require Import TypeclassHierarchy.Interfaces.Semigroup.

Instance List_Semigroup :
  forall A : Set, Semigroup (list A) := { sg_op             := @app A
                                   ; sg_op_associative := @app_assoc A
                                   }.

Instance List_Monoid :
  forall A : Set, Monoid (list A) := { monoid_semigroup := List_Semigroup A
                                ; unit             := nil
                                ; left_identity    := @app_nil_l A
                                ; right_identity   := @app_nil_r A
                                }.

Section Nat_Monoid.
  Instance Nat_Semigroup : Semigroup nat :=
    { sg_op             := plus
    ; sg_op_associative := Plus.plus_assoc
    }.

  Instance Nat_Monoid : Monoid nat :=
    { monoid_semigroup := Nat_Semigroup
    ; unit             := 0
    }.
  Proof.
    { (* Left identity *)
      unfold sg_op.
      unfold Nat_Semigroup.
      apply plus_O_n.
    }
    {
      unfold sg_op.
      unfold Nat_Semigroup.
      intros a.
      apply (eq_sym (x := a) (y := a + 0)).
      apply plus_n_O.
    }
  Defined.
End Nat_Monoid.


Set Warnings "-notation-overridden,-parsing".
Require Export indProp.

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

Theorem next_nat_partial_function :
  partial_function next_nat.
Proof.
  unfold partial_function. intros.
  inversion H. inversion H0. reflexivity.
Qed.

Theorem le_not_a_paritial_function :
  ~(partial_function le).
Proof.
  unfold partial_function.
  intros H. pose proof (H 0 0 1) as H1.
  assert(tmpH1: 0 =1). apply H1. apply (le_n 0).  apply le_S, (le_n 0). inversion tmpH1.
Qed.

Theorem total_relation_not_a_partial_function :
  ~(partial_function total_relation).
Proof.
  unfold partial_function. intros H.
  pose proof (H 0 0 1) as H1.
  assert(tmpH: 0=1). apply H1. apply tr_1.  apply tr_2.   unfold lt. apply le_n.
  inversion tmpH.
Qed.

Print empty_relation.

Definition reflexive {X:Type} (R:relation X) :=
  forall a : X, R a a.
Theorem le_reflexive :
  reflexive le.
Proof.
  intros a. apply le_n.
Qed.

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.
  unfold transitive. intros.
  apply (PeanoNat.Nat.le_trans a b c).
  congruence. congruence.
Qed.

Theorem lt_trans:
  transitive lt.
Proof.
  unfold transitive. intros.
  apply (PeanoNat.Nat.lt_trans a b c).
  apply H. apply H0.
Qed.

Theorem lt_trans' :
  transitive lt.
Proof.
  unfold lt. unfold transitive.
  intros n m o Hnm Hmo.
  induction Hmo as [| m' Hm'o].
  - apply le_S. apply Hnm.
  - apply le_S. apply IHHm'o.
Qed.

Theorem lt_trans'' :
  transitive lt.
Proof.
  unfold transitive. unfold lt.
  intros a b c Hab Hbc.
  induction c.
  - inversion Hbc.
  - simpl. inversion Hbc.
    + apply le_S. subst c. congruence.
    + subst m. apply le_S. apply IHc in H0. congruence.
Qed.

Theorem le_S_n : forall n m,
    (S n <= S m) -> n <= m.
Proof.
  intros.
  inversion H.
  - apply le_n.
  - subst m0. apply (le_trans n (S n) m).
    + apply le_S, le_n.
    + congruence.
Qed.

Theorem le_Sn_n :forall n,
    ~(S n<= n).
Proof.
  intros.
  intros H.
  induction n.
  - inversion H.
  - apply IHn, le_S_n, H.
Qed.

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

Theorem le_not_symmetric:
  ~(symmetric le).
Proof.
  unfold symmetric. unfold not.
  intros. pose proof (H 0 1) as H1.
  assert(tmpH: 0<=1). apply le_S, le_n.
  apply H1 in tmpH. inversion tmpH.
Qed.

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

Theorem le_antisymmetric :
  antisymmetric le.
Proof.
  unfold antisymmetric.
  intros a.
  induction a.
  - intros. inversion H. reflexivity. subst b. inversion H0.
  - intros. inversion H0.
    + reflexivity.
    + subst m. apply le_S in H as H3. apply le_S_n in H3.
      assert(tmpH: a =b). apply IHa. apply H3. apply H2.
      subst b. apply le_Sn_n in H. inversion H.
Qed.

Theorem le_step : forall n m p,
    n < m -> m <= S p -> n <= p.
Proof.
  intros.
  induction H.
  - apply le_S_n in H0. apply H0.
  - apply IHle. apply le_S in H0. apply le_S_n in H0. apply H0.
Qed.

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

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

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

Theorem le_order :
  order le.
Proof.
  split.
  - unfold reflexive. intros. apply le_n.
  - split.
    + apply le_antisymmetric.
    + apply le_trans.
Qed.

Inductive clos_refl_trans {A:Type} (R:relation A) :relation A:=
| rt_step x y (H: R x y) :clos_refl_trans R x y
| rt_refl x : clos_refl_trans R x x
| rt_trans x y z
           (Hxy : clos_refl_trans R x y)
           (Hyz: clos_refl_trans R y z) :
    clos_refl_trans R x z.

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

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)
             (Hxy : R x y) (Hrest : clos_refl_trans_1n R y z):
    clos_refl_trans_1n  R x z.

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

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 IHclos_refl_trans_1n in H0. apply rt1n_trans with y. apply Hxy. apply H0.
Qed.

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.
  split.
  - intros H. induction H.
    + apply rsc_R. apply H.
    + apply rt1n_refl.
    + apply rsc_trans with y. congruence. congruence.
  - intros H. induction H.
    + apply rt_refl.
    + apply rt_step in Hxy. apply rt_trans with y. congruence. congruence.
Qed.


(* -*- coding: utf-8; mode:coq -*-
 * Auto-generated - Do not edit or overwrite!
 *)

Require Import Arith. (* ouvre droit, notamment, à 'auto with arith' *)

Section exo3.

  (* Il existe une fonction, qui réalise une certaine spécification *)

  Variable fact : nat -> nat.
  Axiom fact_spec_zero : fact 0 = 1.
  Axiom fact_spec_succ : forall x : nat, x > 0 -> fact x = x * fact (x - 1).

  Parameter n : nat.

  (* Programme annoté :

  { (n >= 0 and x = n) }
    Auto0:f <- 1
    Inv:assert (fact(n) = (f * fact(x)) and x >= 0);
    Auto4:while (x > 0) {
        Auto1:f <- (f * x)
        Auto2:x <- (x - 1)
      }
  { (fact(n) = f and x = 0) }

  *)

  (* Valeurs des Weakest Least Preconditions (WLP) *)
  Definition Post (f x : nat) := ((fact n) = f /\ x = 0).
  Definition Pre (f x : nat) := (n >= 0 /\ x = n).
  Definition Auto4 (f x : nat) := ((fact n) = (f * (fact x)) /\ x >= 0).
  Definition Auto2 (f x : nat) := ((fact n) = (f * (fact (x - 1))) /\ (x - 1) >= 0).
  Definition Auto1 (f x : nat) := ((fact n) = ((f * x) * (fact (x - 1))) /\ (x - 1) >= 0).
  Definition Inv (f x : nat) := ((fact n) = (f * (fact x)) /\ x >= 0).
  Definition Auto0 (f x : nat) := ((fact n) = (1 * (fact x)) /\ x >= 0).

  (* Obligations de preuve engendrées *)
  Lemma obligation_Pre : forall f x : nat,
    ((n >= 0 /\ x = n) -> ((fact n) = (1 * (fact x)) /\ x >= 0)).
  Proof.
    intros.
    destruct H.
    subst.
    split.
    auto with arith.
    assumption.
  Qed.

  Lemma obligation_Inv_false : forall f x : nat,
    (((fact n) = (f * (fact x)) /\ x >= 0) -> (x <= 0 -> ((fact n) = f /\ x = 0))).
  Proof.
    intros.
    destruct H.
    split.
    assert(x=0).
    auto with arith.
    subst.
    rewrite fact_spec_zero in H.
    auto with arith.
    assert(f*1=f).
    auto with arith.
    rewrite H2 in H.
    assumption.
    auto with arith.
  Qed.

  Lemma obligation_Inv_true : forall f x : nat,
    (((fact n) = (f * (fact x)) /\ x >= 0) -> (x > 0 -> ((fact n) = ((f * x) * (fact (x - 1))) /\ (x - 1) >= 0))).
  Proof.
    intros.
    destruct H.
    split.
    rewrite H.
    rewrite fact_spec_succ.
    auto with arith.
    assumption.
    auto with arith.
  Qed.

End exo3.


Require Import Coq.Bool.Bvector.
Require Import Coq.ZArith.BinInt.
Require Import Coq.ZArith.Zdigits.
Require Import Coq.ZArith.Zdiv.
Require Import Coq.ZArith.Zorder.
Require Import Coq.micromega.Lia.
Require Import CPidgin.Data.Bits.

Module BitsTheorems.

Import Bits.

Module ZStuff.

    Local Open Scope Z_scope.

    (* 0 = 0 * 2. *)
    Lemma zero_2_mult:
        0 = 0 * 2.
    Proof.
        compute.
        trivial.
    Qed.

    (* Shifting a value to the left is the same as multiplying it by 2. *)
    Lemma bits_shl:
        forall (x : Z),
            0 <= x * 2 < two_power_nat 64 ->
                B64_to_Z (B64_shl (Z_to_B64 x)) = x * 2.
    Proof.
        intros.
        destruct H.
        unfold B64_shl.
        unfold Z_to_B64.
        unfold B64_to_Z.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        trivial.
        rewrite Z.ge_le_iff.
        rewrite zero_2_mult in H.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
    Qed.

    (* Left shifting a value by n is the same as multiplying it by 2^n. *)
    Lemma bits_shl_iter:
        forall (x : Z) (n : nat),
            0 <= x ->
            x < two_power_nat 64 ->
            0 <= x * (two_power_nat n) < two_power_nat 64 ->
            B64_to_Z (B64_shl_iter n (Z_to_B64 x)) = x * (two_power_nat n).
    Proof.
        intros x n H0 H1 H2.
        destruct H2.
        unfold B64_shl_iter.
        unfold Z_to_B64.
        unfold B64_to_Z.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        trivial.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
    Qed.

    (* Shifting a value to the right is the same as dividing it by 2. *)
    Lemma bits_shr:
        forall (x : Z),
            0 < x < two_power_nat 64 ->
                B64_to_Z (B64_shr (Z_to_B64 x)) = x / 2.
    Proof.
        intros.
        destruct H.
        unfold B64_shr.
        unfold Z_to_B64.
        unfold B64_to_Z.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        trivial.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        rewrite Z.ge_le_iff.
        apply Z_div_pos.
        nia.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        rewrite Z_div_lt.
        nia.
        nia.
        nia.
        nia.
        nia.
    Qed.

    (* Right shifting a value by n is the same as dividing it by 2^n. *)
    Lemma bits_shr_iter:
        forall (x : Z) (n : nat),
            0 <= x ->
            x < two_power_nat 64 ->
            0 <= x / (two_power_nat n) < two_power_nat 64 ->
            B64_to_Z (B64_shr_iter n (Z_to_B64 x)) = x / (two_power_nat n).
    Proof.
        intros x n H0 H1 H2.
        destruct H2.
        unfold B64_shr_iter.
        unfold Z_to_B64.
        unfold B64_to_Z.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        trivial.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
    Qed.

    (* If two values are equal, then B64_eql returns 1. *)
    Lemma B64_eql_Eq:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Eq ->
                B64_eql x y = nat_to_B64 1.
    Proof.
        intros x y H.
        unfold B64_eql.
        rewrite H.
        trivial.
    Qed.

    (* If two values are Lt, then B64_eql returns 0. *)
    Lemma B64_eql_Lt:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Lt ->
                B64_eql x y = nat_to_B64 0.
    Proof.
        intros x y H.
        unfold B64_eql.
        rewrite H.
        trivial.
    Qed.

    (* If two values are Gt, then B64_eql returns 0. *)
    Lemma B64_eql_Gt:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Gt ->
                B64_eql x y = nat_to_B64 0.
    Proof.
        intros x y H.
        unfold B64_eql.
        rewrite H.
        trivial.
    Qed.

    (* If two values are equal, then B64_lt returns 0. *)
    Lemma B64_lt_Eq:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Eq ->
                B64_lt x y = nat_to_B64 0.
    Proof.
        intros x y H.
        unfold B64_lt.
        rewrite H.
        trivial.
    Qed.

    (* If two values are Lt, then B64_lt returns 1. *)
    Lemma B64_lt_Lt:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Lt ->
                B64_lt x y = nat_to_B64 1.
    Proof.
        intros x y H.
        unfold B64_lt.
        rewrite H.
        trivial.
    Qed.

    (* If two values are Gt, then B64_lt returns 0. *)
    Lemma B64_lt_Gt:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Gt ->
                B64_lt x y = nat_to_B64 0.
    Proof.
        intros x y H.
        unfold B64_lt.
        rewrite H.
        trivial.
    Qed.

    (* If two values are equal, then B64_gt returns 0. *)
    Lemma B64_gt_Eq:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Eq ->
                B64_gt x y = nat_to_B64 0.
    Proof.
        intros x y H.
        unfold B64_gt.
        rewrite H.
        trivial.
    Qed.

    (* If two values are Lt, then B64_gt returns 0. *)
    Lemma B64_gt_Lt:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Lt ->
                B64_gt x y = nat_to_B64 0.
    Proof.
        intros x y H.
        unfold B64_gt.
        rewrite H.
        trivial.
    Qed.

    (* If two values are Gt, then B64_gt returns 1. *)
    Lemma B64_gt_Gt:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Gt ->
                B64_gt x y = nat_to_B64 1.
    Proof.
        intros x y H.
        unfold B64_gt.
        rewrite H.
        trivial.
    Qed.

    (* If two values are equal, then B64_le returns 1. *)
    Lemma B64_le_Eq:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Eq ->
                B64_le x y = nat_to_B64 1.
    Proof.
        intros x y H.
        unfold B64_le.
        rewrite H.
        trivial.
    Qed.

    (* If two values are Lt, then B64_le returns 1. *)
    Lemma B64_le_Lt:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Lt ->
                B64_le x y = nat_to_B64 1.
    Proof.
        intros x y H.
        unfold B64_le.
        rewrite H.
        trivial.
    Qed.

    (* If two values are Gt, then B64_le returns 0. *)
    Lemma B64_le_Gt:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Gt ->
                B64_le x y = nat_to_B64 0.
    Proof.
        intros x y H.
        unfold B64_le.
        rewrite H.
        trivial.
    Qed.

    (* If two values are equal, then B64_ge returns 1. *)
    Lemma B64_ge_Eq:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Eq ->
                B64_ge x y = nat_to_B64 1.
    Proof.
        intros x y H.
        unfold B64_ge.
        rewrite H.
        trivial.
    Qed.

    (* If two values are Lt, then B64_ge returns 0. *)
    Lemma B64_ge_Lt:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Lt ->
                B64_ge x y = nat_to_B64 0.
    Proof.
        intros x y H.
        unfold B64_ge.
        rewrite H.
        trivial.
    Qed.

    (* If two values are Gt, then B64_ge returns 1. *)
    Lemma B64_ge_Gt:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Gt ->
                B64_ge x y = nat_to_B64 1.
    Proof.
        intros x y H.
        unfold B64_ge.
        rewrite H.
        trivial.
    Qed.

    (* If two values are equal, then B64_neq returns 0. *)
    Lemma B64_neq_Eq:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Eq ->
                B64_neq x y = nat_to_B64 0.
    Proof.
        intros x y H.
        unfold B64_neq.
        rewrite H.
        trivial.
    Qed.

    (* If two values are Lt, then B64_neq returns 1. *)
    Lemma B64_neq_Lt:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Lt ->
                B64_neq x y = nat_to_B64 1.
    Proof.
        intros x y H.
        unfold B64_neq.
        rewrite H.
        trivial.
    Qed.

    (* If two values are Gt, then B64_neq returns 1. *)
    Lemma B64_neq_Gt:
        forall (x y : B64),
            (B64_to_Z x) ?= (B64_to_Z y) = Gt ->
                B64_neq x y = nat_to_B64 1.
    Proof.
        intros x y H.
        unfold B64_neq.
        rewrite H.
        trivial.
    Qed.

    (* We can add two values. *)
    Lemma B64_add:
        forall (x y : Z),
            0 <= x < two_power_nat 64 ->
            0 <= y < two_power_nat 64 ->
            x + y < two_power_nat 64 ->
            (B64_to_Z (B64_add (Z_to_B64 x) (Z_to_B64 y))) = x + y.
    Proof.
        intros x y Hx Hy Hxy.
        unfold B64_add.
        unfold B64_to_Z.
        unfold Z_to_B64.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        trivial.
        nia.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        nia.
        nia.
    Qed.

    (* We can subtract two values. *)
    Lemma B64_sub:
        forall (x y : Z),
            0 <= x < two_power_nat 64 ->
            0 <= y < two_power_nat 64 ->
            x - y >= 0 ->
            (B64_to_Z (B64_sub (Z_to_B64 x) (Z_to_B64 y))) = x - y.
    Proof.
        intros x y Hx Hy Hxy.
        unfold B64_sub.
        unfold B64_to_Z.
        unfold Z_to_B64.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        trivial.
        nia.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        nia.
        nia.
    Qed.

    (* We can multiply two values. *)
    Lemma B64_mul:
        forall (x y : Z),
            0 <= x < two_power_nat 64 ->
            0 <= y < two_power_nat 64 ->
            x * y < two_power_nat 64 ->
            (B64_to_Z (B64_mul (Z_to_B64 x) (Z_to_B64 y))) = x * y.
    Proof.
        intros x y Hx Hy Hxy.
        unfold B64_mul.
        unfold B64_to_Z.
        unfold Z_to_B64.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        trivial.
        nia.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        nia.
        nia.
    Qed.

    (* We can divide two values. *)
    Lemma B64_div:
        forall (x y : Z),
            0 <= x < two_power_nat 64 ->
            0 <= y < two_power_nat 64 ->
            0 <= x / y < two_power_nat 64 ->
            (B64_to_Z (B64_div (Z_to_B64 x) (Z_to_B64 y))) = x / y.
    Proof.
        intros x y Hx Hy Hxy.
        unfold B64_div.
        unfold B64_to_Z.
        unfold Z_to_B64.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        trivial.
        nia.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        nia.
        nia.
    Qed.

    (* We can compute x modulo y. *)
    Lemma B64_mod:
        forall (x y : Z),
            0 <= x < two_power_nat 64 ->
            0 <= y < two_power_nat 64 ->
            0 <= x mod y < two_power_nat 64 ->
            (B64_to_Z (B64_mod (Z_to_B64 x) (Z_to_B64 y))) = x mod y.
    Proof.
        intros x y Hx Hy Hxy.
        unfold B64_mod.
        unfold B64_to_Z.
        unfold Z_to_B64.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        trivial.
        nia.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        nia.
        nia.
        rewrite Z_to_binary_to_Z.
        rewrite Z_to_binary_to_Z.
        nia.
        nia.
        nia.
        nia.
        nia.
    Qed.

End ZStuff.

End BitsTheorems.


(** Generated by coq-of-ocaml *)
Require Import OCaml.OCaml.

Local Set Primitive Projections.
Local Open Scope string_scope.
Local Open Scope Z_scope.
Local Open Scope type_scope.
Import ListNotations.

Unset Positivity Checking.
Unset Guard Checking.

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

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

Fixpoint plus (plus_arg0 : natural) (plus_arg1 : natural) {struct plus_arg0}
  : natural :=
  match plus_arg0 with
  | Zero => plus_arg1
  | Succ n => Succ (plus n plus_arg1)
  end.

Fixpoint mult (mult_arg0 : natural) (mult_arg1 : natural) {struct mult_arg0}
  : natural :=
  match mult_arg0 with
  | Zero => Zero
  | Succ n => plus (mult n mult_arg1) mult_arg1
  end.

Definition synth (y : natural) (x : natural) : natural := mult (Succ x) (Succ y).


Require Import Essentials.Notations.
Require Import Essentials.Types.
Require Import Essentials.Facts_Tactics.
Require Import Category.Category.

(** The oposite of a category C is a category with the same objects where the arrows are inverted.
As a result, f ∘_Cᵒᵖ g is just g ∘_C f and consequently, assoc is assoc_sym (reversed with arrow
arguments) and vice versa. Similarly, id_unit_left and id_unit_right are also swapped. *)

Definition Opposite (C : Category) : Category :=
{|

  Obj := Obj C;

  Hom := fun a b => (b –≻ a)%morphism;

  compose :=
    fun a b c (f : (b –≻ a)%morphism) (g : (c –≻ b)%morphism) => compose C c b a g f;

  id := fun c => id C c;

  assoc := fun _ _ _ _ f g h => assoc_sym h g f;

  assoc_sym := fun _ _ _ _ f g h => assoc h g f;

  id_unit_left := fun _ _ h => @id_unit_right C _ _ h;

  id_unit_right := fun _ _ h => @id_unit_left C _ _ h

|}.

Notation "C '^op'" := (Opposite C) : category_scope.


Require Import bool.
Require Import nat.
Require Import hsyntax.
Require Import state.
Require Import dictionary.

Fixpoint aeval (env:State) (a:aexp) : nat :=
    match a with
    | ANum n        => n
    | AKey k        => env k
    | APlus a1 a2   => (aeval env a1) + (aeval env a2)
    | AMinus a1 a2  => (aeval env a1) - (aeval env a2)
    | AMult a1 a2   => (aeval env a1) * (aeval env a2)
    end.

Fixpoint beval (env:State) (b:bexp) : bool :=
    match b with
    | BTrue         => true
    | BFalse        => false
    | BEq a1 a2     => eqb (aeval env a1) (aeval env a2)
    | BLe a1 a2     => leb (aeval env a1) (aeval env a2)
    | BNot b1       => negb (beval env b1)
    | BAnd b1 b2    => andb (beval env b1) (beval env b2)
    end.

Inductive ceval : com -> State -> State -> Prop :=
| E_Skip     : forall e, ceval SKIP e e
| E_Ass      : forall e a n x, aeval e a = n -> ceval (x ::= a) e (t_update e x n)
| E_Seq      : forall e e' e'' c1 c2, ceval c1 e e' -> ceval c2 e' e'' ->
                ceval (c1 ;; c2) e e''
| E_IfTrue   : forall e e' b c1 c2, beval e b = true -> ceval c1 e e' ->
                ceval (IFB b THEN c1 ELSE c2 FI) e e'
| E_IfFalse  : forall e e' b c1 c2, beval e b = false -> ceval c2 e e' ->
                ceval (IFB b THEN c1 ELSE c2 FI) e e'
| E_WhileEnd : forall e b c, beval e b = false -> ceval (WHILE b DO c END) e e
| E_WhileLoop: forall e e' e'' b c, beval e b = true -> ceval c e e' ->
                ceval (WHILE b DO c END) e' e'' ->
                ceval (WHILE b DO c END) e  e''
| E_Havoc    : forall e k n, ceval (CHavoc k) e (t_update e k n)
.

Example havoc_test1 : ceval (HAVOC x) emptyState (t_update emptyState x 0).
Proof. constructor. Qed.

Example havoc_test2 : ceval (SKIP ;; HAVOC z) emptyState (t_update emptyState z 20).
Proof. apply E_Seq with emptyState; constructor. Qed.

Lemma ceval_havoc: forall (k:Key) (e e':State),
    ceval (HAVOC k) e e' -> exists n, e' = t_update e k n.
Proof.
    intros k e e' H. remember (HAVOC k) as c eqn:C. revert C.
    destruct H; intros H'; inversion H'; subst.
    exists n. reflexivity.
Qed.

Lemma ceval_assign: forall (k:Key) (a:aexp) (e e':State),
    ceval (k ::= a) e e' -> e' k = aeval e a.
Proof.
    intros k a e e' H. remember (k ::= a) as c eqn:C. revert C.
    destruct H; intros H'; inversion H'; subst; apply t_update_eq.
Qed.

Lemma ceval_assign': forall (k k':Key) (a:aexp) (e e':State),
    ceval (k ::= a) e e' -> k <> k' -> e k' = e' k'.
Proof.
    intros k k' a e e' H H'. remember (k ::= a) as c eqn:C. revert C.
    destruct H; intros E; inversion E; subst. symmetry.
    apply t_update_neq. assumption.
Qed.


Require Import Cpdt.CpdtTactics.
Require Import Cpdt.Subset.
Require Import Cpdt.MoreSpecif.

(* 1番は eq_nat_dec の少し違うバージョン *)
Definition leq_or_greater : forall n m : nat, {n <= m} + {n > m}.
  refine (fix f (n m : nat) : {n <= m} + {n > m} :=
            match n, m with
            | O, O => Yes       (* 左側 *)
            | O, S m' => Yes    (* 左側 *)
            | S n', O => No     (* 右側 *)
            | S n', S m' => Reduce (f n' m') (* 再帰 *)
            end); intuition.
Defined.

(* 2-a *)