Add LoadPath "C:\Users\21692\ParcoursRecherche\dossier_final\coq_parcours_recherche\znaidi22\dev\final" as lp.

Load Verbose ordreNat.

Require Import Arith Bool Decidable PeanoNat Coq.Arith.Peano_dec.

(** * Division euclidienne *)

(* division euclidienne

 -------------
 0 = 0 * d + 0

 n = q * d + r     d = r + 1    n = q * d + r     d ≠ r + 1
 ---------------------------    ---------------------------
    S n = (q + 1) * d + 0          S n = q * d + (r + 1)
*)
Fixpoint divisionEuclidienne(n d : nat) : nat * nat.
Proof.
  case n as [ | pn].
  - exact (0, 0).
  - case (divisionEuclidienne pn d) as [q r].
    case (d =? (S r)) as [ | ].
    -- exact (S q, 0).
    -- exact (q, S r).
Defined.

Print divisionEuclidienne.

Example divisionEuclidienne_13_5 : divisionEuclidienne 13 5 = (2, 3).
cbn.
reflexivity.
Qed.

Example divisionEuclidienne_14_5 : divisionEuclidienne 14 5 = (2, 4).
cbn.
reflexivity.
Qed.

Example divisionEuclidienne_15_5 : divisionEuclidienne 15 5 = (3, 0).
cbn.
reflexivity.
Qed.

Example divisionEuclidienne_13_0 : divisionEuclidienne 13 0 = (0, 13).
cbn.
reflexivity.
Qed.

Definition quotient(n d : nat) : nat.
  case (divisionEuclidienne n d) as [q _].
  exact q.
Defined.

Print quotient.

Definition reste(n d : nat) : nat.
  case (divisionEuclidienne n d) as [_ r].
  exact r.
Defined.

Print reste.

Proposition divEuclidienne_decomposition :
  forall n d, n = (quotient n d) * d + (reste n d).
Proof.
  unfold quotient, reste.
  fix HR 1.
  intros n d.
  case n as [ | pn].
  - cbn.
    reflexivity.
  - cbn.
    case (divisionEuclidienne pn d) as [q r] eqn:divE.
    case (d =? (S r)) as [ | ] eqn:egReste.
    -- rewrite (HR pn d).
       rewrite divE.
       rewrite (beq_nat_true _ _ egReste).
       ring.
    -- rewrite (HR pn d).
       rewrite divE.
       ring.
Qed.
(* Un cas particulier : d = 0. Reste. *)
Proposition divEuclidienne_resteDivParZero : forall n, (reste n 0 = n).
Proof.
  intro n.
  rewrite (divEuclidienne_decomposition n 0) at 2.
  ring.
Qed.
(* Un cas particulier : d = 0. Quotient. *)
Proposition divEuclidienne_quotientDivParZero : forall n, (quotient n 0 = 0).
Proof.
  unfold quotient.
  fix HR 1.
  intro n.
  case n as [ | pn].
  - cbn.
    reflexivity.
  - cbn.
    case (divisionEuclidienne pn 0) as [q r] eqn:eqDiv.
    pose (hr := HR pn).
    rewrite eqDiv in hr.
    assumption.
Qed.

(* Cas général : d > 0.
   Majoration du reste : strictement par d.

----------------------
0 = 0 * d + 0 => 0 < d

n = q * d + r     d = r + 1
------------------------------
S n = (q + 1) * d + 0 => 0 < d

n = q * d + r     d ≠ r + 1  HR : r < d
-----------------------------------------------------------
S n = q * d + (r + 1) => r + 1 <= d, d ≠ r + 1 => r + 1 < d
*)
Proposition divEuclidienne_majorationReste :
  forall n d, (0 < d) -> (reste n d) < d.
Proof.
  unfold reste.
  fix HR 1.
  intros n d dPos.
  case n as [ | pn].
  - cbn.
    assumption.
  - cbn.
    case (divisionEuclidienne pn d) as [q r] eqn:eqDiv.
    case (d =? S r) as [ | ] eqn:eqD.
    -- assumption.
    -- apply inferieurStrict_lt.
       split.
       --- pose (hr := HR pn d).
           rewrite eqDiv in hr.
           apply hr.
           assumption.
       --- intro abs.
           Search((_ =? _ = false) -> ~(_ = _)).
           apply (beq_nat_false _ _ eqD).
           symmetry.
           assumption.
Qed.

(* Cas général : d > 0. Unicité de la décomposition euclidienne.

(q1 * d + r1) = (q2 * d + r2)  (r1 < d)  (r2 < d)
------------------------------------------------
      (q1 = q2) ∧ (r1 = r2)

Induction sur q1, décomposition de q2
- q1 = 0, q2 = 0 : trivial
- q1 = 0, q2 = S p2 : r1 = d + ..., r1 < d, absurde.
- q1 = S p1, q2 = 0 : absurde aussi.
- q1 = S p1, q2 = S p2 : HR / p1, p2 r1, r2 *)
Lemma decompositionEuclidienne_unicite :
  forall d, (0 < d) -> forall q1 r1 q2 r2,
      ((q1 * d + r1) = (q2 * d + r2))
      -> (r1 < d) -> (r2 < d)
      -> (q1 = q2) /\ (r1 = r2).
Proof.
  intros d dPos.
  fix HR 1.
  intros q1 r1 q2 r2 egDec maj1 maj2.
  case q1 as [ | p1].
  - case q2 as [ | p2].
    + split.
      * reflexivity.
      * cbn in egDec.
        assumption.
    + exfalso.
      cbn in egDec.
      Search(_ <= _ + _). (* Nat.le_add_r *)
      Search(_ <= _ -> _ <= _ -> _ = _). (* Nat.le_antisymm *)
      assert (d <= r1) as oppMaj1.
      {
        rewrite egDec.
        Search(_ + (_ + _)).
        rewrite plus_assoc_reverse.
        apply Nat.le_add_r.
      }
      Search (S _ <= _).
      apply (Nat.nle_succ_diag_l r1).
      transitivity d; assumption.
  - case q2 as [ | p2].
    + exfalso.
      cbn in egDec.
      assert (d <= r2) as oppMaj2.
      {
        rewrite <- egDec.
        Search(_ + (_ + _)).
        rewrite plus_assoc_reverse.
        apply Nat.le_add_r.
      }
      apply (Nat.nle_succ_diag_l r2).
      transitivity d; assumption.
    + cbn in egDec.
      assert(p1 * d + r1 = p2 * d + r2) as egDec'.
      {
        Search(_ + _ = _ + _).
        rewrite plus_assoc_reverse in egDec.
        rewrite plus_assoc_reverse in egDec.
        apply (plus_reg_l _ _ d) in egDec.
        assumption.
      }
      pose (hr := HR p1 r1 p2 r2 egDec' maj1 maj2).
      case hr as [egQ egR].
      split.
      * rewrite egQ.
        reflexivity.
      * assumption.
Qed.

(* Cas général : d > 0. Caractérisation du quotient et du reste
   par décomposition euclidienne. *)
Proposition divEuclidienne_caracterisation :
  forall d, (0 < d) ->
       forall n q r, (n = q * d + r) -> (r < d)
                -> ((quotient n d = q) /\ (reste n d = r)).
Proof.
  intros d dPos n q r egN majR.
  rewrite (divEuclidienne_decomposition n d) in egN.
  apply decompositionEuclidienne_unicite with d.
  - assumption.
  - assumption.
  - apply divEuclidienne_majorationReste.
    assumption.
  - assumption.
Qed.

Proposition divEuclidienne_caracterisationReste :
  forall d, (0 < d) ->
       forall n q r, (n = q * d + r) -> (r < d)
                -> (reste n d = r).
Proof.
  intros d dPos n q r eqN majR.
  case (divEuclidienne_caracterisation d dPos n q r eqN majR) as [_ eqR].
  assumption.
Qed.

(* Premières applications de la caractérisation par décomposition du reste :
   le caractère cyclique et l'idempotence. *)
Proposition reste_cycle :
  forall d, reste d d = 0.
Proof.
  intro d.
  case d as [ | pd].
  - reflexivity.
  - apply divEuclidienne_caracterisationReste with 1.
    -- Search(0 < S _).
       apply Nat.lt_0_succ.
    -- ring.
    -- apply Nat.lt_0_succ.
Qed.

Proposition reste_idempotence :
  forall d n, reste (reste n d) d = reste n d.
Proof.
  intros d n.
  case d as [ | pd].
  - rewrite divEuclidienne_resteDivParZero.
    reflexivity.
  - apply divEuclidienne_caracterisationReste with 0.
    -- Search(0 < S _).
       apply Nat.lt_0_succ.
    -- reflexivity.
    -- apply divEuclidienne_majorationReste.
       apply Nat.lt_0_succ.
Qed.

(* Une seconde application de la caractérisation par décomposition :
   le calcul du reste d'une somme *)
Proposition reste_preMorphismeAdditif :
  forall d m n, reste (m + n) d = reste ((reste m d) + (reste n d)) d.
Proof.
  intros d m n.
  case d as [ | pd].
  - (* cas 'd = 0' *)
    repeat (rewrite divEuclidienne_resteDivParZero).
    reflexivity.
  - (* cas 'd = S pd' *)
    pose (qm := quotient m (S pd)).
    pose (qn := quotient n (S pd)).
    pose (rm := reste m (S pd)).
    pose (rn := reste n (S pd)).
    pose (q_rmrn := quotient (rm + rn) (S pd)).
    pose (r_rmrn := reste (rm + rn) (S pd)).
    (* m + n = (qm + qn + q_rmrn) * d + r_rmrn *)
    fold rm.
    fold rn.
    fold r_rmrn.
    apply divEuclidienne_caracterisationReste with (qm + qn + q_rmrn).
    -- Search(0 < S _).
       apply Nat.lt_0_succ.
    -- rewrite (divEuclidienne_decomposition m (S pd)).
       rewrite (divEuclidienne_decomposition n (S pd)).
       fold qm qn rm rn.
       transitivity (qm * S pd + qn * S pd + (rm + rn)).
       ring.
       rewrite (divEuclidienne_decomposition (rm + rn) (S pd)).
       fold q_rmrn r_rmrn.
       ring.
    -- apply divEuclidienne_majorationReste.
       Search(0 < S _).
       apply Nat.lt_0_succ.
Qed.

(* Définition de l'équivalence modulo d. *)
Definition modulo_egalite(d m n: nat) : Prop.
  exact (reste m d = reste n d).
Defined.

Proposition modulo_egalite_reflexivite : forall d n, modulo_egalite d n n.
Proof.
  intros d n.
  unfold modulo_egalite.
  reflexivity.
Qed.

Proposition modulo_egalite_symetrie : forall d m n, modulo_egalite d m n -> modulo_egalite d n m.
Proof.
  intros d m n.
  unfold modulo_egalite.
  intro h.
  symmetry.
  assumption.
Qed.

Proposition modulo_egalite_transitivite :
  forall d n1 n2 m, modulo_egalite d n1 m -> modulo_egalite d m n2 -> modulo_egalite d n1 n2.
Proof.
  unfold modulo_egalite.
  intros d n1 n2 m eg1 eg2.
  transitivity (reste m d); assumption.
Qed.
(* Compatibilité avec l'addition de l'équivalence modulo. *)
Proposition modulo_egalite_compatibiliteAddition :
  forall d, forall m1 n1 m2 n2,
    modulo_egalite d m1 m2
    -> modulo_egalite d n1 n2
    -> modulo_egalite d (m1 + n1) (m2 + n2).
Proof.
  intros d m1 n1 m2 n2 egM egN.
  unfold modulo_egalite.
  rewrite (reste_preMorphismeAdditif d m1 n1).
  rewrite (reste_preMorphismeAdditif d m2 n2).
  rewrite egM.
  rewrite egN.
  reflexivity.
Qed.

Print Nat.sub.

(* Définition d'un opposé modulo. *)
Definition modulo_oppose(n d : nat) : nat.
  exact (reste (Nat.sub d (reste n d)) d).
Defined.

(* Correction de l'opposé : (n modulo d) + (opposé modulo d de n) = 0 modulo d.
- (n%d + (d - n%d)%d)%d = 0 ?
- (n%d + (d - n%d)%d)%d
  = ((n%d)%d + (d - n%d)%d)%d  idempotence
  = (n%d + (d - n%d))%d        pré-morphisme additif
  = d%d                        (0 < d) -> (n%d < d)
  = 0
*)
Proposition modulo_oppose_correction :
  forall n d, (0 < d) -> modulo_egalite d ((reste n d) + (modulo_oppose n d)) 0.
Proof.
  intros n d dPos.
  unfold modulo_egalite.
  unfold modulo_oppose.
  rewrite <- (reste_idempotence d n) at 1.
  rewrite <- (reste_preMorphismeAdditif d).
  Search(_ + (_ - _)). (* le_plus_minus_r *)
  assert(reste n d <= d) as majR.
  {
    Search(_ < _ -> _ <= _).
    apply Nat.lt_le_incl.
    apply divEuclidienne_majorationReste.
    assumption.
  }
  erewrite (le_plus_minus_r _ _ majR).
  apply  divEuclidienne_caracterisationReste with (S 0).
  assumption.
  cbn.
  ring.
  cbn.
  assumption.
Qed.

(** * Vers une représentation canonique ?

Avertissement : ci-dessous '(S d)' correspond à 'd' utilisé au dessus.
On exclut ainsi le cas particulier de la relation modulo zéro.

Il est possible de représenter le quotient de nat par l'égalité modulo
(S d) par restriction de nat : on considère l'ensemble '{v : nat & v
<= d}' ou encore '{v : nat & ∃h, v + h = d}'.  Un inconvénient de
cette définition est de recourir à une proposition, autrement dit une
partie non calculatoire.

Il est cependant possible de transformer cette définition en utilisant
une double définition inductive :
- la première vise à décrire les couples '(h, v)' tels que 'v + h = d',
- la seconde vise à décrire leur réunion.

Cette approche présente des difficultés : certaines démonstrations sont difficiles
pour des questions techniques liées aux définitions inductives.

En résumé : 'Modulo d' (pour représenter les classes de la relation modulo '(S d)') :
'{(d, 0), ..., (0, d)}' formé de couples '(h, v)',
avec 'v' la valeur et 'h' le complémentaire. Invariant : 'h + v = d'.

Construction en deux temps.

1. 'ModuloBrut(d : nat) : nat -> Type' - paramétrisation par 'd' et
indexation par 'h'

                                (ModuloBrut d (S h))
---------------- [mb_zero]      -------------------- [mb_succ]
(ModuloBrut d d)                   (ModuloBrut d h)

Interprétation :
- 'ModuloBrut d h' est le type singleton '{(h, v)}', avec 'h + v = d',
la valeur 'v' étant donnée par '(mb_succ^v mb_zero)'.
- La structure des termes est identique à celle des preuves de 'd >= h' (cf. supra).

2. 'Modulo (d : nat)' : somme des singletons '(ModuloBrut d h)'

Modulo(d : nat) : Type.

(h : nat) (ModuloBrut d h)
-------------------------- [modulo]
       Modulo d

Interprétation :
- 'Modulo d = {(d, 0), ..., (0, d)}' - 'nat' modulo '(S d)'
*)

Inductive ModuloBrut(d : nat) : nat -> Type :=
| mb_zero : ModuloBrut d d
| mb_succ : forall h, ModuloBrut d (S h) -> ModuloBrut d h.

Fixpoint moduloBrut_valeur(d h : nat)(mb : ModuloBrut d h) : nat.
Proof.
  case mb as [ | h pmb].
  - exact 0. (* mb_zero évalué en 0 *)
  - exact (S (moduloBrut_valeur _ _ pmb)). (* mb_succ évalué en S *)
Defined.

(* La structure des termes de 'ModuloBrut d h'
correspond exactement à celle des preuves de 'SuperieurOuEgal d h'. *)
Proposition moduloBrut_majoration :
  forall (d h : nat)(mb : ModuloBrut d h), SuperieurOuEgal d h.
Proof.
  fix HR 3.
  intros d h mb.
  case mb as [ | h pmb].
  - apply diagonale.
  - apply descenteVerticale.
    exact (HR _ _ pmb).
Defined.

(* L'invariant est bien vérifié. *)
Proposition moduloBrut_invariant :
  forall d h, forall (mb : ModuloBrut d h),
    (moduloBrut_valeur d h mb) + h = d.
Proof.
  fix HR 3.
  intros d h mb.
  case mb as [ | h pmb].
  - cbn.
    reflexivity.
  - cbn.
    pose (hr := HR d (S h) pmb).
    Search(_ + S _).
    rewrite <- plus_n_Sm in hr.
    assumption.
Qed.

(* Somme (réuniondisjointe) des singletons 'ModuloBrut d h'

  h : nat   m : ModuloBrut d h
  ----------------------------
      modulo m  : Modulo d
*)
Inductive Modulo(d : nat) : Type :=
| modulo : forall h, ModuloBrut d h -> Modulo d.

(* Valeur et complémentaire :
   - V (v, h) = v
   - C (v, h) = h
   - invariant : V (v, h) + C (v, h) = d *)
Definition modulo_valeur{d : nat}(m : Modulo d) : nat.
Proof.
  case m as [h mb].
  exact (moduloBrut_valeur _ _ mb).
Defined.

Definition modulo_complementaire{d : nat}(m : Modulo d) : nat.
Proof.
  case m as [h mb].
  exact h.
Defined.

Proposition modulo_invariant :
  forall d, forall (m : Modulo d),
    (modulo_valeur m) + (modulo_complementaire m) = d.
Proof.
  intros d m.
  case m as [h mb].
  cbn.
  apply moduloBrut_invariant.
Qed.

Proposition modulo_valeur_majoration :
  forall d, forall (m : Modulo d),
    (modulo_valeur m) < S d.
Proof.
  intros d m.
  Search(_ <= _ -> _ < S _).
  apply le_lt_n_Sm.
  transitivity ((modulo_valeur m) + (modulo_complementaire m)).
  Search(_ <= _ + _).
  apply Nat.le_add_r.
  rewrite (modulo_invariant d m).
  constructor.
Qed.

(* Structure algébrique de 'Modulo d'
- algèbre sur la signature (0, S) :
  - une constante correspondant à '0',
  - une fonction correspondant au successeur 'S'.
- groupe additif commutatif :
  - loi additive associative et commutative,
  - élément neutre '0',
  - opposé (de valeur égale au reste du successeur du complémentaire).
- anneau commutatif (non traité, mais pourrait l'être) :
  - loi multiplicative associative et commutative,
  - élément neutre '1',
  - pas d'inverse en général, l'inversibilité étant équivalente au fait
    d'être premier avec 'S d' (par application du théorème de Bézout
    https://fr.wikipedia.org/wiki/Th%C3%A9or%C3%A8me_de_Bachet-B%C3%A9zout). *)

(* Modulo d : algèbre sur la signature (0, S). *)

Definition modulo_zero(d : nat) : Modulo d := modulo _ _ (mb_zero d).

Definition moduloBrut_succ{d h : nat}(mb : ModuloBrut d h) : Modulo d.
Proof.
  case h as [ | ph].
  + exact (modulo_zero d).
  + exact (modulo _ _ (mb_succ _ _ mb)).
Defined.

Definition modulo_succ{d : nat}(m : Modulo d) : Modulo d.
Proof.
  case m as [h mb].
  exact (moduloBrut_succ mb).
Defined.

(* Morphisme d'algèbre sur la signature '(0, S)', de 'nat' vers 'Modulo d' (noté M).
   - M 0 = 0
   - M(S n) = S (M n)
   (0 et S étant interprétés de deux manières différentes dans l'algèbre du domaine,
   'nat', et dans l'algèbre image, 'Modulo d') *)
Fixpoint modulo_morphismeNat(d : nat)(n : nat) : Modulo d.
Proof.
  case n as [ | pn].
  - exact (modulo_zero d).
  - exact (modulo_succ (modulo_morphismeNat d pn)).
Defined.

(* Valeur : pré_inverse du morphisme

'V (M n) = R n', où 'R' calcule le reste modulo '(S d)'.
Induction sur 'n'
- n = 0 : V (M 0) = 0 = R 0
- n = S pn : analyse suivant 'M pn'
  - M pn = (0, v) : par l'invariant, v = d.
    - V (M (S pn)) = V (S (0, d)) = V (d, 0) = 0
    - R (S pn) = 0 car HR : V (M pn) = d = R pn
  - M pn = (S h, v) : par l'invariant, v + (S h) = d
    - V (M (S pn)) = V (S (S h, v)) = V (h, S v) = S v
    - R (S pn) = S (R pn) car (HR : v = R pn) et (R pn) < d. *)
Lemma modulo_morphismeNat_valeur :
  forall d, forall n,
    modulo_valeur (modulo_morphismeNat d n) = reste n (S d).
Proof.
  fix HR 2.
  intros d n.
  case n as [ | pn].
  - cbn.
    reflexivity.
  - cbn.
    case (modulo_morphismeNat d pn) as [h mb] eqn:egMorphPn.
    cbn.
    case h as [ | ph].
    + cbn.
      pose (hr := HR d pn).
      rewrite egMorphPn in hr.
      assert(reste pn (S d) = d) as egRestPn.
      {
        rewrite <- hr.
        rewrite <- (modulo_invariant d (modulo d 0 mb)) at 3.
        cbn.
        ring.
      }
      symmetry.
      apply divEuclidienne_caracterisationReste with (S (quotient pn (S d))).
      Search(0 < S _).
      apply Nat.lt_0_succ.
      assert(pn = quotient pn (S d) * S d + d) as egPn.
      {
        rewrite <- egRestPn at 3.
        apply divEuclidienne_decomposition.
      }
      rewrite egPn at 1.
      ring.
      apply Nat.lt_0_succ.
    + cbn.
      pose (hr := HR d pn).
      rewrite egMorphPn in hr.
      cbn in hr.
      rewrite hr.
      symmetry.
      apply divEuclidienne_caracterisationReste with (quotient pn (S d)).
      Search(0 < S _).
      apply Nat.lt_0_succ.
      assert(pn = quotient pn (S d) * S d + (reste pn (S d))) as egPn.
      {
        apply divEuclidienne_decomposition.
      }
      rewrite egPn at 1.
      ring.
      Search(S _ < S _).
      apply lt_n_S.
      assert (S(reste pn (S d)) + ph = d) as invRpn.
      {
        transitivity ((reste pn (S d)) + (S ph)).
        ring.
        rewrite <- hr.
        apply moduloBrut_invariant.
      }
      Search (_ <= _). (* Nat.le_add_r: forall n m : nat, n <= n + m *)
      rewrite <- invRpn at 2.
      apply Nat.le_add_r.
Qed.

(* Vers la compatibilité avec le morphisme de l'égalité modulo
- M n = M (R n)

Induction sur n
- n = 0 : M 0 = M (R 0)
- n = S pn : analyse suivant (M pn)
  - M pn = (0, v) : par l'invariant, v = d.
    - M (S pn) = S (M pn) = (d, 0)
    - R (S pn) = V (M (S pn)) (en utilisant la proposition préc.)
               = V (d, O) = 0
      - M (R (S pn)) = M 0 =  (d, 0)
  - M pn = (S h, v) : par l'invariant, v + (S h) = d
    - HR : M pn = M (R pn), avec (R pn) = V (M pn) = v
    - M (S pn) = S (M pn) = (h, S v)
    - R (S pn) = V (M (S pn)) = V (h, S v) = S v = S (R pn)
      - M (R (S pn)) = M (S (R pn)) = S (M (R pn)) = S (M pn) par HR *)
Lemma modulo_morphismeNat_calculParReste :
  forall d, forall n,
    modulo_morphismeNat d n = modulo_morphismeNat d (reste n (S d)).
Proof.
  fix HR 2.
  intros d n.
  case n as [ | pn].
  - cbn.
    reflexivity.
  - cbn.
    case (modulo_morphismeNat d pn) as [h mb] eqn:egMorphPn.
    cbn.
    case h as [ | ph].
    + rewrite <- modulo_morphismeNat_valeur.
      cbn.
      rewrite egMorphPn.
      cbn.
      reflexivity.
    + assert(reste (S pn) (S d) = S (reste pn (S d))) as egR.
      {
        rewrite <- modulo_morphismeNat_valeur.
        cbn.
        rewrite egMorphPn.
        cbn.
        f_equal.
        rewrite <- modulo_morphismeNat_valeur.
        rewrite egMorphPn.
        cbn.
        reflexivity.
      }
      rewrite egR.
      cbn.
      rewrite <- (HR d pn).
      rewrite egMorphPn.
      cbn.
      reflexivity.
Qed.

(* Compatibilité de l'égalité modulo avec le morphisme *)
Proposition modulo_egalite_compatibiliteMorphismeNat :
  forall d, forall m n,
    modulo_egalite (S d) m n
    -> modulo_morphismeNat d m = modulo_morphismeNat d n.
Proof.
  intros d m n equiv_m_n.
  unfold modulo_egalite.
  rewrite (modulo_morphismeNat_calculParReste d m).
  rewrite (modulo_morphismeNat_calculParReste d n).
  rewrite equiv_m_n.
  reflexivity.
Qed.

Definition zeroMod3 := modulo_morphismeNat 2 3.
Print zeroMod3.
Compute zeroMod3.

Definition unMod3 := modulo_morphismeNat 2 1.
Print unMod3.
Compute unMod3.

Definition deuxMod3 := modulo_morphismeNat 2 2.
Print deuxMod3.
Compute deuxMod3.

Example identite_valeur_2_mod3 :
  modulo_morphismeNat 2 (modulo_valeur deuxMod3) = deuxMod3.
reflexivity.
Qed.

(* L'inversibilité antérieure entraîne la surjectivité. *)
Proposition moduloBrut_morphismeNat_inversibiliteAnterieure :
  forall d h (mb : ModuloBrut d h),
    modulo_morphismeNat d (moduloBrut_valeur _ _ mb) = modulo _ _ mb.
Proof.
  fix HR 3.
  intros d h mb.
  case mb as [ | h pmb].
  - cbn.
    reflexivity.
  - cbn.
    pose (hr := HR _ _ pmb).
    cbn in hr.
    rewrite hr.
    reflexivity.
Qed.

Proposition modulo_morphismeNat_inversibiliteAnterieure :
  forall d (m : Modulo d),
    modulo_morphismeNat d (modulo_valeur m) = m.
Proof.
  intros d m.
  case m as [h mb].
  apply moduloBrut_morphismeNat_inversibiliteAnterieure.
Qed.

(* Surjectivité du morphisme *)
Proposition modulo_morphismeNat_surjectivite :
  forall d (m : Modulo d), exists n, modulo_morphismeNat d n = m.
Proof.
  intros d m.
  exists (modulo_valeur m).
  apply modulo_morphismeNat_inversibiliteAnterieure.
Qed.

(* L'inversibilité postérieure entraîne l'injectivité (modulo (S d)). *)
Proposition modulo_morphismeNat_inversibilitePosterieure :
  forall d n,
    modulo_egalite (S d)
      (modulo_valeur (modulo_morphismeNat d n))
      n.
Proof.
  intros d n.
  unfold modulo_egalite.
  rewrite (modulo_morphismeNat_valeur d).
  rewrite (reste_idempotence (S d)).
  reflexivity.
Qed.

(* Injectivité du morphisme modulo *)
Proposition modulo_morphismeNat_injectivite :
  forall d n1 n2,
    (modulo_morphismeNat d n1) = (modulo_morphismeNat d n2)
    -> modulo_egalite (S d) n1 n2.
Proof.
  intros d n1 n2 egIm.
  apply modulo_egalite_transitivite with (modulo_valeur (modulo_morphismeNat d n1)).
  apply modulo_egalite_symetrie.
  apply modulo_morphismeNat_inversibilitePosterieure.
  rewrite egIm.
  apply modulo_morphismeNat_inversibilitePosterieure.
Qed.

(* Groupe additif commutatif *)

Fixpoint moduloBrut_somme{d h : nat}(mb : ModuloBrut d h)(n : Modulo d){struct mb} : Modulo d.
Proof.
  case mb as [ | h pmb].
  - exact n.
  - exact (modulo_succ (moduloBrut_somme _ _ pmb n)).
Defined.

Definition modulo_somme{d : nat}(m n : Modulo d) : Modulo d.
Proof.
  case m as [h mb].
  exact (moduloBrut_somme mb n).
Defined.

Example somme_12_13_mod25 :
  modulo_somme (modulo_morphismeNat 24 12) (modulo_morphismeNat 24 13) = modulo_morphismeNat 24 0.
reflexivity.
Qed.

Example somme_1_2_mod3 : modulo_somme unMod3 deuxMod3 = zeroMod3.
reflexivity.
Qed.

Example somme_2_2_mod3 : modulo_somme deuxMod3 deuxMod3 = unMod3.
reflexivity.
Qed.

Proposition modulo_somme_neutraliteGauche :
  forall d (n : Modulo d),
    modulo_somme (modulo_zero d) n = n.
Proof.
  intros d n.
  cbn.
  reflexivity.
Qed.

Lemma moduloBrut_somme_neutraliteDroite :
  forall d h (nb : ModuloBrut d h),
    moduloBrut_somme nb (modulo_zero d) = modulo _ _ nb.
Proof.
  fix HR 3.
  intros d h nb.
  case nb as [ | h pnb].
  - cbn.
    reflexivity.
  - cbn.
    rewrite (HR _ _ pnb).
    cbn.
    reflexivity.
Qed.

(* n + 0 = n *)
Proposition modulo_somme_neutraliteDroite :
  forall d (n : Modulo d),
    modulo_somme n (modulo_zero d) = n.
Proof.
  intros d n.
  case n as [h nb].
  cbn.
  apply moduloBrut_somme_neutraliteDroite.
Qed.

Lemma moduloBrut_somme_successionDroite :
  forall d h (mb : ModuloBrut d h) (n : Modulo d),
    moduloBrut_somme mb (modulo_succ n) =
      modulo_succ (moduloBrut_somme mb n).
Proof.
  fix HR 3.
  intros d h mb n.
  case mb as [ | h pmb].
  - cbn.
    reflexivity.
  - cbn.
    rewrite (HR _ _ pmb _).
    reflexivity.
Qed.

Proposition modulo_somme_successionDroite :
  forall d (m n : Modulo d),
    modulo_somme m (modulo_succ n)
    = modulo_succ (modulo_somme m n).
Proof.
  intros d m n.
  case m as [h mb].
  cbn.
  apply moduloBrut_somme_successionDroite.
Qed.

Lemma moduloBrut_somme_commutativite :
  forall d h (mb : ModuloBrut d h) k (nb : ModuloBrut d k),
    moduloBrut_somme mb (modulo _ _ nb)
    = moduloBrut_somme nb (modulo _ _ mb).
Proof.
  intro d.
  fix HR 2.
  intros h mb k nb.
  case mb as [ | h pmb].
  - cbn.
    rewrite moduloBrut_somme_neutraliteDroite.
    reflexivity.
  - cbn.
    fold (moduloBrut_succ pmb).
    fold (modulo_succ (modulo _ _ pmb)).
    rewrite moduloBrut_somme_successionDroite.
    rewrite (HR (S h) pmb k nb).
    reflexivity.
Qed.

(* m + n = n + m *)
Proposition modulo_somme_commutativite :
  forall d (m n : Modulo d),
    modulo_somme m n = modulo_somme n m.
Proof.
  intro d.
  intros m n.
  case m as [h mb].
  case n as [k nb].
  apply moduloBrut_somme_commutativite.
Qed.

(* démonstration directe pénible ! *)
(* Lemma moduloBrut_somme_successionGauche :
  forall d h (mb : ModuloBrut d h) (n : Modulo d),
    modulo_somme (moduloBrut_succ mb) n =
      modulo_succ (moduloBrut_somme mb n).
Proof.
  fix HR 3.
  intros d h mb n.
  case mb as [ | h pmb].
  - cbn.
    Print moduloBrut_succ.
    Check (mb_zero d).
    (* oblige à décomposer d ! *)
Abort. *)

(* Démonstration utilisant la commutativité *)
Proposition modulo_somme_successionGauche :
  forall d (m n : Modulo d),
    modulo_somme (modulo_succ m) n
    = modulo_succ (modulo_somme m n).
Proof.
  intros d m n.
  rewrite modulo_somme_commutativite.
  rewrite modulo_somme_successionDroite.
  rewrite modulo_somme_commutativite.
  reflexivity.
Qed.

(* Compatibilité du morphisme avec l'addition
- M (m + n) = (M m) + (M n)

Induction sur m
- m = 0
  - M (0 + n) = M n
  - (M 0) + (M n) = (d, 0) + (M n) = M n
- m = S pm
  - M ((S pm) + n) = M (S (pm + n)) = S (M (pm + n)) =[HR] S ((M pm) + (M n))
  - (M (S pm)) + (M n) = (S (M pm)) + (M n) =[succ gauche] S ((M pm) + (M n))
 *)
Proposition modulo_morphismeNat_compatibiliteAddition :
  forall d m n,
    modulo_morphismeNat d (m + n)
    = modulo_somme (modulo_morphismeNat d m) (modulo_morphismeNat d n).
Proof.
  fix HR 2.
  intros d m n.
  case m as [ | pm].
  - cbn.
    reflexivity.
  - cbn.
    rewrite (HR d pm n).
    rewrite modulo_somme_successionGauche.
    reflexivity.
Qed.

(* Associativité de la somme *)
Lemma moduloBrut_somme_associativite_droiteAGauche :
  forall d h (mb : ModuloBrut d h) (n1 n2 : Modulo d),
    moduloBrut_somme mb (modulo_somme n1 n2)
    = modulo_somme (moduloBrut_somme mb n1) n2.
Proof.
  intro d.
  fix HR 2.
  intros h mb n1 n2.
  case mb as [ | h pmb].
  - cbn.
    reflexivity.
  - cbn.
    rewrite modulo_somme_successionGauche.
    rewrite (HR _ pmb n1 n2).
    reflexivity.
Qed.

(* m + (n1 + n2) = (m + n1) + n2 *)
Proposition modulo_somme_associativite_droiteAGauche :
  forall d (m n1 n2 : Modulo d),
    modulo_somme m (modulo_somme n1 n2)
    = modulo_somme (modulo_somme m n1) n2.
Proof.
  intros d m n1 n2.
  case m as [h mb].
  apply moduloBrut_somme_associativite_droiteAGauche.
Qed.

(* (m + n1) + n2 = m + (n1 + n2) *)
Proposition modulo_somme_associativite_gaucheADroite :
  forall d (m n1 n2 : Modulo d),
    modulo_somme (modulo_somme m n1) n2
    = modulo_somme m (modulo_somme n1 n2).
Proof.
  intros d m n1 n2.
  symmetry.
  apply modulo_somme_associativite_droiteAGauche.
Qed.

Definition moduloBrut_opposeSomme{d h : nat}(mb : ModuloBrut d h) : Modulo d.
Proof.
  exact (modulo_morphismeNat d (S h)).
Defined.

Definition modulo_opposeSomme{d : nat}(m : Modulo d) : Modulo d.
Proof.
  case m as [h mb].
  exact (moduloBrut_opposeSomme mb).
Defined.

(* m + (- m) = 0 *)
Proposition modulo_opposeSomme_correction :
  forall d (m : Modulo d),
    modulo_somme m (modulo_opposeSomme m) = modulo_zero d.
Proof.
  intros d m.
  rewrite <- (modulo_morphismeNat_inversibiliteAnterieure d m) at 1.
  case m as [h mb].
  cbn.
  rewrite modulo_somme_successionDroite.
  rewrite <- modulo_morphismeNat_compatibiliteAddition.
  assert(moduloBrut_valeur d h mb + h = d) as inv.
  {
    replace h with (modulo_complementaire (modulo _ _ mb)) at 2.
    apply (modulo_invariant d (modulo _ _ mb)).
    reflexivity.
  }
  rewrite inv.
  transitivity (modulo_morphismeNat d (S d)).
  - reflexivity.
  - rewrite (modulo_morphismeNat_calculParReste).
    rewrite reste_cycle.
    reflexivity.
Qed.

(* Complément : sur l'unicité de la représentation. Démonstrations difficiles. *)

(* Objectif : démontrer que chaque type 'ModuloBrut d h' est un singleton.
 Première tentative. *)
(* Proposition moduloBrut_typesSingletons :
  forall (d h : nat)(mb1 mb2 : ModuloBrut d h),
    mb1 = mb2.
Proof.
  fix HR 3.
  intros d h mb1 mb2.
  case mb1 as [ | h pmb1].
  - admit. (* On aurait besoin d'un lemme. *)
  - case mb2 as [ | h pmb2].
    * exfalso.
      apply moduloBrut_majoration in pmb1 as majAbs.
      apply superieurOuEgal_adequation in majAbs.
      Search(S _ <= _).
      apply (Nat.nle_succ_diag_l d).
      assumption.
    * f_equal.
      apply HR.
Abort. *)

(* Essayons de démontrer ce lemme. *)
(* Lemma moduloBrut_singleton_casZero :  forall d (mb : ModuloBrut d d),
    mb = mb_zero d.
Proof.
  intros d mb.
  (* case mb as [ | h pmb].
     Error: Cannot instantiate metavariable P of type
     "forall n : nat, ModuloBrut d n -> Prop"
     with abstraction "fun (d : nat) (mb : ModuloBrut d d) => mb = mb_zero d"
     of incompatible type "forall d : nat, ModuloBrut d d -> Prop".

   Explication :

   - Système d'inférence
                                   (ModuloBrut d (S h))
   ---------------- [mb_zero]      -------------------- [mb_succ]
   (ModuloBrut d d)                   (ModuloBrut d h)

   - Règle d'inférence pour la tactique 'case' (en première approximation)
   (d : nat) ⊢ mb_zero d = mb_zero d
         (d : nat), (h : nat), (pmb : ModuloBrut d (S h)) ⊢
            (mb = mb_zero d)[mb := mb_succ d h pmb] // Mal typé !
   -------------------------------------------------------------- [case mb]
   (d : nat), (mb :  ModuloBrut d d) ⊢ mb = mb_zero d
  *)
Abort.*)

(* Pour permettre une décomposition par 'case', il devient nécessaire de modifier
   la formulation de la proposition, en distinguant 'd' du complémentaire 'h'.
   Pour typer, on utilise un foncteur qui transforme :
   - / objets : un 'h : nat' en un type 'ModuloBrut d h',
   - / flèches : une égalité 'eg : h1 = h2' en une fonction
     'conversion eg : ModuloBrut d h1 -> ModuloBrut d h2'. *)

(* Conversion : foncteur catégorique - voir egalite_preuves_singletonSiDecidable. *)
Definition conversion{d h1 h2 : nat}(eg : h1 = h2) : ModuloBrut d h1 -> ModuloBrut d h2.
  case eg. (* 'eg' serait remplacé par 'eq_refl h1', et 'h2' est récrit en 'h1'. *)
  exact (fun mb => mb). (* La conversion devient l'identité. *)
Defined.

(* On reformule le lemme en utilisant la conversion.  *)
(*
Lemma moduloBrut_singleton_casZeroModuloConversion :
  forall d h (mb : ModuloBrut d h)(eg : h = d),
    conversion eg mb = mb_zero d.
Proof.
  intros d h mb.
  intro eg.
  case mb as [ | h pmb].
  - Print eq. (* Définition de l'égalité. *)
    Print conversion.
    (* Pour simplifier la conversion, il est nécessaire de transformer 'eg' en 'eq_refl'. *)
    (* case eg. Erreur ! *)
    (* Error: Cannot instantiate metavariable P of type
       "forall a : nat, d = a -> Prop" with abstraction
       "fun (d : nat) (eg : d = d) => conversion eg (mb_zero d) = mb_zero d"
       of incompatible type "forall d : nat, d = d -> Prop".

       Explication
       - Système d'inférence pour l'égalité 'eq' (notée '=')

       eq(T : Type)(x : T) : T -> Prop // Paramétrisation par 'T' et 'x',
                                          indexation par un 'T'

       ----- [eq_refl]
       x = x           // L'index 'x' doit être égal, c'est-à-dire identique,
                       // au paramètre 'x'.

       - Règle d'inférence pour la tactique 'case'

       La règle pour la tactique 'case' pourrait être la suivante :

       (d : nat) ⊢ (conversion eg (mb_zero d) = mb_zero d)[eg := @eq_refl nat d]
       ------------------------------------------------------------------------- [case eg]
       (d : nat), (eg : d = d) ⊢ conversion eg (mb_zero d) = mb_zero d

       Dans ce cas, on aurait bien le sous-but souhaité :
       - (d : nat) ⊢ mb_zero d = mb_zero d

       Cependant, la règle pour la tactique 'case' réalise aussi
       une abstraction de l'index, car il n'est pas possible de résoudre
       en général les contraintes induites par les index qui peuvent varier librement
       dans les conclusions des règles du type inductif, contrairement aux paramètres.

       (d : nat) ⊢ ...[y := d, egX := @eq_refl nat d]
       -------------------------------------------------------------------------- [case eg]
       (d : nat), (eg : d = d)
          ⊢ (conversion egX (mb_zero d) = mb_zero d)[y := d, egX : (d = y) := eg]
            // égalité mal typée : '(ModuloBrut d y) / (ModuloBrut d d)'

       Ainsi Coq interdit l'usage de la tactique 'case'. La solution ici est de
       démontrer que 'eg' est égal à '@eq_refl nat d' (abrégé en 'eq_refl'). C'est le cas
       pour tous les types pour lesquels l'égalité est décidable, comme 'nat'.
     *)
Abort.*)

(* Nouvel essai : au lieu de la tactique 'case', on utilise le fait
que toute égalité sur 'nat' est le constructeur 'eq_refl'. *)
Lemma moduloBrut_singleton_casZeroModuloConversion :
  forall d h (mb : ModuloBrut d h)(eg : h = d),
    conversion eg mb = mb_zero d.
Proof.
  intros d h mb.
  intro eg.
  case mb as [ | h pmb].
  - (* Pour simplifier la conversion, il est nécessaire de transformer 'eg' en 'eq_refl'.
       On peut montrer que 'eg' est égal à 'eq_refl', grâce à la décidabilité
       de l'égalité sur 'nat'. C'est un résultat dans la bibliothèqe standard. *)
    assert(eg = eq_refl) as eqPreuves.
    {
      Check UIP_nat.
      apply UIP_nat.
    }
    rewrite eqPreuves.
    cbn.
    reflexivity.
  - (* cas absurde : 'S h <= d' et 'h = d' impossibles. *)
    exfalso.
    apply moduloBrut_majoration in pmb as majAbs.
    apply superieurOuEgal_adequation in majAbs.
    Search(S _ <= _).
    apply (Nat.nle_succ_diag_l d).
    rewrite eg in majAbs.
    assumption.
Qed.
(* On déduit le lemme en instantiant l'égalité par 'eq_refl' :
la conversion est alors l'identité. *)
Lemma moduloBrut_singleton_casZero :  forall d (mb : ModuloBrut d d),
    mb = mb_zero d.
Proof.
  intros d mb.
  transitivity (conversion eq_refl mb).
  - reflexivity.
  - apply moduloBrut_singleton_casZeroModuloConversion.
Qed.

(* On peut conclure en reprenant la démonstration interrompue.
Les types 'ModuloBrut'sont des types singletons. *)
Proposition moduloBrut_typesSingletons :
  forall (d h : nat)(mb1 mb2 : ModuloBrut d h),
    mb1 = mb2.
Proof.
  fix HR 3.
  intros d h mb1 mb2.
  case mb1 as [ | h pmb1].
  - symmetry.
    apply moduloBrut_singleton_casZero.
  - case mb2 as [ | h pmb2].
    * exfalso.
      apply moduloBrut_majoration in pmb1 as majAbs.
      apply superieurOuEgal_adequation in majAbs.
      Search(S _ <= _).
      apply (Nat.nle_succ_diag_l d).
      assumption.
    * f_equal.
      apply HR.
Qed.


Require Import Compare_dec.
Require Import PeanoNat.

Require Import Top.Terms.Term.
Require Import Top.Terms.VecUtils.

Set Implicit Arguments.

Section term_at.
  Variable L : lType.

  (** The [term_at] function is an analogue of [nth_error] on lists. *)
  Fixpoint term_at (pos : list nat) (t : Term L) : option (Term L) :=
    match pos with
    | nil => Some t
    | cons i pos' =>
      match t with
      | varTerm _ _ => None
      | funTerm f ts =>
        match lt_dec i (Term.a L f) with
        | left ltH => term_at pos' (VectorDef.nth_order ts ltH)
        | right _ => None
        end
      end
    end.

  Lemma term_at_cons_fun i pos f ts (ltH : i < Term.a L f)
    : term_at (cons i pos) (funTerm f ts) =
      term_at pos (VectorDef.nth_order ts ltH).
  Proof.
    simpl; destruct (lt_dec i (Term.a L f)) as [ ltH' | ]; try contradiction.
    unfold VectorDef.nth_order.
    rewrite (Fin.of_nat_ext ltH ltH'); auto.
  Qed.

  Lemma term_height_term_at t t' pos
    : term_at pos t = Some t' ->
      term_height t >= length pos + term_height t'.
  Proof.
    revert t; induction pos as [ | i pos IH ]; intro t; simpl.
    - injection 1; intro tH; rewrite tH; auto.
    - destruct t as [ | f ts ]; try discriminate.
      destruct (lt_dec i (Term.a L f)) as [ ltH | ]; try discriminate.
      intro someH; simpl.
      unfold ge. apply le_n_S.
      apply (Nat.le_trans _ (term_height (VectorDef.nth_order ts ltH))).
      + exact (IH _ someH).
      + exact (vec_max_at_ge_nth_order (term_height (L := L)) ts ltH).
  Qed.
End term_at.


Require Export GeoCoq.Elements.OriginalProofs.lemma_lessthantransitive.

Section Euclid.

Context `{Ax:euclidean_neutral_ruler_compass}.

Lemma lemma_midpointunique :
   forall A B C D,
   Midpoint A B C -> Midpoint A D C ->
   eq B D.
Proof.
intros.
assert ((BetS A B C /\ Cong A B B C)) by (conclude_def Midpoint ).
assert ((BetS A D C /\ Cong A D D C)) by (conclude_def Midpoint ).
assert (Cong A B A B) by (conclude cn_congruencereflexive).
assert (~ BetS C D B).
 {
 intro.
 assert (BetS B D C) by (conclude axiom_betweennesssymmetry).
 assert (BetS A B D) by (conclude axiom_innertransitivity).
 assert (Lt A B A D) by (conclude_def Lt ).
 assert (Cong A D C D) by (forward_using lemma_congruenceflip).
 assert (Lt A B C D) by (conclude lemma_lessthancongruence).
 assert (BetS C D B) by (conclude axiom_betweennesssymmetry).
 assert (Cong C D C D) by (conclude cn_congruencereflexive).
 assert (Lt C D C B) by (conclude_def Lt ).
 assert (Lt A B C B) by (conclude lemma_lessthantransitive).
 assert (Cong C B B C) by (conclude cn_equalityreverse).
 assert (Lt A B B C) by (conclude lemma_lessthancongruence).
 assert (Cong B C A B) by (conclude lemma_congruencesymmetric).
 assert (Lt A B A B) by (conclude lemma_lessthancongruence).
 let Tf:=fresh in
 assert (Tf:exists E, (BetS A E B /\ Cong A E A B)) by (conclude_def Lt );destruct Tf as [E];spliter.
 assert (~ Cong A E A B) by (conclude lemma_partnotequalwhole).
 contradict.
 }
assert (~ BetS C B D).
 {
 intro.
 assert (BetS D B C) by (conclude axiom_betweennesssymmetry).
 assert (BetS A D B) by (conclude axiom_innertransitivity).
 assert (Cong A D A D) by (conclude cn_congruencereflexive).
 assert (Lt A D A B) by (conclude_def Lt ).
 assert (Cong A B C B) by (forward_using lemma_congruenceflip).
 assert (Lt A D C B) by (conclude lemma_lessthancongruence).
 assert (BetS C B D) by (conclude axiom_betweennesssymmetry).
 assert (Cong C B C B) by (conclude cn_congruencereflexive).
 assert (Lt C B C D) by (conclude_def Lt ).
 assert (Lt A D C D) by (conclude lemma_lessthantransitive).
 assert (Cong C D D C) by (conclude cn_equalityreverse).
 assert (Lt A D D C) by (conclude lemma_lessthancongruence).
 assert (Cong D C C D) by (conclude lemma_congruencesymmetric).
 assert (Lt A D C D) by (conclude lemma_lessthancongruence).
 assert (Cong D C A D) by (conclude lemma_congruencesymmetric).
 assert (Cong C D A D) by (forward_using lemma_congruenceflip).
 assert (Lt A D A D) by (conclude lemma_lessthancongruence).
 let Tf:=fresh in
 assert (Tf:exists F, (BetS A F D /\ Cong A F A D)) by (conclude_def Lt );destruct Tf as [F];spliter.
 assert (~ Cong A F A D) by (conclude lemma_partnotequalwhole).
 contradict.
 }
assert (BetS C D A) by (conclude axiom_betweennesssymmetry).
assert (BetS C B A) by (conclude axiom_betweennesssymmetry).
assert (eq B D) by (conclude axiom_connectivity).
close.
Qed.

End Euclid.


(** Exercise 7.1 **)

(* Given *)

Definition divides (n m:nat) :=
  exists p:nat, p * n = m.

(* To do *)

Lemma divides_0: forall n:nat, divides n 0.
Proof.
  unfold divides.
  intros n.
  exists 0; simpl; reflexivity.
Qed.

Lemma divides_plus:
  forall n m:nat,
  divides n m -> divides n (n + m).
Proof.
  unfold divides.
  intros n m H1.
  destruct H1 as [p H1].
  exists (S p); simpl.
  rewrite H1; reflexivity.
Qed.

Lemma sum_zero_implies_zero:
  forall n m:nat, n + m = 0 -> n = 0.
Proof.
  intros n m H.
  induction n.
  reflexivity.
  discriminate.
Qed.

Lemma sum_comm:
  forall n m:nat, n + m = m + n.
Proof.
  intros n m.
  induction n.
  simpl; apply plus_n_O.
  rewrite <-plus_n_Sm with (m := n).
  simpl; apply f_equal; exact IHn.
Qed.

Lemma succ_pred_identity:
  forall n:nat, n<>0 -> n = S (pred n).
Proof.
  intros n H1.
  induction n.
  assert (0 = 0) as H2.
  reflexivity.
  contradiction.
  simpl.
  reflexivity.
Qed.

Lemma sum_cancel:
  forall n m p:nat, n + p = m + p -> n = m.
Proof.
  induction p.
  repeat rewrite <-plus_n_O.
  intro H; exact H.
  repeat rewrite <-plus_n_Sm.
  intro H.
  apply IHp.
  apply eq_add_S; exact H.
Qed.

Lemma not_divides_plus:
  forall n m:nat,
  ~divides n m -> ~divides n (n + m).
Proof.
  unfold divides.
  intros n m H1 H2.
  destruct H2 as [q H2].
  assert (exists p: nat, p * n = m).
  exists (pred q).
  assert (q <> 0) as H3.
  intros H4.
  assert (q * n = 0) as H5.
  rewrite H4; simpl; reflexivity.
  assert (m = 0) as H6.
  apply sum_zero_implies_zero with (n := m) (m := n).
  symmetry.
  rewrite sum_comm.
  rewrite <-H5; exact H2.
  assert (exists p: nat, p * n = m) as H7.
  exists 0.
  simpl; rewrite H6; reflexivity.
  contradiction.
  assert (q = S (pred q)) as H4.
  apply succ_pred_identity; exact H3.
  assert (S (pred q) * n = n + m) as H5.
  rewrite <-H4; exact H2.
  assert (S (pred q) * n =
    pred q * n + n) as H6.
  simpl.
  rewrite sum_comm; reflexivity.
  rewrite H6 in H5.
  apply sum_cancel with (p := n).
  assert (m + n = n + m) as H7.
  apply sum_comm.
  rewrite H7; exact H5.
  contradiction.
Qed.

(* Now I use the 'Arith' module, otherwise I
   would get lost proving auxiliary lemmas *)
Require Import Arith.

Lemma not_divides_lt:
  forall n m:nat,
  0 < m -> m < n -> ~divides n m.
Proof.
  unfold divides.
  intros n m H1 H2 H3.
  destruct H3 as [p H3].
  assert (0 < n) as H4.
  apply lt_trans with (m := m); assumption.
  assert (0 < p) as H5.
  assert (0 <> p) as H6.
  intro H7.
  rewrite <-H7 in H3.
  simpl in H3.
  rewrite <-H3 in H1.
  apply lt_irrefl with (n:=0); exact H1.
  apply neq_0_lt; exact H6.
  assert (m * p < n * p) as H6.
  apply mult_lt_compat_r with (n := m).
  exact H2.
  exact H5.
  rewrite mult_comm in H3.
  rewrite H3 in H6.
  assert (1 <= p) as H7.
  apply H5.
  assert (1 * m <= p * m) as H8.
  apply mult_le_compat_r; exact H7.
  rewrite mult_1_l in H8.
  rewrite mult_comm in H8.
  apply le_not_lt with (n := m) (m := m * p).
  exact H8.
  exact H6.
Qed.

Lemma not_lt_2_divides:
  forall n m:nat,
  n <> 1 -> n < 2 -> 0 < m -> ~divides n m.
Proof.
  unfold divides.
  induction n.
  intros m H1 H2 H3 H4.
  destruct H4 as [p H4].
  rewrite mult_0_r in H4.
  rewrite H4 in H3.
  apply lt_irrefl with (n := m).
  exact H3.
  intros m H1 H2 H3 H4.
  unfold lt in H2.
  assert (S n = 1) as H5.
  apply f_equal.
  symmetry.
  apply le_n_0_eq.
  do 2 apply le_S_n; exact H2.
  contradiction.
Qed.

Lemma le_plus_minus:
  forall n m:nat, n <= m -> m = n + (m - n).
Proof.
  intros n m H.
  induction n.
  simpl; rewrite <-minus_n_O; reflexivity.
  rewrite plus_Sn_m.
  rewrite plus_n_Sm.
  rewrite minus_Sn_m.
  simpl.
  apply IHn.
  apply le_Sn_le.
  exact H.
  exact H.
Qed.

Lemma lt_lt_or_eq:
  forall n m:nat, n < S m -> n < m \/ n = m.
Proof.
  unfold lt.
  intros n m H.
  inversion H.
  right; reflexivity.
  left; exact H1.
Qed.


(** 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 (lf1 : natural) : natural := mult (Succ Zero) lf1.


(** * Post Correspondence problem PCP *)

(* Definitions of variants of the Post correspondence problem. *)

Require Import List.
Import ListNotations.

(* A string is a list of symbols. *)
Notation string := list.

(* A card a is a pair of the upper string x and the lower string y. *)
Notation card := (fun X => string X * string X)%type.

(* A stack is a list of cards. *)
Definition stack X := list (card X).

(* The upper trace tau1 of a stack A
  is the concatenation of the upper strings of A. *)
Fixpoint tau1 {X : Type} (A : stack X) : string X :=
  match A with
  | [] => []
  | (x, y) :: A => x ++ tau1 A
  end.

(* The lower trace tau2 of a stack A
  is the concatenation of the lower strings of A. *)
Fixpoint tau2 {X : Type} (A : stack X) : string X :=
  match A with
  | [] => []
  | (x, y) :: A => y ++ tau2 A
  end.

(* The Post correspondence problem PCP is
  given a stack P of cards to determine
  whether there is a non-empty stack A of cards from P (with possible repetition)
  such that the upper trace of A is equal to the lower trace of A. *)
Definition PCPX {X : Type}: stack X -> Prop :=
  fun P => exists A, incl A P /\ A <> [] /\ tau1 A = tau2 A.

Definition PCP : stack nat -> Prop := @PCPX nat.

(* PCPb is PCP restricted to cards with binary strings. *)
Definition PCPb : stack bool -> Prop := @PCPX bool.

(* The indexed upper trace itau1 of indices A from a stack P
  is the concatenation of the upper strings of P each with index from A. *)
Fixpoint itau1 {X : Type} (P : stack X) (A : list nat) : string X :=
  match A with
    | [] => []
    | i :: A => fst (nth i P ([], [])) ++ itau1 P A
  end.

(* The indexed lower trace itau1 of indices A from a stack P
  is the concatenation of the upper strings of P each with index from A. *)
Fixpoint itau2 {X : Type} (P : stack X) (A : list nat) : string X :=
  match A with
    | [] => []
    | i :: A => snd (nth i P ([], [])) ++ itau2 P A
  end.

(* iPCPb is a different presentation of PCPb based on index lists. *)
Definition iPCPb : stack bool -> Prop :=
  fun P => exists (A : list nat),
    (forall a, In a A -> a < length P) /\ A <> [] /\ itau1 P A = itau2 P A.

(* A pair of words is derivable from a stack P
  if it can be build by concatenation of upper and lower strings of cards from P. *)
Inductive derivable {X : Type} (P : stack X) : string X -> string X -> Prop :=
  | der_sing x y : In (x, y) P -> derivable P x y
  | der_cons x y u v : In (x, y) P -> derivable P u v -> derivable P (x ++ u) (y ++ v).

(* dPCPb is a different presentation of inductive presentation of PCP. *)
Definition dPCP {X : Type} : stack X -> Prop :=
  fun P => exists u, @derivable X P u u.

(* dPCPb is a different presentation of PCPb based in index derivability. *)
Definition dPCPb : stack bool -> Prop := @dPCP bool.

(* Binary PCP inductively defined (cf Trakhtenbrot IJCAR 2020) *)

Inductive BPCP (P : stack bool) : Prop :=
  | cBPCP : forall u, derivable P u u -> BPCP P.

(* The modified Post correspondence problem MPCP is
  given a card x/y and stack P of cards to determine
  whether there is a stack A of cards from x/y, P (with possible repetition)
  such that the upper trace of x/y, A is equal to the lower trace of x/y,A. *)
Definition MPCP : card nat * stack nat -> Prop :=
  fun '((x, y), P) => exists (A : stack nat),
    incl A ((x, y) :: P) /\ x ++ tau1 A = y ++ tau2 A.

(* MPCPb is MPCP restricted to cards with binary strings. *)
Definition MPCPb : card bool * stack bool -> Prop :=
  fun '((x, y), P) => exists (A : stack bool),
    incl A ((x, y) :: P) /\ x ++ tau1 A = y ++ tau2 A.


Require Import SepTypes.OrderedType SepTypes.OFuns SepTypes.Functor SepTypes.PChain.

Open Scope ofun_scope.

(** A simple inductive type for binary trees with an order relation
    and an fmap operation. *)
Section tree.
  Inductive Tree A :=
  | Leaf : A -> Tree A
  | Node : Tree A -> Tree A -> Tree A.

  Global Arguments Leaf {_}.
  Global Arguments Node {_}.

  Inductive tree_oleq {A} `{OType A} : Tree A -> Tree A -> Prop :=
  | tree_oleq_Leaf : forall x y,
      x <o= y ->
      tree_oleq (Leaf x) (Leaf y)
  | tree_oleq_Node : forall t1 t2 t1' t2',
      tree_oleq t1 t1' ->
      tree_oleq t2 t2' ->
      tree_oleq (Node t1 t2) (Node t1' t2').

  Global Instance Reflexive_tree_oleq {A} `{OType A} : Reflexive tree_oleq.
  Proof. intro x; induction x; constructor; auto; reflexivity. Qed.

  Global Instance Transitive_tree_oleq {A} `{OType A} : Transitive tree_oleq.
  Proof.
    intros x y z Hxy Hyz; revert x z Hxy Hyz.
    induction y; intros; destruct x, z;
      inversion Hxy; inversion Hyz; subst.
    - constructor; etransitivity; eauto.
    - constructor.
      + apply IHy1; auto.
      + apply IHy2; auto.
  Qed.

  Global Program Instance OTtree A `(OType A) : OType (Tree A) :=
    {| oleq := tree_oleq |}.
  Next Obligation.
    constructor.
    - apply Reflexive_tree_oleq.
    - apply Transitive_tree_oleq.
  Qed.

  Inductive isLeaf {A} : Tree A -> Prop :=
  | isLeafLeaf : forall x, isLeaf (Leaf x).

  Inductive isNode {A} : Tree A -> Prop :=
  | isNodeNode : forall t1 t2, isNode (Node t1 t2).

  Definition isLeafb {A} (t : Tree A) : bool :=
    match t with
    | Leaf _ => true
    | Node _ _ => false
    end.

  Definition isNodeb {A} (t : Tree A) : bool :=
    match t with
    | Leaf _ => false
    | Node _ _ => true
    end.

  Lemma isLeaf_isLeafb A (t : Tree A) :
    isLeaf t <-> isLeafb t = true.
  Proof.
    split; intros H; inversion H; auto; destruct t.
    - constructor.
    - simpl in H; congruence.
  Qed.

  Lemma isNode_isNodeb A (t : Tree A) :
    isNode t <-> isNodeb t = true.
  Proof.
    split; intros H; inversion H; auto; destruct t.
    - simpl in H; congruence.
    - constructor.
  Qed.

  (* tree_oleq is reflexive wrt equivalence. *)
  Lemma Reflexive'_tree_oleq A `{OType A} t1 t2 :
    t1 =o= t2 ->
    tree_oleq t1 t2.
  Proof. firstorder. Qed.

  Global Instance Proper_tree_oleq' A `{OType A} :
    Proper (oeq ==> oeq ==> oleq) tree_oleq.
  Proof.
    intros x y Hleq1 z w Hleq2 Hleq3.
    rewrite <- Hleq1.
    etransitivity; eauto.
    apply Reflexive'_tree_oleq; auto.
  Qed.

  Global Instance Proper_Leaf {A} `{OType A} :
    Proper (oleq ==> oleq) Leaf.
  Proof. constructor; auto. Qed.

  Global Instance Proper_Node {A} `{OType A} :
    Proper (oleq ==> oleq ==> oleq) Node.
  Proof. constructor; auto. Qed.

  (* Plain-old fmap for trees. *)
  Fixpoint tree_fmap {A B} `{OType A} `{OType B} (f : A -o> B)
           (t : Tree A) : Tree B :=
    match t with
    | Leaf x => Leaf (f @@ x)
    | Node t1 t2 => Node (tree_fmap f t1) (tree_fmap f t2)
    end.

  Global Instance Proper_tree_fmap {A B} `{OType A} `{OType B} (f : A -o> B) :
    Proper (oleq ==> oleq) (tree_fmap f).
  Proof.
    intros x y Hleq; induction Hleq; simpl.
    + rewrite H1; reflexivity.
    + constructor; auto.
  Qed.

  (* OFun version of fmap. *)
  Program Definition Tree_fmap {A B} `{OType A} `{OType B} (f : A -o> B)
    : Tree A -o> Tree B :=
    {| ofun_app := fun t => tree_fmap f t |}.
  Next Obligation.
    intros t1 t2 Hleq; induction Hleq; simpl.
    - rewrite H1; reflexivity.
    - constructor; auto.
  Qed.

  Global Instance Proper_Tree_fmap {A B} `{OType A} `{OType B} :
    Proper (@oleq (A -o> B) _ ==> oleq) (Tree_fmap).
  Proof.
    intros ? ? ? ? ? Hleq2; induction Hleq2; constructor; auto.
  Qed.

  Global Instance Proper_Tree_fmap' {A B} `{OType A} `{OType B} :
    Proper (@oeq (A -o> B) _ ==> oeq) (Tree_fmap).
  Proof. intros ? ? Heq; split; apply Proper_Tree_fmap; apply Heq. Qed.

  (* tree_fmap satisfies the functor laws. *)
  Lemma tree_fmap_id A `{OType A} x :
    tree_fmap id_ofun x =o= x.
  Proof.
    induction x.
    - reflexivity.
    - simpl; rewrite IHx1, IHx2; reflexivity.
  Qed.

  Lemma Tree_fmap_id A `{OType A} :
    Tree_fmap id_ofun =o= id_ofun.
  Proof.
    generalize (tree_fmap_id A); intros H0; split;
      intros t1 t2 Hleq; simpl; rewrite H0; auto.
  Qed.

  Lemma Tree_fmap_comp A B C `{OType A} `{OType B} `{OType C}
        (f : A -o> B) (g : B -o> C) :
    Tree_fmap (g ∘ f) =o= Tree_fmap g ∘ Tree_fmap f.
  Proof.
    split; intros t1 t2 Hleq; unfold oleq; simpl;
      induction Hleq; constructor; auto; rewrite H2; reflexivity.
  Qed.

  (* Get the element out of a leaf. If the argument isn't a leaf, just
     recurse to the left until one is found. *)
  Fixpoint unLeaf {A} (t : Tree A) : A :=
    match t with
    | Leaf x => x
    | Node t1 _ => unLeaf t1 (* shouldn't happen *)
    end.

  Global Instance Proper_unLeaf {A} `{OType A} :
    Proper (oleq ==> oleq) unLeaf.
  Proof. intros ? ? Heq; induction Heq; auto. Qed.

  Lemma leaf_unleaf A (t : Tree A) :
    isLeaf t ->
    Leaf (unLeaf t) = t.
  Proof. intros Hleaf; inversion Hleaf; auto. Qed.

  (* OFun version of unLeaf *)
  Definition unLeaf' {A} `{OType A} : Tree A -o> A :=
    {| ofun_app := unLeaf; ofun_Proper := Proper_unLeaf |}.

  (* Get the left subtree of a tree. If the argument is a leaf, just
     return it unchanged. *)
  Fixpoint unNodeLeft {A} (t : Tree A) : Tree A :=
    match t with
    | Leaf _ => t (* shouldn't happen *)
    | Node t1 _ => t1
    end.

  Global Instance Proper_unNodeLeft {A} `{OType A} :
    Proper (oleq ==> oleq) unNodeLeft.
  Proof.
    intros ? ? Heq; induction Heq; auto; simpl; rewrite H0; reflexivity.
  Qed.

  (* OFun version of unNodeLeft *)
  Definition unNodeLeft' {A} `{OType A} : Tree A -o> Tree A :=
    {| ofun_app := unNodeLeft; ofun_Proper := Proper_unNodeLeft |}.

  (* Get the right subtree of a tree. If the argument is a leaf, just
     return it unchanged. *)
  Fixpoint unNodeRight {A} (t : Tree A) : Tree A :=
    match t with
    | Leaf _ => t (* shouldn't happen *)
    | Node _ t2 => t2
    end.

  Global Instance Proper_unNodeRight {A} `{OType A} :
    Proper (oleq ==> oleq) unNodeRight.
  Proof.
    intros ? ? Heq; induction Heq; auto; simpl; rewrite H0; reflexivity.
  Qed.

  (* OFun version of unNodeRight *)
  Definition unNodeRight' {A} `{OType A} : Tree A -o> Tree A :=
    {| ofun_app := unNodeRight; ofun_Proper := Proper_unNodeRight |}.
End tree.

(** The tree functor. *)
Section treeFunctor.
  Context F {oF : OTypeF F} {fm : FMap F} {func : Functor F}
          {uF : UnfoldTypeF F} {uOF : UnfoldOTypeF F}
          {fF : FoldF F} {ufF : UnfoldF F}
          {cFunc : ContinuousFunctor F}.

  Definition TreeF : TypeF := fun X oX => Tree (F X oX).

  Global Instance TreeOTypeF : OTypeF TreeF := fun _ _ => _.

  Global Instance TreeFMap : FMap TreeF :=
    fun _ _ _ _ => fun f => Tree_fmap (fmap f).

  Global Program Instance TreeFunctor : Functor TreeF.
  Next Obligation.
    unfold fmap, TreeFMap; destruct func.
    rewrite fmap_id; apply Tree_fmap_id.
  Qed.
  Next Obligation.
    unfold fmap, TreeFMap; destruct func.
    rewrite fmap_comp; apply Tree_fmap_comp.
  Qed.
End treeFunctor.

(** Operations and proofs related to chains of trees. *)
Section treePChain.
  Definition treeDiag f `{PDiagram f} := typeSequenceMap f (TreeF IdentityF).

  Program Definition unLeafPChain {f} `{PDiagram f}
  : PChain (treeDiag f) -o> PChain f := pChainMap (treeDiag f) f
              (fun _ => {| ofun_app := fun x => unLeaf' @@ x |}) _.
  Next Obligation.
    unfold oeq, oleq; split; simpl; intros ? ? Heq;
      induction Heq; simpl; auto; rewrite H0; reflexivity.
  Qed.

  Program Definition unNodeLeftPChain {f} `{PDiagram f}
    : PChain (treeDiag f) -o> PChain (treeDiag f) :=
    pChainMap (treeDiag f) (treeDiag f)
              (fun _ => {| ofun_app := fun x => unNodeLeft' @@ x |}) _.
  Next Obligation.
    split; simpl; intros c1 c2 Hleq; induction Hleq;
      try apply Proper_tree_fmap; auto; constructor;
        rewrite H0; reflexivity.
  Qed.

  Program Definition unNodeRightPChain {f} `{PDiagram f}
    : PChain (treeDiag f) -o> PChain (treeDiag f) :=
    pChainMap (treeDiag f) (treeDiag f)
              (fun _ => {| ofun_app := fun x => unNodeRight' @@ x |}) _.
  Next Obligation.
    split; simpl; intros c1 c2 Hleq; induction Hleq;
      try apply Proper_tree_fmap; auto; constructor;
        rewrite H0; reflexivity.
  Qed.

  Lemma unNodeLeftPChain_oleq {f} `{PDiagram f} (c1 c2 : PChain (treeDiag f)) :
    c1 <o= c2 ->
    unNodeLeftPChain @@ c1 <o= unNodeLeftPChain @@ c2.
  Proof.
    intros Hleq n; simpl; specialize (Hleq n);
      destruct (chain c1 n), (chain c2 n);
      inversion Hleq; subst; auto.
  Qed.

  Lemma unNodeRightPChain_oleq {f} `{PDiagram f} (c1 c2 : PChain (treeDiag f)) :
    c1 <o= c2 ->
    unNodeRightPChain @@ c1 <o= unNodeRightPChain @@ c2.
  Proof.
    intros Hleq n; simpl; specialize (Hleq n);
      destruct (chain c1 n), (chain c2 n);
      inversion Hleq; subst; auto.
  Qed.

  Program Definition treeFold {f} `{PDiagram f} :
    Tree (PChain f) -o> PChain (treeDiag f) :=
    {| ofun_app :=
         fun t =>
           {| chain := fun n => Tree_fmap (chainProj n) @@ t |} |}.
  Next Obligation.
    induction t; simpl.
    - destruct a; apply (Proper_oeq_oleq_op1 _ _ _ Proper_Leaf);
        apply chainCondition.
    - apply (Proper_oeq_oleq_op2 _ _ _ _ Proper_Node); auto.
  Qed.
  Next Obligation.
    intros x y Heq n. simpl.
    induction Heq; simpl in *.
    - specialize (H0 n). apply Proper_Leaf; auto.
    - apply Proper_Node; auto.
  Qed.

  Fixpoint treeUnfold_f_aux {f} `{PDiagram f}
           (c : PChain (treeDiag f))
           (t : Tree (f 0))
    : Tree (PChain f) :=
    match t with
    | Leaf _ => Leaf (unLeafPChain @@ c)
    | Node t1 t2 => Node (treeUnfold_f_aux (unNodeLeftPChain @@ c) t1)
                        (treeUnfold_f_aux (unNodeRightPChain @@ c) t2)
    end.

  Global Instance Proper_treeUnfold_f_aux f `{PDiagram f} :
    Proper (oeq ==> oeq ==> oeq) treeUnfold_f_aux.
  Proof.
    intros c1 c2 Heq1 x y Heq2.
    split; unfold oleq; simpl.
    - destruct Heq2 as [Heq2 _].
      revert c1 c2 Heq1.
      induction Heq2; intros.
      + constructor; intros n; destruct Heq1; simpl;
          rewrite (H1 n); reflexivity.
      + constructor.
        * apply IHHeq2_1; destruct Heq1 as [Heq1 Heq2]; split;
            unfold oleq; simpl; intros n; try rewrite (Heq1 n);
              try rewrite (Heq2 n); reflexivity.
        * apply IHHeq2_2; destruct Heq1 as [Heq1 Heq2]; split;
            unfold oleq; simpl; intros n; try rewrite (Heq1 n);
              try rewrite (Heq2 n); reflexivity.
    - destruct Heq2 as [_ Heq2].
      revert c1 c2 Heq1.
      induction Heq2; intros.
      + constructor; intros n; destruct Heq1; simpl;
          rewrite (H2 n); reflexivity.
      + constructor.
        * apply IHHeq2_1; destruct Heq1 as [Heq1 Heq2]; split;
            unfold oleq; simpl; intros n; try rewrite (Heq1 n);
              try rewrite (Heq2 n); reflexivity.
        * apply IHHeq2_2; destruct Heq1 as [Heq1 Heq2]; split;
            unfold oleq; simpl; intros n; try rewrite (Heq1 n);
              try rewrite (Heq2 n); reflexivity.
  Qed.

  Definition treeUnfold_f {f} `{PDiagram f}
           (c : PChain (treeDiag f))
    : Tree (PChain f) :=
    treeUnfold_f_aux c (chain c 0).

  Global Instance Proper_treeUnfold_f {f} `{PDiagram f} :
    Proper (oleq ==> oleq) treeUnfold_f.
  Proof.
    intros c1 c2 Hleq.
    unfold oleq in *. simpl in *.
    unfold treeUnfold_f.
    pose proof Hleq as Hleq'.
    specialize (Hleq' 0).
    remember (chain c1 0) as x.
    remember (chain c2 0) as y.
    revert Heqx Heqy. revert c1 c2 Hleq.
    induction Hleq'; intros.
    - simpl. constructor. intros ?. simpl.
      rewrite Hleq. reflexivity.
    - simpl. constructor.
      + assert (H0: t1 = chain (unNodeLeftPChain @@ c1) 0).
        { simpl; destruct (chain c1 0); inversion Heqx; auto. }
        assert (H1: t1' = chain (unNodeLeftPChain @@ c2) 0).
        { simpl; destruct (chain c2 0); inversion Heqy; auto. }
        specialize (IHHleq'1 (unNodeLeftPChain @@ c1)
                             (unNodeLeftPChain @@ c2)
                             (unNodeLeftPChain_oleq _ _ Hleq) H0 H1).
        etransitivity. apply IHHleq'1.
        apply Reflexive'_tree_oleq. reflexivity.
      + assert (H0: t2 = chain (unNodeRightPChain @@ c1) 0).
        { simpl; destruct (chain c1 0); inversion Heqx; auto. }
        assert (H1: t2' = chain (unNodeRightPChain @@ c2) 0).
        { simpl; destruct (chain c2 0); inversion Heqy; auto. }
        specialize (IHHleq'2 (unNodeRightPChain @@ c1)
                             (unNodeRightPChain @@ c2)
                             (unNodeRightPChain_oleq _ _ Hleq) H0 H1).
        etransitivity. apply IHHleq'2.
        apply Reflexive'_tree_oleq. reflexivity.
  Qed.

  Definition treeUnfold {f} `{PDiagram f}
    : PChain (treeDiag f) -o> Tree (PChain f) :=
    {| ofun_app := treeUnfold_f |}.

  Lemma isLeaf_oleq A `{OType A} (t1 t2 : Tree A) :
    isLeaf t1 -> t1 <o= t2 -> isLeaf t2.
  Proof.
    intros Hleaf Hleq; inversion Hleq; subst;
      try constructor; inversion Hleaf.
  Qed.

  Lemma isNode_oleq A `{OType A} (t1 t2 : Tree A) :
    isNode t1 -> t1 <o= t2 -> isNode t2.
  Proof.
    intros Hnode Hleq; inversion Hleq; subst;
      try constructor; inversion Hnode.
  Qed.

  Lemma isLeaf_fmap {A B} `{OType A} `{OType B} (t : Tree A) (f : A -o> B) :
    isLeaf (tree_fmap f t) -> isLeaf t.
  Proof.
    intros Hleaf; destruct t. constructor. inversion Hleaf.
  Qed.

  Lemma isNode_fmap {A B} `{OType A} `{OType B} (t : Tree A) (f : A -o> B) :
    isNode (tree_fmap f t) -> isNode t.
  Proof.
    intros Hnode. destruct t. inversion Hnode. constructor.
  Qed.

  Lemma isLeaf_chain f `{PDiagram f} (c : PChain (treeDiag f)) n :
    isLeaf (chain c 0) -> isLeaf (chain c n).
  Proof.
    intros Hleaf; inversion Hleaf.
    destruct c; simpl in *.
    induction n.
    - rewrite <- H1; constructor.
    - specialize (chainCondition n).
      generalize (isLeaf_oleq _ (chain n)
                              (tree_fmap (proj n) (chain (S n)))
                              IHn (proj1 chainCondition)); intros Hleaf'.
      apply isLeaf_fmap in Hleaf'; auto.
  Qed.

  Lemma isNode_chain f `{PDiagram f} (c : PChain (treeDiag f)) n :
    isNode (chain c 0) -> isNode (chain c n).
  Proof.
    intros Hnode; inversion Hnode.
    destruct c; simpl in *.
    induction n.
    - rewrite <- H1; constructor.
    - specialize (chainCondition n).
      generalize (isNode_oleq _ (chain n)
                              (tree_fmap (proj n) (chain (S n)))
                              IHn (proj1 chainCondition)); intros Hnode'.
      apply isNode_fmap in Hnode'; auto.
  Qed.

  Lemma tree_fold_unfold f `{PDiagram f} :
    treeFold ∘ treeUnfold =o= id_ofun.
  Proof.
    split; simpl.
    - intros c1 c2 Hleq n. unfold oleq; simpl.
      unfold treeUnfold_f.
      transitivity (chain c1 n).
      + clear Hleq c2; remember (chain c1 0) as m; revert c1 Heqm.
        induction m; intros; simpl.
        * assert (isLeaf (chain c1 n)).
          { apply isLeaf_chain; rewrite <- Heqm; constructor. }
          rewrite leaf_unleaf; auto; reflexivity.
        * assert (isNode (chain c1 n)).
          { apply isNode_chain; rewrite <- Heqm; constructor. }
          inversion H0; subst; constructor.
          -- assert (H1: m1 = chain (unNodeLeftPChain @@ c1) 0).
             { simpl; destruct (chain c1 0); inversion Heqm; auto. }
             specialize (IHm1 (unNodeLeftPChain @@ c1) H1).
             etransitivity. apply IHm1.
             simpl; rewrite <- H2; reflexivity.
          -- assert (H1: m2 = chain (unNodeRightPChain @@ c1) 0).
            { simpl; destruct (chain c1 0); inversion Heqm; auto. }
            specialize (IHm2 (unNodeRightPChain @@ c1) H1).
            etransitivity. apply IHm2.
            simpl; rewrite <- H2; reflexivity.
      + apply Hleq.
    - intros c1 c2 Hleq n. unfold oleq; simpl.
      transitivity (chain c2 n).
      + apply Hleq.
      + clear Hleq c1; unfold treeUnfold_f; remember (chain c2 0) as m.
        revert c2 Heqm; induction m; intros; simpl.
        * assert (isLeaf (chain c2 n)).
          { apply isLeaf_chain; rewrite <- Heqm; constructor. }
          rewrite leaf_unleaf; auto; reflexivity.
        * assert (isNode (chain c2 n)).
          { apply isNode_chain; rewrite <- Heqm; constructor. }
          inversion H0; subst; constructor.
          -- assert (H1: m1 = chain (unNodeLeftPChain @@ c2) 0).
             { simpl; destruct (chain c2 0); inversion Heqm; auto. }
             specialize (IHm1 (unNodeLeftPChain @@ c2) H1).
             transitivity (chain (unNodeLeftPChain @@ c2) n).
             { simpl. rewrite <- H2. simpl. reflexivity. }
             etransitivity; eauto. reflexivity.
          -- assert (H1: m2 = chain (unNodeRightPChain @@ c2) 0).
             { simpl; destruct (chain c2 0); inversion Heqm; auto. }
             specialize (IHm2 (unNodeRightPChain @@ c2) H1).
             transitivity (chain (unNodeRightPChain @@ c2) n).
             { simpl. rewrite <- H2. simpl. reflexivity. }
             etransitivity; eauto. reflexivity.
  Qed.

  Lemma tree_unfold_fold f `{PDiagram f} :
    treeUnfold ∘ treeFold =o= id_ofun.
  Proof.
    split; unfold oleq; simpl.
    - intros t1 t2 Hleq. unfold oleq; simpl.
      induction Hleq; simpl in *.
      + constructor; auto.
      + unfold treeUnfold_f in *. simpl in *.
        constructor.
        * match goal with
          | [ _ : tree_oleq ?x t1' |- _ ] => transitivity x
          end; auto;
          apply Reflexive'_tree_oleq;
          apply Proper_treeUnfold_f_aux;
          split; simpl; unfold oleq; simpl; reflexivity;
          reflexivity.
        * match goal with
          | [ _ : tree_oleq ?x t2' |- _ ] => transitivity x
          end; auto.
          apply Reflexive'_tree_oleq.
          apply Proper_treeUnfold_f_aux.
          split; simpl; unfold oleq; simpl; reflexivity.
          reflexivity.
    - intros t1 t2 Hleq.
      induction Hleq; simpl in *.
      + transitivity (Leaf y). constructor; auto.
        apply Reflexive'_tree_oleq.
        split; constructor; unfold oleq; simpl; reflexivity.
      + constructor; etransitivity; try apply IHHleq1;
          try apply IHHleq2; apply Reflexive'_tree_oleq;
            unfold treeUnfold_f; simpl; apply Proper_treeUnfold_f_aux;
              split; unfold oleq; simpl; reflexivity.
  Qed.
End treePChain.

(** The tree continuous functor. *)
Section continuousTreeFunctor.
  Context F {oF : OTypeF F} {fm : FMap F} {func : Functor F}
          {uF : UnfoldTypeF F} {uOF : UnfoldOTypeF F}
          {fF : FoldF F} {ufF : UnfoldF F}
          {cFunc : ContinuousFunctor F}.

  Global Instance TreeUnfoldTypeF : UnfoldTypeF (TreeF F) :=
  fun f _ _ => Tree (@unfoldTypeF F uF f _ _).
  Global Instance TreeUnfoldOTypeF : UnfoldOTypeF (TreeF F) := fun _ _ _ => _.
  Global Instance TreeFoldF : FoldF (TreeF F) :=
    fun f _ _ => treeFold ∘ Tree_fmap (foldF f).
  Global Instance TreeUnfoldF : UnfoldF (TreeF F) :=
    fun f _ _ => Tree_fmap (unfoldF f) ∘ treeUnfold.
  Global Instance TreeContinuousFunctor : ContinuousFunctor (TreeF F).
  Proof.
    constructor.
    - intros f o G.
      unfold unfoldF, TreeUnfoldF, foldF, TreeFoldF.
      rewrite compose_ofun_assoc_4.
      rewrite tree_unfold_fold.
      rewrite id_compose_ofun.
      match goal with
      | [ |- Tree_fmap ?f ∘ Tree_fmap ?g =o= _ ] =>
        transitivity (Tree_fmap (f ∘ g))
      end.
      symmetry.
      apply Tree_fmap_comp.
      destruct cFunc. rewrite unfold_fold_id.
      apply Tree_fmap_id.
    - intros f o G.
      unfold unfoldF, TreeUnfoldF, foldF, TreeFoldF.
      rewrite compose_ofun_assoc_4.
      rewrite compose_ofun_middle_id.
      apply tree_fold_unfold.
      match goal with
      | [ |- Tree_fmap ?f ∘ Tree_fmap ?g =o= _ ] =>
        transitivity (Tree_fmap (f ∘ g))
      end.
      symmetry; apply Tree_fmap_comp.
      destruct cFunc. rewrite fold_unfold_id.
      apply Tree_fmap_id.
  Qed.
End continuousTreeFunctor.


Load "Utils".

Fixpoint pad_list {A} r default (l : list A) :=
  match r, l with
  | 0, _ => []
  | _, [] => List.repeat default r
  | _, x :: l'  => x :: pad_list (pred r) default l'
  end.

Lemma pad_list_length :
  forall {A} r default (l : list A),
  length (pad_list r default l) = r.
Proof.
  intros ? ? ? ?. generalize dependent r. induction l; intros ?.
  - destruct r.
    + auto.
    + simpl. f_equal. apply List.repeat_length.
  - destruct r.
    + auto.
    + simpl. f_equal. apply IHl.
Qed.

Definition indexes_list_of_index r d i :=
  List.rev (pad_list d 0 (to_digits r i)).

Fixpoint indexes_list_to_index r d il :=
  match il with
  | [] => 0
  | i :: il' => Nat.pow r (pred d) * i + indexes_list_to_index r (pred d) il'
  end.

Section Example.

Compute indexes_list_of_index 2 8 10.
Compute indexes_list_to_index 2 8 [0; 0; 0; 0; 1; 0; 1; 0].

End Example.

Lemma indexes_list_of_index_length :
  forall r d i,
  length (indexes_list_of_index r d i) = d.
Proof.
  intros ? ? ?. unfold indexes_list_of_index. rewrite List.rev_length. apply pad_list_length.
Qed.

Lemma indexes_list_to_indexes_list_rev_cons :
  forall r d i il,
  length il = d ->
  indexes_list_to_index r (S d) (List.rev (i :: il)) =
  indexes_list_to_index r d (List.rev il) * r + i.
Proof.
  intros ? ? ? ?. remember (List.rev il) as l0. generalize dependent il.
  generalize dependent d. generalize dependent i. induction l0; intros ? ? ? ? ?.
  - simpl. destruct il.
    + simpl in H. subst d. simpl. lia.
    + simpl in Heql0. symmetry in Heql0. apply List.app_eq_nil in Heql0. intuition discriminate.
  - simpl. destruct d.
    + simpl. destruct il; discriminate.
    + rewrite <- List.rev_involutive in Heql0 at 1. simpl in Heql0.
      apply list_rev_injective in Heql0. subst il. simpl.
      rewrite PeanoNat.Nat.mul_add_distr_r. rewrite <- PeanoNat.Nat.add_assoc.
      simpl in IHl0. rewrite <- (IHl0 _ _ (List.rev l0)); clear IHl0.
      * replace [i] with (List.rev [i]) at 1 by auto. rewrite List.rev_app_distr. simpl. lia.
      * symmetry. apply List.rev_involutive.
      * rewrite List.app_length in H. simpl in H. lia.
Qed.

Lemma indexes_list_to_indexes_list_rev_list_repeat_0 :
  forall r d,
  indexes_list_to_index r d (List.rev (List.repeat 0 d)) = 0.
Proof.
  intros ? ?. induction d.
  - auto.
  - simpl List.repeat. rewrite indexes_list_to_indexes_list_rev_cons.
    + lia.
    + apply List.repeat_length.
Qed.

Theorem indexes_list_to_of_correct :
  forall r d i,
  r > 1 ->
  i < Nat.pow r d ->
  indexes_list_to_index r d (indexes_list_of_index r d i) = i.
Proof.
  intros ? ? ? ?. generalize dependent i. unfold indexes_list_of_index. induction d; intros ? ?.
  - simpl in H0. destruct i; try lia. rewrite to_digits_red_any_zero. simpl. auto.
  - destruct (PeanoNat.Nat.eqb_spec i 0).
    + clear IHd. subst i. rewrite to_digits_red_any_zero. simpl pad_list.
      rewrite indexes_list_to_indexes_list_rev_cons.
      * rewrite indexes_list_to_indexes_list_rev_list_repeat_0. auto.
      * apply List.repeat_length.
    + assert (Nat.div i r < Nat.pow r d). {
        simpl in H0. destruct (PeanoNat.Nat.eqb_spec (Nat.div i r) (Nat.pow r d)).
        - apply PeanoNat.Nat.div_lt_upper_bound; lia.
        - unfold lt in H0. apply Le.le_Sn_le in H0. apply PeanoNat.Nat.div_le_mono with (c := r) in H0; try lia.
          rewrite PeanoNat.Nat.mul_comm in H0. rewrite PeanoNat.Nat.div_mul in H0; try lia.
      }
      specialize (IHd (Nat.div i r) H1); clear H1. rewrite to_digits_red_any_nonzero; try lia.
      simpl pad_list. rewrite indexes_list_to_indexes_list_rev_cons.
      * rewrite IHd; clear IHd. symmetry. rewrite PeanoNat.Nat.mul_comm. apply PeanoNat.Nat.div_mod_eq.
      * apply pad_list_length.
Qed.

Theorem indexes_list_of_index_upper_bound :
  forall r d i,
  r > 1 ->
  list_forall (fun i => i < r) (indexes_list_of_index r d i).
Proof.
  intros ? ? ? ?. unfold indexes_list_of_index.
  rewrite list_forall_equiv. apply List.Forall_rev. rewrite <- list_forall_equiv.
  generalize dependent i. induction d; intros ?.
  - remember (pad_list 0 0 (to_digits r i)) as l. rewrite (proj1 (List.length_zero_iff_nil l)).
    + simpl. auto.
    + subst l. apply pad_list_length.
  - destruct (PeanoNat.Nat.eqb_spec i 0).
    + clear IHd. subst i. rewrite to_digits_red_any_zero. simpl. split; try lia. induction d.
      * simpl. auto.
      * simpl. intuition lia.
    + rewrite to_digits_red_any_nonzero; try lia. simpl. split.
      * apply PeanoNat.Nat.mod_upper_bound. lia.
      * auto.
Qed.

Theorem indexes_list_to_index_upper_bound :
  forall r d il,
  length il = d ->
  list_forall (fun i => i < r) il ->
  indexes_list_to_index r d il < Nat.pow r d.
Proof.
  intros ? ? ?. generalize dependent d. induction il; intros ? ? ?.
  - simpl. simpl in H. subst d. simpl. auto.
  - simpl. simpl in H. destruct H0 as (? & ?). specialize (IHil (pred d) ltac:(lia) H1); clear H1. destruct d.
    + lia.
    + simpl. simpl in IHil. nia.
Qed.


(** 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 (lf1 : natural) (lf3 : natural) (lf2 : natural) : natural :=
  plus (Succ lf3) lf2.


(** 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 (lf2 : natural) (lf1 : natural) (x : natural) (y : natural)
  : natural := plus Zero (mult x y).


From Coq Require Import Sets.Ensembles.
From Coq Require Import Relations_1.
From Coq Require Import Bool.
Section Groups.
Variable U : Type.

(*Binary operation.*)
Definition binop :=U->U->U.

Definition Group (G : Ensemble U) (star : binop) : Prop:=
(
    (forall (a b c: U), In U G a /\ In U G b /\ In U G c->
    In U G (star a b)) (*Being closed under operator*)
    /\
    (forall (a b c: U), In U G a /\ In U G b /\ In U G c->
    star a (star b c) = star (star a b) c) (*Associativity*)
    /\
    exists e: U, In U G e /\ (forall d: U, In U G d -> star e d = d /\ star d e = d) (*Existence of identity*)
    /\
    forall d: U, In U G d -> (exists d': U, In U G d' /\ star d d'= e /\ star d' d = e) (*Invertibality*)
).
(*More Variables:*)
Variable G : Ensemble U.
Variable star : binop.

Notation "x ** y" := (star x y) (at level 40, left associativity).

(*Associativiy:*)
Lemma assoc:
Group G star -> (forall (a b c: U), In U G a /\ In U G b /\ In U G c-> a ** (b ** c) = star (star a b) c).
Proof.
    intros H a b c H1. apply H. apply H1.
    Qed.

(*Identity element:*)
Variable e : U.
Definition Group_iden G star e : Prop :=
    Group G star /\ In U G e -> forall d : U, In U G d -> d**e=d /\ e**d=d.

Lemma iden_l :
Group G star -> In U G e -> Group_iden G star e ->
    forall d :U, In U G d -> e**d = d.
    Proof.
        intros H H0 H1 d H2. apply H1. +split. ++apply H.
        ++apply H0. +apply H2.
    Qed.
Lemma iden_r :
Group G star -> In U G e -> Group_iden G star e ->
    forall d :U, In U G d -> d**e = d.
    Proof.
        intros H H0 H1 d H2. apply H1. +split. ++apply H.
        ++apply H0. +apply H2.
    Qed.

(*Inverse element:*)
Definition inv_prop (a a' : U) : Prop :=
    Group G star -> Group_iden G star e -> In U G a -> In U G a' -> a ** a' = e /\ a'**a = e.

Lemma inv_l:
    Group G star -> Group_iden G star e ->
    forall a a':U, In U G a -> In U G a' -> inv_prop a a' -> a' ** a = e.
    Proof.
        intros H H1 a a' H2 H3 H4. apply H4.
        +apply H. +apply H1. +apply H2. +apply H3.
    Qed.
Lemma inv_r:
    Group G star -> Group_iden G star e ->
    forall a a':U, In U G a -> In U G a' -> inv_prop a a' -> a ** a' = e.
    Proof.
        intros H H1 a a' H2 H3 H4. apply H4.
        +apply H. +apply H1. +apply H2. +apply H3.
    Qed.

(*Multiplying an element on two sides of an equality:*)
Lemma eq_mul_l :
Group G star -> forall (a b c:U), b = c -> star a b = star a c.
Proof.
    intros H a b c H1. rewrite -> H1. reflexivity.
    Qed.

Lemma eq_mul_r :
Group G star -> forall (a b c:U), b = c -> b ** a = c **a.
Proof.
    intros H a b c H1. rewrite -> H1. reflexivity.
    Qed.

(*(*Cancellation laws:*)
Lemma cancel_l :
Group G star -> forall (a b c:U),
In U G a /\ In U G b /\ In U G c ->
star a b = star a c -> b = c.
Proof.
    intros H a b c H1 H2. unfold Group in H. destruct H.
    destruct H0. destruct H3. destruct H3. destruct H4.
    assert (H12: exists a', In U G a' -> a ** a' = e /\ a' ** a = e).
    +destruct H1. apply H5 in H1. destruct H1.
    exists x0. intros H54. split. ++apply H1.
    rewrite -> eq_mul_l with (a:=a'). *)

End Groups.

Definition add (a b:bool):=a || b.
Definition adib : binop bool := add.
Theorem disj_group: forall (G : Ensemble bool) , (forall (n:bool), In bool G n)
->Group bool G adib.
Proof.
    intros G H. unfold Group. split.
    +intros a b c H0. apply H. +split.
    ++intros a b c H0. unfold adib. unfold add. apply orb_assoc.
    ++exists false. split. +++apply H. +++split.
    ++++intros d H1. split. +++++unfold adib. unfold add. simpl. reflexivity.
    +++++unfold adib. unfold add. rewrite -> orb_commutative.

Qed.


(** 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 (lf2 : natural) (lf1 : natural) (y : natural) (x : natural)
  : natural := plus Zero (plus y x).


Require Import List.
Require Import Nat.
Require Import Tactics.
Require Import Program.
Require Import Setoid.
Require Import SetoidClass.
Require Import Relation_Definitions.
Require Import Specif.

(** * Parametric types **)

(** Type syntax. T,U,V *)
Inductive type :=
| TyUnit : type
| TyZero : type (* Empty. *)
| TyArr  : type -> type -> type (* Functions. *)
| TyProduct : type -> type -> type
| TySum : type -> type -> type
| TyAlpha : type. (* A single type parameter. *)

Infix ":->" := TyArr (at level 30, right associativity) : type_scope.

Definition t := TyAlpha :-> TyAlpha.
Definition t2 := TyProduct (TyAlpha :-> TyAlpha) TyAlpha.
Print t2.

(** Interpretation of a type as a Set,
    parameterized by the interpretation of Alpha. *)
Fixpoint sem (K : Set) (T : type) : Set :=
  match T with
  | TyAlpha => K
  | TyProduct T1 T2 => sem K T1 * sem K T2
  | TySum T1 T2 => sem K T1 + sem K T2
  | T :-> U => sem K T -> sem K U
  | TyUnit => unit
  | TyZero => Empty_set
  end.

(*
Record Setoid : Type :=
  mkSetoid
    { carrier : Type;
      rel : relation carrier;
      equiv : equivalence carrier rel }.
 *)

Instance unit_setoid : Setoid unit :=
  { equiv := fun _ _ => True }.
Proof.
  split; intro; auto.
Qed.

Instance empty_setoid : Setoid Empty_set :=
  { equiv := fun _ _ => False }.
Proof.
  split; intro; auto.
  destruct x.
Qed.

Print equiv.

Instance pair_setoid A B `(a : Setoid A) `(b : Setoid B)
  : Setoid (A * B) :=
  { equiv :=
      fun x y =>
        let (a1, b1) := x in
        let (a2, b2) := y in
        a1 == a2 /\ b1 == b2 }.
Proof.
  split; intro.
  - destruct x.
    split.
    + apply a.
    + apply b.
  - intros y H; destruct x, y.
    split.
    + apply a. apply H.
    + apply b; apply H.
  - intros y z H I. destruct x as [x1 x2], y as [y1 y2], z as [z1 z2].
    split.
    + apply (@setoid_trans _ a x1 y1 z1).
      * apply H. * apply I.
    + apply (@setoid_trans _ b x2 y2 z2).
      * apply H. * apply I.
Qed.

Instance sum_setoid A1 A2 `(a1 : Setoid A1) `(a2 : Setoid A2)
  : Setoid (A1 + A2) :=
  { equiv :=
      fun x y =>
        match x, y with
        | inl x1, inl y1 => x1 == y1
        | inr x2, inr y2 => x2 == y2
        | _, _ => False
        end }.
Proof.
  split.
  - intro x; destruct x.
    + apply a1.
    + apply a2.
  - intros x y.
    destruct x as [x1 | x2], y as [y1 | y2]; auto.
    + apply a1; apply H.
    + apply a2; apply H.
  - intros x y z Hx Hy.
    destruct x as [x1 | x2], y as [y1 | y2], z as [z1 | z2]; auto.
    + apply (@setoid_trans _ _ x1 y1 z1).
      * apply Hx. * apply Hy.
    + destruct Hx.
    + destruct Hx.
    + apply (@setoid_trans _ _ x2 y2 z2).
      * apply Hx. * apply Hy.
Qed.

Record smorph (A : Type) (B : Type)
       `{S_A : Setoid A} `{S_B : Setoid B}
  : Type :=
  mksmorph
    { smorph_f : A -> B;
      smorph_equiv : forall a1 a2, a1 == a2 -> smorph_f a1 == smorph_f a2 }.

Instance smorph_setoid A B `(S_A : Setoid A) `(S_B : Setoid B) : Setoid (smorph A B) :=
  { equiv :=
      fun f g =>
        forall a, smorph_f _ _ f a == smorph_f _ _ g a}.
Proof.
  split.
  - intros f a.
    apply S_B.
  - intros f g H a.
    apply S_B. apply H.
  - intros f g h Hf Hg a.
    apply (@setoid_trans _ S_B (smorph_f _ _ f a) (smorph_f _ _ g a) (smorph_f _ _ h a)).
    + apply Hf.
    + apply Hg.
Qed.

Print existT.

Locate "*".

Fixpoint sem_eq (K : Set) `{K_S : Setoid K} (T : type) : { S : Set & `(Setoid S) } :=
  match T with
  | TyUnit => existT _ unit unit_setoid
  | TyZero => existT _ Empty_set empty_setoid
  | T :-> U =>
    match sem_eq K T, sem_eq K U with
    | existT _ KT KT_S, existT _ KU KU_S =>
      existT _ (@smorph KT KU KT_S KU_S) (smorph_setoid KT KU KT_S KU_S)
    end
  | TyProduct T1 T2 =>
    match sem_eq K T1, sem_eq K T2 with
    | existT _ KT1 KT1_S, existT _ KT2 KT2_S =>
      existT _ (prod KT1 KT2) (pair_setoid KT1 KT2 KT1_S KT2_S)
    end
  | TySum T1 T2 =>
    match sem_eq K T1, sem_eq K T2 with
    | existT _ KT1 KT1_S, existT _ KT2 KT2_S =>
      existT _ (sum KT1 KT2) (sum_setoid KT1 KT2 KT1_S KT2_S)
    end
  | TyAlpha =>
    existT _ K K_S
  end.

Instance sem_eq_setoid (K : Set) `(K_S : Setoid K) T : Setoid (projT1 (sem_eq K T)) :=
  projT2 (sem_eq K T).

     match T with
  | TyUnit => tt
  | TyZero =>
  | T :-> U =>
    fun x y =>
      forall r s, sem_eq K R T r r -> sem_eq K R T s s -> sem_eq K R T r s -> sem_eq K R U (x r) (y s)
  | TyProduct T1 T2 =>
    fun x y =>
      let (x1, x2) := x in
      let (y1, y2) := y in
      sem_eq K R T1 x1 y1 /\ sem_eq K R T2 x2 y2
  | TySum T1 T2 =>
    fun x y =>
      match x, y with
      | inl x1, inl y1 => sem_eq K R T1 x1 y1
      | inr x2, inr y2 => sem_eq K R T2 x2 y2
      | _, _ => False
      end
  | TyAlpha => R
  end.

Lemma
  sem_eq_sym
  (K : Set) (R : K -> K -> Prop) (R_sym : forall x y, R x y -> R y x)
  (T : type)
  : forall x y, sem_eq K R T x y -> sem_eq K R T y x.
Proof.
  induction T; intros x y H; auto.
  - intros r s Hr Hs I.
    apply IHT2, H, IHT1.
    + apply Hs.
    + apply Hr.
    + apply I.
  - destruct x; destruct y; split.
    + apply IHT1.
      destruct H; apply H.
    + apply IHT2.
      destruct H.
      apply H0.
  - destruct x; destruct y; auto.
    + apply IHT1.
      apply H.
    + apply IHT2.
      apply H.
  - apply R_sym, H.
Qed.

Lemma
  sem_eq_trans
  (K : Set) (R : K -> K -> Prop)
  (R_trans : forall x y z, R x y -> R y z -> R x z)
  (T : type)
  : forall x y z, sem_eq K R T x y -> sem_eq K R T y z -> sem_eq K R T x z.
Proof.
  induction T; intros x y z Hx Hy; auto.
  - intros r s Hr Hs I.
    apply IHT2 with (y := y r).
    apply Hx.
    + apply Hr.
    + apply Hr.
    + apply Hr.
    + apply Hy.
      * apply Hr.
      * apply Hs.
      * apply I.
  - destruct x, y as [y1 y2], z.
    split.
    + apply IHT1 with (y := y1).
      * destruct Hx.
        apply H.
      * destruct Hy.
        apply H.
    + apply IHT2 with (y := y2).
      * destruct Hx; auto.
      * destruct Hy; auto.
  - destruct x, z; inversion y as [y1 | y2]; auto.
    + apply IHT1 with (y := y1); auto.
    + apply IHT1. with (y := y). auto.

        (*
Inductive sem_eq (K : Set) (R : K -> K -> Prop)
  : forall (T : type), sem K T -> sem K T -> Prop :=
| SEqAlpha : forall x y, R x y -> sem_eq K R TyAlpha x y
| SEqProduct : forall T1 T2 x1 x2 y1 y2,
    sem_eq K R T1 x1 y1 ->
    sem_eq K R T2 x2 y2 ->
    sem_eq K R (TyProduct T1 T2) (x1, x2) (y1, y2)
| SEqLeft : forall T1 T2 x1 y1,
    sem_eq K R T1 x1 y1 ->
    sem_eq K R (TySum T1 T2) (inl x1) (inl y1)
| SEqRight : forall T1 T2 x2 y2,
    sem_eq K R T2 x2 y2 ->
    sem_eq K R (TySum T1 T2) (inr x2) (inr y2)
| SEqFun : forall T U x y,
    (forall r s, sem_eq K R T r s -> sem_eq K R U (x r) (y s)) ->
    sem_eq K R (T :-> U) x y.
 *)

(** * Paths in values

    We will define a type of "paths" that, given a value of
    type T, leads to a leaf of type alpha.
    We actually do this on the semantic level:
    given a value of type sem K T, a path leads to a leaf of
    type K. *)

(** Choices. C

    To make sure paths remain valid, we must restrict values
    of sum types. A "choice" chooses one alternative for
    every occurence of a sum type. *)
Inductive choice
          {K : Set}
  : type -> Set :=
| CAlpha : choice TyAlpha
| CProduct : forall {T1} {T2},
    choice T1 -> choice T2 -> choice (TyProduct T1 T2)
| CLeft : forall {T1 T2}, choice T1 -> choice (TySum T1 T2)
| CRight : forall {T1 T2}, choice T2 -> choice (TySum T1 T2)
| CUnit : choice TyUnit
| CArrow : forall {T U}, (sem K T -> choice U) -> choice (T :-> U).
  (* For functions, we make one choice for every argument. *)

(* Paths. p *)
Inductive path
          (K : Set)
  : forall (T : type), choice T -> Set :=

(* We're at a leaf. *)
| PHere : path K TyAlpha CAlpha

(* Given a pair, a path goes into either component. *)
| PFst : forall T1 T2 (C1 : choice T1) (C2 : choice T2),
    path K T1 C1 -> path K (TyProduct T1 T2) (CProduct C1 C2)
| PSnd : forall T1 T2 (C1 : choice T1) (C2 : choice T2),
    path K T2 C2 -> path K (TyProduct T1 T2) (CProduct C1 C2)

(* For sums, the choice allows only one alternative. *)
| PLeft : forall T1 T2 (C1 : choice T1),
    path K T1 C1 -> path K (TySum T1 T2) (CLeft C1)
| PRight : forall T1 T2 (C2 : choice T2),
    path K T2 C2 -> path K (TySum T1 T2) (CRight C2)

(* A path in a function specifies an argument to continue. *)
| PFun : forall T U (c : sem K T -> choice U),
    forall (t : sem K T), path K U (c t) -> path K (T :-> U) (CArrow c).

Arguments PHere [K].
Arguments PFst [K T1 T2 C1 C2] _.
Arguments PSnd [K T1 T2 C1 C2] p.
Arguments PLeft [K T1 T2 C1] p.
Arguments PRight [K T1 T2 C2] p.
Arguments PFun [K T U c] t p.

(** Isomorphism between A and B. *)
Inductive iso (A : Set) (B : Set) : Set :=
| Iso : forall (constr : B -> A) (destr : A -> B),
    (forall a, constr (destr a) = a) ->
    (forall b, destr (constr b) = b) ->
    iso A B.

Definition to {A} {B} (i : iso A B) : A -> B :=
  match i with
  | Iso _ _ _ destr _ _ => destr
  end.

Definition from {A} {B} (i : iso A B) : B -> A :=
  match i with
  | Iso _ _ constr _ _ _ => constr
  end.

(** We want to interpret [T] at the type of its own paths.
    But it seems unlikely that we can have literally
    [K = path K T C]; isomorphism is the next best thing.

    The poorly chosen name of [initial] refers to the fact
    that this somehow corresponds to an initial algebra
    construction. *)
Definition initial (K : Set) (T : type) (C : choice T) : Type :=
  iso K (path K T C).

(** The predicate [chosen T C x] states that
    a value [x : sem K T] matches the given [choice]. *)
Inductive chosen
          {K : Set}
  : forall (T : type), choice T -> sem K T -> Set :=
| ChUnit : chosen TyUnit CUnit tt
| ChProduct : forall T1 T2 C1 C2 x1 x2,
    chosen T1 C1 x1 -> chosen T2 C2 x2 -> chosen (TyProduct T1 T2) (CProduct C1 C2) (x1, x2)
| ChLeft : forall T1 T2 C1 x1,
    chosen T1 C1 x1 -> chosen (TySum T1 T2) (CLeft C1) (inl x1)
| ChRight : forall T1 T2 C2 x2,
    chosen T2 C2 x2 -> chosen (TySum T1 T2) (CRight C2) (inr x2)
| ChArrow : forall T U c x,
    (forall t, chosen U (c t) (x t)) -> chosen (T :-> U) (CArrow c) x
| ChAlpha : forall x, chosen TyAlpha CAlpha x.

Arguments ChProduct [K T1 T2 C1 C2 x1 x2] _ _.
Arguments ChLeft [K T1 T2 C1 x1] _.
Arguments ChRight [K T1 T2 C2 x2] _.
Arguments ChArrow [K T U c x] _.
Arguments ChAlpha [K] _.

(** Given a path [p : path K T C] and a (chosen) value [x : sem K T],
    we can follow the path to a leaf of type [K]. *)
Fixpoint index {K : Set} {T : type} {C : choice T} {x : sem K T} (k : chosen T C x) (p : path K T C) : K :=
  match p in path _ T C return forall x, chosen T C x -> K with
  | PHere =>
    fun _ k =>
      match
        k in chosen _ CAlpha x
        return K
      with
      | ChAlpha x => x
      end
  | PFun t p1 =>
    fun _ k =>
      match
        k in chosen _ (@CArrow _ T U c) r
        return forall t, path K U (c t) -> K
      with
      | ChArrow k1 => fun t p1 => index (k1 t) p1
      end t p1
  | @PFst _ T1 _ C1 _ p1 =>
    fun _ k1 =>
      match
        k1 in chosen _ (@CProduct _ T1 _ C1 _) r
        return path _ T1 C1 -> K
      with
      | ChProduct k1 _ => fun p1 => index k1 p1
      end p1
  | @PSnd _ _ T2 _ C2 p2 =>
    fun _ k =>
      match
        k in chosen _ (@CProduct _ _ T2 _ C2) r
        return path K T2 C2 -> K
      with
      | ChProduct _ k2 =>
        fun p2 => index k2 p2
      end p2
  | @PLeft _ T1 _ C1 p1 =>
    fun _ k =>
      match
        k in chosen _ (@CLeft _ T1 _ C1) r
        return path K T1 C1 -> K
      with
      | ChLeft k1 => fun p1 => index k1 p1
      end p1
  | @PRight _ _ T2 C2 p2 =>
    fun _ k =>
      match
        k in chosen _ (@CRight _ _ T2 C2) r
        return path K T2 C2 -> K
      with
      | ChRight k2 => fun p2 => index k2 p2
      end p2
  end x k.

(** A property that should be satisfied by values produced
    by our generator (to be defined): every leaf encodes
    the path to itself. *)
Definition generates {K : Set} {T : type} {C : choice T} (i : initial K T C) (x : sem K T) (k : chosen T C x) :=
  forall (p : path K T C), index k p = from i p.

Inductive variance : Set :=
| CO : variance
| CONTRA : variance.

Definition covary (co : variance) : variance :=
  match co with
  | CO => CONTRA
  | CONTRA => CO
  end.

Inductive variant : variance -> type -> Set :=
| VAlpha : variant CO TyAlpha
| VUnit : forall co, variant co TyUnit
| VZero : forall co, variant co TyZero
| VProduct : forall co {T1 T2},
    variant co T1 -> variant co T2 -> variant co (TyProduct T1 T2)
| VSum : forall co {T1 T2},
    variant co T1 -> variant co T2 -> variant co (TySum T1 T2)
| VArrow : forall co {T U},
    variant (covary co) T ->
    variant co U ->
    variant co (T :-> U).

Definition switch {U : Type} (co : variance) (K : U) (H : U) :=
  match co with
  | CO => K
  | CONTRA => H
  end.

Lemma switch_covary :
  forall {U : Type} (co : variance),
    switch (covary co) = (fun (K H : U) => switch co H K).
Proof.
  intros.
  destruct co; auto.
Qed.

Fixpoint map_co
         {K H : Set} {T : type} {co : variance}
         (v : variant co T) (f : K -> H)
  : sem (switch co K H) T ->
    sem (switch co H K) T :=
  match
    v in variant co T
    return sem (switch co K H) T -> sem (switch co H K) T
  with
  | VAlpha => f
  | VUnit _ => fun x => x
  | VZero _ => fun x => x
  | VProduct _ v1 v2 =>
    fun x =>
      match x with
      | (x1, x2) => (map_co v1 f x1, map_co v2 f x2)
      end
  | VSum _ v1 v2 =>
    fun x =>
      match x with
      | inl x1 => inl (map_co v1 f x1)
      | inr x2 => inr (map_co v2 f x2)
      end
  | @VArrow co T U v1 v2 =>
    fun x =>
      let comap := eq_rect
                     (switch (covary co))
                     (fun sw => sem (sw K H) T -> sem (sw H K) T)
                     (map_co v1 f)
                     (fun K H => switch co H K)
                     (switch_covary co)
      in fun t => map_co v2 f (x (comap t))
  end.

Definition covariant := variant CO.

Inductive project
          {K : Set} {B : Set} (f : K -> B)
  : forall (T : type) (C : @choice K T),
    (path K T C -> B) ->
    sem K T ->
    sem B T ->
    Set :=
| ProjAlpha : forall x y, project f TyAlpha CAlpha (fun PHere => y) x y
| ProjUnit : project f TyUnit CUnit (fun p => match p with end) tt tt
| ProjProduct : forall T1 T2 C1 C2 g1 g2 x1 x2 y1 y2,
    project f T1 C1 g1 x1 y1 -> project f T2 C2 g2 x2 y2 ->
    project f (TyProduct T1 T2) (CProduct C1 C2)
            (fun p =>
               match
                 p in path _ _ (@CProduct _ T1 T2 C1 C2)
                 return forall A,
                   (path _ T1 C1 -> A) -> (path _ T2 C2 -> A) -> A
               with
               | PFst p1 => fun _ g1 _ => g1 p1
               | PSnd p2 => fun _ _ g2 => g2 p2
               end _ g1 g2) (x1, x2) (y1, y2)
| ProjLeft : forall T1 T2 C1 g1 x1 y1,
    project f T1 C1 g1 x1 y1 ->
    project f (TySum T1 T2) (CLeft C1)
            (fun p =>
               match
                 p in path _ _ (@CLeft _ T1 _ C1)
                 return forall A, (path _ T1 C1 -> A) -> A
               with
               | PLeft p1 => fun _ g1 => g1 p1
               end _ g1) (inl x1) (inl y1)
| ProjRight : forall T1 T2 C2 g2 x2 y2,
    project f T2 C2 g2 x2 y2 ->
    project f (TySum T1 T2) (CRight C2)
            (fun p =>
               match
                 p in path _ _ (@CRight _ _ T2 C2)
                 return forall A, (path _ T2 C2 -> A) -> A
               with
               | PRight p2 => fun _ g2 => g2 p2
               end _ g2) (inr x2) (inr y2)
| ProjArrow : forall T U c g x y (v : covariant T),
    (forall (t : sem K T),
        project f U (c t) (g t) (x t) (y (map_co v f t))) ->
    project f (T :-> U) (CArrow c)
            (fun p =>
               match
                 p in path _ _ (@CArrow _ T U c)
                 return forall A, (forall t, path _ U (c t) -> A) -> A
               with
               | PFun t pf => fun _ g => g t pf
               end _ g) x y.

(** * Properties of test case generators *)

(** Ordering between individual inputs.
    [x] subsumes [y] if [x] distinguishes polymorphic functions
    better than [y]. *)
Definition
  subsumes {K H : Set} {T : type} (S : Set -> Set)
  (x : sem K T) (y : sem H T) : Prop :=
  forall (f g : forall {L}, sem L T -> S L), f x = g x -> f y = g y.

(** Completeness.
    Every possible input [y] is subsumed
    by a generated test case [x]. *)
Definition
  complete (T : type) (S : Set -> Set)
  (Generated : forall K, sem K T -> Prop) : Prop :=
  forall H (y : sem H T), exists K x, Generated K x /\ subsumes S x y.

(** Canonicity properties. *)

(** Optimality of a test case.
    Every generated test case [x] is as general as possible:
    if another [y] subsumes [x], then [x] also subsumes [y]. *)
Definition
  optimality (T : type) (S : Set -> Set)
  (Generated : forall K, sem K T -> Prop) : Prop :=
  forall K x, Generated K x -> forall H (y : sem H T), subsumes S x y -> subsumes S y x.

(** Non-redundancy.
    Generated test cases don't subsume each other. *)
Definition
  non_redundant (T : type) (S : Set -> Set)
  (Generated : forall K, sem K T -> Prop) : Prop :=
  forall K x H y, Generated K x -> Generated H y -> subsumes S x y -> JMeq x y.

(*
Inductive generate (K : Set) (T : type) (C : choice T) (x :
*)