(* Version courante
- définition des vecteurs
- 'Vecteur _ n' est un foncteur qui préserve les produits.
 *)
Add LoadPath "C:\Users\21692\ParcoursRecherche\dossier_final\coq_parcours_recherche\znaidi22\dev\final" as lp.

Load Verbose produitCartesien.

Load Verbose modulo.

(* Bibliothèque standard pour les vecteurs *)
Require Import List Arith Bool Decidable PeanoNat Coq.Arith.Peano_dec.
Import ListNotations.

Require Import Vector.
Import VectorNotations.

(* TODO Une tactique apply permettant de transmettre un à un les arguments *)
(* Ltac appliquer f :=
  unshelve (eapply f).
*)

(** *Vecteur *)

(* Un type indexé décrivant les vecteurs (des listes avec leur taille) *)

Print Vector.t. (* Type correspondant dans la bibliothèque standard *)

(*

Vecteur (A : Type) : nat -> Type - une paramétrisation par un type, indexation par un nat

                           (p : nat)  A  (Vecteur A p)
----------- [vecteur_vide]  --------------------------- [vecteur_cons]
Vecteur A 0                    (Vecteur A (S p))

*)

Inductive Vecteur(A : Type) : nat -> Type :=
| vecteur_vide : Vecteur A 0
| vecteur_cons : forall p, A -> Vecteur A p -> Vecteur A (S p).

(** * Règles d'élimination ou gauches pour les vecteurs *)

(* 1. P : forall (v : Vecteur A 0), Sorte - Sorte := Prop | Type

- Elimination de (v : Vecteur A 0) pour P

   Γ ⊢ (v : Vecteur A 0)  Γ ⊢ P vide
   ---------------------------------
             Γ ⊢ P v

- Règle gauche pour un (Vecteur A (S n))

       Γ ⊢ P vide
   --------------------------
   Γ, (v : Vecteur A 0) ⊢ P v

2. P : forall n (v : Vecteur A (S n)), Sorte - Sorte := Prop | Type

- Elimination de (v : Vecteur A (S n)) pour P

   Γ ⊢ (v : Vecteur A (S n))
     Γ ⊢ forall (m : nat)(t : A)(r : Vecteur A m), P m (cons t r)
   --------------------------------------------------------------
                          Γ ⊢ P n v

- Règle gauche pour un (Vecteur A (S n))

   Γ, (n : nat), (t : A), (r : Vecteur A n) ⊢ P n (cons t r)
   ---------------------------------------------------------
         Γ, (n : nat), (v : Vecteur A (S n)) ⊢ P n v

Mais du fait de l'indexation, ces règles ne peuvent être obtenues par la tactique 'case'.
Pour les obtenir, on utilise la technique de paramétrisation du but : elle vise à remplacer
les index par des paramètres. Dans ce cas, la tactique 'case' ne perd pas d'information. *)

Check Vector.caseS.
(* Principe dans la bibliothèque standard
caseS
     : forall P : forall n : nat, t ?A (S n) -> Type,
       (forall (h : ?A) (n : nat) (t : t ?A n), P n (h :: t)) ->
       forall (n : nat) (v : t ?A (S n)), P n v
where
?A : [ |- Type] *)

Check Vector.case0.
(* Principe dans la bibliothèque standard
case0
     : forall P : t ?A 0 -> Type, P [] -> forall v : t ?A 0, P v
where
?A : [ |- Type] *)

(* Technique de paramétrisation du but *)

(* Cas des propositions *)

(* P1. Extension d'un prédicat sur le vecteur vide aux vecteurs non vides *)
Definition vecteur_extensionPredicatVecteurVide
           {A : Type}(P : Vecteur A 0 -> Prop):
  forall n, Vecteur A n -> Prop.
  intros n v.
  case n as [ | pn].
  - exact (P v).
  - exact True.
Defined.

(* P2.a Equivalence de l'extension - cas de la spécialisation *)
Lemma vecteur_extensionPredicatVecteurVide_specialisation :
  forall (A : Type)(P : Vecteur A 0 -> Prop),
  (forall n (v : Vecteur A n), (vecteur_extensionPredicatVecteurVide P n v))
  -> (forall (v : Vecteur A 0), P v).
  intros A P H v.
  apply (H 0 v).
Qed.

(* P2.b Equivalence de l'extension - cas de la généralisation *)
Lemma vecteur_extensionPredicatVecteurVide_generalisation :
  forall (A : Type)(P : Vecteur A 0 -> Prop),
  (forall (v : Vecteur A 0), P v)
  -> (forall n (v : Vecteur A n), (vecteur_extensionPredicatVecteurVide P n v)).
  intros A P H n v.
  case n as [ | pn].
  - cbn.
    exact (H v).
  - cbn.
    exact I.
Qed.

(* P3. Proposition à appliquer pour obtenir
les règles d'élimination ou gauche dans le cas d'un prédicat
 appliqué à un vecteur vide. *)
Proposition vecteur_regleGaucheProp_vecteurVide :
  forall (A : Type)(P : Vecteur A 0 -> Prop),
    (P (vecteur_vide A)) -> forall v, P v.
Proof.
  intros A P H.
  apply vecteur_extensionPredicatVecteurVide_specialisation. (* paramétrisation du but *)
  intros n v.
  case v as [ | pn tv rv]. (* décomposition sans perte ni d'informations ni de typage *)
  - cbn.
    exact H.
  - cbn.
    exact I.
Qed.

Print vecteur_regleGaucheProp_vecteurVide.

(* P1. Extension d'un prédicat sur des vecteurs non vides au vecteur vide *)
Definition vecteur_extensionPredicatVecteursNonVides
           {A : Type}(P : forall n, Vecteur A (S n) -> Prop):
  forall n, Vecteur A n -> Prop.
  intros n v.
  case n as [ | pn].
  - exact True.
  - exact (P pn v).
Defined.

(* P2.a Equivalence de l'extension - cas de la spécialisation *)
Lemma vecteur_extensionPredicatVecteursNonVides_specialisation :
  forall (A : Type)(P : forall n, Vecteur A (S n) -> Prop),
  (forall n (v : Vecteur A n), (vecteur_extensionPredicatVecteursNonVides P n v))
  -> (forall n (v : Vecteur A (S n)), P n v).
  intros A P H n v.
  apply (H (S n) v).
Qed.

(* P2.b Equivalence de l'extension - cas de la généralisation *)
Lemma vecteur_extensionPredicatVecteursNonVides_generalisation :
  forall (A : Type)(P : forall n, Vecteur A (S n) -> Prop),
  (forall n (v : Vecteur A (S n)), P n v)
  -> (forall n (v : Vecteur A n), (vecteur_extensionPredicatVecteursNonVides P n v)).
  intros A P H n v.
  case n as [ | pn].
  - cbn.
    exact I.
  - apply (H pn v).
Qed.

(* P3. Proposition à appliquer pour obtenir
les règles d'élimination ou gauche dans le cas d'un prédicat
 appliqué à un vecteur non vide. *)
Proposition vecteur_regleGaucheProp_vecteurNonVide :
  forall (A : Type)(P : forall n, Vecteur A (S n) -> Prop),
    (forall n t r, P n (vecteur_cons A n t r))
    -> forall n v, P n v.
Proof.
  intros A P H.
  apply vecteur_extensionPredicatVecteursNonVides_specialisation. (* paramétrisation du but *)
  intros n v.
  case v as [ | pn tv rv]. (* décomposition sans perte ni d'informations ni de typage *)
  - cbn. exact I.
  - cbn.
    exact (H pn tv rv).
Qed.

Print vecteur_regleGaucheProp_vecteurNonVide.

(* Cas des types *)

(* T1. Extension d'une famille de types paramétrée par le vecteur vide
aux vecteurs non vides *)
Definition vecteur_extensionFamilleTypesVecteurVide
           {A : Type}(R : Vecteur A 0 -> Type):
  forall n, Vecteur A n -> Type.
  intros n v.
  case n as [ | pn].
  - exact (R v).
  - exact unit.
Defined.

(* T2.a Equivalence de l'extension - cas de la spécialisation *)
Definition vecteur_extensionFamilleTypesVecteurVide_specialisation
           {A : Type}{R : Vecteur A 0 -> Type} :
  (forall n v, (vecteur_extensionFamilleTypesVecteurVide R n v))
  -> (forall v, R v).
  intros H v.
  apply (H 0 v).
Defined.

(* T2.b Equivalence de l'extension - cas de la généralisation *)
Definition vecteur_extensionFamilleTypesVecteurVide_generalisation
  {A : Type}{R : Vecteur A 0 -> Type} :
  (forall v, R v)
  -> (forall n v, (vecteur_extensionFamilleTypesVecteurVide R n v)).
  intros H n v.
  case n as [ | pn].
  - cbn.
    apply (H v).
  - cbn.
    exact tt.
Defined.

(* T3. Definiition à appliquer pour obtenir
   les règles d'élimination ou gauche dans le cas d'une famille de types
   paramétrée par le vecteur vide. *)
Definition vecteur_regleGaucheType_vecteurVide
           {A : Type}(R : Vecteur A 0 -> Type)
           (f : R (vecteur_vide A)) :
  forall v, R v.
  apply (@vecteur_extensionFamilleTypesVecteurVide_specialisation A). (* paramétrisation du but *)
  intros n v.
  case v as [ | pn tv rv]. (* décomposition sans perte ni d'informations ni de typage *)
  - cbn.
    exact f.
  - cbn.
    exact tt.
Defined.

(* T1. Extension d'une famille de types paramétrée par des vecteurs non vides
au vecteur vide *)
Definition vecteur_extensionFamilleTypesVecteursNonVides
           {A : Type}(R : forall n, Vecteur A (S n) -> Type):
  forall n, Vecteur A n -> Type.
  intros n v.
  case n as [ | pn].
  - exact unit.
  - exact (R pn v).
Defined.

(* T2.a Equivalence de l'extension - cas de la spécialisation *)
Definition vecteur_extensionFamilleTypesVecteursNonVides_specialisation
           {A : Type}{R : forall n, Vecteur A (S n) -> Type} :
  (forall n v, (vecteur_extensionFamilleTypesVecteursNonVides R n v))
  -> (forall n v, R n v).
  intros H n v.
  apply (H (S n) v).
Defined.

(* T2.b Equivalence de l'extension - cas de la généralisation *)
Definition vecteur_extensionFamilleTypesVecteursNonVides_generalisation
  {A : Type}{R : forall n, Vecteur A (S n) -> Type} :
  (forall n v, R n v)
  -> (forall n v, (vecteur_extensionFamilleTypesVecteursNonVides R n v)).
  intros H n v.
  case n as [ | pn].
  - cbn.
    exact tt.
  - cbn.
    apply (H pn v).
Defined.

(* T3. Definiition à appliquer pour obtenir
   les règles d'élimination ou gauche dans le cas d'une famille de types
   paramétrée par des vecteurs non vides. *)
Definition vecteur_regleGaucheType_vecteurNonVide
           {A : Type}(R : forall n, Vecteur A (S n) -> Type)
           (f : forall n t r, R n (vecteur_cons A n t r)) :
  forall n v, R n v.
  apply (@vecteur_extensionFamilleTypesVecteursNonVides_specialisation A). (* paramétrisation du but *)
  intros n v.
  case v as [ | pn tv rv]. (* décomposition sans perte ni d'informations ni de typage *)
  - cbn. exact tt.
  - cbn.
    exact (f pn tv rv).
Defined.

(** *Applications *)

Print hd. (* Première projection du vecteur donnant la tête (bibliothèque standard).
Utilisation du principe caseS.
hd =
fun A : Type =>
@caseS A (fun (n : nat) (_ : t A (S n)) => A) (fun (h : A) (n : nat) (_ : t A n) => h)
     : forall (A : Type) (n : nat) (v : t A (S n)),
       (fun (n0 : nat) (_ : t A (S n0)) => A) n v
*)

Definition vecteur_tete{A : Type} : forall {n : nat}, Vecteur A (S n) -> A.
  apply (@vecteur_regleGaucheType_vecteurNonVide A).
  intros n t r.
  exact t.
Defined.

(* Variante utilisant la spécialisation. *)
Definition vecteur_tete_bis{A : Type} : forall {n : nat}, Vecteur A (S n) -> A.
  apply (@vecteur_extensionFamilleTypesVecteursNonVides_specialisation A).
  intros n v.
  case v as [ | pn tv rv].
  - cbn.
    Print unit. (* Inductive unit : Set :=  tt : unit. *)
    Print True.    (* Inductive True : Prop :=  I : True. *)
    exact tt.
  - cbn.
    exact tv.
Defined.

Print vecteur_tete.
Print vecteur_tete_bis.

(* Les fonctions précédentes ne sont pas présentées sous la forme habituelle,
   avec les paramètres déjà introduits. En effet, dans ce cas, la tactique
   'apply' n'arrive pas à inférer certains arguments.*)

Definition vecteur_tete_ter{A : Type}{n : nat}(v : Vecteur A (S n)) : A.
  Print vecteur_regleGaucheType_vecteurNonVide.
  Check (@vecteur_regleGaucheType_vecteurNonVide A).
  (* apply (@vecteur_regleGaucheType_vecteurNonVide A).
     Error: Unable to find an instance for the variable n. *)
  (* Type (avec les -> transformées en forall):
    'forall
        (R : forall n : nat, Vecteur A (S n) -> Type),
        (H : forall (n : nat) (t : A) (r : Vecteur A n), R n (vecteur_cons A n t r)),
        (n : nat)
        (v : Vecteur A (S n)),
           R n v'
     Coq infère :
     - R := fun n v => A, une fonction constante égale à 'A', le but. Cette solution
       est la plus simple, mais n'est pas la plus générale puisqu'elle donne 'A'
       pour tous arguments 'n' et 'v'. Si elle ne convenait pas (par exemple
       pour une hypothèse dépendante de 'R' comme 'H'), il faudrait explicitement
       donner le prédicat comme argument.
     En revanche, à partir de 'A', Coq ne peut inférer
     ni (n : nat) ni (v : Vecteur A (S n))),
     qui doivent être fournis par l'utilisateur, tout comme 'H'.
     Bien sûr, il pourrait les deviner grâce à une tactique, mais ce n'est pas le rôle de
     la tactique 'apply' qui est seulement d'inférer les arguments déterminés
     par le but (précisément, la conséquence du séquent formant le but). *)
  (* La solution est d'utiliser une variante de la tactique 'apply'
     qui demande tous les arguments. *)
  unshelve (eapply (@vecteur_regleGaucheType_vecteurNonVide A)).
  - exact n.
  - intros m t r.
    exact t.
  - exact v.
Defined.

(* Il est possible de définir une tactique pour cette variante de la tactique 'apply'.
   Elle permet de transmettre un à un les arguments *)
Ltac appliquer f :=
  unshelve (eapply f).

Print vecteur_tete_ter.

Print tl. (*  Seconde projection du vecteur donnant le reste (bibliothèque standard).
Utilisation du principe caseS.
tl =
fun A : Type =>
@caseS A (fun (n : nat) (_ : t A (S n)) => t A n) (fun (_ : A) (n : nat) (t : t A n) => t)
     : forall (A : Type) (n : nat) (v : t A (S n)),
       (fun (n0 : nat) (_ : t A (S n0)) => t A n0) n v
*)

Definition vecteur_reste{A : Type} : forall {n : nat}, Vecteur A (S n) -> Vecteur A n.
  apply (@vecteur_regleGaucheType_vecteurNonVide A). (* paramétrisation du but *)
  intros n t r.
  exact r.
Defined.

(* Definition vecteur_reste{A : Type} : forall {n : nat}, Vecteur A (S n) -> Vecteur A n.
  appliquer (@vecteur_specialisationExtensionType_enSuccesseur A). (* paramétrisation du but *)
  intros n v.
  case v as [ | pn tv rv].
  - cbn.
    exact tt.
  - cbn.
    exact rv.
Defined. *)

Print vecteur_reste.

Check eta. (* Correction de la décomposition (bibliothèque standard).
eta
     : forall v : VectorDef.t ?A (S ?n), v = VectorDef.hd v :: VectorDef.tl v
where
?A : [ |- Type]
?n : [ |- nat]
            *)
Print eta. (* Utilisation du principe caseS.
eta =
fun (A : Type) (n : nat) (v : VectorDef.t A (S n)) =>
VectorDef.caseS
  (fun (n0 : nat) (v0 : VectorDef.t A (S n0)) => v0 = VectorDef.hd v0 :: VectorDef.tl v0)
  (fun (h : A) (n0 : nat) (t : VectorDef.t A n0) => eq_refl) v
     : forall (A : Type) (n : nat) (v : VectorDef.t A (S n)),
       v = VectorDef.hd v :: VectorDef.tl v
*)

Proposition vecteur_decomposition :
  forall A n (v : Vecteur A (S n)), v = vecteur_cons A n (vecteur_tete v) (vecteur_reste v).
Proof.
  intro A.
  apply (@vecteur_regleGaucheProp_vecteurNonVide A). (* paramétrisation du but *)
  intros n t r.
  cbn.
  reflexivity.
Qed.

Print vecteur_decomposition.

Print nth. (* n-ième projection en utilisant un indice.
Utilisation du principe inductif caseS.
nth =
fun A : Type =>
fix nth_fix (m : nat) (v' : t A m) (p : Fin.t m) {struct v'} : A :=
  match p in (Fin.t m') return (t A m' -> A) with
  | @Fin.F1 n =>
      caseS (fun (n0 : nat) (_ : t A (S n0)) => A)
        (fun (h : A) (n0 : nat) (_ : t A n0) => h)
  | @Fin.FS n p' =>
      fun v : t A (S n) =>
      caseS (fun (n0 : nat) (_ : t A (S n0)) => Fin.t n0 -> A)
        (fun (_ : A) (n0 : nat) (t : t A n0) (p0 : Fin.t n0) => nth_fix n0 t p0) v p'
  end v'
     : forall (A : Type) (m : nat), t A m -> Fin.t m -> A
*)

Definition vecteur_suffixeBrut{A : Type} : forall {n h : nat},
    (ModuloBrut n h) ->  (Vecteur A (S n)) -> (Vecteur A (S h)).
  fix REC 3.
  intros n h ib v.
  case ib as [ | h pib].
  - exact v.
  - exact (vecteur_reste (REC _ _ pib v)).
Defined.

Definition vecteur_suffixe{A : Type}{n : nat}(m : Modulo n)
    (v : Vecteur A (S n)) : (Vecteur A (S (modulo_complementaire m))).
  case m as [h mb].
  cbn.
  exact (vecteur_suffixeBrut mb v).
Defined.

Definition vecteur_valeur{A : Type}{n : nat}(m : Modulo n)(v : Vecteur A (S n)) : A.
Proof.
  exact (vecteur_tete (vecteur_suffixe m v)).
Defined.

Definition vecteur_projection{A : Type}{n : nat}(m : nat)(v : Vecteur A (S n)) : A.
Proof.
  exact (vecteur_valeur (modulo_morphismeNat n m) v).
Defined.

(* 'Vecteur _ n' est un foncteur. *)
(* Partie fonctionnelle du foncteur :
                       f : A -> B
   ----------------------------------------
   Vecteur f n : Vecteur A n -> Vecteur B n
Notation : app n f := Vecteur f n (app pour application, map en anglais, nom traditionnel)
- app 0 f v := vide
- app (S n) f (t.r) := (f t).(app n f r) *)
Fixpoint vecteur_application{A B : Type}{n : nat}(f : A -> B)(v : Vecteur A n) : Vecteur B n.
Proof.
  case n as [ | pn].
  - exact (vecteur_vide B).
  - apply vecteur_cons.
    + exact (f (vecteur_tete v)).
    + exact (vecteur_application _ _ _ f (vecteur_reste v)).
Defined.

(* Comptibilité avec l'égalité fonctionnelle. *)
Proposition vecteur_application_compatibiliteEgaliteFonctionnelle :
  forall (A B : Type){n : nat}(f g: A -> B),
    (fonction_egalite f g) ->
    (@fonction_egalite (Vecteur A n) (Vecteur B n)
       (vecteur_application f) (vecteur_application g)).
Proof.
  unfold fonction_egalite.
  fix HR 7.
  intros A B n f g egFG v.
  case v as [ | pn tv rv].
  - cbn.
    reflexivity.
  - simpl vecteur_application.
    f_equal.
    apply egFG.
    apply HR.
    assumption.
Qed.

(* Variante due au fait que le foncteur 'Vecteur _ n' préserve les produits.
                               f : A * B -> C
   ------------------------------------------------------
   app2 n fn : Vecteur A n * Vecteur B n -> Vecteur C n
- app2 0 f v := vide
- app2 (S n) f (t1.r1, t2.r2) := (f (t1, t2)).(app2 n f (r1, r2)) *)
Fixpoint vecteur_biApplication{A B C : Type}{n : nat}(f : A * B -> C)
  (c : (Vecteur A n) * (Vecteur B n)){struct n} : Vecteur C n.
Proof.
  case n as [ | pn].
  - exact (vecteur_vide C).
  - case c as [a b].
    apply vecteur_cons.
    + exact (f (vecteur_tete a, vecteur_tete b)).
    + exact (vecteur_biApplication A B C pn f (vecteur_reste a, vecteur_reste b)).
Defined.

(* Comptibilité avec l'égalité fonctionnelle. *)
Proposition vecteur_biApplication_compatibiliteEgaliteFonctionnelle :
  forall (A B C : Type){n : nat}(f g: A * B -> C),
    (fonction_egalite f g) ->
    (@fonction_egalite ((Vecteur A n) * (Vecteur B n)) (Vecteur C n)
       (vecteur_biApplication f) (vecteur_biApplication g)).
Proof.
  unfold fonction_egalite.
  fix HR 4.
  intros A B C n f g egFG [vA vB].
  case n as [ | pn].
  - Check vecteur_regleGaucheProp_vecteurVide.
    apply (vecteur_regleGaucheProp_vecteurVide
             A
             (fun v => (vecteur_biApplication f (v, vB) = vecteur_biApplication g (v, vB)))).
    apply (vecteur_regleGaucheProp_vecteurVide
             B
             (fun v => (vecteur_biApplication f (vecteur_vide A, v)
                     = vecteur_biApplication g (vecteur_vide A, v)))).
    cbn.
    reflexivity.
  - simpl vecteur_biApplication.
    f_equal.
    apply egFG.
    apply HR.
    assumption.
Qed.

(* Notations inspirées des listes. *)
Notation "[[ ]]" := (vecteur_vide _).
Notation "t ::: r" := (vecteur_cons _ _ t r) (at level 60, right associativity).
Notation "[[ x ]]" := (x ::: [[]]).
Notation "[[ x ; y ; .. ; z ]]" :=
  (vecteur_cons _ _ x (vecteur_cons _ _ y .. (vecteur_cons _ _ z (vecteur_vide _)) ..)).
Notation "v [@ m ]" := (@vecteur_projection _ _ m v) (at level 1, format "v [@ m ]").

Example testProjection3En2 :
  [[1 ; 4 ; 6]] [@2] = 6.
Proof.
  cbn.
  reflexivity.
Qed.

Example testProjection3En5 :
  [[1 ; 4 ; 6]] [@5] = 6.
Proof.
  cbn.
  reflexivity.
Qed.

Print id.
Print ID.

(* Vecteur : un foncteur.
   Il préserve les identités et la composition.
   Ci-dessous, dans les commentaires, l'égalité fonctionnelle est entendue
   comme l'égalité extensionnelle:
   - F égal à G G si ∀x, F x = G x. On peut avoir ¬(F = G).
 *)
(* app id = id *)
Proposition vecteur_application_preservationIdentite :
  forall A n,
    fonction_egalite
      (vecteur_application (@id A))
      (@id (Vecteur A n)).
Proof.
  unfold fonction_egalite.
  unfold id.
  fix HR 3.
  intros A n v.
  case v as [ | pn tv rv].
  - cbn.
    reflexivity.
  - simpl vecteur_application.
    f_equal.
    apply HR.
Qed.

(* app (f ; g) = (app f) ; (app g) *)
Print fonction_egalite.
Proposition vecteur_application_preservationSequence :
  forall A B C n (f : A -> B)(g : B -> C),
    @fonction_egalite (Vecteur A n) (Vecteur C n)
      (vecteur_application (f ;; g))
      ((vecteur_application f) ;; (vecteur_application g)).
Proof.
  unfold fonction_egalite.
  fix HR 7.
  intros A B C n f g v.
  case v as [ | pn tv rv].
  - cbn.
    reflexivity.
  - cbn.
    f_equal.
    apply HR.
Qed.

(* 'Vecteur _ n' : foncteur préservant le produit cartésien.
   Isomorphisme entre 'Vecteur (A * B) n' et '(Vecteur A n) * (Vecteur B n)'.
 *)

(* isomorphisme 1 : [app _ fst, app _ snd] *)
Definition vecteur_preservationProduit_coupleVecteurs{A B : Type}{n : nat} :
  (Vecteur (A * B)  n) -> (Vecteur A n) * (Vecteur B n) :=
  produitCartesien_produitFonctionnel
     (vecteur_application fst) (vecteur_application snd).

Print id.

(* isomorphisme 2 : (app2 _ id) *)
Definition vecteur_preservationProduit_vecteurCouples{A B : Type}{n : nat} :
  ((Vecteur A n) * (Vecteur B n)) -> Vecteur (A * B)  n
  := vecteur_biApplication (@id _).

(* Vérification de l'isomorphisme
- cas 0 : ([app fst, app snd] ; (app2 id)) v = [] et v = []
- cas (S pn) :
  - ([app fst, app snd] ; (app2 id)) (t.r)
  = app2 id ([app fst, app snd] (t.r))
  = app2 id (app fst (t.r), app snd (t.r))
  = app2 id ((fst t).(app fst r), (snd t).(app snd r))
  = (id (fst t, snd t)).(app2 id (app fst r, app snd r))
  = t.(([app fst, app snd] ; (app2 id)) r) = t.r par HR
*)
Proposition vecteur_preservationProduit_deVecteurAVecteur :
  forall A B n,
    @fonction_egalite (Vecteur (A * B)  n) (Vecteur (A * B) n)
      (vecteur_preservationProduit_coupleVecteurs
       ;; vecteur_preservationProduit_vecteurCouples)
      id.
Proof.
  unfold fonction_egalite.
  unfold id.
  fix HR 3.
  intros A B n v.
  case n as [ | pn].
  - cbn.
    apply vecteur_regleGaucheProp_vecteurVide.
    reflexivity.
  - unfold fonction_sequence.
    unfold vecteur_preservationProduit_coupleVecteurs.
    unfold produitCartesien_produitFonctionnel.
    simpl vecteur_application. (* La tactique 'simpl f' permet de simplifier
                                  une fonction récursive, en dépliant sa
                                  définition récursive. *)
    unfold vecteur_preservationProduit_vecteurCouples.
    simpl vecteur_biApplication.
    rewrite (vecteur_decomposition _ _ v) at 5.
    case (vecteur_tete v) as [tv1 tv2].
    f_equal.
    apply HR.
Qed.

(* Vérification de l'isomorphisme
- cas 0 : ((app2 id) ; [app fst, app snd]) (c1, c2) = ([], [])
          et c1 = [], c2 = []
- cas (S pn) :
  - ((app2 id) ; [app fst, app snd]) (t1.r1, t2.r2)
  = [app fst, app snd] (id (t1, t2)).(app2 id (r1, r2))
  = (app fst (id (t1, t2)).(app2 id (r1, r2)),
     app snd (id (t1, t2)).(app2 id (r1, r2)))
  = (t1.(app fst (app2 id (r1, r2)),
     t2.(app snd (app2 id (r1, r2)))
  = (t1.r1, t2.r2) par HR
*)
Proposition vecteur_preservationProduit_deCoupleACouple :
  forall A B n,
    @fonction_egalite ((Vecteur A n) * (Vecteur B n)) ((Vecteur A n) * (Vecteur B n))
      (vecteur_preservationProduit_vecteurCouples
       ;; (vecteur_preservationProduit_coupleVecteurs))
      id.
Proof.
  unfold fonction_egalite.
  unfold id.
  fix HR 3.
  intros A B n c.
  unfold fonction_sequence.
  case c as [c1 c2].
  case n as [ | pn].
  - compute. (* 'cbn' ne déplie pas les fonctions sauf pour faire des calculs.
                Ici, préférer la tactique 'compute' qui calcule la forme normale.
                Attention : ne l'utiliser que lorsque la forme normale est simple,
                sinon on obtient un terme illisible ! Règle pratique : l'utiliser
                si on sait calculer de tête la forme normale.*)
    f_equal.
    + apply vecteur_regleGaucheProp_vecteurVide.
      reflexivity.
    + apply vecteur_regleGaucheProp_vecteurVide.
      reflexivity.
  - unfold vecteur_preservationProduit_vecteurCouples.
    simpl vecteur_biApplication.
    unfold vecteur_preservationProduit_coupleVecteurs.
    unfold produitCartesien_produitFonctionnel.
    simpl vecteur_application.
    rewrite (vecteur_decomposition _ _ c1) at 4.
    rewrite (vecteur_decomposition _ _ c2) at 4.
    pose (hr := HR _ _ pn (vecteur_reste c1, vecteur_reste c2)).
    injection hr as eg1 eg2.
    f_equal.
    f_equal.
    exact eg1.
    f_equal.
    exact eg2.
Qed.

(*                     f : A -> B     g : A -> C
   --------------------------------------------------------------
     app [f, g] : Vecteur A n -> Vecteur (B * C) n
   ~ [app f, app g] : Vecteur A n -> (Vecteur B n) * (Vecteur C n)
   // ~ : égalité à isomorphisme près
- cas 0 : [] ~ ([], [])
- cas (S pn) :
  - app [f, g] t.r = (f t, g t).(app [f, g] r)
  - [app f, app g] t.r = (app f t.r, app g t.r)
                       = ((f t).(app f r), (g t).(app g r))
  - égalité à isomorphisme près par HR
 *)
Proposition vecteur_application_distributionSurProduitFonctionnel :
  forall (A B C : Type)(f : A -> B)(g : A -> C),
  forall n,
    @fonction_egalite (Vecteur A n) ((Vecteur B n) * (Vecteur C n))
      ((vecteur_application (produitCartesien_produitFonctionnel f g)) ;;
       vecteur_preservationProduit_coupleVecteurs)
      (produitCartesien_produitFonctionnel
         (vecteur_application f) (vecteur_application g)).
Proof.
  fix HR 6.
  intros A B C f g n a.
  case n as [ | pn].
  - reflexivity.
  - unfold fonction_sequence.
    simpl vecteur_application at 1.
    unfold produitCartesien_produitFonctionnel at 1.
    unfold vecteur_preservationProduit_coupleVecteurs.
    unfold produitCartesien_produitFonctionnel at 1 3.
    simpl vecteur_application at 1 3.
    simpl vecteur_application at 5 6.
    pose (hr := HR A B C f g pn (vecteur_reste a)).
    injection hr as eg1 eg2.
    f_equal.
    f_equal.
    exact eg1.
    f_equal.
    exact eg2.
Qed.

(*                  f : A * B -> C
   ---------------------------------------------------
     app2 f : Vecteur n A * Vecteur B n -> Vecteur C n
   ~  app f : Vecteur n (A * B) -> Vecteur C n
   // ~ : égalité à isomorphisme près
- cas 0 : app2 f c = [], app f ([], []) = []
- cas (S pn)
  - app2 f (t1.r1, t2.r2) = (f (t1, t2)).(app2 f (r1, r2))
  - app f (iso (t1.r1, t2.r2)) = app f (t1, t2).(iso (r1, r2))
                                = (f (t1, t2)).(app f (iso (r1, r2))
  - égalité par HR
*)
Proposition vecteur_biApplication_equivalenceApplication :
  forall (A B C : Type)(f : A * B -> C),
  forall n,
    @fonction_egalite ((Vecteur A n) * (Vecteur B n)) (Vecteur C n)
      (vecteur_biApplication f)
      (vecteur_preservationProduit_vecteurCouples ;;
       vecteur_application f).
Proof.
  fix HR 5.
  intros A B C f n c.
  case c as [c1 c2].
  case n as [ | pn].
  - cbn.
    reflexivity.
  - unfold fonction_sequence.
    unfold vecteur_preservationProduit_vecteurCouples.
    simpl vecteur_biApplication.
    simpl vecteur_application.
    f_equal.
    apply HR.
Qed.

Proposition vecteur_biApplicationProjection1 :
  forall A B n,
    @fonction_egalite ((Vecteur A n) * (Vecteur B n)) (Vecteur A n)
      (vecteur_biApplication fst) fst.
Proof.
  fix HR 3.
  intros A B n [vA vB].
  case n as [ | pn].
  - cbn.
    apply vecteur_regleGaucheProp_vecteurVide.
    reflexivity.
  - simpl vecteur_biApplication.
    cbn.
    rewrite (vecteur_decomposition _ _ vA) at 3.
    f_equal.
    apply HR.
Qed.

Proposition vecteur_biApplicationProjection2 :
  forall A B n,
    @fonction_egalite ((Vecteur A n) * (Vecteur B n)) (Vecteur B n)
      (vecteur_biApplication snd) snd.
Proof.
  fix HR 3.
  intros A B n [vA vB].
  case n as [ | pn].
  - cbn.
    apply vecteur_regleGaucheProp_vecteurVide.
    reflexivity.
  - simpl vecteur_biApplication.
    cbn.
    rewrite (vecteur_decomposition _ _ vB) at 3.
    f_equal.
    apply HR.
Qed.


From mathcomp Require Import ssreflect ssrbool ssrnat ssrfun.

Set Implicit Arguments.
Unset Strict Implicit.
Unset Printing Implicit Defensive.

(**
Exercise 7.2 Partially-ordered sets

Mathcomp ライブラリに命名規則をあわせた。
 (* see. ssr_pnp_deprecords_2.v *)
*)

Module Poset.
  Module POSET.
(**
Mixinの定義
*)
    Record mixin_of (T : Type) :=
      Mixin {
          valid : T -> bool;
          rel : T -> T -> bool;
          refl (x : T) : rel x x;
          asym (x y : T) : rel x y -> rel y x -> x = y;
          trans (y x z : T) : rel x y -> rel y z -> rel x z
        }.
    Notation class_of := mixin_of (only parsing). (* not used *)
(**
Packの定義
*)
    Section ClassDef.
      Structure type : Type :=
        Pack {
            sort : Type;
            m : mixin_of sort
          }.
      Local Coercion sort : type >-> Sortclass.
      Print Graph.                          (* [sort] : type >-> Sortclass *)

      Variable cT: type.
      Definition poset_struct : mixin_of cT := (* Coercion cT *)
        let: Pack _ c := cT return mixin_of cT in c.
      Definition valid_op := valid poset_struct.
      Definition rel_op := rel poset_struct.
    End ClassDef.

(**
Exports の宣言
*)
    Module Exports.
      Notation posetMixin := mixin_of.
      Notation posetType := type.
      Notation PosetMixin := Mixin.
      Notation PosetType T m := (@Pack T m).

      Notation "x <== y" := (rel_op x y) (at level 70, no associativity).
      (* rel ではない！ *)
      Notation Rel := rel_op.
      Notation Valid := valid_op.
      Coercion sort : type >-> Sortclass.

      Section POSETLemmas.
        Variable T : posetType.

        Lemma poset_refl (x : T) : x <== x.
        Proof.
          case: T x => tp [rel Hv Href Hasym Htrans x].
            by apply: Href.
        Qed.

        Lemma poset_asym (x y : T) : x <== y -> y <== x -> x = y.
        Proof.
          case: T x y => tp [rel Hv Href Hasym Htrans x y].
            by apply Hasym.
        Qed.

        Lemma poset_trans (y x z : T) : x <== y -> y <== z -> x <== z.
        Proof.
          case: T x y z => tp [rel Hv Href Hasym Htrans x y z].
            by apply Htrans.
        Qed.
      End POSETLemmas.
    End Exports.
  End POSET.
  Export POSET.Exports.                    (* Exportsをexportする。 *)

(**
自然数のPOSETを定義する。
 *)
  Check leqnn : forall n : nat, n <= n.

  Lemma eqn_leq' : forall m n : nat, m <= n -> n <= m -> m = n.
  Proof.
    move=> m n.
    elim: m n => [|m IHm] [|n] //.
    move=> H1 H2; congr (_ .+1); move: H1 H2.
      by apply (IHm n).
  Qed.

  Check leq_trans : forall n m p : nat, m <= n -> n <= p -> m <= p.

  Definition nat_posetMixin :=
    PosetMixin
      (fun _ => id true)                    (* valid *)
      leqnn                                 (* ref *)
      eqn_leq'                              (* asym *)
      leq_trans.                            (* trans *)

  Canonical nat_posetType := PosetType nat nat_posetMixin.
  Print Canonical Projections. (* nat <- POSETDef.sort ( nat_posetType ) *)

  Compute 1 <== 1.                          (* true *)
  Compute 1 <== 2.                          (* true *)
  Compute 2 <== 1.                          (* false *)

  Section PosetExamples.
    Variables x y z : nat.

    Check Rel : forall cT : posetType, cT -> cT -> bool.
    About "_ <== _".                          (* Rel := POSET.rel_op *)

    Goal x <== x.
    Proof.
        by apply: poset_refl.
    Qed.

    Goal x <== y -> y <== x -> x = y.
    Proof.
        by apply: poset_asym.
    Qed.

    Goal x <== y -> y <== z -> x <== z.
    Proof.
        by apply: poset_trans.
    Qed.
  End PosetExamples.
End Poset.

(* END *)


From Hammer Require Import Hammer.

Require Import PeanoNat.

Local Open Scope nat_scope.

Notation plus_0_l := Nat.add_0_l (compat "8.4").
Notation plus_0_r := Nat.add_0_r (compat "8.4").
Notation plus_comm := Nat.add_comm (compat "8.4").
Notation plus_assoc := Nat.add_assoc (compat "8.4").

Notation plus_permute := Nat.add_shuffle3 (compat "8.4").

Definition plus_Snm_nSm : forall n m, S n + m = n + S m :=
Peano.plus_n_Sm.

Lemma plus_assoc_reverse n m p : n + m + p = n + (m + p).
Proof. hammer_hook "Plus" "Plus.plus_assoc_reverse".
symmetry. apply Nat.add_assoc.
Qed.

Lemma plus_reg_l n m p : p + n = p + m -> n = m.
Proof. hammer_hook "Plus" "Plus.plus_reg_l".
apply Nat.add_cancel_l.
Qed.

Lemma plus_le_reg_l n m p : p + n <= p + m -> n <= m.
Proof. hammer_hook "Plus" "Plus.plus_le_reg_l".
apply Nat.add_le_mono_l.
Qed.

Lemma plus_lt_reg_l n m p : p + n < p + m -> n < m.
Proof. hammer_hook "Plus" "Plus.plus_lt_reg_l".
apply Nat.add_lt_mono_l.
Qed.

Lemma plus_le_compat_l n m p : n <= m -> p + n <= p + m.
Proof. hammer_hook "Plus" "Plus.plus_le_compat_l".
apply Nat.add_le_mono_l.
Qed.

Lemma plus_le_compat_r n m p : n <= m -> n + p <= m + p.
Proof. hammer_hook "Plus" "Plus.plus_le_compat_r".
apply Nat.add_le_mono_r.
Qed.

Lemma plus_lt_compat_l n m p : n < m -> p + n < p + m.
Proof. hammer_hook "Plus" "Plus.plus_lt_compat_l".
apply Nat.add_lt_mono_l.
Qed.

Lemma plus_lt_compat_r n m p : n < m -> n + p < m + p.
Proof. hammer_hook "Plus" "Plus.plus_lt_compat_r".
apply Nat.add_lt_mono_r.
Qed.

Lemma plus_le_compat n m p q : n <= m -> p <= q -> n + p <= m + q.
Proof. hammer_hook "Plus" "Plus.plus_le_compat".
apply Nat.add_le_mono.
Qed.

Lemma plus_le_lt_compat n m p q : n <= m -> p < q -> n + p < m + q.
Proof. hammer_hook "Plus" "Plus.plus_le_lt_compat".
apply Nat.add_le_lt_mono.
Qed.

Lemma plus_lt_le_compat n m p q : n < m -> p <= q -> n + p < m + q.
Proof. hammer_hook "Plus" "Plus.plus_lt_le_compat".
apply Nat.add_lt_le_mono.
Qed.

Lemma plus_lt_compat n m p q : n < m -> p < q -> n + p < m + q.
Proof. hammer_hook "Plus" "Plus.plus_lt_compat".
apply Nat.add_lt_mono.
Qed.

Lemma le_plus_l n m : n <= n + m.
Proof. hammer_hook "Plus" "Plus.le_plus_l".
apply Nat.le_add_r.
Qed.

Lemma le_plus_r n m : m <= n + m.
Proof. hammer_hook "Plus" "Plus.le_plus_r".
rewrite Nat.add_comm. apply Nat.le_add_r.
Qed.

Theorem le_plus_trans n m p : n <= m -> n <= m + p.
Proof. hammer_hook "Plus" "Plus.le_plus_trans".
intros. now rewrite <- Nat.le_add_r.
Qed.

Theorem lt_plus_trans n m p : n < m -> n < m + p.
Proof. hammer_hook "Plus" "Plus.lt_plus_trans".
intros. apply Nat.lt_le_trans with m. trivial. apply Nat.le_add_r.
Qed.

Lemma plus_is_O n m : n + m = 0 -> n = 0 /\ m = 0.
Proof. hammer_hook "Plus" "Plus.plus_is_O".
destruct n; now split.
Qed.

Definition plus_is_one m n :
m + n = 1 -> {m = 0 /\ n = 1} + {m = 1 /\ n = 0}.
Proof. hammer_hook "Plus" "Plus.plus_is_one".
destruct m as [| m]; auto.
destruct m; auto.
discriminate.
Defined.

Notation plus_permute_2_in_4 := Nat.add_shuffle1 (compat "8.4").

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

Lemma plus_tail_plus : forall n m, n + m = tail_plus n m.
Proof. hammer_hook "Plus" "Plus.plus_tail_plus".
induction n as [| n IHn]; simpl; auto.
intro m; rewrite <- IHn; simpl; auto.
Qed.

Lemma succ_plus_discr n m : n <> S (m+n).
Proof. hammer_hook "Plus" "Plus.succ_plus_discr".
apply Nat.succ_add_discr.
Qed.

Lemma n_SSn n : n <> S (S n).
Proof. hammer_hook "Plus" "Plus.n_SSn".  exact ((succ_plus_discr n 1)). Qed.

Lemma n_SSSn n : n <> S (S (S n)).
Proof. hammer_hook "Plus" "Plus.n_SSSn".  exact ((succ_plus_discr n 2)). Qed.

Lemma n_SSSSn n : n <> S (S (S (S n))).
Proof. hammer_hook "Plus" "Plus.n_SSSSn".  exact ((succ_plus_discr n 3)). Qed.

Hint Immediate plus_comm : arith.
Hint Resolve plus_assoc plus_assoc_reverse : arith.
Hint Resolve plus_le_compat_l plus_le_compat_r : arith.
Hint Resolve le_plus_l le_plus_r le_plus_trans : arith.
Hint Immediate lt_plus_trans : arith.
Hint Resolve plus_lt_compat_l plus_lt_compat_r : arith.

Require Import Le Lt.


Require Import List.

(** We'll use [countdown] to help test our list functions. *)
Fixpoint countdown (n: nat) :=
  match n with
    | O => nil
    | S m => n :: countdown m
  end.

(** In lecture, we noticed a simple relationship between [length] and [countdown]: *)
Lemma length_countdown:
  forall n, length (countdown n) = n.
Proof.
  (** Consider arbitrary [n]. *)
  intro. induction n.


(* Function composition *)

Definition funcomp {X Y Z} (g : Y -> Z) (f : X -> Y)  :=
  fun x => g (f x).

Lemma funcomp_assoc {W X Y Z} (g: Y -> Z) (f: X -> Y) (h: W -> X) :
  funcomp g (funcomp f h) = (funcomp (funcomp g f) h).
Proof.
  reflexivity.
Qed.

Definition ap {X Y} (f : X -> Y) {x y : X} (p : x = y) : f x = f y :=
  match p with eq_refl => eq_refl end.

(** ** Functor Instances

Exemplary functor instances needed to make Autosubst's generation possible for functors.
Two things are important:
1. The names are fixed.
2. For Coq to check termination, also the proofs have to be closed with Defined.
 *)

(** *** List Instance *)
Require Import List.

Definition list_map {A B: Type} (f: A -> B) (l: list A) := @List.map A B f l.

Definition list_ext {A B} {f g : A -> B} :
  (forall x, f x = g x) -> forall xs, list_map f xs = list_map g xs.
  intros H. induction xs. reflexivity.
  cbn. f_equal. apply H. apply IHxs.
Defined.

Definition list_id {A}  { f : A -> A} :
  (forall x, f x = x) -> forall xs, list_map f xs = xs.
Proof.
  unfold list_map.
  intros H. induction xs. reflexivity.
  cbn. rewrite H. rewrite IHxs; eauto.
Defined.

Definition list_comp {A B C} {f: A -> B} {g: B -> C} {h} :
  (forall x, (funcomp  g f) x = h x) -> forall xs, map g (map f xs) = map h xs.
Proof.
  unfold list_map.
  induction xs. reflexivity.
  cbn. rewrite <- H. f_equal. apply IHxs.
Defined.

(** *** Prod Instance *)

Definition prod_map {A B C D} (f : A -> C) (g : B -> D) (p : A * B) :
  C * D.
Proof.
  destruct p as [a b]. split.
  exact (f a). exact (g b).
Defined.

Definition prod_id {A B} {f : A -> A} {g : B -> B} :
  (forall x, f x = x) -> (forall x, g x = x) -> forall p, prod_map f g p = p.
Proof.
  intros H0 H1. destruct p. cbn. f_equal; [ apply H0 | apply H1 ].
Defined.

Definition prod_ext {A B C D} {f f' : A -> C} {g g': B -> D} :
  (forall x, f x = f' x) -> (forall x, g x = g' x) -> forall p, prod_map f g p = prod_map f' g' p.
Proof.
  intros H0 H1. destruct p as [a b]. cbn. f_equal; [ apply H0 | apply H1 ].
Defined.

Definition prod_comp {A B C D E F} {f1 : A -> C} {g1 : C -> E} {h1 : A -> E} {f2: B -> D} {g2: D -> F} {h2 : B -> F}:
  (forall x, (funcomp  g1 f1) x = h1 x) -> (forall x, (funcomp g2 f2) x = h2 x) -> forall p, prod_map g1 g2 (prod_map f1 f2 p) = prod_map h1 h2 p.
Proof.
  intros H0 H1. destruct p as [a b]. cbn. f_equal; [ apply H0 | apply H1 ].
Defined.

(* a.d. TODO hints outside of sections without explicit locality are deprecated. Is this even used in the first place?  *)
(* but with 8.13.1 the attribute is forbidden. So what's the correct way to use this? *)
(* #[ global ] *)
Hint Rewrite in_map_iff : FunctorInstances.

(* Declaring the scopes that all our notations will live in *)
Declare Scope fscope.
Declare Scope subst_scope.

Ltac eta_reduce :=
  repeat match goal with
         | [|- context[fun x => ?f x]] => change (fun x => f x) with f (* eta reduction *)
         end.

Ltac minimize :=
  repeat match goal with
         | [|- context[fun x => ?f x]] => change (fun x => f x) with f (* eta reduction *)
         | [|- context[fun x => ?g (?f x)]] => change (fun x => g (f x)) with (funcomp g f) (* funcomp folding *)
         end.

(* had to add this tactic abbreviation because I could not print a setoid_rewrite with the arrow *)
Ltac setoid_rewrite_left t := setoid_rewrite <- t.

Ltac check_no_evars :=
  match goal with
  | [|- ?x] => assert_fails (has_evar x)
  end.

Require Import Setoid Morphisms.

Lemma pointwise_forall {X Y:Type} (f g: X -> Y) :
  (pointwise_relation _ eq f g) -> forall x, f x = g x.
Proof.
  trivial.
Qed.

Instance funcomp_morphism {X Y Z} :
  Proper (@pointwise_relation Y Z eq ==> @pointwise_relation X Y eq ==> @pointwise_relation X Z eq) funcomp.
Proof.
  cbv - [funcomp].
  intros g0 g1 Hg f0 f1 Hf x.
  unfold funcomp. rewrite Hf, Hg.
  reflexivity.
Qed.

Instance funcomp_morphism2 {X Y Z} :
  Proper (@pointwise_relation Y Z eq ==> @pointwise_relation X Y eq ==> eq ==> eq) funcomp.
Proof.
  intros g0 g1 Hg f0 f1 Hf ? x ->.
  unfold funcomp. rewrite Hf, Hg.
  reflexivity.
Qed.

Ltac unfold_funcomp := match goal with
                           | |-  context[(funcomp ?f ?g) ?s] => change ((funcomp f g) s) with (f (g s))
                           end.

Require Import Coq.Logic.FunctionalExtensionality.
Require Import Program.Tactics.
Tactic Notation "autosubst_nointr" tactic(t) :=
  let m := fresh "marker" in
  pose (m := tt);
  t; revert_until m; clear m.

Ltac fext := autosubst_nointr repeat (
  match goal with
    [ |- ?x = ?y ] =>
    (refine (@functional_extensionality_dep _ _ _ _ _) ||
     refine (@forall_extensionality _ _ _ _) ||
     refine (@forall_extensionalityP _ _ _ _) ||
     refine (@forall_extensionalityS _ _ _ _)); intro
  end).

(* TODO added here but need the _axioms library *)
Definition cod X A:  Type :=  X -> A.

Definition cod_map {X} {A B} (f : A -> B) (p : X -> A) :
  X -> B.
Proof.
  intros x. exact (f (p x)).
Defined.

(** Note that this requires functional extensionality. *)
Definition cod_id {X} {A} {f : A -> A} :
  (forall x, f x = x) -> forall (p: X -> A), cod_map f p = p.
Proof. intros H p. unfold cod_map.
       fext.
       congruence. Defined.

Definition cod_ext {X} {A B} {f f' : A -> B} :
  (forall x, f x = f' x) -> forall (p: X -> A), cod_map f p = cod_map f' p.
Proof. intros H p. unfold cod_map. fext. congruence. Defined.

Definition cod_comp {X} {A B C} {f : A -> B} {g : B -> C} {h} :
  (forall x, (funcomp g f) x =  h x) -> forall (p: X -> _), cod_map g (cod_map f p) = cod_map h p.
Proof. intros H p. unfold cod_map. fext. intros x. apply H. Defined.


(* Fermat の小定理 *)
(* 2014_3_30 *)
(* suahrahiromichi@gmail.com *)

Require Import ssreflect ssrfun ssrbool eqtype ssrnat.
Require Import fintype div bigop prime binomial.

(**
 全体の証明は、
 http://ja.wikipedia.org/wiki/フェルマーの小定理
 証明(1) に沿う、つもり。
 *)

(* この補題は、Coqによる定理証明 2013 12, p.14 *)
(* 乱数列の網羅性 著者：坂口和彦さん *)
Lemma expSS a p :
  a.+1 ^ p.+1 =
  (a ^ p.+1).+1 + \sum_(1 <= k < p.+1 | 0 < k < p.+1) 'C(p.+1, k) * a ^ k.
Proof.
  rewrite -add1n Pascal big_ord_recl big_ord_recr /= /bump /= !add1n
                 bin0 binn subn0 subnn !mul1n exp1n add1n -addnS addnC.
  rewrite -big_nat.
  rewrite (big_addn 0 p.+1 1) subn1 /= big_mkord.
  by congr (_ + _); apply eq_bigr => m _; rewrite exp1n add1n addn1 mul1n.
Qed.

(* pが素数なら、二項定理を使って (m + 1) ^ p を展開したときの、
  m^p + C + 1 の 「C」がpで割りきれることを証明する。 *)
Lemma bino_body__p m p :
  prime p ->
  (\sum_(1 <= i < p | 0 < i < p) 'C(p, i) * m ^ i) %% p == 0.
Proof.
  apply big_ind => //.
    by rewrite mod0n.
  move=> m1 m2 H1 H2 Hp.
    by apply dvdn_add; [apply H1, Hp | apply H2, Hp].
  move=> i H0 Hp.
    by apply dvdn_mulr, prime_dvd_bin.
Qed.

Lemma mod_m_1p__mp_1 m p :
  prime p.+1 -> m.+1 ^ p.+1 = (m ^ p.+1).+1 %[mod p.+1].
Proof.
  move=> Hp.
  apply/eqP.
  rewrite expSS addSn (eqn_modDl 1)
  -{2}(addn0 (m ^ p.+1)) (eqn_modDl (m ^ p.+1)).
  apply/eqP.
  have H := (bino_body__p m p.+1 Hp).
  move/eqP in H.
  by rewrite mod0n.
Qed.

Lemma mod_1n a b p : a = b %[mod p] -> a.+1 = b.+1 %[mod p].
Proof.
  move=> /eqP H.                            (* move/eqP => H *)
  apply/eqP.
  by rewrite -(addn1 a) -(addn1 b) (eqn_modDr 1 a b p).
Qed.

Theorem Fermat a p:
  prime p.+1 -> a ^ p.+1 = a %[mod p.+1].
Proof.
  move=> Hp.
  elim: a => [|a].
  (* a = 0 *)
  by rewrite exp0n.
  elim: a => [|a] H0.
  (* a = 1 *)
  by rewrite exp1n.
  move=> H1 {H0} {H1}.
  elim: a => [|a].
  (* a = 2 *)
  rewrite (mod_m_1p__mp_1 1 p); last done.  (* last は prime p *)
    by rewrite exp1n.
  (* a = k + 1 *)
  move=> H2.
  rewrite (mod_m_1p__mp_1 a.+2); last done. (* last は prime p *)
  rewrite -addn3.
  Check (mod_1n (a.+2 ^ p.+1) (a + 2) p.+1).
  rewrite (mod_1n (a.+2 ^ p.+1) (a + 2) p.+1).
    by rewrite addn2 addn3.
      by rewrite addn2.
Qed.

(* 使わなかった補題 *)
Lemma mod_2_3n a b p : a = b.+2 %[mod p] -> a.+1 = b.+3 %[mod p].
Proof.
  move=> H.
  apply/eqP.
  move/eqP in H.
  Check eqn_modDr 1 a b.+2 p.
  rewrite -(eqn_modDr 1 a b.+2 p) in H.
  rewrite -addn2 in H.
  rewrite -(addnA b 2 1) in H.
  rewrite addn3 in H.
  rewrite addn1 in H.
  done.
Qed.

Lemma modn_trans l m n d :
  l = m %[mod d] -> m = n %[mod d] -> l = n %[mod d].
Proof.
  move=> Hlm Hmn.
  by rewrite Hlm.
Qed.

(* END *)


Require Import Coq.micromega.Lia.
Require Import Coq.Arith.Compare_dec.
Import List.ListNotations.

Require Import Leapfrog.P4automaton.
Require Import Leapfrog.FinType.
Require Import Leapfrog.ConfRel.
Require Import Leapfrog.Relations.
Require Leapfrog.Bisimulations.Semantic.
Module BS := Leapfrog.Bisimulations.Semantic.

Section Leaps.
  Variable (a: p4automaton).
  Notation conf := (configuration a).

  (* Minimal number of steps to be taken from a pair of states before a
     state-to-state transition can be triggered, i.e., when one of the buffers
     is filled up. *)
  Definition leap_size (q1 q2: conf) : nat :=
    match conf_state q1, conf_state q2 with
    | inl s1, inl s2 => min (configuration_room_left q1) (configuration_room_left q2)
    | inl s1, inr _ => configuration_room_left q1
    | inr _, inl s2 => configuration_room_left q2
    | inr _, inr _ => 1
    end.

  (* Closure operation on bisimulations which is the basis which lets us
     instantiate "bisimulation up-to interpolation", an intermediate step
     relating bisimulations to bisimulations with leaps. *)
  Inductive close_interpolate (R: rel conf) : rel conf :=
    | InterpolateBase:
        forall q1 q2,
          R q1 q2 -> close_interpolate _ q1 q2
    | InterpolateStep
        (q1 q2: conf)
        (b: bool):
        close_interpolate R q1 q2 ->
        (forall buf,
            length buf = leap_size q1 q2 ->
            R (follow q1 buf) (follow q2 buf)) ->
        close_interpolate R (step q1 b) (step q2 b).

  (* Co-inductive definition of bisimilarity with leaps, later shown to be
     equivalent to the up-to based definition given above. *)
  CoInductive bisimilar_with_leaps: rel conf :=
  | Bisimilar:
      forall q1 q2,
        (accepting q1 <-> accepting q2) ->
        (forall buf,
          length buf = leap_size q1 q2 ->
          bisimilar_with_leaps (follow q1 buf) (follow q2 buf)) ->
        bisimilar_with_leaps q1 q2.

End Leaps.


C02W82DBHV2R:~ i847419$ coqtop
Welcome to Coq 8.8.0 (April 2018)

Coq < Theorem exp001 : (forall I R : Prop, ((I /\ ~R) /\ I) -> ~R).
1 subgoal

  ============================
  forall I R : Prop, (I /\ ~ R) /\ I -> ~ R

exp001 < Proof.

exp001 < intros.
1 subgoal

  I, R : Prop
  H : (I /\ ~ R) /\ I
  ============================
  ~ R

exp001 < destruct H.
1 subgoal

  I, R : Prop
  H : I /\ ~ R
  H0 : I
  ============================
  ~ R

exp001 < destruct H.
1 subgoal

  I, R : Prop
  H : I
  H1 : ~ R
  H0 : I
  ============================
  ~ R

exp001 < exact H1.
No more subgoals.

exp001 < Qed.
exp001 is defined


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

Require Import List Arith Bool Lia Eqdep_dec.

From Undecidability.Shared.Libs.DLW.Utils
  Require Import utils_tac utils_list utils_nat finite.

From Undecidability.Shared.Libs.DLW.Vec
  Require Import pos vec.

From Undecidability.TRAKHTENBROT
  Require Import notations fol_ops fo_sig fo_terms fo_logic fo_sat.

Import fol_notations.

Set Implicit Arguments.

(* * From binary singleton to n-ary singleton with n >= 2 *)

Local Notation ø := vec_nil.

(* The reduction could be made to work for (infinite) SAT only *)

Section Sig2_Sig_n_encoding.

  Variable (n : nat).

  Notation Σ2 := (Σrel 2).
  Notation Σn := (Σrel (S (S n))).

  (* The encoding is trivial here : replace R2(x,y) with Rn(x,y,...,y) *)

  Fixpoint Σ2_Σn (A : fol_form Σ2) : fol_form Σn :=
    match A with
      | ⊥              => ⊥
      | fol_atom   _ v => let x := Σrel_var (vec_head v)            in
                          let y := Σrel_var (vec_head (vec_tail v))
                          in  @fol_atom Σn tt (£x##vec_set_pos (fun _ => £y))
      | fol_bin b A B  => fol_bin b (Σ2_Σn A) (Σ2_Σn B)
      | fol_quant q A  => fol_quant q (Σ2_Σn A)
     end.

  Section correctness.

    Variable (X : Type) (M2 : fo_model Σ2 X) (Mn : fo_model Σn X).

    Notation "⟪ A ⟫" := (fun ψ => fol_sem M2 ψ A).
    Notation "⟪ A ⟫'" := (fun φ => fol_sem Mn φ A) (at level 1, format "⟪ A ⟫'").

    Let P2 a b := fom_rels M2 tt (a##b##ø).
    Let Pn a b := fom_rels Mn tt (a##vec_set_pos (fun _ => b)).

    Hypothesis HP : forall x y, P2 x y <-> Pn x y.

    Lemma Σ2_Σn_correct (A : fol_form Σ2) φ : ⟪ A ⟫ φ <-> ⟪Σ2_Σn A⟫' φ.
    Proof.
      revert φ.
      induction A as [ | [] v | b A HA B HB | q A HA ]; intros phi.
      + simpl; tauto.
      + vec split v with a; vec split v with b; vec nil v; clear v; revert a b.
        intros [ a | [] ] [ b | [] ]; unfold Σ2_Σn; simpl; rew fot.
        rewrite vec_map_set_pos; apply HP.
      + simpl; apply fol_bin_sem_ext; auto.
      + simpl; apply fol_quant_sem_ext; intro; auto.
    Qed.

  End correctness.

  Variable (A : fol_form Σ2).

  Section soundness.

    Variables (X : Type)
              (M2 : fo_model Σ2 X)
              (H1 : finite_t X)
              (H2 : fo_model_dec M2)
              (phi : nat -> X)
              (H3 : fol_sem M2 phi A).

    Let Mn : fo_model Σn X.
    Proof.
      exists.
      + intros [].
      + intros []; simpl.
        intros v.
        exact (fom_rels M2 tt (vec_head v##vec_head (vec_tail v)##ø)).
    Defined.

    Local Lemma Σ2_Σn_sound_loc : fo_form_fin_dec_SAT (Σ2_Σn A).
    Proof.
      exists X, Mn, H1.
      exists. { intros [] ?; apply H2. }
      exists phi.
      revert H3.
      apply Σ2_Σn_correct; simpl; tauto.
    Qed.

  End soundness.

  Lemma Σ2_Σn_soundness :
        fo_form_fin_dec_SAT A
     -> fo_form_fin_dec_SAT (Σ2_Σn A).
  Proof.
    intros (X & M2 & H1 & H2 & phi & H3).
    apply Σ2_Σn_sound_loc with (M2 := M2) (phi := phi); auto.
  Qed.

  Section completeness.

    Variables (X : Type)
              (Mn : fo_model Σn X)
              (H1 : finite_t X)
              (H2 : fo_model_dec Mn)
              (phi : nat -> X)
              (H3 : fol_sem Mn phi (Σ2_Σn A)).

    Let M2 : fo_model Σ2 X.
    Proof.
      exists.
      + intros [].
      + intros []; simpl.
        intros v.
        exact (fom_rels Mn tt (vec_head v##vec_set_pos (fun _ => vec_head (vec_tail v)))).
    Defined.

    Local Lemma Σ2_Σn_complete_loc : fo_form_fin_dec_SAT A.
    Proof.
      exists X, M2, H1.
      exists. { intros [] ?; apply H2. }
      exists phi.
      revert H3.
      apply Σ2_Σn_correct; simpl; tauto.
    Qed.

  End completeness.

  Lemma Σ2_Σn_completeness :
        fo_form_fin_dec_SAT (Σ2_Σn A)
     -> fo_form_fin_dec_SAT A.
  Proof.
    intros (X & Mn & H1 & H2 & phi & H3).
    apply Σ2_Σn_complete_loc with (Mn := Mn) (phi := phi); auto.
  Qed.

End Sig2_Sig_n_encoding.